public
Last active

  • Download Gist
MyApp.hs
Haskell
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116
{-# 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")

Please sign in to comment on this gist.

Something went wrong with that request. Please try again.