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 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)
-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
+mkPreserve initS = do
+ ref <- newIORef initS
return $ \f -> do
s <- readIORef ref
(x, s') <- S.runStateT f s
, ("antonia", "1234")
, ("owen", "haskell")
]
+-- | 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
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)
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
+ posts <- take 5 <$> liftIO loadAll
template "Cool blog" $ sequence (mapMaybe render posts)
get "/posts/:post" $ do
mPost <- liftIO (load name)
case mPost of
Nothing -> status notFound404
- Just post ->
- case render post of
+ Just p -> case render p of
Nothing -> status internalServerError500
- Just content -> template (title post) content
+ Just content -> template (postTitle p) content
+
+ get "/author/:author" $ do
+ author <- param "author"
+ posts <- filter ((== author) . postAuthor) <$> liftIO loadAll
+ let title = "Posts by " <> author
+ template title $ do
+ h1_ (toHtml title)
+ sequence (mapMaybe render posts)
template :: T.Text -> Html a -> ActionM ()
template title content = do
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"]
data Post = Post
- { markdown :: T.Text
- , title :: T.Text
- , date :: UTCTime
- , author :: T.Text
+ { postBody :: T.Text
+ , postTitle :: T.Text
+ , postDate :: UTCTime
+ , postAuthor :: T.Text
} deriving (Read, Show)
+loadAll :: IO [Post]
+loadAll = do
+ fps <- listDirectory "posts"
+ posts <- catMaybes <$> mapM load fps
+ return $ sortOn (Down . postDate) posts
+
load :: String -> IO (Maybe Post)
load name = do
- let file = "posts" </> name
- guard =<< doesFileExist file
- readMaybe <$> readFile file
+ let fp = "posts" </> name
+ guard =<< doesFileExist fp
+ readMaybe <$> readFile fp
render :: Post -> Maybe (Html ())
render p@(Post markdown title date author) =
case M.parse (pathToPost p) (T.toStrict markdown) of
- Left e -> Nothing
+ Left _ -> 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
+ a_ [href_ (T.toStrict $ "/author/" <> postAuthor p)] $
+ 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))
+linkToPost p = T.pack $ "/posts" </> kebab (T.unpack (postTitle p))
pathToPost :: Post -> FilePath
-pathToPost p = "posts" </> kebab (T.unpack (title p))
-
-createPost :: T.Text -> T.Text -> ActionM Post
-createPost md title = do
- author <- do
+pathToPost p = "posts" </> kebab (T.unpack (postTitle 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 markdown = do
+ auth <- 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
+ let p = Post markdown title curTime auth
liftIO $ writeFile (pathToPost p) (show p)
return p
projects / blog.git / blobdiff