X-Git-Url: https://git.lukelau.me/?p=blog.git;a=blobdiff_plain;f=Main.hs;h=a0560b26c4cbf3ac897f41b0d9c6a1dcee7aab0e;hp=f3a7472085479ec5555524fd133ac0146fb210eb;hb=HEAD;hpb=203a4ba8a08faf4c6640c7d60e729459de56d865 diff --git a/Main.hs b/Main.hs index f3a7472..a0560b2 100644 --- a/Main.hs +++ b/Main.hs @@ -4,13 +4,13 @@ module Main where 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 Data.IORef +import Control.Exception import Control.Monad import Control.Monad.IO.Class import Control.Monad.Trans.Class @@ -24,30 +24,17 @@ 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) -loggedIn :: ActionM Bool -loggedIn = do - mCookie <- getCookie "session" - case mCookie of - Nothing -> return False - Just cookie -> Map.member (T.fromStrict cookie) <$> lift S.get - -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 +mkPreserve initS = do + ref <- newIORef initS return $ \f -> do s <- readIORef ref (x, s') <- S.runStateT f s @@ -62,10 +49,26 @@ logins = Map.fromList , ("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 = do preserve <- mkPreserve mempty + createDirectory "posts" `catch` (\e -> unless (isAlreadyExistsError e) (throw e)) scottyT 3000 preserve $ do get "/style.css" $ file "style.css" @@ -80,19 +83,23 @@ main = do textarea_ [name_ "body", placeholder_ "# Your markdown here"] "" br_ [] input_ [type_ "submit", value_ "Post"] - else status unauthorized401 + else do + text "You're not logged in" + status unauthorized401 post "/create" $ do t <- param "title" b <- param "body" - p <- createPost b t + p <- createPost t b redirect (linkToPost p) post "/login" $ do username <- param "username" password <- param "password" if Map.lookup username logins /= Just password - then status unauthorized401 + 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) @@ -102,10 +109,7 @@ main = do 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 + posts <- take 5 <$> liftIO loadAll template "Cool blog" $ sequence (mapMaybe render posts) get "/posts/:post" $ do @@ -113,10 +117,17 @@ main = do 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 -> template (title post) 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 @@ -139,47 +150,60 @@ template title content = do where style = link_ [Attribute "rel" "stylesheet", Attribute "href" "/style.css"] data Post = Post - { markdown :: T.Text - , title :: T.Text - , date :: UTCTime - , author :: T.Text + { 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 author) = case M.parse (pathToPost p) (T.toStrict markdown) of - Left e -> Nothing + Left _ -> 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 + 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)) - -createPost :: T.Text -> T.Text -> ActionM Post -createPost md title = do - author <- do +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 md title curTime author + let p = Post markdown title curTime auth liftIO $ writeFile (pathToPost p) (show p) return p