git.iko.soy/typeable/wai
on master help sign in
Abstract away file system stuff
c8010fdMichael Snoyman
Network/Wai/Application/Static.hs+100−58
compare with master
unifiedsplit
@@ -34,6 +34,10 @@ module Network.Wai.Application.Static
34 , CacheSettings (..)
34 , CacheSettings (..)
35 -- should be moved to common helper
35 -- should be moved to common helper
36 , unfixPathName
36 , unfixPathName
37+ -- new stuff to be sorted
38+ , fileSystemLookup
39+ , defaultMkRedirect
40+ , File (..)
37 ) where
41 ) where
38
42
39import qualified Network.Wai as W
43import qualified Network.Wai as W
@@ -177,12 +181,11 @@ data CheckPieces
177 = Redirect Pieces
181 = Redirect Pieces
178 | Forbidden
182 | Forbidden
179 | NotFound
183 | NotFound
180− | FileResponse FilePath
184+ | FileResponse File
181 | NotModified
185 | NotModified
182− | DirectoryResponse FilePath
186+ | DirectoryResponse Folder
183 -- TODO: add file size
187 -- TODO: add file size
184 | SendContent MimeType L.ByteString
188 | SendContent MimeType L.ByteString
185− deriving Show
186
189
187safeInit :: [a] -> [a]
190safeInit :: [a] -> [a]
188safeInit [] = []
191safeInit [] = []
@@ -214,9 +217,9 @@ pathFromPieces :: FilePath -> Pieces -> FilePath
214pathFromPieces prefix pieces =
217pathFromPieces prefix pieces =
215 concat $ prefix : map ((:) '/') (map unfixPathName $ map T.unpack pieces)
218 concat $ prefix : map ((:) '/') (map unfixPathName $ map T.unpack pieces)
216
219
217−checkPieces :: FilePath -- ^ static file prefix
220+checkPieces :: (Pieces -> IO FileLookup) -- ^ file lookup function
218− -> [FilePath] -- ^ List of default index files. Cannot contain slashes.
221+ -> [T.Text] -- ^ List of default index files. Cannot contain slashes.
219− -> Pieces -- ^ parsed request
222+ -> Pieces -- ^ parsed request
220 -> CacheSettings
223 -> CacheSettings
221 -> W.Request
224 -> W.Request
222 -> IO CheckPieces
225 -> IO CheckPieces
@@ -224,12 +227,11 @@ checkPieces _ _ [".hidden", "folder.png"] _ _ =
224 return $ SendContent "image/png" $ L.fromChunks [$(embedFile "folder.png")]
227 return $ SendContent "image/png" $ L.fromChunks [$(embedFile "folder.png")]
225checkPieces _ _ [".hidden", "haskell.png"] _ _ =
228checkPieces _ _ [".hidden", "haskell.png"] _ _ =
226 return $ SendContent "image/png" $ L.fromChunks [$(embedFile "haskell.png")]
229 return $ SendContent "image/png" $ L.fromChunks [$(embedFile "haskell.png")]
227−checkPieces prefix indices pieces cache req
230+checkPieces fileLookup indices pieces cache req
228 | any unsafe pieces = return Forbidden
231 | any unsafe pieces = return Forbidden
229 | any T.null $ safeInit pieces =
232 | any T.null $ safeInit pieces =
230 return $ Redirect $ filterButLast (not . T.null) pieces
233 return $ Redirect $ filterButLast (not . T.null) pieces
231 | otherwise = do
234 | otherwise = do
232− let fp = pathFromPieces prefix pieces
233 let (isFile, isFolder) =
235 let (isFile, isFolder) =
234 case () of
236 case () of
235 ()
237 ()
@@ -237,7 +239,8 @@ checkPieces prefix indices pieces cache req
237 | T.null (last pieces) -> (False, True)
239 | T.null (last pieces) -> (False, True)
238 | otherwise -> (True, False)
240 | otherwise -> (True, False)
239
241
242+ let fp = undefined
240− if not isFile then uncached fp isFile isFolder
243+ if not isFile then uncached isFile isFolder
241 else
244 else
242 case cache of
245 case cache of
243 ETag ioLookup -> do
246 ETag ioLookup -> do
@@ -246,67 +249,81 @@ checkPieces prefix indices pieces cache req
246 metag <- ioLookup fp
249 metag <- ioLookup fp
247 case debug (metag, mlastEtag) of
250 case debug (metag, mlastEtag) of
248 (Just hash, Just lastHash) | hash == lastHash -> return NotModified
251 (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
250 Forever isStaticFile ->
253 Forever isStaticFile ->
251 if isStaticFile fp (S8.drop 1 $ W.rawQueryString req) &&
254 if isStaticFile fp (S8.drop 1 $ W.rawQueryString req) &&
252 (isJust $ lookup "If-Modified-Since" (W.requestHeaders req)) &&
255 (isJust $ lookup "If-Modified-Since" (W.requestHeaders req)) &&
253 (isNothing $ lookup "If-Unmodified-Since" (W.requestHeaders req))
256 (isNothing $ lookup "If-Unmodified-Since" (W.requestHeaders req))
254 then return NotModified
257 then return NotModified
255− else trace "Static: no cache match" uncached fp isFile isFolder
258+ else trace "Static: no cache match" uncached isFile isFolder
256− NoCache -> trace "NoCache" uncached fp isFile isFolder
259+ NoCache -> trace "NoCache" uncached isFile isFolder
257
260
258
261
259 where
262 where
260− uncached fp isFile isFolder = do
263+ uncached isFile isFolder = do
261− fe <- doesFileExist $ stripTrailingSlash fp
264+ fl <- fileLookup pieces
262− case (fe, isFile) of
265+ case (fl, isFile) of
266+ (FLDoesNotExist, _) -> return NotFound
263− (True, True) -> return $ FileResponse fp
267+ (FLFile file, True) -> return $ FileResponse file
264− (True, False) -> return $ Redirect $ init pieces
268+ (FLFile{}, False) -> return $ Redirect $ init pieces
265− (False, _) -> do
269+ (FLFolder folder@(Folder contents), _) -> do
266− de <- doesDirectoryExist fp
270+ case checkIndices $ map feName $ filter feIsFile contents of
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)
271+ Just index -> return $ Redirect $ setLast pieces index
273− Nothing ->
272+ Nothing ->
274− if isFolder
273+ if isFolder
275− then return $ DirectoryResponse fp
274+ then return $ DirectoryResponse folder
276− else return $ Redirect $ pieces ++ [""]
275+ else return $ Redirect $ pieces ++ [""]
277
276
278 setLast [] x = [x]
277 setLast [] x = [x]
279 setLast [""] x = [x]
278 setLast [""] x = [x]
280 setLast (a:b) x = a : setLast b x
279 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
280
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+
289−type Listing = (Pieces -> FilePath -> IO L.ByteString)
290+type Listing = (Pieces -> Folder -> IO L.ByteString)
290
291
291data StaticDirListing = ListingForbidden | StaticDirListing {
292data StaticDirListing = ListingForbidden | StaticDirListing {
292 ssListing :: Listing
293 ssListing :: Listing
293− , ssIndices :: [FilePath]
294+ , ssIndices :: [T.Text]
294}
295}
295
296
296defaultDirListing :: StaticDirListing
297defaultDirListing :: StaticDirListing
297defaultDirListing = StaticDirListing defaultListing []
298defaultDirListing = StaticDirListing defaultListing []
298
299
299-- IO is for development mode
300-- IO is for development mode
300−type CheckHashParam = (FilePath -> S8.ByteString -> Bool)
301+type CheckHashParam = (File -> S8.ByteString -> Bool)
301−data CacheSettings = NoCache | Forever CheckHashParam | ETag (FilePath -> IO (Maybe S8.ByteString))
302+data CacheSettings = NoCache | Forever CheckHashParam | ETag (File -> IO (Maybe S8.ByteString))
302
303
303oneYear :: Int
304oneYear :: Int
304oneYear = 60 * 60 * 24 * 365
305oneYear = 60 * 60 * 24 * 365
305
306
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+
306data StaticSettings = StaticSettings
323data StaticSettings = StaticSettings
307− { ssFolder :: FilePath
324+ { ssFolder :: Pieces -> IO FileLookup
308 , ssMkRedirect :: Pieces -> ByteString -> S8.ByteString
325 , ssMkRedirect :: Pieces -> ByteString -> S8.ByteString
309− , ssGetMimeType :: FilePath -> IO MimeType
326+ , ssGetMimeType :: File -> IO MimeType
310 , ssDirListing :: StaticDirListing
327 , ssDirListing :: StaticDirListing
311 , ssCacheSettings :: CacheSettings
328 , ssCacheSettings :: CacheSettings
312 }
329 }
@@ -319,20 +336,46 @@ defaultMkRedirect pieces newPath =
319 else newPath)
336 else newPath)
320
337
321defaultStaticSettings :: CacheSettings -> StaticSettings
338defaultStaticSettings :: CacheSettings -> StaticSettings
322−defaultStaticSettings isStaticFile = StaticSettings { ssFolder = "static"
339+defaultStaticSettings isStaticFile = StaticSettings { ssFolder = fileSystemLookup "static"
323 , ssMkRedirect = defaultMkRedirect
340 , ssMkRedirect = defaultMkRedirect
324− , ssGetMimeType = return . defaultMimeTypeByExt
341+ , ssGetMimeType = return . defaultMimeTypeByExt . T.unpack . fileName
325 , ssDirListing = defaultDirListing
342 , ssDirListing = defaultDirListing
326 , ssCacheSettings = isStaticFile
343 , ssCacheSettings = isStaticFile
327}
344}
328defaultPublicSettings :: CacheSettings -> StaticSettings
345defaultPublicSettings :: CacheSettings -> StaticSettings
329−defaultPublicSettings etags = StaticSettings { ssFolder = "public"
346+defaultPublicSettings etags = StaticSettings { ssFolder = fileSystemLookup "public"
330 , ssMkRedirect = defaultMkRedirect
347 , ssMkRedirect = defaultMkRedirect
331− , ssGetMimeType = return . defaultMimeTypeByExt
348+ , ssGetMimeType = return . defaultMimeTypeByExt . T.unpack . fileName
332 , ssDirListing = ListingForbidden
349 , ssDirListing = ListingForbidden
333 , ssCacheSettings = etags
350 , ssCacheSettings = etags
334}
351}
335
352
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
336
379
337staticApp :: StaticSettings -> W.Application
380staticApp :: StaticSettings -> W.Application
338staticApp set req = do
381staticApp set req = do
@@ -356,14 +399,14 @@ staticAppPieces ss@StaticSettings{} pieces req = liftIO $ do
356 ListingForbidden -> []
399 ListingForbidden -> []
357 cp <- checkPieces (ssFolder ss) indices pieces cache req
400 cp <- checkPieces (ssFolder ss) indices pieces cache req
358 case cp of
401 case cp of
359− FileResponse fp -> do
402+ FileResponse file -> do
360− mimetype <- (ssGetMimeType ss) fp
403+ mimetype <- ssGetMimeType ss file
361− filesize <- fileSize `fmap` getFileStatus fp
404+ filesize <- fileGetSize file
362− ch <- setCacheHeaders cache fp
405+ ch <- setCacheHeaders cache file
363− return $ W.ResponseFile H.status200
364− ( [ ("Content-Type", mimetype)
406+ let headers = ("Content-Type", mimetype)
365− , ("Content-Length", S8.pack $ show filesize)
407+ : ("Content-Length", S8.pack $ show filesize)
366− ] ++ ch ) fp Nothing
408+ : ch
409+ return $ fileToResponse file H.status200 headers
367 NotModified ->
410 NotModified ->
368 return $ W.responseLBS statusNotModified
411 return $ W.responseLBS statusNotModified
369 [ ("Content-Type", "text/plain")
412 [ ("Content-Type", "text/plain")
@@ -405,7 +448,7 @@ staticAppPieces ss@StaticSettings{} pieces req = liftIO $ do
405 ] "File not found"
448 ] "File not found"
406 where
449 where
407 -- expires header: formatTime "%a, %d-%b-%Y %X GMT"
450 -- expires header: formatTime "%a, %d-%b-%Y %X GMT"
408− setCacheHeaders :: CacheSettings -> FilePath -> IO H.ResponseHeaders
451+ setCacheHeaders :: CacheSettings -> File -> IO H.ResponseHeaders
409 setCacheHeaders (Forever isStaticFile) fp = return $
452 setCacheHeaders (Forever isStaticFile) fp = return $
410 if isStaticFile fp (S8.drop 1 $ W.rawQueryString req)
453 if isStaticFile fp (S8.drop 1 $ W.rawQueryString req)
411 then [("Cache-Control", S8.append "max-age=" $ S8.pack $ show oneYear)]
454 then [("Cache-Control", S8.append "max-age=" $ S8.pack $ show oneYear)]
@@ -443,9 +486,8 @@ unfixPathName = S8.unpack . TE.encodeUtf8 . T.pack
443
486
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
487-- 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
488defaultListing :: Listing
446−defaultListing pieces localPath = do
489+defaultListing pieces (Folder contents) = do
447− fps <- getDirectoryContents localPath
490+ fps' <- mapM feGetMetaData contents
448− fps' <- mapM (getMetaData localPath) fps
449 let isTop = null pieces || pieces == [""]
491 let isTop = null pieces || pieces == [""]
450 let fps'' = if isTop then fps' else Just (FolderMetaData "..") : fps'
492 let fps'' = if isTop then fps' else Just (FolderMetaData "..") : fps'
451 return $ HU.renderHtml
493 return $ HU.renderHtml
sample.hsnew file+11
@@ -0,0 +1,11 @@
1+import Network.Wai.Application.Static
2+import Network.Wai.Handler.Warp (run)
3+import qualified Data.Text as T
4+
5+main = run 3000 $ staticApp StaticSettings
6+ { ssFolder = fileSystemLookup "."
7+ , ssMkRedirect = defaultMkRedirect
8+ , ssGetMimeType = return . defaultMimeTypeByExt . T.unpack . fileName
9+ , ssDirListing = defaultDirListing
10+ , ssCacheSettings = NoCache
11+ }
קרררר.htmlnew file+1
@@ -0,0 +1 @@
1+<h1>HELLO WORLD</h1>