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.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 Network.HTTP.Types
  28
  29 type Sessions = Map.Map T.Text T.Text
  30 type ActionM = ActionT T.Text (S.StateT Sessions IO)
  31
  32 -- | Checks if the user is logged in
  33 loggedIn :: ActionM Bool
  34 loggedIn = do
  35   mCookie <- getCookie "session"
  36   case mCookie of
  37     Nothing -> return False
  38     Just cookie -> Map.member (T.fromStrict cookie) <$> lift S.get
  39
  40 -- | Returns the current username
  41 currentUser :: ActionM (Maybe T.Text)
  42 currentUser = do
  43   mCookie <- getCookie "session"
  44   case mCookie of
  45     Nothing -> return Nothing
  46     Just cookie -> Map.lookup (T.fromStrict cookie) <$> lift S.get
  47
  48 -- | Makes a function that carries over the state from one
  49 -- request to the next
  50 mkPreserve :: s -> IO ((S.StateT s IO) a -> IO a)
  51 mkPreserve s = do
  52   ref <- newIORef s
  53   return $ \f -> do
  54     s <- readIORef ref
  55     (x, s') <- S.runStateT f s
  56     writeIORef ref s'
  57     return x
  58
  59 -- TODO: Use hashes
  60 logins :: Map.Map T.Text T.Text
  61 logins = Map.fromList
  62            [ ("luke", "pass")
  63            , ("dave", "abcd")
  64            , ("antonia", "1234")
  65            , ("owen", "haskell")
  66            ]
  67
  68 main :: IO ()
  69 main = do
  70   preserve <- mkPreserve mempty
  71   scottyT 3000 preserve $ do
  72     get "/style.css" $ file "style.css"
  73
  74     get "/create" $ do
  75       authed <- loggedIn
  76       if authed
  77         then template "Create" $ do
  78           h1_ "Create a new post"
  79           form_ [action_ "create", method_ "post"] $ do
  80             input_ [name_ "title", type_ "text", placeholder_ "Title"]
  81             br_ []
  82             textarea_ [name_ "body", placeholder_ "# Your markdown here"] ""
  83             br_ []
  84             input_ [type_ "submit", value_ "Post"]
  85         else do
  86           text "You're not logged in"
  87           status unauthorized401
  88
  89     post "/create" $ do
  90       t <- param "title"
  91       b <- param "body"
  92       p <- createPost t b
  93       redirect (linkToPost p)
  94
  95     post "/login" $ do
  96       username <- param "username"
  97       password <- param "password"
  98       if Map.lookup username logins /= Just password
  99         then do
 100           text "Invalid username and/or password"
 101           status unauthorized401
 102         else do
 103           session <- T.pack . show <$> liftIO (randomIO :: IO Int)
 104           lift $ S.modify (Map.insert session username)
 105           setSimpleCookie "session" (T.toStrict session)
 106           redirect "/"
 107
 108     post "/logout" $ deleteCookie "session" >> redirect "/"
 109
 110     get "/" $ do
 111       posts <- liftIO $ do
 112         files <- listDirectory "posts"
 113         posts <- catMaybes <$> mapM load files
 114         return $ take 5 $ sortOn (Down . date) posts
 115       template "Cool blog" $ sequence (mapMaybe render posts)
 116
 117     get "/posts/:post" $ do
 118       name <- param "post"
 119       mPost <- liftIO (load name)
 120       case mPost of
 121         Nothing -> status notFound404
 122         Just post ->
 123           case render post of
 124             Nothing -> status internalServerError500
 125             Just content -> template (title post) 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           { markdown :: T.Text
 149           , title    :: T.Text
 150           , date     :: UTCTime
 151           , author   :: T.Text
 152           } deriving (Read, Show)
 153
 154 load :: String -> IO (Maybe Post)
 155 load name = do
 156   let file = "posts" </> name
 157   guard =<< doesFileExist file
 158   readMaybe <$> readFile file
 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 e -> 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 (title p))
 177
 178 pathToPost :: Post -> FilePath
 179 pathToPost p = "posts" </> kebab (T.unpack (title 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 md = do
 189   author <- 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 md title curTime author
 196   liftIO $ writeFile (pathToPost p) (show p)
 197   return p