--
-- HTTP client for use with io-streams
--
-- Copyright © 2012-2021 Athae Eredh Siniath and Others
--
-- The code in this file, and the program it is a part of, is
-- made available to you by its authors as open source software:
-- you can redistribute it and/or modify it under the terms of
-- the BSD licence.
--
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# OPTIONS_HADDOCK hide, not-home #-}

module Network.Http.Inconvenience (
    URL,
    modifyContextSSL,
    establishConnection,
    get,
    post,
    postForm,
    encodedFormBody,
    multipartFormBody,
    Part,
    simplePart,
    filePart,
    inputStreamPart,
    put,
    baselineContextSSL,
    simpleHandler',
    concatHandler',
    jsonBody,
    jsonHandler,
    TooManyRedirects (..),
    HttpClientError (..),
    -- for testing
    splitURI,
    parseURL,
) where

import Blaze.ByteString.Builder (Builder)
import qualified Blaze.ByteString.Builder as Builder (
    fromByteString,
    fromLazyByteString,
    fromWord8,
    toByteString,
 )
import qualified Blaze.ByteString.Builder.Char8 as Builder (fromString)
import Control.Exception (Exception, bracket, throw)
import Data.Aeson (FromJSON, Result (..), ToJSON, encode, fromJSON)
import Data.Aeson.Parser (json')
import Data.Bits (Bits (..))
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as S
import Data.ByteString.Internal (c2w, w2c)
import Data.Char (intToDigit)
import Data.HashSet (HashSet)
import qualified Data.HashSet as HashSet
import Data.IORef (IORef, newIORef, readIORef, writeIORef)
import Data.List (intersperse)
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import Data.Typeable (Typeable)
import Data.Word (Word16)
import GHC.Exts
import GHC.Word (Word8 (..))
import Network.URI (
    URI (..),
    URIAuth (..),
    escapeURIString,
    isAbsoluteURI,
    isAllowedInURI,
    parseRelativeReference,
    parseURI,
    uriToString,
 )
import OpenSSL (withOpenSSL)
import OpenSSL.Session (SSLContext)
import qualified OpenSSL.Session as SSL
import System.FilePath.Posix (takeFileName)
import System.IO.Streams (InputStream, OutputStream)
import qualified System.IO.Streams as Streams
import qualified System.IO.Streams.Attoparsec as Streams
import System.IO.Unsafe (unsafePerformIO)

#if !MIN_VERSION_base(4,8,0)
import Data.Monoid (Monoid (..), mappend)
#endif

import Network.Http.Connection
import Network.Http.Internal
import Network.Http.RequestBuilder

-- (see also http://downloads.haskell.org/~ghc/8.4.2/docs/html/users_guide/phases.html#standard-cpp-macros
-- for a list of predefined CPP macros provided by GHC and/or Cabal; see also the cabal user's guide)
#if defined(linux_HOST_OS) || defined(freebsd_HOST_OS)
import System.Directory (doesDirectoryExist)
#endif

type URL = ByteString

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

{- |
URL-escapes a string (see
<http://tools.ietf.org/html/rfc2396.html#section-2.4>)
-}
urlEncode :: ByteString -> URL
urlEncode :: ByteString -> ByteString
urlEncode = Builder -> ByteString
Builder.toByteString forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Builder
urlEncodeBuilder
{-# INLINE urlEncode #-}

{- |
URL-escapes a string (see
<http://tools.ietf.org/html/rfc2396.html#section-2.4>) into a 'Builder'.
-}
urlEncodeBuilder :: ByteString -> Builder
urlEncodeBuilder :: ByteString -> Builder
urlEncodeBuilder = Builder -> ByteString -> Builder
go forall a. Monoid a => a
mempty
  where
    go :: Builder -> ByteString -> Builder
go !Builder
b !ByteString
s = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Builder
b' (Char, ByteString) -> Builder
esc (ByteString -> Maybe (Char, ByteString)
S.uncons ByteString
y)
      where
        (ByteString
x, ByteString
y) = (Char -> Bool) -> ByteString -> (ByteString, ByteString)
S.span (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. (Eq a, Hashable a) => a -> HashSet a -> Bool
HashSet.member HashSet Char
urlEncodeTable) ByteString
s
        b' :: Builder
b' = Builder
b forall a. Monoid a => a -> a -> a
`mappend` ByteString -> Builder
Builder.fromByteString ByteString
x
        esc :: (Char, ByteString) -> Builder
esc (Char
c, ByteString
r) =
            let b'' :: Builder
b'' =
                    if Char
c forall a. Eq a => a -> a -> Bool
== Char
' '
                        then Builder
b' forall a. Monoid a => a -> a -> a
`mappend` Word8 -> Builder
Builder.fromWord8 (Char -> Word8
c2w Char
'+')
                        else Builder
b' forall a. Monoid a => a -> a -> a
`mappend` Char -> Builder
hexd Char
c
             in Builder -> ByteString -> Builder
go Builder
b'' ByteString
r

hexd :: Char -> Builder
hexd :: Char -> Builder
hexd Char
c0 =
    Word8 -> Builder
Builder.fromWord8 (Char -> Word8
c2w Char
'%') forall a. Monoid a => a -> a -> a
`mappend` Word8 -> Builder
Builder.fromWord8 Word8
hi
        forall a. Monoid a => a -> a -> a
`mappend` Word8 -> Builder
Builder.fromWord8 Word8
low
  where
    !c :: Word8
c = Char -> Word8
c2w Char
c0
    toDigit :: StatusCode -> Word8
toDigit = Char -> Word8
c2w forall b c a. (b -> c) -> (a -> b) -> a -> c
. StatusCode -> Char
intToDigit
    !low :: Word8
low = StatusCode -> Word8
toDigit forall a b. (a -> b) -> a -> b
$ forall a. Enum a => a -> StatusCode
fromEnum forall a b. (a -> b) -> a -> b
$ Word8
c forall a. Bits a => a -> a -> a
.&. Word8
0xf
    !hi :: Word8
hi = StatusCode -> Word8
toDigit forall a b. (a -> b) -> a -> b
$ (Word8
c forall a. Bits a => a -> a -> a
.&. Word8
0xf0) Word8 -> StatusCode -> StatusCode
`shiftr` StatusCode
4

    shiftr :: Word8 -> StatusCode -> StatusCode
shiftr (W8# Word8#
a#) (I# Int#
b#) = Int# -> StatusCode
I# (Word# -> Int#
word2Int# (Word8# -> Int# -> Word#
uncheckedShiftRL'# Word8#
a# Int#
b#))
#if MIN_VERSION_base(4,16,0)
    uncheckedShiftRL'# :: Word8# -> Int# -> Word#
uncheckedShiftRL'# Word8#
a# Int#
b# = Word8# -> Word#
word8ToWord# (Word8# -> Int# -> Word8#
uncheckedShiftRLWord8# Word8#
a# Int#
b#)
#else
    uncheckedShiftRL'# = uncheckedShiftRL#
#endif

urlEncodeTable :: HashSet Char
urlEncodeTable :: HashSet Char
urlEncodeTable = forall a. (Eq a, Hashable a) => [a] -> HashSet a
HashSet.fromList forall a b. (a -> b) -> a -> b
$! forall a. (a -> Bool) -> [a] -> [a]
filter Char -> Bool
f forall a b. (a -> b) -> a -> b
$! forall a b. (a -> b) -> [a] -> [b]
map Word8 -> Char
w2c [Word8
0 .. Word8
255]
  where
    f :: Char -> Bool
f Char
c
        | Char
c forall a. Ord a => a -> a -> Bool
>= Char
'A' Bool -> Bool -> Bool
&& Char
c forall a. Ord a => a -> a -> Bool
<= Char
'Z' = Bool
True
        | Char
c forall a. Ord a => a -> a -> Bool
>= Char
'a' Bool -> Bool -> Bool
&& Char
c forall a. Ord a => a -> a -> Bool
<= Char
'z' = Bool
True
        | Char
c forall a. Ord a => a -> a -> Bool
>= Char
'0' Bool -> Bool -> Bool
&& Char
c forall a. Ord a => a -> a -> Bool
<= Char
'9' = Bool
True
    f Char
c = Char
c forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ([Char]
"$-_.!~*'()," :: String)

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

{-
    The default SSLContext used by the convenience APIs in the http-streams
    library. This is a kludge, unsafe bad yada yada. The technique, however,
    was described on a Haskell Wiki page, so that makes it an officially
    supported kludge. The justification for doing this is a) the functions
    accessing this IORef are themselves all in the IO monad, and b) these
    contortions are necessary to allow the library to be used for https:// URLs
    *without* requiring the developer to do 'withOpenSSL'.
-}
global :: IORef SSLContext
global :: IORef SSLContext
global = forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ do
    SSLContext
ctx <- IO SSLContext
baselineContextSSL
    forall a. a -> IO (IORef a)
newIORef SSLContext
ctx
{-# NOINLINE global #-}

{- |
Modify the context being used to configure the SSL tunnel used by
the convenience API functions to make @https://@ connections. The
default is that setup by 'baselineContextSSL'.
-}
modifyContextSSL :: (SSLContext -> IO SSLContext) -> IO ()
modifyContextSSL :: (SSLContext -> IO SSLContext) -> IO ()
modifyContextSSL SSLContext -> IO SSLContext
f = do
    SSLContext
ctx <- forall a. IORef a -> IO a
readIORef IORef SSLContext
global
    SSLContext
ctx' <- SSLContext -> IO SSLContext
f SSLContext
ctx
    forall a. IORef a -> a -> IO ()
writeIORef IORef SSLContext
global SSLContext
ctx'

{- |
Given a URL, work out whether it is normal, secure, or unix domain,
and then open the connection to the webserver including setting the
appropriate default port if one was not specified in the URL. This
is what powers the convenience API, but you may find it useful in
composing your own similar functions.

For example (on the assumption that your server behaves when given
an absolute URI as the request path), this will open a connection
to server @www.example.com@ port @443@ and request @/photo.jpg@:

>     let url = "https://www.example.com/photo.jpg"
>
>     c <- establishConnection url
>     let q = buildRequest1 $ do
>                 http GET url
>     ...
-}
establishConnection :: URL -> IO (Connection)
establishConnection :: ByteString -> IO Connection
establishConnection ByteString
r' = do
    URI -> IO Connection
establish URI
u
  where
    u :: URI
u = ByteString -> URI
parseURL ByteString
r'
{-# INLINE establishConnection #-}

establish :: URI -> IO (Connection)
establish :: URI -> IO Connection
establish URI
u =
    case [Char]
scheme of
        [Char]
"http:" -> do
            ByteString -> Port -> IO Connection
openConnection ByteString
host Port
port
        [Char]
"https:" -> do
            SSLContext
ctx <- forall a. IORef a -> IO a
readIORef IORef SSLContext
global
            SSLContext -> ByteString -> Port -> IO Connection
openConnectionSSL SSLContext
ctx ByteString
host Port
ports
        [Char]
"unix:" -> do
            [Char] -> IO Connection
openConnectionUnix forall a b. (a -> b) -> a -> b
$ URI -> [Char]
uriPath URI
u
        [Char]
_ -> forall a. HasCallStack => [Char] -> a
error ([Char]
"Unknown URI scheme " forall a. [a] -> [a] -> [a]
++ [Char]
scheme)
  where
    scheme :: [Char]
scheme = URI -> [Char]
uriScheme URI
u

    auth :: URIAuth
auth = case URI -> Maybe URIAuth
uriAuthority URI
u of
        Just URIAuth
x -> URIAuth
x
        Maybe URIAuth
Nothing -> [Char] -> [Char] -> [Char] -> URIAuth
URIAuth [Char]
"" [Char]
"localhost" [Char]
""

    host :: ByteString
host = [Char] -> ByteString
S.pack (URIAuth -> [Char]
uriRegName URIAuth
auth)
    port :: Port
port = case URIAuth -> [Char]
uriPort URIAuth
auth of
        [Char]
"" -> Port
80
        [Char]
_ -> forall a. Read a => [Char] -> a
read forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
tail forall a b. (a -> b) -> a -> b
$ URIAuth -> [Char]
uriPort URIAuth
auth :: Word16
    ports :: Port
ports = case URIAuth -> [Char]
uriPort URIAuth
auth of
        [Char]
"" -> Port
443
        [Char]
_ -> forall a. Read a => [Char] -> a
read forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
tail forall a b. (a -> b) -> a -> b
$ URIAuth -> [Char]
uriPort URIAuth
auth :: Word16

{- |
Creates a basic SSL context. This is the SSL context used if you make an
@\"https:\/\/\"@ request using one of the convenience functions. It
configures OpenSSL to use the default set of ciphers.

On Linux, OpenBSD and FreeBSD systems, this function also configures
OpenSSL to verify certificates using the system/distribution supplied
certificate authorities' certificates

On other systems, /no certificate validation is performed/ by the
generated 'SSLContext' because there is no canonical place to find
the set of system certificates. When using this library on such system,
you are encouraged to install the system
certificates somewhere and create your own 'SSLContext'.
-}

{-
    We would like to turn certificate verification on for everyone, but
    this has proved contingent on leveraging platform specific mechanisms
    to reach the certificate store. That logic should probably be in
    hsopenssl, but feel free to change this as appropriate for your OS.
-}
baselineContextSSL :: IO SSLContext
baselineContextSSL :: IO SSLContext
baselineContextSSL = forall a. IO a -> IO a
withOpenSSL forall a b. (a -> b) -> a -> b
$ do
    SSLContext
ctx <- IO SSLContext
SSL.context
    SSLContext -> IO ()
SSL.contextSetDefaultCiphers SSLContext
ctx
#if defined(darwin_HOST_OS)
    SSL.contextSetVerificationMode ctx SSL.VerifyNone
#elif defined(mingw32_HOST_OS)
    SSL.contextSetVerificationMode ctx SSL.VerifyNone
#elif defined(freebsd_HOST_OS)
    SSL.contextSetCAFile ctx "/usr/local/etc/ssl/cert.pem"
    SSL.contextSetVerificationMode ctx $ SSL.VerifyPeer True True Nothing
#elif defined(openbsd_HOST_OS)
    SSL.contextSetCAFile ctx "/etc/ssl/cert.pem"
    SSL.contextSetVerificationMode ctx $ SSL.VerifyPeer True True Nothing
#else
    Bool
fedora <- [Char] -> IO Bool
doesDirectoryExist [Char]
"/etc/pki/tls"
    if Bool
fedora
        then do
            SSLContext -> [Char] -> IO ()
SSL.contextSetCAFile SSLContext
ctx [Char]
"/etc/pki/tls/certs/ca-bundle.crt"
        else do
            SSLContext -> [Char] -> IO ()
SSL.contextSetCADirectory SSLContext
ctx [Char]
"/etc/ssl/certs"
    SSLContext -> VerificationMode -> IO ()
SSL.contextSetVerificationMode SSLContext
ctx forall a b. (a -> b) -> a -> b
$ Bool
-> Bool
-> Maybe (Bool -> X509StoreCtx -> IO Bool)
-> VerificationMode
SSL.VerifyPeer Bool
True Bool
True forall a. Maybe a
Nothing
#endif
    forall (m :: * -> *) a. Monad m => a -> m a
return SSLContext
ctx

parseURL :: URL -> URI
parseURL :: ByteString -> URI
parseURL ByteString
r' =
    case [Char] -> Maybe URI
parseURI [Char]
r of
        Just URI
u -> URI
u
        Maybe URI
Nothing -> forall a. HasCallStack => [Char] -> a
error ([Char]
"Can't parse URI " forall a. [a] -> [a] -> [a]
++ [Char]
r)
  where
    r :: [Char]
r = (Char -> Bool) -> [Char] -> [Char]
escapeURIString Char -> Bool
isAllowedInURI forall a b. (a -> b) -> a -> b
$ Text -> [Char]
T.unpack forall a b. (a -> b) -> a -> b
$ ByteString -> Text
T.decodeUtf8 ByteString
r'

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

{-
    Account for bug where "http://www.example.com" is parsed with no
    path element, resulting in an illegal HTTP request line.
-}

pathFrom :: URI -> ByteString
pathFrom :: URI -> ByteString
pathFrom URI
u = case ByteString
url of
    ByteString
"" -> ByteString
"/"
    ByteString
_ -> ByteString
url
  where
    url :: ByteString
url =
        Text -> ByteString
T.encodeUtf8 forall a b. (a -> b) -> a -> b
$! [Char] -> Text
T.pack
            forall a b. (a -> b) -> a -> b
$! forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [URI -> [Char]
uriPath URI
u, URI -> [Char]
uriQuery URI
u, URI -> [Char]
uriFragment URI
u]

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

{- |
Issue an HTTP GET request and pass the resultant response to the
supplied handler function. This code will silently follow redirects,
to a maximum depth of 5 hops.

The handler function is as for 'receiveResponse', so you can use one
of the supplied convenience handlers if you're in a hurry:

>     x' <- get "http://www.bbc.co.uk/news/" concatHandler

But as ever the disadvantage of doing this is that you're not doing
anything intelligent with the HTTP response status code. If you want
an exception raised in the event of a non @2xx@ response, you can use:

>     x' <- get "http://www.bbc.co.uk/news/" concatHandler'

but for anything more refined you'll find it easy to simply write
your own handler function.

Throws 'TooManyRedirects' if more than 5 redirects are thrown.
-}
get ::
    -- | Resource to GET from.
    URL ->
    -- | Handler function to receive the response from the server.
    (Response -> InputStream ByteString -> IO β) ->
    IO β
get :: forall β.
ByteString -> (Response -> InputStream ByteString -> IO β) -> IO β
get ByteString
r' Response -> InputStream ByteString -> IO β
handler = forall {c}.
StatusCode
-> ByteString
-> (Response -> InputStream ByteString -> IO c)
-> IO c
getN StatusCode
0 ByteString
r' Response -> InputStream ByteString -> IO β
handler

getN :: StatusCode
-> ByteString
-> (Response -> InputStream ByteString -> IO c)
-> IO c
getN StatusCode
n ByteString
r' Response -> InputStream ByteString -> IO c
handler = do
    forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket
        (URI -> IO Connection
establish URI
u)
        (Connection -> IO ()
teardown)
        (Connection -> IO c
process)
  where
    teardown :: Connection -> IO ()
teardown = Connection -> IO ()
closeConnection

    u :: URI
u = ByteString -> URI
parseURL ByteString
r'

    q :: Request
q = forall α. RequestBuilder α -> Request
buildRequest1 forall a b. (a -> b) -> a -> b
$ do
        Method -> ByteString -> RequestBuilder ()
http Method
GET (URI -> ByteString
pathFrom URI
u)
        ByteString -> RequestBuilder ()
setAccept ByteString
"*/*"

    process :: Connection -> IO c
process Connection
c = do
        forall α.
Connection -> Request -> (OutputStream Builder -> IO α) -> IO α
sendRequest Connection
c Request
q OutputStream Builder -> IO ()
emptyBody

        forall β.
Connection -> (Response -> InputStream ByteString -> IO β) -> IO β
receiveResponse Connection
c (forall β.
URI
-> StatusCode
-> (Response -> InputStream ByteString -> IO β)
-> Response
-> InputStream ByteString
-> IO β
wrapRedirect URI
u StatusCode
n Response -> InputStream ByteString -> IO c
handler)

{-
    This is fairly simple-minded. Improvements could include reusing
    the Connection if the redirect is to the same host, and closing
    the original Connection if it is not. These are both things that
    can be done manually if using the full API, so not worried about
    it for now.
-}

wrapRedirect ::
    URI ->
    Int ->
    (Response -> InputStream ByteString -> IO β) ->
    Response ->
    InputStream ByteString ->
    IO β
wrapRedirect :: forall β.
URI
-> StatusCode
-> (Response -> InputStream ByteString -> IO β)
-> Response
-> InputStream ByteString
-> IO β
wrapRedirect URI
u StatusCode
n Response -> InputStream ByteString -> IO β
handler Response
p InputStream ByteString
i = do
    if (StatusCode
s forall a. Eq a => a -> a -> Bool
== StatusCode
301 Bool -> Bool -> Bool
|| StatusCode
s forall a. Eq a => a -> a -> Bool
== StatusCode
302 Bool -> Bool -> Bool
|| StatusCode
s forall a. Eq a => a -> a -> Bool
== StatusCode
303 Bool -> Bool -> Bool
|| StatusCode
s forall a. Eq a => a -> a -> Bool
== StatusCode
307)
        then case Maybe ByteString
lm of
            Just ByteString
l -> forall {c}.
StatusCode
-> ByteString
-> (Response -> InputStream ByteString -> IO c)
-> IO c
getN StatusCode
n' (URI -> ByteString -> ByteString
splitURI URI
u ByteString
l) Response -> InputStream ByteString -> IO β
handler
            Maybe ByteString
Nothing -> Response -> InputStream ByteString -> IO β
handler Response
p InputStream ByteString
i
        else Response -> InputStream ByteString -> IO β
handler Response
p InputStream ByteString
i
  where
    s :: StatusCode
s = Response -> StatusCode
getStatusCode Response
p
    lm :: Maybe ByteString
lm = Response -> ByteString -> Maybe ByteString
getHeader Response
p ByteString
"Location"
    !n' :: StatusCode
n' =
        if StatusCode
n forall a. Ord a => a -> a -> Bool
< StatusCode
5
            then StatusCode
n forall a. Num a => a -> a -> a
+ StatusCode
1
            else forall a e. Exception e => e -> a
throw forall a b. (a -> b) -> a -> b
$! StatusCode -> TooManyRedirects
TooManyRedirects StatusCode
n

splitURI :: URI -> URL -> URL
splitURI :: URI -> ByteString -> ByteString
splitURI URI
old ByteString
new' =
    let new :: [Char]
new = ByteString -> [Char]
S.unpack ByteString
new'
     in if [Char] -> Bool
isAbsoluteURI [Char]
new
            then ByteString
new'
            else
                let rel :: Maybe URI
rel = [Char] -> Maybe URI
parseRelativeReference [Char]
new
                 in case Maybe URI
rel of
                        Maybe URI
Nothing -> ByteString
new'
                        Just URI
x ->
                            [Char] -> ByteString
S.pack forall a b. (a -> b) -> a -> b
$
                                ([Char] -> [Char]) -> URI -> [Char] -> [Char]
uriToString
                                    forall a. a -> a
id
                                    URI
old
                                        { uriPath :: [Char]
uriPath = URI -> [Char]
uriPath URI
x
                                        , uriQuery :: [Char]
uriQuery = URI -> [Char]
uriQuery URI
x
                                        , uriFragment :: [Char]
uriFragment = URI -> [Char]
uriFragment URI
x
                                        }
                                    [Char]
""

data TooManyRedirects = TooManyRedirects Int
    deriving (Typeable, StatusCode -> TooManyRedirects -> [Char] -> [Char]
[TooManyRedirects] -> [Char] -> [Char]
TooManyRedirects -> [Char]
forall a.
(StatusCode -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
showList :: [TooManyRedirects] -> [Char] -> [Char]
$cshowList :: [TooManyRedirects] -> [Char] -> [Char]
show :: TooManyRedirects -> [Char]
$cshow :: TooManyRedirects -> [Char]
showsPrec :: StatusCode -> TooManyRedirects -> [Char] -> [Char]
$cshowsPrec :: StatusCode -> TooManyRedirects -> [Char] -> [Char]
Show, TooManyRedirects -> TooManyRedirects -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TooManyRedirects -> TooManyRedirects -> Bool
$c/= :: TooManyRedirects -> TooManyRedirects -> Bool
== :: TooManyRedirects -> TooManyRedirects -> Bool
$c== :: TooManyRedirects -> TooManyRedirects -> Bool
Eq)

instance Exception TooManyRedirects

{- |
Send content to a server via an HTTP POST request. Use this
function if you have an 'OutputStream' with the body content.
-}
post ::
    -- | Resource to POST to.
    URL ->
    -- | MIME type of the request body being sent.
    ContentType ->
    -- | Handler function to write content to server.
    (OutputStream Builder -> IO α) ->
    -- | Handler function to receive the response from the server.
    (Response -> InputStream ByteString -> IO β) ->
    IO β
post :: forall α β.
ByteString
-> ByteString
-> (OutputStream Builder -> IO α)
-> (Response -> InputStream ByteString -> IO β)
-> IO β
post ByteString
r' ByteString
t OutputStream Builder -> IO α
body Response -> InputStream ByteString -> IO β
handler = do
    forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket
        (URI -> IO Connection
establish URI
u)
        (Connection -> IO ()
teardown)
        (Connection -> IO β
process)
  where
    teardown :: Connection -> IO ()
teardown = Connection -> IO ()
closeConnection

    u :: URI
u = ByteString -> URI
parseURL ByteString
r'

    q :: Request
q = forall α. RequestBuilder α -> Request
buildRequest1 forall a b. (a -> b) -> a -> b
$ do
        Method -> ByteString -> RequestBuilder ()
http Method
POST (URI -> ByteString
pathFrom URI
u)
        ByteString -> RequestBuilder ()
setAccept ByteString
"*/*"
        ByteString -> RequestBuilder ()
setContentType ByteString
t

    process :: Connection -> IO β
process Connection
c = do
        α
_ <- forall α.
Connection -> Request -> (OutputStream Builder -> IO α) -> IO α
sendRequest Connection
c Request
q OutputStream Builder -> IO α
body

        β
x <- forall β.
Connection -> (Response -> InputStream ByteString -> IO β) -> IO β
receiveResponse Connection
c Response -> InputStream ByteString -> IO β
handler
        forall (m :: * -> *) a. Monad m => a -> m a
return β
x

{- |
Send form data to a server via an HTTP POST request. This is the
usual use case; most services expect the body to be MIME type
@application/x-www-form-urlencoded@ as this is what conventional
web browsers send on form submission. If you want to POST to a URL
with an arbitrary Content-Type, use 'post'.
-}
postForm ::
    -- | Resource to POST to.
    URL ->
    -- | List of name=value pairs. Will be sent URL-encoded.
    [(ByteString, ByteString)] ->
    -- | Handler function to receive the response from the server.
    (Response -> InputStream ByteString -> IO β) ->
    IO β
postForm :: forall β.
ByteString
-> [(ByteString, ByteString)]
-> (Response -> InputStream ByteString -> IO β)
-> IO β
postForm ByteString
r' [(ByteString, ByteString)]
nvs Response -> InputStream ByteString -> IO β
handler = do
    forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket
        (URI -> IO Connection
establish URI
u)
        (Connection -> IO ()
teardown)
        (Connection -> IO β
process)
  where
    teardown :: Connection -> IO ()
teardown = Connection -> IO ()
closeConnection

    u :: URI
u = ByteString -> URI
parseURL ByteString
r'

    q :: Request
q = forall α. RequestBuilder α -> Request
buildRequest1 forall a b. (a -> b) -> a -> b
$ do
        Method -> ByteString -> RequestBuilder ()
http Method
POST (URI -> ByteString
pathFrom URI
u)
        ByteString -> RequestBuilder ()
setAccept ByteString
"*/*"
        ByteString -> RequestBuilder ()
setContentType ByteString
"application/x-www-form-urlencoded"

    process :: Connection -> IO β
process Connection
c = do
        ()
_ <- forall α.
Connection -> Request -> (OutputStream Builder -> IO α) -> IO α
sendRequest Connection
c Request
q ([(ByteString, ByteString)] -> OutputStream Builder -> IO ()
encodedFormBody [(ByteString, ByteString)]
nvs)

        β
x <- forall β.
Connection -> (Response -> InputStream ByteString -> IO β) -> IO β
receiveResponse Connection
c Response -> InputStream ByteString -> IO β
handler
        forall (m :: * -> *) a. Monad m => a -> m a
return β
x

{- |
Specify name/value pairs to be sent to the server in the manner
used by web browsers when submitting a form via a POST request.
Parameters will be URL encoded per RFC 2396 and combined into a
single string which will be sent as the body of your request.

You use this partially applied:

>     let nvs = [("name","Kermit"),
>                ("type","frog")]
>                ("role","stagehand")]
>
>     sendRequest c q (encodedFormBody nvs)

Note that it's going to be up to you to call 'setContentType' with
a value of @\"application/x-www-form-urlencoded\"@ when building the
Request object; the 'postForm' convenience (which uses this
@encodedFormBody@ function) takes care of this for you, obviously.
-}
encodedFormBody :: [(ByteString, ByteString)] -> OutputStream Builder -> IO ()
encodedFormBody :: [(ByteString, ByteString)] -> OutputStream Builder -> IO ()
encodedFormBody [(ByteString, ByteString)]
nvs OutputStream Builder
o = do
    forall a. Maybe a -> OutputStream a -> IO ()
Streams.write (forall a. a -> Maybe a
Just Builder
b) OutputStream Builder
o
  where
    b :: Builder
b = forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ forall a. a -> [a] -> [a]
intersperse ([Char] -> Builder
Builder.fromString [Char]
"&") forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (ByteString, ByteString) -> Builder
combine [(ByteString, ByteString)]
nvs

    combine :: (ByteString, ByteString) -> Builder
    combine :: (ByteString, ByteString) -> Builder
combine (ByteString
n', ByteString
v') = forall a. Monoid a => [a] -> a
mconcat [ByteString -> Builder
urlEncodeBuilder ByteString
n', [Char] -> Builder
Builder.fromString [Char]
"=", ByteString -> Builder
urlEncodeBuilder ByteString
v']

{- |
Build a list of parts into an upload body.

You use this partially applied:

>     boundary <- randomBoundary
>
>     let q = buildRequest1 $ do
>           http POST "/api/v1/upload"
>           setContentMultipart boundary
>
>     let parts =
>             [ simplePart "metadata" Nothing metadata
>             , filePart "submission" (Just "audio/wav") filepath
>             ]
>
>     sendRequest c q (multipartFormBody boundary parts)

You /must/ have called 'setContentMultipart' when forming the request or the
request body you are sending will be invalid and (obviously) you must pass in
that same 'Boundary' value when calling this function.
-}
multipartFormBody :: Boundary -> [Part] -> OutputStream Builder -> IO ()
multipartFormBody :: Boundary -> [Part] -> OutputStream Builder -> IO ()
multipartFormBody Boundary
boundary [Part]
parts OutputStream Builder
o = do
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Part -> IO ()
handlePart [Part]
parts
    IO ()
handleEnding
  where
    handlePart :: Part -> IO ()
    handlePart :: Part -> IO ()
handlePart (Part ByteString
field Maybe ByteString
possibleContentType Maybe [Char]
possibleFilename OutputStream Builder -> IO ()
action) = do
        let h' :: Builder
h' = Boundary
-> ByteString -> Maybe [Char] -> Maybe ByteString -> Builder
composeMultipartBytes Boundary
boundary ByteString
field Maybe [Char]
possibleFilename Maybe ByteString
possibleContentType
        forall a. Maybe a -> OutputStream a -> IO ()
Streams.write (forall a. a -> Maybe a
Just Builder
h') OutputStream Builder
o
        OutputStream Builder -> IO ()
action OutputStream Builder
o

    handleEnding :: IO ()
    handleEnding :: IO ()
handleEnding = do
        forall a. Maybe a -> OutputStream a -> IO ()
Streams.write (forall a. a -> Maybe a
Just (Boundary -> Builder
composeMultipartEnding Boundary
boundary)) OutputStream Builder
o

{- |
Information about each of the parts of a @multipart/form-data@ form upload.
Build these with 'simplePart', 'filePart', or 'inputStreamPart'.
-}
data Part = Part
    { Part -> ByteString
partFieldName :: FieldName
    , Part -> Maybe ByteString
partContentType :: Maybe ContentType
    , Part -> Maybe [Char]
partFilename :: Maybe FilePath
    , Part -> OutputStream Builder -> IO ()
partDataHandler :: OutputStream Builder -> IO ()
    }

{- |
Given a simple static set of bytes, send them as a part in a multipart form
upload. You need to specify the name of the field for the form, and optionally
can supply a MIME content-type.
-}
simplePart :: FieldName -> Maybe ContentType -> ByteString -> Part
simplePart :: ByteString -> Maybe ByteString -> ByteString -> Part
simplePart ByteString
name Maybe ByteString
possibleContentType ByteString
x' =
    let action :: OutputStream Builder -> IO ()
action OutputStream Builder
o = do
            InputStream ByteString
i1 <- ByteString -> IO (InputStream ByteString)
Streams.fromByteString ByteString
x'
            InputStream Builder
i2 <- forall a b. (a -> b) -> InputStream a -> IO (InputStream b)
Streams.map ByteString -> Builder
Builder.fromByteString InputStream ByteString
i1
            forall a. InputStream a -> OutputStream a -> IO ()
Streams.supply InputStream Builder
i2 OutputStream Builder
o
     in ByteString
-> Maybe ByteString
-> Maybe [Char]
-> (OutputStream Builder -> IO ())
-> Part
Part ByteString
name Maybe ByteString
possibleContentType forall a. Maybe a
Nothing OutputStream Builder -> IO ()
action

{- |
The most common case in using multipart form data is to upload a file. Specify
the name of the field, optionally a MIME content-type, and then the path to
the file to be transmitted. The filename (without directory) will be used to
name the file to the server.
-}
filePart :: FieldName -> Maybe ContentType -> FilePath -> Part
filePart :: ByteString -> Maybe ByteString -> [Char] -> Part
filePart ByteString
name Maybe ByteString
possibleContentType [Char]
path =
    let action :: OutputStream Builder -> IO ()
action OutputStream Builder
o = do
            forall a. [Char] -> (InputStream ByteString -> IO a) -> IO a
Streams.withFileAsInput
                [Char]
path
                ( \InputStream ByteString
i1 -> do
                    InputStream Builder
i2 <- forall a b. (a -> b) -> InputStream a -> IO (InputStream b)
Streams.map ByteString -> Builder
Builder.fromByteString InputStream ByteString
i1
                    forall a. InputStream a -> OutputStream a -> IO ()
Streams.supply InputStream Builder
i2 OutputStream Builder
o
                )

        filename :: [Char]
filename = [Char] -> [Char]
takeFileName [Char]
path
     in ByteString
-> Maybe ByteString
-> Maybe [Char]
-> (OutputStream Builder -> IO ())
-> Part
Part ByteString
name Maybe ByteString
possibleContentType (forall a. a -> Maybe a
Just [Char]
filename) OutputStream Builder -> IO ()
action

{- |
Build a piece of a multipart submission from an 'InputStream'. You need to
specify a field name for this piece of the submission, and can optionally
indicate the MIME type and a filename (if what you are sending is going to be
interpreted as a file).
-}
inputStreamPart :: FieldName -> Maybe ContentType -> Maybe FilePath -> InputStream ByteString -> Part
inputStreamPart :: ByteString
-> Maybe ByteString
-> Maybe [Char]
-> InputStream ByteString
-> Part
inputStreamPart ByteString
name Maybe ByteString
possibleContentType Maybe [Char]
possilbeFilename InputStream ByteString
i1 =
    let action :: OutputStream Builder -> IO ()
action OutputStream Builder
o = do
            InputStream Builder
i2 <- forall a b. (a -> b) -> InputStream a -> IO (InputStream b)
Streams.map ByteString -> Builder
Builder.fromByteString InputStream ByteString
i1
            forall a. InputStream a -> OutputStream a -> IO ()
Streams.supply InputStream Builder
i2 OutputStream Builder
o
     in ByteString
-> Maybe ByteString
-> Maybe [Char]
-> (OutputStream Builder -> IO ())
-> Part
Part ByteString
name Maybe ByteString
possibleContentType Maybe [Char]
possilbeFilename OutputStream Builder -> IO ()
action

{- |
Place content on the server at the given URL via an HTTP PUT
request, specifying the content type and a function to write the
content to the supplied 'OutputStream'. You might see:

>     put "http://s3.example.com/bucket42/object149" "text/plain"
>         (fileBody "hello.txt") (\p i -> do
>             putStr $ show p
>             Streams.connect i stdout)
-}
put ::
    -- | Resource to PUT to.
    URL ->
    -- | MIME type of the request body being sent.
    ContentType ->
    -- | Handler function to write content to server.
    (OutputStream Builder -> IO α) ->
    -- | Handler function to receive the response from the server.
    (Response -> InputStream ByteString -> IO β) ->
    IO β
put :: forall α β.
ByteString
-> ByteString
-> (OutputStream Builder -> IO α)
-> (Response -> InputStream ByteString -> IO β)
-> IO β
put ByteString
r' ByteString
t OutputStream Builder -> IO α
body Response -> InputStream ByteString -> IO β
handler = do
    forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket
        (URI -> IO Connection
establish URI
u)
        (Connection -> IO ()
teardown)
        (Connection -> IO β
process)
  where
    teardown :: Connection -> IO ()
teardown = Connection -> IO ()
closeConnection

    u :: URI
u = ByteString -> URI
parseURL ByteString
r'

    q :: Request
q = forall α. RequestBuilder α -> Request
buildRequest1 forall a b. (a -> b) -> a -> b
$ do
        Method -> ByteString -> RequestBuilder ()
http Method
PUT (URI -> ByteString
pathFrom URI
u)
        ByteString -> RequestBuilder ()
setAccept ByteString
"*/*"
        ByteString -> ByteString -> RequestBuilder ()
setHeader ByteString
"Content-Type" ByteString
t

    process :: Connection -> IO β
process Connection
c = do
        α
_ <- forall α.
Connection -> Request -> (OutputStream Builder -> IO α) -> IO α
sendRequest Connection
c Request
q OutputStream Builder -> IO α
body

        β
x <- forall β.
Connection -> (Response -> InputStream ByteString -> IO β) -> IO β
receiveResponse Connection
c Response -> InputStream ByteString -> IO β
handler
        forall (m :: * -> *) a. Monad m => a -> m a
return β
x

{- |
A special case of 'concatHandler', this function will return the
entire response body as a single ByteString, but will throw
'HttpClientError' if the response status code was other than @2xx@.
-}
simpleHandler' :: Response -> InputStream ByteString -> IO ByteString
simpleHandler' :: Response -> InputStream ByteString -> IO ByteString
simpleHandler' Response
p InputStream ByteString
i =
    if StatusCode
s forall a. Ord a => a -> a -> Bool
>= StatusCode
300
        then forall a e. Exception e => e -> a
throw (StatusCode -> ByteString -> HttpClientError
HttpClientError StatusCode
s ByteString
m)
        else Response -> InputStream ByteString -> IO ByteString
simpleHandler Response
p InputStream ByteString
i
  where
    s :: StatusCode
s = Response -> StatusCode
getStatusCode Response
p
    m :: ByteString
m = Response -> ByteString
getStatusMessage Response
p

concatHandler' :: Response -> InputStream ByteString -> IO ByteString
concatHandler' :: Response -> InputStream ByteString -> IO ByteString
concatHandler' = Response -> InputStream ByteString -> IO ByteString
simpleHandler'

data HttpClientError = HttpClientError Int ByteString
    deriving (Typeable)

instance Exception HttpClientError

instance Show HttpClientError where
    show :: HttpClientError -> [Char]
show (HttpClientError StatusCode
s ByteString
msg) = forall a. Show a => a -> [Char]
Prelude.show StatusCode
s forall a. [a] -> [a] -> [a]
++ [Char]
" " forall a. [a] -> [a] -> [a]
++ ByteString -> [Char]
S.unpack ByteString
msg

{-
    There should probably also be HttpServerError and maybe even
    HttpRedirectError, but as these names don't seem to show up
    in the runtime when raised, not sure it's worth the bother. It's
    not like we'd want anything different in their Show instances.
-}

{- |
If you've got an object of a type with a 'ToJSON' instance and you need to
send that object as JSON up to a web service API, this can help.

You use this partially applied:

>    sendRequest c q (jsonBody thing)
-}
jsonBody :: ToJSON a => a -> OutputStream Builder -> IO ()
jsonBody :: forall a. ToJSON a => a -> OutputStream Builder -> IO ()
jsonBody a
thing OutputStream Builder
o = do
    let b :: Builder
b = ByteString -> Builder
Builder.fromLazyByteString (forall a. ToJSON a => a -> ByteString
encode a
thing)
    forall a. Maybe a -> OutputStream a -> IO ()
Streams.write (forall a. a -> Maybe a
Just Builder
b) OutputStream Builder
o

{- |
If you're working with a data stream that is in @application/json@,
then chances are you're using @aeson@ to handle the JSON to Haskell
decoding. If so, then this helper function might be of use.

>     v <- get "http://api.example.com/v1/" jsonHandler

This function feeds the input body to the 'Data.Aeson.Parser.json''
@attoparsec@ Parser in order to get the aeson Value type. This is then
marshalled to your type represeting the source data, via the FromJSON
typeclass.

The above example was actually insufficient; when working with
@aeson@ you need to fix the type so it knows what FromJSON instance
to use. Let's say you're getting Person objects, then it would be

>     v <- get "http://api.example.com/v1/person/461" jsonHandler :: IO Person

assuming your Person type had a FromJSON instance, of course.

/Note/

This function parses a single top level JSON object or array, which
is all you're supposed to get if it's a valid document. People do
all kinds of crazy things though, so beware. Also, this function (like the
"concatHander" convenience) loads the entire response into memory; it's
not /streaming/; if you're receiving a document which is (say) a very
long array of objects then you may want to implement your own
handler function, perhaps using "Streams.parserToInputStream" and
the 'Data.Aeson.Parser' combinators directly — with a result type of
InputStream Value, perhaps — by which you could then iterate over
the Values one at a time in constant space.
-}

{-
    This looks simple. It wasn't. The types involved are rediculous to
    disentangle. The biggest problem is that the Parser type used in
    [aeson] is *NOT* the Parser type from [attoparsec]. But the parsing
    function `json` and `json` from Aeson use the attoparsec Parser even
    though the rest of the top level page is all about Aeson's parser as
    used in FromJSON!

    Anyway, `json` and `json'` are [attoparsec] Parser [aeson] Value; we
    run that using the [io-streams] convenience function
    `parseFromStream` which gets us a Value which is the intermediate
    abstract syntax tree for a  JSON document. Then (and this was hard
    to find) to work with that in terms of the FromJSON typeclass, you
    use the `fromJSON` function which has type (FromJSON α => Value ->
    Result α). Then finally, pull the result out of it. Why in Bog's
    name this wasn't just Either I'll never know.
-}
jsonHandler ::
    (FromJSON α) =>
    Response ->
    InputStream ByteString ->
    IO α
jsonHandler :: forall α. FromJSON α => Response -> InputStream ByteString -> IO α
jsonHandler Response
_ InputStream ByteString
i = do
    Value
v <- forall r. Parser r -> InputStream ByteString -> IO r
Streams.parseFromStream Parser Value
json' InputStream ByteString
i -- Value
    let r :: Result α
r = forall a. FromJSON a => Value -> Result a
fromJSON Value
v -- Result
    case Result α
r of
        (Success α
a) -> forall (m :: * -> *) a. Monad m => a -> m a
return α
a
        (Error [Char]
str) -> forall a. HasCallStack => [Char] -> a
error [Char]
str