Create a gist now

Instantly share code, notes, and snippets.

@stepcut /MyApp.hs
Last active Dec 19, 2015

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