snap-core 0.2.9 → 0.2.10
raw patch · 9 files changed
+162/−45 lines, 9 filesdep ~attoparsecnew-uploader
Dependency ranges changed: attoparsec
Files
- CONTRIBUTORS +1/−0
- snap-core.cabal +2/−2
- src/Snap/Internal/Http/Types.hs +61/−1
- src/Snap/Internal/Types.hs +24/−0
- src/Snap/Iteratee.hs +50/−39
- src/Snap/Types.hs +3/−0
- src/Snap/Util/GZip.hs +2/−1
- test/snap-core-testsuite.cabal +1/−1
- test/suite/Snap/Types/Tests.hs +18/−1
CONTRIBUTORS view
@@ -5,3 +5,4 @@ Shane O'Brien <shane@duairc.com> James Sanders <jimmyjazz14@gmail.com> Jacob Stanley <jystic@jystic.com>+Jonas Kramer <jkramer@nex.scrapping.cc>
snap-core.cabal view
@@ -1,5 +1,5 @@ name: snap-core-version: 0.2.9+version: 0.2.10 synopsis: Snap: A Haskell Web Framework (Core) description:@@ -184,7 +184,7 @@ other-modules: Snap.StarterTH build-depends:- attoparsec >= 0.8.0.2 && < 0.9,+ attoparsec >= 0.8.1 && < 0.9, base >= 4 && < 5, bytestring, bytestring-nums,
src/Snap/Internal/Http/Types.hs view
@@ -31,10 +31,12 @@ import Data.DList (DList) import qualified Data.DList as DL import Data.Int+import qualified Data.IntMap as IM import Data.IORef import Data.List hiding (take) import Data.Map (Map) import qualified Data.Map as Map+import Data.Maybe import Data.Monoid import Data.Serialize.Builder import Data.Time.Clock@@ -459,7 +461,9 @@ --------------------------------------------------------------------------------- | Sets the HTTP response status.+-- | Sets the HTTP response status. Note: normally you would use+-- 'setResponseCode' unless you needed a custom response explanation.+-- setResponseStatus :: Int -- ^ HTTP response integer code -> ByteString -- ^ HTTP response explanation -> Response -- ^ Response to be modified@@ -469,6 +473,17 @@ ------------------------------------------------------------------------------+-- | Sets the HTTP response code.+setResponseCode :: Int -- ^ HTTP response integer code+ -> Response -- ^ Response to be modified+ -> Response+setResponseCode s r = setResponseStatus s reason r+ where+ reason = fromMaybe "Unknown" (IM.lookup s statusReasonMap)+{-# INLINE setResponseCode #-}+++------------------------------------------------------------------------------ -- | Modifies a response body. modifyResponseBody :: (forall a . Enumerator a -> Enumerator a) -> Response@@ -692,3 +707,48 @@ toStr :: ByteString -> String toStr = map w2c . S.unpack ++------------------------------------------------------------------------------+statusReasonMap :: IM.IntMap ByteString+statusReasonMap = IM.fromList [+ (100, "Continue"),+ (101, "Switching Protocols"),+ (200, "OK"),+ (201, "Created"),+ (202, "Accepted"),+ (203, "Non-Authoritative Information"),+ (204, "No Content"),+ (205, "Reset Content"),+ (206, "Partial Content"),+ (300, "Multiple Choices"),+ (301, "Moved Permanently"),+ (302, "Found"),+ (303, "See Other"),+ (304, "Not Modified"),+ (305, "Use Proxy"),+ (307, "Temporary Redirect"),+ (400, "Bad Request"),+ (401, "Unauthorized"),+ (402, "Payment Required"),+ (403, "Forbidden"),+ (404, "Not Found"),+ (405, "Method Not Allowed"),+ (406, "Not Acceptable"),+ (407, "Proxy Authentication Required"),+ (408, "Request Time-out"),+ (409, "Conflict"),+ (410, "Gone"),+ (411, "Length Required"),+ (412, "Precondition Failed"),+ (413, "Request Entity Too Large"),+ (414, "Request-URI Too Large"),+ (415, "Unsupported Media Type"),+ (416, "Requested range not satisfiable"),+ (417, "Expectation Failed"),+ (500, "Internal Server Error"),+ (501, "Not Implemented"),+ (502, "Bad Gateway"),+ (503, "Service Unavailable"),+ (504, "Gateway Time-out"),+ (505, "HTTP Version not supported")+ ]
src/Snap/Internal/Types.hs view
@@ -369,6 +369,30 @@ ------------------------------------------------------------------------------+-- | Performs a redirect by setting the @Location@ header to the given target+-- URL/path and the status code to 302 in the 'Response' object stored in a+-- 'Snap' monad. Note that the target URL is not validated in any way. Consider+-- using 'redirect\'' instead, which allows you to choose the correct status+-- code.+redirect :: ByteString -> Snap ()+redirect target = redirect' target 302+{-# INLINE redirect #-}+++------------------------------------------------------------------------------+-- | Performs a redirect by setting the @Location@ header to the given target+-- URL/path and the status code (should be one of 301, 302, 303 or 307) in the+-- 'Response' object stored in a 'Snap' monad. Note that the target URL is not+-- validated in any way.+redirect' :: ByteString -> Int -> Snap ()+redirect' target status =+ finishWith+ $ setResponseCode status+ $ setHeader "Location" target emptyResponse+{-# INLINE redirect' #-}+++------------------------------------------------------------------------------ -- | Log an error message in the 'Snap' monad logError :: ByteString -> Snap () logError s = Snap $ gets _snapLogError >>= (\l -> liftIO $ l s)
src/Snap/Iteratee.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PackageImports #-} {-# LANGUAGE TypeSynonymInstances #-} -- | Snap Framework type aliases and utilities for iteratees. Note that as a@@ -44,34 +45,33 @@ ) where -------------------------------------------------------------------------------import Control.Monad-import Control.Monad.CatchIO-import Data.ByteString (ByteString)-import qualified Data.ByteString as S-import qualified Data.ByteString.Unsafe as S-import qualified Data.ByteString.Lazy as L-import Data.Int-import Data.IORef-import Data.Iteratee-#ifdef PORTABLE-import Data.Iteratee.IO (enumHandle)-#endif-import qualified Data.Iteratee.Base.StreamChunk as SC-import Data.Iteratee.WrappedByteString-import qualified Data.ListLike as LL-import Data.Monoid (mappend)-import Foreign-import Foreign.C.Types-import GHC.ForeignPtr-import Prelude hiding (catch,drop)-import qualified Data.DList as D+import Control.Monad+import Control.Monad.CatchIO+import Data.ByteString (ByteString)+import qualified Data.ByteString as S+import qualified Data.ByteString.Unsafe as S+import qualified Data.ByteString.Lazy as L+import qualified Data.DList as D+import Data.Int+import Data.IORef+import Data.Iteratee+import Data.Iteratee.IO (enumHandle)+import qualified Data.Iteratee.Base.StreamChunk as SC+import Data.Iteratee.WrappedByteString+import qualified Data.ListLike as LL+import Data.Monoid (mappend)+import Foreign+import Foreign.C.Types+import GHC.ForeignPtr+import Prelude hiding (catch,drop)+import System.IO+import "monads-fd" Control.Monad.Trans (liftIO) -#ifdef PORTABLE-import Control.Monad.Trans (liftIO)-import System.IO-#else+#ifndef PORTABLE import Control.Exception (SomeException) import System.IO.Posix.MMap+import System.PosixCompat.Files+import System.Posix.Types #endif ------------------------------------------------------------------------------@@ -312,7 +312,7 @@ enumLBS :: (Monad m) => L.ByteString -> Enumerator m a enumLBS lbs = el chunks where- el [] i = liftM liftI $ runIter i (EOF Nothing)+ el [] i = return i el (x:xs) i = do i' <- liftM liftI $ runIter i (Chunk $ WrapBS x) el xs i'@@ -427,27 +427,38 @@ ------------------------------------------------------------------------------+_enumFile :: FilePath -> Iteratee IO a -> IO (Iteratee IO a)+_enumFile fp iter = do+ h <- liftIO $ openBinaryFile fp ReadMode+ i' <- enumHandle h iter+ return (i' `finally` liftIO (hClose h))++ enumFile :: FilePath -> Iteratee IO a -> IO (Iteratee IO a) #ifdef PORTABLE -enumFile fp iter = do- h <- liftIO $ openBinaryFile fp ReadMode- i' <- enumHandle h iter- return $ do- x <- i'- liftIO (hClose h)- return x+enumFile = _enumFile #else +-- 40MB limit+maxMMapFileSize :: FileOffset+maxMMapFileSize = 41943040+ enumFile fp iter = do- es <- (try $- liftM WrapBS $- unsafeMMapFile fp) :: IO (Either SomeException (WrappedByteString Word8))+ -- for small files we'll use mmap to save ourselves a copy, otherwise we'll+ -- stream it+ stat <- getFileStatus fp+ if fileSize stat > maxMMapFileSize+ then _enumFile fp iter+ else do+ es <- (try $+ liftM WrapBS $+ unsafeMMapFile fp) :: IO (Either SomeException (WrappedByteString Word8)) - case es of- (Left e) -> return $ throwErr $ Err $ "IO error" ++ show e- (Right s) -> liftM liftI $ runIter iter $ Chunk s+ case es of+ (Left e) -> return $ throwErr $ Err $ "IO error" ++ show e+ (Right s) -> liftM liftI $ runIter iter $ Chunk s #endif
src/Snap/Types.hs view
@@ -84,6 +84,7 @@ -- ** Responses , emptyResponse+ , setResponseCode , setResponseStatus , rspStatus , rspStatusReason@@ -91,6 +92,8 @@ , addCookie , setContentLength , clearContentLength+ , redirect+ , redirect' -- *** Response I/O , setResponseBody
src/Snap/Util/GZip.hs view
@@ -242,7 +242,8 @@ let output = L.toChunks $ compFunc bs let runIt = do- mapM_ (writeChan writeEnd . toChunk) output+ --Prelude specified to work with iteratee-0.3.6+ Prelude.mapM_ (writeChan writeEnd . toChunk) output writeChan writeEnd $ EOF Nothing runIt `catch` \(e::SomeException) ->
test/snap-core-testsuite.cabal view
@@ -36,7 +36,7 @@ build-depends: QuickCheck >= 2,- attoparsec >= 0.8.0.2 && < 0.9,+ attoparsec >= 0.8.1 && < 0.9, base >= 4 && < 5, bytestring, bytestring-nums,
test/suite/Snap/Types/Tests.hs view
@@ -49,7 +49,8 @@ , testIpHeaderFilter , testMZero404 , testEvalSnap- , testLocalRequest ]+ , testLocalRequest+ , testRedirect ] expectException :: IO () -> IO ()@@ -404,3 +405,19 @@ assertEqual "localRequest backtrack" u1 u2 +++testRedirect :: Test+testRedirect = testCase "redirect" $ do+ (_,rsp) <- go (redirect "/foo/bar")++ assertEqual "redirect path" (Just "/foo/bar") $ getHeader "Location" rsp+ assertEqual "redirect status" 302 $ rspStatus rsp+ assertEqual "status description" "Found" $ rspStatusReason rsp+++ (_,rsp) <- go (redirect' "/bar/foo" 307)++ assertEqual "redirect path" (Just "/bar/foo") $ getHeader "Location" rsp+ assertEqual "redirect status" 307 $ rspStatus rsp+ assertEqual "status description" "Temporary Redirect" $ rspStatusReason rsp