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 Lucid
  17 import Lucid.Base
  18 import System.Directory
  19 import System.FilePath
  20 import Network.HTTP.Types
  21
  22 main :: IO ()
  23 main = scotty 3000 $ do
  24   get "/style.css" $ file "style.css"
  25
  26   get "/create" $ html $ renderText $ html_ $ do
  27     head_ $ do
  28       title_ "Create"
  29       style
  30     body_ $ do
  31       h1_ "Create a new post"
  32       with form_ [action_ "create", method_ "post"] $ do
  33         input_ [name_ "title", type_ "text", placeholder_ "Title"]
  34         br_ []
  35         with textarea_ [name_ "body", placeholder_ "# Your markdown here"] ""
  36         br_ []
  37         input_ [type_ "submit"]
  38
  39   post "/create" $ do
  40     t <- param "title"
  41     b <- param "body"
  42     p <- liftIO $ save b t
  43     redirect ("post/" <> title p)
  44
  45   post "/login" $ do
  46     username <- param "username"
  47     password <- param "password"
  48     if username /= ("luke" :: T.Text) || password /= ("pass" :: T.Text)
  49       then status unauthorized401
  50       else redirect "/create"
  51
  52   get "/" $ do
  53     posts <- liftIO $ do
  54       names <- listDirectory "posts"
  55       let files = ("posts" </>) <$> names
  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 ("posts" </> name <.> "md")
  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           }
  91
  92 load :: FilePath -> IO (Maybe Post)
  93 load file = do
  94   liftIO $ guard (takeExtension file == ".md")
  95   md <- liftIO (T.readFile file)
  96   modTime <- getModificationTime file
  97   let title = T.pack $ takeBaseName file
  98   return $ Just (Post md title modTime)
  99
 100 render :: Post -> Maybe (Html ())
 101 render p@(Post markdown title date) =
 102   case M.parse (pathToPost p) (T.toStrict markdown) of
 103     Left e -> Nothing
 104     Right doc -> Just $
 105       with div_ [id_ (T.toStrict title)] $ do
 106         with a_ [href_ (T.toStrict $ linkToPost p)] $
 107           i_ $ toHtml $ formatTime defaultTimeLocale "%a %e %B %Y" date
 108         br_ []
 109         M.render (M.useExtensions extensions doc)
 110   where extensions = [M.ghcSyntaxHighlighter, M.skylighting, M.footnotes]
 111
 112 linkToPost :: Post -> T.Text
 113 linkToPost p = T.pack $ "/posts" </> T.unpack (title p)
 114
 115 pathToPost :: Post -> FilePath
 116 pathToPost p = "posts" </> T.unpack (title p) <.> "md"
 117
 118 save :: T.Text -> T.Text -> IO Post
 119 save md title = do
 120   curTime <- getCurrentTime
 121   let kTitle = T.pack $ kebab $ T.unpack title
 122       p = Post md kTitle curTime
 123   T.writeFile (pathToPost p) (markdown p)
 124   return p