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-core".
The branch, snapt has been created
at 7eefd688606e36764493728b2a931757106a365a (commit)
- Log -----------------------------------------------------------------
commit 7eefd688606e36764493728b2a931757106a365a
Author: Mighty Byte <[email protected]>
Date: Mon Nov 29 01:16:27 2010 -0500
Refactored Snap to SnapT.
diff --git a/src/Snap/Internal/Instances.hs b/src/Snap/Internal/Instances.hs
index 3faff78..efacb7c 100644
--- a/src/Snap/Internal/Instances.hs
+++ b/src/Snap/Internal/Instances.hs
@@ -1,5 +1,8 @@
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE PackageImports #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE FlexibleInstances #-}
module Snap.Internal.Instances where
@@ -33,50 +36,50 @@ instance MonadPlus m => Alternative (ContT c m) where
------------------------------------------------------------------------------
-instance MonadSnap m => MonadSnap (ContT c m) where
+instance MonadSnap im m => MonadSnap im (ContT c m) where
liftSnap = lift . liftSnap
------------------------------------------------------------------------------
-instance (MonadSnap m, Error e) => MonadSnap (ErrorT e m) where
+instance (MonadSnap im m, Error e) => MonadSnap im (ErrorT e m) where
liftSnap = lift . liftSnap
------------------------------------------------------------------------------
-instance MonadSnap m => MonadSnap (ListT m) where
+instance MonadSnap im m => MonadSnap im (ListT m) where
liftSnap = lift . liftSnap
------------------------------------------------------------------------------
-instance (MonadSnap m, Monoid w) => MonadSnap (RWST r w s m) where
+instance (MonadSnap im m, Monoid w) => MonadSnap im (RWST r w s m) where
liftSnap = lift . liftSnap
------------------------------------------------------------------------------
-instance (MonadSnap m, Monoid w) => MonadSnap (LRWS.RWST r w s m) where
+instance (MonadSnap im m, Monoid w) => MonadSnap im (LRWS.RWST r w s m) where
liftSnap = lift . liftSnap
------------------------------------------------------------------------------
-instance MonadSnap m => MonadSnap (ReaderT r m) where
+instance MonadSnap im m => MonadSnap im (ReaderT r m) where
liftSnap = lift . liftSnap
------------------------------------------------------------------------------
-instance MonadSnap m => MonadSnap (StateT s m) where
+instance MonadSnap im m => MonadSnap im (StateT s m) where
liftSnap = lift . liftSnap
------------------------------------------------------------------------------
-instance MonadSnap m => MonadSnap (LState.StateT s m) where
+instance MonadSnap im m => MonadSnap im (LState.StateT s m) where
liftSnap = lift . liftSnap
------------------------------------------------------------------------------
-instance (MonadSnap m, Monoid w) => MonadSnap (WriterT w m) where
+instance (MonadSnap im m, Monoid w) => MonadSnap im (WriterT w m) where
liftSnap = lift . liftSnap
------------------------------------------------------------------------------
-instance (MonadSnap m, Monoid w) => MonadSnap (LWriter.WriterT w m) where
+instance (MonadSnap im m, Monoid w) => MonadSnap im (LWriter.WriterT w m) where
liftSnap = lift . liftSnap
diff --git a/src/Snap/Internal/Routing.hs b/src/Snap/Internal/Routing.hs
index b6427b4..4960e09 100644
--- a/src/Snap/Internal/Routing.hs
+++ b/src/Snap/Internal/Routing.hs
@@ -36,7 +36,7 @@ triggering its fallback. It's NoRoute, so we go to the
nearest parent
fallback and try that, which is the baz action.
-}
-data Route a m = Action ((MonadSnap m) => m a) -- wraps a 'Snap'
action
+data Route a m = Action ((MonadSnap im m) => m a) -- wraps a
'Snap' action
| Capture ByteString (Route a m) (Route a m) -- captures the
dir in a param
| Dir (Map.Map ByteString (Route a m)) (Route a m) -- match on
a dir
| NoRoute
@@ -147,7 +147,7 @@ routeEarliestNC r n = case r of
-- > , ("article/:id", renderArticle)
-- > , ("login", method POST doLogin) ]
--
-route :: MonadSnap m => [(ByteString, m a)] -> m a
+route :: (MonadSnap im m, Monad im) => [(ByteString, m a)] -> m a
route rts = do
p <- getRequest >>= return . rqPathInfo
route' (return ()) ([], splitPath p) Map.empty rts'
@@ -160,7 +160,7 @@ route rts = do
-- the request's context path. This is useful if you want to route to a
-- particular handler but you want that handler to receive the 'rqPathInfo' as
-- it is.
-routeLocal :: MonadSnap m => [(ByteString, m a)] -> m a
+routeLocal :: (MonadSnap im m, Monad im) => [(ByteString, m a)] -> m a
routeLocal rts = do
req <- getRequest
let ctx = rqContextPath req
@@ -178,7 +178,7 @@ splitPath = B.splitWith (== (c2w '/'))
------------------------------------------------------------------------------
-pRoute :: MonadSnap m => (ByteString, m a) -> Route a m
+pRoute :: MonadSnap im m => (ByteString, m a) -> Route a m
pRoute (r, a) = foldr f (Action a) hier
where
hier = filter (not . B.null) $ B.splitWith (== (c2w '/')) r
@@ -188,7 +188,7 @@ pRoute (r, a) = foldr f (Action a) hier
------------------------------------------------------------------------------
-route' :: MonadSnap m
+route' :: (MonadSnap im m, Monad im)
=> m ()
-> ([ByteString], [ByteString])
-> Params
diff --git a/src/Snap/Internal/Types.hs b/src/Snap/Internal/Types.hs
index de80c08..748a162 100644
--- a/src/Snap/Internal/Types.hs
+++ b/src/Snap/Internal/Types.hs
@@ -4,6 +4,10 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PackageImports #-}
{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE FlexibleContexts #-}
module Snap.Internal.Types where
@@ -100,16 +104,21 @@ transformers ('ReaderT', 'WriterT', 'StateT', etc.).
-- | 'MonadSnap' is a type class, analogous to 'MonadIO' for 'IO', that makes
-- it easy to wrap 'Snap' inside monad transformers.
class (Monad m, MonadIO m, MonadCatchIO m, MonadPlus m, Functor m,
- Applicative m, Alternative m) => MonadSnap m where
- liftSnap :: Snap a -> m a
+ Applicative m, Alternative m) => MonadSnap innerm m | m -> innerm where
+ liftSnap :: SnapT innerm a -> m a
------------------------------------------------------------------------------
-newtype Snap a = Snap {
- unSnap :: StateT SnapState (Iteratee ByteString IO) (Maybe (Either
Response a))
+newtype SnapT m a = SnapT {
+ unSnap :: StateT SnapState (Iteratee ByteString m) (Maybe (Either
Response a))
}
------------------------------------------------------------------------------
+-- | Convenient type alias for compatibility.
+type Snap = SnapT IO
+
+
+------------------------------------------------------------------------------
data SnapState = SnapState
{ _snapRequest :: Request
, _snapResponse :: Response
@@ -117,89 +126,88 @@ data SnapState = SnapState
------------------------------------------------------------------------------
-instance Monad Snap where
- (Snap m) >>= f =
- Snap $ do
+instance (Monad m) => Monad (SnapT m) where
+ (SnapT m) >>= f =
+ SnapT $ do
eth <- m
maybe (return Nothing)
(either (return . Just . Left)
(unSnap . f))
eth
- return = Snap . return . Just . Right
- fail = const $ Snap $ return Nothing
+ return = SnapT . return . Just . Right
+ fail = const $ SnapT $ return Nothing
+
+
+------------------------------------------------------------------------------
+instance (MonadIO m) => MonadIO (SnapT m) where
+ liftIO m = SnapT $ liftM (Just . Right) $ liftIO m
------------------------------------------------------------------------------
-instance MonadIO Snap where
- liftIO m = Snap $ liftM (Just . Right) $ liftIO m
+instance (MonadCatchIO m, Functor m) => MonadSnap m (SnapT m) where
+ liftSnap = id
------------------------------------------------------------------------------
-instance MonadCatchIO Snap where
- catch (Snap m) handler = Snap $ do
+instance (MonadCatchIO m, Functor m) => MonadCatchIO (SnapT m) where
+ catch (SnapT m) handler = SnapT $ do
x <- try m
case x of
- (Left e) -> let (Snap z) = handler e in z
+ (Left e) -> let (SnapT z) = handler e in z
(Right y) -> return y
- block (Snap m) = Snap $ block m
- unblock (Snap m) = Snap $ unblock m
+ block (SnapT m) = SnapT $ block m
+ unblock (SnapT m) = SnapT $ unblock m
------------------------------------------------------------------------------
-instance MonadPlus Snap where
- mzero = Snap $ return Nothing
+instance (Monad m) => MonadPlus (SnapT m) where
+ mzero = SnapT $ return Nothing
a `mplus` b =
- Snap $ do
+ SnapT $ do
mb <- unSnap a
if isJust mb then return mb else unSnap b
------------------------------------------------------------------------------
-instance Functor Snap where
+instance (Monad m) => Functor (SnapT m) where
fmap = liftM
------------------------------------------------------------------------------
-instance Applicative Snap where
+instance (Monad m) => Applicative (SnapT m) where
pure = return
(<*>) = ap
------------------------------------------------------------------------------
-instance Alternative Snap where
+instance (Monad m) => Alternative (SnapT m) where
empty = mzero
(<|>) = mplus
------------------------------------------------------------------------------
-instance MonadSnap Snap where
- liftSnap = id
-
-
-
-------------------------------------------------------------------------------
-- | The Typeable instance is here so Snap can be dynamically executed with
-- Hint.
snapTyCon :: TyCon
-snapTyCon = mkTyCon "Snap.Types.Snap"
+snapTyCon = mkTyCon "SnapT.Types.SnapT"
{-# NOINLINE snapTyCon #-}
-instance Typeable1 Snap where
+instance Typeable1 (SnapT m) where
typeOf1 _ = mkTyConApp snapTyCon []
------------------------------------------------------------------------------
-liftIter :: MonadSnap m => Iteratee ByteString IO a -> m a
-liftIter i = liftSnap $ Snap (lift i >>= return . Just . Right)
+liftIter :: (MonadSnap im m, Monad im) => Iteratee ByteString im a -> m a
+liftIter i = liftSnap $ SnapT (lift i >>= return . Just . Right)
------------------------------------------------------------------------------
-- | Sends the request body through an iteratee (data consumer) and
-- returns the result.
-runRequestBody :: MonadSnap m => Iteratee ByteString IO a -> m a
+runRequestBody :: (MonadSnap IO m) => Iteratee ByteString IO a -> m a
runRequestBody iter = do
req <- getRequest
senum <- liftIO $ readIORef $ rqBody req
@@ -222,7 +230,7 @@ runRequestBody iter = do
------------------------------------------------------------------------------
-- | Returns the request body as a bytestring.
-getRequestBody :: MonadSnap m => m L.ByteString
+getRequestBody :: (MonadSnap IO m) => m L.ByteString
getRequestBody = liftM L.fromChunks $ runRequestBody consume
{-# INLINE getRequestBody #-}
@@ -237,12 +245,12 @@ getRequestBody = liftM L.fromChunks $ runRequestBody
consume
-- if you called 'finishWith'. Make sure you set any content types, headers,
-- cookies, etc. before you call this function.
--
-transformRequestBody :: (forall a . Enumerator ByteString IO a)
+transformRequestBody :: (MonadSnap IO m) => (forall a . Enumerator ByteString
IO a)
-- ^ the output 'Iteratee' is passed to this
-- 'Enumerator', and then the resulting 'Iteratee' is
-- fed the request body stream. Your 'Enumerator' is
-- responsible for transforming the input.
- -> Snap ()
+ -> m ()
transformRequestBody trans = do
req <- getRequest
let ioref = rqBody req
@@ -263,25 +271,25 @@ transformRequestBody trans = do
------------------------------------------------------------------------------
--- | Short-circuits a 'Snap' monad action early, storing the given
+-- | Short-circuits a 'SnapT' monad action early, storing the given
-- 'Response' value in its state.
-finishWith :: MonadSnap m => Response -> m a
-finishWith = liftSnap . Snap . return . Just . Left
+finishWith :: (MonadSnap im m, Monad im) => Response -> m a
+finishWith = liftSnap . SnapT . return . Just . Left
{-# INLINE finishWith #-}
------------------------------------------------------------------------------
--- | Fails out of a 'Snap' monad action. This is used to indicate
+-- | Fails out of a 'SnapT' monad action. This is used to indicate
-- that you choose not to handle the given request within the given
-- handler.
-pass :: MonadSnap m => m a
+pass :: MonadSnap im m => m a
pass = empty
------------------------------------------------------------------------------
--- | Runs a 'Snap' monad action only if the request's HTTP method matches
+-- | Runs a 'SnapT' monad action only if the request's HTTP method matches
-- the given method.
-method :: MonadSnap m => Method -> m a -> m a
+method :: (MonadSnap im m, Monad im) => Method -> m a -> m a
method m action = do
req <- getRequest
unless (rqMethod req == m) pass
@@ -303,9 +311,9 @@ updateContextPath n req | n > 0 = req { rqContextPath =
ctx
------------------------------------------------------------------------------
--- Runs a 'Snap' monad action only if the 'rqPathInfo' matches the given
+-- Runs a 'SnapT' monad action only if the 'rqPathInfo' matches the given
-- predicate.
-pathWith :: MonadSnap m
+pathWith :: (MonadSnap im m, Monad im)
=> (ByteString -> ByteString -> Bool)
-> ByteString
-> m a
@@ -317,14 +325,14 @@ pathWith c p action = do
------------------------------------------------------------------------------
--- | Runs a 'Snap' monad action only when the 'rqPathInfo' of the request
+-- | Runs a 'SnapT' monad action only when the 'rqPathInfo' of the request
-- starts with the given path. For example,
--
-- > dir "foo" handler
--
-- Will fail if 'rqPathInfo' is not \"@\/f...@\" or \"@\/foo\/....@\", and will
-- add @\"foo\/\"@ to the handler's local 'rqContextPath'.
-dir :: MonadSnap m
+dir :: (MonadSnap im m, Monad im)
=> ByteString -- ^ path component to match
-> m a -- ^ handler to run
-> m a
@@ -337,11 +345,11 @@ dir = pathWith f
------------------------------------------------------------------------------
--- | Runs a 'Snap' monad action only for requests where 'rqPathInfo' is exactly
+-- | Runs a 'SnapT' monad action only for requests where 'rqPathInfo' is
exactly
-- equal to the given string. If the path matches, locally sets 'rqContextPath'
-- to the old value of 'rqPathInfo', sets 'rqPathInfo'=\"\", and runs the given
-- handler.
-path :: MonadSnap m
+path :: (MonadSnap im m, Monad im)
=> ByteString -- ^ path to match against
-> m a -- ^ handler to run
-> m a
@@ -350,65 +358,65 @@ path = pathWith (==)
------------------------------------------------------------------------------
--- | Runs a 'Snap' monad action only when 'rqPathInfo' is empty.
-ifTop :: MonadSnap m => m a -> m a
+-- | Runs a 'SnapT' monad action only when 'rqPathInfo' is empty.
+ifTop :: (MonadSnap im m, Monad im) => m a -> m a
ifTop = path ""
{-# INLINE ifTop #-}
------------------------------------------------------------------------------
--- | Local Snap version of 'get'.
-sget :: Snap SnapState
-sget = Snap $ liftM (Just . Right) get
+-- | Local SnapT version of 'get'.
+sget :: (Monad m) => SnapT m SnapState
+sget = SnapT $ liftM (Just . Right) get
{-# INLINE sget #-}
------------------------------------------------------------------------------
--- | Local Snap monad version of 'modify'.
-smodify :: (SnapState -> SnapState) -> Snap ()
-smodify f = Snap $ modify f >> return (Just $ Right ())
+-- | Local SnapT monad version of 'modify'.
+smodify :: (Monad m) => (SnapState -> SnapState) -> SnapT m ()
+smodify f = SnapT $ modify f >> return (Just $ Right ())
{-# INLINE smodify #-}
------------------------------------------------------------------------------
--- | Grabs the 'Request' object out of the 'Snap' monad.
-getRequest :: MonadSnap m => m Request
+-- | Grabs the 'Request' object out of the 'SnapT' monad.
+getRequest :: (MonadSnap im m, Monad im) => m Request
getRequest = liftSnap $ liftM _snapRequest sget
{-# INLINE getRequest #-}
------------------------------------------------------------------------------
--- | Grabs the 'Response' object out of the 'Snap' monad.
-getResponse :: MonadSnap m => m Response
+-- | Grabs the 'Response' object out of the 'SnapT' monad.
+getResponse :: (MonadSnap im m, Monad im) => m Response
getResponse = liftSnap $ liftM _snapResponse sget
{-# INLINE getResponse #-}
------------------------------------------------------------------------------
--- | Puts a new 'Response' object into the 'Snap' monad.
-putResponse :: MonadSnap m => Response -> m ()
+-- | Puts a new 'Response' object into the 'SnapT' monad.
+putResponse :: (MonadSnap im m, Monad im) => Response -> m ()
putResponse r = liftSnap $ smodify $ \ss -> ss { _snapResponse = r }
{-# INLINE putResponse #-}
------------------------------------------------------------------------------
--- | Puts a new 'Request' object into the 'Snap' monad.
-putRequest :: MonadSnap m => Request -> m ()
+-- | Puts a new 'Request' object into the 'SnapT' monad.
+putRequest :: (MonadSnap im m, Monad im) => Request -> m ()
putRequest r = liftSnap $ smodify $ \ss -> ss { _snapRequest = r }
{-# INLINE putRequest #-}
------------------------------------------------------------------------------
--- | Modifies the 'Request' object stored in a 'Snap' monad.
-modifyRequest :: MonadSnap m => (Request -> Request) -> m ()
+-- | Modifies the 'Request' object stored in a 'SnapT' monad.
+modifyRequest :: (MonadSnap im m, Monad im) => (Request -> Request) -> m ()
modifyRequest f = liftSnap $
smodify $ \ss -> ss { _snapRequest = f $ _snapRequest ss }
{-# INLINE modifyRequest #-}
------------------------------------------------------------------------------
--- | Modifes the 'Response' object stored in a 'Snap' monad.
-modifyResponse :: MonadSnap m => (Response -> Response) -> m ()
+-- | Modifes the 'Response' object stored in a 'SnapT' monad.
+modifyResponse :: (MonadSnap im m, Monad im) => (Response -> Response) -> m ()
modifyResponse f = liftSnap $
smodify $ \ss -> ss { _snapResponse = f $ _snapResponse ss }
{-# INLINE modifyResponse #-}
@@ -417,10 +425,10 @@ modifyResponse f = liftSnap $
------------------------------------------------------------------------------
-- | Performs a redirect by setting the @Location@ header to the given target
-- URL/path and the status code to 302 in the 'Response' object stored in a
--- 'Snap' monad. Note that the target URL is not validated in any way. Consider
+-- 'SnapT' monad. Note that the target URL is not validated in any way.
Consider
-- using 'redirect\'' instead, which allows you to choose the correct status
-- code.
-redirect :: MonadSnap m => ByteString -> m ()
+redirect :: (MonadSnap im m, Monad im) => ByteString -> m ()
redirect target = redirect' target 302
{-# INLINE redirect #-}
@@ -428,9 +436,9 @@ redirect target = redirect' target 302
------------------------------------------------------------------------------
-- | Performs a redirect by setting the @Location@ header to the given target
-- URL/path and the status code (should be one of 301, 302, 303 or 307) in the
--- 'Response' object stored in a 'Snap' monad. Note that the target URL is not
+-- 'Response' object stored in a 'SnapT' monad. Note that the target URL is not
-- validated in any way.
-redirect' :: MonadSnap m => ByteString -> Int -> m ()
+redirect' :: (MonadSnap im m, Monad im) => ByteString -> Int -> m ()
redirect' target status = do
r <- getResponse
@@ -444,17 +452,17 @@ redirect' target status = do
------------------------------------------------------------------------------
--- | Log an error message in the 'Snap' monad
-logError :: MonadSnap m => ByteString -> m ()
-logError s = liftSnap $ Snap $ gets _snapLogError >>= (\l -> liftIO $ l s)
+-- | Log an error message in the 'SnapT' monad
+logError :: (MonadSnap im m, MonadIO im) => ByteString -> m ()
+logError s = liftSnap $ SnapT $ gets _snapLogError >>= (\l -> liftIO $ l s)
>> return (Just $ Right ())
{-# INLINE logError #-}
------------------------------------------------------------------------------
-- | Adds the output from the given enumerator to the 'Response'
--- stored in the 'Snap' monad state.
-addToOutput :: MonadSnap m
+-- stored in the 'SnapT' monad state.
+addToOutput :: (MonadSnap im m, Monad im)
=> (forall a . Enumerator ByteString IO a) -- ^ output to add
-> m ()
addToOutput enum = modifyResponse $ modifyResponseBody (>==> enum)
@@ -462,45 +470,45 @@ addToOutput enum = modifyResponse $ modifyResponseBody
(>==> enum)
------------------------------------------------------------------------------
-- | Adds the given strict 'ByteString' to the body of the 'Response' stored in
--- the 'Snap' monad state.
+-- the 'SnapT' monad state.
--
-- Warning: This function is intentionally non-strict. If any pure
-- exceptions are raised by the expression creating the 'ByteString',
-- the exception won't actually be raised within the Snap handler.
-writeBS :: MonadSnap m => ByteString -> m ()
+writeBS :: (MonadSnap im m, Monad im) => ByteString -> m ()
writeBS s = addToOutput $ enumBS s
------------------------------------------------------------------------------
-- | Adds the given lazy 'L.ByteString' to the body of the 'Response' stored in
--- the 'Snap' monad state.
+-- the 'SnapT' monad state.
--
-- Warning: This function is intentionally non-strict. If any pure
-- exceptions are raised by the expression creating the 'ByteString',
-- the exception won't actually be raised within the Snap handler.
-writeLBS :: MonadSnap m => L.ByteString -> m ()
+writeLBS :: (MonadSnap im m, Monad im) => L.ByteString -> m ()
writeLBS s = addToOutput $ enumLBS s
------------------------------------------------------------------------------
-- | Adds the given strict 'T.Text' to the body of the 'Response' stored in the
--- 'Snap' monad state.
+-- 'SnapT' monad state.
--
-- Warning: This function is intentionally non-strict. If any pure
-- exceptions are raised by the expression creating the 'ByteString',
-- the exception won't actually be raised within the Snap handler.
-writeText :: MonadSnap m => T.Text -> m ()
+writeText :: (MonadSnap im m, Monad im) => T.Text -> m ()
writeText s = writeBS $ T.encodeUtf8 s
------------------------------------------------------------------------------
-- | Adds the given lazy 'LT.Text' to the body of the 'Response' stored in the
--- 'Snap' monad state.
+-- 'SnapT' monad state.
--
-- Warning: This function is intentionally non-strict. If any pure
-- exceptions are raised by the expression creating the 'ByteString',
-- the exception won't actually be raised within the Snap handler.
-writeLazyText :: MonadSnap m => LT.Text -> m ()
+writeLazyText :: (MonadSnap im m, Monad im) => LT.Text -> m ()
writeLazyText s = writeLBS $ LT.encodeUtf8 s
@@ -514,7 +522,7 @@ writeLazyText s = writeLBS $ LT.encodeUtf8 s
--
-- If the response body is modified (using 'modifyResponseBody'), the file will
-- be read using @mmap()@.
-sendFile :: (MonadSnap m) => FilePath -> m ()
+sendFile :: (MonadSnap im m, Monad im) => FilePath -> m ()
sendFile f = modifyResponse $ \r -> r { rspBody = SendFile f Nothing }
@@ -529,16 +537,16 @@ sendFile f = modifyResponse $ \r -> r { rspBody =
SendFile f Nothing }
--
-- If the response body is modified (using 'modifyResponseBody'), the file will
-- be read using @mmap()@.
-sendFilePartial :: (MonadSnap m) => FilePath -> (Int64,Int64) -> m ()
+sendFilePartial :: (MonadSnap im m, Monad im) => FilePath -> (Int64,Int64) ->
m ()
sendFilePartial f rng = modifyResponse $ \r ->
r { rspBody = SendFile f (Just rng) }
------------------------------------------------------------------------------
--- | Runs a 'Snap' action with a locally-modified 'Request' state
--- object. The 'Request' object in the Snap monad state after the call
+-- | Runs a 'SnapT' action with a locally-modified 'Request' state
+-- object. The 'Request' object in the SnapT monad state after the call
-- to localRequest will be unchanged.
-localRequest :: MonadSnap m => (Request -> Request) -> m a -> m a
+localRequest :: (MonadSnap im m, Monad im) => (Request -> Request) -> m a -> m
a
localRequest f m = do
req <- getRequest
@@ -555,14 +563,14 @@ localRequest f m = do
------------------------------------------------------------------------------
-- | Fetches the 'Request' from state and hands it to the given action.
-withRequest :: MonadSnap m => (Request -> m a) -> m a
+withRequest :: (MonadSnap im m, Monad im) => (Request -> m a) -> m a
withRequest = (getRequest >>=)
{-# INLINE withRequest #-}
------------------------------------------------------------------------------
-- | Fetches the 'Response' from state and hands it to the given action.
-withResponse :: MonadSnap m => (Response -> m a) -> m a
+withResponse :: (MonadSnap im m, Monad im) => (Response -> m a) -> m a
withResponse = (getResponse >>=)
{-# INLINE withResponse #-}
@@ -580,7 +588,7 @@ withResponse = (getResponse >>=)
-- address can get it in a uniform manner. It has specifically limited
-- functionality to ensure that its transformation can be trusted,
-- when used correctly.
-ipHeaderFilter :: MonadSnap m => m ()
+ipHeaderFilter :: (MonadSnap im m, Monad im) => m ()
ipHeaderFilter = ipHeaderFilter' "x-forwarded-for"
@@ -597,7 +605,7 @@ ipHeaderFilter = ipHeaderFilter' "x-forwarded-for"
-- address can get it in a uniform manner. It has specifically limited
-- functionality to ensure that its transformation can be trusted,
-- when used correctly.
-ipHeaderFilter' :: MonadSnap m => CIB.CIByteString -> m ()
+ipHeaderFilter' :: (MonadSnap im m, Monad im) => CIB.CIByteString -> m ()
ipHeaderFilter' header = do
headerContents <- getHeader header <$> getRequest
@@ -629,11 +637,12 @@ ipHeaderFilter' header = do
-- 2. Short-circuit completion, either from calling 'fail' or 'finishWith'
--
-- 3. An exception being thrown.
-bracketSnap :: IO a -> (a -> IO b) -> (a -> Snap c) -> Snap c
-bracketSnap before after thing = block . Snap $ do
+bracketSnap :: (Monad m, MonadCatchIO m, Functor m) -- Not sure why Functor
+ => IO a -> (a -> IO b) -> (a -> SnapT m c) -> SnapT m c
+bracketSnap before after thing = block . SnapT $ do
a <- liftIO before
let after' = liftIO $ after a
- (Snap thing') = thing a
+ (SnapT thing') = thing a
r <- unblock thing' `onException` after'
_ <- after'
return r
@@ -655,12 +664,13 @@ instance Exception NoHandlerException
------------------------------------------------------------------------------
--- | Runs a 'Snap' monad action in the 'Iteratee IO' monad.
-runSnap :: Snap a
+-- | Runs a 'SnapT' monad action in the 'Iteratee IO' monad.
+runSnap :: (MonadIO m)
+ => SnapT m a
-> (ByteString -> IO ())
-> Request
- -> Iteratee ByteString IO (Request,Response)
-runSnap (Snap m) logerr req = do
+ -> Iteratee ByteString m (Request,Response)
+runSnap (SnapT m) logerr req = do
(r, ss') <- runStateT m ss
e <- maybe (return $ Left fourohfour)
@@ -687,11 +697,12 @@ runSnap (Snap m) logerr req = do
------------------------------------------------------------------------------
-evalSnap :: Snap a
+evalSnap :: (MonadIO m)
+ => SnapT m a
-> (ByteString -> IO ())
-> Request
- -> Iteratee ByteString IO a
-evalSnap (Snap m) logerr req = do
+ -> Iteratee ByteString m a
+evalSnap (SnapT m) logerr req = do
(r, _) <- runStateT m ss
e <- maybe (liftIO $ throwIO NoHandlerException)
@@ -716,7 +727,7 @@ evalSnap (Snap m) logerr req = do
--
-- @ 'S.intercalate' \" \"@
--
-getParam :: MonadSnap m
+getParam :: (MonadSnap im m, Monad im)
=> ByteString -- ^ parameter name to look up
-> m (Maybe ByteString)
getParam k = do
@@ -726,7 +737,7 @@ getParam k = do
------------------------------------------------------------------------------
-- | Gets the HTTP 'Cookie' with the specified name.
-getCookie :: MonadSnap m
+getCookie :: (MonadSnap im m, Monad im)
=> ByteString
-> m (Maybe Cookie)
getCookie name = withRequest $
diff --git a/src/Snap/Iteratee.hs b/src/Snap/Iteratee.hs
index 8148628..1caad79 100644
--- a/src/Snap/Iteratee.hs
+++ b/src/Snap/Iteratee.hs
@@ -286,7 +286,7 @@ unsafeBufferIterateeWithBuffer buf iter = Iteratee $ do
return $ copyStep step2
- go !n !k ch@(Chunks xs) = Iteratee $ do
+ go !n !k (Chunks xs) = Iteratee $ do
assert (n >= 0) (return ())
assert (n <= bUFSIZ) (return ())
diff --git a/src/Snap/Types.hs b/src/Snap/Types.hs
index d3113d1..353bd45 100644
--- a/src/Snap/Types.hs
+++ b/src/Snap/Types.hs
@@ -7,7 +7,7 @@ for HTTP as well as the 'Snap' monad, which is used for web
handlers.
module Snap.Types
(
-- * The Snap Monad
- Snap
+ SnapT
, runSnap
, MonadSnap(..)
, NoHandlerException(..)
diff --git a/src/Snap/Util/FileServe.hs b/src/Snap/Util/FileServe.hs
index 8d98fce..971e7bd 100644
--- a/src/Snap/Util/FileServe.hs
+++ b/src/Snap/Util/FileServe.hs
@@ -1,5 +1,6 @@
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
+{-# LANGUAGE PackageImports #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
@@ -16,6 +17,8 @@ module Snap.Util.FileServe
) where
------------------------------------------------------------------------------
+import "MonadCatchIO-transformers" Control.Monad.CatchIO
+
import Control.Applicative
import Control.Monad
import Control.Monad.Trans
@@ -167,7 +170,7 @@ defaultMimeTypes = Map.fromList [
-- | Gets a path from the 'Request' using 'rqPathInfo' and makes sure it is
-- safe to use for opening files. A path is safe if it is a relative path
-- and has no ".." elements to escape the intended directory structure.
-getSafePath :: MonadSnap m => m FilePath
+getSafePath :: (MonadSnap im m, Monad im) => m FilePath
getSafePath = do
req <- getRequest
let p = S.unpack $ rqPathInfo req
@@ -190,7 +193,7 @@ getSafePath = do
--
-- Uses 'defaultMimeTypes' to determine the @Content-Type@ based on the file's
-- extension.
-fileServe :: MonadSnap m
+fileServe :: (MonadSnap im m, Monad im, MonadCatchIO im, Functor im)
=> FilePath -- ^ root directory
-> m ()
fileServe = fileServe' defaultMimeTypes
@@ -199,7 +202,7 @@ fileServe = fileServe' defaultMimeTypes
------------------------------------------------------------------------------
-- | Same as 'fileServe', with control over the MIME mapping used.
-fileServe' :: MonadSnap m
+fileServe' :: (MonadSnap im m, Monad im, MonadCatchIO im, Functor im)
=> MimeMap -- ^ MIME type mapping
-> FilePath -- ^ root directory
-> m ()
@@ -220,7 +223,7 @@ fileServe' mm root = do
-- | Serves a single file specified by a full or relative path. The
-- path restrictions on fileServe don't apply to this function since
-- the path is not being supplied by the user.
-fileServeSingle :: MonadSnap m
+fileServeSingle :: (MonadSnap im m, MonadCatchIO im, Functor im)
=> FilePath -- ^ path to file
-> m ()
fileServeSingle fp =
@@ -230,7 +233,7 @@ fileServeSingle fp =
------------------------------------------------------------------------------
-- | Same as 'fileServeSingle', with control over the MIME mapping used.
-fileServeSingle' :: MonadSnap m
+fileServeSingle' :: (MonadSnap im m, MonadCatchIO im, Functor im)
=> ByteString -- ^ MIME type mapping
-> FilePath -- ^ path to file
-> m ()
@@ -345,7 +348,8 @@ rangeParser = string "bytes=" *>
------------------------------------------------------------------------------
-checkRangeReq :: (MonadSnap m) => Request -> FilePath -> Int64 -> m Bool
+checkRangeReq :: ((MonadSnap im m, Monad im)) => Request -> FilePath -> Int64
+ -> m Bool
checkRangeReq req fp sz = do
-- TODO/FIXME: multiple ranges
dbg $ "checkRangeReq, fp=" ++ fp ++ ", sz=" ++ Prelude.show sz
diff --git a/src/Snap/Util/GZip.hs b/src/Snap/Util/GZip.hs
index c658e09..13c78b0 100644
--- a/src/Snap/Util/GZip.hs
+++ b/src/Snap/Util/GZip.hs
@@ -61,7 +61,7 @@ import Snap.Types
-- that's contained within the 'Snap' monad state will be passed to
-- 'finishWith' to prevent further processing.
--
-withCompression :: MonadSnap m
+withCompression :: (MonadSnap im m, Monad im)
=> m a -- ^ the web handler to run
-> m ()
withCompression = withCompression' compressibleMimeTypes
@@ -70,7 +70,7 @@ withCompression = withCompression' compressibleMimeTypes
------------------------------------------------------------------------------
-- | The same as 'withCompression', with control over which MIME types to
-- compress.
-withCompression' :: MonadSnap m
+withCompression' :: (MonadSnap im m, Monad im)
=> Set ByteString
-- ^ set of compressible MIME types
-> m a
@@ -134,7 +134,7 @@ compressibleMimeTypes = Set.fromList [
"application/x-font-truetype"
------------------------------------------------------------------------------
-gzipCompression :: MonadSnap m => ByteString -> m ()
+gzipCompression :: (MonadSnap im m, Monad im) => ByteString -> m ()
gzipCompression ce = modifyResponse f
where
f = setHeader "Content-Encoding" ce .
@@ -144,7 +144,7 @@ gzipCompression ce = modifyResponse f
------------------------------------------------------------------------------
-compressCompression :: MonadSnap m => ByteString -> m ()
+compressCompression :: (MonadSnap im m, Monad im) => ByteString -> m ()
compressCompression ce = modifyResponse f
where
f = setHeader "Content-Encoding" ce .
-----------------------------------------------------------------------
hooks/post-receive
--
snap-core
_______________________________________________
Snap mailing list
[email protected]
http://mailman-mail5.webfaction.com/listinfo/snap
