{-# 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 (..),
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
#if defined(linux_HOST_OS) || defined(freebsd_HOST_OS)
import System.Directory (doesDirectoryExist)
#endif
type URL = ByteString
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. (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)
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'
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
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'
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]
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
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)
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
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
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
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
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']
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
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 ()
}
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
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
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
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
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
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
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
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
let r :: Result α
r = forall a. FromJSON a => Value -> Result a
fromJSON Value
v
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