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

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

import           Conduit ( ConduitT, ZipSink (..), await, getZipSink )
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
                   ( FileSize (..), Mismatch (..), PantryException (..), SHA256
                   )
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 a. m a -> IO a) -> IO a) -> m a
forall b. ((forall a. m a -> IO a) -> IO b) -> m b
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 :: forall (m :: * -> *) a.
MonadUnliftIO m =>
Request -> (Response () -> ConduitT ByteString Void m a) -> m a
httpSink Request
req = Request -> (Response () -> ConduitM ByteString Void m a) -> m a
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 <- IO Request -> m Request
forall a. IO a -> m a
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 () -> ConduitT 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 -> ConduitT i Void 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
<$> ConduitT ByteString Void m SHA256 -> ZipSink ByteString m SHA256
forall i (m :: * -> *) r. ConduitT i Void m r -> ZipSink i m r
ZipSink (Maybe SHA256 -> ConduitT ByteString Void 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 a b.
ZipSink ByteString m (a -> b)
-> ZipSink ByteString m a -> ZipSink ByteString m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ConduitT ByteString Void m FileSize
-> ZipSink ByteString m FileSize
forall i (m :: * -> *) r. ConduitT i Void m r -> ZipSink i m r
ZipSink (Maybe FileSize -> ConduitT ByteString Void 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 a b.
ZipSink ByteString m (a -> b)
-> ZipSink ByteString m a -> ZipSink ByteString m b
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. 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 <- 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
        { mismatchExpected :: SHA256
mismatchExpected = SHA256
expected
        , mismatchActual :: SHA256
mismatchActual = SHA256
actual
        }
    SHA256 -> ConduitT ByteString o m SHA256
forall a. a -> ConduitT ByteString o m a
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 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 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
                { 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 a. a -> ConduitT ByteString o m a
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 Word
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
                  { 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'