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 "
Directory Listing: " - writeBS (rqURI rq) + writeBS uri writeBS "
" writeBS "" - when (rqURI rq /= "/") $ + when (uri /= "/") $ writeBS "" 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 "
File NameTypeLast Modified" writeBS "
..DIR