Permalink
Switch branches/tags
Nothing to show
Find file
Fetching contributors…
Cannot retrieve contributors at this time
83 lines (69 sloc) 2.49 KB
{-# LANGUAGE OverloadedStrings #-}
module Main where
import Happstack.Server
import Data.Text (Text)
import Control.Exception (bracket)
import Control.Monad.Trans (liftIO)
import Control.Monad.Reader (runReaderT, ReaderT, ask, asks)
import Data.Acid (openLocalState, createCheckpoint, closeAcidState, AcidState)
import qualified Data.Acid as Acid (query, update)
import Control.Monad (msum)
import Data.Aeson
import System.Log.Logger
import Data.Time (getCurrentTime)
import qualified Data.Set as S (empty)
import Model
type AcidicServer a = ReaderT (AcidState Content) (ServerPartT IO) a
errorResponse :: Text -> Response
errorResponse l = toResponse $ object ["error" .= l]
query q = do
st <- ask
liftIO $ Acid.query st $ q
update q = do
st <- ask
liftIO $ Acid.update st $ q
instance ToMessage Value where
toContentType _ = "application/json"
toMessage = encode
main :: IO ()
main = do
updateGlobalLogger rootLoggerName $ setLevel DEBUG
bracket (openLocalState emptyContent) (createCheckpoint >> closeAcidState) $ simpleHTTP nullConf . runReaderT mainServer
mainServer :: AcidicServer Response
mainServer = do
decodeBody $ defaultBodyPolicy "/tmp" 1024 1024 1024
msum [ dir "all" $ allMessages
, dir "register" $ register
, dir "users" $ allUsers
, dir "profile" $ oneUser
, notFound $ errorResponse "not found"
]
allMessages :: AcidicServer Response
allMessages = do
st <- ask
msgs <- query AllMessages
ok $ toResponse $ toJSON msgs
register :: AcidicServer Response
register = msum [register', naughty]
where
naughty = internalServerError $ errorResponse "wrong format"
register' = do
method POST
userName <- lookText' "name"
b <- query $ NameTaken userName
if b
then internalServerError $ errorResponse "name already taken"
else do
userPassword <- lookText' "password"
userDisplayName <- lookText' "display-name"
now <- liftIO getCurrentTime
let user = User userName userPassword userDisplayName 0 S.empty S.empty now
update $ SaveUser user
ok . toResponse . toJSON $ user
allUsers :: AcidicServer Response
allUsers = ok . toResponse . toJSON =<< query AllUsers
oneUser :: AcidicServer Response
oneUser = do
method GET
name <- lookText' "name"
ok . toResponse . toJSON =<< query (UserByName name)