{-# 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,
concatHandler',
TooManyRedirects(..),
HttpClientError(..),
ConnectionAddress(..),
connectionAddressFromURI,
connectionAddressFromURL,
openConnectionAddress,
openConnectionAddress',
openConnectionAddress'',
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#)
#if MIN_VERSION_base(4,16,0)
import GHC.Exts (word8ToWord#)
#endif
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
#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 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 = forall a. Enum a => StatusCode -> a
toEnum StatusCode
b forall a. a -> [a] -> [a]
: [Char] -> [Char]
go [Char]
rest
where
b :: StatusCode
b = (StatusCode
16 forall a. Num a => a -> a -> a
* Char -> StatusCode
digitToInt Char
h) forall a. Num a => a -> a -> a
+ Char -> StatusCode
digitToInt Char
l
go (Char
c:[Char]
rest) = Char
c forall a. a -> [a] -> [a]
: [Char] -> [Char]
go [Char]
rest
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 #-}
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. Ord a => a -> Set a -> Bool
Set.member Set 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
#if MIN_VERSION_base(4,16,0)
shiftr :: Word8 -> StatusCode -> StatusCode
shiftr (W8# Word8#
a#) (I# Int#
b#) = Int# -> StatusCode
I# (Word# -> Int#
word2Int# (Word# -> Int# -> Word#
uncheckedShiftRL# (Word8# -> Word#
word8ToWord# Word8#
a#) Int#
b#))
#else
shiftr (W8# a#) (I# b#) = I# (word2Int# (uncheckedShiftRL# a# b#))
#endif
urlEncodeTable :: Set Char
urlEncodeTable :: Set Char
urlEncodeTable = forall a. Ord a => [a] -> Set a
Set.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)
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 #-}
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'
getContextSSL :: IO SSLContext
getContextSSL :: IO SSLContext
getContextSSL = forall a. IORef a -> IO a
readIORef IORef SSLContext
global
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 -> Word16 -> IO Connection
openConnection ByteString
host Word16
port
[Char]
"https:" -> do
SSLContext
ctx <- forall a. IORef a -> IO a
readIORef IORef SSLContext
global
SSLContext -> ByteString -> Word16 -> IO Connection
openConnectionSSL SSLContext
ctx ByteString
host Word16
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 :: Word16
port = case URIAuth -> [Char]
uriPort URIAuth
auth of
[Char]
"" -> Word16
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 :: Word16
ports = case URIAuth -> [Char]
uriPort URIAuth
auth of
[Char]
"" -> Word16
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
data ConnectionAddress
= ConnectionAddressHttp !Hostname !Word16
| ConnectionAddressHttps !Hostname !Word16
| ConnectionAddressHttpUnix !ByteString
deriving StatusCode -> ConnectionAddress -> [Char] -> [Char]
[ConnectionAddress] -> [Char] -> [Char]
ConnectionAddress -> [Char]
forall a.
(StatusCode -> 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 :: StatusCode -> ConnectionAddress -> [Char] -> [Char]
$cshowsPrec :: StatusCode -> ConnectionAddress -> [Char] -> [Char]
Show
openConnectionAddress :: ConnectionAddress -> IO Connection
openConnectionAddress :: ConnectionAddress -> IO Connection
openConnectionAddress = ((ByteString, Word16) -> IO SSLContext)
-> ConnectionAddress -> IO Connection
openConnectionAddress' (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall a. IORef a -> IO a
readIORef IORef SSLContext
global)
openConnectionAddress' :: ((Hostname,Word16) -> IO SSLContext) -> ConnectionAddress -> IO Connection
openConnectionAddress' :: ((ByteString, Word16) -> IO SSLContext)
-> ConnectionAddress -> IO Connection
openConnectionAddress' (ByteString, Word16) -> IO SSLContext
getCtx ConnectionAddress
ca = case ConnectionAddress
ca of
ConnectionAddressHttp ByteString
host Word16
port -> ByteString -> Word16 -> IO Connection
openConnection ByteString
host Word16
port
ConnectionAddressHttps ByteString
host Word16
ports -> do
SSLContext
ctx <- (ByteString, Word16) -> IO SSLContext
getCtx (ByteString
host,Word16
ports)
SSLContext -> ByteString -> Word16 -> IO Connection
openConnectionSSL SSLContext
ctx ByteString
host Word16
ports
ConnectionAddressHttpUnix ByteString
fp -> do
Connection
c <- [Char] -> IO Connection
openConnectionUnix (ByteString -> [Char]
S.unpack ByteString
fp)
forall (m :: * -> *) a. Monad m => a -> m a
return Connection
c { cHost :: ByteString
cHost = forall a. Monoid a => a
mempty }
openConnectionAddress'' :: ((Hostname,Word16) -> IO (SSLContext, SSL.SSL -> IO ())) -> ConnectionAddress -> IO Connection
openConnectionAddress'' :: ((ByteString, Word16) -> IO (SSLContext, SSL -> IO ()))
-> ConnectionAddress -> IO Connection
openConnectionAddress'' (ByteString, Word16) -> IO (SSLContext, SSL -> IO ())
getCtx ConnectionAddress
ca = case ConnectionAddress
ca of
ConnectionAddressHttp ByteString
host Word16
port -> ByteString -> Word16 -> IO Connection
openConnection ByteString
host Word16
port
ConnectionAddressHttps ByteString
host Word16
ports -> do
(SSLContext
ctx,SSL -> IO ()
modssl) <- (ByteString, Word16) -> IO (SSLContext, SSL -> IO ())
getCtx (ByteString
host,Word16
ports)
(SSL -> IO ())
-> SSLContext -> ByteString -> Word16 -> IO Connection
openConnectionSSL' SSL -> IO ()
modssl SSLContext
ctx ByteString
host Word16
ports
ConnectionAddressHttpUnix ByteString
fp -> do
Connection
c <- [Char] -> IO Connection
openConnectionUnix (ByteString -> [Char]
S.unpack ByteString
fp)
forall (m :: * -> *) a. Monad m => a -> m a
return Connection
c { cHost :: ByteString
cHost = forall a. Monoid a => a
mempty }
connectionAddressFromURL :: URL -> Either String (ConnectionAddress, String, ByteString, String)
connectionAddressFromURL :: ByteString
-> Either [Char] (ConnectionAddress, [Char], ByteString, [Char])
connectionAddressFromURL ByteString
r' = do
Text
r <- forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (\UnicodeException
_ -> forall a b. a -> Either a b
Left [Char]
"invalid UTF-8 encoding") forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> Either UnicodeException Text
T.decodeUtf8' ByteString
r')
URI
u <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a b. a -> Either a b
Left [Char]
"invalid URI syntax") 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
connectionAddressFromURI :: URI -> Either String (ConnectionAddress, String, ByteString, String)
connectionAddressFromURI :: URI
-> Either [Char] (ConnectionAddress, [Char], ByteString, [Char])
connectionAddressFromURI URI
u = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall {a} {c}. (a, c) -> (a, [Char], c, [Char])
addxinfo forall a b. (a -> b) -> a -> b
$
case 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
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> Word16 -> ConnectionAddress
ConnectionAddressHttp ByteString
host (Word16 -> Word16
port Word16
80), ByteString
urlpath)
[Char]
"https:" -> do
[Char]
_ <- Either [Char] [Char]
getUrlPath
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> Word16 -> ConnectionAddress
ConnectionAddressHttps ByteString
host (Word16 -> Word16
port Word16
443), ByteString
urlpath)
[Char]
"unix:" -> do
Either [Char] ()
noPort
Either [Char] ()
noHost
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => t a -> Bool
null (URI -> [Char]
uriPath URI
u)) forall a b. (a -> b) -> a -> b
$
forall a b. a -> Either a b
Left [Char]
"invalid empty path in unix: URI"
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null (URI -> [Char]
uriQuery URI
u)) forall a b. (a -> b) -> a -> b
$
forall a b. a -> Either a b
Left [Char]
"invalid query component in unix: URI"
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null (URI -> [Char]
uriFragment URI
u)) forall a b. (a -> b) -> a -> b
$
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)
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteString -> StatusCode
S.length ByteString
rfp forall a. Ord a => a -> a -> Bool
> StatusCode
104) forall a b. (a -> b) -> a -> b
$
forall a b. a -> Either a b
Left [Char]
"unix domain socket path must be at most 104 bytes long"
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Char -> ByteString -> Bool
S.elem Char
'\x00' ByteString
rfp) forall a b. (a -> b) -> a -> b
$
forall a b. a -> Either a b
Left [Char]
"unix domain socket path must not contain NUL bytes"
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
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> ConnectionAddress
ConnectionAddressHttpUnix ByteString
fp, ByteString
urlpath)
[Char]
_ -> forall a b. a -> Either a b
Left ([Char]
"Unknown URI scheme " 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 forall (t :: * -> *) a. Foldable t => t a -> Bool
null (URIAuth -> [Char]
uriPort URIAuth
auth) then forall a b. b -> Either a b
Right () else 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 -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just (URIAuth [Char]
"" [Char]
"" [Char]
"") -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just URIAuth
_ -> 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]
"" -> forall a b. a -> Either a b
Left [Char]
"missing/empty host component in uri"
[Char]
p -> forall a b. b -> Either a b
Right [Char]
p
getUnixPath :: Either [Char] ByteString
getUnixPath = case URIAuth -> [Char]
uriRegName URIAuth
auth of
[Char]
"" -> 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
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteString -> StatusCode
S.length ByteString
rfp forall a. Ord a => a -> a -> Bool
> StatusCode
104) forall a b. (a -> b) -> a -> b
$
forall a b. a -> Either a b
Left [Char]
"unix domain socket path must be at most 104 bytes long"
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Char -> ByteString -> Bool
S.elem Char
'\x00' ByteString
rfp) forall a b. (a -> b) -> a -> b
$
forall a b. a -> Either a b
Left [Char]
"unix domain socket path must not contain NUL bytes"
forall a b. b -> Either a b
Right ByteString
rfp
urlpath :: ByteString
urlpath = [Char] -> ByteString
S.pack (URI -> [Char]
uriPath URI
u forall a. [a] -> [a] -> [a]
++ URI -> [Char]
uriQuery URI
u)
host :: ByteString
host = [Char] -> ByteString
S.pack (URIAuth -> [Char]
uriRegName URIAuth
auth)
port :: Word16 -> Word16
port Word16
def = case URIAuth -> [Char]
uriPort URIAuth
auth of
[Char]
"" -> Word16
def
[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
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 = Text -> [Char]
T.unpack forall a b. (a -> b) -> a -> b
$ ByteString -> Text
T.decodeUtf8 ByteString
r'
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 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]
get :: URL
-> (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
path 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)
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
post :: URL
-> ContentType
-> (OutputStream Builder -> IO α)
-> (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
path 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
postForm
:: URL
-> [(ByteString, ByteString)]
-> (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
path 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
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']
put :: URL
-> ContentType
-> (OutputStream Builder -> IO α)
-> (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
path 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
concatHandler' :: Response -> InputStream ByteString -> IO ByteString
concatHandler' :: Response -> InputStream ByteString -> IO ByteString
concatHandler' 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
concatHandler Response
p InputStream ByteString
i
where
s :: StatusCode
s = Response -> StatusCode
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 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