@@ -30,8 +30,6 @@ module Network.Wai.Application.Static
3030 -- ** Settings
3131 , StaticSettings (..)
3232 , defaultStaticSettings
33− , defaultPublicSettings
34− , CacheSettings (..)
3533 -- should be moved to common helper
3634 , unfixPathName
3735 -- new stuff to be sorted
@@ -41,6 +39,7 @@ module Network.Wai.Application.Static
4139 , File (..)
4240 , toEmbedded
4341 , StaticDirListing (..)
42+ , MaxAge (..)
4443 ) where
4544
4645import qualified Network.Wai as W
@@ -56,6 +55,7 @@ import System.PosixCompat.Files (fileSize, getFileStatus, modificationTime)
5655import System.Posix.Types (FileOffset, EpochTime)
5756import Control.Monad.IO.Class (liftIO)
5857import Data.Maybe (catMaybes, isNothing, isJust)
58+import qualified Crypto.Hash.MD5 as MD5
5959
6060import Text.Blaze ((!))
6161import qualified Text.Blaze.Html5 as H
@@ -79,6 +79,7 @@ import Control.Arrow ((&&&), second)
7979import Data.List (groupBy, sortBy)
8080import Data.Function (on)
8181import Data.Ord (comparing)
82+import qualified Data.ByteString.Base64 as B64
8283
8384#ifdef PRINT
8485import Debug.Trace
@@ -188,7 +189,7 @@ data CheckPieces
188189 = Redirect Pieces
189190 | Forbidden
190191 | NotFound
191− | FileResponse File
192+ | FileResponse File H.ResponseHeaders
192193 | NotModified
193194 | DirectoryResponse Folder
194195 -- TODO: add file size
@@ -233,14 +234,14 @@ pathFromPieces prefix pieces =
233234checkPieces :: (Pieces -> IO FileLookup) -- ^ file lookup function
234235 -> [T.Text] -- ^ List of default index files. Cannot contain slashes.
235236 -> Pieces -- ^ parsed request
236− -> CacheSettings
237237 -> W.Request
238+ -> StaticSettings
238239 -> IO CheckPieces
239240checkPieces _ _ [Piece _ ".hidden", Piece _ "folder.png"] _ _ =
240241 return $ SendContent "image/png" $ L.fromChunks [$(embedFile "folder.png")]
241242checkPieces _ _ [Piece _ ".hidden", Piece _ "haskell.png"] _ _ =
242243 return $ SendContent "image/png" $ L.fromChunks [$(embedFile "haskell.png")]
243−checkPieces fileLookup indices pieces cache req
244+checkPieces fileLookup indices pieces req ss
244245 | any (unsafe . piecePretty) pieces = return Forbidden
245246 | any (T.null . piecePretty) $ safeInit pieces =
246247 return $ Redirect $ filterButLast (not . T.null . piecePretty) pieces
@@ -255,7 +256,7 @@ checkPieces fileLookup indices pieces cache req
255256 fl <- fileLookup pieces
256257 case (fl, isFile) of
257258 (FLDoesNotExist, _) -> return NotFound
258− (FLFile file, True) -> handleCache file cache
259+ (FLFile file, True) -> handleCache file
259260 (FLFile{}, False) -> return $ Redirect $ init pieces
260261 (FLFolder folder@(Folder contents), _) -> do
261262 case checkIndices $ map feName $ filter feIsFile contents of
@@ -265,20 +266,40 @@ checkPieces fileLookup indices pieces cache req
265266 then return $ DirectoryResponse folder
266267 else return $ Redirect $ pieces ++ [Piece "" ""]
267268 where
268− handleCache file NoCache = trace "NoCache" $ return (FileResponse file)
269− handleCache file (ETag ioLookup) = do
270− -- No support for If-Match
271− let mlastEtag = lookup "If-None-Match" (W.requestHeaders req)
272− metag <- ioLookup file
273− case debug (metag, mlastEtag) of
274− (Just hash, Just lastHash) | hash == lastHash -> return NotModified
275− _ -> trace "ETAG: no cache match" (return $ FileResponse file)
276− handleCache file (Forever isStaticFile) = do
277− if isStaticFile file (S8.drop 1 $ W.rawQueryString req) &&
278− (isJust $ lookup "If-Modified-Since" (W.requestHeaders req)) &&
279− (isNothing $ lookup "If-Unmodified-Since" (W.requestHeaders req))
280− then return NotModified
281− else trace "Static: no cache match" (return $ FileResponse file)
269+ headers = W.requestHeaders req
270+ handleCache file =
271+ case (lookup "if-none-match" headers, fileGetHash file) of
272+ (Just lastHash, Just getHash) -> do
273+ hash <- getHash
274+ if hash == lastHash
275+ then return NotModified
276+ else return $ FileResponse file $ cc [("ETag", hash)]
277+ _ ->
278+ case (lookup "if-modified-since" headers >>= parseDate, fileGetModified file) of
279+ (Just lastSent, Just getMod) -> do
280+ modified <- getMod
281+ if lastSent >= modified
282+ then return NotModified
283+ else respond file
284+ _ -> respond file
285+
286+ respond file = do
287+ mhash <- maybe (return Nothing) (fmap Just) $ fileGetHash file
288+ let hash =
289+ case mhash of
290+ Just h -> (:) ("ETag", h)
291+ Nothing -> id
292+ return $ FileResponse file $ hash $ cc []
293+
294+ ccInt =
295+ case ssMaxAge ss of
296+ NoMaxAge -> Nothing
297+ MaxAgeSeconds i -> Just i
298+ MaxAgeForever -> Just oneYear
299+ cc =
300+ case ccInt of
301+ Nothing -> id
302+ Just i -> (:) ("Cache-Control", S8.append "max-age" $ S8.pack $ show i)
282303
283304 setLast [] x = [x]
284305 setLast [Piece "" ""] x = [x]
@@ -303,17 +324,6 @@ data StaticDirListing = StaticDirListing {
303324defaultDirListing :: StaticDirListing
304325defaultDirListing = StaticDirListing (Just defaultListing) []
305326
306−-- IO is for development mode
307−
308−-- FIXME: Greg: Is the idea with ETag that an implementation could cache the
309−-- hashes at compile time and then not need to recompute them? It might make
310−-- more sense to include that as part of the File datatype itself. If we do
311−-- something like that, would it be possible to get rid of CacheSettings
312−-- altogether?
313−
314−type CheckHashParam = (File -> S8.ByteString -> Bool) -- FIXME Greg: Can you explain the purposes of the parameters here?
315−data CacheSettings = NoCache | Forever CheckHashParam | ETag (File -> IO (Maybe S8.ByteString))
316−
317327oneYear :: Int
318328oneYear = 60 * 60 * 24 * 365
319329
@@ -331,16 +341,23 @@ data File = File
331341 { fileGetSize :: IO Int
332342 , fileToResponse :: H.Status -> H.ResponseHeaders -> W.Response
333343 , fileName :: T.Text
344+ , fileGetHash :: Maybe (IO ByteString)
345+ , fileGetModified :: Maybe (IO EpochTime)
334346 }
335347
348+parseDate :: ByteString -> Maybe EpochTime
349+parseDate = error "parseDate"
350+
336351data StaticSettings = StaticSettings
337352 { ssFolder :: Pieces -> IO FileLookup
338− , ssMkRedirect :: Pieces -> ByteString -> S8.ByteString
353+ , ssMkRedirect :: Pieces -> ByteString -> ByteString
339354 , ssGetMimeType :: File -> IO MimeType
340355 , ssDirListing :: StaticDirListing
341− , ssCacheSettings :: CacheSettings
356+ , ssMaxAge :: MaxAge
342357 }
343358
359+data MaxAge = NoMaxAge | MaxAgeSeconds Int | MaxAgeForever
360+
344361defaultMkRedirect :: Pieces -> ByteString -> S8.ByteString
345362defaultMkRedirect pieces newPath
346363 | S8.null newPath || S8.null relDir ||
@@ -350,20 +367,14 @@ defaultMkRedirect pieces newPath
350367 where
351368 relDir = TE.encodeUtf8 (relativeDirFromPieces pieces)
352369
353−defaultStaticSettings :: CacheSettings -> StaticSettings
354−defaultStaticSettings isStaticFile = StaticSettings { ssFolder = fileSystemLookup "static"
355− , ssMkRedirect = defaultMkRedirect
356− , ssGetMimeType = return . defaultMimeTypeByExt . T.unpack . fileName
357− , ssDirListing = defaultDirListing
358− , ssCacheSettings = isStaticFile
359−}
360−defaultPublicSettings :: CacheSettings -> StaticSettings
361−defaultPublicSettings etags = StaticSettings { ssFolder = fileSystemLookup "public"
362− , ssMkRedirect = defaultMkRedirect
363− , ssGetMimeType = return . defaultMimeTypeByExt . T.unpack . fileName
364− , ssDirListing = StaticDirListing Nothing []
365− , ssCacheSettings = etags
366−}
370+defaultStaticSettings :: StaticSettings
371+defaultStaticSettings = StaticSettings
372+ { ssFolder = fileSystemLookup "static"
373+ , ssMkRedirect = defaultMkRedirect
374+ , ssGetMimeType = return . defaultMimeTypeByExt . T.unpack . fileName
375+ , ssDirListing = defaultDirListing
376+ , ssMaxAge = MaxAgeSeconds $ 60 * 60
377+ }
367378
368379fileSystemLookup :: FilePath -> Pieces -> IO FileLookup
369380fileSystemLookup prefix pieces = do
@@ -375,6 +386,12 @@ fileSystemLookup prefix pieces = do
375386 { fileGetSize = fmap (fromIntegral . fileSize) $ getFileStatus fp
376387 , fileToResponse = \s h -> W.ResponseFile s h fp Nothing
377388 , fileName = piecePretty $ last pieces
389+ , fileGetHash = Just $ do
390+ -- FIXME replace lazy IO with enumerators
391+ -- FIXME let's use a dictionary to cache these values?
392+ l <- L.readFile fp
393+ return $ runHashL l
394+ , fileGetModified = Just $ fmap modificationTime $ getFileStatus fp
378395 }
379396 else do
380397 de <- doesDirectoryExist fp
@@ -400,9 +417,8 @@ embeddedLookup :: Embedded -> Pieces -> IO FileLookup
400417embeddedLookup root pieces =
401418 return $ elookup (map piecePretty pieces) root
402419 where
403− modified = 0 -- FIXME
404420 elookup :: [T.Text] -> Embedded -> FileLookup
405− elookup [] x = FLFolder $ Folder $ map (toEntry modified) $ Map.toList x
421+ elookup [] x = FLFolder $ Folder $ map toEntry $ Map.toList x
406422 elookup [""] x = elookup [] x
407423 elookup (p:ps) x =
408424 case Map.lookup p x of
@@ -413,8 +429,8 @@ embeddedLookup root pieces =
413429 _ -> FLDoesNotExist
414430 Just (EEFolder y) -> elookup ps y
415431
416−toEntry :: EpochTime -> (T.Text, EmbeddedEntry) -> FolderEntry
417−toEntry modified (name, ee) = FolderEntry
432+toEntry :: (T.Text, EmbeddedEntry) -> FolderEntry
433+toEntry (name, ee) = FolderEntry
418434 { feName = name
419435 , feIsFile =
420436 case ee of
@@ -424,7 +440,7 @@ toEntry modified (name, ee) = FolderEntry
424440 case ee of
425441 EEFile bs -> FileMetaData
426442 { mdName = name
427− , mdModified = modified
443+ , mdModified = Nothing
428444 , mdSize = fromIntegral $ S8.length bs
429445 }
430446 EEFolder _ -> FolderMetaData
@@ -460,8 +476,16 @@ bsToFile name bs = File
460476 { fileGetSize = return $ S8.length bs
461477 , fileToResponse = \s h -> W.ResponseBuilder s h $ fromByteString bs
462478 , fileName = name
479+ , fileGetHash = Just $ return $ runHash bs
480+ , fileGetModified = Nothing
463481 }
464482
483+runHash :: S8.ByteString -> S8.ByteString
484+runHash = B64.encode . MD5.hash
485+
486+runHashL :: L.ByteString -> ByteString
487+runHashL = B64.encode . MD5.hashlazy
488+
465489staticApp :: StaticSettings -> W.Application
466490staticApp set req =
467491 staticAppPieces set (map toPiece $ W.pathInfo req) req
@@ -481,16 +505,14 @@ staticAppPieces _ _ req
481505 H.status405
482506 [("Content-Type", "text/plain")]
483507 "Only GET is supported"
484−staticAppPieces ss@StaticSettings{} pieces req = liftIO $ do
485− let cache = ssCacheSettings ss
508+staticAppPieces ss pieces req = liftIO $ do
486509 let indices = case ssDirListing ss of
487510 StaticDirListing _ is -> is
488− cp <- checkPieces (ssFolder ss) indices pieces cache req
511+ cp <- checkPieces (ssFolder ss) indices pieces req ss
489512 case cp of
490− FileResponse file -> do
513+ FileResponse file ch -> do
491514 mimetype <- ssGetMimeType ss file
492515 filesize <- fileGetSize file
493− ch <- setCacheHeaders cache file
494516 let headers = ("Content-Type", mimetype)
495517 : ("Content-Length", S8.pack $ show filesize)
496518 : ch
@@ -537,6 +559,7 @@ staticAppPieces ss@StaticSettings{} pieces req = liftIO $ do
537559 [ ("Content-Type", "text/plain")
538560 ] "File not found"
539561 where
562+ {-
540563 -- expires header: formatTime "%a, %d-%b-%Y %X GMT"
541564 setCacheHeaders :: CacheSettings -> File -> IO H.ResponseHeaders
542565 setCacheHeaders (Forever isStaticFile) fp = return $
@@ -549,6 +572,7 @@ staticAppPieces ss@StaticSettings{} pieces req = liftIO $ do
549572 return $ case etag of
550573 Just hash -> [("ETag", hash)]
551574 Nothing -> []
575+ -}
552576
553577{-
554578The problem is that the System.Directory functions are a lie: they
@@ -609,7 +633,7 @@ defaultListing pieces (Folder contents) = do
609633 haskellSrc = image "haskell"
610634 showName "" = "root"
611635 showName x = x
612− showFolder [] = H.string "error: Unexpected showFolder []"
636+ showFolder [] = H.string "/"
613637 showFolder [x] = H.string $ showName x
614638 showFolder (x:xs) = do
615639 let href = concat $ replicate (length xs) "../"
@@ -651,7 +675,10 @@ renderDirectoryContentsTable haskellSrc folderSrc fps =
651675 H.td (H.a ! A.href (H.stringValue $ T.unpack (mdName md) ++ if mdIsFile md then "" else "/") $ H.string $ T.unpack (mdName md))
652676 H.td ! A.class_ (H.stringValue "date") $ H.string $
653677 if mdIsFile md
654− then formatCalendarTime defaultTimeLocale "%d-%b-%Y %X" $ mdModified md
678+ then
679+ case mdModified md of
680+ Nothing -> ""
681+ Just t -> formatCalendarTime defaultTimeLocale "%d-%b-%Y %X" t
655682 else ""
656683 H.td ! A.class_ (H.stringValue "size") $ H.string $
657684 if mdIsFile md
@@ -675,7 +702,7 @@ renderDirectoryContentsTable haskellSrc folderSrc fps =
675702data MetaData =
676703 FileMetaData
677704 { mdName :: T.Text
678− , mdModified :: EpochTime
705+ , mdModified :: Maybe EpochTime
679706 , mdSize :: FileOffset
680707 }
681708 | FolderMetaData
@@ -701,7 +728,7 @@ getMetaData localPath fp = do
701728 fs <- getFileStatus fp'
702729 let modTime = modificationTime fs
703730 let count = fileSize fs
704− return $ Just $ FileMetaData fpPretty modTime count
731+ return $ Just $ FileMetaData fpPretty (Just modTime) count
705732 else do
706733 de <- doesDirectoryExist fp'
707734 return $ if de then Just (FolderMetaData fpPretty) else Nothing