snap-core 0.2.16 → 0.3.0
raw patch · 33 files changed
+1294/−1592 lines, 33 filesdep +enumeratordep +mtldep −ListLikedep −directory-treedep −haskell98dep ~attoparsecdep ~basedep ~text
Dependencies added: enumerator, mtl
Dependencies removed: ListLike, directory-tree, haskell98, iteratee, monads-fd, template-haskell
Dependency ranges changed: attoparsec, base, text, transformers, unix-compat
Files
- LICENSE +1/−0
- README.SNAP.md +5/−18
- README.md +7/−12
- cbits/timefuncs.c +1/−0
- project_template/barebones/foo.cabal +0/−35
- project_template/barebones/src/Main.hs +0/−22
- project_template/barebones/src/Server.hs +0/−111
- project_template/default/foo.cabal +0/−37
- project_template/default/src/Glue.hs +0/−46
- project_template/default/src/Main.hs +0/−30
- project_template/default/src/Server.hs +0/−111
- snap-core.cabal +7/−57
- src/Data/CIByteString.hs +20/−1
- src/Snap/Internal/Debug.hs +15/−14
- src/Snap/Internal/Http/Types.hs +44/−40
- src/Snap/Internal/Instances.hs +82/−0
- src/Snap/Internal/Iteratee/Debug.hs +40/−35
- src/Snap/Internal/Routing.hs +26/−19
- src/Snap/Internal/Types.hs +186/−110
- src/Snap/Iteratee.hs +426/−315
- src/Snap/Starter.hs +0/−99
- src/Snap/StarterTH.hs +0/−55
- src/Snap/Types.hs +5/−0
- src/Snap/Util/FileServe.hs +27/−20
- src/Snap/Util/GZip.hs +89/−82
- test/snap-core-testsuite.cabal +4/−5
- test/suite/Snap/Internal/Http/Types/Tests.hs +7/−5
- test/suite/Snap/Internal/Routing/Tests.hs +2/−2
- test/suite/Snap/Iteratee/Tests.hs +207/−204
- test/suite/Snap/Test/Common.hs +0/−5
- test/suite/Snap/Types/Tests.hs +58/−56
- test/suite/Snap/Util/FileServe/Tests.hs +11/−9
- test/suite/Snap/Util/GZip/Tests.hs +24/−37
LICENSE view
@@ -1,4 +1,5 @@ Copyright (c) 2009, Snap Framework authors (see CONTRIBUTORS)+Copyright (c) 2010, Google, Inc. All rights reserved. Redistribution and use in source and binary forms, with or without
README.SNAP.md view
@@ -1,10 +1,9 @@ Snap Framework -------------- -This is the first developer prerelease of the Snap framework. Snap is a simple-and fast web development framework and server written in Haskell. For more-information or to download the latest version, you can visit the Snap project-website at http://snapframework.com/.+Snap is a simple and fast web development framework and server written in+Haskell. For more information or to download the latest version, you can visit+the Snap project website at http://snapframework.com/. Snap Status and Features@@ -23,8 +22,8 @@ bind Haskell functionality to XML tags without getting PHP-style tag soup all over your pants -Snap currently only runs on Unix platforms; it has been tested on Linux and Mac-OSX Snow Leopard.+Snap is currently only officially supported on Unix platforms; it has been+tested on Linux and Mac OSX Snow Leopard, and is reported to work on Windows. Snap Philosophy@@ -41,15 +40,3 @@ * Excellent documentation * Robustness and high test coverage---Snap Roadmap---------------Where are we going?--1. First prerelease: HTTP server, monad, template system--2. Second prerelease: component system with a collection of useful stock-modules (called "Snaplets") for things like user and session management,-caching, an administrative interface, etc.
README.md view
@@ -1,13 +1,12 @@ Snap Framework Core =================== -This is the first developer prerelease of the Snap Framework Core library. For-more information about Snap, read the `README.SNAP.md` or visit the Snap-project website at http://www.snapframework.com/.+This is the Snap Framework Core library. For more information about Snap, read+the `README.SNAP.md` or visit the Snap project website at+http://www.snapframework.com/. -Snap is a nascent web framework for Haskell, based on iteratee I/O (as-[popularized by Oleg-Kiselyov](http://okmij.org/ftp/Streams.html#iteratee)).+Snap is a web framework for Haskell, based on iteratee I/O (as [popularized by+Oleg Kiselyov](http://okmij.org/ftp/Streams.html#iteratee)). ## Library contents@@ -57,11 +56,8 @@ ## Building the testsuite -Snap is still in its very early stages, so most of the "action" (and a big-chunk of the code) right now is centred on the test suite. Snap aims for 100%-test coverage, and we're trying hard to stick to that.--To build the test suite, `cd` into the `test/` directory and run+Snap-core has a fairly comprehensive testsuite. To build it, `cd` into the+`test/` directory and run $ cabal configure $ cabal build@@ -69,6 +65,5 @@ From here you can invoke the testsuite by running: $ ./runTestsAndCoverage.sh - The testsuite generates an `hpc` test coverage report in `test/dist/hpc`.
cbits/timefuncs.c view
@@ -1,4 +1,5 @@ #define _XOPEN_SOURCE+#define _BSD_SOURCE #include <time.h> #include <locale.h>
− project_template/barebones/foo.cabal
@@ -1,35 +0,0 @@-Name: projname-Version: 0.1-Synopsis: Project Synopsis Here-Description: Project Description Here-License: AllRightsReserved-Author: Author-Maintainer: maintainer@example.com-Stability: Experimental-Category: Web-Build-type: Simple-Cabal-version: >=1.2--Executable projname- hs-source-dirs: src- main-is: Main.hs-- Build-depends:- base >= 4,- haskell98,- monads-fd >= 0.1 && <0.2,- bytestring >= 0.9.1 && <0.10,- snap-core >= 0.2 && <0.3,- snap-server >= 0.2 && <0.3,- xhtml-combinators,- unix,- text,- containers,- MonadCatchIO-transformers,- filepath >= 1.1 && <1.2-- if impl(ghc >= 6.12.0)- ghc-options: -threaded -Wall -fwarn-tabs -funbox-strict-fields -O2- -fno-warn-unused-do-bind- else- ghc-options: -threaded -Wall -fwarn-tabs -funbox-strict-fields -O2
− project_template/barebones/src/Main.hs
@@ -1,22 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-module Main where--import Control.Applicative-import Snap.Types-import Snap.Util.FileServe--import Server--main :: IO ()-main = quickServer $- ifTop (writeBS "hello world") <|>- route [ ("foo", writeBS "bar")- , ("echo/:echoparam", echoHandler)- ] <|>- dir "static" (fileServe ".")--echoHandler :: Snap ()-echoHandler = do- param <- getParam "echoparam"- maybe (writeBS "must specify echo/param in URL")- writeBS param
− project_template/barebones/src/Server.hs
@@ -1,111 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-module Server- ( ServerConfig(..)- , emptyServerConfig- , commandLineConfig- , server- , quickServer- ) where-import qualified Data.ByteString.Char8 as B-import Data.ByteString.Char8 (ByteString)-import Data.Char-import Control.Concurrent-import Control.Exception (SomeException)-import Control.Monad.CatchIO-import qualified Data.Text as T-import Prelude hiding (catch)-import Snap.Http.Server-import Snap.Types-import Snap.Util.GZip-import System hiding (getEnv)-import System.Posix.Env-import qualified Text.XHtmlCombinators.Escape as XH---data ServerConfig = ServerConfig- { locale :: String- , interface :: ByteString- , port :: Int- , hostname :: ByteString- , accessLog :: Maybe FilePath- , errorLog :: Maybe FilePath- , compression :: Bool- , error500Handler :: SomeException -> Snap ()- }---emptyServerConfig :: ServerConfig-emptyServerConfig = ServerConfig- { locale = "en_US"- , interface = "0.0.0.0"- , port = 8000- , hostname = "myserver"- , accessLog = Just "access.log"- , errorLog = Just "error.log"- , compression = True- , error500Handler = \e -> do- let t = T.pack $ show e- r = setContentType "text/html; charset=utf-8" $- setResponseStatus 500 "Internal Server Error" emptyResponse- putResponse r- writeBS "<html><head><title>Internal Server Error</title></head>"- writeBS "<body><h1>Internal Server Error</h1>"- writeBS "<p>A web handler threw an exception. Details:</p>"- writeBS "<pre>\n"- writeText $ XH.escape t- writeBS "\n</pre></body></html>"- }---commandLineConfig :: IO ServerConfig-commandLineConfig = do- args <- getArgs- let conf = case args of- [] -> emptyServerConfig- (port':_) -> emptyServerConfig { port = read port' }- locale' <- getEnv "LANG"- return $ case locale' of- Nothing -> conf- Just l -> conf {locale = takeWhile (\c -> isAlpha c || c == '_') l}--server :: ServerConfig -> Snap () -> IO ()-server config handler = do- putStrLn $ "Listening on " ++ (B.unpack $ interface config)- ++ ":" ++ show (port config)- setUTF8Locale (locale config)- try $ httpServe- (interface config)- (port config)- (hostname config)- (accessLog config)- (errorLog config)- (catch500 $ compress $ handler)- :: IO (Either SomeException ())- threadDelay 1000000- putStrLn "Shutting down"- where- catch500 = (`catch` (error500Handler config))- compress = if compression config then withCompression else id---quickServer :: Snap () -> IO ()-quickServer = (commandLineConfig >>=) . flip server---setUTF8Locale :: String -> IO ()-setUTF8Locale locale' = do- mapM_ (\k -> setEnv k (locale' ++ ".UTF-8") True)- [ "LANG"- , "LC_CTYPE"- , "LC_NUMERIC"- , "LC_TIME"- , "LC_COLLATE"- , "LC_MONETARY"- , "LC_MESSAGES"- , "LC_PAPER"- , "LC_NAME"- , "LC_ADDRESS"- , "LC_TELEPHONE"- , "LC_MEASUREMENT"- , "LC_IDENTIFICATION"- , "LC_ALL" ]
− project_template/default/foo.cabal
@@ -1,37 +0,0 @@-Name: projname-Version: 0.1-Synopsis: Project Synopsis Here-Description: Project Description Here-License: AllRightsReserved-Author: Author-Maintainer: maintainer@example.com-Stability: Experimental-Category: Web-Build-type: Simple-Cabal-version: >=1.2--Executable projname- hs-source-dirs: src- main-is: Main.hs-- Build-depends:- base >= 4,- haskell98,- monads-fd >= 0.1 && <0.2,- bytestring >= 0.9.1 && <0.10,- snap-core >= 0.2 && <0.3,- snap-server >= 0.2 && <0.3,- heist >= 0.2.4 && <0.3,- hexpat >= 0.19 && <0.20,- xhtml-combinators,- unix,- text,- containers,- MonadCatchIO-transformers,- filepath >= 1.1 && <1.2-- if impl(ghc >= 6.12.0)- ghc-options: -threaded -Wall -fwarn-tabs -funbox-strict-fields -O2- -fno-warn-unused-do-bind- else- ghc-options: -threaded -Wall -fwarn-tabs -funbox-strict-fields -O2
− project_template/default/src/Glue.hs
@@ -1,46 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-module Glue- ( templateHandler- , defaultReloadHandler- , templateServe- , render- ) where--import Control.Applicative-import Control.Monad-import Data.ByteString.Char8 (ByteString)-import qualified Data.ByteString.Char8 as B-import Prelude hiding (catch)-import Snap.Types hiding (dir)-import Snap.Util.FileServe-import Text.Templating.Heist-import Text.Templating.Heist.TemplateDirectory---templateHandler :: TemplateDirectory Snap- -> (TemplateDirectory Snap -> Snap ())- -> (TemplateState Snap -> Snap ())- -> Snap ()-templateHandler td reload f = reload td <|> (f =<< getDirectoryTS td)---defaultReloadHandler :: TemplateDirectory Snap -> Snap ()-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 ts template = do- bytes <- renderTemplate ts template- flip (maybe pass) bytes $ \x -> do- modifyResponse $ setContentType "text/html; charset=utf-8"- writeBS x---templateServe :: TemplateState Snap -> Snap ()-templateServe ts = ifTop (render ts "index") <|> do- path' <- getSafePath- when (head path' == '_') pass- render ts $ B.pack path'
− project_template/default/src/Main.hs
@@ -1,30 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-module Main where--import Control.Applicative-import Snap.Types-import Snap.Util.FileServe-import Text.Templating.Heist-import Text.Templating.Heist.TemplateDirectory--import Glue-import Server---main :: IO ()-main = do- td <- newTemplateDirectory' "templates" emptyTemplateState- quickServer $ templateHandler td defaultReloadHandler $ \ts ->- ifTop (writeBS "hello world") <|>- route [ ("foo", writeBS "bar")- , ("echo/:echoparam", echoHandler)- ] <|>- templateServe ts <|>- dir "static" (fileServe ".")---echoHandler :: Snap ()-echoHandler = do- param <- getParam "echoparam"- maybe (writeBS "must specify echo/param in URL")- writeBS param
− project_template/default/src/Server.hs
@@ -1,111 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-module Server- ( ServerConfig(..)- , emptyServerConfig- , commandLineConfig- , server- , quickServer- ) where-import qualified Data.ByteString.Char8 as B-import Data.ByteString.Char8 (ByteString)-import Data.Char-import Control.Concurrent-import Control.Exception (SomeException)-import Control.Monad.CatchIO-import qualified Data.Text as T-import Prelude hiding (catch)-import Snap.Http.Server-import Snap.Types-import Snap.Util.GZip-import System hiding (getEnv)-import System.Posix.Env-import qualified Text.XHtmlCombinators.Escape as XH---data ServerConfig = ServerConfig- { locale :: String- , interface :: ByteString- , port :: Int- , hostname :: ByteString- , accessLog :: Maybe FilePath- , errorLog :: Maybe FilePath- , compression :: Bool- , error500Handler :: SomeException -> Snap ()- }---emptyServerConfig :: ServerConfig-emptyServerConfig = ServerConfig- { locale = "en_US"- , interface = "0.0.0.0"- , port = 8000- , hostname = "myserver"- , accessLog = Just "access.log"- , errorLog = Just "error.log"- , compression = True- , error500Handler = \e -> do- let t = T.pack $ show e- r = setContentType "text/html; charset=utf-8" $- setResponseStatus 500 "Internal Server Error" emptyResponse- putResponse r- writeBS "<html><head><title>Internal Server Error</title></head>"- writeBS "<body><h1>Internal Server Error</h1>"- writeBS "<p>A web handler threw an exception. Details:</p>"- writeBS "<pre>\n"- writeText $ XH.escape t- writeBS "\n</pre></body></html>"- }---commandLineConfig :: IO ServerConfig-commandLineConfig = do- args <- getArgs- let conf = case args of- [] -> emptyServerConfig- (port':_) -> emptyServerConfig { port = read port' }- locale' <- getEnv "LANG"- return $ case locale' of- Nothing -> conf- Just l -> conf {locale = takeWhile (\c -> isAlpha c || c == '_') l}--server :: ServerConfig -> Snap () -> IO ()-server config handler = do- putStrLn $ "Listening on " ++ (B.unpack $ interface config)- ++ ":" ++ show (port config)- setUTF8Locale (locale config)- try $ httpServe- (interface config)- (port config)- (hostname config)- (accessLog config)- (errorLog config)- (catch500 $ compress $ handler)- :: IO (Either SomeException ())- threadDelay 1000000- putStrLn "Shutting down"- where- catch500 = (`catch` (error500Handler config))- compress = if compression config then withCompression else id---quickServer :: Snap () -> IO ()-quickServer = (commandLineConfig >>=) . flip server---setUTF8Locale :: String -> IO ()-setUTF8Locale locale' = do- mapM_ (\k -> setEnv k (locale' ++ ".UTF-8") True)- [ "LANG"- , "LC_CTYPE"- , "LC_NUMERIC"- , "LC_TIME"- , "LC_COLLATE"- , "LC_MONETARY"- , "LC_MESSAGES"- , "LC_PAPER"- , "LC_NAME"- , "LC_ADDRESS"- , "LC_TELEPHONE"- , "LC_MEASUREMENT"- , "LC_IDENTIFICATION"- , "LC_ALL" ]
snap-core.cabal view
@@ -1,5 +1,5 @@ name: snap-core-version: 0.2.16+version: 0.3.0 synopsis: Snap: A Haskell Web Framework (Core) description:@@ -73,13 +73,6 @@ extra/logo.gif, haddock.sh, LICENSE,- 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/default/src/Server.hs, README.md, README.SNAP.md, Setup.hs,@@ -140,6 +133,7 @@ Snap.Util.GZip other-modules:+ Snap.Internal.Instances, Snap.Internal.Parsing, Snap.Internal.Routing, Snap.Internal.Types@@ -155,60 +149,16 @@ deepseq >= 1.1 && <1.2, directory, dlist >= 0.5 && < 0.6,+ enumerator > 0.4.2 && < 0.5, filepath,- iteratee >= 0.3.1 && < 0.4,- ListLike >= 1 && < 2, MonadCatchIO-transformers >= 0.2.1 && < 0.3,- monads-fd < 0.1.0.3,- old-locale,- old-time,- text >= 0.10 && <0.11,- time,- transformers,- unix-compat,- zlib-- ghc-prof-options: -prof -auto-all-- if impl(ghc >= 6.12.0)- ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2- -fno-warn-unused-do-bind- else- ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2---Executable snap- hs-source-dirs: src- main-is: Snap/Starter.hs-- other-modules: Snap.StarterTH-- if flag(no-debug)- cpp-options: -DNODEBUG-- build-depends:- attoparsec >= 0.8.1 && < 0.9,- base >= 4 && < 5,- bytestring,- bytestring-nums,- bytestring-show >= 0.3.2 && < 0.4,- cereal >= 0.3 && < 0.4,- containers,- deepseq >= 1.1 && <1.2,- directory,- directory-tree,- dlist >= 0.5 && < 0.6,- filepath,- haskell98,- iteratee >= 0.3.1 && <0.4,- monads-fd,+ mtl == 2.0.*, old-locale, old-time,- template-haskell,- text >= 0.10 && <0.11,+ text >= 0.11 && <0.12, time,- transformers,- unix-compat,+ transformers == 0.2.*,+ unix-compat == 0.2.*, zlib ghc-prof-options: -prof -auto-all
src/Data/CIByteString.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE OverloadedStrings #-} +------------------------------------------------------------------------------ -- | "Data.CIByteString" is a module containing 'CIByteString', a wrapper for -- 'ByteString' which provides case-insensitive (ASCII-wise) 'Ord' and 'Eq' -- instances.@@ -11,7 +12,8 @@ -- -- @ -- \> let a = \"Foo\" in--- putStrLn $ (show $ unCI a) ++ \"==\\\"FoO\\\" is \" ++ show (a == \"FoO\")+-- putStrLn $ (show $ unCI a) ++ \"==\\\"FoO\\\" is \" +++-- show (a == \"FoO\") -- \"Foo\"==\"FoO\" is True -- @ @@ -22,6 +24,8 @@ , ciToLower ) where ++------------------------------------------------------------------------------ -- for IsString instance import Data.ByteString.Char8 () import Data.ByteString (ByteString)@@ -31,30 +35,45 @@ import Data.String +------------------------------------------------------------------------------ -- | A case-insensitive newtype wrapper for 'ByteString' data CIByteString = CIByteString { unCI :: !ByteString , _lowercased :: !ByteString } ++------------------------------------------------------------------------------ toCI :: ByteString -> CIByteString toCI s = CIByteString s t where t = lowercase s ++------------------------------------------------------------------------------ ciToLower :: CIByteString -> ByteString ciToLower = _lowercased ++------------------------------------------------------------------------------ instance Show CIByteString where show (CIByteString s _) = show s ++------------------------------------------------------------------------------ lowercase :: ByteString -> ByteString lowercase = S.map (c2w . toLower . w2c) ++------------------------------------------------------------------------------ instance Eq CIByteString where (CIByteString _ a) == (CIByteString _ b) = a == b (CIByteString _ a) /= (CIByteString _ b) = a /= b ++------------------------------------------------------------------------------ instance Ord CIByteString where (CIByteString _ a) <= (CIByteString _ b) = a <= b ++------------------------------------------------------------------------------ instance IsString CIByteString where fromString = toCI . fromString
src/Snap/Internal/Debug.hs view
@@ -8,6 +8,7 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-}+{-# LANGUAGE PackageImports #-} {-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -fno-cse #-} @@ -15,18 +16,18 @@ module Snap.Internal.Debug where -------------------------------------------------------------------------------import Control.Concurrent-import Control.DeepSeq-import Control.Exception-import Control.Monad.Trans-import Data.Char-import Data.List-import Data.Maybe-import Foreign.C.Error-import System.Environment-import System.IO-import System.IO.Unsafe-import Text.Printf+import Control.Concurrent+import Control.DeepSeq+import Control.Exception+import Control.Monad.Trans+import Data.Char+import Data.List+import Data.Maybe+import Foreign.C.Error+import System.Environment+import System.IO+import System.IO.Unsafe+import Text.Printf ------------------------------------------------------------------------------ debug, debugErrno :: forall m . (MonadIO m => String -> m ())@@ -37,7 +38,7 @@ {-# NOINLINE debug #-} debug = let !x = unsafePerformIO $! do !e <- try $ getEnv "DEBUG"- + !f <- either (\(_::SomeException) -> return debugIgnore) (\y -> if y == "1" || y == "on" then return debugOn@@ -52,7 +53,7 @@ {-# NOINLINE debugErrno #-} debugErrno = let !x = unsafePerformIO $ do e <- try $ getEnv "DEBUG"- + !f <- either (\(_::SomeException) -> return debugErrnoIgnore) (\y -> if y == "1" || y == "on" then return debugErrnoOn
src/Snap/Internal/Http/Types.hs view
@@ -57,6 +57,7 @@ ------------------------------------------------------------------------------ import Data.CIByteString+import Snap.Iteratee (Enumerator) import qualified Snap.Iteratee as I @@ -79,8 +80,6 @@ #endif --------------------------------------------------------------------------------type Enumerator a = I.Enumerator IO a ------------------------------------------------------------------------------ -- | A type alias for a case-insensitive key-value mapping.@@ -99,8 +98,9 @@ --------------------------------------------------------------------------------- | Adds a header key-value-pair to the 'HasHeaders' datatype. If a header with--- the same name already exists, the new value is appended to the headers list.+-- | Adds a header key-value-pair to the 'HasHeaders' datatype. If a header+-- with the same name already exists, the new value is appended to the headers+-- list. addHeader :: (HasHeaders a) => CIByteString -> ByteString -> a -> a addHeader k v = updateHeaders $ Map.insertWith' (++) k [v] @@ -175,7 +175,7 @@ ------------------------------------------------------------------------------ -- | An existential wrapper for the 'Enumerator' type-data SomeEnumerator = SomeEnumerator (forall a . Enumerator a)+data SomeEnumerator = SomeEnumerator (forall a . Enumerator ByteString IO a) ------------------------------------------------------------------------------@@ -223,11 +223,11 @@ , rqCookies :: [Cookie] - -- | We'll be doing web components (or \"snaplets\") for version 0.2. The- -- \"snaplet path\" refers to the place on the URL where your containing- -- snaplet is hung. The value of 'rqSnapletPath' is either @\"\"@ (at the- -- top-level context) or is a path beginning with a slash, but not ending- -- with one.+ -- | We'll be doing web components (or \"snaplets\") for version 0.2.+ -- The \"snaplet path\" refers to the place on the URL where your+ -- containing snaplet is hung. The value of 'rqSnapletPath' is either+ -- @\"\"@ (at the top-level context) or is a path beginning with a+ -- slash, but not ending with one. -- -- An identity is that: --@@ -235,18 +235,18 @@ -- > , rqContextPath r -- > , rqPathInfo r ] --- -- note that until we introduce snaplets in v0.2, 'rqSnapletPath' will be- -- \"\"+ -- note that until we introduce snaplets in v0.2, 'rqSnapletPath' will+ -- be \"\" , rqSnapletPath :: !ByteString -- | Handlers can (/will be; --ed/) be hung on a @URI@ \"entry point\"; -- this is called the \"context path\". If a handler is hung on the- -- context path @\"\/foo\/\"@, and you request @\"\/foo\/bar\"@, the value- -- of 'rqPathInfo' will be @\"bar\"@.+ -- context path @\"\/foo\/\"@, and you request @\"\/foo\/bar\"@, the+ -- value of 'rqPathInfo' will be @\"bar\"@. , rqPathInfo :: !ByteString - -- | The \"context path\" of the request; catenating 'rqContextPath', and- -- 'rqPathInfo' should get you back to the original 'rqURI'. The+ -- | The \"context path\" of the request; catenating 'rqContextPath',+ -- and 'rqPathInfo' should get you back to the original 'rqURI'. The -- 'rqContextPath' always begins and ends with a slash (@\"\/\"@) -- character, and represents the path (relative to your -- component\/snaplet) you took to get to your handler.@@ -351,7 +351,7 @@ -- response type ------------------------------------------------------------------------------ -data ResponseBody = Enum (forall a . Enumerator a)+data ResponseBody = Enum (forall a . Enumerator ByteString IO a) -- ^ output body is enumerator | SendFile FilePath (Maybe (Int64,Int64))@@ -360,14 +360,15 @@ -------------------------------------------------------------------------------rspBodyMap :: (forall a . Enumerator a -> Enumerator a)+rspBodyMap :: (forall a .+ Enumerator ByteString IO a -> Enumerator ByteString IO a) -> ResponseBody -> ResponseBody rspBodyMap f b = Enum $ f $ rspBodyToEnum b -------------------------------------------------------------------------------rspBodyToEnum :: ResponseBody -> Enumerator a+rspBodyToEnum :: ResponseBody -> Enumerator ByteString IO a rspBodyToEnum (Enum e) = e rspBodyToEnum (SendFile fp Nothing) = I.enumFile fp rspBodyToEnum (SendFile fp (Just s)) = I.enumFilePartial fp s@@ -429,8 +430,8 @@ ------------------------------------------------------------------------------ -- | Looks up the value(s) for the given named parameter. Parameters initially -- come from the request's query string and any decoded POST body (if the--- request's @Content-Type@ is @application\/x-www-form-urlencoded@). Parameter--- values can be modified within handlers using "rqModifyParams".+-- request's @Content-Type@ is @application\/x-www-form-urlencoded@).+-- Parameter values can be modified within handlers using "rqModifyParams". rqParam :: ByteString -- ^ parameter name to look up -> Request -- ^ HTTP request -> Maybe [ByteString]@@ -439,8 +440,8 @@ --------------------------------------------------------------------------------- | Modifies the parameters mapping (which is a @Map ByteString ByteString@) in--- a 'Request' using the given function.+-- | Modifies the parameters mapping (which is a @Map ByteString ByteString@)+-- in a 'Request' using the given function. rqModifyParams :: (Params -> Params) -> Request -> Request rqModifyParams f r = r { rqParams = p } where@@ -449,7 +450,8 @@ --------------------------------------------------------------------------------- | Writes a key-value pair to the parameters mapping within the given request.+-- | Writes a key-value pair to the parameters mapping within the given+-- request. rqSetParam :: ByteString -- ^ parameter name -> [ByteString] -- ^ parameter values -> Request -- ^ request@@ -462,16 +464,16 @@ ------------------------------------------------------------------------------ -- | An empty 'Response'.-emptyResponse :: Response-emptyResponse = Response Map.empty (1,1) Nothing (Enum return) 200- "OK" False+emptyResponse :: Response+emptyResponse = Response Map.empty (1,1) Nothing (Enum (I.enumBS "")) 200+ "OK" False ------------------------------------------------------------------------------ -- | Sets an HTTP response body to the given 'Enumerator' value.-setResponseBody :: (forall a . Enumerator a) -- ^ new response body- -- enumerator- -> Response -- ^ response to modify+setResponseBody :: (forall a . Enumerator ByteString IO a)+ -- ^ new response body enumerator+ -> Response -- ^ response to modify -> Response setResponseBody e r = r { rspBody = Enum e } {-# INLINE setResponseBody #-}@@ -502,7 +504,8 @@ ------------------------------------------------------------------------------ -- | Modifies a response body.-modifyResponseBody :: (forall a . Enumerator a -> Enumerator a)+modifyResponseBody :: (forall a . Enumerator ByteString IO a+ -> Enumerator ByteString IO a) -> Response -> Response modifyResponseBody f r = r { rspBody = rspBodyMap f (rspBody r) }@@ -528,21 +531,22 @@ path = maybe "" (S.append "; path=") mbPath domain = maybe "" (S.append "; domain=") mbDomain exptime = maybe "" (S.append "; expires=" . fmt) mbExpTime- fmt = fromStr . formatTime defaultTimeLocale "%a, %d-%b-%Y %H:%M:%S GMT"+ fmt = fromStr .+ formatTime defaultTimeLocale "%a, %d-%b-%Y %H:%M:%S GMT" ------------------------------------------------------------------------------ -- | A note here: if you want to set the @Content-Length@ for the response,--- Snap forces you to do it with this function rather than by setting it in the--- headers; the @Content-Length@ in the headers will be ignored.+-- Snap forces you to do it with this function rather than by setting it in+-- the headers; the @Content-Length@ in the headers will be ignored. -- -- The reason for this is that Snap needs to look up the value of -- @Content-Length@ for each request, and looking the string value up in the -- headers and parsing the number out of the text will be too expensive. -- -- If you don't set a content length in your response, HTTP keep-alive will be--- disabled for HTTP\/1.0 clients, forcing a @Connection: close@. For HTTP\/1.1--- clients, Snap will switch to the chunked transfer encoding if+-- disabled for HTTP\/1.0 clients, forcing a @Connection: close@. For+-- HTTP\/1.1 clients, Snap will switch to the chunked transfer encoding if -- @Content-Length@ is not specified. setContentLength :: Int64 -> Response -> Response setContentLength l r = r { rspContentLength = Just l }@@ -590,10 +594,10 @@ toUTCTime = posixSecondsToUTCTime . realToFrac -parseHttpTime = return . toCTime . parse . toStr+parseHttpTime = return . toCTime . prs . toStr where- parse :: String -> Maybe UTCTime- parse = parseTime defaultTimeLocale "%a, %d %b %Y %H:%M:%S GMT"+ prs :: String -> Maybe UTCTime+ prs = parseTime defaultTimeLocale "%a, %d %b %Y %H:%M:%S GMT" toCTime :: Maybe UTCTime -> CTime toCTime (Just t) = fromInteger $ truncate $ utcTimeToPOSIXSeconds t@@ -651,7 +655,7 @@ when (S.length hx /= 2 || (not $ S.all (isHexDigit . w2c) hx)) $ fail "bad hex in url"- + let code = (Cvt.hex hx) :: Word8 nextChunk $ DL.snoc l (S.singleton code)
+ src/Snap/Internal/Instances.hs view
@@ -0,0 +1,82 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE PackageImports #-}++module Snap.Internal.Instances where++import Control.Applicative+import Control.Monad.Cont+import Control.Monad.Error+import Control.Monad.List+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 qualified Control.Monad.State.Lazy as LState+import Control.Monad.Writer.Strict hiding (pass)+import qualified Control.Monad.Writer.Lazy as LWriter+import Prelude hiding (catch)++------------------------------------------------------------------------------+import Snap.Internal.Types+++------------------------------------------------------------------------------+instance MonadPlus m => MonadPlus (ContT c m) where+ mzero = lift mzero+ m `mplus` n = ContT $ \ f -> runContT m f `mplus` runContT n f+++------------------------------------------------------------------------------+instance MonadPlus 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, Monoid w) => MonadSnap (LRWS.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 => 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
src/Snap/Internal/Iteratee/Debug.hs view
@@ -3,9 +3,9 @@ -- /N.B./ this is an internal interface, please don't write user code that -- depends on it. -{-# OPTIONS_GHC -fno-warn-orphans #-}-{-# LANGUAGE CPP #-}+{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE PackageImports #-} module Snap.Internal.Iteratee.Debug@@ -14,9 +14,9 @@ ) where -------------------------------------------------------------------------------import Data.Iteratee.WrappedByteString-import Data.Word (Word8)-import System.IO+import Control.Monad.Trans+import Data.ByteString (ByteString)+import System.IO ------------------------------------------------------------------------------ #ifndef NODEBUG import Snap.Internal.Debug@@ -26,47 +26,52 @@ -------------------------------------------------------------------------------instance Show (WrappedByteString Word8) where- show (WrapBS s) = show s----------------------------------------------------------------------------------debugIteratee :: Iteratee IO ()-debugIteratee = IterateeG f+debugIteratee :: Iteratee ByteString IO ()+debugIteratee = continue f where- f c@(EOF _) = do- putStrLn $ "got EOF: " ++ show c- hFlush stdout- return (Done () c)+ f EOF = do+ liftIO $ putStrLn $ "got EOF"+ liftIO $ hFlush stdout+ yield () EOF - f c@(Chunk _) = do- putStrLn $ "got chunk: " ++ show c- hFlush stdout- return $ Cont debugIteratee Nothing+ f (Chunks xs) = do+ liftIO $ putStrLn $ "got chunk: " ++ show (xs)+ liftIO $ hFlush stdout+ continue f #ifndef NODEBUG -iterateeDebugWrapper :: String -> Iteratee IO a -> Iteratee IO a-iterateeDebugWrapper name iter = IterateeG f+iterateeDebugWrapper :: (Show a, MonadIO m) =>+ String+ -> Iteratee a m b+ -> Iteratee a m b+iterateeDebugWrapper name iter = do+ debug $ name ++ ": BEGIN"+ step <- lift $ runIteratee iter+ whatWasReturn step+ check step+ where- f c@(EOF Nothing) = do- debug $ name ++ ": got EOF: " ++ show c- runIter iter c+ whatWasReturn (Continue _) = debug $ name ++ ": continue"+ whatWasReturn (Yield _ z) = debug $ name ++ ": yield, with remainder "+ ++ show z+ whatWasReturn (Error e) = debug $ name ++ ": error, with " ++ show e - f c@(EOF (Just _)) = do- debug $ name ++ ": got EOF **error**: " ++ show c- runIter iter c+ check (Continue k) = continue $ f k+ check st = returnI st - f c@(Chunk _) = do- debug $ name ++ ": got chunk: " ++ show c- wrapResult $ runIter iter c - wrapResult m = do- iv <- m- let i = liftI iv+ f k EOF = do+ debug $ name ++ ": got EOF"+ k EOF - return $ Cont (iterateeDebugWrapper name i) Nothing+ f k ch@(Chunks xs) = do+ debug $ name ++ ": got chunk: " ++ show xs+ step <- lift $ runIteratee $ k ch+ whatWasReturn step+ check step+ #else
src/Snap/Internal/Routing.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE FlexibleContexts #-} module Snap.Internal.Routing where @@ -34,14 +36,16 @@ 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+ -- captures the dir in a param+ | Capture ByteString (Route a m) (Route a m)+ -- match on a dir+ | Dir (Map.Map ByteString (Route a m)) (Route a m)+ | NoRoute -------------------------------------------------------------------------------instance Monoid (Route a) where+instance Monoid (Route a m) where mempty = NoRoute mappend NoRoute r = r@@ -81,14 +85,14 @@ -------------------------------------------------------------------------------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@@ -135,8 +139,8 @@ -- -- > [ ("a", h1), ("a/b", h2), ("a/:x", h3) ] ----- a request for \"@\/a\/b@\" will go to @h2@, \"@\/a\/s@\" for any /s/ will go--- to @h3@, and \"@\/a@\" will go to @h1@.+-- a request for \"@\/a\/b@\" will go to @h2@, \"@\/a\/s@\" for any /s/ will+-- go to @h3@, and \"@\/a@\" will go to @h1@. -- -- The following example matches \"@\/article@\" to an article index, -- \"@\/login@\" to a login, and \"@\/article\/...@\" to an article renderer.@@ -145,38 +149,40 @@ -- > , ("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+ p <- getRequest >>= maybe pass return . urlDecode . rqPathInfo route' (return ()) ([], splitPath p) Map.empty rts' where rts' = mconcat (map pRoute rts) --------------------------------------------------------------------------------- | The 'routeLocal' function is the same as 'route'', except it doesn't change--- the request's context path. This is useful if you want to route to a+-- | The 'routeLocal' function is the same as 'route'', except it doesn't+-- change 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 let p = rqPathInfo req+ p' <- maybe pass return $ urlDecode p let md = modifyRequest $ \r -> r {rqContextPath=ctx, rqPathInfo=p} - (route' md ([], splitPath p) Map.empty rts') <|> (md >> pass)+ (route' md ([], splitPath p') Map.empty rts') <|> (md >> pass) where rts' = mconcat (map pRoute rts) + ------------------------------------------------------------------------------ splitPath :: ByteString -> [ByteString] 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 +192,12 @@ -------------------------------------------------------------------------------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)
src/Snap/Internal/Types.hs view
@@ -1,34 +1,38 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PackageImports #-} {-# LANGUAGE RankNTypes #-} module Snap.Internal.Types where -------------------------------------------------------------------------------import Control.Applicative-import Control.Exception (throwIO, ErrorCall(..))-import Control.Monad.CatchIO-import Control.Monad.State.Strict-import Data.ByteString.Char8 (ByteString)-import qualified Data.ByteString.Char8 as S-import qualified Data.ByteString.Lazy.Char8 as L-import qualified Data.CIByteString as CIB-import Data.Int-import Data.IORef-import qualified Data.Iteratee as Iter-import Data.Maybe-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 "MonadCatchIO-transformers" Control.Monad.CatchIO -import Data.Typeable+import Control.Applicative+import Control.Exception (throwIO, ErrorCall(..))+import Control.Monad+import Control.Monad.State+import Data.ByteString.Char8 (ByteString)+import qualified Data.ByteString.Char8 as S+import qualified Data.ByteString.Lazy.Char8 as L+import qualified Data.CIByteString as CIB+import Data.Int+import Data.IORef+import Data.Maybe+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 Data.Typeable+import Prelude hiding (catch, take) + -------------------------------------------------------------------------------import Snap.Iteratee hiding (Enumerator)-import Snap.Internal.Http.Types-import Snap.Internal.Iteratee.Debug+import Snap.Internal.Http.Types+import Snap.Iteratee+import Snap.Internal.Iteratee.Debug ------------------------------------------------------------------------------@@ -74,19 +78,36 @@ > r <- getResponse > finishWith r - then any subsequent processing will be skipped and supplied 'Response' value- will be returned from 'runSnap' as-is.+ then any subsequent processing will be skipped and supplied 'Response'+ value will be returned from 'runSnap' as-is. 6. access to the 'IO' monad through a 'MonadIO' instance: > a :: Snap () > a = liftIO fireTheMissiles++You may notice that most of the type signatures in this module contain a+@(MonadSnap m) => ...@ typeclass constraint. 'MonadSnap' is a typeclass which,+in essence, says \"you can get back to the 'Snap' monad from here\". Using+'MonadSnap' you can extend the 'Snap' monad with additional functionality and+still have access to most of the 'Snap' functions without writing 'lift'+everywhere. Instances are already provided for most of the common monad+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 + ------------------------------------------------------------------------------ newtype Snap a = Snap {- unSnap :: StateT SnapState (Iteratee IO) (Maybe (Either Response a))+ unSnap :: StateT SnapState (Iteratee ByteString IO)+ (Maybe (Either Response a)) } @@ -154,7 +175,14 @@ empty = mzero (<|>) = mplus + ------------------------------------------------------------------------------+instance MonadSnap Snap where+ liftSnap = id++++------------------------------------------------------------------------------ -- | The Typeable instance is here so Snap can be dynamically executed with -- Hint. snapTyCon :: TyCon@@ -166,51 +194,52 @@ -------------------------------------------------------------------------------liftIter :: Iteratee IO a -> Snap a-liftIter i = Snap (lift i >>= return . Just . Right)+liftIter :: MonadSnap m => Iteratee ByteString 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 ByteString IO a -> m a runRequestBody iter = do req <- getRequest senum <- liftIO $ readIORef $ rqBody req let (SomeEnumerator enum) = senum -- make sure the iteratee consumes all of the output- let iter' = iter >>= (\a -> Iter.skipToEof >> return a)+ let iter' = iter >>= \a -> skipToEof >> return a -- run the iteratee- result <- liftIter $ Iter.joinIM $ enum iter'+ step <- liftIO $ runIteratee iter'+ result <- liftIter $ enum step -- stuff a new dummy enumerator into the request, so you can only try to -- read the request body from the socket once liftIO $ writeIORef (rqBody req)- (SomeEnumerator $ return . Iter.joinI . Iter.take 0 )+ (SomeEnumerator $ joinI . take 0 ) return result ------------------------------------------------------------------------------ -- | Returns the request body as a bytestring.-getRequestBody :: Snap L.ByteString-getRequestBody = liftM fromWrap $ runRequestBody stream2stream+getRequestBody :: MonadSnap m => m L.ByteString+getRequestBody = liftM L.fromChunks $ runRequestBody consume {-# INLINE getRequestBody #-} --------------------------------------------------------------------------------- | Normally Snap is careful to ensure that the request body is fully consumed--- after your web handler runs, but before the 'Response' enumerator is--- streamed out the socket. If you want to transform the request body into some--- output in O(1) space, you should use this function.+-- | Normally Snap is careful to ensure that the request body is fully+-- consumed after your web handler runs, but before the 'Response' enumerator+-- is streamed out the socket. If you want to transform the request body into+-- some output in O(1) space, you should use this function. -- -- Note that upon calling this function, response processing finishes early as -- if you called 'finishWith'. Make sure you set any content types, headers, -- cookies, etc. before you call this function. ---transformRequestBody :: (forall a . Enumerator a)+transformRequestBody :: (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@@ -221,14 +250,16 @@ let ioref = rqBody req senum <- liftIO $ readIORef ioref let (SomeEnumerator enum) = senum- liftIO $ writeIORef ioref- (SomeEnumerator $ return . Iter.joinI . Iter.take 0)+ liftIO $ writeIORef ioref (SomeEnumerator enumEOF) origRsp <- getResponse let rsp = setResponseBody (\writeEnd -> do- i <- trans writeEnd- enum $ iterateeDebugWrapper "transformRequestBody" i)+ let i = iterateeDebugWrapper "transformRequestBody"+ $ trans writeEnd+ st <- liftIO $ runIteratee i++ enum st) $ origRsp { rspTransformingRqBody = True } finishWith rsp @@ -236,8 +267,8 @@ ------------------------------------------------------------------------------ -- | Short-circuits a 'Snap' monad action early, storing the given -- 'Response' value in its state.-finishWith :: Response -> Snap a-finishWith = Snap . return . Just . Left+finishWith :: MonadSnap m => Response -> m a+finishWith = liftSnap . Snap . return . Just . Left {-# INLINE finishWith #-} @@ -245,14 +276,14 @@ -- | 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@@ -276,10 +307,11 @@ ------------------------------------------------------------------------------ -- 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@@ -294,9 +326,10 @@ -- -- Will fail if 'rqPathInfo' is not \"@\/foo@\" 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@@ -306,20 +339,21 @@ --------------------------------------------------------------------------------- | Runs a 'Snap' 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 :: ByteString -- ^ path to match against- -> Snap a -- ^ handler to run- -> Snap a+-- | Runs a 'Snap' 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+ => 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 #-} @@ -340,53 +374,55 @@ ------------------------------------------------------------------------------ -- | 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 #-} ------------------------------------------------------------------------------ -- | 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--- using 'redirect\'' instead, which allows you to choose the correct status--- code.-redirect :: ByteString -> Snap ()+-- 'Snap' 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 target = redirect' target 302 {-# INLINE redirect #-} @@ -396,7 +432,7 @@ -- 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 -- validated in any way.-redirect' :: ByteString -> Int -> Snap ()+redirect' :: MonadSnap m => ByteString -> Int -> m () redirect' target status = do r <- getResponse @@ -411,8 +447,8 @@ ------------------------------------------------------------------------------ -- | 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 #-} @@ -420,41 +456,42 @@ ------------------------------------------------------------------------------ -- | 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 enum = modifyResponse $ modifyResponseBody (>. enum)+addToOutput :: MonadSnap m+ => (forall a . Enumerator ByteString IO 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.+-- | Adds the given strict 'ByteString' to the body of the 'Response' stored+-- in the 'Snap' 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 :: 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.+-- | Adds the given lazy 'L.ByteString' to the body of the 'Response' stored+-- in the 'Snap' 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 :: 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.+-- | Adds the given strict 'T.Text' to the body of the 'Response' stored in+-- the 'Snap' 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 :: T.Text -> Snap ()+writeText :: MonadSnap m => T.Text -> m () writeText s = writeBS $ T.encodeUtf8 s @@ -465,7 +502,7 @@ -- 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 :: LT.Text -> Snap ()+writeLazyText :: MonadSnap m => LT.Text -> m () writeLazyText s = writeLBS $ LT.encodeUtf8 s @@ -477,24 +514,24 @@ -- 'sendFile', Snap will use the efficient @sendfile()@ system call on -- platforms that support it. ----- If the response body is modified (using 'modifyResponseBody'), the file will--- be read using @mmap()@.-sendFile :: FilePath -> Snap ()+-- If the response body is modified (using 'modifyResponseBody'), the file+-- will be read using @mmap()@.+sendFile :: (MonadSnap m) => FilePath -> m () sendFile f = modifyResponse $ \r -> r { rspBody = SendFile f Nothing } --------------------------------------------------------------------------------- | Sets the output to be the contents of the specified file, within the given--- (start,end) range.+-- | Sets the output to be the contents of the specified file, within the+-- given (start,end) range. ----- Calling 'sendFilePartial' will overwrite any output queued to be sent in the--- 'Response'. If the response body is not modified after the call to+-- Calling 'sendFilePartial' will overwrite any output queued to be sent in+-- the 'Response'. If the response body is not modified after the call to -- 'sendFilePartial', Snap will use the efficient @sendfile()@ system call on -- platforms that support it. ----- If the response body is modified (using 'modifyResponseBody'), the file will--- be read using @mmap()@.-sendFilePartial :: FilePath -> (Int64,Int64) -> Snap ()+-- If the response body is modified (using 'modifyResponseBody'), the file+-- will be read using @mmap()@.+sendFilePartial :: (MonadSnap m) => FilePath -> (Int64,Int64) -> m () sendFilePartial f rng = modifyResponse $ \r -> r { rspBody = SendFile f (Just rng) } @@ -503,7 +540,7 @@ -- | 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 @@ -520,14 +557,14 @@ ------------------------------------------------------------------------------ -- | 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 #-} @@ -545,7 +582,7 @@ -- 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" @@ -562,7 +599,7 @@ -- 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 @@ -576,6 +613,35 @@ ------------------------------------------------------------------------------+-- | This function brackets a Snap action in resource acquisition and+-- release. This is provided because MonadCatchIO's 'bracket' function+-- doesn't work properly in the case of a short-circuit return from+-- the action being bracketed.+--+-- In order to prevent confusion regarding the effects of the+-- aquisition and release actions on the Snap state, this function+-- doesn't accept Snap actions for the acquire or release actions.+--+-- This function will run the release action in all cases where the+-- acquire action succeeded. This includes the following behaviors+-- from the bracketed Snap action.+--+-- 1. Normal completion+--+-- 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+ a <- liftIO before+ let after' = liftIO $ after a+ (Snap thing') = thing a+ r <- unblock thing' `onException` after'+ _ <- after'+ return r+++------------------------------------------------------------------------------ -- | This exception is thrown if the handler you supply to 'runSnap' fails. data NoHandlerException = NoHandlerException deriving (Eq, Typeable)@@ -595,7 +661,7 @@ runSnap :: Snap a -> (ByteString -> IO ()) -> Request- -> Iteratee IO (Request,Response)+ -> Iteratee ByteString IO (Request,Response) runSnap (Snap m) logerr req = do (r, ss') <- runStateT m ss @@ -613,7 +679,7 @@ where fourohfour = setContentLength 3 $ setResponseStatus 404 "Not Found" $- modifyResponseBody (>. enumBS "404") $+ modifyResponseBody (>==> enumBS "404") $ emptyResponse dresp = emptyResponse { rspHttpVersion = rqVersion req }@@ -626,7 +692,7 @@ evalSnap :: Snap a -> (ByteString -> IO ()) -> Request- -> Iteratee IO a+ -> Iteratee ByteString IO a evalSnap (Snap m) logerr req = do (r, _) <- runStateT m ss @@ -652,10 +718,20 @@ -- -- @ '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+++------------------------------------------------------------------------------+-- | Gets the HTTP 'Cookie' with the specified name.+getCookie :: MonadSnap m+ => ByteString+ -> m (Maybe Cookie)+getCookie name = withRequest $+ return . listToMaybe . filter (\c -> cookieName c == name) . rqCookies
src/Snap/Iteratee.hs view
@@ -7,264 +7,334 @@ {-# LANGUAGE TypeSynonymInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} +------------------------------------------------------------------------------ -- | Snap Framework type aliases and utilities for iteratees. Note that as a--- convenience, this module also exports everything from @Data.Iteratee@ in the--- @iteratee@ library.------ /WARNING/: Note that all of these types are scheduled to change in the--- @darcs@ head version of the @iteratee@ library; John Lato et al. are working--- on a much improved iteratee formulation.+-- convenience, this module also exports everything from @Data.Enumerator@ in+-- the @enumerator@ library. module Snap.Iteratee- ( -- * Convenience aliases around types from @Data.Iteratee@- Stream- , IterV- , Iteratee- , Enumerator-- -- * Re-export types and functions from @Data.Iteratee@- , module Data.Iteratee-- -- * Helper functions-- -- ** Enumerators- , enumBS+ (+ -- * Enumerators+ enumBS , enumLBS , enumFile , enumFilePartial , InvalidRangeException - -- ** Conversion to/from 'WrappedByteString'- , fromWrap- , toWrap - -- ** Iteratee utilities- , drop'- , takeExactly- , takeNoMoreThan+ -- * Iteratee utilities , countBytes- , bufferIteratee+ , drop' , mkIterateeBuffer , unsafeBufferIterateeWithBuffer , unsafeBufferIteratee+ , take+ , drop+ , takeExactly+ , takeNoMoreThan+ , skipToEof++ , TooManyBytesReadException+ , ShortWriteException++ -- * Re-export types and functions from @Data.Enumerator@+ , Stream (..)+ , Step (..)+ , Iteratee (..)+ , Enumerator+ , Enumeratee++ -- ** Primitives+ -- *** Combinators+ -- | These are common patterns which occur whenever iteratees are+ -- being defined.+ , returnI+ , yield+ , continue+ , throwError+ , catchError+ , liftI+ , (>>==)+ , (==<<)+ , ($$)+ , (>==>)+ , (<==<)++ -- *** Iteratees+ , run+ , run_+ , consume+ , Data.Enumerator.isEOF+ , liftTrans+ , liftFoldL+ , liftFoldL'+ , liftFoldM+ , printChunks+ , head+ , peek++ -- *** Enumerators+ , enumEOF+ , enumList+ , concatEnums+ -- *** Enumeratees+ , checkDone+ , Data.Enumerator.map+ , Data.Enumerator.sequence+ , joinI+++{-+ -- ** Iteratee utilities+ , drop'++-} ) where -------------------------------------------------------------------------------import Control.Monad-import Control.Monad.CatchIO++{-+ import Control.Exception (SomeException)-import Data.ByteString (ByteString)-import qualified Data.ByteString as S-import qualified Data.ByteString.Unsafe as S-import qualified Data.ByteString.Lazy as L+import "MonadCatchIO-transformers" Control.Monad.CatchIO import qualified Data.DList as D-import Data.Int import Data.IORef-import Data.Iteratee-import Data.Iteratee.IO (enumHandle)-import qualified Data.Iteratee.Base.StreamChunk as SC-import Data.Iteratee.WrappedByteString-import qualified Data.ListLike as LL+import Prelude hiding (catch,drop)++-}++import Control.DeepSeq+import Control.Exception (SomeException, assert)+import Control.Monad+import "MonadCatchIO-transformers" Control.Monad.CatchIO+import Control.Monad.Trans (MonadIO, lift, liftIO)+import Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as S+import qualified Data.ByteString.Unsafe as S+import qualified Data.ByteString.Lazy.Char8 as L+import Data.Enumerator hiding (drop)+import Data.Enumerator.IO (enumHandle)+import Data.List (foldl') import Data.Monoid (mappend) import Data.Typeable-import Foreign+import Foreign hiding (peek) import Foreign.C.Types import GHC.ForeignPtr-import Prelude hiding (catch,drop)+import Prelude hiding (drop, head, take) import System.IO-import "monads-fd" Control.Monad.Trans (liftIO) #ifndef PORTABLE import System.IO.Posix.MMap import System.PosixCompat.Files+import System.PosixCompat.Types #endif ------------------------------------------------------------------------------- -type Stream = StreamG WrappedByteString Word8-type IterV m = IterGV WrappedByteString Word8 m-type Iteratee m = IterateeG WrappedByteString Word8 m-type Enumerator m a = Iteratee m a -> m (Iteratee m a)-- ------------------------------------------------------------------------------ instance (Functor m, MonadCatchIO m) =>- MonadCatchIO (IterateeG s el m) where+ MonadCatchIO (Iteratee s m) where --catch :: Exception e => m a -> (e -> m a) -> m a- catch m handler = IterateeG $ \str -> do- ee <- try $ runIter m str+ catch m handler = Iteratee $ do+ ee <- try $ runIteratee m case ee of- (Left e) -> runIter (handler e) str+ (Left e) -> runIteratee (handler e) (Right v) -> return v --block :: m a -> m a- block m = IterateeG $ \str -> block $ runIter m str- unblock m = IterateeG $ \str -> unblock $ runIter m str+ block m = Iteratee $ block $ runIteratee m+ unblock m = Iteratee $ unblock $ runIteratee m + --------------------------------------------------------------------------------- | Wraps an 'Iteratee', counting the number of bytes consumed by it.-countBytes :: (Monad m) => Iteratee m a -> Iteratee m (a, Int64)-countBytes = go 0- where- go !n iter = IterateeG $ f n iter+-- | Get the length of a bytestring Stream+streamLength :: Stream ByteString -> Int+streamLength (Chunks xs) = foldl' (\c s -> c + S.length s) 0 xs+streamLength EOF = 0 - f !n !iter ch@(Chunk ws) = do- iterv <- runIter iter ch- case iterv of- Done x rest -> let !n' = n + m - len rest- in return $! Done (x, n') rest- Cont i err -> return $ Cont ((go $! n + m) i) err- where- m = fromIntegral $ S.length (unWrap ws) - len (EOF _) = 0- len (Chunk s) = fromIntegral $ S.length (unWrap s)-- f !n !iter stream = do- iterv <- runIter iter stream- case iterv of- Done x rest -> return $ Done (x, n) rest- Cont i err -> return $ Cont (go n i) err+------------------------------------------------------------------------------+-- | Enumerates a strict bytestring.+enumBS :: (Monad m) => ByteString -> Enumerator ByteString m a+enumBS bs (Continue k) = k (Chunks [bs])+enumBS bs (Yield x s) = Iteratee $ return $ Yield x (s `mappend` Chunks [bs])+enumBS _ (Error e) = Iteratee $ return $ Error e+{-# INLINE enumBS #-} --------------------------------------------------------------------------------- | Buffers an iteratee.------ Our enumerators produce a lot of little strings; rather than spending all--- our time doing kernel context switches for 4-byte write() calls, we buffer--- the iteratee to send 8KB at a time.------ The IORef returned can be set to True to "cancel" buffering. We added this--- so that transfer-encoding: chunked (which needs its own buffer and therefore--- doesn't need /its/ output buffered) can switch the outer buffer off.----bufferIteratee :: Iteratee IO a -> IO (Iteratee IO a, IORef Bool)-bufferIteratee iteratee = do- esc <- newIORef False- return $ (start esc iteratee, esc)+-- | Enumerates a lazy bytestring. - where- blocksize = 8192+enumLBS :: (Monad m) => L.ByteString -> Enumerator ByteString m a+enumLBS bs = enumList 1 (L.toChunks bs)+{-# INLINE enumLBS #-} - start esc iter = IterateeG $! checkRef esc iter - checkRef esc iter ch = do- quit <- readIORef esc- if quit- then runIter iter ch- else f (D.empty,0) iter ch+------------------------------------------------------------------------------+skipToEof :: (Monad m) => Iteratee a m ()+skipToEof = continue k+ where+ k EOF = return ()+ k _ = skipToEof - --go :: (DList ByteString, Int) -> Iteratee m a -> Iteratee m a- go (!dl,!n) iter = IterateeG $! f (dl,n) iter - --f :: (DList ByteString, Int) -> Iteratee m a -> Stream -> m (IterV m a)- f _ !iter ch@(EOF (Just _)) = runIter iter ch- f (!dl,_) !iter ch@(EOF Nothing) = do- iter' <- if S.null str- then return iter- else liftM liftI $ runIter iter $ Chunk big- runIter iter' ch- where- str = S.concat $ D.toList dl- big = WrapBS str+------------------------------------------------------------------------------+-- | Wraps an 'Iteratee', counting the number of bytes consumed by it.+countBytes :: (Monad m) => forall a .+ Iteratee ByteString m a+ -> Iteratee ByteString m (a, Int64)+countBytes i = Iteratee $ do+ step <- runIteratee i+ case step of+ (Continue k) -> return (Continue $ go 0 k)+ (Yield x s) -> return $ Yield (x,0) s+ (Error e) -> return $ Error e - f (!dl,!n) iter (Chunk (WrapBS s)) =- if n' >= blocksize- then do- iterv <- runIter iter (Chunk big)- case iterv of- Done x rest -> return $ Done x rest- Cont i (Just e) -> return $ Cont i (Just e)- Cont i Nothing -> return $ Cont (go (D.empty,0) i) Nothing- else return $ Cont (go (dl',n') iter) Nothing- where- m = S.length s- n' = n+m- dl' = D.snoc dl s- big = WrapBS $ S.concat $ D.toList dl'+ where+ go !n k str = Iteratee $ do+ let len = toEnum $ streamLength str+ step <- runIteratee (k str)+ case step of+ (Continue k') -> return (Continue $ go (n + len) k')+ (Yield x s) -> let len' = n + len - (toEnum $ streamLength s)+ in return (Yield (x, len') s)+ (Error e) -> return (Error e) +------------------------------------------------------------------------------ bUFSIZ :: Int bUFSIZ = 8192 +------------------------------------------------------------------------------ -- | Creates a buffer to be passed into 'unsafeBufferIterateeWithBuffer'. mkIterateeBuffer :: IO (ForeignPtr CChar) mkIterateeBuffer = mallocPlainForeignPtrBytes bUFSIZ + --------------------------------------------------------------------------------- | Buffers an iteratee, \"unsafely\". Here we use a fixed binary buffer which--- we'll re-use, meaning that if you hold on to any of the bytestring data--- passed into your iteratee (instead of, let's say, shoving it right out a--- socket) it'll get changed out from underneath you, breaking referential+-- | Buffers an iteratee, \"unsafely\". Here we use a fixed binary buffer+-- which we'll re-use, meaning that if you hold on to any of the bytestring+-- data passed into your iteratee (instead of, let's say, shoving it right out+-- a socket) it'll get changed out from underneath you, breaking referential -- transparency. Use with caution!----unsafeBufferIteratee :: Iteratee IO a -> IO (Iteratee IO a)-unsafeBufferIteratee iter = do+unsafeBufferIteratee :: Iteratee ByteString IO a+ -> IO (Iteratee ByteString IO a)+unsafeBufferIteratee step = do buf <- mkIterateeBuffer- unsafeBufferIterateeWithBuffer buf iter+ return $ unsafeBufferIterateeWithBuffer buf step --------------------------------------------------------------------------------- | Buffers an iteratee, \"unsafely\". Here we use a fixed binary buffer which--- we'll re-use, meaning that if you hold on to any of the bytestring data--- passed into your iteratee (instead of, let's say, shoving it right out a--- socket) it'll get changed out from underneath you, breaking referential+-- | Buffers an iteratee, \"unsafely\". Here we use a fixed binary buffer+-- which we'll re-use, meaning that if you hold on to any of the bytestring+-- data passed into your iteratee (instead of, let's say, shoving it right out+-- a socket) it'll get changed out from underneath you, breaking referential -- transparency. Use with caution! -- -- This version accepts a buffer created by 'mkIterateeBuffer'. -- unsafeBufferIterateeWithBuffer :: ForeignPtr CChar- -> Iteratee IO a- -> IO (Iteratee IO a)-unsafeBufferIterateeWithBuffer buf iteratee = do- return $! start iteratee+ -> Iteratee ByteString IO a+ -> Iteratee ByteString IO a+unsafeBufferIterateeWithBuffer buf iter = Iteratee $ do+ step <- runIteratee iter+ start step where- start iter = IterateeG $! f 0 iter- go bytesSoFar iter =- {-# SCC "unsafeBufferIteratee/go" #-}- IterateeG $! f bytesSoFar iter+ --------------------------------------------------------------------------+ start :: Step ByteString IO a -> IO (Step ByteString IO a)+ start (Continue k) = return $ Continue $ go 0 k+ start s@_ = return s - sendBuf n iter =- {-# SCC "unsafeBufferIteratee/sendBuf" #-}++ --------------------------------------------------------------------------+ sendBuf :: Int+ -> (Stream ByteString -> Iteratee ByteString IO a)+ -> IO (Step ByteString IO a)+ sendBuf n k =+ {-# SCC "unsafeBufferIteratee/sendBuf" #-} do+ assert (n > 0) (return ())+ assert (n <= bUFSIZ) (return ())+ withForeignPtr buf $ \ptr -> do- s <- S.unsafePackCStringLen (ptr, n)- runIter iter $ Chunk $ WrapBS s+ !s <- S.unsafePackCStringLen (ptr, n)+ runIteratee $ k $ Chunks [s] - copy c@(EOF _) = c- copy (Chunk (WrapBS s)) = Chunk $ WrapBS $ S.copy s - f _ iter ch@(EOF (Just _)) = runIter iter ch+ --------------------------------------------------------------------------+ copy EOF = EOF+ copy (Chunks xs) = zs `deepseq` Chunks ys+ where+ !ys = Prelude.map S.copy xs+ !zs = Prelude.map (`seq` ()) ys - f !n iter ch@(EOF Nothing) =+ --------------------------------------------------------------------------+ go :: Int+ -> (Stream ByteString -> Iteratee ByteString IO a)+ -> (Stream ByteString -> Iteratee ByteString IO a)+ go !n !k EOF = Iteratee $ do if n == 0- then runIter iter ch+ then runIteratee $ k EOF else do- iter' <- liftM liftI $ sendBuf n iter- runIter iter' ch+ assert (n > 0) (return ())+ assert (n <= bUFSIZ) (return ()) - f !n iter (Chunk (WrapBS s)) = do+ step <- sendBuf n k+ step2 <- runIteratee $ enumEOF step+ return $ copyStep step2+++ go !n !k (Chunks xs) = Iteratee $ do+ assert (n >= 0) (return ())+ assert (n <= bUFSIZ) (return ())++ let s = S.concat xs let m = S.length s- if m+n > bUFSIZ- then overflow n iter s m- else copyAndCont n iter s m+ if m+n >= bUFSIZ+ then overflow n k s m+ else copyAndCont n k s m - copyAndCont n iter s m =++ --------------------------------------------------------------------------+ copyStep (Yield x r) = let !z = copy r in Yield x z+ copyStep x = x+++ --------------------------------------------------------------------------+ copyAndCont :: Int+ -> (Stream ByteString -> Iteratee ByteString IO a)+ -> ByteString+ -> Int+ -> IO (Step ByteString IO a)+ copyAndCont !n k !s !m = {-# SCC "unsafeBufferIteratee/copyAndCont" #-} do- S.unsafeUseAsCStringLen s $ \(p,sz) ->- withForeignPtr buf $ \bufp -> do- let b' = plusPtr bufp n- copyBytes b' p sz+ assert (n >= 0) (return ())+ assert (n+m < bUFSIZ) (return ())+ S.unsafeUseAsCStringLen s $ \(p,sz) -> do+ assert (m == sz) (return ())+ withForeignPtr buf $ \bufp -> do+ let b' = plusPtr bufp n+ copyBytes b' p sz - return $ Cont (go (n+m) iter) Nothing+ return $ Continue $ go (n+m) k - overflow n iter s m =++ --------------------------------------------------------------------------+ overflow :: Int+ -> (Stream ByteString -> Iteratee ByteString IO a)+ -> ByteString+ -> Int+ -> IO (Step ByteString IO a)+ overflow !n k !s !m = {-# SCC "unsafeBufferIteratee/overflow" #-} do- let rest = bUFSIZ - n- let m2 = m - rest+ assert (n+m >= bUFSIZ) (return ())+ assert (n < bUFSIZ) (return ())++ let rest = bUFSIZ - n+ let m2 = m - rest+ let (s1,s2) = S.splitAt rest s S.unsafeUseAsCStringLen s1 $ \(p,_) ->@@ -272,165 +342,206 @@ let b' = plusPtr bufp n copyBytes b' p rest - iv <- sendBuf bUFSIZ iter+ iv <- sendBuf bUFSIZ k case iv of- Done x r -> return $- Done x (copy r `mappend` (Chunk $ WrapBS s2))- Cont i (Just e) -> return $ Cont i (Just e)- Cont i Nothing -> do+ (Yield x r) -> let !z = copy r+ in return $ Yield x $ (z `mappend` Chunks [s2])+ (Error e) -> return $ Error e+ (Continue k') -> do -- check the size of the remainder; if it's bigger than the -- buffer size then just send it if m2 >= bUFSIZ then do- iv' <- runIter i (Chunk $ WrapBS s2)- case iv' of- Done x r -> return $ Done x (copy r)- Cont i' (Just e) -> return $ Cont i' (Just e)- Cont i' Nothing -> return $ Cont (go 0 i') Nothing- else copyAndCont 0 i s2 m2+ step <- runIteratee $ k' $ Chunks [s2]+ case step of+ (Yield x r) -> let !z = copy r+ in return $! Yield x z+ (Error e) -> return $ Error e+ (Continue k'') -> return $ Continue $ go 0 k'' + else copyAndCont 0 k' s2 m2 ---------------------------------------------------------------------------------- | Enumerates a strict bytestring.-enumBS :: (Monad m) => ByteString -> Enumerator m a-enumBS bs = enumPure1Chunk $ WrapBS bs-{-# INLINE enumBS #-} +------------------------------------------------------------------------------+-- | Skip n elements of the stream, if there are that many+drop :: (Monad m) => Int -> Iteratee ByteString m ()+drop k = drop' (toEnum k) --------------------------------------------------------------------------------- | Enumerates a lazy bytestring.-enumLBS :: (Monad m) => L.ByteString -> Enumerator m a-enumLBS lbs = el chunks+-- | Skip n elements of the stream, if there are that many+drop' :: (Monad m) => Int64 -> Iteratee ByteString m ()+drop' 0 = return ()+drop' !n = continue k+ where- el [] i = return i- el (x:xs) i = do- i' <- liftM liftI $ runIter i (Chunk $ WrapBS x)- el xs i'+ k EOF = return ()+ k (Chunks xs) = chunks n xs - chunks = L.toChunks lbs+ chunks !m [] = drop' m+ chunks !m (x:xs) = do+ let strlen = toEnum $ S.length x+ if strlen <= m+ then chunks (m-strlen) xs+ else yield () $ Chunks ((S.drop (fromEnum m) x):xs) --------------------------------------------------------------------------------- | Converts a lazy bytestring to a wrapped bytestring.-toWrap :: L.ByteString -> WrappedByteString Word8-toWrap = WrapBS . S.concat . L.toChunks-{-# INLINE toWrap #-}+data ShortWriteException = ShortWriteException+ deriving (Typeable) --------------------------------------------------------------------------------- | Converts a wrapped bytestring to a lazy bytestring.-fromWrap :: WrappedByteString Word8 -> L.ByteString-fromWrap = L.fromChunks . (:[]) . unWrap-{-# INLINE fromWrap #-}+instance Show ShortWriteException where+ show ShortWriteException = "Short write" --------------------------------------------------------------------------------- | Skip n elements of the stream, if there are that many--- This is the Int64 version of the drop function in the iteratee library-drop' :: (SC.StreamChunk s el, Monad m)- => Int64- -> IterateeG s el m ()-drop' 0 = return ()-drop' n = IterateeG step- where- step (Chunk str)- | strlen <= n = return $ Cont (drop' (n - strlen)) Nothing- where- strlen = fromIntegral $ SC.length str- step (Chunk str) = return $ Done () (Chunk (LL.drop (fromIntegral n) str))- step stream = return $ Done () stream+instance Exception ShortWriteException --------------------------------------------------------------------------------- | Reads n elements from a stream and applies the given iteratee to--- the stream of the read elements. Reads exactly n elements, and if--- the stream is short propagates an error.-takeExactly :: (SC.StreamChunk s el, Monad m)- => Int64- -> EnumeratorN s el s el m a-takeExactly 0 iter = return iter-takeExactly n' iter =- if n' < 0- then takeExactly 0 iter- else IterateeG (step n')+data TooManyBytesReadException = TooManyBytesReadException+ deriving (Typeable)+++------------------------------------------------------------------------------+instance Show TooManyBytesReadException where+ show TooManyBytesReadException = "Too many bytes read"+++------------------------------------------------------------------------------+instance Exception TooManyBytesReadException++++------------------------------------------------------------------------------+take :: (Monad m) => Int -> Enumeratee ByteString ByteString m a+take k = take' (toEnum k)+++------------------------------------------------------------------------------+take' :: (Monad m) => Int64 -> Enumeratee ByteString ByteString m a+take' _ y@(Yield _ _ ) = return y+take' _ (Error e ) = throwError e+take' !n st@(Continue k) = do+ if n == 0+ then lift $ runIteratee $ k EOF+ else do+ mbX <- head+ maybe (lift $ runIteratee $ k EOF)+ check+ mbX+ where- step n chk@(Chunk str)- | SC.null str = return $ Cont (takeExactly n iter) Nothing- | strlen < n = liftM (flip Cont Nothing) inner- | otherwise = done (Chunk s1) (Chunk s2)+ check x | S.null x = take' n st+ | strlen <= n = do+ newStep <- lift $ runIteratee $ k $ Chunks [x]+ take' (n-strlen) newStep+ | otherwise = do+ step1 <- lift $ runIteratee $ k $ Chunks [s1]+ step2 <- lift $ runIteratee $ enumEOF step1++ case step2 of+ (Yield v _) -> yield (Yield v EOF) (Chunks [s2])+ (Error e) -> throwError e+ (Continue _) -> error "divergent iteratee" where- strlen = fromIntegral $ SC.length str- inner = liftM (check (n - strlen)) (runIter iter chk)- (s1, s2) = SC.splitAt (fromIntegral n) str- step _n (EOF (Just e)) = return $ Cont undefined (Just e)- step _n (EOF Nothing) = return $ Cont undefined (Just (Err "short write"))- check n (Done x _) = drop' n >> return (return x)- check n (Cont x Nothing) = takeExactly n x- check n (Cont _ (Just e)) = drop' n >> throwErr e- done s1 s2 = liftM (flip Done s2) (runIter iter s1 >>= checkIfDone return)+ strlen = toEnum $ S.length x+ (s1,s2) = S.splitAt (fromEnum n) x --------------------------------------------------------------------------------- | Reads up to n elements from a stream and applies the given iteratee to the--- stream of the read elements. If more than n elements are read, propagates an--- error.-takeNoMoreThan :: (SC.StreamChunk s el, Monad m)- => Int64- -> EnumeratorN s el s el m a-takeNoMoreThan n' iter =- if n' < 0- then takeNoMoreThan 0 iter- else IterateeG (step n')+-- | Reads n bytes from a stream and applies the given iteratee to the stream+-- of the read elements. Reads exactly n bytes, and if the stream is short+-- propagates an error.+takeExactly :: (Monad m)+ => Int64+ -> Enumeratee ByteString ByteString m a+takeExactly 0 s = do+ s' <- lift $ runIteratee $ enumEOF s+ case s' of+ (Continue _) -> error "divergent iteratee"+ (Error e) -> throwError e+ (Yield v _) -> yield (Yield v EOF) EOF++takeExactly !n y@(Yield _ _ ) = drop' n >> return y+takeExactly _ (Error e ) = throwError e+takeExactly !n st@(Continue k) = do+ if n == 0+ then lift $ runIteratee $ k EOF+ else do+ mbX <- head+ maybe (throwError ShortWriteException)+ check+ mbX+ where- step n chk@(Chunk str)- | SC.null str = return $ Cont (takeNoMoreThan n iter) Nothing- | strlen < n = liftM (flip Cont Nothing) inner- | otherwise = done (Chunk s1) (Chunk s2)- where- strlen = fromIntegral $ SC.length str- inner = liftM (check (n - strlen)) (runIter iter chk)- (s1, s2) = SC.splitAt (fromIntegral n) str+ check x | S.null x = takeExactly n st+ | strlen < n = do+ newStep <- lift $ runIteratee $ k $ Chunks [x]+ takeExactly (n-strlen) newStep+ | otherwise = do+ step1 <- lift $ runIteratee $ k $ Chunks [s1]+ step2 <- lift $ runIteratee $ enumEOF step1 - step _n (EOF (Just e)) = return $ Cont undefined (Just e)- step _n chk@(EOF Nothing) = do- v <- runIter iter chk+ case step2 of+ (Continue _) -> error "divergent iteratee"+ (Error e) -> throwError e+ (Yield v _) -> yield (Yield v EOF) (Chunks [s2]) - case v of- (Done x s) -> return $ Done (return x) s- (Cont _ (Just e)) -> return $ Cont undefined (Just e)- (Cont _ Nothing) -> return $ Cont (throwErr $ Err "premature EOF") Nothing+ where+ strlen = toEnum $ S.length x+ (s1,s2) = S.splitAt (fromEnum n) x - check _ v@(Done _ _) = return $ liftI v- check n (Cont x Nothing) = takeNoMoreThan n x- check _ (Cont _ (Just e)) = throwErr e - done _ (EOF _) = error "impossible"- done s1 s2@(Chunk s2') = do- v <- runIter iter s1- case v of- (Done x s') -> return $ Done (return x) (s' `mappend` s2)- (Cont _ (Just e)) -> return $ Cont undefined (Just e)- (Cont i Nothing) ->- if SC.null s2'- then return $ Cont (takeNoMoreThan 0 i) Nothing- else return $ Cont undefined (Just $ Err "too many bytes")+------------------------------------------------------------------------------+takeNoMoreThan :: (Monad m) =>+ Int64 -> Enumeratee ByteString ByteString m a+takeNoMoreThan _ y@(Yield _ _) = return y+takeNoMoreThan _ (Error e ) = throwError e+takeNoMoreThan !n st@(Continue k) = do+ mbX <- head+ maybe (lift $ runIteratee $ k EOF)+ check+ mbX + where+ check x | S.null x = takeNoMoreThan n st+ | strlen <= n = do+ newStep <- lift $ runIteratee $ k $ Chunks [x]+ takeNoMoreThan (n-strlen) newStep+ | otherwise = do+ step1 <- lift $ runIteratee $ k $ Chunks [s1]+ case step1 of+ (Yield v rest) -> yield (Yield v EOF)+ (rest `mappend` Chunks [s2])+ (Error e) -> throwError e+ (Continue _) -> throwError TooManyBytesReadException+ where+ strlen = toEnum $ S.length x+ (s1,s2) = S.splitAt (fromEnum n) x + ------------------------------------------------------------------------------ {-# INLINE _enumFile #-}-_enumFile :: FilePath -> Iteratee IO a -> IO (Iteratee IO a)+_enumFile :: FilePath+ -> Enumerator ByteString IO a _enumFile fp iter = do h <- liftIO $ openBinaryFile fp ReadMode- enumHandle h iter `finally` hClose h+ enumHandle 32678 h iter `finally` (liftIO $ hClose h) ------------------------------------------------------------------------------ data InvalidRangeException = InvalidRangeException deriving (Typeable) ++------------------------------------------------------------------------------ instance Show InvalidRangeException where show InvalidRangeException = "Invalid range" ++------------------------------------------------------------------------------ instance Exception InvalidRangeException @@ -438,22 +549,26 @@ {-# INLINE _enumFilePartial #-} _enumFilePartial :: FilePath -> (Int64,Int64)- -> Iteratee IO a- -> IO (Iteratee IO a)+ -> Enumerator ByteString IO a _enumFilePartial fp (start,end) iter = do let len = end - start- withBinaryFile fp ReadMode- (\h -> do- unless (start == 0) $ hSeek h AbsoluteSeek $ toInteger start- enumHandle h $ joinI $ takeExactly len iter) + bracket (liftIO $ openBinaryFile fp ReadMode)+ (liftIO . hClose)+ (\h -> do+ unless (start == 0) $ liftIO $+ hSeek h AbsoluteSeek $ toInteger start+ step <- lift $ runIteratee $ joinI $ takeExactly len iter+ enumHandle 32678 h step) -enumFile :: FilePath -> Iteratee IO a -> IO (Iteratee IO a)++------------------------------------------------------------------------------+enumFile :: FilePath -> Enumerator ByteString IO a enumFilePartial :: FilePath -> (Int64,Int64)- -> Iteratee IO a- -> IO (Iteratee IO a)+ -> Enumerator ByteString IO a + #ifdef PORTABLE enumFile = _enumFile@@ -467,53 +582,49 @@ maxMMapFileSize :: FileOffset maxMMapFileSize = 41943040 ++------------------------------------------------------------------------------ tooBigForMMap :: FilePath -> IO Bool tooBigForMMap fp = do stat <- getFileStatus fp return $ fileSize stat > maxMMapFileSize -enumFile fp iter = do- -- for small files we'll use mmap to save ourselves a copy, otherwise we'll- -- stream it- tooBig <- tooBigForMMap fp+------------------------------------------------------------------------------+enumFile _ (Error e) = throwError e+enumFile _ (Yield x _) = yield x EOF+enumFile fp st@(Continue k) = do+ -- for small files we'll use mmap to save ourselves a copy, otherwise+ -- we'll stream it+ tooBig <- lift $ tooBigForMMap fp if tooBig- then _enumFile fp iter+ then _enumFile fp st else do- es <- try $- liftM WrapBS $- unsafeMMapFile fp-+ es <- try $ lift $ unsafeMMapFile fp case es of- (Left (e :: SomeException)) -> return $ throwErr- $ Err- $ "IO error" ++ show e-- (Right s) -> liftM liftI $ runIter iter $ Chunk s+ (Left (e :: SomeException)) -> throwError e+ (Right s) -> k $ Chunks [s] -enumFilePartial fp rng@(start,end) iter = do- when (end < start) $ throw InvalidRangeException+------------------------------------------------------------------------------+enumFilePartial _ _ (Error e) = throwError e+enumFilePartial _ _ (Yield x _) = yield x EOF+enumFilePartial fp rng@(start,end) st@(Continue k) = do+ when (end < start) $ throwError InvalidRangeException let len = end - start - tooBig <- tooBigForMMap fp+ tooBig <- lift $ tooBigForMMap fp if tooBig- then _enumFilePartial fp rng iter+ then _enumFilePartial fp rng st else do- es <- try $ unsafeMMapFile fp+ es <- try $ lift $ unsafeMMapFile fp case es of- (Left (e::SomeException)) -> return $ throwErr- $ Err- $ "IO error" ++ show e-- (Right s) -> liftM liftI $ runIter iter- $ Chunk- $ WrapBS- $ S.take (fromEnum len)- $ S.drop (fromEnum start) s+ (Left (e::SomeException)) -> throwError e+ (Right s) -> k $ Chunks [ S.take (fromEnum len) $+ S.drop (fromEnum start) s ] #endif
− src/Snap/Starter.hs
@@ -1,99 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}-module Main where---------------------------------------------------------------------------------import Char-import Data.List-import qualified Data.Text as T-import System-import System.Directory-import System.Console.GetOpt-import System.FilePath---------------------------------------------------------------------------------import Snap.StarterTH------------------------------------------------------------------------------------ Creates a value tDir :: ([String], [(String, String)])-$(buildData "tDirDefault" "default")-$(buildData "tDirBareBones" "barebones")----------------------------------------------------------------------------------usage :: String-usage = unlines- ["Usage:"- ,""- ," snap <action>"- ,""- ," <action> can be one of:"- ," init - create a new project directory structure in the current directory"- ]----------------------------------------------------------------------------------data InitFlag = InitBareBones- | InitHelp- deriving (Show, Eq)---setup :: String -> ([FilePath], [(String, String)]) -> IO ()-setup projName tDir = do- mapM createDirectory (fst tDir)- mapM_ write (snd tDir)- where- write (f,c) =- if isSuffixOf "foo.cabal" f- then writeFile (projName++".cabal") (insertProjName $ T.pack c)- else writeFile f c- isNameChar c = isAlphaNum c || c == '-'- insertProjName c = T.unpack $ T.replace- (T.pack "projname")- (T.pack $ filter isNameChar projName) c---------------------------------------------------------------------------------initProject :: [String] -> IO ()-initProject args = do- case getOpt Permute options args of- (flags, _, [])- | InitHelp `elem` flags -> do putStrLn initUsage- exitFailure- | otherwise -> init' (InitBareBones `elem` flags)-- (_, _, errs) -> do putStrLn $ concat errs- putStrLn initUsage- exitFailure- where- initUsage = unlines- ["Usage:"- ,""- ," snap init"- ,""- ," -b --barebones Depend only on -core and -server"- ," -h --help Print this message"- ]-- options =- [ Option ['b'] ["barebones"] (NoArg InitBareBones)- "Depend only on -core and -server"- , Option ['h'] ["help"] (NoArg InitHelp)- "Print this message"- ]-- init' isBareBones = do- cur <- getCurrentDirectory- let dirs = splitDirectories cur- projName = last dirs- setup projName (if isBareBones then tDirBareBones else tDirDefault)----------------------------------------------------------------------------------main :: IO ()-main = do- args <- getArgs- case args of- ("init":args') -> initProject args'- _ -> do putStrLn usage- exitFailure-
− src/Snap/StarterTH.hs
@@ -1,55 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}-module Snap.StarterTH where---------------------------------------------------------------------------------import qualified Data.Foldable as F-import Data.List-import Language.Haskell.TH-import System.Directory.Tree------------------------------------------------------------------------------------------------------------------------------------------------------------------- Convenience types-type FileData = (String, String)-type DirData = FilePath------------------------------------------------------------------------------------ Gets all the directorys in a DirTree-getDirs :: [FilePath] -> DirTree a -> [FilePath]-getDirs prefix (Dir n c) = (intercalate "/" (reverse (n:prefix))) : concatMap (getDirs (n:prefix)) c-getDirs _ (File _ _) = []-getDirs _ (Failed _ _) = []------------------------------------------------------------------------------------ Reads a directory and returns a tuple of the list of all directories--- encountered and a list of filenames and content strings.-readTree :: FilePath -> IO ([DirData], [FileData])-readTree dir = do- d <- readDirectory $ dir++"/."- let ps = zipPaths $ "" :/ (free d)- fd = F.foldr (:) [] ps- dirs = tail $ getDirs [] $ free d- return $ (dirs, fd)------------------------------------------------------------------------------------ Calls readTree and returns it's value in a quasiquote.-dirQ :: FilePath -> Q Exp-dirQ tplDir = do- d <- runIO $ readTree $ "project_template/"++tplDir- runQ [| d |]------------------------------------------------------------------------------------ Creates a declaration assigning the specified name the value returned by--- dirQ.-buildData :: String -> FilePath -> Q [Dec]-buildData dirName tplDir = do- v <- valD (varP (mkName dirName))- (normalB $ dirQ tplDir)- []- return [v]-
src/Snap/Types.hs view
@@ -9,9 +9,11 @@ -- * The Snap Monad Snap , runSnap+ , MonadSnap(..) , NoHandlerException(..) -- ** Functions for control flow and early termination+ , bracketSnap , finishWith , pass @@ -92,6 +94,7 @@ , rspStatusReason , setContentType , addCookie+ , getCookie , setContentLength , clearContentLength , redirect@@ -121,8 +124,10 @@ ------------------------------------------------------------------------------ import Snap.Internal.Http.Types+import Snap.Internal.Instances () import Snap.Internal.Routing import Snap.Internal.Types+import Snap.Iteratee (Enumerator) ------------------------------------------------------------------------------ -- $httpDoc
src/Snap/Util/FileServe.hs view
@@ -167,11 +167,13 @@ -- | 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+ let mp = urlDecode $ rqPathInfo req + p <- maybe pass (return . S.unpack) mp+ -- relative paths only! when (not $ isRelative p) pass @@ -184,23 +186,25 @@ ------------------------------------------------------------------------------ -- | Serves files out of the given directory. The relative path given in--- 'rqPathInfo' is searched for the given file, and the file is served with the--- appropriate mime type if it is found. Absolute paths and \"@..@\" are prohibited--- to prevent files from being served from outside the sandbox.+-- 'rqPathInfo' is searched for the given file, and the file is served with+-- the appropriate mime type if it is found. Absolute paths and \"@..@\" are+-- prohibited to prevent files from being served from outside the sandbox. -- -- 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@@ -218,8 +222,9 @@ -- | 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 #-}@@ -227,9 +232,10 @@ ------------------------------------------------------------------------------ -- | 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 reqOrig <- getRequest @@ -273,7 +279,8 @@ -- now check: is this a range request? If there is an 'If-Range' header- -- with an old modification time we skip this check and send a 200 response+ -- with an old modification time we skip this check and send a 200+ -- response let skipRangeCheck = maybe (False) (\lt -> mt > lt) mbIfRange@@ -282,7 +289,7 @@ -- partial response if it matches. wasRange <- if skipRangeCheck then return False- else checkRangeReq req fp sz+ else liftSnap $ checkRangeReq req fp sz dbg $ "was this a range request? " ++ Prelude.show wasRange @@ -290,7 +297,7 @@ unless wasRange $ do modifyResponse $ setResponseCode 200 . setContentLength sz- sendFile fp+ liftSnap $ sendFile fp where --------------------------------------------------------------------------@@ -341,7 +348,7 @@ -------------------------------------------------------------------------------checkRangeReq :: Request -> FilePath -> Int64 -> Snap Bool+checkRangeReq :: (MonadSnap m) => Request -> FilePath -> Int64 -> m Bool checkRangeReq req fp sz = do -- TODO/FIXME: multiple ranges dbg $ "checkRangeReq, fp=" ++ fp ++ ", sz=" ++ Prelude.show sz@@ -409,7 +416,7 @@ let crng = S.concat $ L.toChunks $ L.concat ["bytes */", show sz]- + modifyResponse $ setResponseCode 416 . setHeader "Content-Range" crng . setContentLength 0@@ -417,10 +424,10 @@ . deleteHeader "Content-Encoding" . deleteHeader "Transfer-Encoding" . setResponseBody (enumBS "")- - return True + return True +------------------------------------------------------------------------------ dbg :: (MonadIO m) => String -> m () dbg s = debug $ "FileServe:" ++ s
src/Snap/Util/GZip.hs view
@@ -1,34 +1,34 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PackageImports #-} {-# LANGUAGE ScopedTypeVariables #-} module Snap.Util.GZip ( withCompression , withCompression' ) where -import qualified Codec.Compression.GZip as GZip-import qualified Codec.Compression.Zlib as Zlib-import Control.Concurrent-import Control.Applicative hiding (many)-import Control.Exception-import Control.Monad-import Control.Monad.Trans-import Data.Attoparsec.Char8 hiding (Done)-import qualified Data.ByteString.Lazy.Char8 as L-import Data.ByteString.Char8 (ByteString)-import Data.Iteratee.WrappedByteString-import Data.Maybe-import qualified Data.Set as Set-import Data.Set (Set)-import Data.Typeable-import Prelude hiding (catch, takeWhile)+import qualified Codec.Compression.GZip as GZip+import qualified Codec.Compression.Zlib as Zlib+import Control.Concurrent+import Control.Applicative hiding (many)+import Control.Exception+import Control.Monad+import Control.Monad.Trans+import Data.Attoparsec.Char8 hiding (Done)+import qualified Data.ByteString.Lazy.Char8 as L+import Data.ByteString.Char8 (ByteString)+import Data.Maybe+import qualified Data.Set as Set+import Data.Set (Set)+import Data.Typeable+import Prelude hiding (catch, takeWhile) -------------------------------------------------------------------------------import Snap.Internal.Debug-import Snap.Internal.Parsing-import Snap.Iteratee hiding (Enumerator)-import Snap.Types+import Snap.Internal.Debug+import Snap.Internal.Parsing+import Snap.Iteratee+import Snap.Types ------------------------------------------------------------------------------@@ -54,26 +54,28 @@ -- -- Then the given handler's output stream will be compressed, -- @Content-Encoding@ will be set in the output headers, and the--- @Content-Length@ will be cleared if it was set. (We can't process the stream--- in O(1) space if the length is known beforehand.)+-- @Content-Length@ will be cleared if it was set. (We can't process the+-- stream in O(1) space if the length is known beforehand.) -- -- The wrapped handler will be run to completion, and then the 'Response' -- 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@@ -93,7 +95,6 @@ getResponse >>= finishWith where- chkAcceptEncoding :: Snap () chkAcceptEncoding = do req <- getRequest debug $ "checking accept-encoding"@@ -133,7 +134,7 @@ -------------------------------------------------------------------------------gzipCompression :: ByteString -> Snap ()+gzipCompression :: MonadSnap m => ByteString -> m () gzipCompression ce = modifyResponse f where f = setHeader "Content-Encoding" ce .@@ -143,7 +144,7 @@ -------------------------------------------------------------------------------compressCompression :: ByteString -> Snap ()+compressCompression :: MonadSnap m => ByteString -> m () compressCompression ce = modifyResponse f where f = setHeader "Content-Encoding" ce .@@ -153,83 +154,88 @@ -------------------------------------------------------------------------------gcompress :: forall a . Enumerator a -> Enumerator a+-- FIXME: use zlib-bindings+gcompress :: forall a . Enumerator ByteString IO a+ -> Enumerator ByteString IO a gcompress = compressEnumerator GZip.compress -------------------------------------------------------------------------------ccompress :: forall a . Enumerator a -> Enumerator a+ccompress :: forall a . Enumerator ByteString IO a+ -> Enumerator ByteString IO a ccompress = compressEnumerator Zlib.compress ------------------------------------------------------------------------------ compressEnumerator :: forall a . (L.ByteString -> L.ByteString)- -> Enumerator a- -> Enumerator a-compressEnumerator compFunc enum iteratee = do- writeEnd <- newChan- readEnd <- newChan- tid <- forkIO $ threadProc readEnd writeEnd+ -> Enumerator ByteString IO a+ -> Enumerator ByteString IO a+compressEnumerator compFunc enum origStep = do+ writeEnd <- liftIO $ newChan+ readEnd <- liftIO $ newChan+ tid <- liftIO $ forkIO $ threadProc readEnd writeEnd - enum (IterateeG $ f readEnd writeEnd tid iteratee)+ enum (f readEnd writeEnd tid origStep) where --------------------------------------------------------------------------- streamFinished :: Stream -> Bool- streamFinished (EOF _) = True- streamFinished (Chunk _) = False+ streamFinished :: Stream ByteString -> Bool+ streamFinished EOF = True+ streamFinished (Chunks _) = False --------------------------------------------------------------------------- consumeSomeOutput :: Chan Stream- -> Iteratee IO a- -> IO (Iteratee IO a)- consumeSomeOutput writeEnd iter = do- e <- isEmptyChan writeEnd+ consumeSomeOutput :: Chan (Either SomeException (Stream ByteString))+ -> Step ByteString IO a+ -> Iteratee ByteString IO (Step ByteString IO a)+ consumeSomeOutput writeEnd step = do+ e <- lift $ isEmptyChan writeEnd if e- then return iter+ then return step else do- ch <- readChan writeEnd-- iter' <- liftM liftI $ runIter iter ch- consumeSomeOutput writeEnd iter'-+ ech <- lift $ readChan writeEnd+ either throwError+ (\ch -> do+ step' <- checkDone (\k -> lift $ runIteratee $ k ch)+ step+ consumeSomeOutput writeEnd step')+ ech --------------------------------------------------------------------------- consumeRest :: Chan Stream- -> Iteratee IO a- -> IO (IterV IO a)- consumeRest writeEnd iter = do- ch <- readChan writeEnd-- iv <- runIter iter ch- if (streamFinished ch)- then return iv- else consumeRest writeEnd $ liftI iv-+ consumeRest :: Chan (Either SomeException (Stream ByteString))+ -> Step ByteString IO a+ -> Iteratee ByteString IO a+ consumeRest writeEnd step = do+ ech <- lift $ readChan writeEnd+ either throwError+ (\ch -> do+ step' <- checkDone (\k -> lift $ runIteratee $ k ch) step+ if (streamFinished ch)+ then returnI step'+ else consumeRest writeEnd step')+ ech --------------------------------------------------------------------------- f readEnd writeEnd tid i (EOF Nothing) = do- writeChan readEnd Nothing- x <- consumeRest writeEnd i- killThread tid- return x-- f _ _ tid _ (EOF (Just e)) = do- killThread tid- return $ Cont undefined (Just e)+ f _ _ _ (Error e) = Error e+ f _ _ _ (Yield x _) = Yield x EOF+ f readEnd writeEnd tid st@(Continue k) = Continue $ \ch ->+ case ch of+ EOF -> do+ lift $ writeChan readEnd Nothing+ x <- consumeRest writeEnd st+ lift $ killThread tid+ return x - f readEnd writeEnd tid i (Chunk s') = do- let s = unWrap s'- writeChan readEnd $ Just s- i' <- consumeSomeOutput writeEnd i- return $ Cont (IterateeG $ f readEnd writeEnd tid i') Nothing+ (Chunks xs) -> do+ mapM_ (lift . writeChan readEnd . Just) xs+ step' <- consumeSomeOutput writeEnd (Continue k)+ returnI $ f readEnd writeEnd tid step' -------------------------------------------------------------------------- threadProc :: Chan (Maybe ByteString)- -> Chan Stream+ -> Chan (Either SomeException (Stream ByteString)) -> IO () threadProc readEnd writeEnd = do stream <- getChanContents readEnd@@ -238,14 +244,15 @@ let output = L.toChunks $ compFunc bs runIt output `catch` \(e::SomeException) ->- writeChan writeEnd $ EOF (Just $ Err $ show e)+ writeChan writeEnd $ Left e where runIt (x:xs) = do writeChan writeEnd (toChunk x) >> runIt xs runIt [] = do- writeChan writeEnd $ EOF Nothing+ writeChan writeEnd $ Right EOF+ -------------------------------------------------------------------------- streamToChunks [] = [] streamToChunks (Nothing:_) = []@@ -253,7 +260,7 @@ --------------------------------------------------------------------------- toChunk = Chunk . WrapBS+ toChunk = Right . Chunks . (:[]) ------------------------------------------------------------------------------
test/snap-core-testsuite.cabal view
@@ -33,10 +33,9 @@ dlist >= 0.5 && < 0.6, filepath, HUnit >= 1.2 && < 2,- iteratee >= 0.3.1 && < 0.4,- ListLike >= 1 && < 2,+ enumerator == 0.4.*, MonadCatchIO-transformers >= 0.2 && < 0.3,- monads-fd,+ monads-fd <0.2, old-locale, old-time, parallel >= 2.2 && <2.3,@@ -45,10 +44,10 @@ test-framework >= 0.3.1 && <0.4, test-framework-hunit >= 0.2.5 && < 0.3, test-framework-quickcheck2 >= 0.2.6 && < 0.3,- text >= 0.10 && <0.11,+ text >= 0.11 && <0.12, time, transformers,- unix-compat,+ unix-compat == 0.2.*, zlib ghc-options: -O2 -Wall -fhpc -fwarn-tabs -funbox-strict-fields -threaded
test/suite/Snap/Internal/Http/Types/Tests.hs view
@@ -5,10 +5,10 @@ import Control.Monad import Control.Parallel.Strategies+import qualified Data.ByteString.Char8 as S import Data.ByteString.Char8 (ByteString) import Data.ByteString.Lazy.Char8 () import Data.IORef-import Data.Iteratee (stream2stream, run) import Data.List (sort) import qualified Data.Map as Map import Data.Time.Calendar@@ -20,8 +20,9 @@ import Text.Regex.Posix import Snap.Internal.Http.Types-import Snap.Iteratee (enumBS, fromWrap)+import Snap.Iteratee + tests :: [Test] tests = [ testTypes , testUrlDecode@@ -31,7 +32,7 @@ mkRq :: IO Request mkRq = do- enum <- newIORef (SomeEnumerator return)+ enum <- newIORef (SomeEnumerator $ enumBS "") return $ Request "foo" 80 "foo" 999 "foo" 1000 "foo" False Map.empty enum Nothing GET (1,1) [] "" "/" "/" "/" "" Map.empty @@ -93,8 +94,9 @@ assertEqual "response status reason" "bogus" $ rspStatusReason resp assertEqual "content-length" (Just 4) $ rspContentLength resp -- run response body- bd <- (rspBodyToEnum $ rspBody resp) stream2stream >>= run- assertEqual "response body" "PING" (fromWrap bd)+ let benum = rspBodyToEnum $ rspBody resp+ bd <- runIteratee consume >>= run_ . benum+ assertEqual "response body" "PING" $ S.concat bd let !_ = show GET let !_ = GET == POST
test/suite/Snap/Internal/Routing/Tests.hs view
@@ -63,7 +63,7 @@ mkRequest :: ByteString -> IO Request mkRequest uri = do- enum <- newIORef $ SomeEnumerator return+ enum <- newIORef $ SomeEnumerator returnI return $ Request "foo" 80 "foo" 999 "foo" 1000 "foo" False Map.empty enum Nothing GET (1,1) [] "" uri "/"@@ -72,7 +72,7 @@ go :: Snap a -> ByteString -> IO a go m s = do req <- mkRequest s- run $ evalSnap m (const $ return ()) req+ run_ $ evalSnap m (const $ return ()) req routes :: Snap ByteString
test/suite/Snap/Iteratee/Tests.hs view
@@ -1,39 +1,42 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PackageImports #-} {-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Snap.Iteratee.Tests ( tests ) where -import qualified Control.Exception as E-import Control.Exception hiding (try, assert)-import Control.Monad-import Control.Monad.Identity-import qualified Data.ByteString as S-import qualified Data.ByteString.Lazy.Char8 as L-import Data.Monoid-import Data.Int-import Data.IORef-import Data.Iteratee.WrappedByteString-import Data.Word-import Prelude hiding (drop, take)-import Test.Framework -import Test.Framework.Providers.QuickCheck2-import Test.QuickCheck-import qualified Test.QuickCheck.Monadic as QC-import Test.QuickCheck.Monadic hiding (run)-import Test.Framework.Providers.HUnit-import qualified Test.HUnit as H+import qualified Control.Exception as E+import Control.Exception hiding (try, assert)+import Control.Monad+import "monads-fd" Control.Monad.Identity+import Data.ByteString (ByteString)+import qualified Data.ByteString as S+import qualified Data.ByteString.Lazy.Char8 as L+import Data.Int+import Data.Maybe+import Prelude hiding (head, drop, take)+import Test.Framework+import Test.Framework.Providers.QuickCheck2+import Test.QuickCheck+import qualified Test.QuickCheck.Monadic as QC+import Test.QuickCheck.Monadic hiding (run)+import Test.Framework.Providers.HUnit+import qualified Test.HUnit as H -import Snap.Iteratee-import Snap.Test.Common ()+import Snap.Iteratee+import Snap.Test.Common () +import Snap.Internal.Iteratee.Debug liftQ :: forall a m . (Monad m) => m a -> PropertyM m a liftQ = QC.run +throwErr :: String -> Iteratee a IO b+throwErr = throwError . AssertionFailed+ expectException :: IO a -> PropertyM IO () expectException m = do e <- liftQ $ E.try m@@ -45,12 +48,6 @@ tests :: [Test] tests = [ testEnumBS , testEnumLBS- , testBuffer- , testBuffer2- , testBuffer3- , testBuffer4- , testBufferChain- , testBufferChainEscape , testUnsafeBuffer , testUnsafeBuffer2 , testUnsafeBuffer3@@ -67,340 +64,346 @@ ] testEnumBS :: Test-testEnumBS = testProperty "enumBS" prop+testEnumBS = testProperty "iteratee/enumBS" prop where prop :: S.ByteString -> Bool- prop s = (S.concat $ L.toChunks $ fromWrap $ runIdentity (run iter)) == s+ prop s = (S.concat $ runIdentity (run_ iter)) == s where- iter = runIdentity $ enumBS s stream2stream+ iter = runIdentity $ liftM (enumBS s) $ runIteratee consume testEnumLBS :: Test-testEnumLBS = testProperty "enumLBS" prop+testEnumLBS = testProperty "iteratee/enumLBS" prop where prop :: L.ByteString -> Bool- prop s = fromWrap (runIdentity (run iter)) == s+ prop s = L.fromChunks (runIdentity (run_ iter)) == s where- iter = runIdentity $ enumLBS s stream2stream+ iter = runIdentity $ liftM (enumLBS s) $ runIteratee consume -testBuffer :: Test-testBuffer = testProperty "testBuffer" $- monadicIO $ forAllM arbitrary prop+copyingConsume :: Iteratee ByteString IO L.ByteString+copyingConsume = f [] where- prop s = do- pre (s /= L.empty)-- (i,_) <- liftQ $ bufferIteratee stream2stream- iter <- liftQ $ enumLBS s' i- x <- liftQ $ run iter-- QC.assert $ fromWrap x == s'- where- s' = L.take 20000 $ L.cycle s+ f l = do+ mbX <- head+ maybe (return $ L.fromChunks $ reverse l)+ (\x -> let !z = S.copy x+ in z `seq` f (z : l))+ mbX -testBuffer2 :: Test-testBuffer2 = testCase "testBuffer2" prop- where- prop = do- (i,_) <- bufferIteratee $ drop 4 >> stream2stream-- s <- enumLBS "abcdefgh" i >>= run >>= return . fromWrap- H.assertEqual "s == 'efgh'" "efgh" s+bufferAndRun :: Iteratee ByteString IO a -> L.ByteString -> IO a+bufferAndRun ii s = do+ i <- unsafeBufferIteratee ii >>= runIteratee+ run_ $ enumLBS s i -testBuffer3 :: Test-testBuffer3 = testProperty "testBuffer3" $- monadicIO $ forAllM arbitrary prop+testUnsafeBuffer :: Test+testUnsafeBuffer = testProperty "iteratee/testUnsafeBuffer" $+ monadicIO $ forAllM arbitrary prop where prop s = do- pre (s /= L.empty)- (i,_) <- liftQ $ bufferIteratee (ss >>= \x -> drop 1 >> return x)- iter <- liftQ $ enumLBS s' i- x <- liftQ $ run iter+ pre $ s /= L.empty+ x <- liftQ $ bufferAndRun copyingConsume s'+ assert $ x == s' - QC.assert $ fromWrap x == (L.take 19999 s') where s' = L.take 20000 $ L.cycle s- ss = joinI $ take 19999 stream2stream -testBuffer4 :: Test-testBuffer4 = testProperty "testBuffer4" $- monadicIO $ forAllM arbitrary prop+testUnsafeBuffer2 :: Test+testUnsafeBuffer2 = testCase "iteratee/testUnsafeBuffer2" prop where- prop s = do- (i,_) <- liftQ $ bufferIteratee (stream2stream >> throwErr (Err "foo"))- i' <- liftQ $ enumLBS s i- expectException $ run i'-- (j,_) <- liftQ $ bufferIteratee (throwErr (Err "foo") >> stream2stream)- j' <- liftQ $ enumLBS s j- expectException $ run j'- - k <- liftQ $ enumErr "foo" j- expectException $ run k+ prop = do+ i <- unsafeBufferIteratee (drop 4 >> copyingConsume) >>= runIteratee+ s <- run_ $ enumLBS "abcdefgh" i+ H.assertEqual "s == 'efgh'" "efgh" s -testBufferChain :: Test-testBufferChain = testProperty "testBufferChain" $- monadicIO $ forAllM arbitrary prop+testUnsafeBuffer3 :: Test+testUnsafeBuffer3 = testProperty "iteratee/testUnsafeBuffer3" $+ monadicIO $ forAllM arbitrary prop where prop s = do- pre (s /= L.empty)+ pre $ s /= L.empty - (j,_) <- liftQ $ bufferIteratee stream2stream- (i,_) <- liftQ $ bufferIteratee j- iter <- liftQ $ enumLBS s' i- x <- liftQ $ run iter+ ss <- liftQ $ runIteratee copyingConsume >>=+ return . joinI . take 19999 - QC.assert $ fromWrap x == s'+ x <- liftQ $ bufferAndRun (ss >>= \x -> drop 1 >> return x) s'++ let y = L.take 19999 s'+ if x /= y+ then liftQ $ do+ putStrLn $ "FAILED!!!!!"+ putStrLn $ "length x = " ++ show (L.length x)+ putStrLn $ "length y = " ++ show (L.length y)+ diff x y+ putStrLn $ "input was " ++ show s+ else return ()++ assert $ x == y where s' = L.take 20000 $ L.cycle s -testBufferChainEscape :: Test-testBufferChainEscape = testProperty "testBufferChainEscape" $- monadicIO $ forAllM arbitrary prop- where- prop s = do- pre (s /= L.empty)-- (j,esc) <- liftQ $ bufferIteratee stream2stream- (i,_) <- liftQ $ bufferIteratee j-- liftQ $ writeIORef esc True-- iter <- liftQ $ enumLBS s' i- x <- liftQ $ run iter+ diff a b = d a b (0::Int)+ d a b n = do+ case ma of+ Nothing -> if mb /= Nothing+ then do+ let Just (y,_) = mb+ putStrLn $ "differ at byte " ++ show n+ putStrLn $ "a=Nothing, b=" ++ show y+ else return () - QC.assert $ fromWrap x == s'+ Just (x,rest1) ->+ if isNothing mb+ then do+ putStrLn $ "differ at byte " ++ show n+ putStrLn $ "a=" ++ show x ++ ", b=Nothing"+ else do+ let Just (y,rest2) = mb+ if x /= y+ then do+ putStrLn $ "differ at byte " ++ show n+ putStrLn $ "a=" ++ show x ++ ", b=" ++ show y+ let r1 = L.take 6 rest1+ let r2 = L.take 6 rest2+ putStrLn $ "next few bytes a = " ++ show r1+ putStrLn $ "next few bytes b = " ++ show r2+ else+ d rest1 rest2 (n+1) where- s' = L.take 20000 $ L.cycle s+ ma = L.uncons a+ mb = L.uncons b -copyingStream2stream :: Iteratee IO (WrappedByteString Word8)-copyingStream2stream = IterateeG (step mempty)- where- step acc (Chunk (WrapBS ls))- | S.null ls = return $ Cont (IterateeG (step acc)) Nothing- | otherwise = do- let !ls' = S.copy ls- let !bs' = WrapBS $! ls'- return $ Cont (IterateeG (step (acc `mappend` bs')))- Nothing - step acc str = return $ Done acc str-+tub3Prop s = do+ ss <- runIteratee copyingConsume >>=+ return . joinI . take 19999 -bufferAndRun :: Iteratee IO a -> L.ByteString -> IO a-bufferAndRun ii s = do- i <- unsafeBufferIteratee ii- iter <- enumLBS s i- run iter+ let it = (ss >>= \x -> drop 1 >> return x)+ x <- bufferAndRun (iterateeDebugWrapper "foo" it) s' + let a = x+ let b = L.take 19999 s'+ let boo = (a == b)+ putStrLn $ "equal? " ++ show boo+ diff a b -testUnsafeBuffer :: Test-testUnsafeBuffer = testProperty "testUnsafeBuffer" $- monadicIO $ forAllM arbitrary prop where- prop s = do- pre $ s /= L.empty- x <- liftQ $ bufferAndRun copyingStream2stream s'- assert $ fromWrap x == s'+ diff a b = d a b (0::Int)+ d a b n = do+ case ma of+ Nothing -> if mb /= Nothing+ then do+ let Just (y,_) = mb+ putStrLn $ "differ at byte " ++ show n+ putStrLn $ "a=Nothing, b=" ++ show y+ else return () + Just (x,rest1) ->+ if isNothing mb+ then do+ putStrLn $ "differ at byte " ++ show n+ putStrLn $ "a=" ++ show x ++ ", b=Nothing"+ else do+ let Just (y,rest2) = mb+ if x /= y+ then do+ putStrLn $ "differ at byte " ++ show n+ putStrLn $ "a=" ++ show x ++ ", b=" ++ show y+ else+ d rest1 rest2 (n+1) where- s' = L.take 20000 $ L.cycle s+ ma = L.uncons a+ mb = L.uncons b + s' = L.take 20000 $ L.cycle s -testUnsafeBuffer2 :: Test-testUnsafeBuffer2 = testCase "testUnsafeBuffer2" prop- where- prop = do- i <- unsafeBufferIteratee $ drop 4 >> copyingStream2stream - s <- enumLBS "abcdefgh" i >>= run >>= return . fromWrap- H.assertEqual "s == 'efgh'" "efgh" s -testUnsafeBuffer3 :: Test-testUnsafeBuffer3 = testProperty "testUnsafeBuffer3" $- monadicIO $ forAllM arbitrary prop- where- prop s = do- pre $ s /= L.empty- x <- liftQ $ bufferAndRun (ss >>= \x -> drop 1 >> return x) s'-- assert $ fromWrap x == (L.take 19999 s')- where- s' = L.take 20000 $ L.cycle s- ss = joinI $ take 19999 copyingStream2stream-- testUnsafeBuffer4 :: Test-testUnsafeBuffer4 = testProperty "testUnsafeBuffer4" $+testUnsafeBuffer4 = testProperty "iteratee/testUnsafeBuffer4" $ monadicIO $ forAllM arbitrary prop where prop s = do- i <- liftQ $- unsafeBufferIteratee (copyingStream2stream >> throwErr (Err "foo"))- i' <- liftQ $ enumLBS s i- expectException $ run i'+ i <- liftQ (unsafeBufferIteratee (copyingConsume >> throwErr "foo") >>=+ runIteratee)+ expectException $ run_ $ enumLBS s i - j <- liftQ $- unsafeBufferIteratee (throwErr (Err "foo") >> copyingStream2stream)- j' <- liftQ $ enumLBS s j- expectException $ run j'- - k <- liftQ $ enumErr "foo" j- expectException $ run k+ j <- liftQ $ unsafeBufferIteratee (throwErr "foo" >> copyingConsume)+ >>= runIteratee+ expectException $ run_ $ enumLBS s j testUnsafeBuffer5 :: Test-testUnsafeBuffer5 = testProperty "testUnsafeBuffer5" $+testUnsafeBuffer5 = testProperty "iteratee/testUnsafeBuffer5" $ monadicIO $ forAllM arbitrary prop where prop s = do pre $ s /= L.empty- x <- liftQ $ bufferAndRun copyingStream2stream s- assert $ fromWrap x == s+ x <- liftQ $ bufferAndRun copyingConsume s+ assert $ x == s testTakeExactly1 :: Test-testTakeExactly1 = testProperty "short stream" $+testTakeExactly1 = testProperty "iteratee/takeExactly1" $ monadicIO $ forAllM arbitrary prop where prop :: L.ByteString -> PropertyM IO () prop s = do- expectException $ doIter >>= run >>= return . fromWrap+ expectException $ doIter >>= run_ where- doIter = enumLBS s (joinI (takeExactly (n+1) stream2stream))+ doIter = runIteratee consume >>=+ runIteratee . joinI . takeExactly (n+1) >>=+ return . enumLBS s n = fromIntegral $ L.length s testTakeExactly2 :: Test-testTakeExactly2 = testProperty "exact stream" $+testTakeExactly2 = testProperty "iteratee/takeExactly2" $ monadicIO $ forAllM arbitrary prop where prop :: L.ByteString -> PropertyM IO () prop s = do- e <- liftQ $ doIter >>= run >>= return . fromWrap- assert $ e == s+ e <- liftQ $ doIter >>= run_+ assert $ L.fromChunks e == s where- doIter = enumLBS s (joinI (takeExactly n stream2stream))+ doIter = runIteratee consume >>=+ runIteratee . joinI . takeExactly n >>=+ return . enumLBS s n = fromIntegral $ L.length s testTakeExactly3 :: Test-testTakeExactly3 = testProperty "long stream" $+testTakeExactly3 = testProperty "iteratee/takeExactly3" $ monadicIO $ forAllM arbitrary prop where prop :: L.ByteString -> PropertyM IO () prop s = do- e <- liftQ $ doIter >>= run >>= return . fromWrap- assert $ e == L.take (fromIntegral n) s+ e <- liftQ $ doIter >>= run_+ assert $ L.fromChunks e == L.take (fromIntegral n) s where- doIter = enumLBS s (joinI (takeExactly n stream2stream))+ doIter = runIteratee consume >>=+ runIteratee . joinI . takeExactly n >>=+ return . enumLBS s n = fromIntegral $ L.length s testTakeNoMoreThan1 :: Test-testTakeNoMoreThan1 = testProperty "takeNoMore: short stream" $+testTakeNoMoreThan1 = testProperty "iteratee/takeNoMoreThan1" $ monadicIO $ forAllM arbitrary prop where prop :: L.ByteString -> PropertyM IO () prop s = do- s' <- liftQ $ doIter >>= run >>= return . fromWrap+ s' <- liftQ $ doIter >>= run_ - assert $ s == s'+ assert $ s == L.fromChunks s' where- doIter = enumLBS s (joinI (takeNoMoreThan (n+1) stream2stream))+ doIter = do+ step <- runIteratee consume >>=+ runIteratee . joinI . takeNoMoreThan (n+1)+ return $ enumLBS s step n = fromIntegral $ L.length s testTakeNoMoreThan2 :: Test-testTakeNoMoreThan2 = testProperty "takeNoMore: exact stream" $+testTakeNoMoreThan2 = testProperty "iteratee/takeNoMoreThan2" $ monadicIO $ forAllM arbitrary prop where prop :: L.ByteString -> PropertyM IO () prop s = do- e <- liftQ $ doIter >>= run >>= return . fromWrap- assert $ e == s+ e <- liftQ $ doIter >>= run_+ assert $ L.fromChunks e == s where- doIter = enumLBS (L.concat ["", s])- (joinI (takeNoMoreThan n stream2stream))+ doIter = do+ step <- runIteratee consume+ step' <- runIteratee (joinI (takeNoMoreThan n step))+ return $ enumLBS (L.concat ["", s]) step' + n = fromIntegral $ L.length s testTakeNoMoreThan3 :: Test-testTakeNoMoreThan3 = testProperty "takeNoMoreLong" $+testTakeNoMoreThan3 = testProperty "iteratee/takeNoMoreThan3" $ monadicIO $ forAllM arbitrary prop where prop :: (Int64,L.ByteString) -> PropertyM IO () prop (m,s) = do- v <- liftQ $ enumLBS "" (joinI (takeNoMoreThan 0 stream2stream)) >>= run- assert $ fromWrap v == ""+ step1 <- liftQ $ runIteratee consume+ step2 <- liftQ $ runIteratee $ joinI (takeNoMoreThan 0 step1)+ v <- liftQ $ run_ $ enumLBS "" step2+ assert $ S.concat v == "" if (L.null s || m == 0) then liftQ $ do- !_ <- doIter >>= run+ !_ <- doIter >>= run_ return ()- else expectException $ doIter >>= run >>= return . fromWrap+ else expectException $ doIter >>= run_ >>= return - + where- doIter = enumLBS s (joinI (takeNoMoreThan (n-abs m) stream2stream))+ doIter = do+ step <- runIteratee consume+ let i = joinI $ takeNoMoreThan (n-abs m) step+ step' <- runIteratee i+ return $ enumLBS s step'+ n = L.length s testCountBytes :: Test-testCountBytes = testProperty "count bytes" $+testCountBytes = testProperty "iteratee/countBytes" $ monadicIO $ forAllM arbitrary prop where prop :: L.ByteString -> PropertyM IO () prop s = do- (!_,n1) <- f (countBytes (return ()))- (!_,n2) <- f (countBytes stream2stream)+ (!_,n1) <- liftQ (runIteratee (countBytes (return ())) >>= f)+ (!_,n2) <- liftQ (runIteratee (countBytes consume) >>= f) assert $ n1 == 0 assert $ n2 == n - expectException $ g erriter- expectException $ enumEof erriter >>= run- + expectException $ (runIteratee erriter >>= f)+ expectException $ (runIteratee erriter >>= run_ . enumEOF) + where- erriter = countBytes $ throwErr $ Err "foo"- g iter = enumLBS s iter >>= run- f = liftQ . g+ erriter = countBytes $ throwError $ AssertionFailed "foo"+ f iter = run_ $ enumLBS s iter n = L.length s testCountBytes2 :: Test-testCountBytes2 = testProperty "count bytes" $+testCountBytes2 = testProperty "iteratee/countBytes2" $ monadicIO $ forAllM arbitrary prop where prop :: L.ByteString -> PropertyM IO () prop s = do pre $ L.length s > 4- (n1,s') <- f iter + step <- liftQ $ runIteratee iter+ (n1,s') <- f step+ assert $ n1 == 4- assert $ fromWrap s' == L.drop 4 s+ assert $ s' == L.drop 4 s where- f i = liftQ $ enumLBS s i >>= run+ f i = liftQ $ run_ $ enumLBS s i iter = do (!_,m) <- countBytes $ drop' 4- x <- stream2stream+ x <- liftM L.fromChunks consume return (m,x)
test/suite/Snap/Test/Common.hs view
@@ -8,13 +8,8 @@ import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L import Data.ByteString.Internal (c2w)-import Data.Iteratee.WrappedByteString-import Data.Word import Test.QuickCheck --instance Show (WrappedByteString Word8) where- show (WrapBS s) = show s instance Arbitrary S.ByteString where arbitrary = liftM (S.pack . map c2w) arbitrary
test/suite/Snap/Types/Tests.hs view
@@ -1,35 +1,35 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PackageImports #-} {-# LANGUAGE ScopedTypeVariables #-} module Snap.Types.Tests ( tests ) where -import Control.Applicative-import Control.Concurrent.MVar-import Control.Exception (SomeException)-import Control.Monad-import Control.Monad.CatchIO-import Control.Monad.Trans (liftIO)-import Control.Parallel.Strategies-import Data.ByteString.Char8 (ByteString)-import qualified Data.ByteString.Char8 as S-import qualified Data.ByteString.Lazy.Char8 as L-import Data.IORef-import Data.Iteratee-import Data.Text ()-import Data.Text.Lazy ()-import qualified Data.Map as Map-import Prelude hiding (catch)-import Test.Framework-import Test.Framework.Providers.HUnit-import Test.Framework.Providers.QuickCheck2-import Test.HUnit hiding (Test, path)--import Snap.Internal.Types-import Snap.Internal.Http.Types-import Snap.Iteratee-import Snap.Test.Common ()+import Control.Applicative+import Control.Concurrent.MVar+import Control.Exception (SomeException)+import Control.Monad+import Control.Monad.CatchIO+import "monads-fd" Control.Monad.Trans (liftIO)+import Control.Parallel.Strategies+import Data.ByteString.Char8 (ByteString)+import qualified Data.ByteString.Char8 as S+import qualified Data.ByteString.Lazy.Char8 as L+import Data.IORef+import Data.Text ()+import Data.Text.Lazy ()+import qualified Data.Map as Map+import Prelude hiding (catch)+import Test.Framework+import Test.Framework.Providers.HUnit+import Test.Framework.Providers.QuickCheck2+import Test.HUnit hiding (Test, path)+ +import Snap.Internal.Types+import Snap.Internal.Http.Types+import Snap.Iteratee+import Snap.Test.Common () tests :: [Test]@@ -76,7 +76,7 @@ mkRequest :: ByteString -> IO Request mkRequest uri = do- enum <- newIORef $ SomeEnumerator return+ enum <- newIORef $ SomeEnumerator returnI return $ Request "foo" 80 "127.0.0.1" 999 "foo" 1000 "foo" False Map.empty enum Nothing GET (1,1) [] "" uri "/"@@ -84,7 +84,7 @@ mkRequestQuery :: ByteString -> ByteString -> [ByteString] -> IO Request mkRequestQuery uri k v = do- enum <- newIORef $ SomeEnumerator return+ enum <- newIORef $ SomeEnumerator returnI let mp = Map.fromList [(k,v)] let q = S.concat [k,"=", S.concat v]@@ -96,7 +96,7 @@ mkZomgRq :: IO Request mkZomgRq = do- enum <- newIORef $ SomeEnumerator return+ enum <- newIORef $ SomeEnumerator returnI return $ Request "foo" 80 "127.0.0.1" 999 "foo" 1000 "foo" False Map.empty enum Nothing GET (1,1) [] "" "/" "/" "/" "" Map.empty@@ -112,14 +112,14 @@ mkRqWithBody :: IO Request mkRqWithBody = do- enum <- newIORef $ SomeEnumerator (enumBS "zazzle")+ enum <- newIORef $ SomeEnumerator (enumBS "zazzle" >==> enumEOF) return $ Request "foo" 80 "foo" 999 "foo" 1000 "foo" False Map.empty enum Nothing GET (1,1) [] "" "/" "/" "/" "" Map.empty testCatchIO :: Test-testCatchIO = testCase "catchIO" $ do+testCatchIO = testCase "types/catchIO" $ do (_,rsp) <- go f (_,rsp2) <- go g @@ -139,19 +139,19 @@ go :: Snap a -> IO (Request,Response) go m = do zomgRq <- mkZomgRq- run $ runSnap m (\x -> return $! (show x `using` rdeepseq) `seq` ()) zomgRq+ run_ $ runSnap m (\x -> return $! (show x `using` rdeepseq) `seq` ()) zomgRq goIP :: Snap a -> IO (Request,Response) goIP m = do rq <- mkIpHeaderRq- run $ runSnap m (const $ return ()) rq+ run_ $ runSnap m (const $ return ()) rq goPath :: ByteString -> Snap a -> IO (Request,Response) goPath s m = do rq <- mkRequest s- run $ runSnap m (const $ return ()) rq+ run_ $ runSnap m (const $ return ()) rq goPathQuery :: ByteString@@ -161,13 +161,13 @@ -> IO (Request,Response) goPathQuery s k v m = do rq <- mkRequestQuery s k v- run $ runSnap m (const $ return ()) rq+ run_ $ runSnap m (const $ return ()) rq goBody :: Snap a -> IO (Request,Response) goBody m = do rq <- mkRqWithBody- run $ runSnap m (const $ return ()) rq+ run_ $ runSnap m (const $ return ()) rq testFail :: Test@@ -182,7 +182,7 @@ testAlternative :: Test-testAlternative = testCase "alternative" $ do+testAlternative = testCase "types/alternative" $ do (_,resp) <- go (pass <|> setFoo "Bar") assertEqual "foo present" (Just "Bar") $ getHeader "Foo" resp @@ -203,13 +203,13 @@ testEarlyTermination :: Test-testEarlyTermination = testCase "early termination" $ do+testEarlyTermination = testCase "types/earlyTermination" $ do (_,resp) <- go (finishWith sampleResponse >>= \_ -> setFoo "Bar") assertEqual "foo" (Just ["Quux"]) $ getHeaders "Foo" resp testRqBody :: Test-testRqBody = testCase "request bodies" $ do+testRqBody = testCase "types/requestBodies" $ do mvar1 <- newEmptyMVar mvar2 <- newEmptyMVar @@ -232,11 +232,11 @@ getRequestBody >>= liftIO . putMVar mvar1 getRequestBody >>= liftIO . putMVar mvar2 - g = transformRequestBody return+ g = transformRequestBody returnI testTrivials :: Test-testTrivials = testCase "trivial functions" $ do+testTrivials = testCase "types/trivials" $ do (rq,rsp) <- go $ do req <- getRequest putRequest $ req { rqIsSecure=True }@@ -275,13 +275,13 @@ testMethod :: Test-testMethod = testCase "method" $ do+testMethod = testCase "types/method" $ do expect404 $ go (method POST $ return ()) expectNo404 $ go (method GET $ return ()) testDir :: Test-testDir = testCase "dir" $ do+testDir = testCase "types/dir" $ do expect404 $ goPath "foo/bar" (dir "zzz" $ return ()) expectNo404 $ goPath "foo/bar" (dir "foo" $ return ()) expect404 $ goPath "fooz/bar" (dir "foo" $ return ())@@ -292,7 +292,7 @@ testParam :: Test-testParam = testCase "getParam" $ do+testParam = testCase "types/getParam" $ do expect404 $ goPath "/foo" f expectNo404 $ goPathQuery "/foo" "param" ["foo"] f where@@ -304,11 +304,13 @@ getBody :: Response -> IO L.ByteString-getBody r = liftM fromWrap ((rspBodyToEnum $ rspBody r) stream2stream >>= run)+getBody r = do+ let benum = rspBodyToEnum $ rspBody r+ liftM L.fromChunks (runIteratee consume >>= run_ . benum) testWrites :: Test-testWrites = testCase "writes" $ do+testWrites = testCase "types/writes" $ do (_,r) <- go h b <- getBody r assertEqual "output functions" "Foo1Foo2Foo3" b@@ -321,20 +323,20 @@ testURLEncode1 :: Test-testURLEncode1 = testCase "url encoding 1" $ do+testURLEncode1 = testCase "types/urlEncoding1" $ do let b = urlEncode "the quick brown fox~#" assertEqual "url encoding 1" "the+quick+brown+fox%7e%23" b assertEqual "fail" Nothing $ urlDecode "%" testURLEncode2 :: Test-testURLEncode2 = testProperty "url encoding 2" prop+testURLEncode2 = testProperty "types/urlEncoding2" prop where prop s = (urlDecode $ urlEncode s) == Just s testDir2 :: Test-testDir2 = testCase "dir2" $ do+testDir2 = testCase "types/dir2" $ do (_,resp) <- goPath "foo/bar" f b <- getBody resp assertEqual "context path" "/foo/bar/" b@@ -346,7 +348,7 @@ testIpHeaderFilter :: Test-testIpHeaderFilter = testCase "ipHeaderFilter" $ do+testIpHeaderFilter = testCase "types/ipHeaderFilter" $ do (_,r) <- goIP f b <- getBody r assertEqual "ipHeaderFilter" "1.2.3.4" b@@ -364,7 +366,7 @@ testMZero404 :: Test-testMZero404 = testCase "mzero 404" $ do+testMZero404 = testCase "types/mzero404" $ do (_,r) <- go mzero let l = rspContentLength r b <- getBody r@@ -373,9 +375,9 @@ testEvalSnap :: Test-testEvalSnap = testCase "evalSnap exception" $ do+testEvalSnap = testCase "types/evalSnap-exception" $ do rq <- mkZomgRq- expectException (run $ evalSnap f+ expectException (run_ $ evalSnap f (const $ return ()) rq >> return ()) where@@ -387,7 +389,7 @@ testLocalRequest :: Test-testLocalRequest = testCase "localRequest" $ do+testLocalRequest = testCase "types/localRequest" $ do rq1 <- mkZomgRq rq2 <- mkRequest "zzz/zz/z" @@ -403,7 +405,7 @@ testRedirect :: Test-testRedirect = testCase "redirect" $ do+testRedirect = testCase "types/redirect" $ do (_,rsp) <- go (redirect "/foo/bar") assertEqual "redirect path" (Just "/foo/bar") $ getHeader "Location" rsp
test/suite/Snap/Util/FileServe/Tests.hs view
@@ -38,20 +38,22 @@ getBody :: Response -> IO L.ByteString-getBody r = liftM fromWrap ((rspBodyToEnum $ rspBody r) stream2stream >>= run)+getBody r = do+ let benum = rspBodyToEnum $ rspBody r+ liftM L.fromChunks (runIteratee consume >>= run_ . benum) go :: Snap a -> ByteString -> IO Response go m s = do rq <- mkRequest s- liftM snd (run $ runSnap m (const $ return ()) rq)+ liftM snd (run_ $ runSnap m (const $ return ()) rq) goIfModifiedSince :: Snap a -> ByteString -> ByteString -> IO Response goIfModifiedSince m s lm = do rq <- mkRequest s let r = setHeader "if-modified-since" lm rq- liftM snd (run $ runSnap m (const $ return ()) r)+ liftM snd (run_ $ runSnap m (const $ return ()) r) goIfRange :: Snap a -> ByteString -> (Int,Int) -> ByteString -> IO Response@@ -61,7 +63,7 @@ setHeader "Range" (S.pack $ "bytes=" ++ show start ++ "-" ++ show end) rq- liftM snd (run $ runSnap m (const $ return ()) r)+ liftM snd (run_ $ runSnap m (const $ return ()) r) goRange :: Snap a -> ByteString -> (Int,Int) -> IO Response@@ -70,7 +72,7 @@ let rq = setHeader "Range" (S.pack $ "bytes=" ++ show start ++ "-" ++ show end) rq'- liftM snd (run $ runSnap m (const $ return ()) rq)+ liftM snd (run_ $ runSnap m (const $ return ()) rq) goMultiRange :: Snap a -> ByteString -> (Int,Int) -> (Int,Int) -> IO Response@@ -80,7 +82,7 @@ (S.pack $ "bytes=" ++ show start ++ "-" ++ show end ++ "," ++ show start2 ++ "-" ++ show end2) rq'- liftM snd (run $ runSnap m (const $ return ()) rq)+ liftM snd (run_ $ runSnap m (const $ return ()) rq) goRangePrefix :: Snap a -> ByteString -> Int -> IO Response@@ -89,7 +91,7 @@ let rq = setHeader "Range" (S.pack $ "bytes=" ++ show start ++ "-") rq'- liftM snd (run $ runSnap m (const $ return ()) rq)+ liftM snd (run_ $ runSnap m (const $ return ()) rq) goRangeSuffix :: Snap a -> ByteString -> Int -> IO Response@@ -98,12 +100,12 @@ let rq = setHeader "Range" (S.pack $ "bytes=-" ++ show end) rq'- liftM snd (run $ runSnap m (const $ return ()) rq)+ liftM snd (run_ $ runSnap m (const $ return ()) rq) mkRequest :: ByteString -> IO Request mkRequest uri = do- enum <- newIORef $ SomeEnumerator return+ enum <- newIORef $ SomeEnumerator returnI return $ Request "foo" 80 "foo" 999 "foo" 1000 "foo" False Map.empty enum Nothing GET (1,1) [] "" uri "/" (S.concat ["/",uri]) "" Map.empty
test/suite/Snap/Util/GZip/Tests.hs view
@@ -9,10 +9,11 @@ import qualified Codec.Compression.GZip as GZip import qualified Codec.Compression.Zlib as Zlib import Control.Exception hiding (assert)+import Control.Monad (liftM)+import Data.ByteString (ByteString) import qualified Data.ByteString.Lazy.Char8 as L import Data.Digest.Pure.MD5 import Data.IORef-import Data.Iteratee import qualified Data.Map as Map import Data.Serialize import Test.Framework@@ -30,6 +31,10 @@ import Snap.Util.GZip +stream2stream+ :: Iteratee ByteString IO L.ByteString+stream2stream = liftM L.fromChunks consume+ ------------------------------------------------------------------------------ tests :: [Test] tests = [ testIdentity1@@ -42,8 +47,7 @@ , testNopWhenContentEncodingSet , testCompositionDoesn'tExplode , testGzipLotsaChunks- , testBadHeaders- , testIterateeException ]+ , testBadHeaders ] ------------------------------------------------------------------------------@@ -74,7 +78,7 @@ ------------------------------------------------------------------------------ mkNoHeaders :: IO Request mkNoHeaders = do- enum <- newIORef $ SomeEnumerator return+ enum <- newIORef $ SomeEnumerator returnI return $ Request "foo" 80 "foo" 999 "foo" 1000 "foo" False emptyHdrs enum Nothing GET (1,1) [] "" "/" "/" "/" "" Map.empty@@ -82,14 +86,14 @@ mkGzipRq :: IO Request mkGzipRq = do- enum <- newIORef $ SomeEnumerator return+ enum <- newIORef $ SomeEnumerator returnI return $ Request "foo" 80 "foo" 999 "foo" 1000 "foo" False gzipHdrs enum Nothing GET (1,1) [] "" "/" "/" "/" "" Map.empty mkXGzipRq :: IO Request mkXGzipRq = do- enum <- newIORef $ SomeEnumerator return+ enum <- newIORef $ SomeEnumerator returnI return $ Request "foo" 80 "foo" 999 "foo" 1000 "foo" False xGzipHdrs enum Nothing GET (1,1) [] "" "/" "/" "/" "" Map.empty@@ -99,14 +103,14 @@ ------------------------------------------------------------------------------ mkCompressRq :: IO Request mkCompressRq = do- enum <- newIORef $ SomeEnumerator return+ enum <- newIORef $ SomeEnumerator returnI return $ Request "foo" 80 "foo" 999 "foo" 1000 "foo" False compressHdrs enum Nothing GET (1,1) [] "" "/" "/" "/" "" Map.empty mkXCompressRq :: IO Request mkXCompressRq = do- enum <- newIORef $ SomeEnumerator return+ enum <- newIORef $ SomeEnumerator returnI return $ Request "foo" 80 "foo" 999 "foo" 1000 "foo" False xCompressHdrs enum Nothing GET (1,1) [] "" "/" "/" "/" "" Map.empty@@ -116,7 +120,7 @@ ------------------------------------------------------------------------------ mkBadRq :: IO Request mkBadRq = do- enum <- newIORef $ SomeEnumerator return+ enum <- newIORef $ SomeEnumerator returnI return $ Request "foo" 80 "foo" 999 "foo" 1000 "foo" False badHdrs enum Nothing GET (1,1) [] "" "/" "/" "/" "" Map.empty@@ -132,7 +136,7 @@ goGeneric :: IO Request -> Snap a -> IO (Request, Response) goGeneric mkRq m = do rq <- mkRq- run $! runSnap (seqSnap m) (const $ return ()) rq+ run_ $! runSnap (seqSnap m) (const $ return ()) rq goGZip, goCompress, goXGZip :: Snap a -> IO (Request,Response) goNoHeaders, goXCompress, goBad :: Snap a -> IO (Request,Response)@@ -150,12 +154,6 @@ -------------------------------------------------------------------------------textPlainErr :: L.ByteString -> Snap ()-textPlainErr s = modifyResponse $- setResponseBody (enumLBS s >. enumErr "blah") .- setContentType "text/plain"-- textPlain :: L.ByteString -> Snap () textPlain s = modifyResponse $ setResponseBody (enumLBS s) .@@ -185,7 +183,7 @@ let body = rspBodyToEnum $ rspBody rsp c <- liftQ $- body stream2stream >>= run >>= return . fromWrap+ runIteratee stream2stream >>= run_ . body assert $ s == c @@ -206,7 +204,7 @@ let body = rspBodyToEnum $ rspBody rsp c <- liftQ $- body stream2stream >>= run >>= return . fromWrap+ runIteratee stream2stream >>= run_ . body assert $ s == c @@ -223,7 +221,7 @@ let body = rspBodyToEnum $ rspBody rsp c <- liftQ $- body stream2stream >>= run >>= return . fromWrap+ runIteratee stream2stream >>= run_ . body let s1 = GZip.decompress c assert $ s == s1@@ -242,7 +240,7 @@ let body = rspBodyToEnum $ rspBody rsp c <- liftQ $- body stream2stream >>= run >>= return . fromWrap+ runIteratee stream2stream >>= run_ . body let s' = Zlib.decompress c assert $ s == s'@@ -258,7 +256,7 @@ let body3 = rspBodyToEnum $ rspBody rsp3 s3 <- liftQ $- body3 stream2stream >>= run >>= return . fromWrap+ runIteratee stream2stream >>= run_ . body3 assert $ s == s3 @@ -274,7 +272,7 @@ let body = rspBodyToEnum $ rspBody rsp c <- liftQ $- body stream2stream >>= run >>= return . fromWrap+ runIteratee stream2stream >>= run_ . body let s1 = GZip.decompress c assert $ s == s1@@ -292,7 +290,7 @@ let body2 = rspBodyToEnum $ rspBody rsp2 c2 <- liftQ $- body2 stream2stream >>= run >>= return . fromWrap+ runIteratee stream2stream >>= run_ . body2 let s2 = Zlib.decompress c2 assert $ s == s2@@ -307,7 +305,7 @@ (!_,!rsp) <- goBad (seqSnap $ withCompression $ textPlain s) let body = rspBodyToEnum $ rspBody rsp - body stream2stream >>= run >>= return . fromWrap+ runIteratee stream2stream >>= run_ . body ------------------------------------------------------------------------------@@ -346,7 +344,7 @@ let body = rspBodyToEnum $ rspBody rsp c <- liftQ $- body stream2stream >>= run >>= return . fromWrap+ runIteratee stream2stream >>= run_ . body let s1 = GZip.decompress c assert $ s == s1@@ -361,7 +359,7 @@ (!_,!rsp) <- goGZip (seqSnap $ withCompression $ textPlain s) let body = rspBodyToEnum $ rspBody rsp - c <- body stream2stream >>= run >>= return . fromWrap+ c <- runIteratee stream2stream >>= run_ . body let s1 = GZip.decompress c H.assertBool "streams equal" $ s == s1@@ -373,14 +371,3 @@ frobnicate s = let s' = encode $ md5 $ L.fromChunks [s] in (s:frobnicate s') ---------------------------------------------------------------------------------testIterateeException :: Test-testIterateeException = testProperty "gzip/iterateeException" $- monadicIO $ forAllM arbitrary prop- where- prop :: L.ByteString -> PropertyM IO ()- prop s = expectException $ do- (!_,!rsp) <- goGZip (seqSnap $ withCompression $ textPlainErr s)- let body = rspBodyToEnum $ rspBody rsp- body stream2stream >>= run >>= return . fromWrap