HTTP.hs

{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}

module Pantry.HTTP
  ( module Export
  , withResponse
  , httpSink
  , httpSinkChecked
  ) where

import           Conduit
import           Network.HTTP.Client as Export
                   ( BodyReader, HttpExceptionContent (StatusCodeException)
                   , parseRequest, parseUrlThrow
                   )
import qualified Network.HTTP.Client as HTTP ( withResponse )
import           Network.HTTP.Client.Internal as Export ( setUri )
import           Network.HTTP.Client.TLS ( getGlobalManager )
import           Network.HTTP.Simple as Export
                   ( HttpException (..), Request, Response, addRequestHeader
                   , defaultRequest, getResponseBody, getResponseHeaders
                   , getResponseStatus, setRequestHeader
                   )
import qualified Network.HTTP.Simple as HTTP hiding ( withResponse )
import           Network.HTTP.Types as Export
                   ( Header, HeaderName, Status, hCacheControl, hRange, ok200
                   , partialContent206, statusCode
                   )
import qualified Pantry.SHA256 as SHA256
import           Pantry.Types
import           RIO
import qualified RIO.ByteString as B
import qualified RIO.Text as T

setUserAgent :: Request -> Request
setUserAgent = setRequestHeader "User-Agent" ["Haskell pantry package"]

withResponse
  :: MonadUnliftIO m
  => HTTP.Request
  -> (Response BodyReader -> m a)
  -> m a
withResponse req inner = withRunInIO $ \run -> do
  manager <- getGlobalManager
  HTTP.withResponse (setUserAgent req) manager (run . inner)

httpSink
  :: MonadUnliftIO m
  => Request
  -> (Response () -> ConduitT ByteString Void m a)
  -> m a
httpSink req = HTTP.httpSink (setUserAgent req)

httpSinkChecked
  :: MonadUnliftIO m
  => Text
  -> Maybe SHA256
  -> Maybe FileSize
  -> ConduitT ByteString Void m a
  -> m (SHA256, FileSize, a)
httpSinkChecked url msha msize sink = do
  req <- liftIO $ parseUrlThrow $ T.unpack url
  httpSink req $ const $ getZipSink $ (,,)
    <$> ZipSink (checkSha msha)
    <*> ZipSink (checkSize msize)
    <*> ZipSink sink
 where
  checkSha mexpected = do
    actual <- SHA256.sinkHash
    for_ mexpected $ \expected -> unless (actual == expected) $
      throwIO $ DownloadInvalidSHA256 url Mismatch
        { mismatchExpected = expected
        , mismatchActual = actual
        }
    pure actual
  checkSize mexpected =
    loop 0
   where
    loop accum = do
      mbs <- await
      case mbs of
        Nothing ->
          case mexpected of
            Just (FileSize expected) | expected /= accum ->
              throwIO $ DownloadInvalidSize url Mismatch
                { mismatchExpected = FileSize expected
                , mismatchActual = FileSize accum
                }
            _ -> pure (FileSize accum)
        Just bs -> do
          let accum' = accum + fromIntegral (B.length bs)
          case mexpected of
            Just (FileSize expected)
              | accum' > expected ->
                throwIO $ DownloadTooLarge url Mismatch
                  { mismatchExpected = FileSize expected
                  , mismatchActual = FileSize accum'
                  }
            _ -> loop accum'