{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}

-- | Implementation of 'HttpLib' using cabal-install's own 'HttpTransport'
module Distribution.Client.Security.HTTP (HttpLib, transportAdapter) where

import Distribution.Solver.Compat.Prelude
import Prelude ()

-- stdlibs

import qualified Data.ByteString.Lazy as BS.L
import qualified Network.HTTP as HTTP
import Network.URI
  ( URI
  )
import System.Directory
  ( getTemporaryDirectory
  )

-- Cabal/cabal-install

import Distribution.Client.HttpUtils
  ( HttpCode
  , HttpTransport (..)
  )
import Distribution.Client.Utils
  ( withTempFileName
  )
import Distribution.Verbosity
  ( Verbosity
  )

-- hackage-security

import qualified Hackage.Security.Client as HC
import Hackage.Security.Client.Repository.HttpLib (HttpLib (..))
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

{-------------------------------------------------------------------------------
  'HttpLib' implementation
-------------------------------------------------------------------------------}

-- | Translate from hackage-security's 'HttpLib' to cabal-install's 'HttpTransport'
--
-- NOTE: The match between these two APIs is currently not perfect:
--
-- * We don't get any response headers back from the 'HttpTransport', so we
--   don't know if the server supports range requests. For now we optimistically
--   assume that it does.
-- * The 'HttpTransport' wants to know where to place the resulting file,
--   whereas the 'HttpLib' expects an 'IO' action which streams the download;
--   the security library then makes sure that the file gets written to a
--   location which is suitable (in particular, to a temporary file in the
--   directory where the file needs to end up, so that it can "finalize" the
--   file simply by doing 'renameFile'). Right now we write the file to a
--   temporary file in the system temp directory here and then read it again
--   to pass it to the security library; this is a problem for two reasons: it
--   is a source of inefficiency; and it means that the security library cannot
--   insist on a minimum download rate (potential security attack).
--   Fixing it however would require changing the 'HttpTransport'.
transportAdapter :: Verbosity -> IO HttpTransport -> HttpLib
transportAdapter :: Verbosity -> IO HttpTransport -> HttpLib
transportAdapter Verbosity
verbosity IO HttpTransport
getTransport =
  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 :: forall a.
Throws SomeRemoteError =>
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 :: forall a.
Throws SomeRemoteError =>
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

-- | Internal generalization of 'get' and 'getRange'
get'
  :: Verbosity
  -> HttpTransport
  -> [HC.HttpRequestHeader]
  -> URI
  -> Maybe (Int, Int)
  -> (HttpCode -> [HC.HttpResponseHeader] -> HC.BodyReader -> IO a)
  -> IO a
get' :: 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)
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

{-------------------------------------------------------------------------------
  Request headers
-------------------------------------------------------------------------------}

mkRangeHeader :: Int -> Int -> HTTP.Header
mkRangeHeader :: Int -> Int -> Header
mkRangeHeader Int
from Int
to = HeaderName -> FilePath -> Header
HTTP.Header HeaderName
HTTP.HdrRange FilePath
rangeHeader
  where
    -- Content-Range header uses inclusive rather than exclusive bounds
    -- See <http://www.w3.org/Protocols/rfc2616/rfc2616-sec14.html>
    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]
mkReqHeaders :: [HttpRequestHeader] -> Maybe (Int, Int) -> [Header]
mkReqHeaders [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
    -- guard against malformed range headers.
    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

    -- Some headers are comma-separated, others need multiple headers for
    -- multiple options.
    --
    -- TODO: Right we just comma-separate all of them.
    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 :: forall a b. Eq a => 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)

    -- modify the first matching element
    modifyAssocList :: Eq a => a -> (b -> b) -> [(a, b)] -> [(a, b)]
    modifyAssocList :: forall a b. Eq a => 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

{-------------------------------------------------------------------------------
  Custom exceptions
-------------------------------------------------------------------------------}

data UnexpectedResponse = UnexpectedResponse URI Int

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

deriving instance Show UnexpectedResponse
instance Exception UnexpectedResponse where displayException :: UnexpectedResponse -> FilePath
displayException = UnexpectedResponse -> FilePath
forall a. Pretty a => a -> FilePath
HC.pretty

wrapCustomEx
  :: ( ( HC.Throws UnexpectedResponse
       , HC.Throws IOException
       )
       => IO a
     )
  -> (HC.Throws HC.SomeRemoteError => IO a)
wrapCustomEx :: forall a.
((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
$
      IO a
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)