{-# 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'