@@ -2,9 +2,21 @@
22{-# LANGUAGE TemplateHaskell, CPP #-}
33-- | Static file serving for WAI.
44module Network.Wai.Application.Static
5− ( -- * Generic, non-WAI code
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
17+ -- * Generic, non-WAI code
618 -- ** Mime types
7− MimeType
19+ , MimeType
820 , defaultMimeType
921 -- ** Mime type by file extension
1022 , Extension
@@ -14,26 +26,25 @@ module Network.Wai.Application.Static
1426 , mimeTypeByExt
1527 , defaultMimeTypeByExt
1628 -- ** Finding files
29+ , Piece (..)
1730 , Pieces
1831 , pathFromPieces
19− -- ** File/folder metadata
20− , MetaData (..)
21− , mdIsFile
22− , getMetaData
32+ , unfixPathName
2333 -- ** Directory listings
2434 , Listing
2535 , defaultListing
26− , defaultDirListing
27− -- * WAI application
28− , staticApp
29− , staticAppPieces
30− -- ** Settings
31− , StaticSettings (..)
32− , defaultStaticSettings
33− , defaultPublicSettings
34− , CacheSettings (..)
35− -- should be moved to common helper
36− , unfixPathName
36+ -- ** Lookup functions
37+ , fileSystemLookup
38+ , embeddedLookup
39+ -- ** Embedded
40+ , Embedded
41+ , EmbeddedEntry (..)
42+ , toEmbedded
43+ -- ** Redirecting
44+ , defaultMkRedirect
45+ -- * Other data types
46+ , File (..)
47+ , MaxAge (..)
3748 ) where
3849
3950import qualified Network.Wai as W
@@ -46,39 +57,41 @@ import qualified Data.ByteString.Char8 as S8
4657import qualified Data.ByteString.Lazy as L
4758import Data.ByteString.Lazy.Char8 ()
4859import System.PosixCompat.Files (fileSize, getFileStatus, modificationTime)
49−import System.Posix.Types (FileOffset, EpochTime)
60+import System.Posix.Types (EpochTime)
5061import 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)
5264
5365import Text.Blaze ((!))
5466import qualified Text.Blaze.Html5 as H
5567import qualified Text.Blaze.Renderer.Utf8 as HU
5668import qualified Text.Blaze.Html5.Attributes as A
5769
58−import Blaze.ByteString.Builder (toByteString, copyByteString)
59−import Data.Monoid (mappend)
70+import Blaze.ByteString.Builder (toByteString, fromByteString)
6071
6172import Data.Time
6273import Data.Time.Clock.POSIX
6374import System.Locale (defaultTimeLocale)
6475
65−import Data.List (sortBy)
6676import Data.FileEmbed (embedFile)
6777
6878import qualified Data.Text as T
6979import qualified Data.Text.Encoding as TE
7080import qualified Data.Text.Encoding.Error as TEE
7181
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+{-
7391import Debug.Trace
7492debug :: (Show a) => a -> a
7593debug a = trace ("DEBUG: " ++ show a) a
76−#else
77−trace :: String -> a -> a
78−trace _ x = x
79−debug :: a -> a
80−debug = id
81−#endif
94+-}
8295
8396-- | A list of all possible extensions, starting from the largest.
8497takeExtensions :: FilePath -> [String]
@@ -152,6 +165,7 @@ defaultMimeTypes = Map.fromList [
152165 ( "wma" , "audio/x-ms-wma" ),
153166 ( "wmv" , "video/x-ms-wmv" ),
154167 ( "xbm" , "image/x-xbitmap" ),
168+ ( "xhtml" , "application/xhtml+xml" ),
155169 ( "xml" , "text/xml" ),
156170 ( "xpm" , "image/x-xpixmap" ),
157171 ( "xwd" , "image/x-xwindowdump" ),
@@ -173,16 +187,16 @@ mimeTypeByExt mm def =
173187defaultMimeTypeByExt :: FilePath -> MimeType
174188defaultMimeTypeByExt = mimeTypeByExt defaultMimeTypes defaultMimeType
175189
176−data CheckPieces
177− = Redirect Pieces
190+data CheckPieces =
191+ -- | Just the etag hash or Nothing for no etag hash
192+ Redirect Pieces (Maybe ByteString)
178193 | Forbidden
179194 | NotFound
180− | FileResponse FilePath
195+ | FileResponse File H.ResponseHeaders
181196 | NotModified
182− | DirectoryResponse FilePath
197+ | DirectoryResponse Folder
183198 -- TODO: add file size
184199 | SendContent MimeType L.ByteString
185− deriving Show
186200
187201safeInit :: [a] -> [a]
188202safeInit [] = []
@@ -206,176 +220,362 @@ stripTrailingSlash "/" = ""
206220stripTrailingSlash "" = ""
207221stripTrailingSlash (x:xs) = x : stripTrailingSlash xs
208222
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+
210230relativeDirFromPieces :: Pieces -> T.Text
211231relativeDirFromPieces pieces = T.concat $ map (const "../") (drop 1 pieces) -- last piece is not a dir
212232
213233pathFromPieces :: FilePath -> Pieces -> FilePath
214234pathFromPieces prefix pieces =
215− concat $ prefix : map ((:) '/') (map unfixPathName $ map T.unpack pieces)
216−
217−checkPieces :: FilePath -- ^ static file prefix
218− -> [FilePath] -- ^ List of default index files. Cannot contain slashes.
219− -> Pieces -- ^ parsed request
220− -> CacheSettings
235+ concat $ prefix : map ((:) '/') (map pieceRaw pieces)
236+
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
245+ -> [T.Text] -- ^ List of default index files. Cannot contain slashes.
246+ -> Pieces -- ^ parsed request
221247 -> W.Request
248+ -> MaxAge
222249 -> IO CheckPieces
223−checkPieces _ _ [".hidden", "folder.png"] _ _ =
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
229− | any T.null $ safeInit pieces =
230− return $ Redirect $ filterButLast (not . T.null) pieces
250+checkPieces fileLookup indices pieces req maxAge
251+ | any (unsafe . piecePretty) pieces = return Forbidden
252+ | any (T.null . piecePretty) $ safeInit pieces =
253+ return $ Redirect (filterButLast (not . T.null . piecePretty) pieces) Nothing
231254 | otherwise = do
232− let fp = pathFromPieces prefix pieces
233255 let (isFile, isFolder) =
234256 case () of
235257 ()
236258 | null pieces -> (True, True)
237− | T.null (last pieces) -> (False, True)
259+ | T.null $ piecePretty (last pieces) -> (False, True)
238260 | otherwise -> (True, False)
239261
240− if not isFile then uncached fp isFile isFolder
241− else
242− case cache of
243− ETag ioLookup -> do
244− -- No support for If-Match
245− let mlastEtag = lookup "If-None-Match" (W.requestHeaders req)
246− metag <- ioLookup fp
247− case debug (metag, mlastEtag) of
248− (Just hash, Just lastHash) | hash == lastHash -> return NotModified
249− _ -> trace "ETAG: no cache match" uncached fp isFile isFolder
250− Forever isStaticFile ->
251− if isStaticFile fp (S8.drop 1 $ W.rawQueryString req) &&
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−
262+ fl <- fileLookup pieces
263+ case (fl, isFile) of
264+ (Nothing, _) -> return NotFound
265+ (Just (Right file), True) -> handleCache file
266+ (Just Right{}, False) -> return $ Redirect (init pieces) Nothing
267+ (Just (Left folder@(Folder _ contents)), _) -> do
268+ case checkIndices $ map fileName $ rights contents of
269+ Just index -> return $ Redirect (setLast pieces $ Piece (T.unpack index) index) Nothing
270+ Nothing ->
271+ if isFolder
272+ then return $ DirectoryResponse folder
273+ else return $ Redirect (pieces ++ [Piece "" ""]) Nothing
259274 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 ++ [""]
277−
275+ headers = W.requestHeaders req
276+ queryString = W.queryString req
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
303+ then return $ FileResponse file $ ("ETag", hash):cacheControl
304+ else return $ Redirect pieces (Just hash)
305+ -- a file used to have an etag parameter, but no longer does
306+ (Just _, Nothing) -> return $ Redirect pieces Nothing
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
314+ then return NotModified
315+ else return $ FileResponse file $ [("ETag", hash)]
316+ _ ->
317+ case (lookup "if-modified-since" headers >>= parseModifiedDate, fileGetModified file) of
318+ -- last-modified
319+ (Just lastSent, Just modified) -> do
320+ if lastSent >= modified
321+ then return NotModified
322+ else respond file
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
278333 setLast [] x = [x]
279− setLast [""] x = [x]
334+ setLast [Piece "" ""] x = [x]
280335 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
288336
289−type Listing = (Pieces -> FilePath -> IO L.ByteString)
337+ checkIndices :: [T.Text] -> Maybe T.Text
338+ checkIndices contents = find (flip elem indices) contents
290339
291−data StaticDirListing = ListingForbidden | StaticDirListing {
292− ssListing :: Listing
293− , ssIndices :: [FilePath]
294−}
340+ cacheControl = case ccInt of
341+ Nothing -> []
342+ Just i -> [("Cache-Control", S8.append "max-age=" $ S8.pack $ show i)]
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
295351
296−defaultDirListing :: StaticDirListing
297−defaultDirListing = StaticDirListing defaultListing []
352+type Listing = (Pieces -> Folder -> IO L.ByteString)
298353
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))
302354
303−oneYear :: Int
304−oneYear = 60 * 60 * 24 * 365
355+type FileLookup = Maybe (Either Folder File)
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"
305375
306376data StaticSettings = StaticSettings
307− { ssFolder :: FilePath
308− , ssMkRedirect :: Pieces -> ByteString -> S8.ByteString
309− , ssGetMimeType :: FilePath -> IO MimeType
310− , ssDirListing :: StaticDirListing
311− , ssCacheSettings :: CacheSettings
377+ { ssFolder :: Pieces -> IO FileLookup
378+ , ssMkRedirect :: Pieces -> ByteString -> ByteString
379+ , ssGetMimeType :: File -> IO MimeType
380+ , ssListing :: Maybe Listing
381+ , ssIndices :: [T.Text] -- index.html
382+ , ssMaxAge :: MaxAge
312383 }
313384
385+data MaxAge = NoMaxAge | MaxAgeSeconds Int | MaxAgeForever
386+
314387defaultMkRedirect :: Pieces -> ByteString -> S8.ByteString
315−defaultMkRedirect pieces newPath =
316− let relDir = TE.encodeUtf8 (relativeDirFromPieces pieces) in
317− S8.append relDir (if (S8.last relDir) == '/' && (S8.head newPath) == '/'
318− then S8.tail newPath
319− else newPath)
320−
321−defaultStaticSettings :: CacheSettings -> StaticSettings
322−defaultStaticSettings isStaticFile = StaticSettings { ssFolder = "static"
323− , ssMkRedirect = defaultMkRedirect
324− , ssGetMimeType = return . defaultMimeTypeByExt
325− , ssDirListing = defaultDirListing
326− , ssCacheSettings = isStaticFile
327−}
328−defaultPublicSettings :: CacheSettings -> StaticSettings
329−defaultPublicSettings etags = StaticSettings { ssFolder = "public"
330− , ssMkRedirect = defaultMkRedirect
331− , ssGetMimeType = return . defaultMimeTypeByExt
332− , ssDirListing = ListingForbidden
333− , ssCacheSettings = etags
334−}
388+defaultMkRedirect pieces newPath
389+ | S8.null newPath || S8.null relDir ||
390+ S8.last relDir /= '/' || S8.head newPath /= '/' =
391+ relDir `S8.append` newPath
392+ | otherwise = relDir `S8.append` S8.tail newPath
393+ where
394+ relDir = TE.encodeUtf8 (relativeDirFromPieces pieces)
395+
396+defaultWebAppSettings :: StaticSettings
397+defaultWebAppSettings = StaticSettings
398+ { ssFolder = fileSystemLookup "static"
399+ , ssMkRedirect = defaultMkRedirect
400+ , ssGetMimeType = return . defaultMimeTypeByExt . T.unpack . fileName
401+ , ssMaxAge = MaxAgeForever
402+ , ssListing = Nothing
403+ , ssIndices = []
404+ }
405+
406+defaultFileServerSettings :: StaticSettings
407+defaultFileServerSettings = StaticSettings
408+ { ssFolder = fileSystemLookup "static"
409+ , ssMkRedirect = defaultMkRedirect
410+ , ssGetMimeType = return . defaultMimeTypeByExt . T.unpack . fileName
411+ , ssMaxAge = MaxAgeSeconds $ 60 * 60
412+ , ssListing = Just defaultListing
413+ , ssIndices = ["index.html", "index.htm"]
414+ }
335415
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
336521
337522staticApp :: StaticSettings -> W.Application
338−staticApp set req = do
339− let pieces = W.pathInfo req
340− staticAppPieces set pieces req
523+staticApp set req =
524+ staticAppPieces set (map toPiece $ W.pathInfo req) req
525+ where
526+ toPiece t = Piece
527+ { piecePretty = t
528+ , pieceRaw = unfixPathName $ T.unpack t
529+ }
341530
342531status304, statusNotModified :: H.Status
343532status304 = H.Status 304 "Not Modified"
344533statusNotModified = status304
345534
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+
346547staticAppPieces :: StaticSettings -> Pieces -> W.Application
347548staticAppPieces _ _ req
348549 | W.requestMethod req /= "GET" = return $ W.responseLBS
349550 H.status405
350551 [("Content-Type", "text/plain")]
351552 "Only GET is supported"
352−staticAppPieces ss@StaticSettings{} pieces req = liftIO $ do
353− let cache = ssCacheSettings ss
354− let indices = case ssDirListing ss of
355− StaticDirListing _ is -> is
356− ListingForbidden -> []
357− cp <- checkPieces (ssFolder ss) indices pieces cache req
358− 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
553+staticAppPieces ss pieces req = liftIO $ do
554+ let indices = ssIndices ss
555+ case checkSpecialDirListing pieces of
556+ Just res -> response res
557+ Nothing -> checkPieces (ssFolder ss) indices pieces req (ssMaxAge ss) >>= response
558+ where
559+ response cp = case cp of
560+ FileResponse file ch -> do
561+ mimetype <- ssGetMimeType ss file
562+ let filesize = fileGetSize file
563+ let headers = ("Content-Type", mimetype)
564+ : ("Content-Length", S8.pack $ show filesize)
565+ : ch
566+ return $ fileToResponse file H.status200 headers
367567 NotModified ->
368568 return $ W.responseLBS statusNotModified
369569 [ ("Content-Type", "text/plain")
370570 ] "Not Modified"
371571 DirectoryResponse fp ->
372− case ssDirListing ss of
373− StaticDirListing f _ -> do
572+ case ssListing ss of
573+ (Just f) -> do
374574 lbs <- f pieces fp
375575 return $ W.responseLBS H.status200
376576 [ ("Content-Type", "text/html; charset=utf-8")
377577 ] lbs
378− ListingForbidden -> return $ W.responseLBS H.status403
578+ Nothing -> return $ W.responseLBS H.status403
379579 [ ("Content-Type", "text/plain")
380580 ] "Directory listings disabled"
381581 SendContent mt lbs -> do
@@ -384,18 +584,16 @@ staticAppPieces ss@StaticSettings{} pieces req = liftIO $ do
384584 [ ("Content-Type", mt)
385585 -- TODO: set Content-Length
386586 ] lbs
387− Redirect pieces' -> do
388− let loc = (ssMkRedirect ss) pieces' $ toByteString (H.encodePathSegments pieces')
389−
390− let loc' =
391− -- relativeDirFromPieces pieces = T.concat $ map (const "../") (drop 1 pieces) -- last piece is not a dir
392− -- (ssMkRedirect ss) pieces' $ encodePathInfo pieces' []
393− toByteString $
394− foldr mappend (H.encodePathSegments pieces') -- FIXME use Text
395− $ map (const $ copyByteString "../") $ drop 1 pieces
587+
588+ Redirect pieces' mHash -> do
589+ let loc = (ssMkRedirect ss) pieces' $ toByteString (H.encodePathSegments $ map piecePretty pieces')
590+ let qString = case mHash of
591+ Just hash -> replace "etag" (Just hash) (W.queryString req)
592+ Nothing -> remove "etag" (W.queryString req)
593+
396594 return $ W.responseLBS H.status301
397595 [ ("Content-Type", "text/plain")
398− , ("Location", loc)
596+ , ("Location", S8.append loc $ H.renderQuery True qString)
399597 ] "Redirect"
400598 Forbidden -> return $ W.responseLBS H.status403
401599 [ ("Content-Type", "text/plain")
@@ -403,19 +601,6 @@ staticAppPieces ss@StaticSettings{} pieces req = liftIO $ do
403601 NotFound -> return $ W.responseLBS H.status404
404602 [ ("Content-Type", "text/plain")
405603 ] "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 -> []
419604
420605{-
421606The problem is that the System.Directory functions are a lie: they
@@ -443,18 +628,17 @@ unfixPathName = S8.unpack . TE.encodeUtf8 . T.pack
443628
444629-- Code below taken from Happstack: http://patch-tag.com/r/mae/happstack/snapshot/current/content/pretty/happstack-server/src/Happstack/Server/FileServe/BuildingBlocks.hs
445630defaultListing :: Listing
446−defaultListing pieces localPath = do
447− fps <- getDirectoryContents localPath
448− fps' <- mapM (getMetaData localPath) fps
449− let isTop = null pieces || pieces == [""]
450− let fps'' = if isTop then fps' else Just (FolderMetaData "..") : fps'
631+defaultListing pieces (Folder _ contents) = do
632+ let isTop = null pieces || pieces == [Piece "" ""]
633+ let fps'' :: [Either Folder File]
634+ fps'' = (if isTop then id else (Left (Folder ".." []) :)) contents
451635 return $ HU.renderHtml
452636 $ H.html $ do
453637 H.head $ do
454− let title = T.unpack $ T.intercalate "/" pieces
638+ let title = T.unpack $ T.intercalate "/" $ map piecePretty pieces
455639 let title' = if null title then "root folder" else title
456− H.title $ H.string title'
457− H.style $ H.string $ unlines [ "table { margin: 0 auto; width: 760px; border-collapse: collapse; font-family: 'sans-serif'; }"
640+ H.title $ H.toHtml title'
641+ H.style $ H.toHtml $ unlines [ "table { margin: 0 auto; width: 760px; border-collapse: collapse; font-family: 'sans-serif'; }"
458642 , "table, th, td { border: 1px solid #353948; }"
459643 , "td.size { text-align: right; font-size: 0.7em; width: 50px }"
460644 , "td.date { text-align: right; font-size: 0.7em; width: 130px }"
@@ -469,20 +653,20 @@ defaultListing pieces localPath = do
469653 , "a { text-decoration: none }"
470654 ]
471655 H.body $ do
472− H.h1 $ showFolder $ map T.unpack $ filter (not . T.null) pieces
473− renderDirectoryContentsTable haskellSrc folderSrc $ catMaybes fps''
656+ H.h1 $ showFolder $ map piecePretty $ filter (not . T.null . piecePretty) pieces
657+ renderDirectoryContentsTable haskellSrc folderSrc fps''
474658 where
475659 image x = T.unpack $ T.concat [(relativeDirFromPieces pieces), ".hidden/", x, ".png"]
476660 folderSrc = image "folder"
477661 haskellSrc = image "haskell"
478662 showName "" = "root"
479663 showName x = x
480− showFolder [] = H.string "error: Unexpected showFolder []"
481− showFolder [x] = H.string $ showName x
664+ showFolder [] = "/"
665+ showFolder [x] = H.toHtml $ showName x
482666 showFolder (x:xs) = do
483− let href = concat $ replicate (length xs) "../"
484− H.a ! A.href (H.stringValue href) $ H.string $ showName x
485− H.string " / "
667+ let href = concat $ replicate (length xs) "../" :: String
668+ H.a ! A.href (H.toValue href) $ H.toHtml $ showName x
669+ () <- " / "
486670 showFolder xs
487671
488672-- | a function to generate an HTML table showing the contents of a directory on the disk
@@ -495,36 +679,41 @@ defaultListing pieces localPath = do
495679-- see also: 'getMetaData', 'renderDirectoryContents'
496680renderDirectoryContentsTable :: String
497681 -> String
498− -> [MetaData] -- ^ list of files+meta data, see 'getMetaData'
682+ -> [Either Folder File]
499683 -> H.Html
500684renderDirectoryContentsTable haskellSrc folderSrc fps =
501− H.table $ do H.thead $ do H.th ! (A.class_ $ H.stringValue "first") $ H.img ! (A.src $ H.stringValue haskellSrc)
502− H.th $ H.string "Name"
503− H.th $ H.string "Modified"
504− H.th $ H.string "Size"
685+ H.table $ do H.thead $ do H.th ! (A.class_ "first") $ H.img ! (A.src $ H.toValue haskellSrc)
686+ H.th "Name"
687+ H.th "Modified"
688+ H.th "Size"
505689 H.tbody $ mapM_ mkRow (zip (sortBy sortMD fps) $ cycle [False, True])
506690 where
507− sortMD FolderMetaData{} FileMetaData{} = LT
508− sortMD FileMetaData{} FolderMetaData{} = GT
509− sortMD x y = mdName x `compare` mdName y
510− mkRow :: (MetaData, Bool) -> H.Html
691+ sortMD :: Either Folder File -> Either Folder File -> Ordering
692+ sortMD Left{} Right{} = LT
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)
696+ mkRow :: (Either Folder File, Bool) -> H.Html
511697 mkRow (md, alt) =
512− (if alt then (! A.class_ (H.stringValue "alt")) else id) $
698+ (if alt then (! A.class_ "alt") else id) $
513699 H.tr $ do
514− H.td ! A.class_ (H.stringValue "first")
515− $ if mdIsFile md
516− then return ()
517− else H.img ! A.src (H.stringValue folderSrc)
518− ! A.alt (H.stringValue "Folder")
519− H.td (H.a ! A.href (H.stringValue $ mdName' md ++ if mdIsFile md then "" else "/") $ H.string $ mdName' md)
520− H.td ! A.class_ (H.stringValue "date") $ H.string $
521− if mdIsFile md
522− then formatCalendarTime defaultTimeLocale "%d-%b-%Y %X" $ mdModified md
523− else ""
524− H.td ! A.class_ (H.stringValue "size") $ H.string $
525− if mdIsFile md
526− then prettyShow $ mdSize md
527− else ""
700+ H.td ! A.class_ "first"
701+ $ case md of
702+ Left{} -> H.img ! A.src (H.toValue folderSrc)
703+ ! A.alt "Folder"
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)
708+ H.td ! A.class_ "date" $ H.toHtml $
709+ case md of
710+ Right File { fileGetModified = Just t } ->
711+ formatCalendarTime defaultTimeLocale "%d-%b-%Y %X" t
712+ _ -> ""
713+ H.td ! A.class_ "size" $ H.toHtml $
714+ case md of
715+ Right File { fileGetSize = s } -> prettyShow s
716+ Left{} -> ""
528717 formatCalendarTime a b c = formatTime a b $ posixSecondsToUTCTime (realToFrac c :: POSIXTime)
529718 prettyShow x
530719 | x > 1024 = prettyShowK $ x `div` 1024
@@ -540,20 +729,7 @@ renderDirectoryContentsTable haskellSrc folderSrc fps =
540729 addCommas' (a:b:c:d:e) = a : b : c : ',' : addCommas' (d : e)
541730 addCommas' x = x
542731
543−mdName' :: MetaData -> FilePath
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−
732+{-
557733mdIsFile :: MetaData -> Bool
558734mdIsFile FileMetaData{} = True
559735mdIsFile FolderMetaData{} = False
@@ -566,12 +742,14 @@ getMetaData _ ('.':_) = return Nothing
566742getMetaData localPath fp = do
567743 let fp' = localPath ++ '/' : fp
568744 fe <- doesFileExist fp'
745+ let fpPretty = T.pack $ fixPathName fp
569746 if fe
570747 then do
571748 fs <- getFileStatus fp'
572749 let modTime = modificationTime fs
573750 let count = fileSize fs
574− return $ Just $ FileMetaData fp modTime count
751+ return $ Just $ FileMetaData fpPretty (Just modTime) count
575752 else do
576753 de <- doesDirectoryExist fp'
577− return $ if de then Just (FolderMetaData fp) else Nothing
754+ return $ if de then Just (FolderMetaData fpPretty) else Nothing
755+-}