-----------------------------------------------------------------------------
-- |
-- Module      :  Network.HTTP.HandleStream
-- Copyright   :  See LICENSE file
-- License     :  BSD
-- 
-- Maintainer  :  Ganesh Sittampalam <ganesh@earth.li>
-- Stability   :  experimental
-- Portability :  non-portable (not tested)
--
-- A 'HandleStream'-based version of "Network.HTTP" interface.
--
-- For more detailed information about what the individual exports do, please consult
-- the documentation for "Network.HTTP". /Notice/ however that the functions here do
-- not perform any kind of normalization prior to transmission (or receipt); you are
-- responsible for doing any such yourself, or, if you prefer, just switch to using
-- "Network.HTTP" function instead.
-- 
-----------------------------------------------------------------------------
module Network.HTTP.HandleStream 
       ( simpleHTTP      -- :: Request ty -> IO (Result (Response ty))
       , simpleHTTP_     -- :: HStream ty => HandleStream ty -> Request ty -> IO (Result (Response ty))
       , sendHTTP        -- :: HStream ty => HandleStream ty -> Request ty -> IO (Result (Response ty))
       , sendHTTP_notify -- :: HStream ty => HandleStream ty -> Request ty -> IO () -> IO (Result (Response ty))
       , receiveHTTP     -- :: HStream ty => HandleStream ty -> IO (Result (Request ty))
       , respondHTTP     -- :: HStream ty => HandleStream ty -> Response ty -> IO ()
       
       , simpleHTTP_debug -- :: FilePath -> Request DebugString -> IO (Response DebugString)
       ) where

-----------------------------------------------------------------
------------------ Imports --------------------------------------
-----------------------------------------------------------------

import Network.BufferType
import Network.Stream ( fmapE, Result )
import Network.StreamDebugger ( debugByteStream )
import Network.TCP (HStream(..), HandleStream )

import Network.HTTP.Base
import Network.HTTP.Headers
import Network.HTTP.Utils ( trim, readsOne )

import Data.Char (toLower)
import Data.Maybe (fromMaybe)
import Control.Exception (onException)
import Control.Monad (when)

-----------------------------------------------------------------
------------------ Misc -----------------------------------------
-----------------------------------------------------------------

-- | @simpleHTTP@ transmits a resource across a non-persistent connection.
simpleHTTP :: HStream ty => Request ty -> IO (Result (Response ty))
simpleHTTP :: Request ty -> IO (Result (Response ty))
simpleHTTP Request ty
r = do 
  URIAuthority
auth <- Request ty -> IO URIAuthority
forall (m :: * -> *) ty.
MonadFail m =>
Request ty -> m URIAuthority
getAuth Request ty
r
  URI -> IO ()
forall (m :: * -> *). MonadFail m => URI -> m ()
failHTTPS (Request ty -> URI
forall a. Request a -> URI
rqURI Request ty
r)
  HandleStream ty
c <- String -> Int -> IO (HandleStream ty)
forall bufType.
HStream bufType =>
String -> Int -> IO (HandleStream bufType)
openStream (URIAuthority -> String
host URIAuthority
auth) (Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
80 (URIAuthority -> Maybe Int
port URIAuthority
auth))
  HandleStream ty -> Request ty -> IO (Result (Response ty))
forall ty.
HStream ty =>
HandleStream ty -> Request ty -> IO (Result (Response ty))
simpleHTTP_ HandleStream ty
c Request ty
r

-- | @simpleHTTP_debug debugFile req@ behaves like 'simpleHTTP', but logs
-- the HTTP operation via the debug file @debugFile@.
simpleHTTP_debug :: HStream ty => FilePath -> Request ty -> IO (Result (Response ty))
simpleHTTP_debug :: String -> Request ty -> IO (Result (Response ty))
simpleHTTP_debug String
httpLogFile Request ty
r = do 
  URIAuthority
auth <- Request ty -> IO URIAuthority
forall (m :: * -> *) ty.
MonadFail m =>
Request ty -> m URIAuthority
getAuth Request ty
r
  URI -> IO ()
forall (m :: * -> *). MonadFail m => URI -> m ()
failHTTPS (Request ty -> URI
forall a. Request a -> URI
rqURI Request ty
r)
  HandleStream ty
c0   <- String -> Int -> IO (HandleStream ty)
forall bufType.
HStream bufType =>
String -> Int -> IO (HandleStream bufType)
openStream (URIAuthority -> String
host URIAuthority
auth) (Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
80 (URIAuthority -> Maybe Int
port URIAuthority
auth))
  HandleStream ty
c    <- String -> HandleStream ty -> IO (HandleStream ty)
forall ty.
HStream ty =>
String -> HandleStream ty -> IO (HandleStream ty)
debugByteStream String
httpLogFile HandleStream ty
c0
  HandleStream ty -> Request ty -> IO (Result (Response ty))
forall ty.
HStream ty =>
HandleStream ty -> Request ty -> IO (Result (Response ty))
simpleHTTP_ HandleStream ty
c Request ty
r

-- | Like 'simpleHTTP', but acting on an already opened stream.
simpleHTTP_ :: HStream ty => HandleStream ty -> Request ty -> IO (Result (Response ty))
simpleHTTP_ :: HandleStream ty -> Request ty -> IO (Result (Response ty))
simpleHTTP_ HandleStream ty
s Request ty
r = HandleStream ty -> Request ty -> IO (Result (Response ty))
forall ty.
HStream ty =>
HandleStream ty -> Request ty -> IO (Result (Response ty))
sendHTTP HandleStream ty
s Request ty
r

-- | @sendHTTP hStream httpRequest@ transmits @httpRequest@ over
-- @hStream@, but does not alter the status of the connection, nor request it to be
-- closed upon receiving the response.
sendHTTP :: HStream ty => HandleStream ty -> Request ty -> IO (Result (Response ty))
sendHTTP :: HandleStream ty -> Request ty -> IO (Result (Response ty))
sendHTTP HandleStream ty
conn Request ty
rq = HandleStream ty -> Request ty -> IO () -> IO (Result (Response ty))
forall ty.
HStream ty =>
HandleStream ty -> Request ty -> IO () -> IO (Result (Response ty))
sendHTTP_notify HandleStream ty
conn Request ty
rq (() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())

-- | @sendHTTP_notify hStream httpRequest action@ behaves like 'sendHTTP', but
-- lets you supply an IO @action@ to execute once the request has been successfully
-- transmitted over the connection. Useful when you want to set up tracing of
-- request transmission and its performance.
sendHTTP_notify :: HStream ty
                => HandleStream ty
                -> Request ty
                -> IO ()
                -> IO (Result (Response ty))
sendHTTP_notify :: HandleStream ty -> Request ty -> IO () -> IO (Result (Response ty))
sendHTTP_notify HandleStream ty
conn Request ty
rq IO ()
onSendComplete = do
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
providedClose (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ (HandleStream ty -> Bool -> IO ()
forall bufType.
HStream bufType =>
HandleStream bufType -> Bool -> IO ()
closeOnEnd HandleStream ty
conn Bool
True)
  IO (Result (Response ty)) -> IO () -> IO (Result (Response ty))
forall a b. IO a -> IO b -> IO a
onException (HandleStream ty -> Request ty -> IO () -> IO (Result (Response ty))
forall ty.
HStream ty =>
HandleStream ty -> Request ty -> IO () -> IO (Result (Response ty))
sendMain HandleStream ty
conn Request ty
rq IO ()
onSendComplete)
              (HandleStream ty -> IO ()
forall bufType. HStream bufType => HandleStream bufType -> IO ()
close HandleStream ty
conn)
 where
  providedClose :: Bool
providedClose = [Header] -> Bool
findConnClose (Request ty -> [Header]
forall a. Request a -> [Header]
rqHeaders Request ty
rq)

-- From RFC 2616, section 8.2.3:
-- 'Because of the presence of older implementations, the protocol allows
-- ambiguous situations in which a client may send "Expect: 100-
-- continue" without receiving either a 417 (Expectation Failed) status
-- or a 100 (Continue) status. Therefore, when a client sends this
-- header field to an origin server (possibly via a proxy) from which it
-- has never seen a 100 (Continue) status, the client SHOULD NOT wait
-- for an indefinite period before sending the request body.'
--
-- Since we would wait forever, I have disabled use of 100-continue for now.
sendMain :: HStream ty
         => HandleStream ty
         -> Request ty
         -> (IO ())
         -> IO (Result (Response ty))
sendMain :: HandleStream ty -> Request ty -> IO () -> IO (Result (Response ty))
sendMain HandleStream ty
conn Request ty
rqst IO ()
onSendComplete = do
      --let str = if null (rqBody rqst)
      --              then show rqst
      --              else show (insertHeader HdrExpect "100-continue" rqst)
  -- TODO review throwing away of result
  Result ()
_ <- HandleStream ty -> ty -> IO (Result ())
forall bufType.
HStream bufType =>
HandleStream bufType -> bufType -> IO (Result ())
writeBlock HandleStream ty
conn (BufferOp ty -> String -> ty
forall a. BufferOp a -> String -> a
buf_fromStr BufferOp ty
forall bufType. BufferType bufType => BufferOp bufType
bufferOps (String -> ty) -> String -> ty
forall a b. (a -> b) -> a -> b
$ Request ty -> String
forall a. Show a => a -> String
show Request ty
rqst)
    -- write body immediately, don't wait for 100 CONTINUE
  -- TODO review throwing away of result
  Result ()
_ <- HandleStream ty -> ty -> IO (Result ())
forall bufType.
HStream bufType =>
HandleStream bufType -> bufType -> IO (Result ())
writeBlock HandleStream ty
conn (Request ty -> ty
forall a. Request a -> a
rqBody Request ty
rqst)
  IO ()
onSendComplete
  Result ResponseData
rsp <- HandleStream ty -> IO (Result ResponseData)
forall ty.
HStream ty =>
HandleStream ty -> IO (Result ResponseData)
getResponseHead HandleStream ty
conn
  HandleStream ty
-> Bool
-> Bool
-> Result ResponseData
-> Request ty
-> IO (Result (Response ty))
forall ty.
HStream ty =>
HandleStream ty
-> Bool
-> Bool
-> Result ResponseData
-> Request ty
-> IO (Result (Response ty))
switchResponse HandleStream ty
conn Bool
True Bool
False Result ResponseData
rsp Request ty
rqst

   -- Hmmm, this could go bad if we keep getting "100 Continue"
   -- responses...  Except this should never happen according
   -- to the RFC.

switchResponse :: HStream ty
               => HandleStream ty
               -> Bool {- allow retry? -}
               -> Bool {- is body sent? -}
               -> Result ResponseData
               -> Request ty
               -> IO (Result (Response ty))
switchResponse :: HandleStream ty
-> Bool
-> Bool
-> Result ResponseData
-> Request ty
-> IO (Result (Response ty))
switchResponse HandleStream ty
_ Bool
_ Bool
_ (Left ConnError
e) Request ty
_ = Result (Response ty) -> IO (Result (Response ty))
forall (m :: * -> *) a. Monad m => a -> m a
return (ConnError -> Result (Response ty)
forall a b. a -> Either a b
Left ConnError
e)
                -- retry on connreset?
                -- if we attempt to use the same socket then there is an excellent
                -- chance that the socket is not in a completely closed state.

switchResponse HandleStream ty
conn Bool
allow_retry Bool
bdy_sent (Right (ResponseCode
cd,String
rn,[Header]
hdrs)) Request ty
rqst = 
   case RequestMethod -> ResponseCode -> ResponseNextStep
matchResponse (Request ty -> RequestMethod
forall a. Request a -> RequestMethod
rqMethod Request ty
rqst) ResponseCode
cd of
     ResponseNextStep
Continue
      | Bool -> Bool
not Bool
bdy_sent -> do {- Time to send the body -}
        HandleStream ty -> ty -> IO (Result ())
forall bufType.
HStream bufType =>
HandleStream bufType -> bufType -> IO (Result ())
writeBlock HandleStream ty
conn (Request ty -> ty
forall a. Request a -> a
rqBody Request ty
rqst) IO (Result ())
-> (Result () -> IO (Result (Response ty)))
-> IO (Result (Response ty))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (ConnError -> IO (Result (Response ty)))
-> (() -> IO (Result (Response ty)))
-> Result ()
-> IO (Result (Response ty))
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Result (Response ty) -> IO (Result (Response ty))
forall (m :: * -> *) a. Monad m => a -> m a
return (Result (Response ty) -> IO (Result (Response ty)))
-> (ConnError -> Result (Response ty))
-> ConnError
-> IO (Result (Response ty))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConnError -> Result (Response ty)
forall a b. a -> Either a b
Left)
           (\ ()
_ -> do
              Result ResponseData
rsp <- HandleStream ty -> IO (Result ResponseData)
forall ty.
HStream ty =>
HandleStream ty -> IO (Result ResponseData)
getResponseHead HandleStream ty
conn
              HandleStream ty
-> Bool
-> Bool
-> Result ResponseData
-> Request ty
-> IO (Result (Response ty))
forall ty.
HStream ty =>
HandleStream ty
-> Bool
-> Bool
-> Result ResponseData
-> Request ty
-> IO (Result (Response ty))
switchResponse HandleStream ty
conn Bool
allow_retry Bool
True Result ResponseData
rsp Request ty
rqst)
      | Bool
otherwise    -> do {- keep waiting -}
        Result ResponseData
rsp <- HandleStream ty -> IO (Result ResponseData)
forall ty.
HStream ty =>
HandleStream ty -> IO (Result ResponseData)
getResponseHead HandleStream ty
conn
        HandleStream ty
-> Bool
-> Bool
-> Result ResponseData
-> Request ty
-> IO (Result (Response ty))
forall ty.
HStream ty =>
HandleStream ty
-> Bool
-> Bool
-> Result ResponseData
-> Request ty
-> IO (Result (Response ty))
switchResponse HandleStream ty
conn Bool
allow_retry Bool
bdy_sent Result ResponseData
rsp Request ty
rqst

     ResponseNextStep
Retry -> do {- Request with "Expect" header failed.
                    Trouble is the request contains Expects
                    other than "100-Continue" -}
        -- TODO review throwing away of result
        Result ()
_ <- HandleStream ty -> ty -> IO (Result ())
forall bufType.
HStream bufType =>
HandleStream bufType -> bufType -> IO (Result ())
writeBlock HandleStream ty
conn ((BufferOp ty -> ty -> ty -> ty
forall a. BufferOp a -> a -> a -> a
buf_append BufferOp ty
forall bufType. BufferType bufType => BufferOp bufType
bufferOps)
                                     (BufferOp ty -> String -> ty
forall a. BufferOp a -> String -> a
buf_fromStr BufferOp ty
forall bufType. BufferType bufType => BufferOp bufType
bufferOps (Request ty -> String
forall a. Show a => a -> String
show Request ty
rqst))
                                     (Request ty -> ty
forall a. Request a -> a
rqBody Request ty
rqst))
        Result ResponseData
rsp <- HandleStream ty -> IO (Result ResponseData)
forall ty.
HStream ty =>
HandleStream ty -> IO (Result ResponseData)
getResponseHead HandleStream ty
conn
        HandleStream ty
-> Bool
-> Bool
-> Result ResponseData
-> Request ty
-> IO (Result (Response ty))
forall ty.
HStream ty =>
HandleStream ty
-> Bool
-> Bool
-> Result ResponseData
-> Request ty
-> IO (Result (Response ty))
switchResponse HandleStream ty
conn Bool
False Bool
bdy_sent Result ResponseData
rsp Request ty
rqst
                     
     ResponseNextStep
Done -> do
       Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([Header] -> Bool
findConnClose [Header]
hdrs)
            (HandleStream ty -> Bool -> IO ()
forall bufType.
HStream bufType =>
HandleStream bufType -> Bool -> IO ()
closeOnEnd HandleStream ty
conn Bool
True)
       Result (Response ty) -> IO (Result (Response ty))
forall (m :: * -> *) a. Monad m => a -> m a
return (Response ty -> Result (Response ty)
forall a b. b -> Either a b
Right (Response ty -> Result (Response ty))
-> Response ty -> Result (Response ty)
forall a b. (a -> b) -> a -> b
$ ResponseCode -> String -> [Header] -> ty -> Response ty
forall a. ResponseCode -> String -> [Header] -> a -> Response a
Response ResponseCode
cd String
rn [Header]
hdrs (BufferOp ty -> ty
forall a. BufferOp a -> a
buf_empty BufferOp ty
forall bufType. BufferType bufType => BufferOp bufType
bufferOps))

     DieHorribly String
str -> do
       HandleStream ty -> IO ()
forall bufType. HStream bufType => HandleStream bufType -> IO ()
close HandleStream ty
conn
       Result (Response ty) -> IO (Result (Response ty))
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> String -> Result (Response ty)
forall a. String -> String -> Result a
responseParseError String
"Invalid response:" String
str)
     ResponseNextStep
ExpectEntity -> do
       Result (Response ty)
r <- (([Header], ty) -> Result (Response ty))
-> IO (Result ([Header], ty)) -> IO (Result (Response ty))
forall a b. (a -> Result b) -> IO (Result a) -> IO (Result b)
fmapE (\ ([Header]
ftrs,ty
bdy) -> Response ty -> Result (Response ty)
forall a b. b -> Either a b
Right (ResponseCode -> String -> [Header] -> ty -> Response ty
forall a. ResponseCode -> String -> [Header] -> a -> Response a
Response ResponseCode
cd String
rn ([Header]
hdrs[Header] -> [Header] -> [Header]
forall a. [a] -> [a] -> [a]
++[Header]
ftrs) ty
bdy)) (IO (Result ([Header], ty)) -> IO (Result (Response ty)))
-> IO (Result ([Header], ty)) -> IO (Result (Response ty))
forall a b. (a -> b) -> a -> b
$
             IO (Result ([Header], ty))
-> (String -> IO (Result ([Header], ty)))
-> Maybe String
-> IO (Result ([Header], ty))
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (IO (Result ([Header], ty))
-> (String -> IO (Result ([Header], ty)))
-> Maybe String
-> IO (Result ([Header], ty))
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (BufferOp ty -> IO (Result ty) -> [ty] -> IO (Result ([Header], ty))
forall a.
BufferOp a -> IO (Result a) -> [a] -> IO (Result ([Header], a))
hopefulTransfer BufferOp ty
bo (HandleStream ty -> IO (Result ty)
forall bufType.
HStream bufType =>
HandleStream bufType -> IO (Result bufType)
readLine HandleStream ty
conn) [])
                       (\ String
x ->
                          (Int -> IO (Result ([Header], ty)))
-> IO (Result ([Header], ty))
-> String
-> IO (Result ([Header], ty))
forall a b. Read a => (a -> b) -> b -> String -> b
readsOne ((Int -> IO (Result ty)) -> Int -> IO (Result ([Header], ty))
forall a.
(Int -> IO (Result a)) -> Int -> IO (Result ([Header], a))
linearTransfer (HandleStream ty -> Int -> IO (Result ty)
forall bufType.
HStream bufType =>
HandleStream bufType -> Int -> IO (Result bufType)
readBlock HandleStream ty
conn))
                                   (Result ([Header], ty) -> IO (Result ([Header], ty))
forall (m :: * -> *) a. Monad m => a -> m a
return(Result ([Header], ty) -> IO (Result ([Header], ty)))
-> Result ([Header], ty) -> IO (Result ([Header], ty))
forall a b. (a -> b) -> a -> b
$String -> String -> Result ([Header], ty)
forall a. String -> String -> Result a
responseParseError String
"unrecognized content-length value" String
x)
                                   String
x)
                        Maybe String
cl)
                   (IO (Result ([Header], ty))
-> IO (Result ([Header], ty))
-> String
-> IO (Result ([Header], ty))
forall a. a -> a -> String -> a
ifChunked (BufferOp ty
-> IO (Result ty)
-> (Int -> IO (Result ty))
-> IO (Result ([Header], ty))
forall a.
BufferOp a
-> IO (Result a)
-> (Int -> IO (Result a))
-> IO (Result ([Header], a))
chunkedTransfer BufferOp ty
bo (HandleStream ty -> IO (Result ty)
forall bufType.
HStream bufType =>
HandleStream bufType -> IO (Result bufType)
readLine HandleStream ty
conn) (HandleStream ty -> Int -> IO (Result ty)
forall bufType.
HStream bufType =>
HandleStream bufType -> Int -> IO (Result bufType)
readBlock HandleStream ty
conn))
                              (String -> IO (Result ([Header], ty))
forall a. String -> IO (Result ([Header], a))
uglyDeathTransfer String
"sendHTTP"))
                   Maybe String
tc
       case Result (Response ty)
r of
         Left{} -> do
           HandleStream ty -> IO ()
forall bufType. HStream bufType => HandleStream bufType -> IO ()
close HandleStream ty
conn
           Result (Response ty) -> IO (Result (Response ty))
forall (m :: * -> *) a. Monad m => a -> m a
return Result (Response ty)
r
         Right (Response ResponseCode
_ String
_ [Header]
hs ty
_) -> do
           Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([Header] -> Bool
findConnClose [Header]
hs)
                (HandleStream ty -> Bool -> IO ()
forall bufType.
HStream bufType =>
HandleStream bufType -> Bool -> IO ()
closeOnEnd HandleStream ty
conn Bool
True)
           Result (Response ty) -> IO (Result (Response ty))
forall (m :: * -> *) a. Monad m => a -> m a
return Result (Response ty)
r

      where
       tc :: Maybe String
tc = HeaderName -> [Header] -> Maybe String
lookupHeader HeaderName
HdrTransferEncoding [Header]
hdrs
       cl :: Maybe String
cl = HeaderName -> [Header] -> Maybe String
lookupHeader HeaderName
HdrContentLength [Header]
hdrs
       bo :: BufferOp ty
bo = BufferOp ty
forall bufType. BufferType bufType => BufferOp bufType
bufferOps
                    
-- reads and parses headers
getResponseHead :: HStream ty => HandleStream ty -> IO (Result ResponseData)
getResponseHead :: HandleStream ty -> IO (Result ResponseData)
getResponseHead HandleStream ty
conn = 
   ([ty] -> Result ResponseData)
-> IO (Result [ty]) -> IO (Result ResponseData)
forall a b. (a -> Result b) -> IO (Result a) -> IO (Result b)
fmapE (\[ty]
es -> [String] -> Result ResponseData
parseResponseHead ((ty -> String) -> [ty] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (BufferOp ty -> ty -> String
forall a. BufferOp a -> a -> String
buf_toStr BufferOp ty
forall bufType. BufferType bufType => BufferOp bufType
bufferOps) [ty]
es))
         (BufferOp ty -> IO (Result ty) -> IO (Result [ty])
forall a. BufferOp a -> IO (Result a) -> IO (Result [a])
readTillEmpty1 BufferOp ty
forall bufType. BufferType bufType => BufferOp bufType
bufferOps (HandleStream ty -> IO (Result ty)
forall bufType.
HStream bufType =>
HandleStream bufType -> IO (Result bufType)
readLine HandleStream ty
conn))

-- | @receiveHTTP hStream@ reads a 'Request' from the 'HandleStream' @hStream@
receiveHTTP :: HStream bufTy => HandleStream bufTy -> IO (Result (Request bufTy))
receiveHTTP :: HandleStream bufTy -> IO (Result (Request bufTy))
receiveHTTP HandleStream bufTy
conn = IO (Result RequestData)
getRequestHead IO (Result RequestData)
-> (Result RequestData -> IO (Result (Request bufTy)))
-> IO (Result (Request bufTy))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (ConnError -> IO (Result (Request bufTy)))
-> (RequestData -> IO (Result (Request bufTy)))
-> Result RequestData
-> IO (Result (Request bufTy))
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Result (Request bufTy) -> IO (Result (Request bufTy))
forall (m :: * -> *) a. Monad m => a -> m a
return (Result (Request bufTy) -> IO (Result (Request bufTy)))
-> (ConnError -> Result (Request bufTy))
-> ConnError
-> IO (Result (Request bufTy))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConnError -> Result (Request bufTy)
forall a b. a -> Either a b
Left) RequestData -> IO (Result (Request bufTy))
processRequest
  where
    -- reads and parses headers
   getRequestHead :: IO (Result RequestData)
   getRequestHead :: IO (Result RequestData)
getRequestHead = do
      ([bufTy] -> Result RequestData)
-> IO (Result [bufTy]) -> IO (Result RequestData)
forall a b. (a -> Result b) -> IO (Result a) -> IO (Result b)
fmapE (\[bufTy]
es -> [String] -> Result RequestData
parseRequestHead ((bufTy -> String) -> [bufTy] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (BufferOp bufTy -> bufTy -> String
forall a. BufferOp a -> a -> String
buf_toStr BufferOp bufTy
forall bufType. BufferType bufType => BufferOp bufType
bufferOps) [bufTy]
es))
            (BufferOp bufTy -> IO (Result bufTy) -> IO (Result [bufTy])
forall a. BufferOp a -> IO (Result a) -> IO (Result [a])
readTillEmpty1 BufferOp bufTy
forall bufType. BufferType bufType => BufferOp bufType
bufferOps (HandleStream bufTy -> IO (Result bufTy)
forall bufType.
HStream bufType =>
HandleStream bufType -> IO (Result bufType)
readLine HandleStream bufTy
conn))

   processRequest :: RequestData -> IO (Result (Request bufTy))
processRequest (RequestMethod
rm,URI
uri,[Header]
hdrs) =
      (([Header], bufTy) -> Result (Request bufTy))
-> IO (Result ([Header], bufTy)) -> IO (Result (Request bufTy))
forall a b. (a -> Result b) -> IO (Result a) -> IO (Result b)
fmapE (\ ([Header]
ftrs,bufTy
bdy) -> Request bufTy -> Result (Request bufTy)
forall a b. b -> Either a b
Right (URI -> RequestMethod -> [Header] -> bufTy -> Request bufTy
forall a. URI -> RequestMethod -> [Header] -> a -> Request a
Request URI
uri RequestMethod
rm ([Header]
hdrs[Header] -> [Header] -> [Header]
forall a. [a] -> [a] -> [a]
++[Header]
ftrs) bufTy
bdy)) (IO (Result ([Header], bufTy)) -> IO (Result (Request bufTy)))
-> IO (Result ([Header], bufTy)) -> IO (Result (Request bufTy))
forall a b. (a -> b) -> a -> b
$
             IO (Result ([Header], bufTy))
-> (String -> IO (Result ([Header], bufTy)))
-> Maybe String
-> IO (Result ([Header], bufTy))
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
              (IO (Result ([Header], bufTy))
-> (String -> IO (Result ([Header], bufTy)))
-> Maybe String
-> IO (Result ([Header], bufTy))
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Result ([Header], bufTy) -> IO (Result ([Header], bufTy))
forall (m :: * -> *) a. Monad m => a -> m a
return (([Header], bufTy) -> Result ([Header], bufTy)
forall a b. b -> Either a b
Right ([], BufferOp bufTy -> bufTy
forall a. BufferOp a -> a
buf_empty BufferOp bufTy
bo))) -- hopefulTransfer ""
                     (\ String
x -> (Int -> IO (Result ([Header], bufTy)))
-> IO (Result ([Header], bufTy))
-> String
-> IO (Result ([Header], bufTy))
forall a b. Read a => (a -> b) -> b -> String -> b
readsOne ((Int -> IO (Result bufTy)) -> Int -> IO (Result ([Header], bufTy))
forall a.
(Int -> IO (Result a)) -> Int -> IO (Result ([Header], a))
linearTransfer (HandleStream bufTy -> Int -> IO (Result bufTy)
forall bufType.
HStream bufType =>
HandleStream bufType -> Int -> IO (Result bufType)
readBlock HandleStream bufTy
conn))
                                      (Result ([Header], bufTy) -> IO (Result ([Header], bufTy))
forall (m :: * -> *) a. Monad m => a -> m a
return(Result ([Header], bufTy) -> IO (Result ([Header], bufTy)))
-> Result ([Header], bufTy) -> IO (Result ([Header], bufTy))
forall a b. (a -> b) -> a -> b
$String -> String -> Result ([Header], bufTy)
forall a. String -> String -> Result a
responseParseError String
"unrecognized Content-Length value" String
x)
                                      String
x)

                     Maybe String
cl)
              (IO (Result ([Header], bufTy))
-> IO (Result ([Header], bufTy))
-> String
-> IO (Result ([Header], bufTy))
forall a. a -> a -> String -> a
ifChunked (BufferOp bufTy
-> IO (Result bufTy)
-> (Int -> IO (Result bufTy))
-> IO (Result ([Header], bufTy))
forall a.
BufferOp a
-> IO (Result a)
-> (Int -> IO (Result a))
-> IO (Result ([Header], a))
chunkedTransfer BufferOp bufTy
bo (HandleStream bufTy -> IO (Result bufTy)
forall bufType.
HStream bufType =>
HandleStream bufType -> IO (Result bufType)
readLine HandleStream bufTy
conn) (HandleStream bufTy -> Int -> IO (Result bufTy)
forall bufType.
HStream bufType =>
HandleStream bufType -> Int -> IO (Result bufType)
readBlock HandleStream bufTy
conn))
                         (String -> IO (Result ([Header], bufTy))
forall a. String -> IO (Result ([Header], a))
uglyDeathTransfer String
"receiveHTTP"))
              Maybe String
tc
    where
     -- FIXME : Also handle 100-continue.
     tc :: Maybe String
tc = HeaderName -> [Header] -> Maybe String
lookupHeader HeaderName
HdrTransferEncoding [Header]
hdrs
     cl :: Maybe String
cl = HeaderName -> [Header] -> Maybe String
lookupHeader HeaderName
HdrContentLength [Header]
hdrs
     bo :: BufferOp bufTy
bo = BufferOp bufTy
forall bufType. BufferType bufType => BufferOp bufType
bufferOps

-- | @respondHTTP hStream httpResponse@ transmits an HTTP 'Response' over
-- the 'HandleStream' @hStream@. It could be used to implement simple web
-- server interactions, performing the dual role to 'sendHTTP'.
respondHTTP :: HStream ty => HandleStream ty -> Response ty -> IO ()
respondHTTP :: HandleStream ty -> Response ty -> IO ()
respondHTTP HandleStream ty
conn Response ty
rsp = do 
  -- TODO: review throwing away of result
  Result ()
_ <- HandleStream ty -> ty -> IO (Result ())
forall bufType.
HStream bufType =>
HandleStream bufType -> bufType -> IO (Result ())
writeBlock HandleStream ty
conn (BufferOp ty -> String -> ty
forall a. BufferOp a -> String -> a
buf_fromStr BufferOp ty
forall bufType. BufferType bufType => BufferOp bufType
bufferOps (String -> ty) -> String -> ty
forall a b. (a -> b) -> a -> b
$ Response ty -> String
forall a. Show a => a -> String
show Response ty
rsp)
   -- write body immediately, don't wait for 100 CONTINUE
  -- TODO: review throwing away of result
  Result ()
_ <- HandleStream ty -> ty -> IO (Result ())
forall bufType.
HStream bufType =>
HandleStream bufType -> bufType -> IO (Result ())
writeBlock HandleStream ty
conn (Response ty -> ty
forall a. Response a -> a
rspBody Response ty
rsp)
  () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

------------------------------------------------------------------------------

headerName :: String -> String
headerName :: String -> String
headerName String
x = (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower (String -> String
trim String
x)

ifChunked :: a -> a -> String -> a
ifChunked :: a -> a -> String -> a
ifChunked a
a a
b String
s = 
  case String -> String
headerName String
s of
    String
"chunked" -> a
a
    String
_ -> a
b