@@ -16,10 +16,6 @@ module Network.Wai.Application.Static
1616 -- ** Finding files
1717 , Pieces
1818 , pathFromPieces
19− -- ** File/folder metadata
20− , MetaData (..)
21− , mdIsFile
22− , getMetaData
2319 -- ** Directory listings
2420 , Listing
2521 , defaultListing
@@ -56,6 +52,7 @@ import System.Posix.Types (FileOffset, EpochTime)
5652import Control.Monad.IO.Class (liftIO)
5753import Data.Maybe (catMaybes, isNothing, isJust)
5854import qualified Crypto.Hash.MD5 as MD5
55+import Control.Monad (filterM)
5956
6057import Text.Blaze ((!))
6158import qualified Text.Blaze.Html5 as H
@@ -80,6 +77,7 @@ import Data.List (groupBy, sortBy)
8077import Data.Function (on)
8178import Data.Ord (comparing)
8279import qualified Data.ByteString.Base64 as B64
80+import Data.Either (rights)
8381
8482#ifdef PRINT
8583import Debug.Trace
@@ -258,8 +256,8 @@ checkPieces fileLookup indices pieces req ss
258256 (FLDoesNotExist, _) -> return NotFound
259257 (FLFile file, True) -> handleCache file
260258 (FLFile{}, False) -> return $ Redirect $ init pieces
261− (FLFolder folder@(Folder contents), _) -> do
262− case checkIndices $ map feName $ filter feIsFile contents of
259+ (FLFolder folder@(Folder _ contents), _) -> do
260+ case checkIndices $ map fileName $ rights contents of
263261 Just index -> return $ Redirect $ setLast pieces $ Piece (T.unpack index) index
264262 Nothing ->
265263 if isFolder
@@ -276,8 +274,7 @@ checkPieces fileLookup indices pieces req ss
276274 else return $ FileResponse file $ cc [("ETag", hash)]
277275 _ ->
278276 case (lookup "if-modified-since" headers >>= parseDate, fileGetModified file) of
279− (Just lastSent, Just getMod) -> do
280− modified <- getMod
277+ (Just lastSent, Just modified) -> do
281278 if lastSent >= modified
282279 then return NotModified
283280 else respond file
@@ -327,22 +324,25 @@ defaultDirListing = StaticDirListing (Just defaultListing) []
327324oneYear :: Int
328325oneYear = 60 * 60 * 24 * 365
329326
330−data FileLookup = FLFolder Folder | FLFile File | FLDoesNotExist
327+data FileLookup = FLFolder Folder | FLFile File | FLDoesNotExist -- FIXME remove
331328
332−data Folder = Folder [FolderEntry] -- Bool: True = file, False = folder
329+data Folder = Folder
330+ { folderName :: T.Text
331+ , folderContents :: [Either Folder File]
332+ }
333333
334−data FolderEntry = FolderEntry
334+data FolderEntry = FolderEntry -- FIXME remove
335335 { feName :: T.Text
336336 , feIsFile :: Bool
337− , feGetMetaData :: IO (Maybe MetaData)
337+ --, feGetMetaData :: IO (Maybe MetaData)
338338 }
339339
340340data File = File
341− { fileGetSize :: IO Int
341+ { fileGetSize :: Int
342342 , fileToResponse :: H.Status -> H.ResponseHeaders -> W.Response
343343 , fileName :: T.Text
344344 , fileGetHash :: Maybe (IO ByteString)
345− , fileGetModified :: Maybe (IO EpochTime)
345+ , fileGetModified :: Maybe EpochTime
346346 }
347347
348348parseDate :: ByteString -> Maybe EpochTime
@@ -382,8 +382,9 @@ fileSystemLookup prefix pieces = do
382382 fe <- doesFileExist fp
383383 if fe
384384 then do
385+ fs <- getFileStatus fp
385386 return $ FLFile File
386− { fileGetSize = fmap (fromIntegral . fileSize) $ getFileStatus fp
387+ { fileGetSize = fromIntegral $ fileSize fs
387388 , fileToResponse = \s h -> W.ResponseFile s h fp Nothing
388389 , fileName = piecePretty $ last pieces
389390 , fileGetHash = Just $ do
@@ -391,22 +392,35 @@ fileSystemLookup prefix pieces = do
391392 -- FIXME let's use a dictionary to cache these values?
392393 l <- L.readFile fp
393394 return $ runHashL l
394− , fileGetModified = Just $ fmap modificationTime $ getFileStatus fp
395+ , fileGetModified = Just $ modificationTime fs
395396 }
396397 else do
397398 de <- doesDirectoryExist fp
398399 if de
399400 then do
400− entries <- getDirectoryContents fp >>= (mapM $ \name -> do
401− let name' = T.pack name
401+ let isVisible ('.':_) = return False
402+ isVisible "" = return False
403+ isVisible _ = return True
404+ entries <- getDirectoryContents fp >>= filterM isVisible >>= (mapM $ \name -> do
405+ let name' = T.pack $ fixPathName name
402406 let fp' = fp ++ '/' : name
403407 fe' <- doesFileExist fp'
404− return FolderEntry
405− { feName = name'
406− , feIsFile = fe'
407− , feGetMetaData = getMetaData fp name
408− })
409− return $ FLFolder $ Folder entries
408+ if fe'
409+ then do
410+ fs <- getFileStatus fp'
411+ return $ Right File
412+ { fileGetSize = fromIntegral $ fileSize fs
413+ , fileToResponse = \s h -> W.ResponseFile s h fp' Nothing
414+ , fileName = name'
415+ , fileGetHash = Just $ do
416+ -- FIXME replace lazy IO with enumerators
417+ -- FIXME let's use a dictionary to cache these values?
418+ l <- L.readFile fp'
419+ return $ runHashL l
420+ , fileGetModified = Just $ modificationTime fs
421+ }
422+ else return $ Left $ Folder name' [])
423+ return $ FLFolder $ Folder (error "413") entries
410424 else return FLDoesNotExist
411425
412426type Embedded = Map.Map T.Text EmbeddedEntry
@@ -415,37 +429,28 @@ data EmbeddedEntry = EEFile S8.ByteString | EEFolder Embedded
415429
416430embeddedLookup :: Embedded -> Pieces -> IO FileLookup
417431embeddedLookup root pieces =
418− return $ elookup (map piecePretty pieces) root
432+ return $ elookup "<root>" (map piecePretty pieces) root
419433 where
420− elookup :: [T.Text] -> Embedded -> FileLookup
421− elookup [] x = FLFolder $ Folder $ map toEntry $ Map.toList x
422− elookup [""] x = elookup [] x
423− elookup (p:ps) x =
434+ elookup :: T.Text -> [T.Text] -> Embedded -> FileLookup
435+ elookup p [] x = FLFolder $ Folder p $ map toEntry $ Map.toList x
436+ elookup p [""] x = elookup p [] x
437+ elookup _ (p:ps) x =
424438 case Map.lookup p x of
425439 Nothing -> FLDoesNotExist
426440 Just (EEFile f) ->
427441 case ps of
428442 [] -> FLFile $ bsToFile p f
429443 _ -> FLDoesNotExist
430− Just (EEFolder y) -> elookup ps y
431−
432−toEntry :: (T.Text, EmbeddedEntry) -> FolderEntry
433−toEntry (name, ee) = FolderEntry
434− { feName = name
435− , feIsFile =
436− case ee of
437− EEFile{} -> True
438− EEFolder{} -> False
439− , feGetMetaData = return $ Just $
440− case ee of
441− EEFile bs -> FileMetaData
442− { mdName = name
443− , mdModified = Nothing
444− , mdSize = fromIntegral $ S8.length bs
445− }
446− EEFolder _ -> FolderMetaData
447− { mdName = name
448− }
444+ Just (EEFolder y) -> elookup p ps y
445+
446+toEntry :: (T.Text, EmbeddedEntry) -> Either Folder File
447+toEntry (name, EEFolder e) = Left $ Folder name (error "toEntry")
448+toEntry (name, EEFile bs) = Right $ File
449+ { fileGetSize = S8.length bs
450+ , fileToResponse = \s h -> W.ResponseBuilder s h $ fromByteString bs
451+ , fileName = name
452+ , fileGetHash = Just $ return $ runHash bs
453+ , fileGetModified = Nothing
449454 }
450455
451456toEmbedded :: [(FilePath, S8.ByteString)] -> Embedded
@@ -473,7 +478,7 @@ toEmbedded fps =
473478
474479bsToFile :: T.Text -> S8.ByteString -> File
475480bsToFile name bs = File
476− { fileGetSize = return $ S8.length bs
481+ { fileGetSize = S8.length bs
477482 , fileToResponse = \s h -> W.ResponseBuilder s h $ fromByteString bs
478483 , fileName = name
479484 , fileGetHash = Just $ return $ runHash bs
@@ -512,7 +517,7 @@ staticAppPieces ss pieces req = liftIO $ do
512517 case cp of
513518 FileResponse file ch -> do
514519 mimetype <- ssGetMimeType ss file
515− filesize <- fileGetSize file
520+ let filesize = fileGetSize file
516521 let headers = ("Content-Type", mimetype)
517522 : ("Content-Length", S8.pack $ show filesize)
518523 : ch
@@ -600,10 +605,10 @@ unfixPathName = S8.unpack . TE.encodeUtf8 . T.pack
600605
601606-- Code below taken from Happstack: http://patch-tag.com/r/mae/happstack/snapshot/current/content/pretty/happstack-server/src/Happstack/Server/FileServe/BuildingBlocks.hs
602607defaultListing :: Listing
603−defaultListing pieces (Folder contents) = do
604− fps' <- mapM feGetMetaData contents
608+defaultListing pieces (Folder _ contents) = do
605609 let isTop = null pieces || pieces == [Piece "" ""]
606− let fps'' = if isTop then fps' else Just (FolderMetaData "..") : fps'
610+ let fps'' :: [Either Folder File]
611+ fps'' = (if isTop then id else (Left (Folder ".." []) :)) contents
607612 return $ HU.renderHtml
608613 $ H.html $ do
609614 H.head $ do
@@ -626,7 +631,7 @@ defaultListing pieces (Folder contents) = do
626631 ]
627632 H.body $ do
628633 H.h1 $ showFolder $ map (T.unpack . piecePretty) $ filter (not . T.null . piecePretty) pieces -- FIXME don't unpack
629− renderDirectoryContentsTable haskellSrc folderSrc $ catMaybes fps''
634+ renderDirectoryContentsTable haskellSrc folderSrc fps''
630635 where
631636 image x = T.unpack $ T.concat [(relativeDirFromPieces pieces), ".hidden/", x, ".png"]
632637 folderSrc = image "folder"
@@ -651,7 +656,7 @@ defaultListing pieces (Folder contents) = do
651656-- see also: 'getMetaData', 'renderDirectoryContents'
652657renderDirectoryContentsTable :: String
653658 -> String
654− -> [MetaData] -- ^ list of files+meta data, see 'getMetaData'
659+ -> [Either Folder File]
655660 -> H.Html
656661renderDirectoryContentsTable haskellSrc folderSrc fps =
657662 H.table $ do H.thead $ do H.th ! (A.class_ $ H.stringValue "first") $ H.img ! (A.src $ H.stringValue haskellSrc)
@@ -660,30 +665,32 @@ renderDirectoryContentsTable haskellSrc folderSrc fps =
660665 H.th $ H.string "Size"
661666 H.tbody $ mapM_ mkRow (zip (sortBy sortMD fps) $ cycle [False, True])
662667 where
663− sortMD FolderMetaData{} FileMetaData{} = LT
664− sortMD FileMetaData{} FolderMetaData{} = GT
665− sortMD x y = mdName x `compare` mdName y
666− mkRow :: (MetaData, Bool) -> H.Html
668+ sortMD :: Either Folder File -> Either Folder File -> Ordering
669+ sortMD Left{} Right{} = LT
670+ sortMD Right{} Left{} = GT
671+ sortMD (Left a) (Left b) = compare (folderName a) (folderName b)
672+ sortMD (Right a) (Right b) = compare (fileName a) (fileName b)
673+ mkRow :: (Either Folder File, Bool) -> H.Html
667674 mkRow (md, alt) =
668675 (if alt then (! A.class_ (H.stringValue "alt")) else id) $
669676 H.tr $ do
670677 H.td ! A.class_ (H.stringValue "first")
671− $ if mdIsFile md
672− then return ()
673− else H.img ! A.src (H.stringValue folderSrc)
674− ! A.alt (H.stringValue "Folder")
675− H.td (H.a ! A.href (H.stringValue $ T.unpack (mdName md) ++ if mdIsFile md then "" else "/") $ H.string $ T.unpack (mdName md))
676− H.td ! A.class_ (H.stringValue "date") $ H.string $
677− if mdIsFile md
678− then
679− case mdModified md of
680− Nothing -> ""
681− Just t -> formatCalendarTime defaultTimeLocale "%d-%b-%Y %X" t
682− else ""
683− H.td ! A.class_ (H.stringValue "size") $ H.string $
684− if mdIsFile md
685− then prettyShow $ mdSize md
686− else ""
678+ $ case md of
679+ Left{} -> H.img ! A.src (H.stringValue folderSrc)
680+ ! A.alt (H.stringValue "Folder")
681+ Right{} -> return ()
682+ let name = either folderName fileName md
683+ let isFile = either (const False) (const True) md
684+ H.td (H.a ! A.href (H.toValue $ name `T.append` if isFile then "" else "/") $ H.toHtml name)
685+ H.td ! A.class_ "date" $ H.toHtml $
686+ case md of
687+ Right File { fileGetModified = Just t } ->
688+ formatCalendarTime defaultTimeLocale "%d-%b-%Y %X" t
689+ _ -> ""
690+ H.td ! A.class_ "size" $ H.toHtml $
691+ case md of
692+ Right File { fileGetSize = s } -> prettyShow s
693+ Left{} -> ""
687694 formatCalendarTime a b c = formatTime a b $ posixSecondsToUTCTime (realToFrac c :: POSIXTime)
688695 prettyShow x
689696 | x > 1024 = prettyShowK $ x `div` 1024
@@ -699,17 +706,7 @@ renderDirectoryContentsTable haskellSrc folderSrc fps =
699706 addCommas' (a:b:c:d:e) = a : b : c : ',' : addCommas' (d : e)
700707 addCommas' x = x
701708
702−data MetaData =
703− FileMetaData
704− { mdName :: T.Text
705− , mdModified :: Maybe EpochTime
706− , mdSize :: FileOffset
707− }
708− | FolderMetaData
709− { mdName :: T.Text
710− }
711− deriving Show
712−
709+{-
713710mdIsFile :: MetaData -> Bool
714711mdIsFile FileMetaData{} = True
715712mdIsFile FolderMetaData{} = False
@@ -732,3 +729,4 @@ getMetaData localPath fp = do
732729 else do
733730 de <- doesDirectoryExist fp'
734731 return $ if de then Just (FolderMetaData fpPretty) else Nothing
732+-}