diff --git a/CONTRIBUTORS b/CONTRIBUTORS --- a/CONTRIBUTORS +++ b/CONTRIBUTORS @@ -5,3 +5,4 @@ Shane O'Brien James Sanders Jacob Stanley +Jonas Kramer diff --git a/snap-core.cabal b/snap-core.cabal --- a/snap-core.cabal +++ b/snap-core.cabal @@ -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, diff --git a/src/Snap/Internal/Http/Types.hs b/src/Snap/Internal/Http/Types.hs --- a/src/Snap/Internal/Http/Types.hs +++ b/src/Snap/Internal/Http/Types.hs @@ -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") + ] diff --git a/src/Snap/Internal/Types.hs b/src/Snap/Internal/Types.hs --- a/src/Snap/Internal/Types.hs +++ b/src/Snap/Internal/Types.hs @@ -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) diff --git a/src/Snap/Iteratee.hs b/src/Snap/Iteratee.hs --- a/src/Snap/Iteratee.hs +++ b/src/Snap/Iteratee.hs @@ -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 diff --git a/src/Snap/Types.hs b/src/Snap/Types.hs --- a/src/Snap/Types.hs +++ b/src/Snap/Types.hs @@ -84,6 +84,7 @@ -- ** Responses , emptyResponse + , setResponseCode , setResponseStatus , rspStatus , rspStatusReason @@ -91,6 +92,8 @@ , addCookie , setContentLength , clearContentLength + , redirect + , redirect' -- *** Response I/O , setResponseBody diff --git a/src/Snap/Util/GZip.hs b/src/Snap/Util/GZip.hs --- a/src/Snap/Util/GZip.hs +++ b/src/Snap/Util/GZip.hs @@ -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) -> diff --git a/test/snap-core-testsuite.cabal b/test/snap-core-testsuite.cabal --- a/test/snap-core-testsuite.cabal +++ b/test/snap-core-testsuite.cabal @@ -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, diff --git a/test/suite/Snap/Types/Tests.hs b/test/suite/Snap/Types/Tests.hs --- a/test/suite/Snap/Types/Tests.hs +++ b/test/suite/Snap/Types/Tests.hs @@ -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