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 <- take 5 <$> liftIO loadAll
 113       template "Cool blog" $ sequence (mapMaybe render posts)
 114
 115     get "/posts/:post" $ do
 116       name <- param "post"
 117       mPost <- liftIO (load name)
 118       case mPost of
 119         Nothing -> status notFound404
 120         Just p -> case render p of
 121           Nothing -> status internalServerError500
 122           Just content -> template (postTitle p) content
 123
 124     get "/author/:author" $ do
 125       author <- param "author"
 126       posts <- filter ((== author) . postAuthor) <$> liftIO loadAll
 127       let title = "Posts by " <> author
 128       template title $ do
 129         h1_ (toHtml title)
 130         sequence (mapMaybe render posts)
 131
 132 template :: T.Text -> Html a -> ActionM ()
 133 template title content = do
 134   authed <- loggedIn
 135   html $ renderText $ html_ $ do
 136     head_ $ style >> title_ (toHtml title)
 137     body_ $ do
 138       term "nav" $ do
 139         a_ [href_ "/"] "🏠 Cool Blog"
 140         if authed
 141           then do
 142             "   " >> a_ [href_ "/create"] "Create a Post"
 143             form_ [action_ "/logout", method_ "post", class_ "login-form"] $
 144               input_ [type_ "submit", value_ "Log Out"]
 145           else form_ [action_ "/login", method_ "post", class_ "login-form"] $ do
 146             input_ [name_ "username", placeholder_ "Username", type_ "text"]
 147             input_ [name_ "password", placeholder_ "Password", type_ "password"]
 148             input_ [type_ "submit", value_ "Log In"]
 149       content
 150   where style = link_ [Attribute "rel" "stylesheet", Attribute "href" "/style.css"]
 151
 152 data Post = Post
 153           { postBody     :: T.Text
 154           , postTitle    :: T.Text
 155           , postDate     :: UTCTime
 156           , postAuthor   :: T.Text
 157           } deriving (Read, Show)
 158
 159 loadAll :: IO [Post]
 160 loadAll = do
 161   fps <- listDirectory "posts"
 162   posts <- catMaybes <$> mapM load fps
 163   return $ sortOn (Down . postDate) posts
 164
 165 load :: String -> IO (Maybe Post)
 166 load name = do
 167   let fp = "posts" </> name
 168   guard =<< doesFileExist fp
 169   readMaybe <$> readFile fp
 170
 171 render :: Post -> Maybe (Html ())
 172 render p@(Post markdown title date author) =
 173   case M.parse (pathToPost p) (T.toStrict markdown) of
 174     Left _ -> Nothing
 175     Right doc -> Just $
 176       article_ [id_ (T.toStrict title)] $ do
 177         header_ $ do
 178           a_ [href_ (T.toStrict $ linkToPost p)] $
 179             h1_ $ toHtml title
 180           a_ [href_ (T.toStrict $ "/author/" <> postAuthor p)] $
 181             address_ ("By " >> toHtml author)
 182           time_ [datetime_ (T.toStrict $ T.pack (show date))] $ toHtml dateStr
 183         M.render (M.useExtensions extensions doc)
 184   where extensions = [M.ghcSyntaxHighlighter, M.skylighting, M.footnotes]
 185         dateStr = T.pack $ formatTime defaultTimeLocale "%a %e %B %Y" date
 186
 187 linkToPost :: Post -> T.Text
 188 linkToPost p = T.pack $ "/posts" </> kebab (T.unpack (postTitle p))
 189
 190 pathToPost :: Post -> FilePath
 191 pathToPost p = "posts" </> kebab (T.unpack (postTitle p))
 192
 193 -- | Creates and saves a new post
 194 createPost :: T.Text
 195            -- ^ The title of the post
 196            -> T.Text
 197            -- ^ The markdown body
 198            -> ActionM Post
 199            -- ^ The freshly created post
 200 createPost title markdown = do
 201   auth <- do
 202     ma <- currentUser
 203     case ma of
 204       Just a -> return a
 205       Nothing -> raise "Not logged in"
 206   curTime <- liftIO getCurrentTime
 207   let p = Post markdown title curTime auth
 208   liftIO $ writeFile (pathToPost p) (show p)
 209   return p