@@ -0,0 +1,756 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+{-# LANGUAGE TemplateHaskell, CPP #-}
3+-- | Static file serving for WAI.
4+module Network.Wai.Application.Static
5+ ( -- * WAI application
6+ staticApp
7+ -- ** Settings
8+ , defaultWebAppSettings
9+ , defaultFileServerSettings
10+ , StaticSettings
11+ , ssFolder
12+ , ssMkRedirect
13+ , ssGetMimeType
14+ , ssListing
15+ , ssIndices
16+ , ssMaxAge
17+ -- * Generic, non-WAI code
18+ -- ** Mime types
19+ , MimeType
20+ , defaultMimeType
21+ -- ** Mime type by file extension
22+ , Extension
23+ , MimeMap
24+ , takeExtensions
25+ , defaultMimeTypes
26+ , mimeTypeByExt
27+ , defaultMimeTypeByExt
28+ -- ** Finding files
29+ , Pieces
30+ , pathFromPieces
31+ -- ** Directory listings
32+ , Listing
33+ , defaultListing
34+ -- ** Lookup functions
35+ , fileSystemLookup
36+ , embeddedLookup
37+ -- ** Embedded
38+ , Embedded
39+ , EmbeddedEntry (..)
40+ , toEmbedded
41+ -- ** Redirecting
42+ , defaultMkRedirect
43+ -- * Other data types
44+ , File (..)
45+ , FilePath (..)
46+ , toFilePath
47+ , fromFilePath
48+ , MaxAge (..)
49+ ) where
50+
51+import Prelude hiding (FilePath)
52+import qualified Prelude
53+import qualified Network.Wai as W
54+import qualified Network.HTTP.Types as H
55+import Data.Map (Map)
56+import qualified Data.Map as Map
57+import Data.ByteString (ByteString)
58+import System.Directory (doesFileExist, doesDirectoryExist, getDirectoryContents)
59+import qualified Data.ByteString.Char8 as S8
60+import qualified Data.ByteString.Lazy as L
61+import Data.ByteString.Lazy.Char8 ()
62+import System.PosixCompat.Files (fileSize, getFileStatus, modificationTime)
63+import System.Posix.Types (EpochTime)
64+import Control.Monad.IO.Class (liftIO)
65+import qualified Crypto.Hash.MD5 as MD5
66+import Control.Monad (filterM)
67+
68+import Text.Blaze ((!))
69+import qualified Text.Blaze.Html5 as H
70+import qualified Text.Blaze.Renderer.Utf8 as HU
71+import qualified Text.Blaze.Html5.Attributes as A
72+
73+import Blaze.ByteString.Builder (toByteString, fromByteString)
74+
75+import Data.Time
76+import Data.Time.Clock.POSIX
77+import System.Locale (defaultTimeLocale)
78+
79+import Data.FileEmbed (embedFile)
80+
81+import Data.Text (Text)
82+import qualified Data.Text as T
83+import qualified Data.Text.Encoding as TE
84+import qualified Data.Text.Encoding.Error as TEE
85+
86+import Control.Arrow ((&&&), second)
87+import Data.List (groupBy, sortBy, find, foldl')
88+import Data.Function (on)
89+import Data.Ord (comparing)
90+import qualified Data.ByteString.Base64 as B64
91+import Data.Either (rights)
92+import Data.Maybe (isJust, fromJust)
93+import Network.HTTP.Date (parseHTTPDate, epochTimeToHTTPDate, formatHTTPDate)
94+import Data.String (IsString (..))
95+
96+newtype FilePath = FilePath { unFilePath :: Text }
97+ deriving (Ord, Eq, Show)
98+instance IsString FilePath where
99+ fromString = toFilePath
100+
101+(</>) :: FilePath -> FilePath -> FilePath
102+(FilePath a) </> (FilePath b) = FilePath $ T.concat [a, "/", b]
103+
104+-- | A list of all possible extensions, starting from the largest.
105+takeExtensions :: FilePath -> [FilePath]
106+takeExtensions (FilePath s) =
107+ case T.break (== '.') s of
108+ (_, "") -> []
109+ (_, x) -> FilePath (T.drop 1 x) : takeExtensions (FilePath $ T.drop 1 x)
110+
111+type MimeType = ByteString
112+type Extension = FilePath
113+type MimeMap = Map Extension MimeType
114+
115+defaultMimeType :: MimeType
116+defaultMimeType = "application/octet-stream"
117+
118+-- taken from snap-core Snap.Util.FileServer
119+defaultMimeTypes :: MimeMap
120+defaultMimeTypes = Map.fromList [
121+ ( "apk" , "application/vnd.android.package-archive" ),
122+ ( "asc" , "text/plain" ),
123+ ( "asf" , "video/x-ms-asf" ),
124+ ( "asx" , "video/x-ms-asf" ),
125+ ( "avi" , "video/x-msvideo" ),
126+ ( "bz2" , "application/x-bzip" ),
127+ ( "c" , "text/plain" ),
128+ ( "class" , "application/octet-stream" ),
129+ ( "conf" , "text/plain" ),
130+ ( "cpp" , "text/plain" ),
131+ ( "css" , "text/css" ),
132+ ( "cxx" , "text/plain" ),
133+ ( "dtd" , "text/xml" ),
134+ ( "dvi" , "application/x-dvi" ),
135+ ( "epub" , "application/epub+zip" ),
136+ ( "gif" , "image/gif" ),
137+ ( "gz" , "application/x-gzip" ),
138+ ( "hs" , "text/plain" ),
139+ ( "htm" , "text/html" ),
140+ ( "html" , "text/html" ),
141+ ( "ico" , "image/vnd.microsoft.icon" ),
142+ ( "jar" , "application/x-java-archive" ),
143+ ( "jpeg" , "image/jpeg" ),
144+ ( "jpg" , "image/jpeg" ),
145+ ( "js" , "text/javascript" ),
146+ ( "log" , "text/plain" ),
147+ ( "m3u" , "audio/x-mpegurl" ),
148+ ( "mov" , "video/quicktime" ),
149+ ( "mp3" , "audio/mpeg" ),
150+ ( "mpeg" , "video/mpeg" ),
151+ ( "mpg" , "video/mpeg" ),
152+ ( "ogg" , "application/ogg" ),
153+ ( "pac" , "application/x-ns-proxy-autoconfig" ),
154+ ( "pdf" , "application/pdf" ),
155+ ( "png" , "image/png" ),
156+ ( "bmp" , "image/bmp" ),
157+ ( "ps" , "application/postscript" ),
158+ ( "qt" , "video/quicktime" ),
159+ ( "sig" , "application/pgp-signature" ),
160+ ( "spl" , "application/futuresplash" ),
161+ ( "svg" , "image/svg+xml" ),
162+ ( "swf" , "application/x-shockwave-flash" ),
163+ ( "tar" , "application/x-tar" ),
164+ ( "tar.bz2" , "application/x-bzip-compressed-tar" ),
165+ ( "tar.gz" , "application/x-tgz" ),
166+ ( "tbz" , "application/x-bzip-compressed-tar" ),
167+ ( "text" , "text/plain" ),
168+ ( "tgz" , "application/x-tgz" ),
169+ ( "torrent" , "application/x-bittorrent" ),
170+ ( "ttf" , "application/x-font-truetype" ),
171+ ( "txt" , "text/plain" ),
172+ ( "wav" , "audio/x-wav" ),
173+ ( "wax" , "audio/x-ms-wax" ),
174+ ( "wma" , "audio/x-ms-wma" ),
175+ ( "wmv" , "video/x-ms-wmv" ),
176+ ( "xbm" , "image/x-xbitmap" ),
177+ ( "xhtml" , "application/xhtml+xml" ),
178+ ( "xml" , "text/xml" ),
179+ ( "xpm" , "image/x-xpixmap" ),
180+ ( "xwd" , "image/x-xwindowdump" ),
181+ ( "zip" , "application/zip" )]
182+
183+mimeTypeByExt :: MimeMap
184+ -> MimeType -- ^ default mime type
185+ -> FilePath
186+ -> MimeType
187+mimeTypeByExt mm def =
188+ go . takeExtensions
189+ where
190+ go [] = def
191+ go (e:es) =
192+ case Map.lookup e mm of
193+ Nothing -> go es
194+ Just mt -> mt
195+
196+defaultMimeTypeByExt :: FilePath -> MimeType
197+defaultMimeTypeByExt = mimeTypeByExt defaultMimeTypes defaultMimeType
198+
199+data CheckPieces =
200+ -- | Just the etag hash or Nothing for no etag hash
201+ Redirect Pieces (Maybe ByteString)
202+ | Forbidden
203+ | NotFound
204+ | FileResponse File H.ResponseHeaders
205+ | NotModified
206+ | DirectoryResponse Folder
207+ -- TODO: add file size
208+ | SendContent MimeType L.ByteString
209+
210+safeInit :: [a] -> [a]
211+safeInit [] = []
212+safeInit xs = init xs
213+
214+filterButLast :: (a -> Bool) -> [a] -> [a]
215+filterButLast _ [] = []
216+filterButLast _ [x] = [x]
217+filterButLast f (x:xs)
218+ | f x = x : filterButLast f xs
219+ | otherwise = filterButLast f xs
220+
221+
222+unsafe :: FilePath -> Bool
223+unsafe (FilePath s)
224+ | T.null s = False
225+ | T.head s == '.' = True
226+ | otherwise = T.any (== '/') s
227+
228+nullFilePath :: FilePath -> Bool
229+nullFilePath = T.null . unFilePath
230+
231+stripTrailingSlash :: FilePath -> FilePath
232+stripTrailingSlash fp@(FilePath t)
233+ | T.null t || T.last t /= '/' = fp
234+ | otherwise = FilePath $ T.init t
235+
236+type Pieces = [FilePath]
237+
238+relativeDirFromPieces :: Pieces -> T.Text
239+relativeDirFromPieces pieces = T.concat $ map (const "../") (drop 1 pieces) -- last piece is not a dir
240+
241+pathFromPieces :: FilePath -> Pieces -> FilePath
242+pathFromPieces = foldl' (</>)
243+
244+checkSpecialDirListing :: Pieces -> Maybe CheckPieces
245+checkSpecialDirListing [".hidden", "folder.png"] =
246+ Just $ SendContent "image/png" $ L.fromChunks [$(embedFile "folder.png")]
247+checkSpecialDirListing [".hidden", "haskell.png"] =
248+ Just $ SendContent "image/png" $ L.fromChunks [$(embedFile "haskell.png")]
249+checkSpecialDirListing _ = Nothing
250+
251+checkPieces :: (Pieces -> IO FileLookup) -- ^ file lookup function
252+ -> [FilePath] -- ^ List of default index files. Cannot contain slashes.
253+ -> Pieces -- ^ parsed request
254+ -> W.Request
255+ -> MaxAge
256+ -> Bool
257+ -> IO CheckPieces
258+checkPieces fileLookup indices pieces req maxAge useHash
259+ | any unsafe pieces = return Forbidden
260+ | any nullFilePath $ safeInit pieces =
261+ return $ Redirect (filterButLast (not . nullFilePath) pieces) Nothing
262+ | otherwise = do
263+ let (isFile, isFolder) =
264+ case () of
265+ ()
266+ | null pieces -> (True, True)
267+ | nullFilePath (last pieces) -> (False, True)
268+ | otherwise -> (True, False)
269+
270+ fl <- fileLookup pieces
271+ case (fl, isFile) of
272+ (Nothing, _) -> return NotFound
273+ (Just (Right file), True) -> handleCache file
274+ (Just Right{}, False) -> return $ Redirect (init pieces) Nothing
275+ (Just (Left folder@(Folder _ contents)), _) -> do
276+ case checkIndices $ map fileName $ rights contents of
277+ Just index -> return $ Redirect (setLast pieces index) Nothing
278+ Nothing ->
279+ if isFolder
280+ then return $ DirectoryResponse folder
281+ else return $ Redirect (pieces ++ [""]) Nothing
282+ where
283+ headers = W.requestHeaders req
284+ queryString = W.queryString req
285+
286+ -- HTTP caching has a cache control header that you can set an expire time for a resource.
287+ -- Max-Age is easiest because it is a simple number
288+ -- a cache-control asset will only be downloaded once (if the browser maintains its cache)
289+ -- and the server will never be contacted for the resource again (until it expires)
290+ --
291+ -- A second caching mechanism is ETag and last-modified
292+ -- this form of caching is not as good as the static- the browser can avoid downloading the file, but it always need to send a request with the etag value or the last-modified value to the server to see if its copy is up to date
293+ --
294+ -- We should set a cache control and one of ETag or last-modifed whenever possible
295+ --
296+ -- In a Yesod web application we can append an etag parameter to static assets.
297+ -- This signals that both a max-age and ETag header should be set
298+ -- if there is no etag parameter
299+ -- * don't set the max-age
300+ -- * set ETag or last-modified
301+ -- * ETag must be calculated ahead of time.
302+ -- * last-modified is just the file mtime.
303+ handleCache file =
304+ if not useHash then lastModifiedCache file
305+ else do
306+ let mGetHash = fileGetHash file
307+ let etagParam = lookup "etag" queryString
308+
309+ case (etagParam, mGetHash) of
310+ (Just mEtag, Just getHash) -> do
311+ hash <- getHash
312+ if isJust mEtag && hash == fromJust mEtag
313+ then return $ FileResponse file $ ("ETag", hash):cacheControl
314+ else return $ Redirect pieces (Just hash)
315+ -- a file used to have an etag parameter, but no longer does
316+ (Just _, Nothing) -> return $ Redirect pieces Nothing
317+
318+ _ ->
319+ case (lookup "if-none-match" headers, mGetHash) of
320+ -- etag
321+ (mLastHash, Just getHash) -> do
322+ hash <- getHash
323+ case mLastHash of
324+ Just lastHash ->
325+ if hash == lastHash
326+ then return NotModified
327+ else return $ FileResponse file $ [("ETag", hash)]
328+ Nothing -> return $ FileResponse file $ [("ETag", hash)]
329+ (_, Nothing) -> lastModifiedCache file
330+
331+ lastModifiedCache file =
332+ case (lookup "if-modified-since" headers >>= parseHTTPDate, fileGetModified file) of
333+ (mLastSent, Just modified) -> do
334+ let mdate = epochTimeToHTTPDate modified in
335+ case mLastSent of
336+ Just lastSent ->
337+ if lastSent == mdate
338+ then return NotModified
339+ else return $ FileResponse file $ [("last-modified", formatHTTPDate mdate)]
340+ Nothing -> return $ FileResponse file $ [("last-modified", formatHTTPDate mdate)]
341+ _ -> return $ FileResponse file []
342+
343+ setLast :: Pieces -> FilePath -> Pieces
344+ setLast [] x = [x]
345+ setLast [""] x = [x]
346+ setLast (a:b) x = a : setLast b x
347+
348+ checkIndices :: [FilePath] -> Maybe FilePath
349+ checkIndices contents = find (flip elem indices) contents
350+
351+ cacheControl = case ccInt of
352+ Nothing -> []
353+ Just i -> [("Cache-Control", S8.append "max-age=" $ S8.pack $ show i)]
354+ where
355+ ccInt =
356+ case maxAge of
357+ NoMaxAge -> Nothing
358+ MaxAgeSeconds i -> Just i
359+ MaxAgeForever -> Just oneYear
360+ oneYear :: Int
361+ oneYear = 60 * 60 * 24 * 365
362+
363+type Listing = (Pieces -> Folder -> IO L.ByteString)
364+
365+
366+type FileLookup = Maybe (Either Folder File)
367+
368+data Folder = Folder
369+ { folderName :: FilePath
370+ , folderContents :: [Either Folder File]
371+ }
372+
373+data File = File
374+ { fileGetSize :: Int
375+ , fileToResponse :: H.Status -> H.ResponseHeaders -> W.Response
376+ , fileName :: FilePath
377+ , fileGetHash :: Maybe (IO ByteString)
378+ , fileGetModified :: Maybe EpochTime
379+ }
380+
381+data StaticSettings = StaticSettings
382+ { ssFolder :: Pieces -> IO FileLookup
383+ , ssMkRedirect :: Pieces -> ByteString -> ByteString
384+ , ssGetMimeType :: File -> IO MimeType
385+ , ssListing :: Maybe Listing
386+ , ssIndices :: [T.Text] -- index.html
387+ , ssMaxAge :: MaxAge
388+ , ssUseHash :: Bool
389+ }
390+
391+data MaxAge = NoMaxAge | MaxAgeSeconds Int | MaxAgeForever
392+
393+defaultMkRedirect :: Pieces -> ByteString -> S8.ByteString
394+defaultMkRedirect pieces newPath
395+ | S8.null newPath || S8.null relDir ||
396+ S8.last relDir /= '/' || S8.head newPath /= '/' =
397+ relDir `S8.append` newPath
398+ | otherwise = relDir `S8.append` S8.tail newPath
399+ where
400+ relDir = TE.encodeUtf8 (relativeDirFromPieces pieces)
401+
402+defaultWebAppSettings :: StaticSettings
403+defaultWebAppSettings = StaticSettings
404+ { ssFolder = fileSystemLookup "static"
405+ , ssMkRedirect = defaultMkRedirect
406+ , ssGetMimeType = return . defaultMimeTypeByExt . fileName
407+ , ssMaxAge = MaxAgeForever
408+ , ssListing = Nothing
409+ , ssIndices = []
410+ , ssUseHash = True
411+ }
412+
413+defaultFileServerSettings :: StaticSettings
414+defaultFileServerSettings = StaticSettings
415+ { ssFolder = fileSystemLookup "static"
416+ , ssMkRedirect = defaultMkRedirect
417+ , ssGetMimeType = return . defaultMimeTypeByExt . fileName
418+ , ssMaxAge = MaxAgeSeconds $ 60 * 60
419+ , ssListing = Just defaultListing
420+ , ssIndices = ["index.html", "index.htm"]
421+ , ssUseHash = False
422+ }
423+
424+fileHelper :: FilePath -> FilePath -> IO File
425+fileHelper fp name = do
426+ fs <- getFileStatus $ fromFilePath fp
427+ return File
428+ { fileGetSize = fromIntegral $ fileSize fs
429+ , fileToResponse = \s h -> W.ResponseFile s h (fromFilePath fp) Nothing
430+ , fileName = name
431+ , fileGetHash = Just $ do
432+ -- FIXME replace lazy IO with enumerators
433+ -- FIXME let's use a dictionary to cache these values?
434+ l <- L.readFile $ fromFilePath fp
435+ return $ runHashL l
436+ , fileGetModified = Just $ modificationTime fs
437+ }
438+
439+fileSystemLookup :: FilePath -> Pieces -> IO FileLookup
440+fileSystemLookup prefix pieces = do
441+ let fp = pathFromPieces prefix pieces
442+ fe <- doesFileExist $ fromFilePath fp
443+ if fe
444+ then fmap (Just . Right) $ fileHelper fp $ last pieces
445+ else do
446+ de <- doesDirectoryExist $ fromFilePath fp
447+ if de
448+ then do
449+ let isVisible ('.':_) = return False
450+ isVisible "" = return False
451+ isVisible _ = return True
452+ entries <- getDirectoryContents (fromFilePath fp) >>= filterM isVisible >>= mapM (\nameRaw -> do
453+ let name = toFilePath nameRaw
454+ let fp' = fp </> name
455+ fe' <- doesFileExist $ fromFilePath fp'
456+ if fe'
457+ then fmap Right $ fileHelper fp' name
458+ else return $ Left $ Folder name [])
459+ return $ Just $ Left $ Folder (error "413") entries
460+ else return Nothing
461+
462+type Embedded = Map.Map FilePath EmbeddedEntry
463+
464+data EmbeddedEntry = EEFile S8.ByteString | EEFolder Embedded
465+
466+embeddedLookup :: Embedded -> Pieces -> IO FileLookup
467+embeddedLookup root pieces =
468+ return $ elookup "<root>" pieces root
469+ where
470+ elookup :: FilePath -> [FilePath] -> Embedded -> FileLookup
471+ elookup p [] x = Just $ Left $ Folder p $ map toEntry $ Map.toList x
472+ elookup p [""] x = elookup p [] x
473+ elookup _ (p:ps) x =
474+ case Map.lookup p x of
475+ Nothing -> Nothing
476+ Just (EEFile f) ->
477+ case ps of
478+ [] -> Just $ Right $ bsToFile p f
479+ _ -> Nothing
480+ Just (EEFolder y) -> elookup p ps y
481+
482+toEntry :: (FilePath, EmbeddedEntry) -> Either Folder File
483+toEntry (name, EEFolder{}) = Left $ Folder name []
484+toEntry (name, EEFile bs) = Right $ File
485+ { fileGetSize = S8.length bs
486+ , fileToResponse = \s h -> W.ResponseBuilder s h $ fromByteString bs
487+ , fileName = name
488+ , fileGetHash = Just $ return $ runHash bs
489+ , fileGetModified = Nothing
490+ }
491+
492+toEmbedded :: [(Prelude.FilePath, S8.ByteString)] -> Embedded
493+toEmbedded fps =
494+ go texts
495+ where
496+ texts = map (\(x, y) -> (filter (not . T.null . unFilePath) $ toPieces x, y)) fps
497+ toPieces "" = []
498+ toPieces x =
499+ let (y, z) = break (== '/') x
500+ in toFilePath y : toPieces (drop 1 z)
501+ go :: [([FilePath], S8.ByteString)] -> Embedded
502+ go orig =
503+ Map.fromList $ map (second go') hoisted
504+ where
505+ next = map (\(x, y) -> (head x, (tail x, y))) orig
506+ grouped :: [[(FilePath, ([FilePath], S8.ByteString))]]
507+ grouped = groupBy ((==) `on` fst) $ sortBy (comparing fst) next
508+ hoisted :: [(FilePath, [([FilePath], S8.ByteString)])]
509+ hoisted = map (fst . head &&& map snd) grouped
510+ go' :: [([FilePath], S8.ByteString)] -> EmbeddedEntry
511+ go' [([], content)] = EEFile content
512+ go' x = EEFolder $ go $ filter (\y -> not $ null $ fst y) x
513+
514+bsToFile :: FilePath -> S8.ByteString -> File
515+bsToFile name bs = File
516+ { fileGetSize = S8.length bs
517+ , fileToResponse = \s h -> W.ResponseBuilder s h $ fromByteString bs
518+ , fileName = name
519+ , fileGetHash = Just $ return $ runHash bs
520+ , fileGetModified = Nothing
521+ }
522+
523+runHash :: S8.ByteString -> S8.ByteString
524+runHash = B64.encode . MD5.hash
525+
526+runHashL :: L.ByteString -> ByteString
527+runHashL = B64.encode . MD5.hashlazy
528+
529+staticApp :: StaticSettings -> W.Application
530+staticApp set req = staticAppPieces set (map FilePath $ W.pathInfo req) req
531+
532+status304, statusNotModified :: H.Status
533+status304 = H.Status 304 "Not Modified"
534+statusNotModified = status304
535+
536+-- alist helper functions
537+replace :: Eq a => a -> b -> [(a, b)] -> [(a, b)]
538+replace k v [] = [(k,v)]
539+replace k v (x:xs) | fst x == k = (k,v):xs
540+ | otherwise = x:replace k v xs
541+
542+remove :: Eq a => a -> [(a, b)] -> [(a, b)]
543+remove _ [] = []
544+remove k (x:xs) | fst x == k = xs
545+ | otherwise = x:remove k xs
546+
547+
548+staticAppPieces :: StaticSettings -> Pieces -> W.Application
549+staticAppPieces _ _ req
550+ | W.requestMethod req /= "GET" = return $ W.responseLBS
551+ H.status405
552+ [("Content-Type", "text/plain")]
553+ "Only GET is supported"
554+staticAppPieces ss pieces req = liftIO $ do
555+ let indices = ssIndices ss
556+ case checkSpecialDirListing pieces of
557+ Just res -> response res
558+ Nothing -> checkPieces (ssFolder ss) (map FilePath indices) pieces req (ssMaxAge ss) (ssUseHash ss) >>= response
559+ where
560+ response cp = case cp of
561+ FileResponse file ch -> do
562+ mimetype <- ssGetMimeType ss file
563+ let filesize = fileGetSize file
564+ let headers = ("Content-Type", mimetype)
565+ : ("Content-Length", S8.pack $ show filesize)
566+ : ch
567+ return $ fileToResponse file H.status200 headers
568+ NotModified ->
569+ return $ W.responseLBS statusNotModified
570+ [ ("Content-Type", "text/plain")
571+ ] "Not Modified"
572+ DirectoryResponse fp -> do
573+ case ssListing ss of
574+ (Just f) -> do
575+ lbs <- f pieces fp
576+ return $ W.responseLBS H.status200
577+ [ ("Content-Type", "text/html; charset=utf-8")
578+ ] lbs
579+ Nothing -> return $ W.responseLBS H.status403
580+ [ ("Content-Type", "text/plain")
581+ ] "Directory listings disabled"
582+ SendContent mt lbs -> do
583+ -- TODO: set caching headers
584+ return $ W.responseLBS H.status200
585+ [ ("Content-Type", mt)
586+ -- TODO: set Content-Length
587+ ] lbs
588+
589+ Redirect pieces' mHash -> do
590+ let loc = (ssMkRedirect ss) pieces' $ toByteString (H.encodePathSegments $ map unFilePath pieces')
591+ let qString = case mHash of
592+ Just hash -> replace "etag" (Just hash) (W.queryString req)
593+ Nothing -> remove "etag" (W.queryString req)
594+
595+ return $ W.responseLBS H.status301
596+ [ ("Content-Type", "text/plain")
597+ , ("Location", S8.append loc $ H.renderQuery True qString)
598+ ] "Redirect"
599+ Forbidden -> return $ W.responseLBS H.status403
600+ [ ("Content-Type", "text/plain")
601+ ] "Forbidden"
602+ NotFound -> return $ W.responseLBS H.status404
603+ [ ("Content-Type", "text/plain")
604+ ] "File not found"
605+
606+{-
607+The problem is that the System.Directory functions are a lie: they
608+claim to be using String, but it's really just a raw byte sequence.
609+We're assuming that non-Windows systems use UTF-8 encoding (there was
610+a discussion regarding this, it wasn't an arbitrary decision). So we
611+need to encode/decode the byte sequence to/from UTF8. That's the use
612+case for fixPathName/unfixPathName. I'm starting to use John
613+Millikin's system-filepath package for some stuff with work, and might
614+consider migrating over to it for this in the future.
615+-}
616+toFilePath :: Prelude.FilePath -> FilePath
617+#if defined(mingw32_HOST_OS)
618+toFilePath = FilePath . T.pack
619+#else
620+toFilePath = FilePath . TE.decodeUtf8With TEE.lenientDecode . S8.pack
621+#endif
622+
623+fromFilePath :: FilePath -> Prelude.FilePath
624+#if defined(mingw32_HOST_OS)
625+fromFilePath = T.unpack . unFilePath
626+#else
627+fromFilePath = S8.unpack . TE.encodeUtf8 . unFilePath
628+#endif
629+
630+-- Code below taken from Happstack: http://patch-tag.com/r/mae/happstack/snapshot/current/content/pretty/happstack-server/src/Happstack/Server/FileServe/BuildingBlocks.hs
631+defaultListing :: Listing
632+defaultListing pieces (Folder _ contents) = do
633+ let isTop = null pieces || pieces == [""]
634+ let fps'' :: [Either Folder File]
635+ fps'' = (if isTop then id else (Left (Folder ".." []) :)) contents
636+ return $ HU.renderHtml
637+ $ H.html $ do
638+ H.head $ do
639+ let title = T.unpack $ T.intercalate "/" $ map unFilePath pieces
640+ let title' = if null title then "root folder" else title
641+ H.title $ H.toHtml title'
642+ H.style $ H.toHtml $ unlines [ "table { margin: 0 auto; width: 760px; border-collapse: collapse; font-family: 'sans-serif'; }"
643+ , "table, th, td { border: 1px solid #353948; }"
644+ , "td.size { text-align: right; font-size: 0.7em; width: 50px }"
645+ , "td.date { text-align: right; font-size: 0.7em; width: 130px }"
646+ , "td { padding-right: 1em; padding-left: 1em; }"
647+ , "th.first { background-color: white; width: 24px }"
648+ , "td.first { padding-right: 0; padding-left: 0; text-align: center }"
649+ , "tr { background-color: white; }"
650+ , "tr.alt { background-color: #A3B5BA}"
651+ , "th { background-color: #3C4569; color: white; font-size: 1.125em; }"
652+ , "h1 { width: 760px; margin: 1em auto; font-size: 1em; font-family: sans-serif }"
653+ , "img { width: 20px }"
654+ , "a { text-decoration: none }"
655+ ]
656+ H.body $ do
657+ H.h1 $ showFolder $ map unFilePath $ filter (not . nullFilePath) pieces
658+ renderDirectoryContentsTable haskellSrc folderSrc fps''
659+ where
660+ image x = T.unpack $ T.concat [(relativeDirFromPieces pieces), ".hidden/", x, ".png"]
661+ folderSrc = image "folder"
662+ haskellSrc = image "haskell"
663+ showName "" = "root"
664+ showName x = x
665+ showFolder [] = "/"
666+ showFolder [x] = H.toHtml $ showName x
667+ showFolder (x:xs) = do
668+ let href = concat $ replicate (length xs) "../" :: String
669+ H.a ! A.href (H.toValue href) $ H.toHtml $ showName x
670+ " / " :: H.Html
671+ showFolder xs
672+
673+-- | a function to generate an HTML table showing the contents of a directory on the disk
674+--
675+-- This function generates most of the content of the
676+-- 'renderDirectoryContents' page. If you want to style the page
677+-- differently, or add google analytics code, etc, you can just create
678+-- a new page template to wrap around this HTML.
679+--
680+-- see also: 'getMetaData', 'renderDirectoryContents'
681+renderDirectoryContentsTable :: String
682+ -> String
683+ -> [Either Folder File]
684+ -> H.Html
685+renderDirectoryContentsTable haskellSrc folderSrc fps =
686+ H.table $ do H.thead $ do H.th ! (A.class_ "first") $ H.img ! (A.src $ H.toValue haskellSrc)
687+ H.th "Name"
688+ H.th "Modified"
689+ H.th "Size"
690+ H.tbody $ mapM_ mkRow (zip (sortBy sortMD fps) $ cycle [False, True])
691+ where
692+ sortMD :: Either Folder File -> Either Folder File -> Ordering
693+ sortMD Left{} Right{} = LT
694+ sortMD Right{} Left{} = GT
695+ sortMD (Left a) (Left b) = compare (folderName a) (folderName b)
696+ sortMD (Right a) (Right b) = compare (fileName a) (fileName b)
697+ mkRow :: (Either Folder File, Bool) -> H.Html
698+ mkRow (md, alt) =
699+ (if alt then (! A.class_ "alt") else id) $
700+ H.tr $ do
701+ H.td ! A.class_ "first"
702+ $ case md of
703+ Left{} -> H.img ! A.src (H.toValue folderSrc)
704+ ! A.alt "Folder"
705+ Right{} -> return ()
706+ let name = either folderName fileName md
707+ let isFile = either (const False) (const True) md
708+ H.td (H.a ! A.href (H.toValue $ unFilePath name `T.append` if isFile then "" else "/") $ H.toHtml $ unFilePath name)
709+ H.td ! A.class_ "date" $ H.toHtml $
710+ case md of
711+ Right File { fileGetModified = Just t } ->
712+ formatCalendarTime defaultTimeLocale "%d-%b-%Y %X" t
713+ _ -> ""
714+ H.td ! A.class_ "size" $ H.toHtml $
715+ case md of
716+ Right File { fileGetSize = s } -> prettyShow s
717+ Left{} -> ""
718+ formatCalendarTime a b c = formatTime a b $ posixSecondsToUTCTime (realToFrac c :: POSIXTime)
719+ prettyShow x
720+ | x > 1024 = prettyShowK $ x `div` 1024
721+ | otherwise = addCommas "B" x
722+ prettyShowK x
723+ | x > 1024 = prettyShowM $ x `div` 1024
724+ | otherwise = addCommas "KB" x
725+ prettyShowM x
726+ | x > 1024 = prettyShowG $ x `div` 1024
727+ | otherwise = addCommas "MB" x
728+ prettyShowG x = addCommas "GB" x
729+ addCommas s = (++ (' ' : s)) . reverse . addCommas' . reverse . show
730+ addCommas' (a:b:c:d:e) = a : b : c : ',' : addCommas' (d : e)
731+ addCommas' x = x
732+
733+{-
734+mdIsFile :: MetaData -> Bool
735+mdIsFile FileMetaData{} = True
736+mdIsFile FolderMetaData{} = False
737+
738+-- | look up the meta data associated with a file
739+getMetaData :: FilePath -- ^ path to directory on disk containing the entry
740+ -> FilePath -- ^ entry in that directory
741+ -> IO (Maybe MetaData)
742+getMetaData _ ('.':_) = return Nothing
743+getMetaData localPath fp = do
744+ let fp' = localPath ++ '/' : fp
745+ fe <- doesFileExist fp'
746+ let fpPretty = T.pack $ fixPathName fp
747+ if fe
748+ then do
749+ fs <- getFileStatus fp'
750+ let modTime = modificationTime fs
751+ let count = fileSize fs
752+ return $ Just $ FileMetaData fpPretty (Just modTime) count
753+ else do
754+ de <- doesDirectoryExist fp'
755+ return $ if de then Just (FolderMetaData fpPretty) else Nothing
756+-}