1 {-# LANGUAGE OverloadedStrings #-}
5 import qualified Data.Text.Lazy as T
6 import qualified Data.Text.Lazy.IO as T
11 import Control.Monad.IO.Class
13 import qualified Text.MMark as M
14 import qualified Text.MMark.Extension.Common as M
16 import Text.Read (readMaybe)
19 import System.Directory
20 import System.FilePath
21 import Network.HTTP.Types
24 main = scotty 3000 $ do
25 get "/style.css" $ file "style.css"
27 get "/create" $ html $ renderText $ html_ $ do
32 h1_ "Create a new post"
33 with form_ [action_ "create", method_ "post"] $ do
34 input_ [name_ "title", type_ "text", placeholder_ "Title"]
36 with textarea_ [name_ "body", placeholder_ "# Your markdown here"] ""
38 input_ [type_ "submit"]
43 p <- liftIO $ save b t
44 redirect ("posts/" <> title p)
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"
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"
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)
68 get "/posts/:post" $ do
70 mPost <- liftIO (load name)
72 Nothing -> status notFound404
75 Nothing -> status internalServerError500
77 html $ renderText $ html_ $ do
78 head_ $ style >> title_ "Post"
80 p_ $ a_ [href_ "/"] "Home"
84 style = link_ [Attribute "rel" "stylesheet", Attribute "href" "/style.css"]
90 } deriving (Read, Show)
92 load :: String -> IO (Maybe Post)
94 let file = "posts" </> name
95 guard =<< doesFileExist file
96 readMaybe <$> readFile file
98 render :: Post -> Maybe (Html ())
99 render p@(Post markdown title date) =
100 case M.parse (pathToPost p) (T.toStrict markdown) of
103 with div_ [id_ (T.toStrict title)] $ do
104 with a_ [href_ (T.toStrict $ linkToPost p)] $
106 i_ $ toHtml $ formatTime defaultTimeLocale "%a %e %B %Y" date
108 M.render (M.useExtensions extensions doc)
109 where extensions = [M.ghcSyntaxHighlighter, M.skylighting, M.footnotes]
111 linkToPost :: Post -> T.Text
112 linkToPost p = T.pack $ "/posts" </> kebab (T.unpack (title p))
114 pathToPost :: Post -> FilePath
115 pathToPost p = "posts" </> kebab (T.unpack (title p))
117 save :: T.Text -> T.Text -> IO Post
119 curTime <- getCurrentTime
120 let kTitle = T.pack $ kebab $ T.unpack title
121 p = Post md kTitle curTime
122 writeFile (pathToPost p) (show p)