1 {-# LANGUAGE DeriveDataTypeable, ViewPatterns #-}
2 {-# OPTIONS_GHC -O2 -Wall #-}
4 import Prelude hiding (catch)
5 import Control.Applicative
7 import Control.Monad.CatchIO
8 import qualified Data.ByteString.Lazy as B
12 import qualified Data.Map as M
13 import Data.Time.Clock.POSIX
14 import Data.Time.Format
17 import System.FilePath
19 import System.IO.Error (isDoesNotExistError, isPermissionError)
20 import System.IO.Unsafe
23 import System.Posix.Handle
25 encodings :: M.Map String String
26 encodings = M.fromList [
32 types :: M.Map String String
34 (".avi", "video/x-msvideo"),
36 (".doc", "application/msword"),
37 (".docm", "application/vnd.ms-word.document.macroEnabled.12"),
38 (".docx", "application/vnd.openxmlformats-officedocument.wordprocessingml.document"),
39 (".dot", "application/msword"),
40 (".dotm", "application/vnd.ms-word.template.macroEnabled.12"),
41 (".dotx", "application/vnd.openxmlformats-officedocument.wordprocessingml.template"),
42 (".gif", "image/gif"),
43 (".htm", "text/html"),
44 (".html", "text/html"),
45 (".ico", "image/vnd.microsoft.icon"),
46 (".il", "application/octet-stream"),
47 (".jar", "application/java-archive"),
48 (".jpeg", "image/jpeg"),
49 (".jpg", "image/jpeg"),
50 (".js", "application/x-javascript"),
51 (".mid", "audio/midi"),
52 (".midi", "audio/midi"),
53 (".mov", "video/quicktime"),
54 (".mp3", "audio/mpeg"),
55 (".mpeg", "video/mpeg"),
56 (".mpg", "video/mpeg"),
57 (".odb", "application/vnd.oasis.opendocument.database"),
58 (".odc", "application/vnd.oasis.opendocument.chart"),
59 (".odf", "application/vnd.oasis.opendocument.formula"),
60 (".odg", "application/vnd.oasis.opendocument.graphics"),
61 (".odi", "application/vnd.oasis.opendocument.image"),
62 (".odm", "application/vnd.oasis.opendocument.text-master"),
63 (".odp", "application/vnd.oasis.opendocument.presentation"),
64 (".ods", "application/vnd.oasis.opendocument.spreadsheet"),
65 (".odt", "application/vnd.oasis.opendocument.text"),
66 (".otf", "application/octet-stream"),
67 (".otg", "application/vnd.oasis.opendocument.graphics-template"),
68 (".oth", "application/vnd.oasis.opendocument.text-web"),
69 (".otp", "application/vnd.oasis.opendocument.presentation-template"),
70 (".ots", "application/vnd.oasis.opendocument.spreadsheet-template"),
71 (".ott", "application/vnd.oasis.opendocument.text-template"),
72 (".pdf", "application/pdf"),
73 (".png", "image/png"),
74 (".pot", "application/vnd.ms-powerpoint"),
75 (".potm", "application/vnd.ms-powerpoint.template.macroEnabled.12"),
76 (".potx", "application/vnd.openxmlformats-officedocument.presentationml.template"),
77 (".ppa", "application/vnd.ms-powerpoint"),
78 (".ppam", "application/vnd.ms-powerpoint.addin.macroEnabled.12"),
79 (".pps", "application/vnd.ms-powerpoint"),
80 (".ppsm", "application/vnd.ms-powerpoint.slideshow.macroEnabled.12"),
81 (".ppsx", "application/vnd.openxmlformats-officedocument.presentationml.slideshow"),
82 (".ppt", "application/vnd.ms-powerpoint"),
83 (".pptm", "application/vnd.ms-powerpoint.presentation.macroEnabled.12"),
84 (".pptx", "application/vnd.openxmlformats-officedocument.presentationml.presentation"),
85 (".ps", "application/postscript"),
86 (".svg", "image/svg+xml"),
87 (".swf", "application/x-shockwave-flash"),
88 (".tar", "application/x-tar"),
89 (".tgz", "application/x-gzip"),
90 (".tif", "image/tiff"),
91 (".tiff", "image/tiff"),
92 (".ttf", "application/octet-stream"),
93 (".wav", "audio/x-wav"),
94 (".wmv", "video/x-ms-wmv"),
95 (".xaml", "application/xaml+xml"),
96 (".xap", "application/x-silverlight-app"),
97 (".xhtml", "application/xhtml+xml"),
98 (".xla", "application/vnd.ms-excel"),
99 (".xlam", "application/vnd.ms-excel.addin.macroEnabled.12"),
100 (".xls", "application/vnd.ms-excel"),
101 (".xlsb", "application/vnd.ms-excel.sheet.binary.macroEnabled.12"),
102 (".xlsm", "application/vnd.ms-excel.sheet.macroEnabled.12"),
103 (".xlsx", "application/vnd.openxmlformats-officedocument.spreadsheetml.sheet"),
104 (".xlt", "application/vnd.ms-excel"),
105 (".xltm", "application/vnd.ms-excel.template.macroEnabled.12"),
106 (".xltx", "application/vnd.openxmlformats-officedocument.spreadsheetml.template"),
107 (".xml", "text/xml"),
108 (".xsl", "text/xml"),
109 (".zip", "application/zip")
112 data MyError = NotModified | Forbidden | NotFound | BadMethod | BadRange
113 deriving (Show, Typeable)
115 instance Exception MyError
117 outputMyError :: MyError -> CGI CGIResult
118 outputMyError NotModified = setStatus 304 "Not Modified" >> outputNothing
119 outputMyError Forbidden = outputError 403 "Forbidden" []
120 outputMyError NotFound = outputError 404 "Not Found" []
121 outputMyError BadMethod = outputError 405 "Method Not Allowed" []
122 outputMyError BadRange = outputError 416 "Requested Range Not Satisfiable" []
124 checkExtension :: FilePath -> CGI ()
125 checkExtension file = do
126 let (base, ext) = splitExtension file
127 ext' <- case M.lookup (map toLower ext) encodings of
128 Nothing -> return ext
130 setHeader "Content-Encoding" e
131 return $ takeExtension base
133 case M.lookup (map toLower ext') types of
134 Nothing -> throw Forbidden
135 Just t -> setHeader "Content-Type" t
137 checkMethod :: CGI CGIResult -> CGI CGIResult
138 checkMethod rOutput = do
141 "HEAD" -> rOutput >> outputNothing
147 httpDate = "%a, %d %b %Y %H:%M:%S %Z"
148 formatHTTPDate :: EpochTime -> String
149 formatHTTPDate = formatTime defaultTimeLocale httpDate .
150 posixSecondsToUTCTime . realToFrac
151 parseHTTPDate :: String -> Maybe EpochTime
152 parseHTTPDate = (fromInteger . floor . utcTimeToPOSIXSeconds <$>) .
153 parseTime defaultTimeLocale httpDate
155 checkModified :: EpochTime -> CGI ()
156 checkModified mTime = do
157 setHeader "Last-Modified" $ formatHTTPDate mTime
158 (requestHeader "If-Modified-Since" >>=) $ maybe (return ()) $ \ims ->
159 when (parseHTTPDate ims >= Just mTime) $ throw NotModified
161 checkIfRange :: EpochTime -> CGI (Maybe ())
162 checkIfRange mTime = do
163 (requestHeader "If-Range" >>=) $ maybe (return $ Just ()) $ \ir ->
164 return $ if parseHTTPDate ir == Just mTime then Just () else Nothing
166 parseRange :: String -> FileOffset -> Maybe (FileOffset, FileOffset)
167 parseRange (splitAt 6 -> ("bytes=", '-':(readDec -> [(len, "")]))) size =
168 Just (max 0 (size - len), size - 1)
169 parseRange (splitAt 6 -> ("bytes=", readDec -> [(a, "-")])) size =
171 parseRange (splitAt 6 -> ("bytes=", readDec -> [(a, '-':(readDec -> [(b, "")]))])) size =
172 Just (a, min (size - 1) b)
173 parseRange _ _ = Nothing
175 checkRange :: EpochTime -> FileOffset -> CGI (Maybe (FileOffset, FileOffset))
176 checkRange mTime size = do
177 setHeader "Accept-Ranges" "bytes"
178 (requestHeader "Range" >>=) $ maybe (return Nothing) $ \range -> do
179 (checkIfRange mTime >>=) $ maybe (return Nothing) $ \() -> do
180 case parseRange range size of
181 Just (a, b) | a <= b -> return $ Just (a, b)
182 Just _ -> throw BadRange
183 Nothing -> return Nothing
185 outputAll :: Handle -> FileOffset -> CGI CGIResult
186 outputAll h size = do
187 setHeader "Content-Length" $ show size
188 outputFPS =<< liftIO (B.hGetContents h)
190 -- | Lazily read a given number of bytes from the handle into a
191 -- 'ByteString', then close the handle.
192 hGetClose :: Handle -> Int64 -> IO B.ByteString
194 contents <- B.hGetContents h
195 end <- unsafeInterleaveIO (hClose h >> return B.empty)
196 return (B.append (B.take len contents) end)
198 outputRange :: Handle -> FileOffset -> Maybe (FileOffset, FileOffset) -> CGI CGIResult
199 outputRange h size Nothing = outputAll h size
200 outputRange h size (Just (a, b)) = do
203 setStatus 206 "Partial Content"
204 setHeader "Content-Range" $
205 "bytes " ++ show a ++ "-" ++ show b ++ "/" ++ show size
206 setHeader "Content-Length" $ show len
207 liftIO $ hSeek h AbsoluteSeek (fromIntegral a)
208 outputFPS =<< liftIO (hGetClose h (fromIntegral len))
210 serveFile :: FilePath -> CGI CGIResult
211 serveFile file = (`catch` outputMyError) $ do
216 let handleOpenError e =
217 if isDoesNotExistError e then throw NotFound
218 else if isPermissionError e then throw Forbidden
220 h <- liftIO (openBinaryFile file ReadMode) `catch` handleOpenError
221 (`onException` liftIO (hClose h)) $ do
223 status <- liftIO $ hGetStatus h
224 let mTime = modificationTime status
225 size = fileSize status
228 range <- checkRange mTime size
229 outputRange h size range
232 main = runCGI $ handleErrors $ serveFile =<< pathTranslated