{-# LANGUAGE GeneralizedNewtypeDeriving #-} | |
{-# LANGUAGE FlexibleInstances #-} | |
{-# LANGUAGE MultiParamTypeClasses #-} | |
{-# LANGUAGE UndecidableInstances #-} | |
module MyApp where | |
import Control.Applicative | |
import Control.Monad.State | |
import Control.Monad.Reader | |
import Control.Monad.Error | |
import Happstack.Server | |
import System.IO (stderr) | |
import System.Log.Logger | |
import System.Log.Handler.Simple | |
import System.Log.Handler hiding (setLevel) | |
import System.Log.Formatter | |
------------------------------------------------------------------------------ | |
-- ErrorT instances that should be provided by Happstack | |
------------------------------------------------------------------------------ | |
instance (Error e, FilterMonad a m) => FilterMonad a (ErrorT e m) where | |
setFilter f = lift $ setFilter f | |
composeFilter = lift . composeFilter | |
getFilter m = mapErrorT (\m' -> | |
do (eb, f) <- getFilter m' | |
case eb of | |
(Left e) -> return (Left e) | |
(Right b) -> return $ Right (b, f) | |
) m | |
instance (Error e, WebMonad a m) => WebMonad a (ErrorT e m) where | |
finishWith = lift . finishWith | |
instance (Monad m, Error e, HasRqData m) => HasRqData (ErrorT e m) where | |
askRqEnv = lift askRqEnv | |
localRqEnv f = mapErrorT (localRqEnv f) | |
rqDataError e = lift (rqDataError e) | |
instance (Error e, Happstack m) => Happstack (ErrorT e m) | |
------------------------------------------------------------------------------ | |
data AppState = | |
NotStarted | | |
Starting | | |
Started | | |
Stopping | | |
Stopped | | |
Crashed | | |
Restarting | |
deriving (Eq, Show) | |
data Config = Config { | |
confLogName :: String | |
} | |
newtype MyApp a = MyApp { | |
runMyApp :: ReaderT Config (ErrorT String (StateT AppState (ServerPartT IO))) a | |
} deriving ( | |
Alternative, | |
Applicative, | |
Monad, | |
Functor, | |
MonadIO, | |
MonadPlus, | |
MonadError String, | |
MonadReader Config, | |
MonadState AppState, | |
HasRqData, | |
FilterMonad Response, | |
WebMonad Response, | |
ServerMonad, | |
Happstack | |
) | |
type MyAppResult a = (Either String a, AppState) | |
instance (ToMessage a) => ToMessage (MyAppResult a) where | |
toMessage (Left errmsg, _) = toMessage errmsg | |
toMessage (Right a, _) = toMessage a | |
toContentType (Left errmsg, _) = toContentType errmsg | |
toContentType (Right a, _) = toContentType a | |
toResponse (Left errmsg, _) = toResponse errmsg | |
toResponse (Right a, _) = toResponse a | |
setupLogging :: MyApp () | |
setupLogging = do | |
conf <- ask | |
let loggerName = confLogName conf | |
fmt = simpleLogFormatter "[$time] $prio - $msg" | |
ch <- fmap (\h -> setFormatter h fmt) $ liftIO $ streamHandler stderr DEBUG | |
liftIO $ updateGlobalLogger loggerName (setLevel INFO) | |
liftIO $ updateGlobalLogger loggerName (setHandlers [ch]) | |
home :: MyApp Response | |
home = do | |
conf <- ask | |
let l = confLogName conf | |
liftIO $ logM l INFO "Entering `home`" | |
dir "home" $ ok $ toResponse "Welcome home!" | |
-- liftIO $ logM l INFO "Leaving `home`" | |
simpleServer :: MyApp Response | |
simpleServer = do | |
req <- askRq | |
liftIO $ putStrLn $ "Method: " ++ show (rqMethod req) | |
liftIO $ putStrLn $ "URI: " ++ rqUri req | |
home | |
runApp :: MyApp a -> Config -> ServerPartT IO (MyAppResult a) | |
runApp app conf = runStateT (runErrorT (runReaderT (runMyApp app) conf)) NotStarted | |
main :: IO () | |
main = simpleHTTP nullConf $ runApp simpleServer (Config "myapp") |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment