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