{-# LANGUAGE ScopedTypeVariables, ScopedTypeVariables, TupleSections #-}

module Happstack.Server.Internal.Handler
    ( request
    , parseResponse
    , putRequest
    ) where

import qualified Paths_happstack_server as Paths
import qualified Data.Version as DV
import Control.Applicative (pure)
import Control.Concurrent (newMVar, newEmptyMVar, tryTakeMVar)
import Control.Exception.Extensible as E
import Control.Monad
import Data.List(elemIndex)
import Data.Char(toLower)
import Data.Maybe ( fromMaybe, fromJust, isJust, isNothing )
import Data.Time      (UTCTime)
import Prelude hiding (last)
import qualified Data.ByteString.Char8 as P
import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString.Lazy.Char8 as L
import           Data.ByteString.Lazy.Internal (ByteString(Chunk, Empty))
import qualified Data.ByteString.Lazy.Char8 as LC
import qualified Data.Map as M
import Data.Int (Int64)
import Happstack.Server.Internal.Cookie
import Happstack.Server.Internal.Clock
import Happstack.Server.Internal.Types
import Happstack.Server.Internal.Multipart
import Happstack.Server.Internal.RFC822Headers
import Happstack.Server.Internal.MessageWrap
import Happstack.Server.SURI(SURI(..),path,query)
import Happstack.Server.SURI.ParseURI
import Happstack.Server.Internal.TimeoutIO (TimeoutIO(..))
import Happstack.Server.Internal.Monads (failResponse)
import qualified Happstack.Server.Internal.TimeoutManager as TM
import Numeric
import System.Directory (removeFile)
import System.IO
import System.IO.Error (isDoesNotExistError)

request :: TimeoutIO -> Maybe (LogAccess UTCTime) -> Host -> (Request -> IO Response) -> IO ()
request :: TimeoutIO
-> Maybe (LogAccess UTCTime)
-> Host
-> (Request -> IO Response)
-> IO ()
request TimeoutIO
timeoutIO Maybe (LogAccess UTCTime)
mlog Host
host Request -> IO Response
handler =
    TimeoutIO
-> Maybe (LogAccess UTCTime)
-> Host
-> (Request -> IO Response)
-> ByteString
-> IO ()
rloop TimeoutIO
timeoutIO Maybe (LogAccess UTCTime)
mlog Host
host Request -> IO Response
handler (ByteString -> IO ()) -> IO ByteString -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< TimeoutIO -> IO ByteString
toGetContents TimeoutIO
timeoutIO

required :: String -> Maybe a -> Either String a
required :: String -> Maybe a -> Either String a
required String
err Maybe a
Nothing  = String -> Either String a
forall a b. a -> Either a b
Left String
err
required String
_   (Just a
a) = a -> Either String a
forall a b. b -> Either a b
Right a
a

rloop :: TimeoutIO
         -> Maybe (LogAccess UTCTime)
         -> Host
         -> (Request -> IO Response)
         -> L.ByteString
         -> IO ()
rloop :: TimeoutIO
-> Maybe (LogAccess UTCTime)
-> Host
-> (Request -> IO Response)
-> ByteString
-> IO ()
rloop TimeoutIO
timeoutIO Maybe (LogAccess UTCTime)
mlog Host
host Request -> IO Response
handler ByteString
inputStr
    | ByteString -> Bool
L.null ByteString
inputStr = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    | Bool
otherwise
    = (IO (IO ()) -> IO ()
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (IO (IO ()) -> IO ()) -> IO (IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$
      do let parseRequest :: Either
  String
  (Method, SURI, [(String, Cookie)], HttpVersion, Headers,
   ByteString, ByteString)
parseRequest
                 = do
                      (ByteString
topStr, ByteString
restStr) <- String
-> Maybe (ByteString, ByteString)
-> Either String (ByteString, ByteString)
forall a. String -> Maybe a -> Either String a
required String
"failed to separate request" (Maybe (ByteString, ByteString)
 -> Either String (ByteString, ByteString))
-> Maybe (ByteString, ByteString)
-> Either String (ByteString, ByteString)
forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe (ByteString, ByteString)
splitAtEmptyLine ByteString
inputStr
                      (ByteString
rql, ByteString
headerStr)  <- String
-> Maybe (ByteString, ByteString)
-> Either String (ByteString, ByteString)
forall a. String -> Maybe a -> Either String a
required String
"failed to separate headers/body" (Maybe (ByteString, ByteString)
 -> Either String (ByteString, ByteString))
-> Maybe (ByteString, ByteString)
-> Either String (ByteString, ByteString)
forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe (ByteString, ByteString)
splitAtCRLF ByteString
topStr
                      let (Method
m,SURI
u,HttpVersion
v) = ByteString -> (Method, SURI, HttpVersion)
requestLine ByteString
rql
                      [Header]
headers' <- case String -> String -> Maybe [Header]
forall (m :: * -> *). MonadFail m => String -> String -> m [Header]
parseHeaders String
"host" (ByteString -> String
L.unpack ByteString
headerStr) of
                        Maybe [Header]
Nothing -> String -> Either String [Header]
forall a b. a -> Either a b
Left String
"failed to parse host header"
                        Just [Header]
x -> [Header] -> Either String [Header]
forall a b. b -> Either a b
Right [Header]
x
                      let headers :: Headers
headers = [Header] -> Headers
mkHeaders [Header]
headers'
                      let contentLen :: Int
contentLen = Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
0 (Maybe Int -> Int) -> Maybe Int -> Int
forall a b. (a -> b) -> a -> b
$ ((Int, ByteString) -> Int) -> Maybe (Int, ByteString) -> Maybe Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int, ByteString) -> Int
forall a b. (a, b) -> a
fst (ByteString -> Maybe (Int, ByteString)
P.readInt (ByteString -> Maybe (Int, ByteString))
-> Maybe ByteString -> Maybe (Int, ByteString)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ByteString -> Headers -> Maybe ByteString
forall r. HasHeaders r => ByteString -> r -> Maybe ByteString
getHeaderUnsafe ByteString
contentlengthC Headers
headers)
                      (ByteString
body, ByteString
nextRequest) <- case () of
                          () | Int
contentLen Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0               -> String -> Either String (ByteString, ByteString)
forall a b. a -> Either a b
Left String
"negative content-length"
                             | Maybe ByteString -> Bool
forall a. Maybe a -> Bool
isJust (Maybe ByteString -> Bool) -> Maybe ByteString -> Bool
forall a b. (a -> b) -> a -> b
$ ByteString -> Headers -> Maybe ByteString
forall r. HasHeaders r => ByteString -> r -> Maybe ByteString
getHeaderBS ByteString
transferEncodingC Headers
headers ->
                                 (ByteString, ByteString) -> Either String (ByteString, ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return ((ByteString, ByteString)
 -> Either String (ByteString, ByteString))
-> (ByteString, ByteString)
-> Either String (ByteString, ByteString)
forall a b. (a -> b) -> a -> b
$ ByteString -> (ByteString, ByteString)
consumeChunks ByteString
restStr
                             | Bool
otherwise                       -> (ByteString, ByteString) -> Either String (ByteString, ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int64 -> ByteString -> (ByteString, ByteString)
L.splitAt (Int -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
contentLen) ByteString
restStr)
                      let cookies :: [(String, Cookie)]
cookies = [ (Cookie -> String
cookieName Cookie
c, Cookie
c) | [Cookie]
cl <- [[Cookie]] -> Maybe [[Cookie]] -> [[Cookie]]
forall a. a -> Maybe a -> a
fromMaybe [] ((ByteString -> [[Cookie]]) -> Maybe ByteString -> Maybe [[Cookie]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> [[Cookie]]
forall (m :: * -> *). MonadFail m => ByteString -> m [Cookie]
getCookies (String -> Headers -> Maybe ByteString
forall r. HasHeaders r => String -> r -> Maybe ByteString
getHeader String
"Cookie" Headers
headers)), Cookie
c <- [Cookie]
cl ] -- Ugle
                      (Method, SURI, [(String, Cookie)], HttpVersion, Headers,
 ByteString, ByteString)
-> Either
     String
     (Method, SURI, [(String, Cookie)], HttpVersion, Headers,
      ByteString, ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (Method
m, SURI
u, [(String, Cookie)]
cookies, HttpVersion
v, Headers
headers, ByteString
body, ByteString
nextRequest)

         case Either
  String
  (Method, SURI, [(String, Cookie)], HttpVersion, Headers,
   ByteString, ByteString)
parseRequest of
           Left String
err -> String -> IO (IO ())
forall a. HasCallStack => String -> a
error (String -> IO (IO ())) -> String -> IO (IO ())
forall a b. (a -> b) -> a -> b
$ String
"failed to parse HTTP request: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
err
           Right (Method
m, SURI
u, [(String, Cookie)]
cookies, HttpVersion
v, Headers
headers, ByteString
body, ByteString
nextRequest)
              -> IO () -> IO (IO ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (IO () -> IO (IO ())) -> IO () -> IO (IO ())
forall a b. (a -> b) -> a -> b
$
                  do MVar RqBody
bodyRef        <- RqBody -> IO (MVar RqBody)
forall a. a -> IO (MVar a)
newMVar (ByteString -> RqBody
Body ByteString
body)
                     MVar [(String, Input)]
bodyInputRef   <- IO (MVar [(String, Input)])
forall a. IO (MVar a)
newEmptyMVar
                     let req :: Request
req = Bool
-> Method
-> [String]
-> String
-> String
-> [(String, Input)]
-> MVar [(String, Input)]
-> [(String, Cookie)]
-> HttpVersion
-> Headers
-> MVar RqBody
-> Host
-> Request
Request (TimeoutIO -> Bool
toSecure TimeoutIO
timeoutIO) Method
m (String -> [String]
pathEls (SURI -> String
path SURI
u)) (SURI -> String
path SURI
u) (SURI -> String
query SURI
u)
                                  (SURI -> [(String, Input)]
queryInput SURI
u) MVar [(String, Input)]
bodyInputRef [(String, Cookie)]
cookies HttpVersion
v Headers
headers MVar RqBody
bodyRef Host
host

                     let ioseq :: m b -> m b
ioseq m b
act = m b
act m b -> (b -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \b
x -> b
x b -> m b -> m b
`seq` b -> m b
forall (m :: * -> *) a. Monad m => a -> m a
return b
x

                     (Response
res, Bool
handlerKilled) <- ((, Bool
False) (Response -> (Response, Bool))
-> IO Response -> IO (Response, Bool)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` IO Response -> IO Response
forall (m :: * -> *) b. Monad m => m b -> m b
ioseq (Request -> IO Response
handler Request
req))
                         IO (Response, Bool)
-> [Handler (Response, Bool)] -> IO (Response, Bool)
forall a. IO a -> [Handler a] -> IO a
`E.catches` [ (EscapeHTTP -> IO (Response, Bool)) -> Handler (Response, Bool)
forall a e. Exception e => (e -> IO a) -> Handler a
Handler ((EscapeHTTP -> IO (Response, Bool)) -> Handler (Response, Bool))
-> (EscapeHTTP -> IO (Response, Bool)) -> Handler (Response, Bool)
forall a b. (a -> b) -> a -> b
$ \(EscapeHTTP
e::EscapeHTTP)      -> EscapeHTTP -> IO (Response, Bool)
forall e a. Exception e => e -> IO a
throwIO EscapeHTTP
e -- need to handle this higher up
                                     , (SomeException -> IO (Response, Bool)) -> Handler (Response, Bool)
forall a e. Exception e => (e -> IO a) -> Handler a
Handler ((SomeException -> IO (Response, Bool))
 -> Handler (Response, Bool))
-> (SomeException -> IO (Response, Bool))
-> Handler (Response, Bool)
forall a b. (a -> b) -> a -> b
$ \(SomeException
e::E.SomeException) -> (Response, Bool) -> IO (Response, Bool)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> Response
failResponse (SomeException -> String
forall a. Show a => a -> String
show SomeException
e), SomeException -> Maybe AsyncException
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e Maybe AsyncException -> Maybe AsyncException -> Bool
forall a. Eq a => a -> a -> Bool
== AsyncException -> Maybe AsyncException
forall a. a -> Maybe a
Just AsyncException
ThreadKilled)
                                     ]

                     case Maybe (LogAccess UTCTime)
mlog of
                       Maybe (LogAccess UTCTime)
Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                       (Just LogAccess UTCTime
logger) ->
                           do UTCTime
time <- IO UTCTime
getApproximateUTCTime
                              let host' :: String
host'        = Host -> String
forall a b. (a, b) -> a
fst Host
host
                                  user :: String
user         = String
"-"
                                  requestLn :: String
requestLn    = [String] -> String
unwords [Method -> String
forall a. Show a => a -> String
show (Method -> String) -> Method -> String
forall a b. (a -> b) -> a -> b
$ Request -> Method
rqMethod Request
req, Request -> String
rqUri Request
req, HttpVersion -> String
forall a. Show a => a -> String
show (HttpVersion -> String) -> HttpVersion -> String
forall a b. (a -> b) -> a -> b
$ Request -> HttpVersion
rqVersion Request
req]
                                  responseCode :: Int
responseCode = Response -> Int
rsCode Response
res
                                  size :: Integer
size         = Integer -> (ByteString -> Integer) -> Maybe ByteString -> Integer
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (-Integer
1) (String -> Integer
forall a. (Num a, Eq a) => String -> a
readDec' (String -> Integer)
-> (ByteString -> String) -> ByteString -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
B.unpack) (String -> Response -> Maybe ByteString
forall r. HasHeaders r => String -> r -> Maybe ByteString
getHeader String
"Content-Length" Response
res) -- -1 indicates unknown size
                                  referer :: String
referer      = ByteString -> String
B.unpack (ByteString -> String) -> ByteString -> String
forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe ByteString -> ByteString
forall a. a -> Maybe a -> a
fromMaybe (String -> ByteString
B.pack String
"") (Maybe ByteString -> ByteString) -> Maybe ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ String -> Request -> Maybe ByteString
forall r. HasHeaders r => String -> r -> Maybe ByteString
getHeader String
"Referer" Request
req
                                  userAgent :: String
userAgent    = ByteString -> String
B.unpack (ByteString -> String) -> ByteString -> String
forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe ByteString -> ByteString
forall a. a -> Maybe a -> a
fromMaybe (String -> ByteString
B.pack String
"") (Maybe ByteString -> ByteString) -> Maybe ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ String -> Request -> Maybe ByteString
forall r. HasHeaders r => String -> r -> Maybe ByteString
getHeader String
"User-Agent" Request
req
                              LogAccess UTCTime
logger String
host' String
user UTCTime
time String
requestLn Int
responseCode Integer
size String
referer String
userAgent

                     -- withNoPush sock $ putAugmentedResult thandle sock req res
                     TimeoutIO -> Request -> Response -> IO ()
putAugmentedResult TimeoutIO
timeoutIO Request
req Response
res
                     -- clean up tmp files
                     Request -> IO ()
cleanupTempFiles Request
req
                     -- do not continue if handler was killed
                     Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
handlerKilled Bool -> Bool -> Bool
&& Request -> Response -> Bool
continueHTTP Request
req Response
res) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                         TimeoutIO
-> Maybe (LogAccess UTCTime)
-> Host
-> (Request -> IO Response)
-> ByteString
-> IO ()
rloop TimeoutIO
timeoutIO Maybe (LogAccess UTCTime)
mlog Host
host Request -> IO Response
handler ByteString
nextRequest) IO () -> (EscapeHTTP -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`E.catch` (TimeoutIO -> EscapeHTTP -> IO ()
escapeHttpHandler TimeoutIO
timeoutIO)

escapeHttpHandler :: TimeoutIO
                  -> EscapeHTTP
                  -> IO ()
escapeHttpHandler :: TimeoutIO -> EscapeHTTP -> IO ()
escapeHttpHandler TimeoutIO
tio (EscapeHTTP TimeoutIO -> IO ()
f) = TimeoutIO -> IO ()
f TimeoutIO
tio

-- NOTE: if someone took the inputs and never put them back, then they are responsible for the cleanup
cleanupTempFiles :: Request -> IO ()
cleanupTempFiles :: Request -> IO ()
cleanupTempFiles Request
req =
    do Maybe [(String, Input)]
mInputs <- MVar [(String, Input)] -> IO (Maybe [(String, Input)])
forall a. MVar a -> IO (Maybe a)
tryTakeMVar (Request -> MVar [(String, Input)]
rqInputsBody Request
req)
       case Maybe [(String, Input)]
mInputs of
         Maybe [(String, Input)]
Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
         (Just [(String, Input)]
inputs) -> ((String, Input) -> IO ()) -> [(String, Input)] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (String, Input) -> IO ()
deleteTmpFile [(String, Input)]
inputs
    where
      deleteTmpFile :: (String, Input) -> IO ()
      deleteTmpFile :: (String, Input) -> IO ()
deleteTmpFile (String
_, Input
input) =
          case Input -> Either String ByteString
inputValue Input
input of
            (Left String
fp) -> (IOError -> Maybe ()) -> IO () -> (() -> IO ()) -> IO ()
forall e b a.
Exception e =>
(e -> Maybe b) -> IO a -> (b -> IO a) -> IO a
E.catchJust (Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> (IOError -> Bool) -> IOError -> Maybe ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IOError -> Bool
isDoesNotExistError) (String -> IO ()
removeFile String
fp)  (IO () -> () -> IO ()
forall a b. a -> b -> a
const (IO () -> () -> IO ()) -> IO () -> () -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())
            Either String ByteString
_         -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | Unserializes the bytestring into a response.  If there is an
-- error it will return @Left msg@.
parseResponse :: L.ByteString -> Either String Response
parseResponse :: ByteString -> Either String Response
parseResponse ByteString
inputStr =
    do (ByteString
topStr,ByteString
restStr) <- String
-> Maybe (ByteString, ByteString)
-> Either String (ByteString, ByteString)
forall a. String -> Maybe a -> Either String a
required String
"failed to separate response" (Maybe (ByteString, ByteString)
 -> Either String (ByteString, ByteString))
-> Maybe (ByteString, ByteString)
-> Either String (ByteString, ByteString)
forall a b. (a -> b) -> a -> b
$
                           ByteString -> Maybe (ByteString, ByteString)
splitAtEmptyLine ByteString
inputStr
       (ByteString
rsl,ByteString
headerStr) <- String
-> Maybe (ByteString, ByteString)
-> Either String (ByteString, ByteString)
forall a. String -> Maybe a -> Either String a
required String
"failed to separate headers/body" (Maybe (ByteString, ByteString)
 -> Either String (ByteString, ByteString))
-> Maybe (ByteString, ByteString)
-> Either String (ByteString, ByteString)
forall a b. (a -> b) -> a -> b
$
                          ByteString -> Maybe (ByteString, ByteString)
splitAtCRLF ByteString
topStr
       let (ByteString
_,Int
code) = ByteString -> (ByteString, Int)
responseLine ByteString
rsl
       [Header]
headers' <- case String -> String -> Maybe [Header]
forall (m :: * -> *). MonadFail m => String -> String -> m [Header]
parseHeaders String
"host" (ByteString -> String
L.unpack ByteString
headerStr) of
         Maybe [Header]
Nothing -> String -> Either String [Header]
forall a b. a -> Either a b
Left String
"failed to parse host header"
         Just [Header]
x -> [Header] -> Either String [Header]
forall a b. b -> Either a b
Right [Header]
x
       let headers :: Headers
headers = [Header] -> Headers
mkHeaders [Header]
headers'
       let mbCL :: Maybe Int
mbCL = ((Int, ByteString) -> Int) -> Maybe (Int, ByteString) -> Maybe Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int, ByteString) -> Int
forall a b. (a, b) -> a
fst (ByteString -> Maybe (Int, ByteString)
B.readInt (ByteString -> Maybe (Int, ByteString))
-> Maybe ByteString -> Maybe (Int, ByteString)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> Headers -> Maybe ByteString
forall r. HasHeaders r => String -> r -> Maybe ByteString
getHeader String
"content-length" Headers
headers)
       (ByteString
body,ByteString
_) <-
           Either String (ByteString, ByteString)
-> (Int -> Either String (ByteString, ByteString))
-> Maybe Int
-> Either String (ByteString, ByteString)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (if (Maybe ByteString -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe ByteString -> Bool) -> Maybe ByteString -> Bool
forall a b. (a -> b) -> a -> b
$ String -> Headers -> Maybe ByteString
forall r. HasHeaders r => String -> r -> Maybe ByteString
getHeader String
"transfer-encoding" Headers
headers)
                       then  (ByteString, ByteString) -> Either String (ByteString, ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString
restStr,String -> ByteString
L.pack String
"")
                       else  (ByteString, ByteString) -> Either String (ByteString, ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return ((ByteString, ByteString)
 -> Either String (ByteString, ByteString))
-> (ByteString, ByteString)
-> Either String (ByteString, ByteString)
forall a b. (a -> b) -> a -> b
$ ByteString -> (ByteString, ByteString)
consumeChunks ByteString
restStr)
                 (\Int
cl->(ByteString, ByteString) -> Either String (ByteString, ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int64 -> ByteString -> (ByteString, ByteString)
L.splitAt (Int -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
cl) ByteString
restStr))
                 Maybe Int
mbCL
       Response -> Either String Response
forall (m :: * -> *) a. Monad m => a -> m a
return (Response -> Either String Response)
-> Response -> Either String Response
forall a b. (a -> b) -> a -> b
$ Response :: Int
-> Headers
-> RsFlags
-> ByteString
-> Maybe (Response -> IO Response)
-> Response
Response {rsCode :: Int
rsCode=Int
code,rsHeaders :: Headers
rsHeaders=Headers
headers,rsBody :: ByteString
rsBody=ByteString
body,rsFlags :: RsFlags
rsFlags=Length -> RsFlags
RsFlags Length
ContentLength,rsValidator :: Maybe (Response -> IO Response)
rsValidator=Maybe (Response -> IO Response)
forall a. Maybe a
Nothing}

-- http://www.w3.org/Protocols/rfc2616/rfc2616-sec3.html
-- note this does NOT handle extenions
consumeChunks::L.ByteString->(L.ByteString,L.ByteString)
consumeChunks :: ByteString -> (ByteString, ByteString)
consumeChunks ByteString
str = let ([(Int64, ByteString)]
parts,ByteString
tr,ByteString
rest) = ByteString -> ([(Int64, ByteString)], ByteString, ByteString)
consumeChunksImpl ByteString
str in ([ByteString] -> ByteString
L.concat ([ByteString] -> ByteString)
-> ([(Int64, ByteString)] -> [ByteString])
-> [(Int64, ByteString)]
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([ByteString] -> [ByteString] -> [ByteString]
forall a. [a] -> [a] -> [a]
++ [ByteString
tr]) ([ByteString] -> [ByteString])
-> ([(Int64, ByteString)] -> [ByteString])
-> [(Int64, ByteString)]
-> [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.((Int64, ByteString) -> ByteString)
-> [(Int64, ByteString)] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map (Int64, ByteString) -> ByteString
forall a b. (a, b) -> b
snd ([(Int64, ByteString)] -> ByteString)
-> [(Int64, ByteString)] -> ByteString
forall a b. (a -> b) -> a -> b
$ [(Int64, ByteString)]
parts,ByteString
rest)

consumeChunksImpl :: L.ByteString -> ([(Int64, L.ByteString)], L.ByteString, L.ByteString)
consumeChunksImpl :: ByteString -> ([(Int64, ByteString)], ByteString, ByteString)
consumeChunksImpl ByteString
str
    | ByteString -> Bool
L.null ByteString
str = ([],ByteString
L.empty,ByteString
str)
    | Int64
chunkLen Int64 -> Int64 -> Bool
forall a. Eq a => a -> a -> Bool
== Int64
0 = let (ByteString
last,ByteString
rest') = Int64 -> ByteString -> (ByteString, ByteString)
L.splitAt Int64
lenLine1 ByteString
str
                          (ByteString
tr',ByteString
rest'') = ByteString -> (ByteString, ByteString)
getTrailer ByteString
rest'
                      in ([(Int64
0,ByteString
last)],ByteString
tr',ByteString
rest'')
    | Bool
otherwise = ((Int64
chunkLen,ByteString
part)(Int64, ByteString)
-> [(Int64, ByteString)] -> [(Int64, ByteString)]
forall a. a -> [a] -> [a]
:[(Int64, ByteString)]
crest,ByteString
tr,ByteString
rest2)
    where
      line1 :: ByteString
line1 = [ByteString] -> ByteString
forall a. [a] -> a
head ([ByteString] -> ByteString) -> [ByteString] -> ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> [ByteString]
lazylines ByteString
str
      lenLine1 :: Int64
lenLine1 = (ByteString -> Int64
L.length ByteString
line1) Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Int64
1 -- endchar
      chunkLen :: Int64
chunkLen = ((Int64, String) -> Int64
forall a b. (a, b) -> a
fst ((Int64, String) -> Int64) -> (Int64, String) -> Int64
forall a b. (a -> b) -> a -> b
$ [(Int64, String)] -> (Int64, String)
forall a. [a] -> a
head ([(Int64, String)] -> (Int64, String))
-> [(Int64, String)] -> (Int64, String)
forall a b. (a -> b) -> a -> b
$ ReadS Int64
forall a. (Eq a, Num a) => ReadS a
readHex ReadS Int64 -> ReadS Int64
forall a b. (a -> b) -> a -> b
$ ByteString -> String
L.unpack ByteString
line1)
      len :: Int64
len = Int64
chunkLen Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Int64
lenLine1 Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Int64
2
      (ByteString
part,ByteString
rest) = Int64 -> ByteString -> (ByteString, ByteString)
L.splitAt Int64
len ByteString
str
      ([(Int64, ByteString)]
crest,ByteString
tr,ByteString
rest2) = ByteString -> ([(Int64, ByteString)], ByteString, ByteString)
consumeChunksImpl ByteString
rest
      getTrailer :: ByteString -> (ByteString, ByteString)
getTrailer ByteString
s = Int64 -> ByteString -> (ByteString, ByteString)
L.splitAt Int64
index ByteString
s
          where index :: Int64
index | ByteString
crlfLC ByteString -> ByteString -> Bool
`L.isPrefixOf` ByteString
s = Int64
2
                      | Bool
otherwise = let iscrlf :: [Bool]
iscrlf = (Char -> Char -> Bool) -> ByteString -> ByteString -> [Bool]
forall a. (Char -> Char -> a) -> ByteString -> ByteString -> [a]
L.zipWith (\Char
a Char
b -> Char
a Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\r' Bool -> Bool -> Bool
&& Char
b Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\n') ByteString
s (ByteString -> [Bool])
-> (ByteString -> ByteString) -> ByteString -> [Bool]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
L.tail (ByteString -> [Bool]) -> ByteString -> [Bool]
forall a b. (a -> b) -> a -> b
$ ByteString
s
                                        Just Int
i = Bool -> [Bool] -> Maybe Int
forall a. Eq a => a -> [a] -> Maybe Int
elemIndex Bool
True ([Bool] -> Maybe Int) -> [Bool] -> Maybe Int
forall a b. (a -> b) -> a -> b
$ (Bool -> Bool -> Bool) -> [Bool] -> [Bool] -> [Bool]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Bool -> Bool -> Bool
(&&) [Bool]
iscrlf ([Bool] -> [Bool]
forall a. [a] -> [a]
tail ([Bool] -> [Bool]
forall a. [a] -> [a]
tail [Bool]
iscrlf))
                                    in Int -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Int64) -> Int -> Int64
forall a b. (a -> b) -> a -> b
$ Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
4

crlfLC :: L.ByteString
crlfLC :: ByteString
crlfLC = String -> ByteString
L.pack String
"\r\n"

-- Properly lazy version of 'lines' for lazy bytestrings
lazylines           :: L.ByteString -> [L.ByteString]
lazylines :: ByteString -> [ByteString]
lazylines ByteString
s
    | ByteString -> Bool
L.null ByteString
s  = []
    | Bool
otherwise =
        let (ByteString
l,ByteString
s') = (Char -> Bool) -> ByteString -> (ByteString, ByteString)
L.break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
(==) Char
'\n') ByteString
s
        in ByteString
l ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
: if ByteString -> Bool
L.null ByteString
s' then []
                            else ByteString -> [ByteString]
lazylines (ByteString -> ByteString
L.tail ByteString
s')

requestLine :: L.ByteString -> (Method, SURI, HttpVersion)
requestLine :: ByteString -> (Method, SURI, HttpVersion)
requestLine ByteString
l = case ByteString -> [ByteString]
P.words (([ByteString] -> ByteString
P.concat ([ByteString] -> ByteString)
-> (ByteString -> [ByteString]) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [ByteString]
L.toChunks) ByteString
l) of
                  [ByteString
rq,ByteString
uri,ByteString
ver] -> (ByteString -> Method
method ByteString
rq, URI -> SURI
SURI (URI -> SURI) -> URI -> SURI
forall a b. (a -> b) -> a -> b
$ ByteString -> URI
parseURIRef ByteString
uri, ByteString -> HttpVersion
version ByteString
ver)
                  [ByteString
rq,ByteString
uri] -> (ByteString -> Method
method ByteString
rq, URI -> SURI
SURI (URI -> SURI) -> URI -> SURI
forall a b. (a -> b) -> a -> b
$ ByteString -> URI
parseURIRef ByteString
uri,Int -> Int -> HttpVersion
HttpVersion Int
0 Int
9)
                  [ByteString]
x -> String -> (Method, SURI, HttpVersion)
forall a. HasCallStack => String -> a
error (String -> (Method, SURI, HttpVersion))
-> String -> (Method, SURI, HttpVersion)
forall a b. (a -> b) -> a -> b
$ String
"requestLine cannot handle input:  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ([ByteString] -> String
forall a. Show a => a -> String
show [ByteString]
x)

responseLine :: L.ByteString -> (B.ByteString, Int)
responseLine :: ByteString -> (ByteString, Int)
responseLine ByteString
l = case ByteString -> [ByteString]
B.words (([ByteString] -> ByteString
B.concat ([ByteString] -> ByteString)
-> (ByteString -> [ByteString]) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [ByteString]
L.toChunks) ByteString
l) of
                   (ByteString
v:ByteString
c:[ByteString]
_) -> ByteString -> HttpVersion
version ByteString
v HttpVersion -> (ByteString, Int) -> (ByteString, Int)
`seq` (ByteString
v,(Int, ByteString) -> Int
forall a b. (a, b) -> a
fst (Maybe (Int, ByteString) -> (Int, ByteString)
forall a. HasCallStack => Maybe a -> a
fromJust (ByteString -> Maybe (Int, ByteString)
B.readInt ByteString
c)))
                   [ByteString]
x -> String -> (ByteString, Int)
forall a. HasCallStack => String -> a
error (String -> (ByteString, Int)) -> String -> (ByteString, Int)
forall a b. (a -> b) -> a -> b
$ String
"responseLine cannot handle input: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ([ByteString] -> String
forall a. Show a => a -> String
show [ByteString]
x)


method :: B.ByteString -> Method
method :: ByteString -> Method
method ByteString
r = Maybe Method -> Method
fj (Maybe Method -> Method) -> Maybe Method -> Method
forall a b. (a -> b) -> a -> b
$ ByteString -> [(ByteString, Method)] -> Maybe Method
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup ByteString
r [(ByteString, Method)]
mtable
    where fj :: Maybe Method -> Method
fj (Just Method
x) = Method
x
          fj Maybe Method
Nothing  = ByteString -> Method
EXTENSION ByteString
r
          mtable :: [(ByteString, Method)]
mtable = [ (String -> ByteString
P.pack String
"GET",     Method
GET)
                   , (String -> ByteString
P.pack String
"HEAD",    Method
HEAD)
                   , (String -> ByteString
P.pack String
"POST",    Method
POST)
                   , (String -> ByteString
P.pack String
"PUT",     Method
PUT)
                   , (String -> ByteString
P.pack String
"DELETE",  Method
DELETE)
                   , (String -> ByteString
P.pack String
"TRACE",   Method
TRACE)
                   , (String -> ByteString
P.pack String
"OPTIONS", Method
OPTIONS)
                   , (String -> ByteString
P.pack String
"CONNECT", Method
CONNECT)
                   , (String -> ByteString
P.pack String
"PATCH",   Method
PATCH)
                   ]

-- Result side

staticHeaders :: Headers
staticHeaders :: Headers
staticHeaders =
    ((ByteString, ByteString) -> Headers -> Headers)
-> Headers -> [(ByteString, ByteString)] -> Headers
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((ByteString -> ByteString -> Headers -> Headers)
-> (ByteString, ByteString) -> Headers -> Headers
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ByteString -> ByteString -> Headers -> Headers
forall r. HasHeaders r => ByteString -> ByteString -> r -> r
setHeaderBS) ([Header] -> Headers
mkHeaders [])
    [ (ByteString
serverC, ByteString
happstackC) ]

-- FIXME: we should not be controlling the response headers in mysterious ways in this low level code
-- headers should be set by application code and the core http engine should be very lean.
putAugmentedResult :: TimeoutIO -> Request -> Response -> IO ()
putAugmentedResult :: TimeoutIO -> Request -> Response -> IO ()
putAugmentedResult TimeoutIO
timeoutIO Request
req Response
res = do
    case Response
res of
        -- standard bytestring response
        Response {} -> do
            let isChunked :: Bool
isChunked = RsFlags -> Length
rsfLength (Response -> RsFlags
rsFlags Response
res) Length -> Length -> Bool
forall a. Eq a => a -> a -> Bool
== Length
TransferEncodingChunked Bool -> Bool -> Bool
&& Request -> Bool
isHTTP1_1 Request
req
            Maybe Integer -> Bool -> IO ()
sendTop (if Bool
isChunked then Maybe Integer
forall a. Maybe a
Nothing else (Integer -> Maybe Integer
forall a. a -> Maybe a
Just (Int64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int64
L.length (Response -> ByteString
rsBody Response
res))))) Bool
isChunked
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Request -> Method
rqMethod Request
req Method -> Method -> Bool
forall a. Eq a => a -> a -> Bool
/= Method
HEAD)
                     (let body :: ByteString
body = if Bool
isChunked
                                 then ByteString -> ByteString
chunk (Response -> ByteString
rsBody Response
res)
                                 else Response -> ByteString
rsBody Response
res
                      in TimeoutIO -> ByteString -> IO ()
toPutLazy TimeoutIO
timeoutIO ByteString
body)
        -- zero-copy sendfile response
        -- the handle *should* be closed by the garbage collector

        SendFile {} -> do
            let infp :: String
infp = Response -> String
sfFilePath Response
res
                off :: Integer
off = Response -> Integer
sfOffset Response
res
                count :: Integer
count = Response -> Integer
sfCount Response
res
            Maybe Integer -> Bool -> IO ()
sendTop (Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
count) Bool
False
            Handle -> IO ()
TM.tickle (TimeoutIO -> Handle
toHandle TimeoutIO
timeoutIO)
            TimeoutIO -> String -> Integer -> Integer -> IO ()
toSendFile TimeoutIO
timeoutIO String
infp Integer
off Integer
count

    where ph :: HeaderPair -> [ByteString]
ph (HeaderPair ByteString
k [ByteString]
vs) = (ByteString -> ByteString) -> [ByteString] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map (\ByteString
v -> [ByteString] -> ByteString
P.concat [ByteString
k, ByteString
fsepC, ByteString
v, ByteString
crlfC]) [ByteString]
vs
          sendTop :: Maybe Integer -> Bool -> IO ()
sendTop Maybe Integer
cl Bool
isChunked = do
              Headers
allHeaders <- Request -> Response -> Maybe Integer -> Bool -> IO Headers
augmentHeaders Request
req Response
res Maybe Integer
cl Bool
isChunked
              TimeoutIO -> ByteString -> IO ()
toPut TimeoutIO
timeoutIO (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ [ByteString] -> ByteString
B.concat ([ByteString] -> ByteString) -> [ByteString] -> ByteString
forall a b. (a -> b) -> a -> b
$ [[ByteString]] -> [ByteString]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
                 [ (HttpVersion -> [ByteString]
pversion (HttpVersion -> [ByteString]) -> HttpVersion -> [ByteString]
forall a b. (a -> b) -> a -> b
$ Request -> HttpVersion
rqVersion Request
req)          -- Print HTTP version
                 , [Int -> ByteString
forall t. (Num t, Show t, Eq t) => t -> ByteString
responseMessage (Int -> ByteString) -> Int -> ByteString
forall a b. (a -> b) -> a -> b
$ Response -> Int
rsCode Response
res]      -- Print responseCode
                 , (HeaderPair -> [ByteString]) -> [HeaderPair] -> [ByteString]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap HeaderPair -> [ByteString]
ph (Headers -> [HeaderPair]
forall k a. Map k a -> [a]
M.elems Headers
allHeaders)   -- Print all headers
                 , [ByteString
crlfC]
                 ]
              Handle -> IO ()
TM.tickle (TimeoutIO -> Handle
toHandle TimeoutIO
timeoutIO)
          chunk :: L.ByteString -> L.ByteString
          chunk :: ByteString -> ByteString
chunk ByteString
Empty        = String -> ByteString
LC.pack String
"0\r\n\r\n"
          chunk (Chunk ByteString
c ByteString
cs) = ByteString -> ByteString -> ByteString
Chunk (String -> ByteString
B.pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ Int -> String -> String
forall a. (Integral a, Show a) => a -> String -> String
showHex (ByteString -> Int
B.length ByteString
c) String
"\r\n") (ByteString -> ByteString -> ByteString
Chunk ByteString
c (ByteString -> ByteString -> ByteString
Chunk (String -> ByteString
B.pack String
"\r\n") (ByteString -> ByteString
chunk ByteString
cs)))

augmentHeaders :: Request -> Response -> Maybe Integer -> Bool -> IO Headers
augmentHeaders :: Request -> Response -> Maybe Integer -> Bool -> IO Headers
augmentHeaders Request
req Response
res Maybe Integer
mcl Bool
isChunked = do
    -- TODO: Hoist static headers to the toplevel.
    ByteString
raw <- IO ByteString
getApproximateTime
    let stdHeaders :: Headers
stdHeaders = Headers
staticHeaders Headers -> Headers -> Headers
forall k a. Ord k => Map k a -> Map k a -> Map k a
`M.union`
          [(ByteString, HeaderPair)] -> Headers
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ( [ (ByteString
dateCLower,       ByteString -> [ByteString] -> HeaderPair
HeaderPair ByteString
dateC [ByteString
raw])
                       , (ByteString
connectionCLower, ByteString -> [ByteString] -> HeaderPair
HeaderPair ByteString
connectionC [if Request -> Response -> Bool
continueHTTP Request
req Response
res then ByteString
keepAliveC else ByteString
closeC])
                       ] [(ByteString, HeaderPair)]
-> [(ByteString, HeaderPair)] -> [(ByteString, HeaderPair)]
forall a. [a] -> [a] -> [a]
++ case RsFlags -> Length
rsfLength (Response -> RsFlags
rsFlags Response
res) of
                              Length
NoContentLength -> []
                              Length
ContentLength | Bool -> Bool
not (String -> Response -> Bool
forall r. HasHeaders r => String -> r -> Bool
hasHeader String
"Content-Length" Response
res) ->
                                                case Maybe Integer
mcl of
                                                  (Just Integer
cl) -> [(ByteString
contentlengthC, ByteString -> [ByteString] -> HeaderPair
HeaderPair ByteString
contentLengthC [String -> ByteString
P.pack (Integer -> String
forall a. Show a => a -> String
show Integer
cl)])]
                                                  Maybe Integer
_ -> []
                                            | Bool
otherwise -> []
                              Length
TransferEncodingChunked
                                  -- we check 'chunked' because we might not use this mode if the client is http 1.0
                                  | Bool
isChunked -> [(ByteString
transferEncodingC, ByteString -> [ByteString] -> HeaderPair
HeaderPair ByteString
transferEncodingC [ByteString
chunkedC])]
                                  | Bool
otherwise -> []

                     )
    Headers -> IO Headers
forall (m :: * -> *) a. Monad m => a -> m a
return (Response -> Headers
rsHeaders Response
res Headers -> Headers -> Headers
forall k a. Ord k => Map k a -> Map k a -> Map k a
`M.union` Headers
stdHeaders) -- 'union' prefers 'headers res' when duplicate keys are encountered.

-- | Serializes the request to the given handle
putRequest :: Handle -> Request -> IO ()
putRequest :: Handle -> Request -> IO ()
putRequest Handle
h Request
rq = do
    let put :: ByteString -> IO ()
put = Handle -> ByteString -> IO ()
B.hPut Handle
h
        ph :: HeaderPair -> [ByteString]
ph (HeaderPair ByteString
k [ByteString]
vs) = (ByteString -> ByteString) -> [ByteString] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map (\ByteString
v -> [ByteString] -> ByteString
B.concat [ByteString
k, ByteString
fsepC, ByteString
v, ByteString
crlfC]) [ByteString]
vs
        sp :: [ByteString]
sp = [String -> ByteString
B.pack String
" "]
    (ByteString -> IO ()) -> [ByteString] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ByteString -> IO ()
put ([ByteString] -> IO ()) -> [ByteString] -> IO ()
forall a b. (a -> b) -> a -> b
$ [[ByteString]] -> [ByteString]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
      [[String -> ByteString
B.pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ Method -> String
forall a. Show a => a -> String
show (Method -> String) -> Method -> String
forall a b. (a -> b) -> a -> b
$ Request -> Method
rqMethod Request
rq],[ByteString]
sp
      ,[String -> ByteString
B.pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ Request -> String
rqURL Request
rq],[ByteString]
sp
      ,(HttpVersion -> [ByteString]
pversion (HttpVersion -> [ByteString]) -> HttpVersion -> [ByteString]
forall a b. (a -> b) -> a -> b
$ Request -> HttpVersion
rqVersion Request
rq), [ByteString
crlfC]
      ,(HeaderPair -> [ByteString]) -> [HeaderPair] -> [ByteString]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap HeaderPair -> [ByteString]
ph (Headers -> [HeaderPair]
forall k a. Map k a -> [a]
M.elems (Headers -> [HeaderPair]) -> Headers -> [HeaderPair]
forall a b. (a -> b) -> a -> b
$ Request -> Headers
rqHeaders Request
rq)
      ,[ByteString
crlfC]
      ]
    Maybe RqBody
mBody <- Request -> IO (Maybe RqBody)
forall (m :: * -> *). MonadIO m => Request -> m (Maybe RqBody)
takeRequestBody Request
rq -- tryTakeMVar (rqBody rq)
    Handle -> ByteString -> IO ()
L.hPut Handle
h (ByteString -> (RqBody -> ByteString) -> Maybe RqBody -> ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ByteString
L.empty RqBody -> ByteString
unBody Maybe RqBody
mBody) -- FIXME: should this actually be an error if the body is null?
    Handle -> IO ()
hFlush Handle
h

-- HttpVersion

pversion :: HttpVersion -> [B.ByteString]
pversion :: HttpVersion -> [ByteString]
pversion (HttpVersion Int
1 Int
1) = [ByteString
http11]
pversion (HttpVersion Int
1 Int
0) = [ByteString
http10]
pversion (HttpVersion Int
x Int
y) = [String -> ByteString
P.pack String
"HTTP/", String -> ByteString
P.pack (Int -> String
forall a. Show a => a -> String
show Int
x), String -> ByteString
P.pack String
".", String -> ByteString
P.pack (Int -> String
forall a. Show a => a -> String
show Int
y)]

version :: B.ByteString -> HttpVersion
version :: ByteString -> HttpVersion
version ByteString
x | ByteString
x ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
http09 = Int -> Int -> HttpVersion
HttpVersion Int
0 Int
9
          | ByteString
x ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
http10 = Int -> Int -> HttpVersion
HttpVersion Int
1 Int
0
          | ByteString
x ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
http11 = Int -> Int -> HttpVersion
HttpVersion Int
1 Int
1
          | Bool
otherwise   = String -> HttpVersion
forall a. HasCallStack => String -> a
error String
"Invalid HTTP version"

http09 :: B.ByteString
http09 :: ByteString
http09 = String -> ByteString
P.pack String
"HTTP/0.9"
http10 :: B.ByteString
http10 :: ByteString
http10 = String -> ByteString
P.pack String
"HTTP/1.0"
http11 :: B.ByteString
http11 :: ByteString
http11 = String -> ByteString
P.pack String
"HTTP/1.1"

-- * ByteString Constants

connectionC :: B.ByteString
connectionC :: ByteString
connectionC      = String -> ByteString
P.pack String
"Connection"
connectionCLower :: B.ByteString
connectionCLower :: ByteString
connectionCLower = (Char -> Char) -> ByteString -> ByteString
P.map Char -> Char
toLower ByteString
connectionC
closeC :: B.ByteString
closeC :: ByteString
closeC           = String -> ByteString
P.pack String
"close"
keepAliveC :: B.ByteString
keepAliveC :: ByteString
keepAliveC       = String -> ByteString
P.pack String
"Keep-Alive"
crlfC :: B.ByteString
crlfC :: ByteString
crlfC            = String -> ByteString
P.pack String
"\r\n"
fsepC :: B.ByteString
fsepC :: ByteString
fsepC            = String -> ByteString
P.pack String
": "
-- contentTypeC :: B.ByteString
-- contentTypeC     = P.pack "Content-Type"
contentLengthC :: B.ByteString
contentLengthC :: ByteString
contentLengthC   = String -> ByteString
P.pack String
"Content-Length"
contentlengthC :: B.ByteString
contentlengthC :: ByteString
contentlengthC   = String -> ByteString
P.pack String
"content-length"
dateC :: B.ByteString
dateC :: ByteString
dateC            = String -> ByteString
P.pack String
"Date"
dateCLower :: B.ByteString
dateCLower :: ByteString
dateCLower       = (Char -> Char) -> ByteString -> ByteString
P.map Char -> Char
toLower ByteString
dateC
serverC :: B.ByteString
serverC :: ByteString
serverC          = String -> ByteString
P.pack String
"Server"
happstackC :: B.ByteString
happstackC :: ByteString
happstackC           = String -> ByteString
P.pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ String
"Happstack/" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Version -> String
DV.showVersion Version
Paths.version
-- textHtmlC :: B.ByteString
-- textHtmlC        = P.pack "text/html; charset=utf-8"
transferEncodingC :: B.ByteString
transferEncodingC :: ByteString
transferEncodingC = String -> ByteString
P.pack String
"Transfer-Encoding"
chunkedC :: B.ByteString
chunkedC :: ByteString
chunkedC = String -> ByteString
P.pack String
"chunked"

-- Response code names

responseMessage :: (Num t, Show t, Eq t) => t -> B.ByteString
responseMessage :: t -> ByteString
responseMessage t
100 = String -> ByteString
P.pack String
" 100 Continue\r\n"
responseMessage t
101 = String -> ByteString
P.pack String
" 101 Switching Protocols\r\n"
responseMessage t
200 = String -> ByteString
P.pack String
" 200 OK\r\n"
responseMessage t
201 = String -> ByteString
P.pack String
" 201 Created\r\n"
responseMessage t
202 = String -> ByteString
P.pack String
" 202 Accepted\r\n"
responseMessage t
203 = String -> ByteString
P.pack String
" 203 Non-Authoritative Information\r\n"
responseMessage t
204 = String -> ByteString
P.pack String
" 204 No Content\r\n"
responseMessage t
205 = String -> ByteString
P.pack String
" 205 Reset Content\r\n"
responseMessage t
206 = String -> ByteString
P.pack String
" 206 Partial Content\r\n"
responseMessage t
300 = String -> ByteString
P.pack String
" 300 Multiple Choices\r\n"
responseMessage t
301 = String -> ByteString
P.pack String
" 301 Moved Permanently\r\n"
responseMessage t
302 = String -> ByteString
P.pack String
" 302 Found\r\n"
responseMessage t
303 = String -> ByteString
P.pack String
" 303 See Other\r\n"
responseMessage t
304 = String -> ByteString
P.pack String
" 304 Not Modified\r\n"
responseMessage t
305 = String -> ByteString
P.pack String
" 305 Use Proxy\r\n"
responseMessage t
307 = String -> ByteString
P.pack String
" 307 Temporary Redirect\r\n"
responseMessage t
400 = String -> ByteString
P.pack String
" 400 Bad Request\r\n"
responseMessage t
401 = String -> ByteString
P.pack String
" 401 Unauthorized\r\n"
responseMessage t
402 = String -> ByteString
P.pack String
" 402 Payment Required\r\n"
responseMessage t
403 = String -> ByteString
P.pack String
" 403 Forbidden\r\n"
responseMessage t
404 = String -> ByteString
P.pack String
" 404 Not Found\r\n"
responseMessage t
405 = String -> ByteString
P.pack String
" 405 Method Not Allowed\r\n"
responseMessage t
406 = String -> ByteString
P.pack String
" 406 Not Acceptable\r\n"
responseMessage t
407 = String -> ByteString
P.pack String
" 407 Proxy Authentication Required\r\n"
responseMessage t
408 = String -> ByteString
P.pack String
" 408 Request Time-out\r\n"
responseMessage t
409 = String -> ByteString
P.pack String
" 409 Conflict\r\n"
responseMessage t
410 = String -> ByteString
P.pack String
" 410 Gone\r\n"
responseMessage t
411 = String -> ByteString
P.pack String
" 411 Length Required\r\n"
responseMessage t
412 = String -> ByteString
P.pack String
" 412 Precondition Failed\r\n"
responseMessage t
413 = String -> ByteString
P.pack String
" 413 Request Entity Too Large\r\n"
responseMessage t
414 = String -> ByteString
P.pack String
" 414 Request-URI Too Large\r\n"
responseMessage t
415 = String -> ByteString
P.pack String
" 415 Unsupported Media Type\r\n"
responseMessage t
416 = String -> ByteString
P.pack String
" 416 Requested range not satisfiable\r\n"
responseMessage t
417 = String -> ByteString
P.pack String
" 417 Expectation Failed\r\n"
responseMessage t
500 = String -> ByteString
P.pack String
" 500 Internal Server Error\r\n"
responseMessage t
501 = String -> ByteString
P.pack String
" 501 Not Implemented\r\n"
responseMessage t
502 = String -> ByteString
P.pack String
" 502 Bad Gateway\r\n"
responseMessage t
503 = String -> ByteString
P.pack String
" 503 Service Unavailable\r\n"
responseMessage t
504 = String -> ByteString
P.pack String
" 504 Gateway Time-out\r\n"
responseMessage t
505 = String -> ByteString
P.pack String
" 505 HTTP Version not supported\r\n"
responseMessage t
x   = String -> ByteString
P.pack (String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ t -> String
forall a. Show a => a -> String
show t
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" \r\n")