{-# 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 :: Request -> Request
setUserAgent = HeaderName -> [ByteString] -> Request -> Request
setRequestHeader HeaderName
"User-Agent" [ByteString
"Haskell pantry package"]

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

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

httpSinkChecked
  :: MonadUnliftIO m
  => Text
  -> Maybe SHA256
  -> Maybe FileSize
  -> ConduitT ByteString Void m a
  -> m (SHA256, FileSize, a)
httpSinkChecked :: forall (m :: * -> *) a.
MonadUnliftIO m =>
Text
-> Maybe SHA256
-> Maybe FileSize
-> ConduitT ByteString Void m a
-> m (SHA256, FileSize, a)
httpSinkChecked Text
url Maybe SHA256
msha Maybe FileSize
msize ConduitT ByteString Void m a
sink = do
  Request
req <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadThrow m => String -> m Request
parseUrlThrow forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
url
  forall (m :: * -> *) a.
MonadUnliftIO m =>
Request -> (Response () -> ConduitT ByteString Void m a) -> m a
httpSink Request
req forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall i (m :: * -> *) r. ZipSink i m r -> ConduitT i Void m r
getZipSink forall a b. (a -> b) -> a -> b
$ (,,)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall i (m :: * -> *) r. ConduitT i Void m r -> ZipSink i m r
ZipSink (forall {m :: * -> *} {t :: * -> *} {o}.
(Foldable t, MonadIO m) =>
t SHA256 -> ConduitT ByteString o m SHA256
checkSha Maybe SHA256
msha)
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall i (m :: * -> *) r. ConduitT i Void m r -> ZipSink i m r
ZipSink (forall {m :: * -> *} {o}.
MonadIO m =>
Maybe FileSize -> ConduitT ByteString o m FileSize
checkSize Maybe FileSize
msize)
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall i (m :: * -> *) r. ConduitT i Void m r -> ZipSink i m r
ZipSink ConduitT ByteString Void m a
sink
 where
  checkSha :: t SHA256 -> ConduitT ByteString o m SHA256
checkSha t SHA256
mexpected = do
    SHA256
actual <- forall (m :: * -> *) o. Monad m => ConduitT ByteString o m SHA256
SHA256.sinkHash
    forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ t SHA256
mexpected forall a b. (a -> b) -> a -> b
$ \SHA256
expected -> forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (SHA256
actual forall a. Eq a => a -> a -> Bool
== SHA256
expected) forall a b. (a -> b) -> a -> b
$
      forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO forall a b. (a -> b) -> a -> b
$ Text -> Mismatch SHA256 -> PantryException
DownloadInvalidSHA256 Text
url Mismatch
        { mismatchExpected :: SHA256
mismatchExpected = SHA256
expected
        , mismatchActual :: SHA256
mismatchActual = SHA256
actual
        }
    forall (f :: * -> *) a. Applicative f => a -> f a
pure SHA256
actual
  checkSize :: Maybe FileSize -> ConduitT ByteString o m FileSize
checkSize Maybe FileSize
mexpected =
    forall {m :: * -> *} {o}.
MonadIO m =>
Word -> ConduitT ByteString o m FileSize
loop Word
0
   where
    loop :: Word -> ConduitT ByteString o m FileSize
loop Word
accum = do
      Maybe ByteString
mbs <- forall (m :: * -> *) i o. Monad m => ConduitT i o m (Maybe i)
await
      case Maybe ByteString
mbs of
        Maybe ByteString
Nothing ->
          case Maybe FileSize
mexpected of
            Just (FileSize Word
expected) | Word
expected forall a. Eq a => a -> a -> Bool
/= Word
accum ->
              forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO forall a b. (a -> b) -> a -> b
$ Text -> Mismatch FileSize -> PantryException
DownloadInvalidSize Text
url Mismatch
                { mismatchExpected :: FileSize
mismatchExpected = Word -> FileSize
FileSize Word
expected
                , mismatchActual :: FileSize
mismatchActual = Word -> FileSize
FileSize Word
accum
                }
            Maybe FileSize
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (Word -> FileSize
FileSize Word
accum)
        Just ByteString
bs -> do
          let accum' :: Word
accum' = Word
accum forall a. Num a => a -> a -> a
+ forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int
B.length ByteString
bs)
          case Maybe FileSize
mexpected of
            Just (FileSize Word
expected)
              | Word
accum' forall a. Ord a => a -> a -> Bool
> Word
expected ->
                forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO forall a b. (a -> b) -> a -> b
$ Text -> Mismatch FileSize -> PantryException
DownloadTooLarge Text
url Mismatch
                  { mismatchExpected :: FileSize
mismatchExpected = Word -> FileSize
FileSize Word
expected
                  , mismatchActual :: FileSize
mismatchActual = Word -> FileSize
FileSize Word
accum'
                  }
            Maybe FileSize
_ -> Word -> ConduitT ByteString o m FileSize
loop Word
accum'