Skip to content

@stepcut /MyApp.hs
Last active

Embed URL

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
{-# 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
Something went wrong with that request. Please try again.