public

stepcut / MyApp.hs

Last active 2013-07-01

{-# 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")