Server.hs

{-# LANGUAGE OverloadedStrings, GeneralizedNewtypeDeriving, TemplateHaskell, DeriveDataTypeable #-}
module Server where

import Control.Monad
import Control.Monad.Trans
import Control.Monad.Reader
import Control.Monad.Error
import Happstack.Server
import Happstack.Server.Error
import Happstack.Server.ClientSession
import Data.SafeCopy
import Data.Aeson
import Data.Data (Data, Typeable)
import Data.Text (Text)

type UserId = Text

data ServerInfo = ServerInfo

--instance (MonadClientSession s m) => MonadClientSession s (ReaderT r m) where

newtype SessionData = SessionData (Maybe UserId)
    deriving (Eq, Ord, Read, Show, Data, Typeable)
$(deriveSafeCopy 0 'base ''SessionData)

instance ClientSession SessionData where
    emptySession = SessionData Nothing

newtype PonyServerT e m a = PonyServer (ReaderT ServerInfo (ClientSessionT SessionData (ServerPartT (ErrorT e m))) a)
    deriving (Monad, MonadIO, MonadPlus, MonadReader ServerInfo, ServerMonad, MonadError e, FilterMonad Response, WebMonad Response, MonadClientSession SessionData)

type PonyServer = PonyServerT String IO
type Port = Int

runServer :: Port -> ServerInfo -> PonyServer Response -> IO ()
runServer p i (PonyServer s) = do
    key <- getDefaultKey
    let sessionConf = mkSessionConf key
    simpleHTTP conf $ mapServerPartT' (spUnwrapErrorT simpleErrorHandler) $ withClientSessionT sessionConf $ runReaderT s i
    where
        conf = nullConf { port = p }

instance ToMessage Value where
    toContentType _ = "application/json"
    toMessage = encode