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 html $ renderText $ html_ $ do
  76           head_ $ do
  77             title_ "Create"
  78             style
  79           body_ $ do
  80             h1_ "Create a new post"
  81             with form_ [action_ "create", method_ "post"] $ do
  82               input_ [name_ "title", type_ "text", placeholder_ "Title"]
  83               br_ []
  84               with textarea_ [name_ "body", placeholder_ "# Your markdown here"] ""
  85               br_ []
  86               input_ [type_ "submit"]
  87         else status unauthorized401
  88
  89     post "/create" $ do
  90       t <- param "title"
  91       b <- param "body"
  92       p <- createPost b t
  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 status unauthorized401
 100         else do
 101           session <- T.pack . show <$> liftIO (randomIO :: IO Int)
 102           lift $ S.modify (Map.insert session username)
 103           setSimpleCookie "session" (T.toStrict session)
 104           redirect "/"
 105
 106     post "/logout" $ deleteCookie "session" >> redirect "/"
 107
 108     get "/" $ do
 109       authed <- loggedIn
 110       posts <- liftIO $ do
 111         files <- listDirectory "posts"
 112         posts <- catMaybes <$> mapM load files
 113         return $ take 5 $ sortOn (Down . date) posts
 114       html $ renderText $ html_ $ do
 115         head_ $ style >> title_ "Cool Blog"
 116         body_ $ do
 117           p_ $ a_ [href_ "/"] "Cool Blog"
 118           if authed
 119             then do
 120               a_ [href_ "/create"] "Create a Post"
 121               br_ []
 122               with form_ [action_ "/logout", method_ "post"] $
 123                 input_ [type_ "submit", value_ "Log Out"]
 124             else with form_ [action_ "/login", method_ "post"] $ do
 125               input_ [name_ "username", placeholder_ "Username", type_ "text"]
 126               input_ [name_ "password", placeholder_ "Password", type_ "password"]
 127               input_ [type_ "submit"]
 128           sequence (mapMaybe render posts)
 129
 130     get "/posts/:post" $ do
 131       name <- param "post"
 132       mPost <- liftIO (load name)
 133       case mPost of
 134         Nothing -> status notFound404
 135         Just post ->
 136           case render post of
 137             Nothing -> status internalServerError500
 138             Just content ->
 139               html $ renderText $ html_ $ do
 140                 head_ $ style >> title_ "Post"
 141                 body_ $ do
 142                   p_ $ a_ [href_ "/"] "Home"
 143                   content
 144
 145 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       with div_ [id_ (T.toStrict title)] $ do
 166         with a_ [href_ (T.toStrict $ linkToPost p)] $
 167           h1_ $ toHtml title
 168         i_ $ toHtml $ "By " <> author <> ", " <> dateStr
 169         br_ []
 170         M.render (M.useExtensions extensions doc)
 171   where extensions = [M.ghcSyntaxHighlighter, M.skylighting, M.footnotes]
 172         dateStr = T.pack $ formatTime defaultTimeLocale "%a %e %B %Y" date
 173
 174 linkToPost :: Post -> T.Text
 175 linkToPost p = T.pack $ "/posts" </> kebab (T.unpack (title p))
 176
 177 pathToPost :: Post -> FilePath
 178 pathToPost p = "posts" </> kebab (T.unpack (title p))
 179
 180 createPost :: T.Text -> T.Text -> ActionM Post
 181 createPost md title = do
 182   author <- do
 183     ma <- currentUser
 184     case ma of
 185       Just a -> return a
 186       Nothing -> raise "Not logged in"
 187   curTime <- liftIO getCurrentTime
 188   let p = Post md title curTime author
 189   liftIO $ writeFile (pathToPost p) (show p)
 190   return p