{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE OverloadedStrings #-}
module Hackage.Security.Client.Repository.HttpLib.HttpClient (
httpLib
) where
import Control.Exception
import Control.Monad (void)
import Data.ByteString (ByteString)
import Network.URI
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BS.C8
import qualified Pantry.HTTP as HTTP
import Hackage.Security.Client hiding (Header)
import Hackage.Security.Client.Repository.HttpLib
import Hackage.Security.Util.Checked
httpLib :: HttpLib
httpLib :: HttpLib
httpLib = HttpLib
{ httpGet :: forall a.
Throws SomeRemoteError =>
[HttpRequestHeader]
-> URI -> ([HttpResponseHeader] -> BodyReader -> IO a) -> IO a
httpGet = forall a.
Throws SomeRemoteError =>
[HttpRequestHeader]
-> URI -> ([HttpResponseHeader] -> BodyReader -> IO a) -> IO a
get
, httpGetRange :: forall a.
Throws SomeRemoteError =>
[HttpRequestHeader]
-> URI
-> (Int, Int)
-> (HttpStatus -> [HttpResponseHeader] -> BodyReader -> IO a)
-> IO a
httpGetRange = forall a.
Throws SomeRemoteError =>
[HttpRequestHeader]
-> URI
-> (Int, Int)
-> (HttpStatus -> [HttpResponseHeader] -> BodyReader -> IO a)
-> IO a
getRange
}
get :: Throws SomeRemoteError
=> [HttpRequestHeader] -> URI
-> ([HttpResponseHeader] -> BodyReader -> IO a)
-> IO a
get :: forall a.
Throws SomeRemoteError =>
[HttpRequestHeader]
-> URI -> ([HttpResponseHeader] -> BodyReader -> IO a) -> IO a
get [HttpRequestHeader]
reqHeaders URI
uri [HttpResponseHeader] -> BodyReader -> IO a
callback = forall a.
(Throws HttpException => IO a) -> Throws SomeRemoteError => IO a
wrapCustomEx forall a b. (a -> b) -> a -> b
$ do
Request
request' <- forall (m :: * -> *). MonadThrow m => Request -> URI -> m Request
HTTP.setUri Request
HTTP.defaultRequest URI
uri
let request :: Request
request = [HttpRequestHeader] -> Request -> Request
setRequestHeaders [HttpRequestHeader]
reqHeaders Request
request'
forall a. Throws HttpException => IO a -> IO a
checkHttpException forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
MonadUnliftIO m =>
Request -> (Response BodyReader -> m a) -> m a
HTTP.withResponse Request
request forall a b. (a -> b) -> a -> b
$ \Response BodyReader
response -> do
let br :: BodyReader
br = forall a.
(Throws HttpException => IO a) -> Throws SomeRemoteError => IO a
wrapCustomEx forall a b. (a -> b) -> a -> b
$ forall a. Response a -> a
HTTP.getResponseBody Response BodyReader
response
[HttpResponseHeader] -> BodyReader -> IO a
callback (forall a. Response a -> [HttpResponseHeader]
getResponseHeaders Response BodyReader
response) BodyReader
br
getRange :: Throws SomeRemoteError
=> [HttpRequestHeader] -> URI -> (Int, Int)
-> (HttpStatus -> [HttpResponseHeader] -> BodyReader -> IO a)
-> IO a
getRange :: forall a.
Throws SomeRemoteError =>
[HttpRequestHeader]
-> URI
-> (Int, Int)
-> (HttpStatus -> [HttpResponseHeader] -> BodyReader -> IO a)
-> IO a
getRange [HttpRequestHeader]
reqHeaders URI
uri (Int
from, Int
to) HttpStatus -> [HttpResponseHeader] -> BodyReader -> IO a
callback = forall a.
(Throws HttpException => IO a) -> Throws SomeRemoteError => IO a
wrapCustomEx forall a b. (a -> b) -> a -> b
$ do
Request
request' <- forall (m :: * -> *). MonadThrow m => Request -> URI -> m Request
HTTP.setUri Request
HTTP.defaultRequest URI
uri
let request :: Request
request = Int -> Int -> Request -> Request
setRange Int
from Int
to
forall a b. (a -> b) -> a -> b
$ [HttpRequestHeader] -> Request -> Request
setRequestHeaders [HttpRequestHeader]
reqHeaders Request
request'
forall a. Throws HttpException => IO a -> IO a
checkHttpException forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
MonadUnliftIO m =>
Request -> (Response BodyReader -> m a) -> m a
HTTP.withResponse Request
request forall a b. (a -> b) -> a -> b
$ \Response BodyReader
response -> do
let br :: BodyReader
br = forall a.
(Throws HttpException => IO a) -> Throws SomeRemoteError => IO a
wrapCustomEx forall a b. (a -> b) -> a -> b
$ forall a. Response a -> a
HTTP.getResponseBody Response BodyReader
response
case () of
() | forall a. Response a -> Status
HTTP.getResponseStatus Response BodyReader
response forall a. Eq a => a -> a -> Bool
== Status
HTTP.partialContent206 ->
HttpStatus -> [HttpResponseHeader] -> BodyReader -> IO a
callback HttpStatus
HttpStatus206PartialContent (forall a. Response a -> [HttpResponseHeader]
getResponseHeaders Response BodyReader
response) BodyReader
br
() | forall a. Response a -> Status
HTTP.getResponseStatus Response BodyReader
response forall a. Eq a => a -> a -> Bool
== Status
HTTP.ok200 ->
HttpStatus -> [HttpResponseHeader] -> BodyReader -> IO a
callback HttpStatus
HttpStatus200OK (forall a. Response a -> [HttpResponseHeader]
getResponseHeaders Response BodyReader
response) BodyReader
br
()
_otherwise ->
forall e a. (Exception e, Throws e) => e -> IO a
throwChecked forall a b. (a -> b) -> a -> b
$ Request -> HttpExceptionContent -> HttpException
HTTP.HttpExceptionRequest Request
request
forall a b. (a -> b) -> a -> b
$ Response () -> ByteString -> HttpExceptionContent
HTTP.StatusCodeException (forall (f :: * -> *) a. Functor f => f a -> f ()
void Response BodyReader
response) ByteString
""
wrapCustomEx :: (Throws HTTP.HttpException => IO a)
-> (Throws SomeRemoteError => IO a)
wrapCustomEx :: forall a.
(Throws HttpException => IO a) -> Throws SomeRemoteError => IO a
wrapCustomEx Throws HttpException => IO a
act = forall e a.
Exception e =>
(e -> IO a) -> (Throws e => IO a) -> IO a
handleChecked (\(HttpException
ex :: HTTP.HttpException) -> forall {e} {a}. Exception e => e -> IO a
go HttpException
ex) Throws HttpException => IO a
act
where
go :: e -> IO a
go e
ex = forall e a. (Exception e, Throws e) => e -> IO a
throwChecked (forall e. Exception e => e -> SomeRemoteError
SomeRemoteError e
ex)
checkHttpException :: Throws HTTP.HttpException => IO a -> IO a
checkHttpException :: forall a. Throws HttpException => IO a -> IO a
checkHttpException = forall e a. Exception e => (e -> IO a) -> IO a -> IO a
handle forall a b. (a -> b) -> a -> b
$ \(HttpException
ex :: HTTP.HttpException) ->
forall e a. (Exception e, Throws e) => e -> IO a
throwChecked HttpException
ex
hAcceptRanges :: HTTP.HeaderName
hAcceptRanges :: HeaderName
hAcceptRanges = HeaderName
"Accept-Ranges"
hAcceptEncoding :: HTTP.HeaderName
hAcceptEncoding :: HeaderName
hAcceptEncoding = HeaderName
"Accept-Encoding"
setRange :: Int -> Int
-> HTTP.Request -> HTTP.Request
setRange :: Int -> Int -> Request -> Request
setRange Int
from Int
to =
HeaderName -> ByteString -> Request -> Request
HTTP.addRequestHeader HeaderName
HTTP.hRange ByteString
rangeHeader
where
rangeHeader :: ByteString
rangeHeader = [Char] -> ByteString
BS.C8.pack forall a b. (a -> b) -> a -> b
$ [Char]
"bytes=" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Int
from forall a. [a] -> [a] -> [a]
++ [Char]
"-" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show (Int
to forall a. Num a => a -> a -> a
- Int
1)
setRequestHeaders :: [HttpRequestHeader]
-> HTTP.Request -> HTTP.Request
[HttpRequestHeader]
opts =
[Header] -> Request -> Request
setRequestHeaders' ([(HeaderName, [ByteString])] -> [HttpRequestHeader] -> [Header]
trOpt [(HeaderName, [ByteString])]
disallowCompressionByDefault [HttpRequestHeader]
opts)
where
setRequestHeaders' :: [HTTP.Header] -> HTTP.Request -> HTTP.Request
setRequestHeaders' :: [Header] -> Request -> Request
setRequestHeaders' = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\(HeaderName
name, ByteString
val) Request -> Request
f -> Request -> Request
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. HeaderName -> [ByteString] -> Request -> Request
HTTP.setRequestHeader HeaderName
name [ByteString
val]) forall a. a -> a
id
trOpt :: [(HTTP.HeaderName, [ByteString])]
-> [HttpRequestHeader]
-> [HTTP.Header]
trOpt :: [(HeaderName, [ByteString])] -> [HttpRequestHeader] -> [Header]
trOpt [(HeaderName, [ByteString])]
acc [] =
forall a b. (a -> b) -> [a] -> [b]
map (HeaderName, [ByteString]) -> Header
finalizeHeader [(HeaderName, [ByteString])]
acc
trOpt [(HeaderName, [ByteString])]
acc (HttpRequestHeader
HttpRequestMaxAge0:[HttpRequestHeader]
os) =
[(HeaderName, [ByteString])] -> [HttpRequestHeader] -> [Header]
trOpt (forall a b. Eq a => a -> [b] -> [(a, [b])] -> [(a, [b])]
insert HeaderName
HTTP.hCacheControl [ByteString
"max-age=0"] [(HeaderName, [ByteString])]
acc) [HttpRequestHeader]
os
trOpt [(HeaderName, [ByteString])]
acc (HttpRequestHeader
HttpRequestNoTransform:[HttpRequestHeader]
os) =
[(HeaderName, [ByteString])] -> [HttpRequestHeader] -> [Header]
trOpt (forall a b. Eq a => a -> [b] -> [(a, [b])] -> [(a, [b])]
insert HeaderName
HTTP.hCacheControl [ByteString
"no-transform"] [(HeaderName, [ByteString])]
acc) [HttpRequestHeader]
os
disallowCompressionByDefault :: [(HTTP.HeaderName, [ByteString])]
disallowCompressionByDefault :: [(HeaderName, [ByteString])]
disallowCompressionByDefault = [(HeaderName
hAcceptEncoding, [])]
finalizeHeader :: (HTTP.HeaderName, [ByteString])
-> HTTP.Header
finalizeHeader :: (HeaderName, [ByteString]) -> Header
finalizeHeader (HeaderName
name, [ByteString]
strs) = (HeaderName
name, ByteString -> [ByteString] -> ByteString
BS.intercalate ByteString
", " (forall a. [a] -> [a]
reverse [ByteString]
strs))
insert :: Eq a => a -> [b] -> [(a, [b])] -> [(a, [b])]
insert :: forall a b. Eq a => a -> [b] -> [(a, [b])] -> [(a, [b])]
insert a
_ [b]
_ [] = []
insert a
x [b]
y ((a
k, [b]
v):[(a, [b])]
pairs)
| a
x forall a. Eq a => a -> a -> Bool
== a
k = (a
k, [b]
v forall a. [a] -> [a] -> [a]
++ [b]
y) forall a. a -> [a] -> [a]
: forall a b. Eq a => a -> [b] -> [(a, [b])] -> [(a, [b])]
insert a
x [b]
y [(a, [b])]
pairs
| Bool
otherwise = (a
k, [b]
v) forall a. a -> [a] -> [a]
: forall a b. Eq a => a -> [b] -> [(a, [b])] -> [(a, [b])]
insert a
x [b]
y [(a, [b])]
pairs
getResponseHeaders :: HTTP.Response a -> [HttpResponseHeader]
Response a
response = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [
[ HttpResponseHeader
HttpResponseAcceptRangesBytes
| (HeaderName
hAcceptRanges, ByteString
"bytes") forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Header]
headers
]
]
where
headers :: [Header]
headers = forall a. Response a -> [Header]
HTTP.getResponseHeaders Response a
response