@@ -78,7 +78,7 @@ import qualified Data.Text.Encoding as TE
7878import qualified Data.Text.Encoding.Error as TEE
7979
8080import Control.Arrow ((&&&), second)
81−import Data.List (groupBy, sortBy)
81+import Data.List (groupBy, sortBy, find)
8282import Data.Function (on)
8383import Data.Ord (comparing)
8484import qualified Data.ByteString.Base64 as B64
@@ -89,8 +89,6 @@ import Debug.Trace
8989debug :: (Show a) => a -> a
9090debug a = trace ("DEBUG: " ++ show a) a
9191#else
92−trace :: String -> a -> a
93−trace _ x = x
9492debug :: a -> a
9593debug = id
9694#endif
@@ -235,17 +233,20 @@ pathFromPieces :: FilePath -> Pieces -> FilePath
235233pathFromPieces prefix pieces =
236234 concat $ prefix : map ((:) '/') (map pieceRaw pieces)
237235
236+checkSpecialDirListing :: Pieces -> Maybe CheckPieces
237+checkSpecialDirListing [Piece _ ".hidden", Piece _ "folder.png"] =
238+ Just $ SendContent "image/png" $ L.fromChunks [$(embedFile "folder.png")]
239+checkSpecialDirListing [Piece _ ".hidden", Piece _ "haskell.png"] =
240+ Just $ SendContent "image/png" $ L.fromChunks [$(embedFile "haskell.png")]
241+checkSpecialDirListing _ = Nothing
242+
238243checkPieces :: (Pieces -> IO FileLookup) -- ^ file lookup function
239244 -> [T.Text] -- ^ List of default index files. Cannot contain slashes.
240245 -> Pieces -- ^ parsed request
241246 -> W.Request
242− -> StaticSettings
247+ -> MaxAge
243248 -> IO CheckPieces
244−checkPieces _ _ [Piece _ ".hidden", Piece _ "folder.png"] _ _ =
245− return $ SendContent "image/png" $ L.fromChunks [$(embedFile "folder.png")]
246−checkPieces _ _ [Piece _ ".hidden", Piece _ "haskell.png"] _ _ =
247− return $ SendContent "image/png" $ L.fromChunks [$(embedFile "haskell.png")]
248−checkPieces fileLookup indices pieces req ss
249+checkPieces fileLookup indices pieces req maxAge
249250 | any (unsafe . piecePretty) pieces = return Forbidden
250251 | any (T.null . piecePretty) $ safeInit pieces =
251252 return $ Redirect $ filterButLast (not . T.null . piecePretty) pieces
@@ -277,7 +278,7 @@ checkPieces fileLookup indices pieces req ss
277278 hash <- getHash
278279 if hash == lastHash
279280 then return NotModified
280− else return $ FileResponse file $ cc [("ETag", hash)]
281+ else return $ FileResponse file $ [("ETag", hash)] ++ cacheControl
281282 _ ->
282283 case (lookup "if-modified-since" headers >>= parseDate, fileGetModified file) of
283284 (Just lastSent, Just modified) -> do
@@ -290,37 +291,32 @@ checkPieces fileLookup indices pieces req ss
290291 mhash <- maybe (return Nothing) (fmap Just) $ fileGetHash file
291292 let hash =
292293 case mhash of
293− Just h -> (:) ("ETag", h)
294− Nothing -> id
295− return $ FileResponse file $ hash $ cc []
296−
297− ccInt =
298− case ssMaxAge ss of
299− NoMaxAge -> Nothing
300− MaxAgeSeconds i -> Just i
301− MaxAgeForever -> Just oneYear
302− cc =
303− case ccInt of
304− Nothing -> id
305− Just i -> (:) ("Cache-Control", S8.append "max-age" $ S8.pack $ show i)
294+ Just h -> [("ETag", h)]
295+ Nothing -> []
296+ return $ FileResponse file $ hash ++ cacheControl
306297
298+ setLast :: Pieces -> Piece -> Pieces
307299 setLast [] x = [x]
308300 setLast [Piece "" ""] x = [x]
309301 setLast (a:b) x = a : setLast b x
310302
311303 checkIndices :: [T.Text] -> Maybe T.Text
312− checkIndices contents =
313− go indices
304+ checkIndices contents = find (flip elem indices) contents
305+
306+ cacheControl = case ccInt of
307+ Nothing -> []
308+ Just i -> [("Cache-Control", S8.append "max-age" $ S8.pack $ show i)]
314309 where
315− go [] = Nothing
316− go (i:is)
317− | i `elem` contents = Just i
318− | otherwise = go is
310+ ccInt =
311+ case maxAge of
312+ NoMaxAge -> Nothing
313+ MaxAgeSeconds i -> Just i
314+ MaxAgeForever -> Just oneYear
315+ oneYear :: Int
316+ oneYear = 60 * 60 * 24 * 365
319317
320318type Listing = (Pieces -> Folder -> IO L.ByteString)
321319
322−oneYear :: Int
323−oneYear = 60 * 60 * 24 * 365
324320
325321type FileLookup = Maybe (Either Folder File)
326322
@@ -345,7 +341,7 @@ data StaticSettings = StaticSettings
345341 , ssMkRedirect :: Pieces -> ByteString -> ByteString
346342 , ssGetMimeType :: File -> IO MimeType
347343 , ssListing :: Maybe Listing
348− , ssIndices :: [T.Text]
344+ , ssIndices :: [T.Text] -- index.html
349345 , ssMaxAge :: MaxAge
350346 }
351347
@@ -497,8 +493,11 @@ staticAppPieces _ _ req
497493 "Only GET is supported"
498494staticAppPieces ss pieces req = liftIO $ do
499495 let indices = ssIndices ss
500− cp <- checkPieces (ssFolder ss) indices pieces req ss
501− case cp of
496+ case checkSpecialDirListing pieces of
497+ Just res -> response res
498+ Nothing -> checkPieces (ssFolder ss) indices pieces req (ssMaxAge ss) >>= response
499+ where
500+ response cp = case cp of
502501 FileResponse file ch -> do
503502 mimetype <- ssGetMimeType ss file
504503 let filesize = fileGetSize file