@@ -1,4 +1,5 @@
11{-# LANGUAGE OverloadedStrings #-}
2+{-# LANGUAGE TemplateHaskell #-}
23-- | Static file serving for WAI.
34module Network.Wai.Application.Static
45 ( -- * Generic, non-WAI code
@@ -50,7 +51,8 @@ import Data.Time
5051import Data.Time.Clock.POSIX
5152import System.Locale (defaultTimeLocale)
5253
53−import Data.List (sortBy)
54+import Data.List (sortBy, intercalate)
55+import Data.FileEmbed (embedFile)
5456
5557-- | A list of all possible extensions, starting from the largest.
5658takeExtensions :: FilePath -> [String]
@@ -147,6 +149,7 @@ data CheckPieces
147149 | NotFound
148150 | FileResponse FilePath
149151 | DirectoryResponse FilePath
152+ | SendContent MimeType L.ByteString
150153 deriving Show
151154
152155anyButLast :: (a -> Bool) -> [a] -> Bool
@@ -176,6 +179,8 @@ checkPieces :: FilePath -- ^ static file prefix
176179 -> [FilePath] -- ^ List of default index files. Cannot contain slashes.
177180 -> [String] -- ^ parsed request
178181 -> IO CheckPieces
182+checkPieces _ _ [".hidden", "folder.png"] =
183+ return $ SendContent "image/png" $ L.fromChunks [$(embedFile "folder.png")]
179184checkPieces prefix indices pieces
180185 | any unsafe pieces = return Forbidden
181186 | anyButLast null pieces =
@@ -254,11 +259,14 @@ staticApp (StaticSettings folder indices mlisting getmime) req = liftIO $ do
254259 Just listing -> do
255260 lbs <- listing pieces fp
256261 return $ W.responseLBS W.status200
257− [ ("Content-Type", "text/html")
262+ [ ("Content-Type", "text/html; charset=utf-8")
258263 ] lbs
259264 Nothing -> return $ W.responseLBS W.status403
260265 [ ("Content-Type", "text/plain")
261266 ] "Directory listings disabled"
267+ SendContent mt lbs -> return $ W.responseLBS W.status200
268+ [ ("Content-Type", mt)
269+ ] lbs
262270
263271-- Code below taken from Happstack: http://patch-tag.com/r/mae/happstack/snapshot/current/content/pretty/happstack-server/src/Happstack/Server/FileServe/BuildingBlocks.hs
264272defaultListing :: Listing
@@ -270,20 +278,35 @@ defaultListing pieces localPath = do
270278 return $ HU.renderHtml
271279 $ H.html $ do
272280 H.head $ do
273− H.title $ H.string "Directory Listing"
274− H.meta ! A.httpEquiv (H.stringValue "Content-Type") ! A.content (H.stringValue "text/html;charset=utf-8")
275− H.style $ H.string $ unlines [ "table { border-collapse: collapse; font-family: 'sans-serif'; }"
281+ let title = intercalate "/" pieces
282+ let title' = if null title then "root folder" else title
283+ H.title $ H.string title'
284+ H.style $ H.string $ unlines [ "table { margin: 0 auto; width: 760px; border-collapse: collapse; font-family: 'sans-serif'; }"
276285 , "table, th, td { border: 1px solid #98BF21; }"
277286 , "td.size { text-align: right; }"
278287 , "td.date { text-align: right; }"
279288 , "td { padding-right: 1em; padding-left: 1em; }"
289+ , "td.first { padding-right: 0; padding-left: 0; text-align: center }"
280290 , "tr { background-color: white; }"
281291 , "tr.alt { background-color: #EAF2D3 }"
282292 , "th { background-color: #A7C942; color: white; font-size: 1.125em; }"
293+ , "h1 { width: 760px; margin: 1em auto; font-size: 1em }"
294+ , "img { width: 20px }"
283295 ]
284296 H.body $ do
285− H.h1 $ H.string "Directory Listing"
286− renderDirectoryContentsTable $ catMaybes fps''
297+ H.h1 $ showFolder $ "" : filter (not . null) pieces
298+ renderDirectoryContentsTable folderSrc $ catMaybes fps''
299+ where
300+ folderSrc = concatMap (const "../") (drop 1 pieces) ++ ".hidden/folder.png"
301+ showName "" = "root"
302+ showName x = x
303+ showFolder [] = H.string "FIXME: Unexpected showFolder []"
304+ showFolder [x] = H.string $ showName x
305+ showFolder (x:xs) = do
306+ let href = concat $ replicate (length xs) "../"
307+ H.a ! A.href (H.stringValue href) $ H.string $ showName x
308+ H.string " / "
309+ showFolder xs
287310
288311-- | a function to generate an HTML table showing the contents of a directory on the disk
289312--
@@ -293,9 +316,10 @@ defaultListing pieces localPath = do
293316-- a new page template to wrap around this HTML.
294317--
295318-- see also: 'getMetaData', 'renderDirectoryContents'
296−renderDirectoryContentsTable :: [MetaData] -- ^ list of files+meta data, see 'getMetaData'
319+renderDirectoryContentsTable :: String
320+ -> [MetaData] -- ^ list of files+meta data, see 'getMetaData'
297321 -> H.Html
298−renderDirectoryContentsTable fps =
322+renderDirectoryContentsTable folderSrc fps =
299323 H.table $ do H.thead $ do H.th $ H.string ""
300324 H.th $ H.string "Name"
301325 H.th $ H.string "Last modified"
@@ -303,22 +327,26 @@ renderDirectoryContentsTable fps =
303327 H.tbody $ mapM_ mkRow (zip (sortBy sortMD fps) $ cycle [False, True])
304328 where
305329 sortMD FolderMetaData{} FileMetaData{} = LT
306− sortMD FileMetaData{} FolderMetaData{} = LT
330+ sortMD FileMetaData{} FolderMetaData{} = GT
307331 sortMD x y = mdName x `compare` mdName y
308332 mkRow :: (MetaData, Bool) -> H.Html
309333 mkRow (md, alt) =
310334 (if alt then (! A.class_ (H.stringValue "alt")) else id) $
311335 H.tr $ do
312− H.td $ H.string $ if mdIsFile md then "File" else "Folder"
336+ H.td ! A.class_ (H.stringValue "first")
337+ $ if mdIsFile md
338+ then return ()
339+ else H.img ! A.src (H.stringValue folderSrc)
340+ ! A.alt (H.stringValue "Folder")
313341 H.td (H.a ! A.href (H.stringValue $ mdName md ++ if mdIsFile md then "" else "/") $ H.string $ mdName md)
314342 H.td ! A.class_ (H.stringValue "date") $ H.string $
315343 if mdIsFile md
316344 then formatCalendarTime defaultTimeLocale "%d-%b-%Y %X %Z" $ mdModified md
317− else "-"
345+ else ""
318346 H.td ! A.class_ (H.stringValue "size") $ H.string $
319347 if mdIsFile md
320348 then prettyShow $ mdSize md
321− else "-"
349+ else ""
322350 formatCalendarTime a b c = formatTime a b $ posixSecondsToUTCTime (realToFrac c :: POSIXTime)
323351 prettyShow = (++ " bytes") . reverse . addCommas . reverse . show
324352 addCommas (a:b:c:d:e) = a : b : c : ',' : addCommas (d : e)