diff --git a/snap-core.cabal b/snap-core.cabal --- a/snap-core.cabal +++ b/snap-core.cabal @@ -1,5 +1,5 @@ name: snap-core -version: 0.5.0 +version: 0.5.1 synopsis: Snap: A Haskell Web Framework (Core) description: diff --git a/src/Snap/Internal/Http/Types.hs b/src/Snap/Internal/Http/Types.hs --- a/src/Snap/Internal/Http/Types.hs +++ b/src/Snap/Internal/Http/Types.hs @@ -232,9 +232,14 @@ -- -- 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 @@ -- 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 --- a/src/Snap/Util/FileServe.hs +++ b/src/Snap/Util/FileServe.hs @@ -287,18 +287,19 @@ -> 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 @@ -- 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 @@ 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 @@ {-# 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 --- a/test/suite/Snap/Util/FileServe/Tests.hs +++ b/test/suite/Snap/Util/FileServe/Tests.hs @@ -25,9 +25,19 @@ import Snap.Iteratee tests :: [Test] -tests = [ testFs - , testFsCfg +tests = [ testFooBin + , testFooTxt + , testFooHtml + , testFooBinBinBin + , test404s , testFsSingle + + , testFsCfgA + , testFsCfgB + , testFsCfgC + , testFsCfgD + , testFsCfgFancy + , testRangeOK , testRangeBad , testMultiRange @@ -60,6 +70,7 @@ where d = const $ return () + go :: Snap a -> ByteString -> IO Response go m s = do rq <- mkRequest s @@ -124,10 +135,17 @@ 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 () fs = do x <- serveDirectory "data/fileServe" @@ -146,57 +164,120 @@ return $! x `seq` () -testFs :: Test -testFs = testCase "fileServe/multi" $ do - r1 <- go fs "foo.bin" - b1 <- getBody r1 - assertEqual "foo.bin" "FOO\n" b1 - assertEqual "foo.bin content-type" - (Just "application/octet-stream") - (getHeader "content-type" r1) - - assertEqual "foo.bin size" (Just 4) (rspContentLength r1) - - assertBool "last-modified header" (isJust $ getHeader "last-modified" r1) - assertEqual "accept-ranges header" (Just "bytes") - (getHeader "accept-ranges" r1) - +------------------------------------------------------------------------------ +testFooBin :: Test +testFooBin = testCase "fileServe/foo.bin" $ do + r1 <- go fs "foo.bin" + checkProps "fileServe/foo.bin/default" r1 let !lm = fromJust $ getHeader "last-modified" r1 + go fs "foo.bin?blah=blah" >>= checkProps "fileServe/foo.bin/query-string" + -- check last modified stuff r2 <- goIfModifiedSince fs "foo.bin" lm assertEqual "foo.bin 304" 304 $ rspStatus r2 r3 <- goIfModifiedSince fs "foo.bin" "Wed, 15 Nov 1995 04:58:08 GMT" - assertEqual "foo.bin 200" 200 $ rspStatus r3 - b3 <- getBody r3 - assertEqual "foo.bin 2" "FOO\n" b3 + checkProps "fileServe/foo.bin/ifModifiedSince" r3 - r4 <- go fs "foo.txt" - b4 <- getBody r4 + where + checkProps name r = do + b <- getBody r - assertEqual "foo.txt" "FOO\n" b4 - assertEqual "foo.txt content-type" - (Just "text/plain") - (getHeader "content-type" r4) - - r5 <- go fs "foo.html" - b5 <- getBody r5 + assertEqual (name ++ "/contents") "FOO\n" b + assertEqual (name ++ "/content-type") + (Just "application/octet-stream") + (getHeader "content-type" r) - assertEqual "foo.html" "FOO\n" b5 - assertEqual "foo.html content-type" - (Just "text/html") - (getHeader "content-type" r5) + assertEqual (name ++ "/size") (Just 4) (rspContentLength r) + + assertBool (name ++ "/last-modified") + (isJust $ getHeader "last-modified" r) + + assertEqual (name ++ "/accept-ranges") + (Just "bytes") + (getHeader "accept-ranges" r) + + +------------------------------------------------------------------------------ +testFooTxt :: Test +testFooTxt = testCase "fileServe/foo.txt" $ do + go fs "foo.txt" >>= checkProps "fileServe/foo.txt/default" + go fs "foo.txt?blah=blah" >>= checkProps "fileServe/foo.txt/query" + + where + checkProps name r = do + b <- getBody r + + assertEqual (name ++ "/contents") "FOO\n" b + assertEqual (name ++ "/content-type") + (Just "text/plain") + (getHeader "content-type" r) + + assertEqual (name ++ "/size") (Just 4) (rspContentLength r) + + assertBool (name ++ "/last-modified") + (isJust $ getHeader "last-modified" r) + + assertEqual (name ++ "/accept-ranges") + (Just "bytes") + (getHeader "accept-ranges" r) - r6 <- go fs "foo.bin.bin.bin" - b6 <- getBody r6 + - assertEqual "foo.bin.bin.bin" "FOO\n" b6 - assertEqual "foo.bin.bin.bin content-type" - (Just "application/octet-stream") - (getHeader "content-type" r6) +------------------------------------------------------------------------------ +testFooHtml :: Test +testFooHtml = testCase "fileServe/foo.html" $ do + go fs "foo.html" >>= checkProps "fileServe/foo.html/default" + go fs "foo.html?bar=bar" >>= checkProps "fileServe/foo.html/query" + where + checkProps name r = do + b <- getBody r + + assertEqual (name ++ "/contents") "FOO\n" b + assertEqual (name ++ "/content-type") + (Just "text/html") + (getHeader "content-type" r) + + assertEqual (name ++ "/size") (Just 4) (rspContentLength r) + + assertBool (name ++ "/last-modified") + (isJust $ getHeader "last-modified" r) + + assertEqual (name ++ "/accept-ranges") + (Just "bytes") + (getHeader "accept-ranges" r) + + +------------------------------------------------------------------------------ +testFooBinBinBin :: Test +testFooBinBinBin = testCase "fileServe/foo.bin.bin.bin" $ do + go fs "foo.bin.bin.bin" >>= checkProps "fileServe/foo.bin.bin.bin" + + where + checkProps name r = do + b <- getBody r + + assertEqual (name ++ "/contents") "FOO\n" b + assertEqual (name ++ "/content-type") + (Just "application/octet-stream") + (getHeader "content-type" r) + + assertEqual (name ++ "/size") (Just 4) (rspContentLength r) + + assertBool (name ++ "/last-modified") + (isJust $ getHeader "last-modified" r) + + assertEqual (name ++ "/accept-ranges") + (Just "bytes") + (getHeader "accept-ranges" r) + + +------------------------------------------------------------------------------ +test404s :: Test +test404s = testCase "fileServe/404s" $ do expect404 $ go fs "jfldksjflksd" expect404 $ go fs "dummy/../foo.txt" expect404 $ go fs "/etc/password" @@ -204,75 +285,102 @@ coverMimeMap -testFsSingle :: Test -testFsSingle = testCase "fileServe/Single" $ do - r1 <- go fsSingle "foo.html" - b1 <- getBody r1 +------------------------------------------------------------------------------ +printName :: FilePath -> Snap () +printName c = writeBS $ snd $ S.breakEnd (=='/') $ S.pack c - assertEqual "foo.html" "FOO\n" b1 - assertEqual "foo.html content-type" - (Just "text/html") - (getHeader "content-type" r1) - assertEqual "foo.html size" (Just 4) (rspContentLength r1) +cfgA, cfgB, cfgC, cfgD :: DirectoryConfig Snap +cfgA = DirectoryConfig { + indexFiles = [] + , indexGenerator = const pass + , dynamicHandlers = Map.empty + , mimeTypes = defaultMimeTypes + , preServeHook = const $ return () + } +cfgB = DirectoryConfig { + indexFiles = ["index.txt", "altindex.html"] + , indexGenerator = const pass + , dynamicHandlers = Map.empty + , mimeTypes = defaultMimeTypes + , preServeHook = const $ return () + } -testFsCfg :: Test -testFsCfg = testCase "fileServe/Cfg" $ do +cfgC = DirectoryConfig { + indexFiles = ["index.txt", "altindex.html"] + , indexGenerator = printName + , dynamicHandlers = Map.empty + , mimeTypes = defaultMimeTypes + , preServeHook = const $ return () + } - let cfgA = DirectoryConfig { - indexFiles = [], - indexGenerator = const pass, - dynamicHandlers = Map.empty, - mimeTypes = defaultMimeTypes, - preServeHook = const $ return () - } +cfgD = DirectoryConfig { + indexFiles = [] + , indexGenerator = const pass + , dynamicHandlers = Map.fromList [ (".txt", printName) ] + , mimeTypes = defaultMimeTypes + , preServeHook = const $ return () + } - -- Named file in the root directory - rA1 <- go (fsCfg cfgA) "foo.bin" - bA1 <- getBody rA1 - assertEqual "A1" "FOO\n" bA1 - assertEqual "A1 content-type" - (Just "application/octet-stream") - (getHeader "content-type" rA1) +testFsCfgA :: Test +testFsCfgA = testCase "fileServe/cfgA" $ do + let gooo = go (fsCfg cfgA) + -- Named file in the root directory + gooo "foo.bin" >>= checkProps "cfgA1/1" "application/octet-stream" + gooo "foo.bin?blah=blah" >>= + checkProps "cfgA1/2" "application/octet-stream" + -- Missing file in the root directory - expect404 $ go (fsCfg cfgA) "bar.bin" + expect404 $ gooo "bar.bin" -- Named file in a subdirectory - rA2 <- go (fsCfg cfgA) "mydir2/foo.txt" - bA2 <- getBody rA2 - - assertEqual "A2" "FOO\n" bA2 - assertEqual "A2 content-type" - (Just "text/plain") - (getHeader "content-type" rA2) - + gooo "mydir2/foo.txt" >>= checkProps "cfgA1/subdir/1" "text/plain" + gooo "mydir2/foo.txt?z=z" >>= checkProps "cfgA1/subdir/2" "text/plain" + -- Missing file in a subdirectory - expect404 $ go (fsCfg cfgA) "mydir2/bar.txt" + expect404 $ gooo "mydir2/bar.txt" -- Request for directory with no trailing slash - expect302 "/mydir1/" $ go (fsCfg cfgA) "mydir1" + expect302 "/mydir1/" $ gooo "mydir1" + -- Request for directory with no trailing slash, with query param + expect302 "/mydir1/?z=z" $ gooo "mydir1?z=z" + -- Request for directory with trailing slash, no index - expect404 $ go (fsCfg cfgA) "mydir1/" - expect404 $ go (fsCfg cfgA) "mydir2/" + expect404 $ gooo "mydir1/" + expect404 $ gooo "mydir2/" -- Request file with trailing slash - expect404 $ go (fsCfg cfgA) "foo.html/" - expect404 $ go (fsCfg cfgA) "mydir2/foo.txt/" + expect404 $ gooo "foo.html/" + expect404 $ gooo "mydir2/foo.txt/" - let cfgB = DirectoryConfig { - indexFiles = ["index.txt", "altindex.html"], - indexGenerator = const pass, - dynamicHandlers = Map.empty, - mimeTypes = defaultMimeTypes, - preServeHook = const $ return () - } + where + checkProps name ct r = do + b <- getBody r + assertEqual (name ++ "/contents") "FOO\n" b + assertEqual (name ++ "/content-type") + (Just ct) + (getHeader "content-type" r) + + assertEqual (name ++ "/size") (Just 4) (rspContentLength r) + + assertBool (name ++ "/last-modified") + (isJust $ getHeader "last-modified" r) + + assertEqual (name ++ "/accept-ranges") + (Just "bytes") + (getHeader "accept-ranges" r) + +testFsCfgB :: Test +testFsCfgB = testCase "fileServe/cfgB" $ do + let gooo = go (fsCfg cfgB) + -- Request for root directory with index - rB1 <- go (fsCfg cfgB) "mydir1/" + rB1 <- gooo "mydir1/" bB1 <- getBody rB1 assertEqual "B1" "INDEX\n" bB1 @@ -280,30 +388,35 @@ (Just "text/plain") (getHeader "content-type" rB1) - -- Request for root directory with alternate index - rB2 <- go (fsCfg cfgB) "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 $ go (fsCfg cfgB) "mydir2/" + expect404 $ gooo "mydir2/" - let printName c = writeBS $ snd $ S.breakEnd (=='/') $ S.pack c - let cfgC = DirectoryConfig { - indexFiles = ["index.txt", "altindex.html"], - indexGenerator = printName, - dynamicHandlers = Map.empty, - mimeTypes = defaultMimeTypes, - preServeHook = const $ return () - } +testFsCfgC :: Test +testFsCfgC = testCase "fileServe/cfgC" $ do + let gooo = go (fsCfg cfgC) -- Request for root directory with index - rC1 <- go (fsCfg cfgC) "mydir1/" + rC1 <- gooo "mydir1/" bC1 <- getBody rC1 assertEqual "C1" "INDEX\n" bC1 @@ -311,26 +424,33 @@ (Just "text/plain") (getHeader "content-type" rC1) - -- Request for root directory with generated index - rC2 <- go (fsCfg cfgC) "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) - let cfgD = DirectoryConfig { - indexFiles = [], - indexGenerator = const pass, - dynamicHandlers = Map.fromList [ (".txt", printName) ], - mimeTypes = defaultMimeTypes, - preServeHook = const $ return () - } + -- Request for root directory with generated index + rC3 <- gooo "mydir2/" + bC3 <- getBody rC3 + assertEqual "C3" "mydir2" bC3 + + +testFsCfgD :: Test +testFsCfgD = testCase "fileServe/cfgD" $ do -- Request for file with dynamic handler rD1 <- go (fsCfg cfgD) "mydir2/foo.txt" bD1 <- getBody rD1 assertEqual "D1" "foo.txt" bD1 + +testFsCfgFancy :: Test +testFsCfgFancy = testCase "fileServe/cfgFancy" $ do -- Request for directory with autogen index rE1 <- go (fsCfg fancyDirectoryConfig) "mydir2/" bE1 <- S.concat `fmap` L.toChunks `fmap` getBody rE1 @@ -341,6 +461,33 @@ "
File NameTypeLast Modified" writeBS "
..DIR