git.iko.soy/typeable/wai
on master help sign in
Merge pull request #7 from gregwebs/embedded
2d196d0Michael Snoyman
.gitignore+1
compare with master
unifiedsplit
@@ -1 +1,2 @@
1dist/
1dist/
2+cabal-dev
Network/Wai/Application/Static.hs+410−232
@@ -2,9 +2,21 @@
2{-# LANGUAGE TemplateHaskell, CPP #-}
2{-# LANGUAGE TemplateHaskell, CPP #-}
3-- | Static file serving for WAI.
3-- | Static file serving for WAI.
4module Network.Wai.Application.Static
4module Network.Wai.Application.Static
5+ ( -- * WAI application
6+ staticApp
7+ -- ** Settings
8+ , defaultWebAppSettings
9+ , defaultFileServerSettings
10+ , StaticSettings
11+ , ssFolder
12+ , ssMkRedirect
13+ , ssGetMimeType
14+ , ssListing
15+ , ssIndices
16+ , ssMaxAge
5− ( -- * Generic, non-WAI code
17+ -- * Generic, non-WAI code
6 -- ** Mime types
18 -- ** Mime types
7− MimeType
19+ , MimeType
8 , defaultMimeType
20 , defaultMimeType
9 -- ** Mime type by file extension
21 -- ** Mime type by file extension
10 , Extension
22 , Extension
@@ -14,26 +26,25 @@ module Network.Wai.Application.Static
14 , mimeTypeByExt
26 , mimeTypeByExt
15 , defaultMimeTypeByExt
27 , defaultMimeTypeByExt
16 -- ** Finding files
28 -- ** Finding files
29+ , Piece (..)
17 , Pieces
30 , Pieces
18 , pathFromPieces
31 , pathFromPieces
19− -- ** File/folder metadata
32+ , unfixPathName
20− , MetaData (..)
21− , mdIsFile
22− , getMetaData
23 -- ** Directory listings
33 -- ** Directory listings
24 , Listing
34 , Listing
25 , defaultListing
35 , defaultListing
26− , defaultDirListing
36+ -- ** Lookup functions
27− -- * WAI application
37+ , fileSystemLookup
28− , staticApp
38+ , embeddedLookup
29− , staticAppPieces
39+ -- ** Embedded
30− -- ** Settings
40+ , Embedded
31− , StaticSettings (..)
41+ , EmbeddedEntry (..)
32− , defaultStaticSettings
42+ , toEmbedded
33− , defaultPublicSettings
43+ -- ** Redirecting
34− , CacheSettings (..)
44+ , defaultMkRedirect
35− -- should be moved to common helper
45+ -- * Other data types
36− , unfixPathName
46+ , File (..)
47+ , MaxAge (..)
37 ) where
48 ) where
38
49
39import qualified Network.Wai as W
50import qualified Network.Wai as W
@@ -46,39 +57,41 @@ import qualified Data.ByteString.Char8 as S8
46import qualified Data.ByteString.Lazy as L
57import qualified Data.ByteString.Lazy as L
47import Data.ByteString.Lazy.Char8 ()
58import Data.ByteString.Lazy.Char8 ()
48import System.PosixCompat.Files (fileSize, getFileStatus, modificationTime)
59import System.PosixCompat.Files (fileSize, getFileStatus, modificationTime)
49−import System.Posix.Types (FileOffset, EpochTime)
60+import System.Posix.Types (EpochTime)
50import Control.Monad.IO.Class (liftIO)
61import Control.Monad.IO.Class (liftIO)
51−import Data.Maybe (catMaybes, isNothing, isJust)
62+import qualified Crypto.Hash.MD5 as MD5
63+import Control.Monad (filterM)
52
64
53import Text.Blaze ((!))
65import Text.Blaze ((!))
54import qualified Text.Blaze.Html5 as H
66import qualified Text.Blaze.Html5 as H
55import qualified Text.Blaze.Renderer.Utf8 as HU
67import qualified Text.Blaze.Renderer.Utf8 as HU
56import qualified Text.Blaze.Html5.Attributes as A
68import qualified Text.Blaze.Html5.Attributes as A
57
69
58−import Blaze.ByteString.Builder (toByteString, copyByteString)
70+import Blaze.ByteString.Builder (toByteString, fromByteString)
59−import Data.Monoid (mappend)
60
71
61import Data.Time
72import Data.Time
62import Data.Time.Clock.POSIX
73import Data.Time.Clock.POSIX
63import System.Locale (defaultTimeLocale)
74import System.Locale (defaultTimeLocale)
64
75
65−import Data.List (sortBy)
66import Data.FileEmbed (embedFile)
76import Data.FileEmbed (embedFile)
67
77
68import qualified Data.Text as T
78import qualified Data.Text as T
69import qualified Data.Text.Encoding as TE
79import qualified Data.Text.Encoding as TE
70import qualified Data.Text.Encoding.Error as TEE
80import qualified Data.Text.Encoding.Error as TEE
71
81
72−#ifdef PRINT
82+import Control.Arrow ((&&&), second)
83+import Data.List (groupBy, sortBy, find)
84+import Data.Function (on)
85+import Data.Ord (comparing)
86+import qualified Data.ByteString.Base64 as B64
87+import Data.Either (rights)
88+import Data.Maybe (isJust, fromJust)
89+
90+{-
73import Debug.Trace
91import Debug.Trace
74debug :: (Show a) => a -> a
92debug :: (Show a) => a -> a
75debug a = trace ("DEBUG: " ++ show a) a
93debug a = trace ("DEBUG: " ++ show a) a
76−#else
94+-}
77−trace :: String -> a -> a
78−trace _ x = x
79−debug :: a -> a
80−debug = id
81−#endif
82
95
83-- | A list of all possible extensions, starting from the largest.
96-- | A list of all possible extensions, starting from the largest.
84takeExtensions :: FilePath -> [String]
97takeExtensions :: FilePath -> [String]
@@ -152,6 +165,7 @@ defaultMimeTypes = Map.fromList [
152 ( "wma" , "audio/x-ms-wma" ),
165 ( "wma" , "audio/x-ms-wma" ),
153 ( "wmv" , "video/x-ms-wmv" ),
166 ( "wmv" , "video/x-ms-wmv" ),
154 ( "xbm" , "image/x-xbitmap" ),
167 ( "xbm" , "image/x-xbitmap" ),
168+ ( "xhtml" , "application/xhtml+xml" ),
155 ( "xml" , "text/xml" ),
169 ( "xml" , "text/xml" ),
156 ( "xpm" , "image/x-xpixmap" ),
170 ( "xpm" , "image/x-xpixmap" ),
157 ( "xwd" , "image/x-xwindowdump" ),
171 ( "xwd" , "image/x-xwindowdump" ),
@@ -173,16 +187,16 @@ mimeTypeByExt mm def =
173defaultMimeTypeByExt :: FilePath -> MimeType
187defaultMimeTypeByExt :: FilePath -> MimeType
174defaultMimeTypeByExt = mimeTypeByExt defaultMimeTypes defaultMimeType
188defaultMimeTypeByExt = mimeTypeByExt defaultMimeTypes defaultMimeType
175
189
176−data CheckPieces
190+data CheckPieces =
191+ -- | Just the etag hash or Nothing for no etag hash
177− = Redirect Pieces
192+ Redirect Pieces (Maybe ByteString)
178 | Forbidden
193 | Forbidden
179 | NotFound
194 | NotFound
180− | FileResponse FilePath
195+ | FileResponse File H.ResponseHeaders
181 | NotModified
196 | NotModified
182− | DirectoryResponse FilePath
197+ | DirectoryResponse Folder
183 -- TODO: add file size
198 -- TODO: add file size
184 | SendContent MimeType L.ByteString
199 | SendContent MimeType L.ByteString
185− deriving Show
186
200
187safeInit :: [a] -> [a]
201safeInit :: [a] -> [a]
188safeInit [] = []
202safeInit [] = []
@@ -206,176 +220,362 @@ stripTrailingSlash "/" = ""
206stripTrailingSlash "" = ""
220stripTrailingSlash "" = ""
207stripTrailingSlash (x:xs) = x : stripTrailingSlash xs
221stripTrailingSlash (x:xs) = x : stripTrailingSlash xs
208
222
209−type Pieces = [T.Text]
223+data Piece = Piece
224+ { pieceRaw :: FilePath
225+ , piecePretty :: T.Text
226+ }
227+ deriving (Eq, Ord, Show)
228+type Pieces = [Piece]
229+
210relativeDirFromPieces :: Pieces -> T.Text
230relativeDirFromPieces :: Pieces -> T.Text
211relativeDirFromPieces pieces = T.concat $ map (const "../") (drop 1 pieces) -- last piece is not a dir
231relativeDirFromPieces pieces = T.concat $ map (const "../") (drop 1 pieces) -- last piece is not a dir
212
232
213pathFromPieces :: FilePath -> Pieces -> FilePath
233pathFromPieces :: FilePath -> Pieces -> FilePath
214pathFromPieces prefix pieces =
234pathFromPieces prefix pieces =
215− concat $ prefix : map ((:) '/') (map unfixPathName $ map T.unpack pieces)
235+ concat $ prefix : map ((:) '/') (map pieceRaw pieces)
216−
236+
217−checkPieces :: FilePath -- ^ static file prefix
237+checkSpecialDirListing :: Pieces -> Maybe CheckPieces
238+checkSpecialDirListing [Piece _ ".hidden", Piece _ "folder.png"] =
239+ Just $ SendContent "image/png" $ L.fromChunks [$(embedFile "folder.png")]
240+checkSpecialDirListing [Piece _ ".hidden", Piece _ "haskell.png"] =
241+ Just $ SendContent "image/png" $ L.fromChunks [$(embedFile "haskell.png")]
242+checkSpecialDirListing _ = Nothing
243+
244+checkPieces :: (Pieces -> IO FileLookup) -- ^ file lookup function
218− -> [FilePath] -- ^ List of default index files. Cannot contain slashes.
245+ -> [T.Text] -- ^ List of default index files. Cannot contain slashes.
219− -> Pieces -- ^ parsed request
246+ -> Pieces -- ^ parsed request
220− -> CacheSettings
221 -> W.Request
247 -> W.Request
248+ -> MaxAge
222 -> IO CheckPieces
249 -> IO CheckPieces
223−checkPieces _ _ [".hidden", "folder.png"] _ _ =
250+checkPieces fileLookup indices pieces req maxAge
224− return $ SendContent "image/png" $ L.fromChunks [$(embedFile "folder.png")]
225−checkPieces _ _ [".hidden", "haskell.png"] _ _ =
226− return $ SendContent "image/png" $ L.fromChunks [$(embedFile "haskell.png")]
227−checkPieces prefix indices pieces cache req
228− | any unsafe pieces = return Forbidden
251+ | any (unsafe . piecePretty) pieces = return Forbidden
229− | any T.null $ safeInit pieces =
252+ | any (T.null . piecePretty) $ safeInit pieces =
230− return $ Redirect $ filterButLast (not . T.null) pieces
253+ return $ Redirect (filterButLast (not . T.null . piecePretty) pieces) Nothing
231 | otherwise = do
254 | otherwise = do
232− let fp = pathFromPieces prefix pieces
233 let (isFile, isFolder) =
255 let (isFile, isFolder) =
234 case () of
256 case () of
235 ()
257 ()
236 | null pieces -> (True, True)
258 | null pieces -> (True, True)
237− | T.null (last pieces) -> (False, True)
259+ | T.null $ piecePretty (last pieces) -> (False, True)
238 | otherwise -> (True, False)
260 | otherwise -> (True, False)
239
261
240− if not isFile then uncached fp isFile isFolder
262+ fl <- fileLookup pieces
241− else
263+ case (fl, isFile) of
242− case cache of
264+ (Nothing, _) -> return NotFound
243− ETag ioLookup -> do
265+ (Just (Right file), True) -> handleCache file
244− -- No support for If-Match
266+ (Just Right{}, False) -> return $ Redirect (init pieces) Nothing
245− let mlastEtag = lookup "If-None-Match" (W.requestHeaders req)
267+ (Just (Left folder@(Folder _ contents)), _) -> do
246− metag <- ioLookup fp
268+ case checkIndices $ map fileName $ rights contents of
247− case debug (metag, mlastEtag) of
269+ Just index -> return $ Redirect (setLast pieces $ Piece (T.unpack index) index) Nothing
248− (Just hash, Just lastHash) | hash == lastHash -> return NotModified
270+ Nothing ->
249− _ -> trace "ETAG: no cache match" uncached fp isFile isFolder
271+ if isFolder
250− Forever isStaticFile ->
272+ then return $ DirectoryResponse folder
251− if isStaticFile fp (S8.drop 1 $ W.rawQueryString req) &&
273+ else return $ Redirect (pieces ++ [Piece "" ""]) Nothing
252− (isJust $ lookup "If-Modified-Since" (W.requestHeaders req)) &&
253− (isNothing $ lookup "If-Unmodified-Since" (W.requestHeaders req))
254− then return NotModified
255− else trace "Static: no cache match" uncached fp isFile isFolder
256− NoCache -> trace "NoCache" uncached fp isFile isFolder
257−
258−
259 where
274 where
260− uncached fp isFile isFolder = do
275+ headers = W.requestHeaders req
261− fe <- doesFileExist $ stripTrailingSlash fp
276+ queryString = W.queryString req
262− case (fe, isFile) of
277+
278+ -- HTTP caching has a cache control header that you can set an expire time for a resource.
279+ -- Max-Age is easiest because it is a simple number
280+ -- a cache-control asset will only be downloaded once (if the browser maintains its cache)
281+ -- and the server will never be contacted for the resource again (until it expires)
282+ --
283+ -- A second caching mechanism is ETag and last-modified
284+ -- this form of caching is not as good as the static- the browser can avoid downloading the file, but it always need to send a request with the etag value or the last-modified value to the server to see if its copy is up to date
285+ --
286+ -- We should set a cache control and one of ETag or last-modifed whenever possible
287+ --
288+ -- In a Yesod web application we can append an etag parameter to static assets.
289+ -- This signals that both a max-age and ETag header should be set
290+ -- if there is no etag parameter
291+ -- * don't set the max-age
292+ -- * set ETag or last-modified
293+ -- * ETag must be calculated ahead of time.
294+ -- * last-modified is just the file mtime.
295+ handleCache file = do
296+ let mGetHash = fileGetHash file
297+ let etagParam = lookup "etag" queryString
298+
299+ case (etagParam, mGetHash) of
300+ (Just mEtag, Just getHash) -> do
301+ hash <- getHash
302+ if isJust mEtag && hash == fromJust mEtag
263− (True, True) -> return $ FileResponse fp
303+ then return $ FileResponse file $ ("ETag", hash):cacheControl
264− (True, False) -> return $ Redirect $ init pieces
304+ else return $ Redirect pieces (Just hash)
265− (False, _) -> do
305+ -- a file used to have an etag parameter, but no longer does
266− de <- doesDirectoryExist fp
306+ (Just _, Nothing) -> return $ Redirect pieces Nothing
267− if not de
307+
308+ _ ->
309+ case (lookup "if-none-match" headers, mGetHash) of
310+ -- etag
311+ (Just lastHash, Just getHash) -> do
312+ hash <- getHash
313+ if hash == lastHash
268− then return NotFound
314+ then return NotModified
269− else do
315+ else return $ FileResponse file $ [("ETag", hash)]
270− x <- checkIndices fp indices
316+ _ ->
271− case x of
317+ case (lookup "if-modified-since" headers >>= parseModifiedDate, fileGetModified file) of
272− Just index -> return $ Redirect $ setLast pieces (T.pack index)
318+ -- last-modified
273− Nothing ->
319+ (Just lastSent, Just modified) -> do
274− if isFolder
320+ if lastSent >= modified
275− then return $ DirectoryResponse fp
321+ then return NotModified
276− else return $ Redirect $ pieces ++ [""]
322+ else respond file
277−
323+ _ -> respond file
324+
325+ respond file = do
326+ mhash <- maybe (return Nothing) (fmap Just) $ fileGetHash file
327+ return $ FileResponse file $
328+ case mhash of
329+ Just h -> [("ETag", h)]
330+ Nothing -> []
331+
332+ setLast :: Pieces -> Piece -> Pieces
278 setLast [] x = [x]
333 setLast [] x = [x]
279− setLast [""] x = [x]
334+ setLast [Piece "" ""] x = [x]
280 setLast (a:b) x = a : setLast b x
335 setLast (a:b) x = a : setLast b x
281− checkIndices _ [] = return Nothing
282− checkIndices fp (i:is) = do
283− let fp' = fp ++ '/' : i
284− fe <- doesFileExist fp'
285− if fe
286− then return $ Just i
287− else checkIndices fp is
288
336
289−type Listing = (Pieces -> FilePath -> IO L.ByteString)
337+ checkIndices :: [T.Text] -> Maybe T.Text
338+ checkIndices contents = find (flip elem indices) contents
290
339
291−data StaticDirListing = ListingForbidden | StaticDirListing {
340+ cacheControl = case ccInt of
292− ssListing :: Listing
341+ Nothing -> []
293− , ssIndices :: [FilePath]
342+ Just i -> [("Cache-Control", S8.append "max-age=" $ S8.pack $ show i)]
294−}
343+ where
344+ ccInt =
345+ case maxAge of
346+ NoMaxAge -> Nothing
347+ MaxAgeSeconds i -> Just i
348+ MaxAgeForever -> Just oneYear
349+ oneYear :: Int
350+ oneYear = 60 * 60 * 24 * 365
295
351
296−defaultDirListing :: StaticDirListing
352+type Listing = (Pieces -> Folder -> IO L.ByteString)
297−defaultDirListing = StaticDirListing defaultListing []
298
353
299−-- IO is for development mode
300−type CheckHashParam = (FilePath -> S8.ByteString -> Bool)
301−data CacheSettings = NoCache | Forever CheckHashParam | ETag (FilePath -> IO (Maybe S8.ByteString))
302
354
303−oneYear :: Int
355+type FileLookup = Maybe (Either Folder File)
304−oneYear = 60 * 60 * 24 * 365
356+
357+data Folder = Folder
358+ { folderName :: T.Text
359+ , folderContents :: [Either Folder File]
360+ }
361+
362+data File = File
363+ { fileGetSize :: Int
364+ , fileToResponse :: H.Status -> H.ResponseHeaders -> W.Response
365+ , fileName :: T.Text
366+ , fileGetHash :: Maybe (IO ByteString)
367+ , fileGetModified :: Maybe EpochTime
368+ }
369+
370+parseModifiedDate :: ByteString -> Maybe EpochTime
371+parseModifiedDate =
372+ fmap (fromIntegral . fromEnum . utcTimeToPOSIXSeconds) . parseTime defaultTimeLocale format . S8.unpack
373+ where
374+ format = "%a, %d %b %Y %X %Z"
305
375
306data StaticSettings = StaticSettings
376data StaticSettings = StaticSettings
307− { ssFolder :: FilePath
377+ { ssFolder :: Pieces -> IO FileLookup
308− , ssMkRedirect :: Pieces -> ByteString -> S8.ByteString
378+ , ssMkRedirect :: Pieces -> ByteString -> ByteString
309− , ssGetMimeType :: FilePath -> IO MimeType
379+ , ssGetMimeType :: File -> IO MimeType
310− , ssDirListing :: StaticDirListing
380+ , ssListing :: Maybe Listing
311− , ssCacheSettings :: CacheSettings
381+ , ssIndices :: [T.Text] -- index.html
382+ , ssMaxAge :: MaxAge
312 }
383 }
313
384
385+data MaxAge = NoMaxAge | MaxAgeSeconds Int | MaxAgeForever
386+
314defaultMkRedirect :: Pieces -> ByteString -> S8.ByteString
387defaultMkRedirect :: Pieces -> ByteString -> S8.ByteString
315−defaultMkRedirect pieces newPath =
388+defaultMkRedirect pieces newPath
316− let relDir = TE.encodeUtf8 (relativeDirFromPieces pieces) in
389+ | S8.null newPath || S8.null relDir ||
317− S8.append relDir (if (S8.last relDir) == '/' && (S8.head newPath) == '/'
390+ S8.last relDir /= '/' || S8.head newPath /= '/' =
391+ relDir `S8.append` newPath
318− then S8.tail newPath
392+ | otherwise = relDir `S8.append` S8.tail newPath
319− else newPath)
393+ where
320−
394+ relDir = TE.encodeUtf8 (relativeDirFromPieces pieces)
321−defaultStaticSettings :: CacheSettings -> StaticSettings
395+
322−defaultStaticSettings isStaticFile = StaticSettings { ssFolder = "static"
396+defaultWebAppSettings :: StaticSettings
397+defaultWebAppSettings = StaticSettings
398+ { ssFolder = fileSystemLookup "static"
323− , ssMkRedirect = defaultMkRedirect
399+ , ssMkRedirect = defaultMkRedirect
324− , ssGetMimeType = return . defaultMimeTypeByExt
400+ , ssGetMimeType = return . defaultMimeTypeByExt . T.unpack . fileName
325− , ssDirListing = defaultDirListing
401+ , ssMaxAge = MaxAgeForever
326− , ssCacheSettings = isStaticFile
402+ , ssListing = Nothing
403+ , ssIndices = []
327−}
404+ }
328−defaultPublicSettings :: CacheSettings -> StaticSettings
405+
329−defaultPublicSettings etags = StaticSettings { ssFolder = "public"
406+defaultFileServerSettings :: StaticSettings
407+defaultFileServerSettings = StaticSettings
408+ { ssFolder = fileSystemLookup "static"
330− , ssMkRedirect = defaultMkRedirect
409+ , ssMkRedirect = defaultMkRedirect
331− , ssGetMimeType = return . defaultMimeTypeByExt
410+ , ssGetMimeType = return . defaultMimeTypeByExt . T.unpack . fileName
332− , ssDirListing = ListingForbidden
411+ , ssMaxAge = MaxAgeSeconds $ 60 * 60
333− , ssCacheSettings = etags
412+ , ssListing = Just defaultListing
413+ , ssIndices = ["index.html", "index.htm"]
334−}
414+ }
335
415
416+fileHelper :: FilePath -> T.Text -> IO File
417+fileHelper fp name = do
418+ fs <- getFileStatus fp
419+ return File
420+ { fileGetSize = fromIntegral $ fileSize fs
421+ , fileToResponse = \s h -> W.ResponseFile s h fp Nothing
422+ , fileName = name
423+ , fileGetHash = Just $ do
424+ -- FIXME replace lazy IO with enumerators
425+ -- FIXME let's use a dictionary to cache these values?
426+ l <- L.readFile fp
427+ return $ runHashL l
428+ , fileGetModified = Just $ modificationTime fs
429+ }
430+
431+fileSystemLookup :: FilePath -> Pieces -> IO FileLookup
432+fileSystemLookup prefix pieces = do
433+ let fp = pathFromPieces prefix pieces
434+ fe <- doesFileExist fp
435+ if fe
436+ then fmap (Just . Right) $ fileHelper fp (piecePretty $ last pieces)
437+ else do
438+ de <- doesDirectoryExist fp
439+ if de
440+ then do
441+ let isVisible ('.':_) = return False
442+ isVisible "" = return False
443+ isVisible _ = return True
444+ entries <- getDirectoryContents fp >>= filterM isVisible >>= (mapM $ \name -> do
445+ let name' = T.pack $ fixPathName name
446+ let fp' = fp ++ '/' : name
447+ fe' <- doesFileExist fp'
448+ if fe'
449+ then fmap Right $ fileHelper fp' name'
450+ else return $ Left $ Folder name' [])
451+ return $ Just $ Left $ Folder (error "413") entries
452+ else return Nothing
453+
454+type Embedded = Map.Map T.Text EmbeddedEntry
455+
456+data EmbeddedEntry = EEFile S8.ByteString | EEFolder Embedded
457+
458+embeddedLookup :: Embedded -> Pieces -> IO FileLookup
459+embeddedLookup root pieces =
460+ return $ elookup "<root>" (map piecePretty pieces) root
461+ where
462+ elookup :: T.Text -> [T.Text] -> Embedded -> FileLookup
463+ elookup p [] x = Just $ Left $ Folder p $ map toEntry $ Map.toList x
464+ elookup p [""] x = elookup p [] x
465+ elookup _ (p:ps) x =
466+ case Map.lookup p x of
467+ Nothing -> Nothing
468+ Just (EEFile f) ->
469+ case ps of
470+ [] -> Just $ Right $ bsToFile p f
471+ _ -> Nothing
472+ Just (EEFolder y) -> elookup p ps y
473+
474+toEntry :: (T.Text, EmbeddedEntry) -> Either Folder File
475+toEntry (name, EEFolder{}) = Left $ Folder name []
476+toEntry (name, EEFile bs) = Right $ File
477+ { fileGetSize = S8.length bs
478+ , fileToResponse = \s h -> W.ResponseBuilder s h $ fromByteString bs
479+ , fileName = name
480+ , fileGetHash = Just $ return $ runHash bs
481+ , fileGetModified = Nothing
482+ }
483+
484+toEmbedded :: [(FilePath, S8.ByteString)] -> Embedded
485+toEmbedded fps =
486+ go texts
487+ where
488+ texts = map (\(x, y) -> (filter (not . T.null) $ toPieces x, y)) fps
489+ toPiece fp = T.pack $ fixPathName fp
490+ toPieces "" = []
491+ toPieces x =
492+ let (y, z) = break (== '/') x
493+ in toPiece y : toPieces (drop 1 z)
494+ go :: [([T.Text], S8.ByteString)] -> Embedded
495+ go orig =
496+ Map.fromList $ map (second go') hoisted
497+ where
498+ next = map (\(x, y) -> (head x, (tail x, y))) orig
499+ grouped :: [[(T.Text, ([T.Text], S8.ByteString))]]
500+ grouped = groupBy ((==) `on` fst) $ sortBy (comparing fst) next
501+ hoisted :: [(T.Text, [([T.Text], S8.ByteString)])]
502+ hoisted = map (fst . head &&& map snd) grouped
503+ go' :: [([T.Text], S8.ByteString)] -> EmbeddedEntry
504+ go' [([], content)] = EEFile content
505+ go' x = EEFolder $ go $ filter (\y -> not $ null $ fst y) x
506+
507+bsToFile :: T.Text -> S8.ByteString -> File
508+bsToFile name bs = File
509+ { fileGetSize = S8.length bs
510+ , fileToResponse = \s h -> W.ResponseBuilder s h $ fromByteString bs
511+ , fileName = name
512+ , fileGetHash = Just $ return $ runHash bs
513+ , fileGetModified = Nothing
514+ }
515+
516+runHash :: S8.ByteString -> S8.ByteString
517+runHash = B64.encode . MD5.hash
518+
519+runHashL :: L.ByteString -> ByteString
520+runHashL = B64.encode . MD5.hashlazy
336
521
337staticApp :: StaticSettings -> W.Application
522staticApp :: StaticSettings -> W.Application
338−staticApp set req = do
523+staticApp set req =
339− let pieces = W.pathInfo req
524+ staticAppPieces set (map toPiece $ W.pathInfo req) req
340− staticAppPieces set pieces req
525+ where
526+ toPiece t = Piece
527+ { piecePretty = t
528+ , pieceRaw = unfixPathName $ T.unpack t
529+ }
341
530
342status304, statusNotModified :: H.Status
531status304, statusNotModified :: H.Status
343status304 = H.Status 304 "Not Modified"
532status304 = H.Status 304 "Not Modified"
344statusNotModified = status304
533statusNotModified = status304
345
534
535+-- alist helper functions
536+replace :: Eq a => a -> b -> [(a, b)] -> [(a, b)]
537+replace k v [] = [(k,v)]
538+replace k v (x:xs) | fst x == k = (k,v):xs
539+ | otherwise = x:replace k v xs
540+
541+remove :: Eq a => a -> [(a, b)] -> [(a, b)]
542+remove _ [] = []
543+remove k (x:xs) | fst x == k = xs
544+ | otherwise = x:remove k xs
545+
546+
346staticAppPieces :: StaticSettings -> Pieces -> W.Application
547staticAppPieces :: StaticSettings -> Pieces -> W.Application
347staticAppPieces _ _ req
548staticAppPieces _ _ req
348 | W.requestMethod req /= "GET" = return $ W.responseLBS
549 | W.requestMethod req /= "GET" = return $ W.responseLBS
349 H.status405
550 H.status405
350 [("Content-Type", "text/plain")]
551 [("Content-Type", "text/plain")]
351 "Only GET is supported"
552 "Only GET is supported"
352−staticAppPieces ss@StaticSettings{} pieces req = liftIO $ do
553+staticAppPieces ss pieces req = liftIO $ do
353− let cache = ssCacheSettings ss
554+ let indices = ssIndices ss
354− let indices = case ssDirListing ss of
555+ case checkSpecialDirListing pieces of
355− StaticDirListing _ is -> is
556+ Just res -> response res
356− ListingForbidden -> []
357− cp <- checkPieces (ssFolder ss) indices pieces cache req
557+ Nothing -> checkPieces (ssFolder ss) indices pieces req (ssMaxAge ss) >>= response
558+ where
358− case cp of
559+ response cp = case cp of
359− FileResponse fp -> do
560+ FileResponse file ch -> do
360− mimetype <- (ssGetMimeType ss) fp
561+ mimetype <- ssGetMimeType ss file
361− filesize <- fileSize `fmap` getFileStatus fp
562+ let filesize = fileGetSize file
362− ch <- setCacheHeaders cache fp
363− return $ W.ResponseFile H.status200
364− ( [ ("Content-Type", mimetype)
563+ let headers = ("Content-Type", mimetype)
365− , ("Content-Length", S8.pack $ show filesize)
564+ : ("Content-Length", S8.pack $ show filesize)
366− ] ++ ch ) fp Nothing
565+ : ch
566+ return $ fileToResponse file H.status200 headers
367 NotModified ->
567 NotModified ->
368 return $ W.responseLBS statusNotModified
568 return $ W.responseLBS statusNotModified
369 [ ("Content-Type", "text/plain")
569 [ ("Content-Type", "text/plain")
370 ] "Not Modified"
570 ] "Not Modified"
371 DirectoryResponse fp ->
571 DirectoryResponse fp ->
372− case ssDirListing ss of
572+ case ssListing ss of
373− StaticDirListing f _ -> do
573+ (Just f) -> do
374 lbs <- f pieces fp
574 lbs <- f pieces fp
375 return $ W.responseLBS H.status200
575 return $ W.responseLBS H.status200
376 [ ("Content-Type", "text/html; charset=utf-8")
576 [ ("Content-Type", "text/html; charset=utf-8")
377 ] lbs
577 ] lbs
378− ListingForbidden -> return $ W.responseLBS H.status403
578+ Nothing -> return $ W.responseLBS H.status403
379 [ ("Content-Type", "text/plain")
579 [ ("Content-Type", "text/plain")
380 ] "Directory listings disabled"
580 ] "Directory listings disabled"
381 SendContent mt lbs -> do
581 SendContent mt lbs -> do
@@ -384,18 +584,16 @@ staticAppPieces ss@StaticSettings{} pieces req = liftIO $ do
384 [ ("Content-Type", mt)
584 [ ("Content-Type", mt)
385 -- TODO: set Content-Length
585 -- TODO: set Content-Length
386 ] lbs
586 ] lbs
587+
387− Redirect pieces' -> do
588+ Redirect pieces' mHash -> do
388− let loc = (ssMkRedirect ss) pieces' $ toByteString (H.encodePathSegments pieces')
589+ let loc = (ssMkRedirect ss) pieces' $ toByteString (H.encodePathSegments $ map piecePretty pieces')
389−
590+ let qString = case mHash of
390− let loc' =
591+ Just hash -> replace "etag" (Just hash) (W.queryString req)
391− -- relativeDirFromPieces pieces = T.concat $ map (const "../") (drop 1 pieces) -- last piece is not a dir
592+ Nothing -> remove "etag" (W.queryString req)
392− -- (ssMkRedirect ss) pieces' $ encodePathInfo pieces' []
593+
393− toByteString $
394− foldr mappend (H.encodePathSegments pieces') -- FIXME use Text
395− $ map (const $ copyByteString "../") $ drop 1 pieces
396 return $ W.responseLBS H.status301
594 return $ W.responseLBS H.status301
397 [ ("Content-Type", "text/plain")
595 [ ("Content-Type", "text/plain")
398− , ("Location", loc)
596+ , ("Location", S8.append loc $ H.renderQuery True qString)
399 ] "Redirect"
597 ] "Redirect"
400 Forbidden -> return $ W.responseLBS H.status403
598 Forbidden -> return $ W.responseLBS H.status403
401 [ ("Content-Type", "text/plain")
599 [ ("Content-Type", "text/plain")
@@ -403,19 +601,6 @@ staticAppPieces ss@StaticSettings{} pieces req = liftIO $ do
403 NotFound -> return $ W.responseLBS H.status404
601 NotFound -> return $ W.responseLBS H.status404
404 [ ("Content-Type", "text/plain")
602 [ ("Content-Type", "text/plain")
405 ] "File not found"
603 ] "File not found"
406− where
407− -- expires header: formatTime "%a, %d-%b-%Y %X GMT"
408− setCacheHeaders :: CacheSettings -> FilePath -> IO H.ResponseHeaders
409− setCacheHeaders (Forever isStaticFile) fp = return $
410− if isStaticFile fp (S8.drop 1 $ W.rawQueryString req)
411− then [("Cache-Control", S8.append "max-age=" $ S8.pack $ show oneYear)]
412− else []
413− setCacheHeaders NoCache _ = return []
414− setCacheHeaders (ETag ioLookup) fp = do
415− etag <- ioLookup fp
416− return $ case etag of
417− Just hash -> [("ETag", hash)]
418− Nothing -> []
419
604
420{-
605{-
421The problem is that the System.Directory functions are a lie: they
606The problem is that the System.Directory functions are a lie: they
@@ -443,18 +628,17 @@ unfixPathName = S8.unpack . TE.encodeUtf8 . T.pack
443
628
444-- Code below taken from Happstack: http://patch-tag.com/r/mae/happstack/snapshot/current/content/pretty/happstack-server/src/Happstack/Server/FileServe/BuildingBlocks.hs
629-- Code below taken from Happstack: http://patch-tag.com/r/mae/happstack/snapshot/current/content/pretty/happstack-server/src/Happstack/Server/FileServe/BuildingBlocks.hs
445defaultListing :: Listing
630defaultListing :: Listing
446−defaultListing pieces localPath = do
631+defaultListing pieces (Folder _ contents) = do
447− fps <- getDirectoryContents localPath
448− fps' <- mapM (getMetaData localPath) fps
449− let isTop = null pieces || pieces == [""]
632+ let isTop = null pieces || pieces == [Piece "" ""]
450− let fps'' = if isTop then fps' else Just (FolderMetaData "..") : fps'
633+ let fps'' :: [Either Folder File]
634+ fps'' = (if isTop then id else (Left (Folder ".." []) :)) contents
451 return $ HU.renderHtml
635 return $ HU.renderHtml
452 $ H.html $ do
636 $ H.html $ do
453 H.head $ do
637 H.head $ do
454− let title = T.unpack $ T.intercalate "/" pieces
638+ let title = T.unpack $ T.intercalate "/" $ map piecePretty pieces
455 let title' = if null title then "root folder" else title
639 let title' = if null title then "root folder" else title
456− H.title $ H.string title'
640+ H.title $ H.toHtml title'
457− H.style $ H.string $ unlines [ "table { margin: 0 auto; width: 760px; border-collapse: collapse; font-family: 'sans-serif'; }"
641+ H.style $ H.toHtml $ unlines [ "table { margin: 0 auto; width: 760px; border-collapse: collapse; font-family: 'sans-serif'; }"
458 , "table, th, td { border: 1px solid #353948; }"
642 , "table, th, td { border: 1px solid #353948; }"
459 , "td.size { text-align: right; font-size: 0.7em; width: 50px }"
643 , "td.size { text-align: right; font-size: 0.7em; width: 50px }"
460 , "td.date { text-align: right; font-size: 0.7em; width: 130px }"
644 , "td.date { text-align: right; font-size: 0.7em; width: 130px }"
@@ -469,20 +653,20 @@ defaultListing pieces localPath = do
469 , "a { text-decoration: none }"
653 , "a { text-decoration: none }"
470 ]
654 ]
471 H.body $ do
655 H.body $ do
472− H.h1 $ showFolder $ map T.unpack $ filter (not . T.null) pieces
656+ H.h1 $ showFolder $ map piecePretty $ filter (not . T.null . piecePretty) pieces
473− renderDirectoryContentsTable haskellSrc folderSrc $ catMaybes fps''
657+ renderDirectoryContentsTable haskellSrc folderSrc fps''
474 where
658 where
475 image x = T.unpack $ T.concat [(relativeDirFromPieces pieces), ".hidden/", x, ".png"]
659 image x = T.unpack $ T.concat [(relativeDirFromPieces pieces), ".hidden/", x, ".png"]
476 folderSrc = image "folder"
660 folderSrc = image "folder"
477 haskellSrc = image "haskell"
661 haskellSrc = image "haskell"
478 showName "" = "root"
662 showName "" = "root"
479 showName x = x
663 showName x = x
480− showFolder [] = H.string "error: Unexpected showFolder []"
664+ showFolder [] = "/"
481− showFolder [x] = H.string $ showName x
665+ showFolder [x] = H.toHtml $ showName x
482 showFolder (x:xs) = do
666 showFolder (x:xs) = do
483− let href = concat $ replicate (length xs) "../"
667+ let href = concat $ replicate (length xs) "../" :: String
484− H.a ! A.href (H.stringValue href) $ H.string $ showName x
668+ H.a ! A.href (H.toValue href) $ H.toHtml $ showName x
485− H.string " / "
669+ () <- " / "
486 showFolder xs
670 showFolder xs
487
671
488-- | a function to generate an HTML table showing the contents of a directory on the disk
672-- | a function to generate an HTML table showing the contents of a directory on the disk
@@ -495,36 +679,41 @@ defaultListing pieces localPath = do
495-- see also: 'getMetaData', 'renderDirectoryContents'
679-- see also: 'getMetaData', 'renderDirectoryContents'
496renderDirectoryContentsTable :: String
680renderDirectoryContentsTable :: String
497 -> String
681 -> String
498− -> [MetaData] -- ^ list of files+meta data, see 'getMetaData'
682+ -> [Either Folder File]
499 -> H.Html
683 -> H.Html
500renderDirectoryContentsTable haskellSrc folderSrc fps =
684renderDirectoryContentsTable haskellSrc folderSrc fps =
501− H.table $ do H.thead $ do H.th ! (A.class_ $ H.stringValue "first") $ H.img ! (A.src $ H.stringValue haskellSrc)
685+ H.table $ do H.thead $ do H.th ! (A.class_ "first") $ H.img ! (A.src $ H.toValue haskellSrc)
502− H.th $ H.string "Name"
686+ H.th "Name"
503− H.th $ H.string "Modified"
687+ H.th "Modified"
504− H.th $ H.string "Size"
688+ H.th "Size"
505 H.tbody $ mapM_ mkRow (zip (sortBy sortMD fps) $ cycle [False, True])
689 H.tbody $ mapM_ mkRow (zip (sortBy sortMD fps) $ cycle [False, True])
506 where
690 where
507− sortMD FolderMetaData{} FileMetaData{} = LT
691+ sortMD :: Either Folder File -> Either Folder File -> Ordering
508− sortMD FileMetaData{} FolderMetaData{} = GT
692+ sortMD Left{} Right{} = LT
509− sortMD x y = mdName x `compare` mdName y
693+ sortMD Right{} Left{} = GT
694+ sortMD (Left a) (Left b) = compare (folderName a) (folderName b)
695+ sortMD (Right a) (Right b) = compare (fileName a) (fileName b)
510− mkRow :: (MetaData, Bool) -> H.Html
696+ mkRow :: (Either Folder File, Bool) -> H.Html
511 mkRow (md, alt) =
697 mkRow (md, alt) =
512− (if alt then (! A.class_ (H.stringValue "alt")) else id) $
698+ (if alt then (! A.class_ "alt") else id) $
513 H.tr $ do
699 H.tr $ do
514− H.td ! A.class_ (H.stringValue "first")
700+ H.td ! A.class_ "first"
515− $ if mdIsFile md
701+ $ case md of
516− then return ()
517− else H.img ! A.src (H.stringValue folderSrc)
702+ Left{} -> H.img ! A.src (H.toValue folderSrc)
518− ! A.alt (H.stringValue "Folder")
703+ ! A.alt "Folder"
519− H.td (H.a ! A.href (H.stringValue $ mdName' md ++ if mdIsFile md then "" else "/") $ H.string $ mdName' md)
704+ Right{} -> return ()
705+ let name = either folderName fileName md
706+ let isFile = either (const False) (const True) md
707+ H.td (H.a ! A.href (H.toValue $ name `T.append` if isFile then "" else "/") $ H.toHtml name)
520− H.td ! A.class_ (H.stringValue "date") $ H.string $
708+ H.td ! A.class_ "date" $ H.toHtml $
521− if mdIsFile md
709+ case md of
710+ Right File { fileGetModified = Just t } ->
522− then formatCalendarTime defaultTimeLocale "%d-%b-%Y %X" $ mdModified md
711+ formatCalendarTime defaultTimeLocale "%d-%b-%Y %X" t
523− else ""
712+ _ -> ""
524− H.td ! A.class_ (H.stringValue "size") $ H.string $
713+ H.td ! A.class_ "size" $ H.toHtml $
525− if mdIsFile md
714+ case md of
526− then prettyShow $ mdSize md
715+ Right File { fileGetSize = s } -> prettyShow s
527− else ""
716+ Left{} -> ""
528 formatCalendarTime a b c = formatTime a b $ posixSecondsToUTCTime (realToFrac c :: POSIXTime)
717 formatCalendarTime a b c = formatTime a b $ posixSecondsToUTCTime (realToFrac c :: POSIXTime)
529 prettyShow x
718 prettyShow x
530 | x > 1024 = prettyShowK $ x `div` 1024
719 | x > 1024 = prettyShowK $ x `div` 1024
@@ -540,20 +729,7 @@ renderDirectoryContentsTable haskellSrc folderSrc fps =
540 addCommas' (a:b:c:d:e) = a : b : c : ',' : addCommas' (d : e)
729 addCommas' (a:b:c:d:e) = a : b : c : ',' : addCommas' (d : e)
541 addCommas' x = x
730 addCommas' x = x
542
731
543−mdName' :: MetaData -> FilePath
732+{-
544−mdName' = fixPathName . mdName
545−
546−data MetaData =
547− FileMetaData
548− { mdName :: FilePath
549− , mdModified :: EpochTime
550− , mdSize :: FileOffset
551− }
552− | FolderMetaData
553− { mdName :: FilePath
554− }
555− deriving Show
556−
557mdIsFile :: MetaData -> Bool
733mdIsFile :: MetaData -> Bool
558mdIsFile FileMetaData{} = True
734mdIsFile FileMetaData{} = True
559mdIsFile FolderMetaData{} = False
735mdIsFile FolderMetaData{} = False
@@ -566,12 +742,14 @@ getMetaData _ ('.':_) = return Nothing
566getMetaData localPath fp = do
742getMetaData localPath fp = do
567 let fp' = localPath ++ '/' : fp
743 let fp' = localPath ++ '/' : fp
568 fe <- doesFileExist fp'
744 fe <- doesFileExist fp'
745+ let fpPretty = T.pack $ fixPathName fp
569 if fe
746 if fe
570 then do
747 then do
571 fs <- getFileStatus fp'
748 fs <- getFileStatus fp'
572 let modTime = modificationTime fs
749 let modTime = modificationTime fs
573 let count = fileSize fs
750 let count = fileSize fs
574− return $ Just $ FileMetaData fp modTime count
751+ return $ Just $ FileMetaData fpPretty (Just modTime) count
575 else do
752 else do
576 de <- doesDirectoryExist fp'
753 de <- doesDirectoryExist fp'
577− return $ if de then Just (FolderMetaData fp) else Nothing
754+ return $ if de then Just (FolderMetaData fpPretty) else Nothing
755+-}
embedded-sample.hsnew file+11
@@ -0,0 +1,11 @@
1+{-# LANGUAGE TemplateHaskell #-}
2+import Network.Wai.Application.Static
3+import Network.Wai.Handler.Warp (run)
4+import Data.FileEmbed
5+
6+main :: IO ()
7+main = run 3000 $ staticApp defaultStaticSettings
8+ { ssFolder = embeddedLookup $ toEmbedded $(embedDir ".")
9+ , ssIndices = []
10+ , ssMaxAge = NoMaxAge
11+ }
sample.hsnew file+9
@@ -0,0 +1,9 @@
1+import Network.Wai.Application.Static
2+import Network.Wai.Handler.Warp (run)
3+
4+main :: IO ()
5+main = run 3000 $ staticApp defaultStaticSettings
6+ { ssFolder = fileSystemLookup "."
7+ , ssMaxAge = MaxAgeForever
8+ , ssIndices = []
9+ }
tests/a/bnew file

No changes to the content.

tests/runtests.hs+82−46
@@ -1,21 +1,28 @@
1−{-# LANGUAGE OverloadedStrings #-}
1+{-# LANGUAGE OverloadedStrings, NoMonomorphismRestriction #-}
2import Network.Wai.Application.Static
2import Network.Wai.Application.Static
3
3
4import Test.Hspec.Monadic
4import Test.Hspec.Monadic
5import Test.Hspec.QuickCheck
5import Test.Hspec.QuickCheck
6import Test.Hspec.HUnit ()
6import Test.Hspec.HUnit ()
7−import Test.HUnit ((@?=))
7+import Test.HUnit ((@?=), assert)
8import Distribution.Simple.Utils (isInfixOf)
8import Distribution.Simple.Utils (isInfixOf)
9import qualified Data.ByteString.Char8 as S8
9import qualified Data.ByteString.Char8 as S8
10+import qualified Data.ByteString.Lazy.Char8 as L8
10import qualified Data.Text as T
11import qualified Data.Text as T
11import qualified Data.Text.Encoding as TE
12import qualified Data.Text.Encoding as TE
13+import System.PosixCompat.Files (getFileStatus, modificationTime)
14+import System.IO (stderr, hPutStrLn)
12
15
16+import Network.HTTP.Date
17+{-import System.Locale (defaultTimeLocale)-}
18+{-import Data.Time.Format (formatTime)-}
13
19
14import Network.Wai
20import Network.Wai
15import Network.Wai.Test
21import Network.Wai.Test
16
22
17import Network.Socket.Internal as Sock
23import Network.Socket.Internal as Sock
18import qualified Network.HTTP.Types as H
24import qualified Network.HTTP.Types as H
25+import Control.Monad.IO.Class (liftIO)
19
26
20defRequest :: Request
27defRequest :: Request
21defRequest = Request {
28defRequest = Request {
@@ -29,7 +36,7 @@ defRequest = Request {
29, httpVersion = H.http11
36, httpVersion = H.http11
30, serverPort = 80
37, serverPort = 80
31, isSecure = False
38, isSecure = False
32−, remoteHost = Sock.SockAddrUnix "/dev/null"
39+, remoteHost = Sock.SockAddrInet 1 2
33}
40}
34
41
35setRawPathInfo :: Request -> S8.ByteString -> Request
42setRawPathInfo :: Request -> S8.ByteString -> Request
@@ -37,42 +44,52 @@ setRawPathInfo r rawPinfo =
37 let pInfo = T.split (== '/') $ TE.decodeUtf8 rawPinfo
44 let pInfo = T.split (== '/') $ TE.decodeUtf8 rawPinfo
38 in r { rawPathInfo = rawPinfo, pathInfo = pInfo }
45 in r { rawPathInfo = rawPinfo, pathInfo = pInfo }
39
46
47+
48+-- debug :: String -> m0 ()
49+debug = liftIO . hPutStrLn stderr
50+
40main :: IO a
51main :: IO a
41main = hspecX $ do
52main = hspecX $ do
42− describe "Pieces: pathFromPieces" $ do
53+ let must = liftIO . assert
43− it "converts to a file path" $
44− (pathFromPieces "prefix" ["a", "bc"]) @?= "prefix/a/bc"
45
54
46− prop "each piece is in file path" $ \pieces ->
55+ let webApp = flip runSession $ staticApp defaultWebAppSettings {ssFolder = fileSystemLookup "tests"}
47− let piecesT = (map T.pack pieces) in
56+ let fileServerApp = flip runSession $ staticApp defaultFileServerSettings {ssFolder = fileSystemLookup "tests"}
48− all (\p -> ("/" ++ (unfixPathName $ T.unpack p)) `isInfixOf` (pathFromPieces "root" $ piecesT)) piecesT
49
57
58+ let etag = "1B2M2Y8AsgTpgAmY7PhCfg=="
59+ let file = "a/b"
60+ let statFile = setRawPathInfo defRequest file
50
61
51
62
52− let cacheLookup = Forever (\fp h -> fp == "tests/runtests.hs" && h == "cached")
63+ describe "Pieces: pathFromPieces" $ do
53− let statApp = flip runSession $ staticApp $ (defaultStaticSettings cacheLookup) {ssFolder = "tests"}
64+ it "converts to a file path" $
65+ (pathFromPieces "prefix" [Piece "a" "a", Piece "bc" "bc"]) @?= "prefix/a/bc"
66+
67+ prop "each piece is in file path" $ \piecesS ->
68+ let pieces = map (\p -> Piece p "") piecesS
69+ in all (\p -> ("/" ++ p) `isInfixOf` (pathFromPieces "root" $ pieces)) piecesS
70+
54− describe "staticApp" $ do
71+ describe "webApp" $ do
55− it "403 for unsafe paths" $ statApp $
72+ it "403 for unsafe paths" $ webApp $
56 flip mapM_ ["..", "."] $ \path ->
73 flip mapM_ ["..", "."] $ \path ->
57 assertStatus 403 =<<
74 assertStatus 403 =<<
58 request (setRawPathInfo defRequest path)
75 request (setRawPathInfo defRequest path)
59
76
60− it "200 for hidden paths" $ statApp $
77+ it "200 for hidden paths" $ webApp $
61 flip mapM_ [".hidden/folder.png", ".hidden/haskell.png"] $ \path ->
78 flip mapM_ [".hidden/folder.png", ".hidden/haskell.png"] $ \path ->
62 assertStatus 200 =<<
79 assertStatus 200 =<<
63 request (setRawPathInfo defRequest path)
80 request (setRawPathInfo defRequest path)
64
81
65− it "404 for non-existant files" $ statApp $
82+ it "404 for non-existant files" $ webApp $
66 assertStatus 404 =<<
83 assertStatus 404 =<<
67 request (setRawPathInfo defRequest "doesNotExist")
84 request (setRawPathInfo defRequest "doesNotExist")
68
85
69− it "301 redirect when multiple slashes" $ statApp $ do
86+ it "301 redirect when multiple slashes" $ webApp $ do
70 req <- request (setRawPathInfo defRequest "a//b/c")
87 req <- request (setRawPathInfo defRequest "a//b/c")
71 assertStatus 301 req
88 assertStatus 301 req
72 assertHeader "Location" "../../a/b/c" req
89 assertHeader "Location" "../../a/b/c" req
73
90
74− let absoluteApp = flip runSession $ staticApp $ (defaultStaticSettings cacheLookup) {
91+ let absoluteApp = flip runSession $ staticApp $ defaultWebAppSettings {
75− ssFolder = "tests", ssMkRedirect = \_ u -> S8.append "http://www.example.com" u
92+ ssFolder = fileSystemLookup "tests", ssMkRedirect = \_ u -> S8.append "http://www.example.com" u
76 }
93 }
77 it "301 redirect when multiple slashes" $ absoluteApp $
94 it "301 redirect when multiple slashes" $ absoluteApp $
78 flip mapM_ ["/a//b/c", "a//b/c"] $ \path -> do
95 flip mapM_ ["/a//b/c", "a//b/c"] $ \path -> do
@@ -80,42 +97,61 @@ main = hspecX $ do
80 assertStatus 301 req
97 assertStatus 301 req
81 assertHeader "Location" "http://www.example.com/a/b/c" req
98 assertHeader "Location" "http://www.example.com/a/b/c" req
82
99
83− describe "when requesting a static asset" $ do
100+ describe "webApp when requesting a static asset" $ do
84− let runtests = setRawPathInfo defRequest "runtests.hs"
85− it "200 when no query parameters" $ statApp $ do
101+ it "200 and etag when no etag query parameters" $ webApp $ do
86− req <- request runtests {
102+ req <- request statFile
87− requestHeaders = [("If-Modified-Since", "")]
88− }
89 assertStatus 200 req
103 assertStatus 200 req
90 assertNoHeader "Cache-Control" req
104 assertNoHeader "Cache-Control" req
105+ assertHeader "ETag" etag req
91
106
92− it "200 when no cache headers sent" $ statApp $ do
107+ it "200 when no cache headers and bad cache query string" $ webApp $ do
93− req <- request runtests { rawQueryString ="?cached" }
108+ flip mapM_ [Just "cached", Nothing] $ \badETag -> do
109+ req <- request statFile { queryString = [("etag", badETag)] }
94− assertStatus 200 req
110+ assertStatus 301 req
111+ assertHeader "Location" "../a/b?etag=1B2M2Y8AsgTpgAmY7PhCfg%3D%3D" req
95− assertHeader "Cache-Control" "max-age=31536000" req
112+ assertNoHeader "Cache-Control" req
96
113
97− it "200 when If-Unmodified-Since" $ statApp $ do
114+ it "Cache-Control set when etag parameter is correct" $ webApp $ do
98− req <- request runtests { rawQueryString ="?cached",
115+ req <- request statFile { queryString = [("etag", Just etag)] }
99− requestHeaders = [("If-Unmodified-Since", "")]
100− }
101 assertStatus 200 req
116 assertStatus 200 req
102 assertHeader "Cache-Control" "max-age=31536000" req
117 assertHeader "Cache-Control" "max-age=31536000" req
103
118
104− it "304 when cache header and query parameter sent" $ statApp $ do
119+ it "200 when invalid in-none-match sent" $ webApp $
105− req <- request runtests { rawQueryString ="?cached",
120+ flip mapM_ ["cached", ""] $ \badETag -> do
121+ req <- request statFile { requestHeaders = [("If-None-Match", badETag)] }
122+ assertStatus 200 req
123+ assertHeader "ETag" etag req
124+
125+ it "304 when valid if-none-match sent" $ webApp $ do
126+ req <- request statFile { requestHeaders = [("If-None-Match", etag)] }
127+ assertStatus 304 req
128+ assertNoHeader "Etag" req
129+
130+ describe "fileServerApp" $ do
131+ it "directory listing for index" $ fileServerApp $ do
132+ resp <- request (setRawPathInfo defRequest "a/")
133+ assertStatus 200 resp
134+ let body = simpleBody resp
135+ let contains a b = isInfixOf b (L8.unpack a)
136+ must $ body `contains` "<img src=\"../.hidden/haskell.png\" />"
137+ must $ body `contains` "<img src=\"../.hidden/folder.png\" alt=\"Folder\" />"
138+ must $ body `contains` "<a href=\"b\">b</a>"
139+
140+ it "200 when invalid if-modified-since header" $ fileServerApp $ do
141+ flip mapM_ ["123", ""] $ \badDate -> do
142+ req <- request statFile {
143+ requestHeaders = [("If-Modified-Since", badDate)]
144+ }
145+ assertStatus 200 req
146+ assertNoHeader "Cache-Control" req
147+
148+ it "304 when if-modified-since matches" $ fileServerApp $ do
149+ -- formatTime defaultTimeLocale format $
150+ -- let format = "%a, %d %b %Y %X %Z"
151+ stat <- liftIO $ getFileStatus $ "tests/" ++ file
152+ req <- request statFile {
106− requestHeaders = [("If-Modified-Since", "")]
153+ requestHeaders = [("If-Modified-Since", formatHTTPDate . epochTimeToHTTPDate $ modificationTime stat)]
107 }
154 }
108 assertStatus 304 req
155 assertStatus 304 req
109 assertNoHeader "Cache-Control" req
156 assertNoHeader "Cache-Control" req
110
157
111− let pubApp = flip runSession $ staticApp (defaultPublicSettings $ ETag (\_ -> return $ Just "hash")) {ssFolder = "tests"}
112− describe "staticApp when requesting a public asset - etags" $ do
113− it "200 when no etag parameters" $ pubApp $ do
114− req <- request (setRawPathInfo defRequest "runtests.hs")
115− assertStatus 200 req
116− assertHeader "Etag" "hash" req
117−
118− it "304 when etag parameter sent" $ pubApp $ do
119− req <- request (setRawPathInfo defRequest "runtests.hs") { requestHeaders = [("If-None-Match", "hash")] }
120− assertStatus 304 req
121− assertNoHeader "Etag" req
wai-app-static.cabal+10−3
@@ -1,5 +1,5 @@
1name: wai-app-static
1name: wai-app-static
2−version: 0.4
2+version: 0.3.0
3license: BSD3
3license: BSD3
4license-file: LICENSE
4license-file: LICENSE
5author: Michael Snoyman <michael@snoyman.com>
5author: Michael Snoyman <michael@snoyman.com>
@@ -32,6 +32,9 @@ library
32 , file-embed >= 0.0.3.1 && < 0.1
32 , file-embed >= 0.0.3.1 && < 0.1
33 , text >= 0.5 && < 1.0
33 , text >= 0.5 && < 1.0
34 , blaze-builder >= 0.2.1.4 && < 0.4
34 , blaze-builder >= 0.2.1.4 && < 0.4
35+ , base64-bytestring >= 0.1 && < 0.2
36+ , cryptohash >= 0.7 && < 0.8
37+ , http-date
35 exposed-modules: Network.Wai.Application.Static
38 exposed-modules: Network.Wai.Application.Static
36 ghc-options: -Wall
39 ghc-options: -Wall
37 extensions: CPP
40 extensions: CPP
@@ -45,10 +48,14 @@ test-suite runtests
45 type: exitcode-stdio-1.0
48 type: exitcode-stdio-1.0
46
49
47 build-depends: base >= 4 && < 5
50 build-depends: base >= 4 && < 5
48− , hspec >= 0.5
51+ , hspec >= 0.6
49 , HUnit
52 , HUnit
53+ , unix-compat >= 0.2 && < 0.3
54+ , time >= 1.1.4 && < 1.3
55+ , old-locale >= 1.0.0.2 && < 1.1
56+ , http-date
50 , Cabal
57 , Cabal
51− , wai-app-static >= 0.4
58+ , wai-app-static >= 0.3
52 , wai-test
59 , wai-test
53 , wai
60 , wai
54 , http-types
61 , http-types
קרררר.htmlnew file+1
@@ -0,0 +1 @@
1+<h1>HELLO WORLD</h1>