1 {-# LANGUAGE OverloadedStrings #-}
4 import Web.Scotty.Cookie
5 import Web.Scotty.Trans
6 import qualified Data.Text.Lazy as T
7 import qualified Data.Text.Lazy.IO as T
10 import qualified Data.Map.Lazy as Map
15 import Control.Monad.IO.Class
16 import Control.Monad.Trans.Class
17 import qualified Control.Monad.Trans.State as S
18 import qualified Text.MMark as M
19 import qualified Text.MMark.Extension.Common as M
21 import Text.Read (readMaybe)
24 import System.Directory
25 import System.FilePath
27 import Network.HTTP.Types
29 type Sessions = Map.Map T.Text T.Text
30 type ActionM = ActionT T.Text (S.StateT Sessions IO)
32 loggedIn :: ActionM Bool
34 mCookie <- getCookie "session"
36 Nothing -> return False
37 Just cookie -> Map.member (T.fromStrict cookie) <$> lift S.get
39 currentUser :: ActionM (Maybe T.Text)
41 mCookie <- getCookie "session"
43 Nothing -> return Nothing
44 Just cookie -> Map.lookup (T.fromStrict cookie) <$> lift S.get
46 -- | Makes a function that carries over the state from one
47 -- request to the next
48 mkPreserve :: s -> IO ((S.StateT s IO) a -> IO a)
53 (x, s') <- S.runStateT f s
58 logins :: Map.Map T.Text T.Text
68 preserve <- mkPreserve mempty
69 scottyT 3000 preserve $ do
70 get "/style.css" $ file "style.css"
75 then template "Create" $ do
76 h1_ "Create a new post"
77 with form_ [action_ "create", method_ "post"] $ do
78 input_ [name_ "title", type_ "text", placeholder_ "Title"]
80 with textarea_ [name_ "body", placeholder_ "# Your markdown here"] ""
82 input_ [type_ "submit"]
83 else status unauthorized401
89 redirect (linkToPost p)
92 username <- param "username"
93 password <- param "password"
94 if Map.lookup username logins /= Just password
95 then status unauthorized401
97 session <- T.pack . show <$> liftIO (randomIO :: IO Int)
98 lift $ S.modify (Map.insert session username)
99 setSimpleCookie "session" (T.toStrict session)
102 post "/logout" $ deleteCookie "session" >> redirect "/"
106 files <- listDirectory "posts"
107 posts <- catMaybes <$> mapM load files
108 return $ take 5 $ sortOn (Down . date) posts
109 template "Cool blog" $ sequence (mapMaybe render posts)
111 get "/posts/:post" $ do
113 mPost <- liftIO (load name)
115 Nothing -> status notFound404
118 Nothing -> status internalServerError500
119 Just content -> template (title post) content
121 template :: T.Text -> Html a -> ActionM ()
122 template title content = do
124 html $ renderText $ html_ $ do
125 head_ $ style >> title_ (toHtml title)
128 a_ [href_ "/"] "🏠 Cool Blog"
131 a_ [href_ "/create"] "Create a Post"
132 with form_ [action_ "/logout", method_ "post", class_ "login-form"] $
133 input_ [type_ "submit", value_ "Log Out"]
134 else with form_ [action_ "/login", method_ "post", class_ "login-form"] $ do
135 input_ [name_ "username", placeholder_ "Username", type_ "text"]
136 input_ [name_ "password", placeholder_ "Password", type_ "password"]
137 input_ [type_ "submit"]
139 where style = link_ [Attribute "rel" "stylesheet", Attribute "href" "/style.css"]
146 } deriving (Read, Show)
148 load :: String -> IO (Maybe Post)
150 let file = "posts" </> name
151 guard =<< doesFileExist file
152 readMaybe <$> readFile file
154 render :: Post -> Maybe (Html ())
155 render p@(Post markdown title date author) =
156 case M.parse (pathToPost p) (T.toStrict markdown) of
159 with article_ [id_ (T.toStrict title)] $ do
161 with a_ [href_ (T.toStrict $ linkToPost p)] $
163 address_ $ "By " >> toHtml author
164 with time_ [datetime_ (T.toStrict $ T.pack (show date))] $ toHtml dateStr
165 M.render (M.useExtensions extensions doc)
166 where extensions = [M.ghcSyntaxHighlighter, M.skylighting, M.footnotes]
167 dateStr = T.pack $ formatTime defaultTimeLocale "%a %e %B %Y" date
169 linkToPost :: Post -> T.Text
170 linkToPost p = T.pack $ "/posts" </> kebab (T.unpack (title p))
172 pathToPost :: Post -> FilePath
173 pathToPost p = "posts" </> kebab (T.unpack (title p))
175 createPost :: T.Text -> T.Text -> ActionM Post
176 createPost md title = do
181 Nothing -> raise "Not logged in"
182 curTime <- liftIO getCurrentTime
183 let p = Post md title curTime author
184 liftIO $ writeFile (pathToPost p) (show p)