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