X-Git-Url: https://git.lukelau.me/?p=blog.git;a=blobdiff_plain;f=Main.hs;h=24e201726f653d994b9ea53c63f69419b358bdd3;hp=92935c8be3d445e4ce4f8d3d89c38b4bc4123400;hb=a2fb53d788ced698c13a0ecf5a2f0f8cbc884f8a;hpb=0848263e3bc89a44d351980eef66207931eaa7aa diff --git a/Main.hs b/Main.hs index 92935c8..24e2017 100644 --- a/Main.hs +++ b/Main.hs @@ -1,72 +1,200 @@ {-# LANGUAGE OverloadedStrings #-} module Main where -import Web.Scotty +import Web.Scotty.Cookie +import Web.Scotty.Trans import qualified Data.Text.Lazy as T import qualified Data.Text.Lazy.IO as T -import Control.Monad.IO.Class +import Data.List +import Data.Time +import qualified Data.Map.Lazy as Map +import Data.Maybe +import Data.Ord +import Data.IORef +import Control.Exception import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.Trans.Class +import qualified Control.Monad.Trans.State as S import qualified Text.MMark as M import qualified Text.MMark.Extension.Common as M +import Text.Casing +import Text.Read (readMaybe) import Lucid import Lucid.Base import System.Directory import System.FilePath +import System.Random +import System.IO.Error import Network.HTTP.Types +type Sessions = Map.Map T.Text T.Text +type ActionM = ActionT T.Text (S.StateT Sessions IO) + +-- | Checks if the user is logged in +loggedIn :: ActionM Bool +loggedIn = do + mCookie <- getCookie "session" + case mCookie of + Nothing -> return False + Just cookie -> Map.member (T.fromStrict cookie) <$> lift S.get + +-- | Returns the current username +currentUser :: ActionM (Maybe T.Text) +currentUser = do + mCookie <- getCookie "session" + case mCookie of + Nothing -> return Nothing + Just cookie -> Map.lookup (T.fromStrict cookie) <$> lift S.get + +-- | Makes a function that carries over the state from one +-- request to the next +mkPreserve :: s -> IO ((S.StateT s IO) a -> IO a) +mkPreserve s = do + ref <- newIORef s + return $ \f -> do + s <- readIORef ref + (x, s') <- S.runStateT f s + writeIORef ref s' + return x + +-- TODO: Use hashes +logins :: Map.Map T.Text T.Text +logins = Map.fromList + [ ("luke", "pass") + , ("dave", "abcd") + , ("antonia", "1234") + , ("owen", "haskell") + ] + main :: IO () -main = scotty 3000 $ do +main = do + preserve <- mkPreserve mempty + createDirectory "posts" `catch` (\e -> unless (isAlreadyExistsError e) (throw e)) + scottyT 3000 preserve $ do get "/style.css" $ file "style.css" - get "/create" $ html $ renderText $ html_ $ do - head_ style - body_ $ with form_ [action_ "create", method_ "post"] $ do - input_ [name_ "title", type_ "text"] - with textarea_ [name_ "body", placeholder_ "body"] "" - input_ [type_ "submit"] + get "/create" $ do + authed <- loggedIn + if authed + then template "Create" $ do + h1_ "Create a new post" + form_ [action_ "create", method_ "post"] $ do + input_ [name_ "title", type_ "text", placeholder_ "Title"] + br_ [] + textarea_ [name_ "body", placeholder_ "# Your markdown here"] "" + br_ [] + input_ [type_ "submit", value_ "Post"] + else do + text "You're not logged in" + status unauthorized401 post "/create" $ do - title <- param "title" - body <- param "body" - let fp = "posts" T.unpack title <.> "md" - liftIO $ T.writeFile fp body - redirect ("post/" <> title) + t <- param "title" + b <- param "body" + p <- createPost t b + redirect (linkToPost p) post "/login" $ do username <- param "username" password <- param "password" - if username /= ("luke" :: T.Text) || password /= ("pass" :: T.Text) - then status unauthorized401 - else redirect "/create" + if Map.lookup username logins /= Just password + then do + text "Invalid username and/or password" + status unauthorized401 + else do + session <- T.pack . show <$> liftIO (randomIO :: IO Int) + lift $ S.modify (Map.insert session username) + setSimpleCookie "session" (T.toStrict session) + redirect "/" + + post "/logout" $ deleteCookie "session" >> redirect "/" get "/" $ do - posts <- fmap dropExtension <$> liftIO (listDirectory "posts") - contents <- mapM render posts + posts <- liftIO $ do + files <- listDirectory "posts" + posts <- catMaybes <$> mapM load files + return $ take 5 $ sortOn (Down . date) posts + template "Cool blog" $ sequence (mapMaybe render posts) + + get "/posts/:post" $ do + name <- param "post" + mPost <- liftIO (load name) + case mPost of + Nothing -> status notFound404 + Just post -> + case render post of + Nothing -> status internalServerError500 + Just content -> template (title post) content + +template :: T.Text -> Html a -> ActionM () +template title content = do + authed <- loggedIn html $ renderText $ html_ $ do - head_ style + head_ $ style >> title_ (toHtml title) body_ $ do - with form_ [action_ "/login", method_ "post"] $ do - input_ [name_ "username", placeholder_ "username", type_ "text"] - input_ [name_ "password", placeholder_ "password", type_ "password"] - input_ [type_ "submit"] - sequence contents + term "nav" $ do + a_ [href_ "/"] "🏠 Cool Blog" + if authed + then do + " " >> a_ [href_ "/create"] "Create a Post" + form_ [action_ "/logout", method_ "post", class_ "login-form"] $ + input_ [type_ "submit", value_ "Log Out"] + else form_ [action_ "/login", method_ "post", class_ "login-form"] $ do + input_ [name_ "username", placeholder_ "Username", type_ "text"] + input_ [name_ "password", placeholder_ "Password", type_ "password"] + input_ [type_ "submit", value_ "Log In"] + content + where style = link_ [Attribute "rel" "stylesheet", Attribute "href" "/style.css"] +data Post = Post + { markdown :: T.Text + , title :: T.Text + , date :: UTCTime + , author :: T.Text + } deriving (Read, Show) - get "/post/:post" $ do - post <- param "post" - content <- render post - html $ renderText $ html_ $ do - head_ style - body_ content - - where - style = link_ [Attribute "rel" "stylesheet", Attribute "href" "style.css"] - -render :: String -> ActionM (Html ()) -render post = do - let name = "posts" post <.> ".md" - markdown <- T.toStrict <$> liftIO (T.readFile name) - case M.parse name markdown of - Left e -> return "shit" - Right doc -> return $ M.render (M.useExtensions extensions doc) +load :: String -> IO (Maybe Post) +load name = do + let file = "posts" name + guard =<< doesFileExist file + readMaybe <$> readFile file + +render :: Post -> Maybe (Html ()) +render p@(Post markdown title date author) = + case M.parse (pathToPost p) (T.toStrict markdown) of + Left e -> Nothing + Right doc -> Just $ + article_ [id_ (T.toStrict title)] $ do + header_ $ do + a_ [href_ (T.toStrict $ linkToPost p)] $ + h1_ $ toHtml title + address_ $ "By " >> toHtml author + time_ [datetime_ (T.toStrict $ T.pack (show date))] $ toHtml dateStr + M.render (M.useExtensions extensions doc) where extensions = [M.ghcSyntaxHighlighter, M.skylighting, M.footnotes] + dateStr = T.pack $ formatTime defaultTimeLocale "%a %e %B %Y" date + +linkToPost :: Post -> T.Text +linkToPost p = T.pack $ "/posts" kebab (T.unpack (title p)) + +pathToPost :: Post -> FilePath +pathToPost p = "posts" kebab (T.unpack (title p)) + +-- | Creates and saves a new post +createPost :: T.Text + -- ^ The title of the post + -> T.Text + -- ^ The markdown body + -> ActionM Post + -- ^ The freshly created post +createPost title md = do + author <- do + ma <- currentUser + case ma of + Just a -> return a + Nothing -> raise "Not logged in" + curTime <- liftIO getCurrentTime + let p = Post md title curTime author + liftIO $ writeFile (pathToPost p) (show p) + return p