{-# LANGUAGE DeriveGeneric              #-}
{-# LANGUAGE DerivingStrategies         #-}
{-# LANGUAGE GADTs                      #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE ScopedTypeVariables        #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

module Marconi.Index.ScriptTx where

import Data.ByteString qualified as BS
import Data.Foldable (foldl', toList)
import Data.Functor ((<&>))
import Data.Maybe (catMaybes, fromMaybe)
import Data.Proxy (Proxy (Proxy))
import Database.SQLite.Simple qualified as SQL
import Database.SQLite.Simple.FromField qualified as SQL
import Database.SQLite.Simple.ToField qualified as SQL
import GHC.Generics (Generic)

import Cardano.Api (BlockHeader, ChainPoint (ChainPoint, ChainPointAtGenesis), Hash, SlotNo (SlotNo))
import Cardano.Api qualified as C
import Cardano.Api.Shelley qualified as Shelley
-- TODO Remove the following dependencies (and also cardano-ledger-*
-- package dependencies in cabal file) when fromShelleyBasedScript is
-- exported from cardano-node PR:
-- https://github.com/input-output-hk/cardano-node/pull/4386
import Cardano.Ledger.Alonzo.Language qualified as Alonzo
import Cardano.Ledger.Alonzo.Scripts qualified as Alonzo
import Cardano.Ledger.Core qualified
import Cardano.Ledger.Crypto qualified as LedgerCrypto
import Cardano.Ledger.Keys qualified as LedgerShelley
import Cardano.Ledger.Shelley.Scripts qualified as LedgerShelley
import Cardano.Ledger.ShelleyMA.Timelocks qualified as Timelock

import RewindableIndex.Storable (Buffered (getStoredEvents, persistToStorage), HasPoint (getPoint),
                                 QueryInterval (QEverything, QInterval), Queryable (queryStorage),
                                 Resumable (resumeFromStorage), Rewindable (rewindStorage), StorableEvent,
                                 StorableMonad, StorablePoint, StorableQuery, StorableResult, emptyState,
                                 filterWithQueryInterval)
import RewindableIndex.Storable qualified as Storable

{- The first thing that we need to define for a new indexer is the `handler` data
   type, meant as a wrapper for the connection type (in this case the SQLite
   connection).

   However this is a very good place to add some more configurations
   that the indexer may require (for example performance tuning settings). In our
   case we add the number of events that we want to return from the on-disk buffer -}

data ScriptTxHandle = ScriptTxHandle
  { ScriptTxHandle -> Connection
hdlConnection :: SQL.Connection
  , ScriptTxHandle -> Int
hdlDepth      :: Int
  }

{- The next step is to define the data types that make up the indexer. There are
   5 of these and they depend on the handle that we previously defined. We make use
   of this semantic dependency by using type and data families that connect these
   types to the `handle` that was previously defined.

   If you want to consider semantics, you can think of the `handle` type as identifying
   both the database connection type and the database structure. Thinking of it this
   way makes the reason for the dependency clearer.

   The first type we introduce is the monad in which the database (and by extension,
   the indexer) runs. -}

type instance StorableMonad ScriptTxHandle = IO

{- The next type we introduce is the type of events. Events are the data atoms that
   the indexer consumes. They depend on the `handle` because they need to eventually
   be persisted in the database, so the database has to be able to accomodate them.

   The original implementation used two spearate data structures for storing data
   in memory vs. on-disk. It has the advantage of a better usage of memory and the
   disadvantage of complicating the implementation quite a bit. I am leaving it as-is
   for now, as this is more of a tutorial implementation and complicating things
   may have some educational value. -}

data instance StorableEvent ScriptTxHandle = ScriptTxEvent
  { StorableEvent ScriptTxHandle
-> [(TxCbor, [StorableQuery ScriptTxHandle])]
txScripts  :: [(TxCbor, [StorableQuery ScriptTxHandle])]
  , StorableEvent ScriptTxHandle -> ChainPoint
chainPoint :: !ChainPoint
  } deriving (Int -> StorableEvent ScriptTxHandle -> ShowS
[StorableEvent ScriptTxHandle] -> ShowS
StorableEvent ScriptTxHandle -> String
(Int -> StorableEvent ScriptTxHandle -> ShowS)
-> (StorableEvent ScriptTxHandle -> String)
-> ([StorableEvent ScriptTxHandle] -> ShowS)
-> Show (StorableEvent ScriptTxHandle)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [StorableEvent ScriptTxHandle] -> ShowS
$cshowList :: [StorableEvent ScriptTxHandle] -> ShowS
show :: StorableEvent ScriptTxHandle -> String
$cshow :: StorableEvent ScriptTxHandle -> String
showsPrec :: Int -> StorableEvent ScriptTxHandle -> ShowS
$cshowsPrec :: Int -> StorableEvent ScriptTxHandle -> ShowS
Show)

{- The resume and query functionality requires a way to specify points on the chain
   from which we want to resume, or points up to which we want to query. Next we
   define the types of these points. -}

type instance StorablePoint ScriptTxHandle = ChainPoint

-- We also need to know at which slot number an event was produced.

instance HasPoint (StorableEvent ScriptTxHandle) ChainPoint where
  getPoint :: StorableEvent ScriptTxHandle -> ChainPoint
getPoint (ScriptTxEvent _ cp) = ChainPoint
cp

{- Next we begin to defined the types required for running queries. Both request and
   response types will depend naturally on the structure of the database, which is
   identified by our `handle`. First, lets define the type for queries (or requests). -}

newtype instance StorableQuery ScriptTxHandle = ScriptTxAddress Shelley.ScriptHash
  deriving (Int -> StorableQuery ScriptTxHandle -> ShowS
[StorableQuery ScriptTxHandle] -> ShowS
StorableQuery ScriptTxHandle -> String
(Int -> StorableQuery ScriptTxHandle -> ShowS)
-> (StorableQuery ScriptTxHandle -> String)
-> ([StorableQuery ScriptTxHandle] -> ShowS)
-> Show (StorableQuery ScriptTxHandle)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [StorableQuery ScriptTxHandle] -> ShowS
$cshowList :: [StorableQuery ScriptTxHandle] -> ShowS
show :: StorableQuery ScriptTxHandle -> String
$cshow :: StorableQuery ScriptTxHandle -> String
showsPrec :: Int -> StorableQuery ScriptTxHandle -> ShowS
$cshowsPrec :: Int -> StorableQuery ScriptTxHandle -> ShowS
Show, StorableQuery ScriptTxHandle
-> StorableQuery ScriptTxHandle -> Bool
(StorableQuery ScriptTxHandle
 -> StorableQuery ScriptTxHandle -> Bool)
-> (StorableQuery ScriptTxHandle
    -> StorableQuery ScriptTxHandle -> Bool)
-> Eq (StorableQuery ScriptTxHandle)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: StorableQuery ScriptTxHandle
-> StorableQuery ScriptTxHandle -> Bool
$c/= :: StorableQuery ScriptTxHandle
-> StorableQuery ScriptTxHandle -> Bool
== :: StorableQuery ScriptTxHandle
-> StorableQuery ScriptTxHandle -> Bool
$c== :: StorableQuery ScriptTxHandle
-> StorableQuery ScriptTxHandle -> Bool
Eq)

-- Now, we need one more type for the query results.

newtype instance StorableResult ScriptTxHandle = ScriptTxResult [TxCbor]

-- Next, we define types required for the interaction with SQLite and the cardano
-- blocks.

newtype Depth = Depth Int

newtype TxCbor = TxCbor BS.ByteString
  deriving (TxCbor -> TxCbor -> Bool
(TxCbor -> TxCbor -> Bool)
-> (TxCbor -> TxCbor -> Bool) -> Eq TxCbor
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TxCbor -> TxCbor -> Bool
$c/= :: TxCbor -> TxCbor -> Bool
== :: TxCbor -> TxCbor -> Bool
$c== :: TxCbor -> TxCbor -> Bool
Eq, Int -> TxCbor -> ShowS
[TxCbor] -> ShowS
TxCbor -> String
(Int -> TxCbor -> ShowS)
-> (TxCbor -> String) -> ([TxCbor] -> ShowS) -> Show TxCbor
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TxCbor] -> ShowS
$cshowList :: [TxCbor] -> ShowS
show :: TxCbor -> String
$cshow :: TxCbor -> String
showsPrec :: Int -> TxCbor -> ShowS
$cshowsPrec :: Int -> TxCbor -> ShowS
Show)
  deriving newtype (TxCbor -> SQLData
(TxCbor -> SQLData) -> ToField TxCbor
forall a. (a -> SQLData) -> ToField a
toField :: TxCbor -> SQLData
$ctoField :: TxCbor -> SQLData
SQL.ToField, FieldParser TxCbor
FieldParser TxCbor -> FromField TxCbor
forall a. FieldParser a -> FromField a
fromField :: FieldParser TxCbor
$cfromField :: FieldParser TxCbor
SQL.FromField)

type ScriptTxIndexer = Storable.State ScriptTxHandle

-- * SQLite
data ScriptTxRow = ScriptTxRow
  { ScriptTxRow -> StorableQuery ScriptTxHandle
scriptAddress :: !(StorableQuery ScriptTxHandle)
  , ScriptTxRow -> TxCbor
txCbor        :: !TxCbor
  , ScriptTxRow -> SlotNo
txSlot        :: !SlotNo
  , ScriptTxRow -> Hash BlockHeader
blockHash     :: !(Hash BlockHeader)
  } deriving ((forall x. ScriptTxRow -> Rep ScriptTxRow x)
-> (forall x. Rep ScriptTxRow x -> ScriptTxRow)
-> Generic ScriptTxRow
forall x. Rep ScriptTxRow x -> ScriptTxRow
forall x. ScriptTxRow -> Rep ScriptTxRow x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep ScriptTxRow x -> ScriptTxRow
$cfrom :: forall x. ScriptTxRow -> Rep ScriptTxRow x
Generic)

instance SQL.ToField (StorableQuery ScriptTxHandle) where
  toField :: StorableQuery ScriptTxHandle -> SQLData
toField (ScriptTxAddress hash)  = ByteString -> SQLData
SQL.SQLBlob (ByteString -> SQLData)
-> (ScriptHash -> ByteString) -> ScriptHash -> SQLData
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ScriptHash -> ByteString
forall a. SerialiseAsRawBytes a => a -> ByteString
Shelley.serialiseToRawBytes (ScriptHash -> SQLData) -> ScriptHash -> SQLData
forall a b. (a -> b) -> a -> b
$ ScriptHash
hash
instance SQL.FromField (StorableQuery ScriptTxHandle) where
  fromField :: FieldParser (StorableQuery ScriptTxHandle)
fromField Field
f = FieldParser ByteString
forall a. FromField a => FieldParser a
SQL.fromField Field
f Ok ByteString
-> (ByteString -> Ok (StorableQuery ScriptTxHandle))
-> Ok (StorableQuery ScriptTxHandle)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
      \ByteString
b -> Ok (StorableQuery ScriptTxHandle)
-> (ScriptHash -> Ok (StorableQuery ScriptTxHandle))
-> Maybe ScriptHash
-> Ok (StorableQuery ScriptTxHandle)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Ok (StorableQuery ScriptTxHandle)
cantDeserialise (StorableQuery ScriptTxHandle -> Ok (StorableQuery ScriptTxHandle)
forall (m :: * -> *) a. Monad m => a -> m a
return (StorableQuery ScriptTxHandle -> Ok (StorableQuery ScriptTxHandle))
-> (ScriptHash -> StorableQuery ScriptTxHandle)
-> ScriptHash
-> Ok (StorableQuery ScriptTxHandle)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ScriptHash -> StorableQuery ScriptTxHandle
ScriptTxAddress) (Maybe ScriptHash -> Ok (StorableQuery ScriptTxHandle))
-> Maybe ScriptHash -> Ok (StorableQuery ScriptTxHandle)
forall a b. (a -> b) -> a -> b
$ AsType ScriptHash -> ByteString -> Maybe ScriptHash
forall a.
SerialiseAsRawBytes a =>
AsType a -> ByteString -> Maybe a
Shelley.deserialiseFromRawBytes AsType ScriptHash
Shelley.AsScriptHash ByteString
b
    where
      cantDeserialise :: Ok (StorableQuery ScriptTxHandle)
cantDeserialise = (String -> String -> String -> ResultError)
-> Field -> String -> Ok (StorableQuery ScriptTxHandle)
forall a err.
(Typeable a, Exception err) =>
(String -> String -> String -> err) -> Field -> String -> Ok a
SQL.returnError String -> String -> String -> ResultError
SQL.ConversionFailed Field
f String
"Cannot deserialise address."
instance SQL.ToField SlotNo where
  toField :: SlotNo -> SQLData
toField (SlotNo Word64
n) =  Int -> SQLData
forall a. ToField a => a -> SQLData
SQL.toField (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
n :: Int)
instance SQL.FromField SlotNo where
  fromField :: FieldParser SlotNo
fromField Field
f = Word64 -> SlotNo
SlotNo (Word64 -> SlotNo) -> Ok Word64 -> Ok SlotNo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FieldParser Word64
forall a. FromField a => FieldParser a
SQL.fromField Field
f

instance SQL.ToRow ScriptTxRow where
  toRow :: ScriptTxRow -> [SQLData]
toRow ScriptTxRow
o = [ StorableQuery ScriptTxHandle -> SQLData
forall a. ToField a => a -> SQLData
SQL.toField (StorableQuery ScriptTxHandle -> SQLData)
-> StorableQuery ScriptTxHandle -> SQLData
forall a b. (a -> b) -> a -> b
$ ScriptTxRow -> StorableQuery ScriptTxHandle
scriptAddress ScriptTxRow
o
            , TxCbor -> SQLData
forall a. ToField a => a -> SQLData
SQL.toField (TxCbor -> SQLData) -> TxCbor -> SQLData
forall a b. (a -> b) -> a -> b
$ ScriptTxRow -> TxCbor
txCbor ScriptTxRow
o
            , SlotNo -> SQLData
forall a. ToField a => a -> SQLData
SQL.toField (SlotNo -> SQLData) -> SlotNo -> SQLData
forall a b. (a -> b) -> a -> b
$ ScriptTxRow -> SlotNo
txSlot ScriptTxRow
o
            , Hash BlockHeader -> SQLData
forall a. ToField a => a -> SQLData
SQL.toField (Hash BlockHeader -> SQLData) -> Hash BlockHeader -> SQLData
forall a b. (a -> b) -> a -> b
$ ScriptTxRow -> Hash BlockHeader
blockHash ScriptTxRow
o ]

deriving instance SQL.FromRow ScriptTxRow

instance SQL.ToField (Hash BlockHeader) where
  toField :: Hash BlockHeader -> SQLData
toField Hash BlockHeader
f = ByteString -> SQLData
forall a. ToField a => a -> SQLData
SQL.toField (ByteString -> SQLData) -> ByteString -> SQLData
forall a b. (a -> b) -> a -> b
$ Hash BlockHeader -> ByteString
forall a. SerialiseAsRawBytes a => a -> ByteString
C.serialiseToRawBytes Hash BlockHeader
f

instance SQL.FromField (Hash BlockHeader) where
   fromField :: FieldParser (Hash BlockHeader)
fromField Field
f =
      FieldParser ByteString
forall a. FromField a => FieldParser a
SQL.fromField Field
f Ok ByteString
-> (ByteString -> Hash BlockHeader) -> Ok (Hash BlockHeader)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&>
        Hash BlockHeader -> Maybe (Hash BlockHeader) -> Hash BlockHeader
forall a. a -> Maybe a -> a
fromMaybe (String -> Hash BlockHeader
forall a. HasCallStack => String -> a
error String
"Cannot deserialise block hash") (Maybe (Hash BlockHeader) -> Hash BlockHeader)
-> (ByteString -> Maybe (Hash BlockHeader))
-> ByteString
-> Hash BlockHeader
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
          AsType (Hash BlockHeader) -> ByteString -> Maybe (Hash BlockHeader)
forall a.
SerialiseAsRawBytes a =>
AsType a -> ByteString -> Maybe a
C.deserialiseFromRawBytes (Proxy (Hash BlockHeader) -> AsType (Hash BlockHeader)
forall t. HasTypeProxy t => Proxy t -> AsType t
C.proxyToAsType Proxy (Hash BlockHeader)
forall k (t :: k). Proxy t
Proxy)

instance Ord ChainPoint where
   ChainPoint
ChainPointAtGenesis <= :: ChainPoint -> ChainPoint -> Bool
<= ChainPoint
_                = Bool
True
   ChainPoint
_ <= ChainPoint
ChainPointAtGenesis                = Bool
False
   (ChainPoint SlotNo
sn Hash BlockHeader
_) <= (ChainPoint SlotNo
sn' Hash BlockHeader
_) = SlotNo
sn SlotNo -> SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
<= SlotNo
sn'

-- * Indexer

type Query  = StorableQuery  ScriptTxHandle
type Result = StorableResult ScriptTxHandle

toUpdate
  :: forall era . C.IsCardanoEra era
  => [C.Tx era]
  -> ChainPoint
  -> StorableEvent ScriptTxHandle
toUpdate :: [Tx era] -> ChainPoint -> StorableEvent ScriptTxHandle
toUpdate [Tx era]
txs = [(TxCbor, [StorableQuery ScriptTxHandle])]
-> ChainPoint -> StorableEvent ScriptTxHandle
ScriptTxEvent [(TxCbor, [StorableQuery ScriptTxHandle])]
txScripts'
  where
    txScripts' :: [(TxCbor, [StorableQuery ScriptTxHandle])]
txScripts' = (Tx era -> (TxCbor, [StorableQuery ScriptTxHandle]))
-> [Tx era] -> [(TxCbor, [StorableQuery ScriptTxHandle])]
forall a b. (a -> b) -> [a] -> [b]
map (\Tx era
tx -> (ByteString -> TxCbor
TxCbor (ByteString -> TxCbor) -> ByteString -> TxCbor
forall a b. (a -> b) -> a -> b
$ Tx era -> ByteString
forall a. SerialiseAsCBOR a => a -> ByteString
C.serialiseToCBOR Tx era
tx, Tx era -> [StorableQuery ScriptTxHandle]
forall era. Tx era -> [StorableQuery ScriptTxHandle]
getTxScripts Tx era
tx)) [Tx era]
txs

getTxBodyScripts :: forall era . C.TxBody era -> [StorableQuery ScriptTxHandle]
getTxBodyScripts :: TxBody era -> [StorableQuery ScriptTxHandle]
getTxBodyScripts TxBody era
body = let
    hashesMaybe :: [Maybe C.ScriptHash]
    hashesMaybe :: [Maybe ScriptHash]
hashesMaybe = case TxBody era
body of
      Shelley.ShelleyTxBody ShelleyBasedEra era
shelleyBasedEra TxBody (ShelleyLedgerEra era)
_ [Script (ShelleyLedgerEra era)]
scripts TxBodyScriptData era
_ Maybe (AuxiliaryData (ShelleyLedgerEra era))
_ TxScriptValidity era
_ ->
        ((Script (ShelleyLedgerEra era) -> Maybe ScriptHash)
 -> [Script (ShelleyLedgerEra era)] -> [Maybe ScriptHash])
-> [Script (ShelleyLedgerEra era)]
-> (Script (ShelleyLedgerEra era) -> Maybe ScriptHash)
-> [Maybe ScriptHash]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Script (ShelleyLedgerEra era) -> Maybe ScriptHash)
-> [Script (ShelleyLedgerEra era)] -> [Maybe ScriptHash]
forall a b. (a -> b) -> [a] -> [b]
map [Script (ShelleyLedgerEra era)]
scripts ((Script (ShelleyLedgerEra era) -> Maybe ScriptHash)
 -> [Maybe ScriptHash])
-> (Script (ShelleyLedgerEra era) -> Maybe ScriptHash)
-> [Maybe ScriptHash]
forall a b. (a -> b) -> a -> b
$ \Script (ShelleyLedgerEra era)
script ->
          case ShelleyBasedEra era
-> Script (ShelleyLedgerEra era) -> ScriptInEra era
forall era.
ShelleyBasedEra era
-> Script (ShelleyLedgerEra era) -> ScriptInEra era
fromShelleyBasedScript ShelleyBasedEra era
shelleyBasedEra Script (ShelleyLedgerEra era)
script of
            Shelley.ScriptInEra ScriptLanguageInEra lang era
_ Script lang
script' -> ScriptHash -> Maybe ScriptHash
forall a. a -> Maybe a
Just (ScriptHash -> Maybe ScriptHash) -> ScriptHash -> Maybe ScriptHash
forall a b. (a -> b) -> a -> b
$ Script lang -> ScriptHash
forall lang. Script lang -> ScriptHash
C.hashScript Script lang
script'
      TxBody era
_ -> [] -- Byron transactions have no scripts
    hashes :: [ScriptHash]
hashes = [Maybe ScriptHash] -> [ScriptHash]
forall a. [Maybe a] -> [a]
catMaybes [Maybe ScriptHash]
hashesMaybe :: [Shelley.ScriptHash]
  in (ScriptHash -> StorableQuery ScriptTxHandle)
-> [ScriptHash] -> [StorableQuery ScriptTxHandle]
forall a b. (a -> b) -> [a] -> [b]
map ScriptHash -> StorableQuery ScriptTxHandle
ScriptTxAddress [ScriptHash]
hashes

getTxScripts :: forall era . C.Tx era -> [StorableQuery ScriptTxHandle]
getTxScripts :: Tx era -> [StorableQuery ScriptTxHandle]
getTxScripts (C.Tx TxBody era
txBody [KeyWitness era]
_ws) = TxBody era -> [StorableQuery ScriptTxHandle]
forall era. TxBody era -> [StorableQuery ScriptTxHandle]
getTxBodyScripts TxBody era
txBody

{- Now that all connected data types have been defined, we go on to implement some
   of the type classes required for information storage and retrieval. -}

instance Buffered ScriptTxHandle where
  {- The data is buffered in memory. When the memory buffer is filled, we need to store
     it on disk. -}
  persistToStorage
    :: Foldable f
    => f (StorableEvent ScriptTxHandle)
    -> ScriptTxHandle
    -> IO ScriptTxHandle
  persistToStorage :: f (StorableEvent ScriptTxHandle)
-> ScriptTxHandle -> IO ScriptTxHandle
persistToStorage f (StorableEvent ScriptTxHandle)
es ScriptTxHandle
h = do
    let rows :: [ScriptTxRow]
rows = ([ScriptTxRow] -> StorableEvent ScriptTxHandle -> [ScriptTxRow])
-> [ScriptTxRow]
-> f (StorableEvent ScriptTxHandle)
-> [ScriptTxRow]
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\[ScriptTxRow]
ea StorableEvent ScriptTxHandle
e -> [ScriptTxRow]
ea [ScriptTxRow] -> [ScriptTxRow] -> [ScriptTxRow]
forall a. [a] -> [a] -> [a]
++ StorableEvent ScriptTxHandle -> [ScriptTxRow]
flatten StorableEvent ScriptTxHandle
e) [] f (StorableEvent ScriptTxHandle)
es
        c :: Connection
c    = ScriptTxHandle -> Connection
hdlConnection ScriptTxHandle
h
    Connection -> Query -> [ScriptTxRow] -> IO ()
forall q. ToRow q => Connection -> Query -> [q] -> IO ()
SQL.executeMany Connection
c
      Query
"INSERT INTO script_transactions (scriptAddress, txCbor, slotNo, blockHash) VALUES (?, ?, ?, ?)" [ScriptTxRow]
rows
    ScriptTxHandle -> IO ScriptTxHandle
forall (f :: * -> *) a. Applicative f => a -> f a
pure ScriptTxHandle
h

    where
      flatten :: StorableEvent ScriptTxHandle -> [ScriptTxRow]
      flatten :: StorableEvent ScriptTxHandle -> [ScriptTxRow]
flatten (ScriptTxEvent txs (ChainPoint sn hsh)) = do
        (TxCbor
tx, [StorableQuery ScriptTxHandle]
scriptAddrs) <- [(TxCbor, [StorableQuery ScriptTxHandle])]
txs
        StorableQuery ScriptTxHandle
addr <- [StorableQuery ScriptTxHandle]
scriptAddrs
        ScriptTxRow -> [ScriptTxRow]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ScriptTxRow -> [ScriptTxRow]) -> ScriptTxRow -> [ScriptTxRow]
forall a b. (a -> b) -> a -> b
$ ScriptTxRow :: StorableQuery ScriptTxHandle
-> TxCbor -> SlotNo -> Hash BlockHeader -> ScriptTxRow
ScriptTxRow { scriptAddress :: StorableQuery ScriptTxHandle
scriptAddress = StorableQuery ScriptTxHandle
addr
                           , txCbor :: TxCbor
txCbor        = TxCbor
tx
                           , txSlot :: SlotNo
txSlot        = SlotNo
sn
                           , blockHash :: Hash BlockHeader
blockHash     = Hash BlockHeader
hsh
                           }
      flatten StorableEvent ScriptTxHandle
_ = String -> [ScriptTxRow]
forall a. HasCallStack => String -> a
error String
"There should be no scripts in the genesis block."

  {- We want to potentially store data in two formats. The first one is similar (if
     not identical) to the format of data stored in memory; it should contain information
     that allows knowing at which point the data was generated.

     We use this first format to support rollbacks for disk data. The second format,
     which is not always necessary and does not have any predetermined structure,
     should be thought of as an aggregate of the previously produced events.

     For this indexer we don't really need an aggregate, so our "aggregate" has almost the same
     structure as the in-memory data. We pretend that there is an aggregate by
     segregating the data into two sections, by using the `hdlDiskStore` parameter. We
     take this approach because we don't want to return the entire database when this
     function is called, and we know that there is a point after which we will not
     see any rollbacks. -}

  getStoredEvents
    :: ScriptTxHandle
    -> IO [StorableEvent ScriptTxHandle]
  getStoredEvents :: ScriptTxHandle -> IO [StorableEvent ScriptTxHandle]
getStoredEvents (ScriptTxHandle Connection
c Int
sz) = do
    [[Integer]]
sns :: [[Integer]] <-
      Connection -> Query -> Only Int -> IO [[Integer]]
forall q r.
(ToRow q, FromRow r) =>
Connection -> Query -> q -> IO [r]
SQL.query Connection
c Query
"SELECT slotNo FROM script_transactions GROUP BY slotNo ORDER BY slotNo DESC LIMIT ?" (Int -> Only Int
forall a. a -> Only a
SQL.Only Int
sz)
    -- Take the slot number of the sz'th slot
    let sn :: Integer
sn = if [[Integer]] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[Integer]]
sns
                then Integer
0
                else [Integer] -> Integer
forall a. [a] -> a
head ([Integer] -> Integer)
-> ([[Integer]] -> [Integer]) -> [[Integer]] -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Integer]] -> [Integer]
forall a. [a] -> a
last ([[Integer]] -> Integer) -> [[Integer]] -> Integer
forall a b. (a -> b) -> a -> b
$ Int -> [[Integer]] -> [[Integer]]
forall a. Int -> [a] -> [a]
take Int
sz [[Integer]]
sns
    [ScriptTxRow]
es <- Connection -> Query -> Only Integer -> IO [ScriptTxRow]
forall q r.
(ToRow q, FromRow r) =>
Connection -> Query -> q -> IO [r]
SQL.query Connection
c Query
"SELECT scriptAddress, txCbor, slotNo, blockHash FROM script_transactions WHERE slotNo >= ? ORDER BY slotNo DESC, txCbor, scriptAddress" (Integer -> Only Integer
forall a. a -> Only a
SQL.Only (Integer
sn :: Integer))
    [StorableEvent ScriptTxHandle] -> IO [StorableEvent ScriptTxHandle]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([StorableEvent ScriptTxHandle]
 -> IO [StorableEvent ScriptTxHandle])
-> [StorableEvent ScriptTxHandle]
-> IO [StorableEvent ScriptTxHandle]
forall a b. (a -> b) -> a -> b
$ [ScriptTxRow] -> [StorableEvent ScriptTxHandle]
asEvents [ScriptTxRow]
es

-- This function recomposes the in-memory format from the database records. This
-- function expectes it's first argument to be ordered by slotNo and txCbor for the
-- proper grouping of records.
--
-- TODO: There should be an easier lensy way of doing this.
asEvents
  :: [ScriptTxRow]
  -> [StorableEvent ScriptTxHandle]
asEvents :: [ScriptTxRow] -> [StorableEvent ScriptTxHandle]
asEvents [] = []
asEvents rs :: [ScriptTxRow]
rs@(ScriptTxRow StorableQuery ScriptTxHandle
_ TxCbor
_ SlotNo
sn Hash BlockHeader
hsh : [ScriptTxRow]
_) =
   let ([ScriptTxRow]
xs, [ScriptTxRow]
ys) = (ScriptTxRow -> Bool)
-> [ScriptTxRow] -> ([ScriptTxRow], [ScriptTxRow])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (\(ScriptTxRow StorableQuery ScriptTxHandle
_ TxCbor
_ SlotNo
sn' Hash BlockHeader
hsh') -> SlotNo
sn SlotNo -> SlotNo -> Bool
forall a. Eq a => a -> a -> Bool
== SlotNo
sn' Bool -> Bool -> Bool
&& Hash BlockHeader
hsh Hash BlockHeader -> Hash BlockHeader -> Bool
forall a. Eq a => a -> a -> Bool
== Hash BlockHeader
hsh') [ScriptTxRow]
rs
    in [ScriptTxRow] -> StorableEvent ScriptTxHandle
mkEvent [ScriptTxRow]
xs StorableEvent ScriptTxHandle
-> [StorableEvent ScriptTxHandle] -> [StorableEvent ScriptTxHandle]
forall a. a -> [a] -> [a]
: [ScriptTxRow] -> [StorableEvent ScriptTxHandle]
asEvents [ScriptTxRow]
ys
  where
    mkEvent :: [ScriptTxRow] -> StorableEvent ScriptTxHandle
    mkEvent :: [ScriptTxRow] -> StorableEvent ScriptTxHandle
mkEvent rs' :: [ScriptTxRow]
rs'@(ScriptTxRow StorableQuery ScriptTxHandle
_ TxCbor
_ SlotNo
sn' Hash BlockHeader
hsh' : [ScriptTxRow]
_) =
       ScriptTxEvent :: [(TxCbor, [StorableQuery ScriptTxHandle])]
-> ChainPoint -> StorableEvent ScriptTxHandle
ScriptTxEvent { chainPoint :: ChainPoint
chainPoint = SlotNo -> Hash BlockHeader -> ChainPoint
ChainPoint SlotNo
sn' Hash BlockHeader
hsh'
                     , txScripts :: [(TxCbor, [StorableQuery ScriptTxHandle])]
txScripts = [ScriptTxRow] -> [(TxCbor, [StorableQuery ScriptTxHandle])]
agScripts [ScriptTxRow]
rs'
                     }
    mkEvent [ScriptTxRow]
_ = String -> StorableEvent ScriptTxHandle
forall a. HasCallStack => String -> a
error String
"We should always be called with a non-empty list"
    agScripts :: [ScriptTxRow] -> [(TxCbor, [StorableQuery ScriptTxHandle])]
    agScripts :: [ScriptTxRow] -> [(TxCbor, [StorableQuery ScriptTxHandle])]
agScripts [] = []
    agScripts rs' :: [ScriptTxRow]
rs'@(ScriptTxRow StorableQuery ScriptTxHandle
_ TxCbor
tx SlotNo
_ Hash BlockHeader
_ : [ScriptTxRow]
_) =
       let ([ScriptTxRow]
xs, [ScriptTxRow]
ys) = (ScriptTxRow -> Bool)
-> [ScriptTxRow] -> ([ScriptTxRow], [ScriptTxRow])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (\(ScriptTxRow StorableQuery ScriptTxHandle
_ TxCbor
tx' SlotNo
_ Hash BlockHeader
_) -> TxCbor
tx TxCbor -> TxCbor -> Bool
forall a. Eq a => a -> a -> Bool
== TxCbor
tx') [ScriptTxRow]
rs'
        in (TxCbor
tx, (ScriptTxRow -> StorableQuery ScriptTxHandle)
-> [ScriptTxRow] -> [StorableQuery ScriptTxHandle]
forall a b. (a -> b) -> [a] -> [b]
map ScriptTxRow -> StorableQuery ScriptTxHandle
scriptAddress [ScriptTxRow]
xs) (TxCbor, [StorableQuery ScriptTxHandle])
-> [(TxCbor, [StorableQuery ScriptTxHandle])]
-> [(TxCbor, [StorableQuery ScriptTxHandle])]
forall a. a -> [a] -> [a]
: [ScriptTxRow] -> [(TxCbor, [StorableQuery ScriptTxHandle])]
agScripts [ScriptTxRow]
ys

instance Queryable ScriptTxHandle where
  queryStorage
    :: Foldable f
    => QueryInterval ChainPoint
    -> f (StorableEvent ScriptTxHandle)
    -> ScriptTxHandle
    -> StorableQuery ScriptTxHandle
    -> IO (StorableResult ScriptTxHandle)
  queryStorage :: QueryInterval ChainPoint
-> f (StorableEvent ScriptTxHandle)
-> ScriptTxHandle
-> StorableQuery ScriptTxHandle
-> IO (StorableResult ScriptTxHandle)
queryStorage QueryInterval ChainPoint
qi f (StorableEvent ScriptTxHandle)
es (ScriptTxHandle Connection
c Int
_) StorableQuery ScriptTxHandle
q = do
    [ScriptTxRow]
persisted :: [ScriptTxRow] <-
      case QueryInterval ChainPoint
qi of
        QueryInterval ChainPoint
QEverything -> Connection
-> Query -> Only (StorableQuery ScriptTxHandle) -> IO [ScriptTxRow]
forall q r.
(ToRow q, FromRow r) =>
Connection -> Query -> q -> IO [r]
SQL.query Connection
c
          Query
"SELECT scriptAddress, txCbor, slotNo, blockHash FROM script_transactions WHERE scriptAddress = ? ORDER BY slotNo ASC, txCbor, scriptAddress" (StorableQuery ScriptTxHandle -> Only (StorableQuery ScriptTxHandle)
forall a. a -> Only a
SQL.Only StorableQuery ScriptTxHandle
q)
        QInterval ChainPoint
_ (ChainPoint SlotNo
sn Hash BlockHeader
_) -> Connection
-> Query
-> (SlotNo, StorableQuery ScriptTxHandle)
-> IO [ScriptTxRow]
forall q r.
(ToRow q, FromRow r) =>
Connection -> Query -> q -> IO [r]
SQL.query Connection
c
          Query
"SELECT scriptAddress, txCbor, slotNo, blockHash FROM script_transactions WHERE slotNo <= ? AND scriptAddress = ? ORDER BY slotNo ASC, txCbor, scriptAddress" (SlotNo
sn, StorableQuery ScriptTxHandle
q)
        QInterval ChainPoint
_ ChainPoint
ChainPointAtGenesis -> [ScriptTxRow] -> IO [ScriptTxRow]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
    -- Note that ordering is quite important here, as the `filterWithQueryInterval`
    -- function assumes events are ordered from oldest (the head) to most recent.
    let updates :: [StorableEvent ScriptTxHandle]
updates = QueryInterval (StorablePoint ScriptTxHandle)
-> [StorableEvent ScriptTxHandle] -> [StorableEvent ScriptTxHandle]
forall h.
(HasPoint (StorableEvent h) (StorablePoint h),
 Ord (StorablePoint h)) =>
QueryInterval (StorablePoint h)
-> [StorableEvent h] -> [StorableEvent h]
filterWithQueryInterval QueryInterval ChainPoint
QueryInterval (StorablePoint ScriptTxHandle)
qi ([ScriptTxRow] -> [StorableEvent ScriptTxHandle]
asEvents [ScriptTxRow]
persisted [StorableEvent ScriptTxHandle]
-> [StorableEvent ScriptTxHandle] -> [StorableEvent ScriptTxHandle]
forall a. [a] -> [a] -> [a]
++ f (StorableEvent ScriptTxHandle) -> [StorableEvent ScriptTxHandle]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList f (StorableEvent ScriptTxHandle)
es)
    StorableResult ScriptTxHandle -> IO (StorableResult ScriptTxHandle)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (StorableResult ScriptTxHandle
 -> IO (StorableResult ScriptTxHandle))
-> ([TxCbor] -> StorableResult ScriptTxHandle)
-> [TxCbor]
-> IO (StorableResult ScriptTxHandle)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [TxCbor] -> StorableResult ScriptTxHandle
ScriptTxResult ([TxCbor] -> IO (StorableResult ScriptTxHandle))
-> [TxCbor] -> IO (StorableResult ScriptTxHandle)
forall a b. (a -> b) -> a -> b
$ StorableQuery ScriptTxHandle
-> [StorableEvent ScriptTxHandle] -> [TxCbor]
filterByScriptAddress StorableQuery ScriptTxHandle
q [StorableEvent ScriptTxHandle]
updates

    where
      filterByScriptAddress :: StorableQuery ScriptTxHandle -> [StorableEvent ScriptTxHandle] -> [TxCbor]
      filterByScriptAddress :: StorableQuery ScriptTxHandle
-> [StorableEvent ScriptTxHandle] -> [TxCbor]
filterByScriptAddress StorableQuery ScriptTxHandle
addr [StorableEvent ScriptTxHandle]
updates = do
         ScriptTxEvent update _slotNo <- [StorableEvent ScriptTxHandle]
updates
         ((TxCbor, [StorableQuery ScriptTxHandle]) -> TxCbor)
-> [(TxCbor, [StorableQuery ScriptTxHandle])] -> [TxCbor]
forall a b. (a -> b) -> [a] -> [b]
map (TxCbor, [StorableQuery ScriptTxHandle]) -> TxCbor
forall a b. (a, b) -> a
fst ([(TxCbor, [StorableQuery ScriptTxHandle])] -> [TxCbor])
-> [(TxCbor, [StorableQuery ScriptTxHandle])] -> [TxCbor]
forall a b. (a -> b) -> a -> b
$ ((TxCbor, [StorableQuery ScriptTxHandle]) -> Bool)
-> [(TxCbor, [StorableQuery ScriptTxHandle])]
-> [(TxCbor, [StorableQuery ScriptTxHandle])]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(TxCbor
_, [StorableQuery ScriptTxHandle]
addrs) -> StorableQuery ScriptTxHandle
addr StorableQuery ScriptTxHandle
-> [StorableQuery ScriptTxHandle] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [StorableQuery ScriptTxHandle]
addrs) [(TxCbor, [StorableQuery ScriptTxHandle])]
update

instance Rewindable ScriptTxHandle where
  rewindStorage
    :: ChainPoint
    -> ScriptTxHandle
    -> IO (Maybe ScriptTxHandle)
  rewindStorage :: ChainPoint -> ScriptTxHandle -> IO (Maybe ScriptTxHandle)
rewindStorage (ChainPoint SlotNo
sn   Hash BlockHeader
_) h :: ScriptTxHandle
h@(ScriptTxHandle Connection
c Int
_) = do
     Connection -> Query -> Only SlotNo -> IO ()
forall q. ToRow q => Connection -> Query -> q -> IO ()
SQL.execute Connection
c Query
"DELETE FROM script_transactions WHERE slotNo > ?" (SlotNo -> Only SlotNo
forall a. a -> Only a
SQL.Only SlotNo
sn)
     Maybe ScriptTxHandle -> IO (Maybe ScriptTxHandle)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe ScriptTxHandle -> IO (Maybe ScriptTxHandle))
-> Maybe ScriptTxHandle -> IO (Maybe ScriptTxHandle)
forall a b. (a -> b) -> a -> b
$ ScriptTxHandle -> Maybe ScriptTxHandle
forall a. a -> Maybe a
Just ScriptTxHandle
h
  rewindStorage ChainPoint
ChainPointAtGenesis h :: ScriptTxHandle
h@(ScriptTxHandle Connection
c Int
_) = do
     Connection -> Query -> IO ()
SQL.execute_ Connection
c Query
"DELETE FROM script_transactions"
     Maybe ScriptTxHandle -> IO (Maybe ScriptTxHandle)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe ScriptTxHandle -> IO (Maybe ScriptTxHandle))
-> Maybe ScriptTxHandle -> IO (Maybe ScriptTxHandle)
forall a b. (a -> b) -> a -> b
$ ScriptTxHandle -> Maybe ScriptTxHandle
forall a. a -> Maybe a
Just ScriptTxHandle
h


-- For resuming we need to provide a list of points where we can resume from.

instance Resumable ScriptTxHandle where
  resumeFromStorage :: ScriptTxHandle
-> StorableMonad ScriptTxHandle [StorablePoint ScriptTxHandle]
resumeFromStorage ScriptTxHandle
h = do
    [StorableEvent ScriptTxHandle]
es <- ScriptTxHandle
-> StorableMonad ScriptTxHandle [StorableEvent ScriptTxHandle]
forall h. Buffered h => h -> StorableMonad h [StorableEvent h]
Storable.getStoredEvents ScriptTxHandle
h
    -- The ordering here matters. The node will try to find the first point in the
    -- ledger, then move to the next and so on, so we will send the latest point
    -- first.
    [ChainPoint] -> IO [ChainPoint]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([ChainPoint] -> IO [ChainPoint])
-> [ChainPoint] -> IO [ChainPoint]
forall a b. (a -> b) -> a -> b
$ (StorableEvent ScriptTxHandle -> ChainPoint)
-> [StorableEvent ScriptTxHandle] -> [ChainPoint]
forall a b. (a -> b) -> [a] -> [b]
map StorableEvent ScriptTxHandle -> ChainPoint
chainPoint [StorableEvent ScriptTxHandle]
es [ChainPoint] -> [ChainPoint] -> [ChainPoint]
forall a. [a] -> [a] -> [a]
++ [ChainPoint
ChainPointAtGenesis]

open :: FilePath -> Depth -> IO ScriptTxIndexer
open :: String -> Depth -> IO ScriptTxIndexer
open String
dbPath (Depth Int
k) = do
  Connection
c <- String -> IO Connection
SQL.open String
dbPath
  Connection -> Query -> IO ()
SQL.execute_ Connection
c Query
"CREATE TABLE IF NOT EXISTS script_transactions (scriptAddress TEXT NOT NULL, txCbor BLOB NOT NULL, slotNo INT NOT NULL, blockHash BLOB NOT NULL)"
  -- Add this index for normal queries.
  Connection -> Query -> IO ()
SQL.execute_ Connection
c Query
"CREATE INDEX IF NOT EXISTS script_address ON script_transactions (scriptAddress)"
  -- Add this index for interval queries.
  Connection -> Query -> IO ()
SQL.execute_ Connection
c Query
"CREATE INDEX IF NOT EXISTS script_address_slot ON script_transactions (scriptAddress, slotNo)"
  -- This index helps with group by
  Connection -> Query -> IO ()
SQL.execute_ Connection
c Query
"CREATE INDEX IF NOT EXISTS script_grp ON script_transactions (slotNo)"
  Int
-> ScriptTxHandle -> StorableMonad ScriptTxHandle ScriptTxIndexer
forall h.
PrimMonad (StorableMonad h) =>
Int -> h -> StorableMonad h (State h)
emptyState Int
k (Connection -> Int -> ScriptTxHandle
ScriptTxHandle Connection
c Int
k)

-- * Copy-paste
--
-- | TODO: Remove when the following function is exported from Cardano.Api.Script
-- PR: https://github.com/input-output-hk/cardano-node/pull/4386
fromShelleyBasedScript  :: Shelley.ShelleyBasedEra era
                        -> Cardano.Ledger.Core.Script (Shelley.ShelleyLedgerEra era)
                        -> Shelley.ScriptInEra era
fromShelleyBasedScript :: ShelleyBasedEra era
-> Script (ShelleyLedgerEra era) -> ScriptInEra era
fromShelleyBasedScript ShelleyBasedEra era
era Script (ShelleyLedgerEra era)
script =
  case ShelleyBasedEra era
era of
    ShelleyBasedEra era
Shelley.ShelleyBasedEraShelley ->
      ScriptLanguageInEra SimpleScriptV1 ShelleyEra
-> Script SimpleScriptV1 -> ScriptInEra ShelleyEra
forall lang era.
ScriptLanguageInEra lang era -> Script lang -> ScriptInEra era
Shelley.ScriptInEra ScriptLanguageInEra SimpleScriptV1 ShelleyEra
Shelley.SimpleScriptV1InShelley (Script SimpleScriptV1 -> ScriptInEra ShelleyEra)
-> Script SimpleScriptV1 -> ScriptInEra ShelleyEra
forall a b. (a -> b) -> a -> b
$
      SimpleScriptVersion SimpleScriptV1
-> SimpleScript SimpleScriptV1 -> Script SimpleScriptV1
forall lang.
SimpleScriptVersion lang -> SimpleScript lang -> Script lang
Shelley.SimpleScript SimpleScriptVersion SimpleScriptV1
Shelley.SimpleScriptV1 (SimpleScript SimpleScriptV1 -> Script SimpleScriptV1)
-> SimpleScript SimpleScriptV1 -> Script SimpleScriptV1
forall a b. (a -> b) -> a -> b
$
      MultiSig StandardCrypto -> SimpleScript SimpleScriptV1
forall lang. MultiSig StandardCrypto -> SimpleScript lang
fromShelleyMultiSig MultiSig StandardCrypto
Script (ShelleyLedgerEra era)
script
    ShelleyBasedEra era
Shelley.ShelleyBasedEraAllegra ->
      ScriptLanguageInEra SimpleScriptV2 AllegraEra
-> Script SimpleScriptV2 -> ScriptInEra AllegraEra
forall lang era.
ScriptLanguageInEra lang era -> Script lang -> ScriptInEra era
Shelley.ScriptInEra ScriptLanguageInEra SimpleScriptV2 AllegraEra
Shelley.SimpleScriptV2InAllegra (Script SimpleScriptV2 -> ScriptInEra AllegraEra)
-> Script SimpleScriptV2 -> ScriptInEra AllegraEra
forall a b. (a -> b) -> a -> b
$
      SimpleScriptVersion SimpleScriptV2
-> SimpleScript SimpleScriptV2 -> Script SimpleScriptV2
forall lang.
SimpleScriptVersion lang -> SimpleScript lang -> Script lang
Shelley.SimpleScript SimpleScriptVersion SimpleScriptV2
Shelley.SimpleScriptV2 (SimpleScript SimpleScriptV2 -> Script SimpleScriptV2)
-> SimpleScript SimpleScriptV2 -> Script SimpleScriptV2
forall a b. (a -> b) -> a -> b
$
      TimeLocksSupported SimpleScriptV2
-> Timelock StandardCrypto -> SimpleScript SimpleScriptV2
forall lang.
TimeLocksSupported lang
-> Timelock StandardCrypto -> SimpleScript lang
fromAllegraTimelock TimeLocksSupported SimpleScriptV2
Shelley.TimeLocksInSimpleScriptV2 Timelock StandardCrypto
Script (ShelleyLedgerEra era)
script
    ShelleyBasedEra era
Shelley.ShelleyBasedEraMary ->
      ScriptLanguageInEra SimpleScriptV2 MaryEra
-> Script SimpleScriptV2 -> ScriptInEra MaryEra
forall lang era.
ScriptLanguageInEra lang era -> Script lang -> ScriptInEra era
Shelley.ScriptInEra ScriptLanguageInEra SimpleScriptV2 MaryEra
Shelley.SimpleScriptV2InMary (Script SimpleScriptV2 -> ScriptInEra MaryEra)
-> Script SimpleScriptV2 -> ScriptInEra MaryEra
forall a b. (a -> b) -> a -> b
$
      SimpleScriptVersion SimpleScriptV2
-> SimpleScript SimpleScriptV2 -> Script SimpleScriptV2
forall lang.
SimpleScriptVersion lang -> SimpleScript lang -> Script lang
Shelley.SimpleScript SimpleScriptVersion SimpleScriptV2
Shelley.SimpleScriptV2 (SimpleScript SimpleScriptV2 -> Script SimpleScriptV2)
-> SimpleScript SimpleScriptV2 -> Script SimpleScriptV2
forall a b. (a -> b) -> a -> b
$
      TimeLocksSupported SimpleScriptV2
-> Timelock StandardCrypto -> SimpleScript SimpleScriptV2
forall lang.
TimeLocksSupported lang
-> Timelock StandardCrypto -> SimpleScript lang
fromAllegraTimelock TimeLocksSupported SimpleScriptV2
Shelley.TimeLocksInSimpleScriptV2 Timelock StandardCrypto
Script (ShelleyLedgerEra era)
script
    ShelleyBasedEra era
Shelley.ShelleyBasedEraAlonzo ->
      case Script (ShelleyLedgerEra era)
script of
        Alonzo.TimelockScript s ->
          ScriptLanguageInEra SimpleScriptV2 AlonzoEra
-> Script SimpleScriptV2 -> ScriptInEra AlonzoEra
forall lang era.
ScriptLanguageInEra lang era -> Script lang -> ScriptInEra era
Shelley.ScriptInEra ScriptLanguageInEra SimpleScriptV2 AlonzoEra
Shelley.SimpleScriptV2InAlonzo (Script SimpleScriptV2 -> ScriptInEra AlonzoEra)
-> Script SimpleScriptV2 -> ScriptInEra AlonzoEra
forall a b. (a -> b) -> a -> b
$
          SimpleScriptVersion SimpleScriptV2
-> SimpleScript SimpleScriptV2 -> Script SimpleScriptV2
forall lang.
SimpleScriptVersion lang -> SimpleScript lang -> Script lang
Shelley.SimpleScript SimpleScriptVersion SimpleScriptV2
Shelley.SimpleScriptV2 (SimpleScript SimpleScriptV2 -> Script SimpleScriptV2)
-> SimpleScript SimpleScriptV2 -> Script SimpleScriptV2
forall a b. (a -> b) -> a -> b
$
          TimeLocksSupported SimpleScriptV2
-> Timelock StandardCrypto -> SimpleScript SimpleScriptV2
forall lang.
TimeLocksSupported lang
-> Timelock StandardCrypto -> SimpleScript lang
fromAllegraTimelock TimeLocksSupported SimpleScriptV2
Shelley.TimeLocksInSimpleScriptV2 Timelock StandardCrypto
Timelock (Crypto (AlonzoEra StandardCrypto))
s
        Alonzo.PlutusScript Alonzo.PlutusV1 s ->
          ScriptLanguageInEra PlutusScriptV1 AlonzoEra
-> Script PlutusScriptV1 -> ScriptInEra AlonzoEra
forall lang era.
ScriptLanguageInEra lang era -> Script lang -> ScriptInEra era
Shelley.ScriptInEra ScriptLanguageInEra PlutusScriptV1 AlonzoEra
Shelley.PlutusScriptV1InAlonzo (Script PlutusScriptV1 -> ScriptInEra AlonzoEra)
-> Script PlutusScriptV1 -> ScriptInEra AlonzoEra
forall a b. (a -> b) -> a -> b
$
          PlutusScriptVersion PlutusScriptV1
-> PlutusScript PlutusScriptV1 -> Script PlutusScriptV1
forall lang.
PlutusScriptVersion lang -> PlutusScript lang -> Script lang
Shelley.PlutusScript PlutusScriptVersion PlutusScriptV1
Shelley.PlutusScriptV1 (PlutusScript PlutusScriptV1 -> Script PlutusScriptV1)
-> PlutusScript PlutusScriptV1 -> Script PlutusScriptV1
forall a b. (a -> b) -> a -> b
$
          ShortByteString -> PlutusScript PlutusScriptV1
forall lang. ShortByteString -> PlutusScript lang
Shelley.PlutusScriptSerialised ShortByteString
s
        Alonzo.PlutusScript Alonzo.PlutusV2 _ ->
          String -> ScriptInEra era
forall a. HasCallStack => String -> a
error String
"fromShelleyBasedScript: PlutusV2 not supported in Alonzo era"
    ShelleyBasedEra era
Shelley.ShelleyBasedEraBabbage ->
      case Script (ShelleyLedgerEra era)
script of
        Alonzo.TimelockScript s ->
          ScriptLanguageInEra SimpleScriptV2 BabbageEra
-> Script SimpleScriptV2 -> ScriptInEra BabbageEra
forall lang era.
ScriptLanguageInEra lang era -> Script lang -> ScriptInEra era
Shelley.ScriptInEra ScriptLanguageInEra SimpleScriptV2 BabbageEra
Shelley.SimpleScriptV2InBabbage (Script SimpleScriptV2 -> ScriptInEra BabbageEra)
-> Script SimpleScriptV2 -> ScriptInEra BabbageEra
forall a b. (a -> b) -> a -> b
$
          SimpleScriptVersion SimpleScriptV2
-> SimpleScript SimpleScriptV2 -> Script SimpleScriptV2
forall lang.
SimpleScriptVersion lang -> SimpleScript lang -> Script lang
Shelley.SimpleScript SimpleScriptVersion SimpleScriptV2
Shelley.SimpleScriptV2 (SimpleScript SimpleScriptV2 -> Script SimpleScriptV2)
-> SimpleScript SimpleScriptV2 -> Script SimpleScriptV2
forall a b. (a -> b) -> a -> b
$
          TimeLocksSupported SimpleScriptV2
-> Timelock StandardCrypto -> SimpleScript SimpleScriptV2
forall lang.
TimeLocksSupported lang
-> Timelock StandardCrypto -> SimpleScript lang
fromAllegraTimelock TimeLocksSupported SimpleScriptV2
Shelley.TimeLocksInSimpleScriptV2 Timelock StandardCrypto
Timelock (Crypto (BabbageEra StandardCrypto))
s
        Alonzo.PlutusScript Alonzo.PlutusV1 s ->
          ScriptLanguageInEra PlutusScriptV1 BabbageEra
-> Script PlutusScriptV1 -> ScriptInEra BabbageEra
forall lang era.
ScriptLanguageInEra lang era -> Script lang -> ScriptInEra era
Shelley.ScriptInEra ScriptLanguageInEra PlutusScriptV1 BabbageEra
Shelley.PlutusScriptV1InBabbage (Script PlutusScriptV1 -> ScriptInEra BabbageEra)
-> Script PlutusScriptV1 -> ScriptInEra BabbageEra
forall a b. (a -> b) -> a -> b
$
          PlutusScriptVersion PlutusScriptV1
-> PlutusScript PlutusScriptV1 -> Script PlutusScriptV1
forall lang.
PlutusScriptVersion lang -> PlutusScript lang -> Script lang
Shelley.PlutusScript PlutusScriptVersion PlutusScriptV1
Shelley.PlutusScriptV1 (PlutusScript PlutusScriptV1 -> Script PlutusScriptV1)
-> PlutusScript PlutusScriptV1 -> Script PlutusScriptV1
forall a b. (a -> b) -> a -> b
$
          ShortByteString -> PlutusScript PlutusScriptV1
forall lang. ShortByteString -> PlutusScript lang
Shelley.PlutusScriptSerialised ShortByteString
s
        Alonzo.PlutusScript Alonzo.PlutusV2 s ->
          ScriptLanguageInEra PlutusScriptV2 BabbageEra
-> Script PlutusScriptV2 -> ScriptInEra BabbageEra
forall lang era.
ScriptLanguageInEra lang era -> Script lang -> ScriptInEra era
Shelley.ScriptInEra ScriptLanguageInEra PlutusScriptV2 BabbageEra
Shelley.PlutusScriptV2InBabbage (Script PlutusScriptV2 -> ScriptInEra BabbageEra)
-> Script PlutusScriptV2 -> ScriptInEra BabbageEra
forall a b. (a -> b) -> a -> b
$
          PlutusScriptVersion PlutusScriptV2
-> PlutusScript PlutusScriptV2 -> Script PlutusScriptV2
forall lang.
PlutusScriptVersion lang -> PlutusScript lang -> Script lang
Shelley.PlutusScript PlutusScriptVersion PlutusScriptV2
Shelley.PlutusScriptV2 (PlutusScript PlutusScriptV2 -> Script PlutusScriptV2)
-> PlutusScript PlutusScriptV2 -> Script PlutusScriptV2
forall a b. (a -> b) -> a -> b
$
          ShortByteString -> PlutusScript PlutusScriptV2
forall lang. ShortByteString -> PlutusScript lang
Shelley.PlutusScriptSerialised ShortByteString
s

  where
  fromAllegraTimelock :: Shelley.TimeLocksSupported lang
                      -> Timelock.Timelock LedgerCrypto.StandardCrypto
                      -> Shelley.SimpleScript lang
  fromAllegraTimelock :: TimeLocksSupported lang
-> Timelock StandardCrypto -> SimpleScript lang
fromAllegraTimelock TimeLocksSupported lang
timelocks = Timelock StandardCrypto -> SimpleScript lang
go
    where
      go :: Timelock StandardCrypto -> SimpleScript lang
go (Timelock.RequireSignature KeyHash 'Witness StandardCrypto
kh) = Hash PaymentKey -> SimpleScript lang
forall lang. Hash PaymentKey -> SimpleScript lang
Shelley.RequireSignature
                                            (KeyHash 'Payment StandardCrypto -> Hash PaymentKey
Shelley.PaymentKeyHash (KeyHash 'Witness StandardCrypto -> KeyHash 'Payment StandardCrypto
forall (a :: KeyRole -> * -> *) (r :: KeyRole) crypto
       (r' :: KeyRole).
HasKeyRole a =>
a r crypto -> a r' crypto
LedgerShelley.coerceKeyRole KeyHash 'Witness StandardCrypto
kh))
      go (Timelock.RequireTimeExpire SlotNo
t) = TimeLocksSupported lang -> SlotNo -> SimpleScript lang
forall lang. TimeLocksSupported lang -> SlotNo -> SimpleScript lang
Shelley.RequireTimeBefore TimeLocksSupported lang
timelocks SlotNo
t
      go (Timelock.RequireTimeStart  SlotNo
t) = TimeLocksSupported lang -> SlotNo -> SimpleScript lang
forall lang. TimeLocksSupported lang -> SlotNo -> SimpleScript lang
Shelley.RequireTimeAfter  TimeLocksSupported lang
timelocks SlotNo
t
      go (Timelock.RequireAllOf      StrictSeq (Timelock StandardCrypto)
s) = [SimpleScript lang] -> SimpleScript lang
forall lang. [SimpleScript lang] -> SimpleScript lang
Shelley.RequireAllOf ((Timelock StandardCrypto -> SimpleScript lang)
-> [Timelock StandardCrypto] -> [SimpleScript lang]
forall a b. (a -> b) -> [a] -> [b]
map Timelock StandardCrypto -> SimpleScript lang
go (StrictSeq (Timelock StandardCrypto) -> [Timelock StandardCrypto]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList StrictSeq (Timelock StandardCrypto)
s))
      go (Timelock.RequireAnyOf      StrictSeq (Timelock StandardCrypto)
s) = [SimpleScript lang] -> SimpleScript lang
forall lang. [SimpleScript lang] -> SimpleScript lang
Shelley.RequireAnyOf ((Timelock StandardCrypto -> SimpleScript lang)
-> [Timelock StandardCrypto] -> [SimpleScript lang]
forall a b. (a -> b) -> [a] -> [b]
map Timelock StandardCrypto -> SimpleScript lang
go (StrictSeq (Timelock StandardCrypto) -> [Timelock StandardCrypto]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList StrictSeq (Timelock StandardCrypto)
s))
      go (Timelock.RequireMOf      Int
i StrictSeq (Timelock StandardCrypto)
s) = Int -> [SimpleScript lang] -> SimpleScript lang
forall lang. Int -> [SimpleScript lang] -> SimpleScript lang
Shelley.RequireMOf Int
i ((Timelock StandardCrypto -> SimpleScript lang)
-> [Timelock StandardCrypto] -> [SimpleScript lang]
forall a b. (a -> b) -> [a] -> [b]
map Timelock StandardCrypto -> SimpleScript lang
go (StrictSeq (Timelock StandardCrypto) -> [Timelock StandardCrypto]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList StrictSeq (Timelock StandardCrypto)
s))

  fromShelleyMultiSig :: LedgerShelley.MultiSig LedgerCrypto.StandardCrypto -> Shelley.SimpleScript lang
  fromShelleyMultiSig :: MultiSig StandardCrypto -> SimpleScript lang
fromShelleyMultiSig = MultiSig StandardCrypto -> SimpleScript lang
forall lang. MultiSig StandardCrypto -> SimpleScript lang
go
    where
      go :: MultiSig StandardCrypto -> SimpleScript lang
go (LedgerShelley.RequireSignature KeyHash 'Witness StandardCrypto
kh)
                                  = Hash PaymentKey -> SimpleScript lang
forall lang. Hash PaymentKey -> SimpleScript lang
Shelley.RequireSignature
                                      (KeyHash 'Payment StandardCrypto -> Hash PaymentKey
Shelley.PaymentKeyHash (KeyHash 'Witness StandardCrypto -> KeyHash 'Payment StandardCrypto
forall (a :: KeyRole -> * -> *) (r :: KeyRole) crypto
       (r' :: KeyRole).
HasKeyRole a =>
a r crypto -> a r' crypto
LedgerShelley.coerceKeyRole KeyHash 'Witness StandardCrypto
kh))
      go (LedgerShelley.RequireAllOf [MultiSig StandardCrypto]
s) = [SimpleScript lang] -> SimpleScript lang
forall lang. [SimpleScript lang] -> SimpleScript lang
Shelley.RequireAllOf ((MultiSig StandardCrypto -> SimpleScript lang)
-> [MultiSig StandardCrypto] -> [SimpleScript lang]
forall a b. (a -> b) -> [a] -> [b]
map MultiSig StandardCrypto -> SimpleScript lang
go [MultiSig StandardCrypto]
s)
      go (LedgerShelley.RequireAnyOf [MultiSig StandardCrypto]
s) = [SimpleScript lang] -> SimpleScript lang
forall lang. [SimpleScript lang] -> SimpleScript lang
Shelley.RequireAnyOf ((MultiSig StandardCrypto -> SimpleScript lang)
-> [MultiSig StandardCrypto] -> [SimpleScript lang]
forall a b. (a -> b) -> [a] -> [b]
map MultiSig StandardCrypto -> SimpleScript lang
go [MultiSig StandardCrypto]
s)
      go (LedgerShelley.RequireMOf Int
m [MultiSig StandardCrypto]
s) = Int -> [SimpleScript lang] -> SimpleScript lang
forall lang. Int -> [SimpleScript lang] -> SimpleScript lang
Shelley.RequireMOf Int
m ((MultiSig StandardCrypto -> SimpleScript lang)
-> [MultiSig StandardCrypto] -> [SimpleScript lang]
forall a b. (a -> b) -> [a] -> [b]
map MultiSig StandardCrypto -> SimpleScript lang
go [MultiSig StandardCrypto]
s)