X-Git-Url: https://git.lukelau.me/?p=blog.git;a=blobdiff_plain;f=Main.hs;h=a0560b26c4cbf3ac897f41b0d9c6a1dcee7aab0e;hp=8a0c5a30e3c72642901247ca4f89ec630ff2bfa3;hb=HEAD;hpb=f500b88dce0855766c5a8da4fdf3a855eb0a4d9b diff --git a/Main.hs b/Main.hs index 8a0c5a3..a0560b2 100644 --- a/Main.hs +++ b/Main.hs @@ -1,15 +1,20 @@ {-# 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 Data.List import Data.Time +import qualified Data.Map.Lazy as Map import Data.Maybe import Data.Ord -import Control.Monad.IO.Class +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 @@ -18,106 +23,187 @@ 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) + +-- | 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 initS = do + ref <- newIORef initS + 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") + ] +-- | 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 + 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_ $ do - title_ "Create" - style - body_ $ do + get "/create" $ do + authed <- loggedIn + if authed + then template "Create" $ do h1_ "Create a new post" - with form_ [action_ "create", method_ "post"] $ do + form_ [action_ "create", method_ "post"] $ do input_ [name_ "title", type_ "text", placeholder_ "Title"] br_ [] - with textarea_ [name_ "body", placeholder_ "# Your markdown here"] "" + textarea_ [name_ "body", placeholder_ "# Your markdown here"] "" br_ [] - input_ [type_ "submit"] + input_ [type_ "submit", value_ "Post"] + else do + text "You're not logged in" + status unauthorized401 post "/create" $ do t <- param "title" b <- param "body" - p <- liftIO $ save b t - redirect ("posts/" <> title p) + 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 <- liftIO $ do - files <- listDirectory "posts" - posts <- catMaybes <$> mapM load files - return $ take 5 $ sortOn (Down . date) posts - html $ renderText $ html_ $ do - head_ $ style >> title_ "Cool Blog" - body_ $ do - p_ $ a_ [href_ "/"] "Cool Blog" - 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 (mapMaybe render posts) + posts <- take 5 <$> liftIO loadAll + 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 + Just p -> case render p of Nothing -> status internalServerError500 - Just content -> + Just content -> template (postTitle p) content + + get "/author/:author" $ do + author <- param "author" + posts <- filter ((== author) . postAuthor) <$> liftIO loadAll + let title = "Posts by " <> author + template title $ do + h1_ (toHtml title) + sequence (mapMaybe render posts) + +template :: T.Text -> Html a -> ActionM () +template title content = do + authed <- loggedIn html $ renderText $ html_ $ do - head_ $ style >> title_ "Post" + head_ $ style >> title_ (toHtml title) body_ $ do - p_ $ a_ [href_ "/"] "Home" + 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"] + where style = link_ [Attribute "rel" "stylesheet", Attribute "href" "/style.css"] data Post = Post - { markdown :: T.Text - , title :: T.Text - , date :: UTCTime + { postBody :: T.Text + , postTitle :: T.Text + , postDate :: UTCTime + , postAuthor :: T.Text } deriving (Read, Show) +loadAll :: IO [Post] +loadAll = do + fps <- listDirectory "posts" + posts <- catMaybes <$> mapM load fps + return $ sortOn (Down . postDate) posts + load :: String -> IO (Maybe Post) load name = do - let file = "posts" name - guard =<< doesFileExist file - readMaybe <$> readFile file + let fp = "posts" name + guard =<< doesFileExist fp + readMaybe <$> readFile fp render :: Post -> Maybe (Html ()) -render p@(Post markdown title date) = +render p@(Post markdown title date author) = case M.parse (pathToPost p) (T.toStrict markdown) of - Left e -> Nothing + Left _ -> Nothing Right doc -> Just $ - with div_ [id_ (T.toStrict title)] $ do - with a_ [href_ (T.toStrict $ linkToPost p)] $ + article_ [id_ (T.toStrict title)] $ do + header_ $ do + a_ [href_ (T.toStrict $ linkToPost p)] $ h1_ $ toHtml title - i_ $ toHtml $ formatTime defaultTimeLocale "%a %e %B %Y" date - br_ [] + a_ [href_ (T.toStrict $ "/author/" <> postAuthor p)] $ + 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)) +linkToPost p = T.pack $ "/posts" kebab (T.unpack (postTitle p)) pathToPost :: Post -> FilePath -pathToPost p = "posts" kebab (T.unpack (title p)) - -save :: T.Text -> T.Text -> IO Post -save md title = do - curTime <- getCurrentTime - let kTitle = T.pack $ kebab $ T.unpack title - p = Post md kTitle curTime - writeFile (pathToPost p) (show p) +pathToPost p = "posts" kebab (T.unpack (postTitle 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 markdown = do + auth <- do + ma <- currentUser + case ma of + Just a -> return a + Nothing -> raise "Not logged in" + curTime <- liftIO getCurrentTime + let p = Post markdown title curTime auth + liftIO $ writeFile (pathToPost p) (show p) return p