{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Hackage.Security.Client.Repository.HttpLib.HttpClient (
makeHttpLib
, Manager
) 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 Network.HTTP.StackClient (Manager)
import qualified Network.HTTP.StackClient as StackClient
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
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' <- StackClient.setUri StackClient.defaultRequest uri
let request = setRequestHeaders reqHeaders request'
checkHttpException $ StackClient.withResponseByManager request manager $ \response -> do
let br = wrapCustomEx $ StackClient.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' <- StackClient.setUri StackClient.defaultRequest uri
let request = setRange from to
$ setRequestHeaders reqHeaders request'
checkHttpException $ StackClient.withResponseByManager request manager $ \response -> do
let br = wrapCustomEx $ StackClient.responseBody response
case () of
() | StackClient.responseStatus response == StackClient.partialContent206 ->
callback HttpStatus206PartialContent (getResponseHeaders response) br
() | StackClient.responseStatus response == StackClient.ok200 ->
callback HttpStatus200OK (getResponseHeaders response) br
_otherwise ->
throwChecked $ StackClient.HttpExceptionRequest request
$ StackClient.StatusCodeException (void response) ""
wrapCustomEx :: (Throws StackClient.HttpException => IO a)
-> (Throws SomeRemoteError => IO a)
wrapCustomEx act = handleChecked (\(ex :: StackClient.HttpException) -> go ex) act
where
go ex = throwChecked (SomeRemoteError ex)
checkHttpException :: Throws StackClient.HttpException => IO a -> IO a
checkHttpException = handle $ \(ex :: StackClient.HttpException) ->
throwChecked ex
hAcceptRanges :: StackClient.HeaderName
hAcceptRanges = "Accept-Ranges"
hAcceptEncoding :: StackClient.HeaderName
hAcceptEncoding = "Accept-Encoding"
setRange :: Int -> Int
-> StackClient.Request -> StackClient.Request
setRange from to req = req {
StackClient.requestHeaders = (StackClient.hRange, rangeHeader)
: StackClient.requestHeaders req
}
where
rangeHeader = BS.C8.pack $ "bytes=" ++ show from ++ "-" ++ show (to - 1)
setRequestHeaders :: [HttpRequestHeader]
-> StackClient.Request -> StackClient.Request
setRequestHeaders opts req = req {
StackClient.requestHeaders = trOpt disallowCompressionByDefault opts
}
where
trOpt :: [(StackClient.HeaderName, [ByteString])]
-> [HttpRequestHeader]
-> [StackClient.Header]
trOpt acc [] =
concatMap finalizeHeader acc
trOpt acc (HttpRequestMaxAge0:os) =
trOpt (insert StackClient.hCacheControl ["max-age=0"] acc) os
trOpt acc (HttpRequestNoTransform:os) =
trOpt (insert StackClient.hCacheControl ["no-transform"] acc) os
disallowCompressionByDefault :: [(StackClient.HeaderName, [ByteString])]
disallowCompressionByDefault = [(hAcceptEncoding, [])]
finalizeHeader :: (StackClient.HeaderName, [ByteString])
-> [StackClient.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 :: StackClient.Response a -> [HttpResponseHeader]
getResponseHeaders response = concat [
[ HttpResponseAcceptRangesBytes
| (hAcceptRanges, "bytes") `elem` headers
]
]
where
headers = StackClient.responseHeaders response