snap-core 0.3.0 → 0.3.1
raw patch · 11 files changed
+184/−97 lines, 11 filesdep ~basedep ~enumerator
Dependency ranges changed: base, enumerator
Files
- README.md +12/−7
- snap-core.cabal +2/−2
- src/Snap/Internal/Http/Types.hs +58/−13
- src/Snap/Internal/Iteratee/Debug.hs +4/−1
- src/Snap/Internal/Types.hs +7/−0
- src/Snap/Iteratee.hs +6/−15
- src/Snap/Types.hs +6/−0
- test/snap-core-testsuite.cabal +1/−1
- test/suite/Snap/Internal/Http/Types/Tests.hs +45/−13
- test/suite/Snap/Iteratee/Tests.hs +19/−20
- test/suite/Snap/Types/Tests.hs +24/−25
README.md view
@@ -1,12 +1,13 @@ Snap Framework Core =================== -This is the Snap Framework Core library. For more information about Snap, read-the `README.SNAP.md` or visit the Snap project website at-http://www.snapframework.com/.+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 web framework for Haskell, based on iteratee I/O (as [popularized by-Oleg Kiselyov](http://okmij.org/ftp/Streams.html#iteratee)).+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)). ## Library contents@@ -56,14 +57,18 @@ ## Building the testsuite -Snap-core has a fairly comprehensive testsuite. To build it, `cd` into the-`test/` directory and run+Snap is still in its very early stages, so most of the "action" (and a big+chunk of the code) right now is centred on the test suite. Snap aims for 100%+test coverage, and we're trying hard to stick to that. +To build the test suite, `cd` into the `test/` directory and run+ $ cabal configure $ cabal build From here you can invoke the testsuite by running: $ ./runTestsAndCoverage.sh + The testsuite generates an `hpc` test coverage report in `test/dist/hpc`.
snap-core.cabal view
@@ -1,5 +1,5 @@ name: snap-core-version: 0.3.0+version: 0.3.1 synopsis: Snap: A Haskell Web Framework (Core) description:@@ -149,7 +149,7 @@ deepseq >= 1.1 && <1.2, directory, dlist >= 0.5 && < 0.6,- enumerator > 0.4.2 && < 0.5,+ enumerator >= 0.4.5 && < 0.5, filepath, MonadCatchIO-transformers >= 0.2.1 && < 0.3, mtl == 2.0.*,
src/Snap/Internal/Http/Types.hs view
@@ -378,6 +378,7 @@ -- | Represents an HTTP response. data Response = Response { rspHeaders :: Headers+ , rspCookies :: Map ByteString Cookie , rspHttpVersion :: !HttpVersion -- | We will need to inspect the content length no matter what, and@@ -465,8 +466,8 @@ -- | An empty 'Response'. emptyResponse :: Response-emptyResponse = Response Map.empty (1,1) Nothing (Enum (I.enumBS "")) 200- "OK" False+emptyResponse = Response Map.empty Map.empty (1,1) Nothing (Enum (I.enumBS "")) + 200 "OK" False ------------------------------------------------------------------------------@@ -520,19 +521,63 @@ --------------------------------------------------------------------------------- | Adds an HTTP 'Cookie' to the 'Response' headers.-addCookie :: Cookie -- ^ cookie value- -> Response -- ^ response to modify+-- | addCookie has been deprecated and will be removed in 0.4. Please use+-- 'addResponseCookie' instead.+addCookie :: Cookie -- ^ cookie value + -> Response -- ^ response to modify -> Response-addCookie (Cookie k v mbExpTime mbDomain mbPath) = updateHeaders f+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' } where- f = Map.insertWith' (++) "Set-Cookie" [cookie]- cookie = S.concat [k, "=", v, path, exptime, domain]- path = maybe "" (S.append "; path=") mbPath- domain = maybe "" (S.append "; domain=") mbDomain- exptime = maybe "" (S.append "; expires=" . fmt) mbExpTime- fmt = fromStr .- formatTime defaultTimeLocale "%a, %d-%b-%Y %H:%M:%S GMT"+ cks'= Map.insert k ck $ rspCookies r+{-# INLINE addResponseCookie #-}+++------------------------------------------------------------------------------+-- | Gets an HTTP 'Cookie' with the given name from 'Response' headers.+getResponseCookie :: ByteString -- ^ cookie name+ -> Response -- ^ response to query+ -> Maybe Cookie+getResponseCookie cn r = Map.lookup cn $ rspCookies r+{-# INLINE getResponseCookie #-}+++-- | Returns a list of 'Cookie's present in 'Response'+getResponseCookies :: Response -- ^ response to query+ -> [Cookie]+getResponseCookies = Map.elems . rspCookies +{-# INLINE getResponseCookies #-}+++------------------------------------------------------------------------------+-- | Deletes an HTTP 'Cookie' from the 'Response' headers.+deleteResponseCookie :: ByteString -- ^ cookie name + -> Response -- ^ response to modify+ -> Response+deleteResponseCookie cn r = r { rspCookies = cks' }+ where+ cks'= Map.delete cn $ rspCookies r+{-# INLINE deleteResponseCookie #-}+++------------------------------------------------------------------------------+-- | Modifies an HTTP 'Cookie' with given name in 'Response' headers.+-- Nothing will happen if a matching 'Cookie' can not be found in 'Response'.+modifyResponseCookie :: ByteString -- ^ cookie name+ -> (Cookie -> Cookie) -- ^ modifier function+ -> Response -- ^ response to modify+ -> Response+modifyResponseCookie cn f r = maybe r modify $ getResponseCookie cn r+ where+ modify ck = addResponseCookie (f ck) r+{-# INLINE modifyResponseCookie #-} ------------------------------------------------------------------------------
src/Snap/Internal/Iteratee/Debug.hs view
@@ -75,7 +75,10 @@ #else -iterateeDebugWrapper :: String -> Iteratee IO a -> Iteratee IO a+iterateeDebugWrapper :: (Show a, MonadIO m) =>+ String+ -> Iteratee a m b+ -> Iteratee a m b iterateeDebugWrapper _ = id {-# INLINE iterateeDebugWrapper #-}
src/Snap/Internal/Types.hs view
@@ -727,6 +727,13 @@ ------------------------------------------------------------------------------+-- | See 'rqParams'. Convenience function to return 'Params' from the 'Request'+-- inside of a 'MonadSnap' instance.+getParams :: MonadSnap m => m Params+getParams = getRequest >>= return . rqParams +++------------------------------------------------------------------------------ -- | Gets the HTTP 'Cookie' with the specified name. getCookie :: MonadSnap m => ByteString
src/Snap/Iteratee.hs view
@@ -93,18 +93,8 @@ ------------------------------------------------------------------------------ -{---import Control.Exception (SomeException)-import "MonadCatchIO-transformers" Control.Monad.CatchIO-import qualified Data.DList as D-import Data.IORef-import Prelude hiding (catch,drop)---}- import Control.DeepSeq-import Control.Exception (SomeException, assert)+import Control.Exception (assert) import Control.Monad import "MonadCatchIO-transformers" Control.Monad.CatchIO import Control.Monad.Trans (MonadIO, lift, liftIO)@@ -112,9 +102,10 @@ import qualified Data.ByteString.Char8 as S import qualified Data.ByteString.Unsafe as S import qualified Data.ByteString.Lazy.Char8 as L-import Data.Enumerator hiding (drop)-import Data.Enumerator.IO (enumHandle)-import Data.List (foldl')+import Data.Enumerator hiding (consume, drop, head)+import Data.Enumerator.List hiding (take, drop)+import Data.Enumerator.Binary (enumHandle)+import qualified Data.List as List import Data.Monoid (mappend) import Data.Typeable import Foreign hiding (peek)@@ -149,7 +140,7 @@ ------------------------------------------------------------------------------ -- | Get the length of a bytestring Stream streamLength :: Stream ByteString -> Int-streamLength (Chunks xs) = foldl' (\c s -> c + S.length s) 0 xs+streamLength (Chunks xs) = List.foldl' (\c s -> c + S.length s) 0 xs streamLength EOF = 0
src/Snap/Types.hs view
@@ -83,6 +83,7 @@ , rqParams , rqParam , getParam+ , getParams , rqModifyParams , rqSetParam @@ -94,6 +95,11 @@ , rspStatusReason , setContentType , addCookie+ , addResponseCookie+ , getResponseCookie+ , getResponseCookies+ , deleteResponseCookie+ , modifyResponseCookie , getCookie , setContentLength , clearContentLength
test/snap-core-testsuite.cabal view
@@ -35,7 +35,7 @@ HUnit >= 1.2 && < 2, enumerator == 0.4.*, MonadCatchIO-transformers >= 0.2 && < 0.3,- monads-fd <0.2,+ mtl == 2.*, old-locale, old-time, parallel >= 2.2 && <2.3,
test/suite/Snap/Internal/Http/Types/Tests.hs view
@@ -25,6 +25,7 @@ tests :: [Test] tests = [ testTypes+ , testCookies , testUrlDecode , testFormatLogTime , testAddHeader ]@@ -84,12 +85,7 @@ 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 "cookie" (Just ["foo=bar; path=/; expires=Sat, 30-Jan-2010 00:00:00 GMT; domain=.foo.com"]) cookieHeader - assertEqual "cookie2" (Just ["foo=bar; path=/; expires=Sat, 30-Jan-2010 00:00:00 GMT; domain=.foo.com", "foo=baz; path=/; expires=Sat, 30-Jan-2010 00:00:00 GMT; domain=.foo.com"]) (liftM sort cookieHeader2)-- assertEqual "cookie3" (Just ["foo=baz"]) cookieHeader3- assertEqual "response status" 555 $ rspStatus resp assertEqual "response status reason" "bogus" $ rspStatusReason resp assertEqual "content-length" (Just 4) $ rspContentLength resp@@ -108,7 +104,7 @@ return () where- resp = addCookie cook $+ resp = addResponseCookie cook $ setContentLength 4 $ modifyResponseBody id $ setResponseBody (enumBS "PING") $@@ -117,16 +113,52 @@ emptyResponse !b = show resp `using` rdeepseq - resp2 = addCookie cook2 resp- resp3 = addCookie cook3 emptyResponse+ 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 "/") ++testCookies :: Test+testCookies = testCase "cookies" $ do+ assertEqual "cookie" (Just cook) rCook+ assertEqual "cookie2" (Just cook2) rCook2+ assertEqual "cookie3" (Just cook3) rCook3+ assertEqual "empty response cookie3" (Just cook3) rCook3e+ assertEqual "removed cookie" Nothing nilCook+ assertEqual "multiple cookies" [cook, cook2] cks+ assertEqual "cookie modification" (Just cook3) rCook3Mod++ return ()++ where+ resp = addResponseCookie cook $+ setContentType "text/plain" $+ emptyResponse++ f _ = cook3++ resp' = deleteResponseCookie "foo" resp+ resp'' = modifyResponseCookie "foo" f resp+ resp2 = addResponseCookie cook2 resp+ resp3 = addResponseCookie cook3 resp2+ resp4 = addResponseCookie cook3 emptyResponse+ utc = UTCTime (ModifiedJulianDay 55226) 0 cook = Cookie "foo" "bar" (Just utc) (Just ".foo.com") (Just "/")- cook2 = Cookie "foo" "baz" (Just utc) (Just ".foo.com") (Just "/")- cook3 = Cookie "foo" "baz" Nothing Nothing Nothing+ cook2 = Cookie "zoo" "baz" (Just utc) (Just ".foo.com") (Just "/")+ cook3 = Cookie "boo" "baz" Nothing Nothing Nothing - cookieHeader = Map.lookup "Set-Cookie" $ headers resp- cookieHeader2 = Map.lookup "Set-Cookie" $ headers resp2- cookieHeader3 = Map.lookup "Set-Cookie" $ headers resp3+ rCook = getResponseCookie "foo" resp+ nilCook = getResponseCookie "foo" resp'+ rCook2 = getResponseCookie "zoo" resp2+ rCook3 = getResponseCookie "boo" resp3+ rCook3e = getResponseCookie "boo" resp4+ rCook3Mod = getResponseCookie "boo" resp''++ cks = getResponseCookies resp2+++
test/suite/Snap/Iteratee/Tests.hs view
@@ -1,32 +1,31 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE PackageImports #-} {-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Snap.Iteratee.Tests ( tests ) where -import qualified Control.Exception as E-import Control.Exception hiding (try, assert)-import Control.Monad-import "monads-fd" Control.Monad.Identity-import Data.ByteString (ByteString)-import qualified Data.ByteString as S-import qualified Data.ByteString.Lazy.Char8 as L-import Data.Int-import Data.Maybe-import Prelude hiding (head, drop, take)-import Test.Framework-import Test.Framework.Providers.QuickCheck2-import Test.QuickCheck-import qualified Test.QuickCheck.Monadic as QC-import Test.QuickCheck.Monadic hiding (run)-import Test.Framework.Providers.HUnit-import qualified Test.HUnit as H+import qualified Control.Exception as E+import Control.Exception hiding (try, assert)+import Control.Monad+import Control.Monad.Identity+import Data.ByteString (ByteString)+import qualified Data.ByteString as S+import qualified Data.ByteString.Lazy.Char8 as L+import Data.Int+import Data.Maybe+import Prelude hiding (head, drop, take)+import Test.Framework+import Test.Framework.Providers.QuickCheck2+import Test.QuickCheck+import qualified Test.QuickCheck.Monadic as QC+import Test.QuickCheck.Monadic hiding (run)+import Test.Framework.Providers.HUnit+import qualified Test.HUnit as H -import Snap.Iteratee-import Snap.Test.Common ()+import Snap.Iteratee+import Snap.Test.Common () import Snap.Internal.Iteratee.Debug
test/suite/Snap/Types/Tests.hs view
@@ -1,35 +1,34 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE PackageImports #-} {-# LANGUAGE ScopedTypeVariables #-} module Snap.Types.Tests ( tests ) where -import Control.Applicative-import Control.Concurrent.MVar-import Control.Exception (SomeException)-import Control.Monad-import Control.Monad.CatchIO-import "monads-fd" Control.Monad.Trans (liftIO)-import Control.Parallel.Strategies-import Data.ByteString.Char8 (ByteString)-import qualified Data.ByteString.Char8 as S-import qualified Data.ByteString.Lazy.Char8 as L-import Data.IORef-import Data.Text ()-import Data.Text.Lazy ()-import qualified Data.Map as Map-import Prelude hiding (catch)-import Test.Framework-import Test.Framework.Providers.HUnit-import Test.Framework.Providers.QuickCheck2-import Test.HUnit hiding (Test, path)- -import Snap.Internal.Types-import Snap.Internal.Http.Types-import Snap.Iteratee-import Snap.Test.Common ()+import Control.Applicative+import Control.Concurrent.MVar+import Control.Exception (SomeException)+import Control.Monad+import Control.Monad.CatchIO+import Control.Monad.Trans (liftIO)+import Control.Parallel.Strategies+import Data.ByteString.Char8 (ByteString)+import qualified Data.ByteString.Char8 as S+import qualified Data.ByteString.Lazy.Char8 as L+import Data.IORef+import Data.Text ()+import Data.Text.Lazy ()+import qualified Data.Map as Map+import Prelude hiding (catch)+import Test.Framework+import Test.Framework.Providers.HUnit+import Test.Framework.Providers.QuickCheck2+import Test.HUnit hiding (Test, path)+ +import Snap.Internal.Types+import Snap.Internal.Http.Types+import Snap.Iteratee+import Snap.Test.Common () tests :: [Test]