9c3b085 · typeable/wai

git.iko.soy/typeable/wai

on master help sign in

defaultListing

9c3b085Michael Snoyman16 years ago

Network/Wai/Application/Static.hs+117−4

compare with master

unifiedsplit

@@ -15,6 +15,13 @@ module Network.Wai.Application.Static

15 -- ** Finding files

16 , CheckPieces

17 , checkPieces

18+ -- ** File/folder metadata

19+ , MetaData (..)

20+ , mdIsFile

21+ , getMetaData

22+ -- ** Directory listings

23+ , Listing

24+ , defaultListing

18 -- * WAI application

25 -- * WAI application

19 , StaticSettings (..)

26 , StaticSettings (..)

20 , staticApp

27 , staticApp

@@ -24,13 +31,25 @@ import qualified Network.Wai as W

24import Data.Map (Map)

31import Data.Map (Map)

25import qualified Data.Map as Map

32import qualified Data.Map as Map

26import Data.ByteString (ByteString)

33import Data.ByteString (ByteString)

27−import System.Directory (doesFileExist, doesDirectoryExist)

34+import System.Directory (doesFileExist, doesDirectoryExist, getDirectoryContents)

28import qualified Data.ByteString.Char8 as S8

35import qualified Data.ByteString.Char8 as S8

29import qualified Data.ByteString.Lazy as L

36import qualified Data.ByteString.Lazy as L

30import Data.ByteString.Lazy.Char8 ()

37import Data.ByteString.Lazy.Char8 ()

31import Web.Routes.Base (decodePathInfo, encodePathInfo)

38import 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)

33import Control.Monad.IO.Class (liftIO)

41import 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)

35-- | A list of all possible extensions, starting from the largest.

54-- | A list of all possible extensions, starting from the largest.

36takeExtensions :: FilePath -> [String]

55takeExtensions :: FilePath -> [String]

@@ -196,7 +215,7 @@ checkPieces prefix indices pieces

196 then return $ Just i

215 then return $ Just i

197 else checkIndices fp is

216 else checkIndices fp is

198

217

199−type Listing = FilePath -> IO L.ByteString

218+type Listing = [String] -> FilePath -> IO L.ByteString

200

219

201data StaticSettings = StaticSettings

220data StaticSettings = StaticSettings

202 { ssFolder :: FilePath

221 { ssFolder :: FilePath

@@ -232,10 +251,104 @@ staticApp (StaticSettings folder indices mlisting getmime) req = liftIO $ do

232 DirectoryResponse fp ->

251 DirectoryResponse fp ->

233 case mlisting of

252 case mlisting of

234 Just listing -> do

253 Just listing -> do

235− lbs <- listing fp

254+ lbs <- listing pieces fp

236 return $ W.responseLBS W.status200

255 return $ W.responseLBS W.status200

237 [ ("Content-Type", "text/html")

256 [ ("Content-Type", "text/html")

238 ] lbs

257 ] lbs

239 Nothing -> return $ W.responseLBS W.status403

258 Nothing -> return $ W.responseLBS W.status403

240 [ ("Content-Type", "text/plain")

259 [ ("Content-Type", "text/plain")

241 ] "Directory listings disabled"

260 ] "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

wai-app-static.cabal+3

@@ -21,6 +21,9 @@ library

21 , unix-compat >= 0.2 && < 0.3

22 , directory >= 1.0 && < 1.2

23 , containers >= 0.2 && < 0.5

24+ , blaze-html >= 0.4 && < 0.5

25+ , time >= 1.1.4 && < 1.3

26+ , old-locale >= 1.0.0.2 && < 1.1

24 exposed-modules: Network.Wai.Application.Static

27 exposed-modules: Network.Wai.Application.Static

25 ghc-options: -Wall

28 ghc-options: -Wall

warp-static.hs+2−2

@@ -1,5 +1,5 @@

1import Network.Wai.Application.Static

2− ( StaticSettings (..), staticApp, defaultMimeTypeByExt

2+ ( StaticSettings (..), staticApp, defaultMimeTypeByExt, defaultListing

3 )

4import Network.Wai.Handler.Warp (run)

5import System.Environment (getArgs)

@@ -16,6 +16,6 @@ main = do

16 run port $ staticApp StaticSettings

17 { ssFolder = folder

18 , ssIndices = ["index.html", "index.htm"]

19− , ssListing = Nothing

19+ , ssListing = Just defaultListing

20 , ssGetMimeType = return . defaultMimeTypeByExt

21 }