Permalink
Browse files

Fix handling of query strings in fileServe (closes #72)

  • Loading branch information...
1 parent b52f3d8 commit 429a335067e175d5f90939e67fad462ff7856862 @gregorycollins gregorycollins committed Jun 19, 2011
Showing with 84 additions and 21 deletions.
  1. +12 −7 src/Snap/Internal/Http/Types.hs
  2. +25 −5 src/Snap/Util/FileServe.hs
  3. +47 −9 test/suite/Snap/Util/FileServe/Tests.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
@@ -287,18 +287,19 @@ defaultIndexGenerator :: MonadSnap m
-> m ()
defaultIndexGenerator mm styles d = do
modifyResponse $ setContentType "text/html"
-
rq <- getRequest
+ let uri = uriWithoutQueryString rq
+
writeBS "<style type='text/css'>"
writeBS styles
writeBS "</style><div class=\"header\">Directory Listing: "
- writeBS (rqURI rq)
+ writeBS uri
writeBS "</div><div class=\"content\">"
writeBS "<table><tr><th>File Name</th><th>Type</th><th>Last Modified"
writeBS "</th></tr>"
- when (rqURI rq /= "/") $
+ when (uri /= "/") $
writeBS "<tr><td><a href='../'>..</a></td><td colspan=2>DIR</td></tr>"
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 "?"
@@ -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
"<a href='foo.txt'" `S.isInfixOf` bE1
+ -- Request for directory with autogen index
+ rE2 <- go (fsCfg fancyDirectoryConfig) "mydir2/?z=z"
+ bE2 <- S.concat `fmap` L.toChunks `fmap` getBody rE2
+
+ assertBool "autogen-sub-index" $
+ "Directory Listing: /mydir2/" `S.isInfixOf` bE2
+ assertBool "autogen-sub-parent" $
+ "<a href='../'" `S.isInfixOf` bE2
+ assertBool "autogen-sub-file" $
+ "<a href='foo.txt'" `S.isInfixOf` bE2
+
+
testFsSingle :: Test
testFsSingle = testCase "fileServe/Single" $ do

0 comments on commit 429a335

Please sign in to comment.