-----------------------------------------------------------------------------
--
-- Module      :  $Headers
-- Copyright   :  (c) 2021 Brian W Bush
-- License     :  MIT
--
-- Maintainer  :  Brian W Bush <code@functionally.io>
-- Stability   :  Experimental
-- Portability :  Portable
--
-- | Monitor and act on the blockchain.
--
-----------------------------------------------------------------------------


{-# LANGUAGE RecordWildCards    #-}


module Pigy.Chain (
-- * Running
  runChain
) where


import Cardano.Api                (BlockHeader(..), ChainPoint, SlotNo(..), StakeAddressReference(NoStakeAddress), TxIn(..), TxOut(..), TxOutValue(..), Value, selectAsset)
import Control.Lens               ((.~), (%~))
import Control.Monad              (unless, when)
import Control.Monad.IO.Class     (MonadIO, liftIO)
import Control.Monad.State.Strict (MonadState(..), modify)
import Data.Default               (Default(..))
import Data.IORef                 (newIORef)
import Data.Maybe                 (mapMaybe)
import Mantis.Chain               (watchTransactions)
import Mantis.Script              (mintingScript)
import Mantis.Types               (MantisM, runMantisToIO)
import Mantis.Transaction         (printValueIO)
import Mantis.Wallet              (showAddressMary, stakeReferenceMary)
import Pigy.Chain.Mint            (checkValue, mint)
import Pigy.Chain.Types           (Chain, ChainState(..), History, MaryAddress, Origins, Pendings, activeLens, currentLens, historyLens, originsLens, pendingsLens, withChainState)
import Pigy.Types                 (Context(..), KeyedAddress(..), Mode(..))

import qualified Data.Map.Strict as M  (delete, difference, fromListWith, insert, lookup, member, toList)


-- | The Ouroboros security parameter.
kSecurity :: Int
kSecurity :: Int
kSecurity = Int
2160


-- | Record history.
record :: SlotNo              -- ^ The curent slot number.
       -> (Origins, Pendings) -- ^ The tracked transactions and queued mintings.
       -> History             -- ^ The original history.
       -> History             -- ^ The augmented history.
record :: SlotNo -> (Origins, Pendings) -> History -> History
record SlotNo
slot (Origins, Pendings)
sourcePending = Int -> History -> History
forall a. Int -> [a] -> [a]
take Int
kSecurity (History -> History) -> (History -> History) -> History -> History
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((SlotNo
slot, (Origins, Pendings)
sourcePending) (SlotNo, (Origins, Pendings)) -> History -> History
forall a. a -> [a] -> [a]
:)


-- | Roll back history.
rollback :: SlotNo  -- ^ The slot number to revert to.
         -> History -- ^ The original history.
         -> History -- ^ The rolled-back history.
rollback :: SlotNo -> History -> History
rollback SlotNo
slot = ((SlotNo, (Origins, Pendings)) -> Bool) -> History -> History
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (((SlotNo, (Origins, Pendings)) -> Bool) -> History -> History)
-> ((SlotNo, (Origins, Pendings)) -> Bool) -> History -> History
forall a b. (a -> b) -> a -> b
$ (SlotNo -> SlotNo -> Bool
forall a. Eq a => a -> a -> Bool
/= SlotNo
slot) (SlotNo -> Bool)
-> ((SlotNo, (Origins, Pendings)) -> SlotNo)
-> (SlotNo, (Origins, Pendings))
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SlotNo, (Origins, Pendings)) -> SlotNo
forall a b. (a, b) -> a
fst


-- | Extract the slot number from the chain point.
toSlotNo :: ChainPoint -- ^ The chain point.
         -> SlotNo     -- ^ The slot number.
toSlotNo :: ChainPoint -> SlotNo
toSlotNo ChainPoint
point =
  -- FIXME: Find a less fragile way to extract the slot number at a chain point.
  case ChainPoint -> String
forall a. Show a => a -> String
show ChainPoint
point of
    String
"ChainPointAtGenesis" -> Word64 -> SlotNo
SlotNo Word64
0
    String
text                  -> Word64 -> SlotNo
SlotNo (Word64 -> SlotNo) -> (String -> Word64) -> String -> SlotNo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Word64
forall a. Read a => String -> a
read (String -> Word64) -> (String -> String) -> String -> Word64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
')') (String -> SlotNo) -> String -> SlotNo
forall a b. (a -> b) -> a -> b
$ Int -> String -> String
forall a. Int -> [a] -> [a]
drop Int
19 String
text


-- | Allow minting.
makeActive :: Chain () -- ^ Action to modify the chain state.
makeActive :: Chain ()
makeActive =
  do
    ChainState{Bool
History
Pendings
Origins
MaryAddress
ScriptHash
MaryScript
SlotNo
Context
Value -> Bool
checker :: ChainState -> Value -> Bool
scriptHash :: ChainState -> ScriptHash
script :: ChainState -> MaryScript
scriptAddress :: ChainState -> MaryAddress
history :: ChainState -> History
pendings :: ChainState -> Pendings
origins :: ChainState -> Origins
current :: ChainState -> SlotNo
active :: ChainState -> Bool
context :: ChainState -> Context
checker :: Value -> Bool
scriptHash :: ScriptHash
script :: MaryScript
scriptAddress :: MaryAddress
history :: History
pendings :: Pendings
origins :: Origins
current :: SlotNo
active :: Bool
context :: Context
..} <- StateT ChainState IO ChainState
forall s (m :: * -> *). MonadState s m => m s
get
    Bool -> Chain () -> Chain ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
active
      (Chain () -> Chain ()) -> Chain () -> Chain ()
forall a b. (a -> b) -> a -> b
$ do
        IO () -> Chain ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
          (IO () -> Chain ()) -> IO () -> Chain ()
forall a b. (a -> b) -> a -> b
$ do
            String -> IO ()
putStrLn String
""
            String -> IO ()
putStrLn String
"First idling."
        (ChainState -> ChainState) -> Chain ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify
          ((ChainState -> ChainState) -> Chain ())
-> (ChainState -> ChainState) -> Chain ()
forall a b. (a -> b) -> a -> b
$ (Bool -> Identity Bool) -> ChainState -> Identity ChainState
Lens' ChainState Bool
activeLens ((Bool -> Identity Bool) -> ChainState -> Identity ChainState)
-> Bool -> ChainState -> ChainState
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Bool
True


-- | Record a new block.
recordBlock :: SlotNo   -- ^ The slot number.
            -> Chain () -- ^ Action to modify the chain state.
recordBlock :: SlotNo -> Chain ()
recordBlock SlotNo
slot =
  do
    ChainState{Bool
History
Pendings
Origins
MaryAddress
ScriptHash
MaryScript
SlotNo
Context
Value -> Bool
checker :: Value -> Bool
scriptHash :: ScriptHash
script :: MaryScript
scriptAddress :: MaryAddress
history :: History
pendings :: Pendings
origins :: Origins
current :: SlotNo
active :: Bool
context :: Context
checker :: ChainState -> Value -> Bool
scriptHash :: ChainState -> ScriptHash
script :: ChainState -> MaryScript
scriptAddress :: ChainState -> MaryAddress
history :: ChainState -> History
pendings :: ChainState -> Pendings
origins :: ChainState -> Origins
current :: ChainState -> SlotNo
active :: ChainState -> Bool
context :: ChainState -> Context
..} <- StateT ChainState IO ChainState
forall s (m :: * -> *). MonadState s m => m s
get
    Bool -> Chain () -> Chain ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Context -> Bool
verbose Context
context Bool -> Bool -> Bool
&& Bool
active)
      (Chain () -> Chain ()) -> (IO () -> Chain ()) -> IO () -> Chain ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> Chain ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
      (IO () -> Chain ()) -> IO () -> Chain ()
forall a b. (a -> b) -> a -> b
$ do
        String -> IO ()
putStrLn String
""
        String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"New block: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ SlotNo -> String
forall a. Show a => a -> String
show SlotNo
current String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" -> " String -> String -> String
forall a. [a] -> [a] -> [a]
++ SlotNo -> String
forall a. Show a => a -> String
show SlotNo
slot
    (ChainState -> ChainState) -> Chain ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify
      ((ChainState -> ChainState) -> Chain ())
-> (ChainState -> ChainState) -> Chain ()
forall a b. (a -> b) -> a -> b
$ ((SlotNo -> Identity SlotNo) -> ChainState -> Identity ChainState
Lens' ChainState SlotNo
currentLens ((SlotNo -> Identity SlotNo) -> ChainState -> Identity ChainState)
-> SlotNo -> ChainState -> ChainState
forall s t a b. ASetter s t a b -> b -> s -> t
.~ SlotNo
slot)
      (ChainState -> ChainState)
-> (ChainState -> ChainState) -> ChainState -> ChainState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((History -> Identity History) -> ChainState -> Identity ChainState
Lens' ChainState History
historyLens ((History -> Identity History)
 -> ChainState -> Identity ChainState)
-> (History -> History) -> ChainState -> ChainState
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ SlotNo -> (Origins, Pendings) -> History -> History
record SlotNo
current (Origins
origins, Pendings
pendings))


-- | Roll back the chain state.
recordRollback :: SlotNo   -- ^ The slot number to roll back to.
               -> Chain () -- ^ The action to modify the chain state.
recordRollback :: SlotNo -> Chain ()
recordRollback SlotNo
slot =
  do
    ChainState{Bool
History
Pendings
Origins
MaryAddress
ScriptHash
MaryScript
SlotNo
Context
Value -> Bool
checker :: Value -> Bool
scriptHash :: ScriptHash
script :: MaryScript
scriptAddress :: MaryAddress
history :: History
pendings :: Pendings
origins :: Origins
current :: SlotNo
active :: Bool
context :: Context
checker :: ChainState -> Value -> Bool
scriptHash :: ChainState -> ScriptHash
script :: ChainState -> MaryScript
scriptAddress :: ChainState -> MaryAddress
history :: ChainState -> History
pendings :: ChainState -> Pendings
origins :: ChainState -> Origins
current :: ChainState -> SlotNo
active :: ChainState -> Bool
context :: ChainState -> Context
..} <- StateT ChainState IO ChainState
forall s (m :: * -> *). MonadState s m => m s
get
    let
      history' :: History
history'@((SlotNo
_, (Origins
origins', Pendings
pendings')) : History
_) = SlotNo -> History -> History
rollback SlotNo
slot History
history
    IO () -> Chain ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
      (IO () -> Chain ()) -> IO () -> Chain ()
forall a b. (a -> b) -> a -> b
$ do
        String -> IO ()
putStrLn String
""
        String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Rollback: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ SlotNo -> String
forall a. Show a => a -> String
show SlotNo
slot String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" <- " String -> String -> String
forall a. [a] -> [a] -> [a]
++ SlotNo -> String
forall a. Show a => a -> String
show SlotNo
current
    (Origins, Origins) -> (Pendings, Pendings) -> Chain ()
printRollback (Origins
origins, Origins
origins') (Pendings
pendings, Pendings
pendings')
    (ChainState -> ChainState) -> Chain ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify
      ((ChainState -> ChainState) -> Chain ())
-> (ChainState -> ChainState) -> Chain ()
forall a b. (a -> b) -> a -> b
$ ((SlotNo -> Identity SlotNo) -> ChainState -> Identity ChainState
Lens' ChainState SlotNo
currentLens  ((SlotNo -> Identity SlotNo) -> ChainState -> Identity ChainState)
-> SlotNo -> ChainState -> ChainState
forall s t a b. ASetter s t a b -> b -> s -> t
.~ SlotNo
slot     )
      (ChainState -> ChainState)
-> (ChainState -> ChainState) -> ChainState -> ChainState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Origins -> Identity Origins) -> ChainState -> Identity ChainState
Lens' ChainState Origins
originsLens  ((Origins -> Identity Origins)
 -> ChainState -> Identity ChainState)
-> Origins -> ChainState -> ChainState
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Origins
origins' )
      (ChainState -> ChainState)
-> (ChainState -> ChainState) -> ChainState -> ChainState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Pendings -> Identity Pendings)
-> ChainState -> Identity ChainState
Lens' ChainState Pendings
pendingsLens ((Pendings -> Identity Pendings)
 -> ChainState -> Identity ChainState)
-> Pendings -> ChainState -> ChainState
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Pendings
pendings')
      (ChainState -> ChainState)
-> (ChainState -> ChainState) -> ChainState -> ChainState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((History -> Identity History) -> ChainState -> Identity ChainState
Lens' ChainState History
historyLens  ((History -> Identity History)
 -> ChainState -> Identity ChainState)
-> History -> ChainState -> ChainState
forall s t a b. ASetter s t a b -> b -> s -> t
.~ History
history' )


-- | Record the input to a transaction.
recordInput :: SlotNo   -- ^ The slot number.
            -> TxIn     -- ^ The spent UTxO.
            -> Chain () -- ^ The action to modify the chain state.
recordInput :: SlotNo -> TxIn -> Chain ()
recordInput SlotNo
slot TxIn
txIn =
  do
    ChainState{Bool
History
Pendings
Origins
MaryAddress
ScriptHash
MaryScript
SlotNo
Context
Value -> Bool
checker :: Value -> Bool
scriptHash :: ScriptHash
script :: MaryScript
scriptAddress :: MaryAddress
history :: History
pendings :: Pendings
origins :: Origins
current :: SlotNo
active :: Bool
context :: Context
checker :: ChainState -> Value -> Bool
scriptHash :: ChainState -> ScriptHash
script :: ChainState -> MaryScript
scriptAddress :: ChainState -> MaryAddress
history :: ChainState -> History
pendings :: ChainState -> Pendings
origins :: ChainState -> Origins
current :: ChainState -> SlotNo
active :: ChainState -> Bool
context :: ChainState -> Context
..} <- StateT ChainState IO ChainState
forall s (m :: * -> *). MonadState s m => m s
get
    let
      found :: Bool
found     = TxIn
txIn TxIn -> Origins -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`M.member` Origins
origins
      isPending :: Bool
isPending = TxIn
txIn TxIn -> Pendings -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`M.member` Pendings
pendings
    Bool -> Chain () -> Chain ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
found
      (Chain () -> Chain ()) -> Chain () -> Chain ()
forall a b. (a -> b) -> a -> b
$ do
        Bool -> Chain () -> Chain ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Context -> Bool
verbose Context
context Bool -> Bool -> Bool
|| Bool
isPending)
          (Chain () -> Chain ()) -> (IO () -> Chain ()) -> IO () -> Chain ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> Chain ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
          (IO () -> Chain ()) -> IO () -> Chain ()
forall a b. (a -> b) -> a -> b
$ do
            String -> IO ()
putStrLn String
""
            String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ SlotNo -> String
forall a. Show a => a -> String
show SlotNo
slot String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": spent " String -> String -> String
forall a. [a] -> [a] -> [a]
++ TxIn -> String
forall a. Show a => a -> String
show TxIn
txIn
        (ChainState -> ChainState) -> Chain ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify
          ((ChainState -> ChainState) -> Chain ())
-> (ChainState -> ChainState) -> Chain ()
forall a b. (a -> b) -> a -> b
$ ((Origins -> Identity Origins) -> ChainState -> Identity ChainState
Lens' ChainState Origins
originsLens  ((Origins -> Identity Origins)
 -> ChainState -> Identity ChainState)
-> (Origins -> Origins) -> ChainState -> ChainState
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ TxIn -> Origins -> Origins
forall k a. Ord k => k -> Map k a -> Map k a
M.delete TxIn
txIn)
          (ChainState -> ChainState)
-> (ChainState -> ChainState) -> ChainState -> ChainState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Pendings -> Identity Pendings)
-> ChainState -> Identity ChainState
Lens' ChainState Pendings
pendingsLens ((Pendings -> Identity Pendings)
 -> ChainState -> Identity ChainState)
-> (Pendings -> Pendings) -> ChainState -> ChainState
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ TxIn -> Pendings -> Pendings
forall k a. Ord k => k -> Map k a -> Map k a
M.delete TxIn
txIn)


-- | Record the output of a transaction.
recordOutput :: [TxIn]      -- ^ The spend UTxOs.
             -> TxIn        -- ^ The UTxO.
             -> MaryAddress -- ^ The destination address.
             -> Value       -- ^ The total value.
             -> Chain ()    -- ^ The action to modify the chain state.
recordOutput :: [TxIn] -> TxIn -> MaryAddress -> Value -> Chain ()
recordOutput [TxIn]
inputs TxIn
output MaryAddress
destination Value
value =
  do
    ChainState{Bool
History
Pendings
Origins
MaryAddress
ScriptHash
MaryScript
SlotNo
Context
Value -> Bool
checker :: Value -> Bool
scriptHash :: ScriptHash
script :: MaryScript
scriptAddress :: MaryAddress
history :: History
pendings :: Pendings
origins :: Origins
current :: SlotNo
active :: Bool
context :: Context
checker :: ChainState -> Value -> Bool
scriptHash :: ChainState -> ScriptHash
script :: ChainState -> MaryScript
scriptAddress :: ChainState -> MaryAddress
history :: ChainState -> History
pendings :: ChainState -> Pendings
origins :: ChainState -> Origins
current :: ChainState -> SlotNo
active :: ChainState -> Bool
context :: ChainState -> Context
..} <- StateT ChainState IO ChainState
forall s (m :: * -> *). MonadState s m => m s
get
    (ChainState -> ChainState) -> Chain ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify
      ((ChainState -> ChainState) -> Chain ())
-> (ChainState -> ChainState) -> Chain ()
forall a b. (a -> b) -> a -> b
$ (Origins -> Identity Origins) -> ChainState -> Identity ChainState
Lens' ChainState Origins
originsLens ((Origins -> Identity Origins)
 -> ChainState -> Identity ChainState)
-> (Origins -> Origins) -> ChainState -> ChainState
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ TxIn -> MaryAddress -> Origins -> Origins
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert TxIn
output MaryAddress
destination
    let
      sources :: [MaryAddress]
sources = (TxIn -> Maybe MaryAddress) -> [TxIn] -> [MaryAddress]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (TxIn -> Origins -> Maybe MaryAddress
forall k a. Ord k => k -> Map k a -> Maybe a
`M.lookup` Origins
origins) [TxIn]
inputs
      valid :: Bool
valid = Value -> Bool
checker Value
value
    Bool -> Chain () -> Chain ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Context -> Bool
verbose Context
context Bool -> Bool -> Bool
|| MaryAddress
destination MaryAddress -> MaryAddress -> Bool
forall a. Eq a => a -> a -> Bool
== MaryAddress
scriptAddress)
      (Chain () -> Chain ()) -> (IO () -> Chain ()) -> IO () -> Chain ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> Chain ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
      (IO () -> Chain ()) -> IO () -> Chain ()
forall a b. (a -> b) -> a -> b
$ do
        String -> IO ()
putStrLn String
""
        String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Output: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ TxIn -> String
forall a. Show a => a -> String
show TxIn
output
        [IO ()] -> IO ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_
          [
            String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"  Source: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show (MaryAddress -> String
showAddressMary MaryAddress
source')
          |
            MaryAddress
source' <- [MaryAddress]
sources
          ]
        String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"  Destination: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ MaryAddress -> String
showAddressMary MaryAddress
destination
        String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"  Stake: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ StakeAddressReference -> String
forall a. Show a => a -> String
show (MaryAddress -> StakeAddressReference
stakeReferenceMary MaryAddress
destination)
        String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"  To me: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Bool -> String
forall a. Show a => a -> String
show (MaryAddress
destination MaryAddress -> MaryAddress -> Bool
forall a. Eq a => a -> a -> Bool
== MaryAddress
scriptAddress)
        String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"  Valid: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Bool -> String
forall a. Show a => a -> String
show Bool
valid
        String -> Value -> IO ()
printValueIO String
"  " Value
value
    Bool -> Chain () -> Chain ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (MaryAddress
destination MaryAddress -> MaryAddress -> Bool
forall a. Eq a => a -> a -> Bool
== MaryAddress
scriptAddress Bool -> Bool -> Bool
&& Bool -> Bool
not ([MaryAddress] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [MaryAddress]
sources))
      (Chain () -> Chain ()) -> Chain () -> Chain ()
forall a b. (a -> b) -> a -> b
$ if Bool
active Bool -> Bool -> Bool
&& Bool
valid Bool -> Bool -> Bool
&& Context -> Mode
operation Context
context Mode -> Mode -> Bool
forall a. Eq a => a -> a -> Bool
== Mode
Aggressive
          then [TxIn] -> (MaryAddress, Value) -> Chain ()
createToken [TxIn
output] ([MaryAddress] -> MaryAddress
forall a. [a] -> a
head [MaryAddress]
sources, Value
value)
          else do
                 IO () -> Chain ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Chain ()) -> IO () -> Chain ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn String
"  Queued for creation."
                 (ChainState -> ChainState) -> Chain ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify
                   ((ChainState -> ChainState) -> Chain ())
-> (ChainState -> ChainState) -> Chain ()
forall a b. (a -> b) -> a -> b
$ (Pendings -> Identity Pendings)
-> ChainState -> Identity ChainState
Lens' ChainState Pendings
pendingsLens ((Pendings -> Identity Pendings)
 -> ChainState -> Identity ChainState)
-> (Pendings -> Pendings) -> ChainState -> ChainState
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ TxIn -> ([MaryAddress], Value) -> Pendings -> Pendings
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert TxIn
output ([MaryAddress]
sources, Value
value)


-- | Mint a token from a single transaction.
createPendingSingle :: Chain () -- ^ The action to modify the chain state.
createPendingSingle :: Chain ()
createPendingSingle =
  do
    ChainState{Bool
History
Pendings
Origins
MaryAddress
ScriptHash
MaryScript
SlotNo
Context
Value -> Bool
checker :: Value -> Bool
scriptHash :: ScriptHash
script :: MaryScript
scriptAddress :: MaryAddress
history :: History
pendings :: Pendings
origins :: Origins
current :: SlotNo
active :: Bool
context :: Context
checker :: ChainState -> Value -> Bool
scriptHash :: ChainState -> ScriptHash
script :: ChainState -> MaryScript
scriptAddress :: ChainState -> MaryAddress
history :: ChainState -> History
pendings :: ChainState -> Pendings
origins :: ChainState -> Origins
current :: ChainState -> SlotNo
active :: ChainState -> Bool
context :: ChainState -> Context
..} <- StateT ChainState IO ChainState
forall s (m :: * -> *). MonadState s m => m s
get
    [Chain ()] -> Chain ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_
      [
        [TxIn] -> (MaryAddress, Value) -> Chain ()
createToken [TxIn
output] ([MaryAddress] -> MaryAddress
forall a. [a] -> a
head [MaryAddress]
sources, Value
value)
      |
        (TxIn
output, ([MaryAddress]
sources, Value
value)) <- Pendings -> [(TxIn, ([MaryAddress], Value))]
forall k a. Map k a -> [(k, a)]
M.toList Pendings
pendings
      , Value -> Bool
checker Value
value
      ]


-- | Mint a token from multiple transactions.
createPendingMultiple :: Chain ()-- ^ The action to modify the chain state.
createPendingMultiple :: Chain ()
createPendingMultiple =
  do
    ChainState{Bool
History
Pendings
Origins
MaryAddress
ScriptHash
MaryScript
SlotNo
Context
Value -> Bool
checker :: Value -> Bool
scriptHash :: ScriptHash
script :: MaryScript
scriptAddress :: MaryAddress
history :: History
pendings :: Pendings
origins :: Origins
current :: SlotNo
active :: Bool
context :: Context
checker :: ChainState -> Value -> Bool
scriptHash :: ChainState -> ScriptHash
script :: ChainState -> MaryScript
scriptAddress :: ChainState -> MaryAddress
history :: ChainState -> History
pendings :: ChainState -> Pendings
origins :: ChainState -> Origins
current :: ChainState -> SlotNo
active :: ChainState -> Bool
context :: ChainState -> Context
..} <- StateT ChainState IO ChainState
forall s (m :: * -> *). MonadState s m => m s
get
    [Chain ()] -> Chain ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_
      [
        do
          Bool -> Chain () -> Chain ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Context -> Bool
verbose Context
context Bool -> Bool -> Bool
|| Bool
valid)
            (Chain () -> Chain ()) -> (IO () -> Chain ()) -> IO () -> Chain ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> Chain ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
            (IO () -> Chain ()) -> IO () -> Chain ()
forall a b. (a -> b) -> a -> b
$ do
              String -> IO ()
putStrLn String
""
              String -> IO ()
putStrLn String
"Multiple input transactions:"
              String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"  Stake: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
stake
              [IO ()] -> IO ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_
                [
                  String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"  Source: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show (MaryAddress -> String
showAddressMary MaryAddress
source)
                |
                  MaryAddress
source <- [MaryAddress]
sources
                ]
              String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"  Valid: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Bool -> String
forall a. Show a => a -> String
show Bool
valid
              String -> Value -> IO ()
printValueIO String
"  " Value
value
          Bool -> Chain () -> Chain ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
valid
            (Chain () -> Chain ()) -> Chain () -> Chain ()
forall a b. (a -> b) -> a -> b
$ [TxIn] -> (MaryAddress, Value) -> Chain ()
createToken [TxIn]
outputs ([MaryAddress] -> MaryAddress
forall a. [a] -> a
head [MaryAddress]
sources, Value
value)
      |
        let pending' :: Map String ([TxIn], [MaryAddress], Value)
pending' = (([TxIn], [MaryAddress], Value)
 -> ([TxIn], [MaryAddress], Value)
 -> ([TxIn], [MaryAddress], Value))
-> [(String, ([TxIn], [MaryAddress], Value))]
-> Map String ([TxIn], [MaryAddress], Value)
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
M.fromListWith
                         (
                           \([TxIn]
outputs, [MaryAddress]
sources, Value
value) ([TxIn]
outputs', [MaryAddress]
sources', Value
value') ->
                             (
                               [TxIn]
outputs [TxIn] -> [TxIn] -> [TxIn]
forall a. Semigroup a => a -> a -> a
<> [TxIn]
outputs'
                             , [MaryAddress]
sources [MaryAddress] -> [MaryAddress] -> [MaryAddress]
forall a. Semigroup a => a -> a -> a
<> [MaryAddress]
sources'
                             , Value
value   Value -> Value -> Value
forall a. Semigroup a => a -> a -> a
<> Value
value'
                             )
                         )
                         ([(String, ([TxIn], [MaryAddress], Value))]
 -> Map String ([TxIn], [MaryAddress], Value))
-> ([(TxIn, ([MaryAddress], Value))]
    -> [(String, ([TxIn], [MaryAddress], Value))])
-> [(TxIn, ([MaryAddress], Value))]
-> Map String ([TxIn], [MaryAddress], Value)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((TxIn, ([MaryAddress], Value))
 -> (String, ([TxIn], [MaryAddress], Value)))
-> [(TxIn, ([MaryAddress], Value))]
-> [(String, ([TxIn], [MaryAddress], Value))]
forall a b. (a -> b) -> [a] -> [b]
map
                         (
                           \(TxIn
output, ([MaryAddress]
sources, Value
value)) ->
                             (
                               StakeAddressReference -> String
forall a. Show a => a -> String
show (StakeAddressReference -> String)
-> (MaryAddress -> StakeAddressReference) -> MaryAddress -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MaryAddress -> StakeAddressReference
stakeReferenceMary (MaryAddress -> String) -> MaryAddress -> String
forall a b. (a -> b) -> a -> b
$ [MaryAddress] -> MaryAddress
forall a. [a] -> a
head [MaryAddress]
sources
                             , (
                                 [TxIn
output]
                               , [MaryAddress]
sources
                               , Value
value
                               )
                             )
                         )
                         ([(TxIn, ([MaryAddress], Value))]
 -> Map String ([TxIn], [MaryAddress], Value))
-> [(TxIn, ([MaryAddress], Value))]
-> Map String ([TxIn], [MaryAddress], Value)
forall a b. (a -> b) -> a -> b
$ Pendings -> [(TxIn, ([MaryAddress], Value))]
forall k a. Map k a -> [(k, a)]
M.toList Pendings
pendings
      , (String
stake, ([TxIn]
outputs, [MaryAddress]
sources, Value
value)) <- Map String ([TxIn], [MaryAddress], Value)
-> [(String, ([TxIn], [MaryAddress], Value))]
forall k a. Map k a -> [(k, a)]
M.toList Map String ([TxIn], [MaryAddress], Value)
pending'
      , let valid :: Bool
valid = Value -> Bool
checker Value
value
      , String
stake String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= StakeAddressReference -> String
forall a. Show a => a -> String
show StakeAddressReference
NoStakeAddress
      ]


-- | Mint or burn a token.
createToken :: [TxIn]               -- ^ The UTxOs to spend.
            -> (MaryAddress, Value) -- ^ The destination and total value.
            -> Chain ()             -- ^ The action to modify the chain state.
createToken :: [TxIn] -> (MaryAddress, Value) -> Chain ()
createToken [TxIn]
inputs (MaryAddress
destination, Value
value) =
  do
    ChainState{Bool
History
Pendings
Origins
MaryAddress
ScriptHash
MaryScript
SlotNo
Context
Value -> Bool
checker :: Value -> Bool
scriptHash :: ScriptHash
script :: MaryScript
scriptAddress :: MaryAddress
history :: History
pendings :: Pendings
origins :: Origins
current :: SlotNo
active :: Bool
context :: Context
checker :: ChainState -> Value -> Bool
scriptHash :: ChainState -> ScriptHash
script :: ChainState -> MaryScript
scriptAddress :: ChainState -> MaryAddress
history :: ChainState -> History
pendings :: ChainState -> Pendings
origins :: ChainState -> Origins
current :: ChainState -> SlotNo
active :: ChainState -> Bool
context :: ChainState -> Context
..} <- StateT ChainState IO ChainState
forall s (m :: * -> *). MonadState s m => m s
get
    IO () -> Chain ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
      (IO () -> Chain ()) -> IO () -> Chain ()
forall a b. (a -> b) -> a -> b
$ do
        String -> IO ()
putStrLn String
""
        String -> IO ()
putStrLn String
"Minting token."
        [IO ()] -> IO ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_
          [
            String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"  Input: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ TxIn -> String
forall a. Show a => a -> String
show TxIn
input
          |
            TxIn
input <- [TxIn]
inputs
          ]
        String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"  Destination: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ MaryAddress -> String
showAddressMary MaryAddress
destination
        String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"  To me: "String -> String -> String
forall a. [a] -> [a] -> [a]
++ Bool -> String
forall a. Show a => a -> String
show (MaryAddress
destination MaryAddress -> MaryAddress -> Bool
forall a. Eq a => a -> a -> Bool
== MaryAddress
scriptAddress)
        String -> Value -> IO ()
printValueIO String
"  " Value
value
    [Chain ()] -> Chain ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_
      [
        -- FIXME: Consider deleting the transactions only if the minting succeeeds.
        (ChainState -> ChainState) -> Chain ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify
          ((ChainState -> ChainState) -> Chain ())
-> (ChainState -> ChainState) -> Chain ()
forall a b. (a -> b) -> a -> b
$ ((Origins -> Identity Origins) -> ChainState -> Identity ChainState
Lens' ChainState Origins
originsLens  ((Origins -> Identity Origins)
 -> ChainState -> Identity ChainState)
-> (Origins -> Origins) -> ChainState -> ChainState
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ TxIn -> Origins -> Origins
forall k a. Ord k => k -> Map k a -> Map k a
M.delete TxIn
input)
          (ChainState -> ChainState)
-> (ChainState -> ChainState) -> ChainState -> ChainState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Pendings -> Identity Pendings)
-> ChainState -> Identity ChainState
Lens' ChainState Pendings
pendingsLens ((Pendings -> Identity Pendings)
 -> ChainState -> Identity ChainState)
-> (Pendings -> Pendings) -> ChainState -> ChainState
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ TxIn -> Pendings -> Pendings
forall k a. Ord k => k -> Map k a -> Map k a
M.delete TxIn
input)
      |
        TxIn
input <-[TxIn]
inputs
      ]
    Bool -> Chain () -> Chain ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (MaryAddress
destination MaryAddress -> MaryAddress -> Bool
forall a. Eq a => a -> a -> Bool
== MaryAddress
scriptAddress)
      (Chain () -> Chain ()) -> Chain () -> Chain ()
forall a b. (a -> b) -> a -> b
$ IO () -> Chain ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Chain ()) -> IO () -> Chain ()
forall a b. (a -> b) -> a -> b
$ do
        let
          message :: [String]
message =
            case (Value -> AssetId -> Quantity
selectAsset Value
value (AssetId -> Quantity) -> AssetId -> Quantity
forall a b. (a -> b) -> a -> b
$ Context -> AssetId
token Context
context, [TxIn] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [TxIn]
inputs) of
              (Quantity
1, Int
1) -> [
                          String
"Thank you!"
                        ]
              (Quantity
1, Int
_) -> [
                          String
"Please send the tokens and ADA in a single transaction."
                        ]
              (Quantity
_, Int
1) -> [
                          String
"There is a limit of one minting per transaction."
                        , String
"Sending more that one PIGY does not mint more pig images."
                        ]
              (Quantity
_, Int
_) -> [
                          String
"There is a limit of one minting per transaction."
                        , String
"Sending more that one PIGY does not mint more pig images."
                        , String
"Also, please send the tokens and ADA in a single transaction."
                        ]
        Either String ()
result <- MantisM IO () -> IO (Either String ())
forall a. MantisM IO a -> IO (Either String a)
runMantisToIO (MantisM IO () -> IO (Either String ()))
-> MantisM IO () -> IO (Either String ())
forall a b. (a -> b) -> a -> b
$ Context
-> [TxIn] -> MaryAddress -> Value -> [String] -> MantisM IO ()
forall (m :: * -> *).
(MonadFail m, MonadIO m) =>
Context
-> [TxIn] -> MaryAddress -> Value -> [String] -> MantisM m ()
mint Context
context [TxIn]
inputs MaryAddress
destination Value
value [String]
message
        case Either String ()
result of
          Right () -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
          Left  String
e  -> String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
e


-- | Print diagnostic information for a rollback.
printRollback :: (Origins , Origins ) -- ^ The prior and posterior tracking of transaction origins.
              -> (Pendings, Pendings) -- ^ The prior and posterior queues for minting.
              -> Chain ()             -- ^ The action to modify the chain state.
printRollback :: (Origins, Origins) -> (Pendings, Pendings) -> Chain ()
printRollback (Origins
origins, Origins
origins') (Pendings
pendings, Pendings
pendings') =
  do
    Bool -> Chain () -> Chain ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Origins
origins Origins -> Origins -> Bool
forall a. Eq a => a -> a -> Bool
== Origins
origins')
      (Chain () -> Chain ()) -> (IO () -> Chain ()) -> IO () -> Chain ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> Chain ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
      (IO () -> Chain ()) -> IO () -> Chain ()
forall a b. (a -> b) -> a -> b
$ do
        String -> IO ()
putStrLn String
"  Origins:"
        String -> Origins -> IO ()
printOrigins String
"Removed by rollback:"
          (Origins -> IO ()) -> Origins -> IO ()
forall a b. (a -> b) -> a -> b
$ Origins
origins Origins -> Origins -> Origins
forall k a b. Ord k => Map k a -> Map k b -> Map k a
`M.difference` Origins
origins'
        String -> Origins -> IO ()
printOrigins String
"Added by rollback:"
          (Origins -> IO ()) -> Origins -> IO ()
forall a b. (a -> b) -> a -> b
$ Origins
origins' Origins -> Origins -> Origins
forall k a b. Ord k => Map k a -> Map k b -> Map k a
`M.difference` Origins
origins
    Bool -> Chain () -> Chain ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Pendings
pendings Pendings -> Pendings -> Bool
forall a. Eq a => a -> a -> Bool
== Pendings
pendings')
      (Chain () -> Chain ()) -> (IO () -> Chain ()) -> IO () -> Chain ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> Chain ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
      (IO () -> Chain ()) -> IO () -> Chain ()
forall a b. (a -> b) -> a -> b
$ do
        String -> Pendings -> IO ()
printPendings String
"Removed by rollback:"
          (Pendings -> IO ()) -> Pendings -> IO ()
forall a b. (a -> b) -> a -> b
$ Pendings
pendings Pendings -> Pendings -> Pendings
forall k a b. Ord k => Map k a -> Map k b -> Map k a
`M.difference` Pendings
pendings'
        String -> IO ()
putStrLn String
"  Pendings:"
        String -> Pendings -> IO ()
printPendings String
"Added by rollback:"
          (Pendings -> IO ()) -> Pendings -> IO ()
forall a b. (a -> b) -> a -> b
$ Pendings
pendings' Pendings -> Pendings -> Pendings
forall k a b. Ord k => Map k a -> Map k b -> Map k a
`M.difference` Pendings
pendings


-- | Print diagnostic information for transaction origins.
printOrigins :: String  -- ^ The prefatory message.
             -> Origins -- ^ The transaction origins.
             -> IO ()   -- ^ The action to print the information.
printOrigins :: String -> Origins -> IO ()
printOrigins String
message Origins
origins' =
  do
    String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"    " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
message
    [IO ()] -> IO ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_
      [
        do
          String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"      " String -> String -> String
forall a. [a] -> [a] -> [a]
++ TxIn -> String
forall a. Show a => a -> String
show TxIn
output
          String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"        Source: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show (MaryAddress -> String
showAddressMary MaryAddress
source)
      |
        (TxIn
output, MaryAddress
source) <- Origins -> [(TxIn, MaryAddress)]
forall k a. Map k a -> [(k, a)]
M.toList Origins
origins'
      ]


-- | Print diagnostic information for queued mintings.
printPendings :: String   -- ^ The prefatory message.
              -> Pendings -- ^ The queued mintings.
              -> IO ()    -- ^ The action to print the information.
printPendings :: String -> Pendings -> IO ()
printPendings String
message Pendings
pendings' =
  do
    String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"    " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
message
    [IO ()] -> IO ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_
      [
        do
          String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"      " String -> String -> String
forall a. [a] -> [a] -> [a]
++ TxIn -> String
forall a. Show a => a -> String
show TxIn
output
          [IO ()] -> IO ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_
            [
              String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"        Source: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show (MaryAddress -> String
showAddressMary MaryAddress
source)
            |
              MaryAddress
source <- [MaryAddress]
sources
            ]
          String -> Value -> IO ()
printValueIO String
"        " Value
value
      |
        (TxIn
output, ([MaryAddress]
sources, Value
value)) <- Pendings -> [(TxIn, ([MaryAddress], Value))]
forall k a. Map k a -> [(k, a)]
M.toList Pendings
pendings'
      ]


-- | Run the chain operations for tracking and minting.
runChain :: MonadFail m
         => MonadIO m
         => Context      -- ^ The service context.
         -> MantisM m () -- ^ Action to run the operations.
runChain :: Context -> MantisM m ()
runChain context :: Context
context@Context{Bool
String
IOGenM StdGen
ConsensusModeParams CardanoMode
NetworkId
AssetId
ProtocolParameters
KeyedAddress
Mode
images :: Context -> String
ipfsPin :: Context -> String
gRandom :: Context -> IOGenM StdGen
keyedAddress :: Context -> KeyedAddress
pparams :: Context -> ProtocolParameters
network :: Context -> NetworkId
protocol :: Context -> ConsensusModeParams CardanoMode
socket :: Context -> String
verbose :: Bool
operation :: Mode
images :: String
ipfsPin :: String
gRandom :: IOGenM StdGen
keyedAddress :: KeyedAddress
token :: AssetId
pparams :: ProtocolParameters
network :: NetworkId
protocol :: ConsensusModeParams CardanoMode
socket :: String
token :: Context -> AssetId
operation :: Context -> Mode
verbose :: Context -> Bool
..} =
  do
    let
      KeyedAddress{SomePaymentVerificationKey
MaryAddress
Hash PaymentKey
SigningKey PaymentExtendedKey
signing :: KeyedAddress -> SigningKey PaymentExtendedKey
verification :: KeyedAddress -> SomePaymentVerificationKey
verificationHash :: KeyedAddress -> Hash PaymentKey
keyAddress :: KeyedAddress -> MaryAddress
signing :: SigningKey PaymentExtendedKey
verification :: SomePaymentVerificationKey
verificationHash :: Hash PaymentKey
keyAddress :: MaryAddress
..} = KeyedAddress
keyedAddress
      (MaryScript
script, ScriptHash
scriptHash) = Hash PaymentKey -> Maybe SlotNo -> (MaryScript, ScriptHash)
mintingScript Hash PaymentKey
verificationHash Maybe SlotNo
forall a. Maybe a
Nothing
    IORef ChainState
chainState <-
      IO (IORef ChainState) -> MantisM m (IORef ChainState)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
        (IO (IORef ChainState) -> MantisM m (IORef ChainState))
-> (ChainState -> IO (IORef ChainState))
-> ChainState
-> MantisM m (IORef ChainState)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChainState -> IO (IORef ChainState)
forall a. a -> IO (IORef a)
newIORef
        (ChainState -> MantisM m (IORef ChainState))
-> ChainState -> MantisM m (IORef ChainState)
forall a b. (a -> b) -> a -> b
$ ChainState
forall a. Default a => a
def
          {
            context :: Context
context       = Context
context
          , scriptAddress :: MaryAddress
scriptAddress = MaryAddress
keyAddress
          , script :: MaryScript
script        = MaryScript
script
          , scriptHash :: ScriptHash
scriptHash    = ScriptHash
scriptHash
          , checker :: Value -> Bool
checker       = AssetId -> ScriptHash -> Value -> Bool
checkValue AssetId
token ScriptHash
scriptHash
          }
    let
      blockHandler :: BlockHeader -> p -> IO ()
blockHandler (BlockHeader SlotNo
slot Hash BlockHeader
_ BlockNo
_) p
_ =
        IORef ChainState -> Chain () -> IO ()
forall a. IORef ChainState -> Chain a -> IO a
withChainState IORef ChainState
chainState
          (Chain () -> IO ()) -> Chain () -> IO ()
forall a b. (a -> b) -> a -> b
$ SlotNo -> Chain ()
recordBlock SlotNo
slot
      rollbackHandler :: ChainPoint -> p -> IO ()
rollbackHandler ChainPoint
point p
_ =
        IORef ChainState -> Chain () -> IO ()
forall a. IORef ChainState -> Chain a -> IO a
withChainState IORef ChainState
chainState
          (Chain () -> IO ()) -> (SlotNo -> Chain ()) -> SlotNo -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SlotNo -> Chain ()
recordRollback
          (SlotNo -> IO ()) -> SlotNo -> IO ()
forall a b. (a -> b) -> a -> b
$ ChainPoint -> SlotNo
toSlotNo ChainPoint
point
      idleHandler :: IO Bool
idleHandler =
        IORef ChainState -> Chain Bool -> IO Bool
forall a. IORef ChainState -> Chain a -> IO a
withChainState IORef ChainState
chainState
          (Chain Bool -> IO Bool) -> Chain Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ do
            Chain ()
makeActive
            Bool -> Chain () -> Chain ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Mode
operation Mode -> Mode -> Bool
forall a. Eq a => a -> a -> Bool
== Mode
Lenient)
              Chain ()
createPendingSingle
            Bool -> Chain () -> Chain ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Mode
operation Mode -> Mode -> Bool
forall a. Eq a => a -> a -> Bool
== Mode
Strict)
              Chain ()
createPendingMultiple
            Bool -> Chain Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
      inHandler :: BlockHeader -> TxIn -> IO ()
inHandler (BlockHeader SlotNo
slot Hash BlockHeader
_ BlockNo
_) TxIn
txIn =
        IORef ChainState -> Chain () -> IO ()
forall a. IORef ChainState -> Chain a -> IO a
withChainState IORef ChainState
chainState
          (Chain () -> IO ()) -> Chain () -> IO ()
forall a b. (a -> b) -> a -> b
$ SlotNo -> TxIn -> Chain ()
recordInput SlotNo
slot TxIn
txIn
      outHandler :: p -> [TxIn] -> TxIn -> TxOut MaryEra -> IO ()
outHandler p
_ [TxIn]
inputs TxIn
output (TxOut MaryAddress
destination TxOutValue MaryEra
txOutValue) =
        case TxOutValue MaryEra
txOutValue of
          TxOutValue MultiAssetSupportedInEra MaryEra
_ Value
value ->
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Value -> AssetId -> Quantity
selectAsset Value
value AssetId
token Quantity -> Quantity -> Bool
forall a. Ord a => a -> a -> Bool
> Quantity
0 Bool -> Bool -> Bool
|| MaryAddress
destination MaryAddress -> MaryAddress -> Bool
forall a. Eq a => a -> a -> Bool
== MaryAddress
keyAddress)
              (IO () -> IO ()) -> (Chain () -> IO ()) -> Chain () -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IORef ChainState -> Chain () -> IO ()
forall a. IORef ChainState -> Chain a -> IO a
withChainState IORef ChainState
chainState
              (Chain () -> IO ()) -> Chain () -> IO ()
forall a b. (a -> b) -> a -> b
$ [TxIn] -> TxIn -> MaryAddress -> Value -> Chain ()
recordOutput [TxIn]
inputs TxIn
output MaryAddress
destination Value
value
          TxOutValue MaryEra
_ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    String
-> ConsensusModeParams CardanoMode
-> NetworkId
-> Maybe Reverter
-> IO Bool
-> BlockHandler
-> (BlockHeader -> TxIn -> IO ())
-> TxOutHandler
-> MantisM m ()
forall (m :: * -> *).
MonadIO m =>
String
-> ConsensusModeParams CardanoMode
-> NetworkId
-> Maybe Reverter
-> IO Bool
-> BlockHandler
-> (BlockHeader -> TxIn -> IO ())
-> TxOutHandler
-> MantisM m ()
watchTransactions
      String
socket
      ConsensusModeParams CardanoMode
protocol
      NetworkId
network
      (Reverter -> Maybe Reverter
forall a. a -> Maybe a
Just Reverter
forall p. ChainPoint -> p -> IO ()
rollbackHandler)
      IO Bool
idleHandler
      BlockHandler
forall p. BlockHeader -> p -> IO ()
blockHandler
      BlockHeader -> TxIn -> IO ()
inHandler
      TxOutHandler
forall p. p -> [TxIn] -> TxIn -> TxOut MaryEra -> IO ()
outHandler