{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Ouroboros.Consensus.Util.CBOR
  ( -- * Incremental parsing in I/O
    IDecodeIO (..)
  , deserialiseIncrementalIO
  , fromIDecode

    -- * Higher-level incremental interface
  , Decoder (..)
  , initDecoderIO

    -- * Decode as FlatTerm
  , decodeAsFlatTerm

    -- * HasFS interaction
  , ReadIncrementalErr (..)
  , readIncremental
  , withStreamIncrementalOffsets

    -- * Encoding/decoding containers
  , decodeList
  , decodeMaybe
  , decodeSeq
  , decodeWithOrigin
  , encodeList
  , encodeMaybe
  , encodeSeq
  , encodeWithOrigin
  ) where

import Cardano.Binary (decodeMaybe, encodeMaybe)
import Cardano.Slotting.Slot
  ( WithOrigin (..)
  , withOriginFromMaybe
  , withOriginToMaybe
  )
import qualified Codec.CBOR.Decoding as CBOR.D
import qualified Codec.CBOR.Encoding as CBOR.E
import qualified Codec.CBOR.FlatTerm as CBOR.F
import qualified Codec.CBOR.Read as CBOR.R
import Control.Exception (assert)
import Control.Monad
import Control.Monad.Except
import Control.Monad.ST
import qualified Control.Monad.ST.Lazy as ST.Lazy
import Data.ByteString (ByteString)
import qualified Data.ByteString as BS
import Data.ByteString.Builder.Extra (defaultChunkSize)
import qualified Data.ByteString.Lazy as LBS
import Data.Foldable (toList)
import Data.IORef
import Data.Sequence.Strict (StrictSeq)
import qualified Data.Sequence.Strict as Seq
import Data.Word (Word64)
import GHC.Stack (HasCallStack)
import Ouroboros.Consensus.Util.IOLike as U
import qualified Streaming as S
import Streaming.Prelude (Of (..), Stream)
import qualified Streaming.Prelude as S
import System.FS.API
import System.FS.CRC (CRC (..), initCRC, updateCRC)

{-------------------------------------------------------------------------------
  Incremental parsing in I/O
-------------------------------------------------------------------------------}

data IDecodeIO a
  = Partial (Maybe ByteString -> IO (IDecodeIO a))
  | Done !ByteString !CBOR.R.ByteOffset a
  | Fail !ByteString !CBOR.R.ByteOffset CBOR.R.DeserialiseFailure

fromIDecode :: CBOR.R.IDecode RealWorld a -> IDecodeIO a
fromIDecode :: forall a. IDecode RealWorld a -> IDecodeIO a
fromIDecode (CBOR.R.Partial Maybe ByteString -> ST RealWorld (IDecode RealWorld a)
k) = (Maybe ByteString -> IO (IDecodeIO a)) -> IDecodeIO a
forall a. (Maybe ByteString -> IO (IDecodeIO a)) -> IDecodeIO a
Partial ((Maybe ByteString -> IO (IDecodeIO a)) -> IDecodeIO a)
-> (Maybe ByteString -> IO (IDecodeIO a)) -> IDecodeIO a
forall a b. (a -> b) -> a -> b
$ (IDecode RealWorld a -> IDecodeIO a)
-> IO (IDecode RealWorld a) -> IO (IDecodeIO a)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap IDecode RealWorld a -> IDecodeIO a
forall a. IDecode RealWorld a -> IDecodeIO a
fromIDecode (IO (IDecode RealWorld a) -> IO (IDecodeIO a))
-> (Maybe ByteString -> IO (IDecode RealWorld a))
-> Maybe ByteString
-> IO (IDecodeIO a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ST RealWorld (IDecode RealWorld a) -> IO (IDecode RealWorld a)
ST (PrimState IO) (IDecode RealWorld a) -> IO (IDecode RealWorld a)
forall a. ST (PrimState IO) a -> IO a
forall (m :: * -> *) a. MonadST m => ST (PrimState m) a -> m a
U.stToIO (ST RealWorld (IDecode RealWorld a) -> IO (IDecode RealWorld a))
-> (Maybe ByteString -> ST RealWorld (IDecode RealWorld a))
-> Maybe ByteString
-> IO (IDecode RealWorld a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe ByteString -> ST RealWorld (IDecode RealWorld a)
k
fromIDecode (CBOR.R.Done ByteString
bs ByteOffset
off a
x) = ByteString -> ByteOffset -> a -> IDecodeIO a
forall a. ByteString -> ByteOffset -> a -> IDecodeIO a
Done ByteString
bs ByteOffset
off a
x
fromIDecode (CBOR.R.Fail ByteString
bs ByteOffset
off DeserialiseFailure
e) = ByteString -> ByteOffset -> DeserialiseFailure -> IDecodeIO a
forall a.
ByteString -> ByteOffset -> DeserialiseFailure -> IDecodeIO a
Fail ByteString
bs ByteOffset
off DeserialiseFailure
e

deserialiseIncrementalIO :: (forall s. CBOR.D.Decoder s a) -> IO (IDecodeIO a)
deserialiseIncrementalIO :: forall a. (forall s. Decoder s a) -> IO (IDecodeIO a)
deserialiseIncrementalIO =
  (IDecode RealWorld a -> IDecodeIO a)
-> IO (IDecode RealWorld a) -> IO (IDecodeIO a)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap IDecode RealWorld a -> IDecodeIO a
forall a. IDecode RealWorld a -> IDecodeIO a
fromIDecode
    (IO (IDecode RealWorld a) -> IO (IDecodeIO a))
-> (Decoder RealWorld a -> IO (IDecode RealWorld a))
-> Decoder RealWorld a
-> IO (IDecodeIO a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ST RealWorld (IDecode RealWorld a) -> IO (IDecode RealWorld a)
ST (PrimState IO) (IDecode RealWorld a) -> IO (IDecode RealWorld a)
forall a. ST (PrimState IO) a -> IO a
forall (m :: * -> *) a. MonadST m => ST (PrimState m) a -> m a
U.stToIO
    (ST RealWorld (IDecode RealWorld a) -> IO (IDecode RealWorld a))
-> (Decoder RealWorld a -> ST RealWorld (IDecode RealWorld a))
-> Decoder RealWorld a
-> IO (IDecode RealWorld a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Decoder RealWorld a -> ST RealWorld (IDecode RealWorld a)
forall s a. Decoder s a -> ST s (IDecode s a)
CBOR.R.deserialiseIncremental

{-------------------------------------------------------------------------------
  Higher-level incremental interface
-------------------------------------------------------------------------------}

data Decoder m = Decoder
  { forall (m :: * -> *).
Decoder m -> forall a. (forall s. Decoder s a) -> m a
decodeNext :: forall a. (forall s. CBOR.D.Decoder s a) -> m a
  -- ^ Decode next failure
  --
  -- May throw 'CBOR.DeserialiseFailure'
  }

-- | Construct incremental decoder given a way to get chunks
--
-- Resulting decoder is not thread safe.
initDecoderIO :: IO ByteString -> IO (Decoder IO)
initDecoderIO :: IO ByteString -> IO (Decoder IO)
initDecoderIO IO ByteString
getChunk = do
  leftover <- ByteString -> IO (IORef ByteString)
forall a. a -> IO (IORef a)
newIORef ByteString
BS.empty
  let go :: forall a. (forall s. CBOR.D.Decoder s a) -> IO a
      go forall s. Decoder s a
decoder = do
        i <- (forall s. Decoder s a) -> IO (IDecodeIO a)
forall a. (forall s. Decoder s a) -> IO (IDecodeIO a)
deserialiseIncrementalIO Decoder s a
forall s. Decoder s a
decoder
        case i of
          Done ByteString
bs ByteOffset
_ a
a -> Bool -> IO a -> IO a
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (ByteString -> Bool
BS.null ByteString
bs) (IO a -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$ a -> IO a
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a
          Fail ByteString
_ ByteOffset
_ DeserialiseFailure
e -> DeserialiseFailure -> IO a
forall e a. Exception e => e -> IO a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO DeserialiseFailure
e
          Partial Maybe ByteString -> IO (IDecodeIO a)
k -> IORef ByteString -> IO ByteString
forall a. IORef a -> IO a
readIORef IORef ByteString
leftover IO ByteString -> (ByteString -> IO a) -> IO a
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Maybe ByteString -> IO (IDecodeIO a)
k (Maybe ByteString -> IO (IDecodeIO a))
-> (ByteString -> Maybe ByteString)
-> ByteString
-> IO (IDecodeIO a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> IO (IDecodeIO a))
-> (IDecodeIO a -> IO a) -> ByteString -> IO a
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> IDecodeIO a -> IO a
forall a. IDecodeIO a -> IO a
goWith)

      goWith :: forall a. IDecodeIO a -> IO a
      goWith (Partial Maybe ByteString -> IO (IDecodeIO a)
k) = IO (Maybe ByteString)
getChunk' IO (Maybe ByteString) -> (Maybe ByteString -> IO a) -> IO a
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Maybe ByteString -> IO (IDecodeIO a)
k (Maybe ByteString -> IO (IDecodeIO a))
-> (IDecodeIO a -> IO a) -> Maybe ByteString -> IO a
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> IDecodeIO a -> IO a
forall a. IDecodeIO a -> IO a
goWith)
      goWith (Done ByteString
bs ByteOffset
_ a
a) = IORef ByteString -> ByteString -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef ByteString
leftover ByteString
bs IO () -> IO a -> IO a
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> a -> IO a
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a
      goWith (Fail ByteString
_ ByteOffset
_ DeserialiseFailure
e) = DeserialiseFailure -> IO a
forall e a. Exception e => e -> IO a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO DeserialiseFailure
e

  return $ Decoder go
 where
  getChunk' :: IO (Maybe ByteString)
  getChunk' :: IO (Maybe ByteString)
getChunk' = ByteString -> Maybe ByteString
checkEmpty (ByteString -> Maybe ByteString)
-> IO ByteString -> IO (Maybe ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO ByteString
getChunk

  checkEmpty :: ByteString -> Maybe ByteString
  checkEmpty :: ByteString -> Maybe ByteString
checkEmpty ByteString
bs
    | ByteString -> Bool
BS.null ByteString
bs = Maybe ByteString
forall a. Maybe a
Nothing
    | Bool
otherwise = ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
bs

{-------------------------------------------------------------------------------
  Decode as FlatTerm
-------------------------------------------------------------------------------}

decodeAsFlatTerm ::
  ByteString ->
  Either CBOR.R.DeserialiseFailure CBOR.F.FlatTerm
decodeAsFlatTerm :: ByteString -> Either DeserialiseFailure FlatTerm
decodeAsFlatTerm ByteString
bs0 =
  (forall s. ST s (Either DeserialiseFailure FlatTerm))
-> Either DeserialiseFailure FlatTerm
forall a. (forall s. ST s a) -> a
ST.Lazy.runST (ExceptT DeserialiseFailure (ST s) FlatTerm
-> ST s (Either DeserialiseFailure FlatTerm)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ByteString -> ExceptT DeserialiseFailure (ST s) FlatTerm
forall s. ByteString -> ExceptT DeserialiseFailure (ST s) FlatTerm
provideInput ByteString
bs0))
 where
  provideInput ::
    ByteString ->
    ExceptT CBOR.R.DeserialiseFailure (ST.Lazy.ST s) CBOR.F.FlatTerm
  provideInput :: forall s. ByteString -> ExceptT DeserialiseFailure (ST s) FlatTerm
provideInput ByteString
bs
    | ByteString -> Bool
BS.null ByteString
bs = FlatTerm -> ExceptT DeserialiseFailure (ST s) FlatTerm
forall a. a -> ExceptT DeserialiseFailure (ST s) a
forall (m :: * -> *) a. Monad m => a -> m a
return []
    | Bool
otherwise = do
        next <- ST s (IDecode s TermToken)
-> ExceptT DeserialiseFailure (ST s) (IDecode s TermToken)
forall (m :: * -> *) a.
Monad m =>
m a -> ExceptT DeserialiseFailure m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
S.lift (ST s (IDecode s TermToken)
 -> ExceptT DeserialiseFailure (ST s) (IDecode s TermToken))
-> ST s (IDecode s TermToken)
-> ExceptT DeserialiseFailure (ST s) (IDecode s TermToken)
forall a b. (a -> b) -> a -> b
$ ST s (IDecode s TermToken) -> ST s (IDecode s TermToken)
forall s a. ST s a -> ST s a
ST.Lazy.strictToLazyST (ST s (IDecode s TermToken) -> ST s (IDecode s TermToken))
-> ST s (IDecode s TermToken) -> ST s (IDecode s TermToken)
forall a b. (a -> b) -> a -> b
$ do
          -- This will always be a 'Partial' here because decodeTermToken
          -- always starts by requesting initial input. Only decoders that
          -- fail or return a value without looking at their input can give
          -- a different initial result.
          idc <- Decoder s TermToken -> ST s (IDecode s TermToken)
forall s a. Decoder s a -> ST s (IDecode s a)
CBOR.R.deserialiseIncremental Decoder s TermToken
forall s. Decoder s TermToken
CBOR.F.decodeTermToken
          let k = IDecode s TermToken
-> Maybe ByteString -> ST s (IDecode s TermToken)
forall s a. IDecode s a -> Maybe ByteString -> ST s (IDecode s a)
fromPartial IDecode s TermToken
idc
          k (Just bs)
        collectOutput next
   where
    fromPartial ::
      CBOR.R.IDecode s a ->
      Maybe ByteString ->
      ST s (CBOR.R.IDecode s a)
    fromPartial :: forall s a. IDecode s a -> Maybe ByteString -> ST s (IDecode s a)
fromPartial IDecode s a
idc = case IDecode s a
idc of
      CBOR.R.Partial Maybe ByteString -> ST s (IDecode s a)
k -> Maybe ByteString -> ST s (IDecode s a)
k
      CBOR.R.Done{} -> [Char] -> Maybe ByteString -> ST s (IDecode s a)
forall a. (?callStack::CallStack) => [Char] -> a
error [Char]
"fromPartial: expected a Partial decoder"
      CBOR.R.Fail{} -> [Char] -> Maybe ByteString -> ST s (IDecode s a)
forall a. (?callStack::CallStack) => [Char] -> a
error [Char]
"fromPartial: expected a Partial decoder"

  collectOutput ::
    CBOR.R.IDecode s CBOR.F.TermToken ->
    ExceptT CBOR.R.DeserialiseFailure (ST.Lazy.ST s) CBOR.F.FlatTerm
  collectOutput :: forall s.
IDecode s TermToken -> ExceptT DeserialiseFailure (ST s) FlatTerm
collectOutput (CBOR.R.Fail ByteString
_ ByteOffset
_ DeserialiseFailure
err) = DeserialiseFailure -> ExceptT DeserialiseFailure (ST s) FlatTerm
forall a. DeserialiseFailure -> ExceptT DeserialiseFailure (ST s) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError DeserialiseFailure
err
  collectOutput (CBOR.R.Partial Maybe ByteString -> ST s (IDecode s TermToken)
k) =
    ST s (IDecode s TermToken)
-> ExceptT DeserialiseFailure (ST s) (IDecode s TermToken)
forall (m :: * -> *) a.
Monad m =>
m a -> ExceptT DeserialiseFailure m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
S.lift (ST s (IDecode s TermToken) -> ST s (IDecode s TermToken)
forall s a. ST s a -> ST s a
ST.Lazy.strictToLazyST (Maybe ByteString -> ST s (IDecode s TermToken)
k Maybe ByteString
forall a. Maybe a
Nothing))
      ExceptT DeserialiseFailure (ST s) (IDecode s TermToken)
-> (IDecode s TermToken
    -> ExceptT DeserialiseFailure (ST s) FlatTerm)
-> ExceptT DeserialiseFailure (ST s) FlatTerm
forall a b.
ExceptT DeserialiseFailure (ST s) a
-> (a -> ExceptT DeserialiseFailure (ST s) b)
-> ExceptT DeserialiseFailure (ST s) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IDecode s TermToken -> ExceptT DeserialiseFailure (ST s) FlatTerm
forall s.
IDecode s TermToken -> ExceptT DeserialiseFailure (ST s) FlatTerm
collectOutput
  collectOutput (CBOR.R.Done ByteString
bs' ByteOffset
_ TermToken
x) = do
    xs <- ByteString -> ExceptT DeserialiseFailure (ST s) FlatTerm
forall s. ByteString -> ExceptT DeserialiseFailure (ST s) FlatTerm
provideInput ByteString
bs'
    return (x : xs)

{-------------------------------------------------------------------------------
  HasFS interaction
-------------------------------------------------------------------------------}

data ReadIncrementalErr
  = -- | Could not deserialise the data
    ReadFailed CBOR.R.DeserialiseFailure
  | -- | Deserialisation was successful, but there was additional data
    TrailingBytes ByteString
  deriving (ReadIncrementalErr -> ReadIncrementalErr -> Bool
(ReadIncrementalErr -> ReadIncrementalErr -> Bool)
-> (ReadIncrementalErr -> ReadIncrementalErr -> Bool)
-> Eq ReadIncrementalErr
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ReadIncrementalErr -> ReadIncrementalErr -> Bool
== :: ReadIncrementalErr -> ReadIncrementalErr -> Bool
$c/= :: ReadIncrementalErr -> ReadIncrementalErr -> Bool
/= :: ReadIncrementalErr -> ReadIncrementalErr -> Bool
Eq, Int -> ReadIncrementalErr -> ShowS
[ReadIncrementalErr] -> ShowS
ReadIncrementalErr -> [Char]
(Int -> ReadIncrementalErr -> ShowS)
-> (ReadIncrementalErr -> [Char])
-> ([ReadIncrementalErr] -> ShowS)
-> Show ReadIncrementalErr
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ReadIncrementalErr -> ShowS
showsPrec :: Int -> ReadIncrementalErr -> ShowS
$cshow :: ReadIncrementalErr -> [Char]
show :: ReadIncrementalErr -> [Char]
$cshowList :: [ReadIncrementalErr] -> ShowS
showList :: [ReadIncrementalErr] -> ShowS
Show)

-- | Read a file incrementally, optionally calculating the CRC checksum.
--
-- NOTE: The 'MonadThrow' constraint is only needed for 'bracket'. This
-- function does not actually throw anything.
--
-- NOTE: This uses a chunk size of roughly 32k. If we use this function to read
-- small things this might not be ideal.
--
-- NOTE: This currently expects the file to contain precisely one value; see also
-- 'withStreamIncrementalOffsets'.
readIncremental ::
  forall m f a.
  (IOLike m, Functor f) =>
  SomeHasFS m ->
  (CRC -> f CRC) ->
  CBOR.D.Decoder (U.PrimState m) a ->
  FsPath ->
  m (Either ReadIncrementalErr (a, f CRC))
readIncremental :: forall (m :: * -> *) (f :: * -> *) a.
(IOLike m, Functor f) =>
SomeHasFS m
-> (CRC -> f CRC)
-> Decoder (PrimState m) a
-> FsPath
-> m (Either ReadIncrementalErr (a, f CRC))
readIncremental = \(SomeHasFS HasFS m h
hasFS) CRC -> f CRC
mkInitCRC Decoder (PrimState m) a
decoder FsPath
fp -> do
  HasFS m h
-> FsPath
-> OpenMode
-> (Handle h -> m (Either ReadIncrementalErr (a, f CRC)))
-> m (Either ReadIncrementalErr (a, f CRC))
forall (m :: * -> *) h a.
(?callStack::CallStack, MonadThrow m) =>
HasFS m h -> FsPath -> OpenMode -> (Handle h -> m a) -> m a
withFile HasFS m h
hasFS FsPath
fp OpenMode
ReadMode ((Handle h -> m (Either ReadIncrementalErr (a, f CRC)))
 -> m (Either ReadIncrementalErr (a, f CRC)))
-> (Handle h -> m (Either ReadIncrementalErr (a, f CRC)))
-> m (Either ReadIncrementalErr (a, f CRC))
forall a b. (a -> b) -> a -> b
$ \Handle h
h ->
    HasFS m h
-> Handle h
-> f CRC
-> IDecode (PrimState m) a
-> m (Either ReadIncrementalErr (a, f CRC))
forall h.
HasFS m h
-> Handle h
-> f CRC
-> IDecode (PrimState m) a
-> m (Either ReadIncrementalErr (a, f CRC))
go HasFS m h
hasFS Handle h
h (CRC -> f CRC
mkInitCRC CRC
initCRC) (IDecode (PrimState m) a
 -> m (Either ReadIncrementalErr (a, f CRC)))
-> m (IDecode (PrimState m) a)
-> m (Either ReadIncrementalErr (a, f CRC))
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ST (PrimState m) (IDecode (PrimState m) a)
-> m (IDecode (PrimState m) a)
forall a. ST (PrimState m) a -> m a
forall (m :: * -> *) a. MonadST m => ST (PrimState m) a -> m a
U.stToIO (Decoder (PrimState m) a
-> ST (PrimState m) (IDecode (PrimState m) a)
forall s a. Decoder s a -> ST s (IDecode s a)
CBOR.R.deserialiseIncremental Decoder (PrimState m) a
decoder)
 where
  go ::
    HasFS m h ->
    Handle h ->
    f CRC ->
    CBOR.R.IDecode (U.PrimState m) a ->
    m (Either ReadIncrementalErr (a, f CRC))
  go :: forall h.
HasFS m h
-> Handle h
-> f CRC
-> IDecode (PrimState m) a
-> m (Either ReadIncrementalErr (a, f CRC))
go hasFS :: HasFS m h
hasFS@HasFS{m [Char]
(?callStack::CallStack) => Bool -> FsPath -> m ()
(?callStack::CallStack) => Handle h -> m Bool
(?callStack::CallStack) => Handle h -> m Word64
(?callStack::CallStack) => Handle h -> m ()
(?callStack::CallStack) => Handle h -> Word64 -> m ()
(?callStack::CallStack) => Handle h -> Word64 -> m ByteString
(?callStack::CallStack) =>
Handle h -> Word64 -> AbsOffset -> m ByteString
(?callStack::CallStack) => Handle h -> ByteString -> m Word64
(?callStack::CallStack) =>
Handle h -> SeekMode -> ByteOffset -> m ()
(?callStack::CallStack) =>
Handle h
-> MutableByteArray (PrimState m)
-> BufferOffset
-> ByteCount
-> m ByteCount
(?callStack::CallStack) =>
Handle h
-> MutableByteArray (PrimState m)
-> BufferOffset
-> ByteCount
-> AbsOffset
-> m ByteCount
(?callStack::CallStack) => FsPath -> m Bool
(?callStack::CallStack) => FsPath -> m ()
(?callStack::CallStack) => FsPath -> m (Set [Char])
(?callStack::CallStack) => FsPath -> FsPath -> m ()
(?callStack::CallStack) => FsPath -> OpenMode -> m (Handle h)
FsPath -> m [Char]
FsPath -> FsErrorPath
dumpState :: m [Char]
hOpen :: (?callStack::CallStack) => FsPath -> OpenMode -> m (Handle h)
hClose :: (?callStack::CallStack) => Handle h -> m ()
hIsOpen :: (?callStack::CallStack) => Handle h -> m Bool
hSeek :: (?callStack::CallStack) =>
Handle h -> SeekMode -> ByteOffset -> m ()
hGetSome :: (?callStack::CallStack) => Handle h -> Word64 -> m ByteString
hGetSomeAt :: (?callStack::CallStack) =>
Handle h -> Word64 -> AbsOffset -> m ByteString
hPutSome :: (?callStack::CallStack) => Handle h -> ByteString -> m Word64
hTruncate :: (?callStack::CallStack) => Handle h -> Word64 -> m ()
hGetSize :: (?callStack::CallStack) => Handle h -> m Word64
createDirectory :: (?callStack::CallStack) => FsPath -> m ()
createDirectoryIfMissing :: (?callStack::CallStack) => Bool -> FsPath -> m ()
listDirectory :: (?callStack::CallStack) => FsPath -> m (Set [Char])
doesDirectoryExist :: (?callStack::CallStack) => FsPath -> m Bool
doesFileExist :: (?callStack::CallStack) => FsPath -> m Bool
removeDirectoryRecursive :: (?callStack::CallStack) => FsPath -> m ()
removeFile :: (?callStack::CallStack) => FsPath -> m ()
renameFile :: (?callStack::CallStack) => FsPath -> FsPath -> m ()
mkFsErrorPath :: FsPath -> FsErrorPath
unsafeToFilePath :: FsPath -> m [Char]
hGetBufSome :: (?callStack::CallStack) =>
Handle h
-> MutableByteArray (PrimState m)
-> BufferOffset
-> ByteCount
-> m ByteCount
hGetBufSomeAt :: (?callStack::CallStack) =>
Handle h
-> MutableByteArray (PrimState m)
-> BufferOffset
-> ByteCount
-> AbsOffset
-> m ByteCount
hPutBufSome :: (?callStack::CallStack) =>
Handle h
-> MutableByteArray (PrimState m)
-> BufferOffset
-> ByteCount
-> m ByteCount
hPutBufSomeAt :: (?callStack::CallStack) =>
Handle h
-> MutableByteArray (PrimState m)
-> BufferOffset
-> ByteCount
-> AbsOffset
-> m ByteCount
hPutBufSomeAt :: forall (m :: * -> *) h.
HasFS m h
-> (?callStack::CallStack) =>
   Handle h
   -> MutableByteArray (PrimState m)
   -> BufferOffset
   -> ByteCount
   -> AbsOffset
   -> m ByteCount
hPutBufSome :: forall (m :: * -> *) h.
HasFS m h
-> (?callStack::CallStack) =>
   Handle h
   -> MutableByteArray (PrimState m)
   -> BufferOffset
   -> ByteCount
   -> m ByteCount
hGetBufSomeAt :: forall (m :: * -> *) h.
HasFS m h
-> (?callStack::CallStack) =>
   Handle h
   -> MutableByteArray (PrimState m)
   -> BufferOffset
   -> ByteCount
   -> AbsOffset
   -> m ByteCount
hGetBufSome :: forall (m :: * -> *) h.
HasFS m h
-> (?callStack::CallStack) =>
   Handle h
   -> MutableByteArray (PrimState m)
   -> BufferOffset
   -> ByteCount
   -> m ByteCount
unsafeToFilePath :: forall (m :: * -> *) h. HasFS m h -> FsPath -> m [Char]
mkFsErrorPath :: forall (m :: * -> *) h. HasFS m h -> FsPath -> FsErrorPath
renameFile :: forall (m :: * -> *) h.
HasFS m h -> (?callStack::CallStack) => FsPath -> FsPath -> m ()
removeFile :: forall (m :: * -> *) h.
HasFS m h -> (?callStack::CallStack) => FsPath -> m ()
removeDirectoryRecursive :: forall (m :: * -> *) h.
HasFS m h -> (?callStack::CallStack) => FsPath -> m ()
doesFileExist :: forall (m :: * -> *) h.
HasFS m h -> (?callStack::CallStack) => FsPath -> m Bool
doesDirectoryExist :: forall (m :: * -> *) h.
HasFS m h -> (?callStack::CallStack) => FsPath -> m Bool
listDirectory :: forall (m :: * -> *) h.
HasFS m h -> (?callStack::CallStack) => FsPath -> m (Set [Char])
createDirectoryIfMissing :: forall (m :: * -> *) h.
HasFS m h -> (?callStack::CallStack) => Bool -> FsPath -> m ()
createDirectory :: forall (m :: * -> *) h.
HasFS m h -> (?callStack::CallStack) => FsPath -> m ()
hGetSize :: forall (m :: * -> *) h.
HasFS m h -> (?callStack::CallStack) => Handle h -> m Word64
hTruncate :: forall (m :: * -> *) h.
HasFS m h -> (?callStack::CallStack) => Handle h -> Word64 -> m ()
hPutSome :: forall (m :: * -> *) h.
HasFS m h
-> (?callStack::CallStack) => Handle h -> ByteString -> m Word64
hGetSomeAt :: forall (m :: * -> *) h.
HasFS m h
-> (?callStack::CallStack) =>
   Handle h -> Word64 -> AbsOffset -> m ByteString
hGetSome :: forall (m :: * -> *) h.
HasFS m h
-> (?callStack::CallStack) => Handle h -> Word64 -> m ByteString
hSeek :: forall (m :: * -> *) h.
HasFS m h
-> (?callStack::CallStack) =>
   Handle h -> SeekMode -> ByteOffset -> m ()
hIsOpen :: forall (m :: * -> *) h.
HasFS m h -> (?callStack::CallStack) => Handle h -> m Bool
hClose :: forall (m :: * -> *) h.
HasFS m h -> (?callStack::CallStack) => Handle h -> m ()
hOpen :: forall (m :: * -> *) h.
HasFS m h
-> (?callStack::CallStack) => FsPath -> OpenMode -> m (Handle h)
dumpState :: forall (m :: * -> *) h. HasFS m h -> m [Char]
..} Handle h
h !f CRC
checksum (CBOR.R.Partial Maybe ByteString -> ST (PrimState m) (IDecode (PrimState m) a)
k) = do
    bs <- (?callStack::CallStack) => Handle h -> Word64 -> m ByteString
Handle h -> Word64 -> m ByteString
hGetSome Handle h
h (Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
defaultChunkSize)
    dec' <- U.stToIO $ k (checkEmpty bs)
    go hasFS h (updateCRC bs <$> checksum) dec'
  go HasFS m h
_ Handle h
_ !f CRC
checksum (CBOR.R.Done ByteString
leftover ByteOffset
_ a
a) =
    Either ReadIncrementalErr (a, f CRC)
-> m (Either ReadIncrementalErr (a, f CRC))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ReadIncrementalErr (a, f CRC)
 -> m (Either ReadIncrementalErr (a, f CRC)))
-> Either ReadIncrementalErr (a, f CRC)
-> m (Either ReadIncrementalErr (a, f CRC))
forall a b. (a -> b) -> a -> b
$
      if ByteString -> Bool
BS.null ByteString
leftover
        then (a, f CRC) -> Either ReadIncrementalErr (a, f CRC)
forall a b. b -> Either a b
Right (a
a, f CRC
checksum)
        else ReadIncrementalErr -> Either ReadIncrementalErr (a, f CRC)
forall a b. a -> Either a b
Left (ReadIncrementalErr -> Either ReadIncrementalErr (a, f CRC))
-> ReadIncrementalErr -> Either ReadIncrementalErr (a, f CRC)
forall a b. (a -> b) -> a -> b
$ ByteString -> ReadIncrementalErr
TrailingBytes ByteString
leftover
  go HasFS m h
_ Handle h
_ f CRC
_ (CBOR.R.Fail ByteString
_ ByteOffset
_ DeserialiseFailure
err) =
    Either ReadIncrementalErr (a, f CRC)
-> m (Either ReadIncrementalErr (a, f CRC))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ReadIncrementalErr (a, f CRC)
 -> m (Either ReadIncrementalErr (a, f CRC)))
-> Either ReadIncrementalErr (a, f CRC)
-> m (Either ReadIncrementalErr (a, f CRC))
forall a b. (a -> b) -> a -> b
$ ReadIncrementalErr -> Either ReadIncrementalErr (a, f CRC)
forall a b. a -> Either a b
Left (ReadIncrementalErr -> Either ReadIncrementalErr (a, f CRC))
-> ReadIncrementalErr -> Either ReadIncrementalErr (a, f CRC)
forall a b. (a -> b) -> a -> b
$ DeserialiseFailure -> ReadIncrementalErr
ReadFailed DeserialiseFailure
err

  checkEmpty :: ByteString -> Maybe ByteString
  checkEmpty :: ByteString -> Maybe ByteString
checkEmpty ByteString
bs
    | ByteString -> Bool
BS.null ByteString
bs = Maybe ByteString
forall a. Maybe a
Nothing
    | Bool
otherwise = ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
bs

-- | Read multiple @a@s incrementally from a file in a streaming way.
--
-- Continuation-passing style to ensure proper closure of the file.
--
-- Reads the offset ('Word64') of the start of each @a@, the size ('Word64')
-- of each @a@, and each @a@ itself. When deserialising fails, it passes all
-- already deserialised @a@s, the error, and the offset after which the
-- failure occurred.
--
-- NOTE: f we introduce user-facing streaming API also, the fact that we are
-- using @streaming@ here should not dictate that we should stick with it
-- later; rather, we should revisit this code at that point.
withStreamIncrementalOffsets ::
  forall m h a r.
  (IOLike m, HasCallStack) =>
  HasFS m h ->
  (forall s. CBOR.D.Decoder s (LBS.ByteString -> a)) ->
  FsPath ->
  (Stream (Of (Word64, (Word64, a))) m (Maybe (ReadIncrementalErr, Word64)) -> m r) ->
  m r
withStreamIncrementalOffsets :: forall (m :: * -> *) h a r.
(IOLike m, ?callStack::CallStack) =>
HasFS m h
-> (forall s. Decoder s (ByteString -> a))
-> FsPath
-> (Stream
      (Of (Word64, (Word64, a))) m (Maybe (ReadIncrementalErr, Word64))
    -> m r)
-> m r
withStreamIncrementalOffsets hasFS :: HasFS m h
hasFS@HasFS{m [Char]
(?callStack::CallStack) => Bool -> FsPath -> m ()
(?callStack::CallStack) => Handle h -> m Bool
(?callStack::CallStack) => Handle h -> m Word64
(?callStack::CallStack) => Handle h -> m ()
(?callStack::CallStack) => Handle h -> Word64 -> m ()
(?callStack::CallStack) => Handle h -> Word64 -> m ByteString
(?callStack::CallStack) =>
Handle h -> Word64 -> AbsOffset -> m ByteString
(?callStack::CallStack) => Handle h -> ByteString -> m Word64
(?callStack::CallStack) =>
Handle h -> SeekMode -> ByteOffset -> m ()
(?callStack::CallStack) =>
Handle h
-> MutableByteArray (PrimState m)
-> BufferOffset
-> ByteCount
-> m ByteCount
(?callStack::CallStack) =>
Handle h
-> MutableByteArray (PrimState m)
-> BufferOffset
-> ByteCount
-> AbsOffset
-> m ByteCount
(?callStack::CallStack) => FsPath -> m Bool
(?callStack::CallStack) => FsPath -> m ()
(?callStack::CallStack) => FsPath -> m (Set [Char])
(?callStack::CallStack) => FsPath -> FsPath -> m ()
(?callStack::CallStack) => FsPath -> OpenMode -> m (Handle h)
FsPath -> m [Char]
FsPath -> FsErrorPath
hPutBufSomeAt :: forall (m :: * -> *) h.
HasFS m h
-> (?callStack::CallStack) =>
   Handle h
   -> MutableByteArray (PrimState m)
   -> BufferOffset
   -> ByteCount
   -> AbsOffset
   -> m ByteCount
hPutBufSome :: forall (m :: * -> *) h.
HasFS m h
-> (?callStack::CallStack) =>
   Handle h
   -> MutableByteArray (PrimState m)
   -> BufferOffset
   -> ByteCount
   -> m ByteCount
hGetBufSomeAt :: forall (m :: * -> *) h.
HasFS m h
-> (?callStack::CallStack) =>
   Handle h
   -> MutableByteArray (PrimState m)
   -> BufferOffset
   -> ByteCount
   -> AbsOffset
   -> m ByteCount
hGetBufSome :: forall (m :: * -> *) h.
HasFS m h
-> (?callStack::CallStack) =>
   Handle h
   -> MutableByteArray (PrimState m)
   -> BufferOffset
   -> ByteCount
   -> m ByteCount
unsafeToFilePath :: forall (m :: * -> *) h. HasFS m h -> FsPath -> m [Char]
mkFsErrorPath :: forall (m :: * -> *) h. HasFS m h -> FsPath -> FsErrorPath
renameFile :: forall (m :: * -> *) h.
HasFS m h -> (?callStack::CallStack) => FsPath -> FsPath -> m ()
removeFile :: forall (m :: * -> *) h.
HasFS m h -> (?callStack::CallStack) => FsPath -> m ()
removeDirectoryRecursive :: forall (m :: * -> *) h.
HasFS m h -> (?callStack::CallStack) => FsPath -> m ()
doesFileExist :: forall (m :: * -> *) h.
HasFS m h -> (?callStack::CallStack) => FsPath -> m Bool
doesDirectoryExist :: forall (m :: * -> *) h.
HasFS m h -> (?callStack::CallStack) => FsPath -> m Bool
listDirectory :: forall (m :: * -> *) h.
HasFS m h -> (?callStack::CallStack) => FsPath -> m (Set [Char])
createDirectoryIfMissing :: forall (m :: * -> *) h.
HasFS m h -> (?callStack::CallStack) => Bool -> FsPath -> m ()
createDirectory :: forall (m :: * -> *) h.
HasFS m h -> (?callStack::CallStack) => FsPath -> m ()
hGetSize :: forall (m :: * -> *) h.
HasFS m h -> (?callStack::CallStack) => Handle h -> m Word64
hTruncate :: forall (m :: * -> *) h.
HasFS m h -> (?callStack::CallStack) => Handle h -> Word64 -> m ()
hPutSome :: forall (m :: * -> *) h.
HasFS m h
-> (?callStack::CallStack) => Handle h -> ByteString -> m Word64
hGetSomeAt :: forall (m :: * -> *) h.
HasFS m h
-> (?callStack::CallStack) =>
   Handle h -> Word64 -> AbsOffset -> m ByteString
hGetSome :: forall (m :: * -> *) h.
HasFS m h
-> (?callStack::CallStack) => Handle h -> Word64 -> m ByteString
hSeek :: forall (m :: * -> *) h.
HasFS m h
-> (?callStack::CallStack) =>
   Handle h -> SeekMode -> ByteOffset -> m ()
hIsOpen :: forall (m :: * -> *) h.
HasFS m h -> (?callStack::CallStack) => Handle h -> m Bool
hClose :: forall (m :: * -> *) h.
HasFS m h -> (?callStack::CallStack) => Handle h -> m ()
hOpen :: forall (m :: * -> *) h.
HasFS m h
-> (?callStack::CallStack) => FsPath -> OpenMode -> m (Handle h)
dumpState :: forall (m :: * -> *) h. HasFS m h -> m [Char]
dumpState :: m [Char]
hOpen :: (?callStack::CallStack) => FsPath -> OpenMode -> m (Handle h)
hClose :: (?callStack::CallStack) => Handle h -> m ()
hIsOpen :: (?callStack::CallStack) => Handle h -> m Bool
hSeek :: (?callStack::CallStack) =>
Handle h -> SeekMode -> ByteOffset -> m ()
hGetSome :: (?callStack::CallStack) => Handle h -> Word64 -> m ByteString
hGetSomeAt :: (?callStack::CallStack) =>
Handle h -> Word64 -> AbsOffset -> m ByteString
hPutSome :: (?callStack::CallStack) => Handle h -> ByteString -> m Word64
hTruncate :: (?callStack::CallStack) => Handle h -> Word64 -> m ()
hGetSize :: (?callStack::CallStack) => Handle h -> m Word64
createDirectory :: (?callStack::CallStack) => FsPath -> m ()
createDirectoryIfMissing :: (?callStack::CallStack) => Bool -> FsPath -> m ()
listDirectory :: (?callStack::CallStack) => FsPath -> m (Set [Char])
doesDirectoryExist :: (?callStack::CallStack) => FsPath -> m Bool
doesFileExist :: (?callStack::CallStack) => FsPath -> m Bool
removeDirectoryRecursive :: (?callStack::CallStack) => FsPath -> m ()
removeFile :: (?callStack::CallStack) => FsPath -> m ()
renameFile :: (?callStack::CallStack) => FsPath -> FsPath -> m ()
mkFsErrorPath :: FsPath -> FsErrorPath
unsafeToFilePath :: FsPath -> m [Char]
hGetBufSome :: (?callStack::CallStack) =>
Handle h
-> MutableByteArray (PrimState m)
-> BufferOffset
-> ByteCount
-> m ByteCount
hGetBufSomeAt :: (?callStack::CallStack) =>
Handle h
-> MutableByteArray (PrimState m)
-> BufferOffset
-> ByteCount
-> AbsOffset
-> m ByteCount
hPutBufSome :: (?callStack::CallStack) =>
Handle h
-> MutableByteArray (PrimState m)
-> BufferOffset
-> ByteCount
-> m ByteCount
hPutBufSomeAt :: (?callStack::CallStack) =>
Handle h
-> MutableByteArray (PrimState m)
-> BufferOffset
-> ByteCount
-> AbsOffset
-> m ByteCount
..} forall s. Decoder s (ByteString -> a)
decoder FsPath
fp = \Stream
  (Of (Word64, (Word64, a))) m (Maybe (ReadIncrementalErr, Word64))
-> m r
k ->
  HasFS m h -> FsPath -> OpenMode -> (Handle h -> m r) -> m r
forall (m :: * -> *) h a.
(?callStack::CallStack, MonadThrow m) =>
HasFS m h -> FsPath -> OpenMode -> (Handle h -> m a) -> m a
withFile HasFS m h
hasFS FsPath
fp OpenMode
ReadMode ((Handle h -> m r) -> m r) -> (Handle h -> m r) -> m r
forall a b. (a -> b) -> a -> b
$ \Handle h
h -> Stream
  (Of (Word64, (Word64, a))) m (Maybe (ReadIncrementalErr, Word64))
-> m r
k (Stream
   (Of (Word64, (Word64, a))) m (Maybe (ReadIncrementalErr, Word64))
 -> m r)
-> Stream
     (Of (Word64, (Word64, a))) m (Maybe (ReadIncrementalErr, Word64))
-> m r
forall a b. (a -> b) -> a -> b
$ do
    fileSize <- m Word64 -> Stream (Of (Word64, (Word64, a))) m Word64
forall (m :: * -> *) a.
Monad m =>
m a -> Stream (Of (Word64, (Word64, a))) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
S.lift (m Word64 -> Stream (Of (Word64, (Word64, a))) m Word64)
-> m Word64 -> Stream (Of (Word64, (Word64, a))) m Word64
forall a b. (a -> b) -> a -> b
$ (?callStack::CallStack) => Handle h -> m Word64
Handle h -> m Word64
hGetSize Handle h
h
    if fileSize == 0
      then
        -- If the file is empty, we will immediately get "end of input"
        return Nothing
      else
        S.lift (U.stToIO (CBOR.R.deserialiseIncremental decoder))
          >>= go h 0 Nothing [] fileSize
 where
  -- TODO stream from HasFS?
  go ::
    Handle h ->
    Word64 ->
    -- \^ Offset
    Maybe ByteString ->
    -- \^ Unconsumed bytes from last time
    [ByteString] ->
    -- \^ Chunks pushed for this item (rev order)
    Word64 ->
    -- \^ Total file size
    CBOR.R.IDecode (U.PrimState m) (LBS.ByteString -> a) ->
    Stream (Of (Word64, (Word64, a))) m (Maybe (ReadIncrementalErr, Word64))
  go :: Handle h
-> Word64
-> Maybe ByteString
-> [ByteString]
-> Word64
-> IDecode (PrimState m) (ByteString -> a)
-> Stream
     (Of (Word64, (Word64, a))) m (Maybe (ReadIncrementalErr, Word64))
go Handle h
h Word64
offset Maybe ByteString
mbUnconsumed [ByteString]
bss Word64
fileSize IDecode (PrimState m) (ByteString -> a)
dec = case IDecode (PrimState m) (ByteString -> a)
dec of
    CBOR.R.Partial Maybe ByteString
-> ST (PrimState m) (IDecode (PrimState m) (ByteString -> a))
k -> do
      -- First use the unconsumed bytes from a previous read before read
      -- some more bytes from the file.
      bs <- case Maybe ByteString
mbUnconsumed of
        Just ByteString
unconsumed -> ByteString -> Stream (Of (Word64, (Word64, a))) m ByteString
forall a. a -> Stream (Of (Word64, (Word64, a))) m a
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
unconsumed
        Maybe ByteString
Nothing -> m ByteString -> Stream (Of (Word64, (Word64, a))) m ByteString
forall (m :: * -> *) a.
Monad m =>
m a -> Stream (Of (Word64, (Word64, a))) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
S.lift (m ByteString -> Stream (Of (Word64, (Word64, a))) m ByteString)
-> m ByteString -> Stream (Of (Word64, (Word64, a))) m ByteString
forall a b. (a -> b) -> a -> b
$ (?callStack::CallStack) => Handle h -> Word64 -> m ByteString
Handle h -> Word64 -> m ByteString
hGetSome Handle h
h (Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
defaultChunkSize)
      dec' <- S.lift $ U.stToIO $ k (checkEmpty bs)
      go h offset Nothing (bs : bss) fileSize dec'
    CBOR.R.Done ByteString
leftover ByteOffset
size ByteString -> a
mkA -> do
      let nextOffset :: Word64
nextOffset = Word64
offset Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ ByteOffset -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral ByteOffset
size
          -- We've been keeping track of the bytes pushed into the decoder
          -- for this item so far in bss. Now there's some trailing data to
          -- remove and we can get the whole bytes used for this item. We
          -- supply the bytes to the final decoded value. This is to support
          -- annotating values with their original input bytes.
          aBytes :: ByteString
aBytes = case [ByteString]
bss of
            [] -> ByteString
LBS.empty
            ByteString
bs : [ByteString]
bss' -> [ByteString] -> ByteString
LBS.fromChunks ([ByteString] -> [ByteString]
forall a. [a] -> [a]
reverse (ByteString
bs' ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
: [ByteString]
bss'))
             where
              bs' :: ByteString
bs' = Int -> ByteString -> ByteString
BS.take (ByteString -> Int
BS.length ByteString
bs Int -> Int -> Int
forall a. Num a => a -> a -> a
- ByteString -> Int
BS.length ByteString
leftover) ByteString
bs
          -- The bang on the @a'@ here allows the used 'Decoder' to force
          -- its computation. For example, the decoder might decode a whole
          -- block and then (maybe through a use of 'fmap') just return its
          -- hash. If we don't force the value it returned here, we're just
          -- putting a thunk that references the whole block in the list
          -- instead of merely the hash.
          !a :: a
a = ByteString -> a
mkA ByteString
aBytes
      (Word64, (Word64, a)) -> Stream (Of (Word64, (Word64, a))) m ()
forall (m :: * -> *) a. Monad m => a -> Stream (Of a) m ()
S.yield (Word64
offset, (ByteOffset -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral ByteOffset
size, a
a))
      case ByteString -> Maybe ByteString
checkEmpty ByteString
leftover of
        Maybe ByteString
Nothing
          | Word64
nextOffset Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== Word64
fileSize ->
              -- We're at the end of the file, so stop
              Maybe (ReadIncrementalErr, Word64)
-> Stream
     (Of (Word64, (Word64, a))) m (Maybe (ReadIncrementalErr, Word64))
forall a. a -> Stream (Of (Word64, (Word64, a))) m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (ReadIncrementalErr, Word64)
forall a. Maybe a
Nothing
        -- Some more bytes, so try to read the next @a@.
        Maybe ByteString
mbLeftover ->
          m (IDecode (PrimState m) (ByteString -> a))
-> Stream
     (Of (Word64, (Word64, a)))
     m
     (IDecode (PrimState m) (ByteString -> a))
forall (m :: * -> *) a.
Monad m =>
m a -> Stream (Of (Word64, (Word64, a))) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
S.lift (ST (PrimState m) (IDecode (PrimState m) (ByteString -> a))
-> m (IDecode (PrimState m) (ByteString -> a))
forall a. ST (PrimState m) a -> m a
forall (m :: * -> *) a. MonadST m => ST (PrimState m) a -> m a
U.stToIO (Decoder (PrimState m) (ByteString -> a)
-> ST (PrimState m) (IDecode (PrimState m) (ByteString -> a))
forall s a. Decoder s a -> ST s (IDecode s a)
CBOR.R.deserialiseIncremental Decoder (PrimState m) (ByteString -> a)
forall s. Decoder s (ByteString -> a)
decoder))
            Stream
  (Of (Word64, (Word64, a)))
  m
  (IDecode (PrimState m) (ByteString -> a))
-> (IDecode (PrimState m) (ByteString -> a)
    -> Stream
         (Of (Word64, (Word64, a))) m (Maybe (ReadIncrementalErr, Word64)))
-> Stream
     (Of (Word64, (Word64, a))) m (Maybe (ReadIncrementalErr, Word64))
forall a b.
Stream (Of (Word64, (Word64, a))) m a
-> (a -> Stream (Of (Word64, (Word64, a))) m b)
-> Stream (Of (Word64, (Word64, a))) m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Handle h
-> Word64
-> Maybe ByteString
-> [ByteString]
-> Word64
-> IDecode (PrimState m) (ByteString -> a)
-> Stream
     (Of (Word64, (Word64, a))) m (Maybe (ReadIncrementalErr, Word64))
go Handle h
h Word64
nextOffset Maybe ByteString
mbLeftover [] Word64
fileSize
    CBOR.R.Fail ByteString
_ ByteOffset
_ DeserialiseFailure
err -> Maybe (ReadIncrementalErr, Word64)
-> Stream
     (Of (Word64, (Word64, a))) m (Maybe (ReadIncrementalErr, Word64))
forall a. a -> Stream (Of (Word64, (Word64, a))) m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (ReadIncrementalErr, Word64)
 -> Stream
      (Of (Word64, (Word64, a))) m (Maybe (ReadIncrementalErr, Word64)))
-> Maybe (ReadIncrementalErr, Word64)
-> Stream
     (Of (Word64, (Word64, a))) m (Maybe (ReadIncrementalErr, Word64))
forall a b. (a -> b) -> a -> b
$ (ReadIncrementalErr, Word64) -> Maybe (ReadIncrementalErr, Word64)
forall a. a -> Maybe a
Just (DeserialiseFailure -> ReadIncrementalErr
ReadFailed DeserialiseFailure
err, Word64
offset)

  checkEmpty :: ByteString -> Maybe ByteString
  checkEmpty :: ByteString -> Maybe ByteString
checkEmpty ByteString
bs
    | ByteString -> Bool
BS.null ByteString
bs = Maybe ByteString
forall a. Maybe a
Nothing
    | Bool
otherwise = ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
bs

{-------------------------------------------------------------------------------
  Encoding/decoding lists
-------------------------------------------------------------------------------}

encodeList :: (a -> CBOR.E.Encoding) -> [a] -> CBOR.E.Encoding
encodeList :: forall a. (a -> Encoding) -> [a] -> Encoding
encodeList a -> Encoding
_ [] = Word -> Encoding
CBOR.E.encodeListLen Word
0
encodeList a -> Encoding
enc [a]
xs =
  [Encoding] -> Encoding
forall a. Monoid a => [a] -> a
mconcat
    [ Encoding
CBOR.E.encodeListLenIndef
    , (a -> Encoding -> Encoding) -> Encoding -> [a] -> Encoding
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\a
x Encoding
r -> a -> Encoding
enc a
x Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Encoding
r) Encoding
CBOR.E.encodeBreak [a]
xs
    ]

decodeList :: CBOR.D.Decoder s a -> CBOR.D.Decoder s [a]
decodeList :: forall s a. Decoder s a -> Decoder s [a]
decodeList Decoder s a
dec = do
  mn <- Decoder s (Maybe Int)
forall s. Decoder s (Maybe Int)
CBOR.D.decodeListLenOrIndef
  case mn of
    Maybe Int
Nothing -> ([a] -> a -> [a])
-> [a] -> ([a] -> [a]) -> Decoder s a -> Decoder s [a]
forall r a r' s.
(r -> a -> r) -> r -> (r -> r') -> Decoder s a -> Decoder s r'
CBOR.D.decodeSequenceLenIndef ((a -> [a] -> [a]) -> [a] -> a -> [a]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (:)) [] [a] -> [a]
forall a. [a] -> [a]
reverse Decoder s a
dec
    Just Int
n -> ([a] -> a -> [a])
-> [a] -> ([a] -> [a]) -> Int -> Decoder s a -> Decoder s [a]
forall r a r' s.
(r -> a -> r)
-> r -> (r -> r') -> Int -> Decoder s a -> Decoder s r'
CBOR.D.decodeSequenceLenN ((a -> [a] -> [a]) -> [a] -> a -> [a]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (:)) [] [a] -> [a]
forall a. [a] -> [a]
reverse Int
n Decoder s a
dec

encodeSeq :: (a -> CBOR.E.Encoding) -> StrictSeq a -> CBOR.E.Encoding
encodeSeq :: forall a. (a -> Encoding) -> StrictSeq a -> Encoding
encodeSeq a -> Encoding
f = (a -> Encoding) -> [a] -> Encoding
forall a. (a -> Encoding) -> [a] -> Encoding
encodeList a -> Encoding
f ([a] -> Encoding)
-> (StrictSeq a -> [a]) -> StrictSeq a -> Encoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StrictSeq a -> [a]
forall a. StrictSeq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList

decodeSeq :: CBOR.D.Decoder s a -> CBOR.D.Decoder s (StrictSeq a)
decodeSeq :: forall s a. Decoder s a -> Decoder s (StrictSeq a)
decodeSeq Decoder s a
f = [a] -> StrictSeq a
forall a. [a] -> StrictSeq a
Seq.fromList ([a] -> StrictSeq a) -> Decoder s [a] -> Decoder s (StrictSeq a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s a -> Decoder s [a]
forall s a. Decoder s a -> Decoder s [a]
decodeList Decoder s a
f

encodeWithOrigin :: (a -> CBOR.E.Encoding) -> WithOrigin a -> CBOR.E.Encoding
encodeWithOrigin :: forall a. (a -> Encoding) -> WithOrigin a -> Encoding
encodeWithOrigin a -> Encoding
f = (a -> Encoding) -> Maybe a -> Encoding
forall a. (a -> Encoding) -> Maybe a -> Encoding
encodeMaybe a -> Encoding
f (Maybe a -> Encoding)
-> (WithOrigin a -> Maybe a) -> WithOrigin a -> Encoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WithOrigin a -> Maybe a
forall t. WithOrigin t -> Maybe t
withOriginToMaybe

decodeWithOrigin :: CBOR.D.Decoder s a -> CBOR.D.Decoder s (WithOrigin a)
decodeWithOrigin :: forall s a. Decoder s a -> Decoder s (WithOrigin a)
decodeWithOrigin Decoder s a
f = Maybe a -> WithOrigin a
forall t. Maybe t -> WithOrigin t
withOriginFromMaybe (Maybe a -> WithOrigin a)
-> Decoder s (Maybe a) -> Decoder s (WithOrigin a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s a -> Decoder s (Maybe a)
forall s a. Decoder s a -> Decoder s (Maybe a)
decodeMaybe Decoder s a
f