HttpClient.hs

-- Explicitly disabling due to external code {-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE RankNTypes          #-}
{-# LANGUAGE ScopedTypeVariables #-}

-- Adapted from `hackage-security-http-client` to use our own
-- `Pantry.HTTP` implementation
module Hackage.Security.Client.Repository.HttpLib.HttpClient
  ( httpLib
  ) where

import           Control.Exception ( handle )
import           Control.Monad ( void )
import           Data.ByteString ( ByteString )
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BS.C8
import           Hackage.Security.Client ( SomeRemoteError (..) )
import           Hackage.Security.Client.Repository.HttpLib
                   ( BodyReader, HttpLib (..), HttpRequestHeader (..)
                   , HttpResponseHeader (..), HttpStatus (..)
                   )
import           Hackage.Security.Util.Checked
                   ( Throws, handleChecked, throwChecked )
import           Network.URI ( URI )
import qualified Pantry.HTTP as HTTP

{-------------------------------------------------------------------------------
  Top-level API
-------------------------------------------------------------------------------}

-- | An 'HttpLib' value using the default global manager
httpLib :: HttpLib
httpLib = HttpLib
  { httpGet      = get
  , httpGetRange = getRange
  }

{-------------------------------------------------------------------------------
  Individual methods
-------------------------------------------------------------------------------}

get ::
     Throws SomeRemoteError
  => [HttpRequestHeader] -> URI
  -> ([HttpResponseHeader] -> BodyReader -> IO a)
  -> IO a
get reqHeaders uri callback = wrapCustomEx $ do
  -- TODO: setUri fails under certain circumstances; in particular, when
  -- the URI contains URL auth. Not sure if this is a concern.
  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) ""

-- | Wrap custom exceptions
--
-- NOTE: The only other exception defined in @http-client@ is @TimeoutTriggered@
-- but it is currently disabled <https://github.com/snoyberg/http-client/issues/116>
wrapCustomEx ::
     (Throws HTTP.HttpException => IO a)
  -> (Throws SomeRemoteError => IO a)
wrapCustomEx = handleChecked (\(ex :: HTTP.HttpException) -> go ex)
 where
  go ex = throwChecked (SomeRemoteError ex)

checkHttpException :: Throws HTTP.HttpException => IO a -> IO a
checkHttpException = handle $ \(ex :: HTTP.HttpException) ->
                       throwChecked ex

{-------------------------------------------------------------------------------
  http-client auxiliary
-------------------------------------------------------------------------------}

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
  -- Content-Range header uses inclusive rather than exclusive bounds
  -- See <http://www.w3.org/Protocols/rfc2616/rfc2616-sec14.html>
  rangeHeader = BS.C8.pack $ "bytes=" ++ show from ++ "-" ++ show (to - 1)

-- | Set request headers
setRequestHeaders ::
     [HttpRequestHeader]
  -> HTTP.Request
  -> HTTP.Request
setRequestHeaders opts =
  setRequestHeaders' (trOpt disallowCompressionByDefault opts)
 where
  setRequestHeaders' :: [HTTP.Header] -> HTTP.Request -> HTTP.Request
  setRequestHeaders' =
    foldr (\(name, val) f -> f . HTTP.setRequestHeader name [val]) id

  trOpt ::
       [(HTTP.HeaderName, [ByteString])]
    -> [HttpRequestHeader]
    -> [HTTP.Header]
  trOpt acc [] =
    map 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

  -- disable content compression (potential security issue)
  disallowCompressionByDefault :: [(HTTP.HeaderName, [ByteString])]
  disallowCompressionByDefault = [(hAcceptEncoding, [])]

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

-- | Extract the response headers
getResponseHeaders :: HTTP.Response a -> [HttpResponseHeader]
getResponseHeaders response =
  [ HttpResponseAcceptRangesBytes | (hAcceptRanges, "bytes") `elem` headers ]
 where
  headers = HTTP.getResponseHeaders response