1 {-# LANGUAGE OverloadedStrings #-}
4 import Web.Scotty.Cookie
5 import Web.Scotty.Trans
6 import qualified Data.Text.Lazy as T
9 import qualified Data.Map.Lazy as Map
13 import Control.Exception
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 System.IO.Error
28 import Network.HTTP.Types
30 type Sessions = Map.Map T.Text T.Text
31 type ActionM = ActionT T.Text (S.StateT Sessions IO)
33 -- | Makes a function that carries over the state from one
34 -- request to the next
35 mkPreserve :: s -> IO ((S.StateT s IO) a -> IO a)
40 (x, s') <- S.runStateT f s
45 logins :: Map.Map T.Text T.Text
52 -- | Checks if the user is logged in
53 loggedIn :: ActionM Bool
55 mCookie <- getCookie "session"
57 Nothing -> return False
58 Just cookie -> Map.member (T.fromStrict cookie) <$> lift S.get
60 -- | Returns the current username
61 currentUser :: ActionM (Maybe T.Text)
63 mCookie <- getCookie "session"
65 Nothing -> return Nothing
66 Just cookie -> Map.lookup (T.fromStrict cookie) <$> lift S.get
70 preserve <- mkPreserve mempty
71 createDirectory "posts" `catch` (\e -> unless (isAlreadyExistsError e) (throw e))
72 scottyT 3000 preserve $ do
73 get "/style.css" $ file "style.css"
78 then template "Create" $ do
79 h1_ "Create a new post"
80 form_ [action_ "create", method_ "post"] $ do
81 input_ [name_ "title", type_ "text", placeholder_ "Title"]
83 textarea_ [name_ "body", placeholder_ "# Your markdown here"] ""
85 input_ [type_ "submit", value_ "Post"]
87 text "You're not logged in"
88 status unauthorized401
94 redirect (linkToPost p)
97 username <- param "username"
98 password <- param "password"
99 if Map.lookup username logins /= Just password
101 text "Invalid username and/or password"
102 status unauthorized401
104 session <- T.pack . show <$> liftIO (randomIO :: IO Int)
105 lift $ S.modify (Map.insert session username)
106 setSimpleCookie "session" (T.toStrict session)
109 post "/logout" $ deleteCookie "session" >> redirect "/"
113 fps <- listDirectory "posts"
114 posts <- catMaybes <$> mapM load fps
115 return $ take 5 $ sortOn (Down . postDate) posts
116 template "Cool blog" $ sequence (mapMaybe render posts)
118 get "/posts/:post" $ do
120 mPost <- liftIO (load name)
122 Nothing -> status notFound404
123 Just p -> case render p of
124 Nothing -> status internalServerError500
125 Just content -> template (postTitle p) content
127 template :: T.Text -> Html a -> ActionM ()
128 template title content = do
130 html $ renderText $ html_ $ do
131 head_ $ style >> title_ (toHtml title)
134 a_ [href_ "/"] "🏠 Cool Blog"
137 " " >> a_ [href_ "/create"] "Create a Post"
138 form_ [action_ "/logout", method_ "post", class_ "login-form"] $
139 input_ [type_ "submit", value_ "Log Out"]
140 else form_ [action_ "/login", method_ "post", class_ "login-form"] $ do
141 input_ [name_ "username", placeholder_ "Username", type_ "text"]
142 input_ [name_ "password", placeholder_ "Password", type_ "password"]
143 input_ [type_ "submit", value_ "Log In"]
145 where style = link_ [Attribute "rel" "stylesheet", Attribute "href" "/style.css"]
149 , postTitle :: T.Text
150 , postDate :: UTCTime
151 , postAuthor :: T.Text
152 } deriving (Read, Show)
154 load :: String -> IO (Maybe Post)
156 let fp = "posts" </> name
157 guard =<< doesFileExist fp
158 readMaybe <$> readFile fp
160 render :: Post -> Maybe (Html ())
161 render p@(Post markdown title date author) =
162 case M.parse (pathToPost p) (T.toStrict markdown) of
165 article_ [id_ (T.toStrict title)] $ do
167 a_ [href_ (T.toStrict $ linkToPost p)] $
169 address_ $ "By " >> toHtml author
170 time_ [datetime_ (T.toStrict $ T.pack (show date))] $ toHtml dateStr
171 M.render (M.useExtensions extensions doc)
172 where extensions = [M.ghcSyntaxHighlighter, M.skylighting, M.footnotes]
173 dateStr = T.pack $ formatTime defaultTimeLocale "%a %e %B %Y" date
175 linkToPost :: Post -> T.Text
176 linkToPost p = T.pack $ "/posts" </> kebab (T.unpack (postTitle p))
178 pathToPost :: Post -> FilePath
179 pathToPost p = "posts" </> kebab (T.unpack (postTitle p))
181 -- | Creates and saves a new post
183 -- ^ The title of the post
185 -- ^ The markdown body
187 -- ^ The freshly created post
188 createPost title markdown = do
193 Nothing -> raise "Not logged in"
194 curTime <- liftIO getCurrentTime
195 let p = Post markdown title curTime auth
196 liftIO $ writeFile (pathToPost p) (show p)