@@ -0,0 +1,217 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+-- | Static file serving for WAI.
3+module Network.Wai.Application.Static
4+ ( -- * Generic, non-WAI code
5+ -- ** Mime types
6+ MimeType
7+ , defaultMimeType
8+ -- ** Mime type by file extension
9+ , MimeMap
10+ , defaultMimeTypes
11+ , mimeTypeByExt
12+ , defaultMimeTypeByExt
13+ -- ** Finding files
14+ , CheckPieces
15+ , checkPieces
16+ -- * WAI application
17+ , StaticSettings (..)
18+ , staticApp
19+ ) where
20+
21+import qualified Network.Wai as W
22+import Data.Map (Map)
23+import qualified Data.Map as Map
24+import Data.ByteString (ByteString)
25+import System.FilePath (takeExtensions)
26+import Data.Maybe (fromMaybe)
27+import System.Directory (doesFileExist, doesDirectoryExist)
28+import qualified Data.ByteString.Char8 as S8
29+import qualified Data.ByteString.Lazy as L
30+import Data.ByteString.Lazy.Char8 ()
31+import Web.Routes.Base (decodePathInfo, encodePathInfo)
32+import System.PosixCompat.Files (fileSize, getFileStatus)
33+import Control.Monad.IO.Class (liftIO)
34+
35+type MimeType = ByteString
36+type MimeMap = Map FilePath MimeType
37+
38+defaultMimeType :: MimeType
39+defaultMimeType = "application/octet-stream"
40+
41+-- taken from snap-core Snap.Util.FileServer
42+defaultMimeTypes :: MimeMap
43+defaultMimeTypes = Map.fromList [
44+ ( ".asc" , "text/plain" ),
45+ ( ".asf" , "video/x-ms-asf" ),
46+ ( ".asx" , "video/x-ms-asf" ),
47+ ( ".avi" , "video/x-msvideo" ),
48+ ( ".bz2" , "application/x-bzip" ),
49+ ( ".c" , "text/plain" ),
50+ ( ".class" , "application/octet-stream" ),
51+ ( ".conf" , "text/plain" ),
52+ ( ".cpp" , "text/plain" ),
53+ ( ".css" , "text/css" ),
54+ ( ".cxx" , "text/plain" ),
55+ ( ".dtd" , "text/xml" ),
56+ ( ".dvi" , "application/x-dvi" ),
57+ ( ".gif" , "image/gif" ),
58+ ( ".gz" , "application/x-gzip" ),
59+ ( ".hs" , "text/plain" ),
60+ ( ".htm" , "text/html" ),
61+ ( ".html" , "text/html" ),
62+ ( ".jar" , "application/x-java-archive" ),
63+ ( ".jpeg" , "image/jpeg" ),
64+ ( ".jpg" , "image/jpeg" ),
65+ ( ".js" , "text/javascript" ),
66+ ( ".log" , "text/plain" ),
67+ ( ".m3u" , "audio/x-mpegurl" ),
68+ ( ".mov" , "video/quicktime" ),
69+ ( ".mp3" , "audio/mpeg" ),
70+ ( ".mpeg" , "video/mpeg" ),
71+ ( ".mpg" , "video/mpeg" ),
72+ ( ".ogg" , "application/ogg" ),
73+ ( ".pac" , "application/x-ns-proxy-autoconfig" ),
74+ ( ".pdf" , "application/pdf" ),
75+ ( ".png" , "image/png" ),
76+ ( ".ps" , "application/postscript" ),
77+ ( ".qt" , "video/quicktime" ),
78+ ( ".sig" , "application/pgp-signature" ),
79+ ( ".spl" , "application/futuresplash" ),
80+ ( ".swf" , "application/x-shockwave-flash" ),
81+ ( ".tar" , "application/x-tar" ),
82+ ( ".tar.bz2" , "application/x-bzip-compressed-tar" ),
83+ ( ".tar.gz" , "application/x-tgz" ),
84+ ( ".tbz" , "application/x-bzip-compressed-tar" ),
85+ ( ".text" , "text/plain" ),
86+ ( ".tgz" , "application/x-tgz" ),
87+ ( ".torrent" , "application/x-bittorrent" ),
88+ ( ".ttf" , "application/x-font-truetype" ),
89+ ( ".txt" , "text/plain" ),
90+ ( ".wav" , "audio/x-wav" ),
91+ ( ".wax" , "audio/x-ms-wax" ),
92+ ( ".wma" , "audio/x-ms-wma" ),
93+ ( ".wmv" , "video/x-ms-wmv" ),
94+ ( ".xbm" , "image/x-xbitmap" ),
95+ ( ".xml" , "text/xml" ),
96+ ( ".xpm" , "image/x-xpixmap" ),
97+ ( ".xwd" , "image/x-xwindowdump" ),
98+ ( ".zip" , "application/zip" )]
99+
100+mimeTypeByExt :: MimeMap
101+ -> MimeType -- ^ default mime type
102+ -> FilePath
103+ -> MimeType
104+mimeTypeByExt mm def fp = fromMaybe def $ Map.lookup (takeExtensions fp) mm
105+
106+defaultMimeTypeByExt :: FilePath -> MimeType
107+defaultMimeTypeByExt = mimeTypeByExt defaultMimeTypes defaultMimeType
108+
109+data CheckPieces
110+ = Redirect [String]
111+ | Forbidden
112+ | NotFound
113+ | FileResponse FilePath
114+ | DirectoryResponse FilePath
115+ deriving Show
116+
117+anyButLast :: (a -> Bool) -> [a] -> Bool
118+anyButLast _ [] = False
119+anyButLast _ [_] = False
120+anyButLast p (x:xs)
121+ | p x == True = True
122+ | otherwise = anyButLast p xs
123+
124+filterButLast :: (a -> Bool) -> [a] -> [a]
125+filterButLast _ [] = []
126+filterButLast _ [x] = [x]
127+filterButLast f (x:xs)
128+ | f x = x : filterButLast f xs
129+ | otherwise = filterButLast f xs
130+
131+unsafe :: FilePath -> Bool
132+unsafe ('.':_) = True
133+unsafe s = any (== '/') s
134+
135+stripTrailingSlash :: FilePath -> FilePath
136+stripTrailingSlash "/" = ""
137+stripTrailingSlash "" = ""
138+stripTrailingSlash (x:xs) = x : stripTrailingSlash xs
139+
140+checkPieces :: FilePath -- ^ static file prefix
141+ -> [String] -- ^ parsed request
142+ -> IO CheckPieces
143+checkPieces prefix pieces
144+ | any unsafe pieces = return Forbidden
145+ | anyButLast null pieces =
146+ return $ Redirect $ filterButLast (not . null) pieces
147+ | otherwise = do
148+ let fp = concat $ prefix : map ((:) '/') pieces
149+ let (isFile, isFolder) =
150+ case () of
151+ ()
152+ | null pieces -> (True, True)
153+ | null (last pieces) -> (False, True)
154+ | otherwise -> (True, False)
155+ fe <- doesFileExist $ stripTrailingSlash fp
156+ case (fe, isFile) of
157+ (True, True) -> return $ FileResponse fp
158+ (True, False) -> return $ Redirect $ init pieces
159+ (False, _) -> do
160+ de <- doesDirectoryExist fp
161+ case (de, isFolder) of
162+ (True, True) -> return $ DirectoryResponse fp
163+ (True, False) -> return $ Redirect $ pieces ++ [""]
164+ (False, _) -> return NotFound
165+
166+type Listing = FilePath -> IO L.ByteString
167+
168+data StaticSettings = StaticSettings
169+ { ssFolder :: FilePath
170+ , ssIndices :: [FilePath]
171+ , ssListing :: Maybe Listing
172+ , ssGetMimeType :: FilePath -> IO MimeType
173+ }
174+
175+staticApp :: StaticSettings -> W.Application
176+staticApp (StaticSettings folder indices mlisting getmime) req = liftIO $ do
177+ let pieces = decodePathInfo $ S8.unpack $ W.pathInfo req
178+ cp <- checkPieces folder pieces
179+ case cp of
180+ Redirect pieces' -> do
181+ let loc = S8.pack $ '/' : encodePathInfo pieces' []
182+ return $ W.responseLBS W.status301
183+ [ ("Content-Type", "text/plain")
184+ , ("Location", loc)
185+ ] "Redirect"
186+ Forbidden -> return $ W.responseLBS W.status403
187+ [ ("Content-Type", "text/plain")
188+ ] "Forbidden"
189+ NotFound -> return $ W.responseLBS W.status404
190+ [ ("Content-Type", "text/plain")
191+ ] "File not found"
192+ FileResponse fp -> sendfile fp
193+ DirectoryResponse fp -> sendfolder fp indices
194+ where
195+ sendfolder fp (i:is) = do
196+ let fp' = fp ++ '/' : i
197+ fe <- doesFileExist fp'
198+ if fe
199+ then sendfile fp'
200+ else sendfolder fp is
201+ sendfolder fp [] =
202+ case mlisting of
203+ Just listing -> do
204+ lbs <- listing fp
205+ return $ W.responseLBS W.status200
206+ [ ("Content-Type", "text/html")
207+ ] lbs
208+ Nothing -> return $ W.responseLBS W.status403
209+ [ ("Content-Type", "text/plain")
210+ ] "Directory listings disabled"
211+ sendfile fp = do
212+ mimetype <- getmime fp
213+ filesize <- fileSize `fmap` getFileStatus fp
214+ return $ W.ResponseFile W.status200
215+ [ ("Content-Type", mimetype)
216+ , ("Content-Length", S8.pack $ show filesize)
217+ ] fp