2a3d51b · typeable/wai

git.iko.soy/typeable/wai

update for 0.8

commit2a3d51bb52f02d9eb3cd39c3af03816fa7bdd969 authorGreg Weber <greg@gregweber.info> dateSat 7 May 2011, 18:42 (16 years ago) parent170b47a

3 files changed+93−55

compare with master

unifiedsplit

Network/Wai/Application/Static.hs+55−34 tests/runtests.hs+32−17 wai-app-static.cabal+6−4

Network/Wai/Application/Static.hs+55−34

@@ -32,6 +32,8 @@ module Network.Wai.Application.Static

3232 , defaultStaticSettings

3333 , defaultPublicSettings

3434 , CacheSettings (..)

35+ -- should be moved to common helper

36+ , unfixPathName

3537 ) where

3638

3739import qualified Network.Wai as W

@@ -60,7 +62,7 @@ import Data.Time

6062import Data.Time.Clock.POSIX

6163import System.Locale (defaultTimeLocale)

6264

63−import Data.List (sortBy, intercalate)

65+import Data.List (sortBy)

6466import Data.FileEmbed (embedFile)

6567

6668import qualified Data.Text as T

@@ -194,22 +196,23 @@ filterButLast f (x:xs)

194196 | otherwise = filterButLast f xs

195197

196198

197−unsafe :: FilePath -> Bool

198−unsafe ('.':_) = True

199−unsafe s = any (== '/') s

199+unsafe :: T.Text -> Bool

200+unsafe s | T.null s = False

201+ | T.head s == '.' = True

202+ | otherwise = T.any (== '/') s

200203

201204stripTrailingSlash :: FilePath -> FilePath

202205stripTrailingSlash "/" = ""

203206stripTrailingSlash "" = ""

204207stripTrailingSlash (x:xs) = x : stripTrailingSlash xs

205208

206−type Pieces = [Text]

207−relativeFromPieces :: Pieces -> Text

208−relativeFromPieces pieces = concatMap (const "../") (drop 1 pieces) -- last path which is not a dir

209+type Pieces = [T.Text]

210+relativeDirFromPieces :: Pieces -> T.Text

211+relativeDirFromPieces pieces = T.concat $ map (const "../") (drop 1 pieces) -- last piece is not a dir

209212

210213pathFromPieces :: FilePath -> Pieces -> FilePath

211214pathFromPieces prefix pieces =

212− concat $ prefix : map ((:) '/') (map unfixPathName pieces)

215+ concat $ prefix : map ((:) '/') (map unfixPathName $ map T.unpack pieces)

213216

214217checkPieces :: FilePath -- ^ static file prefix

215218 -> [FilePath] -- ^ List of default index files. Cannot contain slashes.

@@ -223,15 +226,15 @@ checkPieces _ _ [".hidden", "haskell.png"] _ _ =

223226 return $ SendContent "image/png" $ L.fromChunks [$(embedFile "haskell.png")]

224227checkPieces prefix indices pieces cache req

225228 | any unsafe pieces = return Forbidden

226− | any null $ safeInit pieces =

227− return $ Redirect $ filterButLast (not . null) pieces

229+ | any T.null $ safeInit pieces =

230+ return $ Redirect $ filterButLast (not . T.null) pieces

228231 | otherwise = do

229232 let fp = pathFromPieces prefix pieces

230233 let (isFile, isFolder) =

231234 case () of

232235 ()

233236 | null pieces -> (True, True)

234− | null (last pieces) -> (False, True)

237+ | T.null (last pieces) -> (False, True)

235238 | otherwise -> (True, False)

236239

237240 if not isFile then uncached fp isFile isFolder

@@ -245,7 +248,7 @@ checkPieces prefix indices pieces cache req

245248 (Just hash, Just lastHash) | hash == lastHash -> return NotModified

246249 _ -> trace "ETAG: no cache match" uncached fp isFile isFolder

247250 Forever isStaticFile ->

248− if isStaticFile fp (W.queryString req) &&

251+ if isStaticFile fp (S8.drop 1 $ W.rawQueryString req) &&

249252 (isJust $ lookup "If-Modified-Since" (W.requestHeaders req)) &&

250253 (isNothing $ lookup "If-Unmodified-Since" (W.requestHeaders req))

251254 then return NotModified

@@ -266,7 +269,7 @@ checkPieces prefix indices pieces cache req

266269 else do

267270 x <- checkIndices fp indices

268271 case x of

269− Just index -> return $ Redirect $ setLast pieces index

272+ Just index -> return $ Redirect $ setLast pieces (T.pack index)

270273 Nothing ->

271274 if isFolder

272275 then return $ DirectoryResponse fp

@@ -297,31 +300,34 @@ defaultDirListing = StaticDirListing defaultListing []

297300type CheckHashParam = (FilePath -> S8.ByteString -> Bool)

298301data CacheSettings = NoCache | Forever CheckHashParam | ETag (FilePath -> IO (Maybe S8.ByteString))

299302

300−{-MaxAge S8.ByteString -}

301−{-maxAge :: Int -> CacheSettings-}

302−{-maxAge = MaxAge . S8.pack . show-}

303−

304303oneYear :: Int

305304oneYear = 60 * 60 * 24 * 365

306305

307306data StaticSettings = StaticSettings

308307 { ssFolder :: FilePath

309− , ssMkRedirect :: Pieces -> FilePath -> S8.ByteString

308+ , ssMkRedirect :: Pieces -> ByteString -> S8.ByteString

310309 , ssGetMimeType :: FilePath -> IO MimeType

311310 , ssDirListing :: StaticDirListing

312311 , ssCacheSettings :: CacheSettings

313312 }

314313

314+defaultMkRedirect :: Pieces -> ByteString -> S8.ByteString

315+defaultMkRedirect pieces newPath =

316+ let relDir = TE.encodeUtf8 (relativeDirFromPieces pieces) in

317+ S8.append relDir (if (S8.last relDir) == '/' && (S8.head newPath) == '/'

318+ then S8.tail newPath

319+ else newPath)

320+

315321defaultStaticSettings :: CacheSettings -> StaticSettings

316322defaultStaticSettings isStaticFile = StaticSettings { ssFolder = "static"

317− , ssMkRedirect = \pieces newPath -> S8.pack $ (relativeFromPieces pieces) ++ newPath

323+ , ssMkRedirect = defaultMkRedirect

318324 , ssGetMimeType = return . defaultMimeTypeByExt

319325 , ssDirListing = defaultDirListing

320326 , ssCacheSettings = isStaticFile

321327}

322328defaultPublicSettings :: CacheSettings -> StaticSettings

323329defaultPublicSettings etags = StaticSettings { ssFolder = "public"

324− , ssMkRedirect = \pieces newPath -> S8.pack $ (relativeFromPieces pieces) ++ newPath

330+ , ssMkRedirect = defaultMkRedirect

325331 , ssGetMimeType = return . defaultMimeTypeByExt

326332 , ssDirListing = ListingForbidden

327333 , ssCacheSettings = etags

@@ -333,8 +339,8 @@ staticApp set req = do

333339 let pieces = W.pathInfo req

334340 staticAppPieces set pieces req

335341

336−status304, statusNotModified :: W.Status

337−status304 = W.Status 304 "Not Modified"

342+status304, statusNotModified :: H.Status

343+status304 = H.Status 304 "Not Modified"

338344statusNotModified = status304

339345

340346staticAppPieces :: StaticSettings -> Pieces -> W.Application

@@ -349,12 +355,12 @@ staticAppPieces ss@StaticSettings{} pieces req = liftIO $ do

349355 StaticDirListing _ is -> is

350356 ListingForbidden -> []

351357 cp <- checkPieces (ssFolder ss) indices pieces cache req

352− case debug cp of

358+ case cp of

353359 FileResponse fp -> do

354360 mimetype <- (ssGetMimeType ss) fp

355361 filesize <- fileSize `fmap` getFileStatus fp

356362 ch <- setCacheHeaders cache fp

357− return $ W.ResponseFile W.status200

363+ return $ W.ResponseFile H.status200

358364 ( [ ("Content-Type", mimetype)

359365 , ("Content-Length", S8.pack $ show filesize)

360366 ] ++ ch ) fp Nothing

@@ -366,22 +372,26 @@ staticAppPieces ss@StaticSettings{} pieces req = liftIO $ do

366372 case ssDirListing ss of

367373 StaticDirListing f _ -> do

368374 lbs <- f pieces fp

369− return $ W.responseLBS W.status200

375+ return $ W.responseLBS H.status200

370376 [ ("Content-Type", "text/html; charset=utf-8")

371377 ] lbs

372− ListingForbidden -> return $ W.responseLBS W.status403

378+ ListingForbidden -> return $ W.responseLBS H.status403

373379 [ ("Content-Type", "text/plain")

374380 ] "Directory listings disabled"

375381 SendContent mt lbs -> do

376382 -- TODO: set caching headers

377− return $ W.responseLBS W.status200

383+ return $ W.responseLBS H.status200

378384 [ ("Content-Type", mt)

379385 -- TODO: set Content-Length

380386 ] lbs

381387 Redirect pieces' -> do

382− let loc =

388+ let loc = (ssMkRedirect ss) pieces' $ toByteString (H.encodePathSegments pieces')

389+

390+ let loc' =

391+ -- relativeDirFromPieces pieces = T.concat $ map (const "../") (drop 1 pieces) -- last piece is not a dir

392+ -- (ssMkRedirect ss) pieces' $ encodePathInfo pieces' []

383393 toByteString $

384− foldr mappend (H.encodePathSegments $ map T.pack pieces') -- FIXME use Text

394+ foldr mappend (H.encodePathSegments pieces') -- FIXME use Text

385395 $ map (const $ copyByteString "../") $ drop 1 pieces

386396 return $ W.responseLBS H.status301

387397 [ ("Content-Type", "text/plain")

@@ -395,9 +405,9 @@ staticAppPieces ss@StaticSettings{} pieces req = liftIO $ do

395405 ] "File not found"

396406 where

397407 -- expires header: formatTime "%a, %d-%b-%Y %X GMT"

398− setCacheHeaders :: CacheSettings -> FilePath -> IO W.ResponseHeaders

408+ setCacheHeaders :: CacheSettings -> FilePath -> IO H.ResponseHeaders

399409 setCacheHeaders (Forever isStaticFile) fp = return $

400− if isStaticFile fp (W.queryString req)

410+ if isStaticFile fp (S8.drop 1 $ W.rawQueryString req)

401411 then [("Cache-Control", S8.append "max-age=" $ S8.pack $ show oneYear)]

402412 else []

403413 setCacheHeaders NoCache _ = return []

@@ -407,6 +417,16 @@ staticAppPieces ss@StaticSettings{} pieces req = liftIO $ do

407417 Just hash -> [("ETag", hash)]

408418 Nothing -> []

409419

420+{-

421+The problem is that the System.Directory functions are a lie: they

422+claim to be using String, but it's really just a raw byte sequence.

423+We're assuming that non-Windows systems use UTF-8 encoding (there was

424+a discussion regarding this, it wasn't an arbitrary decision). So we

425+need to encode/decode the byte sequence to/from UTF8. That's the use

426+case for fixPathName/unfixPathName. I'm starting to use John

427+Millikin's system-filepath package for some stuff with work, and might

428+consider migrating over to it for this in the future.

429+-}

410430fixPathName :: FilePath -> FilePath

411431#if defined(mingw32_HOST_OS)

412432fixPathName = id

@@ -431,7 +451,7 @@ defaultListing pieces localPath = do

431451 return $ HU.renderHtml

432452 $ H.html $ do

433453 H.head $ do

434− let title = intercalate "/" pieces

454+ let title = T.unpack $ T.intercalate "/" pieces

435455 let title' = if null title then "root folder" else title

436456 H.title $ H.string title'

437457 H.style $ H.string $ unlines [ "table { margin: 0 auto; width: 760px; border-collapse: collapse; font-family: 'sans-serif'; }"

@@ -449,10 +469,10 @@ defaultListing pieces localPath = do

449469 , "a { text-decoration: none }"

450470 ]

451471 H.body $ do

452− H.h1 $ showFolder $ "" : filter (not . null) pieces

472+ H.h1 $ showFolder $ map T.unpack $ filter (not . T.null) pieces

453473 renderDirectoryContentsTable haskellSrc folderSrc $ catMaybes fps''

454474 where

455− image x = (relativeFromPieces pieces) ++ ".hidden/" ++ x ++ ".png"

475+ image x = T.unpack $ T.concat [(relativeDirFromPieces pieces), ".hidden/", x, ".png"]

456476 folderSrc = image "folder"

457477 haskellSrc = image "haskell"

458478 showName "" = "root"

@@ -520,6 +540,7 @@ renderDirectoryContentsTable haskellSrc folderSrc fps =

520540 addCommas' (a:b:c:d:e) = a : b : c : ',' : addCommas' (d : e)

521541 addCommas' x = x

522542

543+mdName' :: MetaData -> FilePath

523544mdName' = fixPathName . mdName

524545

525546data MetaData =

tests/runtests.hs+32−17

@@ -7,38 +7,51 @@ import Test.Hspec.QuickCheck (prop)

77import Test.HUnit ((@?=))

88import Distribution.Simple.Utils (isInfixOf)

99import qualified Data.ByteString.Char8 as S8

10+import qualified Data.Text as T

11+import qualified Data.Text.Encoding as TE

1012

1113

1214import Network.Wai

1315import Network.Wai.Test

1416

1517import Network.Socket.Internal as Sock

18+import qualified Network.HTTP.Types as H

1619

1720main :: IO ()

1821main = hspecX specs

1922

2023defRequest :: Request

2124defRequest = Request {

22− queryString = ""

25+ rawQueryString = ""

26+, queryString = []

2327, requestMethod = "GET"

24−, pathInfo = "/index.html"

28+, rawPathInfo = ""

29+, pathInfo = []

2530, requestHeaders = []

2631, serverName = "wai-test"

27−, httpVersion = "1.1"

32+, httpVersion = H.http11

2833, serverPort = 80

2934, isSecure = False

30−, errorHandler = putStrLn

3135, remoteHost = Sock.SockAddrUnix "/dev/null"

3236}

3337

38+setRawPathInfo :: Request -> S8.ByteString -> Request

39+setRawPathInfo r rawPinfo =

40+ let pInfo = T.split (== '/') $ TE.decodeUtf8 rawPinfo

41+ in r { rawPathInfo = rawPinfo, pathInfo = pInfo }

42+

3443specs :: IO [Spec]

3544specs = runSpecM $ do

45+{-

3646 context "Pieces: pathFromPieces" $ do

3747 ti "converts to a file path" $

3848 (pathFromPieces "prefix" ["a", "bc"]) @?= "prefix/a/bc"

3949

4050 prop "each piece is in file path" $ \pieces ->

41− all (\p -> ("/" ++ p) `isInfixOf` (pathFromPieces "root" $ pieces)) pieces

51+ let piecesT = (map T.pack pieces) in

52+ all (\p -> ("/" ++ (unfixPathName $ T.unpack p)) `isInfixOf` (pathFromPieces "root" $ piecesT)) piecesT

53+ -}

54+

4255

4356

4457 let cacheLookup = Forever (\fp h -> fp == "tests/runtests.hs" && h == "cached")

@@ -47,33 +60,33 @@ specs = runSpecM $ do

4760 ti "403 for unsafe paths" $ statApp $

4861 flip mapM_ ["..", "."] $ \path ->

4962 assertStatus 403 =<<

50− request defRequest { pathInfo = path }

63+ request (setRawPathInfo defRequest path)

5164

5265 ti "200 for hidden paths" $ statApp $

5366 flip mapM_ [".hidden/folder.png", ".hidden/haskell.png"] $ \path ->

5467 assertStatus 200 =<<

55− request defRequest { pathInfo = path }

68+ request (setRawPathInfo defRequest path)

5669

5770 ti "404 for non-existant files" $ statApp $

5871 assertStatus 404 =<<

59− request defRequest { pathInfo = "doesNotExist" }

72+ request (setRawPathInfo defRequest "doesNotExist")

6073

6174 ti "301 redirect when multiple slashes" $ statApp $ do

62− req <- request defRequest { pathInfo = "a//b/c" }

75+ req <- request (setRawPathInfo defRequest "a//b/c")

6376 assertStatus 301 req

6477 assertHeader "Location" "../../a/b/c" req

6578

6679 let absoluteApp = flip runSession $ staticApp $ (defaultStaticSettings cacheLookup) {

67− ssFolder = "tests", ssMkRedirect = \_ u -> S8.pack $ "http://www.example.com" ++ "/" ++ u

80+ ssFolder = "tests", ssMkRedirect = \_ u -> S8.append "http://www.example.com" u

6881 }

6982 ti "301 redirect when multiple slashes" $ absoluteApp $

7083 flip mapM_ ["/a//b/c", "a//b/c"] $ \path -> do

71− req <- request defRequest { pathInfo = path }

84+ req <- request (setRawPathInfo defRequest path)

7285 assertStatus 301 req

7386 assertHeader "Location" "http://www.example.com/a/b/c" req

7487

7588 context "when requesting a static asset" $ do

76− let runtests = defRequest { pathInfo = "runtests.hs" }

89+ let runtests = setRawPathInfo defRequest "runtests.hs"

7790 ti "200 when no query parameters" $ statApp $ do

7891 req <- request runtests {

7992 requestHeaders = [("If-Modified-Since", "")]

@@ -82,19 +95,19 @@ specs = runSpecM $ do

8295 assertNoHeader "Cache-Control" req

8396

8497 ti "200 when no cache headers sent" $ statApp $ do

85− req <- request runtests { queryString ="cached" }

98+ req <- request runtests { rawQueryString ="?cached" }

8699 assertStatus 200 req

87100 assertHeader "Cache-Control" "max-age=31536000" req

88101

89102 ti "200 when If-Unmodified-Since" $ statApp $ do

90− req <- request runtests { queryString ="cached",

103+ req <- request runtests { rawQueryString ="?cached",

91104 requestHeaders = [("If-Unmodified-Since", "")]

92105 }

93106 assertStatus 200 req

94107 assertHeader "Cache-Control" "max-age=31536000" req

95108

96109 ti "304 when cache header and query parameter sent" $ statApp $ do

97− req <- request runtests { queryString ="cached",

110+ req <- request runtests { rawQueryString ="?cached",

98111 requestHeaders = [("If-Modified-Since", "")]

99112 }

100113 assertStatus 304 req

@@ -103,11 +116,13 @@ specs = runSpecM $ do

103116 let pubApp = flip runSession $ staticApp (defaultPublicSettings $ ETag (\_ -> return $ Just "hash")) {ssFolder = "tests"}

104117 context "staticApp when requesting a public asset - etags" $ do

105118 ti "200 when no etag parameters" $ pubApp $ do

106− req <- request defRequest { pathInfo = "runtests.hs" }

119+ req <- request (setRawPathInfo defRequest "runtests.hs")

107120 assertStatus 200 req

108121 assertHeader "Etag" "hash" req

109122

110123 ti "304 when etag parameter sent" $ pubApp $ do

111− req <- request defRequest { pathInfo = "runtests.hs", requestHeaders = [("If-None-Match", "hash")] }

124+ req <- request (setRawPathInfo defRequest "runtests.hs") { requestHeaders = [("If-None-Match", "hash")] }

112125 assertStatus 304 req

113126 assertNoHeader "Etag" req

127+{-

128+-}

wai-app-static.cabal+6−4

@@ -1,5 +1,5 @@

11name: wai-app-static

2−version: 0.1.0

2+version: 0.2.0

33license: BSD3

44license-file: LICENSE

55author: Michael Snoyman <michael@snoyman.com>

@@ -49,12 +49,14 @@ test-suite runtests

4949 , HUnit

5050 , Cabal

5151 , wai-app-static

52− , wai

5352 , wai-test

53+ , wai

54+ , http-types

5455 , network

5556 , bytestring

56− , transformers

57− , containers

57+ , text

58+ -- , transformers

59+ -- , containers

5860 ghc-options: -Wall

5961

6062source-repository head