{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}

module Cardano.Chain.Epoch.File (
  mainnetEpochSlots,
  parseEpochFileWithBoundary,
  parseEpochFilesWithBoundary,
  ParseError (..),
)
where

import Cardano.Chain.Block.Block (
  ABlockOrBoundary (..),
  decCBORABlockOrBoundary,
 )
import Cardano.Chain.Slotting (EpochSlots (..))
import Cardano.Ledger.Binary (DecoderError, byronProtVer, decodeFullDecoder, slice)
import Cardano.Prelude
import Control.Monad.Trans.Resource (ResIO)
import qualified Data.Binary as B
import Data.Binary.Get (getWord32be)
import qualified Data.Binary.Get as B
import qualified Data.ByteString.Lazy as LBS
import Data.String (String)
import Streaming.Binary (decodedWith)
import qualified Streaming.ByteString as SBS
import Streaming.Prelude (Of (..), Stream)
import qualified Streaming.Prelude as S
import System.Directory (doesFileExist)
import System.FilePath ((-<.>))

-- Epoch file format:
--
-- EpochFile := "Epoch data v1\n" *SlotData
-- SlotData := "blnd" BlockLength UndoLength Block Undo
-- BlockLength := Word32BE
-- UndoLength := Word32BE
-- Block := CBOR
-- Undo := CBOR

epochHeader :: LBS.ByteString
epochHeader :: ByteString
epochHeader = ByteString
"Epoch data v1\n"

data ParseError
  = -- | The CBOR is invalid
    ParseErrorDecoder !DecoderError
  | ParseErrorBinary !FilePath !B.ByteOffset !Text
  | ParseErrorMissingHeader !FilePath
  deriving (ParseError -> ParseError -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ParseError -> ParseError -> Bool
$c/= :: ParseError -> ParseError -> Bool
== :: ParseError -> ParseError -> Bool
$c== :: ParseError -> ParseError -> Bool
Eq, Int -> ParseError -> ShowS
[ParseError] -> ShowS
ParseError -> FilePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [ParseError] -> ShowS
$cshowList :: [ParseError] -> ShowS
show :: ParseError -> FilePath
$cshow :: ParseError -> FilePath
showsPrec :: Int -> ParseError -> ShowS
$cshowsPrec :: Int -> ParseError -> ShowS
Show)

loadFileWithHeader ::
  FilePath -> LBS.ByteString -> SBS.ByteStream (ExceptT ParseError ResIO) ()
loadFileWithHeader :: FilePath -> ByteString -> ByteString (ExceptT ParseError ResIO) ()
loadFileWithHeader FilePath
file ByteString
header =
  let bytes :: SBS.ByteStream (ExceptT ParseError ResIO) ()
      bytes :: ByteString (ExceptT ParseError ResIO) ()
bytes = forall (m :: * -> *).
MonadResource m =>
FilePath -> ByteStream m ()
SBS.readFile FilePath
file

      len :: Int64
      len :: Int64
len = ByteString -> Int64
LBS.length ByteString
header
   in do
        (ByteString
h :> ByteString (ExceptT ParseError ResIO) ()
rest) <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) r.
Monad m =>
ByteStream m r -> m (Of ByteString r)
SBS.toLazy forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) r.
Monad m =>
Int64 -> ByteStream m r -> ByteStream m (ByteStream m r)
SBS.splitAt Int64
len ByteString (ExceptT ParseError ResIO) ()
bytes
        if ByteString
h forall a. Eq a => a -> a -> Bool
== ByteString
header
          then ByteString (ExceptT ParseError ResIO) ()
rest
          else forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (FilePath -> ParseError
ParseErrorMissingHeader FilePath
file)

-- | Slots per epoch used in mainnet
--
-- This number has been fixed throughout the Byron era.
mainnetEpochSlots :: EpochSlots
mainnetEpochSlots :: EpochSlots
mainnetEpochSlots = Word64 -> EpochSlots
EpochSlots Word64
21600

parseEpochFileWithBoundary ::
  EpochSlots ->
  FilePath ->
  Stream
    (Of (ABlockOrBoundary ByteString))
    (ExceptT ParseError ResIO)
    ()
parseEpochFileWithBoundary :: EpochSlots
-> FilePath
-> Stream
     (Of (ABlockOrBoundary ByteString)) (ExceptT ParseError ResIO) ()
parseEpochFileWithBoundary EpochSlots
epochSlots FilePath
file = do
  (ByteString (ExceptT ParseError ResIO) (), Int64,
 Either FilePath ())
s <-
    forall (m :: * -> *) a b r.
Monad m =>
(a -> m b) -> Stream (Of a) m r -> Stream (Of b) m r
S.mapM forall a. Either DecoderError a -> ExceptT ParseError ResIO a
liftDecoderError
      forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a r.
Monad m =>
Get a
-> ByteString m r
-> Stream (Of a) m (ByteString m r, Int64, Either FilePath r)
decodedWith (EpochSlots
-> Get (Either DecoderError (ABlockOrBoundary ByteString))
getSlotData EpochSlots
epochSlots) (ByteString (ExceptT ParseError ResIO) ()
boundaryBytes forall a. Semigroup a => a -> a -> a
<> ByteString (ExceptT ParseError ResIO) ()
bytes)
  forall a.
(a, Int64, Either FilePath ())
-> Stream
     (Of (ABlockOrBoundary ByteString)) (ExceptT ParseError ResIO) ()
liftBinaryError (ByteString (ExceptT ParseError ResIO) (), Int64,
 Either FilePath ())
s
  where
    boundaryBytes :: SBS.ByteStream (ExceptT ParseError ResIO) ()
    boundaryBytes :: ByteString (ExceptT ParseError ResIO) ()
boundaryBytes = do
      let boundaryFile :: FilePath
boundaryFile = FilePath
file FilePath -> ShowS
-<.> FilePath
"boundary"
      Bool
boundaryExists <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ FilePath -> IO Bool
doesFileExist FilePath
boundaryFile
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
boundaryExists forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadResource m =>
FilePath -> ByteStream m ()
SBS.readFile FilePath
boundaryFile

    bytes :: ByteString (ExceptT ParseError ResIO) ()
bytes = FilePath -> ByteString -> ByteString (ExceptT ParseError ResIO) ()
loadFileWithHeader FilePath
file ByteString
epochHeader

    liftDecoderError :: Either DecoderError a -> ExceptT ParseError ResIO a
    liftDecoderError :: forall a. Either DecoderError a -> ExceptT ParseError ResIO a
liftDecoderError = \case
      Right a
a -> forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
      Left DecoderError
err -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (DecoderError -> ParseError
ParseErrorDecoder DecoderError
err)

    liftBinaryError ::
      (a, B.ByteOffset, Either String ()) ->
      Stream
        (Of (ABlockOrBoundary ByteString))
        (ExceptT ParseError ResIO)
        ()
    liftBinaryError :: forall a.
(a, Int64, Either FilePath ())
-> Stream
     (Of (ABlockOrBoundary ByteString)) (ExceptT ParseError ResIO) ()
liftBinaryError = \case
      (a
_, Int64
_, Right ()) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      (a
_, Int64
offset, Left FilePath
message) ->
        forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (FilePath -> Int64 -> Text -> ParseError
ParseErrorBinary FilePath
file Int64
offset (forall a b. ConvertText a b => a -> b
toS FilePath
message))

parseEpochFilesWithBoundary ::
  EpochSlots ->
  [FilePath] ->
  Stream
    (Of (ABlockOrBoundary ByteString))
    (ExceptT ParseError ResIO)
    ()
parseEpochFilesWithBoundary :: EpochSlots
-> [FilePath]
-> Stream
     (Of (ABlockOrBoundary ByteString)) (ExceptT ParseError ResIO) ()
parseEpochFilesWithBoundary EpochSlots
epochSlots [FilePath]
fs =
  forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall a. Semigroup a => a -> a -> a
(<>) forall a. Monoid a => a
mempty (EpochSlots
-> FilePath
-> Stream
     (Of (ABlockOrBoundary ByteString)) (ExceptT ParseError ResIO) ()
parseEpochFileWithBoundary EpochSlots
epochSlots forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [FilePath]
fs)

slotDataHeader :: LBS.ByteString
slotDataHeader :: ByteString
slotDataHeader = ByteString
"blnd"

getSlotData :: EpochSlots -> B.Get (Either DecoderError (ABlockOrBoundary ByteString))
getSlotData :: EpochSlots
-> Get (Either DecoderError (ABlockOrBoundary ByteString))
getSlotData EpochSlots
epochSlots = forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT forall a b. (a -> b) -> a -> b
$ do
  ByteString
header <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ Int64 -> Get ByteString
B.getLazyByteString (ByteString -> Int64
LBS.length ByteString
slotDataHeader)
  forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *). Alternative f => Bool -> f ()
guard (ByteString
header forall a. Eq a => a -> a -> Bool
== ByteString
slotDataHeader)
  Word32
blockSize <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Get Word32
getWord32be
  Word32
undoSize <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Get Word32
getWord32be
  ABlockOrBoundary ByteString
block <- do
    ByteString
blockBytes <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ Int64 -> Get ByteString
B.getLazyByteString (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
blockSize)
    ABlockOrBoundary ByteSpan
bb <-
      forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT
        forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure
        forall a b. (a -> b) -> a -> b
$ forall a.
Version
-> Text
-> (forall s. Decoder s a)
-> ByteString
-> Either DecoderError a
decodeFullDecoder
          Version
byronProtVer
          Text
"ABlockOrBoundary"
          (forall s. EpochSlots -> Decoder s (ABlockOrBoundary ByteSpan)
decCBORABlockOrBoundary EpochSlots
epochSlots)
          ByteString
blockBytes
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (ByteString -> ByteString
LBS.toStrict forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ByteString -> ByteSpan -> ByteString
slice ByteString
blockBytes) ABlockOrBoundary ByteSpan
bb
  -- Drop the Undo bytes as we no longer use these
  forall (f :: * -> *) a. Functor f => f a -> f ()
void forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ Int64 -> Get ByteString
B.getLazyByteString (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
undoSize)
  forall (f :: * -> *) a. Applicative f => a -> f a
pure ABlockOrBoundary ByteString
block