1 {-# LANGUAGE DeriveDataTypeable, ViewPatterns #-}
2 {-# OPTIONS_GHC -O2 -Wall #-}
4 import Control.Applicative
5 import Control.Exception
7 import qualified Data.ByteString.Lazy as B
9 import qualified Data.Map as M
10 import Data.Time.Clock.POSIX
11 import Data.Time.Format
14 import System.FilePath
16 import System.IO.Error
19 import System.Posix.Handle
21 encodings :: M.Map String String
22 encodings = M.fromList [
27 types :: M.Map String String
29 (".html", "text/html")
32 throwExceptionCGI :: Exception e => e -> CGI a
33 throwExceptionCGI = throwCGI . toException
35 catchExceptionCGI :: Exception e => CGI a -> (e -> CGI a) -> CGI a
36 a `catchExceptionCGI` handler =
37 a `catchCGI` \e -> case fromException e of
41 data MyError = NotModified | Forbidden | NotFound | BadMethod | BadRange
42 deriving (Show, Typeable)
44 instance Exception MyError
46 outputMyError :: MyError -> CGI CGIResult
47 outputMyError NotModified = setStatus 304 "Not Modified" >> outputNothing
48 outputMyError Forbidden = outputError 403 "Forbidden" []
49 outputMyError NotFound = outputError 404 "Not Found" []
50 outputMyError BadMethod = outputError 405 "Method Not Allowed" []
51 outputMyError BadRange = outputError 416 "Requested Range Not Satisfiable" []
53 checkExtension :: FilePath -> CGI ()
54 checkExtension file = do
55 let (base, ext) = splitExtension file
56 ext' <- case M.lookup ext encodings of
59 setHeader "Content-Encoding" e
60 return $ takeExtension base
62 case M.lookup ext' types of
63 Nothing -> throwExceptionCGI Forbidden
64 Just t -> setHeader "Content-Type" t
66 checkMethod :: CGI CGIResult -> CGI CGIResult
67 checkMethod rOutput = do
70 "HEAD" -> rOutput >> outputNothing
73 _ -> throwExceptionCGI BadMethod
76 httpDate = "%a, %d %b %Y %H:%M:%S %Z"
77 formatHTTPDate :: EpochTime -> String
78 formatHTTPDate = formatTime defaultTimeLocale httpDate .
79 posixSecondsToUTCTime . realToFrac
80 parseHTTPDate :: String -> Maybe EpochTime
81 parseHTTPDate = (fromInteger . floor . utcTimeToPOSIXSeconds <$>) .
82 parseTime defaultTimeLocale httpDate
84 checkModified :: EpochTime -> CGI ()
85 checkModified mTime = do
86 setHeader "Last-Modified" $ formatHTTPDate mTime
87 (requestHeader "If-Modified-Since" >>=) $ maybe (return ()) $ \ims ->
88 when (parseHTTPDate ims >= Just mTime) $ throwExceptionCGI NotModified
90 checkIfRange :: EpochTime -> CGI (Maybe ())
91 checkIfRange mTime = do
92 (requestHeader "If-Range" >>=) $ maybe (return $ Just ()) $ \ir ->
93 return $ if parseHTTPDate ir == Just mTime then Just () else Nothing
95 parseRange :: String -> FileOffset -> Maybe (FileOffset, FileOffset)
96 parseRange (splitAt 6 -> ("bytes=", readDec -> [(a, "-")])) size =
98 parseRange (splitAt 6 -> ("bytes=", readDec -> [(a, '-':(readDec -> [(b, "")]))])) _ =
100 parseRange _ _ = Nothing
102 checkRange :: EpochTime -> FileOffset -> CGI (Maybe (FileOffset, FileOffset))
103 checkRange mTime size = do
104 setHeader "Accept-Ranges" "bytes"
105 (requestHeader "Range" >>=) $ maybe (return Nothing) $ \range -> do
106 (checkIfRange mTime >>=) $ maybe (return Nothing) $ \() -> do
107 case parseRange range size of
108 Just (a, b) | a <= b -> return $ Just (a, b)
109 _ -> throwExceptionCGI BadRange
111 outputAll :: Handle -> FileOffset -> CGI CGIResult
112 outputAll h size = do
113 setHeader "Content-Length" $ show size
114 outputFPS =<< liftIO (B.hGetContents h)
116 outputRange :: Handle -> FileOffset -> Maybe (FileOffset, FileOffset) -> CGI CGIResult
117 outputRange h size Nothing = outputAll h size
118 outputRange h size (Just (a, b)) = do
121 setStatus 206 "Partial Content"
122 setHeader "Content-Range" $
123 "bytes " ++ show a ++ "-" ++ show b ++ "/" ++ show size
124 setHeader "Content-Length" $ show len
125 liftIO $ hSeek h AbsoluteSeek (fromIntegral a)
126 outputFPS =<< liftIO (B.hGet h (fromIntegral len))
128 serveFile :: FilePath -> CGI CGIResult
129 serveFile file = (`catchExceptionCGI` outputMyError) $ do
134 h <- (`catchExceptionCGI` \e ->
135 if isDoesNotExistError e then throwExceptionCGI NotFound
136 else if isPermissionError e then throwExceptionCGI Forbidden
137 else throwExceptionCGI e) $
138 liftIO $ openBinaryFile file ReadMode
140 (liftIO $ hClose h) >> throwCGI e) $ do
142 status <- liftIO $ hGetStatus h
143 let mTime = modificationTime status
144 size = fileSize status
147 range <- checkRange mTime size
148 outputRange h size range
151 main = runCGI $ handleErrors $ serveFile =<< pathTranslated