{-# 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
(ParseError -> ParseError -> Bool)
-> (ParseError -> ParseError -> Bool) -> Eq ParseError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ParseError -> ParseError -> Bool
== :: ParseError -> ParseError -> Bool
$c/= :: ParseError -> ParseError -> Bool
/= :: 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
$cshowsPrec :: Int -> ParseError -> ShowS
showsPrec :: Int -> ParseError -> ShowS
$cshow :: ParseError -> String
show :: ParseError -> String
$cshowList :: [ParseError] -> ShowS
showList :: [ParseError] -> ShowS
Show)

loadFileWithHeader ::
  FilePath -> LBS.ByteString -> SBS.ByteStream (ExceptT ParseError ResIO) ()
loadFileWithHeader :: String -> ByteString -> ByteString (ExceptT ParseError ResIO) ()
loadFileWithHeader String
file ByteString
header =
  let bytes :: SBS.ByteStream (ExceptT ParseError ResIO) ()
      bytes :: ByteString (ExceptT ParseError ResIO) ()
bytes = String -> ByteString (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
        (h :> rest) <- ExceptT
  ParseError
  ResIO
  (Of ByteString (ByteString (ExceptT ParseError ResIO) ()))
-> ByteStream
     (ExceptT ParseError ResIO)
     (Of ByteString (ByteString (ExceptT ParseError ResIO) ()))
forall (m :: * -> *) a. Monad m => m a -> ByteStream m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ExceptT
   ParseError
   ResIO
   (Of ByteString (ByteString (ExceptT ParseError ResIO) ()))
 -> ByteStream
      (ExceptT ParseError ResIO)
      (Of ByteString (ByteString (ExceptT ParseError ResIO) ())))
-> ExceptT
     ParseError
     ResIO
     (Of ByteString (ByteString (ExceptT ParseError ResIO) ()))
-> ByteStream
     (ExceptT ParseError ResIO)
     (Of ByteString (ByteString (ExceptT ParseError ResIO) ()))
forall a b. (a -> b) -> a -> b
$ ByteStream
  (ExceptT ParseError ResIO)
  (ByteString (ExceptT ParseError ResIO) ())
-> ExceptT
     ParseError
     ResIO
     (Of ByteString (ByteString (ExceptT ParseError ResIO) ()))
forall (m :: * -> *) r.
Monad m =>
ByteStream m r -> m (Of ByteString r)
SBS.toLazy (ByteStream
   (ExceptT ParseError ResIO)
   (ByteString (ExceptT ParseError ResIO) ())
 -> ExceptT
      ParseError
      ResIO
      (Of ByteString (ByteString (ExceptT ParseError ResIO) ())))
-> ByteStream
     (ExceptT ParseError ResIO)
     (ByteString (ExceptT ParseError ResIO) ())
-> ExceptT
     ParseError
     ResIO
     (Of ByteString (ByteString (ExceptT ParseError ResIO) ()))
forall a b. (a -> b) -> a -> b
$ Int64
-> ByteString (ExceptT ParseError ResIO) ()
-> ByteStream
     (ExceptT ParseError ResIO)
     (ByteString (ExceptT ParseError ResIO) ())
forall (m :: * -> *) r.
Monad m =>
Int64 -> ByteStream m r -> ByteStream m (ByteStream m r)
SBS.splitAt Int64
len ByteString (ExceptT ParseError ResIO) ()
bytes
        if h == header
          then rest
          else lift $ throwError (ParseErrorMissingHeader 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
  s <-
    (Either DecoderError (ABlockOrBoundary ByteString)
 -> ExceptT ParseError ResIO (ABlockOrBoundary ByteString))
-> Stream
     (Of (Either DecoderError (ABlockOrBoundary ByteString)))
     (ExceptT ParseError ResIO)
     (ByteString (ExceptT ParseError ResIO) (), Int64, Either String ())
-> Stream
     (Of (ABlockOrBoundary ByteString))
     (ExceptT ParseError ResIO)
     (ByteString (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)
   (ByteString (ExceptT ParseError ResIO) (), Int64, Either String ())
 -> Stream
      (Of (ABlockOrBoundary ByteString))
      (ExceptT ParseError ResIO)
      (ByteString (ExceptT ParseError ResIO) (), Int64,
       Either String ()))
-> Stream
     (Of (Either DecoderError (ABlockOrBoundary ByteString)))
     (ExceptT ParseError ResIO)
     (ByteString (ExceptT ParseError ResIO) (), Int64, Either String ())
-> Stream
     (Of (ABlockOrBoundary ByteString))
     (ExceptT ParseError ResIO)
     (ByteString (ExceptT ParseError ResIO) (), Int64, Either String ())
forall a b. (a -> b) -> a -> b
$ Get (Either DecoderError (ABlockOrBoundary ByteString))
-> ByteString (ExceptT ParseError ResIO) ()
-> Stream
     (Of (Either DecoderError (ABlockOrBoundary ByteString)))
     (ExceptT ParseError ResIO)
     (ByteString (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) (ByteString (ExceptT ParseError ResIO) ()
boundaryBytes ByteString (ExceptT ParseError ResIO) ()
-> ByteString (ExceptT ParseError ResIO) ()
-> ByteString (ExceptT ParseError ResIO) ()
forall a. Semigroup a => a -> a -> a
<> ByteString (ExceptT ParseError ResIO) ()
bytes)
  liftBinaryError s
  where
    boundaryBytes :: SBS.ByteStream (ExceptT ParseError ResIO) ()
    boundaryBytes :: ByteString (ExceptT ParseError ResIO) ()
boundaryBytes = do
      let boundaryFile :: String
boundaryFile = String
file String -> ShowS
-<.> String
"boundary"
      boundaryExists <- IO Bool -> ByteStream (ExceptT ParseError ResIO) Bool
forall a. IO a -> ByteStream (ExceptT ParseError ResIO) a
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
      when boundaryExists $ SBS.readFile boundaryFile

    bytes :: ByteString (ExceptT ParseError ResIO) ()
bytes = String -> ByteString -> ByteString (ExceptT ParseError ResIO) ()
loadFileWithHeader String
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 -> a -> ExceptT ParseError ResIO a
forall 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 a. 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 :: forall a.
(a, Int64, Either String ())
-> Stream
     (Of (ABlockOrBoundary ByteString)) (ExceptT ParseError ResIO) ()
liftBinaryError = \case
      (a
_, Int64
_, Right ()) -> ()
-> Stream
     (Of (ABlockOrBoundary ByteString)) (ExceptT ParseError ResIO) ()
forall a.
a
-> Stream
     (Of (ABlockOrBoundary ByteString)) (ExceptT ParseError ResIO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      (a
_, Int64
offset, Left String
message) ->
        ParseError
-> Stream
     (Of (ABlockOrBoundary ByteString)) (ExceptT ParseError ResIO) ()
forall a.
ParseError
-> Stream
     (Of (ABlockOrBoundary ByteString)) (ExceptT ParseError ResIO) a
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 a b. (a -> b -> b) -> b -> [a] -> b
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
  header <- Get ByteString -> ExceptT DecoderError Get ByteString
forall (m :: * -> *) a. Monad m => m a -> ExceptT DecoderError m a
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)
  lift $ guard (header == slotDataHeader)
  blockSize <- lift getWord32be
  undoSize <- lift getWord32be
  block <- do
    blockBytes <- lift $ B.getLazyByteString (fromIntegral blockSize)
    bb <-
      ExceptT
        . pure
        $ decodeFullDecoder
          byronProtVer
          "ABlockOrBoundary"
          (decCBORABlockOrBoundary epochSlots)
          blockBytes
    pure $ map (LBS.toStrict . slice blockBytes) bb
  -- Drop the Undo bytes as we no longer use these
  void . lift $ B.getLazyByteString (fromIntegral undoSize)
  pure block