Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
tree: 658e4b9951
Fetching contributors…

Cannot retrieve contributors at this time

89 lines (70 sloc) 2.604 kb
{-# OPTIONS -fglasgow-exts #-}
{-# LANGUAGE TemplateHaskell , FlexibleInstances,
FlexibleContexts, UndecidableInstances, OverlappingInstances,
MultiParamTypeClasses, GeneralizedNewtypeDeriving #-}
module Main where
import Control.Concurrent
import Control.Monad
import Control.Monad.Reader
import Control.Monad.State (modify,put,get,gets,MonadState)
import Data.Generics hiding ((:+:))
import Happstack.Auth
import Happstack.Server
import Happstack.State
data Post = Post {
postTitle :: String,
postAuthor :: Username,
postBody :: String
} deriving (Read,Show,Ord,Eq,Typeable,Data)
instance Version Post
$(deriveSerialize ''Post)
data BlogState = BlogState {
postDB :: [Post]
} deriving (Read,Show,Ord,Eq,Typeable,Data)
instance Version BlogState
$(deriveSerialize ''BlogState)
instance Component BlogState where
type Dependencies BlogState = AuthState :+: End
initialValue = BlogState []
addPost :: (MonadState BlogState m) => Post -> m ()
addPost p = modify $ (\s -> BlogState $ p:(postDB s))
getPosts :: (MonadReader BlogState m) => m [Post]
getPosts = asks postDB
$(mkMethods ''BlogState ['addPost, 'getPosts])
redir url = seeOther url (toResponse "")
impl = msum
[ dir "new" $ withSession newPostHandlers (redir "/login")
, dir "newuser" $ methodSP POST $ newUserHandler exists noMatch regGood
, dir "login" $ withSession (\_ -> redir "/") $
msum [methodSP GET $ (fileServe ["login.html"] ".")
,methodSP POST $ loginHandler loginGood loginBad]
, dir "logout" $ logoutHandler $ redir "/"
, methodSP GET viewPostsHandler
]
newPostHandlers ses = msum [methodSP GET $ fileServe ["new_post.html"] "."
,methodSP POST $ addPostHandler ses]
loginGood = redir "/new"
loginBad = ok $ toResponse $ "Invalid login"
exists = anyRequest $ ok $ toResponse $ "Username was invalid or already exists."
noMatch = anyRequest $ ok $ toResponse $ "Passwords did not match"
regGood = redir "/new"
addPostHandler ses = do
(Just title) <- getDataFn $ look "title"
(Just body) <- getDataFn $ look "body"
update $ AddPost (Post title (sesUsername ses) body)
redir "/"
viewPostsHandler = do
posts <- query $ GetPosts
case posts of
[] -> ok $ toResponse "No posts yet"
otherwise -> ok $ toResponse $ unlines $ map show posts
entryPoint :: Proxy BlogState
entryPoint = Proxy
main = do
control <- startSystemState entryPoint
tid <- forkIO $ simpleHTTP nullConf impl
waitForTermination
putStrLn "Shutting down..."
killThread tid
shutdownSystem control
putStrLn "Shutdown complete"
Jump to Line
Something went wrong with that request. Please try again.