Main.hs

   1 {-# LANGUAGE OverloadedStrings #-}
   2 module Main where
   3
   4 import Web.Scotty.Cookie
   5 import Web.Scotty.Trans
   6 import qualified Data.Text.Lazy as T
   7 import Data.List
   8 import Data.Time
   9 import qualified Data.Map.Lazy as Map
  10 import Data.Maybe
  11 import Data.Ord
  12 import Data.IORef
  13 import Control.Exception
  14 import Control.Monad
  15 import Control.Monad.IO.Class
  16 import Control.Monad.Trans.Class
  17 import qualified Control.Monad.Trans.State as S
  18 import qualified Text.MMark as M
  19 import qualified Text.MMark.Extension.Common as M
  20 import Text.Casing
  21 import Text.Read (readMaybe)
  22 import Lucid
  23 import Lucid.Base
  24 import System.Directory
  25 import System.FilePath
  26 import System.Random
  27 import System.IO.Error
  28 import Network.HTTP.Types
  29
  30 type Sessions = Map.Map T.Text T.Text
  31 type ActionM = ActionT T.Text (S.StateT Sessions IO)
  32
  33 -- | Makes a function that carries over the state from one
  34 -- request to the next
  35 mkPreserve :: s -> IO ((S.StateT s IO) a -> IO a)
  36 mkPreserve initS = do
  37   ref <- newIORef initS
  38   return $ \f -> do
  39     s <- readIORef ref
  40     (x, s') <- S.runStateT f s
  41     writeIORef ref s'
  42     return x
  43
  44 -- TODO: Use hashes
  45 logins :: Map.Map T.Text T.Text
  46 logins = Map.fromList
  47            [ ("luke", "pass")
  48            , ("dave", "abcd")
  49            , ("antonia", "1234")
  50            , ("owen", "haskell")
  51            ]
  52 -- | Checks if the user is logged in
  53 loggedIn :: ActionM Bool
  54 loggedIn = do
  55   mCookie <- getCookie "session"
  56   case mCookie of
  57     Nothing -> return False
  58     Just cookie -> Map.member (T.fromStrict cookie) <$> lift S.get
  59
  60 -- | Returns the current username
  61 currentUser :: ActionM (Maybe T.Text)
  62 currentUser = do
  63   mCookie <- getCookie "session"
  64   case mCookie of
  65     Nothing -> return Nothing
  66     Just cookie -> Map.lookup (T.fromStrict cookie) <$> lift S.get
  67
  68 main :: IO ()
  69 main = do
  70   preserve <- mkPreserve mempty
  71   createDirectory "posts" `catch` (\e -> unless (isAlreadyExistsError e) (throw e))
  72   scottyT 3000 preserve $ do
  73     get "/style.css" $ file "style.css"
  74
  75     get "/create" $ do
  76       authed <- loggedIn
  77       if authed
  78         then template "Create" $ do
  79           h1_ "Create a new post"
  80           form_ [action_ "create", method_ "post"] $ do
  81             input_ [name_ "title", type_ "text", placeholder_ "Title"]
  82             br_ []
  83             textarea_ [name_ "body", placeholder_ "# Your markdown here"] ""
  84             br_ []
  85             input_ [type_ "submit", value_ "Post"]
  86         else do
  87           text "You're not logged in"
  88           status unauthorized401
  89
  90     post "/create" $ do
  91       t <- param "title"
  92       b <- param "body"
  93       p <- createPost t b
  94       redirect (linkToPost p)
  95
  96     post "/login" $ do
  97       username <- param "username"
  98       password <- param "password"
  99       if Map.lookup username logins /= Just password
 100         then do
 101           text "Invalid username and/or password"
 102           status unauthorized401
 103         else do
 104           session <- T.pack . show <$> liftIO (randomIO :: IO Int)
 105           lift $ S.modify (Map.insert session username)
 106           setSimpleCookie "session" (T.toStrict session)
 107           redirect "/"
 108
 109     post "/logout" $ deleteCookie "session" >> redirect "/"
 110
 111     get "/" $ do
 112       posts <- liftIO $ do
 113         fps <- listDirectory "posts"
 114         posts <- catMaybes <$> mapM load fps
 115         return $ take 5 $ sortOn (Down . postDate) posts
 116       template "Cool blog" $ sequence (mapMaybe render posts)
 117
 118     get "/posts/:post" $ do
 119       name <- param "post"
 120       mPost <- liftIO (load name)
 121       case mPost of
 122         Nothing -> status notFound404
 123         Just p -> case render p of
 124           Nothing -> status internalServerError500
 125           Just content -> template (postTitle p) content
 126
 127 template :: T.Text -> Html a -> ActionM ()
 128 template title content = do
 129   authed <- loggedIn
 130   html $ renderText $ html_ $ do
 131     head_ $ style >> title_ (toHtml title)
 132     body_ $ do
 133       term "nav" $ do
 134         a_ [href_ "/"] "🏠 Cool Blog"
 135         if authed
 136           then do
 137             "   " >> a_ [href_ "/create"] "Create a Post"
 138             form_ [action_ "/logout", method_ "post", class_ "login-form"] $
 139               input_ [type_ "submit", value_ "Log Out"]
 140           else form_ [action_ "/login", method_ "post", class_ "login-form"] $ do
 141             input_ [name_ "username", placeholder_ "Username", type_ "text"]
 142             input_ [name_ "password", placeholder_ "Password", type_ "password"]
 143             input_ [type_ "submit", value_ "Log In"]
 144       content
 145   where style = link_ [Attribute "rel" "stylesheet", Attribute "href" "/style.css"]
 146
 147 data Post = Post
 148           { postBody     :: T.Text
 149           , postTitle    :: T.Text
 150           , postDate     :: UTCTime
 151           , postAuthor   :: T.Text
 152           } deriving (Read, Show)
 153
 154 load :: String -> IO (Maybe Post)
 155 load name = do
 156   let fp = "posts" </> name
 157   guard =<< doesFileExist fp
 158   readMaybe <$> readFile fp
 159
 160 render :: Post -> Maybe (Html ())
 161 render p@(Post markdown title date author) =
 162   case M.parse (pathToPost p) (T.toStrict markdown) of
 163     Left _ -> Nothing
 164     Right doc -> Just $
 165       article_ [id_ (T.toStrict title)] $ do
 166         header_ $ do
 167           a_ [href_ (T.toStrict $ linkToPost p)] $
 168             h1_ $ toHtml title
 169           address_ $ "By " >> toHtml author
 170           time_ [datetime_ (T.toStrict $ T.pack (show date))] $ toHtml dateStr
 171         M.render (M.useExtensions extensions doc)
 172   where extensions = [M.ghcSyntaxHighlighter, M.skylighting, M.footnotes]
 173         dateStr = T.pack $ formatTime defaultTimeLocale "%a %e %B %Y" date
 174
 175 linkToPost :: Post -> T.Text
 176 linkToPost p = T.pack $ "/posts" </> kebab (T.unpack (postTitle p))
 177
 178 pathToPost :: Post -> FilePath
 179 pathToPost p = "posts" </> kebab (T.unpack (postTitle p))
 180
 181 -- | Creates and saves a new post
 182 createPost :: T.Text
 183            -- ^ The title of the post
 184            -> T.Text
 185            -- ^ The markdown body
 186            -> ActionM Post
 187            -- ^ The freshly created post
 188 createPost title markdown = do
 189   auth <- do
 190     ma <- currentUser
 191     case ma of
 192       Just a -> return a
 193       Nothing -> raise "Not logged in"
 194   curTime <- liftIO getCurrentTime
 195   let p = Post markdown title curTime auth
 196   liftIO $ writeFile (pathToPost p) (show p)
 197   return p