@@ -34,6 +34,10 @@ module Network.Wai.Application.Static
3434 , CacheSettings (..)
3535 -- should be moved to common helper
3636 , unfixPathName
37+ -- new stuff to be sorted
38+ , fileSystemLookup
39+ , defaultMkRedirect
40+ , File (..)
3741 ) where
3842
3943import qualified Network.Wai as W
@@ -177,12 +181,11 @@ data CheckPieces
177181 = Redirect Pieces
178182 | Forbidden
179183 | NotFound
180− | FileResponse FilePath
184+ | FileResponse File
181185 | NotModified
182− | DirectoryResponse FilePath
186+ | DirectoryResponse Folder
183187 -- TODO: add file size
184188 | SendContent MimeType L.ByteString
185− deriving Show
186189
187190safeInit :: [a] -> [a]
188191safeInit [] = []
@@ -214,9 +217,9 @@ pathFromPieces :: FilePath -> Pieces -> FilePath
214217pathFromPieces prefix pieces =
215218 concat $ prefix : map ((:) '/') (map unfixPathName $ map T.unpack pieces)
216219
217−checkPieces :: FilePath -- ^ static file prefix
218− -> [FilePath] -- ^ List of default index files. Cannot contain slashes.
219− -> Pieces -- ^ parsed request
220+checkPieces :: (Pieces -> IO FileLookup) -- ^ file lookup function
221+ -> [T.Text] -- ^ List of default index files. Cannot contain slashes.
222+ -> Pieces -- ^ parsed request
220223 -> CacheSettings
221224 -> W.Request
222225 -> IO CheckPieces
@@ -224,12 +227,11 @@ checkPieces _ _ [".hidden", "folder.png"] _ _ =
224227 return $ SendContent "image/png" $ L.fromChunks [$(embedFile "folder.png")]
225228checkPieces _ _ [".hidden", "haskell.png"] _ _ =
226229 return $ SendContent "image/png" $ L.fromChunks [$(embedFile "haskell.png")]
227−checkPieces prefix indices pieces cache req
230+checkPieces fileLookup indices pieces cache req
228231 | any unsafe pieces = return Forbidden
229232 | any T.null $ safeInit pieces =
230233 return $ Redirect $ filterButLast (not . T.null) pieces
231234 | otherwise = do
232− let fp = pathFromPieces prefix pieces
233235 let (isFile, isFolder) =
234236 case () of
235237 ()
@@ -237,7 +239,8 @@ checkPieces prefix indices pieces cache req
237239 | T.null (last pieces) -> (False, True)
238240 | otherwise -> (True, False)
239241
240− if not isFile then uncached fp isFile isFolder
242+ let fp = undefined
243+ if not isFile then uncached isFile isFolder
241244 else
242245 case cache of
243246 ETag ioLookup -> do
@@ -246,67 +249,81 @@ checkPieces prefix indices pieces cache req
246249 metag <- ioLookup fp
247250 case debug (metag, mlastEtag) of
248251 (Just hash, Just lastHash) | hash == lastHash -> return NotModified
249− _ -> trace "ETAG: no cache match" uncached fp isFile isFolder
252+ _ -> trace "ETAG: no cache match" uncached isFile isFolder
250253 Forever isStaticFile ->
251254 if isStaticFile fp (S8.drop 1 $ W.rawQueryString req) &&
252255 (isJust $ lookup "If-Modified-Since" (W.requestHeaders req)) &&
253256 (isNothing $ lookup "If-Unmodified-Since" (W.requestHeaders req))
254257 then return NotModified
255− else trace "Static: no cache match" uncached fp isFile isFolder
256− NoCache -> trace "NoCache" uncached fp isFile isFolder
258+ else trace "Static: no cache match" uncached isFile isFolder
259+ NoCache -> trace "NoCache" uncached isFile isFolder
257260
258261
259262 where
260− uncached fp isFile isFolder = do
261− fe <- doesFileExist $ stripTrailingSlash fp
262− case (fe, isFile) of
263− (True, True) -> return $ FileResponse fp
264− (True, False) -> return $ Redirect $ init pieces
265− (False, _) -> do
266− de <- doesDirectoryExist fp
267− if not de
268− then return NotFound
269− else do
270− x <- checkIndices fp indices
271− case x of
272− Just index -> return $ Redirect $ setLast pieces (T.pack index)
273− Nothing ->
274− if isFolder
275− then return $ DirectoryResponse fp
276− else return $ Redirect $ pieces ++ [""]
263+ uncached isFile isFolder = do
264+ fl <- fileLookup pieces
265+ case (fl, isFile) of
266+ (FLDoesNotExist, _) -> return NotFound
267+ (FLFile file, True) -> return $ FileResponse file
268+ (FLFile{}, False) -> return $ Redirect $ init pieces
269+ (FLFolder folder@(Folder contents), _) -> do
270+ case checkIndices $ map feName $ filter feIsFile contents of
271+ Just index -> return $ Redirect $ setLast pieces index
272+ Nothing ->
273+ if isFolder
274+ then return $ DirectoryResponse folder
275+ else return $ Redirect $ pieces ++ [""]
277276
278277 setLast [] x = [x]
279278 setLast [""] x = [x]
280279 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
288280
289−type Listing = (Pieces -> FilePath -> IO L.ByteString)
281+ checkIndices :: [T.Text] -> Maybe T.Text
282+ checkIndices contents =
283+ go indices
284+ where
285+ go [] = Nothing
286+ go (i:is)
287+ | i `elem` contents = Just i
288+ | otherwise = go is
289+
290+type Listing = (Pieces -> Folder -> IO L.ByteString)
290291
291292data StaticDirListing = ListingForbidden | StaticDirListing {
292293 ssListing :: Listing
293− , ssIndices :: [FilePath]
294+ , ssIndices :: [T.Text]
294295}
295296
296297defaultDirListing :: StaticDirListing
297298defaultDirListing = StaticDirListing defaultListing []
298299
299300-- IO is for development mode
300−type CheckHashParam = (FilePath -> S8.ByteString -> Bool)
301−data CacheSettings = NoCache | Forever CheckHashParam | ETag (FilePath -> IO (Maybe S8.ByteString))
301+type CheckHashParam = (File -> S8.ByteString -> Bool)
302+data CacheSettings = NoCache | Forever CheckHashParam | ETag (File -> IO (Maybe S8.ByteString))
302303
303304oneYear :: Int
304305oneYear = 60 * 60 * 24 * 365
305306
307+data FileLookup = FLFolder Folder | FLFile File | FLDoesNotExist
308+
309+data Folder = Folder [FolderEntry] -- Bool: True = file, False = folder
310+
311+data FolderEntry = FolderEntry
312+ { feName :: T.Text
313+ , feIsFile :: Bool
314+ , feGetMetaData :: IO (Maybe MetaData)
315+ }
316+
317+data File = File
318+ { fileGetSize :: IO Int
319+ , fileToResponse :: H.Status -> H.ResponseHeaders -> W.Response
320+ , fileName :: T.Text
321+ }
322+
306323data StaticSettings = StaticSettings
307− { ssFolder :: FilePath
324+ { ssFolder :: Pieces -> IO FileLookup
308325 , ssMkRedirect :: Pieces -> ByteString -> S8.ByteString
309− , ssGetMimeType :: FilePath -> IO MimeType
326+ , ssGetMimeType :: File -> IO MimeType
310327 , ssDirListing :: StaticDirListing
311328 , ssCacheSettings :: CacheSettings
312329 }
@@ -319,20 +336,46 @@ defaultMkRedirect pieces newPath =
319336 else newPath)
320337
321338defaultStaticSettings :: CacheSettings -> StaticSettings
322−defaultStaticSettings isStaticFile = StaticSettings { ssFolder = "static"
339+defaultStaticSettings isStaticFile = StaticSettings { ssFolder = fileSystemLookup "static"
323340 , ssMkRedirect = defaultMkRedirect
324− , ssGetMimeType = return . defaultMimeTypeByExt
341+ , ssGetMimeType = return . defaultMimeTypeByExt . T.unpack . fileName
325342 , ssDirListing = defaultDirListing
326343 , ssCacheSettings = isStaticFile
327344}
328345defaultPublicSettings :: CacheSettings -> StaticSettings
329−defaultPublicSettings etags = StaticSettings { ssFolder = "public"
346+defaultPublicSettings etags = StaticSettings { ssFolder = fileSystemLookup "public"
330347 , ssMkRedirect = defaultMkRedirect
331− , ssGetMimeType = return . defaultMimeTypeByExt
348+ , ssGetMimeType = return . defaultMimeTypeByExt . T.unpack . fileName
332349 , ssDirListing = ListingForbidden
333350 , ssCacheSettings = etags
334351}
335352
353+fileSystemLookup :: FilePath -> Pieces -> IO FileLookup
354+fileSystemLookup prefix pieces = do
355+ let fp = pathFromPieces prefix pieces
356+ fe <- doesFileExist fp
357+ if fe
358+ then do
359+ return $ FLFile File
360+ { fileGetSize = fmap (fromIntegral . fileSize) $ getFileStatus fp
361+ , fileToResponse = \s h -> W.ResponseFile s h fp Nothing
362+ , fileName = last pieces
363+ }
364+ else do
365+ de <- doesDirectoryExist fp
366+ if de
367+ then do
368+ entries <- getDirectoryContents fp >>= (mapM $ \name -> do
369+ let name' = T.pack name -- FIXME fix/unfix, not sure which
370+ let fp' = fp ++ '/' : name
371+ fe' <- doesFileExist fp'
372+ return FolderEntry
373+ { feName = name'
374+ , feIsFile = fe'
375+ , feGetMetaData = getMetaData fp name
376+ })
377+ return $ FLFolder $ Folder entries
378+ else return FLDoesNotExist
336379
337380staticApp :: StaticSettings -> W.Application
338381staticApp set req = do
@@ -356,14 +399,14 @@ staticAppPieces ss@StaticSettings{} pieces req = liftIO $ do
356399 ListingForbidden -> []
357400 cp <- checkPieces (ssFolder ss) indices pieces cache req
358401 case cp of
359− FileResponse fp -> do
360− mimetype <- (ssGetMimeType ss) fp
361− filesize <- fileSize `fmap` getFileStatus fp
362− ch <- setCacheHeaders cache fp
363− return $ W.ResponseFile H.status200
364− ( [ ("Content-Type", mimetype)
365− , ("Content-Length", S8.pack $ show filesize)
366− ] ++ ch ) fp Nothing
402+ FileResponse file -> do
403+ mimetype <- ssGetMimeType ss file
404+ filesize <- fileGetSize file
405+ ch <- setCacheHeaders cache file
406+ let headers = ("Content-Type", mimetype)
407+ : ("Content-Length", S8.pack $ show filesize)
408+ : ch
409+ return $ fileToResponse file H.status200 headers
367410 NotModified ->
368411 return $ W.responseLBS statusNotModified
369412 [ ("Content-Type", "text/plain")
@@ -405,7 +448,7 @@ staticAppPieces ss@StaticSettings{} pieces req = liftIO $ do
405448 ] "File not found"
406449 where
407450 -- expires header: formatTime "%a, %d-%b-%Y %X GMT"
408− setCacheHeaders :: CacheSettings -> FilePath -> IO H.ResponseHeaders
451+ setCacheHeaders :: CacheSettings -> File -> IO H.ResponseHeaders
409452 setCacheHeaders (Forever isStaticFile) fp = return $
410453 if isStaticFile fp (S8.drop 1 $ W.rawQueryString req)
411454 then [("Cache-Control", S8.append "max-age=" $ S8.pack $ show oneYear)]
@@ -443,9 +486,8 @@ unfixPathName = S8.unpack . TE.encodeUtf8 . T.pack
443486
444487-- Code below taken from Happstack: http://patch-tag.com/r/mae/happstack/snapshot/current/content/pretty/happstack-server/src/Happstack/Server/FileServe/BuildingBlocks.hs
445488defaultListing :: Listing
446−defaultListing pieces localPath = do
447− fps <- getDirectoryContents localPath
448− fps' <- mapM (getMetaData localPath) fps
489+defaultListing pieces (Folder contents) = do
490+ fps' <- mapM feGetMetaData contents
449491 let isTop = null pieces || pieces == [""]
450492 let fps'' = if isTop then fps' else Just (FolderMetaData "..") : fps'
451493 return $ HU.renderHtml