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 html $ renderText $ html_ $ do
80 h1_ "Create a new post"
81 with form_ [action_ "create", method_ "post"] $ do
82 input_ [name_ "title", type_ "text", placeholder_ "Title"]
84 with textarea_ [name_ "body", placeholder_ "# Your markdown here"] ""
86 input_ [type_ "submit"]
87 else status unauthorized401
93 redirect (linkToPost p)
96 username <- param "username"
97 password <- param "password"
98 if Map.lookup username logins /= Just password
99 then status unauthorized401
101 session <- T.pack . show <$> liftIO (randomIO :: IO Int)
102 lift $ S.modify (Map.insert session username)
103 setSimpleCookie "session" (T.toStrict session)
106 post "/logout" $ deleteCookie "session" >> redirect "/"
111 files <- listDirectory "posts"
112 posts <- catMaybes <$> mapM load files
113 return $ take 5 $ sortOn (Down . date) posts
114 html $ renderText $ html_ $ do
115 head_ $ style >> title_ "Cool Blog"
117 p_ $ a_ [href_ "/"] "Cool Blog"
120 a_ [href_ "/create"] "Create a Post"
122 with form_ [action_ "/logout", method_ "post"] $
123 input_ [type_ "submit", value_ "Log Out"]
124 else with form_ [action_ "/login", method_ "post"] $ do
125 input_ [name_ "username", placeholder_ "Username", type_ "text"]
126 input_ [name_ "password", placeholder_ "Password", type_ "password"]
127 input_ [type_ "submit"]
128 sequence (mapMaybe render posts)
130 get "/posts/:post" $ do
132 mPost <- liftIO (load name)
134 Nothing -> status notFound404
137 Nothing -> status internalServerError500
139 html $ renderText $ html_ $ do
140 head_ $ style >> title_ "Post"
142 p_ $ a_ [href_ "/"] "Home"
145 style = link_ [Attribute "rel" "stylesheet", Attribute "href" "/style.css"]
152 } deriving (Read, Show)
154 load :: String -> IO (Maybe Post)
156 let file = "posts" </> name
157 guard =<< doesFileExist file
158 readMaybe <$> readFile file
160 render :: Post -> Maybe (Html ())
161 render p@(Post markdown title date author) =
162 case M.parse (pathToPost p) (T.toStrict markdown) of
165 with div_ [id_ (T.toStrict title)] $ do
166 with a_ [href_ (T.toStrict $ linkToPost p)] $
168 i_ $ toHtml $ "By " <> author <> ", " <> dateStr
170 M.render (M.useExtensions extensions doc)
171 where extensions = [M.ghcSyntaxHighlighter, M.skylighting, M.footnotes]
172 dateStr = T.pack $ formatTime defaultTimeLocale "%a %e %B %Y" date
174 linkToPost :: Post -> T.Text
175 linkToPost p = T.pack $ "/posts" </> kebab (T.unpack (title p))
177 pathToPost :: Post -> FilePath
178 pathToPost p = "posts" </> kebab (T.unpack (title p))
180 createPost :: T.Text -> T.Text -> ActionM Post
181 createPost md title = do
186 Nothing -> raise "Not logged in"
187 curTime <- liftIO getCurrentTime
188 let p = Post md title curTime author
189 liftIO $ writeFile (pathToPost p) (show p)