This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "snap-core".
The branch, master has been updated
via 96f0488e64c1bd585031fd07394028dda3047321 (commit)
via e106a4c4fc13a7e4412f4c741cc2de93c85571e4 (commit)
via fa59ed8da0bf4ee082193fa20b22ba01367ccc16 (commit)
from a58a5a09a4a92726bf207f2827c7170b0578d819 (commit)
Summary of changes:
CONTRIBUTORS | 1 +
src/Snap/Internal/Http/Types.hs | 62 ++++++++++++++++++++++++++++++++++++++-
src/Snap/Internal/Types.hs | 24 +++++++++++++++
src/Snap/Types.hs | 3 ++
test/suite/Snap/Types/Tests.hs | 19 +++++++++++-
5 files changed, 107 insertions(+), 2 deletions(-)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit 96f0488e64c1bd585031fd07394028dda3047321
Author: Gregory Collins <[email protected]>
Date: Sun Aug 15 14:56:34 2010 -0400
Move status code map into Snap.Internal.Http.Types and export a new
function 'setStatusCode'
diff --git a/src/Snap/Internal/Http/Types.hs b/src/Snap/Internal/Http/Types.hs
index a9ff959..dc13ad2 100644
--- a/src/Snap/Internal/Http/Types.hs
+++ b/src/Snap/Internal/Http/Types.hs
@@ -31,10 +31,12 @@ import Data.Char
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 @@ setResponseBody e r = r { rspBody = Enum e }
------------------------------------------------------------------------------
--- | 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 @@ setResponseStatus s reason r = r { rspStatus=s,
rspStatusReason=reason }
------------------------------------------------------------------------------
+-- | 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 @@ fromStr = S.pack . map c2w
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
index 94b7560..90b5db7 100644
--- a/src/Snap/Internal/Types.hs
+++ b/src/Snap/Internal/Types.hs
@@ -23,7 +23,6 @@ import qualified Data.Text.Lazy as LT
import qualified Data.Text.Lazy.Encoding as LT
import Data.Typeable
-import qualified Data.IntMap as IM
------------------------------------------------------------------------------
import Snap.Iteratee hiding (Enumerator)
@@ -388,10 +387,8 @@ redirect target = redirect' target 302
redirect' :: ByteString -> Int -> Snap ()
redirect' target status =
finishWith
- $ setResponseStatus status reason
+ $ setResponseCode status
$ setHeader "Location" target emptyResponse
- where
- reason = fromMaybe "Unknown" (IM.lookup status statusReasonMap)
{-# INLINE redirect' #-}
@@ -629,46 +626,3 @@ getParam k = do
return $ liftM (S.intercalate " ") $ rqParam k rq
-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/Types.hs b/src/Snap/Types.hs
index b45517e..9314a14 100644
--- a/src/Snap/Types.hs
+++ b/src/Snap/Types.hs
@@ -84,6 +84,7 @@ module Snap.Types
-- ** Responses
, emptyResponse
+ , setResponseCode
, setResponseStatus
, rspStatus
, rspStatusReason
commit e106a4c4fc13a7e4412f4c741cc2de93c85571e4
Merge: a58a5a0 fa59ed8
Author: Gregory Collins <[email protected]>
Date: Sun Aug 15 14:50:01 2010 -0400
Merge branch 'master' of http://github.com/jkramer/snap-core
commit fa59ed8da0bf4ee082193fa20b22ba01367ccc16
Author: Jonas Kramer <[email protected]>
Date: Sun Aug 15 18:51:49 2010 +0200
Added functions for redirects and status code lookup table.
diff --git a/CONTRIBUTORS b/CONTRIBUTORS
index 8f8e3ab..43957f6 100644
--- a/CONTRIBUTORS
+++ b/CONTRIBUTORS
@@ -5,3 +5,4 @@ Carl Howells <[email protected]>
Shane O'Brien <[email protected]>
James Sanders <[email protected]>
Jacob Stanley <[email protected]>
+Jonas Kramer <[email protected]>
diff --git a/src/Snap/Internal/Types.hs b/src/Snap/Internal/Types.hs
index b856036..94b7560 100644
--- a/src/Snap/Internal/Types.hs
+++ b/src/Snap/Internal/Types.hs
@@ -23,6 +23,7 @@ import qualified Data.Text.Lazy as LT
import qualified Data.Text.Lazy.Encoding as LT
import Data.Typeable
+import qualified Data.IntMap as IM
------------------------------------------------------------------------------
import Snap.Iteratee hiding (Enumerator)
@@ -369,6 +370,32 @@ modifyResponse f = smodify $ \ss -> ss { _snapResponse = f
$ _snapResponse ss }
------------------------------------------------------------------------------
+-- | 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
+ $ setResponseStatus status reason
+ $ setHeader "Location" target emptyResponse
+ where
+ reason = fromMaybe "Unknown" (IM.lookup status statusReasonMap)
+{-# INLINE redirect' #-}
+
+
+------------------------------------------------------------------------------
-- | Log an error message in the 'Snap' monad
logError :: ByteString -> Snap ()
logError s = Snap $ gets _snapLogError >>= (\l -> liftIO $ l s)
@@ -602,3 +629,46 @@ getParam k = do
return $ liftM (S.intercalate " ") $ rqParam k rq
+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/Types.hs b/src/Snap/Types.hs
index 31344d8..b45517e 100644
--- a/src/Snap/Types.hs
+++ b/src/Snap/Types.hs
@@ -91,6 +91,8 @@ module Snap.Types
, addCookie
, setContentLength
, clearContentLength
+ , redirect
+ , redirect'
-- *** Response I/O
, setResponseBody
diff --git a/test/suite/Snap/Types/Tests.hs b/test/suite/Snap/Types/Tests.hs
index 47edd36..c859688 100644
--- a/test/suite/Snap/Types/Tests.hs
+++ b/test/suite/Snap/Types/Tests.hs
@@ -49,7 +49,8 @@ tests = [ testFail
, testIpHeaderFilter
, testMZero404
, testEvalSnap
- , testLocalRequest ]
+ , testLocalRequest
+ , testRedirect ]
expectException :: IO () -> IO ()
@@ -404,3 +405,19 @@ testLocalRequest = testCase "localRequest" $ do
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
-----------------------------------------------------------------------
hooks/post-receive
--
snap-core
_______________________________________________
Snap mailing list
[email protected]
http://mailman-mail5.webfaction.com/listinfo/snap
