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, 0.3 has been updated
via 03f10c85207022df080b63b989cd9d14791d67cd (commit)
via c3aa514565064b0a4e97e28c0580cea06d2d1bb4 (commit)
via d13de1fb89133b8a856f1ec1b3effb2c42055673 (commit)
via 5e5750e9500dde19680dcd239797472aac368c9e (commit)
from 1197d61574b083de4aff099c0ccecb82f949b437 (commit)
Summary of changes:
src/Snap/Internal/Routing.hs | 29 ++++---
src/Snap/Internal/Types.hs | 184 +++++++++++++++++++++++++++++++-----------
src/Snap/Types.hs | 1 +
src/Snap/Util/FileServe.hs | 22 +++--
src/Snap/Util/GZip.hs | 17 ++--
5 files changed, 177 insertions(+), 76 deletions(-)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit 03f10c85207022df080b63b989cd9d14791d67cd
Author: Shane <[email protected]>
Date: Wed Jun 30 18:34:45 2010 +0100
Okay, actually resolved merge conflicts this time.
diff --git a/snap-core.cabal b/snap-core.cabal
index ba63ca4..c935b80 100644
--- a/snap-core.cabal
+++ b/snap-core.cabal
@@ -73,16 +73,6 @@ extra-source-files:
extra/logo.gif,
haddock.sh,
LICENSE,
-<<<<<<< HEAD
- project_template/barebones/foo.cabal,
- project_template/barebones/src/Main.hs,
- project_template/barebones/src/Server.hs,
- project_template/default/foo.cabal,
- project_template/default/src/Glue.hs,
- project_template/default/src/Main.hs,
- project_template/barebones/src/Server.hs,
-=======
->>>>>>> 1197d61574b083de4aff099c0ccecb82f949b437
README.md,
README.SNAP.md,
Setup.hs,
diff --git a/src/Snap/Internal/Types.hs b/src/Snap/Internal/Types.hs
index 8a7ab44..be3fb08 100644
--- a/src/Snap/Internal/Types.hs
+++ b/src/Snap/Internal/Types.hs
@@ -13,10 +13,13 @@ import Control.Monad.CatchIO
import Control.Monad.Cont
import Control.Monad.Error
import Control.Monad.List
-import Control.Monad.RWS hiding (pass)
+import Control.Monad.RWS.Strict hiding (pass)
+import qualified Control.Monad.RWS.Lazy as LRWS
import Control.Monad.Reader
import Control.Monad.State.Strict
-import Control.Monad.Writer hiding (pass)
+import qualified Control.Monad.State.Lazy as LState
+import Control.Monad.Writer.Strict hiding (pass)
+import qualified Control.Monad.Writer.Lazy as LWriter
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as S
import qualified Data.ByteString.Lazy.Char8 as L
@@ -173,13 +176,13 @@ instance MonadSnap Snap where
------------------------------------------------------------------------------
-instance MonadSnap m => MonadPlus (ContT c m) where
+instance MonadPlus m => MonadPlus (ContT c m) where
mzero = lift mzero
m `mplus` n = ContT $ \ f -> runContT m f `mplus` runContT n f
------------------------------------------------------------------------------
-instance MonadSnap m => Alternative (ContT c m) where
+instance MonadPlus m => Alternative (ContT c m) where
empty = mzero
(<|>) = mplus
@@ -205,6 +208,11 @@ instance (MonadSnap m, Monoid w) => MonadSnap (RWST r w s
m) where
------------------------------------------------------------------------------
+instance (MonadSnap m, Monoid w) => MonadSnap (LRWS.RWST r w s m) where
+ liftSnap = lift . liftSnap
+
+
+------------------------------------------------------------------------------
instance MonadSnap m => MonadSnap (ReaderT r m) where
liftSnap = lift . liftSnap
@@ -215,11 +223,21 @@ instance MonadSnap m => MonadSnap (StateT s m) where
------------------------------------------------------------------------------
+instance MonadSnap m => MonadSnap (LState.StateT s m) where
+ liftSnap = lift . liftSnap
+
+
+------------------------------------------------------------------------------
instance (MonadSnap m, Monoid w) => MonadSnap (WriterT w m) where
liftSnap = lift . liftSnap
------------------------------------------------------------------------------
+instance (MonadSnap m, Monoid w) => MonadSnap (LWriter.WriterT w m) where
+ liftSnap = lift . liftSnap
+
+
+------------------------------------------------------------------------------
-- | The Typeable instance is here so Snap can be dynamically executed with
-- Hint.
snapTyCon :: TyCon
@@ -291,13 +309,8 @@ unsafeDetachRequestBody = do
------------------------------------------------------------------------------
-- | Short-circuits a 'Snap' monad action early, storing the given
-- 'Response' value in its state.
-<<<<<<< HEAD
finishWith :: MonadSnap m => Response -> m ()
finishWith = liftSnap . Snap . return . Just . Left
-=======
-finishWith :: Response -> Snap a
-finishWith = Snap . return . Just . Left
->>>>>>> 1197d61574b083de4aff099c0ccecb82f949b437
{-# INLINE finishWith #-}
commit c3aa514565064b0a4e97e28c0580cea06d2d1bb4
Merge: d13de1f 1197d61
Author: Shane <[email protected]>
Date: Wed Jun 30 18:17:48 2010 +0100
Merge branch '0.3' of git.snapframework.com:snap-core into 0.3
Conflicts:
project_template/barebones/src/Main.hs
project_template/barebones/src/Server.hs
project_template/default/foo.cabal
project_template/default/src/Glue.hs
project_template/default/src/Main.hs
project_template/default/src/Server.hs
snap-core.cabal
src/Snap/Internal/Types.hs
diff --cc snap-core.cabal
index 52fdc5c,c935b80..ba63ca4
--- a/snap-core.cabal
+++ b/snap-core.cabal
@@@ -73,13 -73,6 +73,16 @@@ extra-source-files
extra/logo.gif,
haddock.sh,
LICENSE,
++<<<<<<< HEAD
+ project_template/barebones/foo.cabal,
+ project_template/barebones/src/Main.hs,
+ project_template/barebones/src/Server.hs,
+ project_template/default/foo.cabal,
+ project_template/default/src/Glue.hs,
+ project_template/default/src/Main.hs,
+ project_template/barebones/src/Server.hs,
++=======
++>>>>>>> 1197d61574b083de4aff099c0ccecb82f949b437
README.md,
README.SNAP.md,
Setup.hs,
diff --cc src/Snap/Internal/Types.hs
index 6a3000a,67a6461..8a7ab44
--- a/src/Snap/Internal/Types.hs
+++ b/src/Snap/Internal/Types.hs
@@@ -291,8 -224,8 +291,13 @@@ unsafeDetachRequestBody = d
------------------------------------------------------------------------------
-- | Short-circuits a 'Snap' monad action early, storing the given
-- 'Response' value in its state.
++<<<<<<< HEAD
+finishWith :: MonadSnap m => Response -> m ()
+finishWith = liftSnap . Snap . return . Just . Left
++=======
+ finishWith :: Response -> Snap a
+ finishWith = Snap . return . Just . Left
++>>>>>>> 1197d61574b083de4aff099c0ccecb82f949b437
{-# INLINE finishWith #-}
commit d13de1fb89133b8a856f1ec1b3effb2c42055673
Author: Shane <[email protected]>
Date: Sun Jun 27 11:42:48 2010 +0100
Added MonadSnap class and instances for common transformers.
diff --git a/project_template/barebones/src/Main.hs
b/project_template/barebones/src/Main.hs
index 1c72738..c48d65e 100644
--- a/project_template/barebones/src/Main.hs
+++ b/project_template/barebones/src/Main.hs
@@ -8,7 +8,7 @@ import Snap.Util.FileServe
import Server
main :: IO ()
-main = quickServer $
+main = quickServer id $
ifTop (writeBS "hello world") <|>
route [ ("foo", writeBS "bar")
, ("echo/:echoparam", echoHandler)
diff --git a/project_template/barebones/src/Server.hs
b/project_template/barebones/src/Server.hs
index 2dd625b..0db3778 100644
--- a/project_template/barebones/src/Server.hs
+++ b/project_template/barebones/src/Server.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes #-}
module Server
( ServerConfig(..)
, emptyServerConfig
@@ -30,7 +31,7 @@ data ServerConfig = ServerConfig
, accessLog :: Maybe FilePath
, errorLog :: Maybe FilePath
, compression :: Bool
- , error500Handler :: SomeException -> Snap ()
+ , error500Handler :: MonadSnap m => SomeException -> m ()
}
@@ -68,8 +69,8 @@ commandLineConfig = do
Nothing -> conf
Just l -> conf {locale = takeWhile (\c -> isAlpha c || c == '_') l}
-server :: ServerConfig -> Snap () -> IO ()
-server config handler = do
+server :: MonadSnap m => ServerConfig -> (m () -> Snap ()) -> m () -> IO ()
+server config f handler = do
putStrLn $ "Listening on " ++ (B.unpack $ interface config)
++ ":" ++ show (port config)
setUTF8Locale (locale config)
@@ -79,7 +80,7 @@ server config handler = do
(hostname config)
(accessLog config)
(errorLog config)
- (catch500 $ compress $ handler)
+ (f $ catch500 $ compress $ handler)
:: IO (Either SomeException ())
threadDelay 1000000
putStrLn "Shutting down"
@@ -88,8 +89,8 @@ server config handler = do
compress = if compression config then withCompression else id
-quickServer :: Snap () -> IO ()
-quickServer = (commandLineConfig >>=) . flip server
+quickServer :: MonadSnap m => (m () -> Snap ()) -> m () -> IO ()
+quickServer f a = commandLineConfig >>= (\c -> server c f a)
setUTF8Locale :: String -> IO ()
diff --git a/project_template/default/foo.cabal
b/project_template/default/foo.cabal
index d3e3b7b..33be9fc 100644
--- a/project_template/default/foo.cabal
+++ b/project_template/default/foo.cabal
@@ -21,7 +21,7 @@ Executable projname
bytestring >= 0.9.1 && <0.10,
snap-core >= 0.2 && <0.3,
snap-server >= 0.2 && <0.3,
- heist >= 0.2.2 && <0.3,
+ heist >= 0.2.3 && <0.3,
hexpat == 0.16,
xhtml-combinators,
unix,
diff --git a/project_template/default/src/Glue.hs
b/project_template/default/src/Glue.hs
index e6a789c..8efddb6 100644
--- a/project_template/default/src/Glue.hs
+++ b/project_template/default/src/Glue.hs
@@ -17,21 +17,22 @@ import Text.Templating.Heist
import Text.Templating.Heist.TemplateDirectory
-templateHandler :: TemplateDirectory Snap
- -> (TemplateDirectory Snap -> Snap ())
- -> (TemplateState Snap -> Snap ())
- -> Snap ()
+templateHandler :: MonadSnap m
+ => TemplateDirectory m
+ -> (TemplateDirectory m -> m ())
+ -> (TemplateState m -> m ())
+ -> m ()
templateHandler td reload f = reload td <|> (f =<< getDirectoryTS td)
-defaultReloadHandler :: TemplateDirectory Snap -> Snap ()
+defaultReloadHandler :: MonadSnap m => TemplateDirectory m -> m ()
defaultReloadHandler td = path "admin/reload" $ do
e <- reloadTemplateDirectory td
modifyResponse $ setContentType "text/plain; charset=utf-8"
writeBS . B.pack $ either id (const "Templates loaded successfully.") e
-render :: TemplateState Snap -> ByteString -> Snap ()
+render :: MonadSnap m => TemplateState m -> ByteString -> m ()
render ts template = do
bytes <- renderTemplate ts template
flip (maybe pass) bytes $ \x -> do
@@ -39,7 +40,7 @@ render ts template = do
writeBS x
-templateServe :: TemplateState Snap -> Snap ()
+templateServe :: MonadSnap m => TemplateState m -> m ()
templateServe ts = ifTop (render ts "index") <|> do
path' <- getSafePath
when (head path' == '_') pass
diff --git a/project_template/default/src/Main.hs
b/project_template/default/src/Main.hs
index 3254b3b..9117d13 100644
--- a/project_template/default/src/Main.hs
+++ b/project_template/default/src/Main.hs
@@ -14,7 +14,7 @@ import Server
main :: IO ()
main = do
td <- newTemplateDirectory' "templates" emptyTemplateState
- quickServer $ templateHandler td defaultReloadHandler $ \ts ->
+ quickServer id $ templateHandler td defaultReloadHandler $ \ts ->
ifTop (writeBS "hello world") <|>
route [ ("foo", writeBS "bar")
, ("echo/:echoparam", echoHandler)
diff --git a/project_template/default/src/Server.hs
b/project_template/default/src/Server.hs
index 2dd625b..0db3778 100644
--- a/project_template/default/src/Server.hs
+++ b/project_template/default/src/Server.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes #-}
module Server
( ServerConfig(..)
, emptyServerConfig
@@ -30,7 +31,7 @@ data ServerConfig = ServerConfig
, accessLog :: Maybe FilePath
, errorLog :: Maybe FilePath
, compression :: Bool
- , error500Handler :: SomeException -> Snap ()
+ , error500Handler :: MonadSnap m => SomeException -> m ()
}
@@ -68,8 +69,8 @@ commandLineConfig = do
Nothing -> conf
Just l -> conf {locale = takeWhile (\c -> isAlpha c || c == '_') l}
-server :: ServerConfig -> Snap () -> IO ()
-server config handler = do
+server :: MonadSnap m => ServerConfig -> (m () -> Snap ()) -> m () -> IO ()
+server config f handler = do
putStrLn $ "Listening on " ++ (B.unpack $ interface config)
++ ":" ++ show (port config)
setUTF8Locale (locale config)
@@ -79,7 +80,7 @@ server config handler = do
(hostname config)
(accessLog config)
(errorLog config)
- (catch500 $ compress $ handler)
+ (f $ catch500 $ compress $ handler)
:: IO (Either SomeException ())
threadDelay 1000000
putStrLn "Shutting down"
@@ -88,8 +89,8 @@ server config handler = do
compress = if compression config then withCompression else id
-quickServer :: Snap () -> IO ()
-quickServer = (commandLineConfig >>=) . flip server
+quickServer :: MonadSnap m => (m () -> Snap ()) -> m () -> IO ()
+quickServer f a = commandLineConfig >>= (\c -> server c f a)
setUTF8Locale :: String -> IO ()
diff --git a/src/Snap/Internal/Routing.hs b/src/Snap/Internal/Routing.hs
index 956b048..b6427b4 100644
--- a/src/Snap/Internal/Routing.hs
+++ b/src/Snap/Internal/Routing.hs
@@ -1,3 +1,5 @@
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE FlexibleContexts #-}
module Snap.Internal.Routing where
@@ -34,14 +36,14 @@ 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 = Action (Snap a) -- wraps a 'Snap' action
- | Capture ByteString (Route a) (Route a) -- captures the dir in a
param
- | Dir (Map.Map ByteString (Route a)) (Route a) -- match on a dir
- | NoRoute
+data Route a m = Action ((MonadSnap 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
------------------------------------------------------------------------------
-instance Monoid (Route a) where
+instance Monoid (Route a m) where
mempty = NoRoute
mappend NoRoute r = r
@@ -81,14 +83,14 @@ instance Monoid (Route a) where
------------------------------------------------------------------------------
-routeHeight :: Route a -> Int
+routeHeight :: Route a m -> Int
routeHeight r = case r of
NoRoute -> 1
(Action _) -> 1
(Capture _ r' _) -> 1+routeHeight r'
(Dir rm _) -> 1+foldl max 1 (map routeHeight $ Map.elems rm)
-routeEarliestNC :: Route a -> Int -> Int
+routeEarliestNC :: Route a m -> Int -> Int
routeEarliestNC r n = case r of
NoRoute -> n
(Action _) -> n
@@ -145,7 +147,7 @@ routeEarliestNC r n = case r of
-- > , ("article/:id", renderArticle)
-- > , ("login", method POST doLogin) ]
--
-route :: [(ByteString, Snap a)] -> Snap a
+route :: MonadSnap m => [(ByteString, m a)] -> m a
route rts = do
p <- getRequest >>= return . rqPathInfo
route' (return ()) ([], splitPath p) Map.empty rts'
@@ -158,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 :: [(ByteString, Snap a)] -> Snap a
+routeLocal :: MonadSnap m => [(ByteString, m a)] -> m a
routeLocal rts = do
req <- getRequest
let ctx = rqContextPath req
@@ -176,7 +178,7 @@ splitPath = B.splitWith (== (c2w '/'))
------------------------------------------------------------------------------
-pRoute :: (ByteString, Snap a) -> Route a
+pRoute :: MonadSnap 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
@@ -186,11 +188,12 @@ pRoute (r, a) = foldr f (Action a) hier
------------------------------------------------------------------------------
-route' :: Snap ()
+route' :: MonadSnap m
+ => m ()
-> ([ByteString], [ByteString])
-> Params
- -> Route a
- -> Snap a
+ -> Route a m
+ -> m a
route' pre (ctx, _) params (Action action) =
localRequest (updateContextPath (B.length ctx') . updateParams)
(pre >> action)
diff --git a/src/Snap/Internal/Types.hs b/src/Snap/Internal/Types.hs
index bcf3931..6a3000a 100644
--- a/src/Snap/Internal/Types.hs
+++ b/src/Snap/Internal/Types.hs
@@ -2,6 +2,7 @@
{-# LANGUAGE EmptyDataDecls #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE FlexibleInstances #-}
module Snap.Internal.Types where
@@ -9,7 +10,13 @@ module Snap.Internal.Types where
import Control.Applicative
import Control.Exception (throwIO, ErrorCall(..))
import Control.Monad.CatchIO
+import Control.Monad.Cont
+import Control.Monad.Error
+import Control.Monad.List
+import Control.Monad.RWS hiding (pass)
+import Control.Monad.Reader
import Control.Monad.State.Strict
+import Control.Monad.Writer hiding (pass)
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as S
import qualified Data.ByteString.Lazy.Char8 as L
@@ -21,6 +28,7 @@ import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Data.Text.Lazy as LT
import qualified Data.Text.Lazy.Encoding as LT
+import Prelude hiding (catch)
import Data.Typeable
@@ -81,6 +89,12 @@ import Snap.Internal.Http.Types
> a = liftIO fireTheMissiles
-}
+------------------------------------------------------------------------------
+-- | '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
------------------------------------------------------------------------------
newtype Snap a = Snap {
@@ -152,6 +166,59 @@ instance Alternative Snap where
empty = mzero
(<|>) = mplus
+
+------------------------------------------------------------------------------
+instance MonadSnap Snap where
+ liftSnap = id
+
+
+------------------------------------------------------------------------------
+instance MonadSnap m => MonadPlus (ContT c m) where
+ mzero = lift mzero
+ m `mplus` n = ContT $ \ f -> runContT m f `mplus` runContT n f
+
+
+------------------------------------------------------------------------------
+instance MonadSnap m => Alternative (ContT c m) where
+ empty = mzero
+ (<|>) = mplus
+
+
+------------------------------------------------------------------------------
+instance MonadSnap m => MonadSnap (ContT c m) where
+ liftSnap = lift . liftSnap
+
+
+------------------------------------------------------------------------------
+instance (MonadSnap m, Error e) => MonadSnap (ErrorT e m) where
+ liftSnap = lift . liftSnap
+
+
+------------------------------------------------------------------------------
+instance MonadSnap m => MonadSnap (ListT m) where
+ liftSnap = lift . liftSnap
+
+
+------------------------------------------------------------------------------
+instance (MonadSnap m, Monoid w) => MonadSnap (RWST r w s m) where
+ liftSnap = lift . liftSnap
+
+
+------------------------------------------------------------------------------
+instance MonadSnap m => MonadSnap (ReaderT r m) where
+ liftSnap = lift . liftSnap
+
+
+------------------------------------------------------------------------------
+instance MonadSnap m => MonadSnap (StateT s m) where
+ liftSnap = lift . liftSnap
+
+
+------------------------------------------------------------------------------
+instance (MonadSnap m, Monoid w) => MonadSnap (WriterT w m) where
+ liftSnap = lift . liftSnap
+
+
------------------------------------------------------------------------------
-- | The Typeable instance is here so Snap can be dynamically executed with
-- Hint.
@@ -164,14 +231,14 @@ instance Typeable1 Snap where
------------------------------------------------------------------------------
-liftIter :: Iteratee IO a -> Snap a
-liftIter i = Snap (lift i >>= return . Just . Right)
+liftIter :: MonadSnap m => Iteratee IO a -> m a
+liftIter i = liftSnap $ Snap (lift i >>= return . Just . Right)
------------------------------------------------------------------------------
-- | Sends the request body through an iteratee (data consumer) and
-- returns the result.
-runRequestBody :: Iteratee IO a -> Snap a
+runRequestBody :: MonadSnap m => Iteratee IO a -> m a
runRequestBody iter = do
req <- getRequest
senum <- liftIO $ readIORef $ rqBody req
@@ -193,7 +260,7 @@ runRequestBody iter = do
------------------------------------------------------------------------------
-- | Returns the request body as a bytestring.
-getRequestBody :: Snap L.ByteString
+getRequestBody :: MonadSnap m => m L.ByteString
getRequestBody = liftM fromWrap $ runRequestBody stream2stream
{-# INLINE getRequestBody #-}
@@ -224,8 +291,8 @@ unsafeDetachRequestBody = do
------------------------------------------------------------------------------
-- | Short-circuits a 'Snap' monad action early, storing the given
-- 'Response' value in its state.
-finishWith :: Response -> Snap ()
-finishWith = Snap . return . Just . Left
+finishWith :: MonadSnap m => Response -> m ()
+finishWith = liftSnap . Snap . return . Just . Left
{-# INLINE finishWith #-}
@@ -233,14 +300,14 @@ finishWith = Snap . return . Just . Left
-- | Fails out of a 'Snap' monad action. This is used to indicate
-- that you choose not to handle the given request within the given
-- handler.
-pass :: Snap a
+pass :: MonadSnap m => m a
pass = empty
------------------------------------------------------------------------------
-- | Runs a 'Snap' monad action only if the request's HTTP method matches
-- the given method.
-method :: Method -> Snap a -> Snap a
+method :: MonadSnap m => Method -> m a -> m a
method m action = do
req <- getRequest
unless (rqMethod req == m) pass
@@ -264,10 +331,11 @@ updateContextPath n req | n > 0 = req { rqContextPath
= ctx
------------------------------------------------------------------------------
-- Runs a 'Snap' monad action only if the 'rqPathInfo' matches the given
-- predicate.
-pathWith :: (ByteString -> ByteString -> Bool)
+pathWith :: MonadSnap m
+ => (ByteString -> ByteString -> Bool)
-> ByteString
- -> Snap a
- -> Snap a
+ -> m a
+ -> m a
pathWith c p action = do
req <- getRequest
unless (c p (rqPathInfo req)) pass
@@ -282,9 +350,10 @@ pathWith c p action = do
--
-- Will fail if 'rqPathInfo' is not \"@\/f...@\" or \"@\/foo\/....@\", and will
-- add @\"foo\/\"@ to the handler's local 'rqContextPath'.
-dir :: ByteString -- ^ path component to match
- -> Snap a -- ^ handler to run
- -> Snap a
+dir :: MonadSnap m
+ => ByteString -- ^ path component to match
+ -> m a -- ^ handler to run
+ -> m a
dir = pathWith f
where
f dr pinfo = dr == x
@@ -298,16 +367,17 @@ dir = pathWith f
-- 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 :: ByteString -- ^ path to match against
- -> Snap a -- ^ handler to run
- -> Snap a
+path :: MonadSnap m
+ => ByteString -- ^ path to match against
+ -> m a -- ^ handler to run
+ -> m a
path = pathWith (==)
{-# INLINE path #-}
------------------------------------------------------------------------------
-- | Runs a 'Snap' monad action only when 'rqPathInfo' is empty.
-ifTop :: Snap a -> Snap a
+ifTop :: MonadSnap m => m a -> m a
ifTop = path ""
{-# INLINE ifTop #-}
@@ -328,50 +398,52 @@ smodify f = Snap $ modify f >> return (Just $ Right ())
------------------------------------------------------------------------------
-- | Grabs the 'Request' object out of the 'Snap' monad.
-getRequest :: Snap Request
-getRequest = liftM _snapRequest sget
+getRequest :: MonadSnap m => m Request
+getRequest = liftSnap $ liftM _snapRequest sget
{-# INLINE getRequest #-}
------------------------------------------------------------------------------
-- | Grabs the 'Response' object out of the 'Snap' monad.
-getResponse :: Snap Response
-getResponse = liftM _snapResponse sget
+getResponse :: MonadSnap m => m Response
+getResponse = liftSnap $ liftM _snapResponse sget
{-# INLINE getResponse #-}
------------------------------------------------------------------------------
-- | Puts a new 'Response' object into the 'Snap' monad.
-putResponse :: Response -> Snap ()
-putResponse r = smodify $ \ss -> ss { _snapResponse = r }
+putResponse :: MonadSnap m => Response -> m ()
+putResponse r = liftSnap $ smodify $ \ss -> ss { _snapResponse = r }
{-# INLINE putResponse #-}
------------------------------------------------------------------------------
-- | Puts a new 'Request' object into the 'Snap' monad.
-putRequest :: Request -> Snap ()
-putRequest r = smodify $ \ss -> ss { _snapRequest = r }
+putRequest :: MonadSnap m => Request -> m ()
+putRequest r = liftSnap $ smodify $ \ss -> ss { _snapRequest = r }
{-# INLINE putRequest #-}
------------------------------------------------------------------------------
-- | Modifies the 'Request' object stored in a 'Snap' monad.
-modifyRequest :: (Request -> Request) -> Snap ()
-modifyRequest f = smodify $ \ss -> ss { _snapRequest = f $ _snapRequest ss }
+modifyRequest :: MonadSnap m => (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 :: (Response -> Response) -> Snap ()
-modifyResponse f = smodify $ \ss -> ss { _snapResponse = f $ _snapResponse ss }
+modifyResponse :: MonadSnap m => (Response -> Response) -> m ()
+modifyResponse f = liftSnap $
+ smodify $ \ss -> ss { _snapResponse = f $ _snapResponse ss }
{-# INLINE modifyResponse #-}
------------------------------------------------------------------------------
-- | Log an error message in the 'Snap' monad
-logError :: ByteString -> Snap ()
-logError s = Snap $ gets _snapLogError >>= (\l -> liftIO $ l s)
+logError :: MonadSnap m => ByteString -> m ()
+logError s = liftSnap $ Snap $ gets _snapLogError >>= (\l -> liftIO $ l s)
>> return (Just $ Right ())
{-# INLINE logError #-}
@@ -379,36 +451,37 @@ logError s = Snap $ gets _snapLogError >>= (\l -> liftIO
$ l s)
------------------------------------------------------------------------------
-- | Adds the output from the given enumerator to the 'Response'
-- stored in the 'Snap' monad state.
-addToOutput :: (forall a . Enumerator a) -- ^ output to add
- -> Snap ()
+addToOutput :: MonadSnap m
+ => (forall a . Enumerator a) -- ^ output to add
+ -> m ()
addToOutput enum = modifyResponse $ modifyResponseBody (>. enum)
------------------------------------------------------------------------------
-- | Adds the given strict 'ByteString' to the body of the 'Response' stored in
-- the 'Snap' monad state.
-writeBS :: ByteString -> Snap ()
+writeBS :: MonadSnap m => 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.
-writeLBS :: L.ByteString -> Snap ()
+writeLBS :: MonadSnap m => 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.
-writeText :: T.Text -> Snap ()
+writeText :: MonadSnap m => 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.
-writeLazyText :: LT.Text -> Snap ()
+writeLazyText :: MonadSnap m => LT.Text -> m ()
writeLazyText s = writeLBS $ LT.encodeUtf8 s
@@ -422,7 +495,7 @@ writeLazyText s = writeLBS $ LT.encodeUtf8 s
--
-- If the response body is modified (using 'modifyResponseBody'), the file will
-- be read using @mmap()@.
-sendFile :: FilePath -> Snap ()
+sendFile :: MonadSnap m => FilePath -> m ()
sendFile f = modifyResponse $ \r -> r { rspBody = SendFile f }
@@ -430,7 +503,7 @@ sendFile f = modifyResponse $ \r -> r { rspBody = SendFile
f }
-- | Runs a 'Snap' action with a locally-modified 'Request' state
-- object. The 'Request' object in the Snap monad state after the call
-- to localRequest will be unchanged.
-localRequest :: (Request -> Request) -> Snap a -> Snap a
+localRequest :: MonadSnap m => (Request -> Request) -> m a -> m a
localRequest f m = do
req <- getRequest
@@ -447,14 +520,14 @@ localRequest f m = do
------------------------------------------------------------------------------
-- | Fetches the 'Request' from state and hands it to the given action.
-withRequest :: (Request -> Snap a) -> Snap a
+withRequest :: MonadSnap m => (Request -> m a) -> m a
withRequest = (getRequest >>=)
{-# INLINE withRequest #-}
------------------------------------------------------------------------------
-- | Fetches the 'Response' from state and hands it to the given action.
-withResponse :: (Response -> Snap a) -> Snap a
+withResponse :: MonadSnap m => (Response -> m a) -> m a
withResponse = (getResponse >>=)
{-# INLINE withResponse #-}
@@ -472,7 +545,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 :: Snap ()
+ipHeaderFilter :: MonadSnap m => m ()
ipHeaderFilter = ipHeaderFilter' "x-forwarded-for"
@@ -489,7 +562,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' :: CIB.CIByteString -> Snap ()
+ipHeaderFilter' :: MonadSnap m => CIB.CIByteString -> m ()
ipHeaderFilter' header = do
headerContents <- getHeader header <$> getRequest
@@ -579,8 +652,9 @@ evalSnap (Snap m) logerr req = do
--
-- @ 'S.intercalate' \" \"@
--
-getParam :: ByteString -- ^ parameter name to look up
- -> Snap (Maybe ByteString)
+getParam :: MonadSnap m
+ => ByteString -- ^ parameter name to look up
+ -> m (Maybe ByteString)
getParam k = do
rq <- getRequest
return $ liftM (S.intercalate " ") $ rqParam k rq
diff --git a/src/Snap/Types.hs b/src/Snap/Types.hs
index 31344d8..6a106d5 100644
--- a/src/Snap/Types.hs
+++ b/src/Snap/Types.hs
@@ -9,6 +9,7 @@ module Snap.Types
-- * The Snap Monad
Snap
, runSnap
+ , MonadSnap
, NoHandlerException(..)
-- ** Functions for control flow and early termination
diff --git a/src/Snap/Util/FileServe.hs b/src/Snap/Util/FileServe.hs
index 3a01289..4d68a5d 100644
--- a/src/Snap/Util/FileServe.hs
+++ b/src/Snap/Util/FileServe.hs
@@ -157,7 +157,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 :: Snap FilePath
+getSafePath :: MonadSnap m => m FilePath
getSafePath = do
req <- getRequest
let p = S.unpack $ rqPathInfo req
@@ -176,17 +176,19 @@ getSafePath = do
--
-- Uses 'defaultMimeTypes' to determine the @Content-Type@ based on the file's
-- extension.
-fileServe :: FilePath -- ^ root directory
- -> Snap ()
+fileServe :: MonadSnap m
+ => FilePath -- ^ root directory
+ -> m ()
fileServe = fileServe' defaultMimeTypes
{-# INLINE fileServe #-}
------------------------------------------------------------------------------
-- | Same as 'fileServe', with control over the MIME mapping used.
-fileServe' :: MimeMap -- ^ MIME type mapping
+fileServe' :: MonadSnap m
+ => MimeMap -- ^ MIME type mapping
-> FilePath -- ^ root directory
- -> Snap ()
+ -> m ()
fileServe' mm root = do
sp <- getSafePath
let fp = root </> sp
@@ -204,8 +206,9 @@ 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 :: FilePath -- ^ path to file
- -> Snap ()
+fileServeSingle :: MonadSnap m
+ => FilePath -- ^ path to file
+ -> m ()
fileServeSingle fp =
fileServeSingle' (fileType defaultMimeTypes (takeFileName fp)) fp
{-# INLINE fileServeSingle #-}
@@ -213,9 +216,10 @@ fileServeSingle fp =
------------------------------------------------------------------------------
-- | Same as 'fileServeSingle', with control over the MIME mapping used.
-fileServeSingle' :: ByteString -- ^ MIME type mapping
+fileServeSingle' :: MonadSnap m
+ => ByteString -- ^ MIME type mapping
-> FilePath -- ^ path to file
- -> Snap ()
+ -> m ()
fileServeSingle' mime fp = do
req <- getRequest
diff --git a/src/Snap/Util/GZip.hs b/src/Snap/Util/GZip.hs
index 9a6d2dc..ec14c44 100644
--- a/src/Snap/Util/GZip.hs
+++ b/src/Snap/Util/GZip.hs
@@ -61,19 +61,21 @@ import Snap.Types
-- that's contained within the 'Snap' monad state will be passed to
-- 'finishWith' to prevent further processing.
--
-withCompression :: Snap a -- ^ the web handler to run
- -> Snap ()
+withCompression :: MonadSnap m
+ => m a -- ^ the web handler to run
+ -> m ()
withCompression = withCompression' compressibleMimeTypes
------------------------------------------------------------------------------
-- | The same as 'withCompression', with control over which MIME types to
-- compress.
-withCompression' :: Set ByteString
+withCompression' :: MonadSnap m
+ => Set ByteString
-- ^ set of compressible MIME types
- -> Snap a
+ -> m a
-- ^ the web handler to run
- -> Snap ()
+ -> m ()
withCompression' mimeTable action = do
_ <- action
resp <- getResponse
@@ -97,7 +99,6 @@ withCompression' mimeTable action = do
getResponse >>= finishWith
where
- chkAcceptEncoding :: Snap ()
chkAcceptEncoding = do
req <- getRequest
debug $ "checking accept-encoding"
@@ -137,7 +138,7 @@ compressibleMimeTypes = Set.fromList [
"application/x-font-truetype"
------------------------------------------------------------------------------
-gzipCompression :: Snap ()
+gzipCompression :: MonadSnap m => m ()
gzipCompression = modifyResponse f
where
f = setHeader "Content-Encoding" "gzip" .
@@ -146,7 +147,7 @@ gzipCompression = modifyResponse f
------------------------------------------------------------------------------
-compressCompression :: Snap ()
+compressCompression :: MonadSnap m => m ()
compressCompression = modifyResponse f
where
f = setHeader "Content-Encoding" "compress" .
-----------------------------------------------------------------------
hooks/post-receive
--
snap-core
_______________________________________________
Snap mailing list
[email protected]
http://mailman-mail5.webfaction.com/listinfo/snap
