{-# 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
timeoutIO mlog :: Maybe (LogAccess UTCTime)
mlog host :: Host
host handler :: 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 err :: String
err Nothing  = String -> Either String a
forall a b. a -> Either a b
Left String
err
required _   (Just a :: 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
timeoutIO mlog :: Maybe (LogAccess UTCTime)
mlog host :: Host
host handler :: Request -> IO Response
handler inputStr :: 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
                      (topStr :: ByteString
topStr, restStr :: ByteString
restStr) <- String
-> Maybe (ByteString, ByteString)
-> Either String (ByteString, ByteString)
forall a. String -> Maybe a -> Either String a
required "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
                      (rql :: ByteString
rql, headerStr :: ByteString
headerStr)  <- String
-> Maybe (ByteString, ByteString)
-> Either String (ByteString, ByteString)
forall a. String -> Maybe a -> Either String a
required "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 (m :: Method
m,u :: SURI
u,v :: 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 "host" (ByteString -> String
L.unpack ByteString
headerStr) of
                        Nothing -> String -> Either String [Header]
forall a b. a -> Either a b
Left "failed to parse host header"
                        Just x :: [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 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)
                      (body :: ByteString
body, nextRequest :: ByteString
nextRequest) <- case () of
                          () | Int
contentLen Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< 0               -> String -> Either String (ByteString, ByteString)
forall a b. a -> Either a b
Left "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 "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 err :: String
err -> String -> IO (IO ())
forall a. HasCallStack => String -> a
error (String -> IO (IO ())) -> String -> IO (IO ())
forall a b. (a -> b) -> a -> b
$ "failed to parse HTTP request: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
err
           Right (m :: Method
m, u :: SURI
u, cookies :: [(String, Cookie)]
cookies, v :: HttpVersion
v, headers :: Headers
headers, body :: ByteString
body, nextRequest :: 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 act :: 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
>>= \x :: b
x -> b
x b -> m b -> m b
forall a b. a -> b -> b
`seq` b -> m b
forall (m :: * -> *) a. Monad m => a -> m a
return b
x

                     (res :: Response
res, handlerKilled :: 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
                       Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                       (Just logger :: 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         = "-"
                                  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 (-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 "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 "") (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 "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 "") (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 "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 tio :: TimeoutIO
tio (EscapeHTTP f :: 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 req :: 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
         Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
         (Just inputs :: [(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 (_, input :: Input
input) =
          case Input -> Either String ByteString
inputValue Input
input of
            (Left fp :: 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 ())
            _         -> () -> 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 inputStr :: ByteString
inputStr =
    do (topStr :: ByteString
topStr,restStr :: ByteString
restStr) <- String
-> Maybe (ByteString, ByteString)
-> Either String (ByteString, ByteString)
forall a. String -> Maybe a -> Either String a
required "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
       (rsl :: ByteString
rsl,headerStr :: ByteString
headerStr) <- String
-> Maybe (ByteString, ByteString)
-> Either String (ByteString, ByteString)
forall a. String -> Maybe a -> Either String a
required "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 (_,code :: Int
code) = ByteString -> (ByteString, Int)
responseLine ByteString
rsl
       [Header]
headers' <- case String -> String -> Maybe [Header]
forall (m :: * -> *). MonadFail m => String -> String -> m [Header]
parseHeaders "host" (ByteString -> String
L.unpack ByteString
headerStr) of
         Nothing -> String -> Either String [Header]
forall a b. a -> Either a b
Left "failed to parse host header"
         Just x :: [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 "content-length" Headers
headers)
       (body :: ByteString
body,_) <-
           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 "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 "")
                       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)
                 (\cl :: 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 str :: ByteString
str = let (parts :: [(Int64, ByteString)]
parts,tr :: ByteString
tr,rest :: 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 str :: 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
== 0 = let (last :: ByteString
last,rest' :: ByteString
rest') = Int64 -> ByteString -> (ByteString, ByteString)
L.splitAt Int64
lenLine1 ByteString
str
                          (tr' :: ByteString
tr',rest'' :: ByteString
rest'') = ByteString -> (ByteString, ByteString)
getTrailer ByteString
rest'
                      in ([(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
+ 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
+ 2
      (part :: ByteString
part,rest :: ByteString
rest) = Int64 -> ByteString -> (ByteString, ByteString)
L.splitAt Int64
len ByteString
str
      (crest :: [(Int64, ByteString)]
crest,tr :: ByteString
tr,rest2 :: ByteString
rest2) = ByteString -> ([(Int64, ByteString)], ByteString, ByteString)
consumeChunksImpl ByteString
rest
      getTrailer :: ByteString -> (ByteString, ByteString)
getTrailer s :: 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 = 2
                      | Bool
otherwise = let iscrlf :: [Bool]
iscrlf = (Char -> Char -> Bool) -> ByteString -> ByteString -> [Bool]
forall a. (Char -> Char -> a) -> ByteString -> ByteString -> [a]
L.zipWith (\a :: Char
a b :: Char
b -> Char
a Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '\r' Bool -> Bool -> Bool
&& Char
b Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '\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 i :: 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
+4

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

-- Properly lazy version of 'lines' for lazy bytestrings
lazylines           :: L.ByteString -> [L.ByteString]
lazylines :: ByteString -> [ByteString]
lazylines s :: ByteString
s
    | ByteString -> Bool
L.null ByteString
s  = []
    | Bool
otherwise =
        let (l :: ByteString
l,s' :: ByteString
s') = (Char -> Bool) -> ByteString -> (ByteString, ByteString)
L.break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
(==) '\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 l :: 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
                  [rq :: ByteString
rq,uri :: ByteString
uri,ver :: 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)
                  [rq :: ByteString
rq,uri :: 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 0 9)
                  x :: [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
$ "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 l :: 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
                   (v :: ByteString
v:c :: ByteString
c:_) -> ByteString -> HttpVersion
version ByteString
v HttpVersion -> (ByteString, Int) -> (ByteString, Int)
forall a b. a -> b -> b
`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)))
                   x :: [ByteString]
x -> String -> (ByteString, Int)
forall a. HasCallStack => String -> a
error (String -> (ByteString, Int)) -> String -> (ByteString, Int)
forall a b. (a -> b) -> a -> b
$ "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 r :: 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 x :: Method
x) = Method
x
          fj Nothing  = ByteString -> Method
EXTENSION ByteString
r
          mtable :: [(ByteString, Method)]
mtable = [ (String -> ByteString
P.pack "GET",     Method
GET)
                   , (String -> ByteString
P.pack "HEAD",    Method
HEAD)
                   , (String -> ByteString
P.pack "POST",    Method
POST)
                   , (String -> ByteString
P.pack "PUT",     Method
PUT)
                   , (String -> ByteString
P.pack "DELETE",  Method
DELETE)
                   , (String -> ByteString
P.pack "TRACE",   Method
TRACE)
                   , (String -> ByteString
P.pack "OPTIONS", Method
OPTIONS)
                   , (String -> ByteString
P.pack "CONNECT", Method
CONNECT)
                   , (String -> ByteString
P.pack "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
timeoutIO req :: Request
req res :: 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 k :: ByteString
k vs :: [ByteString]
vs) = (ByteString -> ByteString) -> [ByteString] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map (\v :: ByteString
v -> [ByteString] -> ByteString
P.concat [ByteString
k, ByteString
fsepC, ByteString
v, ByteString
crlfC]) [ByteString]
vs
          sendTop :: Maybe Integer -> Bool -> IO ()
sendTop cl :: Maybe Integer
cl isChunked :: 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 Empty        = String -> ByteString
LC.pack "0\r\n\r\n"
          chunk (Chunk c :: ByteString
c cs :: 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) "\r\n") (ByteString -> ByteString -> ByteString
Chunk ByteString
c (ByteString -> ByteString -> ByteString
Chunk (String -> ByteString
B.pack "\r\n") (ByteString -> ByteString
chunk ByteString
cs)))

augmentHeaders :: Request -> Response -> Maybe Integer -> Bool -> IO Headers
augmentHeaders :: Request -> Response -> Maybe Integer -> Bool -> IO Headers
augmentHeaders req :: Request
req res :: Response
res mcl :: Maybe Integer
mcl isChunked :: 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
                              NoContentLength -> []
                              ContentLength | Bool -> Bool
not (String -> Response -> Bool
forall r. HasHeaders r => String -> r -> Bool
hasHeader "Content-Length" Response
res) ->
                                                case Maybe Integer
mcl of
                                                  (Just cl :: 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)])]
                                                  _ -> []
                                            | Bool
otherwise -> []
                              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 h :: Handle
h rq :: Request
rq = do
    let put :: ByteString -> IO ()
put = Handle -> ByteString -> IO ()
B.hPut Handle
h
        ph :: HeaderPair -> [ByteString]
ph (HeaderPair k :: ByteString
k vs :: [ByteString]
vs) = (ByteString -> ByteString) -> [ByteString] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map (\v :: ByteString
v -> [ByteString] -> ByteString
B.concat [ByteString
k, ByteString
fsepC, ByteString
v, ByteString
crlfC]) [ByteString]
vs
        sp :: [ByteString]
sp = [String -> ByteString
B.pack " "]
    (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 1 1) = [ByteString
http11]
pversion (HttpVersion 1 0) = [ByteString
http10]
pversion (HttpVersion x :: Int
x y :: Int
y) = [String -> ByteString
P.pack "HTTP/", String -> ByteString
P.pack (Int -> String
forall a. Show a => a -> String
show Int
x), String -> ByteString
P.pack ".", String -> ByteString
P.pack (Int -> String
forall a. Show a => a -> String
show Int
y)]

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

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

-- * ByteString Constants

connectionC :: B.ByteString
connectionC :: ByteString
connectionC      = String -> ByteString
P.pack "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 "close"
keepAliveC :: B.ByteString
keepAliveC :: ByteString
keepAliveC       = String -> ByteString
P.pack "Keep-Alive"
crlfC :: B.ByteString
crlfC :: ByteString
crlfC            = String -> ByteString
P.pack "\r\n"
fsepC :: B.ByteString
fsepC :: ByteString
fsepC            = String -> ByteString
P.pack ": "
-- contentTypeC :: B.ByteString
-- contentTypeC     = P.pack "Content-Type"
contentLengthC :: B.ByteString
contentLengthC :: ByteString
contentLengthC   = String -> ByteString
P.pack "Content-Length"
contentlengthC :: B.ByteString
contentlengthC :: ByteString
contentlengthC   = String -> ByteString
P.pack "content-length"
dateC :: B.ByteString
dateC :: ByteString
dateC            = String -> ByteString
P.pack "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 "Server"
happstackC :: B.ByteString
happstackC :: ByteString
happstackC           = String -> ByteString
P.pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ "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 "Transfer-Encoding"
chunkedC :: B.ByteString
chunkedC :: ByteString
chunkedC = String -> ByteString
P.pack "chunked"

-- Response code names

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