{-# LANGUAGE TypeSynonymInstances, DeriveDataTypeable #-} module Network.FastCGI ( -- * The monad FastCGI, FastCGIState, MonadFastCGI, getFastCGIState, implementationThrowFastCGI, implementationCatchFastCGI, implementationBlockFastCGI, implementationUnblockFastCGI, -- * Accepting requests acceptLoop, -- * Logging fLog, -- * Request information -- | It is common practice for web servers to make their own extensions to -- the CGI/1.1 set of defined variables. For example, @REMOTE_PORT@ is -- not defined by the specification, but often seen in the wild. -- Furthermore, it is also common for user agents to make their own -- extensions to the HTTP/1.1 set of defined headers. Therefore, there -- are two levels of call available. Defined variables and headers may -- be interrogated directly, and in addition, there are higher-level -- calls which give convenient names and types to the same information. -- -- Cookies may also be manipulated through HTTP headers directly; the -- functions here are provided only as a convenience. getRequestVariable, getAllRequestVariables, Header(..), getRequestHeader, getAllRequestHeaders, Cookie(..), getCookie, getAllCookies, getCookieValue, getDocumentRoot, getGatewayInterface, getPathInfo, getPathTranslated, getQueryString, getRedirectStatus, getRedirectURI, getRemoteAddress, getRemotePort, getRemoteHost, getRemoteIdent, getRemoteUser, getRequestMethod, getRequestURI, getScriptFilename, getScriptName, getServerAddress, getServerName, getServerPort, getServerProtocol, getServerSoftware, getAuthenticationType, getContentLength, getContentType, -- * Request content data -- | At the moment the handler is invoked, all request headers have been -- received, but content data has not necessarily been. Requests to read -- content data block the handler (but not other concurrent handlers) -- until there is enough data in the buffer to satisfy them, or until -- timeout where applicable. fGet, fGetNonBlocking, fGetContents, fIsReadable, -- * Response information and content data -- | When the handler is first invoked, neither response headers nor -- content data have been sent to the client. Setting of response -- headers is lazy, merely setting internal variables, until something -- forces them to be output. For example, attempting to send content -- data will force response headers to be output first. It is not -- necessary to close the output stream explicitly, but it may be -- desirable, for example to continue processing after returning results -- to the user. -- -- There is no reason that client scripts cannot use any encoding they -- wish, including the chunked encoding, if they have set appropriate -- headers. This package, however, does not explicitly support that, -- because client scripts can easily implement it for themselves. -- -- At the start of each request, the response status is set to @200 OK@ -- and the only response header set is @Content-Type: text/html@. These -- may be overridden by later calls, at any time before headers have -- been sent. -- -- Cookies may also be manipulated through HTTP headers directly; the -- functions here are provided only as a convenience. setResponseStatus, getResponseStatus, setResponseHeader, unsetResponseHeader, getResponseHeader, setCookie, unsetCookie, mkSimpleCookie, mkCookie, permanentRedirect, seeOtherRedirect, sendResponseHeaders, responseHeadersSent, fPut, fPutStr, fCloseOutput, fIsWritable, -- * Exceptions -- Because it is not possible for user code to enter the FastCGI monad -- from outside it, catching exceptions in IO will not work. Therefore -- a full set of exception primitives designed to work with any -- 'MonadFastCGI' instance is provided. FastCGIException(..), fThrow, fCatch, fBlock, fUnblock, fBracket, fFinally, fTry, fHandle, fOnException ) where import Control.Concurrent import qualified Control.Exception as Exception import Control.Monad.Reader import Data.Bits import qualified Data.ByteString as BS import qualified Data.ByteString.UTF8 as BS (toString, fromString) import Data.Char import Data.List import qualified Data.Map as Map import Data.Maybe import Data.Typeable import Data.Word import Foreign.C.Error import GHC.IO.Exception (IOErrorType(..)) import qualified Network.Socket as Network hiding (send, sendTo, recv, recvFrom) import qualified Network.Socket.ByteString as Network import Prelude hiding (catch) import System.Environment import System.IO.Error (ioeGetErrorType) import qualified System.IO.Error as System -- | An opaque type representing the state of a single connection from the web server. data FastCGIState = FastCGIState { webServerAddresses :: Maybe [Network.HostAddress], socket :: Network.Socket, peer :: Network.SockAddr, requestChannelMapMVar :: MVar (Map.Map Int (Chan Record)), request :: Maybe Request } data Request = Request { requestID :: Int, requestChannel :: Chan Record, paramsStreamBufferMVar :: MVar BS.ByteString, stdinStreamBufferMVar :: MVar BS.ByteString, stdinStreamClosedMVar :: MVar Bool, requestEndedMVar :: MVar Bool, requestVariableMapMVar :: MVar (Map.Map String String), requestHeaderMapMVar :: MVar (Map.Map Header String), requestCookieMapMVar :: MVar (Map.Map String Cookie), responseStatusMVar :: MVar Int, responseHeaderMapMVar :: MVar (Map.Map Header String), responseHeadersSentMVar :: MVar Bool, responseCookieMapMVar :: MVar (Map.Map String Cookie) } data Cookie = Cookie { cookieName :: String, cookieValue :: String, cookieVersion :: Int, cookiePath :: Maybe String, cookieDomain :: Maybe String, cookieMaxAge :: Maybe Int, cookieSecure :: Bool, cookieComment :: Maybe String } deriving (Show) -- | The monad within which each single connection from the web server is handled. type FastCGI = ReaderT FastCGIState IO -- | The class of monads within which the FastCGI calls are valid. You may wish to -- create your own monad implementing this class. class (MonadIO m) => MonadFastCGI m where -- | Returns the opaque 'FastCGIState' object representing the state of the -- FastCGI client. -- Should not be called directly by user code, except implementations of -- 'MonadFastCGI'; exported so that -- user monads can implement the interface. getFastCGIState :: m FastCGIState -- | Throws an exception in the monad. -- Should not be called directly by user code; exported so that -- user monads can implement the interface. See 'fThrow'. implementationThrowFastCGI :: (Exception.Exception e) => e -- ^ The exception to throw -> m a -- | Perform an action in the monad, with a given exception-handler action bound. -- Should not be called directly by user code; exported so that -- user monads can implement the interface. See 'fCatch'. implementationCatchFastCGI :: (Exception.Exception e) => m a -- ^ The action to run with the exception handler binding in scope. -> (e -> m a) -- ^ The exception handler to bind. -> m a -- | Block exceptions within an action. -- Should not be called directly by user code; exported so that -- user monads can implement the interface. See 'fBlock'. implementationBlockFastCGI :: m a -- ^ The action to run with exceptions blocked. -> m a -- | Unblock exceptions within an action. -- Should not be called directly by user code; exported so that -- user monads can implement the interface. See 'fUnblock'. implementationUnblockFastCGI :: m a -- ^ The action to run with exceptions unblocked. -> m a instance MonadFastCGI FastCGI where getFastCGIState = ask implementationThrowFastCGI exception = liftIO $ Exception.throwIO exception implementationCatchFastCGI action handler = do state <- getFastCGIState liftIO $ Exception.catch (runReaderT action state) (\exception -> do runReaderT (handler exception) state) implementationBlockFastCGI action = do state <- getFastCGIState liftIO $ Exception.block (runReaderT action state) implementationUnblockFastCGI action = do state <- getFastCGIState liftIO $ Exception.unblock (runReaderT action state) data Record = Record { recordType :: RecordType, recordRequestID :: Int, recordContent :: BS.ByteString } deriving (Show) data RecordType = BeginRequestRecord | AbortRequestRecord | EndRequestRecord | ParamsRecord | StdinRecord | StdoutRecord | StderrRecord | DataRecord | GetValuesRecord | GetValuesResultRecord | UnknownTypeRecord | OtherRecord Int deriving (Eq, Show) instance Enum RecordType where toEnum 1 = BeginRequestRecord toEnum 2 = AbortRequestRecord toEnum 3 = EndRequestRecord toEnum 4 = ParamsRecord toEnum 5 = StdinRecord toEnum 6 = StdoutRecord toEnum 7 = StderrRecord toEnum 8 = DataRecord toEnum 9 = GetValuesRecord toEnum 10 = GetValuesResultRecord toEnum 11 = UnknownTypeRecord toEnum code = OtherRecord code fromEnum BeginRequestRecord = 1 fromEnum AbortRequestRecord = 2 fromEnum EndRequestRecord = 3 fromEnum ParamsRecord = 4 fromEnum StdinRecord = 5 fromEnum StdoutRecord = 6 fromEnum StderrRecord = 7 fromEnum DataRecord = 8 fromEnum GetValuesRecord = 9 fromEnum GetValuesResultRecord = 10 fromEnum UnknownTypeRecord = 11 -- | Takes a forking primitive, such as 'forkIO' or 'forkOS', and a handler, and -- concurrently accepts requests from the web server, forking with the primitive -- and invoking the handler in the forked thread inside the 'FastCGI' monad for each -- one. -- -- It is valid to use a custom forking primitive, such as one that attempts to pool -- OS threads, but the primitive must actually provide concurrency - otherwise there -- will be a deadlock. There is no support for single-threaded operation. -- -- Note that although there is no mechanism to substitute another type of monad for -- FastCGI, you can enter your own monad within the handler, much as you would enter -- your own monad within IO. You simply have to implement the 'MonadFastCGI' class. -- -- Any exceptions not caught within the handler are caught by 'concurrentAcceptLoop', -- and cause the termination of that handler, but not of the accept loop. -- Furthermore, the exception is logged through the FastCGI protocol if at all -- possible. -- -- In the event that the program was not invoked according to the FastCGI protocol, -- returns. acceptLoop :: (IO () -> IO ThreadId) -- ^ A forking primitive, typically either 'forkIO' or 'forkOS'. -> (FastCGI ()) -- ^ A handler which is invoked once for each incoming connection. -> IO () -- ^ Never actually returns. acceptLoop fork handler = do maybeListenSocket <- createListenSocket webServerAddresses <- computeWebServerAddresses case maybeListenSocket of Nothing -> return () Just listenSocket -> do let acceptLoop' = do (socket, peer) <- Network.accept listenSocket requestChannelMapMVar <- newMVar $ Map.empty let state = FastCGIState { webServerAddresses = webServerAddresses, socket = socket, peer = peer, requestChannelMapMVar = requestChannelMapMVar, request = Nothing } flip runReaderT state $ do addressValid <- validateWebServerAddress case addressValid of False -> do FastCGIState { peer = peer } <- getFastCGIState fLog $ "Ignoring connection from invalid address: " ++ (show peer) True -> outsideRequestLoop fork handler acceptLoop' acceptLoop' createListenSocket :: IO (Maybe Network.Socket) createListenSocket = do listenSocket <- Network.mkSocket 0 Network.AF_INET Network.Stream Network.defaultProtocol Network.Listening -- Notice that we do AF_INET even though AF_UNSPEC would be more honest, because -- we need to call getPeerName which needs to know how big a sockaddr to allow for. -- This should work even though the socket could, for all we know, be an ipv6 socket -- with a larger sockaddr, because that check hopefully happens after the check for -- the case we care about, which is that the socket is not connected and therefore -- has no peer name. System.catch (do Network.getPeerName listenSocket return Nothing) (\error -> do if ioeGetErrorType error == InvalidArgument then do -- Since we need to know the specific error code, not just the -- logical mapping of it, we need to actually drill down and check -- errno. Otherwise we can't distinguish "it doesn't have a peer -- name because it's a listening socket" from "it doesn't have a -- peer name because it's not a socket at all". errno <- getErrno if errno == eNOTCONN then return $ Just listenSocket else return Nothing else return Nothing) computeWebServerAddresses :: IO (Maybe [Network.HostAddress]) computeWebServerAddresses = do environment <- getEnvironment System.catch (do string <- getEnv "FCGI_WEB_SERVER_ADDRS" let split [] = [] split string = case elemIndex ',' string of Nothing -> [string] Just index -> let (first, rest) = splitAt index string in first : (split $ drop 1 rest) splitString = split string addresses <- mapM Network.inet_addr splitString return $ Just addresses) (\error -> do if System.isDoesNotExistError error then return Nothing else System.ioError error) validateWebServerAddress :: (MonadFastCGI m) => m Bool validateWebServerAddress = do FastCGIState { webServerAddresses = maybeWebServerAddresses, peer = peer } <- getFastCGIState case maybeWebServerAddresses of Nothing -> return True Just webServerAddresses -> return $ flip any webServerAddresses (\webServerAddress -> case peer of Network.SockAddrInet _ peerAddress -> webServerAddress == peerAddress _ -> False) outsideRequestLoop :: (IO () -> IO ThreadId) -> (FastCGI ()) -> FastCGI () outsideRequestLoop fork handler = do maybeRecord <- recvRecord case maybeRecord of Nothing -> do FastCGIState { socket = socket } <- getFastCGIState liftIO $ Exception.catch (Network.sClose socket) (\error -> do return $ error :: IO Exception.IOException return ()) return () Just record -> do case recordType record of BeginRequestRecord -> do state <- getFastCGIState requestChannel <- liftIO $ newChan requestChannelMap <- liftIO $ takeMVar $ requestChannelMapMVar state paramsStreamBufferMVar <- liftIO $ newMVar $ BS.empty stdinStreamBufferMVar <- liftIO $ newMVar $ BS.empty stdinStreamClosedMVar <- liftIO $ newMVar $ False requestEndedMVar <- liftIO $ newMVar $ False requestVariableMapMVar <- liftIO $ newMVar $ Map.empty requestHeaderMapMVar <- liftIO $ newMVar $ Map.empty requestCookieMapMVar <- liftIO $ newMVar $ Map.empty responseStatusMVar <- liftIO $ newMVar $ 200 responseHeaderMapMVar <- liftIO $ newMVar $ Map.fromList [(HttpContentType, "text/html")] responseHeadersSentMVar <- liftIO $ newMVar $ False responseCookieMapMVar <- liftIO $ newMVar $ Map.empty let requestChannelMap' = Map.insert (recordRequestID record) requestChannel requestChannelMap request = Request { requestID = recordRequestID record, requestChannel = requestChannel, paramsStreamBufferMVar = paramsStreamBufferMVar, stdinStreamBufferMVar = stdinStreamBufferMVar, stdinStreamClosedMVar = stdinStreamClosedMVar, requestEndedMVar = requestEndedMVar, requestVariableMapMVar = requestVariableMapMVar, requestHeaderMapMVar = requestHeaderMapMVar, requestCookieMapMVar = requestCookieMapMVar, responseStatusMVar = responseStatusMVar, responseHeaderMapMVar = responseHeaderMapMVar, responseHeadersSentMVar = responseHeadersSentMVar, responseCookieMapMVar = responseCookieMapMVar } state' = state { request = Just request } liftIO $ putMVar (requestChannelMapMVar state) requestChannelMap' liftIO $ fork $ do Exception.catch (runReaderT (insideRequestLoop handler) state') (\error -> flip runReaderT state' $ do fLog $ "Uncaught exception: " ++ (show (error :: Exception.SomeException))) return () OtherRecord unknownCode -> do sendRecord $ Record { recordType = UnknownTypeRecord, recordRequestID = 0, recordContent = BS.pack [fromIntegral unknownCode, 0, 0, 0, 0, 0, 0, 0] } GetValuesRecord -> do fLog $ "Get values record: " ++ (show record) _ -> do state <- getFastCGIState requestChannelMap <- liftIO $ readMVar $ requestChannelMapMVar state let requestID = recordRequestID record maybeRequestChannel = Map.lookup requestID requestChannelMap case maybeRequestChannel of Nothing -> fLog $ "Ignoring record for unknown request ID " ++ (show requestID) Just requestChannel -> liftIO $ writeChan requestChannel record outsideRequestLoop fork handler insideRequestLoop :: (FastCGI ()) -> FastCGI () insideRequestLoop handler = do FastCGIState { request = Just request } <- getFastCGIState record <- liftIO $ readChan $ requestChannel request case recordType record of ParamsRecord -> do case BS.length $ recordContent record of 0 -> do handler sendResponseHeaders requestEnded <- liftIO $ readMVar $ requestEndedMVar request if not requestEnded then terminateRequest else return () _ -> do buffer <- liftIO $ takeMVar $ paramsStreamBufferMVar request let bufferWithNewData = BS.append buffer $ recordContent record takeUntilEmpty bufferTail = do let maybeNameValuePair = takeNameValuePair bufferTail case maybeNameValuePair of Nothing -> liftIO $ putMVar (paramsStreamBufferMVar request) bufferTail Just ((name, value), bufferTail') -> do let name' = BS.toString name value' = BS.toString value processRequestVariable name' value' takeUntilEmpty bufferTail' takeUntilEmpty bufferWithNewData insideRequestLoop handler _ -> do fLog $ "Ignoring record of unexpected type " ++ (show $ recordType record) processRequestVariable :: String -> String -> FastCGI () processRequestVariable name value = do state <- getFastCGIState requestVariableMap <- liftIO $ takeMVar $ requestVariableMapMVar $ fromJust $ request state let requestVariableMap' = Map.insert name value requestVariableMap liftIO $ putMVar (requestVariableMapMVar $ fromJust $ request state) requestVariableMap' let maybeHeader = requestVariableNameToHeader name case maybeHeader of Nothing -> return () Just header -> do processRequestHeader header value processRequestHeader :: Header -> String -> FastCGI () processRequestHeader header value = do state <- getFastCGIState requestHeaderMap <- liftIO $ takeMVar $ requestHeaderMapMVar $ fromJust $ request state let requestHeaderMap' = Map.insert header value requestHeaderMap liftIO $ putMVar (requestHeaderMapMVar $ fromJust $ request state) requestHeaderMap' case header of HttpCookie -> do processCookies value _ -> return () processCookies :: String -> FastCGI () processCookies value = do state <- getFastCGIState requestCookieMap <- liftIO $ takeMVar $ requestCookieMapMVar $ fromJust $ request state let updateCookieMap cookieMap (cookie:rest) = updateCookieMap (Map.insert (cookieName cookie) cookie cookieMap) rest updateCookieMap cookieMap [] = cookieMap requestCookieMap' = updateCookieMap requestCookieMap $ parseCookies value liftIO $ putMVar (requestCookieMapMVar $ fromJust $ request state) requestCookieMap' parseCookies :: String -> [Cookie] parseCookies value = let findSeparator string = let quotePoint = if (length string > 0) && (string !! 0 == '"') then 1 + (findBalancingQuote $ drop 1 string) else 0 maybeSemicolonPoint = case (findIndex (\c -> (c == ';') || (c == ',')) $ drop quotePoint string) of Nothing -> Nothing Just index -> Just $ index + quotePoint in maybeSemicolonPoint findBalancingQuote string = let consume accumulator ('\\' : c : rest) = consume (accumulator + 2) rest consume accumulator ('"' : rest) = accumulator consume accumulator (c : rest) = consume (accumulator + 1) rest consume accumulator "" = accumulator in consume 0 string split [] = [] split string = case findSeparator string of Nothing -> [string] Just index -> let (first, rest) = splitAt index string in first : (split $ drop 1 rest) splitNameValuePair string = case elemIndex '=' (filterNameValuePair string) of Nothing -> (string, "") Just index -> let (first, rest) = splitAt index (filterNameValuePair string) in (first, filterValue (drop 1 rest)) filterNameValuePair string = reverse $ dropWhile isSpace $ reverse $ dropWhile isSpace string filterValue string = if (length string > 0) && ((string !! 0) == '"') then take (findBalancingQuote $ drop 1 string) $ drop 1 string else string pairs = map splitNameValuePair $ split value (version, pairs') = case pairs of ("$Version", versionString) : rest -> case parseInt versionString of Nothing -> (0, rest) Just version -> (version, rest) _ -> (0, pairs) takeCookie pairs = case pairs of (name, value) : pairs' | (length name > 0) && (take 1 name /= "$") -> let (maybePath, maybeDomain, pairs'') = takePathAndDomain pairs' in (Cookie { cookieName = name, cookieValue = value, cookieVersion = version, cookiePath = maybePath, cookieDomain = maybeDomain, cookieMaxAge = Nothing, cookieSecure = False, cookieComment = Nothing } : takeCookie pairs'') _ : pairs' -> takeCookie pairs' [] -> [] takePathAndDomain pairs = let (maybePath, pairs') = case pairs of ("$Path", path) : rest -> (Just path, rest) _ -> (Nothing, pairs) (maybeDomain, pairs'') = case pairs' of ("$Domain", domain) : rest -> (Just domain, rest) _ -> (Nothing, pairs') in (maybePath, maybeDomain, pairs'') in takeCookie pairs' printCookies :: [Cookie] -> String printCookies cookies = let printCookie cookie = intercalate ";" $ map printNameValuePair $ nameValuePairs cookie printNameValuePair (name, Nothing) = name printNameValuePair (name, Just value) = name ++ "=\"" ++ escape value ++ "\"" escape "" = "" escape ('\\':rest) = "\\\\" ++ escape rest escape ('\"':rest) = "\\\"" ++ escape rest escape (c:rest) = [c] ++ escape rest nameValuePairs cookie = [(cookieName cookie, Just $ cookieValue cookie)] ++ (case cookieComment cookie of Nothing -> [] Just comment -> [("Comment", Just comment)]) ++ (case cookieDomain cookie of Nothing -> [] Just domain -> [("Domain", Just domain)]) ++ (case cookieMaxAge cookie of Nothing -> [] Just maxAge -> [("Max-Age", Just $ show maxAge)]) ++ (case cookiePath cookie of Nothing -> [] Just path -> [("Path", Just $ show path)]) ++ (case cookieSecure cookie of False -> [] True -> [("Secure", Nothing)]) ++ [("Version", Just $ show $ cookieVersion cookie)] in intercalate "," $ map printCookie cookies parseInt :: String -> Maybe Int parseInt string = if (length string > 0) && (all isDigit string) then Just $ let accumulate "" accumulator = accumulator accumulate (n:rest) accumulator = accumulate rest $ accumulator * 10 + digitToInt n in accumulate string 0 else Nothing recvRecord :: (MonadFastCGI m) => m (Maybe Record) recvRecord = do FastCGIState { socket = socket } <- getFastCGIState byteString <- liftIO $ recvAll socket 8 case BS.length byteString of 8 -> do let recordVersion = BS.index byteString 0 recordTypeCode = fromIntegral $ BS.index byteString 1 recordRequestIDB1 = BS.index byteString 2 recordRequestIDB0 = BS.index byteString 3 recordRequestID = (fromIntegral recordRequestIDB1) * 256 + (fromIntegral recordRequestIDB0) recordContentLengthB1 = BS.index byteString 4 recordContentLengthB0 = BS.index byteString 5 recordContentLength = (fromIntegral recordContentLengthB1) * 256 + (fromIntegral recordContentLengthB0) recordPaddingLength = BS.index byteString 6 if recordVersion /= 1 then do fLog $ "Record header of unrecognized version: " ++ (show recordVersion) return Nothing else do let recordType = toEnum recordTypeCode recordContent <- liftIO $ recvAll socket recordContentLength liftIO $ recvAll socket $ fromIntegral recordPaddingLength return $ Just $ Record { recordType = recordType, recordRequestID = recordRequestID, recordContent = recordContent } _ -> return Nothing sendRecord :: (MonadFastCGI m) => Record -> m () sendRecord record = do FastCGIState { socket = socket } <- getFastCGIState let recordRequestIDB0 = fromIntegral $ recordRequestID record `mod` 256 recordRequestIDB1 = fromIntegral $ (recordRequestID record `div` 256) `mod` 256 recordContentLength = BS.length $ recordContent record recordContentLengthB0 = fromIntegral $ recordContentLength `mod` 256 recordContentLengthB1 = fromIntegral $ (recordContentLength `div` 256) `mod` 256 headerByteString = BS.pack [1, fromIntegral $ fromEnum $ recordType record, recordRequestIDB1, recordRequestIDB0, recordContentLengthB1, recordContentLengthB0, 0, 0] byteString = BS.append headerByteString $ recordContent record liftIO $ Network.sendAll socket byteString recvAll :: Network.Socket -> Int -> IO BS.ByteString recvAll socket totalSize = do if totalSize == 0 then return BS.empty else do byteString <- Network.recv socket totalSize case BS.length byteString of 0 -> return byteString receivedSize | receivedSize == totalSize -> return byteString | otherwise -> do restByteString <- recvAll socket $ totalSize - receivedSize return $ BS.append byteString restByteString takeLength :: BS.ByteString -> Maybe (Int, BS.ByteString) takeLength byteString = if BS.length byteString < 1 then Nothing else let firstByte = BS.index byteString 0 threeMoreComing = (firstByte .&. 0x80) == 0x80 in if threeMoreComing then if BS.length byteString < 4 then Nothing else let secondByte = BS.index byteString 1 thirdByte = BS.index byteString 2 fourthByte = BS.index byteString 3 decoded = ((fromIntegral $ firstByte .&. 0x7F) `shiftL` 24) + (fromIntegral secondByte `shiftL` 16) + (fromIntegral thirdByte `shiftL` 8) + (fromIntegral fourthByte) in Just (decoded, BS.drop 4 byteString) else Just (fromIntegral firstByte, BS.drop 1 byteString) takeNameValuePair :: BS.ByteString -> Maybe ((BS.ByteString, BS.ByteString), BS.ByteString) takeNameValuePair byteString = let maybeNameLength = takeLength byteString in case maybeNameLength of Nothing -> Nothing Just (nameLength, byteString') -> let maybeValueLength = takeLength byteString' in case maybeValueLength of Nothing -> Nothing Just (valueLength, byteString'') -> let name = BS.take nameLength byteString'' byteString''' = BS.drop nameLength byteString'' value = BS.take valueLength byteString''' byteString'''' = BS.drop valueLength byteString''' in Just ((name, value), byteString'''') -- | Logs a message using the web server's logging facility. fLog :: (MonadFastCGI m) => String -> m () fLog message = do FastCGIState { request = maybeRequest } <- getFastCGIState case maybeRequest of Nothing -> do -- As you can see, the description is actually incomplete. If there's no request -- in progress, we use syslog instead. But since the user can never call us -- outside a request, that would only be confusing if documented. -- liftIO $ withSyslog "direct-fastcgi" [PID] USER $ syslog Error message return () Just request -> do if length message > 0 then sendRecord $ Record { recordType = StderrRecord, recordRequestID = requestID request, recordContent = BS.fromString message } else return () -- | Headers are classified by HTTP/1.1 as request headers, response headers, or -- entity headers. data Header -- | Request headers = HttpAccept | HttpAcceptCharset | HttpAcceptEncoding | HttpAcceptLanguage | HttpAuthorization | HttpExpect | HttpFrom | HttpHost | HttpIfMatch | HttpIfModifiedSince | HttpIfNoneMatch | HttpIfRange | HttpIfUnmodifiedSince | HttpMaxForwards | HttpProxyAuthorization | HttpRange | HttpReferer | HttpTE | HttpUserAgent -- | Response headers | HttpAcceptRanges | HttpAge | HttpETag | HttpLocation | HttpProxyAuthenticate | HttpRetryAfter | HttpServer | HttpVary | HttpWWWAuthenticate -- | Entity headers | HttpAllow | HttpContentEncoding | HttpContentLanguage | HttpContentLength | HttpContentLocation | HttpContentMD5 | HttpContentRange | HttpContentType | HttpExpires | HttpLastModified | HttpExtensionHeader String -- | Nonstandard headers | HttpConnection | HttpCookie | HttpSetCookie deriving (Eq, Ord) instance Show Header where show header = fromHeader header data HeaderType = RequestHeader | ResponseHeader | EntityHeader deriving (Eq, Show) headerType :: Header -> HeaderType headerType HttpAccept = RequestHeader headerType HttpAcceptCharset = RequestHeader headerType HttpAcceptEncoding = RequestHeader headerType HttpAcceptLanguage = RequestHeader headerType HttpAuthorization = RequestHeader headerType HttpExpect = RequestHeader headerType HttpFrom = RequestHeader headerType HttpHost = RequestHeader headerType HttpIfMatch = RequestHeader headerType HttpIfModifiedSince = RequestHeader headerType HttpIfNoneMatch = RequestHeader headerType HttpIfRange = RequestHeader headerType HttpIfUnmodifiedSince = RequestHeader headerType HttpMaxForwards = RequestHeader headerType HttpProxyAuthorization = RequestHeader headerType HttpRange = RequestHeader headerType HttpReferer = RequestHeader headerType HttpTE = RequestHeader headerType HttpUserAgent = RequestHeader headerType HttpAcceptRanges = ResponseHeader headerType HttpAge = ResponseHeader headerType HttpETag = ResponseHeader headerType HttpLocation = ResponseHeader headerType HttpProxyAuthenticate = ResponseHeader headerType HttpRetryAfter = ResponseHeader headerType HttpServer = ResponseHeader headerType HttpVary = ResponseHeader headerType HttpWWWAuthenticate = ResponseHeader headerType HttpAllow = EntityHeader headerType HttpContentEncoding = EntityHeader headerType HttpContentLanguage = EntityHeader headerType HttpContentLength = EntityHeader headerType HttpContentLocation = EntityHeader headerType HttpContentMD5 = EntityHeader headerType HttpContentRange = EntityHeader headerType HttpContentType = EntityHeader headerType HttpExpires = EntityHeader headerType HttpLastModified = EntityHeader headerType (HttpExtensionHeader _) = EntityHeader headerType HttpConnection = RequestHeader headerType HttpCookie = RequestHeader headerType HttpSetCookie = ResponseHeader fromHeader :: Header -> String fromHeader HttpAccept = "Accept" fromHeader HttpAcceptCharset = "Accept-Charset" fromHeader HttpAcceptEncoding = "Accept-Encoding" fromHeader HttpAcceptLanguage = "Accept-Language" fromHeader HttpAuthorization = "Authorization" fromHeader HttpExpect = "Expect" fromHeader HttpFrom = "From" fromHeader HttpHost = "Host" fromHeader HttpIfMatch = "If-Match" fromHeader HttpIfModifiedSince = "If-Modified-Since" fromHeader HttpIfNoneMatch = "If-None-Match" fromHeader HttpIfRange = "If-Range" fromHeader HttpIfUnmodifiedSince = "If-Unmodified-Since" fromHeader HttpMaxForwards = "Max-Forwards" fromHeader HttpProxyAuthorization = "Proxy-Authorization" fromHeader HttpRange = "Range" fromHeader HttpReferer = "Referer" fromHeader HttpTE = "TE" fromHeader HttpUserAgent = "User-Agent" fromHeader HttpAcceptRanges = "Accept-Ranges" fromHeader HttpAge = "Age" fromHeader HttpETag = "ETag" fromHeader HttpLocation = "Location" fromHeader HttpProxyAuthenticate = "Proxy-Authenticate" fromHeader HttpRetryAfter = "Retry-After" fromHeader HttpServer = "Server" fromHeader HttpVary = "Vary" fromHeader HttpWWWAuthenticate = "WWW-Authenticate" fromHeader HttpAllow = "Allow" fromHeader HttpContentEncoding = "Content-Encoding" fromHeader HttpContentLanguage = "Content-Language" fromHeader HttpContentLength = "Content-Length" fromHeader HttpContentLocation = "Content-Location" fromHeader HttpContentMD5 = "Content-MD5" fromHeader HttpContentRange = "Content-Range" fromHeader HttpContentType = "Content-Type" fromHeader HttpExpires = "Expires" fromHeader HttpLastModified = "Last-Modified" fromHeader (HttpExtensionHeader name) = name fromHeader HttpConnection = "Connection" fromHeader HttpCookie = "Cookie" fromHeader HttpSetCookie = "Set-Cookie" toHeader :: String -> Header toHeader "Accept" = HttpAccept toHeader "Accept-Charset" = HttpAcceptCharset toHeader "Accept-Encoding" = HttpAcceptEncoding toHeader "Accept-Language" = HttpAcceptLanguage toHeader "Authorization" = HttpAuthorization toHeader "Expect" = HttpExpect toHeader "From" = HttpFrom toHeader "Host" = HttpHost toHeader "If-Match" = HttpIfMatch toHeader "If-Modified-Since" = HttpIfModifiedSince toHeader "If-None-Match" = HttpIfNoneMatch toHeader "If-Range" = HttpIfRange toHeader "If-Unmodified-Since" = HttpIfUnmodifiedSince toHeader "Max-Forwards" = HttpMaxForwards toHeader "Proxy-Authorization" = HttpProxyAuthorization toHeader "Range" = HttpRange toHeader "Referer" = HttpReferer toHeader "TE" = HttpTE toHeader "User-Agent" = HttpUserAgent toHeader "Accept-Ranges" = HttpAcceptRanges toHeader "Age" = HttpAge toHeader "ETag" = HttpETag toHeader "Location" = HttpLocation toHeader "Proxy-Authenticate" = HttpProxyAuthenticate toHeader "Retry-After" = HttpRetryAfter toHeader "Server" = HttpServer toHeader "Vary" = HttpVary toHeader "WWW-Authenticate" = HttpWWWAuthenticate toHeader "Allow" = HttpAllow toHeader "Content-Encoding" = HttpContentEncoding toHeader "Content-Language" = HttpContentLanguage toHeader "Content-Length" = HttpContentLength toHeader "Content-Location" = HttpContentLocation toHeader "Content-MD5" = HttpContentMD5 toHeader "Content-Range" = HttpContentRange toHeader "Content-Type" = HttpContentType toHeader "Expires" = HttpExpires toHeader "Last-Modified" = HttpLastModified toHeader "Connection" = HttpConnection toHeader "Cookie" = HttpCookie toHeader "Set-Cookie" = HttpSetCookie toHeader name = HttpExtensionHeader name requestVariableNameIsHeader :: String -> Bool requestVariableNameIsHeader name = (length name > 5) && (take 5 name == "HTTP_") requestVariableNameToHeaderName :: String -> Maybe String requestVariableNameToHeaderName name = if requestVariableNameIsHeader name then let split [] = [] split string = case elemIndex '_' string of Nothing -> [string] Just index -> let (first, rest) = splitAt index string in first : (split $ drop 1 rest) titleCase word = [toUpper $ head word] ++ (map toLower $ tail word) headerName = intercalate "-" $ map titleCase $ split $ drop 5 name in Just headerName else Nothing requestVariableNameToHeader :: String -> Maybe Header requestVariableNameToHeader "HTTP_ACCEPT" = Just HttpAccept requestVariableNameToHeader "HTTP_ACCEPT_CHARSET" = Just HttpAcceptCharset requestVariableNameToHeader "HTTP_ACCEPT_ENCODING" = Just HttpAcceptEncoding requestVariableNameToHeader "HTTP_ACCEPT_LANGUAGE" = Just HttpAcceptLanguage requestVariableNameToHeader "HTTP_AUTHORIZATION" = Just HttpAuthorization requestVariableNameToHeader "HTTP_EXPECT" = Just HttpExpect requestVariableNameToHeader "HTTP_FROM" = Just HttpFrom requestVariableNameToHeader "HTTP_HOST" = Just HttpHost requestVariableNameToHeader "HTTP_IF_MATCH" = Just HttpIfMatch requestVariableNameToHeader "HTTP_IF_MODIFIED_SINCE" = Just HttpIfModifiedSince requestVariableNameToHeader "HTTP_IF_NONE_MATCH" = Just HttpIfNoneMatch requestVariableNameToHeader "HTTP_IF_RANGE" = Just HttpIfRange requestVariableNameToHeader "HTTP_IF_UNMODIFIED_SINCE" = Just HttpIfUnmodifiedSince requestVariableNameToHeader "HTTP_MAX_FORWARDS" = Just HttpMaxForwards requestVariableNameToHeader "HTTP_PROXY_AUTHORIZATION" = Just HttpProxyAuthorization requestVariableNameToHeader "HTTP_RANGE" = Just HttpRange requestVariableNameToHeader "HTTP_REFERER" = Just HttpReferer requestVariableNameToHeader "HTTP_TE" = Just HttpTE requestVariableNameToHeader "HTTP_USER_AGENT" = Just HttpUserAgent requestVariableNameToHeader "HTTP_ALLOW" = Just HttpAllow requestVariableNameToHeader "HTTP_CONTENT_ENCODING" = Just HttpContentEncoding requestVariableNameToHeader "HTTP_CONTENT_LANGUAGE" = Just HttpContentLanguage requestVariableNameToHeader "HTTP_CONTENT_LENGTH" = Just HttpContentLength requestVariableNameToHeader "HTTP_CONTENT_LOCATION" = Just HttpContentLocation requestVariableNameToHeader "HTTP_CONTENT_MD5" = Just HttpContentMD5 requestVariableNameToHeader "HTTP_CONTENT_RANGE" = Just HttpContentRange requestVariableNameToHeader "HTTP_CONTENT_TYPE" = Just HttpContentType requestVariableNameToHeader "HTTP_EXPIRES" = Just HttpExpires requestVariableNameToHeader "HTTP_LAST_MODIFIED" = Just HttpLastModified requestVariableNameToHeader "HTTP_CONNECTION" = Just HttpConnection requestVariableNameToHeader "HTTP_COOKIE" = Just HttpCookie requestVariableNameToHeader name = if requestVariableNameIsHeader name then Just $ HttpExtensionHeader $ fromJust $ requestVariableNameToHeaderName name else Nothing isValidInResponse :: Header -> Bool isValidInResponse header = (headerType header == ResponseHeader) || (headerType header == EntityHeader) -- | Queries the value from the web server of the CGI/1.1 request variable with the -- given name for this request. getRequestVariable :: (MonadFastCGI m) => String -- ^ The name of the request variable to query. -> m (Maybe String) -- ^ The value of the request variable, if the web server -- provided one. getRequestVariable name = do state <- getFastCGIState requestVariableMap <- liftIO $ readMVar $ requestVariableMapMVar $ fromJust $ request state return $ Map.lookup name requestVariableMap -- | Returns an association list of name-value pairs of all the CGI/1.1 request -- variables from the web server. getAllRequestVariables :: (MonadFastCGI m) => m [(String, String)] getAllRequestVariables = do state <- getFastCGIState requestVariableMap <- liftIO $ readMVar $ requestVariableMapMVar $ fromJust $ request state return $ Map.assocs requestVariableMap -- | Queries the value from the user agent of the given HTTP/1.1 header. getRequestHeader :: (MonadFastCGI m) => Header -- ^ The header to query. Must be a request or entity header. -> m (Maybe String) -- ^ The value of the header, if the user agent provided one. getRequestHeader header = do state <- getFastCGIState requestHeaderMap <- liftIO $ readMVar $ requestHeaderMapMVar $ fromJust $ request state return $ Map.lookup header requestHeaderMap -- | Returns an association list of name-value pairs of all the HTTP/1.1 request or -- entity headers from the user agent. getAllRequestHeaders :: (MonadFastCGI m) => m [(Header, String)] getAllRequestHeaders = do state <- getFastCGIState requestHeaderMap <- liftIO $ readMVar $ requestHeaderMapMVar $ fromJust $ request state return $ Map.assocs requestHeaderMap -- | Returns a 'Cookie' object for the given name, if the user agent provided one -- in accordance with RFC 2109. getCookie :: (MonadFastCGI m) => String -- ^ The name of the cookie to look for. -> m (Maybe Cookie) -- ^ The cookie, if the user agent provided it. getCookie name = do state <- getFastCGIState requestCookieMap <- liftIO $ readMVar $ requestCookieMapMVar $ fromJust $ request state return $ Map.lookup name requestCookieMap -- | Returns all 'Cookie' objects provided by the user agent in accordance -- RFC 2109. getAllCookies :: (MonadFastCGI m) => m [Cookie] getAllCookies = do state <- getFastCGIState requestCookieMap <- liftIO $ readMVar $ requestCookieMapMVar $ fromJust $ request state return $ Map.elems requestCookieMap -- | A convenience method; as 'getCookie', but returns only the value of the cookie -- rather than a 'Cookie' object. getCookieValue :: (MonadFastCGI m) => String -- ^ The name of the cookie to look for. -> m (Maybe String) -- ^ The value of the cookie, if the user agent provided it. getCookieValue name = do state <- getFastCGIState requestCookieMap <- liftIO $ readMVar $ requestCookieMapMVar $ fromJust $ request state return $ case Map.lookup name requestCookieMap of Nothing -> Nothing Just cookie -> Just $ cookieValue cookie -- | Return the document root, as provided by the web server, if it was provided. getDocumentRoot :: (MonadFastCGI m) => m (Maybe String) getDocumentRoot = do getRequestVariable "DOCUMENT_ROOT" -- | Return the gateway interface, as provided by the web server, if it was provided. getGatewayInterface :: (MonadFastCGI m) => m (Maybe String) getGatewayInterface = do getRequestVariable "GATEWAY_INTERFACE" -- | Return the path info, as provided by the web server, if it was provided. getPathInfo :: (MonadFastCGI m) => m (Maybe String) getPathInfo = do getRequestVariable "PATH_INFO" -- | Return the path-translated value, as provided by the web server, if it was provided. getPathTranslated :: (MonadFastCGI m) => m (Maybe String) getPathTranslated = do getRequestVariable "PATH_TRANSLATED" -- | Return the query string, as provided by the web server, if it was provided. getQueryString :: (MonadFastCGI m) => m (Maybe String) getQueryString = do getRequestVariable "QUERY_STRING" -- | Return the redirect status, as provided by the web server, if it was provided. getRedirectStatus :: (MonadFastCGI m) => m (Maybe Int) getRedirectStatus = do value <- getRequestVariable "REDIRECT_STATUS" return $ case value of Nothing -> Nothing Just value -> parseInt value -- | Return the redirect URI, as provided by the web server, if it was provided. getRedirectURI :: (MonadFastCGI m) => m (Maybe String) getRedirectURI = do getRequestVariable "REDIRECT_URI" -- | Return the remote address, as provided by the web server, if it was provided. getRemoteAddress :: (MonadFastCGI m) => m (Maybe Network.HostAddress) getRemoteAddress = do value <- getRequestVariable "REMOTE_ADDR" case value of Nothing -> return Nothing Just value -> do fCatch (do value' <- liftIO $ Network.inet_addr value return $ Just value') (\exception -> do return (exception :: System.IOError) return Nothing) -- | Return the remote port, as provided by the web server, if it was provided. getRemotePort :: (MonadFastCGI m) => m (Maybe Int) getRemotePort = do value <- getRequestVariable "REMOTE_PORT" return $ case value of Nothing -> Nothing Just value -> parseInt value -- | Return the remote hostname, as provided by the web server, if it was provided. getRemoteHost :: (MonadFastCGI m) => m (Maybe String) getRemoteHost = do getRequestVariable "REMOTE_HOST" -- | Return the remote ident value, as provided by the web server, if it was provided. getRemoteIdent :: (MonadFastCGI m) => m (Maybe String) getRemoteIdent = do getRequestVariable "REMOTE_IDENT" -- | Return the remote user name, as provided by the web server, if it was provided. getRemoteUser :: (MonadFastCGI m) => m (Maybe String) getRemoteUser = do getRequestVariable "REMOTE_USER" -- | Return the request method, as provided by the web server, if it was provided. getRequestMethod :: (MonadFastCGI m) => m (Maybe String) getRequestMethod = do getRequestVariable "REQUEST_METHOD" -- | Return the request URI, as provided by the web server, if it was provided. getRequestURI :: (MonadFastCGI m) => m (Maybe String) getRequestURI = do getRequestVariable "REQUEST_URI" -- | Return the script filename, as provided by the web server, if it was provided. getScriptFilename :: (MonadFastCGI m) => m (Maybe String) getScriptFilename = do getRequestVariable "SCRIPT_FILENAME" -- | Return the script name, as provided by the web server, if it was provided. getScriptName :: (MonadFastCGI m) => m (Maybe String) getScriptName = do getRequestVariable "SCRIPT_NAME" -- | Return the server address, as provided by the web server, if it was provided. getServerAddress :: (MonadFastCGI m) => m (Maybe Network.HostAddress) getServerAddress = do value <- getRequestVariable "SERVER_ADDR" case value of Nothing -> return Nothing Just value -> do fCatch (do value' <- liftIO $ Network.inet_addr value return $ Just value') (\exception -> do return (exception :: System.IOError) return Nothing) -- | Return the server name, as provided by the web server, if it was provided. getServerName :: (MonadFastCGI m) => m (Maybe String) getServerName = do getRequestVariable "SERVER_NAME" -- | Return the server port, as provided by the web server, if it was provided. getServerPort :: (MonadFastCGI m) => m (Maybe Int) getServerPort = do value <- getRequestVariable "SERVER_PORT" return $ case value of Nothing -> Nothing Just value -> parseInt value -- | Return the server protocol, as provided by the web server, if it was provided. getServerProtocol :: (MonadFastCGI m) => m (Maybe String) getServerProtocol = do getRequestVariable "SERVER_PROTOCOL" -- | Return the server software name and version, as provided by the web server, if -- it was provided. getServerSoftware :: (MonadFastCGI m) => m (Maybe String) getServerSoftware = do getRequestVariable "SERVER_SOFTWARE" -- | Return the authentication type, as provided by the web server, if it was provided. getAuthenticationType :: (MonadFastCGI m) => m (Maybe String) getAuthenticationType = do getRequestVariable "AUTH_TYPE" -- | Return the content length, as provided by the web server, if it was provided. getContentLength :: (MonadFastCGI m) => m (Maybe Int) getContentLength = do value <- getRequestVariable "CONTENT_LENGTH" return $ case value of Nothing -> Nothing Just value -> parseInt value -- | Return the content type, as provided by the web server, if it was provided. getContentType :: (MonadFastCGI m) => m (Maybe String) getContentType = do getRequestVariable "CONTENT_TYPE" -- | Reads up to a specified amount of data from the input stream of the current request, -- and interprets it as binary data. This is the content data of the HTTP request, -- if any. If input has been closed, returns an empty bytestring. If insufficient -- input is available, blocks until there is enough. If output has been closed, -- causes an 'OutputAlreadyClosed' exception. fGet :: (MonadFastCGI m) => Int -> m BS.ByteString fGet size = fGet' size False -- | Reads up to a specified amount of data from the input stream of the curent request, -- and interprets it as binary data. This is the content data of the HTTP request, -- if any. If input has been closed, returns an empty bytestring. If insufficient -- input is available, returns any input which is immediately available, or an empty -- bytestring if there is none, never blocking. If output has been closed, causes an -- 'OutputAlreadyClosed' exception. fGetNonBlocking :: (MonadFastCGI m) => Int -> m BS.ByteString fGetNonBlocking size = fGet' size True fGet' :: (MonadFastCGI m) => Int -> Bool -> m BS.ByteString fGet' size nonBlocking = do requireOutputNotYetClosed FastCGIState { request = Just request } <- getFastCGIState extendStdinStreamBufferToLength size nonBlocking stdinStreamBuffer <- liftIO $ takeMVar $ stdinStreamBufferMVar request if size <= BS.length stdinStreamBuffer then do let result = BS.take size stdinStreamBuffer remainder = BS.drop size stdinStreamBuffer liftIO $ putMVar (stdinStreamBufferMVar request) remainder return result else do liftIO $ putMVar (stdinStreamBufferMVar request) BS.empty return stdinStreamBuffer -- | Reads all remaining data from the input stream of the current request, and -- interprets it as binary data. This is the content data of the HTTP request, if -- any. Blocks until all input has been read. If input has been closed, returns an -- empty bytestring. If output has been closed, causes an 'OutputAlreadyClosed' -- exception. fGetContents :: (MonadFastCGI m) => m BS.ByteString fGetContents = do requireOutputNotYetClosed FastCGIState { request = Just request } <- getFastCGIState let extend = do stdinStreamBuffer <- liftIO $ readMVar $ stdinStreamBufferMVar request extendStdinStreamBufferToLength (BS.length stdinStreamBuffer + 1) False stdinStreamClosed <- liftIO $ readMVar $ stdinStreamClosedMVar request if stdinStreamClosed then do stdinStreamBuffer <- liftIO $ swapMVar (stdinStreamBufferMVar request) BS.empty return stdinStreamBuffer else extend extend -- | Returns whether the input stream of the current request potentially has data -- remaining, either in the buffer or yet to be read. This is the content data of -- the HTTP request, if any. fIsReadable :: (MonadFastCGI m) => m Bool fIsReadable = do FastCGIState { request = Just request } <- getFastCGIState stdinStreamBuffer <- liftIO $ readMVar $ stdinStreamBufferMVar request if BS.length stdinStreamBuffer > 0 then return True else do stdinStreamClosed <- liftIO $ readMVar $ stdinStreamClosedMVar request requestEnded <- liftIO $ readMVar $ requestEndedMVar request return $ (not stdinStreamClosed) && (not requestEnded) extendStdinStreamBufferToLength :: (MonadFastCGI m) => Int -> Bool -> m () extendStdinStreamBufferToLength desiredLength nonBlocking = do FastCGIState { request = Just request } <- getFastCGIState stdinStreamBuffer <- liftIO $ takeMVar $ stdinStreamBufferMVar request let extend bufferSoFar = do if BS.length bufferSoFar >= desiredLength then liftIO $ putMVar (stdinStreamBufferMVar request) bufferSoFar else do maybeRecord <- if nonBlocking then do isEmpty <- liftIO $ isEmptyChan $ requestChannel request if isEmpty then return Nothing else do record <- liftIO $ readChan $ requestChannel request return $ Just record else do record <- liftIO $ readChan $ requestChannel request return $ Just record case maybeRecord of Nothing -> liftIO $ putMVar (stdinStreamBufferMVar request) bufferSoFar Just record -> case recordType record of StdinRecord -> do case BS.length $ recordContent record of 0 -> do liftIO $ swapMVar (stdinStreamClosedMVar request) True liftIO $ putMVar (stdinStreamBufferMVar request) bufferSoFar _ -> do extend $ BS.append bufferSoFar $ recordContent record _ -> do fLog $ "Ignoring record of unexpected type " ++ (show $ recordType record) extend stdinStreamBuffer -- | Sets the response status which will be sent with the response headers. If the -- response headers have already been sent, causes a 'ResponseHeadersAlreadySent' -- exception. setResponseStatus :: (MonadFastCGI m) => Int -- ^ The HTTP/1.1 status code to set. -> m () setResponseStatus status = do requireResponseHeadersNotYetSent FastCGIState { request = Just request } <- getFastCGIState liftIO $ swapMVar (responseStatusMVar request) status return () -- | Returns the response status which will be or has been sent with the response -- headers. getResponseStatus :: (MonadFastCGI m) => m Int -- ^ The HTTP/1.1 status code. getResponseStatus = do FastCGIState { request = Just request } <- getFastCGIState liftIO $ readMVar (responseStatusMVar request) -- | Sets the given 'HttpHeader' response header to the given string value, overriding -- any value which has previously been set. If the response headers have already -- been sent, causes a 'ResponseHeadersAlreadySent' exception. If the header is not -- an HTTP/1.1 or extension response or entity header, ie, is not valid as part of -- a response, causes a 'NotAResponseHeader' exception. -- -- If a value is set for the 'HttpSetCookie' header, this overrides all cookies set -- for this request with 'setCookie'. setResponseHeader :: (MonadFastCGI m) => Header -- ^ The header to set. Must be a response header or an entity header. -> String -- ^ The value to set. -> m () setResponseHeader header value = do requireResponseHeadersNotYetSent if isValidInResponse header then do FastCGIState { request = Just request } <- getFastCGIState responseHeaderMap <- liftIO $ takeMVar $ responseHeaderMapMVar request let responseHeaderMap' = Map.insert header value responseHeaderMap liftIO $ putMVar (responseHeaderMapMVar request) responseHeaderMap' else fThrow $ NotAResponseHeader header -- | Causes the given 'HttpHeader' response header not to be sent, overriding any value -- which has previously been set. If the response headers have already been sent, -- causes a 'ResponseHeadersAlreadySent' exception. If the header is not an HTTP/1.1 -- or extension response or entity header, ie, is not valid as part of a response, -- causes a 'NotAResponseHeader' exception. -- -- Does not prevent the 'HttpSetCookie' header from being sent if cookies have been -- set for this request with 'setCookie'. unsetResponseHeader :: (MonadFastCGI m) => Header -- ^ The header to unset. Must be a response header or an entity header. -> m () unsetResponseHeader header = do requireResponseHeadersNotYetSent if isValidInResponse header then do FastCGIState { request = Just request } <- getFastCGIState responseHeaderMap <- liftIO $ takeMVar $ responseHeaderMapMVar request let responseHeaderMap' = Map.delete header responseHeaderMap liftIO $ putMVar (responseHeaderMapMVar request) responseHeaderMap' else fThrow $ NotAResponseHeader header -- | Returns the value of the given header which will be or has been sent with the -- response headers. If the header is not an HTTP/1.1 or extension response or entity -- header, ie, is not valid as part of a response, causes a 'NotAResponseHeader' -- exception. getResponseHeader :: (MonadFastCGI m) => Header -- ^ The header to query. Must be a response header or an entity -- header. -> m (Maybe String) -- ^ The value of the queried header. getResponseHeader header = do requireResponseHeadersNotYetSent if isValidInResponse header then do FastCGIState { request = Just request } <- getFastCGIState responseHeaderMap <- liftIO $ readMVar $ responseHeaderMapMVar request return $ Map.lookup header responseHeaderMap else fThrow $ NotAResponseHeader header -- | Causes the user agent to record the given cookie and send it back with future -- loads of this page. Does not take effect instantly, but rather when headers are -- sent. Cookies are set in accordance with RFC 2109. -- If an @HttpCookie@ header is set for this request by a call to 'setResponseHeader', -- this function has no effect. -- If the response headers have already been sent, -- causes a 'ResponseHeadersAlreadySent' exception. -- If the name is not a possible name for a cookie, causes a 'CookieNameInvalid' -- exception. setCookie :: (MonadFastCGI m) => Cookie -- ^ The cookie to set. -> m () setCookie cookie = do requireResponseHeadersNotYetSent requireValidCookieName $ cookieName cookie fLog $ show cookie FastCGIState { request = Just request } <- getFastCGIState responseCookieMap <- liftIO $ takeMVar $ responseCookieMapMVar request let responseCookieMap' = Map.insert (cookieName cookie) cookie responseCookieMap fLog $ show responseCookieMap' liftIO $ putMVar (responseCookieMapMVar request) responseCookieMap' -- | Causes the user agent to unset any cookie applicable to this page with the -- given name. Does not take effect instantly, but rather when headers are sent. -- If an @HttpCookie@ header is set for this request by a call to 'setResponseHeader', -- this function has no effect. -- If the response headers have already been sent, -- causes a 'ResponseHeadersAlreadySent' exception. -- If the name is not a possible name for a cookie, causes a 'CookieNameInvalid' -- exception. unsetCookie :: (MonadFastCGI m) => String -- ^ The name of the cookie to unset. -> m () unsetCookie name = do requireResponseHeadersNotYetSent requireValidCookieName name FastCGIState { request = Just request } <- getFastCGIState responseCookieMap <- liftIO $ takeMVar $ responseCookieMapMVar request let responseCookieMap' = Map.insert name (mkUnsetCookie name) responseCookieMap liftIO $ putMVar (responseCookieMapMVar request) responseCookieMap' -- | Constructs a cookie with the given name and value. Version is set to 1; -- path, domain, and maximum age are set to @Nothing@; and the secure flag is -- set to @False@. Constructing the cookie does not cause it to be set; to do -- that, call 'setCookie' on it. mkSimpleCookie :: String -- ^ The name of the cookie to construct. -> String -- ^ The value of the cookie to construct. -> Cookie -- ^ A cookie with the given name and value. mkSimpleCookie name value = Cookie { cookieName = name, cookieValue = value, cookieVersion = 1, cookiePath = Nothing, cookieDomain = Nothing, cookieMaxAge = Nothing, cookieSecure = False, cookieComment = Nothing } -- | Constructs a cookie with the given parameters. Version is set to 1. -- Constructing the cookie does not cause it to be set; to do that, call 'setCookie' -- on it. mkCookie :: String -- ^ The name of the cookie to construct. -> String -- ^ The value of the cookie to construct. -> (Maybe String) -- ^ The path of the cookie to construct. -> (Maybe String) -- ^ The domain of the cookie to construct. -> (Maybe Int) -- ^ The maximum age of the cookie to construct, in seconds. -> Bool -- ^ Whether to flag the cookie to construct as secure. -> Cookie -- ^ A cookie with the given parameters. mkCookie name value maybePath maybeDomain maybeMaxAge secure = Cookie { cookieName = name, cookieValue = value, cookieVersion = 1, cookiePath = maybePath, cookieDomain = maybeDomain, cookieMaxAge = maybeMaxAge, cookieSecure = secure, cookieComment = Nothing } mkUnsetCookie :: String -> Cookie mkUnsetCookie name = Cookie { cookieName = name, cookieValue = "", cookieVersion = 1, cookiePath = Nothing, cookieDomain = Nothing, cookieMaxAge = Just 0, cookieSecure = False, cookieComment = Nothing } requireValidCookieName :: (MonadFastCGI m) => String -> m () requireValidCookieName name = do let valid = (length name > 0) && (all validCharacter name) validCharacter c = (ord c > 0) && (ord c < 128) && (not $ elem c "()<>@,;:\\\"/[]?={} \t") if not valid then fThrow $ CookieNameInvalid name else return () -- | An exception originating within the FastCGI infrastructure or the web server. data FastCGIException = ResponseHeadersAlreadySent -- ^ An exception thrown by operations which require the response headers not -- to have been sent yet. | OutputAlreadyClosed -- ^ An exception thrown by operations which produce output when output has -- been closed, as by 'fCloseOutput'. | NotAResponseHeader Header -- ^ An exception thrown by operations which are given a header that does not -- meet their requirement of being valid in a response. | CookieNameInvalid String -- ^ An exception thrown by operations which are given cookie names that do not -- meet the appropriate syntax requirements. deriving (Show, Typeable) instance Exception.Exception FastCGIException -- | Sets the HTTP/1.1 return status to 301 and sets the 'HttpLocation' header to -- the provided URL. This has the effect of issuing a permanent redirect to the -- user agent. Permanent redirects, as opposed to temporary redirects, may cause -- bookmarks or incoming links to be updated. If the response headers have already -- been sent, causes a 'ResponseHeadersAlreadySent' exception. permanentRedirect :: (MonadFastCGI m) => String -- ^ The URL to redirect to, as a string. -> m () permanentRedirect url = do setResponseStatus 301 setResponseHeader HttpLocation url -- | Sets the HTTP/1.1 return status to 303 and sets the 'HttpLocation' header to -- the provided URL. This has the effect of issuing a see-other or "temporary" -- redirect to the user agent. Temporary redirects, as opposed to permanent redirects, -- do not cause bookmarks or incoming links to be updated. If the response headers -- have already been sent, causes a 'ResponseHeadersAlreadySent' exception. seeOtherRedirect :: (MonadFastCGI m) => String -- ^ The URL to redirect to, as a string. -> m () seeOtherRedirect url = do setResponseStatus 303 setResponseHeader HttpLocation url -- | Ensures that the response headers have been sent. If they are already sent, does -- nothing. If output has already been closed, causes an 'OutputAlreadyClosed' -- exception. sendResponseHeaders :: (MonadFastCGI m) => m () sendResponseHeaders = do requireOutputNotYetClosed FastCGIState { request = Just request } <- getFastCGIState alreadySent <- liftIO $ takeMVar $ responseHeadersSentMVar request if not alreadySent then do responseStatus <- liftIO $ readMVar $ responseStatusMVar request responseHeaderMap <- liftIO $ readMVar $ responseHeaderMapMVar request responseCookieMap <- liftIO $ readMVar $ responseCookieMapMVar request fLog $ show responseCookieMap let nameValuePairs = [("Status", (show responseStatus))] ++ (map (\key -> (fromHeader key, fromJust $ Map.lookup key responseHeaderMap)) $ Map.keys responseHeaderMap) ++ (if (isNothing $ Map.lookup HttpSetCookie responseHeaderMap) && (length (Map.elems responseCookieMap) > 0) then [("Set-Cookie", setCookieValue)] else []) setCookieValue = printCookies $ Map.elems responseCookieMap bytestrings = (map (\(name, value) -> BS.fromString $ name ++ ": " ++ value ++ "\r\n") nameValuePairs) ++ [BS.fromString "\r\n"] buffer = foldl BS.append BS.empty bytestrings sendBuffer buffer else return () liftIO $ putMVar (responseHeadersSentMVar request) True -- | Returns whether the response headers have been sent. responseHeadersSent :: (MonadFastCGI m) => m Bool responseHeadersSent = do FastCGIState { request = Just request } <- getFastCGIState liftIO $ readMVar $ responseHeadersSentMVar request -- | Sends data. This is the content data of the HTTP response. If the response -- headers have not been sent, first sends them. If output has already been closed, -- causes an 'OutputAlreadyClosed' exception. fPut :: (MonadFastCGI m) => BS.ByteString -> m () fPut buffer = do requireOutputNotYetClosed sendResponseHeaders sendBuffer buffer return () -- | Sends text, encoded as UTF-8. This is the content data of the HTTP response. -- if the response headers have not been sent, first sends them. If output has -- already been closed, causes an 'OutputAlreadyClosed' exception. fPutStr :: (MonadFastCGI m) => String -> m () fPutStr string = fPut $ BS.fromString string -- | Informs the web server and the user agent that the request has completed. As -- a side-effect, any unread input is discarded and no more can be read. This is -- implicitly called, if it has not already been, after the handler returns; it -- may be useful within a handler if the handler wishes to return results and then -- perform time-consuming computations before exiting. If output has already been -- closed, causes an 'OutputAlreadyClosed' exception. fCloseOutput :: (MonadFastCGI m) => m () fCloseOutput = do requireOutputNotYetClosed terminateRequest -- | Returns whether it is possible to write more data; ie, whether output has not -- yet been closed as by 'fCloseOutput'. fIsWritable :: (MonadFastCGI m) => m Bool fIsWritable = do FastCGIState { request = Just request } <- getFastCGIState requestEnded <- liftIO $ readMVar $ requestEndedMVar request return $ not requestEnded sendBuffer :: (MonadFastCGI m) => BS.ByteString -> m () sendBuffer buffer = do let length = BS.length buffer lengthThisRecord = minimum [length, 0xFFFF] bufferThisRecord = BS.take lengthThisRecord buffer bufferRemaining = BS.drop lengthThisRecord buffer if lengthThisRecord > 0 then do FastCGIState { request = Just request } <- getFastCGIState sendRecord $ Record { recordType = StdoutRecord, recordRequestID = requestID request, recordContent = bufferThisRecord } else return () if length > lengthThisRecord then sendBuffer bufferRemaining else return () terminateRequest :: (MonadFastCGI m) => m () terminateRequest = do FastCGIState { request = Just request } <- getFastCGIState sendRecord $ Record { recordType = EndRequestRecord, recordRequestID = requestID request, recordContent = BS.pack [0, 0, 0, 0, 0, 0, 0, 0] } requireResponseHeadersNotYetSent :: (MonadFastCGI m) => m () requireResponseHeadersNotYetSent = do FastCGIState { request = Just request } <- getFastCGIState alreadySent <- liftIO $ readMVar $ responseHeadersSentMVar request if alreadySent then fThrow ResponseHeadersAlreadySent else return () requireOutputNotYetClosed :: (MonadFastCGI m) => m () requireOutputNotYetClosed = do FastCGIState { request = Just request } <- getFastCGIState requestEnded <- liftIO $ readMVar $ requestEndedMVar request if requestEnded then fThrow OutputAlreadyClosed else return () -- | Throw an exception in any 'MonadFastCGI' monad. fThrow :: (Exception.Exception e, MonadFastCGI m) => e -- ^ The exception to throw. -> m a fThrow exception = implementationThrowFastCGI exception -- | Perform an action, with a given exception-handler action bound. See -- 'Control.Exception.catch'. The type of exception to catch is determined by the -- type signature of the handler. fCatch :: (Exception.Exception e, MonadFastCGI m) => m a -- ^ The action to run with the exception handler binding in scope. -> (e -> m a) -- ^ The exception handler to bind. -> m a fCatch action handler = implementationCatchFastCGI action handler -- | Block exceptions within an action, as per the discussion in 'Control.Exception'. fBlock :: (MonadFastCGI m) => m a -- ^ The action to run with exceptions blocked. -> m a fBlock action = implementationBlockFastCGI action -- | Unblock exceptions within an action, as per the discussion in 'Control.Exception'. fUnblock :: (MonadFastCGI m) => m a -- ^ The action to run with exceptions unblocked. -> m a fUnblock action = implementationUnblockFastCGI action -- | Acquire a resource, perform computation with it, and release it; see the description -- of 'Control.Exception.bracket'. If an exception is raised during the computation, -- 'fBracket' will re-raise it after running the release function, having the effect -- of propagating the exception further up the call stack. fBracket :: (MonadFastCGI m) => m a -- ^ The action to acquire the resource. -> (a -> m b) -- ^ The action to release the resource. -> (a -> m c) -- ^ The action to perform using the resource. -> m c -- ^ The return value of the perform-action. fBracket acquire release perform = do fBlock (do resource <- acquire result <- fUnblock (perform resource) `fOnException` (release resource) release resource return result) -- | Perform an action, with a cleanup action bound to always occur; see the -- description of 'Control.Exception.finally'. If an exception is raised during the -- computation, 'fFinally' will re-raise it after running the cleanup action, having -- the effect of propagating the exception further up the call stack. If no -- exception is raised, the cleanup action will be invoked after the main action is -- performed. fFinally :: (MonadFastCGI m) => m a -- ^ The action to perform. -> m b -- ^ The cleanup action. -> m a -- ^ The return value of the perform-action. fFinally perform cleanup = do fBlock (do result <- fUnblock perform `fOnException` cleanup cleanup return result) -- | Perform an action. If any exceptions of the appropriate type occur within the -- action, return 'Left' @exception@; otherwise, return 'Right' @result@. fTry :: (Exception.Exception e, MonadFastCGI m) => m a -- ^ The action to perform. -> m (Either e a) fTry action = do fCatch (do result <- action return $ Right result) (\exception -> return $ Left exception) -- | As 'fCatch', but with the arguments in the other order. fHandle :: (Exception.Exception e, MonadFastCGI m) => (e -> m a) -- ^ The exception handler to bind. -> m a -- ^ The action to run with the exception handler binding in scope. -> m a fHandle handler action = fCatch action handler -- | Perform an action, with a cleanup action bound to occur if and only if an exception -- is raised during the action; see the description of 'Control.Exception.finally'. -- If an exception is raised during the computation, 'fFinally' will re-raise it -- after running the cleanup action, having the effect of propagating the exception -- further up the call stack. If no exception is raised, the cleanup action will not -- be invoked. fOnException :: (MonadFastCGI m) => m a -- ^ The action to perform. -> m b -- ^ The cleanup action. -> m a -- ^ The return value of the perform-action. fOnException action cleanup = do fCatch action (\exception -> do cleanup fThrow (exception :: Exception.SomeException))