X-Git-Url: https://git.lukelau.me/?p=blog.git;a=blobdiff_plain;f=Main.hs;h=a0560b26c4cbf3ac897f41b0d9c6a1dcee7aab0e;hp=24e201726f653d994b9ea53c63f69419b358bdd3;hb=HEAD;hpb=a2fb53d788ced698c13a0ecf5a2f0f8cbc884f8a

diff --git a/Main.hs b/Main.hs
index 24e2017..a0560b2 100644
--- a/Main.hs
+++ b/Main.hs
@@ -4,7 +4,6 @@ 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
@@ -31,27 +30,11 @@ 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
+mkPreserve initS = do
+  ref <- newIORef initS
   return $ \f -> do
     s <- readIORef ref
     (x, s') <- S.runStateT f s
@@ -66,6 +49,21 @@ 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
@@ -111,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
@@ -122,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
@@ -148,38 +150,45 @@ 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))
+pathToPost p = "posts" </> kebab (T.unpack (postTitle p))
 
 -- | Creates and saves a new post
 createPost :: T.Text
@@ -188,13 +197,13 @@ createPost :: T.Text
            -- ^ The markdown body
            -> ActionM Post
            -- ^ The freshly created post
-createPost title md = do
-  author <- do
+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