X-Git-Url: https://git.lukelau.me/?p=blog.git;a=blobdiff_plain;f=Main.hs;h=a0560b26c4cbf3ac897f41b0d9c6a1dcee7aab0e;hp=92935c8be3d445e4ce4f8d3d89c38b4bc4123400;hb=HEAD;hpb=0848263e3bc89a44d351980eef66207931eaa7aa

diff --git a/Main.hs b/Main.hs
index 92935c8..a0560b2 100644
--- a/Main.hs
+++ b/Main.hs
@@ -1,72 +1,209 @@
 {-# 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)
+
+-- | 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_ 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 <- 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 p -> case render p of
+          Nothing -> status internalServerError500
+          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
+    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
+          { postBody     :: T.Text
+          , postTitle    :: T.Text
+          , postDate     :: UTCTime
+          , postAuthor   :: 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)
+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 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 _ -> Nothing
+    Right doc -> Just $
+      article_ [id_ (T.toStrict title)] $ do
+        header_ $ do
+          a_ [href_ (T.toStrict $ linkToPost p)] $
+            h1_ $ toHtml title
+          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 (postTitle p))
+
+pathToPost :: Post -> FilePath
+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