    {-# LANGUAGE DeriveLift #-}
    {-# LANGUAGE RecordWildCards #-}
    {-# LANGUAGE TupleSections #-}
    {-# LANGUAGE OverloadedStrings #-}

    -- |

    module Casa.Client
      ( blobsSource
      , SourceConfig(..)
      , blobsSink
      , CasaRepoPrefix
      , parseCasaRepoPrefix
      , thParserCasaRepo
      , PushException(..)
      , PullException(..)
      ) where

    import           Casa.Types
    import           Control.Monad
    import           Control.Monad.Catch
    import           Control.Monad.IO.Class
    import           Control.Monad.IO.Unlift
    import           Control.Monad.Trans.Resource
    import qualified Crypto.Hash as Crypto
    import           Data.Aeson
    import qualified Data.Attoparsec.ByteString as Atto
    import qualified Data.ByteArray as Mem
    import           Data.ByteString (ByteString)
    import qualified Data.ByteString as S
    import qualified Data.ByteString.Builder as SB
    import           Data.Conduit
    import           Data.Conduit.Attoparsec
    import           Data.Conduit.ByteString.Builder
    import qualified Data.Conduit.List as CL
    import           Data.HashMap.Strict (HashMap)
    import qualified Data.HashMap.Strict as HM
    import           Data.List
    import           Data.Monoid ((<>))
    import           Data.Typeable
    import           Language.Haskell.TH
    import           Language.Haskell.TH.Lift
    import           Network.HTTP.Client.Conduit (requestBodySourceChunked)
    import           Network.HTTP.Simple
    import           Network.HTTP.Types
    import           Network.URI

    -- | An exception from blob consuming/sending.
    data PullException
      = AttoParseError ParseError
      | BadHttpStatus Status
      | TooManyReturnedKeys Int
      deriving (Int -> PullException -> ShowS
    [PullException] -> ShowS
    PullException -> String
    (Int -> PullException -> ShowS)
    -> (PullException -> String)
    -> ([PullException] -> ShowS)
    -> Show PullException
    forall a.
    (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
    $cshowsPrec :: Int -> PullException -> ShowS
    showsPrec :: Int -> PullException -> ShowS
    $cshow :: PullException -> String
    show :: PullException -> String
    $cshowList :: [PullException] -> ShowS
    showList :: [PullException] -> ShowS
    Show, Typeable)
    instance Exception PullException

    -- | An exception from blob consuming/sending.
    data PushException
      = PushBadHttpStatus Status
      deriving (Int -> PushException -> ShowS
    [PushException] -> ShowS
    PushException -> String
    (Int -> PushException -> ShowS)
    -> (PushException -> String)
    -> ([PushException] -> ShowS)
    -> Show PushException
    forall a.
    (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
    $cshowsPrec :: Int -> PushException -> ShowS
    showsPrec :: Int -> PushException -> ShowS
    $cshow :: PushException -> String
    show :: PushException -> String
    $cshowList :: [PushException] -> ShowS
    showList :: [PushException] -> ShowS
    Show, Typeable)
    instance Exception PushException

    -- | The URL prefix for a casa repo.
    -- Commonly: @https://casa.fpcomplete.com@
    -- Parsers will strip out a trailing slash.
    newtype CasaRepoPrefix =
      CasaRepoPrefix String
      deriving (Int -> CasaRepoPrefix -> ShowS
    [CasaRepoPrefix] -> ShowS
    CasaRepoPrefix -> String
    (Int -> CasaRepoPrefix -> ShowS)
    -> (CasaRepoPrefix -> String)
    -> ([CasaRepoPrefix] -> ShowS)
    -> Show CasaRepoPrefix
    forall a.
    (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
    $cshowsPrec :: Int -> CasaRepoPrefix -> ShowS
    showsPrec :: Int -> CasaRepoPrefix -> ShowS
    $cshow :: CasaRepoPrefix -> String
    show :: CasaRepoPrefix -> String
    $cshowList :: [CasaRepoPrefix] -> ShowS
    showList :: [CasaRepoPrefix] -> ShowS
    Show, (forall (m :: * -> *). Quote m => CasaRepoPrefix -> m Exp)
    -> (forall (m :: * -> *).
        Quote m =>
        CasaRepoPrefix -> Code m CasaRepoPrefix)
    -> Lift CasaRepoPrefix
    forall t.
    (forall (m :: * -> *). Quote m => t -> m Exp)
    -> (forall (m :: * -> *). Quote m => t -> Code m t) -> Lift t
    forall (m :: * -> *). Quote m => CasaRepoPrefix -> m Exp
    forall (m :: * -> *).
    Quote m =>
    CasaRepoPrefix -> Code m CasaRepoPrefix
    $clift :: forall (m :: * -> *). Quote m => CasaRepoPrefix -> m Exp
    lift :: forall (m :: * -> *). Quote m => CasaRepoPrefix -> m Exp
    $cliftTyped :: forall (m :: * -> *).
    Quote m =>
    CasaRepoPrefix -> Code m CasaRepoPrefix
    liftTyped :: forall (m :: * -> *).
    Quote m =>
    CasaRepoPrefix -> Code m CasaRepoPrefix
    Lift)
    instance FromJSON CasaRepoPrefix where
      parseJSON :: Value -> Parser CasaRepoPrefix
    parseJSON Value
    j = do
        String
    s <- Value -> Parser String
    forall a. FromJSON a => Value -> Parser a
    parseJSON Value
    j
        (String -> Parser CasaRepoPrefix)
    -> (CasaRepoPrefix -> Parser CasaRepoPrefix)
    -> Either String CasaRepoPrefix
    -> Parser CasaRepoPrefix
    forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
    either String -> Parser CasaRepoPrefix
    forall a. String -> Parser a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail CasaRepoPrefix -> Parser CasaRepoPrefix
    forall a. a -> Parser a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure (String -> Either String CasaRepoPrefix
    parseCasaRepoPrefix String
    s)

    -- | TH compile-time parser.
    thParserCasaRepo :: String -> Q Exp
    thParserCasaRepo :: String -> Q Exp
    thParserCasaRepo = (String -> Q Exp)
    -> (CasaRepoPrefix -> Q Exp)
    -> Either String CasaRepoPrefix
    -> Q Exp
    forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
    either String -> Q Exp
    forall a. HasCallStack => String -> a
    error CasaRepoPrefix -> Q Exp
    forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
    forall (m :: * -> *). Quote m => CasaRepoPrefix -> m Exp
    lift (Either String CasaRepoPrefix -> Q Exp)
    -> (String -> Either String CasaRepoPrefix) -> String -> Q Exp
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> Either String CasaRepoPrefix
    parseCasaRepoPrefix

    -- | Parse and normalize a Casa repo prefix.
    parseCasaRepoPrefix :: String -> Either String CasaRepoPrefix
    parseCasaRepoPrefix :: String -> Either String CasaRepoPrefix
    parseCasaRepoPrefix String
    s =
      case String -> Maybe URI
    parseURI String
    s of
        Maybe URI
    Nothing ->
          String -> Either String CasaRepoPrefix
    forall a b. a -> Either a b
    Left
            String
    "Invalid URI for repo. Should be a valid URI e.g. https://casa.fpcomplete.com"
        Just {} -> CasaRepoPrefix -> Either String CasaRepoPrefix
    forall a. a -> Either String a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure (String -> CasaRepoPrefix
    CasaRepoPrefix (ShowS
    stripTrailing String
    s))
      where
        stripTrailing :: ShowS
    stripTrailing = ShowS
    forall a. [a] -> [a]
    reverse ShowS -> ShowS -> ShowS
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (Char -> Bool) -> ShowS
    forall a. (a -> Bool) -> [a] -> [a]
    dropWhile (Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    == Char
    '/') ShowS -> ShowS -> ShowS
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . ShowS
    forall a. [a] -> [a]
    reverse

    -- | Used to build request paths.
    casaServerVersion :: String
    casaServerVersion :: String
    casaServerVersion = String
    "v1"

    -- | Build the URL from a repo prefix.
    casaRepoPushUrl :: CasaRepoPrefix -> String
    casaRepoPushUrl :: CasaRepoPrefix -> String
    casaRepoPushUrl (CasaRepoPrefix String
    uri) = String
    uri String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ String
    "/" String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ String
    casaServerVersion String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ String
    "/push"

    -- | Build the URL from a repo prefix.
    casaRepoPullUrl :: CasaRepoPrefix -> String
    casaRepoPullUrl :: CasaRepoPrefix -> String
    casaRepoPullUrl (CasaRepoPrefix String
    uri) = String
    uri String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ String
    "/" String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ String
    casaServerVersion String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ String
    "/pull"

    -- | A sink to push blobs to the server. Throws 'PushException'.
    blobsSink ::
         (MonadIO m, MonadThrow m, MonadUnliftIO m)
      => CasaRepoPrefix
      -> ConduitT () ByteString m ()
      -> m ()
    blobsSink :: forall (m :: * -> *).
    (MonadIO m, MonadThrow m, MonadUnliftIO m) =>
    CasaRepoPrefix -> ConduitT () ByteString m () -> m ()
    blobsSink CasaRepoPrefix
    casaRepoUrl ConduitT () ByteString m ()
    blobs = do
      UnliftIO m
    runInIO <- m (UnliftIO m)
    forall (m :: * -> *). MonadUnliftIO m => m (UnliftIO m)
    askUnliftIO
      Request
    request <- UnliftIO m -> m Request
    forall {f :: * -> *}. MonadThrow f => UnliftIO m -> f Request
    makeRequest UnliftIO m
    runInIO
      Response ()
    response <- Request -> m (Response ())
    forall (m :: * -> *). MonadIO m => Request -> m (Response ())
    httpNoBody Request
    request
      case Response () -> Status
    forall a. Response a -> Status
    getResponseStatus Response ()
    response of
        Status Int
    200 ByteString
    _ -> () -> m ()
    forall a. a -> m a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure ()
        Status
    status -> PushException -> m ()
    forall e a. Exception e => e -> m a
    forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
    throwM (Status -> PushException
    PushBadHttpStatus Status
    status)
      where
        makeRequest :: UnliftIO m -> f Request
    makeRequest (UnliftIO forall a. m a -> IO a
    runInIO) =
          (Request -> Request) -> f Request -> f Request
    forall a b. (a -> b) -> f a -> f b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap
            (RequestBody -> Request -> Request
    setRequestBody
               (ConduitM () ByteString IO () -> RequestBody
    requestBodySourceChunked
                  ((forall a. m a -> IO a)
    -> ConduitT () ByteString m () -> ConduitM () ByteString IO ()
    forall (m :: * -> *) (n :: * -> *) i o r.
    Monad m =>
    (forall a. m a -> n a) -> ConduitT i o m r -> ConduitT i o n r
    transPipe m a -> IO a
    forall a. m a -> IO a
    runInIO ConduitT () ByteString m ()
    blobs ConduitM () ByteString IO ()
    -> ConduitT ByteString ByteString IO ()
    -> ConduitM () ByteString IO ()
    forall (m :: * -> *) a b c r.
    Monad m =>
    ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
    .|
                   (ByteString -> Builder) -> ConduitT ByteString Builder IO ()
    forall (m :: * -> *) a b. Monad m => (a -> b) -> ConduitT a b m ()
    CL.map
                     (\ByteString
    v ->
                        Word64 -> Builder
    SB.word64BE (Int -> Word64
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral (ByteString -> Int
    S.length ByteString
    v)) Builder -> Builder -> Builder
    forall a. Semigroup a => a -> a -> a
    <> ByteString -> Builder
    SB.byteString ByteString
    v) ConduitT ByteString Builder IO ()
    -> ConduitT Builder ByteString IO ()
    -> ConduitT ByteString ByteString IO ()
    forall (m :: * -> *) a b c r.
    Monad m =>
    ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
    .|
                   ConduitT Builder ByteString IO ()
    forall (m :: * -> *).
    PrimMonad m =>
    ConduitT Builder ByteString m ()
    builderToByteString)) (Request -> Request) -> (Request -> Request) -> Request -> Request
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    .
             ByteString -> Request -> Request
    setRequestMethod ByteString
    "POST")
            (String -> f Request
    forall (m :: * -> *). MonadThrow m => String -> m Request
    parseRequest (CasaRepoPrefix -> String
    casaRepoPushUrl CasaRepoPrefix
    casaRepoUrl))

    -- | Configuration for sourcing blobs from the server.
    data SourceConfig =
      SourceConfig
        { SourceConfig -> CasaRepoPrefix
    sourceConfigUrl :: !CasaRepoPrefix
          -- ^ URL to pull from.
        , SourceConfig -> HashMap BlobKey Int
    sourceConfigBlobs :: !(HashMap BlobKey Int)
          -- ^ The blobs to pull.
        , SourceConfig -> Int
    sourceConfigMaxBlobsPerRequest :: !Int
          -- ^ Maximum number of blobs per request; we split requests into
          -- chunks of this number.
        }

    -- | Make a source of blobs from a URL. Throws 'PullException'.
    blobsSource ::
         (MonadThrow m, MonadResource m, MonadIO m)
      => SourceConfig
      -> ConduitT i (BlobKey, ByteString) m ()
    blobsSource :: forall (m :: * -> *) i.
    (MonadThrow m, MonadResource m, MonadIO m) =>
    SourceConfig -> ConduitT i (BlobKey, ByteString) m ()
    blobsSource SourceConfig
    sourceConfig = do
      Request
    skeletonRequest <- ConduitT i (BlobKey, ByteString) m Request
    makeSkeletonRequest
      Request -> [(BlobKey, Int)] -> ConduitT i ByteString m ()
    forall {m :: * -> *} {i}.
    (MonadResource m, MonadThrow m) =>
    Request -> [(BlobKey, Int)] -> ConduitT i ByteString m ()
    source Request
    skeletonRequest (HashMap BlobKey Int -> [(BlobKey, Int)]
    forall k v. HashMap k v -> [(k, v)]
    HM.toList (SourceConfig -> HashMap BlobKey Int
    sourceConfigBlobs SourceConfig
    sourceConfig)) ConduitT i ByteString m ()
    -> ConduitT ByteString (BlobKey, ByteString) m ()
    -> ConduitT i (BlobKey, ByteString) m ()
    forall (m :: * -> *) a b c r.
    Monad m =>
    ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
    .| ConduitT
      ByteString
      (Either ParseError (PositionRange, (BlobKey, ByteString)))
      m
      ()
    conduit ConduitT
      ByteString
      (Either ParseError (PositionRange, (BlobKey, ByteString)))
      m
      ()
    -> ConduitT
         (Either ParseError (PositionRange, (BlobKey, ByteString)))
         (BlobKey, ByteString)
         m
         ()
    -> ConduitT ByteString (BlobKey, ByteString) m ()
    forall (m :: * -> *) a b c r.
    Monad m =>
    ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
    .|
        Int
    -> ConduitT
         (Either ParseError (PositionRange, (BlobKey, ByteString)))
         (BlobKey, ByteString)
         m
         ()
    forall {m :: * -> *} {t} {a} {o}.
    (MonadThrow m, Eq t, Num t) =>
    t -> ConduitT (Either ParseError (a, o)) o m ()
    consumer (HashMap BlobKey Int -> Int
    forall k v. HashMap k v -> Int
    HM.size (SourceConfig -> HashMap BlobKey Int
    sourceConfigBlobs SourceConfig
    sourceConfig))
      where
        makeSkeletonRequest :: ConduitT i (BlobKey, ByteString) m Request
    makeSkeletonRequest =
          (Request -> Request)
    -> ConduitT i (BlobKey, ByteString) m Request
    -> ConduitT i (BlobKey, ByteString) m Request
    forall a b.
    (a -> b)
    -> ConduitT i (BlobKey, ByteString) m a
    -> ConduitT i (BlobKey, ByteString) m b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap
            (ByteString -> Request -> Request
    setRequestMethod ByteString
    "POST")
            (String -> ConduitT i (BlobKey, ByteString) m Request
    forall (m :: * -> *). MonadThrow m => String -> m Request
    parseRequest (CasaRepoPrefix -> String
    casaRepoPullUrl (SourceConfig -> CasaRepoPrefix
    sourceConfigUrl SourceConfig
    sourceConfig)))
        source :: Request -> [(BlobKey, Int)] -> ConduitT i ByteString m ()
    source Request
    skeletonRequest [(BlobKey, Int)]
    blobs =
          Bool -> ConduitT i ByteString m () -> ConduitT i ByteString m ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    unless
            ([(BlobKey, Int)] -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [(BlobKey, Int)]
    blobs)
            (do Request
    -> (Response (ConduitT i ByteString m ())
        -> ConduitT i ByteString m ())
    -> ConduitT i ByteString m ()
    forall (m :: * -> *) (n :: * -> *) i o r.
    (MonadResource m, MonadIO n) =>
    Request
    -> (Response (ConduitM i ByteString n ()) -> ConduitM i o m r)
    -> ConduitM i o m r
    httpSource
                  Request
    filledRequest
                  (\Response (ConduitT i ByteString m ())
    response ->
                     case Response (ConduitT i ByteString m ()) -> Status
    forall a. Response a -> Status
    getResponseStatus Response (ConduitT i ByteString m ())
    response of
                       Status Int
    200 ByteString
    _ -> Response (ConduitT i ByteString m ()) -> ConduitT i ByteString m ()
    forall a. Response a -> a
    getResponseBody Response (ConduitT i ByteString m ())
    response
                       Status
    status -> PullException -> ConduitT i ByteString m ()
    forall e a. Exception e => e -> ConduitT i ByteString m a
    forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
    throwM (Status -> PullException
    BadHttpStatus Status
    status))
                Request -> [(BlobKey, Int)] -> ConduitT i ByteString m ()
    source Request
    skeletonRequest [(BlobKey, Int)]
    remainingBlobs)
          where
            (Request
    filledRequest, [(BlobKey, Int)]
    remainingBlobs) =
              SourceConfig
    -> [(BlobKey, Int)] -> Request -> (Request, [(BlobKey, Int)])
    setRequestBlobs SourceConfig
    sourceConfig [(BlobKey, Int)]
    blobs Request
    skeletonRequest
        conduit :: ConduitT
      ByteString
      (Either ParseError (PositionRange, (BlobKey, ByteString)))
      m
      ()
    conduit =
          Parser ByteString (BlobKey, ByteString)
    -> ConduitT
         ByteString
         (Either ParseError (PositionRange, (BlobKey, ByteString)))
         m
         ()
    forall (m :: * -> *) a b.
    (Monad m, AttoparsecInput a) =>
    Parser a b
    -> ConduitT a (Either ParseError (PositionRange, b)) m ()
    conduitParserEither (HashMap BlobKey Int -> Parser ByteString (BlobKey, ByteString)
    blobKeyValueParser (SourceConfig -> HashMap BlobKey Int
    sourceConfigBlobs SourceConfig
    sourceConfig))
        consumer :: t -> ConduitT (Either ParseError (a, o)) o m ()
    consumer t
    remaining = do
          Maybe (Either ParseError (a, o))
    mkeyValue <- ConduitT
      (Either ParseError (a, o)) o m (Maybe (Either ParseError (a, o)))
    forall (m :: * -> *) i o. Monad m => ConduitT i o m (Maybe i)
    await
          case Maybe (Either ParseError (a, o))
    mkeyValue of
            Maybe (Either ParseError (a, o))
    Nothing -> () -> ConduitT (Either ParseError (a, o)) o m ()
    forall a. a -> ConduitT (Either ParseError (a, o)) o m a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure ()
            Just (Left ParseError
    x) -> PullException -> ConduitT (Either ParseError (a, o)) o m ()
    forall e a.
    Exception e =>
    e -> ConduitT (Either ParseError (a, o)) o m a
    forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
    throwM (ParseError -> PullException
    AttoParseError ParseError
    x)
            Just (Right (a
    _position, o
    keyValue)) ->
              if t
    remaining t -> t -> Bool
    forall a. Eq a => a -> a -> Bool
    == t
    0
                then PullException -> ConduitT (Either ParseError (a, o)) o m ()
    forall e a.
    Exception e =>
    e -> ConduitT (Either ParseError (a, o)) o m a
    forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
    throwM
                       (Int -> PullException
    TooManyReturnedKeys
                          (HashMap BlobKey Int -> Int
    forall k v. HashMap k v -> Int
    HM.size (SourceConfig -> HashMap BlobKey Int
    sourceConfigBlobs SourceConfig
    sourceConfig)))
                else do
                  o -> ConduitT (Either ParseError (a, o)) o m ()
    forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
    yield o
    keyValue
                  t -> ConduitT (Either ParseError (a, o)) o m ()
    consumer (t
    remaining t -> t -> t
    forall a. Num a => a -> a -> a
    - t
    1)

    -- | Fill the body of the request with max blobs per request.
    setRequestBlobs ::
         SourceConfig -> [(BlobKey, Int)] -> Request -> (Request, [(BlobKey, Int)])
    setRequestBlobs :: SourceConfig
    -> [(BlobKey, Int)] -> Request -> (Request, [(BlobKey, Int)])
    setRequestBlobs SourceConfig
    sourceConfig [(BlobKey, Int)]
    blobs Request
    skeletonRequest = (Request
    request, [(BlobKey, Int)]
    remaining)
      where
        request :: Request
    request =
          ByteString -> Request -> Request
    setRequestBodyLBS
            (Builder -> ByteString
    SB.toLazyByteString
               ((Builder -> (BlobKey, Int) -> Builder)
    -> Builder -> [(BlobKey, Int)] -> Builder
    forall b a. (b -> a -> b) -> b -> [a] -> b
    forall (t :: * -> *) b a.
    Foldable t =>
    (b -> a -> b) -> b -> t a -> b
    foldl'
                  (\Builder
    a (BlobKey
    k, Int
    v) ->
                     Builder
    a Builder -> Builder -> Builder
    forall a. Semigroup a => a -> a -> a
    <> (BlobKey -> Builder
    blobKeyToBuilder BlobKey
    k Builder -> Builder -> Builder
    forall a. Semigroup a => a -> a -> a
    <> Word64 -> Builder
    SB.word64BE (Int -> Word64
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral Int
    v)))
                  Builder
    forall a. Monoid a => a
    mempty
                  [(BlobKey, Int)]
    thisBatch))
            Request
    skeletonRequest
        ([(BlobKey, Int)]
    thisBatch, [(BlobKey, Int)]
    remaining) =
          Int -> [(BlobKey, Int)] -> ([(BlobKey, Int)], [(BlobKey, Int)])
    forall a. Int -> [a] -> ([a], [a])
    splitAt (SourceConfig -> Int
    sourceConfigMaxBlobsPerRequest SourceConfig
    sourceConfig) [(BlobKey, Int)]
    blobs

    -- | Parser for a key/value.
    blobKeyValueParser :: HashMap BlobKey Int -> Atto.Parser (BlobKey, ByteString)
    blobKeyValueParser :: HashMap BlobKey Int -> Parser ByteString (BlobKey, ByteString)
    blobKeyValueParser HashMap BlobKey Int
    lengths = do
      BlobKey
    blobKey <- Parser BlobKey
    blobKeyBinaryParser
      case BlobKey -> HashMap BlobKey Int -> Maybe Int
    forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
    HM.lookup BlobKey
    blobKey HashMap BlobKey Int
    lengths of
        Maybe Int
    Nothing -> String -> Parser ByteString (BlobKey, ByteString)
    forall a. String -> Parser ByteString a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail (String
    "Invalid key: " String -> ShowS
    forall a. Semigroup a => a -> a -> a
    <> BlobKey -> String
    forall a. Show a => a -> String
    show BlobKey
    blobKey)
        Just Int
    len -> do
          ByteString
    blob <- (Int -> Parser ByteString
    Atto.take Int
    len)
          if ByteString -> BlobKey
    BlobKey (ByteString -> ByteString
    sha256Hash ByteString
    blob) BlobKey -> BlobKey -> Bool
    forall a. Eq a => a -> a -> Bool
    == BlobKey
    blobKey
            then (BlobKey, ByteString) -> Parser ByteString (BlobKey, ByteString)
    forall a. a -> Parser ByteString a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure (BlobKey
    blobKey, ByteString
    blob)
            else String -> Parser ByteString (BlobKey, ByteString)
    forall a. String -> Parser ByteString a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail (String
    "Content does not match SHA256 hash: " String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ BlobKey -> String
    forall a. Show a => a -> String
    show BlobKey
    blobKey)

    -- | Hash some raw bytes.
    sha256Hash :: ByteString -> ByteString
    sha256Hash :: ByteString -> ByteString
    sha256Hash = Digest SHA256 -> ByteString
    forall bin bout.
    (ByteArrayAccess bin, ByteArray bout) =>
    bin -> bout
    Mem.convert (Digest SHA256 -> ByteString)
    -> (ByteString -> Digest SHA256) -> ByteString -> ByteString
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . SHA256 -> ByteString -> Digest SHA256
    forall ba alg.
    (ByteArrayAccess ba, HashAlgorithm alg) =>
    alg -> ba -> Digest alg
    Crypto.hashWith SHA256
    Crypto.SHA256