{-# 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 :: (forall a.
Throws SomeRemoteError =>
[HttpRequestHeader]
-> URI -> ([HttpResponseHeader] -> BodyReader -> IO a) -> IO a)
-> (forall a.
Throws SomeRemoteError =>
[HttpRequestHeader]
-> URI
-> (Int, Int)
-> (HttpStatus -> [HttpResponseHeader] -> BodyReader -> IO a)
-> IO a)
-> 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 :: [HttpRequestHeader]
-> URI -> ([HttpResponseHeader] -> BodyReader -> IO a) -> IO a
get reqHeaders :: [HttpRequestHeader]
reqHeaders uri :: URI
uri callback :: [HttpResponseHeader] -> BodyReader -> IO a
callback = (Throws HttpException => IO a) -> IO a
forall a.
(Throws HttpException => IO a) -> Throws SomeRemoteError => IO a
wrapCustomEx ((Throws HttpException => IO a) -> IO a)
-> (Throws HttpException => IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ do
Request
request' <- Request -> URI -> IO 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'
IO a -> IO a
forall a. Throws HttpException => IO a -> IO a
checkHttpException (IO a -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$ Request -> (Response BodyReader -> IO a) -> IO a
forall (m :: * -> *) a.
MonadUnliftIO m =>
Request -> (Response BodyReader -> m a) -> m a
HTTP.withResponse Request
request ((Response BodyReader -> IO a) -> IO a)
-> (Response BodyReader -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \response :: Response BodyReader
response -> do
let br :: BodyReader
br = (Throws HttpException => BodyReader) -> BodyReader
forall a.
(Throws HttpException => IO a) -> Throws SomeRemoteError => IO a
wrapCustomEx ((Throws HttpException => BodyReader) -> BodyReader)
-> (Throws HttpException => BodyReader) -> BodyReader
forall a b. (a -> b) -> a -> b
$ Response BodyReader -> BodyReader
forall a. Response a -> a
HTTP.getResponseBody Response BodyReader
response
[HttpResponseHeader] -> BodyReader -> IO a
callback (Response BodyReader -> [HttpResponseHeader]
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 :: [HttpRequestHeader]
-> URI
-> (Int, Int)
-> (HttpStatus -> [HttpResponseHeader] -> BodyReader -> IO a)
-> IO a
getRange reqHeaders :: [HttpRequestHeader]
reqHeaders uri :: URI
uri (from :: Int
from, to :: Int
to) callback :: HttpStatus -> [HttpResponseHeader] -> BodyReader -> IO a
callback = (Throws HttpException => IO a) -> IO a
forall a.
(Throws HttpException => IO a) -> Throws SomeRemoteError => IO a
wrapCustomEx ((Throws HttpException => IO a) -> IO a)
-> (Throws HttpException => IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ do
Request
request' <- Request -> URI -> IO 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
(Request -> Request) -> Request -> Request
forall a b. (a -> b) -> a -> b
$ [HttpRequestHeader] -> Request -> Request
setRequestHeaders [HttpRequestHeader]
reqHeaders Request
request'
IO a -> IO a
forall a. Throws HttpException => IO a -> IO a
checkHttpException (IO a -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$ Request -> (Response BodyReader -> IO a) -> IO a
forall (m :: * -> *) a.
MonadUnliftIO m =>
Request -> (Response BodyReader -> m a) -> m a
HTTP.withResponse Request
request ((Response BodyReader -> IO a) -> IO a)
-> (Response BodyReader -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \response :: Response BodyReader
response -> do
let br :: BodyReader
br = (Throws HttpException => BodyReader) -> BodyReader
forall a.
(Throws HttpException => IO a) -> Throws SomeRemoteError => IO a
wrapCustomEx ((Throws HttpException => BodyReader) -> BodyReader)
-> (Throws HttpException => BodyReader) -> BodyReader
forall a b. (a -> b) -> a -> b
$ Response BodyReader -> BodyReader
forall a. Response a -> a
HTTP.getResponseBody Response BodyReader
response
case () of
() | Response BodyReader -> Status
forall a. Response a -> Status
HTTP.getResponseStatus Response BodyReader
response Status -> Status -> Bool
forall a. Eq a => a -> a -> Bool
== Status
HTTP.partialContent206 ->
HttpStatus -> [HttpResponseHeader] -> BodyReader -> IO a
callback HttpStatus
HttpStatus206PartialContent (Response BodyReader -> [HttpResponseHeader]
forall a. Response a -> [HttpResponseHeader]
getResponseHeaders Response BodyReader
response) BodyReader
br
() | Response BodyReader -> Status
forall a. Response a -> Status
HTTP.getResponseStatus Response BodyReader
response Status -> Status -> Bool
forall a. Eq a => a -> a -> Bool
== Status
HTTP.ok200 ->
HttpStatus -> [HttpResponseHeader] -> BodyReader -> IO a
callback HttpStatus
HttpStatus200OK (Response BodyReader -> [HttpResponseHeader]
forall a. Response a -> [HttpResponseHeader]
getResponseHeaders Response BodyReader
response) BodyReader
br
_otherwise :: ()
_otherwise ->
HttpException -> IO a
forall e a. (Exception e, Throws e) => e -> IO a
throwChecked (HttpException -> IO a) -> HttpException -> IO a
forall a b. (a -> b) -> a -> b
$ Request -> HttpExceptionContent -> HttpException
HTTP.HttpExceptionRequest Request
request
(HttpExceptionContent -> HttpException)
-> HttpExceptionContent -> HttpException
forall a b. (a -> b) -> a -> b
$ Response () -> ByteString -> HttpExceptionContent
HTTP.StatusCodeException (Response BodyReader -> Response ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void Response BodyReader
response) ""
wrapCustomEx :: (Throws HTTP.HttpException => IO a)
-> (Throws SomeRemoteError => IO a)
wrapCustomEx :: (Throws HttpException => IO a) -> Throws SomeRemoteError => IO a
wrapCustomEx act :: Throws HttpException => IO a
act = (HttpException -> IO a) -> (Throws HttpException => IO a) -> IO a
forall e a.
Exception e =>
(e -> IO a) -> (Throws e => IO a) -> IO a
handleChecked (\(HttpException
ex :: HTTP.HttpException) -> HttpException -> IO a
forall e a. Exception e => e -> IO a
go HttpException
ex) Throws HttpException => IO a
act
where
go :: e -> IO a
go ex :: e
ex = SomeRemoteError -> IO a
forall e a. (Exception e, Throws e) => e -> IO a
throwChecked (e -> SomeRemoteError
forall e. Exception e => e -> SomeRemoteError
SomeRemoteError e
ex)
checkHttpException :: Throws HTTP.HttpException => IO a -> IO a
checkHttpException :: IO a -> IO a
checkHttpException = (HttpException -> IO a) -> IO a -> IO a
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
handle ((HttpException -> IO a) -> IO a -> IO a)
-> (HttpException -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$ \(HttpException
ex :: HTTP.HttpException) ->
HttpException -> IO a
forall e a. (Exception e, Throws e) => e -> IO a
throwChecked HttpException
ex
hAcceptRanges :: HTTP.HeaderName
hAcceptRanges :: HeaderName
hAcceptRanges = "Accept-Ranges"
hAcceptEncoding :: HTTP.HeaderName
hAcceptEncoding :: HeaderName
hAcceptEncoding = "Accept-Encoding"
setRange :: Int -> Int
-> HTTP.Request -> HTTP.Request
setRange :: Int -> Int -> Request -> Request
setRange from :: Int
from to :: Int
to =
HeaderName -> ByteString -> Request -> Request
HTTP.addRequestHeader HeaderName
HTTP.hRange ByteString
rangeHeader
where
rangeHeader :: ByteString
rangeHeader = String -> ByteString
BS.C8.pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ "bytes=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
from String -> String -> String
forall a. [a] -> [a] -> [a]
++ "-" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (Int
to Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1)
setRequestHeaders :: [HttpRequestHeader]
-> HTTP.Request -> HTTP.Request
opts :: [HttpRequestHeader]
opts =
RequestHeaders -> Request -> Request
HTTP.setRequestHeaders ([(HeaderName, [ByteString])]
-> [HttpRequestHeader] -> RequestHeaders
trOpt [(HeaderName, [ByteString])]
disallowCompressionByDefault [HttpRequestHeader]
opts)
where
trOpt :: [(HTTP.HeaderName, [ByteString])]
-> [HttpRequestHeader]
-> [HTTP.Header]
trOpt :: [(HeaderName, [ByteString])]
-> [HttpRequestHeader] -> RequestHeaders
trOpt acc :: [(HeaderName, [ByteString])]
acc [] =
((HeaderName, [ByteString]) -> RequestHeaders)
-> [(HeaderName, [ByteString])] -> RequestHeaders
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (HeaderName, [ByteString]) -> RequestHeaders
finalizeHeader [(HeaderName, [ByteString])]
acc
trOpt acc :: [(HeaderName, [ByteString])]
acc (HttpRequestMaxAge0:os :: [HttpRequestHeader]
os) =
[(HeaderName, [ByteString])]
-> [HttpRequestHeader] -> RequestHeaders
trOpt (HeaderName
-> [ByteString]
-> [(HeaderName, [ByteString])]
-> [(HeaderName, [ByteString])]
forall a b. Eq a => a -> [b] -> [(a, [b])] -> [(a, [b])]
insert HeaderName
HTTP.hCacheControl ["max-age=0"] [(HeaderName, [ByteString])]
acc) [HttpRequestHeader]
os
trOpt acc :: [(HeaderName, [ByteString])]
acc (HttpRequestNoTransform:os :: [HttpRequestHeader]
os) =
[(HeaderName, [ByteString])]
-> [HttpRequestHeader] -> RequestHeaders
trOpt (HeaderName
-> [ByteString]
-> [(HeaderName, [ByteString])]
-> [(HeaderName, [ByteString])]
forall a b. Eq a => a -> [b] -> [(a, [b])] -> [(a, [b])]
insert HeaderName
HTTP.hCacheControl ["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]) -> RequestHeaders
finalizeHeader (name :: HeaderName
name, strs :: [ByteString]
strs) = [(HeaderName
name, ByteString -> [ByteString] -> ByteString
BS.intercalate ", " ([ByteString] -> [ByteString]
forall a. [a] -> [a]
reverse [ByteString]
strs))]
insert :: Eq a => a -> [b] -> [(a, [b])] -> [(a, [b])]
insert :: a -> [b] -> [(a, [b])] -> [(a, [b])]
insert _ _ [] = []
insert x :: a
x y :: [b]
y ((k :: a
k, v :: [b]
v):pairs :: [(a, [b])]
pairs)
| a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
k = (a
k, [b]
v [b] -> [b] -> [b]
forall a. [a] -> [a] -> [a]
++ [b]
y) (a, [b]) -> [(a, [b])] -> [(a, [b])]
forall a. a -> [a] -> [a]
: a -> [b] -> [(a, [b])] -> [(a, [b])]
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) (a, [b]) -> [(a, [b])] -> [(a, [b])]
forall a. a -> [a] -> [a]
: a -> [b] -> [(a, [b])] -> [(a, [b])]
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 :: Response a
response = [[HttpResponseHeader]] -> [HttpResponseHeader]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [
[ HttpResponseHeader
HttpResponseAcceptRangesBytes
| (HeaderName
hAcceptRanges, "bytes") (HeaderName, ByteString) -> RequestHeaders -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` RequestHeaders
headers
]
]
where
headers :: RequestHeaders
headers = Response a -> RequestHeaders
forall a. Response a -> RequestHeaders
HTTP.getResponseHeaders Response a
response