diff --git a/src/Snap/Internal/Http/Types.hs b/src/Snap/Internal/Http/Types.hs
index d612ec2c..9c82b4d3 100644
--- a/src/Snap/Internal/Http/Types.hs
+++ b/src/Snap/Internal/Http/Types.hs
@@ -232,9 +232,14 @@ data Request = Request
--
-- An identity is that:
--
- -- > rqURI r == 'S.concat' [ rqSnapletPath r
- -- > , rqContextPath r
- -- > , rqPathInfo r ]
+ -- > rqURI r == S.concat [ rqSnapletPath r
+ -- > , rqContextPath r
+ -- > , rqPathInfo r
+ -- > , let q = rqQueryString r
+ -- > , in if S.null q
+ -- > then ""
+ -- > else S.append "?" q
+ -- > ]
--
-- note that until we introduce snaplets in v0.2, 'rqSnapletPath' will
-- be \"\"
@@ -246,10 +251,10 @@ 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'. The
- -- 'rqContextPath' always begins and ends with a slash (@\"\/\"@)
- -- character, and represents the path (relative to your
+ -- | 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
diff --git a/src/Snap/Util/FileServe.hs b/src/Snap/Util/FileServe.hs
index 123f9abc..5987dbfd 100644
--- a/src/Snap/Util/FileServe.hs
+++ b/src/Snap/Util/FileServe.hs
@@ -287,18 +287,19 @@ defaultIndexGenerator :: MonadSnap m
-> m ()
defaultIndexGenerator mm styles d = do
modifyResponse $ setContentType "text/html"
-
rq <- getRequest
+ let uri = uriWithoutQueryString rq
+
writeBS "
"
writeBS "
File Name | Type | Last Modified"
writeBS " |
"
- when (rqURI rq /= "/") $
+ when (uri /= "/") $
writeBS ".. | DIR |
"
entries <- liftIO $ getDirectoryContents d
@@ -423,7 +424,8 @@ serveDirectoryWith cfg base = do
-- not for a directory (no trailing slash).
directory = do
rq <- getRequest
- unless ("/" `S.isSuffixOf` rqURI rq) pass
+ let uri = uriWithoutQueryString rq
+ unless ("/" `S.isSuffixOf` uri) pass
rel <- (base >) <$> getSafePath
b <- liftIO $ doesDirectoryExist rel
if b then do let serveRel f = serve (rel > f)
@@ -441,7 +443,10 @@ serveDirectoryWith cfg base = do
rel <- (base >) <$> getSafePath
liftIO (doesDirectoryExist rel) >>= flip unless pass
rq <- getRequest
- redirect $ rqURI rq `S.append` "/" `S.append` rqQueryString rq
+ let uri = uriWithoutQueryString rq
+ let qss = queryStringSuffix rq
+ let u = S.concat [uri, "/", qss]
+ redirect u
------------------------------------------------------------------------------
@@ -723,3 +728,18 @@ fileServeSingle' = serveFileAs
{-# INLINE fileServeSingle' #-}
{-# DEPRECATED fileServeSingle' "Use serveFileAs instead" #-}
+
+------------------------------------------------------------------------------
+uriWithoutQueryString :: Request -> ByteString
+uriWithoutQueryString rq = S.concat [ cp, pinfo ]
+ where
+ cp = rqContextPath rq
+ pinfo = rqPathInfo rq
+
+
+------------------------------------------------------------------------------
+queryStringSuffix :: Request -> ByteString
+queryStringSuffix rq = S.concat [ s, qs ]
+ where
+ qs = rqQueryString rq
+ s = if S.null qs then "" else "?"
diff --git a/test/suite/Snap/Util/FileServe/Tests.hs b/test/suite/Snap/Util/FileServe/Tests.hs
index 359b94a1..9f2eae07 100644
--- a/test/suite/Snap/Util/FileServe/Tests.hs
+++ b/test/suite/Snap/Util/FileServe/Tests.hs
@@ -135,8 +135,15 @@ mkRequest :: ByteString -> IO Request
mkRequest uri = do
enum <- newIORef $ SomeEnumerator returnI
return $ Request "foo" 80 "foo" 999 "foo" 1000 "foo" False Map.empty
- enum Nothing GET (1,1) [] "" uri "/"
- (S.concat ["/",uri]) "" Map.empty
+ enum Nothing GET (1,1) [] "" pathPart "/"
+ (S.concat ["/",uri]) queryPart Map.empty
+
+ where
+ (pathPart, queryPart) = breakQuery uri
+
+ breakQuery s = (a, S.drop 1 b)
+ where
+ (a,b) = S.break (=='?') s
fs :: Snap ()
@@ -381,15 +388,25 @@ testFsCfgB = testCase "fileServe/cfgB" $ do
(Just "text/plain")
(getHeader "content-type" rB1)
- -- Request for root directory with alternate index
- rB2 <- gooo "mydir3/"
+ -- Request for root directory with index, query
+ rB2 <- gooo "mydir1/?z=z"
bB2 <- getBody rB2
- assertEqual "B2" "ALTINDEX\n" bB2
+ assertEqual "B2" "INDEX\n" bB2
assertEqual "B2 content-type"
- (Just "text/html")
+ (Just "text/plain")
(getHeader "content-type" rB2)
+
+ -- Request for root directory with alternate index
+ rB3 <- gooo "mydir3/"
+ bB3 <- getBody rB3
+
+ assertEqual "B3" "ALTINDEX\n" bB3
+ assertEqual "B3 content-type"
+ (Just "text/html")
+ (getHeader "content-type" rB3)
+
-- Request for root directory with no index
expect404 $ gooo "mydir2/"
@@ -407,11 +424,20 @@ testFsCfgC = testCase "fileServe/cfgC" $ do
(Just "text/plain")
(getHeader "content-type" rC1)
- -- Request for root directory with generated index
- rC2 <- gooo "mydir2/"
+ -- Request for root directory with index, query
+ rC2 <- gooo "mydir1/?z=z"
bC2 <- getBody rC2
- assertEqual "C2" "mydir2" bC2
+ assertEqual "C2" "INDEX\n" bC2
+ assertEqual "C2 content-type"
+ (Just "text/plain")
+ (getHeader "content-type" rC2)
+
+ -- Request for root directory with generated index
+ rC3 <- gooo "mydir2/"
+ bC3 <- getBody rC3
+
+ assertEqual "C3" "mydir2" bC3
testFsCfgD :: Test
@@ -437,6 +463,18 @@ testFsCfgFancy = testCase "fileServe/cfgFancy" $ do
"