-- Explicitly disabling due to external code {-# LANGUAGE NoImplicitPrelude #-}

{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE RankNTypes          #-}
{-# LANGUAGE ScopedTypeVariables #-}

-- Adapted from `hackage-security-http-client` to use our own

-- `Pantry.HTTP` implementation

module Hackage.Security.Client.Repository.HttpLib.HttpClient
  ( httpLib
  ) where

import           Control.Exception
import           Control.Monad ( void )
import           Data.ByteString ( ByteString )
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BS.C8
import           Hackage.Security.Client hiding ( Header )
import           Hackage.Security.Client.Repository.HttpLib
import           Hackage.Security.Util.Checked
import           Network.URI
import qualified Pantry.HTTP as HTTP

{-------------------------------------------------------------------------------
  Top-level API
-------------------------------------------------------------------------------}

-- | An 'HttpLib' value using the default global manager

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
  }

{-------------------------------------------------------------------------------
  Individual methods
-------------------------------------------------------------------------------}

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
  -- TODO: setUri fails under certain circumstances; in particular, when

  -- the URI contains URL auth. Not sure if this is a concern.

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

-- | Wrap custom exceptions

--

-- NOTE: The only other exception defined in @http-client@ is @TimeoutTriggered@

-- but it is currently disabled <https://github.com/snoyberg/http-client/issues/116>

wrapCustomEx ::
     (Throws HTTP.HttpException => IO a)
  -> (Throws SomeRemoteError => IO a)
wrapCustomEx :: forall a.
(Throws HttpException => IO a) -> Throws SomeRemoteError => IO a
wrapCustomEx = 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)
 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

{-------------------------------------------------------------------------------
  http-client auxiliary
-------------------------------------------------------------------------------}

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
  -- Content-Range header uses inclusive rather than exclusive bounds

  -- See <http://www.w3.org/Protocols/rfc2616/rfc2616-sec14.html>

  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)

-- | Set request headers

setRequestHeaders ::
     [HttpRequestHeader]
  -> HTTP.Request
  -> HTTP.Request
setRequestHeaders :: [HttpRequestHeader] -> Request -> Request
setRequestHeaders [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

  -- disable content compression (potential security issue)

  disallowCompressionByDefault :: [(HTTP.HeaderName, [ByteString])]
  disallowCompressionByDefault :: [(HeaderName, [ByteString])]
disallowCompressionByDefault = [(HeaderName
hAcceptEncoding, [])]

  -- Some headers are comma-separated, others need multiple headers for

  -- multiple options.

  --

  -- TODO: Right we we just comma-separate all of them.

  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

-- | Extract the response headers

getResponseHeaders :: HTTP.Response a -> [HttpResponseHeader]
getResponseHeaders :: forall a. Response a -> [HttpResponseHeader]
getResponseHeaders Response a
response =
  [ 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