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 Control.Monad.IO.Class
   8 import Control.Monad
   9 import qualified Text.MMark as M
  10 import qualified Text.MMark.Extension.Common as M
  11 import Lucid
  12 import Lucid.Base
  13 import System.Directory
  14 import System.FilePath
  15 import Network.HTTP.Types
  16
  17 main :: IO ()
  18 main = scotty 3000 $ do
  19   get "/style.css" $ file "style.css"
  20
  21   get "/create" $ html $ renderText $ html_ $ do
  22     head_ style
  23     body_ $ with form_ [action_ "create", method_ "post"] $ do
  24       input_ [name_ "title", type_ "text"]
  25       with textarea_ [name_ "body", placeholder_ "body"] ""
  26       input_ [type_ "submit"]
  27
  28   post "/create" $ do
  29     title <- param "title"
  30     body <- param "body"
  31     let fp = "posts" </> T.unpack title <.> "md"
  32     liftIO $ T.writeFile fp body
  33     redirect ("post/" <> title)
  34
  35   post "/login" $ do
  36     username <- param "username"
  37     password <- param "password"
  38     if username /= ("luke" :: T.Text) || password /= ("pass" :: T.Text)
  39       then status unauthorized401
  40       else redirect "/create"
  41
  42   get "/" $ do
  43     posts <- fmap dropExtension <$> liftIO (listDirectory "posts")
  44     contents <- mapM render posts
  45     html $ renderText $ html_ $ do
  46       head_ style
  47       body_ $ do
  48         with form_ [action_ "/login", method_ "post"] $ do
  49           input_ [name_ "username", placeholder_ "username", type_ "text"]
  50           input_ [name_ "password", placeholder_ "password", type_ "password"]
  51           input_ [type_ "submit"]
  52         sequence contents
  53
  54
  55   get "/post/:post" $ do
  56     post <- param "post"
  57     content <- render post
  58     html $ renderText $ html_ $ do
  59       head_ style
  60       body_ content
  61
  62   where
  63     style = link_ [Attribute "rel" "stylesheet", Attribute "href" "style.css"]
  64
  65 render :: String -> ActionM (Html ())
  66 render post = do
  67   let name = "posts" </> post <.> ".md"
  68   markdown <- T.toStrict <$> liftIO (T.readFile name)
  69   case M.parse name markdown of
  70     Left e -> return "shit"
  71     Right doc -> return $ M.render (M.useExtensions extensions doc)
  72   where extensions = [M.ghcSyntaxHighlighter, M.skylighting, M.footnotes]