{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
module Distribution.Client.Security.HTTP (HttpLib, transportAdapter) where
import Distribution.Solver.Compat.Prelude
import Prelude ()
import System.Directory
( getTemporaryDirectory )
import Network.URI
( URI )
import qualified Data.ByteString.Lazy as BS.L
import qualified Network.HTTP as HTTP
import Distribution.Verbosity
( Verbosity )
import Distribution.Client.HttpUtils
( HttpTransport(..), HttpCode )
import Distribution.Client.Utils
( withTempFileName )
import Hackage.Security.Client.Repository.HttpLib (HttpLib (..))
import qualified Hackage.Security.Client as HC
import qualified Hackage.Security.Client.Repository.HttpLib as HC
import qualified Hackage.Security.Util.Checked as HC
import qualified Hackage.Security.Util.Pretty as HC
transportAdapter :: Verbosity -> IO HttpTransport -> HttpLib
transportAdapter :: Verbosity -> IO HttpTransport -> HttpLib
transportAdapter Verbosity
verbosity IO HttpTransport
getTransport = 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 = \[HttpRequestHeader]
headers URI
uri [HttpResponseHeader] -> BodyReader -> IO a
callback -> do
HttpTransport
transport <- IO HttpTransport
getTransport
Verbosity
-> HttpTransport
-> [HttpRequestHeader]
-> URI
-> ([HttpResponseHeader] -> BodyReader -> IO a)
-> IO a
forall a.
Throws SomeRemoteError =>
Verbosity
-> HttpTransport
-> [HttpRequestHeader]
-> URI
-> ([HttpResponseHeader] -> BodyReader -> IO a)
-> IO a
httpGetImpl Verbosity
verbosity HttpTransport
transport [HttpRequestHeader]
headers URI
uri [HttpResponseHeader] -> BodyReader -> IO a
callback
, httpGetRange :: forall a.
Throws SomeRemoteError =>
[HttpRequestHeader]
-> URI
-> (Int, Int)
-> (HttpStatus -> [HttpResponseHeader] -> BodyReader -> IO a)
-> IO a
httpGetRange = \[HttpRequestHeader]
headers URI
uri (Int, Int)
range HttpStatus -> [HttpResponseHeader] -> BodyReader -> IO a
callback -> do
HttpTransport
transport <- IO HttpTransport
getTransport
Verbosity
-> HttpTransport
-> [HttpRequestHeader]
-> URI
-> (Int, Int)
-> (HttpStatus -> [HttpResponseHeader] -> BodyReader -> IO a)
-> IO a
forall a.
Throws SomeRemoteError =>
Verbosity
-> HttpTransport
-> [HttpRequestHeader]
-> URI
-> (Int, Int)
-> (HttpStatus -> [HttpResponseHeader] -> BodyReader -> IO a)
-> IO a
getRange Verbosity
verbosity HttpTransport
transport [HttpRequestHeader]
headers URI
uri (Int, Int)
range HttpStatus -> [HttpResponseHeader] -> BodyReader -> IO a
callback
}
httpGetImpl
:: HC.Throws HC.SomeRemoteError
=> Verbosity
-> HttpTransport
-> [HC.HttpRequestHeader] -> URI
-> ([HC.HttpResponseHeader] -> HC.BodyReader -> IO a)
-> IO a
httpGetImpl :: Verbosity
-> HttpTransport
-> [HttpRequestHeader]
-> URI
-> ([HttpResponseHeader] -> BodyReader -> IO a)
-> IO a
httpGetImpl Verbosity
verbosity HttpTransport
transport [HttpRequestHeader]
reqHeaders URI
uri [HttpResponseHeader] -> BodyReader -> IO a
callback = ((Throws UnexpectedResponse, Throws IOException) => IO a)
-> Throws SomeRemoteError => IO a
forall a.
((Throws UnexpectedResponse, Throws IOException) => IO a)
-> Throws SomeRemoteError => IO a
wrapCustomEx (((Throws UnexpectedResponse, Throws IOException) => IO a)
-> Throws SomeRemoteError => IO a)
-> ((Throws UnexpectedResponse, Throws IOException) => IO a)
-> Throws SomeRemoteError => IO a
forall a b. (a -> b) -> a -> b
$ do
Verbosity
-> HttpTransport
-> [HttpRequestHeader]
-> URI
-> Maybe (Int, Int)
-> (Int -> [HttpResponseHeader] -> BodyReader -> IO a)
-> IO a
forall a.
Verbosity
-> HttpTransport
-> [HttpRequestHeader]
-> URI
-> Maybe (Int, Int)
-> (Int -> [HttpResponseHeader] -> BodyReader -> IO a)
-> IO a
get' Verbosity
verbosity HttpTransport
transport [HttpRequestHeader]
reqHeaders URI
uri Maybe (Int, Int)
forall a. Maybe a
Nothing ((Int -> [HttpResponseHeader] -> BodyReader -> IO a) -> IO a)
-> (Int -> [HttpResponseHeader] -> BodyReader -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \Int
code [HttpResponseHeader]
respHeaders BodyReader
br ->
case Int
code of
Int
200 -> [HttpResponseHeader] -> BodyReader -> IO a
callback [HttpResponseHeader]
respHeaders BodyReader
br
Int
_ -> UnexpectedResponse -> IO a
forall e a. (Exception e, Throws e) => e -> IO a
HC.throwChecked (UnexpectedResponse -> IO a) -> UnexpectedResponse -> IO a
forall a b. (a -> b) -> a -> b
$ URI -> Int -> UnexpectedResponse
UnexpectedResponse URI
uri Int
code
getRange :: HC.Throws HC.SomeRemoteError
=> Verbosity
-> HttpTransport
-> [HC.HttpRequestHeader] -> URI -> (Int, Int)
-> (HC.HttpStatus -> [HC.HttpResponseHeader] -> HC.BodyReader -> IO a)
-> IO a
getRange :: Verbosity
-> HttpTransport
-> [HttpRequestHeader]
-> URI
-> (Int, Int)
-> (HttpStatus -> [HttpResponseHeader] -> BodyReader -> IO a)
-> IO a
getRange Verbosity
verbosity HttpTransport
transport [HttpRequestHeader]
reqHeaders URI
uri (Int, Int)
range HttpStatus -> [HttpResponseHeader] -> BodyReader -> IO a
callback = ((Throws UnexpectedResponse, Throws IOException) => IO a)
-> Throws SomeRemoteError => IO a
forall a.
((Throws UnexpectedResponse, Throws IOException) => IO a)
-> Throws SomeRemoteError => IO a
wrapCustomEx (((Throws UnexpectedResponse, Throws IOException) => IO a)
-> Throws SomeRemoteError => IO a)
-> ((Throws UnexpectedResponse, Throws IOException) => IO a)
-> Throws SomeRemoteError => IO a
forall a b. (a -> b) -> a -> b
$ do
Verbosity
-> HttpTransport
-> [HttpRequestHeader]
-> URI
-> Maybe (Int, Int)
-> (Int -> [HttpResponseHeader] -> BodyReader -> IO a)
-> IO a
forall a.
Verbosity
-> HttpTransport
-> [HttpRequestHeader]
-> URI
-> Maybe (Int, Int)
-> (Int -> [HttpResponseHeader] -> BodyReader -> IO a)
-> IO a
get' Verbosity
verbosity HttpTransport
transport [HttpRequestHeader]
reqHeaders URI
uri ((Int, Int) -> Maybe (Int, Int)
forall a. a -> Maybe a
Just (Int, Int)
range) ((Int -> [HttpResponseHeader] -> BodyReader -> IO a) -> IO a)
-> (Int -> [HttpResponseHeader] -> BodyReader -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \Int
code [HttpResponseHeader]
respHeaders BodyReader
br ->
case Int
code of
Int
200 -> HttpStatus -> [HttpResponseHeader] -> BodyReader -> IO a
callback HttpStatus
HC.HttpStatus200OK [HttpResponseHeader]
respHeaders BodyReader
br
Int
206 -> HttpStatus -> [HttpResponseHeader] -> BodyReader -> IO a
callback HttpStatus
HC.HttpStatus206PartialContent [HttpResponseHeader]
respHeaders BodyReader
br
Int
_ -> UnexpectedResponse -> IO a
forall e a. (Exception e, Throws e) => e -> IO a
HC.throwChecked (UnexpectedResponse -> IO a) -> UnexpectedResponse -> IO a
forall a b. (a -> b) -> a -> b
$ URI -> Int -> UnexpectedResponse
UnexpectedResponse URI
uri Int
code
get' :: Verbosity
-> HttpTransport
-> [HC.HttpRequestHeader] -> URI -> Maybe (Int, Int)
-> (HttpCode -> [HC.HttpResponseHeader] -> HC.BodyReader -> IO a)
-> IO a
get' :: Verbosity
-> HttpTransport
-> [HttpRequestHeader]
-> URI
-> Maybe (Int, Int)
-> (Int -> [HttpResponseHeader] -> BodyReader -> IO a)
-> IO a
get' Verbosity
verbosity HttpTransport
transport [HttpRequestHeader]
reqHeaders URI
uri Maybe (Int, Int)
mRange Int -> [HttpResponseHeader] -> BodyReader -> IO a
callback = do
FilePath
tempDir <- IO FilePath
getTemporaryDirectory
FilePath -> FilePath -> (FilePath -> IO a) -> IO a
forall a. FilePath -> FilePath -> (FilePath -> IO a) -> IO a
withTempFileName FilePath
tempDir FilePath
"transportAdapterGet" ((FilePath -> IO a) -> IO a) -> (FilePath -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \FilePath
temp -> do
(Int
code, Maybe FilePath
_etag) <- HttpTransport
-> Verbosity
-> URI
-> Maybe FilePath
-> FilePath
-> [Header]
-> IO (Int, Maybe FilePath)
getHttp HttpTransport
transport Verbosity
verbosity URI
uri Maybe FilePath
forall a. Maybe a
Nothing FilePath
temp [Header]
reqHeaders'
BodyReader
br <- ByteString -> IO BodyReader
HC.bodyReaderFromBS (ByteString -> IO BodyReader) -> IO ByteString -> IO BodyReader
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< FilePath -> IO ByteString
BS.L.readFile FilePath
temp
Int -> [HttpResponseHeader] -> BodyReader -> IO a
callback Int
code [HttpResponseHeader
HC.HttpResponseAcceptRangesBytes] BodyReader
br
where
reqHeaders' :: [Header]
reqHeaders' = [HttpRequestHeader] -> Maybe (Int, Int) -> [Header]
mkReqHeaders [HttpRequestHeader]
reqHeaders Maybe (Int, Int)
mRange
mkRangeHeader :: Int -> Int -> HTTP.Header
Int
from Int
to = HeaderName -> FilePath -> Header
HTTP.Header HeaderName
HTTP.HdrRange FilePath
rangeHeader
where
rangeHeader :: FilePath
rangeHeader = FilePath
"bytes=" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Int -> FilePath
forall a. Show a => a -> FilePath
show Int
from FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"-" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Int -> FilePath
forall a. Show a => a -> FilePath
show (Int
to Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
mkReqHeaders :: [HC.HttpRequestHeader] -> Maybe (Int, Int) -> [HTTP.Header]
[HttpRequestHeader]
reqHeaders Maybe (Int, Int)
mRange' = [[Header]] -> [Header]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [
[(HeaderName, [FilePath])] -> [HttpRequestHeader] -> [Header]
tr [] [HttpRequestHeader]
reqHeaders
, [Int -> Int -> Header
mkRangeHeader Int
fr Int
to | Just (Int
fr, Int
to) <- [Maybe (Int, Int)
mRange]]
]
where
mRange :: Maybe (Int, Int)
mRange = case Maybe (Int, Int)
mRange' of
Just (Int
fr, Int
to) | Int
fr Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
to -> Maybe (Int, Int)
forall a. Maybe a
Nothing
Maybe (Int, Int)
_ -> Maybe (Int, Int)
mRange'
tr :: [(HTTP.HeaderName, [String])] -> [HC.HttpRequestHeader] -> [HTTP.Header]
tr :: [(HeaderName, [FilePath])] -> [HttpRequestHeader] -> [Header]
tr [(HeaderName, [FilePath])]
acc [] =
((HeaderName, [FilePath]) -> [Header])
-> [(HeaderName, [FilePath])] -> [Header]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (HeaderName, [FilePath]) -> [Header]
finalize [(HeaderName, [FilePath])]
acc
tr [(HeaderName, [FilePath])]
acc (HttpRequestHeader
HC.HttpRequestMaxAge0:[HttpRequestHeader]
os) =
[(HeaderName, [FilePath])] -> [HttpRequestHeader] -> [Header]
tr (HeaderName
-> [FilePath]
-> [(HeaderName, [FilePath])]
-> [(HeaderName, [FilePath])]
forall a b. Eq a => a -> [b] -> [(a, [b])] -> [(a, [b])]
insert HeaderName
HTTP.HdrCacheControl [FilePath
"max-age=0"] [(HeaderName, [FilePath])]
acc) [HttpRequestHeader]
os
tr [(HeaderName, [FilePath])]
acc (HttpRequestHeader
HC.HttpRequestNoTransform:[HttpRequestHeader]
os) =
[(HeaderName, [FilePath])] -> [HttpRequestHeader] -> [Header]
tr (HeaderName
-> [FilePath]
-> [(HeaderName, [FilePath])]
-> [(HeaderName, [FilePath])]
forall a b. Eq a => a -> [b] -> [(a, [b])] -> [(a, [b])]
insert HeaderName
HTTP.HdrCacheControl [FilePath
"no-transform"] [(HeaderName, [FilePath])]
acc) [HttpRequestHeader]
os
finalize :: (HTTP.HeaderName, [String]) -> [HTTP.Header]
finalize :: (HeaderName, [FilePath]) -> [Header]
finalize (HeaderName
name, [FilePath]
strs) = [HeaderName -> FilePath -> Header
HTTP.Header HeaderName
name (FilePath -> [FilePath] -> FilePath
forall a. [a] -> [[a]] -> [a]
intercalate FilePath
", " ([FilePath] -> [FilePath]
forall a. [a] -> [a]
reverse [FilePath]
strs))]
insert :: Eq a => a -> [b] -> [(a, [b])] -> [(a, [b])]
insert :: a -> [b] -> [(a, [b])] -> [(a, [b])]
insert a
x [b]
y = a -> ([b] -> [b]) -> [(a, [b])] -> [(a, [b])]
forall a b. Eq a => a -> (b -> b) -> [(a, b)] -> [(a, b)]
modifyAssocList a
x ([b] -> [b] -> [b]
forall a. [a] -> [a] -> [a]
++ [b]
y)
modifyAssocList :: Eq a => a -> (b -> b) -> [(a, b)] -> [(a, b)]
modifyAssocList :: a -> (b -> b) -> [(a, b)] -> [(a, b)]
modifyAssocList a
a b -> b
f = [(a, b)] -> [(a, b)]
go where
go :: [(a, b)] -> [(a, b)]
go [] = []
go (p :: (a, b)
p@(a
a', b
b) : [(a, b)]
xs) | a
a a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
a' = (a
a', b -> b
f b
b) (a, b) -> [(a, b)] -> [(a, b)]
forall a. a -> [a] -> [a]
: [(a, b)]
xs
| Bool
otherwise = (a, b)
p (a, b) -> [(a, b)] -> [(a, b)]
forall a. a -> [a] -> [a]
: [(a, b)] -> [(a, b)]
go [(a, b)]
xs
data UnexpectedResponse = UnexpectedResponse URI Int
deriving (Typeable)
instance HC.Pretty UnexpectedResponse where
pretty :: UnexpectedResponse -> FilePath
pretty (UnexpectedResponse URI
uri Int
code) = FilePath
"Unexpected response " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Int -> FilePath
forall a. Show a => a -> FilePath
show Int
code
FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" for " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ URI -> FilePath
forall a. Show a => a -> FilePath
show URI
uri
#if MIN_VERSION_base(4,8,0)
deriving instance Show UnexpectedResponse
instance Exception UnexpectedResponse where displayException :: UnexpectedResponse -> FilePath
displayException = UnexpectedResponse -> FilePath
forall a. Pretty a => a -> FilePath
HC.pretty
#else
instance Show UnexpectedResponse where show = HC.pretty
instance Exception UnexpectedResponse
#endif
wrapCustomEx :: ( ( HC.Throws UnexpectedResponse
, HC.Throws IOException
) => IO a)
-> (HC.Throws HC.SomeRemoteError => IO a)
wrapCustomEx :: ((Throws UnexpectedResponse, Throws IOException) => IO a)
-> Throws SomeRemoteError => IO a
wrapCustomEx (Throws UnexpectedResponse, Throws IOException) => IO a
act = (UnexpectedResponse -> IO a)
-> (Throws UnexpectedResponse => IO a) -> IO a
forall e a.
Exception e =>
(e -> IO a) -> (Throws e => IO a) -> IO a
HC.handleChecked (\(UnexpectedResponse
ex :: UnexpectedResponse) -> UnexpectedResponse -> IO a
forall e a. Exception e => e -> IO a
go UnexpectedResponse
ex)
((Throws UnexpectedResponse => IO a) -> IO a)
-> (Throws UnexpectedResponse => IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ (IOException -> IO a) -> (Throws IOException => IO a) -> IO a
forall e a.
Exception e =>
(e -> IO a) -> (Throws e => IO a) -> IO a
HC.handleChecked (\(IOException
ex :: IOException) -> IOException -> IO a
forall e a. Exception e => e -> IO a
go IOException
ex)
((Throws IOException => IO a) -> IO a)
-> (Throws IOException => IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ Throws IOException => IO a
(Throws UnexpectedResponse, Throws IOException) => IO a
act
where
go :: e -> IO a
go e
ex = SomeRemoteError -> IO a
forall e a. (Exception e, Throws e) => e -> IO a
HC.throwChecked (e -> SomeRemoteError
forall e. Exception e => e -> SomeRemoteError
HC.SomeRemoteError e
ex)