Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
branch: master
Fetching contributors…

Cannot retrieve contributors at this time

83 lines (69 sloc) 2.545 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)
Jump to Line
Something went wrong with that request. Please try again.