    {-# LANGUAGE CPP               #-}
    {-# LANGUAGE DeriveLift        #-}
    {-# LANGUAGE LambdaCase        #-}
    {-# LANGUAGE OverloadedStrings #-}

    -- | Types and functions for a client for Casa (Content-addressable Storage

    -- Archive).

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

    import           Casa.Types
                       ( BlobKey (..), blobKeyBinaryParser, blobKeyToBuilder )
    import           Control.Monad ( (>=>), unless )
    import           Control.Monad.Catch ( Exception, MonadThrow (..) )
    import           Control.Monad.IO.Class ( MonadIO )
    import           Control.Monad.IO.Unlift
                       ( MonadUnliftIO, UnliftIO (..), askUnliftIO )
    import           Control.Monad.Trans.Resource ( MonadResource )
    import qualified Crypto.Hash as Crypto
    import           Data.Aeson ( FromJSON (..) )
    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 ( ConduitT, (.|), await, transPipe, yield )
    import           Data.Conduit.Attoparsec ( ParseError, conduitParserEither )
    import           Data.Conduit.ByteString.Builder ( builderToByteString )
    import qualified Data.Conduit.List as CL
    import           Data.HashMap.Strict ( HashMap )
    import qualified Data.HashMap.Strict as HM
    #if !MIN_VERSION_base(4,20,0)
    import           Data.Foldable ( foldl' )
    #endif
    import           Language.Haskell.TH ( Exp, Q )
    import           Language.Haskell.TH.Lift ( Lift (..) )
    import           Network.HTTP.Client.Conduit ( requestBodySourceChunked )
    import           Network.HTTP.Simple
                       ( Request, getResponseBody, getResponseStatus
                       , httpNoBody, httpSource, parseRequest, setRequestBody
                       , setRequestBodyLBS, setRequestMethod
                       )
    import           Network.HTTP.Types ( Status (..) )
    import           Network.URI ( parseURI )

    -- | 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

    instance Exception PullException

    -- | An exception from blob consuming/sending.

    newtype 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

    instance Exception PushException

    -- | The URL prefix for a Casa repository, commonly @https://casa.stackage.org@.

    -- 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 -> Parser String
    forall a. FromJSON a => Value -> Parser a
    parseJSON (Value -> Parser String)
    -> (String -> Parser CasaRepoPrefix)
    -> Value
    -> Parser CasaRepoPrefix
    forall (m :: * -> *) a b c.
    Monad m =>
    (a -> m b) -> (b -> m c) -> a -> m c
    >=> ((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 (Either String CasaRepoPrefix -> Parser CasaRepoPrefix)
    -> (String -> Either String CasaRepoPrefix)
    -> String
    -> Parser CasaRepoPrefix
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> Either String CasaRepoPrefix
    parseCasaRepoPrefix)

    -- | 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 repository. Should be a valid URI e.g. https://casa.stackage.org"
        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. Semigroup a => a -> a -> a
    <> String
    "/" String -> ShowS
    forall a. Semigroup a => a -> a -> a
    <> String
    casaServerVersion String -> ShowS
    forall a. Semigroup 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. Semigroup a => a -> a -> a
    <> String
    "/" String -> ShowS
    forall a. Semigroup a => a -> a -> a
    <> String
    casaServerVersion String -> ShowS
    forall a. Semigroup 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
      runInIO <- m (UnliftIO m)
    forall (m :: * -> *). MonadUnliftIO m => m (UnliftIO m)
    askUnliftIO
      request <- makeRequest runInIO
      response <- httpNoBody request
      case getResponseStatus 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. (HasCallStack, Exception e) => e -> m a
    forall (m :: * -> *) e a.
    (MonadThrow m, HasCallStack, 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
      skeletonRequest <- ConduitT i (BlobKey, ByteString) m Request
    makeSkeletonRequest
      source skeletonRequest scBlobsList .| conduit .| consumer scBlobsSize
     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)))
      scBlobs :: HashMap BlobKey Int
    scBlobs = SourceConfig -> HashMap BlobKey Int
    sourceConfigBlobs SourceConfig
    sourceConfig
      scBlobsList :: [(BlobKey, Int)]
    scBlobsList = HashMap BlobKey Int -> [(BlobKey, Int)]
    forall k v. HashMap k v -> [(k, v)]
    HM.toList HashMap BlobKey Int
    scBlobs
      scBlobsSize :: Int
    scBlobsSize = HashMap BlobKey Int -> Int
    forall k v. HashMap k v -> Int
    HM.size HashMap BlobKey Int
    scBlobs
      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) (ConduitT i ByteString m () -> ConduitT i ByteString m ())
    -> ConduitT i ByteString m () -> ConduitT i ByteString m ()
    forall a b. (a -> b) -> a -> b
    $ 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 ())
      -> ConduitT i ByteString m ())
     -> ConduitT i ByteString m ())
    -> (Response (ConduitT i ByteString m ())
        -> ConduitT i ByteString m ())
    -> ConduitT i ByteString m ()
    forall a b. (a -> b) -> a -> b
    $ \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.
    (HasCallStack, Exception e) =>
    e -> ConduitT i ByteString m a
    forall (m :: * -> *) e a.
    (MonadThrow m, HasCallStack, 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 HashMap BlobKey Int
    scBlobs)
      consumer :: t -> ConduitT (Either ParseError (a, o)) o m ()
    consumer t
    remaining = 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 ConduitT
      (Either ParseError (a, o)) o m (Maybe (Either ParseError (a, o)))
    -> (Maybe (Either ParseError (a, o))
        -> ConduitT (Either ParseError (a, o)) o m ())
    -> ConduitT (Either ParseError (a, o)) o m ()
    forall a b.
    ConduitT (Either ParseError (a, o)) o m a
    -> (a -> ConduitT (Either ParseError (a, o)) o m b)
    -> ConduitT (Either ParseError (a, o)) o m b
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= \case
        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.
    (HasCallStack, Exception e) =>
    e -> ConduitT (Either ParseError (a, o)) o m a
    forall (m :: * -> *) e a.
    (MonadThrow m, HasCallStack, 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.
    (HasCallStack, Exception e) =>
    e -> ConduitT (Either ParseError (a, o)) o m a
    forall (m :: * -> *) e a.
    (MonadThrow m, HasCallStack, Exception e) =>
    e -> m a
    throwM (Int -> PullException
    TooManyReturnedKeys Int
    scBlobsSize)
            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 <- Parser BlobKey
    blobKeyBinaryParser
      case HM.lookup blobKey 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 -> Parser ByteString (BlobKey, ByteString))
    -> String -> Parser ByteString (BlobKey, ByteString)
    forall a b. (a -> b) -> a -> b
    $ 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
          blob <- Int -> Parser ByteString
    Atto.take Int
    len
          if BlobKey (sha256Hash blob) == blobKey
            then pure (blobKey, blob)
            else fail $ "Content does not match SHA256 hash: " <> show 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