    -----------------------------------------------------------------------------
    -- |
    -- Module      :  Network.HTTP.Stream
    -- Copyright   :  See LICENSE file
    -- License     :  BSD
    --
    -- Maintainer  :  Ganesh Sittampalam <ganesh@earth.li>
    -- Stability   :  experimental
    -- Portability :  non-portable (not tested)
    --
    -- Transmitting HTTP requests and responses holding @String@ in their payload bodies.
    -- This is one of the implementation modules for the "Network.HTTP" interface, representing
    -- request and response content as @String@s and transmitting them in non-packed form
    -- (cf. "Network.HTTP.HandleStream" and its use of @ByteString@s.) over 'Stream' handles.
    -- It is mostly here for backwards compatibility, representing how requests and responses
    -- were transmitted up until the 4.x releases of the HTTP package.
    --
    -- 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.Stream
           ( module Network.Stream

           , simpleHTTP      -- :: Request_String -> IO (Result Response_String)
           , simpleHTTP_     -- :: Stream s => s -> Request_String -> IO (Result Response_String)
           , sendHTTP        -- :: Stream s => s -> Request_String -> IO (Result Response_String)
           , sendHTTP_notify -- :: Stream s => s -> Request_String -> IO () -> IO (Result Response_String)
           , receiveHTTP     -- :: Stream s => s -> IO (Result Request_String)
           , respondHTTP     -- :: Stream s => s -> Response_String -> IO ()

           ) where

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

    import Network.Stream
    import Network.StreamDebugger (debugStream)
    import Network.TCP (openTCPPort)
    import Network.BufferType ( stringBufferOp )

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

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

    -- Turn on to enable HTTP traffic logging
    debug :: Bool
    debug :: Bool
    debug = Bool
    False

    -- File that HTTP traffic logs go to
    httpLogFile :: String
    httpLogFile :: String
    httpLogFile = String
    "http-debug.log"

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

    -- | Simple way to transmit a resource across a non-persistent connection.
    simpleHTTP :: Request_String -> IO (Result Response_String)
    simpleHTTP :: Request_String -> IO (Result Response_String)
    simpleHTTP Request_String
    r = do
       auth <- Request_String -> IO URIAuthority
    forall (m :: * -> *) ty.
    MonadFail m =>
    Request ty -> m URIAuthority
    getAuth Request_String
    r
       c    <- openTCPPort (host auth) (fromMaybe 80 (port auth))
       simpleHTTP_ c r

    -- | Like 'simpleHTTP', but acting on an already opened stream.
    simpleHTTP_ :: Stream s => s -> Request_String -> IO (Result Response_String)
    simpleHTTP_ :: forall s.
    Stream s =>
    s -> Request_String -> IO (Result Response_String)
    simpleHTTP_ s
    s Request_String
    r
     | Bool -> Bool
    not Bool
    debug    = s -> Request_String -> IO (Result Response_String)
    forall s.
    Stream s =>
    s -> Request_String -> IO (Result Response_String)
    sendHTTP s
    s Request_String
    r
     | Bool
    otherwise    = do
          s' <- String -> s -> IO (StreamDebugger s)
    forall a. Stream a => String -> a -> IO (StreamDebugger a)
    debugStream String
    httpLogFile s
    s
          sendHTTP s' r

    sendHTTP :: Stream s => s -> Request_String -> IO (Result Response_String)
    sendHTTP :: forall s.
    Stream s =>
    s -> Request_String -> IO (Result Response_String)
    sendHTTP s
    conn Request_String
    rq = s -> Request_String -> IO () -> IO (Result Response_String)
    forall s.
    Stream s =>
    s -> Request_String -> IO () -> IO (Result Response_String)
    sendHTTP_notify s
    conn Request_String
    rq (() -> IO ()
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ())

    sendHTTP_notify :: Stream s => s -> Request_String -> IO () -> IO (Result Response_String)
    sendHTTP_notify :: forall s.
    Stream s =>
    s -> Request_String -> IO () -> IO (Result Response_String)
    sendHTTP_notify s
    conn Request_String
    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
    $ (s -> Bool -> IO ()
    forall x. Stream x => x -> Bool -> IO ()
    closeOnEnd s
    conn Bool
    True)
       IO (Result Response_String) -> IO () -> IO (Result Response_String)
    forall a b. IO a -> IO b -> IO a
    onException (s -> Request_String -> IO () -> IO (Result Response_String)
    forall s.
    Stream s =>
    s -> Request_String -> IO () -> IO (Result Response_String)
    sendMain s
    conn Request_String
    rq IO ()
    onSendComplete)
                   (s -> IO ()
    forall x. Stream x => x -> IO ()
    close s
    conn)
     where
      providedClose :: Bool
    providedClose = [Header] -> Bool
    findConnClose (Request_String -> [Header]
    forall a. Request a -> [Header]
    rqHeaders Request_String
    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 :: Stream s => s -> Request_String -> IO () -> IO (Result Response_String)
    sendMain :: forall s.
    Stream s =>
    s -> Request_String -> IO () -> IO (Result Response_String)
    sendMain s
    conn Request_String
    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
       _ <- s -> String -> IO (Result ())
    forall x. Stream x => x -> String -> IO (Result ())
    writeBlock s
    conn (Request_String -> String
    forall a. Show a => a -> String
    show Request_String
    rqst)
        -- write body immediately, don't wait for 100 CONTINUE
       -- TODO review throwing away of result
       _ <- writeBlock conn (rqBody rqst)
       onSendComplete
       rsp <- getResponseHead conn
       switchResponse conn True False rsp rqst

    -- reads and parses headers
    getResponseHead :: Stream s => s -> IO (Result ResponseData)
    getResponseHead :: forall s. Stream s => s -> IO (Result ResponseData)
    getResponseHead s
    conn = do
       lor <- BufferOp String -> IO (Result String) -> IO (Result [String])
    forall a. BufferOp a -> IO (Result a) -> IO (Result [a])
    readTillEmpty1 BufferOp String
    stringBufferOp (s -> IO (Result String)
    forall x. Stream x => x -> IO (Result String)
    readLine s
    conn)
       return $ lor >>= parseResponseHead

    -- Hmmm, this could go bad if we keep getting "100 Continue"
    -- responses...  Except this should never happen according
    -- to the RFC.
    switchResponse :: Stream s
                   => s
                   -> Bool {- allow retry? -}
                   -> Bool {- is body sent? -}
                   -> Result ResponseData
                   -> Request_String
                   -> IO (Result Response_String)
    switchResponse :: forall s.
    Stream s =>
    s
    -> Bool
    -> Bool
    -> Result ResponseData
    -> Request_String
    -> IO (Result Response_String)
    switchResponse s
    _ Bool
    _ Bool
    _ (Left ConnError
    e) Request_String
    _ = Result Response_String -> IO (Result Response_String)
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (ConnError -> Result Response_String
    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 s
    conn Bool
    allow_retry Bool
    bdy_sent (Right (ResponseCode
    cd,String
    rn,[Header]
    hdrs)) Request_String
    rqst =
                case RequestMethod -> ResponseCode -> ResponseNextStep
    matchResponse (Request_String -> RequestMethod
    forall a. Request a -> RequestMethod
    rqMethod Request_String
    rqst) ResponseCode
    cd of
                    ResponseNextStep
    Continue
                        | Bool -> Bool
    not Bool
    bdy_sent -> {- Time to send the body -}
                            do { val <- s -> String -> IO (Result ())
    forall x. Stream x => x -> String -> IO (Result ())
    writeBlock s
    conn (Request_String -> String
    forall a. Request a -> a
    rqBody Request_String
    rqst)
                               ; case val of
                                    Left ConnError
    e -> Result Response_String -> IO (Result Response_String)
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (ConnError -> Result Response_String
    forall a b. a -> Either a b
    Left ConnError
    e)
                                    Right ()
    _ ->
                                        do { rsp <- s -> IO (Result ResponseData)
    forall s. Stream s => s -> IO (Result ResponseData)
    getResponseHead s
    conn
                                           ; switchResponse conn allow_retry True rsp rqst
                                           }
                               }
                        | Bool
    otherwise -> {- keep waiting -}
                            do { rsp <- s -> IO (Result ResponseData)
    forall s. Stream s => s -> IO (Result ResponseData)
    getResponseHead s
    conn
                               ; switchResponse conn allow_retry bdy_sent rsp rqst
                               }

                    ResponseNextStep
    Retry -> {- Request with "Expect" header failed.
                                    Trouble is the request contains Expects
                                    other than "100-Continue" -}
                        do { -- TODO review throwing away of result
                             _ <- s -> String -> IO (Result ())
    forall x. Stream x => x -> String -> IO (Result ())
    writeBlock s
    conn (Request_String -> String
    forall a. Show a => a -> String
    show Request_String
    rqst String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ Request_String -> String
    forall a. Request a -> a
    rqBody Request_String
    rqst)
                           ; rsp <- getResponseHead conn
                           ; switchResponse conn False bdy_sent rsp rqst
                           }

                    ResponseNextStep
    Done -> do
                        Bool -> IO () -> IO ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when ([Header] -> Bool
    findConnClose [Header]
    hdrs)
                             (s -> Bool -> IO ()
    forall x. Stream x => x -> Bool -> IO ()
    closeOnEnd s
    conn Bool
    True)
                        Result Response_String -> IO (Result Response_String)
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Response_String -> Result Response_String
    forall a b. b -> Either a b
    Right (Response_String -> Result Response_String)
    -> Response_String -> Result Response_String
    forall a b. (a -> b) -> a -> b
    $ ResponseCode -> String -> [Header] -> String -> Response_String
    forall a. ResponseCode -> String -> [Header] -> a -> Response a
    Response ResponseCode
    cd String
    rn [Header]
    hdrs String
    "")

                    DieHorribly String
    str -> do
                        s -> IO ()
    forall x. Stream x => x -> IO ()
    close s
    conn
                        Result Response_String -> IO (Result Response_String)
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Result Response_String -> IO (Result Response_String))
    -> Result Response_String -> IO (Result Response_String)
    forall a b. (a -> b) -> a -> b
    $ String -> String -> Result Response_String
    forall a. String -> String -> Result a
    responseParseError String
    "sendHTTP" (String
    "Invalid response: " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    str)

                    ResponseNextStep
    ExpectEntity ->
                        let 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
                        in
                        do { rslt <- case Maybe String
    tc of
                              Maybe String
    Nothing ->
                                  case Maybe String
    cl of
                                      Just String
    x  -> (Int -> IO (Result String))
    -> Int -> IO (Result ([Header], String))
    forall a.
    (Int -> IO (Result a)) -> Int -> IO (Result ([Header], a))
    linearTransfer (s -> Int -> IO (Result String)
    forall x. Stream x => x -> Int -> IO (Result String)
    readBlock s
    conn) (String -> Int
    forall a. Read a => String -> a
    read String
    x :: Int)
                                      Maybe String
    Nothing -> BufferOp String
    -> IO (Result String) -> [String] -> IO (Result ([Header], String))
    forall a.
    BufferOp a -> IO (Result a) -> [a] -> IO (Result ([Header], a))
    hopefulTransfer BufferOp String
    stringBufferOp {-null (++) []-} (s -> IO (Result String)
    forall x. Stream x => x -> IO (Result String)
    readLine s
    conn) []
                              Just String
    x  ->
                                  case (Char -> Char) -> String -> String
    forall a b. (a -> b) -> [a] -> [b]
    map Char -> Char
    toLower (String -> String
    trim String
    x) of
                                      String
    "chunked" -> BufferOp String
    -> IO (Result String)
    -> (Int -> IO (Result String))
    -> IO (Result ([Header], String))
    forall a.
    BufferOp a
    -> IO (Result a)
    -> (Int -> IO (Result a))
    -> IO (Result ([Header], a))
    chunkedTransfer BufferOp String
    stringBufferOp
                                                                   (s -> IO (Result String)
    forall x. Stream x => x -> IO (Result String)
    readLine s
    conn) (s -> Int -> IO (Result String)
    forall x. Stream x => x -> Int -> IO (Result String)
    readBlock s
    conn)
                                      String
    _         -> String -> IO (Result ([Header], String))
    forall a. String -> IO (Result ([Header], a))
    uglyDeathTransfer String
    "sendHTTP"
                           ; case rslt of
                               Left ConnError
    e -> s -> IO ()
    forall x. Stream x => x -> IO ()
    close s
    conn IO () -> IO (Result Response_String) -> IO (Result Response_String)
    forall a b. IO a -> IO b -> IO b
    forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
    >> Result Response_String -> IO (Result Response_String)
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (ConnError -> Result Response_String
    forall a b. a -> Either a b
    Left ConnError
    e)
                               Right ([Header]
    ftrs,String
    bdy) -> do
                                Bool -> IO () -> IO ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when ([Header] -> Bool
    findConnClose ([Header]
    hdrs[Header] -> [Header] -> [Header]
    forall a. [a] -> [a] -> [a]
    ++[Header]
    ftrs))
                                     (s -> Bool -> IO ()
    forall x. Stream x => x -> Bool -> IO ()
    closeOnEnd s
    conn Bool
    True)
                                Result Response_String -> IO (Result Response_String)
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Response_String -> Result Response_String
    forall a b. b -> Either a b
    Right (ResponseCode -> String -> [Header] -> String -> Response_String
    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) String
    bdy))
                           }

    -- | Receive and parse a HTTP request from the given Stream. Should be used
    --   for server side interactions.
    receiveHTTP :: Stream s => s -> IO (Result Request_String)
    receiveHTTP :: forall s. Stream s => s -> IO (Result Request_String)
    receiveHTTP s
    conn = IO (Result RequestData)
    getRequestHead IO (Result RequestData)
    -> (Result RequestData -> IO (Result Request_String))
    -> IO (Result Request_String)
    forall a b. IO a -> (a -> IO b) -> IO b
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= Result RequestData -> IO (Result Request_String)
    processRequest
        where
            -- reads and parses headers
            getRequestHead :: IO (Result RequestData)
            getRequestHead :: IO (Result RequestData)
    getRequestHead =
                do { lor <- BufferOp String -> IO (Result String) -> IO (Result [String])
    forall a. BufferOp a -> IO (Result a) -> IO (Result [a])
    readTillEmpty1 BufferOp String
    stringBufferOp (s -> IO (Result String)
    forall x. Stream x => x -> IO (Result String)
    readLine s
    conn)
                   ; return $ lor >>= parseRequestHead
                   }

            processRequest :: Result RequestData -> IO (Result Request_String)
    processRequest (Left ConnError
    e) = Result Request_String -> IO (Result Request_String)
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Result Request_String -> IO (Result Request_String))
    -> Result Request_String -> IO (Result Request_String)
    forall a b. (a -> b) -> a -> b
    $ ConnError -> Result Request_String
    forall a b. a -> Either a b
    Left ConnError
    e
            processRequest (Right (RequestMethod
    rm,URI
    uri,[Header]
    hdrs)) =
                do -- FIXME : Also handle 100-continue.
                   let 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
                   rslt <- case Maybe String
    tc of
                              Maybe String
    Nothing ->
                                  case Maybe String
    cl of
                                      Just String
    x  -> (Int -> IO (Result String))
    -> Int -> IO (Result ([Header], String))
    forall a.
    (Int -> IO (Result a)) -> Int -> IO (Result ([Header], a))
    linearTransfer (s -> Int -> IO (Result String)
    forall x. Stream x => x -> Int -> IO (Result String)
    readBlock s
    conn) (String -> Int
    forall a. Read a => String -> a
    read String
    x :: Int)
                                      Maybe String
    Nothing -> Result ([Header], String) -> IO (Result ([Header], String))
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (([Header], String) -> Result ([Header], String)
    forall a b. b -> Either a b
    Right ([], String
    "")) -- hopefulTransfer ""
                              Just String
    x  ->
                                  case (Char -> Char) -> String -> String
    forall a b. (a -> b) -> [a] -> [b]
    map Char -> Char
    toLower (String -> String
    trim String
    x) of
                                      String
    "chunked" -> BufferOp String
    -> IO (Result String)
    -> (Int -> IO (Result String))
    -> IO (Result ([Header], String))
    forall a.
    BufferOp a
    -> IO (Result a)
    -> (Int -> IO (Result a))
    -> IO (Result ([Header], a))
    chunkedTransfer BufferOp String
    stringBufferOp
                                                                   (s -> IO (Result String)
    forall x. Stream x => x -> IO (Result String)
    readLine s
    conn) (s -> Int -> IO (Result String)
    forall x. Stream x => x -> Int -> IO (Result String)
    readBlock s
    conn)
                                      String
    _         -> String -> IO (Result ([Header], String))
    forall a. String -> IO (Result ([Header], a))
    uglyDeathTransfer String
    "receiveHTTP"

                   return $ do
                      (ftrs,bdy) <- rslt
                      return (Request uri rm (hdrs++ftrs) bdy)

    -- | Very simple function, send a HTTP response over the given stream. This
    --   could be improved on to use different transfer types.
    respondHTTP :: Stream s => s -> Response_String -> IO ()
    respondHTTP :: forall s. Stream s => s -> Response_String -> IO ()
    respondHTTP s
    conn Response_String
    rsp = do -- TODO review throwing away of result
                              _ <- s -> String -> IO (Result ())
    forall x. Stream x => x -> String -> IO (Result ())
    writeBlock s
    conn (Response_String -> String
    forall a. Show a => a -> String
    show Response_String
    rsp)
                              -- write body immediately, don't wait for 100 CONTINUE
                              -- TODO review throwing away of result
                              _ <- writeBlock conn (rspBody rsp)
                              return ()