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