f53b921 · typeable/wai

git.iko.soy/typeable/wai

on master help sign in

Prettier and threaded

f53b921Michael Snoyman16 years ago

Network/Wai/Application/Static.hs+41−13

compare with master

unifiedsplit

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

1{-# LANGUAGE OverloadedStrings #-}

2+{-# LANGUAGE TemplateHaskell #-}

2-- | Static file serving for WAI.

3-- | Static file serving for WAI.

3module Network.Wai.Application.Static

4module Network.Wai.Application.Static

4 ( -- * Generic, non-WAI code

5 ( -- * Generic, non-WAI code

@@ -50,7 +51,8 @@ import Data.Time

50import Data.Time.Clock.POSIX

51import Data.Time.Clock.POSIX

51import System.Locale (defaultTimeLocale)

52import System.Locale (defaultTimeLocale)

53−import Data.List (sortBy)

54+import Data.List (sortBy, intercalate)

55+import Data.FileEmbed (embedFile)

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

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

56takeExtensions :: FilePath -> [String]

58takeExtensions :: FilePath -> [String]

@@ -147,6 +149,7 @@ data CheckPieces

147 | NotFound

149 | NotFound

148 | FileResponse FilePath

150 | FileResponse FilePath

149 | DirectoryResponse FilePath

151 | DirectoryResponse FilePath

152+ | SendContent MimeType L.ByteString

150 deriving Show

153 deriving Show

151

154

152anyButLast :: (a -> Bool) -> [a] -> Bool

155anyButLast :: (a -> Bool) -> [a] -> Bool

@@ -176,6 +179,8 @@ checkPieces :: FilePath -- ^ static file prefix

176 -> [FilePath] -- ^ List of default index files. Cannot contain slashes.

179 -> [FilePath] -- ^ List of default index files. Cannot contain slashes.

177 -> [String] -- ^ parsed request

180 -> [String] -- ^ parsed request

178 -> IO CheckPieces

181 -> IO CheckPieces

182+checkPieces _ _ [".hidden", "folder.png"] =

183+ return $ SendContent "image/png" $ L.fromChunks [$(embedFile "folder.png")]

179checkPieces prefix indices pieces

184checkPieces prefix indices pieces

180 | any unsafe pieces = return Forbidden

185 | any unsafe pieces = return Forbidden

181 | anyButLast null pieces =

186 | anyButLast null pieces =

@@ -254,11 +259,14 @@ staticApp (StaticSettings folder indices mlisting getmime) req = liftIO $ do

254 Just listing -> do

259 Just listing -> do

255 lbs <- listing pieces fp

260 lbs <- listing pieces fp

256 return $ W.responseLBS W.status200

261 return $ W.responseLBS W.status200

257− [ ("Content-Type", "text/html")

262+ [ ("Content-Type", "text/html; charset=utf-8")

258 ] lbs

263 ] lbs

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

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

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

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

261 ] "Directory listings disabled"

266 ] "Directory listings disabled"

267+ SendContent mt lbs -> return $ W.responseLBS W.status200

268+ [ ("Content-Type", mt)

269+ ] lbs

262

270

263-- Code below taken from Happstack: http://patch-tag.com/r/mae/happstack/snapshot/current/content/pretty/happstack-server/src/Happstack/Server/FileServe/BuildingBlocks.hs

271-- Code below taken from Happstack: http://patch-tag.com/r/mae/happstack/snapshot/current/content/pretty/happstack-server/src/Happstack/Server/FileServe/BuildingBlocks.hs

264defaultListing :: Listing

272defaultListing :: Listing

@@ -270,20 +278,35 @@ defaultListing pieces localPath = do

270 return $ HU.renderHtml

278 return $ HU.renderHtml

271 $ H.html $ do

279 $ H.html $ do

272 H.head $ do

280 H.head $ do

273− H.title $ H.string "Directory Listing"

281+ let title = intercalate "/" pieces

274− H.meta ! A.httpEquiv (H.stringValue "Content-Type") ! A.content (H.stringValue "text/html;charset=utf-8")

282+ let title' = if null title then "root folder" else title

283+ H.title $ H.string title'

275− H.style $ H.string $ unlines [ "table { border-collapse: collapse; font-family: 'sans-serif'; }"

284+ H.style $ H.string $ unlines [ "table { margin: 0 auto; width: 760px; border-collapse: collapse; font-family: 'sans-serif'; }"

276 , "table, th, td { border: 1px solid #98BF21; }"

285 , "table, th, td { border: 1px solid #98BF21; }"

277 , "td.size { text-align: right; }"

286 , "td.size { text-align: right; }"

278 , "td.date { text-align: right; }"

287 , "td.date { text-align: right; }"

279 , "td { padding-right: 1em; padding-left: 1em; }"

288 , "td { padding-right: 1em; padding-left: 1em; }"

289+ , "td.first { padding-right: 0; padding-left: 0; text-align: center }"

280 , "tr { background-color: white; }"

290 , "tr { background-color: white; }"

281 , "tr.alt { background-color: #EAF2D3 }"

291 , "tr.alt { background-color: #EAF2D3 }"

282 , "th { background-color: #A7C942; color: white; font-size: 1.125em; }"

292 , "th { background-color: #A7C942; color: white; font-size: 1.125em; }"

293+ , "h1 { width: 760px; margin: 1em auto; font-size: 1em }"

294+ , "img { width: 20px }"

283 ]

295 ]

284 H.body $ do

296 H.body $ do

285− H.h1 $ H.string "Directory Listing"

297+ H.h1 $ showFolder $ "" : filter (not . null) pieces

286− renderDirectoryContentsTable $ catMaybes fps''

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

287

310

288-- | a function to generate an HTML table showing the contents of a directory on the disk

311-- | a function to generate an HTML table showing the contents of a directory on the disk

289--

312--

@@ -293,9 +316,10 @@ defaultListing pieces localPath = do

293-- a new page template to wrap around this HTML.

316-- a new page template to wrap around this HTML.

294--

317--

295-- see also: 'getMetaData', 'renderDirectoryContents'

318-- see also: 'getMetaData', 'renderDirectoryContents'

319+renderDirectoryContentsTable :: String

296−renderDirectoryContentsTable :: [MetaData] -- ^ list of files+meta data, see 'getMetaData'

320+ -> [MetaData] -- ^ list of files+meta data, see 'getMetaData'

297 -> H.Html

321 -> H.Html

298−renderDirectoryContentsTable fps =

322+renderDirectoryContentsTable folderSrc fps =

299 H.table $ do H.thead $ do H.th $ H.string ""

323 H.table $ do H.thead $ do H.th $ H.string ""

300 H.th $ H.string "Name"

324 H.th $ H.string "Name"

301 H.th $ H.string "Last modified"

325 H.th $ H.string "Last modified"

@@ -303,22 +327,26 @@ renderDirectoryContentsTable fps =

303 H.tbody $ mapM_ mkRow (zip (sortBy sortMD fps) $ cycle [False, True])

327 H.tbody $ mapM_ mkRow (zip (sortBy sortMD fps) $ cycle [False, True])

304 where

328 where

305 sortMD FolderMetaData{} FileMetaData{} = LT

329 sortMD FolderMetaData{} FileMetaData{} = LT

306− sortMD FileMetaData{} FolderMetaData{} = LT

330+ sortMD FileMetaData{} FolderMetaData{} = GT

307 sortMD x y = mdName x `compare` mdName y

331 sortMD x y = mdName x `compare` mdName y

308 mkRow :: (MetaData, Bool) -> H.Html

332 mkRow :: (MetaData, Bool) -> H.Html

309 mkRow (md, alt) =

333 mkRow (md, alt) =

310 (if alt then (! A.class_ (H.stringValue "alt")) else id) $

334 (if alt then (! A.class_ (H.stringValue "alt")) else id) $

311 H.tr $ do

335 H.tr $ do

336+ H.td ! A.class_ (H.stringValue "first")

312− H.td $ H.string $ if mdIsFile md then "File" else "Folder"

337+ $ if mdIsFile md

338+ then return ()

339+ else H.img ! A.src (H.stringValue folderSrc)

340+ ! A.alt (H.stringValue "Folder")

313 H.td (H.a ! A.href (H.stringValue $ mdName md ++ if mdIsFile md then "" else "/") $ H.string $ mdName md)

341 H.td (H.a ! A.href (H.stringValue $ mdName md ++ if mdIsFile md then "" else "/") $ H.string $ mdName md)

314 H.td ! A.class_ (H.stringValue "date") $ H.string $

342 H.td ! A.class_ (H.stringValue "date") $ H.string $

315 if mdIsFile md

343 if mdIsFile md

316 then formatCalendarTime defaultTimeLocale "%d-%b-%Y %X %Z" $ mdModified md

344 then formatCalendarTime defaultTimeLocale "%d-%b-%Y %X %Z" $ mdModified md

317− else "-"

345+ else ""

318 H.td ! A.class_ (H.stringValue "size") $ H.string $

346 H.td ! A.class_ (H.stringValue "size") $ H.string $

319 if mdIsFile md

347 if mdIsFile md

320 then prettyShow $ mdSize md

348 then prettyShow $ mdSize md

321− else "-"

349+ else ""

322 formatCalendarTime a b c = formatTime a b $ posixSecondsToUTCTime (realToFrac c :: POSIXTime)

350 formatCalendarTime a b c = formatTime a b $ posixSecondsToUTCTime (realToFrac c :: POSIXTime)

323 prettyShow = (++ " bytes") . reverse . addCommas . reverse . show

351 prettyShow = (++ " bytes") . reverse . addCommas . reverse . show

324 addCommas (a:b:c:d:e) = a : b : c : ',' : addCommas (d : e)

352 addCommas (a:b:c:d:e) = a : b : c : ',' : addCommas (d : e)

wai-app-static.cabal+3−1

@@ -11,6 +11,7 @@ stability: Stable

11cabal-version: >= 1.6

12build-type: Simple

13homepage: http://docs.yesodweb.com/

14+Extra-source-files: folder.png

15library

16library

16 build-depends: base >= 4 && < 5

17 build-depends: base >= 4 && < 5

@@ -24,13 +25,14 @@ library

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

25 , blaze-html >= 0.4 && < 0.5

25 , time >= 1.1.4 && < 1.3

26 , time >= 1.1.4 && < 1.3

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

27 , old-locale >= 1.0.0.2 && < 1.1

28+ , file-embed >= 0.0.3.1 && < 0.1

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

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

28 ghc-options: -Wall

30 ghc-options: -Wall

30executable warp-static

32executable warp-static

31 build-depends: warp >= 0.3 && < 0.4

33 build-depends: warp >= 0.3 && < 0.4

32 main-is: warp-static.hs

34 main-is: warp-static.hs

33− ghc-options: -Wall

35+ ghc-options: -Wall -threaded

35source-repository head

37source-repository head

36 type: git

38 type: git