{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
module Pantry.HTTP
  ( module Export
  , withResponse
  , httpSink
  , httpSinkChecked
  ) where

import           Conduit
import           Network.HTTP.Client          as Export (parseRequest)
import           Network.HTTP.Client          as Export (parseUrlThrow)
import           Network.HTTP.Client          as Export (BodyReader, HttpExceptionContent (StatusCodeException))
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 :: Request -> (Response BodyReader -> m a) -> m a
withResponse Request
req Response BodyReader -> m a
inner = ((forall a. m a -> IO a) -> IO a) -> m a
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO (((forall a. m a -> IO a) -> IO a) -> m a)
-> ((forall a. m a -> IO a) -> IO a) -> m a
forall a b. (a -> b) -> a -> b
$ \forall a. m a -> IO a
run -> do
  Manager
manager <- IO Manager
getGlobalManager
  Request -> Manager -> (Response BodyReader -> IO a) -> IO a
forall a.
Request -> Manager -> (Response BodyReader -> IO a) -> IO a
HTTP.withResponse (Request -> Request
setUserAgent Request
req) Manager
manager (m a -> IO a
forall a. m a -> IO a
run (m a -> IO a)
-> (Response BodyReader -> m a) -> Response BodyReader -> IO a
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 :: Request -> (Response () -> ConduitT ByteString Void m a) -> m a
httpSink Request
req Response () -> ConduitT ByteString Void m a
inner = Request -> (Response () -> ConduitT ByteString Void m a) -> m a
forall (m :: * -> *) a.
MonadUnliftIO m =>
Request -> (Response () -> ConduitM ByteString Void m a) -> m a
HTTP.httpSink (Request -> Request
setUserAgent Request
req) Response () -> ConduitT ByteString Void m a
inner

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