-- Explicitly disabling due to external code {-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE RankNTypes          #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE OverloadedStrings   #-}

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

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

-- | An 'HttpLib' value using the default global manager
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
    }

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

get :: Throws SomeRemoteError
    => [HttpRequestHeader] -> URI
    -> ([HttpResponseHeader] -> BodyReader -> IO a)
    -> IO a
get :: [HttpRequestHeader]
-> URI -> ([HttpResponseHeader] -> BodyReader -> IO a) -> IO a
get [HttpRequestHeader]
reqHeaders URI
uri [HttpResponseHeader] -> BodyReader -> IO a
callback = (Throws HttpException => IO a) -> Throws SomeRemoteError => IO a
forall a.
(Throws HttpException => IO a) -> Throws SomeRemoteError => IO a
wrapCustomEx ((Throws HttpException => IO a) -> Throws SomeRemoteError => IO a)
-> (Throws HttpException => IO a) -> Throws SomeRemoteError => IO a
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' <- 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 BodyReader
response -> do
      let br :: BodyReader
br = (Throws HttpException => BodyReader)
-> Throws SomeRemoteError => BodyReader
forall a.
(Throws HttpException => IO a) -> Throws SomeRemoteError => IO a
wrapCustomEx ((Throws HttpException => BodyReader)
 -> Throws SomeRemoteError => BodyReader)
-> (Throws HttpException => BodyReader)
-> Throws SomeRemoteError => 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 [HttpRequestHeader]
reqHeaders URI
uri (Int
from, Int
to) HttpStatus -> [HttpResponseHeader] -> BodyReader -> IO a
callback = (Throws HttpException => IO a) -> Throws SomeRemoteError => IO a
forall a.
(Throws HttpException => IO a) -> Throws SomeRemoteError => IO a
wrapCustomEx ((Throws HttpException => IO a) -> Throws SomeRemoteError => IO a)
-> (Throws HttpException => IO a) -> Throws SomeRemoteError => 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 BodyReader
response -> do
      let br :: BodyReader
br = (Throws HttpException => BodyReader)
-> Throws SomeRemoteError => BodyReader
forall a.
(Throws HttpException => IO a) -> Throws SomeRemoteError => IO a
wrapCustomEx ((Throws HttpException => BodyReader)
 -> Throws SomeRemoteError => BodyReader)
-> (Throws HttpException => BodyReader)
-> Throws SomeRemoteError => 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 ->
           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) 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 :: (Throws HttpException => IO a) -> Throws SomeRemoteError => IO a
wrapCustomEx 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 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

{-------------------------------------------------------------------------------
  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 = String -> ByteString
BS.C8.pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ String
"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 -> 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
- 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' = (Header -> (Request -> Request) -> Request -> Request)
-> (Request -> Request) -> [Header] -> Request -> Request
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\(HeaderName
name, ByteString
val) Request -> Request
f -> Request -> Request
f (Request -> Request) -> (Request -> Request) -> Request -> Request
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HeaderName -> [ByteString] -> Request -> Request
HTTP.setRequestHeader HeaderName
name [ByteString
val]) Request -> Request
forall a. a -> a
id

    trOpt :: [(HTTP.HeaderName, [ByteString])]
          -> [HttpRequestHeader]
          -> [HTTP.Header]
    trOpt :: [(HeaderName, [ByteString])] -> [HttpRequestHeader] -> [Header]
trOpt [(HeaderName, [ByteString])]
acc [] =
      ((HeaderName, [ByteString]) -> Header)
-> [(HeaderName, [ByteString])] -> [Header]
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 (HeaderName
-> [ByteString]
-> [(HeaderName, [ByteString])]
-> [(HeaderName, [ByteString])]
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 (HeaderName
-> [ByteString]
-> [(HeaderName, [ByteString])]
-> [(HeaderName, [ByteString])]
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
", " ([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 a
_ [b]
_ [] = []
    insert a
x [b]
y ((a
k, [b]
v):[(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

-- | Extract the response headers
getResponseHeaders :: HTTP.Response a -> [HttpResponseHeader]
getResponseHeaders :: Response a -> [HttpResponseHeader]
getResponseHeaders Response a
response = [[HttpResponseHeader]] -> [HttpResponseHeader]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [
      [ HttpResponseHeader
HttpResponseAcceptRangesBytes
      | (HeaderName
hAcceptRanges, ByteString
"bytes") Header -> [Header] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Header]
headers
      ]
    ]
  where
    headers :: [Header]
headers = Response a -> [Header]
forall a. Response a -> [Header]
HTTP.getResponseHeaders Response a
response