{-# LANGUAGE TypeSynonymInstances, DeriveDataTypeable #-}
module Network.FastCGI (
-- * The monad
FastCGI,
MonadFastCGI,
FastCGIState,
getFastCGIState,
-- * 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))