Main.hs

   1 {-# LANGUAGE OverloadedStrings #-}
   2 module Main where
   3
   4 import Web.Scotty
   5 import qualified Data.Text.Lazy as T
   6 import qualified Data.Text.Lazy.IO as T
   7 import Data.List
   8 import Data.Time
   9 import Data.Maybe
  10 import Data.Ord
  11 import Control.Monad.IO.Class
  12 import Control.Monad
  13 import qualified Text.MMark as M
  14 import qualified Text.MMark.Extension.Common as M
  15 import Text.Casing
  16 import Text.Read (readMaybe)
  17 import Lucid
  18 import Lucid.Base
  19 import System.Directory
  20 import System.FilePath
  21 import Network.HTTP.Types
  22
  23 main :: IO ()
  24 main = scotty 3000 $ do
  25   get "/style.css" $ file "style.css"
  26
  27   get "/create" $ html $ renderText $ html_ $ do
  28     head_ $ do
  29       title_ "Create"
  30       style
  31     body_ $ do
  32       h1_ "Create a new post"
  33       with form_ [action_ "create", method_ "post"] $ do
  34         input_ [name_ "title", type_ "text", placeholder_ "Title"]
  35         br_ []
  36         with textarea_ [name_ "body", placeholder_ "# Your markdown here"] ""
  37         br_ []
  38         input_ [type_ "submit"]
  39
  40   post "/create" $ do
  41     t <- param "title"
  42     b <- param "body"
  43     p <- liftIO $ save b t
  44     redirect ("posts/" <> title p)
  45
  46   post "/login" $ do
  47     username <- param "username"
  48     password <- param "password"
  49     if username /= ("luke" :: T.Text) || password /= ("pass" :: T.Text)
  50       then status unauthorized401
  51       else redirect "/create"
  52
  53   get "/" $ do
  54     posts <- liftIO $ do
  55       files <- listDirectory "posts"
  56       posts <- catMaybes <$> mapM load files
  57       return $ take 5 $ sortOn (Down . date) posts
  58     html $ renderText $ html_ $ do
  59       head_ $ style >> title_ "Cool Blog"
  60       body_ $ do
  61         p_ $ a_ [href_ "/"] "Cool Blog"
  62         with form_ [action_ "/login", method_ "post"] $ do
  63           input_ [name_ "username", placeholder_ "Username", type_ "text"]
  64           input_ [name_ "password", placeholder_ "Password", type_ "password"]
  65           input_ [type_ "submit"]
  66         sequence (mapMaybe render posts)
  67
  68   get "/posts/:post" $ do
  69     name <- param "post"
  70     mPost <- liftIO (load name)
  71     case mPost of
  72       Nothing -> status notFound404
  73       Just post ->
  74         case render post of
  75           Nothing -> status internalServerError500
  76           Just content ->
  77             html $ renderText $ html_ $ do
  78               head_ $ style >> title_ "Post"
  79               body_ $ do
  80                 p_ $ a_ [href_ "/"] "Home"
  81                 content
  82
  83   where
  84     style = link_ [Attribute "rel" "stylesheet", Attribute "href" "/style.css"]
  85
  86 data Post = Post
  87           { markdown :: T.Text
  88           , title    :: T.Text
  89           , date     :: UTCTime
  90           } deriving (Read, Show)
  91
  92 load :: String -> IO (Maybe Post)
  93 load name = do
  94   let file = "posts" </> name
  95   guard =<< doesFileExist file
  96   readMaybe <$> readFile file
  97
  98 render :: Post -> Maybe (Html ())
  99 render p@(Post markdown title date) =
 100   case M.parse (pathToPost p) (T.toStrict markdown) of
 101     Left e -> Nothing
 102     Right doc -> Just $
 103       with div_ [id_ (T.toStrict title)] $ do
 104         with a_ [href_ (T.toStrict $ linkToPost p)] $
 105           h1_ $ toHtml title
 106         i_ $ toHtml $ formatTime defaultTimeLocale "%a %e %B %Y" date
 107         br_ []
 108         M.render (M.useExtensions extensions doc)
 109   where extensions = [M.ghcSyntaxHighlighter, M.skylighting, M.footnotes]
 110
 111 linkToPost :: Post -> T.Text
 112 linkToPost p = T.pack $ "/posts" </> kebab (T.unpack (title p))
 113
 114 pathToPost :: Post -> FilePath
 115 pathToPost p = "posts" </> kebab (T.unpack (title p))
 116
 117 save :: T.Text -> T.Text -> IO Post
 118 save md title = do
 119   curTime <- getCurrentTime
 120   let kTitle = T.pack $ kebab $ T.unpack title
 121       p = Post md kTitle curTime
 122   writeFile (pathToPost p) (show p)
 123   return p