@@ -26,12 +26,8 @@ module Network.Wai.Application.Static
2626 , mimeTypeByExt
2727 , defaultMimeTypeByExt
2828 -- ** Finding files
29− , Piece (..)
3029 , Pieces
3130 , pathFromPieces
32− , fixPathName
33− , unfixPathName
34− , toPiece
3531 -- ** Directory listings
3632 , Listing
3733 , defaultListing
@@ -46,9 +42,14 @@ module Network.Wai.Application.Static
4642 , defaultMkRedirect
4743 -- * Other data types
4844 , File (..)
45+ , FilePath (..)
46+ , toFilePath
47+ , fromFilePath
4948 , MaxAge (..)
5049 ) where
5150
51+import Prelude hiding (FilePath)
52+import qualified Prelude
5253import qualified Network.Wai as W
5354import qualified Network.HTTP.Types as H
5455import Data.Map (Map)
@@ -77,34 +78,38 @@ import System.Locale (defaultTimeLocale)
7778
7879import Data.FileEmbed (embedFile)
7980
81+import Data.Text (Text)
8082import qualified Data.Text as T
8183import qualified Data.Text.Encoding as TE
8284import qualified Data.Text.Encoding.Error as TEE
8385
8486import Control.Arrow ((&&&), second)
85−import Data.List (groupBy, sortBy, find)
87+import Data.List (groupBy, sortBy, find, foldl')
8688import Data.Function (on)
8789import Data.Ord (comparing)
8890import qualified Data.ByteString.Base64 as B64
8991import Data.Either (rights)
9092import Data.Maybe (isJust, fromJust)
9193import Network.HTTP.Date (parseHTTPDate, epochTimeToHTTPDate, formatHTTPDate)
94+import Data.String (IsString (..))
9295
93−import Debug.Trace
94−debug :: (Show a) => a -> a
95−debug a = trace ("DEBUG: " ++ show a) a
96−{-
97−-}
96+newtype FilePath = FilePath { unFilePath :: Text }
97+ deriving (Ord, Eq, Show)
98+instance IsString FilePath where
99+ fromString = toFilePath
100+
101+(</>) :: FilePath -> FilePath -> FilePath
102+(FilePath a) </> (FilePath b) = FilePath $ T.concat [a, "/", b]
98103
99104-- | A list of all possible extensions, starting from the largest.
100−takeExtensions :: FilePath -> [String]
101−takeExtensions s =
102− case break (== '.') s of
103− (_, '.':x) -> x : takeExtensions x
104− (_, _) -> []
105+takeExtensions :: FilePath -> [FilePath]
106+takeExtensions (FilePath s) =
107+ case T.break (== '.') s of
108+ (_, "") -> []
109+ (_, x) -> FilePath (T.drop 1 x) : takeExtensions (FilePath $ T.drop 1 x)
105110
106111type MimeType = ByteString
107−type Extension = String
112+type Extension = FilePath
108113type MimeMap = Map Extension MimeType
109114
110115defaultMimeType :: MimeType
@@ -214,54 +219,52 @@ filterButLast f (x:xs)
214219 | otherwise = filterButLast f xs
215220
216221
217−unsafe :: T.Text -> Bool
218−unsafe s | T.null s = False
219− | T.head s == '.' = True
220− | otherwise = T.any (== '/') s
222+unsafe :: FilePath -> Bool
223+unsafe (FilePath s)
224+ | T.null s = False
225+ | T.head s == '.' = True
226+ | otherwise = T.any (== '/') s
227+
228+nullFilePath :: FilePath -> Bool
229+nullFilePath = T.null . unFilePath
221230
222231stripTrailingSlash :: FilePath -> FilePath
223−stripTrailingSlash "/" = ""
224−stripTrailingSlash "" = ""
225−stripTrailingSlash (x:xs) = x : stripTrailingSlash xs
232+stripTrailingSlash fp@(FilePath t)
233+ | T.null t || T.last t /= '/' = fp
234+ | otherwise = FilePath $ T.init t
226235
227−data Piece = Piece
228− { pieceRaw :: FilePath
229− , piecePretty :: T.Text
230− }
231− deriving (Eq, Ord, Show)
232−type Pieces = [Piece]
236+type Pieces = [FilePath]
233237
234238relativeDirFromPieces :: Pieces -> T.Text
235239relativeDirFromPieces pieces = T.concat $ map (const "../") (drop 1 pieces) -- last piece is not a dir
236240
237241pathFromPieces :: FilePath -> Pieces -> FilePath
238−pathFromPieces prefix pieces =
239− concat $ prefix : map ((:) '/') (map pieceRaw pieces)
242+pathFromPieces = foldl' (</>)
240243
241244checkSpecialDirListing :: Pieces -> Maybe CheckPieces
242−checkSpecialDirListing [Piece _ ".hidden", Piece _ "folder.png"] =
245+checkSpecialDirListing [".hidden", "folder.png"] =
243246 Just $ SendContent "image/png" $ L.fromChunks [$(embedFile "folder.png")]
244−checkSpecialDirListing [Piece _ ".hidden", Piece _ "haskell.png"] =
247+checkSpecialDirListing [".hidden", "haskell.png"] =
245248 Just $ SendContent "image/png" $ L.fromChunks [$(embedFile "haskell.png")]
246249checkSpecialDirListing _ = Nothing
247250
248251checkPieces :: (Pieces -> IO FileLookup) -- ^ file lookup function
249− -> [T.Text] -- ^ List of default index files. Cannot contain slashes.
252+ -> [FilePath] -- ^ List of default index files. Cannot contain slashes.
250253 -> Pieces -- ^ parsed request
251254 -> W.Request
252255 -> MaxAge
253256 -> Bool
254257 -> IO CheckPieces
255258checkPieces fileLookup indices pieces req maxAge useHash
256− | any (unsafe . piecePretty) pieces = return Forbidden
257− | any (T.null . piecePretty) $ safeInit pieces =
258− return $ Redirect (filterButLast (not . T.null . piecePretty) pieces) Nothing
259+ | any unsafe pieces = return Forbidden
260+ | any nullFilePath $ safeInit pieces =
261+ return $ Redirect (filterButLast (not . nullFilePath) pieces) Nothing
259262 | otherwise = do
260263 let (isFile, isFolder) =
261264 case () of
262265 ()
263266 | null pieces -> (True, True)
264− | T.null $ piecePretty (last pieces) -> (False, True)
267+ | nullFilePath (last pieces) -> (False, True)
265268 | otherwise -> (True, False)
266269
267270 fl <- fileLookup pieces
@@ -271,11 +274,11 @@ checkPieces fileLookup indices pieces req maxAge useHash
271274 (Just Right{}, False) -> return $ Redirect (init pieces) Nothing
272275 (Just (Left folder@(Folder _ contents)), _) -> do
273276 case checkIndices $ map fileName $ rights contents of
274− Just index -> return $ Redirect (setLast pieces $ Piece (T.unpack index) index) Nothing
277+ Just index -> return $ Redirect (setLast pieces index) Nothing
275278 Nothing ->
276279 if isFolder
277280 then return $ DirectoryResponse folder
278− else return $ Redirect (pieces ++ [Piece "" ""]) Nothing
281+ else return $ Redirect (pieces ++ [""]) Nothing
279282 where
280283 headers = W.requestHeaders req
281284 queryString = W.queryString req
@@ -337,12 +340,12 @@ checkPieces fileLookup indices pieces req maxAge useHash
337340 Nothing -> return $ FileResponse file $ [("last-modified", formatHTTPDate mdate)]
338341 _ -> return $ FileResponse file []
339342
340− setLast :: Pieces -> Piece -> Pieces
343+ setLast :: Pieces -> FilePath -> Pieces
341344 setLast [] x = [x]
342− setLast [Piece "" ""] x = [x]
345+ setLast [""] x = [x]
343346 setLast (a:b) x = a : setLast b x
344347
345− checkIndices :: [T.Text] -> Maybe T.Text
348+ checkIndices :: [FilePath] -> Maybe FilePath
346349 checkIndices contents = find (flip elem indices) contents
347350
348351 cacheControl = case ccInt of
@@ -363,14 +366,14 @@ type Listing = (Pieces -> Folder -> IO L.ByteString)
363366type FileLookup = Maybe (Either Folder File)
364367
365368data Folder = Folder
366− { folderName :: T.Text
369+ { folderName :: FilePath
367370 , folderContents :: [Either Folder File]
368371 }
369372
370373data File = File
371374 { fileGetSize :: Int
372375 , fileToResponse :: H.Status -> H.ResponseHeaders -> W.Response
373− , fileName :: T.Text
376+ , fileName :: FilePath
374377 , fileGetHash :: Maybe (IO ByteString)
375378 , fileGetModified :: Maybe EpochTime
376379 }
@@ -400,7 +403,7 @@ defaultWebAppSettings :: StaticSettings
400403defaultWebAppSettings = StaticSettings
401404 { ssFolder = fileSystemLookup "static"
402405 , ssMkRedirect = defaultMkRedirect
403− , ssGetMimeType = return . defaultMimeTypeByExt . T.unpack . fileName
406+ , ssGetMimeType = return . defaultMimeTypeByExt . fileName
404407 , ssMaxAge = MaxAgeForever
405408 , ssListing = Nothing
406409 , ssIndices = []
@@ -411,24 +414,24 @@ defaultFileServerSettings :: StaticSettings
411414defaultFileServerSettings = StaticSettings
412415 { ssFolder = fileSystemLookup "static"
413416 , ssMkRedirect = defaultMkRedirect
414− , ssGetMimeType = return . defaultMimeTypeByExt . T.unpack . fileName
417+ , ssGetMimeType = return . defaultMimeTypeByExt . fileName
415418 , ssMaxAge = MaxAgeSeconds $ 60 * 60
416419 , ssListing = Just defaultListing
417420 , ssIndices = ["index.html", "index.htm"]
418421 , ssUseHash = False
419422 }
420423
421−fileHelper :: FilePath -> T.Text -> IO File
424+fileHelper :: FilePath -> FilePath -> IO File
422425fileHelper fp name = do
423− fs <- getFileStatus fp
426+ fs <- getFileStatus $ fromFilePath fp
424427 return File
425428 { fileGetSize = fromIntegral $ fileSize fs
426− , fileToResponse = \s h -> W.ResponseFile s h fp Nothing
429+ , fileToResponse = \s h -> W.ResponseFile s h (fromFilePath fp) Nothing
427430 , fileName = name
428431 , fileGetHash = Just $ do
429432 -- FIXME replace lazy IO with enumerators
430433 -- FIXME let's use a dictionary to cache these values?
431− l <- L.readFile fp
434+ l <- L.readFile $ fromFilePath fp
432435 return $ runHashL l
433436 , fileGetModified = Just $ modificationTime fs
434437 }
@@ -436,35 +439,35 @@ fileHelper fp name = do
436439fileSystemLookup :: FilePath -> Pieces -> IO FileLookup
437440fileSystemLookup prefix pieces = do
438441 let fp = pathFromPieces prefix pieces
439− fe <- doesFileExist fp
442+ fe <- doesFileExist $ fromFilePath fp
440443 if fe
441− then fmap (Just . Right) $ fileHelper fp (piecePretty $ last pieces)
444+ then fmap (Just . Right) $ fileHelper fp $ last pieces
442445 else do
443− de <- doesDirectoryExist fp
446+ de <- doesDirectoryExist $ fromFilePath fp
444447 if de
445448 then do
446449 let isVisible ('.':_) = return False
447450 isVisible "" = return False
448451 isVisible _ = return True
449− entries <- getDirectoryContents fp >>= filterM isVisible >>= (mapM $ \name -> do
450− let name' = T.pack $ fixPathName name
451− let fp' = fp ++ '/' : name
452− fe' <- doesFileExist fp'
452+ entries <- getDirectoryContents (fromFilePath fp) >>= filterM isVisible >>= mapM (\nameRaw -> do
453+ let name = toFilePath nameRaw
454+ let fp' = fp </> name
455+ fe' <- doesFileExist $ fromFilePath fp'
453456 if fe'
454− then fmap Right $ fileHelper fp' name'
455− else return $ Left $ Folder name' [])
457+ then fmap Right $ fileHelper fp' name
458+ else return $ Left $ Folder name [])
456459 return $ Just $ Left $ Folder (error "413") entries
457460 else return Nothing
458461
459−type Embedded = Map.Map T.Text EmbeddedEntry
462+type Embedded = Map.Map FilePath EmbeddedEntry
460463
461464data EmbeddedEntry = EEFile S8.ByteString | EEFolder Embedded
462465
463466embeddedLookup :: Embedded -> Pieces -> IO FileLookup
464467embeddedLookup root pieces =
465− return $ elookup "<root>" (map piecePretty pieces) root
468+ return $ elookup "<root>" pieces root
466469 where
467− elookup :: T.Text -> [T.Text] -> Embedded -> FileLookup
470+ elookup :: FilePath -> [FilePath] -> Embedded -> FileLookup
468471 elookup p [] x = Just $ Left $ Folder p $ map toEntry $ Map.toList x
469472 elookup p [""] x = elookup p [] x
470473 elookup _ (p:ps) x =
@@ -476,7 +479,7 @@ embeddedLookup root pieces =
476479 _ -> Nothing
477480 Just (EEFolder y) -> elookup p ps y
478481
479−toEntry :: (T.Text, EmbeddedEntry) -> Either Folder File
482+toEntry :: (FilePath, EmbeddedEntry) -> Either Folder File
480483toEntry (name, EEFolder{}) = Left $ Folder name []
481484toEntry (name, EEFile bs) = Right $ File
482485 { fileGetSize = S8.length bs
@@ -486,30 +489,29 @@ toEntry (name, EEFile bs) = Right $ File
486489 , fileGetModified = Nothing
487490 }
488491
489−toEmbedded :: [(FilePath, S8.ByteString)] -> Embedded
492+toEmbedded :: [(Prelude.FilePath, S8.ByteString)] -> Embedded
490493toEmbedded fps =
491494 go texts
492495 where
493− texts = map (\(x, y) -> (filter (not . T.null) $ toPieces x, y)) fps
494− toPiece' fp = T.pack $ fixPathName fp
496+ texts = map (\(x, y) -> (filter (not . T.null . unFilePath) $ toPieces x, y)) fps
495497 toPieces "" = []
496498 toPieces x =
497499 let (y, z) = break (== '/') x
498− in toPiece' y : toPieces (drop 1 z)
499− go :: [([T.Text], S8.ByteString)] -> Embedded
500+ in toFilePath y : toPieces (drop 1 z)
501+ go :: [([FilePath], S8.ByteString)] -> Embedded
500502 go orig =
501503 Map.fromList $ map (second go') hoisted
502504 where
503505 next = map (\(x, y) -> (head x, (tail x, y))) orig
504− grouped :: [[(T.Text, ([T.Text], S8.ByteString))]]
506+ grouped :: [[(FilePath, ([FilePath], S8.ByteString))]]
505507 grouped = groupBy ((==) `on` fst) $ sortBy (comparing fst) next
506− hoisted :: [(T.Text, [([T.Text], S8.ByteString)])]
508+ hoisted :: [(FilePath, [([FilePath], S8.ByteString)])]
507509 hoisted = map (fst . head &&& map snd) grouped
508− go' :: [([T.Text], S8.ByteString)] -> EmbeddedEntry
510+ go' :: [([FilePath], S8.ByteString)] -> EmbeddedEntry
509511 go' [([], content)] = EEFile content
510512 go' x = EEFolder $ go $ filter (\y -> not $ null $ fst y) x
511513
512−bsToFile :: T.Text -> S8.ByteString -> File
514+bsToFile :: FilePath -> S8.ByteString -> File
513515bsToFile name bs = File
514516 { fileGetSize = S8.length bs
515517 , fileToResponse = \s h -> W.ResponseBuilder s h $ fromByteString bs
@@ -525,13 +527,7 @@ runHashL :: L.ByteString -> ByteString
525527runHashL = B64.encode . MD5.hashlazy
526528
527529staticApp :: StaticSettings -> W.Application
528−staticApp set req = staticAppPieces set (map toPiece $ W.pathInfo req) req
529−
530−toPiece :: T.Text -> Piece
531−toPiece t = Piece
532− { piecePretty = t
533− , pieceRaw = unfixPathName $ T.unpack t
534− }
530+staticApp set req = staticAppPieces set (map FilePath $ W.pathInfo req) req
535531
536532status304, statusNotModified :: H.Status
537533status304 = H.Status 304 "Not Modified"
@@ -559,7 +555,7 @@ staticAppPieces ss pieces req = liftIO $ do
559555 let indices = ssIndices ss
560556 case checkSpecialDirListing pieces of
561557 Just res -> response res
562− Nothing -> checkPieces (ssFolder ss) indices pieces req (ssMaxAge ss) (ssUseHash ss) >>= response
558+ Nothing -> checkPieces (ssFolder ss) (map FilePath indices) pieces req (ssMaxAge ss) (ssUseHash ss) >>= response
563559 where
564560 response cp = case cp of
565561 FileResponse file ch -> do
@@ -573,7 +569,7 @@ staticAppPieces ss pieces req = liftIO $ do
573569 return $ W.responseLBS statusNotModified
574570 [ ("Content-Type", "text/plain")
575571 ] "Not Modified"
576− DirectoryResponse fp ->
572+ DirectoryResponse fp -> do
577573 case ssListing ss of
578574 (Just f) -> do
579575 lbs <- f pieces fp
@@ -591,7 +587,7 @@ staticAppPieces ss pieces req = liftIO $ do
591587 ] lbs
592588
593589 Redirect pieces' mHash -> do
594− let loc = (ssMkRedirect ss) pieces' $ toByteString (H.encodePathSegments $ map piecePretty pieces')
590+ let loc = (ssMkRedirect ss) pieces' $ toByteString (H.encodePathSegments $ map unFilePath pieces')
595591 let qString = case mHash of
596592 Just hash -> replace "etag" (Just hash) (W.queryString req)
597593 Nothing -> remove "etag" (W.queryString req)
@@ -617,34 +613,34 @@ case for fixPathName/unfixPathName. I'm starting to use John
617613Millikin's system-filepath package for some stuff with work, and might
618614consider migrating over to it for this in the future.
619615-}
620−fixPathName :: FilePath -> FilePath
616+toFilePath :: Prelude.FilePath -> FilePath
621617#if defined(mingw32_HOST_OS)
622−fixPathName = id
618+toFilePath = FilePath . T.pack
623619#else
624−fixPathName = T.unpack . TE.decodeUtf8With TEE.lenientDecode . S8.pack
620+toFilePath = FilePath . TE.decodeUtf8With TEE.lenientDecode . S8.pack
625621#endif
626622
627−unfixPathName :: FilePath -> FilePath
623+fromFilePath :: FilePath -> Prelude.FilePath
628624#if defined(mingw32_HOST_OS)
629−unfixPathName = id
625+fromFilePath = T.unpack . unFilePath
630626#else
631−unfixPathName = S8.unpack . TE.encodeUtf8 . T.pack
627+fromFilePath = S8.unpack . TE.encodeUtf8 . unFilePath
632628#endif
633629
634630-- Code below taken from Happstack: http://patch-tag.com/r/mae/happstack/snapshot/current/content/pretty/happstack-server/src/Happstack/Server/FileServe/BuildingBlocks.hs
635631defaultListing :: Listing
636632defaultListing pieces (Folder _ contents) = do
637− let isTop = null pieces || pieces == [Piece "" ""]
633+ let isTop = null pieces || pieces == [""]
638634 let fps'' :: [Either Folder File]
639635 fps'' = (if isTop then id else (Left (Folder ".." []) :)) contents
640636 return $ HU.renderHtml
641637 $ H.html $ do
642638 H.head $ do
643− let title = T.unpack $ T.intercalate "/" $ map piecePretty pieces
639+ let title = T.unpack $ T.intercalate "/" $ map unFilePath pieces
644640 let title' = if null title then "root folder" else title
645641 H.title $ H.toHtml title'
646642 H.style $ H.toHtml $ unlines [ "table { margin: 0 auto; width: 760px; border-collapse: collapse; font-family: 'sans-serif'; }"
647− , "table, th, td { border: 1px solid #353948; }"
643+ , "table, th, td { border: 1px solid #353948; }"
648644 , "td.size { text-align: right; font-size: 0.7em; width: 50px }"
649645 , "td.date { text-align: right; font-size: 0.7em; width: 130px }"
650646 , "td { padding-right: 1em; padding-left: 1em; }"
@@ -658,7 +654,7 @@ defaultListing pieces (Folder _ contents) = do
658654 , "a { text-decoration: none }"
659655 ]
660656 H.body $ do
661− H.h1 $ showFolder $ map piecePretty $ filter (not . T.null . piecePretty) pieces
657+ H.h1 $ showFolder $ map unFilePath $ filter (not . nullFilePath) pieces
662658 renderDirectoryContentsTable haskellSrc folderSrc fps''
663659 where
664660 image x = T.unpack $ T.concat [(relativeDirFromPieces pieces), ".hidden/", x, ".png"]
@@ -709,7 +705,7 @@ renderDirectoryContentsTable haskellSrc folderSrc fps =
709705 Right{} -> return ()
710706 let name = either folderName fileName md
711707 let isFile = either (const False) (const True) md
712− H.td (H.a ! A.href (H.toValue $ name `T.append` if isFile then "" else "/") $ H.toHtml name)
708+ H.td (H.a ! A.href (H.toValue $ unFilePath name `T.append` if isFile then "" else "/") $ H.toHtml $ unFilePath name)
713709 H.td ! A.class_ "date" $ H.toHtml $
714710 case md of
715711 Right File { fileGetModified = Just t } ->