import Data.Maybe
import Data.Ord
import Data.IORef
+import Control.Exception
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Trans.Class
import System.Directory
import System.FilePath
import System.Random
+import System.IO.Error
import Network.HTTP.Types
type Sessions = Map.Map T.Text T.Text
type ActionM = ActionT T.Text (S.StateT Sessions IO)
+-- | Checks if the user is logged in
loggedIn :: ActionM Bool
loggedIn = do
mCookie <- getCookie "session"
Nothing -> return False
Just cookie -> Map.member (T.fromStrict cookie) <$> lift S.get
+-- | Returns the current username
currentUser :: ActionM (Maybe T.Text)
currentUser = do
mCookie <- getCookie "session"
main :: IO ()
main = do
preserve <- mkPreserve mempty
+ createDirectory "posts" `catch` (\e -> unless (isAlreadyExistsError e) (throw e))
scottyT 3000 preserve $ do
get "/style.css" $ file "style.css"
if authed
then template "Create" $ do
h1_ "Create a new post"
- with form_ [action_ "create", method_ "post"] $ do
+ form_ [action_ "create", method_ "post"] $ do
input_ [name_ "title", type_ "text", placeholder_ "Title"]
br_ []
- with textarea_ [name_ "body", placeholder_ "# Your markdown here"] ""
+ textarea_ [name_ "body", placeholder_ "# Your markdown here"] ""
br_ []
- input_ [type_ "submit"]
- else status unauthorized401
+ input_ [type_ "submit", value_ "Post"]
+ else do
+ text "You're not logged in"
+ status unauthorized401
post "/create" $ do
t <- param "title"
b <- param "body"
- p <- createPost b t
+ p <- createPost t b
redirect (linkToPost p)
post "/login" $ do
username <- param "username"
password <- param "password"
if Map.lookup username logins /= Just password
- then status unauthorized401
+ then do
+ text "Invalid username and/or password"
+ status unauthorized401
else do
session <- T.pack . show <$> liftIO (randomIO :: IO Int)
lift $ S.modify (Map.insert session username)
a_ [href_ "/"] "🏠 Cool Blog"
if authed
then do
- a_ [href_ "/create"] "Create a Post"
- with form_ [action_ "/logout", method_ "post", class_ "login-form"] $
+ " " >> a_ [href_ "/create"] "Create a Post"
+ form_ [action_ "/logout", method_ "post", class_ "login-form"] $
input_ [type_ "submit", value_ "Log Out"]
- else with form_ [action_ "/login", method_ "post", class_ "login-form"] $ do
+ else form_ [action_ "/login", method_ "post", class_ "login-form"] $ do
input_ [name_ "username", placeholder_ "Username", type_ "text"]
input_ [name_ "password", placeholder_ "Password", type_ "password"]
- input_ [type_ "submit"]
+ input_ [type_ "submit", value_ "Log In"]
content
where style = link_ [Attribute "rel" "stylesheet", Attribute "href" "/style.css"]
case M.parse (pathToPost p) (T.toStrict markdown) of
Left e -> Nothing
Right doc -> Just $
- with article_ [id_ (T.toStrict title)] $ do
+ article_ [id_ (T.toStrict title)] $ do
header_ $ do
- with a_ [href_ (T.toStrict $ linkToPost p)] $
+ a_ [href_ (T.toStrict $ linkToPost p)] $
h1_ $ toHtml title
address_ $ "By " >> toHtml author
- with time_ [datetime_ (T.toStrict $ T.pack (show date))] $ toHtml dateStr
+ time_ [datetime_ (T.toStrict $ T.pack (show date))] $ toHtml dateStr
M.render (M.useExtensions extensions doc)
where extensions = [M.ghcSyntaxHighlighter, M.skylighting, M.footnotes]
dateStr = T.pack $ formatTime defaultTimeLocale "%a %e %B %Y" date
pathToPost :: Post -> FilePath
pathToPost p = "posts" </> kebab (T.unpack (title p))
-createPost :: T.Text -> T.Text -> ActionM Post
-createPost md title = do
+-- | Creates and saves a new post
+createPost :: T.Text
+ -- ^ The title of the post
+ -> T.Text
+ -- ^ The markdown body
+ -> ActionM Post
+ -- ^ The freshly created post
+createPost title md = do
author <- do
ma <- currentUser
case ma of