{-# 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 :: 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 Response () -> ConduitT ByteString Void m a inner = forall (m :: * -> *) a. MonadUnliftIO m => Request -> (Response () -> ConduitT 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 :: 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'