1 | {-# LANGUAGE DeriveDataTypeable, ViewPatterns #-} |
---|
2 | {-# OPTIONS_GHC -O2 -Wall #-} |
---|
3 | |
---|
4 | import Prelude hiding (catch) |
---|
5 | import Control.Applicative |
---|
6 | import Control.Monad |
---|
7 | import Control.Monad.CatchIO |
---|
8 | import qualified Data.ByteString.Lazy as B |
---|
9 | import Data.ByteString.Lazy.Char8 (pack) |
---|
10 | import Data.Char |
---|
11 | import Data.Dynamic |
---|
12 | import Data.Int |
---|
13 | import Data.List (unfoldr) |
---|
14 | import Data.List.Split (splitOn) |
---|
15 | import Data.Maybe (fromJust, isNothing, isJust) |
---|
16 | import qualified Data.Map as M |
---|
17 | import Data.Time.Clock.POSIX |
---|
18 | import Data.Time.Format |
---|
19 | import Network.CGI hiding (ContentType) |
---|
20 | import Numeric |
---|
21 | import System.FilePath |
---|
22 | import System.IO |
---|
23 | import System.IO.Error (isDoesNotExistError, isPermissionError) |
---|
24 | import System.IO.Unsafe |
---|
25 | import System.Locale |
---|
26 | import System.Posix |
---|
27 | import System.Posix.Handle |
---|
28 | import System.Random |
---|
29 | |
---|
30 | type Encoding = String |
---|
31 | type ContentType = String |
---|
32 | |
---|
33 | encodings :: M.Map String Encoding |
---|
34 | encodings = M.fromList [ |
---|
35 | (".bz2", "bzip2"), |
---|
36 | (".gz", "gzip"), |
---|
37 | (".z", "compress") |
---|
38 | ] |
---|
39 | |
---|
40 | types :: M.Map String ContentType |
---|
41 | types = M.fromList [ |
---|
42 | (".avi", "video/x-msvideo"), |
---|
43 | (".css", "text/css"), |
---|
44 | (".doc", "application/msword"), |
---|
45 | (".docm", "application/vnd.ms-word.document.macroEnabled.12"), |
---|
46 | (".docx", "application/vnd.openxmlformats-officedocument.wordprocessingml.document"), |
---|
47 | (".dot", "application/msword"), |
---|
48 | (".dotm", "application/vnd.ms-word.template.macroEnabled.12"), |
---|
49 | (".dotx", "application/vnd.openxmlformats-officedocument.wordprocessingml.template"), |
---|
50 | (".gif", "image/gif"), |
---|
51 | (".htm", "text/html"), |
---|
52 | (".html", "text/html"), |
---|
53 | (".ico", "image/vnd.microsoft.icon"), |
---|
54 | (".il", "application/octet-stream"), |
---|
55 | (".jar", "application/java-archive"), |
---|
56 | (".jpeg", "image/jpeg"), |
---|
57 | (".jpg", "image/jpeg"), |
---|
58 | (".js", "application/x-javascript"), |
---|
59 | (".mid", "audio/midi"), |
---|
60 | (".midi", "audio/midi"), |
---|
61 | (".mov", "video/quicktime"), |
---|
62 | (".mp3", "audio/mpeg"), |
---|
63 | (".mpeg", "video/mpeg"), |
---|
64 | (".mpg", "video/mpeg"), |
---|
65 | (".odb", "application/vnd.oasis.opendocument.database"), |
---|
66 | (".odc", "application/vnd.oasis.opendocument.chart"), |
---|
67 | (".odf", "application/vnd.oasis.opendocument.formula"), |
---|
68 | (".odg", "application/vnd.oasis.opendocument.graphics"), |
---|
69 | (".odi", "application/vnd.oasis.opendocument.image"), |
---|
70 | (".odm", "application/vnd.oasis.opendocument.text-master"), |
---|
71 | (".odp", "application/vnd.oasis.opendocument.presentation"), |
---|
72 | (".ods", "application/vnd.oasis.opendocument.spreadsheet"), |
---|
73 | (".odt", "application/vnd.oasis.opendocument.text"), |
---|
74 | (".otf", "application/octet-stream"), |
---|
75 | (".otg", "application/vnd.oasis.opendocument.graphics-template"), |
---|
76 | (".oth", "application/vnd.oasis.opendocument.text-web"), |
---|
77 | (".otp", "application/vnd.oasis.opendocument.presentation-template"), |
---|
78 | (".ots", "application/vnd.oasis.opendocument.spreadsheet-template"), |
---|
79 | (".ott", "application/vnd.oasis.opendocument.text-template"), |
---|
80 | (".pdf", "application/pdf"), |
---|
81 | (".png", "image/png"), |
---|
82 | (".pot", "application/vnd.ms-powerpoint"), |
---|
83 | (".potm", "application/vnd.ms-powerpoint.template.macroEnabled.12"), |
---|
84 | (".potx", "application/vnd.openxmlformats-officedocument.presentationml.template"), |
---|
85 | (".ppa", "application/vnd.ms-powerpoint"), |
---|
86 | (".ppam", "application/vnd.ms-powerpoint.addin.macroEnabled.12"), |
---|
87 | (".pps", "application/vnd.ms-powerpoint"), |
---|
88 | (".ppsm", "application/vnd.ms-powerpoint.slideshow.macroEnabled.12"), |
---|
89 | (".ppsx", "application/vnd.openxmlformats-officedocument.presentationml.slideshow"), |
---|
90 | (".ppt", "application/vnd.ms-powerpoint"), |
---|
91 | (".pptm", "application/vnd.ms-powerpoint.presentation.macroEnabled.12"), |
---|
92 | (".pptx", "application/vnd.openxmlformats-officedocument.presentationml.presentation"), |
---|
93 | (".ps", "application/postscript"), |
---|
94 | (".svg", "image/svg+xml"), |
---|
95 | (".swf", "application/x-shockwave-flash"), |
---|
96 | (".tar", "application/x-tar"), |
---|
97 | (".tgz", "application/x-gzip"), |
---|
98 | (".tif", "image/tiff"), |
---|
99 | (".tiff", "image/tiff"), |
---|
100 | (".ttf", "application/octet-stream"), |
---|
101 | (".wav", "audio/x-wav"), |
---|
102 | (".wmv", "video/x-ms-wmv"), |
---|
103 | (".xaml", "application/xaml+xml"), |
---|
104 | (".xap", "application/x-silverlight-app"), |
---|
105 | (".xhtml", "application/xhtml+xml"), |
---|
106 | (".xla", "application/vnd.ms-excel"), |
---|
107 | (".xlam", "application/vnd.ms-excel.addin.macroEnabled.12"), |
---|
108 | (".xls", "application/vnd.ms-excel"), |
---|
109 | (".xlsb", "application/vnd.ms-excel.sheet.binary.macroEnabled.12"), |
---|
110 | (".xlsm", "application/vnd.ms-excel.sheet.macroEnabled.12"), |
---|
111 | (".xlsx", "application/vnd.openxmlformats-officedocument.spreadsheetml.sheet"), |
---|
112 | (".xlt", "application/vnd.ms-excel"), |
---|
113 | (".xltm", "application/vnd.ms-excel.template.macroEnabled.12"), |
---|
114 | (".xltx", "application/vnd.openxmlformats-officedocument.spreadsheetml.template"), |
---|
115 | (".xml", "text/xml"), |
---|
116 | (".xsl", "text/xml"), |
---|
117 | (".zip", "application/zip") |
---|
118 | ] |
---|
119 | |
---|
120 | data MyError = NotModified | Forbidden | NotFound | BadMethod | BadRange |
---|
121 | deriving (Show, Typeable) |
---|
122 | |
---|
123 | instance Exception MyError |
---|
124 | |
---|
125 | outputMyError :: MyError -> CGI CGIResult |
---|
126 | outputMyError NotModified = setStatus 304 "Not Modified" >> outputNothing |
---|
127 | outputMyError Forbidden = outputError 403 "Forbidden" [] |
---|
128 | outputMyError NotFound = outputError 404 "Not Found" [] |
---|
129 | outputMyError BadMethod = outputError 405 "Method Not Allowed" [] |
---|
130 | outputMyError BadRange = outputError 416 "Requested Range Not Satisfiable" [] |
---|
131 | |
---|
132 | -- | Nothing if type is not whitelisted. |
---|
133 | checkExtension :: FilePath -> Maybe (Maybe Encoding, ContentType) |
---|
134 | checkExtension file = |
---|
135 | let (base, ext) = splitExtension file |
---|
136 | (file', enc) = case M.lookup (map toLower ext) encodings of |
---|
137 | Nothing -> (file, Nothing) |
---|
138 | Just e -> (base, Just e) |
---|
139 | (_, ext') = splitExtension file' |
---|
140 | in case M.lookup (map toLower ext') types of |
---|
141 | Nothing -> Nothing |
---|
142 | Just e -> Just (enc, e) |
---|
143 | |
---|
144 | checkMethod :: CGI CGIResult -> CGI CGIResult |
---|
145 | checkMethod rOutput = do |
---|
146 | m <- requestMethod |
---|
147 | case m of |
---|
148 | "HEAD" -> rOutput >> outputNothing |
---|
149 | "GET" -> rOutput |
---|
150 | "POST" -> rOutput |
---|
151 | _ -> throw BadMethod |
---|
152 | |
---|
153 | httpDate :: String |
---|
154 | httpDate = "%a, %d %b %Y %H:%M:%S %Z" |
---|
155 | formatHTTPDate :: EpochTime -> String |
---|
156 | formatHTTPDate = formatTime defaultTimeLocale httpDate . |
---|
157 | posixSecondsToUTCTime . realToFrac |
---|
158 | parseHTTPDate :: String -> Maybe EpochTime |
---|
159 | parseHTTPDate = (fromInteger . floor . utcTimeToPOSIXSeconds <$>) . |
---|
160 | parseTime defaultTimeLocale httpDate |
---|
161 | |
---|
162 | checkModified :: EpochTime -> CGI () |
---|
163 | checkModified mTime = do |
---|
164 | setHeader "Last-Modified" $ formatHTTPDate mTime |
---|
165 | (requestHeader "If-Modified-Since" >>=) $ maybe (return ()) $ \ims -> |
---|
166 | when (parseHTTPDate ims >= Just mTime) $ throw NotModified |
---|
167 | |
---|
168 | checkIfRange :: EpochTime -> CGI (Maybe ()) |
---|
169 | checkIfRange mTime = do |
---|
170 | (requestHeader "If-Range" >>=) $ maybe (return $ Just ()) $ \ir -> |
---|
171 | return $ if parseHTTPDate ir == Just mTime then Just () else Nothing |
---|
172 | |
---|
173 | -- | parseRanges string size returns a list of ranges, or Nothing if parse fails. |
---|
174 | parseRanges :: String -> FileOffset -> Maybe [(FileOffset, FileOffset)] |
---|
175 | parseRanges (splitAt 6 -> ("bytes=", ranges)) size = |
---|
176 | mapM parseOneRange $ splitOn "," ranges |
---|
177 | where parseOneRange ('-':(readDec -> [(len, "")])) = |
---|
178 | Just (max 0 (size - len), size - 1) |
---|
179 | parseOneRange (readDec -> [(a, "-")]) = |
---|
180 | Just (a, size - 1) |
---|
181 | parseOneRange (readDec -> [(a, '-':(readDec -> [(b, "")]))]) = |
---|
182 | Just (a, min (size - 1) b) |
---|
183 | parseOneRange _ = Nothing |
---|
184 | parseRanges _ _ = Nothing |
---|
185 | |
---|
186 | checkRanges :: EpochTime -> FileOffset -> CGI (Maybe [(FileOffset, FileOffset)]) |
---|
187 | checkRanges mTime size = do |
---|
188 | setHeader "Accept-Ranges" "bytes" |
---|
189 | (requestHeader "Range" >>=) $ maybe (return Nothing) $ \range -> do |
---|
190 | (checkIfRange mTime >>=) $ maybe (return Nothing) $ \() -> do |
---|
191 | case parseRanges range size of |
---|
192 | Just rs | all (\(a, b) -> a <= b) rs -> return $ Just rs |
---|
193 | Just _ -> throw BadRange |
---|
194 | Nothing -> return Nothing |
---|
195 | |
---|
196 | outputAll :: Handle -> FileOffset -> ContentType -> CGI CGIResult |
---|
197 | outputAll h size ctype = do |
---|
198 | setHeader "Content-Type" ctype |
---|
199 | setHeader "Content-Length" $ show size |
---|
200 | outputFPS =<< liftIO (B.hGetContents h) |
---|
201 | |
---|
202 | -- | Lazily read a given number of bytes from the handle into a |
---|
203 | -- 'ByteString', then close the handle. |
---|
204 | hGetClose :: Handle -> Int64 -> IO B.ByteString |
---|
205 | hGetClose h len = do |
---|
206 | contents <- B.hGetContents h |
---|
207 | end <- unsafeInterleaveIO (hClose h >> return B.empty) |
---|
208 | return (B.append (B.take len contents) end) |
---|
209 | |
---|
210 | outputRange :: Handle -> FileOffset -> ContentType -> Maybe [(FileOffset, FileOffset)] -> CGI CGIResult |
---|
211 | outputRange h size ctype Nothing = outputAll h size ctype |
---|
212 | outputRange h size ctype (Just [(a, b)]) = do |
---|
213 | let len = b - a + 1 |
---|
214 | |
---|
215 | setStatus 206 "Partial Content" |
---|
216 | setHeader "Content-Type" ctype |
---|
217 | setHeader "Content-Range" $ |
---|
218 | "bytes " ++ show a ++ "-" ++ show b ++ "/" ++ show size |
---|
219 | setHeader "Content-Length" $ show len |
---|
220 | liftIO $ hSeek h AbsoluteSeek (fromIntegral a) |
---|
221 | outputFPS =<< liftIO (hGetClose h (fromIntegral len)) |
---|
222 | outputRange h size ctype (Just rs) = do |
---|
223 | seed <- liftIO getStdGen |
---|
224 | let ints = take 16 $ unfoldr (Just . random) seed :: [Int] |
---|
225 | sep = concat $ map (flip showHex "" . (`mod` 16)) ints |
---|
226 | setStatus 206 "Partial Content" |
---|
227 | |
---|
228 | setHeader "Content-Type" $ "multipart/byteranges; boundary=" ++ sep |
---|
229 | -- Need Content-Length? RFC doesn't seem to mandate it... |
---|
230 | chunks <- liftIO $ sequence $ map readChunk rs |
---|
231 | let parts = map (uncurry $ mkPartHeader sep) (zip rs chunks) |
---|
232 | body = B.concat [ pack "\r\n" |
---|
233 | , B.concat parts |
---|
234 | , pack "--", pack sep, pack "--\r\n" |
---|
235 | ] |
---|
236 | end <- liftIO $ unsafeInterleaveIO (hClose h >> return B.empty) |
---|
237 | -- TODO figure out how to guarantee handle is ALWAYS closed, and NEVER before |
---|
238 | -- reading is finished... |
---|
239 | outputFPS (B.append body end) |
---|
240 | where readChunk :: (FileOffset, FileOffset) -> IO B.ByteString |
---|
241 | readChunk (a, b) = do |
---|
242 | hSeek h AbsoluteSeek (fromIntegral a) |
---|
243 | -- Carful here, hGetContents makes the handle unusable afterwards. |
---|
244 | -- TODO Anders says use hGetSome or some other way lazy way |
---|
245 | B.hGet h (fromIntegral $ b - a + 1) |
---|
246 | mkPartHeader :: String -> (FileOffset, FileOffset) -> B.ByteString -> B.ByteString |
---|
247 | mkPartHeader sep (a, b) chunk = B.concat [ pack "--" , pack sep |
---|
248 | , pack "\r\nContent-Type: ", pack ctype |
---|
249 | , pack "\r\nContent-Range: bytes " |
---|
250 | , pack $ show a, pack "-", pack $ show b |
---|
251 | , pack "/", pack $ show size |
---|
252 | , pack "\r\n\r\n", chunk, pack "\r\n" |
---|
253 | ] |
---|
254 | |
---|
255 | |
---|
256 | serveFile :: FilePath -> CGI CGIResult |
---|
257 | serveFile file = (`catch` outputMyError) $ do |
---|
258 | let menctype = checkExtension file |
---|
259 | when (isNothing menctype) $ throw Forbidden |
---|
260 | let (menc, ctype) = fromJust menctype |
---|
261 | when (isJust menc) $ setHeader "Content-Encoding" (fromJust menc) |
---|
262 | |
---|
263 | checkMethod $ do |
---|
264 | |
---|
265 | let handleOpenError e = |
---|
266 | if isDoesNotExistError e then throw NotFound |
---|
267 | else if isPermissionError e then throw Forbidden |
---|
268 | else throw e |
---|
269 | h <- liftIO (openBinaryFile file ReadMode) `catch` handleOpenError |
---|
270 | (`onException` liftIO (hClose h)) $ do |
---|
271 | |
---|
272 | status <- liftIO $ hGetStatus h |
---|
273 | let mTime = modificationTime status |
---|
274 | size = fileSize status |
---|
275 | checkModified mTime |
---|
276 | |
---|
277 | ranges <- checkRanges mTime size |
---|
278 | outputRange h size ctype ranges |
---|
279 | |
---|
280 | main :: IO () |
---|
281 | main = runCGI $ handleErrors $ serveFile =<< pathTranslated |
---|