{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, FlexibleContexts,
DeriveDataTypeable #-}
-- | This module provides facilities for implementing webservers, in a
-- servelet-like style. The general philosophy is that direct-http makes
-- as few decisions as possible for the user code, allowing such things as
-- URL routing and virtual-host policies to be implemented in any desired
-- fashion. It focuses on providing a robust transport layer which can
-- integrate well with any higher layer.
module Network.HTTP (
-- * The monad
HTTP,
HTTPState,
MonadHTTP(..),
-- * Accepting requests
HTTPServerParameters(..),
HTTPListenSocketParameters(..),
acceptLoop,
-- * Logging
httpLog,
-- * Concurrency
httpFork,
-- * Exceptions
HTTPException(..),
-- * 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. One might therefore expect to see
-- functions defined here allowing direct interrogation of
-- variables and headers by name. This is not done, because it
-- is not the primary goal of direct-http to be a CGI/FastCGI
-- host, and that functionality is trivial for any user code
-- implementing such a host to provide. It would actually be
-- rather more difficult for direct-http to provide many of the
-- common values, because it does not implement the facilities
-- they are supposed to give information about. Even as simple
-- a concept as "what server address is this" must take into
-- account name-canonicalization and virtual-host policies,
-- which are left to user code. As for document root, it is
-- possible to implement a server with no capacity to serve
-- files, in which case the concept is nonsensical. Enough
-- important values are necessarily absent for reasons such as
-- these that there is little reason to provide the remaining
-- ones either.
--
-- Too long, didn't read? Instead of providing access to
-- CGI-like variables, direct-http provides higher-level calls
-- which give convenient names and types to the same
-- information. It does provide access to headers, however.
--
-- Cookies may also be manipulated through HTTP headers
-- directly; the functions here are provided only as a
-- convenience.
Header(..),
getRequestHeader,
getAllRequestHeaders,
Cookie(..),
getCookie,
getAllCookies,
getCookieValue,
getRemoteAddress,
getRequestMethod,
getRequestURI,
getServerAddress,
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.
httpGet,
httpGetNonBlocking,
httpGetContents,
httpIsReadable,
-- * 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,
responseHeadersModifiable,
httpPut,
httpPutStr,
httpCloseOutput,
httpIsWritable
)
where
import Control.Concurrent.Lifted
import Control.Concurrent.MSem (MSem)
import qualified Control.Concurrent.MSem as MSem
import Control.Exception.Lifted
import Control.Monad.Base
import Control.Monad.Reader
import Control.Monad.Trans.Control
import Data.Bits
import Data.ByteString (ByteString)
import qualified Data.ByteString as BS
import qualified Data.ByteString.UTF8 as UTF8
import Data.Char
import Data.List
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Maybe
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Time
import Data.Time.Clock.POSIX
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 Numeric
import Prelude hiding (catch)
import System.Daemonize
import System.Environment
import System.Exit
import System.IO
import System.IO.Error (ioeGetErrorType)
import qualified System.IO.Error as System
import System.Locale (defaultTimeLocale)
import qualified System.Posix as POSIX
-- | An opaque type representing the state of the HTTP server during a single
-- connection from a client.
data HTTPState = HTTPState {
httpStateAccessLogMaybeHandleMVar :: MVar (Maybe Handle),
httpStateErrorLogMaybeHandleMVar :: MVar (Maybe Handle),
httpStateForkPrimitive :: IO () -> IO ThreadId,
httpStateThreadSetMVar :: MVar (Set ThreadId),
httpStateThreadTerminationMSem :: MSem Word,
httpStateMaybeConnection :: Maybe HTTPConnection
}
data HTTPConnection = HTTPConnection {
httpConnectionServerAddress :: Network.SockAddr,
httpConnectionSocket :: Network.Socket,
httpConnectionPeer :: Network.SockAddr,
httpConnectionInputBufferMVar :: MVar ByteString,
httpConnectionTimestamp :: MVar POSIXTime,
httpConnectionRemoteHostname :: MVar (Maybe (Maybe String)),
httpConnectionRequestMethod :: MVar String,
httpConnectionRequestURI :: MVar String,
httpConnectionRequestProtocol :: MVar String,
httpConnectionRequestHeaderMap :: MVar (Map Header ByteString),
httpConnectionRequestCookieMap :: MVar (Maybe (Map String Cookie)),
httpConnectionRequestContentBuffer :: MVar ByteString,
httpConnectionRequestContentParameters :: MVar RequestContentParameters,
httpConnectionResponseHeadersSent :: MVar Bool,
httpConnectionResponseHeadersModifiable :: MVar Bool,
httpConnectionResponseStatus :: MVar Int,
httpConnectionResponseHeaderMap :: MVar (Map Header ByteString),
httpConnectionResponseCookieMap :: MVar (Map String Cookie),
httpConnectionResponseContentBuffer :: MVar ByteString,
httpConnectionResponseContentParameters :: MVar ResponseContentParameters
}
data RequestContentParameters
= RequestContentUninitialized
| RequestContentNone
| RequestContentClosed
| RequestContentIdentity Int
| RequestContentChunked Int
data ResponseContentParameters
= ResponseContentUninitialized
| ResponseContentClosed
| ResponseContentBufferedIdentity
| ResponseContentUnbufferedIdentity Int
| ResponseContentChunked
deriving (Show)
-- | An object representing a cookie (a small piece of information, mostly
-- metadata, stored by a user-agent on behalf of the server), either one
-- received as part of the request or one to be sent as part of the
-- response.
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)
data ConnectionTerminatingError = UnexpectedEndOfInput
deriving (Typeable)
instance Exception ConnectionTerminatingError
instance Show ConnectionTerminatingError where
show UnexpectedEndOfInput = "Unexpected end of input."
-- | The monad within which each single request from a client is handled.
--
-- Note that there is an instance 'MonadBaseControl' 'IO' 'HTTP', so that
-- exceptions can be thrown, caught, and otherwise manipulated with the
-- lifted primitives from lifted-base's 'Control.Exception.Lifted'.
type HTTP = ReaderT HTTPState IO
-- | The class of monads within which the HTTP calls are valid. You may wish
-- to create your own monad implementing this class. Note that the
-- prerequisite is 'MonadBaseControl' 'IO' m, which is similar to
-- 'MonadIO' m, but with, among other things, more capability for
-- exception handling.
class (MonadBaseControl IO m) => MonadHTTP m where
-- | Returns the opaque 'HTTPState' object representing the state of
-- the HTTP server.
-- Should not be called directly by user code, except implementations of
-- 'MonadHTTP'; exported so that
-- user monads can implement the interface.
getHTTPState :: m HTTPState
instance MonadHTTP HTTP where
getHTTPState = ask
getHTTPConnection :: (MonadHTTP m) => m HTTPConnection
getHTTPConnection = do
state <- getHTTPState
case httpStateMaybeConnection state of
Nothing -> throwIO NoConnection
Just connection -> return connection
-- | Forks a thread to run the given action, using the forking primitive that
-- was passed in the configuration to 'acceptLoop', and additionally
-- registers that thread with the main server thread, which has the sole
-- effect and purpose of causing the server to not exit until and unless the
-- child thread does. All of the listener-socket and connection threads
-- created by the server go through this function.
httpFork :: (MonadHTTP m) => m () -> m ThreadId
httpFork action = do
state <- getHTTPState
let mvar = httpStateThreadSetMVar state
msem = httpStateThreadTerminationMSem state
modifyMVar mvar $ \threadSet -> do
childThread <- liftBaseDiscard (httpStateForkPrimitive state)
$ finally action
(do
modifyMVar_ mvar $ \threadSet -> do
self <- myThreadId
let threadSet' = Set.delete self threadSet'
return threadSet'
liftBase $ MSem.signal msem)
let threadSet' = Set.insert childThread threadSet
return (threadSet', childThread)
-- | A record used to configure the server. Broken informally into the four
-- categories of logging, job-control, concurrency, and networking. For
-- logging, the configuration contains optional paths to files for the
-- access and error logs (if these are omitted, logging is not done). For
-- job-control, it contains a flag indicating whether to run as a daemon,
-- and optionally the names of a Unix user and/or group to switch to in the
-- process of daemonization. For concurrency, it contains a forking
-- primitive such as 'forkIO' or 'forkOS'. Finally, for networking, it
-- contains a list of parameters for ports to listen on, each of which has
-- its own sub-configuration record.
--
-- Notice that checking the value of the Host: header, and implementing
-- virtual-host policies, is not done by direct-http but rather is up to the
-- user of the library; hence, there is no information in the configuration
-- about the hostnames to accept from the user-agent.
--
-- If the access logfile path is not Nothing, 'acceptLoop' opens this
-- logfile in append mode and uses it to log all accesses; otherwise, access
-- is not logged.
--
-- If the error logfile path is not Nothing, 'acceptLoop' opens this logfile
-- in append mode and uses it to log all errors; otherwise, if not
-- daemonizing, errors are logged to standard output; if daemonizing, errors
-- are not logged.
--
-- If the daemonize flag is True, 'acceptLoop' closes the standard IO
-- streams and moves the process into the background, doing all the usual
-- Unix things to make it run as a daemon henceforth. This is optional
-- because it might be useful to turn it off for debugging purposes.
--
-- The forking primitive is typically either 'forkIO' or 'forkOS', and is
-- used by 'acceptLoop' both to create listener threads, and to create
-- connection threads. It is valid to use a custom primitive, such as one
-- that attempts to pool OS threads, but it must actually provide
-- concurrency - otherwise there will be a deadlock. There is no support for
-- single-threaded operation.
--
-- Notice that we take the forking primitive in terms of 'IO', even though
-- we actually lift it (with 'liftBaseDiscard'). This is because
-- lifted-base, as of this writing and its version 0.1.1, only supports
-- 'forkIO' and not 'forkOS'.
--
-- The loop never returns, but will terminate the program with status 0 if
-- and when it ever has no child threads alive; child threads for this
-- purpose are those created through 'httpFork', which means all
-- listener-socket and connection threads created by 'acceptLoop', as well
-- as any threads created by client code through 'httpFork', but not threads
-- created by client code through other mechanisms.
--
-- The author of direct-http has made no effort to implement custom
-- thread-pooling forking primitives, but has attempted not to preclude
-- them. If anyone attempts to implement such a thing, feedback is hereby
-- solicited.
data HTTPServerParameters = HTTPServerParameters {
serverParametersAccessLogPath :: Maybe FilePath,
serverParametersErrorLogPath :: Maybe FilePath,
serverParametersDaemonize :: Bool,
serverParametersUserToChangeTo :: Maybe String,
serverParametersGroupToChangeTo :: Maybe String,
serverParametersForkPrimitive :: IO () -> IO ThreadId,
serverParametersListenSockets :: [HTTPListenSocketParameters]
}
-- | A record used to configure an individual port listener and its socket as
-- part of the general server configuration. Consists of a host address and
-- port number to bind the socket to, and a flag indicating whether the
-- listener should use the secure version of the protocol.
data HTTPListenSocketParameters = HTTPListenSocketParameters {
listenSocketParametersAddress :: Network.SockAddr,
listenSocketParametersSecure :: Bool
}
-- | Takes a server parameters record and a handler, and concurrently accepts
-- requests from user agents, forking with the primitive specified by the
-- parameters and invoking the handler in the forked thread inside the
-- 'HTTP' monad for each request.
--
-- Note that although there is no mechanism to substitute another type of
-- monad for HTTP, 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 'MonadHTTP' class.
--
-- Any exceptions not caught within the handler are caught by
-- 'acceptLoop', and cause the termination of that handler, but not
-- of the connection or the accept loop.
acceptLoop
:: HTTPServerParameters
-- ^ Parameters describing the behavior of the server to run.
-> (HTTP ())
-- ^ A handler which is invoked once for each incoming connection.
-> IO ()
-- ^ Never actually returns.
acceptLoop parameters handler = do
if serverParametersDaemonize parameters
then daemonize (defaultDaemonOptions {
daemonUserToChangeTo =
serverParametersUserToChangeTo parameters,
daemonGroupToChangeTo =
serverParametersGroupToChangeTo parameters
})
(initialize)
(\bootstrap -> acceptLoop' bootstrap)
else do
bootstrap <- initialize
acceptLoop' bootstrap
where initialize = do
accessLogMaybeHandle
<- case serverParametersAccessLogPath parameters of
Nothing -> return Nothing
Just path -> liftBase $ openBinaryFile path AppendMode
>>= return . Just
errorLogMaybeHandle
<- case serverParametersErrorLogPath parameters of
Nothing -> if serverParametersDaemonize parameters
then return Nothing
else return $ Just stdout
Just path -> liftBase $ openBinaryFile path AppendMode
>>= return . Just
listenSockets <-
catch (mapM createListenSocket
(serverParametersListenSockets parameters))
(\e -> do
case errorLogMaybeHandle of
Nothing -> return ()
Just errorLogHandle -> do
hPutStrLn errorLogHandle $
"Failed to start: " ++ (show (e :: SomeException))
liftBase $ exitFailure)
return (listenSockets, accessLogMaybeHandle, errorLogMaybeHandle)
acceptLoop' (listenSockets,
accessLogMaybeHandle,
errorLogMaybeHandle) = do
accessLogMaybeHandleMVar <- newMVar accessLogMaybeHandle
errorLogMaybeHandleMVar <- newMVar errorLogMaybeHandle
let forkPrimitive = serverParametersForkPrimitive parameters
threadSetMVar <- newMVar Set.empty
threadTerminationMSem <- MSem.new 0
let state = HTTPState {
httpStateAccessLogMaybeHandleMVar =
accessLogMaybeHandleMVar,
httpStateErrorLogMaybeHandleMVar =
errorLogMaybeHandleMVar,
httpStateForkPrimitive = forkPrimitive,
httpStateThreadSetMVar = threadSetMVar,
httpStateThreadTerminationMSem = threadTerminationMSem,
httpStateMaybeConnection = Nothing
}
flip runReaderT state $ do
httpLog $ "Server started."
threadIDs <-
mapM (\listenSocket -> httpFork $ acceptLoop'' listenSocket)
listenSockets
threadWaitLoop
acceptLoop'' :: Network.Socket -> HTTP ()
acceptLoop'' listenSocket = do
(socket, peer) <- liftBase $ Network.accept listenSocket
httpFork $ requestLoop socket peer handler
acceptLoop'' listenSocket
threadWaitLoop = do
state <- getHTTPState
let mvar = httpStateThreadSetMVar state
msem = httpStateThreadTerminationMSem state
threadSet <- readMVar mvar
if Set.null threadSet
then liftBase exitSuccess
else do
liftBase $ MSem.wait msem
threadWaitLoop
createListenSocket
:: HTTPListenSocketParameters -> IO Network.Socket
createListenSocket parameters = do
let address = listenSocketParametersAddress parameters
addressFamily =
case address of
Network.SockAddrInet _ _ -> Network.AF_INET
Network.SockAddrInet6 _ _ _ _ -> Network.AF_INET6
Network.SockAddrUnix _ -> Network.AF_UNIX
listenSocket <- liftBase $ Network.socket addressFamily
Network.Stream
Network.defaultProtocol
liftBase $ Network.bind listenSocket address
liftBase $ Network.listen listenSocket 1024
return listenSocket
requestLoop :: Network.Socket
-> Network.SockAddr
-> HTTP ()
-> HTTP ()
requestLoop socket peer handler = do
serverAddress <- liftBase $ Network.getSocketName socket
inputBufferMVar <- newMVar $ BS.empty
timestampMVar <- newEmptyMVar
remoteHostnameMVar <- newMVar Nothing
requestMethodMVar <- newEmptyMVar
requestURIMVar <- newEmptyMVar
requestProtocolMVar <- newEmptyMVar
requestHeaderMapMVar <- newEmptyMVar
requestCookieMapMVar <- newEmptyMVar
requestContentBufferMVar <- newEmptyMVar
requestContentParametersMVar <- newEmptyMVar
responseHeadersSentMVar <- newEmptyMVar
responseHeadersModifiableMVar <- newEmptyMVar
responseStatusMVar <- newEmptyMVar
responseHeaderMapMVar <- newEmptyMVar
responseCookieMapMVar <- newEmptyMVar
responseContentBufferMVar <- newEmptyMVar
responseContentParametersMVar <- newEmptyMVar
let connection = HTTPConnection {
httpConnectionServerAddress = serverAddress,
httpConnectionSocket = socket,
httpConnectionPeer = peer,
httpConnectionInputBufferMVar = inputBufferMVar,
httpConnectionTimestamp = timestampMVar,
httpConnectionRemoteHostname = remoteHostnameMVar,
httpConnectionRequestMethod = requestMethodMVar,
httpConnectionRequestURI = requestURIMVar,
httpConnectionRequestProtocol = requestProtocolMVar,
httpConnectionRequestHeaderMap = requestHeaderMapMVar,
httpConnectionRequestCookieMap = requestCookieMapMVar,
httpConnectionRequestContentBuffer
= requestContentBufferMVar,
httpConnectionRequestContentParameters
= requestContentParametersMVar,
httpConnectionResponseHeadersSent
= responseHeadersSentMVar,
httpConnectionResponseHeadersModifiable
= responseHeadersModifiableMVar,
httpConnectionResponseStatus = responseStatusMVar,
httpConnectionResponseHeaderMap = responseHeaderMapMVar,
httpConnectionResponseCookieMap = responseCookieMapMVar,
httpConnectionResponseContentBuffer
= responseContentBufferMVar,
httpConnectionResponseContentParameters
= responseContentParametersMVar
}
requestLoop1 :: HTTP ()
requestLoop1 = do
finally requestLoop2
(catch (liftBase $ Network.sClose socket)
(\error -> do
return (error :: IOException)
return ()))
requestLoop2 :: HTTP ()
requestLoop2 = do
catch requestLoop3
(\error -> do
httpLog $ "Internal uncaught exception: "
++ (show (error :: SomeException)))
requestLoop3 :: HTTP ()
requestLoop3 = do
catch requestLoop4
(\error -> do
connection <- getHTTPConnection
httpLog $ "Connection from "
++ (show $ httpConnectionPeer connection)
++ " terminated due to error: "
++ (show (error :: ConnectionTerminatingError)))
requestLoop4 :: HTTP ()
requestLoop4 = do
maybeRequestInfo <- recvHeaders
case maybeRequestInfo of
Nothing -> return ()
Just (method, url, protocol, headers) -> do
timestamp <- liftBase getPOSIXTime
putMVar timestampMVar timestamp
putMVar requestMethodMVar $ UTF8.toString method
putMVar requestURIMVar $ UTF8.toString url
putMVar requestProtocolMVar $ UTF8.toString protocol
putMVar requestHeaderMapMVar headers
putMVar requestCookieMapMVar Nothing
putMVar requestContentBufferMVar BS.empty
putMVar requestContentParametersMVar RequestContentUninitialized
putMVar responseHeadersSentMVar False
putMVar responseHeadersModifiableMVar True
putMVar responseStatusMVar 200
putMVar responseHeaderMapMVar Map.empty
putMVar responseCookieMapMVar Map.empty
putMVar responseContentBufferMVar BS.empty
putMVar responseContentParametersMVar ResponseContentUninitialized
catch
(do
valid <- getRequestValid
if valid
then do
prepareResponse
handler
else do
setResponseStatus 400)
(\error -> do
httpLog $ "Uncaught exception: "
++ (show (error :: SomeException))
alreadySent <- responseHeadersSent
if alreadySent
then return ()
else setResponseStatus 500)
logAccess
isWritable <- httpIsWritable
if isWritable
then httpCloseOutput
else return ()
connectionShouldStayAlive <- getConnectionShouldStayAlive
if connectionShouldStayAlive
then do
takeMVar timestampMVar
takeMVar requestMethodMVar
takeMVar requestURIMVar
takeMVar requestProtocolMVar
takeMVar requestHeaderMapMVar
takeMVar requestCookieMapMVar
takeMVar requestContentBufferMVar
takeMVar requestContentParametersMVar
takeMVar responseHeadersSentMVar
takeMVar responseHeadersModifiableMVar
takeMVar responseStatusMVar
takeMVar responseHeaderMapMVar
takeMVar responseCookieMapMVar
takeMVar responseContentBufferMVar
takeMVar responseContentParametersMVar
requestLoop4
else return ()
state <- ask
lift $ flip runReaderT
(state { httpStateMaybeConnection = Just connection })
requestLoop1
getRequestValid :: (MonadHTTP m) => m Bool
getRequestValid = do
hasContent <- getRequestHasContent
let getHeadersValid = do
connection <- getHTTPConnection
headerMap <- readMVar $ httpConnectionRequestHeaderMap connection
foldM (\result header -> do
if isValidInRequest header
then return result
else do
if hasContent
then return result
else if not $ isValidOnlyWithEntity header
then return result
else do
httpLog $ "Header " ++ (show header)
++ " is valid only with an entity."
return False)
True
(Map.keys headerMap)
getContentValid = do
contentAllowed <- getRequestContentAllowed
if contentAllowed
then return True
else if not hasContent
then return True
else do
method <- getRequestMethod
httpLog $ "Content provided but not allowed with "
++ method ++ "."
return False
httpVersion <- getRequestProtocol
case httpVersion of
"HTTP/1.0" -> do
headersValid <- getHeadersValid
contentValid <- getContentValid
return $ and [headersValid, contentValid]
"HTTP/1.1" -> do
headersValid <- getHeadersValid
contentValid <- getContentValid
mandatoryHeadersIncluded <- do
maybeHost <- getRequestHeader HttpHost
case maybeHost of
Just _ -> return True
Nothing -> do
httpLog $ "Host header not provided and HTTP/1.1 used."
return False
return $ and [headersValid, mandatoryHeadersIncluded, contentValid]
_ -> return False
getConnectionShouldStayAlive :: (MonadHTTP m) => m Bool
getConnectionShouldStayAlive = do
httpVersion <- getRequestProtocol
case httpVersion of
"HTTP/1.0" -> return False
"HTTP/1.1" -> do
maybeConnection <- getRequestHeader HttpConnection
case maybeConnection of
Nothing -> return True
Just connectionValue -> do
let connectionWords = computeWords connectionValue
computeWords input =
let (before, after) = break (\c -> c == ' ') input
in if null after
then [before]
else let rest = computeWords $ drop 1 after
in before : rest
connectionTokens = map (map toLower) connectionWords
closeSpecified = elem "close" connectionTokens
return $ not closeSpecified
_ -> return False
prepareResponse :: (MonadHTTP m) => m ()
prepareResponse = do
HTTPConnection { httpConnectionTimestamp = mvar } <- getHTTPConnection
timestamp <- readMVar mvar
let dateString = formatTime defaultTimeLocale
"%a, %d %b %Y %H:%M:%S Z"
$ posixSecondsToUTCTime timestamp
setResponseHeader HttpDate dateString
setResponseHeader HttpContentType "text/html; charset=UTF8"
logAccess :: (MonadHTTP m) => m ()
logAccess = do
remoteHost <- getRemoteHost
identString <- return "-"
usernameString <- return "-"
connection <- getHTTPConnection
timestamp <- readMVar (httpConnectionTimestamp connection)
let timestampString = formatTime defaultTimeLocale
"%-d/%b/%Y:%H:%M:%S %z"
$ posixSecondsToUTCTime timestamp
methodString <- getRequestMethod
urlString <- getRequestURI
protocolString <- getRequestProtocol
responseStatusString <- getResponseStatus >>= return . show
maybeResponseSize <- return (Nothing :: Maybe Int) -- TODO
responseSizeString
<- case maybeResponseSize of
Nothing -> return "-"
Just responseSize -> return $ show responseSize
maybeReferrerString <- getRequestHeader HttpReferrer
referrerString <- case maybeReferrerString of
Nothing -> return "-"
Just referrerString -> return referrerString
maybeUserAgentString <- getRequestHeader HttpUserAgent
userAgentString <- case maybeUserAgentString of
Nothing -> return "-"
Just userAgentString -> return userAgentString
httpAccessLog $ remoteHost
++ " "
++ identString
++ " "
++ usernameString
++ " ["
++ timestampString
++ "] \""
++ methodString
++ " "
++ urlString
++ " "
++ protocolString
++ "\" "
++ responseStatusString
++ " "
++ responseSizeString
++ " \""
++ referrerString
++ "\" \""
++ userAgentString
++ "\""
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] -> ByteString
printCookies cookies =
let printCookie cookie
= BS.intercalate (UTF8.fromString ";")
$ map printNameValuePair $ nameValuePairs cookie
printNameValuePair (name, Nothing) = UTF8.fromString name
printNameValuePair (name, Just value)
= BS.concat [UTF8.fromString name,
UTF8.fromString "=",
UTF8.fromString value]
{- Safari doesn't like this.
= if isValidCookieToken value
then name ++ "=" ++ value
else 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 $ path)])
++ (case cookieSecure cookie of
False -> []
True -> [("Secure", Nothing)])
++ [("Version", Just $ show $ cookieVersion cookie)]
in BS.intercalate (UTF8.fromString ",") $ map printCookie cookies
parseInt :: String -> Maybe Int
parseInt string =
if (not $ null string) && (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
recvHeaders :: (MonadHTTP m)
=> m (Maybe (ByteString,
ByteString,
ByteString,
Map Header ByteString))
recvHeaders = do
HTTPConnection { httpConnectionInputBufferMVar = inputBufferMVar }
<- getHTTPConnection
modifyMVar inputBufferMVar $ \inputBuffer -> do
(inputBuffer, maybeLine) <- recvLine inputBuffer
(inputBuffer, result) <- case maybeLine of
Nothing -> return (inputBuffer, Nothing)
Just line -> do
let computeWords input =
let (before, after) = BS.breakSubstring (UTF8.fromString " ") input
in if BS.null after
then [before]
else let rest = computeWords $ BS.drop 1 after
in before : rest
words = computeWords line
case words of
[method, url, protocol]
| (isValidMethod method)
&& (isValidURL url)
&& (isValidProtocol protocol)
-> do
let loop inputBuffer headersSoFar = do
(inputBuffer, maybeLine) <- recvLine inputBuffer
case maybeLine of
Nothing -> return (inputBuffer, Nothing)
Just line
| BS.null line -> do
return (inputBuffer,
Just (method, url, protocol, headersSoFar))
| otherwise -> do
case parseHeader line of
Nothing -> do
logInvalidRequest
return (inputBuffer, Nothing)
Just (header, value) -> do
let headersSoFar'
= case Map.lookup header headersSoFar of
Nothing -> Map.insert header
value
headersSoFar
Just oldValue
-> Map.insert
header
(BS.concat [oldValue,
(UTF8.fromString ","),
value])
headersSoFar
loop inputBuffer headersSoFar'
loop inputBuffer Map.empty
_ -> do
logInvalidRequest
return (inputBuffer, Nothing)
return (inputBuffer, result)
parseHeader :: ByteString -> Maybe (Header, ByteString)
parseHeader line = do
case BS.breakSubstring (UTF8.fromString ":") line of
(_, bytestring) | bytestring == BS.empty -> Nothing
(name, delimitedValue) -> Just (toHeader name, BS.drop 1 delimitedValue)
logInvalidRequest :: MonadHTTP m => m ()
logInvalidRequest = do
connection <- getHTTPConnection
httpLog $ "Invalid request from "
++ (show $ httpConnectionPeer connection)
++ "; closing its connection."
isValidMethod :: ByteString -> Bool
isValidMethod bytestring
| bytestring == UTF8.fromString "OPTIONS" = True
| bytestring == UTF8.fromString "GET" = True
| bytestring == UTF8.fromString "HEAD" = True
| bytestring == UTF8.fromString "POST" = True
| bytestring == UTF8.fromString "PUT" = True
| bytestring == UTF8.fromString "DELETE" = True
| bytestring == UTF8.fromString "TRACE" = True
| bytestring == UTF8.fromString "CONNECT" = True
| otherwise = False
isValidURL :: ByteString -> Bool
isValidURL _ = True
isValidProtocol :: ByteString -> Bool
isValidProtocol bytestring
| bytestring == UTF8.fromString "HTTP/1.0" = True
| bytestring == UTF8.fromString "HTTP/1.1" = True
| otherwise = False
recvLine :: (MonadHTTP m) => ByteString -> m (ByteString, Maybe ByteString)
recvLine inputBuffer = do
let loop inputBuffer length firstIteration = do
let blocking = not firstIteration
(inputBuffer, endOfInput)
<- extendInputBuffer inputBuffer length blocking
let (before, after)
= BS.breakSubstring (UTF8.fromString "\r\n") inputBuffer
if BS.null after
then if endOfInput
then return (inputBuffer, Nothing)
else loop inputBuffer (length + 80) False
else return (BS.drop 2 after, Just before)
let (before, after)
= BS.breakSubstring (UTF8.fromString "\r\n") inputBuffer
if BS.null after
then loop inputBuffer 80 True
else return (BS.drop 2 after, Just before)
recvBlock :: (MonadHTTP m) => Int -> m ByteString
recvBlock length = do
HTTPConnection { httpConnectionInputBufferMVar = inputBufferMVar } <-
getHTTPConnection
modifyMVar inputBufferMVar $ \inputBuffer -> do
(inputBuffer, endOfInput) <- extendInputBuffer inputBuffer length True
(result, inputBuffer) <- return $ BS.splitAt length inputBuffer
return (inputBuffer, result)
extendInputBuffer :: (MonadHTTP m)
=> ByteString -> Int -> Bool -> m (ByteString, Bool)
extendInputBuffer inputBuffer length blocking = do
HTTPConnection { httpConnectionSocket = socket } <- getHTTPConnection
let loop inputBuffer = do
if BS.length inputBuffer < length
then do
newInput <- liftBase $ Network.recv socket 4096
if BS.null newInput
then return (inputBuffer, True)
else if blocking
then loop $ BS.append inputBuffer newInput
else return (BS.append inputBuffer newInput, False)
else return (inputBuffer, False)
loop inputBuffer
-- | Logs a message using the web server's logging facility, prefixed with a
-- timestamp.
httpLog :: (MonadHTTP m) => String -> m ()
httpLog message = do
HTTPState { httpStateErrorLogMaybeHandleMVar = logMVar } <- getHTTPState
bracket (takeMVar logMVar)
(\maybeHandle -> putMVar logMVar maybeHandle)
(\maybeHandle -> do
case maybeHandle of
Nothing -> return ()
Just handle -> do
timestamp <- liftBase $ getPOSIXTime
let timestampString =
formatTime defaultTimeLocale "%Y-%m-%dT%H:%M:%SZ"
$ posixSecondsToUTCTime timestamp
liftBase $ hPutStrLn handle
$ timestampString ++ " " ++ message
liftBase $ hFlush handle)
httpAccessLog :: (MonadHTTP m) => String -> m ()
httpAccessLog message = do
HTTPState { httpStateAccessLogMaybeHandleMVar = logMVar } <- getHTTPState
withMVar logMVar
(\maybeHandle -> case maybeHandle of
Nothing -> return ()
Just handle -> do
liftBase $ hPutStrLn handle message
liftBase $ hFlush handle)
-- | Headers are classified by HTTP/1.1 as request headers, response headers,
-- entity headers, or general headers.
data Header
-- | Request headers
= HttpAccept
| HttpAcceptCharset
| HttpAcceptEncoding
| HttpAcceptLanguage
| HttpAuthorization
| HttpExpect
| HttpFrom
| HttpHost
| HttpIfMatch
| HttpIfModifiedSince
| HttpIfNoneMatch
| HttpIfRange
| HttpIfUnmodifiedSince
| HttpMaxForwards
| HttpProxyAuthorization
| HttpRange
| HttpReferrer
| 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 ByteString
-- | General headers
| HttpCacheControl
| HttpConnection
| HttpDate
| HttpPragma
| HttpTrailer
| HttpTransferEncoding
| HttpUpgrade
| HttpVia
| HttpWarning
-- | Nonstandard headers
| HttpCookie
| HttpSetCookie
deriving (Eq, Ord)
instance Show Header where
show header = UTF8.toString $ fromHeader header
data HeaderType = RequestHeader
| ResponseHeader
| EntityHeader
| GeneralHeader
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 HttpReferrer = 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 _) = GeneralHeader
headerType HttpCacheControl = GeneralHeader
headerType HttpConnection = GeneralHeader
headerType HttpDate = GeneralHeader
headerType HttpPragma = GeneralHeader
headerType HttpTrailer = GeneralHeader
headerType HttpTransferEncoding = GeneralHeader
headerType HttpUpgrade = GeneralHeader
headerType HttpVia = GeneralHeader
headerType HttpWarning = GeneralHeader
headerType HttpCookie = RequestHeader
headerType HttpSetCookie = ResponseHeader
fromHeader :: Header -> ByteString
fromHeader HttpAccept = UTF8.fromString "Accept"
fromHeader HttpAcceptCharset = UTF8.fromString "Accept-Charset"
fromHeader HttpAcceptEncoding = UTF8.fromString "Accept-Encoding"
fromHeader HttpAcceptLanguage = UTF8.fromString "Accept-Language"
fromHeader HttpAuthorization = UTF8.fromString "Authorization"
fromHeader HttpExpect = UTF8.fromString "Expect"
fromHeader HttpFrom = UTF8.fromString "From"
fromHeader HttpHost = UTF8.fromString "Host"
fromHeader HttpIfMatch = UTF8.fromString "If-Match"
fromHeader HttpIfModifiedSince = UTF8.fromString "If-Modified-Since"
fromHeader HttpIfNoneMatch = UTF8.fromString "If-None-Match"
fromHeader HttpIfRange = UTF8.fromString "If-Range"
fromHeader HttpIfUnmodifiedSince = UTF8.fromString "If-Unmodified-Since"
fromHeader HttpMaxForwards = UTF8.fromString "Max-Forwards"
fromHeader HttpProxyAuthorization = UTF8.fromString "Proxy-Authorization"
fromHeader HttpRange = UTF8.fromString "Range"
fromHeader HttpReferrer = UTF8.fromString "Referer"
fromHeader HttpTE = UTF8.fromString "TE"
fromHeader HttpUserAgent = UTF8.fromString "User-Agent"
fromHeader HttpAcceptRanges = UTF8.fromString "Accept-Ranges"
fromHeader HttpAge = UTF8.fromString "Age"
fromHeader HttpETag = UTF8.fromString "ETag"
fromHeader HttpLocation = UTF8.fromString "Location"
fromHeader HttpProxyAuthenticate = UTF8.fromString "Proxy-Authenticate"
fromHeader HttpRetryAfter = UTF8.fromString "Retry-After"
fromHeader HttpServer = UTF8.fromString "Server"
fromHeader HttpVary = UTF8.fromString "Vary"
fromHeader HttpWWWAuthenticate = UTF8.fromString "WWW-Authenticate"
fromHeader HttpAllow = UTF8.fromString "Allow"
fromHeader HttpContentEncoding = UTF8.fromString "Content-Encoding"
fromHeader HttpContentLanguage = UTF8.fromString "Content-Language"
fromHeader HttpContentLength = UTF8.fromString "Content-Length"
fromHeader HttpContentLocation = UTF8.fromString "Content-Location"
fromHeader HttpContentMD5 = UTF8.fromString "Content-MD5"
fromHeader HttpContentRange = UTF8.fromString "Content-Range"
fromHeader HttpContentType = UTF8.fromString "Content-Type"
fromHeader HttpExpires = UTF8.fromString "Expires"
fromHeader HttpLastModified = UTF8.fromString "Last-Modified"
fromHeader (HttpExtensionHeader name) = name
fromHeader HttpCacheControl = UTF8.fromString "Cache-Control"
fromHeader HttpConnection = UTF8.fromString "Connection"
fromHeader HttpDate = UTF8.fromString "Date"
fromHeader HttpPragma = UTF8.fromString "Pragma"
fromHeader HttpTrailer = UTF8.fromString "Trailer"
fromHeader HttpTransferEncoding = UTF8.fromString "Transfer-Encoding"
fromHeader HttpUpgrade = UTF8.fromString "Upgrade"
fromHeader HttpVia = UTF8.fromString "Via"
fromHeader HttpWarning = UTF8.fromString "Warning"
fromHeader HttpCookie = UTF8.fromString "Cookie"
fromHeader HttpSetCookie = UTF8.fromString "Set-Cookie"
toHeader :: ByteString -> Header
toHeader bytestring
| bytestring == UTF8.fromString "Accept" = HttpAccept
| bytestring == UTF8.fromString "Accept-Charset" = HttpAcceptCharset
| bytestring == UTF8.fromString "Accept-Encoding" = HttpAcceptEncoding
| bytestring == UTF8.fromString "Accept-Language" = HttpAcceptLanguage
| bytestring == UTF8.fromString "Authorization" = HttpAuthorization
| bytestring == UTF8.fromString "Expect" = HttpExpect
| bytestring == UTF8.fromString "From" = HttpFrom
| bytestring == UTF8.fromString "Host" = HttpHost
| bytestring == UTF8.fromString "If-Match" = HttpIfMatch
| bytestring == UTF8.fromString "If-Modified-Since" = HttpIfModifiedSince
| bytestring == UTF8.fromString "If-None-Match" = HttpIfNoneMatch
| bytestring == UTF8.fromString "If-Range" = HttpIfRange
| bytestring == UTF8.fromString "If-Unmodified-Since" = HttpIfUnmodifiedSince
| bytestring == UTF8.fromString "Max-Forwards" = HttpMaxForwards
| bytestring == UTF8.fromString "Proxy-Authorization" = HttpProxyAuthorization
| bytestring == UTF8.fromString "Range" = HttpRange
| bytestring == UTF8.fromString "Referer" = HttpReferrer
| bytestring == UTF8.fromString "TE" = HttpTE
| bytestring == UTF8.fromString "User-Agent" = HttpUserAgent
| bytestring == UTF8.fromString "Accept-Ranges" = HttpAcceptRanges
| bytestring == UTF8.fromString "Age" = HttpAge
| bytestring == UTF8.fromString "ETag" = HttpETag
| bytestring == UTF8.fromString "Location" = HttpLocation
| bytestring == UTF8.fromString "Proxy-Authenticate" = HttpProxyAuthenticate
| bytestring == UTF8.fromString "Retry-After" = HttpRetryAfter
| bytestring == UTF8.fromString "Server" = HttpServer
| bytestring == UTF8.fromString "Vary" = HttpVary
| bytestring == UTF8.fromString "WWW-Authenticate" = HttpWWWAuthenticate
| bytestring == UTF8.fromString "Allow" = HttpAllow
| bytestring == UTF8.fromString "Content-Encoding" = HttpContentEncoding
| bytestring == UTF8.fromString "Content-Language" = HttpContentLanguage
| bytestring == UTF8.fromString "Content-Length" = HttpContentLength
| bytestring == UTF8.fromString "Content-Location" = HttpContentLocation
| bytestring == UTF8.fromString "Content-MD5" = HttpContentMD5
| bytestring == UTF8.fromString "Content-Range" = HttpContentRange
| bytestring == UTF8.fromString "Content-Type" = HttpContentType
| bytestring == UTF8.fromString "Expires" = HttpExpires
| bytestring == UTF8.fromString "Last-Modified" = HttpLastModified
| bytestring == UTF8.fromString "Cache-Control" = HttpCacheControl
| bytestring == UTF8.fromString "Connection" = HttpConnection
| bytestring == UTF8.fromString "Date" = HttpDate
| bytestring == UTF8.fromString "Pragma" = HttpPragma
| bytestring == UTF8.fromString "Trailer" = HttpTrailer
| bytestring == UTF8.fromString "Transfer-Encoding" = HttpTransferEncoding
| bytestring == UTF8.fromString "Upgrade" = HttpUpgrade
| bytestring == UTF8.fromString "Via" = HttpVia
| bytestring == UTF8.fromString "Warning" = HttpWarning
| bytestring == UTF8.fromString "Cookie" = HttpCookie
| bytestring == UTF8.fromString "Set-Cookie" = HttpSetCookie
| otherwise = HttpExtensionHeader bytestring
isValidInRequest :: Header -> Bool
isValidInRequest header = (headerType header == RequestHeader)
|| (headerType header == EntityHeader)
|| (headerType header == GeneralHeader)
isValidInResponse :: Header -> Bool
isValidInResponse header = (headerType header == ResponseHeader)
|| (headerType header == EntityHeader)
|| (headerType header == GeneralHeader)
isValidOnlyWithEntity :: Header -> Bool
isValidOnlyWithEntity header = headerType header == EntityHeader
-- | Queries the value from the user agent of the given HTTP/1.1 header. If
-- the header is to be provided after the content as specified by the
-- Trailer header, this is potentially time-consuming.
getRequestHeader
:: (MonadHTTP 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
connection <- getHTTPConnection
headerMap <- readMVar $ httpConnectionRequestHeaderMap connection
return $ fmap (stripHeaderValueWhitespace . UTF8.toString)
$ Map.lookup header headerMap
stripHeaderValueWhitespace :: String -> String
stripHeaderValueWhitespace input =
let input' = reverse $ dropWhile isHeaderValueWhitespace
$ reverse $ dropWhile isHeaderValueWhitespace input
computeWords input = case break isHeaderValueWhitespace input of
(all, "") -> [all]
(before, after)
-> [before]
++ (computeWords
$ dropWhile isHeaderValueWhitespace after)
words = computeWords input'
output = intercalate " " words
in output
isHeaderValueWhitespace :: Char -> Bool
isHeaderValueWhitespace char = elem char " \t\r\n"
-- | Returns an association list of name-value pairs of all the HTTP/1.1 request
-- or entity headers from the user agent. If some of these headers are to be
-- provided after the content as specified by the Trailer header, this is
-- potentially time-consuming.
getAllRequestHeaders :: (MonadHTTP m) => m [(Header, String)]
getAllRequestHeaders = do
connection <- getHTTPConnection
headerMap <- readMVar $ httpConnectionRequestHeaderMap connection
return $ map (\(header, bytestring) -> (header, UTF8.toString bytestring))
$ Map.toList headerMap
-- | Returns a 'Cookie' object for the given name, if the user agent provided one
-- in accordance with RFC 2109.
getCookie
:: (MonadHTTP m)
=> String -- ^ The name of the cookie to look for.
-> m (Maybe Cookie) -- ^ The cookie, if the user agent provided it.
getCookie name = do
cookieMap <- getRequestCookieMap
return $ Map.lookup name cookieMap
-- | Returns all 'Cookie' objects provided by the user agent in accordance
-- RFC 2109.
getAllCookies :: (MonadHTTP m) => m [Cookie]
getAllCookies = do
cookieMap <- getRequestCookieMap
return $ Map.elems cookieMap
-- | A convenience method; as 'getCookie', but returns only the value of the
-- cookie rather than a 'Cookie' object.
getCookieValue
:: (MonadHTTP 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
cookieMap <- getRequestCookieMap
return $ fmap cookieValue $ Map.lookup name cookieMap
getRequestCookieMap :: (MonadHTTP m) => m (Map String Cookie)
getRequestCookieMap = do
connection <- getHTTPConnection
let mvar = httpConnectionRequestCookieMap connection
modifyMVar mvar $ \maybeCookieMap -> do
case maybeCookieMap of
Just cookieMap -> do
return (maybeCookieMap, cookieMap)
Nothing -> do
maybeCookieString <- getRequestHeader HttpCookie
let cookieMap =
case maybeCookieString of
Nothing -> Map.empty
Just cookieString ->
Map.fromList (map (\cookie -> (cookieName cookie, cookie))
(parseCookies cookieString))
return (Just cookieMap, cookieMap)
-- | Return the remote address, which includes both host and port information.
-- They are provided in the aggregate like this because it is the most
-- internet-protocol-agnostic representation.
getRemoteAddress :: (MonadHTTP m) => m Network.SockAddr
getRemoteAddress = do
connection <- getHTTPConnection
return $ httpConnectionPeer connection
-- | Return the remote hostname, as determined by the web server. If it has
-- not yet been looked up, performs the lookup. This is potentially
-- time-consuming.
getRemoteHost :: (MonadHTTP m) => m String
getRemoteHost = do
connection <- getHTTPConnection
let mvar = httpConnectionRemoteHostname connection
maybeMaybeHostname <- readMVar mvar
case maybeMaybeHostname of
Nothing -> do
catch (do
(maybeHostname, _) <-
liftBase $ Network.getNameInfo [] True False
(httpConnectionPeer connection)
swapMVar mvar $ Just maybeHostname
case maybeHostname of
Nothing -> return $ show (httpConnectionPeer connection)
Just hostname -> return hostname)
(\exception -> do
return (exception :: SomeException)
return $ show (httpConnectionPeer connection))
Just Nothing -> return $ show (httpConnectionPeer connection)
Just (Just hostname) -> return hostname
-- | Return the request method.
getRequestMethod :: (MonadHTTP m) => m String
getRequestMethod = do
connection <- getHTTPConnection
readMVar (httpConnectionRequestMethod connection)
-- | Return the request URI.
getRequestURI :: (MonadHTTP m) => m String
getRequestURI = do
connection <- getHTTPConnection
readMVar (httpConnectionRequestURI connection)
getRequestProtocol :: (MonadHTTP m) => m String
getRequestProtocol = do
connection <- getHTTPConnection
readMVar (httpConnectionRequestProtocol connection)
-- | Return the server address and port, as a 'Network.SockAddr'. Useful
-- for implementing virtual-hosting policies.
getServerAddress :: (MonadHTTP m) => m Network.SockAddr
getServerAddress = do
connection <- getHTTPConnection
return $ httpConnectionServerAddress connection
-- | Return whether the connection is via the secure version of the
-- protocol. Useful for implementing virtual-hosting policies.
getServerSecure :: (MonadHTTP m) => m Bool
getServerSecure = do
return False
-- | Return the request content length, if this is knowable without actually
-- receiving the content - in particular, if the Content-Length header was
-- used. Otherwise, returns Nothing.
getContentLength :: (MonadHTTP m) => m (Maybe Int)
getContentLength = do
maybeString <- getRequestHeader HttpContentLength
case maybeString of
Nothing -> return Nothing
Just string -> return $ parseInt string
-- | Return the request content type, as provided by the user agent.
getContentType :: (MonadHTTP m) => m (Maybe String)
getContentType = do
getRequestHeader HttpContentType
getRequestHasContent :: (MonadHTTP m) => m Bool
getRequestHasContent = do
HTTPConnection { httpConnectionRequestContentParameters = parametersMVar }
<- getHTTPConnection
modifyMVar parametersMVar $ \parameters -> do
parameters <- ensureRequestContentParametersInitialized parameters
let result = case parameters of
RequestContentNone -> False
_ -> True
return (parameters, result)
getRequestContentAllowed :: (MonadHTTP m) => m Bool
getRequestContentAllowed = do
method <- getRequestMethod
case method of
_ | method == "OPTIONS" -> return True
| method == "GET" -> return False
| method == "HEAD" -> return False
| method == "POST" -> return True
| method == "PUT" -> return True
| method == "DELETE" -> return False
| method == "TRACE" -> return False
| method == "CONNECT" -> return True
| otherwise -> return True
-- | Reads up to a specified amount of data from the content of the HTTP
-- request, if any, and interprets it as binary data. If input has been
-- closed, returns an empty bytestring. If no input is immediately
-- available, blocks until there is some. If output has been closed, causes
-- an 'OutputAlreadyClosed' exception.
httpGet :: (MonadHTTP m) => Int -> m BS.ByteString
httpGet size = httpGet' (Just size) True False
-- | Reads up to a specified amount of data from the content of the HTTP
-- request, if any, and interprets it as binary data. 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.
httpGetNonBlocking :: (MonadHTTP m) => Int -> m BS.ByteString
httpGetNonBlocking size = httpGet' (Just size) False False
-- | Reads all remaining data from the content of the HTTP request, if any,
-- and interprets it as binary data. 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.
httpGetContents :: (MonadHTTP m) => m BS.ByteString
httpGetContents = httpGet' Nothing True False
-- | Returns whether the content of the HTTP request potentially has data
-- remaining, either in the buffer or yet to be read.
httpIsReadable :: (MonadHTTP m) => m Bool
httpIsReadable = do
HTTPConnection { httpConnectionRequestContentParameters = parametersMVar }
<- getHTTPConnection
modifyMVar parametersMVar $ \parameters -> do
parameters <- ensureRequestContentParametersInitialized parameters
let result = case parameters of
RequestContentNone -> False
RequestContentClosed -> False
_ -> True
return (parameters, result)
httpGet' :: (MonadHTTP m) => (Maybe Int) -> Bool -> Bool -> m BS.ByteString
httpGet' maybeSize blocking discarding = do
if not discarding
then requireOutputNotYetClosed
else return ()
modifyRequest $ \buffer parameters -> do
parameters <- ensureRequestContentParametersInitialized parameters
(buffer, parameters)
<- extendRequestContentBuffer buffer parameters maybeSize blocking
(result, buffer) <- return $ case maybeSize of
Nothing -> (buffer, BS.empty)
Just size -> BS.splitAt size buffer
return (buffer, parameters, result)
ensureRequestContentParametersInitialized
:: (MonadHTTP m)
=> RequestContentParameters
-> m RequestContentParameters
ensureRequestContentParametersInitialized RequestContentUninitialized = do
maybeLength <- getContentLength
maybeTransferEncodingString <- getRequestHeader HttpTransferEncoding
let (hasContent, chunked)
= case (maybeLength, maybeTransferEncodingString) of
(Nothing, Nothing) -> (False, False)
(Just length, Nothing) -> (True, False)
(Just length, Just encoding)
| map toLower encoding == "identity" -> (True, False)
| otherwise -> (True, True)
(_, Just _) -> (True, True)
if hasContent
then if chunked
then return $ RequestContentChunked 0
else case maybeLength of
Nothing -> return $ RequestContentNone
Just length -> return $ RequestContentIdentity length
else return RequestContentNone
ensureRequestContentParametersInitialized parameters = return parameters
extendRequestContentBuffer
:: (MonadHTTP m)
=> BS.ByteString
-> RequestContentParameters
-> (Maybe Int)
-> Bool
-> m (BS.ByteString, RequestContentParameters)
extendRequestContentBuffer highLevelBuffer
parameters
maybeTargetLength
blocking = do
let isAtLeastTargetLength buffer =
case maybeTargetLength of
Nothing -> False
Just targetLength -> BS.length buffer >= targetLength
loop highLevelBuffer lowLevelBuffer parameters = do
if isAtLeastTargetLength highLevelBuffer
then return (highLevelBuffer, lowLevelBuffer, parameters)
else do
case parameters of
RequestContentNone
-> return (highLevelBuffer, lowLevelBuffer, parameters)
RequestContentClosed
-> return (highLevelBuffer, lowLevelBuffer, parameters)
RequestContentIdentity lengthRemaining -> do
(lowLevelBuffer, endOfInput)
<- extendInputBuffer lowLevelBuffer lengthRemaining blocking
if endOfInput
then throwIO UnexpectedEndOfInput
else return ()
let (toHighLevelBuffer, lowLevelBuffer')
= BS.splitAt lengthRemaining lowLevelBuffer
lengthRead = BS.length toHighLevelBuffer
highLevelBuffer'
= BS.append highLevelBuffer toHighLevelBuffer
lengthRemaining' = if lengthRemaining > lengthRead
then lengthRemaining - lengthRead
else 0
parameters' = if lengthRemaining' > 0
then RequestContentIdentity lengthRemaining'
else RequestContentClosed
if not blocking || isAtLeastTargetLength highLevelBuffer
then return (highLevelBuffer', lowLevelBuffer', parameters')
else loop highLevelBuffer' lowLevelBuffer' parameters'
RequestContentChunked _ -> do
httpLog $ "Don't understand chunked."
throwIO UnexpectedEndOfInput
-- TODO IAK
HTTPConnection { httpConnectionInputBufferMVar = lowLevelBufferMVar }
<- getHTTPConnection
modifyMVar lowLevelBufferMVar $ \lowLevelBuffer -> do
(highLevelBuffer, lowLevelBuffer, parameters)
<- loop highLevelBuffer lowLevelBuffer parameters
return (lowLevelBuffer, (highLevelBuffer, parameters))
-- | Sets the response status which will be sent with the response headers. If
-- the response headers have already been sent, or are no longer modifiable
-- (because of a call to 'httpPut' or similar), causes a
-- 'ResponseHeadersAlreadySent' or 'ResponseHeadersNotModifiable' exception.
setResponseStatus
:: (MonadHTTP m)
=> Int -- ^ The HTTP/1.1 status code to set.
-> m ()
setResponseStatus status = do
requireResponseHeadersNotYetSent
requireResponseHeadersModifiable
HTTPConnection { httpConnectionResponseStatus = mvar } <- getHTTPConnection
swapMVar mvar status
return ()
-- | Returns the response status which will be or has been sent with the response
-- headers.
getResponseStatus
:: (MonadHTTP m)
=> m Int -- ^ The HTTP/1.1 status code.
getResponseStatus = do
HTTPConnection { httpConnectionResponseStatus = mvar } <- getHTTPConnection
readMVar mvar
-- | Sets the given response header to the given string value, overriding any
-- value which has previously been set. If the response headers have
-- already been sent, or are no longer modifiable (because of a call to
-- 'httpPut' or similar), causes a 'ResponseHeadersAlreadySent' or
-- 'ResponseHeadersNotModifiable' exception. If the header is not an
-- HTTP/1.1 or extension response, entity, or general 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
:: (MonadHTTP 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
requireResponseHeadersModifiable
requireResponseHeadersNotYetSent
setResponseHeader' header value
setResponseHeader'
:: (MonadHTTP m)
=> Header
-> String
-> m ()
setResponseHeader' header value = do
if isValidInResponse header
then do
connection <- getHTTPConnection
let mvar = httpConnectionResponseHeaderMap connection
modifyMVar_ mvar $ \headerMap -> do
let headerMap' = Map.insert header (UTF8.fromString value) headerMap
return headerMap'
else throwIO $ NotAResponseHeader header
-- | Causes the given 'Header' response header not to be sent, overriding
-- any value which has previously been set. If the response headers have
-- already been sent, or are no longer modifiable (because of a call to
-- 'httpPut' or similar), causes a 'ResponseHeadersAlreadySent' or
-- 'ResponseHeadersNotModifiable' 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
:: (MonadHTTP m)
=> Header -- ^ The header to unset. Must be a response header or an entity header.
-> m ()
unsetResponseHeader header = do
requireResponseHeadersNotYetSent
requireResponseHeadersModifiable
if isValidInResponse header
then do
HTTPConnection { httpConnectionResponseHeaderMap = mvar } <- getHTTPConnection
modifyMVar_ mvar $ \headerMap -> do
headerMap <- return $ Map.delete header headerMap
return headerMap
else throwIO $ 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, entity, or general header, ie, is not valid as part of a
-- response, causes a 'NotAResponseHeader' exception.
getResponseHeader
:: (MonadHTTP 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
if isValidInResponse header
then do
HTTPConnection { httpConnectionResponseHeaderMap = mvar } <- getHTTPConnection
headerMap <- readMVar mvar
return $ fmap UTF8.toString $ Map.lookup header headerMap
else throwIO $ 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, or are no longer modifiable (because of a call to
-- 'httpPut' or similar), causes a 'ResponseHeadersAlreadySent' or
-- 'ResponseHeadersNotModifiable' exception.
-- If the name is not a possible name for a cookie, causes a 'CookieNameInvalid'
-- exception.
setCookie
:: (MonadHTTP m)
=> Cookie -- ^ The cookie to set.
-> m ()
setCookie cookie = do
requireResponseHeadersNotYetSent
requireResponseHeadersModifiable
requireValidCookieName $ cookieName cookie
connection <- getHTTPConnection
let mvar = httpConnectionResponseCookieMap connection
modifyMVar_ mvar $ \responseCookieMap -> do
let responseCookieMap' =
Map.insert (cookieName cookie) cookie responseCookieMap
return 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, or are no longer modifiable (because of a call to
-- 'httpPut' or similar), causes a 'ResponseHeadersAlreadySent' or
-- 'ResponseHeadersNotModifiable' exception.
-- If the name is not a possible name for a cookie, causes a
-- 'CookieNameInvalid' exception.
unsetCookie
:: (MonadHTTP m)
=> String -- ^ The name of the cookie to unset.
-> m ()
unsetCookie name = do
requireResponseHeadersNotYetSent
requireResponseHeadersModifiable
requireValidCookieName name
connection <- getHTTPConnection
let mvar = httpConnectionResponseCookieMap connection
modifyMVar_ mvar $ \responseCookieMap -> do
let responseCookieMap' =
Map.insert name (mkUnsetCookie name) responseCookieMap
return 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 :: (MonadHTTP m) => String -> m ()
requireValidCookieName name = do
if not $ isValidCookieToken name
then throwIO $ CookieNameInvalid name
else return ()
isValidCookieToken :: String -> Bool
isValidCookieToken token =
let validCharacter c = (ord c > 0) && (ord c < 128)
&& (not $ elem c "()<>@,;:\\\"/[]?={} \t")
in (length token > 0) && (all validCharacter token)
-- | An exception originating within the HTTP infrastructure or the web server.
data HTTPException
= ResponseHeadersAlreadySent
-- ^ An exception thrown by operations which require the response headers not
-- to have been sent yet.
| ResponseHeadersNotModifiable
-- ^ An exception thrown by operations which require the response headers
-- to still be modifiable.
| OutputAlreadyClosed
-- ^ An exception thrown by operations which produce output when output has
-- been closed, as by 'httpCloseOutput'.
| OutputIncomplete
-- ^ An exception thrown when output is closed, as by 'httpCloseOutput',
-- when the response headers imply that there will be a certain amount
-- of data and there is not.
| 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.
| NoConnection
-- ^ An exception thrown by operations which expect a connection to
-- exist (as it always does within a handler), when none does.
deriving (Show, Typeable)
instance Exception HTTPException
-- | 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, or are no longer modifiable (because of a
-- call to 'httpPut' or similar), causes a 'ResponseHeadersAlreadySent' or
-- 'ResponseHeadersNotModifiable' exception.
permanentRedirect
:: (MonadHTTP 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, or are no longer
-- modifiable (because of a call to 'httpPut' or similar), causes a
-- 'ResponseHeadersAlreadySent' or 'ResponseHeadersNotModifiable' exception.
seeOtherRedirect
:: (MonadHTTP 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. Note that if the buffered identity
-- output mode (the first mode of operation described for 'httpPut') is
-- to be used, this function implies that there is no additional content
-- beyond what has already been sent.
sendResponseHeaders :: (MonadHTTP m) => m ()
sendResponseHeaders = do
requireOutputNotYetClosed
connection <- getHTTPConnection
let socket = httpConnectionSocket connection
alreadySentMVar = httpConnectionResponseHeadersSent connection
modifiableMVar = httpConnectionResponseHeadersModifiable connection
parametersMVar = httpConnectionResponseContentParameters connection
bufferMVar = httpConnectionResponseContentBuffer connection
parameters <-
modifyMVar parametersMVar $ \parameters -> do
parameters <- ensureResponseContentParametersInitialized parameters
return (parameters, parameters)
modifyMVar_ alreadySentMVar $ \alreadySent -> do
if not alreadySent
then do
_ <- swapMVar modifiableMVar False
case parameters of
ResponseContentBufferedIdentity -> do
buffer <- readMVar bufferMVar
setResponseHeader' HttpContentLength (show $ BS.length buffer)
_ -> do
headersBuffer <- getHeadersBuffer
send headersBuffer
else return ()
return True
getHeadersBuffer :: (MonadHTTP m) => m ByteString
getHeadersBuffer = do
connection <- getHTTPConnection
responseStatus <- readMVar (httpConnectionResponseStatus connection)
responseHeaderMap <- readMVar (httpConnectionResponseHeaderMap connection)
responseCookieMap <- readMVar (httpConnectionResponseCookieMap connection)
let statusLine = BS.concat [UTF8.fromString "HTTP/1.1 ",
UTF8.fromString $ show responseStatus,
UTF8.fromString " ",
reasonPhrase responseStatus,
UTF8.fromString "\r\n"]
nameValuePairs
= concat [map (\(header, value) -> (fromHeader header, value))
$ Map.toList responseHeaderMap,
if (isNothing $ Map.lookup HttpSetCookie responseHeaderMap)
&& (not $ Map.null responseCookieMap)
then [(UTF8.fromString "Set-Cookie", setCookieValue)]
else []]
setCookieValue = printCookies $ Map.elems responseCookieMap
delimiterLine = UTF8.fromString "\r\n"
buffer = BS.concat $ [statusLine]
++ (concat
$ map (\(name, value)
-> [name, UTF8.fromString ": ",
value, UTF8.fromString "\r\n"])
nameValuePairs)
++ [delimiterLine]
return buffer
markResponseHeadersUnmodifiable :: (MonadHTTP m) => m ()
markResponseHeadersUnmodifiable = do
HTTPConnection { httpConnectionResponseHeadersModifiable = modifiableMVar }
<- getHTTPConnection
swapMVar modifiableMVar False
return ()
reasonPhrase :: Int -> ByteString
reasonPhrase status =
UTF8.fromString $ case status of
100 -> "Continue"
101 -> "Switching Protocols"
200 -> "OK"
201 -> "Created"
202 -> "Accepted"
203 -> "Non-Authoritative Information"
204 -> "No Content"
205 -> "Reset Content"
206 -> "Partial Content"
300 -> "Multiple Choices"
301 -> "Moved Permanently"
302 -> "Found"
303 -> "See Other"
304 -> "Not Modified"
305 -> "Use Proxy"
307 -> "Temporary Redirect"
400 -> "Bad Request"
401 -> "Unauthorized"
402 -> "Payment Required"
403 -> "Forbidden"
404 -> "Not Found"
405 -> "Method Not Allowed"
406 -> "Not Acceptable"
407 -> "Proxy Authentication Required"
408 -> "Request Time-out"
409 -> "Conflict"
410 -> "Gone"
411 -> "Length Required"
412 -> "Precondition Failed"
413 -> "Request Entity Too Large"
414 -> "Request-URI Too Large"
415 -> "Unsupported Media Type"
416 -> "Requested range not satisfiable"
417 -> "Expectation Failed"
500 -> "Internal Server Error"
501 -> "Not Implemented"
502 -> "Bad Gateway"
503 -> "Service Unavailable"
504 -> "Gateway Time-out"
505 -> "HTTP Version not supported"
_ -> "Extension"
-- | Returns whether the response headers have been sent, regardless of whether
-- they are modifiable (they might not be because of a call to 'httpPut' or
-- similar).
responseHeadersSent :: (MonadHTTP m) => m Bool
responseHeadersSent = do
connection <- getHTTPConnection
readMVar (httpConnectionResponseHeadersSent connection)
-- | Returns whether the response headers are modifiable, a prerequisite of
-- which is that they have not already been sent. (They might not be
-- modifiable because of a call to 'httpPut' or similar.)
responseHeadersModifiable :: (MonadHTTP m) => m Bool
responseHeadersModifiable = do
connection <- getHTTPConnection
readMVar (httpConnectionResponseHeadersModifiable connection)
-- | Appends data, interpreted as binary, to the content of the HTTP response.
-- Makes the response headers no longer modifiable, effective immediately.
-- If output has already been closed, causes an 'OutputAlreadyClosed'
-- exception. If the response Transfer-Encoding as set in the response
-- headers is "identity" or omitted, and the response Content-Length is
-- omitted, data is buffered until output is closed, then sent all at once
-- with an appropriate Content-Length header. Otherwise - that is, if there
-- is a Transfer-Encoding other than "identity" set, or if Content-Length is
-- set - data is sent immediately. If Content-Length is set, and the
-- provided data would cause the cumulative data sent to exceed that length,
-- causes an 'OutputAlreadyClosed' exception. At the time that data is
-- actually sent, if the response headers have not been sent, first sends
-- them.
--
-- In other words, there are effectively three modes of operation for output.
-- The first, simplest mode is used if the handler does nothing special. In
-- this mode output is buffered and sent all at once; headers are not sent
-- until this time. In this mode 'httpCloseOutput' may be useful to force
-- output to be sent before the handler returns, perhaps so that additional
-- time-consuming processing can be done. This mode is easiest to use, in the
-- sense that it requires no support on the handler's part, but probably the
-- second mode should always be used instead.
--
-- The second mode is used if the handler sets a Transfer-Encoding, for
-- example "chunked", and no Content-Length. In this case headers are sent
-- immediately upon the first 'httpPut' or 'httpPutStr', and output is sent
-- as it is provided. Output in this mode is transformed by 'httpPut' into
-- the appropriate transfer encoding. Thus handler code need only specify a
-- transfer encoding, not actually implement that encoding itself. This mode
-- is advantageous to allow user agents to begin displaying partial content as
-- it is received, and particularly useful when the content is quite large
-- or takes significant time to generate. If you are unsure which mode to
-- use, it should probably be this one.
--
-- The third mode is used if the handler sets a Content-Length and no
-- Transfer-Encoding. In this case headers are again sent immediately upon
-- the first 'httpPut' or 'httpPutStr', and output is again sent as it is
-- provided. Output in this mode is not transformed. This may be more
-- efficient than the second mode if output is generated in many small pieces,
-- as it avoids computing and sending the length tags of the "chunked"
-- encoding. However, it requires the content length to be known in advance
-- of actually sending any content. It may be useful if you wish to have
-- direct-http validate that the handler is well-behaved in sending a binary
-- object of known size with no "garbage" inserted by spurious additional
-- puts.
httpPut :: (MonadHTTP m) => BS.ByteString -> m ()
httpPut bytestring = do
requireOutputNotYetClosed
markResponseHeadersUnmodifiable
connection <- getHTTPConnection
let alreadySentMVar = httpConnectionResponseHeadersSent connection
maybeException <- do
modifyResponse $ \buffer parameters -> do
parameters <- ensureResponseContentParametersInitialized parameters
case parameters of
ResponseContentClosed -> do
return (buffer, parameters, Just OutputAlreadyClosed)
ResponseContentBufferedIdentity -> do
return (BS.append buffer bytestring, parameters, Nothing)
ResponseContentUnbufferedIdentity lengthRemaining -> do
modifyMVar_ alreadySentMVar $ \alreadySent -> do
if alreadySent
then return ()
else do
headersBuffer <- getHeadersBuffer
send headersBuffer
return True
let lengthThisPut = BS.length bytestring
if lengthThisPut > lengthRemaining
then do
return (BS.empty,
ResponseContentClosed,
Just OutputAlreadyClosed)
else do
let parameters' = ResponseContentUnbufferedIdentity
$ lengthRemaining - lengthThisPut
send bytestring
return (buffer, parameters', Nothing)
ResponseContentChunked -> do
modifyMVar_ alreadySentMVar $ \alreadySent -> do
if alreadySent
then return ()
else do
headersBuffer <- getHeadersBuffer
send headersBuffer
return True
if BS.length bytestring > 0
then do
let lengthBuffer =
UTF8.fromString $ showHex (BS.length bytestring) ""
++ "\r\n"
crlfBuffer = UTF8.fromString "\r\n"
send $ BS.concat [lengthBuffer, bytestring, crlfBuffer]
else return ()
return (buffer, parameters, Nothing)
case maybeException of
Nothing -> return ()
Just exception -> throwIO exception
ensureResponseContentParametersInitialized
:: (MonadHTTP m)
=> ResponseContentParameters
-> m ResponseContentParameters
ensureResponseContentParametersInitialized ResponseContentUninitialized = do
maybeLengthString <- getResponseHeader HttpContentLength
let maybeLength = case maybeLengthString of
Nothing -> Nothing
Just lengthString -> parseInt lengthString
maybeTransferEncodingString <- getResponseHeader HttpTransferEncoding
let (hasContent, chunked)
= case (maybeLengthString, maybeTransferEncodingString) of
(Nothing, Nothing) -> (False, False)
(Just length, Nothing) -> (True, False)
(Just length, Just encoding)
| map toLower encoding == "identity" -> (True, False)
| otherwise -> (True, True)
(_, Just _) -> (True, True)
if hasContent
then if chunked
then return $ ResponseContentChunked
else case maybeLength of
Nothing -> return ResponseContentBufferedIdentity
Just length ->
return $ ResponseContentUnbufferedIdentity length
else return ResponseContentBufferedIdentity
ensureResponseContentParametersInitialized parameters = return parameters
finishResponseContent :: (MonadHTTP m) => m ()
finishResponseContent = do
connection <- getHTTPConnection
let bufferMVar = httpConnectionResponseContentBuffer connection
parametersMVar = httpConnectionResponseContentParameters connection
maybeException <-
modifyResponse $ \buffer parameters -> do
parameters <- ensureResponseContentParametersInitialized parameters
result <-
case parameters of
ResponseContentClosed -> do
return $ Just OutputAlreadyClosed
ResponseContentBufferedIdentity -> do
headersBuffer <- getHeadersBuffer
send $ BS.concat [headersBuffer, buffer]
return Nothing
ResponseContentUnbufferedIdentity lengthRemaining -> do
if lengthRemaining > 0
then return $ Just OutputIncomplete
else return Nothing
ResponseContentChunked -> do
let emptyChunkBuffer = UTF8.fromString $ "0\r\n\r\n\r\n"
send emptyChunkBuffer
return Nothing
return (BS.empty, ResponseContentClosed, result)
case maybeException of
Nothing -> return ()
Just exception -> throwIO exception
send :: (MonadHTTP m) => ByteString -> m ()
send bytestring = do
HTTPConnection { httpConnectionSocket = socket } <- getHTTPConnection
liftBase $ Network.sendAll socket bytestring
-- | Appends text, encoded as UTF8, to the content of the HTTP response. In
-- all respects this behaves as 'httpPut', but for the fact that it takes
-- text rather than binary data.
httpPutStr :: (MonadHTTP m) => String -> m ()
httpPutStr string = httpPut $ UTF8.fromString string
-- | Informs the web server and the user agent that the request has completed.
-- As side-effects, the response headers are sent if they have not yet been,
-- any unread input is discarded and no more can be read, and any unsent
-- output is sent. 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. If the response headers imply that there
-- will be a certain amount of data and there is not, causes an
-- 'OutputIncomplete' exception.
httpCloseOutput :: (MonadHTTP m) => m ()
httpCloseOutput = do
requireOutputNotYetClosed
sendResponseHeaders
finishResponseContent
httpGet' Nothing True True
return ()
-- | Returns whether it is possible to write more data; ie, whether output has
-- not yet been closed as by 'httpCloseOutput'.
httpIsWritable :: (MonadHTTP m) => m Bool
httpIsWritable = do
connection <- getHTTPConnection
let parametersMVar = httpConnectionResponseContentParameters connection
modifyMVar parametersMVar $ \parameters -> do
parameters <- ensureResponseContentParametersInitialized parameters
let result = case parameters of
ResponseContentClosed -> False
_ -> True
return (parameters, result)
requireResponseHeadersNotYetSent :: (MonadHTTP m) => m ()
requireResponseHeadersNotYetSent = do
alreadySent <- responseHeadersSent
if alreadySent
then throwIO ResponseHeadersAlreadySent
else return ()
requireResponseHeadersModifiable :: (MonadHTTP m) => m ()
requireResponseHeadersModifiable = do
modifiable <- responseHeadersModifiable
if modifiable
then return ()
else throwIO ResponseHeadersNotModifiable
requireOutputNotYetClosed :: (MonadHTTP m) => m ()
requireOutputNotYetClosed = do
isWritable <- httpIsWritable
case isWritable of
False -> throwIO OutputAlreadyClosed
True -> return ()
modifyRequest
:: (MonadHTTP m)
=> (ByteString
-> RequestContentParameters
-> m (ByteString, RequestContentParameters, a))
-> m a
modifyRequest action = do
HTTPConnection {
httpConnectionRequestContentBuffer = bufferMVar,
httpConnectionRequestContentParameters = parametersMVar
} <- getHTTPConnection
modifyMVar bufferMVar $ \buffer -> do
modifyMVar parametersMVar $ \parameters -> do
(buffer, parameters, result) <- action buffer parameters
return (parameters, (buffer, result))
modifyResponse
:: (MonadHTTP m)
=> (ByteString
-> ResponseContentParameters
-> m (ByteString, ResponseContentParameters, a))
-> m a
modifyResponse action = do
HTTPConnection {
httpConnectionResponseContentBuffer = bufferMVar,
httpConnectionResponseContentParameters = parametersMVar
} <- getHTTPConnection
modifyMVar bufferMVar $ \buffer -> do
modifyMVar parametersMVar $ \parameters -> do
(buffer, parameters, result) <- action buffer parameters
return (parameters, (buffer, result))