projects
/
blog.git
/ commitdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
| commitdiff |
tree
raw
|
patch
|
inline
| side by side (from parent 1:
a2fb53d
)
Add -Wall
author
Luke Lau
<luke_lau@icloud.com>
Fri, 12 Oct 2018 14:28:12 +0000
(15:28 +0100)
committer
Luke Lau
<luke_lau@icloud.com>
Fri, 12 Oct 2018 14:28:12 +0000
(15:28 +0100)
Main.hs
patch
|
blob
|
history
blog.cabal
patch
|
blob
|
history
diff --git
a/Main.hs
b/Main.hs
index 24e201726f653d994b9ea53c63f69419b358bdd3..dc1a30dc1afe0111eaf9c4bf8fb220c0e546a4d8 100644
(file)
--- a/
Main.hs
+++ b/
Main.hs
@@
-4,7
+4,6
@@
module Main where
import Web.Scotty.Cookie
import Web.Scotty.Trans
import qualified Data.Text.Lazy as T
import Web.Scotty.Cookie
import Web.Scotty.Trans
import qualified Data.Text.Lazy as T
-import qualified Data.Text.Lazy.IO as T
import Data.List
import Data.Time
import qualified Data.Map.Lazy as Map
import Data.List
import Data.Time
import qualified Data.Map.Lazy as Map
@@
-31,27
+30,11
@@
import Network.HTTP.Types
type Sessions = Map.Map T.Text T.Text
type ActionM = ActionT T.Text (S.StateT Sessions IO)
type Sessions = Map.Map T.Text T.Text
type ActionM = ActionT T.Text (S.StateT Sessions IO)
--- | Checks if the user is logged in
-loggedIn :: ActionM Bool
-loggedIn = do
- mCookie <- getCookie "session"
- case mCookie of
- Nothing -> return False
- Just cookie -> Map.member (T.fromStrict cookie) <$> lift S.get
-
--- | Returns the current username
-currentUser :: ActionM (Maybe T.Text)
-currentUser = do
- mCookie <- getCookie "session"
- case mCookie of
- Nothing -> return Nothing
- Just cookie -> Map.lookup (T.fromStrict cookie) <$> lift S.get
-
-- | Makes a function that carries over the state from one
-- request to the next
mkPreserve :: s -> IO ((S.StateT s IO) a -> IO a)
-- | Makes a function that carries over the state from one
-- request to the next
mkPreserve :: s -> IO ((S.StateT s IO) a -> IO a)
-mkPreserve
s
= do
- ref <- newIORef
s
+mkPreserve
initS
= do
+ ref <- newIORef
initS
return $ \f -> do
s <- readIORef ref
(x, s') <- S.runStateT f s
return $ \f -> do
s <- readIORef ref
(x, s') <- S.runStateT f s
@@
-66,6
+49,21
@@
logins = Map.fromList
, ("antonia", "1234")
, ("owen", "haskell")
]
, ("antonia", "1234")
, ("owen", "haskell")
]
+-- | Checks if the user is logged in
+loggedIn :: ActionM Bool
+loggedIn = do
+ mCookie <- getCookie "session"
+ case mCookie of
+ Nothing -> return False
+ Just cookie -> Map.member (T.fromStrict cookie) <$> lift S.get
+
+-- | Returns the current username
+currentUser :: ActionM (Maybe T.Text)
+currentUser = do
+ mCookie <- getCookie "session"
+ case mCookie of
+ Nothing -> return Nothing
+ Just cookie -> Map.lookup (T.fromStrict cookie) <$> lift S.get
main :: IO ()
main = do
main :: IO ()
main = do
@@
-112,9
+110,9
@@
main = do
get "/" $ do
posts <- liftIO $ do
get "/" $ do
posts <- liftIO $ do
- f
ile
s <- listDirectory "posts"
- posts <- catMaybes <$> mapM load f
ile
s
- return $ take 5 $ sortOn (Down .
d
ate) posts
+ f
p
s <- listDirectory "posts"
+ posts <- catMaybes <$> mapM load f
p
s
+ return $ take 5 $ sortOn (Down .
postD
ate) posts
template "Cool blog" $ sequence (mapMaybe render posts)
get "/posts/:post" $ do
template "Cool blog" $ sequence (mapMaybe render posts)
get "/posts/:post" $ do
@@
-122,10
+120,9
@@
main = do
mPost <- liftIO (load name)
case mPost of
Nothing -> status notFound404
mPost <- liftIO (load name)
case mPost of
Nothing -> status notFound404
- Just post ->
- case render post of
+ Just p -> case render p of
Nothing -> status internalServerError500
Nothing -> status internalServerError500
-
Just content -> template (title post
) content
+
Just content -> template (postTitle p
) content
template :: T.Text -> Html a -> ActionM ()
template title content = do
template :: T.Text -> Html a -> ActionM ()
template title content = do
@@
-148,22
+145,22
@@
template title content = do
where style = link_ [Attribute "rel" "stylesheet", Attribute "href" "/style.css"]
data Post = Post
where style = link_ [Attribute "rel" "stylesheet", Attribute "href" "/style.css"]
data Post = Post
- {
markdown
:: T.Text
- ,
t
itle :: T.Text
- ,
d
ate :: UTCTime
- ,
a
uthor :: T.Text
+ {
postBody
:: T.Text
+ ,
postT
itle :: T.Text
+ ,
postD
ate :: UTCTime
+ ,
postA
uthor :: T.Text
} deriving (Read, Show)
load :: String -> IO (Maybe Post)
load name = do
} deriving (Read, Show)
load :: String -> IO (Maybe Post)
load name = do
- let f
ile
= "posts" </> name
- guard =<< doesFileExist f
ile
- readMaybe <$> readFile f
ile
+ let f
p
= "posts" </> name
+ guard =<< doesFileExist f
p
+ readMaybe <$> readFile f
p
render :: Post -> Maybe (Html ())
render p@(Post markdown title date author) =
case M.parse (pathToPost p) (T.toStrict markdown) of
render :: Post -> Maybe (Html ())
render p@(Post markdown title date author) =
case M.parse (pathToPost p) (T.toStrict markdown) of
- Left
e
-> Nothing
+ Left
_
-> Nothing
Right doc -> Just $
article_ [id_ (T.toStrict title)] $ do
header_ $ do
Right doc -> Just $
article_ [id_ (T.toStrict title)] $ do
header_ $ do
@@
-176,10
+173,10
@@
render p@(Post markdown title date author) =
dateStr = T.pack $ formatTime defaultTimeLocale "%a %e %B %Y" date
linkToPost :: Post -> T.Text
dateStr = T.pack $ formatTime defaultTimeLocale "%a %e %B %Y" date
linkToPost :: Post -> T.Text
-linkToPost p = T.pack $ "/posts" </> kebab (T.unpack (
t
itle p))
+linkToPost p = T.pack $ "/posts" </> kebab (T.unpack (
postT
itle p))
pathToPost :: Post -> FilePath
pathToPost :: Post -> FilePath
-pathToPost p = "posts" </> kebab (T.unpack (
t
itle p))
+pathToPost p = "posts" </> kebab (T.unpack (
postT
itle p))
-- | Creates and saves a new post
createPost :: T.Text
-- | Creates and saves a new post
createPost :: T.Text
@@
-188,13
+185,13
@@
createPost :: T.Text
-- ^ The markdown body
-> ActionM Post
-- ^ The freshly created post
-- ^ The markdown body
-> ActionM Post
-- ^ The freshly created post
-createPost title m
d
= do
- auth
or
<- do
+createPost title m
arkdown
= do
+ auth <- do
ma <- currentUser
case ma of
Just a -> return a
Nothing -> raise "Not logged in"
curTime <- liftIO getCurrentTime
ma <- currentUser
case ma of
Just a -> return a
Nothing -> raise "Not logged in"
curTime <- liftIO getCurrentTime
- let p = Post m
d title curTime author
+ let p = Post m
arkdown title curTime auth
liftIO $ writeFile (pathToPost p) (show p)
return p
liftIO $ writeFile (pathToPost p) (show p)
return p
diff --git
a/blog.cabal
b/blog.cabal
index a3d60b4b4c7774f9e1c2ff9d4d59f5dd0ac7f637..eb8f33818f20ed699efeda84640f6c5a57fc2f4a 100644
(file)
--- a/
blog.cabal
+++ b/
blog.cabal
@@
-13,6
+13,7
@@
extra-source-files:
executable blog
main-is: Main.hs
default-language: Haskell2010
executable blog
main-is: Main.hs
default-language: Haskell2010
+ ghc-options: -Wall
build-depends:
base >=4.11,
scotty,
build-depends:
base >=4.11,
scotty,