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

Last change on this file since 1784 was 1784, checked in by geofft, 11 years ago
Add .ttf and .otf font file types
File size: 6.6 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         (".gif", "image/gif"),
38         (".htm", "text/html"),
39         (".html", "text/html"),
40         (".ico", "image/vnd.microsoft.icon"),
41         (".il", "application/octet-stream"),
42         (".jar", "application/java-archive"),
43         (".jpeg", "image/jpeg"),
44         (".jpg", "image/jpeg"),
45         (".js", "application/x-javascript"),
46         (".mid", "audio/midi"),
47         (".midi", "audio/midi"),
48         (".mov", "video/quicktime"),
49         (".mp3", "audio/mpeg"),
50         (".mpeg", "video/mpeg"),
51         (".mpg", "video/mpeg"),
52         (".otf", "application/octet-stream"),
53         (".pdf", "application/pdf"),
54         (".png", "image/png"),
55         (".ppt", "application/vnd.ms-powerpoint"),
56         (".ps", "application/postscript"),
57         (".svg", "image/svg+xml"),
58         (".swf", "application/x-shockwave-flash"),
59         (".tar", "application/x-tar"),
60         (".tgz", "application/x-gzip"),
61         (".tif", "image/tiff"),
62         (".tiff", "image/tiff"),
63         (".ttf", "application/octet-stream"),
64         (".wav", "audio/x-wav"),
65         (".wmv", "video/x-ms-wmv"),
66         (".xaml", "application/xaml+xml"),
67         (".xap", "application/x-silverlight-app"),
68         (".xhtml", "application/xhtml+xml"),
69         (".xls", "application/vnd.ms-excel"),
70         (".xml", "text/xml"),
71         (".xsl", "text/xml"),
72         (".zip", "application/zip")
73        ]
74
75data MyError = NotModified | Forbidden | NotFound | BadMethod | BadRange
76    deriving (Show, Typeable)
77
78instance Exception MyError
79
80outputMyError :: MyError -> CGI CGIResult
81outputMyError NotModified = setStatus 304 "Not Modified" >> outputNothing
82outputMyError Forbidden = outputError 403 "Forbidden" []
83outputMyError NotFound = outputError 404 "Not Found" []
84outputMyError BadMethod = outputError 405 "Method Not Allowed" []
85outputMyError BadRange = outputError 416 "Requested Range Not Satisfiable" []
86
87checkExtension :: FilePath -> CGI ()
88checkExtension file = do
89  let (base, ext) = splitExtension file
90  ext' <- case M.lookup (map toLower ext) encodings of
91            Nothing -> return ext
92            Just e -> do
93              setHeader "Content-Encoding" e
94              return $ takeExtension base
95
96  case M.lookup (map toLower ext') types of
97    Nothing -> throw Forbidden
98    Just t -> setHeader "Content-Type" t
99
100checkMethod :: CGI CGIResult -> CGI CGIResult
101checkMethod rOutput = do
102  m <- requestMethod
103  case m of
104    "HEAD" -> rOutput >> outputNothing
105    "GET" -> rOutput
106    "POST" -> rOutput
107    _ -> throw BadMethod
108
109httpDate :: String
110httpDate = "%a, %d %b %Y %H:%M:%S %Z"
111formatHTTPDate :: EpochTime -> String
112formatHTTPDate = formatTime defaultTimeLocale httpDate .
113                 posixSecondsToUTCTime . realToFrac
114parseHTTPDate :: String -> Maybe EpochTime
115parseHTTPDate = (fromInteger . floor . utcTimeToPOSIXSeconds <$>) .
116                parseTime defaultTimeLocale httpDate
117
118checkModified :: EpochTime -> CGI ()
119checkModified mTime = do
120  setHeader "Last-Modified" $ formatHTTPDate mTime
121  (requestHeader "If-Modified-Since" >>=) $ maybe (return ()) $ \ims ->
122      when (parseHTTPDate ims >= Just mTime) $ throw NotModified
123
124checkIfRange :: EpochTime -> CGI (Maybe ())
125checkIfRange mTime = do
126  (requestHeader "If-Range" >>=) $ maybe (return $ Just ()) $ \ir ->
127      return $ if parseHTTPDate ir == Just mTime then Just () else Nothing
128
129parseRange :: String -> FileOffset -> Maybe (FileOffset, FileOffset)
130parseRange (splitAt 6 -> ("bytes=", '-':(readDec -> [(len, "")]))) size =
131    Just (max 0 (size - len), size - 1)
132parseRange (splitAt 6 -> ("bytes=", readDec -> [(a, "-")])) size =
133    Just (a, size - 1)
134parseRange (splitAt 6 -> ("bytes=", readDec -> [(a, '-':(readDec -> [(b, "")]))])) size =
135    Just (a, min (size - 1) b)
136parseRange _ _ = Nothing
137
138checkRange :: EpochTime -> FileOffset -> CGI (Maybe (FileOffset, FileOffset))
139checkRange mTime size = do
140  setHeader "Accept-Ranges" "bytes"
141  (requestHeader "Range" >>=) $ maybe (return Nothing) $ \range -> do
142  (checkIfRange mTime >>=) $ maybe (return Nothing) $ \() -> do
143    case parseRange range size of
144      Just (a, b) | a <= b -> return $ Just (a, b)
145      Just _ -> throw BadRange
146      Nothing -> return Nothing
147
148outputAll :: Handle -> FileOffset -> CGI CGIResult
149outputAll h size = do
150  setHeader "Content-Length" $ show size
151  outputFPS =<< liftIO (B.hGetContents h)
152
153-- | Lazily read a given number of bytes from the handle into a
154-- 'ByteString', then close the handle.
155hGetClose :: Handle -> Int64 -> IO B.ByteString
156hGetClose h len = do
157  contents <- B.hGetContents h
158  end <- unsafeInterleaveIO (hClose h >> return B.empty)
159  return (B.append (B.take len contents) end)
160
161outputRange :: Handle -> FileOffset -> Maybe (FileOffset, FileOffset) -> CGI CGIResult
162outputRange h size Nothing = outputAll h size
163outputRange h size (Just (a, b)) = do
164  let len = b - a + 1
165
166  setStatus 206 "Partial Content"
167  setHeader "Content-Range" $
168   "bytes " ++ show a ++ "-" ++ show b ++ "/" ++ show size
169  setHeader "Content-Length" $ show len
170  liftIO $ hSeek h AbsoluteSeek (fromIntegral a)
171  outputFPS =<< liftIO (hGetClose h (fromIntegral len))
172
173serveFile :: FilePath -> CGI CGIResult
174serveFile file = (`catch` outputMyError) $ do
175  checkExtension file
176
177  checkMethod $ do
178
179  let handleOpenError e =
180          if isDoesNotExistError e then throw NotFound
181          else if isPermissionError e then throw Forbidden
182          else throw e
183  h <- liftIO (openBinaryFile file ReadMode) `catch` handleOpenError
184  (`onException` liftIO (hClose h)) $ do
185
186  status <- liftIO $ hGetStatus h
187  let mTime = modificationTime status
188      size = fileSize status
189  checkModified mTime
190
191  range <- checkRange mTime size
192  outputRange h size range
193
194main :: IO ()
195main = runCGI $ handleErrors $ serveFile =<< pathTranslated
Note: See TracBrowser for help on using the repository browser.