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
14 import Control.Exception
16 import Control.Monad.IO.Class
17 import Control.Monad.Trans.Class
18 import qualified Control.Monad.Trans.State as S
19 import qualified Text.MMark as M
20 import qualified Text.MMark.Extension.Common as M
22 import Text.Read (readMaybe)
25 import System.Directory
26 import System.FilePath
28 import System.IO.Error
29 import Network.HTTP.Types
31 type Sessions = Map.Map T.Text T.Text
32 type ActionM = ActionT T.Text (S.StateT Sessions IO)
34 -- | Checks if the user is logged in
35 loggedIn :: ActionM Bool
37 mCookie <- getCookie "session"
39 Nothing -> return False
40 Just cookie -> Map.member (T.fromStrict cookie) <$> lift S.get
42 -- | Returns the current username
43 currentUser :: ActionM (Maybe T.Text)
45 mCookie <- getCookie "session"
47 Nothing -> return Nothing
48 Just cookie -> Map.lookup (T.fromStrict cookie) <$> lift S.get
50 -- | Makes a function that carries over the state from one
51 -- request to the next
52 mkPreserve :: s -> IO ((S.StateT s IO) a -> IO a)
57 (x, s') <- S.runStateT f s
62 logins :: Map.Map T.Text T.Text
72 preserve <- mkPreserve mempty
73 createDirectory "posts" `catch` (\e -> unless (isAlreadyExistsError e) (throw e))
74 scottyT 3000 preserve $ do
75 get "/style.css" $ file "style.css"
80 then template "Create" $ do
81 h1_ "Create a new post"
82 form_ [action_ "create", method_ "post"] $ do
83 input_ [name_ "title", type_ "text", placeholder_ "Title"]
85 textarea_ [name_ "body", placeholder_ "# Your markdown here"] ""
87 input_ [type_ "submit", value_ "Post"]
89 text "You're not logged in"
90 status unauthorized401
96 redirect (linkToPost p)
99 username <- param "username"
100 password <- param "password"
101 if Map.lookup username logins /= Just password
103 text "Invalid username and/or password"
104 status unauthorized401
106 session <- T.pack . show <$> liftIO (randomIO :: IO Int)
107 lift $ S.modify (Map.insert session username)
108 setSimpleCookie "session" (T.toStrict session)
111 post "/logout" $ deleteCookie "session" >> redirect "/"
115 files <- listDirectory "posts"
116 posts <- catMaybes <$> mapM load files
117 return $ take 5 $ sortOn (Down . date) posts
118 template "Cool blog" $ sequence (mapMaybe render posts)
120 get "/posts/:post" $ do
122 mPost <- liftIO (load name)
124 Nothing -> status notFound404
127 Nothing -> status internalServerError500
128 Just content -> template (title post) content
130 template :: T.Text -> Html a -> ActionM ()
131 template title content = do
133 html $ renderText $ html_ $ do
134 head_ $ style >> title_ (toHtml title)
137 a_ [href_ "/"] "🏠 Cool Blog"
140 " " >> a_ [href_ "/create"] "Create a Post"
141 form_ [action_ "/logout", method_ "post", class_ "login-form"] $
142 input_ [type_ "submit", value_ "Log Out"]
143 else form_ [action_ "/login", method_ "post", class_ "login-form"] $ do
144 input_ [name_ "username", placeholder_ "Username", type_ "text"]
145 input_ [name_ "password", placeholder_ "Password", type_ "password"]
146 input_ [type_ "submit", value_ "Log In"]
148 where style = link_ [Attribute "rel" "stylesheet", Attribute "href" "/style.css"]
155 } deriving (Read, Show)
157 load :: String -> IO (Maybe Post)
159 let file = "posts" </> name
160 guard =<< doesFileExist file
161 readMaybe <$> readFile file
163 render :: Post -> Maybe (Html ())
164 render p@(Post markdown title date author) =
165 case M.parse (pathToPost p) (T.toStrict markdown) of
168 article_ [id_ (T.toStrict title)] $ do
170 a_ [href_ (T.toStrict $ linkToPost p)] $
172 address_ $ "By " >> toHtml author
173 time_ [datetime_ (T.toStrict $ T.pack (show date))] $ toHtml dateStr
174 M.render (M.useExtensions extensions doc)
175 where extensions = [M.ghcSyntaxHighlighter, M.skylighting, M.footnotes]
176 dateStr = T.pack $ formatTime defaultTimeLocale "%a %e %B %Y" date
178 linkToPost :: Post -> T.Text
179 linkToPost p = T.pack $ "/posts" </> kebab (T.unpack (title p))
181 pathToPost :: Post -> FilePath
182 pathToPost p = "posts" </> kebab (T.unpack (title p))
184 -- | Creates and saves a new post
186 -- ^ The title of the post
188 -- ^ The markdown body
190 -- ^ The freshly created post
191 createPost title md = do
196 Nothing -> raise "Not logged in"
197 curTime <- liftIO getCurrentTime
198 let p = Post md title curTime author
199 liftIO $ writeFile (pathToPost p) (show p)