{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# 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 System.Directory
         ( getTemporaryDirectory )
import Network.URI
         ( URI )
import qualified Data.ByteString.Lazy as BS.L
import qualified Network.HTTP         as HTTP

-- Cabal/cabal-install
import Distribution.Verbosity
         ( Verbosity )
import Distribution.Client.HttpUtils
         ( HttpTransport(..), HttpCode )
import Distribution.Client.Utils
         ( withTempFileName )

-- hackage-security
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

{-------------------------------------------------------------------------------
  '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 :: (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

-- | 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' :: 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 :: 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 :: 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
  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)