Merge branch 'master' into escape-http

Conflicts:
	CONTRIBUTORS
	src/Snap/Internal/Types.hs

CONTRIBUTORS

@@ -6,4 +6,5 @@ Shane O'Brien <shane@duairc.com>
 James Sanders <jimmyjazz14@gmail.com>
 Jacob Stanley <jystic@jystic.com>
 Jonas Kramer <jkramer@nex.scrapping.cc>
+Jurriën Stutterheim <j.stutterheim@me.com>
 Jasper Van der Jeugt <m@jaspervdj.be>

README.SNAP.md

@@ -16,11 +16,11 @@ The Snap core system consists of:
 
   * 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

@@ -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

@@ -161,6 +161,7 @@ Library
     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

@@ -48,6 +48,7 @@ module Snap.Core
     -- ** Grabbing/transforming request bodies
   , runRequestBody
   , getRequestBody
+  , readRequestBody
   , transformRequestBody
 
     -- * HTTP Datatypes and Functions

src/Snap/Internal/Http/Types.hs

@@ -23,7 +23,6 @@ import           Data.ByteString (ByteString)
 import qualified Data.ByteString.Char8 as B
 import           Data.ByteString.Internal (c2w,w2c)
 import qualified Data.ByteString as S
-import           Data.Char
 import           Data.Int
 import qualified Data.IntMap as IM
 import           Data.IORef
@@ -253,11 +252,11 @@ data Request = Request
       -- 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.
@@ -424,7 +423,7 @@ instance Show Response where
 
       statusline = concat [ "HTTP/"
                           , show v1
-                          , "." 
+                          , "."
                           , show v2
                           , " "
                           , show $ rspStatus r

src/Snap/Internal/Iteratee/BoyerMooreHorspool.hs

@@ -127,7 +127,8 @@ bmhEnumeratee needle _step = do
                   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 @@ bmhEnumeratee needle _step = do
         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/Test/Assertions.hs

@@ -39,9 +39,9 @@ assert404 rsp = assertEqual message 404 status
 
 
 ------------------------------------------------------------------------------
--- | 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.
+-- | 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
@@ -58,8 +58,8 @@ assertRedirectTo uri rsp = do
 
 
 ------------------------------------------------------------------------------
--- | Given a Response, asserts that its HTTP status code is between 300 and 399
--- (a redirect).
+-- | 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
@@ -71,7 +71,7 @@ assertRedirect rsp = assertBool message (300 <= status && status <= 399)
 ------------------------------------------------------------------------------
 -- | Given a Response, asserts that its body matches the given regular
 -- expression.
-assertBodyContains :: ByteString   -- ^ Regexp that will match the body content
+assertBodyContains :: ByteString  -- ^ Regexp that will match the body content
                    -> Response
                    -> Assertion
 assertBodyContains match rsp = do

src/Snap/Internal/Test/RequestBuilder.hs

@@ -105,7 +105,8 @@ buildRequest mm = do
 
     fixupMethod = do
         rq <- rGet
-        if (rqMethod rq == GET || rqMethod rq == DELETE || rqMethod rq == HEAD)
+        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
@@ -116,7 +117,8 @@ buildRequest mm = do
     fixupCL = do
         rq <- rGet
         maybe (rPut $ deleteHeader "Content-Length" rq)
-              (\cl -> rPut $ H.setHeader "Content-Length" (S.pack (show cl)) rq)
+              (\cl -> rPut $ H.setHeader "Content-Length"
+                                         (S.pack (show cl)) rq)
               (rqContentLength rq)
 
     fixupParams = do
@@ -134,7 +136,7 @@ buildRequest mm = do
 
         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.
@@ -160,10 +162,10 @@ data FileData = FileData {
 
 
 ------------------------------------------------------------------------------
--- | 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.
+-- | 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
@@ -357,9 +359,9 @@ fixupURI = do
 
 
 ------------------------------------------------------------------------------
--- | 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.
+-- | 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
@@ -408,8 +410,8 @@ 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'.
+-- 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
@@ -499,11 +501,11 @@ postRaw uri contentType postData = do
 -- 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
+            -- ^ a function defining how the 'MonadSnap' monad should be run
             -> RequestBuilder m ()
-               -- ^ a request builder
+            -- ^ a request builder
             -> n b
-               -- ^ a web handler
+            -- ^ a web handler
             -> m Response
 runHandler' rSnap rBuilder snap = do
     rq  <- buildRequest rBuilder
@@ -513,8 +515,8 @@ runHandler' rSnap rBuilder snap = do
 
 
 ------------------------------------------------------------------------------
--- | Given a web handler in the 'Snap' monad, and a 'RequestBuilder' defining a
--- test request, runs the handler, producing an HTTP 'Response'.
+-- | 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

src/Snap/Internal/Types.hs

@@ -339,8 +339,8 @@ getRequestBody = liftM L.fromChunks $ runRequestBody consume
 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'.
+                          -- received, a 'TooManyBytesReadException' is
+                          -- thrown. See 'takeNoMoreThan'.
                 -> m L.ByteString
 readRequestBody sz = liftM L.fromChunks $ runRequestBody $
                      joinI $ takeNoMoreThan sz $$ consume
@@ -509,7 +509,7 @@ pathArg f = do
     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.
@@ -853,7 +853,8 @@ uncatchableExceptionFromException e = do
 
 
 ------------------------------------------------------------------------------
-data ConnectionTerminatedException = ConnectionTerminatedException SomeException
+data ConnectionTerminatedException =
+    ConnectionTerminatedException SomeException
   deriving (Typeable)
 
 
@@ -999,15 +1000,16 @@ readCookie name = maybe pass (fromBS . cookieValue) =<< getCookie name
 
 ------------------------------------------------------------------------------
 -- | Expire the given 'Cookie' in client's browser.
-expireCookie :: (MonadSnap m) 
-             => ByteString 
+expireCookie :: (MonadSnap m)
+             => ByteString
              -- ^ Cookie name
-             -> Maybe ByteString 
+             -> 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)
+  modifyResponse $ addResponseCookie
+                 $ Cookie nm "" (Just old) Nothing dm False False
 
 
 ------------------------------------------------------------------------------

src/Snap/Iteratee.hs

@@ -684,10 +684,11 @@ enumBuilderToByteString :: MonadIO m => Enumeratee Builder ByteString m a
 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

@@ -1,6 +1,6 @@
 -- | The Snap.Test module contains primitives and combinators for testing Snap
 -- applications.
-module Snap.Test 
+module Snap.Test
   ( -- * Combinators and types for testing Snap handlers.
 
     -- ** Types
@@ -52,4 +52,4 @@ module Snap.Test
 import           Snap.Internal.Test.Assertions
 import           Snap.Internal.Test.RequestBuilder
 
-  
+

src/Snap/Types/Headers.hs

@@ -43,14 +43,16 @@ module Snap.Types.Headers
 import           Data.ByteString.Char8 (ByteString)
 import           Data.CaseInsensitive   (CI)
 import           Data.List (foldl')
-import           Data.Map (Map)
-import qualified Data.Map as Map
+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 :: Map (CI ByteString) [ByteString] }
+newtype Headers = H { unH :: HashMap (CI ByteString) [ByteString] }
   deriving (Show)
 
+
 ------------------------------------------------------------------------------
 empty :: Headers
 empty = H (Map.empty)
@@ -64,7 +66,9 @@ null = Map.null . unH
 
 ------------------------------------------------------------------------------
 member :: CI ByteString -> Headers -> Bool
-member k = Map.member k . unH
+member k = f . unH
+  where
+    f m = isJust $ Map.lookup k m
 {-# INLINE member #-}
 
 
@@ -76,12 +80,12 @@ lookup k (H m) = Map.lookup k m
 
 ------------------------------------------------------------------------------
 lookupWithDefault :: ByteString -> CI ByteString -> Headers -> [ByteString]
-lookupWithDefault d k (H m) = Map.findWithDefault [d] k m
+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
+insert k v (H m) = H $ Map.insertWith (flip (++)) k [v] m
 
 
 ------------------------------------------------------------------------------
@@ -99,12 +103,12 @@ fold :: (a -> CI ByteString -> [ByteString] -> a)
      -> a
      -> Headers
      -> a
-fold f a (H m) = Map.foldlWithKey f a m
+fold f a (H m) = Map.foldlWithKey' f a m
 
 
 ------------------------------------------------------------------------------
 toList :: Headers -> [(CI ByteString, ByteString)]
-toList (H m) = (Map.foldlWithKey f id m) []
+toList (H m) = (Map.foldlWithKey' f id m) []
   where
     f !dl k vs = dl . ((map (\v -> (k,v)) vs) ++)
 

src/Snap/Util/FileServe.hs

@@ -265,7 +265,8 @@ snapIndexStyles =
         ,     "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; }"