--
-- HTTP client for use with io-streams
--
-- Copyright © 2012-2018 Operational Dynamics Consulting, Pty Ltd
--           © 2018-2020 Herbert Valerio Riedel
--
-- 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_HADDOCK hide, not-home #-}

module Network.Http.Inconvenience (
    URL,
    modifyContextSSL,
    getContextSSL,
    establishConnection,
    get,
    post,
    postForm,
    encodedFormBody,
    put,
    baselineContextSSL,
    voidContextSSL,
    contextSetCASystemStore,
    concatHandler',
    TooManyRedirects(..),
    HttpClientError(..),

    ConnectionAddress(..),
    connectionAddressFromURI,
    connectionAddressFromURL,
    openConnectionAddress,
    openConnectionAddress',
    openConnectionAddress'',

        -- for testing
    splitURI
) where

import Blaze.ByteString.Builder (Builder)
import qualified Blaze.ByteString.Builder as Builder (fromByteString,
                                                      fromWord8, toByteString)
import qualified Blaze.ByteString.Builder.Char8 as Builder (fromString)
import Control.Exception (Exception, bracket, throw)
import Control.Monad (when, unless)
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, toLower, digitToInt, isHexDigit)
import Data.Set (Set)
import qualified Data.Set as Set
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 (Int(..),word2Int#, uncheckedShiftRL#)
import GHC.Word (Word8 (..))
import Network.URI (URI (..), URIAuth (..), isAbsoluteURI,
                    parseRelativeReference, parseURI, uriToString)
import OpenSSL (withOpenSSL)
import OpenSSL.Session (SSLContext)
import qualified OpenSSL.Session as SSL
import System.IO.Streams (InputStream, OutputStream)
import qualified System.IO.Streams 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.RequestBuilder
import Network.Http.Types

-- (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

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

unescBytes :: [Char] -> ByteString
unescBytes :: [Char] -> ByteString
unescBytes = [Char] -> ByteString
S.pack ([Char] -> ByteString)
-> ([Char] -> [Char]) -> [Char] -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char]
go
  where
    go :: [Char] -> [Char]
go [] = []
    go (Char
'%':Char
h:Char
l:[Char]
rest)
      | Char -> Bool
isHexDigit Char
h, Char -> Bool
isHexDigit Char
l = Int -> Char
forall a. Enum a => Int -> a
toEnum Int
b Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: [Char] -> [Char]
go [Char]
rest
      where
        b :: Int
b = (Int
16 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Char -> Int
digitToInt Char
h) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Char -> Int
digitToInt Char
l
    go (Char
c:[Char]
rest) = Char
c Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: [Char] -> [Char]
go [Char]
rest

--
-- | 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 (Builder -> ByteString)
-> (ByteString -> Builder) -> ByteString -> ByteString
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 Builder
forall a. Monoid a => a
mempty
  where
    go :: Builder -> ByteString -> Builder
go !Builder
b !ByteString
s = Builder
-> ((Char, ByteString) -> Builder)
-> Maybe (Char, ByteString)
-> Builder
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 ((Char -> Set Char -> Bool) -> Set Char -> Char -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip Char -> Set Char -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member Set Char
urlEncodeTable) ByteString
s
        b' :: Builder
b'        = Builder
b Builder -> Builder -> Builder
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 Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' '
                                then Builder
b' Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` Word8 -> Builder
Builder.fromWord8 (Char -> Word8
c2w Char
'+')
                                else Builder
b' Builder -> Builder -> Builder
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
'%') Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` Word8 -> Builder
Builder.fromWord8 Word8
hi
                                      Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` Word8 -> Builder
Builder.fromWord8 Word8
low
  where
    !c :: Word8
c        = Char -> Word8
c2w Char
c0
    toDigit :: Int -> Word8
toDigit   = Char -> Word8
c2w (Char -> Word8) -> (Int -> Char) -> Int -> Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Char
intToDigit
    !low :: Word8
low      = Int -> Word8
toDigit (Int -> Word8) -> Int -> Word8
forall a b. (a -> b) -> a -> b
$ Word8 -> Int
forall a. Enum a => a -> Int
fromEnum (Word8 -> Int) -> Word8 -> Int
forall a b. (a -> b) -> a -> b
$ Word8
c Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. Word8
0xf
    !hi :: Word8
hi       = Int -> Word8
toDigit (Int -> Word8) -> Int -> Word8
forall a b. (a -> b) -> a -> b
$ (Word8
c Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. Word8
0xf0) Word8 -> Int -> Int
`shiftr` Int
4

    shiftr :: Word8 -> Int -> Int
shiftr (W8# Word#
a#) (I# Int#
b#) = Int# -> Int
I# (Word# -> Int#
word2Int# (Word# -> Int# -> Word#
uncheckedShiftRL# Word#
a# Int#
b#))


urlEncodeTable :: Set Char
urlEncodeTable :: Set Char
urlEncodeTable = [Char] -> Set Char
forall a. Ord a => [a] -> Set a
Set.fromList ([Char] -> Set Char) -> [Char] -> Set Char
forall a b. (a -> b) -> a -> b
$! (Char -> Bool) -> [Char] -> [Char]
forall a. (a -> Bool) -> [a] -> [a]
filter Char -> Bool
f ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$! (Word8 -> Char) -> [Word8] -> [Char]
forall a b. (a -> b) -> [a] -> [b]
map Word8 -> Char
w2c [Word8
0..Word8
255]
  where
    f :: Char -> Bool
f Char
c | Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
'A' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'Z' = Bool
True
        | Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
'a' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'z' = Bool
True
        | Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
'0' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'9' = Bool
True
    f Char
c = Char
c Char -> [Char] -> Bool
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-io-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 = IO (IORef SSLContext) -> IORef SSLContext
forall a. IO a -> a
unsafePerformIO (IO (IORef SSLContext) -> IORef SSLContext)
-> IO (IORef SSLContext) -> IORef SSLContext
forall a b. (a -> b) -> a -> b
$ do
    SSLContext
ctx <- IO SSLContext
baselineContextSSL
    SSLContext -> IO (IORef SSLContext)
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'. See also 'getContextSSL'.
--
-- __NOTE__: This operation is /not/ reentrant; it is assumed this
-- operation is called once during program initialization and thus
-- there is currently no provision implemented to protected against
-- parallel execution from multiple threads!
modifyContextSSL :: (SSLContext -> IO SSLContext) -> IO ()
modifyContextSSL :: (SSLContext -> IO SSLContext) -> IO ()
modifyContextSSL SSLContext -> IO SSLContext
f = do
    SSLContext
ctx <- IORef SSLContext -> IO SSLContext
forall a. IORef a -> IO a
readIORef IORef SSLContext
global
    SSLContext
ctx' <- SSLContext -> IO SSLContext
f SSLContext
ctx
    IORef SSLContext -> SSLContext -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef SSLContext
global SSLContext
ctx'

--
-- | Retrieve the /global/ context being used to configure the SSL
-- connection used by the convenience API functions to make @https://@
-- connections. See also 'modifyContextSSL'.
--
-- @since 0.1.6.0
getContextSSL :: IO SSLContext
getContextSSL :: IO SSLContext
getContextSSL = IORef SSLContext -> IO SSLContext
forall a. IORef a -> IO a
readIORef IORef SSLContext
global

--
-- | 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 <- IORef SSLContext -> IO SSLContext
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 ([Char] -> IO Connection) -> [Char] -> IO Connection
forall a b. (a -> b) -> a -> b
$ URI -> [Char]
uriPath URI
u
        [Char]
_        -> [Char] -> IO Connection
forall a. HasCallStack => [Char] -> a
error ([Char]
"Unknown URI scheme " [Char] -> [Char] -> [Char]
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]
_   -> [Char] -> Port
forall a. Read a => [Char] -> a
read ([Char] -> Port) -> [Char] -> Port
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char]
forall a. [a] -> [a]
tail ([Char] -> [Char]) -> [Char] -> [Char]
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]
_   -> [Char] -> Port
forall a. Read a => [Char] -> a
read ([Char] -> Port) -> [Char] -> Port
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char]
forall a. [a] -> [a]
tail ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ URIAuth -> [Char]
uriPort URIAuth
auth :: Word16


-- | HTTP connection target
--
-- See also 'connectionAddressFromURL' and 'connectionAddressFromURI'.
--
-- @since 0.1.1.0
data ConnectionAddress
  = ConnectionAddressHttp     !Hostname !Word16 -- ^ Represents @http:\/\/host:port@
  | ConnectionAddressHttps    !Hostname !Word16 -- ^ Represents @https:\/\/host:port@
  | ConnectionAddressHttpUnix !ByteString -- ^ Represents @http+unix:\/\/%2Fsome%2Fpath%2Fsocket@ or @unix:\/some\/path\/socket@ ('ByteString' denotes raw filepath and must be at most 104 bytes long)
  deriving Int -> ConnectionAddress -> [Char] -> [Char]
[ConnectionAddress] -> [Char] -> [Char]
ConnectionAddress -> [Char]
(Int -> ConnectionAddress -> [Char] -> [Char])
-> (ConnectionAddress -> [Char])
-> ([ConnectionAddress] -> [Char] -> [Char])
-> Show ConnectionAddress
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
showList :: [ConnectionAddress] -> [Char] -> [Char]
$cshowList :: [ConnectionAddress] -> [Char] -> [Char]
show :: ConnectionAddress -> [Char]
$cshow :: ConnectionAddress -> [Char]
showsPrec :: Int -> ConnectionAddress -> [Char] -> [Char]
$cshowsPrec :: Int -> ConnectionAddress -> [Char] -> [Char]
Show

-- | Open a 'Connection' to the specified 'ConnectionAddress'
--
-- This is a simple wrapper over 'openConnection', 'openConnectionSSL', and 'openConnectionUnix'.
--
-- A subtle difference between @'openConnectionUnix' fp@ and @'openConnectionAddress' ('ConnectionAddressHttpUnix' fp)@ is that the latter sends an empty (but valid) @Host:@ HTTP header by default (unless overriden by 'setHostname'); moreover 'openConnectionUnix' only works with 'FilePath's containing only code-points within the ISO-8859-1 range.
--
-- This operation is often used in combination with 'withConnection'.
--
-- This uses the implicit global 'SSLContext' which can be accessed via 'modifyContextSSL'; see 'openConnectionAddress'' if you need more control in order to supply a local 'SSLContext'.
--
-- @since 0.1.1.0
openConnectionAddress :: ConnectionAddress -> IO Connection
openConnectionAddress :: ConnectionAddress -> IO Connection
openConnectionAddress = ((ByteString, Port) -> IO SSLContext)
-> ConnectionAddress -> IO Connection
openConnectionAddress' (IO SSLContext -> (ByteString, Port) -> IO SSLContext
forall a b. a -> b -> a
const (IO SSLContext -> (ByteString, Port) -> IO SSLContext)
-> IO SSLContext -> (ByteString, Port) -> IO SSLContext
forall a b. (a -> b) -> a -> b
$ IORef SSLContext -> IO SSLContext
forall a. IORef a -> IO a
readIORef IORef SSLContext
global)

-- | Variant of 'openConnectionAddress' allowing to supply local 'SSLContext'
--
-- The @IO SSLContext@ action is only evaluated in case of a 'ConnectionAddressHttps' target.
--
-- See also 'baselineContextSSL' which may be convenient to use as a starting point; you may want to implement your own variant of 'baselineContextSSL'.
--
-- @since 0.1.5.0
openConnectionAddress' :: ((Hostname,Word16) -> IO SSLContext) -> ConnectionAddress -> IO Connection
openConnectionAddress' :: ((ByteString, Port) -> IO SSLContext)
-> ConnectionAddress -> IO Connection
openConnectionAddress' (ByteString, Port) -> IO SSLContext
getCtx ConnectionAddress
ca = case ConnectionAddress
ca of
  ConnectionAddressHttp  ByteString
host Port
port  -> ByteString -> Port -> IO Connection
openConnection ByteString
host Port
port
  ConnectionAddressHttps ByteString
host Port
ports -> do
    SSLContext
ctx <- (ByteString, Port) -> IO SSLContext
getCtx (ByteString
host,Port
ports)
    SSLContext -> ByteString -> Port -> IO Connection
openConnectionSSL SSLContext
ctx ByteString
host Port
ports
  ConnectionAddressHttpUnix ByteString
fp -> do
    Connection
c <- [Char] -> IO Connection
openConnectionUnix (ByteString -> [Char]
S.unpack ByteString
fp)
    Connection -> IO Connection
forall (m :: * -> *) a. Monad m => a -> m a
return Connection
c { cHost :: ByteString
cHost = ByteString
forall a. Monoid a => a
mempty } -- NB: HTTP RFC allows empty Host: headers

-- | Yet another variant of 'openConnectionAddress' allowing to supply local 'SSLContext' as well as an 'SSL.SSL' connection modifier (see 'openConnectionSSL'' for details).
--
-- The @IO (SSLContext@ action is only evaluated in case of a 'ConnectionAddressHttps' target.
--
-- See also 'baselineContextSSL' which may be convenient to use as a starting point; you may want to implement your own variant of 'baselineContextSSL'.
--
-- @since 0.1.6.0
openConnectionAddress'' :: ((Hostname,Word16) -> IO (SSLContext, SSL.SSL -> IO ())) -> ConnectionAddress -> IO Connection
openConnectionAddress'' :: ((ByteString, Port) -> IO (SSLContext, SSL -> IO ()))
-> ConnectionAddress -> IO Connection
openConnectionAddress'' (ByteString, Port) -> IO (SSLContext, SSL -> IO ())
getCtx ConnectionAddress
ca = case ConnectionAddress
ca of
  ConnectionAddressHttp  ByteString
host Port
port  -> ByteString -> Port -> IO Connection
openConnection ByteString
host Port
port
  ConnectionAddressHttps ByteString
host Port
ports -> do
    (SSLContext
ctx,SSL -> IO ()
modssl) <- (ByteString, Port) -> IO (SSLContext, SSL -> IO ())
getCtx (ByteString
host,Port
ports)
    (SSL -> IO ()) -> SSLContext -> ByteString -> Port -> IO Connection
openConnectionSSL' SSL -> IO ()
modssl SSLContext
ctx ByteString
host Port
ports
  ConnectionAddressHttpUnix ByteString
fp -> do
    Connection
c <- [Char] -> IO Connection
openConnectionUnix (ByteString -> [Char]
S.unpack ByteString
fp)
    Connection -> IO Connection
forall (m :: * -> *) a. Monad m => a -> m a
return Connection
c { cHost :: ByteString
cHost = ByteString
forall a. Monoid a => a
mempty } -- NB: HTTP RFC allows empty Host: headers

-- | Decode 'URL' into 'ConnectionAddress', user-info-part, (escaped) URL path, and optional fragment.
--
-- The 'URL' argument is expected to be properly escaped according to RFC 3986.
--
-- This is a wrapper over 'connectionAddressFromURI'
--
-- @since 0.1.1.0
connectionAddressFromURL :: URL -> Either String (ConnectionAddress, String, ByteString, String)
connectionAddressFromURL :: ByteString
-> Either [Char] (ConnectionAddress, [Char], ByteString, [Char])
connectionAddressFromURL ByteString
r' = do
  Text
r <- (UnicodeException -> Either [Char] Text)
-> (Text -> Either [Char] Text)
-> Either UnicodeException Text
-> Either [Char] Text
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (\UnicodeException
_ -> [Char] -> Either [Char] Text
forall a b. a -> Either a b
Left [Char]
"invalid UTF-8 encoding") Text -> Either [Char] Text
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> Either UnicodeException Text
T.decodeUtf8' ByteString
r')
  URI
u <- Either [Char] URI
-> (URI -> Either [Char] URI) -> Maybe URI -> Either [Char] URI
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([Char] -> Either [Char] URI
forall a b. a -> Either a b
Left [Char]
"invalid URI syntax") URI -> Either [Char] URI
forall (m :: * -> *) a. Monad m => a -> m a
return ([Char] -> Maybe URI
parseURI (Text -> [Char]
T.unpack Text
r))
  URI
-> Either [Char] (ConnectionAddress, [Char], ByteString, [Char])
connectionAddressFromURI URI
u

-- | Decode 'URI' (from the @network-uri@ package) into 'ConnectionAddress', user-info part, (escaped) URL path, and optional fragment.
--
-- See also 'connectionAddressFromURL'
--
-- @since 0.1.1.0
connectionAddressFromURI :: URI -> Either String (ConnectionAddress, String, ByteString, String)
connectionAddressFromURI :: URI
-> Either [Char] (ConnectionAddress, [Char], ByteString, [Char])
connectionAddressFromURI URI
u = ((ConnectionAddress, ByteString)
 -> (ConnectionAddress, [Char], ByteString, [Char]))
-> Either [Char] (ConnectionAddress, ByteString)
-> Either [Char] (ConnectionAddress, [Char], ByteString, [Char])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ConnectionAddress, ByteString)
-> (ConnectionAddress, [Char], ByteString, [Char])
forall a c. (a, c) -> (a, [Char], c, [Char])
addxinfo (Either [Char] (ConnectionAddress, ByteString)
 -> Either [Char] (ConnectionAddress, [Char], ByteString, [Char]))
-> Either [Char] (ConnectionAddress, ByteString)
-> Either [Char] (ConnectionAddress, [Char], ByteString, [Char])
forall a b. (a -> b) -> a -> b
$
    case (Char -> Char) -> [Char] -> [Char]
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower (URI -> [Char]
uriScheme URI
u) of
        [Char]
"http:"      -> do
          [Char]
_ <- Either [Char] [Char]
getUrlPath
          (ConnectionAddress, ByteString)
-> Either [Char] (ConnectionAddress, ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> Port -> ConnectionAddress
ConnectionAddressHttp ByteString
host (Port -> Port
port Port
80), ByteString
urlpath)
        [Char]
"https:"     -> do
          [Char]
_ <- Either [Char] [Char]
getUrlPath
          (ConnectionAddress, ByteString)
-> Either [Char] (ConnectionAddress, ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> Port -> ConnectionAddress
ConnectionAddressHttps ByteString
host (Port -> Port
port Port
443), ByteString
urlpath)
        [Char]
"unix:" -> do
          Either [Char] ()
noPort
          Either [Char] ()
noHost
          Bool -> Either [Char] () -> Either [Char] ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([Char] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (URI -> [Char]
uriPath URI
u)) (Either [Char] () -> Either [Char] ())
-> Either [Char] () -> Either [Char] ()
forall a b. (a -> b) -> a -> b
$
            [Char] -> Either [Char] ()
forall a b. a -> Either a b
Left [Char]
"invalid empty path in unix: URI"
          Bool -> Either [Char] () -> Either [Char] ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Char] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (URI -> [Char]
uriQuery URI
u)) (Either [Char] () -> Either [Char] ())
-> Either [Char] () -> Either [Char] ()
forall a b. (a -> b) -> a -> b
$
            [Char] -> Either [Char] ()
forall a b. a -> Either a b
Left [Char]
"invalid query component in unix: URI"
          Bool -> Either [Char] () -> Either [Char] ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Char] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (URI -> [Char]
uriFragment URI
u)) (Either [Char] () -> Either [Char] ())
-> Either [Char] () -> Either [Char] ()
forall a b. (a -> b) -> a -> b
$
            [Char] -> Either [Char] ()
forall a b. a -> Either a b
Left [Char]
"invalid fragment component in unix: URI"
          let rfp :: ByteString
rfp = [Char] -> ByteString
unescBytes (URI -> [Char]
uriPath URI
u)
          Bool -> Either [Char] () -> Either [Char] ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteString -> Int
S.length ByteString
rfp Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
104) (Either [Char] () -> Either [Char] ())
-> Either [Char] () -> Either [Char] ()
forall a b. (a -> b) -> a -> b
$
            [Char] -> Either [Char] ()
forall a b. a -> Either a b
Left [Char]
"unix domain socket path must be at most 104 bytes long"
          Bool -> Either [Char] () -> Either [Char] ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Char -> ByteString -> Bool
S.elem Char
'\x00' ByteString
rfp) (Either [Char] () -> Either [Char] ())
-> Either [Char] () -> Either [Char] ()
forall a b. (a -> b) -> a -> b
$
            [Char] -> Either [Char] ()
forall a b. a -> Either a b
Left [Char]
"unix domain socket path must not contain NUL bytes"
          (ConnectionAddress, ByteString)
-> Either [Char] (ConnectionAddress, ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> ConnectionAddress
ConnectionAddressHttpUnix ByteString
rfp, ByteString
"")
        [Char]
"http+unix:" -> do
          Either [Char] ()
noPort
          ByteString
fp <- Either [Char] ByteString
getUnixPath
          (ConnectionAddress, ByteString)
-> Either [Char] (ConnectionAddress, ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> ConnectionAddress
ConnectionAddressHttpUnix ByteString
fp, ByteString
urlpath)
        [Char]
_ -> [Char] -> Either [Char] (ConnectionAddress, ByteString)
forall a b. a -> Either a b
Left ([Char]
"Unknown URI scheme " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ URI -> [Char]
uriScheme URI
u)
  where
    addxinfo :: (a, c) -> (a, [Char], c, [Char])
addxinfo (a
ca,c
p) = (a
ca, URIAuth -> [Char]
uriUserInfo URIAuth
auth, c
p, URI -> [Char]
uriFragment 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]
"" [Char]
""

    noPort :: Either [Char] ()
noPort = if [Char] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (URIAuth -> [Char]
uriPort URIAuth
auth) then () -> Either [Char] ()
forall a b. b -> Either a b
Right () else [Char] -> Either [Char] ()
forall a b. a -> Either a b
Left [Char]
"invalid port number in URI"
    noHost :: Either [Char] ()
noHost = case URI -> Maybe URIAuth
uriAuthority URI
u of
               Maybe URIAuth
Nothing -> () -> Either [Char] ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
               Just (URIAuth [Char]
"" [Char]
"" [Char]
"") -> () -> Either [Char] ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
               Just URIAuth
_ -> [Char] -> Either [Char] ()
forall a b. a -> Either a b
Left [Char]
"invalid host component in uri"

    getUrlPath :: Either [Char] [Char]
getUrlPath = case URIAuth -> [Char]
uriRegName URIAuth
auth of
                   [Char]
"" -> [Char] -> Either [Char] [Char]
forall a b. a -> Either a b
Left [Char]
"missing/empty host component in uri"
                   [Char]
p  -> [Char] -> Either [Char] [Char]
forall a b. b -> Either a b
Right [Char]
p

    getUnixPath :: Either [Char] ByteString
getUnixPath = case URIAuth -> [Char]
uriRegName URIAuth
auth of
                   [Char]
"" -> [Char] -> Either [Char] ByteString
forall a b. a -> Either a b
Left [Char]
"missing/empty host component in uri"
                   [Char]
fp -> do
                     let rfp :: ByteString
rfp = [Char] -> ByteString
unescBytes [Char]
fp
                     Bool -> Either [Char] () -> Either [Char] ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteString -> Int
S.length ByteString
rfp Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
104) (Either [Char] () -> Either [Char] ())
-> Either [Char] () -> Either [Char] ()
forall a b. (a -> b) -> a -> b
$
                       [Char] -> Either [Char] ()
forall a b. a -> Either a b
Left [Char]
"unix domain socket path must be at most 104 bytes long"
                     Bool -> Either [Char] () -> Either [Char] ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Char -> ByteString -> Bool
S.elem Char
'\x00' ByteString
rfp) (Either [Char] () -> Either [Char] ())
-> Either [Char] () -> Either [Char] ()
forall a b. (a -> b) -> a -> b
$
                       [Char] -> Either [Char] ()
forall a b. a -> Either a b
Left [Char]
"unix domain socket path must not contain NUL bytes"
                     ByteString -> Either [Char] ByteString
forall a b. b -> Either a b
Right ByteString
rfp

    urlpath :: ByteString
urlpath = [Char] -> ByteString
S.pack (URI -> [Char]
uriPath URI
u [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ URI -> [Char]
uriQuery URI
u)

    host :: ByteString
host = [Char] -> ByteString
S.pack (URIAuth -> [Char]
uriRegName URIAuth
auth)

    port :: Port -> Port
port Port
def = case URIAuth -> [Char]
uriPort URIAuth
auth of
      [Char]
""  -> Port
def
      [Char]
_   -> [Char] -> Port
forall a. Read a => [Char] -> a
read ([Char] -> Port) -> [Char] -> Port
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char]
forall a. [a] -> [a]
tail ([Char] -> [Char]) -> [Char] -> [Char]
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'.
--
-- See also 'contextSetCASystemStore'
{-
    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 = IO SSLContext -> IO SSLContext
forall a. IO a -> IO a
withOpenSSL (IO SSLContext -> IO SSLContext) -> IO SSLContext -> IO SSLContext
forall a b. (a -> b) -> a -> b
$ do
    SSLContext
ctx <- IO SSLContext
SSL.context
    SSLContext -> IO ()
SSL.contextSetDefaultCiphers SSLContext
ctx

    Bool
caSet <- SSLContext -> IO Bool
contextSetCASystemStore SSLContext
ctx
    if Bool
caSet
      then SSLContext -> VerificationMode -> IO ()
SSL.contextSetVerificationMode SSLContext
ctx (Bool
-> Bool
-> Maybe (Bool -> X509StoreCtx -> IO Bool)
-> VerificationMode
SSL.VerifyPeer Bool
True Bool
True Maybe (Bool -> X509StoreCtx -> IO Bool)
forall a. Maybe a
Nothing)
      else SSLContext -> VerificationMode -> IO ()
SSL.contextSetVerificationMode SSLContext
ctx VerificationMode
SSL.VerifyNone

    SSLContext -> IO SSLContext
forall (m :: * -> *) a. Monad m => a -> m a
return SSLContext
ctx

-- | Construct a /void/ 'SSL.Context' in a configuration which uses
-- the @HIGH@ cipher-suite and rejects /any/ presented server
-- certificate.
--
-- This is mostly useful for testing purposes or intentionally
-- thwarting any attempt to connect to @https://@ uris.
--
-- @since 0.1.6.0
voidContextSSL :: IO SSLContext
voidContextSSL :: IO SSLContext
voidContextSSL = do
    SSLContext
ctx <- IO SSLContext
SSL.context
    SSLContext -> [Char] -> IO ()
SSL.contextSetCiphers SSLContext
ctx [Char]
"HIGH"
    SSLContext -> VerificationMode -> IO ()
SSL.contextSetVerificationMode SSLContext
ctx (Bool
-> Bool
-> Maybe (Bool -> X509StoreCtx -> IO Bool)
-> VerificationMode
SSL.VerifyPeer Bool
True Bool
True ((Bool -> X509StoreCtx -> IO Bool)
-> Maybe (Bool -> X509StoreCtx -> IO Bool)
forall a. a -> Maybe a
Just (\Bool
_ X509StoreCtx
_ -> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False)))
    SSLContext -> IO SSLContext
forall (m :: * -> *) a. Monad m => a -> m a
return SSLContext
ctx
    
-- | Configure system-wide certificate store based on OS-specific heuristics.
--
-- This function returns 'True' if the 'SSLContext' was configured; or
-- 'False' if the location couldn't be termined for the current OS.
--
-- This function is used by 'baselineContextSSL' but in contrast does
-- *not* invoke 'SSL.contextSetDefaultCiphers' nor
-- 'SSL.contextSetVerificationMode'. See source-code for details on
-- the heuristic used to determine the location of the system
-- certificate store.
--
-- @since 0.1.6.0
contextSetCASystemStore :: SSLContext -> IO Bool
contextSetCASystemStore :: SSLContext -> IO Bool
contextSetCASystemStore SSLContext
ctx = do
#if defined(darwin_HOST_OS)
    return False
#elif defined(mingw32_HOST_OS)
    return False
#elif defined(freebsd_HOST_OS)
    SSL.contextSetCAFile ctx "/usr/local/etc/ssl/cert.pem"
    return True
#elif defined(openbsd_HOST_OS)
    SSL.contextSetCAFile ctx "/etc/ssl/cert.pem"
    return True
#else
    Bool
hasFedoraEtcPkiTls <- [Char] -> IO Bool
doesDirectoryExist [Char]
"/etc/pki/tls"
    if Bool
hasFedoraEtcPkiTls
      then do
        SSLContext -> [Char] -> IO ()
SSL.contextSetCAFile SSLContext
ctx [Char]
"/etc/pki/tls/certs/ca-bundle.crt"
        Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
      else do
        -- Setting this as fallback effectively will cause systems to
        -- either fail to verify any certificates (if peer
        -- verification is enabled) if the folder doesn't exist.
        SSLContext -> [Char] -> IO ()
SSL.contextSetCADirectory SSLContext
ctx [Char]
"/etc/ssl/certs"
        Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
#endif


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 -> [Char] -> URI
forall a. HasCallStack => [Char] -> a
error ([Char]
"Can't parse URI " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
r)
  where
    r :: [Char]
r = Text -> [Char]
T.unpack (Text -> [Char]) -> Text -> [Char]
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.
-}

path :: URI -> ByteString
path :: URI -> ByteString
path URI
u = case ByteString
url of
            ByteString
""  -> ByteString
"/"
            ByteString
_   -> ByteString
url
  where
    url :: ByteString
url = Text -> ByteString
T.encodeUtf8 (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$! [Char] -> Text
T.pack
                      ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$! [[Char]] -> [Char]
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 :: URL
    -- ^ Resource to GET from.
    -> (Response -> InputStream ByteString -> IO β)
    -- ^ Handler function to receive the response from the server.
    -> IO β
get :: ByteString -> (Response -> InputStream ByteString -> IO β) -> IO β
get ByteString
r' Response -> InputStream ByteString -> IO β
handler = Int
-> ByteString
-> (Response -> InputStream ByteString -> IO β)
-> IO β
forall c.
Int
-> ByteString
-> (Response -> InputStream ByteString -> IO c)
-> IO c
getN Int
0 ByteString
r' Response -> InputStream ByteString -> IO β
handler

getN :: Int
-> ByteString
-> (Response -> InputStream ByteString -> IO c)
-> IO c
getN Int
n ByteString
r' Response -> InputStream ByteString -> IO c
handler = do
    IO Connection
-> (Connection -> IO ()) -> (Connection -> IO c) -> IO c
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 = RequestBuilder () -> Request
forall α. RequestBuilder α -> Request
buildRequest1 (RequestBuilder () -> Request) -> RequestBuilder () -> Request
forall a b. (a -> b) -> a -> b
$ do
            Method -> ByteString -> RequestBuilder ()
http Method
GET (URI -> ByteString
path URI
u)
            ByteString -> RequestBuilder ()
setAccept ByteString
"*/*"

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

        Connection -> (Response -> InputStream ByteString -> IO c) -> IO c
forall β.
Connection -> (Response -> InputStream ByteString -> IO β) -> IO β
receiveResponse Connection
c (URI
-> Int
-> (Response -> InputStream ByteString -> IO c)
-> Response
-> InputStream ByteString
-> IO c
forall β.
URI
-> Int
-> (Response -> InputStream ByteString -> IO β)
-> Response
-> InputStream ByteString
-> IO β
wrapRedirect URI
u Int
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 :: URI
-> Int
-> (Response -> InputStream ByteString -> IO β)
-> Response
-> InputStream ByteString
-> IO β
wrapRedirect URI
u Int
n Response -> InputStream ByteString -> IO β
handler Response
p InputStream ByteString
i = do
    if (Int
s Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
301 Bool -> Bool -> Bool
|| Int
s Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
302 Bool -> Bool -> Bool
|| Int
s Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
303 Bool -> Bool -> Bool
|| Int
s Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
307)
        then case Maybe ByteString
lm of
                Just ByteString
l  -> Int
-> ByteString
-> (Response -> InputStream ByteString -> IO β)
-> IO β
forall c.
Int
-> ByteString
-> (Response -> InputStream ByteString -> IO c)
-> IO c
getN Int
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 :: Int
s  = Response -> Int
getStatusCode Response
p
    lm :: Maybe ByteString
lm = Response -> ByteString -> Maybe ByteString
getHeader Response
p ByteString
"Location"
    !n' :: Int
n' = if Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
5
            then Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
            else TooManyRedirects -> Int
forall a e. Exception e => e -> a
throw (TooManyRedirects -> Int) -> TooManyRedirects -> Int
forall a b. (a -> b) -> a -> b
$! Int -> TooManyRedirects
TooManyRedirects Int
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 ([Char] -> ByteString) -> [Char] -> ByteString
forall a b. (a -> b) -> a -> b
$ ([Char] -> [Char]) -> URI -> [Char] -> [Char]
uriToString [Char] -> [Char]
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, Int -> TooManyRedirects -> [Char] -> [Char]
[TooManyRedirects] -> [Char] -> [Char]
TooManyRedirects -> [Char]
(Int -> TooManyRedirects -> [Char] -> [Char])
-> (TooManyRedirects -> [Char])
-> ([TooManyRedirects] -> [Char] -> [Char])
-> Show TooManyRedirects
forall a.
(Int -> 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 :: Int -> TooManyRedirects -> [Char] -> [Char]
$cshowsPrec :: Int -> TooManyRedirects -> [Char] -> [Char]
Show, TooManyRedirects -> TooManyRedirects -> Bool
(TooManyRedirects -> TooManyRedirects -> Bool)
-> (TooManyRedirects -> TooManyRedirects -> Bool)
-> Eq TooManyRedirects
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 :: URL
    -- ^ Resource to POST to.
    -> ContentType
    -- ^ MIME type of the request body being sent.
    -> (OutputStream Builder -> IO α)
    -- ^ Handler function to write content to server.
    -> (Response -> InputStream ByteString -> IO β)
    -- ^ Handler function to receive the response from the server.
    -> IO β
post :: 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
    IO Connection
-> (Connection -> IO ()) -> (Connection -> IO β) -> IO β
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 = RequestBuilder () -> Request
forall α. RequestBuilder α -> Request
buildRequest1 (RequestBuilder () -> Request) -> RequestBuilder () -> Request
forall a b. (a -> b) -> a -> b
$ do
            Method -> ByteString -> RequestBuilder ()
http Method
POST (URI -> ByteString
path URI
u)
            ByteString -> RequestBuilder ()
setAccept ByteString
"*/*"
            ByteString -> RequestBuilder ()
setContentType ByteString
t

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

        β
x <- Connection -> (Response -> InputStream ByteString -> IO β) -> IO β
forall β.
Connection -> (Response -> InputStream ByteString -> IO β) -> IO β
receiveResponse Connection
c Response -> InputStream ByteString -> IO β
handler
        β -> IO β
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
    :: URL
    -- ^ Resource to POST to.
    -> [(ByteString, ByteString)]
    -- ^ List of name=value pairs. Will be sent URL-encoded.
    -> (Response -> InputStream ByteString -> IO β)
    -- ^ Handler function to receive the response from the server.
    -> IO β
postForm :: ByteString
-> [(ByteString, ByteString)]
-> (Response -> InputStream ByteString -> IO β)
-> IO β
postForm ByteString
r' [(ByteString, ByteString)]
nvs Response -> InputStream ByteString -> IO β
handler = do
    IO Connection
-> (Connection -> IO ()) -> (Connection -> IO β) -> IO β
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 = RequestBuilder () -> Request
forall α. RequestBuilder α -> Request
buildRequest1 (RequestBuilder () -> Request) -> RequestBuilder () -> Request
forall a b. (a -> b) -> a -> b
$ do
            Method -> ByteString -> RequestBuilder ()
http Method
POST (URI -> ByteString
path URI
u)
            ByteString -> RequestBuilder ()
setAccept ByteString
"*/*"
            ByteString -> RequestBuilder ()
setContentType ByteString
"application/x-www-form-urlencoded"

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

        β
x <- Connection -> (Response -> InputStream ByteString -> IO β) -> IO β
forall β.
Connection -> (Response -> InputStream ByteString -> IO β) -> IO β
receiveResponse Connection
c Response -> InputStream ByteString -> IO β
handler
        β -> IO β
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
    Maybe Builder -> OutputStream Builder -> IO ()
forall a. Maybe a -> OutputStream a -> IO ()
Streams.write (Builder -> Maybe Builder
forall a. a -> Maybe a
Just Builder
b) OutputStream Builder
o
  where
    b :: Builder
b = [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat ([Builder] -> Builder) -> [Builder] -> Builder
forall a b. (a -> b) -> a -> b
$ Builder -> [Builder] -> [Builder]
forall a. a -> [a] -> [a]
intersperse ([Char] -> Builder
Builder.fromString [Char]
"&") ([Builder] -> [Builder]) -> [Builder] -> [Builder]
forall a b. (a -> b) -> a -> b
$ ((ByteString, ByteString) -> Builder)
-> [(ByteString, ByteString)] -> [Builder]
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') = [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat [ByteString -> Builder
urlEncodeBuilder ByteString
n', [Char] -> Builder
Builder.fromString [Char]
"=", ByteString -> Builder
urlEncodeBuilder ByteString
v']


--
-- | 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 :: URL
    -- ^ Resource to PUT to.
    -> ContentType
    -- ^ MIME type of the request body being sent.
    -> (OutputStream Builder -> IO α)
    -- ^ Handler function to write content to server.
    -> (Response -> InputStream ByteString -> IO β)
    -- ^ Handler function to receive the response from the server.
    -> IO β
put :: 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
    IO Connection
-> (Connection -> IO ()) -> (Connection -> IO β) -> IO β
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 = RequestBuilder () -> Request
forall α. RequestBuilder α -> Request
buildRequest1 (RequestBuilder () -> Request) -> RequestBuilder () -> Request
forall a b. (a -> b) -> a -> b
$ do
            Method -> ByteString -> RequestBuilder ()
http Method
PUT (URI -> ByteString
path URI
u)
            ByteString -> RequestBuilder ()
setAccept ByteString
"*/*"
            ByteString -> ByteString -> RequestBuilder ()
setHeader ByteString
"Content-Type" ByteString
t

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

        β
x <- Connection -> (Response -> InputStream ByteString -> IO β) -> IO β
forall β.
Connection -> (Response -> InputStream ByteString -> IO β) -> IO β
receiveResponse Connection
c Response -> InputStream ByteString -> IO β
handler
        β -> IO β
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@.
--
concatHandler' :: Response -> InputStream ByteString -> IO ByteString
concatHandler' :: Response -> InputStream ByteString -> IO ByteString
concatHandler' Response
p InputStream ByteString
i =
    if Int
s Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
300
        then HttpClientError -> IO ByteString
forall a e. Exception e => e -> a
throw (Int -> ByteString -> HttpClientError
HttpClientError Int
s ByteString
m)
        else Response -> InputStream ByteString -> IO ByteString
concatHandler Response
p InputStream ByteString
i
  where
    s :: Int
s = Response -> Int
getStatusCode Response
p
    m :: ByteString
m = Response -> ByteString
getStatusMessage Response
p

data HttpClientError = HttpClientError Int ByteString
        deriving (Typeable)

instance Exception HttpClientError

instance Show HttpClientError where
    show :: HttpClientError -> [Char]
show (HttpClientError Int
s ByteString
msg) = Int -> [Char]
forall a. Show a => a -> [Char]
Prelude.show Int
s [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" " [Char] -> [Char] -> [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.
-}