snap-core 0.5.5 → 0.6.0
raw patch · 33 files changed
+2047/−1090 lines, 33 filesdep +HUnitdep +base16-bytestringdep +mwc-randomdep ~case-insensitive
Dependencies added: HUnit, base16-bytestring, mwc-random, regex-posix, unordered-containers
Dependency ranges changed: case-insensitive
Files
- CONTRIBUTORS +1/−0
- README.SNAP.md +5/−5
- README.md +4/−8
- snap-core.cabal +16/−5
- src/Snap/Core.hs +159/−0
- src/Snap/Internal/Http/Types.hs +58/−161
- src/Snap/Internal/Instances.hs +14/−13
- src/Snap/Internal/Iteratee/BoyerMooreHorspool.hs +3/−2
- src/Snap/Internal/Parsing.hs +218/−17
- src/Snap/Internal/Routing.hs +1/−0
- src/Snap/Internal/Test/Assertions.hs +82/−0
- src/Snap/Internal/Test/RequestBuilder.hs +559/−0
- src/Snap/Internal/Types.hs +40/−5
- src/Snap/Iteratee.hs +3/−2
- src/Snap/Test.hs +55/−0
- src/Snap/Types.hs +5/−149
- src/Snap/Types/Headers.hs +120/−0
- src/Snap/Util/FileServe.hs +4/−69
- src/Snap/Util/FileUploads.hs +8/−8
- src/Snap/Util/GZip.hs +1/−3
- test/runTestsAndCoverage.sh +2/−0
- test/snap-core-testsuite.cabal +4/−2
- test/suite/Snap/Core/Tests.hs +590/−0
- test/suite/Snap/Internal/Http/Types/Tests.hs +11/−9
- test/suite/Snap/Internal/Parsing/Tests.hs +32/−0
- test/suite/Snap/Internal/Routing/Tests.hs +2/−2
- test/suite/Snap/Iteratee/Tests.hs +1/−21
- test/suite/Snap/Test/Common.hs +25/−0
- test/suite/Snap/Types/Tests.hs +0/−584
- test/suite/Snap/Util/FileServe/Tests.hs +2/−1
- test/suite/Snap/Util/FileUploads/Tests.hs +10/−19
- test/suite/Snap/Util/GZip/Tests.hs +3/−2
- test/suite/TestSuite.hs +9/−3
CONTRIBUTORS view
@@ -6,3 +6,4 @@ James Sanders <jimmyjazz14@gmail.com> Jacob Stanley <jystic@jystic.com> Jonas Kramer <jkramer@nex.scrapping.cc>+Jurriën Stutterheim <j.stutterheim@me.com>
README.SNAP.md view
@@ -16,11 +16,11 @@ * a sensible and clean monad for web programming - * an xml-based templating system for generating HTML based on- [expat](http://expat.sourceforge.net/) (via- [hexpat](http://hackage.haskell.org/package/hexpat)) that allows you to- bind Haskell functionality to XML tags without getting PHP-style tag soup- all over your pants+ * an xml-based templating system for generating HTML that allows you to bind+ Haskell functionality to XML tags without getting PHP-style tag soup all+ over your pants++ * a "snaplet" system for building web sites from composable pieces. 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.
README.md view
@@ -1,14 +1,10 @@ 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/.--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)). For more+information about Snap, read the `README.SNAP.md` or visit the Snap project+website at http://www.snapframework.com/. ## Library contents
snap-core.cabal view
@@ -1,5 +1,5 @@ name: snap-core-version: 0.5.5+version: 0.6.0 synopsis: Snap: A Haskell Web Framework (Core) description:@@ -26,7 +26,7 @@ * Early termination of the computation if you know early what you want to return and want to prevent further monadic processing .- /Quick start/: The 'Snap' monad and HTTP definitions are in "Snap.Types",+ /Quick start/: The 'Snap' monad and HTTP definitions are in "Snap.Core", some iteratee utilities are in "Snap.Iteratee". . Higher-level facilities for building web applications (like user/session@@ -68,11 +68,12 @@ test/data/fileServe/mydir3/altindex.html, test/runTestsAndCoverage.sh, test/snap-core-testsuite.cabal,+ test/suite/Snap/Core/Tests.hs, test/suite/Snap/Internal/Http/Types/Tests.hs,+ test/suite/Snap/Internal/Parsing/Tests.hs, test/suite/Snap/Internal/Routing/Tests.hs, test/suite/Snap/Iteratee/Tests.hs, test/suite/Snap/Test/Common.hs,- test/suite/Snap/Types/Tests.hs, test/suite/Snap/Util/FileServe/Tests.hs, test/suite/Snap/Util/FileUploads/Tests.hs, test/suite/Snap/Util/GZip/Tests.hs@@ -110,12 +111,15 @@ cpp-options: -DUSE_UNIX exposed-modules:+ Snap.Core, Snap.Types, Snap.Iteratee, Snap.Internal.Debug, Snap.Internal.Http.Types, Snap.Internal.Iteratee.Debug, Snap.Internal.Parsing,+ Snap.Test,+ Snap.Types.Headers, Snap.Util.FileServe, Snap.Util.FileUploads, Snap.Util.GZip,@@ -125,32 +129,39 @@ Snap.Internal.Instances, Snap.Internal.Iteratee.BoyerMooreHorspool, Snap.Internal.Routing,- Snap.Internal.Types+ Snap.Internal.Types,+ Snap.Internal.Test.RequestBuilder,+ Snap.Internal.Test.Assertions build-depends: attoparsec >= 0.8.0.2 && < 0.10, attoparsec-enumerator >= 0.2.0.3, base >= 4 && < 5,+ base16-bytestring <= 0.2, blaze-builder >= 0.2.1.4 && <0.4, blaze-builder-enumerator >= 0.2 && <0.3, bytestring, bytestring-nums,- case-insensitive >= 0.2 && < 0.4,+ case-insensitive >= 0.3 && < 0.4, containers, deepseq >= 1.1 && <1.3, directory, dlist >= 0.5 && < 0.6, enumerator >= 0.4.13.1 && < 0.5, filepath,+ HUnit >= 1.2 && < 2, MonadCatchIO-transformers >= 0.2.1 && < 0.3, mtl == 2.0.*,+ mwc-random >= 0.10 && <0.11, old-locale, old-time,+ regex-posix <= 0.94.4, text >= 0.11 && <0.12, time >= 1.0 && < 1.4, transformers == 0.2.*, unix-compat >= 0.2 && <0.4,+ unordered-containers >= 0.1.4.3 && <0.2, vector >= 0.6 && <0.10, zlib-enum >= 0.2.1 && <0.3
+ src/Snap/Core.hs view
@@ -0,0 +1,159 @@+{-|++This module contains the core type definitions, class instances, and functions+for HTTP as well as the 'Snap' monad, which is used for web handlers.++-}+module Snap.Core+ (+ -- * The Snap Monad+ Snap+ , runSnap+ , MonadSnap(..)+ , NoHandlerException(..)++ -- ** Functions for control flow and early termination+ , bracketSnap+ , finishWith+ , catchFinishWith+ , pass+ , terminateConnection++ -- ** Routing+ , method+ , methods+ , path+ , pathArg+ , dir+ , ifTop+ , route+ , routeLocal++ -- ** Access to state+ , getRequest+ , getResponse+ , putRequest+ , putResponse+ , modifyRequest+ , modifyResponse+ , localRequest+ , withRequest+ , withResponse++ -- ** Logging+ , logError++ -- ** Grabbing/transforming request bodies+ , runRequestBody+ , getRequestBody+ , readRequestBody+ , transformRequestBody++ -- * HTTP Datatypes and Functions+ -- $httpDoc+ --+ , Request+ , Response+ , Headers+ , HasHeaders(..)+ , Params+ , Method(..)+ , Cookie(..)+ , HttpVersion++ -- ** Headers+ , addHeader+ , setHeader+ , getHeader+ , getHeaders+ , listHeaders+ , deleteHeader+ , ipHeaderFilter+ , ipHeaderFilter'++ -- ** Requests+ , rqServerName+ , rqServerPort+ , rqRemoteAddr+ , rqRemotePort+ , rqLocalAddr+ , rqLocalHostname+ , rqIsSecure+ , rqContentLength+ , rqMethod+ , rqVersion+ , rqCookies+ , rqPathInfo+ , rqContextPath+ , rqURI+ , rqQueryString+ , rqParams+ , rqParam+ , getParam+ , getParams+ , rqModifyParams+ , rqSetParam++ -- ** Responses+ , emptyResponse+ , setResponseCode+ , setResponseStatus+ , rspStatus+ , rspStatusReason+ , setContentType+ , addResponseCookie+ , getResponseCookie+ , getResponseCookies+ , deleteResponseCookie+ , modifyResponseCookie+ , expireCookie+ , getCookie+ , readCookie+ , setContentLength+ , clearContentLength+ , redirect+ , redirect'++ -- *** Response I/O+ , setResponseBody+ , modifyResponseBody+ , addToOutput+ , writeBuilder+ , writeBS+ , writeLazyText+ , writeText+ , writeLBS+ , sendFile+ , sendFilePartial++ -- ** Timeouts+ , setTimeout+ , getTimeoutAction++ -- * Iteratee+ , Enumerator+ , SomeEnumerator(..)++ -- * HTTP utilities+ , formatHttpTime+ , parseHttpTime+ , parseUrlEncoded+ , buildUrlEncoded+ , printUrlEncoded+ , urlEncode+ , urlEncodeBuilder+ , urlDecode+ ) where++------------------------------------------------------------------------------+import Snap.Internal.Http.Types+import Snap.Internal.Instances ()+import Snap.Internal.Parsing+import Snap.Internal.Routing+import Snap.Internal.Types+import Snap.Iteratee (Enumerator)+import Snap.Types.Headers (Headers)+------------------------------------------------------------------------------++-- $httpDoc+-- HTTP-related datatypes: 'Request', 'Response', 'Cookie', etc.
src/Snap/Internal/Http/Types.hs view
@@ -2,7 +2,7 @@ -- -- /N.B./ this is an internal interface, please don't write user code that -- depends on it. Most of these declarations (except for the--- unsafe/encapsulation-breaking ones) are re-exported from "Snap.Types".+-- unsafe/encapsulation-breaking ones) are re-exported from "Snap.Core". {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-}@@ -18,20 +18,11 @@ ------------------------------------------------------------------------------ import Blaze.ByteString.Builder-import Control.Applicative hiding (empty)-import Control.Monad (liftM, when)-import qualified Data.Attoparsec as Atto-import Data.Attoparsec hiding (many, Result(..))-import Data.Bits+import Control.Monad (liftM) import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as B import Data.ByteString.Internal (c2w,w2c)-import qualified Data.ByteString.Nums.Careless.Hex as Cvt import qualified Data.ByteString as S-import qualified Data.ByteString.Unsafe as S-import Data.Char-import Data.DList (DList)-import qualified Data.DList as DL import Data.Int import qualified Data.IntMap as IM import Data.IORef@@ -41,8 +32,6 @@ import Data.Maybe import Data.Monoid import Data.Time.Clock-import Data.Word-import Foreign hiding (new) import Foreign.C.Types import Prelude hiding (take) @@ -54,6 +43,8 @@ import System.Locale (defaultTimeLocale) #else import Data.Time.Format ()+import Foreign+import qualified Data.ByteString.Unsafe as S import Foreign.C.String #endif @@ -62,7 +53,8 @@ import qualified Data.CaseInsensitive as CI import Snap.Iteratee (Enumerator) import qualified Snap.Iteratee as I-+import Snap.Types.Headers (Headers)+import qualified Snap.Types.Headers as H #ifndef PORTABLE @@ -85,11 +77,6 @@ --------------------------------------------------------------------------------- | A type alias for a case-insensitive key-value mapping.-type Headers = Map (CI ByteString) [ByteString]--------------------------------------------------------------------------------- -- | A typeclass for datatypes which contain HTTP headers. class HasHeaders a where @@ -105,33 +92,40 @@ -- with the same name already exists, the new value is appended to the headers -- list. addHeader :: (HasHeaders a) => CI ByteString -> ByteString -> a -> a-addHeader k v = updateHeaders $ Map.insertWith' (++) k [v]+addHeader k v = updateHeaders $ H.insert k v ------------------------------------------------------------------------------ -- | Sets a header key-value-pair in a 'HasHeaders' datatype. If a header with -- the same name already exists, it is overwritten with the new value. setHeader :: (HasHeaders a) => CI ByteString -> ByteString -> a -> a-setHeader k v = updateHeaders $ Map.insert k [v]+setHeader k v = updateHeaders $ H.set k v ------------------------------------------------------------------------------ -- | Gets all of the values for a given header. getHeaders :: (HasHeaders a) => CI ByteString -> a -> Maybe [ByteString]-getHeaders k a = Map.lookup k $ headers a+getHeaders k a = H.lookup k $ headers a ------------------------------------------------------------------------------ -- | Gets a header value out of a 'HasHeaders' datatype. If many headers came -- in with the same name, they will be catenated together. getHeader :: (HasHeaders a) => CI ByteString -> a -> Maybe ByteString-getHeader k a = liftM (S.intercalate " ") (Map.lookup k $ headers a)+getHeader k a = liftM (S.intercalate " ") (H.lookup k $ headers a) ------------------------------------------------------------------------------+-- | Lists all the headers out of a 'HasHeaders' datatype. If many+-- headers came in with the same name, they will be catenated together.+listHeaders :: (HasHeaders a) => a -> [(CI ByteString, ByteString)]+listHeaders = H.toList . headers+++------------------------------------------------------------------------------ -- | Clears a header value from a 'HasHeaders' datatype. deleteHeader :: (HasHeaders a) => CI ByteString -> a -> a-deleteHeader k = updateHeaders $ Map.delete k+deleteHeader k = updateHeaders $ H.delete k ------------------------------------------------------------------------------@@ -149,19 +143,25 @@ -- | A datatype representing an HTTP cookie. data Cookie = Cookie { -- | The name of the cookie.- cookieName :: !ByteString+ cookieName :: !ByteString -- | The cookie's string value.- , cookieValue :: !ByteString+ , cookieValue :: !ByteString -- | The cookie's expiration value, if it has one.- , cookieExpires :: !(Maybe UTCTime)+ , cookieExpires :: !(Maybe UTCTime) -- | The cookie's \"domain\" value, if it has one.- , cookieDomain :: !(Maybe ByteString)+ , cookieDomain :: !(Maybe ByteString) -- | The cookie path.- , cookiePath :: !(Maybe ByteString)+ , cookiePath :: !(Maybe ByteString)++ -- | Tag as secure cookie?+ , cookieSecure :: !Bool++ -- | HttpOnly?+ , cookieHttpOnly :: !Bool } deriving (Eq, Show) @@ -237,7 +237,7 @@ -- > , rqContextPath r -- > , rqPathInfo r -- > , let q = rqQueryString r- -- > , in if S.null q+ -- > in if S.null q -- > then "" -- > else S.append "?" q -- > ]@@ -252,11 +252,11 @@ -- 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' (ignoring- -- query strings). 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.+ -- | The \"context path\" of the request; catenating 'rqContextPath',+ -- and 'rqPathInfo' should get you back to the original 'rqURI'+ -- (ignoring query strings). 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. , rqContextPath :: !ByteString -- | Returns the @URI@ requested by the client.@@ -310,9 +310,9 @@ beginheaders = "Headers:\n ========================================" endheaders = " ========================================"- hdrs' (a,b) = (B.unpack $ CI.original a) ++ ": " ++ (show (map B.unpack b))+ hdrs' (a,b) = (B.unpack $ CI.original a) ++ ": " ++ B.unpack b hdrs = " " ++ (concat $ intersperse "\n " $- map hdrs' (Map.toAscList $ rqHeaders r))+ map hdrs' (H.toList $ rqHeaders r)) contentlength = concat [ "content-length: " , show $ rqContentLength r ]@@ -414,27 +414,28 @@ ------------------------------------------------------------------------------ instance Show Response where- show r = concat [ "Response <\n"- , body- , ">" ]+ show r = concat [ statusline+ , hdrs+ , "\r\n"+ ] where- body = concat $ map ((" "++) . (++ "\n")) [- hdrs- , version- , status- , reason- ]+ (v1,v2) = rspHttpVersion r - hdrs = concat [ "headers:\n"- , " ==============================\n "- , show $ rspHeaders r- , "\n ==============================" ]+ statusline = concat [ "HTTP/"+ , show v1+ , "."+ , show v2+ , " "+ , show $ rspStatus r+ , " "+ , toStr $ rspStatusReason r+ , "\r\n" ] - version = concat [ "version: ", show $ rspHttpVersion r ]- status = concat [ "status: ", show $ rspStatus r ]- reason = concat [ "reason: ", toStr $ rspStatusReason r ]+ hdrs = concatMap showHdr $ H.toList $ rspHeaders r + showHdr (k,v) = concat [ toStr (CI.original k), ": ", toStr v, "\r\n" ] + ------------------------------------------------------------------------------ instance HasHeaders Response where headers = rspHeaders@@ -479,7 +480,7 @@ -- | An empty 'Response'. emptyResponse :: Response-emptyResponse = Response Map.empty Map.empty (1,1) Nothing+emptyResponse = Response H.empty Map.empty (1,1) Nothing (Enum (I.enumBuilder mempty)) 200 "OK" False @@ -535,20 +536,11 @@ --------------------------------------------------------------------------------- | addCookie has been deprecated and will be removed in 0.5. Please use--- 'addResponseCookie' instead.-addCookie :: Cookie -- ^ cookie value- -> Response -- ^ response to modify- -> Response-addCookie = addResponseCookie--------------------------------------------------------------------------------- -- | Adds an HTTP 'Cookie' to 'Response' headers. addResponseCookie :: Cookie -- ^ cookie value -> Response -- ^ response to modify -> Response-addResponseCookie ck@(Cookie k _ _ _ _) r = r { rspCookies = cks' }+addResponseCookie ck@(Cookie k _ _ _ _ _ _) r = r { rspCookies = cks' } where cks'= Map.insert k ck $ rspCookies r {-# INLINE addResponseCookie #-}@@ -571,7 +563,8 @@ --------------------------------------------------------------------------------- | Deletes an HTTP 'Cookie' from the 'Response' headers.+-- | Deletes an HTTP 'Cookie' from the 'Response' headers. Please note+-- this does not necessarily erase the cookie from the client browser. deleteResponseCookie :: ByteString -- ^ cookie name -> Response -- ^ response to modify -> Response@@ -678,102 +671,6 @@ c_parse_http_time ptr #endif------------------------------------------------------------------------------------ URL ENCODING---------------------------------------------------------------------------------parseToCompletion :: Parser a -> ByteString -> Maybe a-parseToCompletion p s = toResult $ finish r- where- r = parse p s-- toResult (Atto.Done _ c) = Just c- toResult _ = Nothing----------------------------------------------------------------------------------pUrlEscaped :: Parser ByteString-pUrlEscaped = do- sq <- nextChunk DL.empty- return $ S.concat $ DL.toList sq-- where- nextChunk :: DList ByteString -> Parser (DList ByteString)- nextChunk s = (endOfInput *> pure s) <|> do- c <- anyWord8- case w2c c of- '+' -> plusSpace s- '%' -> percentEncoded s- _ -> unEncoded c s-- percentEncoded :: DList ByteString -> Parser (DList ByteString)- percentEncoded l = do- hx <- take 2- 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)-- unEncoded :: Word8 -> DList ByteString -> Parser (DList ByteString)- unEncoded c l' = do- let l = DL.snoc l' (S.singleton c)- bs <- takeTill (flip elem (map c2w "%+"))- if S.null bs- then nextChunk l- else nextChunk $ DL.snoc l bs-- plusSpace :: DList ByteString -> Parser (DList ByteString)- plusSpace l = nextChunk (DL.snoc l (S.singleton $ c2w ' '))------------------------------------------------------------------------------------ | Decodes an URL-escaped string (see--- <http://tools.ietf.org/html/rfc2396.html#section-2.4>)-urlDecode :: ByteString -> Maybe ByteString-urlDecode = parseToCompletion pUrlEscaped------------------------------------------------------------------------------------ "...Only alphanumerics [0-9a-zA-Z], the special characters "$-_.+!*'(),"--- [not including the quotes - ed], and reserved characters used for their--- reserved purposes may be used unencoded within a URL."---- | URL-escapes a string (see--- <http://tools.ietf.org/html/rfc2396.html#section-2.4>)-urlEncode :: ByteString -> ByteString-urlEncode = toByteString . S.foldl' f mempty- where- f b c =- if c == c2w ' '- then b `mappend` fromWord8 (c2w '+')- else if isKosher c- then b `mappend` fromWord8 c- else b `mappend` hexd c-- isKosher w = any ($ c) [ isAlphaNum- , flip elem ['$', '-', '.', '!', '*'- , '\'', '(', ')', ',' ]]- where- c = w2c w----------------------------------------------------------------------------------hexd :: Word8 -> Builder-hexd c = fromWord8 (c2w '%') `mappend` fromWord8 hi `mappend` fromWord8 low- where- d = c2w . intToDigit- low = d $ fromEnum $ c .&. 0xf- hi = d $ fromEnum $ (c .&. 0xf0) `shift` (-4)----------------------------------------------------------------------------------finish :: Atto.Result a -> Atto.Result a-finish (Atto.Partial f) = flip feed "" $ f ""-finish x = x ------------------------------------------------------------------------------
src/Snap/Internal/Instances.hs view
@@ -3,21 +3,22 @@ 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 Control.Applicative+import Control.Monad.CatchIO ()+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+import Snap.Internal.Types ------------------------------------------------------------------------------
src/Snap/Internal/Iteratee/BoyerMooreHorspool.hs view
@@ -127,7 +127,8 @@ let !aftermatch = S.drop (hend+1) haystack step <- if not $ S.null nomatch- then lift $ runIteratee $ k $ Chunks [NoMatch nomatch]+ then lift $ runIteratee $ k+ $ Chunks [NoMatch nomatch] else return $ Continue k cDone step $ \k' -> do@@ -144,7 +145,7 @@ mkCoeff hidx = let !ll = hlen - hidx !nm = nlen - ll in (ll,nm)- + crossBound !hidx0 = {-# SCC "crossBound" #-} do let (!leftLen, needMore) = mkCoeff hidx0
src/Snap/Internal/Parsing.hs view
@@ -2,24 +2,40 @@ module Snap.Internal.Parsing where -import Control.Arrow (first)-import Data.ByteString.Char8 (ByteString)-import qualified Data.ByteString.Char8 as S-import qualified Data.ByteString.Lazy.Char8 as L-import qualified Data.CaseInsensitive as CI-import Data.CaseInsensitive (CI)-import Data.Char (isAlpha, isAscii, isControl)+------------------------------------------------------------------------------+import Blaze.ByteString.Builder import Control.Applicative+import Control.Arrow (first, second) import Control.Monad import Data.Attoparsec.Char8 hiding (Done, many) import qualified Data.Attoparsec.Char8 as Atto+import Data.Attoparsec.FastSet (FastSet)+import qualified Data.Attoparsec.FastSet as FS+import Data.Bits+import Data.ByteString.Char8 (ByteString)+import qualified Data.ByteString.Char8 as S+import Data.ByteString.Internal (c2w, w2c)+import qualified Data.ByteString.Lazy.Char8 as L import Data.ByteString.Nums.Careless.Int (int)+import qualified Data.ByteString.Nums.Careless.Hex as Cvt+import qualified Data.CaseInsensitive as CI+import Data.CaseInsensitive (CI)+import Data.Char hiding (isDigit, isSpace)+import Data.DList (DList)+import qualified Data.DList as DL import Data.Int-import qualified Data.Vector.Unboxed as Vec-import Data.Vector.Unboxed (Vector)+import Data.List (intersperse)+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Maybe+import Data.Monoid+import Data.Word import Prelude hiding (head, take, takeWhile) +------------------------------------------------------------------------------+import Snap.Internal.Http.Types + ------------------------------------------------------------------------------ fullyParse :: ByteString -> Parser a -> Either String a fullyParse s p =@@ -58,6 +74,11 @@ ------------------------------------------------------------------------------+generateFS :: (Word8 -> Bool) -> FastSet+generateFS f = FS.fromList $ filter f [0..255]+++------------------------------------------------------------------------------ -- | Parser for zero or more spaces. spaces :: Parser [Char] spaces = many sp@@ -72,14 +93,15 @@ fieldChars :: Parser ByteString fieldChars = takeWhile isFieldChar where- isFieldChar c = (Vec.!) fieldCharTable (fromEnum c)+ isFieldChar = flip FS.memberChar fieldCharSet -------------------------------------------------------------------------------fieldCharTable :: Vector Bool-fieldCharTable = Vec.generate 256 f+fieldCharSet :: FastSet+fieldCharSet = generateFS f where- f d = let c=toEnum d in (isDigit c) || (isAlpha c) || c == '-' || c == '_'+ f d = let c = (toEnum $ fromEnum d)+ in (isDigit c) || (isAlpha c) || c == '-' || c == '_' ------------------------------------------------------------------------------@@ -212,11 +234,11 @@ ------------------------------------------------------------------------------ {-# INLINE isToken #-} isToken :: Char -> Bool-isToken c = (Vec.!) tokenTable (fromEnum c)- where- tokenTable :: Vector Bool- tokenTable = Vec.generate 256 (f . toEnum)+isToken c = FS.memberChar c tokenTable +tokenTable :: FastSet+tokenTable = generateFS (f . toEnum . fromEnum)+ where f = matchAll [ isAscii , not . isControl , not . isSpace@@ -224,6 +246,185 @@ , ':', '\\', '\"', '/', '[', ']' , '?', '=', '{', '}' ] ]+++------------------------------------------------------------------------------+-- URL ENCODING+------------------------------------------------------------------------------++parseToCompletion :: Parser a -> ByteString -> Maybe a+parseToCompletion p s = toResult $ finish r+ where+ r = parse p s++ toResult (Atto.Done _ c) = Just c+ toResult _ = Nothing+++------------------------------------------------------------------------------+pUrlEscaped :: Parser ByteString+pUrlEscaped = do+ sq <- nextChunk DL.empty+ return $ S.concat $ DL.toList sq++ where+ nextChunk :: DList ByteString -> Parser (DList ByteString)+ nextChunk s = (endOfInput *> pure s) <|> do+ c <- anyChar+ case c of+ '+' -> plusSpace s+ '%' -> percentEncoded s+ _ -> unEncoded c s++ percentEncoded :: DList ByteString -> Parser (DList ByteString)+ percentEncoded l = do+ hx <- take 2+ when (S.length hx /= 2 || (not $ S.all isHexDigit hx)) $+ fail "bad hex in url"++ let code = w2c ((Cvt.hex hx) :: Word8)+ nextChunk $ DL.snoc l (S.singleton code)++ unEncoded :: Char -> DList ByteString -> Parser (DList ByteString)+ unEncoded c l' = do+ let l = DL.snoc l' (S.singleton c)+ bs <- takeTill (flip elem "%+")+ if S.null bs+ then nextChunk l+ else nextChunk $ DL.snoc l bs++ plusSpace :: DList ByteString -> Parser (DList ByteString)+ plusSpace l = nextChunk (DL.snoc l (S.singleton ' '))+++------------------------------------------------------------------------------+-- | Decodes an URL-escaped string (see+-- <http://tools.ietf.org/html/rfc2396.html#section-2.4>)+urlDecode :: ByteString -> Maybe ByteString+urlDecode = parseToCompletion pUrlEscaped+++------------------------------------------------------------------------------+-- "...Only alphanumerics [0-9a-zA-Z], the special characters "$-_.+!*'(),"+-- [not including the quotes - ed], and reserved characters used for their+-- reserved purposes may be used unencoded within a URL."++-- | URL-escapes a string (see+-- <http://tools.ietf.org/html/rfc2396.html#section-2.4>)+urlEncode :: ByteString -> ByteString+urlEncode = toByteString . urlEncodeBuilder+++------------------------------------------------------------------------------+-- | URL-escapes a string (see+-- <http://tools.ietf.org/html/rfc2396.html#section-2.4>) into a 'Builder'.+urlEncodeBuilder :: ByteString -> Builder+urlEncodeBuilder = S.foldl' f mempty+ where+ f b c =+ if c == ' '+ then b `mappend` fromWord8 (c2w '+')+ else if FS.memberChar c urlEncodeTable+ then b `mappend` fromWord8 (c2w c)+ else b `mappend` hexd c+++------------------------------------------------------------------------------+urlEncodeTable :: FastSet+urlEncodeTable = generateFS f+ where+ f w = any ($ c) [ isAlphaNum+ , flip elem ['$', '-', '.', '!', '*'+ , '\'', '(', ')', ',' ]]+ where+ c = w2c w+++------------------------------------------------------------------------------+hexd :: Char -> Builder+hexd c0 = fromWord8 (c2w '%') `mappend` fromWord8 hi `mappend` fromWord8 low+ where+ c = c2w c0+ d = c2w . intToDigit+ low = d $ fromEnum $ c .&. 0xf+ hi = d $ fromEnum $ (c .&. 0xf0) `shiftR` 4+++------------------------------------------------------------------------------+finish :: Atto.Result a -> Atto.Result a+finish (Atto.Partial f) = flip feed "" $ f ""+finish x = x++++------------------------------------------------------------------------------+-- application/x-www-form-urlencoded+------------------------------------------------------------------------------++------------------------------------------------------------------------------+-- | Parses a string encoded in @application/x-www-form-urlencoded@ format.+parseUrlEncoded :: ByteString -> Map ByteString [ByteString]+parseUrlEncoded s = foldr (\(k,v) m -> Map.insertWith' (++) k [v] m)+ Map.empty+ decoded+ where+ breakApart = (second (S.drop 1)) . S.break (== '=')++ parts :: [(ByteString,ByteString)]+ parts = map breakApart $+ S.splitWith (\c -> c == '&' || c == ';') s++ urldecode = parseToCompletion pUrlEscaped++ decodeOne (a,b) = do+ a' <- urldecode a+ b' <- urldecode b+ return (a',b')++ decoded = catMaybes $ map decodeOne parts+++------------------------------------------------------------------------------+buildUrlEncoded :: Map ByteString [ByteString] -> Builder+buildUrlEncoded m = mconcat builders+ where+ builders = intersperse (fromWord8 $ c2w '&') $+ concatMap encodeVS $ Map.toList m++ encodeVS (k,vs) = map (encodeOne k) vs++ encodeOne k v = mconcat [ urlEncodeBuilder k+ , fromWord8 $ c2w '='+ , urlEncodeBuilder v ]+++------------------------------------------------------------------------------+printUrlEncoded :: Map ByteString [ByteString] -> ByteString+printUrlEncoded = toByteString . buildUrlEncoded+++------------------------------------------------------------------------------+-- COOKIE PARSING+------------------------------------------------------------------------------++-- these definitions try to mirror RFC-2068 (the HTTP/1.1 spec) and RFC-2109+-- (cookie spec): please point out any errors!++------------------------------------------------------------------------------+pCookies :: Parser [Cookie]+pCookies = do+ -- grab kvps and turn to strict bytestrings+ kvps <- pAvPairs++ return $ map toCookie $ filter (not . S.isPrefixOf "$" . fst) kvps++ where+ toCookie (nm,val) = Cookie nm val Nothing Nothing Nothing False False+++------------------------------------------------------------------------------+parseCookie :: ByteString -> Maybe [Cookie]+parseCookie = parseToCompletion pCookies ------------------------------------------------------------------------------
src/Snap/Internal/Routing.hs view
@@ -13,6 +13,7 @@ ------------------------------------------------------------------------------ import Snap.Internal.Http.Types+import Snap.Internal.Parsing import Snap.Internal.Types
+ src/Snap/Internal/Test/Assertions.hs view
@@ -0,0 +1,82 @@+{-# LANGUAGE OverloadedStrings #-}+module Snap.Internal.Test.Assertions where++------------------------------------------------------------------------------+import Blaze.ByteString.Builder+import Control.Monad (liftM)+import Data.ByteString.Char8 (ByteString)+import Data.Maybe (fromJust)+import Data.Monoid (mconcat)+import Test.HUnit (Assertion, assertBool, assertEqual)+import Text.Regex.Posix ((=~))++------------------------------------------------------------------------------+import Snap.Internal.Http.Types+import Snap.Iteratee (run_, consume, ($$))++------------------------------------------------------------------------------+getResponseBody :: Response -> IO ByteString+getResponseBody rsp = run_ $ enum $$ liftM toBS consume+ where+ enum = rspBodyToEnum $ rspBody rsp+ toBS = toByteString . mconcat++------------------------------------------------------------------------------+-- | Given a Response, asserts that its HTTP status code is 200 (success).+assertSuccess :: Response -> Assertion+assertSuccess rsp = assertEqual message 200 status+ where+ message = "Expected success (200) but got (" ++ (show status) ++ ")"+ status = rspStatus rsp++------------------------------------------------------------------------------+-- | Given a Response, asserts that its HTTP status code is 404 (Not Found).+assert404 :: Response -> Assertion+assert404 rsp = assertEqual message 404 status+ where+ message = "Expected Not Found (404) but got (" ++ (show status) ++ ")"+ status = rspStatus rsp+++------------------------------------------------------------------------------+-- | Given a Response, asserts that its HTTP status code is between 300 and+-- 399 (a redirect), and that the Location header of the Response points to+-- the specified URI.+assertRedirectTo :: ByteString -- ^ The Response should redirect to this+ -- URI+ -> Response+ -> Assertion+assertRedirectTo uri rsp = do+ assertRedirect rsp+ assertEqual message uri rspUri++ where+ rspUri = fromJust $ getHeader "Location" rsp+ message = "Expected redirect to " ++ show uri+ ++ " but got redirected to "+ ++ show rspUri ++ " instead"+++------------------------------------------------------------------------------+-- | Given a Response, asserts that its HTTP status code is between 300 and+-- 399 (a redirect).+assertRedirect :: Response -> Assertion+assertRedirect rsp = assertBool message (300 <= status && status <= 399)+ where+ message = "Expected redirect but got status code ("+ ++ show status ++ ")"+ status = rspStatus rsp+++------------------------------------------------------------------------------+-- | Given a Response, asserts that its body matches the given regular+-- expression.+assertBodyContains :: ByteString -- ^ Regexp that will match the body content+ -> Response+ -> Assertion+assertBodyContains match rsp = do+ body <- getResponseBody rsp+ assertBool message (body =~ match)+ where+ message = "Expected body to match regexp \"" ++ show match+ ++ "\", but didn't"
+ src/Snap/Internal/Test/RequestBuilder.hs view
@@ -0,0 +1,559 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}++module Snap.Internal.Test.RequestBuilder+ ( RequestBuilder+ , buildRequest+ , MultipartParams+ , MultipartParam(..)+ , FileData (..)+ , RequestType (..)+ , setQueryStringRaw+ , setQueryString+ , setRequestType+ , addHeader+ , setHeader+ , setContentType+ , setSecure+ , setHttpVersion+ , setRequestPath+ , get+ , postUrlEncoded+ , postMultipart+ , put+ , postRaw+ , delete+ , runHandler+ , runHandler'+ , dumpResponse+ , responseToString+ ) where++------------------------------------------------------------------------------+import Blaze.ByteString.Builder+import Blaze.ByteString.Builder.Char8+import Control.Monad.State hiding (get, put)+import qualified Control.Monad.State as State+import qualified Data.ByteString.Base16 as B16+import Data.ByteString.Char8 (ByteString)+import qualified Data.ByteString.Char8 as S+import Data.CaseInsensitive (CI)+import Data.IORef+import qualified Data.Map as Map+import Data.Monoid+import Data.Word+import System.PosixCompat.Time+import System.Random.MWC+------------------------------------------------------------------------------+import Snap.Internal.Http.Types hiding (addHeader,+ setContentType,+ setHeader)+import qualified Snap.Internal.Http.Types as H+import Snap.Internal.Parsing+import Snap.Iteratee hiding (map)+import Snap.Core hiding (addHeader, setContentType, setHeader)+import qualified Snap.Types.Headers as H++------------------------------------------------------------------------------+-- | RequestBuilder is a monad transformer that allows you to conveniently+-- build a snap 'Request' for testing.+newtype RequestBuilder m a = RequestBuilder (StateT Request m a)+ deriving (Monad, MonadIO, MonadTrans)+++------------------------------------------------------------------------------+mkDefaultRequest :: IO Request+mkDefaultRequest = do+ bodyRef <- newIORef $ SomeEnumerator enumEOF+ return $ Request "localhost"+ 8080+ "127.0.0.1"+ 60000+ "127.0.0.1"+ 8080+ "localhost"+ False+ H.empty+ bodyRef+ Nothing+ GET+ (1,1)+ []+ ""+ ""+ "/"+ "/"+ ""+ Map.empty+++------------------------------------------------------------------------------+-- | Runs a 'RequestBuilder', producing the desired 'Request'.+buildRequest :: MonadIO m => RequestBuilder m () -> m Request+buildRequest mm = do+ let (RequestBuilder m) = (mm >> fixup)+ rq0 <- liftIO mkDefaultRequest+ execStateT m rq0++ where+ fixup = do+ fixupURI+ fixupMethod+ fixupCL+ fixupParams++ fixupMethod = do+ rq <- rGet+ if (rqMethod rq == GET || rqMethod rq == DELETE ||+ rqMethod rq == HEAD)+ then do+ -- These requests are not permitted to have bodies+ let rq' = deleteHeader "Content-Type" rq+ liftIO $ writeIORef (rqBody rq') (SomeEnumerator enumEOF)+ rPut $ rq' { rqContentLength = Nothing }+ else return $! ()++ fixupCL = do+ rq <- rGet+ maybe (rPut $ deleteHeader "Content-Length" rq)+ (\cl -> rPut $ H.setHeader "Content-Length"+ (S.pack (show cl)) rq)+ (rqContentLength rq)++ fixupParams = do+ rq <- rGet+ let q = rqQueryString rq+ let pms = parseUrlEncoded q++ let mbCT = getHeader "Content-Type" rq+ post <- if mbCT == Just "application/x-www-form-urlencoded"+ then do+ (SomeEnumerator e) <- liftIO $ readIORef $ rqBody rq+ s <- liftM S.concat (liftIO $ run_ $ e $$ consume)+ return $ parseUrlEncoded s+ else return Map.empty++ rPut $ rq { rqParams = Map.unionWith (++) pms post }++------------------------------------------------------------------------------+-- | A request body of type \"@multipart/form-data@\" consists of a set of+-- named form parameters, each of which can by either a list of regular form+-- values or a set of file uploads.+type MultipartParams = [(ByteString, MultipartParam)]+++------------------------------------------------------------------------------+data MultipartParam =+ FormData [ByteString]+ -- ^ a form variable consisting of the given 'ByteString' values.+ | Files [FileData]+ -- ^ a file upload consisting of the given 'FileData' values.+ deriving (Show)+++------------------------------------------------------------------------------+data FileData = FileData {+ fdFileName :: ByteString -- ^ the file's name+ , fdContentType :: ByteString -- ^ the file's content-type+ , fdContents :: ByteString -- ^ the file contents+ }+ deriving (Show)+++------------------------------------------------------------------------------+-- | The 'RequestType' datatype enumerates the different kinds of HTTP+-- requests you can generate using the testing interface. Most users will+-- prefer to use the 'get', 'postUrlEncoded', 'postMultipart', 'put', and+-- 'delete' convenience functions.+data RequestType+ = GetRequest+ | RequestWithRawBody Method ByteString+ | MultipartPostRequest MultipartParams+ | UrlEncodedPostRequest Params+ | DeleteRequest+ deriving (Show)+++------------------------------------------------------------------------------+-- | Sets the type of the 'Request' being built.+setRequestType :: MonadIO m => RequestType -> RequestBuilder m ()+setRequestType GetRequest = do+ rq <- rGet+ liftIO $ writeIORef (rqBody rq) $ SomeEnumerator enumEOF+ rPut $ rq { rqMethod = GET+ , rqContentLength = Nothing+ }++setRequestType DeleteRequest = do+ rq <- rGet+ liftIO $ writeIORef (rqBody rq) $ SomeEnumerator enumEOF+ rPut $ rq { rqMethod = DELETE+ , rqContentLength = Nothing+ }++setRequestType (RequestWithRawBody m b) = do+ rq <- rGet+ liftIO $ writeIORef (rqBody rq) $ SomeEnumerator $ enumBS b+ rPut $ rq { rqMethod = m+ , rqContentLength = Just $ S.length b+ }++setRequestType (MultipartPostRequest fp) = encodeMultipart fp++setRequestType (UrlEncodedPostRequest fp) = do+ rq <- liftM (H.setHeader "Content-Type"+ "application/x-www-form-urlencoded") rGet+ let b = printUrlEncoded fp+ liftIO $ writeIORef (rqBody rq) $ SomeEnumerator $ enumBS b+ rPut $ rq { rqMethod = POST+ , rqContentLength = Just $ S.length b+ }+++------------------------------------------------------------------------------+makeBoundary :: MonadIO m => m ByteString+makeBoundary = do+ xs <- liftIO $ withSystemRandom $ \rng ->+ replicateM 16 ((uniform rng) :: IO Word8)+ let x = S.pack $ map (toEnum . fromEnum) xs+ return $ S.concat [ "snap-boundary-", B16.encode x ]+++------------------------------------------------------------------------------+multipartHeader :: ByteString -> ByteString -> Builder+multipartHeader boundary name =+ mconcat [ fromByteString boundary+ , fromByteString "\r\ncontent-disposition: form-data"+ , fromByteString "; name=\""+ , fromByteString name+ , fromByteString "\"\r\n" ]+++------------------------------------------------------------------------------+-- Assume initial or preceding "--" just before this+encodeFormData :: ByteString -> ByteString -> [ByteString] -> IO Builder+encodeFormData boundary name vals =+ case vals of+ [] -> return mempty+ [v] -> return $ mconcat [ hdr+ , cr+ , fromByteString v+ , fromByteString "\r\n--" ]+ _ -> multi++ where+ hdr = multipartHeader boundary name+ cr = fromByteString "\r\n"++ oneVal b v = mconcat [ fromByteString b+ , cr+ , cr+ , fromByteString v+ , fromByteString "\r\n--" ]++ multi = do+ b <- makeBoundary+ return $ mconcat [ hdr+ , multipartMixed b+ , cr+ , fromByteString "--"+ , mconcat (map (oneVal b) vals)+ , fromByteString b+ , fromByteString "--\r\n--" ]++multipartMixed :: ByteString -> Builder+multipartMixed b = mconcat [ fromByteString "Content-Type: multipart/mixed"+ , fromByteString "; boundary="+ , fromByteString b+ , fromByteString "\r\n" ]++------------------------------------------------------------------------------+encodeFiles :: ByteString -> ByteString -> [FileData] -> IO Builder+encodeFiles boundary name files =+ case files of+ [] -> return mempty+ _ -> do+ b <- makeBoundary+ return $ mconcat [ hdr+ , multipartMixed b+ , cr+ , fromByteString "--"+ , mconcat (map (oneVal b) files)+ , fromByteString b+ , fromByteString "--\r\n--"+ ]++ where+ contentDisposition fn = mconcat [+ fromByteString "Content-Disposition: attachment"+ , fromByteString "; filename=\""+ , fromByteString fn+ , fromByteString "\"\r\n"+ ]++ contentType ct = mconcat [+ fromByteString "Content-Type: "+ , fromByteString ct+ , cr+ ]++ oneVal b (FileData fileName ct contents) =+ mconcat [ fromByteString b+ , cr+ , contentType ct+ , contentDisposition fileName+ , fromByteString "Content-Transfer-Encoding: binary\r\n"+ , cr+ , fromByteString contents+ , fromByteString "\r\n--"+ ]++ hdr = multipartHeader boundary name+ cr = fromByteString "\r\n"+++------------------------------------------------------------------------------+encodeMultipart :: MonadIO m => MultipartParams -> RequestBuilder m ()+encodeMultipart kvps = do+ boundary <- liftIO $ makeBoundary+ builders <- liftIO $ mapM (handleOne boundary) kvps++ let b = toByteString $+ mconcat (fromByteString "--" : builders)+ `mappend` finalBoundary boundary++ rq0 <- rGet+ liftIO $ writeIORef (rqBody rq0) $ SomeEnumerator $ enumBS b+ let rq = H.setHeader "Content-Type"+ (S.append "multipart/form-data; boundary=" boundary)+ rq0++ rPut $ rq { rqMethod = POST+ , rqContentLength = Just $ S.length b+ }+++ where+ finalBoundary b = mconcat [fromByteString b, fromByteString "--\r\n"]++ handleOne boundary (name, mp) =+ case mp of+ (FormData vals) -> encodeFormData boundary name vals+ (Files fs) -> encodeFiles boundary name fs+++------------------------------------------------------------------------------+fixupURI :: Monad m => RequestBuilder m ()+fixupURI = do+ rq <- rGet+ let u = S.concat [ rqSnapletPath rq+ , rqContextPath rq+ , rqPathInfo rq+ , let q = rqQueryString rq+ in if S.null q+ then ""+ else S.append "?" q+ ]+ rPut $ rq { rqURI = u }+++------------------------------------------------------------------------------+-- | Sets the request's query string to be the raw bytestring provided,+-- without any escaping or other interpretation. Most users should instead+-- choose the 'setQueryString' function, which takes a parameter mapping.+setQueryStringRaw :: Monad m => ByteString -> RequestBuilder m ()+setQueryStringRaw r = do+ rq <- rGet+ rPut $ rq { rqQueryString = r }+ fixupURI+++------------------------------------------------------------------------------+-- | Escapes the given parameter mapping and sets it as the request's query+-- string.+setQueryString :: Monad m => Params -> RequestBuilder m ()+setQueryString p = setQueryStringRaw $ printUrlEncoded p+++------------------------------------------------------------------------------+-- | Sets the given header in the request being built, overwriting any header+-- with the same name already present.+setHeader :: (Monad m) => CI ByteString -> ByteString -> RequestBuilder m ()+setHeader k v = rModify (H.setHeader k v)+++------------------------------------------------------------------------------+-- | Adds the given header to the request being built.+addHeader :: (Monad m) => CI ByteString -> ByteString -> RequestBuilder m ()+addHeader k v = rModify (H.addHeader k v)+++------------------------------------------------------------------------------+-- | Sets the request's @content-type@ to the given MIME type.+setContentType :: Monad m => ByteString -> RequestBuilder m ()+setContentType c = rModify (H.setHeader "Content-Type" c)+++------------------------------------------------------------------------------+-- | Controls whether the test request being generated appears to be an https+-- request or not.+setSecure :: Monad m => Bool -> RequestBuilder m ()+setSecure b = rModify $ \rq -> rq { rqIsSecure = b }+++------------------------------------------------------------------------------+-- | Sets the test request's http version+setHttpVersion :: Monad m => (Int,Int) -> RequestBuilder m ()+setHttpVersion v = rModify $ \rq -> rq { rqVersion = v }+++------------------------------------------------------------------------------+-- | Sets the request's path. The path provided must begin with a \"@/@\" and+-- must /not/ contain a query string; if you want to provide a query string+-- in your test request, you must use 'setQueryString' or 'setQueryStringRaw'.+-- Note that 'rqContextPath' is never set by any 'RequestBuilder' function.+setRequestPath :: Monad m => ByteString -> RequestBuilder m ()+setRequestPath p = do+ rModify $ \rq -> rq { rqSnapletPath = ""+ , rqContextPath = ""+ , rqPathInfo = p }+ fixupURI+++------------------------------------------------------------------------------+-- | Builds an HTTP \"GET\" request with the given query parameters.+get :: MonadIO m =>+ ByteString -- ^ request path+ -> Params -- ^ request's form parameters+ -> RequestBuilder m ()+get uri params = do+ setRequestType GetRequest+ setQueryString params+ setRequestPath uri+++------------------------------------------------------------------------------+-- | Builds an HTTP \"DELETE\" request with the given query parameters.+delete :: MonadIO m =>+ ByteString -- ^ request path+ -> Params -- ^ request's form parameters+ -> RequestBuilder m ()+delete uri params = do+ setRequestType DeleteRequest+ setQueryString params+ setRequestPath uri+++------------------------------------------------------------------------------+-- | Builds an HTTP \"POST\" request with the given form parameters, using the+-- \"application/x-www-form-urlencoded\" MIME type.+postUrlEncoded :: MonadIO m =>+ ByteString -- ^ request path+ -> Params -- ^ request's form parameters+ -> RequestBuilder m ()+postUrlEncoded uri params = do+ setRequestType $ UrlEncodedPostRequest params+ setRequestPath uri+++------------------------------------------------------------------------------+-- | Builds an HTTP \"POST\" request with the given form parameters, using the+-- \"form-data/multipart\" MIME type.+postMultipart :: MonadIO m =>+ ByteString -- ^ request path+ -> MultipartParams -- ^ multipart form parameters+ -> RequestBuilder m ()+postMultipart uri params = do+ setRequestType $ MultipartPostRequest params+ setRequestPath uri+++------------------------------------------------------------------------------+-- | Builds an HTTP \"PUT\" request.+put :: MonadIO m =>+ ByteString -- ^ request path+ -> ByteString -- ^ request body MIME content-type+ -> ByteString -- ^ request body contents+ -> RequestBuilder m ()+put uri contentType putData = do+ setRequestType $ RequestWithRawBody PUT putData+ setHeader "Content-Type" contentType+ setRequestPath uri+++------------------------------------------------------------------------------+-- | Builds a \"raw\" HTTP \"POST\" request, with the given MIME type and body+-- contents.+postRaw :: MonadIO m =>+ ByteString -- ^ request path+ -> ByteString -- ^ request body MIME content-type+ -> ByteString -- ^ request body contents+ -> RequestBuilder m ()+postRaw uri contentType postData = do+ setRequestType $ RequestWithRawBody POST postData+ setHeader "Content-Type" contentType+ setRequestPath uri+++------------------------------------------------------------------------------+-- | Given a web handler in some 'MonadSnap' monad, and a 'RequestBuilder'+-- defining a test request, runs the handler, producing an HTTP 'Response'.+runHandler' :: (MonadIO m, MonadSnap n) =>+ (forall a . Request -> n a -> m Response)+ -- ^ a function defining how the 'MonadSnap' monad should be run+ -> RequestBuilder m ()+ -- ^ a request builder+ -> n b+ -- ^ a web handler+ -> m Response+runHandler' rSnap rBuilder snap = do+ rq <- buildRequest rBuilder+ rsp <- rSnap rq snap+ t1 <- liftIO (epochTime >>= formatHttpTime)+ return $ H.setHeader "Date" t1 rsp+++------------------------------------------------------------------------------+-- | Given a web handler in the 'Snap' monad, and a 'RequestBuilder' defining+-- a test request, runs the handler, producing an HTTP 'Response'.+runHandler :: MonadIO m =>+ RequestBuilder m () -- ^ a request builder+ -> Snap a -- ^ a web handler+ -> m Response+runHandler = runHandler' rs+ where+ rs rq s = do+ (_,rsp) <- liftIO $ run_ $ runSnap s+ (const $ return $! ())+ (const $ return $! ())+ rq+ return rsp+++------------------------------------------------------------------------------+-- | Dumps the given response to stdout.+dumpResponse :: Response -> IO ()+dumpResponse resp = responseToString resp >>= S.putStrLn+++------------------------------------------------------------------------------+-- | Converts the given response to a bytestring.+responseToString :: Response -> IO ByteString+responseToString resp = do+ b <- run_ (rspBodyToEnum (rspBody resp) $$+ liftM mconcat consume)++ return $ toByteString $ fromShow resp `mappend` b++++------------------------------------------------------------------------------+rGet :: Monad m => RequestBuilder m Request+rGet = RequestBuilder State.get++rPut :: Monad m => Request -> RequestBuilder m ()+rPut s = RequestBuilder $ State.put s++rModify :: Monad m => (Request -> Request) -> RequestBuilder m ()+rModify f = RequestBuilder $ modify f
src/Snap/Internal/Types.hs view
@@ -23,11 +23,12 @@ import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as S import qualified Data.ByteString.Lazy.Char8 as L-import Data.CaseInsensitive (CI) +import Data.CaseInsensitive (CI) import Data.Int import Data.IORef import Data.Maybe import Data.Monoid+import Data.Time import qualified Data.Text as T import qualified Data.Text.Lazy as LT import Data.Typeable@@ -257,7 +258,7 @@ -- | The Typeable instance is here so Snap can be dynamically executed with -- Hint. snapTyCon :: TyCon-snapTyCon = mkTyCon "Snap.Types.Snap"+snapTyCon = mkTyCon "Snap.Core.Snap" {-# NOINLINE snapTyCon #-} instance Typeable1 Snap where@@ -319,13 +320,32 @@ --------------------------------------------------------------------------------- | Returns the request body as a bytestring.+-- | Returns the request body as a lazy bytestring.+--+-- This function is deprecated as of 0.6; it places no limits on the size of+-- the request being read, and as such, if used, can result in a+-- denial-of-service attack on your server. Please use 'readRequestBody'+-- instead. getRequestBody :: MonadSnap m => m L.ByteString getRequestBody = liftM L.fromChunks $ runRequestBody consume {-# INLINE getRequestBody #-}+{-# DEPRECATED getRequestBody+ "As of 0.6, please use 'readRequestBody' instead" #-} ------------------------------------------------------------------------------+-- | Returns the request body as a lazy bytestring. /New in 0.6./+readRequestBody :: MonadSnap m =>+ Int64 -- ^ size of the largest request body we're willing+ -- to accept. If a request body longer than this is+ -- received, a 'TooManyBytesReadException' is+ -- thrown. See 'takeNoMoreThan'.+ -> m L.ByteString+readRequestBody sz = liftM L.fromChunks $ runRequestBody $+ joinI $ takeNoMoreThan sz $$ consume+++------------------------------------------------------------------------------ -- | 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@@ -488,8 +508,8 @@ let (p,_) = S.break (=='/') (rqPathInfo req) a <- fromBS p localRequest (updateContextPath $ S.length p) (f a)- + ------------------------------------------------------------------------------ -- | Runs a 'Snap' monad action only when 'rqPathInfo' is empty. ifTop :: MonadSnap m => m a -> m a@@ -804,7 +824,8 @@ -------------------------------------------------------------------------------data ConnectionTerminatedException = ConnectionTerminatedException SomeException+data ConnectionTerminatedException =+ ConnectionTerminatedException SomeException deriving (Typeable) @@ -913,6 +934,20 @@ => ByteString -> m a readCookie name = maybe pass (fromBS . cookieValue) =<< getCookie name+++------------------------------------------------------------------------------+-- | Expire the given 'Cookie' in client's browser.+expireCookie :: (MonadSnap m)+ => ByteString+ -- ^ Cookie name+ -> Maybe ByteString+ -- ^ Cookie domain+ -> m ()+expireCookie nm dm = do+ let old = UTCTime (ModifiedJulianDay 0) 0+ modifyResponse $ addResponseCookie+ $ Cookie nm "" (Just old) Nothing dm False False ------------------------------------------------------------------------------
src/Snap/Iteratee.hs view
@@ -684,10 +684,11 @@ enumBuilderToByteString = builderToByteString -------------------------------------------------------------------------------unsafeEnumBuilderToByteString :: MonadIO m => Enumeratee Builder ByteString m a+unsafeEnumBuilderToByteString :: MonadIO m+ => Enumeratee Builder ByteString m a unsafeEnumBuilderToByteString = builderToByteStringWith (reuseBufferStrategy (allocBuffer 65536))- + ------------------------------------------------------------------------------ enumByteStringToBuilder :: MonadIO m => Enumeratee ByteString Builder m a
+ src/Snap/Test.hs view
@@ -0,0 +1,55 @@+-- | The Snap.Test module contains primitives and combinators for testing Snap+-- applications.+module Snap.Test+ ( -- * Combinators and types for testing Snap handlers.++ -- ** Types+ RequestBuilder+ , MultipartParams+ , MultipartParam(..)+ , FileData (..)+ , RequestType (..)++ -- ** Building Requests and testing handlers+ , buildRequest+ , runHandler++ -- *** Convenience functions for generating common types of HTTP requests+ , get+ , postUrlEncoded+ , postMultipart+ , put+ , postRaw+ , delete++ -- *** Precise control over building Requests+ , addHeader+ , setContentType+ , setHeader+ , setHttpVersion+ , setQueryString+ , setQueryStringRaw+ , setRequestPath+ , setRequestType+ , setSecure++ -- * HUnit Assertions+ , assertSuccess+ , assert404+ , assertRedirectTo+ , assertRedirect+ , assertBodyContains++ -- * Getting response bodies+ , getResponseBody++ -- * Dumping HTTP Responses+ , dumpResponse+ , responseToString+ )+ where++import Snap.Internal.Test.Assertions+import Snap.Internal.Test.RequestBuilder++
src/Snap/Types.hs view
@@ -1,150 +1,6 @@-{-|--This module contains the core type definitions, class instances, and functions-for HTTP as well as the 'Snap' monad, which is used for web handlers.---}-module Snap.Types- (- -- * The Snap Monad- Snap- , runSnap- , MonadSnap(..)- , NoHandlerException(..)-- -- ** Functions for control flow and early termination- , bracketSnap- , finishWith- , catchFinishWith- , pass- , terminateConnection-- -- ** Routing- , method- , methods- , path- , pathArg- , dir- , ifTop- , route- , routeLocal-- -- ** Access to state- , getRequest- , getResponse- , putRequest- , putResponse- , modifyRequest- , modifyResponse- , localRequest- , withRequest- , withResponse-- -- ** Logging- , logError-- -- ** Grabbing/transforming request bodies- , runRequestBody- , getRequestBody- , transformRequestBody-- -- * HTTP Datatypes and Functions- -- $httpDoc- --- , Request- , Response- , Headers- , HasHeaders(..)- , Params- , Method(..)- , Cookie(..)- , HttpVersion-- -- ** Headers- , addHeader- , setHeader- , getHeader- , deleteHeader- , ipHeaderFilter- , ipHeaderFilter'-- -- ** Requests- , rqServerName- , rqServerPort- , rqRemoteAddr- , rqRemotePort- , rqLocalAddr- , rqLocalHostname- , rqIsSecure- , rqContentLength- , rqMethod- , rqVersion- , rqCookies- , rqPathInfo- , rqContextPath- , rqURI- , rqQueryString- , rqParams- , rqParam- , getParam- , getParams- , rqModifyParams- , rqSetParam-- -- ** Responses- , emptyResponse- , setResponseCode- , setResponseStatus- , rspStatus- , rspStatusReason- , setContentType- , addCookie- , addResponseCookie- , getResponseCookie- , getResponseCookies- , deleteResponseCookie- , modifyResponseCookie- , getCookie- , readCookie- , setContentLength- , clearContentLength- , redirect- , redirect'-- -- *** Response I/O- , setResponseBody- , modifyResponseBody- , addToOutput- , writeBuilder- , writeBS- , writeLazyText- , writeText- , writeLBS- , sendFile- , sendFilePartial-- -- ** Timeouts- , setTimeout- , getTimeoutAction-- -- * Iteratee- , Enumerator- , SomeEnumerator(..)-- -- * HTTP utilities- , formatHttpTime- , parseHttpTime- , urlEncode- , urlDecode- ) where---------------------------------------------------------------------------------import Snap.Internal.Http.Types-import Snap.Internal.Instances ()-import Snap.Internal.Routing-import Snap.Internal.Types-import Snap.Iteratee (Enumerator)-------------------------------------------------------------------------------+-- | As of Snap 0.6, the "Snap.Types" module is deprecated: please use+-- "Snap.Core" instead.+module Snap.Types {-# DEPRECATED "As of 0.6, use Snap.Core instead" #-}+ ( module Snap.Core ) where --- $httpDoc--- HTTP-related datatypes: 'Request', 'Response', 'Cookie', etc.+import Snap.Core
+ src/Snap/Types/Headers.hs view
@@ -0,0 +1,120 @@+{-# LANGUAGE BangPatterns #-}++-- | An opaque data type for HTTP headers. Intended to be imported qualified,+-- i.e:+--+-- > import Snap.Types.Headers (Headers)+-- > import qualified Snap.Types.Headers as H+-- >+-- > foo :: Headers+-- > foo = H.empty++module Snap.Types.Headers+ ( -- * Headers type+ Headers++ -- * Headers creation+ , empty++ -- * Predicates+ , null+ , member++ -- * Lookup+ , lookup+ , lookupWithDefault++ -- * Adding/setting headers+ , insert+ , set++ -- * Deleting+ , delete++ -- * Traversal+ , fold++ -- * Lists+ , toList+ , fromList++ ) where++import Data.ByteString.Char8 (ByteString)+import Data.CaseInsensitive (CI)+import Data.List (foldl')+import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as Map+import Data.Maybe (isJust)+import Prelude hiding (null, lookup)++------------------------------------------------------------------------------+newtype Headers = H { unH :: HashMap (CI ByteString) [ByteString] }+ deriving (Show)+++------------------------------------------------------------------------------+empty :: Headers+empty = H (Map.empty)+++------------------------------------------------------------------------------+null :: Headers -> Bool+null = Map.null . unH+{-# INLINE null #-}+++------------------------------------------------------------------------------+member :: CI ByteString -> Headers -> Bool+member k = f . unH+ where+ f m = isJust $ Map.lookup k m+{-# INLINE member #-}+++------------------------------------------------------------------------------+lookup :: CI ByteString -> Headers -> Maybe [ByteString]+lookup k (H m) = Map.lookup k m+{-# INLINE lookup #-}+++------------------------------------------------------------------------------+lookupWithDefault :: ByteString -> CI ByteString -> Headers -> [ByteString]+lookupWithDefault d k (H m) = Map.lookupDefault [d] k m+++------------------------------------------------------------------------------+insert :: CI ByteString -> ByteString -> Headers -> Headers+insert k v (H m) = H $ Map.insertWith (flip (++)) k [v] m+++------------------------------------------------------------------------------+set :: CI ByteString -> ByteString -> Headers -> Headers+set k v (H m) = H $ Map.insert k [v] m+++------------------------------------------------------------------------------+delete :: CI ByteString -> Headers -> Headers+delete k (H m) = H $ Map.delete k m+++------------------------------------------------------------------------------+fold :: (a -> CI ByteString -> [ByteString] -> a)+ -> a+ -> Headers+ -> a+fold f a (H m) = Map.foldlWithKey' f a m+++------------------------------------------------------------------------------+toList :: Headers -> [(CI ByteString, ByteString)]+toList (H m) = (Map.foldlWithKey' f id m) []+ where+ f !dl k vs = dl . ((map (\v -> (k,v)) vs) ++)+++------------------------------------------------------------------------------+fromList :: [(CI ByteString, ByteString)] -> Headers+fromList = foldl' f empty+ where+ f m (k,v) = insert k v m
src/Snap/Util/FileServe.hs view
@@ -16,16 +16,12 @@ , fancyDirectoryConfig , defaultIndexGenerator , defaultMimeTypes+, fileType -- * File servers , serveDirectory , serveDirectoryWith , serveFile , serveFileAs- -- * Deprecated interface-, fileServe-, fileServe'-, fileServeSingle-, fileServeSingle' ) where ------------------------------------------------------------------------------@@ -54,10 +50,10 @@ import System.FilePath import System.PosixCompat.Files ------------------------------------------------------------------------------+import Snap.Core import Snap.Internal.Debug import Snap.Internal.Parsing import Snap.Iteratee hiding (drop)-import Snap.Types ------------------------------------------------------------------------------@@ -269,7 +265,8 @@ , "border-top: 1px solid rgb(194,209,225);" , "color: rgb(160,172,186); font-size:10pt;" , "background: rgb(245,249,255) }"- , "table { max-width:100%; margin: 0 auto; border-collapse: collapse; }"+ , "table { max-width:100%; margin: 0 auto;" `S.append`+ " border-collapse: collapse; }" , "tr:hover { background:rgb(256,256,224) }" , "td { border:0; font-family:monospace; padding: 2px 0; }" , "td.filename, td.type { padding-right: 2em; }"@@ -698,68 +695,6 @@ ------------------------------------------------------------------------------ dbg :: (MonadIO m) => String -> m () dbg s = debug $ "FileServe:" ++ s------------------------------------------------------------------------------------ Obsolete functions retained for compatibility.------------------------------------------------------------------------------------------------------------------------------------------------------------------ | Serves files out of the given directory, using no index files and default--- MIME types.------ The function name is obsolete. You should use 'serveDirectory' or--- 'serveDirectoryWith' instead, which do similar things but with more options--- and clearer, more consistent names.-fileServe :: MonadSnap m- => FilePath -- ^ root directory- -> m ()-fileServe = serveDirectoryWith simpleDirectoryConfig-{-# INLINE fileServe #-}-{-# DEPRECATED fileServe "Use serveDirectory or serveDirectoryWith" #-}------------------------------------------------------------------------------------ | Serves files out of the given directory, with a given MIME type mapping.------ The function name is obsolete. You should use 'serveDirectoryWith'--- instead, which offers more options and a clearer, more consistent name.-fileServe' :: MonadSnap m- => MimeMap -- ^ MIME type mapping- -> FilePath -- ^ root directory- -> m ()-fileServe' mm = serveDirectoryWith (simpleDirectoryConfig { mimeTypes = mm })-{-# INLINE fileServe' #-}-{-# DEPRECATED fileServe' "Use serveDirectoryWith instead" #-}------------------------------------------------------------------------------------ | 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.------ The function name is obsolete. You should use 'serveFile' instead, which--- does the same thing but with a clearer, more consistent name.-fileServeSingle :: MonadSnap m- => FilePath -- ^ path to file- -> m ()-fileServeSingle = serveFile-{-# INLINE fileServeSingle #-}-{-# DEPRECATED fileServeSingle "Use serveFile instead" #-}------------------------------------------------------------------------------------ | Same as 'fileServeSingle', with control over the MIME mapping used.------ The function name is obsolete. You should use 'serveFileAs' instead, which--- does the same thing but with a clearer, more consistent name.-fileServeSingle' :: MonadSnap m- => ByteString -- ^ MIME type mapping- -> FilePath -- ^ path to file- -> m ()-fileServeSingle' = serveFileAs-{-# INLINE fileServeSingle' #-}-{-# DEPRECATED fileServeSingle' "Use serveFileAs instead" #-} ------------------------------------------------------------------------------
src/Snap/Util/FileUploads.hs view
@@ -93,13 +93,14 @@ import System.Directory import System.IO hiding (isEOF) ------------------------------------------------------------------------------+import Snap.Core import Snap.Iteratee hiding (map) import qualified Snap.Iteratee as I import Snap.Internal.Debug import Snap.Internal.Iteratee.Debug import Snap.Internal.Iteratee.BoyerMooreHorspool import Snap.Internal.Parsing-import Snap.Types+import qualified Snap.Types.Headers as H #ifdef USE_UNIX import System.FilePath ((</>))@@ -292,7 +293,7 @@ rateLimit bump $ internalHandleMultipart boundary ph - ins k v = Map.insertWith' (\a b -> Prelude.head a : b) k [v]+ ins k v = Map.insertWith' (flip (++)) k [v] maxFormVars = maximumNumberOfFormInputs uploadPolicy @@ -749,11 +750,11 @@ go :: (Monad m) => (Stream ByteString -> Iteratee ByteString m a) -> Iteratee MatchInfo m (Step ByteString m a) go !k = {-# SCC "pPart/go" #-}- I.head >>= maybe finish process+ I.head >>= maybe finished process where -- called when outer stream is EOF- finish = {-# SCC "pPart/finish" #-}- lift $ runIteratee $ k EOF+ finished = {-# SCC "pPart/finish" #-}+ lift $ runIteratee $ k EOF -- no match ==> pass the stream chunk along process (NoMatch !s) = {-# SCC "pPart/noMatch" #-} do@@ -819,10 +820,9 @@ ------------------------------------------------------------------------------ toHeaders :: [(ByteString,ByteString)] -> Headers-toHeaders kvps = foldl' f Map.empty kvps'+toHeaders kvps = H.fromList kvps' where- kvps' = map (first CI.mk . second (:[])) kvps- f m (k,v) = Map.insertWith' (flip (++)) k v m+ kvps' = map (first CI.mk) kvps ------------------------------------------------------------------------------
src/Snap/Util/GZip.hs view
@@ -11,13 +11,11 @@ import Blaze.ByteString.Builder import qualified Codec.Zlib.Enum as Z-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 qualified Data.ByteString.Char8 as S import qualified Data.Char as Char@@ -30,11 +28,11 @@ ----------------------------------------------------------------------------+import Snap.Core import Snap.Internal.Debug import Snap.Internal.Parsing import Snap.Iteratee import qualified Snap.Iteratee as I-import Snap.Types ------------------------------------------------------------------------------
test/runTestsAndCoverage.sh view
@@ -38,7 +38,9 @@ Snap.Internal.Http.Server.Tests Snap.Internal.Http.Types.Tests Snap.Internal.Iteratee.Tests+Snap.Internal.Parsing.Tests Snap.Internal.Routing.Tests+Snap.Test.Tests Snap.Types.Tests Snap.Util.FileServe.Tests Snap.Util.FileUploads.Tests
test/snap-core-testsuite.cabal view
@@ -31,7 +31,7 @@ blaze-builder-enumerator >= 0.2 && <0.3, bytestring, bytestring-nums,- case-insensitive >= 0.2 && < 0.4,+ case-insensitive >= 0.3 && < 0.4, cereal == 0.3.*, containers, deepseq >= 1.1 && <1.3,@@ -42,18 +42,20 @@ enumerator >= 0.4.13.1 && < 0.5, MonadCatchIO-transformers >= 0.2 && < 0.3, mtl >= 2 && <3,+ mwc-random >= 0.10 && <0.11, old-locale, old-time, parallel >= 3 && <4, pureMD5 == 2.1.*, regex-posix >= 0.94.4 && <0.96,- test-framework >= 0.3.1 && <0.5,+ test-framework >= 0.4 && < 0.5, test-framework-hunit >= 0.2.5 && < 0.3, test-framework-quickcheck2 >= 0.2.6 && < 0.3, text >= 0.11 && <0.12, time, transformers, unix-compat >= 0.2 && <0.4,+ unordered-containers >= 0.1.4.3 && <0.2, vector >= 0.6 && <0.10, zlib, zlib-enum >= 0.2.1 && <0.3
+ test/suite/Snap/Core/Tests.hs view
@@ -0,0 +1,590 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Snap.Core.Tests+ ( tests ) where++import Blaze.ByteString.Builder+import Control.Applicative+import Control.Concurrent.MVar+import Control.DeepSeq+import Control.Exception (ErrorCall(..), SomeException, throwIO)+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 qualified Data.IntMap as IM+import Data.IORef+import Data.Maybe (isJust)+import Data.Monoid+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.Http.Types+import Snap.Internal.Parsing+import Snap.Internal.Types+import Snap.Iteratee+import qualified Snap.Iteratee as I+import Snap.Test.Common+import qualified Snap.Types.Headers as H+++tests :: [Test]+tests = [ testFail+ , testAlternative+ , testEarlyTermination+ , testCatchFinishWith+ , testRqBody+ , testRqBodyTooLong+ , testRqBodyException+ , testRqBodyTermination+ , testTrivials+ , testMethod+ , testMethods+ , testDir+ , testCatchIO+ , testWrites+ , testParam+ , testURLEncode1+ , testURLEncode2+ , testDir2+ , testIpHeaderFilter+ , testMZero404+ , testEvalSnap+ , testLocalRequest+ , testRedirect+ , testBracketSnap ]+++expectSpecificException :: Exception e => e -> IO a -> IO ()+expectSpecificException e0 m = do+ r <- try m++ let b = either (\se -> isJust $+ forceSameType (Just e0) (fromException se))+ (const False)+ r+ assertBool ("expected specific exception: " ++ show e0) b+++expect404 :: IO (Request,Response) -> IO ()+expect404 m = do+ (_,r) <- m+ assertBool "expected 404" (rspStatus r == 404)+++expectNo404 :: IO (Request,Response) -> IO ()+expectNo404 m = do+ (_,r) <- m+ assertBool ("expected 200, got " ++ show (rspStatus r))+ (rspStatus r /= 404)+++mkRequest :: ByteString -> IO Request+mkRequest uri = do+ enum <- newIORef $ SomeEnumerator returnI++ return $ Request "foo" 80 "127.0.0.1" 999 "foo" 1000 "foo" False H.empty+ enum Nothing GET (1,1) [] "" uri "/"+ (S.concat ["/",uri]) "" Map.empty++mkRequestQuery :: ByteString -> ByteString -> [ByteString] -> IO Request+mkRequestQuery uri k v = do+ enum <- newIORef $ SomeEnumerator returnI++ let mp = Map.fromList [(k,v)]+ let q = S.concat [k,"=", S.concat v]++ return $ Request "foo" 80 "foo" 999 "foo" 1000 "foo" False H.empty+ enum Nothing GET (1,1) [] "" uri "/"+ (S.concat ["/",uri,"?",q]) q mp+++mkZomgRq :: IO Request+mkZomgRq = do+ enum <- newIORef $ SomeEnumerator returnI++ return $ Request "foo" 80 "127.0.0.1" 999 "foo" 1000 "foo" False H.empty+ enum Nothing GET (1,1) [] "" "/" "/" "/" "" Map.empty+++mkIpHeaderRq :: IO Request+mkIpHeaderRq = do+ rq <- mkZomgRq+ return $ setHeader "X-Forwarded-For" "1.2.3.4"+ $ deleteHeader "X-Forwarded-For"+ $ setHeader "X-Forwarded-For" "1.2.3.4" rq+++mkRqWithBody :: IO Request+mkRqWithBody = mkRqWithEnum (enumBS "zazzle" >==> enumEOF)+++mkRqWithEnum :: (forall a . Enumerator ByteString IO a) -> IO Request+mkRqWithEnum e = do+ enum <- newIORef $ SomeEnumerator e+ return $ Request "foo" 80 "foo" 999 "foo" 1000 "foo" False H.empty+ enum Nothing GET (1,1) [] "" "/" "/" "/" ""+ Map.empty++testCatchIO :: Test+testCatchIO = testCase "types/catchIO" $ do+ (_,rsp) <- go f+ (_,rsp2) <- go g++ assertEqual "catchIO 1" (Just "bar") $ getHeader "foo" rsp+ assertEqual "catchIO 2" Nothing $ getHeader "foo" rsp2++ where+ f :: Snap ()+ f = (block $ unblock $ throw $ NoHandlerException "") `catch` h++ g :: Snap ()+ g = return () `catch` h++ h :: SomeException -> Snap ()+ h e = e `seq` modifyResponse $ addHeader "foo" "bar"++go :: Snap a -> IO (Request,Response)+go m = do+ zomgRq <- mkZomgRq+ run_ $ runSnap m dummy dummy zomgRq+ where+ dummy !x = return $! (show x `using` rdeepseq) `seq` ()++goIP :: Snap a -> IO (Request,Response)+goIP m = do+ rq <- mkIpHeaderRq+ run_ $ runSnap m dummy dummy rq+ where+ dummy = const $ return ()++goPath :: ByteString -> Snap a -> IO (Request,Response)+goPath s m = do+ rq <- mkRequest s+ run_ $ runSnap m dummy dummy rq+ where+ dummy = const $ return ()+++goPathQuery :: ByteString+ -> ByteString+ -> [ByteString]+ -> Snap a+ -> IO (Request,Response)+goPathQuery s k v m = do+ rq <- mkRequestQuery s k v+ run_ $ runSnap m dummy dummy rq+ where+ dummy = const $ return ()+++goBody :: Snap a -> IO (Request,Response)+goBody m = do+ rq <- mkRqWithBody+ run_ $ runSnap m dummy dummy rq+ where+ dummy = const $ return ()+++goEnum :: (forall a . Enumerator ByteString IO a)+ -> Snap b+ -> IO (Request,Response)+goEnum enum m = do+ rq <- mkRqWithEnum enum+ run_ $ runSnap m dummy dummy rq+ where+ dummy = const $ return ()+++testFail :: Test+testFail = testCase "failure" $ expect404 (go pass)+++setFoo :: ByteString -> Snap ()+setFoo s = do+ modifyResponse (addHeader "Foo" s)+ fmap id $ pure ()+ pure id <*> (liftIO $ return ())+++testAlternative :: Test+testAlternative = testCase "types/alternative" $ do+ (_,resp) <- go (pass <|> setFoo "Bar")+ assertEqual "foo present" (Just "Bar") $ getHeader "Foo" resp++ (_,resp2) <- go (fail ""+ <|> fail2+ <|> setFoo "Bar"+ <|> setFoo "Baz")+ assertEqual "alternative chooses correct branch"+ (Just ["Bar"]) $ getHeaders "Foo" resp2++ where+ fail2 :: Snap ()+ fail2 = pass >>= \_ -> return ()+++sampleResponse :: Response+sampleResponse = addHeader "Foo" "Quux" $ emptyResponse+++testEarlyTermination :: Test+testEarlyTermination = testCase "types/earlyTermination" $ do+ (_,resp) <- go (finishWith sampleResponse >>= \_ -> setFoo "Bar")+ assertEqual "foo" (Just ["Quux"]) $ getHeaders "Foo" resp+++isLeft :: Either a b -> Bool+isLeft (Left _) = True+isLeft _ = False++isRight :: Either a b -> Bool+isRight (Right _) = True+isRight _ = False+++testBracketSnap :: Test+testBracketSnap = testCase "types/bracketSnap" $ do+ rq <- mkZomgRq++ ref <- newIORef 0++ expectSpecificException (NoHandlerException "") $+ run_ $ evalSnap (act ref) (const $ return ()) (const $ return ()) rq++ y <- readIORef ref+ assertEqual "bracketSnap/after1" (1::Int) y++ expectSpecificException (ErrorCall "no value") $+ run_ $ evalSnap (act ref <|> finishWith emptyResponse)+ (const $ return ())+ (const $ return ())+ rq+ + y' <- readIORef ref+ assertEqual "bracketSnap/after" 2 y'+++ expectSpecificException (ErrorCall "foo") $+ run_ $ evalSnap (act2 ref)+ (const $ return ())+ (const $ return ())+ rq+ + y'' <- readIORef ref+ assertEqual "bracketSnap/after" 3 y''++ where+ act ref = bracketSnap (liftIO $ readIORef ref)+ (\z -> liftIO $ writeIORef ref $! z+1)+ (\z -> z `seq` mzero)++ act2 ref = bracketSnap (liftIO $ readIORef ref)+ (\z -> liftIO $ writeIORef ref $! z+1)+ (\z -> z `seq` liftIO $ throwIO $ ErrorCall "foo")+++testCatchFinishWith :: Test+testCatchFinishWith = testCase "types/catchFinishWith" $ do+ rq <- mkZomgRq+ x <- run_ $ evalSnap (catchFinishWith $ finishWith emptyResponse)+ (const $ return ())+ (const $ return ())+ rq+ assertBool "catchFinishWith" $ isLeft x+ y <- run_ $ evalSnap (catchFinishWith $ return ())+ (const $ return ())+ (const $ return ())+ rq+ assertBool "catchFinishWith" $ isRight y+++testRqBody :: Test+testRqBody = testCase "types/requestBodies" $ do+ mvar1 <- newEmptyMVar+ mvar2 <- newEmptyMVar++ _ <- goBody $ f mvar1 mvar2++ v1 <- takeMVar mvar1+ v2 <- takeMVar mvar2++ assertEqual "rq body" "zazzle" v1+ assertEqual "rq body 2" "" v2++ (_,rsp) <- goBody g+ bd <- getBody rsp++ assertEqual "detached rq body" "zazzle" bd+++ where+ f mvar1 mvar2 = do+ getRequestBody >>= liftIO . putMVar mvar1+ getRequestBody >>= liftIO . putMVar mvar2++ g = transformRequestBody returnI+++testRqBodyTooLong :: Test+testRqBodyTooLong = testCase "types/requestBodyTooLong" $ do+ expectExceptionH $ goBody $ f 2+ (_, rsp) <- goBody $ f 200000+ bd <- getBody rsp++ assertEqual "detached rq body" "zazzle" bd+++ where+ f sz = readRequestBody sz >>= writeLBS+++testRqBodyException :: Test+testRqBodyException = testCase "types/requestBodyException" $ do+ (req,resp) <- goEnum (enumList 1 ["the", "quick", "brown", "fox"]) hndlr+ bd <- getBody resp++ (SomeEnumerator e) <- readIORef $ rqBody req+ b' <- liftM (S.concat) $ run_ $ e $$ consume+ assertEqual "request body was consumed" "" b'+ assertEqual "response body was produced" "OK" bd++ where+ h0 = runRequestBody $ do+ _ <- I.head+ throw $ ErrorCall "foo"++ hndlr = h0 `catch` \(_::SomeException) -> writeBS "OK"+++testRqBodyTermination :: Test+testRqBodyTermination =+ testCase "types/requestBodyTermination" $+ expectExceptionH $+ goEnum (enumList 1 ["the", "quick", "brown", "fox"]) hndlr++ where+ h0 = runRequestBody $ do+ _ <- I.head+ terminateConnection $ ErrorCall "foo"++ hndlr = h0 `catch` \(_::SomeException) -> writeBS "OK"++++testTrivials :: Test+testTrivials = testCase "types/trivials" $ do+ (rq,rsp) <- go $ do+ req <- getRequest+ putRequest $ req { rqIsSecure=True }+ putResponse $ setResponseStatus 333 "333" sampleResponse+ r <- getResponse+ liftIO $ assertEqual "rsp status" 333 $ rspStatus r+ !_ <- localRequest (\x -> x {rqIsSecure=False}) $ do+ q <- getRequest+ liftIO $ assertEqual "localrq" False $ rqIsSecure q+ return ()++ logError "foo"+ writeText "zzz"+ writeLazyText "zzz"++ let req' = updateContextPath 0 req+ let cp1 = rqContextPath req+ let cp2 = rqContextPath req'++ liftIO $ assertEqual "updateContextPath 0" cp1 cp2++ withRequest $ return . (`seq` ())+ withResponse $ return . (`seq` ())++ return ()++ b <- getBody rsp+ coverShowInstance b+ coverShowInstance $ NoHandlerException ""+ coverShowInstance GET+ coverReadInstance GET+ coverEqInstance GET+ coverEqInstance $ NoHandlerException ""+ coverOrdInstance GET++ Prelude.map (\(x,y) -> (x,show y)) (IM.toList statusReasonMap)+ `deepseq` return ()++ let cookie = Cookie "" "" Nothing Nothing Nothing False False+ coverEqInstance cookie+ coverShowInstance cookie++ assertEqual "rq secure" True $ rqIsSecure rq+ assertEqual "rsp status" 333 $ rspStatus rsp+++testMethod :: Test+testMethod = testCase "types/method" $ do+ expect404 $ go (method POST $ return ())+ expectNo404 $ go (method GET $ return ())++testMethods :: Test+testMethods = testCase "types/methods" $ do+ expect404 $ go (methods [POST,PUT] $ return ())+ expectNo404 $ go (methods [GET] $ return ())+ expectNo404 $ go (methods [POST,GET] $ return ())+ expectNo404 $ go (methods [PUT,GET] $ return ())+ expectNo404 $ go (methods [GET,PUT,DELETE] $ return ())+++testDir :: Test+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 ())+ expectNo404 $ goPath "foo/bar" (path "foo/bar" $ return ())+ expect404 $ goPath "foo/bar/z" (path "foo/bar" $ return ())+ expectNo404 $ goPath "" (ifTop $ return ())+ expect404 $ goPath "a" (ifTop $ return ())+++testParam :: Test+testParam = testCase "types/getParam" $ do+ expect404 $ goPath "/foo" f+ expectNo404 $ goPathQuery "/foo" "param" ["foo"] f+ where+ f = do+ mp <- getParam "param"+ maybe pass+ (\s -> if s == "foo" then return () else pass)+ mp+++getBody :: Response -> IO L.ByteString+getBody r = do+ let benum = rspBodyToEnum $ rspBody r+ liftM (toLazyByteString . mconcat) (runIteratee consume >>= run_ . benum)+++testWrites :: Test+testWrites = testCase "types/writes" $ do+ (_,r) <- go h+ b <- getBody r+ assertEqual "output functions" "Foo1Foo2Foo3" b+ where+ h :: Snap ()+ h = do+ addToOutput $ enumBuilder $ fromByteString "Foo1"+ writeBS "Foo2"+ writeLBS "Foo3"+++testURLEncode1 :: Test+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 "types/urlEncoding2" prop+ where+ prop s = (urlDecode $ urlEncode s) == Just s+++testDir2 :: Test+testDir2 = testCase "types/dir2" $ do+ (_,resp) <- goPath "foo/bar" f+ b <- getBody resp+ assertEqual "context path" "/foo/bar/" b++ where+ f = dir "foo" $ dir "bar" $ do+ p <- liftM rqContextPath getRequest+ addToOutput $ enumBuilder $ fromByteString p+++testIpHeaderFilter :: Test+testIpHeaderFilter = testCase "types/ipHeaderFilter" $ do+ (_,r) <- goIP f+ b <- getBody r+ assertEqual "ipHeaderFilter" "1.2.3.4" b+++ (_,r2) <- go f+ b2 <- getBody r2+ assertEqual "ipHeaderFilter" "127.0.0.1" b2++ where+ f = do+ ipHeaderFilter+ ip <- liftM rqRemoteAddr getRequest+ writeBS ip+++testMZero404 :: Test+testMZero404 = testCase "types/mzero404" $ do+ (_,r) <- go mzero+ let l = rspContentLength r+ b <- getBody r+ assertEqual "mzero 404" "404" b+ assertEqual "mzero 404 length" (Just 3) l+++testEvalSnap :: Test+testEvalSnap = testCase "types/evalSnap-exception" $ do+ rq <- mkZomgRq+ expectExceptionH (run_ $ evalSnap f+ (const $ return ())+ (const $ return ())+ rq >> return ())+ where+ f = do+ logError "zzz"+ v <- withResponse (return . rspHttpVersion)+ liftIO $ assertEqual "evalSnap rsp version" (1,1) v+ finishWith emptyResponse+++testLocalRequest :: Test+testLocalRequest = testCase "types/localRequest" $ do+ rq1 <- mkZomgRq+ rq2 <- mkRequest "zzz/zz/z"++ let h = localRequest (const rq2) mzero++ (rq',_) <- go (h <|> return ())++ let u1 = rqURI rq1+ let u2 = rqURI rq'++ assertEqual "localRequest backtrack" u1 u2++++testRedirect :: Test+testRedirect = testCase "types/redirect" $ do+ (_,rsp) <- go (redirect "/foo/bar")++ b <- getBody rsp+ assertEqual "no response body" "" b+ assertEqual "response content length" (Just 0) $ rspContentLength rsp+ assertEqual "redirect path" (Just "/foo/bar") $ getHeader "Location" rsp+ assertEqual "redirect status" 302 $ rspStatus rsp+ assertEqual "status description" "Found" $ rspStatusReason rsp+++ (_,rsp2) <- go (redirect' "/bar/foo" 307)++ assertEqual "redirect path" (Just "/bar/foo") $ getHeader "Location" rsp2+ assertEqual "redirect status" 307 $ rspStatus rsp2+ assertEqual "status description" "Temporary Redirect" $ rspStatusReason rsp2
test/suite/Snap/Internal/Http/Types/Tests.hs view
@@ -20,7 +20,9 @@ import Text.Regex.Posix import Snap.Internal.Http.Types+import Snap.Internal.Parsing import Snap.Iteratee+import qualified Snap.Types.Headers as H tests :: [Test]@@ -34,7 +36,7 @@ mkRq :: IO Request mkRq = do enum <- newIORef (SomeEnumerator $ enumBS "")- return $ Request "foo" 80 "foo" 999 "foo" 1000 "foo" False Map.empty+ return $ Request "foo" 80 "foo" 999 "foo" 1000 "foo" False H.empty enum Nothing GET (1,1) [] "" "/" "/" "/" "" Map.empty @@ -57,7 +59,7 @@ let x = getHeader "foo" req- assertEqual "addHeader x 2" (Just "bar baz") x+ assertEqual "addHeader x 2" (Just "baz bar") x testUrlDecode :: Test@@ -70,7 +72,7 @@ defReq <- mkRq let req = rqModifyParams (Map.insert "zzz" ["bbb"]) $- updateHeaders (Map.insert "zzz" ["bbb"]) $+ updateHeaders (H.set "zzz" "bbb") $ rqSetParam "foo" ["bar"] $ defReq @@ -84,7 +86,7 @@ assertBool "show" $ a /= b assertEqual "rqParam" (Just ["bar"]) (rqParam "foo" req) assertEqual "lookup" (Just ["bbb"]) (Map.lookup "zzz" $ rqParams req)- assertEqual "lookup 2" (Just ["bbb"]) (Map.lookup "zzz" $ headers req)+ assertEqual "lookup 2" (Just ["bbb"]) (H.lookup "zzz" $ headers req) assertEqual "response status" 555 $ rspStatus resp assertEqual "response status reason" "bogus" $ rspStatusReason resp@@ -116,8 +118,8 @@ resp2 = addResponseCookie cook2 resp utc = UTCTime (ModifiedJulianDay 55226) 0- cook = Cookie "foo" "bar" (Just utc) (Just ".foo.com") (Just "/")- cook2 = Cookie "zoo" "baz" (Just utc) (Just ".foo.com") (Just "/")+ cook = Cookie "foo" "bar" (Just utc) (Just ".foo.com") (Just "/") False False+ cook2 = Cookie "zoo" "baz" (Just utc) (Just ".foo.com") (Just "/") False False testCookies :: Test@@ -146,9 +148,9 @@ resp4 = addResponseCookie cook3 emptyResponse utc = UTCTime (ModifiedJulianDay 55226) 0- cook = Cookie "foo" "bar" (Just utc) (Just ".foo.com") (Just "/")- cook2 = Cookie "zoo" "baz" (Just utc) (Just ".foo.com") (Just "/")- cook3 = Cookie "boo" "baz" Nothing Nothing Nothing+ cook = Cookie "foo" "bar" (Just utc) (Just ".foo.com") (Just "/") False True+ cook2 = Cookie "zoo" "baz" (Just utc) (Just ".foo.com") (Just "/") True False+ cook3 = Cookie "boo" "baz" Nothing Nothing Nothing False False rCook = getResponseCookie "foo" resp nilCook = getResponseCookie "foo" resp'
+ test/suite/Snap/Internal/Parsing/Tests.hs view
@@ -0,0 +1,32 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE OverloadedStrings #-}+module Snap.Internal.Parsing.Tests+ ( tests ) where+++import qualified Data.ByteString as S+import Test.Framework+import Test.Framework.Providers.HUnit+import Test.HUnit hiding (Test, path)++import Snap.Internal.Http.Types+import Snap.Internal.Parsing+++tests :: [Test]+tests = [ testCookie ]+++testCookie :: Test+testCookie =+ testCase "parsing/parseCookie" $ do+ assertEqual "cookie parsing" (Just [cv]) cv2++ where+ cv = Cookie nm v Nothing Nothing Nothing False False+ cv2 = parseCookie ct++ nm = "foo"+ v = "bar"++ ct = S.concat [ nm , "=" , v ]
test/suite/Snap/Internal/Routing/Tests.hs view
@@ -16,11 +16,11 @@ import Test.Framework.Providers.HUnit import Test.HUnit hiding (Test, path) - import Snap.Internal.Http.Types import Snap.Internal.Routing import Snap.Internal.Types import Snap.Iteratee hiding (head)+import qualified Snap.Types.Headers as H tests :: [Test] tests = [ testRouting1@@ -65,7 +65,7 @@ mkRequest uri = do enum <- newIORef $ SomeEnumerator returnI - return $ Request "foo" 80 "foo" 999 "foo" 1000 "foo" False Map.empty+ return $ Request "foo" 80 "foo" 999 "foo" 1000 "foo" False H.empty enum Nothing GET (1,1) [] "" uri "/" (B.concat ["/",uri]) "" Map.empty
test/suite/Snap/Iteratee/Tests.hs view
@@ -32,32 +32,12 @@ import Snap.Iteratee import Snap.Internal.Iteratee.BoyerMooreHorspool-import Snap.Test.Common (coverShowInstance)+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- case e of- Left (z::SomeException) -> (show z) `seq` return ()- Right _ -> fail "expected exception, didn't get one"---expectExceptionH :: IO a -> IO ()-expectExceptionH act = do- e <- E.try act- case e of- Left (z::SomeException) -> (show z) `seq` return ()- Right _ -> fail "expected expected, didn't get one" tests :: [Test]
test/suite/Snap/Test/Common.hs view
@@ -10,6 +10,9 @@ , coverShowInstance , coverTypeableInstance , forceSameType+ , expectException+ , expectExceptionH+ , liftQ , eatException ) where @@ -24,6 +27,8 @@ import Data.Typeable import Prelude hiding (catch) import Test.QuickCheck+import qualified Test.QuickCheck.Monadic as QC+import Test.QuickCheck.Monadic instance Arbitrary S.ByteString where@@ -83,3 +88,23 @@ coverTypeableInstance :: (Monad m, Typeable a) => a -> m () coverTypeableInstance a = typeOf a `seq` return ()+++expectException :: IO a -> PropertyM IO ()+expectException m = do+ e <- liftQ $ try m+ case e of+ Left (z::SomeException) -> (length $ show z) `seq` return ()+ Right _ -> fail "expected exception, didn't get one"+++expectExceptionH :: IO a -> IO ()+expectExceptionH act = do+ e <- try act+ case e of+ Left (z::SomeException) -> (length $ show z) `seq` return ()+ Right _ -> fail "expected exception, didn't get one"+++liftQ :: forall a m . (Monad m) => m a -> PropertyM m a+liftQ = QC.run
− test/suite/Snap/Types/Tests.hs
@@ -1,584 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}--module Snap.Types.Tests- ( tests ) where--import Blaze.ByteString.Builder-import Control.Applicative-import Control.Concurrent.MVar-import Control.DeepSeq-import Control.Exception (ErrorCall(..), SomeException, throwIO)-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 qualified Data.IntMap as IM-import Data.IORef-import Data.Maybe (isJust)-import Data.Monoid-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 qualified Snap.Iteratee as I-import Snap.Test.Common---tests :: [Test]-tests = [ testFail- , testAlternative- , testEarlyTermination- , testCatchFinishWith- , testRqBody- , testRqBodyException- , testRqBodyTermination- , testTrivials- , testMethod- , testMethods- , testDir- , testCatchIO- , testWrites- , testParam- , testURLEncode1- , testURLEncode2- , testDir2- , testIpHeaderFilter- , testMZero404- , testEvalSnap- , testLocalRequest- , testRedirect- , testBracketSnap ]---expectException :: IO a -> IO ()-expectException m = do- r <- try m- let b = either (\e -> (show (e::SomeException) `using` rdeepseq)- `seq` True)- (const False)- r- assertBool "expected exception" b---expectSpecificException :: Exception e => e -> IO a -> IO ()-expectSpecificException e0 m = do- r <- try m-- let b = either (\se -> isJust $- forceSameType (Just e0) (fromException se))- (const False)- r- assertBool ("expected specific exception: " ++ show e0) b---expect404 :: IO (Request,Response) -> IO ()-expect404 m = do- (_,r) <- m- assertBool "expected 404" (rspStatus r == 404)---expectNo404 :: IO (Request,Response) -> IO ()-expectNo404 m = do- (_,r) <- m- assertBool ("expected 200, got " ++ show (rspStatus r))- (rspStatus r /= 404)---mkRequest :: ByteString -> IO Request-mkRequest uri = do- 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 "/"- (S.concat ["/",uri]) "" Map.empty--mkRequestQuery :: ByteString -> ByteString -> [ByteString] -> IO Request-mkRequestQuery uri k v = do- enum <- newIORef $ SomeEnumerator returnI-- let mp = Map.fromList [(k,v)]- let q = S.concat [k,"=", S.concat v]-- return $ Request "foo" 80 "foo" 999 "foo" 1000 "foo" False Map.empty- enum Nothing GET (1,1) [] "" uri "/"- (S.concat ["/",uri,"?",q]) q mp---mkZomgRq :: IO Request-mkZomgRq = do- 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---mkIpHeaderRq :: IO Request-mkIpHeaderRq = do- rq <- mkZomgRq- return $ setHeader "X-Forwarded-For" "1.2.3.4"- $ deleteHeader "X-Forwarded-For"- $ setHeader "X-Forwarded-For" "1.2.3.4" rq---mkRqWithBody :: IO Request-mkRqWithBody = mkRqWithEnum (enumBS "zazzle" >==> enumEOF)---mkRqWithEnum :: (forall a . Enumerator ByteString IO a) -> IO Request-mkRqWithEnum e = do- enum <- newIORef $ SomeEnumerator e- return $ Request "foo" 80 "foo" 999 "foo" 1000 "foo" False Map.empty- enum Nothing GET (1,1) [] "" "/" "/" "/" ""- Map.empty--testCatchIO :: Test-testCatchIO = testCase "types/catchIO" $ do- (_,rsp) <- go f- (_,rsp2) <- go g-- assertEqual "catchIO 1" (Just "bar") $ getHeader "foo" rsp- assertEqual "catchIO 2" Nothing $ getHeader "foo" rsp2-- where- f :: Snap ()- f = (block $ unblock $ throw $ NoHandlerException "") `catch` h-- g :: Snap ()- g = return () `catch` h-- h :: SomeException -> Snap ()- h e = e `seq` modifyResponse $ addHeader "foo" "bar"--go :: Snap a -> IO (Request,Response)-go m = do- zomgRq <- mkZomgRq- run_ $ runSnap m dummy dummy zomgRq- where- dummy !x = return $! (show x `using` rdeepseq) `seq` ()--goIP :: Snap a -> IO (Request,Response)-goIP m = do- rq <- mkIpHeaderRq- run_ $ runSnap m dummy dummy rq- where- dummy = const $ return ()--goPath :: ByteString -> Snap a -> IO (Request,Response)-goPath s m = do- rq <- mkRequest s- run_ $ runSnap m dummy dummy rq- where- dummy = const $ return ()---goPathQuery :: ByteString- -> ByteString- -> [ByteString]- -> Snap a- -> IO (Request,Response)-goPathQuery s k v m = do- rq <- mkRequestQuery s k v- run_ $ runSnap m dummy dummy rq- where- dummy = const $ return ()---goBody :: Snap a -> IO (Request,Response)-goBody m = do- rq <- mkRqWithBody- run_ $ runSnap m dummy dummy rq- where- dummy = const $ return ()---goEnum :: (forall a . Enumerator ByteString IO a)- -> Snap b- -> IO (Request,Response)-goEnum enum m = do- rq <- mkRqWithEnum enum- run_ $ runSnap m dummy dummy rq- where- dummy = const $ return ()---testFail :: Test-testFail = testCase "failure" $ expect404 (go pass)---setFoo :: ByteString -> Snap ()-setFoo s = do- modifyResponse (addHeader "Foo" s)- fmap id $ pure ()- pure id <*> (liftIO $ return ())---testAlternative :: Test-testAlternative = testCase "types/alternative" $ do- (_,resp) <- go (pass <|> setFoo "Bar")- assertEqual "foo present" (Just "Bar") $ getHeader "Foo" resp-- (_,resp2) <- go (fail ""- <|> fail2- <|> setFoo "Bar"- <|> setFoo "Baz")- assertEqual "alternative chooses correct branch"- (Just ["Bar"]) $ getHeaders "Foo" resp2-- where- fail2 :: Snap ()- fail2 = pass >>= \_ -> return ()---sampleResponse :: Response-sampleResponse = addHeader "Foo" "Quux" $ emptyResponse---testEarlyTermination :: Test-testEarlyTermination = testCase "types/earlyTermination" $ do- (_,resp) <- go (finishWith sampleResponse >>= \_ -> setFoo "Bar")- assertEqual "foo" (Just ["Quux"]) $ getHeaders "Foo" resp---isLeft :: Either a b -> Bool-isLeft (Left _) = True-isLeft _ = False--isRight :: Either a b -> Bool-isRight (Right _) = True-isRight _ = False---testBracketSnap :: Test-testBracketSnap = testCase "types/bracketSnap" $ do- rq <- mkZomgRq-- ref <- newIORef 0-- expectSpecificException (NoHandlerException "") $- run_ $ evalSnap (act ref) (const $ return ()) (const $ return ()) rq-- y <- readIORef ref- assertEqual "bracketSnap/after1" (1::Int) y-- expectSpecificException (ErrorCall "no value") $- run_ $ evalSnap (act ref <|> finishWith emptyResponse)- (const $ return ())- (const $ return ())- rq- - y' <- readIORef ref- assertEqual "bracketSnap/after" 2 y'--- expectSpecificException (ErrorCall "foo") $- run_ $ evalSnap (act2 ref)- (const $ return ())- (const $ return ())- rq- - y'' <- readIORef ref- assertEqual "bracketSnap/after" 3 y''-- where- act ref = bracketSnap (liftIO $ readIORef ref)- (\z -> liftIO $ writeIORef ref $! z+1)- (\z -> z `seq` mzero)-- act2 ref = bracketSnap (liftIO $ readIORef ref)- (\z -> liftIO $ writeIORef ref $! z+1)- (\z -> z `seq` liftIO $ throwIO $ ErrorCall "foo")---testCatchFinishWith :: Test-testCatchFinishWith = testCase "types/catchFinishWith" $ do- rq <- mkZomgRq- x <- run_ $ evalSnap (catchFinishWith $ finishWith emptyResponse)- (const $ return ())- (const $ return ())- rq- assertBool "catchFinishWith" $ isLeft x- y <- run_ $ evalSnap (catchFinishWith $ return ())- (const $ return ())- (const $ return ())- rq- assertBool "catchFinishWith" $ isRight y---testRqBody :: Test-testRqBody = testCase "types/requestBodies" $ do- mvar1 <- newEmptyMVar- mvar2 <- newEmptyMVar-- _ <- goBody $ f mvar1 mvar2-- v1 <- takeMVar mvar1- v2 <- takeMVar mvar2-- assertEqual "rq body" "zazzle" v1- assertEqual "rq body 2" "" v2-- (_,rsp) <- goBody g- bd <- getBody rsp-- assertEqual "detached rq body" "zazzle" bd--- where- f mvar1 mvar2 = do- getRequestBody >>= liftIO . putMVar mvar1- getRequestBody >>= liftIO . putMVar mvar2-- g = transformRequestBody returnI---testRqBodyException :: Test-testRqBodyException = testCase "types/requestBodyException" $ do- (req,resp) <- goEnum (enumList 1 ["the", "quick", "brown", "fox"]) hndlr- bd <- getBody resp-- (SomeEnumerator e) <- readIORef $ rqBody req- b' <- liftM (S.concat) $ run_ $ e $$ consume- assertEqual "request body was consumed" "" b'- assertEqual "response body was produced" "OK" bd-- where- h0 = runRequestBody $ do- _ <- I.head- throw $ ErrorCall "foo"-- hndlr = h0 `catch` \(_::SomeException) -> writeBS "OK"---testRqBodyTermination :: Test-testRqBodyTermination =- testCase "types/requestBodyTermination" $- expectException $- goEnum (enumList 1 ["the", "quick", "brown", "fox"]) hndlr-- where- h0 = runRequestBody $ do- _ <- I.head- terminateConnection $ ErrorCall "foo"-- hndlr = h0 `catch` \(_::SomeException) -> writeBS "OK"----testTrivials :: Test-testTrivials = testCase "types/trivials" $ do- (rq,rsp) <- go $ do- req <- getRequest- putRequest $ req { rqIsSecure=True }- putResponse $ setResponseStatus 333 "333" sampleResponse- r <- getResponse- liftIO $ assertEqual "rsp status" 333 $ rspStatus r- !_ <- localRequest (\x -> x {rqIsSecure=False}) $ do- q <- getRequest- liftIO $ assertEqual "localrq" False $ rqIsSecure q- return ()-- logError "foo"- writeText "zzz"- writeLazyText "zzz"-- let req' = updateContextPath 0 req- let cp1 = rqContextPath req- let cp2 = rqContextPath req'-- liftIO $ assertEqual "updateContextPath 0" cp1 cp2-- withRequest $ return . (`seq` ())- withResponse $ return . (`seq` ())-- return ()-- b <- getBody rsp- coverShowInstance b- coverShowInstance $ NoHandlerException ""- coverShowInstance GET- coverReadInstance GET- coverEqInstance GET- coverEqInstance $ NoHandlerException ""- coverOrdInstance GET-- Prelude.map (\(x,y) -> (x,show y)) (IM.toList statusReasonMap)- `deepseq` return ()-- let cookie = Cookie "" "" Nothing Nothing Nothing- coverEqInstance cookie- coverShowInstance cookie-- assertEqual "rq secure" True $ rqIsSecure rq- assertEqual "rsp status" 333 $ rspStatus rsp---testMethod :: Test-testMethod = testCase "types/method" $ do- expect404 $ go (method POST $ return ())- expectNo404 $ go (method GET $ return ())--testMethods :: Test-testMethods = testCase "types/methods" $ do- expect404 $ go (methods [POST,PUT] $ return ())- expectNo404 $ go (methods [GET] $ return ())- expectNo404 $ go (methods [POST,GET] $ return ())- expectNo404 $ go (methods [PUT,GET] $ return ())- expectNo404 $ go (methods [GET,PUT,DELETE] $ return ())---testDir :: Test-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 ())- expectNo404 $ goPath "foo/bar" (path "foo/bar" $ return ())- expect404 $ goPath "foo/bar/z" (path "foo/bar" $ return ())- expectNo404 $ goPath "" (ifTop $ return ())- expect404 $ goPath "a" (ifTop $ return ())---testParam :: Test-testParam = testCase "types/getParam" $ do- expect404 $ goPath "/foo" f- expectNo404 $ goPathQuery "/foo" "param" ["foo"] f- where- f = do- mp <- getParam "param"- maybe pass- (\s -> if s == "foo" then return () else pass)- mp---getBody :: Response -> IO L.ByteString-getBody r = do- let benum = rspBodyToEnum $ rspBody r- liftM (toLazyByteString . mconcat) (runIteratee consume >>= run_ . benum)---testWrites :: Test-testWrites = testCase "types/writes" $ do- (_,r) <- go h- b <- getBody r- assertEqual "output functions" "Foo1Foo2Foo3" b- where- h :: Snap ()- h = do- addToOutput $ enumBuilder $ fromByteString "Foo1"- writeBS "Foo2"- writeLBS "Foo3"---testURLEncode1 :: Test-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 "types/urlEncoding2" prop- where- prop s = (urlDecode $ urlEncode s) == Just s---testDir2 :: Test-testDir2 = testCase "types/dir2" $ do- (_,resp) <- goPath "foo/bar" f- b <- getBody resp- assertEqual "context path" "/foo/bar/" b-- where- f = dir "foo" $ dir "bar" $ do- p <- liftM rqContextPath getRequest- addToOutput $ enumBuilder $ fromByteString p---testIpHeaderFilter :: Test-testIpHeaderFilter = testCase "types/ipHeaderFilter" $ do- (_,r) <- goIP f- b <- getBody r- assertEqual "ipHeaderFilter" "1.2.3.4" b--- (_,r2) <- go f- b2 <- getBody r2- assertEqual "ipHeaderFilter" "127.0.0.1" b2-- where- f = do- ipHeaderFilter- ip <- liftM rqRemoteAddr getRequest- writeBS ip---testMZero404 :: Test-testMZero404 = testCase "types/mzero404" $ do- (_,r) <- go mzero- let l = rspContentLength r- b <- getBody r- assertEqual "mzero 404" "404" b- assertEqual "mzero 404 length" (Just 3) l---testEvalSnap :: Test-testEvalSnap = testCase "types/evalSnap-exception" $ do- rq <- mkZomgRq- expectException (run_ $ evalSnap f- (const $ return ())- (const $ return ())- rq >> return ())- where- f = do- logError "zzz"- v <- withResponse (return . rspHttpVersion)- liftIO $ assertEqual "evalSnap rsp version" (1,1) v- finishWith emptyResponse---testLocalRequest :: Test-testLocalRequest = testCase "types/localRequest" $ do- rq1 <- mkZomgRq- rq2 <- mkRequest "zzz/zz/z"-- let h = localRequest (const rq2) mzero-- (rq',_) <- go (h <|> return ())-- let u1 = rqURI rq1- let u2 = rqURI rq'-- assertEqual "localRequest backtrack" u1 u2----testRedirect :: Test-testRedirect = testCase "types/redirect" $ do- (_,rsp) <- go (redirect "/foo/bar")-- b <- getBody rsp- assertEqual "no response body" "" b- assertEqual "response content length" (Just 0) $ rspContentLength rsp- assertEqual "redirect path" (Just "/foo/bar") $ getHeader "Location" rsp- assertEqual "redirect status" 302 $ rspStatus rsp- assertEqual "status description" "Found" $ rspStatusReason rsp--- (_,rsp2) <- go (redirect' "/bar/foo" 307)-- assertEqual "redirect path" (Just "/bar/foo") $ getHeader "Location" rsp2- assertEqual "redirect status" 307 $ rspStatus rsp2- assertEqual "status description" "Temporary Redirect" $ rspStatusReason rsp2
test/suite/Snap/Util/FileServe/Tests.hs view
@@ -23,6 +23,7 @@ import Snap.Internal.Types import Snap.Util.FileServe import Snap.Iteratee+import qualified Snap.Types.Headers as H tests :: [Test] tests = [ testFooBin@@ -134,7 +135,7 @@ mkRequest :: ByteString -> IO Request mkRequest uri = do enum <- newIORef $ SomeEnumerator returnI- return $ Request "foo" 80 "foo" 999 "foo" 1000 "foo" False Map.empty+ return $ Request "foo" 80 "foo" 999 "foo" 1000 "foo" False H.empty enum Nothing GET (1,1) [] "" pathPart "/" (S.concat ["/",uri]) queryPart Map.empty
test/suite/Snap/Util/FileUploads/Tests.hs view
@@ -34,6 +34,7 @@ import Snap.Internal.Iteratee.Debug import Snap.Internal.Types import Snap.Iteratee hiding (map)+import qualified Snap.Types.Headers as H import Snap.Test.Common import Snap.Util.FileUploads @@ -44,7 +45,6 @@ instance Exception TestException - ------------------------------------------------------------------------------ tests :: [Test] tests = [ testSuccess1@@ -211,7 +211,7 @@ ------------------------------------------------------------------------------ testNoBoundary :: Test testNoBoundary = testCase "fileUploads/noBoundary" $- expectException $+ expectExceptionH $ harness' goBadContentType tmpdir hndl mixedTestBody where tmpdir = "tempdir_noboundary"@@ -227,7 +227,7 @@ ------------------------------------------------------------------------------ testNoMixedBoundary :: Test testNoMixedBoundary = testCase "fileUploads/noMixedBoundary" $- expectException $+ expectExceptionH $ harness' go tmpdir hndl badMixedBody where tmpdir = "tempdir_mixednoboundary"@@ -243,7 +243,7 @@ ------------------------------------------------------------------------------ testWrongContentType :: Test testWrongContentType = testCase "fileUploads/wrongContentType" $- expectException $+ expectExceptionH $ harness' goWrongContentType tmpdir hndl mixedTestBody where tmpdir = "tempdir_noboundary"@@ -363,9 +363,9 @@ mkRequest body = do enum <- newIORef $ SomeEnumerator $ enumBS body - let hdrs = Map.fromList [- ("Content-type", [S.append "multipart/form-data; boundary="- boundaryValue])+ let hdrs = H.fromList [+ ("Content-type", S.append "multipart/form-data; boundary="+ boundaryValue) ] return $ Request "foo" 80 "foo" 999 "foo" 1000 "foo" False hdrs@@ -378,9 +378,9 @@ mkDamagedRequest body = do enum <- newIORef $ SomeEnumerator $ enum - let hdrs = Map.fromList [- ("Content-type", [S.append "multipart/form-data; boundary="- boundaryValue])+ let hdrs = H.fromList [+ ("Content-type", S.append "multipart/form-data; boundary="+ boundaryValue) ] return $ Request "foo" 80 "foo" 999 "foo" 1000 "foo" False hdrs@@ -599,12 +599,3 @@ , boundaryValue , "--\r\n" ])----------------------------------------------------------------------------------expectException :: IO a -> IO ()-expectException m = do- e <- try m- case e of- Left (z::SomeException) -> (show z) `deepseq` return ()- Right _ -> assertFailure "expected exception, didn't get one"
test/suite/Snap/Util/GZip/Tests.hs view
@@ -26,11 +26,12 @@ import Test.Framework.Providers.HUnit import qualified Test.HUnit as H -import Snap.Types+import Snap.Core import Snap.Internal.Http.Types import Snap.Iteratee import Snap.Test.Common () import Snap.Util.GZip+import qualified Snap.Types.Headers as H stream2stream@@ -70,7 +71,7 @@ ------------------------------------------------------------------------------ gzipHdrs, xGzipHdrs, badHdrs, compressHdrs, xCompressHdrs, emptyHdrs :: Headers-emptyHdrs = Map.empty+emptyHdrs = H.empty gzipHdrs = setHeader "Accept-Encoding" "froz,gzip, x-gzip" emptyHdrs xGzipHdrs = setHeader "Accept-Encoding" "x-gzip;q=1.0" emptyHdrs badHdrs = setHeader "Accept-Encoding" "*&%^&^$%&%&*^\023" emptyHdrs
test/suite/TestSuite.hs view
@@ -2,13 +2,15 @@ import Test.Framework (defaultMain, testGroup) -import qualified Snap.Types.Tests+import qualified Snap.Core.Tests import qualified Snap.Internal.Http.Types.Tests+import qualified Snap.Internal.Parsing.Tests import qualified Snap.Internal.Routing.Tests import qualified Snap.Iteratee.Tests import qualified Snap.Util.FileServe.Tests import qualified Snap.Util.FileUploads.Tests import qualified Snap.Util.GZip.Tests+import qualified Snap.Test.Tests main :: IO ()@@ -18,14 +20,18 @@ Snap.Internal.Http.Types.Tests.tests , testGroup "Snap.Internal.Routing.Tests" Snap.Internal.Routing.Tests.tests- , testGroup "Snap.Types.Tests"- Snap.Types.Tests.tests+ , testGroup "Snap.Core.Tests"+ Snap.Core.Tests.tests , testGroup "Snap.Iteratee.Tests" Snap.Iteratee.Tests.tests+ , testGroup "Snap.Internal.Parsing.Tests"+ Snap.Internal.Parsing.Tests.tests , testGroup "Snap.Util.GZip.Tests" Snap.Util.GZip.Tests.tests , testGroup "Snap.Util.FileServe.Tests" Snap.Util.FileServe.Tests.tests , testGroup "Snap.Util.FileUploads.Tests" Snap.Util.FileUploads.Tests.tests+ , testGroup "Snap.Test.Tests"+ Snap.Test.Tests.tests ]