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