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

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

import Cardano.Binary (DecoderError, decodeFullDecoder, slice)
import Cardano.Chain.Block.Block
  ( ABlockOrBoundary (..),
    fromCBORABlockOrBoundary,
  )
import Cardano.Chain.Slotting (EpochSlots (..))
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
(ParseError -> ParseError -> Bool)
-> (ParseError -> ParseError -> Bool) -> Eq ParseError
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 -> String
(Int -> ParseError -> ShowS)
-> (ParseError -> String)
-> ([ParseError] -> ShowS)
-> Show ParseError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ParseError] -> ShowS
$cshowList :: [ParseError] -> ShowS
show :: ParseError -> String
$cshow :: ParseError -> String
showsPrec :: Int -> ParseError -> ShowS
$cshowsPrec :: Int -> ParseError -> ShowS
Show)

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

      len :: Int64
      len :: Int64
len = ByteString -> Int64
LBS.length ByteString
header
   in do
        (ByteString
h :> ByteStream (ExceptT ParseError ResIO) ()
rest) <- ExceptT
  ParseError
  ResIO
  (Of ByteString (ByteStream (ExceptT ParseError ResIO) ()))
-> ByteStream
     (ExceptT ParseError ResIO)
     (Of ByteString (ByteStream (ExceptT ParseError ResIO) ()))
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ExceptT
   ParseError
   ResIO
   (Of ByteString (ByteStream (ExceptT ParseError ResIO) ()))
 -> ByteStream
      (ExceptT ParseError ResIO)
      (Of ByteString (ByteStream (ExceptT ParseError ResIO) ())))
-> ExceptT
     ParseError
     ResIO
     (Of ByteString (ByteStream (ExceptT ParseError ResIO) ()))
-> ByteStream
     (ExceptT ParseError ResIO)
     (Of ByteString (ByteStream (ExceptT ParseError ResIO) ()))
forall a b. (a -> b) -> a -> b
$ ByteStream
  (ExceptT ParseError ResIO)
  (ByteStream (ExceptT ParseError ResIO) ())
-> ExceptT
     ParseError
     ResIO
     (Of ByteString (ByteStream (ExceptT ParseError ResIO) ()))
forall (m :: * -> *) r.
Monad m =>
ByteStream m r -> m (Of ByteString r)
SBS.toLazy (ByteStream
   (ExceptT ParseError ResIO)
   (ByteStream (ExceptT ParseError ResIO) ())
 -> ExceptT
      ParseError
      ResIO
      (Of ByteString (ByteStream (ExceptT ParseError ResIO) ())))
-> ByteStream
     (ExceptT ParseError ResIO)
     (ByteStream (ExceptT ParseError ResIO) ())
-> ExceptT
     ParseError
     ResIO
     (Of ByteString (ByteStream (ExceptT ParseError ResIO) ()))
forall a b. (a -> b) -> a -> b
$ Int64
-> ByteStream (ExceptT ParseError ResIO) ()
-> ByteStream
     (ExceptT ParseError ResIO)
     (ByteStream (ExceptT ParseError ResIO) ())
forall (m :: * -> *) r.
Monad m =>
Int64 -> ByteStream m r -> ByteStream m (ByteStream m r)
SBS.splitAt Int64
len ByteStream (ExceptT ParseError ResIO) ()
bytes
        if ByteString
h ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
header
          then ByteStream (ExceptT ParseError ResIO) ()
rest
          else ExceptT ParseError ResIO ()
-> ByteStream (ExceptT ParseError ResIO) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ExceptT ParseError ResIO ()
 -> ByteStream (ExceptT ParseError ResIO) ())
-> ExceptT ParseError ResIO ()
-> ByteStream (ExceptT ParseError ResIO) ()
forall a b. (a -> b) -> a -> b
$ ParseError -> ExceptT ParseError ResIO ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> ParseError
ParseErrorMissingHeader String
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
-> String
-> Stream
     (Of (ABlockOrBoundary ByteString)) (ExceptT ParseError ResIO) ()
parseEpochFileWithBoundary EpochSlots
epochSlots String
file = do
  (ByteStream (ExceptT ParseError ResIO) (), Int64, Either String ())
s <-
    (Either DecoderError (ABlockOrBoundary ByteString)
 -> ExceptT ParseError ResIO (ABlockOrBoundary ByteString))
-> Stream
     (Of (Either DecoderError (ABlockOrBoundary ByteString)))
     (ExceptT ParseError ResIO)
     (ByteStream (ExceptT ParseError ResIO) (), Int64, Either String ())
-> Stream
     (Of (ABlockOrBoundary ByteString))
     (ExceptT ParseError ResIO)
     (ByteStream (ExceptT ParseError ResIO) (), Int64, Either String ())
forall (m :: * -> *) a b r.
Monad m =>
(a -> m b) -> Stream (Of a) m r -> Stream (Of b) m r
S.mapM Either DecoderError (ABlockOrBoundary ByteString)
-> ExceptT ParseError ResIO (ABlockOrBoundary ByteString)
forall a. Either DecoderError a -> ExceptT ParseError ResIO a
liftDecoderError (Stream
   (Of (Either DecoderError (ABlockOrBoundary ByteString)))
   (ExceptT ParseError ResIO)
   (ByteStream (ExceptT ParseError ResIO) (), Int64, Either String ())
 -> Stream
      (Of (ABlockOrBoundary ByteString))
      (ExceptT ParseError ResIO)
      (ByteStream (ExceptT ParseError ResIO) (), Int64,
       Either String ()))
-> Stream
     (Of (Either DecoderError (ABlockOrBoundary ByteString)))
     (ExceptT ParseError ResIO)
     (ByteStream (ExceptT ParseError ResIO) (), Int64, Either String ())
-> Stream
     (Of (ABlockOrBoundary ByteString))
     (ExceptT ParseError ResIO)
     (ByteStream (ExceptT ParseError ResIO) (), Int64, Either String ())
forall a b. (a -> b) -> a -> b
$
      Get (Either DecoderError (ABlockOrBoundary ByteString))
-> ByteStream (ExceptT ParseError ResIO) ()
-> Stream
     (Of (Either DecoderError (ABlockOrBoundary ByteString)))
     (ExceptT ParseError ResIO)
     (ByteStream (ExceptT ParseError ResIO) (), Int64, Either String ())
forall (m :: * -> *) a r.
Monad m =>
Get a
-> ByteString m r
-> Stream (Of a) m (ByteString m r, Int64, Either String r)
decodedWith (EpochSlots
-> Get (Either DecoderError (ABlockOrBoundary ByteString))
getSlotData EpochSlots
epochSlots) (ByteStream (ExceptT ParseError ResIO) ()
boundaryBytes ByteStream (ExceptT ParseError ResIO) ()
-> ByteStream (ExceptT ParseError ResIO) ()
-> ByteStream (ExceptT ParseError ResIO) ()
forall a. Semigroup a => a -> a -> a
<> ByteStream (ExceptT ParseError ResIO) ()
bytes)
  (ByteStream (ExceptT ParseError ResIO) (), Int64, Either String ())
-> Stream
     (Of (ABlockOrBoundary ByteString)) (ExceptT ParseError ResIO) ()
forall a.
(a, Int64, Either String ())
-> Stream
     (Of (ABlockOrBoundary ByteString)) (ExceptT ParseError ResIO) ()
liftBinaryError (ByteStream (ExceptT ParseError ResIO) (), Int64, Either String ())
s
  where
    boundaryBytes :: SBS.ByteStream (ExceptT ParseError ResIO) ()
    boundaryBytes :: ByteStream (ExceptT ParseError ResIO) ()
boundaryBytes = do
      let boundaryFile :: String
boundaryFile = String
file String -> ShowS
-<.> String
"boundary"
      Bool
boundaryExists <- IO Bool -> ByteStream (ExceptT ParseError ResIO) Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> ByteStream (ExceptT ParseError ResIO) Bool)
-> IO Bool -> ByteStream (ExceptT ParseError ResIO) Bool
forall a b. (a -> b) -> a -> b
$ String -> IO Bool
doesFileExist String
boundaryFile
      Bool
-> ByteStream (ExceptT ParseError ResIO) ()
-> ByteStream (ExceptT ParseError ResIO) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
boundaryExists (ByteStream (ExceptT ParseError ResIO) ()
 -> ByteStream (ExceptT ParseError ResIO) ())
-> ByteStream (ExceptT ParseError ResIO) ()
-> ByteStream (ExceptT ParseError ResIO) ()
forall a b. (a -> b) -> a -> b
$ String -> ByteStream (ExceptT ParseError ResIO) ()
forall (m :: * -> *). MonadResource m => String -> ByteStream m ()
SBS.readFile String
boundaryFile

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

    liftDecoderError :: Either DecoderError a -> ExceptT ParseError ResIO a
    liftDecoderError :: Either DecoderError a -> ExceptT ParseError ResIO a
liftDecoderError = \case
      Right a
a -> a -> ExceptT ParseError ResIO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
      Left DecoderError
err -> ParseError -> ExceptT ParseError ResIO a
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 :: (a, Int64, Either String ())
-> Stream
     (Of (ABlockOrBoundary ByteString)) (ExceptT ParseError ResIO) ()
liftBinaryError = \case
      (a
_, Int64
_, Right ()) -> ()
-> Stream
     (Of (ABlockOrBoundary ByteString)) (ExceptT ParseError ResIO) ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      (a
_, Int64
offset, Left String
message) ->
        ParseError
-> Stream
     (Of (ABlockOrBoundary ByteString)) (ExceptT ParseError ResIO) ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> Int64 -> Text -> ParseError
ParseErrorBinary String
file Int64
offset (String -> Text
forall a b. ConvertText a b => a -> b
toS String
message))

parseEpochFilesWithBoundary ::
  EpochSlots ->
  [FilePath] ->
  Stream
    (Of (ABlockOrBoundary ByteString))
    (ExceptT ParseError ResIO)
    ()
parseEpochFilesWithBoundary :: EpochSlots
-> [String]
-> Stream
     (Of (ABlockOrBoundary ByteString)) (ExceptT ParseError ResIO) ()
parseEpochFilesWithBoundary EpochSlots
epochSlots [String]
fs =
  (Stream
   (Of (ABlockOrBoundary ByteString)) (ExceptT ParseError ResIO) ()
 -> Stream
      (Of (ABlockOrBoundary ByteString)) (ExceptT ParseError ResIO) ()
 -> Stream
      (Of (ABlockOrBoundary ByteString)) (ExceptT ParseError ResIO) ())
-> Stream
     (Of (ABlockOrBoundary ByteString)) (ExceptT ParseError ResIO) ()
-> [Stream
      (Of (ABlockOrBoundary ByteString)) (ExceptT ParseError ResIO) ()]
-> Stream
     (Of (ABlockOrBoundary ByteString)) (ExceptT ParseError ResIO) ()
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Stream
  (Of (ABlockOrBoundary ByteString)) (ExceptT ParseError ResIO) ()
-> Stream
     (Of (ABlockOrBoundary ByteString)) (ExceptT ParseError ResIO) ()
-> Stream
     (Of (ABlockOrBoundary ByteString)) (ExceptT ParseError ResIO) ()
forall a. Semigroup a => a -> a -> a
(<>) Stream
  (Of (ABlockOrBoundary ByteString)) (ExceptT ParseError ResIO) ()
forall a. Monoid a => a
mempty (EpochSlots
-> String
-> Stream
     (Of (ABlockOrBoundary ByteString)) (ExceptT ParseError ResIO) ()
parseEpochFileWithBoundary EpochSlots
epochSlots (String
 -> Stream
      (Of (ABlockOrBoundary ByteString)) (ExceptT ParseError ResIO) ())
-> [String]
-> [Stream
      (Of (ABlockOrBoundary ByteString)) (ExceptT ParseError ResIO) ()]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String]
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 = ExceptT DecoderError Get (ABlockOrBoundary ByteString)
-> Get (Either DecoderError (ABlockOrBoundary ByteString))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT DecoderError Get (ABlockOrBoundary ByteString)
 -> Get (Either DecoderError (ABlockOrBoundary ByteString)))
-> ExceptT DecoderError Get (ABlockOrBoundary ByteString)
-> Get (Either DecoderError (ABlockOrBoundary ByteString))
forall a b. (a -> b) -> a -> b
$ do
  ByteString
header <- Get ByteString -> ExceptT DecoderError Get ByteString
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Get ByteString -> ExceptT DecoderError Get ByteString)
-> Get ByteString -> ExceptT DecoderError Get ByteString
forall a b. (a -> b) -> a -> b
$ Int64 -> Get ByteString
B.getLazyByteString (ByteString -> Int64
LBS.length ByteString
slotDataHeader)
  Get () -> ExceptT DecoderError Get ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Get () -> ExceptT DecoderError Get ())
-> Get () -> ExceptT DecoderError Get ()
forall a b. (a -> b) -> a -> b
$ Bool -> Get ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (ByteString
header ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
slotDataHeader)
  Word32
blockSize <- Get Word32 -> ExceptT DecoderError Get Word32
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Get Word32
getWord32be
  Word32
undoSize <- Get Word32 -> ExceptT DecoderError Get Word32
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Get Word32
getWord32be
  ABlockOrBoundary ByteString
block <- do
    ByteString
blockBytes <- Get ByteString -> ExceptT DecoderError Get ByteString
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Get ByteString -> ExceptT DecoderError Get ByteString)
-> Get ByteString -> ExceptT DecoderError Get ByteString
forall a b. (a -> b) -> a -> b
$ Int64 -> Get ByteString
B.getLazyByteString (Word32 -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
blockSize)
    ABlockOrBoundary ByteSpan
bb <-
      Get (Either DecoderError (ABlockOrBoundary ByteSpan))
-> ExceptT DecoderError Get (ABlockOrBoundary ByteSpan)
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (Get (Either DecoderError (ABlockOrBoundary ByteSpan))
 -> ExceptT DecoderError Get (ABlockOrBoundary ByteSpan))
-> (Either DecoderError (ABlockOrBoundary ByteSpan)
    -> Get (Either DecoderError (ABlockOrBoundary ByteSpan)))
-> Either DecoderError (ABlockOrBoundary ByteSpan)
-> ExceptT DecoderError Get (ABlockOrBoundary ByteSpan)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Either DecoderError (ABlockOrBoundary ByteSpan)
-> Get (Either DecoderError (ABlockOrBoundary ByteSpan))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either DecoderError (ABlockOrBoundary ByteSpan)
 -> ExceptT DecoderError Get (ABlockOrBoundary ByteSpan))
-> Either DecoderError (ABlockOrBoundary ByteSpan)
-> ExceptT DecoderError Get (ABlockOrBoundary ByteSpan)
forall a b. (a -> b) -> a -> b
$
        Text
-> (forall s. Decoder s (ABlockOrBoundary ByteSpan))
-> ByteString
-> Either DecoderError (ABlockOrBoundary ByteSpan)
forall a.
Text
-> (forall s. Decoder s a) -> ByteString -> Either DecoderError a
decodeFullDecoder
          Text
"ABlockOrBoundary"
          (EpochSlots -> Decoder s (ABlockOrBoundary ByteSpan)
forall s. EpochSlots -> Decoder s (ABlockOrBoundary ByteSpan)
fromCBORABlockOrBoundary EpochSlots
epochSlots)
          ByteString
blockBytes
    ABlockOrBoundary ByteString
-> ExceptT DecoderError Get (ABlockOrBoundary ByteString)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ABlockOrBoundary ByteString
 -> ExceptT DecoderError Get (ABlockOrBoundary ByteString))
-> ABlockOrBoundary ByteString
-> ExceptT DecoderError Get (ABlockOrBoundary ByteString)
forall a b. (a -> b) -> a -> b
$ (ByteSpan -> ByteString)
-> ABlockOrBoundary ByteSpan -> ABlockOrBoundary ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (ByteString -> ByteString
LBS.toStrict (ByteString -> ByteString)
-> (ByteSpan -> ByteString) -> ByteSpan -> ByteString
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
  ExceptT DecoderError Get ByteString -> ExceptT DecoderError Get ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ExceptT DecoderError Get ByteString
 -> ExceptT DecoderError Get ())
-> (Get ByteString -> ExceptT DecoderError Get ByteString)
-> Get ByteString
-> ExceptT DecoderError Get ()
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Get ByteString -> ExceptT DecoderError Get ByteString
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Get ByteString -> ExceptT DecoderError Get ())
-> Get ByteString -> ExceptT DecoderError Get ()
forall a b. (a -> b) -> a -> b
$ Int64 -> Get ByteString
B.getLazyByteString (Word32 -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
undoSize)
  ABlockOrBoundary ByteString
-> ExceptT DecoderError Get (ABlockOrBoundary ByteString)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ABlockOrBoundary ByteString
block