git.iko.soy/typeable/wai
on master help sign in
Fix some lookups
3f42a79Michael Snoyman
wai-app-static/Backend/Filesystem.hs+30−16
compare with master
unifiedsplit
@@ -17,6 +17,7 @@ import qualified Network.Wai as W
17import Listing
17import Listing
18import Mime
18import Mime
19import System.PosixCompat.Files (fileSize, getFileStatus, modificationTime)
19import System.PosixCompat.Files (fileSize, getFileStatus, modificationTime)
20+import Data.Maybe (catMaybes)
20
21
21pathFromPieces :: FilePath -> Pieces -> FilePath
22pathFromPieces :: FilePath -> Pieces -> FilePath
22pathFromPieces = foldl' (\fp p -> fp </> F.fromText (fromPiece p))
23pathFromPieces = foldl' (\fp p -> fp </> F.fromText (fromPiece p))
@@ -49,15 +50,21 @@ webAppSettingsWithLookup :: FilePath -> ETagLookup -> StaticSettings
49webAppSettingsWithLookup dir etagLookup =
50webAppSettingsWithLookup dir etagLookup =
50 defaultWebAppSettings { ssLookupFile = webAppLookup etagLookup dir}
51 defaultWebAppSettings { ssLookupFile = webAppLookup etagLookup dir}
51
52
53+fileHelperLR :: ETagLookup
54+ -> FilePath -- ^ file location
55+ -> Piece -- ^ file name
56+ -> IO LookupResult
57+fileHelperLR a b c = fmap (maybe LRNotFound LRFile) $ fileHelper a b c
58+
52fileHelper :: ETagLookup
59fileHelper :: ETagLookup
53 -> FilePath -- ^ file location
60 -> FilePath -- ^ file location
54 -> Piece -- ^ file name
61 -> Piece -- ^ file name
55− -> IO LookupResult
62+ -> IO (Maybe File)
56fileHelper hashFunc fp name = do
63fileHelper hashFunc fp name = do
57 efs <- try $ getFileStatus $ F.encodeString fp
64 efs <- try $ getFileStatus $ F.encodeString fp
58 case efs of
65 case efs of
59− Left (_ :: SomeException) -> return LRNotFound
66+ Left (_ :: SomeException) -> return Nothing
60− Right fs -> return $ LRFile File
67+ Right fs -> return $ Just File
61 { fileGetSize = fromIntegral $ fileSize fs
68 { fileGetSize = fromIntegral $ fileSize fs
62 , fileToResponse = \s h -> W.ResponseFile s h (F.encodeString fp) Nothing
69 , fileToResponse = \s h -> W.ResponseFile s h (F.encodeString fp) Nothing
63 , fileName = name
70 , fileName = name
@@ -69,9 +76,12 @@ type ETagLookup = (FilePath -> IO (Maybe ByteString))
69
76
70webAppLookup :: ETagLookup -> FilePath -> Pieces -> IO LookupResult
77webAppLookup :: ETagLookup -> FilePath -> Pieces -> IO LookupResult
71webAppLookup cachedLookupHash prefix pieces =
78webAppLookup cachedLookupHash prefix pieces =
72− fileHelper cachedLookupHash fp $ last pieces
79+ fileHelperLR cachedLookupHash fp lastPiece
73 where
80 where
74 fp = pathFromPieces prefix pieces
81 fp = pathFromPieces prefix pieces
82+ lastPiece
83+ | null pieces = unsafeToPiece ""
84+ | otherwise = last pieces
75
85
76defaultFileSystemHash :: ETagLookup
86defaultFileSystemHash :: ETagLookup
77defaultFileSystemHash fp = fmap Just $ hashFile fp
87defaultFileSystemHash fp = fmap Just $ hashFile fp
@@ -98,7 +108,7 @@ filePathToPiece = unsafeToPiece . either id id . F.toText
98
108
99isVisible :: FilePath -> Bool
109isVisible :: FilePath -> Bool
100isVisible =
110isVisible =
101− go . F.encodeString
111+ go . F.encodeString . F.filename
102 where
112 where
103 go ('.':_) = False
113 go ('.':_) = False
104 go "" = False
114 go "" = False
@@ -110,21 +120,25 @@ fileSystemLookupHash hashFunc prefix pieces = do
110 let fp = pathFromPieces prefix pieces
120 let fp = pathFromPieces prefix pieces
111 fe <- F.isFile fp
121 fe <- F.isFile fp
112 if fe
122 if fe
113− then fileHelper hashFunc fp $ last pieces
123+ then fileHelperLR hashFunc fp lastPiece
114 else do
124 else do
115 de <- F.isDirectory fp
125 de <- F.isDirectory fp
116 if de
126 if de
117 then do
127 then do
118 entries' <- fmap (filter isVisible) $ F.listDirectory fp
128 entries' <- fmap (filter isVisible) $ F.listDirectory fp
119 entries <- forM entries' $ \fp' -> do
129 entries <- forM entries' $ \fp' -> do
120− let name =
121− case toPiece $ either id id $ F.toText $ F.filename fp' of
130+ let name = unsafeToPiece $ either id id $ F.toText $ F.filename fp'
122− Just p -> p
131+ de' <- F.isDirectory fp'
123− Nothing -> error "fileSystemLookupHash: FIXME"
132+ if de'
133+ then return $ Just $ Left name
134+ else do
124− mfile' <- fileHelper hashFunc fp' name
135+ mfile <- fileHelper hashFunc fp' name
125− return $ case mfile' of
136+ case mfile of
126− LRNotFound -> Left $ Folder (filePathToPiece $ F.filename fp') []
137+ Nothing -> return Nothing
127− LRFolder f -> Left f
138+ Just file -> return $ Just $ Right file
128− LRFile f -> Right f
129− return $ LRFolder $ Folder (error "Network.Wai.Application.Static.fileSystemLookup") entries
139+ return $ LRFolder $ Folder lastPiece $ catMaybes entries
130 else return LRNotFound
140 else return LRNotFound
141+ where
142+ lastPiece
143+ | null pieces = unsafeToPiece ""
144+ | otherwise = last pieces
wai-app-static/Listing.hs+8−7
@@ -21,8 +21,8 @@ import qualified Text.Blaze.Html.Renderer.Utf8 as HU
21defaultListing :: Listing
21defaultListing :: Listing
22defaultListing pieces (Folder _ contents) = do
22defaultListing pieces (Folder _ contents) = do
23 let isTop = null pieces || map Just pieces == [toPiece ""]
23 let isTop = null pieces || map Just pieces == [toPiece ""]
24− let fps'' :: [Either Folder File]
24+ let fps'' :: [Either FolderName File]
25− fps'' = (if isTop then id else (Left emptyParentFolder :)) contents -- FIXME emptyParentFolder feels like a bit of a hack
25+ fps'' = (if isTop then id else (Left (unsafeToPiece "") :)) contents -- FIXME emptyParentFolder feels like a bit of a hack
26 return $ HU.renderHtmlBuilder
26 return $ HU.renderHtmlBuilder
27 $ H.html $ do
27 $ H.html $ do
28 H.head $ do
28 H.head $ do
@@ -72,7 +72,7 @@ defaultListing pieces (Folder _ contents) = do
72-- see also: 'getMetaData', 'renderDirectoryContents'
72-- see also: 'getMetaData', 'renderDirectoryContents'
73renderDirectoryContentsTable :: String
73renderDirectoryContentsTable :: String
74 -> String
74 -> String
75− -> [Either Folder File]
75+ -> [Either FolderName File]
76 -> H.Html
76 -> H.Html
77renderDirectoryContentsTable haskellSrc folderSrc fps =
77renderDirectoryContentsTable haskellSrc folderSrc fps =
78 H.table $ do H.thead $ do H.th ! (A.class_ "first") $ H.img ! (A.src $ H.toValue haskellSrc)
78 H.table $ do H.thead $ do H.th ! (A.class_ "first") $ H.img ! (A.src $ H.toValue haskellSrc)
@@ -81,12 +81,13 @@ renderDirectoryContentsTable haskellSrc folderSrc fps =
81 H.th "Size"
81 H.th "Size"
82 H.tbody $ mapM_ mkRow (zip (sortBy sortMD fps) $ cycle [False, True])
82 H.tbody $ mapM_ mkRow (zip (sortBy sortMD fps) $ cycle [False, True])
83 where
83 where
84− sortMD :: Either Folder File -> Either Folder File -> Ordering
84+ sortMD :: Either FolderName File -> Either FolderName File -> Ordering
85 sortMD Left{} Right{} = LT
85 sortMD Left{} Right{} = LT
86 sortMD Right{} Left{} = GT
86 sortMD Right{} Left{} = GT
87− sortMD (Left a) (Left b) = compare (folderName a) (folderName b)
87+ sortMD (Left a) (Left b) = compare a b
88 sortMD (Right a) (Right b) = compare (fileName a) (fileName b)
88 sortMD (Right a) (Right b) = compare (fileName a) (fileName b)
89+
89− mkRow :: (Either Folder File, Bool) -> H.Html
90+ mkRow :: (Either FolderName File, Bool) -> H.Html
90 mkRow (md, alt) =
91 mkRow (md, alt) =
91 (if alt then (! A.class_ "alt") else id) $
92 (if alt then (! A.class_ "alt") else id) $
92 H.tr $ do
93 H.tr $ do
@@ -95,7 +96,7 @@ renderDirectoryContentsTable haskellSrc folderSrc fps =
95 Left{} -> H.img ! A.src (H.toValue folderSrc)
96 Left{} -> H.img ! A.src (H.toValue folderSrc)
96 ! A.alt "Folder"
97 ! A.alt "Folder"
97 Right{} -> return ()
98 Right{} -> return ()
98− let name = either folderName fileName md
99+ let name = either id fileName md
99 let isFile = either (const False) (const True) md
100 let isFile = either (const False) (const True) md
100 H.td (H.a ! A.href (H.toValue $ fromPiece name `T.append` if isFile then "" else "/") $ H.toHtml $ fromPiece name)
101 H.td (H.a ! A.href (H.toValue $ fromPiece name `T.append` if isFile then "" else "/") $ H.toHtml $ fromPiece name)
101 H.td ! A.class_ "date" $ H.toHtml $
102 H.td ! A.class_ "date" $ H.toHtml $
wai-app-static/WaiAppStatic/Types.hs+7−6
@@ -12,15 +12,16 @@ module WaiAppStatic.Types
12 , MimeType
12 , MimeType
13 , Extension
13 , Extension
14 , MimeMap
14 , MimeMap
15− -- * File\/folder serving
15+ -- * Caching
16 , MaxAge (..)
16 , MaxAge (..)
17+ -- * File\/folder serving
18+ , FolderName
17 , Folder (..)
19 , Folder (..)
18 , File (..)
20 , File (..)
19 , LookupResult (..)
21 , LookupResult (..)
20 , Listing
22 , Listing
21 -- * Settings
23 -- * Settings
22 , StaticSettings (..)
24 , StaticSettings (..)
23− , emptyParentFolder
24 ) where
25 ) where
25
26
26import Data.Text (Text)
27import Data.Text (Text)
@@ -84,11 +85,14 @@ data MaxAge = NoMaxAge -- ^ no cache-control set
84 | MaxAgeSeconds Int -- ^ set to the given number of seconds
85 | MaxAgeSeconds Int -- ^ set to the given number of seconds
85 | MaxAgeForever -- ^ essentially infinite caching; in reality, probably one year
86 | MaxAgeForever -- ^ essentially infinite caching; in reality, probably one year
86
87
88+-- | Just the name of a folder.
89+type FolderName = Piece
90+
87-- | Represent contents of a single folder, which can be itself either a file
91-- | Represent contents of a single folder, which can be itself either a file
88-- or a folder.
92-- or a folder.
89data Folder = Folder
93data Folder = Folder
90 { folderName :: Piece
94 { folderName :: Piece
91− , folderContents :: [Either Folder File] -- FIXME replace Folder with FolderName?
95+ , folderContents :: [Either FolderName File]
92 }
96 }
93
97
94-- | Information on an individual file.
98-- | Information on an individual file.
@@ -163,6 +167,3 @@ data StaticSettings = StaticSettings
163 -- FIXME Need clarity on what exactly is going on here.
167 -- FIXME Need clarity on what exactly is going on here.
164 , ssUseHash :: Bool
168 , ssUseHash :: Bool
165 }
169 }
166−
167−emptyParentFolder :: Folder -- FIXME get rid of this?
168−emptyParentFolder = Folder (Piece "") []