{-# 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)
+
+loggedIn :: ActionM Bool
+loggedIn = do
+ mCookie <- getCookie "session"
+ case mCookie of
+ Nothing -> return False
+ Just cookie -> Map.member (T.fromStrict cookie) <$> lift S.get
+
+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
+ get "/create" $ do
+ authed <- loggedIn
+ if authed
+ then html $ renderText $ html_ $ do
head_ $ do
title_ "Create"
style
with textarea_ [name_ "body", placeholder_ "# Your markdown here"] ""
br_ []
input_ [type_ "submit"]
+ else status unauthorized401
post "/create" $ do
t <- param "title"
b <- param "body"
- p <- liftIO $ save b t
- redirect ("posts/" <> title p)
+ p <- createPost b t
+ redirect (linkToPost p)
post "/login" $ do
username <- param "username"
password <- param "password"
- if username /= ("luke" :: T.Text) || password /= ("pass" :: T.Text)
+ if Map.lookup username logins /= Just password
then status unauthorized401
- else redirect "/create"
+ 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
+ authed <- loggedIn
posts <- liftIO $ do
files <- listDirectory "posts"
posts <- catMaybes <$> mapM load files
head_ $ style >> title_ "Cool Blog"
body_ $ do
p_ $ a_ [href_ "/"] "Cool Blog"
- with form_ [action_ "/login", method_ "post"] $ do
+ if authed
+ then do
+ a_ [href_ "/create"] "Create a Post"
+ br_ []
+ with form_ [action_ "/logout", method_ "post"] $
+ input_ [type_ "submit", value_ "Log Out"]
+ else with form_ [action_ "/login", method_ "post"] $ do
input_ [name_ "username", placeholder_ "Username", type_ "text"]
input_ [name_ "password", placeholder_ "Password", type_ "password"]
input_ [type_ "submit"]
p_ $ a_ [href_ "/"] "Home"
content
- 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)] $
h1_ $ toHtml title
- i_ $ toHtml $ formatTime defaultTimeLocale "%a %e %B %Y" date
+ i_ $ toHtml $ "By " <> author <> ", " <> dateStr
br_ []
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)
+createPost :: T.Text -> T.Text -> ActionM Post
+createPost md title = 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