Skip to content
Browse files

Merge branch 'master' into escape-http

Conflicts:
	CONTRIBUTORS
	src/Snap/Internal/Types.hs
  • Loading branch information...
2 parents 9939580 + a097294 commit d4d55dd79444d74874fc3192ff44e839a82c0e95 @jaspervdj jaspervdj committed Oct 28, 2011
View
1 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>
View
10 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.
View
12 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
View
1 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
View
1 src/Snap/Core.hs
@@ -48,6 +48,7 @@ module Snap.Core
-- ** Grabbing/transforming request bodies
, runRequestBody
, getRequestBody
+ , readRequestBody
, transformRequestBody
-- * HTTP Datatypes and Functions
View
13 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
View
5 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
View
12 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
View
36 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
View
18 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
------------------------------------------------------------------------------
View
5 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
View
4 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
-
+
View
20 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) ++)
View
3 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; }"
View
2 src/Snap/Util/GZip.hs
@@ -11,13 +11,11 @@ module Snap.Util.GZip
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
View
1 test/snap-core-testsuite.cabal
@@ -55,6 +55,7 @@ Executable testsuite
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

0 comments on commit d4d55dd

Please sign in to comment.
Something went wrong with that request. Please try again.