This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "snap-server".
The branch, snapt has been created
at 33f70b908c7ecf892f4abb2f3b0ceac062dd1639 (commit)
- Log -----------------------------------------------------------------
commit 33f70b908c7ecf892f4abb2f3b0ceac062dd1639
Author: Mighty Byte <[email protected]>
Date: Wed Dec 8 12:43:52 2010 -0500
Working on porting to SnapT. To finish it, the server functions need
another parameter along the lines of "(SnapT m a -> SnapT IO a)" or "(m a -> IO
a)".
diff --git a/src/Snap/Http/Server.hs b/src/Snap/Http/Server.hs
index 8250161..976dcdf 100644
--- a/src/Snap/Http/Server.hs
+++ b/src/Snap/Http/Server.hs
@@ -21,6 +21,7 @@ module Snap.Http.Server
import Control.Monad
import Control.Monad.CatchIO
+import Control.Monad.Trans
import Data.ByteString (ByteString)
import Data.Char
import Data.List
@@ -47,9 +48,9 @@ snapServerVersion = Int.snapServerVersion
-- settings from the given config; error handling and compression are ignored.
-- This function never returns; to shut down the HTTP server, kill the
-- controlling thread.
-simpleHttpServe :: MonadSnap m => Config m a -> Snap () -> IO ()
+simpleHttpServe :: MonadIO m => Config (SnapT m) a -> SnapT m () -> m ()
simpleHttpServe config handler = do
- setUnicodeLocale $ fromJust $ getLocale conf
+ liftIO $ setUnicodeLocale $ fromJust $ getLocale conf
Int.httpServe (map listenToInt $ getListen conf)
(fmap backendToInt $ getBackend conf)
(fromJust $ getHostname conf)
@@ -68,9 +69,10 @@ simpleHttpServe config handler = do
-- | Starts serving HTTP requests using the given handler, with settings from
-- the 'Config' passed in. This function never returns; to shut down the HTTP
-- server, kill the controlling thread.
-httpServe :: Config Snap () -> Snap () -> IO ()
+httpServe :: (MonadCatchIO m, Functor m) => Config (SnapT m) () -> SnapT m ()
+ -> m ()
httpServe config handler = do
- mapM_ (output . ("Listening on "++) . show) $ getListen conf
+ liftIO $ mapM_ (output . ("Listening on "++) . show) $ getListen conf
serve handler `finally` output "\nShutting down..."
where
conf = completeConfig config
@@ -85,8 +87,9 @@ httpServe config handler = do
-- from the options given on the command-line, as returned by
-- 'commandLineConfig'. This function never returns; to shut down the HTTP
-- server, kill the controlling thread.
-quickHttpServe :: Snap () -> IO ()
-quickHttpServe m = commandLineConfig emptyConfig >>= \c -> httpServe c m
+quickHttpServe :: (MonadCatchIO m, Functor m) => SnapT m () -> m ()
+quickHttpServe m = liftIO (commandLineConfig emptyConfig) >>= \c ->
+ httpServe c m
------------------------------------------------------------------------------
diff --git a/src/Snap/Http/Server/Config.hs b/src/Snap/Http/Server/Config.hs
index 38763e1..619b27b 100644
--- a/src/Snap/Http/Server/Config.hs
+++ b/src/Snap/Http/Server/Config.hs
@@ -1,5 +1,6 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE UndecidableInstances #-}
{-|
@@ -88,7 +89,7 @@ data ConfigBackend = ConfigSimpleBackend
--
-- Any fields which are unspecified in the 'Config' passed to 'httpServe' (and
-- this is the norm) are filled in with default values from 'defaultConfig'.
-data MonadSnap m => Config m a = Config
+data Config m a = Config
{ hostname :: Maybe ByteString
-- ^ The name of the server
, listen :: [ConfigListen]
@@ -113,7 +114,7 @@ data MonadSnap m => Config m a = Config
------------------------------------------------------------------------------
-instance MonadSnap m => Show (Config m a) where
+instance MonadSnap im m => Show (Config m a) where
show c = "Config {" ++ concat (intersperse ", " $ filter (/="") $ map ($c)
[ showM "hostname" . hostname
, showL "listen" . listen
@@ -133,12 +134,12 @@ instance MonadSnap m => Show (Config m a) where
------------------------------------------------------------------------------
-- | Returns a completely empty 'Config'. Equivalent to 'mempty' from
-- 'Config''s 'Monoid' instance.
-emptyConfig :: MonadSnap m => Config m a
+emptyConfig :: MonadSnap im m => Config m a
emptyConfig = mempty
------------------------------------------------------------------------------
-instance MonadSnap m => Monoid (Config m a) where
+instance MonadSnap im m => Monoid (Config m a) where
mempty = Config
{ hostname = Nothing
, listen = []
@@ -179,7 +180,7 @@ instance MonadSnap m => Monoid (Config m a) where
-- > verbose = True
-- > errorHandler = prints the error message
--
-defaultConfig :: MonadSnap m => Config m a
+defaultConfig :: (MonadSnap im m, Monad im) => Config m a
defaultConfig = Config
{ hostname = Just "localhost"
, listen = []
@@ -205,7 +206,7 @@ defaultConfig = Config
-- | Completes a partial 'Config' by filling in the unspecified values with
-- the default values from 'defaultConfig'. Also, if no listeners are
-- specified, adds a http listener on 0.0.0.0:8000
-completeConfig :: MonadSnap m => Config m a -> Config m a
+completeConfig :: (MonadSnap im m, Monad im) => Config m a -> Config m a
completeConfig c = case listen c' of
[] -> addListen (ListenHttp "0.0.0.0" 8000) c'
_ -> c'
@@ -217,7 +218,7 @@ completeConfig c = case listen c' of
-- The Config data type allows a list of listen ports, but the command line
-- options only allow one http and one https listener. This data structure
-- is used during option parsing
-data MonadSnap m => OptionData m a = OptionData
+data OptionData m a = OptionData
{ config :: Config m a
, bind :: Maybe ByteString
, port :: Maybe Int
@@ -229,7 +230,7 @@ data MonadSnap m => OptionData m a = OptionData
------------------------------------------------------------------------------
-instance MonadSnap m => Monoid (OptionData m a) where
+instance MonadSnap im m => Monoid (OptionData m a) where
mempty = OptionData
{ config = mempty
, bind = Nothing
@@ -252,7 +253,7 @@ instance MonadSnap m => Monoid (OptionData m a) where
------------------------------------------------------------------------------
-- | These are the default values for the options
-defaultOptions :: MonadSnap m => OptionData m a
+defaultOptions :: (MonadSnap im m, Monad im) => OptionData m a
defaultOptions = OptionData
{ config = defaultConfig
, bind = Just "0.0.0.0"
@@ -266,7 +267,7 @@ defaultOptions = OptionData
------------------------------------------------------------------------------
-- | Convert options to config
-optionsToConfig :: MonadSnap m => OptionData m a -> Config m a
+optionsToConfig :: MonadSnap im m => OptionData m a -> Config m a
optionsToConfig o = mconcat $ [config o] ++ http ++ https
where lhttp = maybe2 [] ListenHttp (bind o) (port o)
lhttps = maybe4 [] ListenHttps (sslbind o)
@@ -283,7 +284,7 @@ optionsToConfig o = mconcat $ [config o] ++ http ++ https
------------------------------------------------------------------------------
-- | Convert config to options
-configToOptions :: MonadSnap m => Config m a -> OptionData m a
+configToOptions :: MonadSnap im m => Config m a -> OptionData m a
configToOptions c = OptionData
{ config = c
, bind = Nothing
@@ -308,7 +309,7 @@ configToOptions c = OptionData
-- as opposed to a @'OptionData' m@, because if the @--help@ option is given,
-- the set of command-line options no longer describe a config, but an action
-- (printing out the usage message).
-options :: MonadSnap m => OptionData m a -> [OptDescr (Maybe (OptionData m a))]
+options :: (MonadSnap im m, Monad im) => OptionData m a -> [OptDescr (Maybe
(OptionData m a))]
options defaults =
[ Option [] ["hostname"]
(ReqArg (Just . setConfig setHostname . U.fromString) "NAME")
@@ -378,7 +379,7 @@ options defaults =
-- parameter.
--
-- On Unix systems, the locale is read from the @LANG@ environment variable.
-commandLineConfig :: MonadSnap m => Config m a -> IO (Config m a)
+commandLineConfig :: (MonadSnap im m, Monad im) => Config m a -> IO (Config m
a)
commandLineConfig defaults = do
args <- getArgs
prog <- getProgName
@@ -407,100 +408,100 @@ commandLineConfig defaults = do
------------------------------------------------------------------------------
-getHostname :: MonadSnap m => Config m a -> Maybe ByteString
+getHostname :: MonadSnap im m => Config m a -> Maybe ByteString
getHostname = hostname
------------------------------------------------------------------------------
-getListen :: MonadSnap m => Config m a -> [ConfigListen]
+getListen :: MonadSnap im m => Config m a -> [ConfigListen]
getListen = listen
------------------------------------------------------------------------------
-getAccessLog :: MonadSnap m => Config m a -> Maybe (Maybe FilePath)
+getAccessLog :: MonadSnap im m => Config m a -> Maybe (Maybe FilePath)
getAccessLog = accessLog
------------------------------------------------------------------------------
-getErrorLog :: MonadSnap m => Config m a -> Maybe (Maybe FilePath)
+getErrorLog :: MonadSnap im m => Config m a -> Maybe (Maybe FilePath)
getErrorLog = errorLog
------------------------------------------------------------------------------
-getLocale :: MonadSnap m => Config m a -> Maybe String
+getLocale :: MonadSnap im m => Config m a -> Maybe String
getLocale = locale
------------------------------------------------------------------------------
-getBackend :: MonadSnap m => Config m a -> Maybe ConfigBackend
+getBackend :: MonadSnap im m => Config m a -> Maybe ConfigBackend
getBackend = backend
------------------------------------------------------------------------------
-getCompression :: MonadSnap m => Config m a -> Maybe Bool
+getCompression :: MonadSnap im m => Config m a -> Maybe Bool
getCompression = compression
------------------------------------------------------------------------------
-getVerbose :: MonadSnap m => Config m a -> Maybe Bool
+getVerbose :: MonadSnap im m => Config m a -> Maybe Bool
getVerbose = verbose
------------------------------------------------------------------------------
-getErrorHandler :: MonadSnap m => Config m a -> Maybe (SomeException -> m ())
+getErrorHandler :: MonadSnap im m => Config m a -> Maybe (SomeException -> m
())
getErrorHandler = errorHandler
------------------------------------------------------------------------------
-getOther :: MonadSnap m => Config m a -> Maybe a
+getOther :: MonadSnap im m => Config m a -> Maybe a
getOther = other
------------------------------------------------------------------------------
-setHostname :: MonadSnap m => ByteString -> Config m a -> Config m a
+setHostname :: MonadSnap im m => ByteString -> Config m a -> Config m a
setHostname a m = m {hostname = Just a}
------------------------------------------------------------------------------
-addListen :: MonadSnap m => ConfigListen -> Config m a -> Config m a
+addListen :: MonadSnap im m => ConfigListen -> Config m a -> Config m a
addListen a m = m {listen = a : listen m}
------------------------------------------------------------------------------
-setAccessLog :: MonadSnap m => Maybe FilePath -> Config m a -> Config m a
+setAccessLog :: MonadSnap im m => Maybe FilePath -> Config m a -> Config m a
setAccessLog a m = m {accessLog = Just a}
------------------------------------------------------------------------------
-setErrorLog :: MonadSnap m => Maybe FilePath -> Config m a -> Config m a
+setErrorLog :: MonadSnap im m => Maybe FilePath -> Config m a -> Config m a
setErrorLog a m = m {errorLog = Just a}
------------------------------------------------------------------------------
-setLocale :: MonadSnap m => String -> Config m a -> Config m a
+setLocale :: MonadSnap im m => String -> Config m a -> Config m a
setLocale a m = m {locale = Just a}
------------------------------------------------------------------------------
-setBackend :: MonadSnap m => ConfigBackend -> Config m a -> Config m a
+setBackend :: MonadSnap im m => ConfigBackend -> Config m a -> Config m a
setBackend a m = m { backend = Just a}
------------------------------------------------------------------------------
-setCompression :: MonadSnap m => Bool -> Config m a -> Config m a
+setCompression :: MonadSnap im m => Bool -> Config m a -> Config m a
setCompression a m = m {compression = Just a}
------------------------------------------------------------------------------
-setVerbose :: MonadSnap m => Bool -> Config m a -> Config m a
+setVerbose :: MonadSnap im m => Bool -> Config m a -> Config m a
setVerbose a m = m {verbose = Just a}
------------------------------------------------------------------------------
-setErrorHandler :: MonadSnap m => (SomeException -> m ()) -> Config m a
+setErrorHandler :: MonadSnap im m => (SomeException -> m ()) -> Config m a
-> Config m a
setErrorHandler a m = m {errorHandler = Just a}
------------------------------------------------------------------------------
-setOther :: MonadSnap m => a -> Config m a -> Config m a
+setOther :: MonadSnap im m => a -> Config m a -> Config m a
setOther a m = m {other = Just a}
diff --git a/src/Snap/Internal/Http/Server.hs b/src/Snap/Internal/Http/Server.hs
index 81db8fd..1bed699 100644
--- a/src/Snap/Internal/Http/Server.hs
+++ b/src/Snap/Internal/Http/Server.hs
@@ -3,13 +3,15 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE FlexibleContexts #-}
module Snap.Internal.Http.Server where
------------------------------------------------------------------------------
import Control.Arrow (first, second)
import Control.Monad.State.Strict
-import Control.Exception
+import Control.Exception (SomeException, AsyncException)
+import Control.Monad.CatchIO
import Data.Char
import Data.CIByteString
import Data.Binary.Put
@@ -62,11 +64,11 @@ import qualified Paths_snap_server as V
--
-- Note that we won't be bothering end users with this -- the details will be
-- hidden inside the Snap monad
-type ServerHandler = (ByteString -> IO ())
- -> Request
- -> Iteratee ByteString IO (Request,Response)
+type ServerHandler m = (ByteString -> m ())
+ -> Request
+ -> Iteratee ByteString m (Request,Response)
-type ServerMonad = StateT ServerState (Iteratee ByteString IO)
+type ServerMonad m = StateT ServerState (Iteratee ByteString m)
data ListenPort = HttpPort ByteString Int -- (bind address,
port)
| HttpsPort ByteString Int FilePath FilePath -- (bind address,
port, path to certificate, path to key)
@@ -91,12 +93,13 @@ data ServerState = ServerState
}
------------------------------------------------------------------------------
-runServerMonad :: ByteString -- ^ local host name
+runServerMonad :: MonadIO m
+ => ByteString -- ^ local host name
-> SessionInfo -- ^ session port information
-> (Request -> Response -> IO ()) -- ^ access log function
-> (ByteString -> IO ()) -- ^ error log function
- -> ServerMonad a -- ^ monadic action to run
- -> Iteratee ByteString IO a
+ -> ServerMonad m a -- ^ monadic action to run
+ -> Iteratee ByteString m a
runServerMonad lh s la le m = evalStateT m st
where
st = ServerState False lh s la le
@@ -107,67 +110,72 @@ runServerMonad lh s la le m = evalStateT m st
------------------------------------------------------------------------------
-httpServe :: [ListenPort] -- ^ ports to listen on
+httpServe :: MonadCatchIO m
+ => [ListenPort] -- ^ ports to listen on
-> Maybe EventLoopType -- ^ Specify a given event loop, otherwise a
default is picked
-> ByteString -- ^ local hostname (server name)
-> Maybe FilePath -- ^ path to the access log
-> Maybe FilePath -- ^ path to the error log
- -> ServerHandler -- ^ handler procedure
- -> IO ()
+ -> ServerHandler m -- ^ handler procedure
+ -> m ()
httpServe ports mevType localHostname alogPath elogPath handler =
withLoggers alogPath elogPath
(\(alog, elog) -> spawnAll alog elog)
where
--------------------------------------------------------------------------
+ spawnAll :: MonadCatchIO m => Maybe Logger -> Maybe Logger -> m ()
spawnAll alog elog = {-# SCC "httpServe/spawnAll" #-} do
let evType = maybe defaultEvType id mevType
- logE elog $ S.concat [ "Server.httpServe: START ("
- , toBS $ Prelude.show evType, ")"]
+ liftIO $ logE elog $ S.concat [ "Server.httpServe: START ("
+ , toBS $ Prelude.show evType, ")"]
let initHttps = foldr (\p b -> b || case p of { (HttpsPort _ _ _ _) ->
True; _ -> False;}) False ports
if initHttps
- then TLS.initTLS
+ then liftIO TLS.initTLS
else return ()
- nports <- mapM bindPort ports
+ nports <- mapM (liftIO . bindPort) ports
- (runEventLoop evType nports numCapabilities (logE elog) $
+ (liftIO $ runEventLoop evType nports numCapabilities (logE elog) $
runHTTP alog elog handler localHostname) `finally` do
- logE elog "Server.httpServe: SHUTDOWN"
+ liftIO $ logE elog "Server.httpServe: SHUTDOWN"
if initHttps
- then TLS.stopTLS
+ then liftIO TLS.stopTLS
else return ()
- logE elog "Server.httpServe: BACKEND STOPPED"
-
- --------------------------------------------------------------------------
- bindPort (HttpPort baddr port) = bindHttp baddr port
- bindPort (HttpsPort baddr port cert key) = TLS.bindHttps baddr port cert
key
-
+ liftIO $ logE elog "Server.httpServe: BACKEND STOPPED"
--------------------------------------------------------------------------
runEventLoop EventLoopSimple = simpleEventLoop
runEventLoop EventLoopLibEv = libEvEventLoop
- --------------------------------------------------------------------------
- maybeSpawnLogger = maybe (return Nothing) $ (liftM Just) . newLogger
+--------------------------------------------------------------------------
+bindPort (HttpPort baddr port) = bindHttp baddr port
+bindPort (HttpsPort baddr port cert key) = TLS.bindHttps baddr port cert key
- --------------------------------------------------------------------------
- withLoggers afp efp =
- bracket (do alog <- maybeSpawnLogger afp
- elog <- maybeSpawnLogger efp
- return (alog, elog))
- (\(alog, elog) -> do
- maybe (return ()) stopLogger alog
- maybe (return ()) stopLogger elog)
+--------------------------------------------------------------------------
+maybeSpawnLogger :: MonadIO m => Maybe FilePath -> m (Maybe Logger)
+maybeSpawnLogger = maybe (return Nothing) $ (liftM Just) . liftIO . newLogger
+
+
+--------------------------------------------------------------------------
+withLoggers :: MonadCatchIO m => Maybe FilePath -> Maybe FilePath
+ -> ((Maybe Logger, Maybe Logger) -> m b) -> m b
+withLoggers afp efp =
+ bracket (do alog <- maybeSpawnLogger afp
+ elog <- maybeSpawnLogger efp
+ return (alog, elog))
+ (\(alog, elog) -> do
+ maybe (return ()) (liftIO . stopLogger) alog
+ maybe (return ()) (liftIO . stopLogger) elog)
------------------------------------------------------------------------------
@@ -215,9 +223,10 @@ logA' logger req rsp = do
------------------------------------------------------------------------------
-runHTTP :: Maybe Logger -- ^ access logger
+runHTTP :: MonadCatchIO m
+ => Maybe Logger -- ^ access logger
-> Maybe Logger -- ^ error logger
- -> ServerHandler -- ^ handler procedure
+ -> ServerHandler m -- ^ handler procedure
-> ByteString -- ^ local host name
-> SessionInfo -- ^ session port information
-> Enumerator ByteString IO () -- ^ read end of socket
@@ -225,19 +234,19 @@ runHTTP :: Maybe Logger -- ^ access
logger
-> (FilePath -> Int64 -> Int64 -> IO ())
-- ^ sendfile end
-> IO () -- ^ timeout tickler
- -> IO ()
+ -> m ()
runHTTP alog elog handler lh sinfo readEnd writeEnd onSendFile tickle =
go `catches` [ Handler $ \(e :: AsyncException) -> do
- throwIO e
+ liftIO $ throw e
, Handler $ \(e :: SomeException) ->
- logE elog $ S.concat [ logPrefix , bshow e ] ]
+ liftIO $ logE elog $ S.concat [ logPrefix , bshow e ] ]
where
logPrefix = S.concat [ "[", remoteAddress sinfo, "]: error: " ]
go = do
- buf <- mkIterateeBuffer
+ buf <- liftIO mkIterateeBuffer
let iter1 = runServerMonad lh sinfo (logA alog) (logE elog) $
httpSession writeEnd buf onSendFile tickle
handler
@@ -245,7 +254,7 @@ runHTTP alog elog handler lh sinfo readEnd writeEnd
onSendFile tickle =
debug "runHTTP/go: prepping iteratee for start"
- step <- liftIO $ runIteratee iter
+ step <- runIteratee iter
debug "runHTTP/go: running..."
run_ $ readEnd step
@@ -263,24 +272,25 @@ snapServerVersion = SC.pack $ showVersion $ V.version
------------------------------------------------------------------------------
-logAccess :: Request -> Response -> ServerMonad ()
+logAccess :: MonadIO m => Request -> Response -> ServerMonad m ()
logAccess req rsp = gets _logAccess >>= (\l -> liftIO $ l req rsp)
------------------------------------------------------------------------------
-logError :: ByteString -> ServerMonad ()
+logError :: MonadIO m => ByteString -> ServerMonad m ()
logError s = gets _logError >>= (\l -> liftIO $ l s)
------------------------------------------------------------------------------
-- | Runs an HTTP session.
-httpSession :: Iteratee ByteString IO () -- ^ write end of socket
+httpSession :: MonadIO m
+ => Iteratee ByteString IO () -- ^ write end of socket
-> ForeignPtr CChar -- ^ iteratee buffer
-> (FilePath -> Int64 -> Int64 -> IO ())
-- ^ sendfile continuation
-> IO () -- ^ timeout tickler
- -> ServerHandler -- ^ handler procedure
- -> ServerMonad ()
+ -> ServerHandler m -- ^ handler procedure
+ -> ServerMonad m ()
httpSession writeEnd' ibuf onSendFile tickle handler = do
let writeEnd1 = I.unsafeBufferIterateeWithBuffer ibuf writeEnd'
@@ -308,7 +318,7 @@ httpSession writeEnd' ibuf onSendFile tickle handler = do
logerr <- gets _logError
- (req',rspOrig) <- lift $ handler logerr req
+ (req',rspOrig) <- lift $ handler (liftIO . logerr) req
liftIO $ debug $ "Server.httpSession: finished running user handler"
@@ -330,7 +340,7 @@ httpSession writeEnd' ibuf onSendFile tickle handler = do
skipStep <- liftIO $ runIteratee $
iterateeDebugWrapper "httpSession/skipToEof"
skipToEof
- lift $ rqEnum skipStep
+ lift $ liftIterIO $ rqEnum skipStep
liftIO $ debug $ "Server.httpSession: request body skipped, " ++
"sending response"
@@ -360,9 +370,9 @@ httpSession writeEnd' ibuf onSendFile tickle handler = do
------------------------------------------------------------------------------
-checkExpect100Continue :: Request
+checkExpect100Continue :: MonadIO m => Request
-> Step ByteString IO ()
- -> ServerMonad ()
+ -> ServerMonad m ()
checkExpect100Continue req writeEnd = do
let mbEx = getHeaders "Expect" req
@@ -384,7 +394,7 @@ checkExpect100Continue req writeEnd = do
------------------------------------------------------------------------------
-receiveRequest :: ServerMonad (Maybe Request)
+receiveRequest :: MonadIO m => ServerMonad m (Maybe Request)
receiveRequest = do
debug "receiveRequest: entered"
mreq <- {-# SCC "receiveRequest/parseRequest" #-} lift $
@@ -412,7 +422,7 @@ receiveRequest = do
--
-- if no content-length and no chunked encoding, enumerate the entire
-- socket and close afterwards
- setEnumerator :: Request -> ServerMonad ()
+ setEnumerator :: MonadIO m => Request -> ServerMonad m ()
setEnumerator req = {-# SCC "receiveRequest/setEnumerator" #-} do
if isChunked
then do
@@ -428,7 +438,7 @@ receiveRequest = do
((== ["chunked"]) . map toCI)
(Map.lookup "transfer-encoding" hdrs)
- hasContentLength :: Int64 -> ServerMonad ()
+ hasContentLength :: MonadIO m => Int64 -> ServerMonad m ()
hasContentLength len = do
liftIO $ debug $ "receiveRequest/setEnumerator: " ++
"request had content-length " ++ Prelude.show len
@@ -444,7 +454,7 @@ receiveRequest = do
joinI $ takeExactly len st'
- noContentLength :: Request -> ServerMonad ()
+ noContentLength :: MonadIO m => Request -> ServerMonad m ()
noContentLength req = liftIO $ do
debug ("receiveRequest/setEnumerator: " ++
"request did NOT have content-length")
@@ -462,7 +472,7 @@ receiveRequest = do
--------------------------------------------------------------------------
- parseForm :: Request -> ServerMonad Request
+ parseForm :: MonadIO m => Request -> ServerMonad m Request
parseForm req = {-# SCC "receiveRequest/parseForm" #-}
if doIt then getIt else return req
where
@@ -475,7 +485,7 @@ receiveRequest = do
maximumPOSTBodySize :: Int64
maximumPOSTBodySize = 10*1024*1024
- getIt :: ServerMonad Request
+ getIt :: MonadIO m => ServerMonad m Request
getIt = {-# SCC "receiveRequest/parseForm/getIt" #-} do
liftIO $ debug "parseForm: got application/x-www-form-urlencoded"
liftIO $ debug "parseForm: reading POST body"
@@ -485,7 +495,7 @@ receiveRequest = do
step <- liftIO $
runIteratee $
joinI $ takeNoMoreThan maximumPOSTBodySize consumeStep
- body <- liftM S.concat $ lift $ enum step
+ body <- liftM S.concat $ lift $ liftIterIO $ enum step
let newParams = parseUrlEncoded body
liftIO $ debug "parseForm: stuffing 'enumBS body' into request"
@@ -571,24 +581,33 @@ receiveRequest = do
S.break (== (c2w '?')) uri
+liftIterIO :: (MonadIO m) => Iteratee a IO b -> Iteratee a m b
+liftIterIO iter = Iteratee $ do
+ step <- liftIO $ runIteratee iter
+ return $ case step of
+ Yield x cs -> Yield x cs
+ Error err -> Error err
+ Continue k -> Continue (liftIterIO . k)
+
------------------------------------------------------------------------------
-- Response must be well-formed here
-sendResponse :: forall a . Request
+sendResponse :: forall m a . (MonadIO m
+ => Request
-> Response
-> Step ByteString IO a -- ^ iteratee write end
-> (FilePath -> Int64 -> Int64 -> IO a) -- ^ function to call on
-- sendfile
- -> ServerMonad (Int64, a)
+ -> ServerMonad m (Int64, a))
sendResponse req rsp' writeEnd onSendFile = do
rsp <- fixupResponse rsp'
let !headerString = mkHeaderString rsp
(!x,!bs) <- case (rspBody rsp) of
- (Enum e) -> lift $ whenEnum headerString rsp e
- (SendFile f Nothing) -> lift $
+ (Enum e) -> lift $ liftIterIO $ whenEnum
headerString rsp e
+ (SendFile f Nothing) -> lift $ liftIterIO $
whenSendFile headerString rsp f 0
(SendFile f (Just (st,_))) ->
- lift $ whenSendFile headerString rsp f st
+ lift $ liftIterIO $ whenSendFile headerString rsp f st
debug "sendResponse: response sent"
@@ -660,7 +679,7 @@ sendResponse req rsp' writeEnd onSendFile = do
--------------------------------------------------------------------------
- noCL :: Response -> ServerMonad Response
+ noCL :: Response -> ServerMonad m Response
noCL r =
{-# SCC "noCL" #-}
do
@@ -686,7 +705,7 @@ sendResponse req rsp' writeEnd onSendFile = do
--------------------------------------------------------------------------
- hasCL :: Int64 -> Response -> ServerMonad Response
+ hasCL :: Int64 -> Response -> ServerMonad m Response
hasCL cl r =
{-# SCC "hasCL" #-}
do
@@ -707,7 +726,7 @@ sendResponse req rsp' writeEnd onSendFile = do
--------------------------------------------------------------------------
- setFileSize :: FilePath -> Response -> ServerMonad Response
+ setFileSize :: MonadIO m => FilePath -> Response -> ServerMonad m Response
setFileSize fp r =
{-# SCC "setFileSize" #-}
do
@@ -723,7 +742,7 @@ sendResponse req rsp' writeEnd onSendFile = do
--------------------------------------------------------------------------
- fixupResponse :: Response -> ServerMonad Response
+ fixupResponse :: Response -> ServerMonad m Response
fixupResponse r = {-# SCC "fixupResponse" #-} do
let r' = deleteHeader "Content-Length" r
@@ -771,7 +790,7 @@ sendResponse req rsp' writeEnd onSendFile = do
------------------------------------------------------------------------------
-checkConnectionClose :: (Int, Int) -> Headers -> ServerMonad ()
+checkConnectionClose :: Monad m => (Int, Int) -> Headers -> ServerMonad m ()
checkConnectionClose ver hdrs =
-- For HTTP/1.1:
-- if there is an explicit Connection: close, close the socket.
diff --git a/src/Snap/Internal/Http/Server/Backend.hs
b/src/Snap/Internal/Http/Server/Backend.hs
index f9bd4d6..6b6a9d3 100644
--- a/src/Snap/Internal/Http/Server/Backend.hs
+++ b/src/Snap/Internal/Http/Server/Backend.hs
@@ -23,18 +23,18 @@ data SessionInfo = SessionInfo
, isSecure :: Bool
}
-type SessionHandler = SessionInfo -- ^ session port
information
- -> Enumerator ByteString IO () -- ^ read end of
socket
- -> Iteratee ByteString IO () -- ^ write end of
socket
- -> (FilePath -> Int64 -> Int64 -> IO ()) -- ^ sendfile end
- -> IO () -- ^ timeout
tickler
- -> IO ()
+type SessionHandler m = SessionInfo -- ^ session
port information
+ -> Enumerator ByteString IO () -- ^ read end
of socket
+ -> Iteratee ByteString IO () -- ^ write end
of socket
+ -> (FilePath -> Int64 -> Int64 -> IO ()) -- ^ sendfile
end
+ -> IO () -- ^ timeout
tickler
+ -> m ()
-type EventLoop = [ListenSocket] -- ^ list of ports
- -> Int -- ^ number of capabilities
- -> (ByteString -> IO ()) -- ^ error log
- -> SessionHandler -- ^ session handler
- -> IO ()
+type EventLoop m = [ListenSocket] -- ^ list of ports
+ -> Int -- ^ number of capabilities
+ -> (ByteString -> IO ()) -- ^ error log
+ -> SessionHandler m -- ^ session handler
+ -> m ()
{- For performance reasons, we do not implement this as a class
diff --git a/src/Snap/Internal/Http/Server/LibevBackend.hs
b/src/Snap/Internal/Http/Server/LibevBackend.hs
index 006f7bc..ce95f73 100644
--- a/src/Snap/Internal/Http/Server/LibevBackend.hs
+++ b/src/Snap/Internal/Http/Server/LibevBackend.hs
@@ -14,6 +14,7 @@ module Snap.Internal.Http.Server.LibevBackend
#ifndef LIBEV
import Control.Exception
+import Control.Monad.Trans
import Data.Typeable
import Snap.Internal.Http.Server.Backend
@@ -21,8 +22,8 @@ data LibevException = LibevException String
deriving (Show, Typeable)
instance Exception LibevException
-libEvEventLoop :: EventLoop
-libEvEventLoop _ _ _ _ = throwIO $ LibevException "libev event loop is not
supported"
+libEvEventLoop :: MonadIO m => EventLoop m
+libEvEventLoop _ _ _ _ = liftIO $ throwIO $ LibevException "libev event loop
is not supported"
#else
diff --git a/src/Snap/Internal/Http/Server/SimpleBackend.hs
b/src/Snap/Internal/Http/Server/SimpleBackend.hs
index 4554871..c85016b 100644
--- a/src/Snap/Internal/Http/Server/SimpleBackend.hs
+++ b/src/Snap/Internal/Http/Server/SimpleBackend.hs
@@ -15,8 +15,9 @@ module Snap.Internal.Http.Server.SimpleBackend
import Control.Monad.Trans
import Control.Concurrent hiding (yield)
-import Control.Exception
+import Control.Exception (SomeException, AsyncException)
import Control.Monad
+import Control.Monad.CatchIO
import Data.ByteString (ByteString)
import qualified Data.ByteString as S
import Data.ByteString.Internal (c2w)
@@ -59,7 +60,7 @@ data EventLoopCpu = EventLoopCpu
, _exitMVar :: !(MVar ())
}
-simpleEventLoop :: EventLoop
+simpleEventLoop :: EventLoop m
simpleEventLoop sockets cap elog handler = do
loops <- Prelude.mapM (newLoop sockets handler elog) [0..(cap-1)]
@@ -72,10 +73,10 @@ simpleEventLoop sockets cap elog handler = do
mapM Listen.closeSocket sockets
newLoop :: [ListenSocket]
- -> SessionHandler
+ -> SessionHandler m
-> (S.ByteString -> IO ())
-> Int
- -> IO EventLoopCpu
+ -> m EventLoopCpu
newLoop sockets handler elog cpu = do
tt <- TT.new
exit <- newEmptyMVar
@@ -89,15 +90,16 @@ stopLoop loop = block $ do
Prelude.mapM_ killThread $ _acceptThreads loop
killThread $ _timeoutThread loop
-acceptThread :: SessionHandler
+acceptThread :: MonadCatchIO m
+ => SessionHandler m
-> TimeoutTable
-> (S.ByteString -> IO ())
-> Int
-> ListenSocket
- -> IO ()
+ -> m ()
acceptThread handler tt elog cpu sock = loop
where
- loop = do
+ loop = liftIO $ do
debug $ "acceptThread: calling accept()"
(s,addr) <- accept $ Listen.listenSocket sock
debug $ "acceptThread: accepted connection from remote: " ++ show addr
@@ -107,7 +109,9 @@ acceptThread handler tt elog cpu sock = loop
go = runSession handler tt sock
cleanup = [
- Handler $ \(e :: SomeException) -> elog $ S.concat [
"SimpleBackend.acceptThread: ", S.pack . map c2w $ show e]
+ Handler $ \(e :: SomeException) -> liftIO $
+ elog $ S.concat [ "SimpleBackend.acceptThread: "
+ , S.pack . map c2w $ show e]
]
timeoutThread :: TimeoutTable -> MVar () -> IO ()
@@ -145,38 +149,44 @@ instance Show AddressNotSupportedException where
instance Exception AddressNotSupportedException
-runSession :: SessionHandler -> TimeoutTable -> ListenSocket -> Socket ->
SockAddr -> IO ()
+runSession :: MonadCatchIO m
+ => SessionHandler m
+ -> TimeoutTable
+ -> ListenSocket
+ -> Socket
+ -> SockAddr
+ -> m ()
runSession handler tt lsock sock addr = do
let fd = fdSocket sock
- curId <- myThreadId
+ curId <- liftIO myThreadId
debug $ "Backend.withConnection: running session: " ++ show addr
- labelThread curId $ "connHndl " ++ show fd
+ liftIO $ labelThread curId $ "connHndl " ++ show fd
- (rport,rhost) <-
+ (rport,rhost) <- liftIO $
case addr of
SockAddrInet p h -> do
h' <- inet_ntoa h
return (fromIntegral p, S.pack $ map c2w h')
- x -> throwIO $ AddressNotSupportedException $ show x
+ x -> throw $ AddressNotSupportedException $ show x
- laddr <- getSocketName sock
+ laddr <- liftIO $ getSocketName sock
- (lport,lhost) <-
+ (lport,lhost) <- liftIO $
case laddr of
SockAddrInet p h -> do
h' <- inet_ntoa h
return (fromIntegral p, S.pack $ map c2w h')
- x -> throwIO $ AddressNotSupportedException $ show x
+ x -> throw $ AddressNotSupportedException $ show x
let sinfo = SessionInfo lhost lport rhost rport $ Listen.isSecure lsock
let curHash = hashString $ show curId
let timeout = tickleTimeout tt curId curHash
- timeout
+ liftIO timeout
- bracket (Listen.createSession lsock 8192 fd (threadWaitRead $ fromIntegral
fd))
- (\session -> block $ do
+ bracket (liftIO $ Listen.createSession lsock 8192 fd (threadWaitRead $
fromIntegral fd))
+ (\session -> block $ liftIO $ do
debug "thread killed, closing socket"
-- remove thread from timeout table
-----------------------------------------------------------------------
hooks/post-receive
--
snap-server
_______________________________________________
Snap mailing list
[email protected]
http://mailman-mail5.webfaction.com/listinfo/snap
