git.iko.soy/typeable/wai
on master help sign in
Rewriting stuff, embedded broken
500cb45Michael Snoyman
Network/Wai/Application/Static.hs+84−86
compare with master
unifiedsplit
@@ -16,10 +16,6 @@ module Network.Wai.Application.Static
16 -- ** Finding files
16 -- ** Finding files
17 , Pieces
17 , Pieces
18 , pathFromPieces
18 , pathFromPieces
19− -- ** File/folder metadata
20− , MetaData (..)
21− , mdIsFile
22− , getMetaData
23 -- ** Directory listings
19 -- ** Directory listings
24 , Listing
20 , Listing
25 , defaultListing
21 , defaultListing
@@ -56,6 +52,7 @@ import System.Posix.Types (FileOffset, EpochTime)
56import Control.Monad.IO.Class (liftIO)
52import Control.Monad.IO.Class (liftIO)
57import Data.Maybe (catMaybes, isNothing, isJust)
53import Data.Maybe (catMaybes, isNothing, isJust)
58import qualified Crypto.Hash.MD5 as MD5
54import qualified Crypto.Hash.MD5 as MD5
55+import Control.Monad (filterM)
59
56
60import Text.Blaze ((!))
57import Text.Blaze ((!))
61import qualified Text.Blaze.Html5 as H
58import qualified Text.Blaze.Html5 as H
@@ -80,6 +77,7 @@ import Data.List (groupBy, sortBy)
80import Data.Function (on)
77import Data.Function (on)
81import Data.Ord (comparing)
78import Data.Ord (comparing)
82import qualified Data.ByteString.Base64 as B64
79import qualified Data.ByteString.Base64 as B64
80+import Data.Either (rights)
83
81
84#ifdef PRINT
82#ifdef PRINT
85import Debug.Trace
83import Debug.Trace
@@ -258,8 +256,8 @@ checkPieces fileLookup indices pieces req ss
258 (FLDoesNotExist, _) -> return NotFound
256 (FLDoesNotExist, _) -> return NotFound
259 (FLFile file, True) -> handleCache file
257 (FLFile file, True) -> handleCache file
260 (FLFile{}, False) -> return $ Redirect $ init pieces
258 (FLFile{}, False) -> return $ Redirect $ init pieces
261− (FLFolder folder@(Folder contents), _) -> do
259+ (FLFolder folder@(Folder _ contents), _) -> do
262− case checkIndices $ map feName $ filter feIsFile contents of
260+ case checkIndices $ map fileName $ rights contents of
263 Just index -> return $ Redirect $ setLast pieces $ Piece (T.unpack index) index
261 Just index -> return $ Redirect $ setLast pieces $ Piece (T.unpack index) index
264 Nothing ->
262 Nothing ->
265 if isFolder
263 if isFolder
@@ -276,8 +274,7 @@ checkPieces fileLookup indices pieces req ss
276 else return $ FileResponse file $ cc [("ETag", hash)]
274 else return $ FileResponse file $ cc [("ETag", hash)]
277 _ ->
275 _ ->
278 case (lookup "if-modified-since" headers >>= parseDate, fileGetModified file) of
276 case (lookup "if-modified-since" headers >>= parseDate, fileGetModified file) of
279− (Just lastSent, Just getMod) -> do
277+ (Just lastSent, Just modified) -> do
280− modified <- getMod
281 if lastSent >= modified
278 if lastSent >= modified
282 then return NotModified
279 then return NotModified
283 else respond file
280 else respond file
@@ -327,22 +324,25 @@ defaultDirListing = StaticDirListing (Just defaultListing) []
327oneYear :: Int
324oneYear :: Int
328oneYear = 60 * 60 * 24 * 365
325oneYear = 60 * 60 * 24 * 365
329
326
330−data FileLookup = FLFolder Folder | FLFile File | FLDoesNotExist
327+data FileLookup = FLFolder Folder | FLFile File | FLDoesNotExist -- FIXME remove
331
328
332−data Folder = Folder [FolderEntry] -- Bool: True = file, False = folder
329+data Folder = Folder
330+ { folderName :: T.Text
331+ , folderContents :: [Either Folder File]
332+ }
333
333
334−data FolderEntry = FolderEntry
334+data FolderEntry = FolderEntry -- FIXME remove
335 { feName :: T.Text
335 { feName :: T.Text
336 , feIsFile :: Bool
336 , feIsFile :: Bool
337− , feGetMetaData :: IO (Maybe MetaData)
337+ --, feGetMetaData :: IO (Maybe MetaData)
338 }
338 }
339
339
340data File = File
340data File = File
341− { fileGetSize :: IO Int
341+ { fileGetSize :: Int
342 , fileToResponse :: H.Status -> H.ResponseHeaders -> W.Response
342 , fileToResponse :: H.Status -> H.ResponseHeaders -> W.Response
343 , fileName :: T.Text
343 , fileName :: T.Text
344 , fileGetHash :: Maybe (IO ByteString)
344 , fileGetHash :: Maybe (IO ByteString)
345− , fileGetModified :: Maybe (IO EpochTime)
345+ , fileGetModified :: Maybe EpochTime
346 }
346 }
347
347
348parseDate :: ByteString -> Maybe EpochTime
348parseDate :: ByteString -> Maybe EpochTime
@@ -382,8 +382,9 @@ fileSystemLookup prefix pieces = do
382 fe <- doesFileExist fp
382 fe <- doesFileExist fp
383 if fe
383 if fe
384 then do
384 then do
385+ fs <- getFileStatus fp
385 return $ FLFile File
386 return $ FLFile File
386− { fileGetSize = fmap (fromIntegral . fileSize) $ getFileStatus fp
387+ { fileGetSize = fromIntegral $ fileSize fs
387 , fileToResponse = \s h -> W.ResponseFile s h fp Nothing
388 , fileToResponse = \s h -> W.ResponseFile s h fp Nothing
388 , fileName = piecePretty $ last pieces
389 , fileName = piecePretty $ last pieces
389 , fileGetHash = Just $ do
390 , fileGetHash = Just $ do
@@ -391,22 +392,35 @@ fileSystemLookup prefix pieces = do
391 -- FIXME let's use a dictionary to cache these values?
392 -- FIXME let's use a dictionary to cache these values?
392 l <- L.readFile fp
393 l <- L.readFile fp
393 return $ runHashL l
394 return $ runHashL l
394− , fileGetModified = Just $ fmap modificationTime $ getFileStatus fp
395+ , fileGetModified = Just $ modificationTime fs
395 }
396 }
396 else do
397 else do
397 de <- doesDirectoryExist fp
398 de <- doesDirectoryExist fp
398 if de
399 if de
399 then do
400 then do
401+ let isVisible ('.':_) = return False
402+ isVisible "" = return False
403+ isVisible _ = return True
400− entries <- getDirectoryContents fp >>= (mapM $ \name -> do
404+ entries <- getDirectoryContents fp >>= filterM isVisible >>= (mapM $ \name -> do
401− let name' = T.pack name
405+ let name' = T.pack $ fixPathName name
402 let fp' = fp ++ '/' : name
406 let fp' = fp ++ '/' : name
403 fe' <- doesFileExist fp'
407 fe' <- doesFileExist fp'
404− return FolderEntry
408+ if fe'
405− { feName = name'
409+ then do
406− , feIsFile = fe'
410+ fs <- getFileStatus fp'
407− , feGetMetaData = getMetaData fp name
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
408− })
421+ }
422+ else return $ Left $ Folder name' [])
409− return $ FLFolder $ Folder entries
423+ return $ FLFolder $ Folder (error "413") entries
410 else return FLDoesNotExist
424 else return FLDoesNotExist
411
425
412type Embedded = Map.Map T.Text EmbeddedEntry
426type Embedded = Map.Map T.Text EmbeddedEntry
@@ -415,37 +429,28 @@ data EmbeddedEntry = EEFile S8.ByteString | EEFolder Embedded
415
429
416embeddedLookup :: Embedded -> Pieces -> IO FileLookup
430embeddedLookup :: Embedded -> Pieces -> IO FileLookup
417embeddedLookup root pieces =
431embeddedLookup root pieces =
418− return $ elookup (map piecePretty pieces) root
432+ return $ elookup "<root>" (map piecePretty pieces) root
419 where
433 where
420− elookup :: [T.Text] -> Embedded -> FileLookup
434+ elookup :: T.Text -> [T.Text] -> Embedded -> FileLookup
421− elookup [] x = FLFolder $ Folder $ map toEntry $ Map.toList x
435+ elookup p [] x = FLFolder $ Folder p $ map toEntry $ Map.toList x
422− elookup [""] x = elookup [] x
436+ elookup p [""] x = elookup p [] x
423− elookup (p:ps) x =
437+ elookup _ (p:ps) x =
424 case Map.lookup p x of
438 case Map.lookup p x of
425 Nothing -> FLDoesNotExist
439 Nothing -> FLDoesNotExist
426 Just (EEFile f) ->
440 Just (EEFile f) ->
427 case ps of
441 case ps of
428 [] -> FLFile $ bsToFile p f
442 [] -> FLFile $ bsToFile p f
429 _ -> FLDoesNotExist
443 _ -> FLDoesNotExist
430− Just (EEFolder y) -> elookup ps y
444+ Just (EEFolder y) -> elookup p ps y
431−
445+
432−toEntry :: (T.Text, EmbeddedEntry) -> FolderEntry
446+toEntry :: (T.Text, EmbeddedEntry) -> Either Folder File
447+toEntry (name, EEFolder e) = Left $ Folder name (error "toEntry")
433−toEntry (name, ee) = FolderEntry
448+toEntry (name, EEFile bs) = Right $ File
434− { feName = name
449+ { fileGetSize = S8.length bs
435− , feIsFile =
450+ , fileToResponse = \s h -> W.ResponseBuilder s h $ fromByteString bs
436− case ee of
451+ , fileName = name
437− EEFile{} -> True
452+ , fileGetHash = Just $ return $ runHash bs
438− EEFolder{} -> False
453+ , fileGetModified = Nothing
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− }
449 }
454 }
450
455
451toEmbedded :: [(FilePath, S8.ByteString)] -> Embedded
456toEmbedded :: [(FilePath, S8.ByteString)] -> Embedded
@@ -473,7 +478,7 @@ toEmbedded fps =
473
478
474bsToFile :: T.Text -> S8.ByteString -> File
479bsToFile :: T.Text -> S8.ByteString -> File
475bsToFile name bs = File
480bsToFile name bs = File
476− { fileGetSize = return $ S8.length bs
481+ { fileGetSize = S8.length bs
477 , fileToResponse = \s h -> W.ResponseBuilder s h $ fromByteString bs
482 , fileToResponse = \s h -> W.ResponseBuilder s h $ fromByteString bs
478 , fileName = name
483 , fileName = name
479 , fileGetHash = Just $ return $ runHash bs
484 , fileGetHash = Just $ return $ runHash bs
@@ -512,7 +517,7 @@ staticAppPieces ss pieces req = liftIO $ do
512 case cp of
517 case cp of
513 FileResponse file ch -> do
518 FileResponse file ch -> do
514 mimetype <- ssGetMimeType ss file
519 mimetype <- ssGetMimeType ss file
515− filesize <- fileGetSize file
520+ let filesize = fileGetSize file
516 let headers = ("Content-Type", mimetype)
521 let headers = ("Content-Type", mimetype)
517 : ("Content-Length", S8.pack $ show filesize)
522 : ("Content-Length", S8.pack $ show filesize)
518 : ch
523 : ch
@@ -600,10 +605,10 @@ unfixPathName = S8.unpack . TE.encodeUtf8 . T.pack
600
605
601-- Code below taken from Happstack: http://patch-tag.com/r/mae/happstack/snapshot/current/content/pretty/happstack-server/src/Happstack/Server/FileServe/BuildingBlocks.hs
606-- Code below taken from Happstack: http://patch-tag.com/r/mae/happstack/snapshot/current/content/pretty/happstack-server/src/Happstack/Server/FileServe/BuildingBlocks.hs
602defaultListing :: Listing
607defaultListing :: Listing
603−defaultListing pieces (Folder contents) = do
608+defaultListing pieces (Folder _ contents) = do
604− fps' <- mapM feGetMetaData contents
605 let isTop = null pieces || pieces == [Piece "" ""]
609 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
607 return $ HU.renderHtml
612 return $ HU.renderHtml
608 $ H.html $ do
613 $ H.html $ do
609 H.head $ do
614 H.head $ do
@@ -626,7 +631,7 @@ defaultListing pieces (Folder contents) = do
626 ]
631 ]
627 H.body $ do
632 H.body $ do
628 H.h1 $ showFolder $ map (T.unpack . piecePretty) $ filter (not . T.null . piecePretty) pieces -- FIXME don't unpack
633 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''
630 where
635 where
631 image x = T.unpack $ T.concat [(relativeDirFromPieces pieces), ".hidden/", x, ".png"]
636 image x = T.unpack $ T.concat [(relativeDirFromPieces pieces), ".hidden/", x, ".png"]
632 folderSrc = image "folder"
637 folderSrc = image "folder"
@@ -651,7 +656,7 @@ defaultListing pieces (Folder contents) = do
651-- see also: 'getMetaData', 'renderDirectoryContents'
656-- see also: 'getMetaData', 'renderDirectoryContents'
652renderDirectoryContentsTable :: String
657renderDirectoryContentsTable :: String
653 -> String
658 -> String
654− -> [MetaData] -- ^ list of files+meta data, see 'getMetaData'
659+ -> [Either Folder File]
655 -> H.Html
660 -> H.Html
656renderDirectoryContentsTable haskellSrc folderSrc fps =
661renderDirectoryContentsTable haskellSrc folderSrc fps =
657 H.table $ do H.thead $ do H.th ! (A.class_ $ H.stringValue "first") $ H.img ! (A.src $ H.stringValue haskellSrc)
662 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 =
660 H.th $ H.string "Size"
665 H.th $ H.string "Size"
661 H.tbody $ mapM_ mkRow (zip (sortBy sortMD fps) $ cycle [False, True])
666 H.tbody $ mapM_ mkRow (zip (sortBy sortMD fps) $ cycle [False, True])
662 where
667 where
663− sortMD FolderMetaData{} FileMetaData{} = LT
668+ sortMD :: Either Folder File -> Either Folder File -> Ordering
664− sortMD FileMetaData{} FolderMetaData{} = GT
669+ sortMD Left{} Right{} = LT
665− sortMD x y = mdName x `compare` mdName y
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)
666− mkRow :: (MetaData, Bool) -> H.Html
673+ mkRow :: (Either Folder File, Bool) -> H.Html
667 mkRow (md, alt) =
674 mkRow (md, alt) =
668 (if alt then (! A.class_ (H.stringValue "alt")) else id) $
675 (if alt then (! A.class_ (H.stringValue "alt")) else id) $
669 H.tr $ do
676 H.tr $ do
670 H.td ! A.class_ (H.stringValue "first")
677 H.td ! A.class_ (H.stringValue "first")
671− $ if mdIsFile md
678+ $ case md of
672− then return ()
673− else H.img ! A.src (H.stringValue folderSrc)
679+ Left{} -> H.img ! A.src (H.stringValue folderSrc)
674− ! A.alt (H.stringValue "Folder")
680+ ! 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))
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)
676− H.td ! A.class_ (H.stringValue "date") $ H.string $
685+ H.td ! A.class_ "date" $ H.toHtml $
677− if mdIsFile md
686+ case md of
678− then
687+ Right File { fileGetModified = Just t } ->
679− case mdModified md of
680− Nothing -> ""
681− Just t -> formatCalendarTime defaultTimeLocale "%d-%b-%Y %X" t
688+ formatCalendarTime defaultTimeLocale "%d-%b-%Y %X" t
682− else ""
689+ _ -> ""
683− H.td ! A.class_ (H.stringValue "size") $ H.string $
690+ H.td ! A.class_ "size" $ H.toHtml $
684− if mdIsFile md
691+ case md of
685− then prettyShow $ mdSize md
692+ Right File { fileGetSize = s } -> prettyShow s
686− else ""
693+ Left{} -> ""
687 formatCalendarTime a b c = formatTime a b $ posixSecondsToUTCTime (realToFrac c :: POSIXTime)
694 formatCalendarTime a b c = formatTime a b $ posixSecondsToUTCTime (realToFrac c :: POSIXTime)
688 prettyShow x
695 prettyShow x
689 | x > 1024 = prettyShowK $ x `div` 1024
696 | x > 1024 = prettyShowK $ x `div` 1024
@@ -699,17 +706,7 @@ renderDirectoryContentsTable haskellSrc folderSrc fps =
699 addCommas' (a:b:c:d:e) = a : b : c : ',' : addCommas' (d : e)
706 addCommas' (a:b:c:d:e) = a : b : c : ',' : addCommas' (d : e)
700 addCommas' x = x
707 addCommas' x = x
701
708
702−data MetaData =
709+{-
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−
713mdIsFile :: MetaData -> Bool
710mdIsFile :: MetaData -> Bool
714mdIsFile FileMetaData{} = True
711mdIsFile FileMetaData{} = True
715mdIsFile FolderMetaData{} = False
712mdIsFile FolderMetaData{} = False
@@ -732,3 +729,4 @@ getMetaData localPath fp = do
732 else do
729 else do
733 de <- doesDirectoryExist fp'
730 de <- doesDirectoryExist fp'
734 return $ if de then Just (FolderMetaData fpPretty) else Nothing
731 return $ if de then Just (FolderMetaData fpPretty) else Nothing
732+-}