{-# LANGUAGE OverloadedStrings #-}
module Main where
-import Web.Scotty
+import Web.Scotty.Cookie
+import Web.Scotty.Trans
import qualified Data.Text.Lazy as T
import qualified Data.Text.Lazy.IO as T
import Data.List
import Data.Time
+import qualified Data.Map.Lazy as Map
import Data.Maybe
import Data.Ord
-import Control.Monad.IO.Class
+import Data.IORef
import Control.Monad
+import Control.Monad.IO.Class
+import Control.Monad.Trans.Class
+import qualified Control.Monad.Trans.State as S
import qualified Text.MMark as M
import qualified Text.MMark.Extension.Common as M
import Text.Casing
import Lucid.Base
import System.Directory
import System.FilePath
+import System.Random
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"
+ case mCookie of
+ 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"
+ case mCookie of
+ Nothing -> return Nothing
+ Just cookie -> Map.lookup (T.fromStrict cookie) <$> lift S.get
+
+-- | Makes a function that carries over the state from one
+-- request to the next
+mkPreserve :: s -> IO ((S.StateT s IO) a -> IO a)
+mkPreserve s = do
+ ref <- newIORef s
+ return $ \f -> do
+ s <- readIORef ref
+ (x, s') <- S.runStateT f s
+ writeIORef ref s'
+ return x
+
+-- TODO: Use hashes
+logins :: Map.Map T.Text T.Text
+logins = Map.fromList
+ [ ("luke", "pass")
+ , ("dave", "abcd")
+ , ("antonia", "1234")
+ , ("owen", "haskell")
+ ]
+
main :: IO ()
-main = scotty 3000 $ do
+main = do
+ preserve <- mkPreserve mempty
+ scottyT 3000 preserve $ do
get "/style.css" $ file "style.css"
- get "/create" $ html $ renderText $ html_ $ do
- head_ $ do
- title_ "Create"
- style
- body_ $ do
+ get "/create" $ do
+ authed <- loggedIn
+ 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"]
+ 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 <- liftIO $ save b t
- redirect ("posts/" <> title p)
+ p <- createPost t b
+ redirect (linkToPost p)
post "/login" $ do
username <- param "username"
password <- param "password"
- if username /= ("luke" :: T.Text) || password /= ("pass" :: T.Text)
- then status unauthorized401
- else redirect "/create"
+ if Map.lookup username logins /= Just password
+ 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)
+ setSimpleCookie "session" (T.toStrict session)
+ redirect "/"
+
+ post "/logout" $ deleteCookie "session" >> redirect "/"
get "/" $ do
posts <- liftIO $ do
files <- listDirectory "posts"
posts <- catMaybes <$> mapM load files
return $ take 5 $ sortOn (Down . date) posts
- html $ renderText $ html_ $ do
- head_ $ style >> title_ "Cool Blog"
- body_ $ do
- p_ $ a_ [href_ "/"] "Cool Blog"
- with form_ [action_ "/login", method_ "post"] $ do
- input_ [name_ "username", placeholder_ "Username", type_ "text"]
- input_ [name_ "password", placeholder_ "Password", type_ "password"]
- input_ [type_ "submit"]
- sequence (mapMaybe render posts)
+ template "Cool blog" $ sequence (mapMaybe render posts)
get "/posts/:post" $ do
name <- param "post"
Just post ->
case render post of
Nothing -> status internalServerError500
- Just content ->
+ Just content -> template (title post) content
+
+template :: T.Text -> Html a -> ActionM ()
+template title content = do
+ authed <- loggedIn
html $ renderText $ html_ $ do
- head_ $ style >> title_ "Post"
+ head_ $ style >> title_ (toHtml title)
body_ $ do
- p_ $ a_ [href_ "/"] "Home"
+ term "nav" $ do
+ a_ [href_ "/"] "🏠 Cool Blog"
+ if authed
+ then do
+ " " >> a_ [href_ "/create"] "Create a Post"
+ form_ [action_ "/logout", method_ "post", class_ "login-form"] $
+ input_ [type_ "submit", value_ "Log Out"]
+ 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", value_ "Log In"]
content
-
- where
- style = link_ [Attribute "rel" "stylesheet", Attribute "href" "/style.css"]
+ where style = link_ [Attribute "rel" "stylesheet", Attribute "href" "/style.css"]
data Post = Post
{ markdown :: T.Text
, title :: T.Text
, date :: UTCTime
+ , author :: T.Text
} deriving (Read, Show)
load :: String -> IO (Maybe Post)
readMaybe <$> readFile file
render :: Post -> Maybe (Html ())
-render p@(Post markdown title date) =
+render p@(Post markdown title date author) =
case M.parse (pathToPost p) (T.toStrict markdown) of
Left e -> Nothing
Right doc -> Just $
- with div_ [id_ (T.toStrict title)] $ do
- with a_ [href_ (T.toStrict $ linkToPost p)] $
+ article_ [id_ (T.toStrict title)] $ do
+ header_ $ do
+ a_ [href_ (T.toStrict $ linkToPost p)] $
h1_ $ toHtml title
- i_ $ toHtml $ formatTime defaultTimeLocale "%a %e %B %Y" date
- br_ []
+ address_ $ "By " >> toHtml author
+ 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
linkToPost :: Post -> T.Text
linkToPost p = T.pack $ "/posts" </> kebab (T.unpack (title p))
pathToPost :: Post -> FilePath
pathToPost p = "posts" </> kebab (T.unpack (title p))
-save :: T.Text -> T.Text -> IO Post
-save md title = do
- curTime <- getCurrentTime
- let kTitle = T.pack $ kebab $ T.unpack title
- p = Post md kTitle curTime
- writeFile (pathToPost p) (show p)
+-- | 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
+ Just a -> return a
+ Nothing -> raise "Not logged in"
+ curTime <- liftIO getCurrentTime
+ let p = Post md title curTime author
+ liftIO $ writeFile (pathToPost p) (show p)
return p
projects / blog.git / blobdiff