{-# 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 <- IO Manager
getGlobalManager
  HTTP.withResponse (setUserAgent req) manager (run . 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
  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
  httpSink req $ const $ getZipSink $ (,,)
    <$> ZipSink (checkSha msha)
    <*> ZipSink (checkSize msize)
    <*> ZipSink sink
 where
  checkSha :: t SHA256 -> ConduitT ByteString o m SHA256
checkSha t SHA256
mexpected = do
    actual <- ConduitT ByteString o m SHA256
forall (m :: * -> *) o. Monad m => ConduitT ByteString o m SHA256
SHA256.sinkHash
    for_ mexpected $ \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
        }
    pure 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
      mbs <- ConduitT ByteString o m (Maybe ByteString)
forall (m :: * -> *) i o. Monad m => ConduitT i o m (Maybe i)
await
      case 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'