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