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