snap-core 0.5.0 → 0.5.1
raw patch · 4 files changed
+298/−126 lines, 4 files
Files
- snap-core.cabal +1/−1
- src/Snap/Internal/Http/Types.hs +12/−7
- src/Snap/Util/FileServe.hs +25/−5
- test/suite/Snap/Util/FileServe/Tests.hs +260/−113
snap-core.cabal view
@@ -1,5 +1,5 @@ name: snap-core-version: 0.5.0+version: 0.5.1 synopsis: Snap: A Haskell Web Framework (Core) description:
src/Snap/Internal/Http/Types.hs view
@@ -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
src/Snap/Util/FileServe.hs view
@@ -287,18 +287,19 @@ -> 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 @@ -- 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 "?"
test/suite/Snap/Util/FileServe/Tests.hs view
@@ -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 @@ "<a href='../'" `S.isInfixOf` bE1 assertBool "autogen-sub-file" $ "<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+ r1 <- go fsSingle "foo.html"+ b1 <- getBody r1++ 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)+ testRangeOK :: Test