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.Maybe
import Data.Ord
import Data.IORef
+import Control.Exception
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Trans.Class
import System.Directory
import System.FilePath
import System.Random
+import System.IO.Error
import Network.HTTP.Types
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)
-mkPreserve s = do
- ref <- newIORef s
+mkPreserve initS = do
+ ref <- newIORef initS
return $ \f -> do
s <- readIORef ref
(x, s') <- S.runStateT f s
, ("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
preserve <- mkPreserve mempty
+ createDirectory "posts" `catch` (\e -> unless (isAlreadyExistsError e) (throw e))
scottyT 3000 preserve $ do
get "/style.css" $ file "style.css"
get "/" $ do
posts <- liftIO $ do
- files <- listDirectory "posts"
- posts <- catMaybes <$> mapM load files
- return $ take 5 $ sortOn (Down . date) posts
+ fps <- listDirectory "posts"
+ posts <- catMaybes <$> mapM load fps
+ return $ take 5 $ sortOn (Down . postDate) posts
template "Cool blog" $ sequence (mapMaybe render posts)
get "/posts/:post" $ do
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
- Just content -> template (title post) content
+ Just content -> template (postTitle p) content
template :: T.Text -> Html a -> ActionM ()
template title content = do
where style = link_ [Attribute "rel" "stylesheet", Attribute "href" "/style.css"]
data Post = Post
- { markdown :: T.Text
- , title :: T.Text
- , date :: UTCTime
- , author :: T.Text
+ { postBody :: T.Text
+ , postTitle :: T.Text
+ , postDate :: UTCTime
+ , postAuthor :: T.Text
} deriving (Read, Show)
load :: String -> IO (Maybe Post)
load name = do
- let file = "posts" </> name
- guard =<< doesFileExist file
- readMaybe <$> readFile file
+ let fp = "posts" </> name
+ guard =<< doesFileExist fp
+ readMaybe <$> readFile fp
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
dateStr = T.pack $ formatTime defaultTimeLocale "%a %e %B %Y" date
linkToPost :: Post -> T.Text
-linkToPost p = T.pack $ "/posts" </> kebab (T.unpack (title p))
+linkToPost p = T.pack $ "/posts" </> kebab (T.unpack (postTitle p))
pathToPost :: Post -> FilePath
-pathToPost p = "posts" </> kebab (T.unpack (title p))
+pathToPost p = "posts" </> kebab (T.unpack (postTitle p))
-- | Creates and saves a new post
createPost :: T.Text
-- ^ The markdown body
-> ActionM Post
-- ^ The freshly created post
-createPost title md = do
- author <- do
+createPost title markdown = do
+ auth <- do
ma <- currentUser
case ma of
Just a -> return a
Nothing -> raise "Not logged in"
curTime <- liftIO getCurrentTime
- let p = Post md title curTime author
+ let p = Post markdown title curTime auth
liftIO $ writeFile (pathToPost p) (show p)
return p