@@ -15,6 +15,13 @@ module Network.Wai.Application.Static
1515 -- ** Finding files
1616 , CheckPieces
1717 , checkPieces
18+ -- ** File/folder metadata
19+ , MetaData (..)
20+ , mdIsFile
21+ , getMetaData
22+ -- ** Directory listings
23+ , Listing
24+ , defaultListing
1825 -- * WAI application
1926 , StaticSettings (..)
2027 , staticApp
@@ -24,13 +31,25 @@ import qualified Network.Wai as W
2431import Data.Map (Map)
2532import qualified Data.Map as Map
2633import Data.ByteString (ByteString)
27−import System.Directory (doesFileExist, doesDirectoryExist)
34+import System.Directory (doesFileExist, doesDirectoryExist, getDirectoryContents)
2835import qualified Data.ByteString.Char8 as S8
2936import qualified Data.ByteString.Lazy as L
3037import Data.ByteString.Lazy.Char8 ()
3138import Web.Routes.Base (decodePathInfo, encodePathInfo)
32−import System.PosixCompat.Files (fileSize, getFileStatus)
39+import System.PosixCompat.Files (fileSize, getFileStatus, modificationTime)
40+import System.Posix.Types (FileOffset, EpochTime)
3341import Control.Monad.IO.Class (liftIO)
42+import Data.Maybe (catMaybes)
43+
44+import Text.Blaze ((!))
45+import qualified Text.Blaze.Html5 as H
46+import qualified Text.Blaze.Renderer.Utf8 as HU
47+import qualified Text.Blaze.Html5.Attributes as A
48+
49+import Data.Time
50+import System.Locale (defaultTimeLocale)
51+
52+import Data.List (sortBy)
3453
3554-- | A list of all possible extensions, starting from the largest.
3655takeExtensions :: FilePath -> [String]
@@ -196,7 +215,7 @@ checkPieces prefix indices pieces
196215 then return $ Just i
197216 else checkIndices fp is
198217
199−type Listing = FilePath -> IO L.ByteString
218+type Listing = [String] -> FilePath -> IO L.ByteString
200219
201220data StaticSettings = StaticSettings
202221 { ssFolder :: FilePath
@@ -232,10 +251,104 @@ staticApp (StaticSettings folder indices mlisting getmime) req = liftIO $ do
232251 DirectoryResponse fp ->
233252 case mlisting of
234253 Just listing -> do
235− lbs <- listing fp
254+ lbs <- listing pieces fp
236255 return $ W.responseLBS W.status200
237256 [ ("Content-Type", "text/html")
238257 ] lbs
239258 Nothing -> return $ W.responseLBS W.status403
240259 [ ("Content-Type", "text/plain")
241260 ] "Directory listings disabled"
261+
262+-- Code below taken from Happstack: http://patch-tag.com/r/mae/happstack/snapshot/current/content/pretty/happstack-server/src/Happstack/Server/FileServe/BuildingBlocks.hs
263+defaultListing :: Listing
264+defaultListing pieces localPath = do
265+ fps <- getDirectoryContents localPath
266+ fps' <- mapM (getMetaData localPath) fps
267+ let isTop = null pieces || pieces == [""]
268+ let fps'' = if isTop then fps' else Just (FolderMetaData "..") : fps'
269+ return $ HU.renderHtml
270+ $ H.html $ do
271+ H.head $ do
272+ H.title $ H.string "Directory Listing"
273+ H.meta ! A.httpEquiv (H.stringValue "Content-Type") ! A.content (H.stringValue "text/html;charset=utf-8")
274+ H.style $ H.string $ unlines [ "table { border-collapse: collapse; font-family: 'sans-serif'; }"
275+ , "table, th, td { border: 1px solid #98BF21; }"
276+ , "td.size { text-align: right; }"
277+ , "td.date { text-align: right; }"
278+ , "td { padding-right: 1em; padding-left: 1em; }"
279+ , "tr { background-color: white; }"
280+ , "tr.alt { background-color: #EAF2D3 }"
281+ , "th { background-color: #A7C942; color: white; font-size: 1.125em; }"
282+ ]
283+ H.body $ do
284+ H.h1 $ H.string "Directory Listing"
285+ renderDirectoryContentsTable $ catMaybes fps''
286+
287+-- | a function to generate an HTML table showing the contents of a directory on the disk
288+--
289+-- This function generates most of the content of the
290+-- 'renderDirectoryContents' page. If you want to style the page
291+-- differently, or add google analytics code, etc, you can just create
292+-- a new page template to wrap around this HTML.
293+--
294+-- see also: 'getMetaData', 'renderDirectoryContents'
295+renderDirectoryContentsTable :: [MetaData] -- ^ list of files+meta data, see 'getMetaData'
296+ -> H.Html
297+renderDirectoryContentsTable fps =
298+ H.table $ do H.thead $ do H.th $ H.string ""
299+ H.th $ H.string "Name"
300+ H.th $ H.string "Last modified"
301+ H.th $ H.string "Size"
302+ H.tbody $ mapM_ mkRow (zip (sortBy sortMD fps) $ cycle [False, True])
303+ where
304+ sortMD FolderMetaData{} FileMetaData{} = LT
305+ sortMD FileMetaData{} FolderMetaData{} = LT
306+ sortMD x y = mdName x `compare` mdName y
307+ mkRow :: (MetaData, Bool) -> H.Html
308+ mkRow (md, alt) =
309+ (if alt then (! A.class_ (H.stringValue "alt")) else id) $
310+ H.tr $ do
311+ H.td $ H.string $ if mdIsFile md then "File" else "Folder"
312+ H.td (H.a ! A.href (H.stringValue $ mdName md ++ if mdIsFile md then "" else "/") $ H.string $ mdName md)
313+ H.td ! A.class_ (H.stringValue "date") $ H.string $
314+ if mdIsFile md
315+ then formatCalendarTime defaultTimeLocale "%d-%b-%Y %X %Z" $ mdModified md
316+ else "-"
317+ H.td ! A.class_ (H.stringValue "size") $ H.string $
318+ if mdIsFile md
319+ then show $ mdSize md
320+ else "-"
321+ formatCalendarTime _ _ _ = "FIXME formatCalendarTime"
322+
323+data MetaData =
324+ FileMetaData
325+ { mdName :: FilePath
326+ , mdModified :: EpochTime
327+ , mdSize :: FileOffset
328+ }
329+ | FolderMetaData
330+ { mdName :: FilePath
331+ }
332+ deriving Show
333+
334+mdIsFile :: MetaData -> Bool
335+mdIsFile FileMetaData{} = True
336+mdIsFile FolderMetaData{} = False
337+
338+-- | look up the meta data associated with a file
339+getMetaData :: FilePath -- ^ path to directory on disk containing the entry
340+ -> FilePath -- ^ entry in that directory
341+ -> IO (Maybe MetaData)
342+getMetaData _ ('.':_) = return Nothing
343+getMetaData localPath fp = do
344+ let fp' = localPath ++ '/' : fp
345+ fe <- doesFileExist fp'
346+ if fe
347+ then do
348+ fs <- getFileStatus fp'
349+ let modTime = modificationTime fs
350+ let count = fileSize fs
351+ return $ Just $ FileMetaData fp modTime count
352+ else do
353+ de <- doesDirectoryExist fp'
354+ return $ if de then Just (FolderMetaData fp) else Nothing