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

Last change on this file since 2795 was 2795, checked in by leee, 6 years ago
Add Webfont Extensions to the Static Whitelist [Trac: #426]
File size: 9.3 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
25encodings :: M.Map String String
26encodings = M.fromList [
27             (".bz2", "bzip2"),
28             (".gz", "gzip"),
29             (".z", "compress")
30            ]
31
32types :: M.Map String String
33types = M.fromList [
34         (".avi", "video/x-msvideo"),
35         (".css", "text/css"),
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         (".eot", "application/vnd.ms-fontobject"),
43         (".gif", "image/gif"),
44         (".htm", "text/html"),
45         (".html", "text/html"),
46         (".ico", "image/vnd.microsoft.icon"),
47         (".il", "application/octet-stream"),
48         (".jar", "application/java-archive"),
49         (".jpeg", "image/jpeg"),
50         (".jpg", "image/jpeg"),
51         (".js", "application/x-javascript"),
52         (".mid", "audio/midi"),
53         (".midi", "audio/midi"),
54         (".mov", "video/quicktime"),
55         (".mp3", "audio/mpeg"),
56         (".mpeg", "video/mpeg"),
57         (".mpg", "video/mpeg"),
58         (".odb", "application/vnd.oasis.opendocument.database"),
59         (".odc", "application/vnd.oasis.opendocument.chart"),
60         (".odf", "application/vnd.oasis.opendocument.formula"),
61         (".odg", "application/vnd.oasis.opendocument.graphics"),
62         (".odi", "application/vnd.oasis.opendocument.image"),
63         (".odm", "application/vnd.oasis.opendocument.text-master"),
64         (".odp", "application/vnd.oasis.opendocument.presentation"),
65         (".ods", "application/vnd.oasis.opendocument.spreadsheet"),
66         (".odt", "application/vnd.oasis.opendocument.text"),
67         (".otf", "application/octet-stream"),
68         (".otg", "application/vnd.oasis.opendocument.graphics-template"),
69         (".oth", "application/vnd.oasis.opendocument.text-web"),
70         (".otp", "application/vnd.oasis.opendocument.presentation-template"),
71         (".ots", "application/vnd.oasis.opendocument.spreadsheet-template"),
72         (".ott", "application/vnd.oasis.opendocument.text-template"),
73         (".pdf", "application/pdf"),
74         (".png", "image/png"),
75         (".pot", "application/vnd.ms-powerpoint"),
76         (".potm", "application/vnd.ms-powerpoint.template.macroEnabled.12"),
77         (".potx", "application/vnd.openxmlformats-officedocument.presentationml.template"),
78         (".ppa", "application/vnd.ms-powerpoint"),
79         (".ppam", "application/vnd.ms-powerpoint.addin.macroEnabled.12"),
80         (".pps", "application/vnd.ms-powerpoint"),
81         (".ppsm", "application/vnd.ms-powerpoint.slideshow.macroEnabled.12"),
82         (".ppsx", "application/vnd.openxmlformats-officedocument.presentationml.slideshow"),
83         (".ppt", "application/vnd.ms-powerpoint"),
84         (".pptm", "application/vnd.ms-powerpoint.presentation.macroEnabled.12"),
85         (".pptx", "application/vnd.openxmlformats-officedocument.presentationml.presentation"),
86         (".ps", "application/postscript"),
87         (".svg", "image/svg+xml"),
88         (".swf", "application/x-shockwave-flash"),
89         (".tar", "application/x-tar"),
90         (".tgz", "application/x-gzip"),
91         (".tif", "image/tiff"),
92         (".tiff", "image/tiff"),
93         (".ttf", "application/octet-stream"),
94         (".wav", "audio/x-wav"),
95         (".wmv", "video/x-ms-wmv"),
96         (".woff", "application/font-woff"),
97         (".woff2", "font/woff2"),
98         (".xaml", "application/xaml+xml"),
99         (".xap", "application/x-silverlight-app"),
100         (".xhtml", "application/xhtml+xml"),
101         (".xla", "application/vnd.ms-excel"),
102         (".xlam", "application/vnd.ms-excel.addin.macroEnabled.12"),
103         (".xls", "application/vnd.ms-excel"),
104         (".xlsb", "application/vnd.ms-excel.sheet.binary.macroEnabled.12"),
105         (".xlsm", "application/vnd.ms-excel.sheet.macroEnabled.12"),
106         (".xlsx", "application/vnd.openxmlformats-officedocument.spreadsheetml.sheet"),
107         (".xlt", "application/vnd.ms-excel"),
108         (".xltm", "application/vnd.ms-excel.template.macroEnabled.12"),
109         (".xltx", "application/vnd.openxmlformats-officedocument.spreadsheetml.template"),
110         (".xml", "text/xml"),
111         (".xsl", "text/xml"),
112         (".zip", "application/zip")
113        ]
114
115data MyError = NotModified | Forbidden | NotFound | BadMethod | BadRange
116    deriving (Show, Typeable)
117
118instance Exception MyError
119
120outputMyError :: MyError -> CGI CGIResult
121outputMyError NotModified = setStatus 304 "Not Modified" >> outputNothing
122outputMyError Forbidden = outputError 403 "Forbidden" []
123outputMyError NotFound = outputError 404 "Not Found" []
124outputMyError BadMethod = outputError 405 "Method Not Allowed" []
125outputMyError BadRange = outputError 416 "Requested Range Not Satisfiable" []
126
127checkExtension :: FilePath -> CGI ()
128checkExtension file = do
129  let (base, ext) = splitExtension file
130  ext' <- case M.lookup (map toLower ext) encodings of
131            Nothing -> return ext
132            Just e -> do
133              setHeader "Content-Encoding" e
134              return $ takeExtension base
135
136  case M.lookup (map toLower ext') types of
137    Nothing -> throw Forbidden
138    Just t -> setHeader "Content-Type" t
139
140checkMethod :: CGI CGIResult -> CGI CGIResult
141checkMethod rOutput = do
142  m <- requestMethod
143  case m of
144    "HEAD" -> rOutput >> outputNothing
145    "GET" -> rOutput
146    "POST" -> rOutput
147    _ -> throw BadMethod
148
149httpDate :: String
150httpDate = "%a, %d %b %Y %H:%M:%S %Z"
151formatHTTPDate :: EpochTime -> String
152formatHTTPDate = formatTime defaultTimeLocale httpDate .
153                 posixSecondsToUTCTime . realToFrac
154parseHTTPDate :: String -> Maybe EpochTime
155parseHTTPDate = (fromInteger . floor . utcTimeToPOSIXSeconds <$>) .
156                parseTime defaultTimeLocale httpDate
157
158checkModified :: EpochTime -> CGI ()
159checkModified mTime = do
160  setHeader "Last-Modified" $ formatHTTPDate mTime
161  (requestHeader "If-Modified-Since" >>=) $ maybe (return ()) $ \ims ->
162      when (parseHTTPDate ims >= Just mTime) $ throw NotModified
163
164checkIfRange :: EpochTime -> CGI (Maybe ())
165checkIfRange mTime = do
166  (requestHeader "If-Range" >>=) $ maybe (return $ Just ()) $ \ir ->
167      return $ if parseHTTPDate ir == Just mTime then Just () else Nothing
168
169parseRange :: String -> FileOffset -> Maybe (FileOffset, FileOffset)
170parseRange (splitAt 6 -> ("bytes=", '-':(readDec -> [(len, "")]))) size =
171    Just (max 0 (size - len), size - 1)
172parseRange (splitAt 6 -> ("bytes=", readDec -> [(a, "-")])) size =
173    Just (a, size - 1)
174parseRange (splitAt 6 -> ("bytes=", readDec -> [(a, '-':(readDec -> [(b, "")]))])) size =
175    Just (a, min (size - 1) b)
176parseRange _ _ = Nothing
177
178checkRange :: EpochTime -> FileOffset -> CGI (Maybe (FileOffset, FileOffset))
179checkRange mTime size = do
180  setHeader "Accept-Ranges" "bytes"
181  (requestHeader "Range" >>=) $ maybe (return Nothing) $ \range -> do
182  (checkIfRange mTime >>=) $ maybe (return Nothing) $ \() -> do
183    case parseRange range size of
184      Just (a, b) | a <= b -> return $ Just (a, b)
185      Just _ -> throw BadRange
186      Nothing -> return Nothing
187
188outputAll :: Handle -> FileOffset -> CGI CGIResult
189outputAll h size = do
190  setHeader "Content-Length" $ show size
191  outputFPS =<< liftIO (B.hGetContents h)
192
193-- | Lazily read a given number of bytes from the handle into a
194-- 'ByteString', then close the handle.
195hGetClose :: Handle -> Int64 -> IO B.ByteString
196hGetClose h len = do
197  contents <- B.hGetContents h
198  end <- unsafeInterleaveIO (hClose h >> return B.empty)
199  return (B.append (B.take len contents) end)
200
201outputRange :: Handle -> FileOffset -> Maybe (FileOffset, FileOffset) -> CGI CGIResult
202outputRange h size Nothing = outputAll h size
203outputRange h size (Just (a, b)) = do
204  let len = b - a + 1
205
206  setStatus 206 "Partial Content"
207  setHeader "Content-Range" $
208   "bytes " ++ show a ++ "-" ++ show b ++ "/" ++ show size
209  setHeader "Content-Length" $ show len
210  liftIO $ hSeek h AbsoluteSeek (fromIntegral a)
211  outputFPS =<< liftIO (hGetClose h (fromIntegral len))
212
213serveFile :: FilePath -> CGI CGIResult
214serveFile file = (`catch` outputMyError) $ do
215  checkExtension file
216
217  checkMethod $ do
218
219  let handleOpenError e =
220          if isDoesNotExistError e then throw NotFound
221          else if isPermissionError e then throw Forbidden
222          else throw e
223  h <- liftIO (openBinaryFile file ReadMode) `catch` handleOpenError
224  (`onException` liftIO (hClose h)) $ do
225
226  status <- liftIO $ hGetStatus h
227  let mTime = modificationTime status
228      size = fileSize status
229  checkModified mTime
230
231  range <- checkRange mTime size
232  outputRange h size range
233
234main :: IO ()
235main = runCGI $ handleErrors $ serveFile =<< pathTranslated
Note: See TracBrowser for help on using the repository browser.