source: trunk/server/common/oursrc/scripts-static-cat/StaticCat.hs

Last change on this file was 2837, checked in by andersk, 5 years ago
Improve Content-Type and Content-Encoding headers Since Chrome has started decompressing tarballs served with Content-Encoding: x-gzip on download, we don’t want to be sending that by default. Remove all the custom AddType and AddEncoding directives from httpd.conf (let it pick up MIME types from /etc/mime.types). Do not set Content-Encoding in static-cat, and fix some of the hard-coded MIME types there.
File size: 8.9 KB
Line 
1{-# LANGUAGE DeriveDataTypeable, ViewPatterns #-}
2{-# OPTIONS_GHC -O2 -Wall #-}
3
4import Prelude hiding (catch)
5import Control.Applicative
6import Control.Monad
7import Control.Monad.CatchIO
8import qualified Data.ByteString.Lazy as B
9import Data.Char
10import Data.Dynamic
11import Data.Int
12import qualified Data.Map as M
13import Data.Time.Clock.POSIX
14import Data.Time.Format
15import Network.CGI
16import Numeric
17import System.FilePath
18import System.IO
19import System.IO.Error (isDoesNotExistError, isPermissionError)
20import System.IO.Unsafe
21import System.Locale
22import System.Posix
23import System.Posix.Handle
24
25types :: M.Map String String
26types = M.fromList [
27         (".avi", "video/x-msvideo"),
28         (".css", "text/css"),
29         (".doc", "application/msword"),
30         (".docm", "application/vnd.ms-word.document.macroEnabled.12"),
31         (".docx", "application/vnd.openxmlformats-officedocument.wordprocessingml.document"),
32         (".dot", "application/msword"),
33         (".dotm", "application/vnd.ms-word.template.macroEnabled.12"),
34         (".dotx", "application/vnd.openxmlformats-officedocument.wordprocessingml.template"),
35         (".eot", "application/vnd.ms-fontobject"),
36         (".gif", "image/gif"),
37         (".htm", "text/html"),
38         (".html", "text/html"),
39         (".ico", "image/vnd.microsoft.icon"),
40         (".il", "application/octet-stream"),
41         (".jar", "application/java-archive"),
42         (".jpeg", "image/jpeg"),
43         (".jpg", "image/jpeg"),
44         (".js", "application/javascript"),
45         (".mid", "audio/midi"),
46         (".midi", "audio/midi"),
47         (".mov", "video/quicktime"),
48         (".mp3", "audio/mpeg"),
49         (".mpeg", "video/mpeg"),
50         (".mpg", "video/mpeg"),
51         (".odb", "application/vnd.oasis.opendocument.database"),
52         (".odc", "application/vnd.oasis.opendocument.chart"),
53         (".odf", "application/vnd.oasis.opendocument.formula"),
54         (".odg", "application/vnd.oasis.opendocument.graphics"),
55         (".odi", "application/vnd.oasis.opendocument.image"),
56         (".odm", "application/vnd.oasis.opendocument.text-master"),
57         (".odp", "application/vnd.oasis.opendocument.presentation"),
58         (".ods", "application/vnd.oasis.opendocument.spreadsheet"),
59         (".odt", "application/vnd.oasis.opendocument.text"),
60         (".otf", "application/font-sfnt"),
61         (".otg", "application/vnd.oasis.opendocument.graphics-template"),
62         (".oth", "application/vnd.oasis.opendocument.text-web"),
63         (".otp", "application/vnd.oasis.opendocument.presentation-template"),
64         (".ots", "application/vnd.oasis.opendocument.spreadsheet-template"),
65         (".ott", "application/vnd.oasis.opendocument.text-template"),
66         (".pdf", "application/pdf"),
67         (".png", "image/png"),
68         (".pot", "application/vnd.ms-powerpoint"),
69         (".potm", "application/vnd.ms-powerpoint.template.macroEnabled.12"),
70         (".potx", "application/vnd.openxmlformats-officedocument.presentationml.template"),
71         (".ppa", "application/vnd.ms-powerpoint"),
72         (".ppam", "application/vnd.ms-powerpoint.addin.macroEnabled.12"),
73         (".pps", "application/vnd.ms-powerpoint"),
74         (".ppsm", "application/vnd.ms-powerpoint.slideshow.macroEnabled.12"),
75         (".ppsx", "application/vnd.openxmlformats-officedocument.presentationml.slideshow"),
76         (".ppt", "application/vnd.ms-powerpoint"),
77         (".pptm", "application/vnd.ms-powerpoint.presentation.macroEnabled.12"),
78         (".pptx", "application/vnd.openxmlformats-officedocument.presentationml.presentation"),
79         (".ps", "application/postscript"),
80         (".svg", "image/svg+xml"),
81         (".swf", "application/x-shockwave-flash"),
82         (".tar", "application/x-tar"),
83         (".tgz", "application/gzip"),
84         (".tif", "image/tiff"),
85         (".tiff", "image/tiff"),
86         (".ttf", "application/font-sfnt"),
87         (".wav", "audio/x-wav"),
88         (".wmv", "video/x-ms-wmv"),
89         (".woff", "application/font-woff"),
90         (".woff2", "font/woff2"),
91         (".xaml", "application/xaml+xml"),
92         (".xap", "application/x-silverlight-app"),
93         (".xhtml", "application/xhtml+xml"),
94         (".xla", "application/vnd.ms-excel"),
95         (".xlam", "application/vnd.ms-excel.addin.macroEnabled.12"),
96         (".xls", "application/vnd.ms-excel"),
97         (".xlsb", "application/vnd.ms-excel.sheet.binary.macroEnabled.12"),
98         (".xlsm", "application/vnd.ms-excel.sheet.macroEnabled.12"),
99         (".xlsx", "application/vnd.openxmlformats-officedocument.spreadsheetml.sheet"),
100         (".xlt", "application/vnd.ms-excel"),
101         (".xltm", "application/vnd.ms-excel.template.macroEnabled.12"),
102         (".xltx", "application/vnd.openxmlformats-officedocument.spreadsheetml.template"),
103         (".xml", "text/xml"),
104         (".xsl", "application/xslt+xml"),
105         (".zip", "application/zip")
106        ]
107
108data MyError = NotModified | Forbidden | NotFound | BadMethod | BadRange
109    deriving (Show, Typeable)
110
111instance Exception MyError
112
113outputMyError :: MyError -> CGI CGIResult
114outputMyError NotModified = setStatus 304 "Not Modified" >> outputNothing
115outputMyError Forbidden = outputError 403 "Forbidden" []
116outputMyError NotFound = outputError 404 "Not Found" []
117outputMyError BadMethod = outputError 405 "Method Not Allowed" []
118outputMyError BadRange = outputError 416 "Requested Range Not Satisfiable" []
119
120checkExtension :: FilePath -> CGI ()
121checkExtension file =
122  case M.lookup (map toLower (takeExtension file)) types of
123    Nothing -> throw Forbidden
124    Just t -> setHeader "Content-Type" t
125
126checkMethod :: CGI CGIResult -> CGI CGIResult
127checkMethod rOutput = do
128  m <- requestMethod
129  case m of
130    "HEAD" -> rOutput >> outputNothing
131    "GET" -> rOutput
132    "POST" -> rOutput
133    _ -> throw BadMethod
134
135httpDate :: String
136httpDate = "%a, %d %b %Y %H:%M:%S %Z"
137formatHTTPDate :: EpochTime -> String
138formatHTTPDate = formatTime defaultTimeLocale httpDate .
139                 posixSecondsToUTCTime . realToFrac
140parseHTTPDate :: String -> Maybe EpochTime
141parseHTTPDate = (fromInteger . floor . utcTimeToPOSIXSeconds <$>) .
142                parseTime defaultTimeLocale httpDate
143
144checkModified :: EpochTime -> CGI ()
145checkModified mTime = do
146  setHeader "Last-Modified" $ formatHTTPDate mTime
147  (requestHeader "If-Modified-Since" >>=) $ maybe (return ()) $ \ims ->
148      when (parseHTTPDate ims >= Just mTime) $ throw NotModified
149
150checkIfRange :: EpochTime -> CGI (Maybe ())
151checkIfRange mTime = do
152  (requestHeader "If-Range" >>=) $ maybe (return $ Just ()) $ \ir ->
153      return $ if parseHTTPDate ir == Just mTime then Just () else Nothing
154
155parseRange :: String -> FileOffset -> Maybe (FileOffset, FileOffset)
156parseRange (splitAt 6 -> ("bytes=", '-':(readDec -> [(len, "")]))) size =
157    Just (max 0 (size - len), size - 1)
158parseRange (splitAt 6 -> ("bytes=", readDec -> [(a, "-")])) size =
159    Just (a, size - 1)
160parseRange (splitAt 6 -> ("bytes=", readDec -> [(a, '-':(readDec -> [(b, "")]))])) size =
161    Just (a, min (size - 1) b)
162parseRange _ _ = Nothing
163
164checkRange :: EpochTime -> FileOffset -> CGI (Maybe (FileOffset, FileOffset))
165checkRange mTime size = do
166  setHeader "Accept-Ranges" "bytes"
167  (requestHeader "Range" >>=) $ maybe (return Nothing) $ \range -> do
168  (checkIfRange mTime >>=) $ maybe (return Nothing) $ \() -> do
169    case parseRange range size of
170      Just (a, b) | a <= b -> return $ Just (a, b)
171      Just _ -> throw BadRange
172      Nothing -> return Nothing
173
174outputAll :: Handle -> FileOffset -> CGI CGIResult
175outputAll h size = do
176  setHeader "Content-Length" $ show size
177  outputFPS =<< liftIO (B.hGetContents h)
178
179-- | Lazily read a given number of bytes from the handle into a
180-- 'ByteString', then close the handle.
181hGetClose :: Handle -> Int64 -> IO B.ByteString
182hGetClose h len = do
183  contents <- B.hGetContents h
184  end <- unsafeInterleaveIO (hClose h >> return B.empty)
185  return (B.append (B.take len contents) end)
186
187outputRange :: Handle -> FileOffset -> Maybe (FileOffset, FileOffset) -> CGI CGIResult
188outputRange h size Nothing = outputAll h size
189outputRange h size (Just (a, b)) = do
190  let len = b - a + 1
191
192  setStatus 206 "Partial Content"
193  setHeader "Content-Range" $
194   "bytes " ++ show a ++ "-" ++ show b ++ "/" ++ show size
195  setHeader "Content-Length" $ show len
196  liftIO $ hSeek h AbsoluteSeek (fromIntegral a)
197  outputFPS =<< liftIO (hGetClose h (fromIntegral len))
198
199serveFile :: FilePath -> CGI CGIResult
200serveFile file = (`catch` outputMyError) $ do
201  checkExtension file
202
203  checkMethod $ do
204
205  let handleOpenError e =
206          if isDoesNotExistError e then throw NotFound
207          else if isPermissionError e then throw Forbidden
208          else throw e
209  h <- liftIO (openBinaryFile file ReadMode) `catch` handleOpenError
210  (`onException` liftIO (hClose h)) $ do
211
212  status <- liftIO $ hGetStatus h
213  let mTime = modificationTime status
214      size = fileSize status
215  checkModified mTime
216
217  range <- checkRange mTime size
218  outputRange h size range
219
220main :: IO ()
221main = runCGI $ handleErrors $ serveFile =<< pathTranslated
Note: See TracBrowser for help on using the repository browser.