{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Hackage.Security.Client.Repository.HttpLib.HttpClient (
withClient
, makeHttpLib
, Manager
) where
import Control.Exception
import Control.Monad (void)
import Data.ByteString (ByteString)
import Network.URI
import Network.HTTP.Client (Manager)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BS.C8
import qualified Network.HTTP.Client as HttpClient
import qualified Network.HTTP.Client.Internal as HttpClient
import qualified Network.HTTP.StackClient as StackClient
import qualified Network.HTTP.Types as HttpClient
import Hackage.Security.Client hiding (Header)
import Hackage.Security.Client.Repository.HttpLib
import Hackage.Security.Util.Checked
import qualified Hackage.Security.Util.Lens as Lens
withClient :: ProxyConfig HttpClient.Proxy -> (Manager -> HttpLib -> IO a) -> IO a
withClient proxyConfig callback = do
manager <- HttpClient.newManager (setProxy HttpClient.defaultManagerSettings)
callback manager $ makeHttpLib manager
where
setProxy = HttpClient.managerSetProxy $
case proxyConfig of
ProxyConfigNone -> HttpClient.noProxy
ProxyConfigUse p -> HttpClient.useProxy p
ProxyConfigAuto -> HttpClient.proxyEnvironment Nothing
makeHttpLib :: Manager -> HttpLib
makeHttpLib manager = HttpLib
{ httpGet = get manager
, httpGetRange = getRange manager
}
get :: Throws SomeRemoteError
=> Manager
-> [HttpRequestHeader] -> URI
-> ([HttpResponseHeader] -> BodyReader -> IO a)
-> IO a
get manager reqHeaders uri callback = wrapCustomEx $ do
request' <- HttpClient.setUri HttpClient.defaultRequest uri
let request = setRequestHeaders reqHeaders request'
checkHttpException $ StackClient.withResponseByManager request manager $ \response -> do
let br = wrapCustomEx $ HttpClient.responseBody response
callback (getResponseHeaders response) br
getRange :: Throws SomeRemoteError
=> Manager
-> [HttpRequestHeader] -> URI -> (Int, Int)
-> (HttpStatus -> [HttpResponseHeader] -> BodyReader -> IO a)
-> IO a
getRange manager reqHeaders uri (from, to) callback = wrapCustomEx $ do
request' <- HttpClient.setUri HttpClient.defaultRequest uri
let request = setRange from to
$ setRequestHeaders reqHeaders request'
checkHttpException $ StackClient.withResponseByManager request manager $ \response -> do
let br = wrapCustomEx $ HttpClient.responseBody response
case () of
() | HttpClient.responseStatus response == HttpClient.partialContent206 ->
callback HttpStatus206PartialContent (getResponseHeaders response) br
() | HttpClient.responseStatus response == HttpClient.ok200 ->
callback HttpStatus200OK (getResponseHeaders response) br
_otherwise ->
throwChecked $ HttpClient.HttpExceptionRequest request
$ HttpClient.StatusCodeException (void response) ""
wrapCustomEx :: (Throws HttpClient.HttpException => IO a)
-> (Throws SomeRemoteError => IO a)
wrapCustomEx act = handleChecked (\(ex :: HttpClient.HttpException) -> go ex) act
where
go ex = throwChecked (SomeRemoteError ex)
checkHttpException :: Throws HttpClient.HttpException => IO a -> IO a
checkHttpException = handle $ \(ex :: HttpClient.HttpException) ->
throwChecked ex
hAcceptRanges :: HttpClient.HeaderName
hAcceptRanges = "Accept-Ranges"
hAcceptEncoding :: HttpClient.HeaderName
hAcceptEncoding = "Accept-Encoding"
setRange :: Int -> Int
-> HttpClient.Request -> HttpClient.Request
setRange from to req = req {
HttpClient.requestHeaders = (HttpClient.hRange, rangeHeader)
: HttpClient.requestHeaders req
}
where
rangeHeader = BS.C8.pack $ "bytes=" ++ show from ++ "-" ++ show (to - 1)
setRequestHeaders :: [HttpRequestHeader]
-> HttpClient.Request -> HttpClient.Request
setRequestHeaders opts req = req {
HttpClient.requestHeaders = trOpt disallowCompressionByDefault opts
}
where
trOpt :: [(HttpClient.HeaderName, [ByteString])]
-> [HttpRequestHeader]
-> [HttpClient.Header]
trOpt acc [] =
concatMap finalizeHeader acc
trOpt acc (HttpRequestMaxAge0:os) =
trOpt (insert HttpClient.hCacheControl ["max-age=0"] acc) os
trOpt acc (HttpRequestNoTransform:os) =
trOpt (insert HttpClient.hCacheControl ["no-transform"] acc) os
disallowCompressionByDefault :: [(HttpClient.HeaderName, [ByteString])]
disallowCompressionByDefault = [(hAcceptEncoding, [])]
finalizeHeader :: (HttpClient.HeaderName, [ByteString])
-> [HttpClient.Header]
finalizeHeader (name, strs) = [(name, BS.intercalate ", " (reverse strs))]
insert :: Eq a => a -> [b] -> [(a, [b])] -> [(a, [b])]
insert x y = Lens.modify (Lens.lookupM x) (++ y)
getResponseHeaders :: HttpClient.Response a -> [HttpResponseHeader]
getResponseHeaders response = concat [
[ HttpResponseAcceptRangesBytes
| (hAcceptRanges, "bytes") `elem` headers
]
]
where
headers = HttpClient.responseHeaders response