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

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
 

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 "<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 "?"

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
         "<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