-- | A data-type to keep track of reference Hydra scripts published on-chain,
-- and needed to construct transactions leveraging reference inputs.
module Hydra.Tx.ScriptRegistry where

import Hydra.Prelude

import Cardano.Api.UTxO (UTxO)
import Cardano.Api.UTxO qualified as UTxO
import Data.Map qualified as Map
import Hydra.Cardano.Api (
  CtxUTxO,
  ScriptHash,
  TxIn (..),
  TxOut,
  hashScriptInAnyLang,
  txOutReferenceScript,
  pattern ReferenceScript,
  pattern ReferenceScriptNone,
 )
import Hydra.Contract (ScriptInfo (..), scriptInfo)

-- | Hydra scripts published as reference scripts at these UTxO.
data ScriptRegistry = ScriptRegistry
  { ScriptRegistry -> (TxIn, TxOut CtxUTxO)
initialReference :: (TxIn, TxOut CtxUTxO)
  , ScriptRegistry -> (TxIn, TxOut CtxUTxO)
commitReference :: (TxIn, TxOut CtxUTxO)
  , ScriptRegistry -> (TxIn, TxOut CtxUTxO)
headReference :: (TxIn, TxOut CtxUTxO)
  }
  deriving stock (ScriptRegistry -> ScriptRegistry -> Bool
(ScriptRegistry -> ScriptRegistry -> Bool)
-> (ScriptRegistry -> ScriptRegistry -> Bool) -> Eq ScriptRegistry
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ScriptRegistry -> ScriptRegistry -> Bool
== :: ScriptRegistry -> ScriptRegistry -> Bool
$c/= :: ScriptRegistry -> ScriptRegistry -> Bool
/= :: ScriptRegistry -> ScriptRegistry -> Bool
Eq, Int -> ScriptRegistry -> ShowS
[ScriptRegistry] -> ShowS
ScriptRegistry -> String
(Int -> ScriptRegistry -> ShowS)
-> (ScriptRegistry -> String)
-> ([ScriptRegistry] -> ShowS)
-> Show ScriptRegistry
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ScriptRegistry -> ShowS
showsPrec :: Int -> ScriptRegistry -> ShowS
$cshow :: ScriptRegistry -> String
show :: ScriptRegistry -> String
$cshowList :: [ScriptRegistry] -> ShowS
showList :: [ScriptRegistry] -> ShowS
Show, (forall x. ScriptRegistry -> Rep ScriptRegistry x)
-> (forall x. Rep ScriptRegistry x -> ScriptRegistry)
-> Generic ScriptRegistry
forall x. Rep ScriptRegistry x -> ScriptRegistry
forall x. ScriptRegistry -> Rep ScriptRegistry x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. ScriptRegistry -> Rep ScriptRegistry x
from :: forall x. ScriptRegistry -> Rep ScriptRegistry x
$cto :: forall x. Rep ScriptRegistry x -> ScriptRegistry
to :: forall x. Rep ScriptRegistry x -> ScriptRegistry
Generic)
  deriving anyclass ([ScriptRegistry] -> Value
[ScriptRegistry] -> Encoding
ScriptRegistry -> Bool
ScriptRegistry -> Value
ScriptRegistry -> Encoding
(ScriptRegistry -> Value)
-> (ScriptRegistry -> Encoding)
-> ([ScriptRegistry] -> Value)
-> ([ScriptRegistry] -> Encoding)
-> (ScriptRegistry -> Bool)
-> ToJSON ScriptRegistry
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
$ctoJSON :: ScriptRegistry -> Value
toJSON :: ScriptRegistry -> Value
$ctoEncoding :: ScriptRegistry -> Encoding
toEncoding :: ScriptRegistry -> Encoding
$ctoJSONList :: [ScriptRegistry] -> Value
toJSONList :: [ScriptRegistry] -> Value
$ctoEncodingList :: [ScriptRegistry] -> Encoding
toEncodingList :: [ScriptRegistry] -> Encoding
$comitField :: ScriptRegistry -> Bool
omitField :: ScriptRegistry -> Bool
ToJSON, Maybe ScriptRegistry
Value -> Parser [ScriptRegistry]
Value -> Parser ScriptRegistry
(Value -> Parser ScriptRegistry)
-> (Value -> Parser [ScriptRegistry])
-> Maybe ScriptRegistry
-> FromJSON ScriptRegistry
forall a.
(Value -> Parser a)
-> (Value -> Parser [a]) -> Maybe a -> FromJSON a
$cparseJSON :: Value -> Parser ScriptRegistry
parseJSON :: Value -> Parser ScriptRegistry
$cparseJSONList :: Value -> Parser [ScriptRegistry]
parseJSONList :: Value -> Parser [ScriptRegistry]
$comittedField :: Maybe ScriptRegistry
omittedField :: Maybe ScriptRegistry
FromJSON)

data NewScriptRegistryException = MissingScript
  { NewScriptRegistryException -> Text
scriptName :: Text
  , NewScriptRegistryException -> ScriptHash
scriptHash :: ScriptHash
  , NewScriptRegistryException -> Set ScriptHash
discoveredScripts :: Set ScriptHash
  }
  deriving stock (NewScriptRegistryException -> NewScriptRegistryException -> Bool
(NewScriptRegistryException -> NewScriptRegistryException -> Bool)
-> (NewScriptRegistryException
    -> NewScriptRegistryException -> Bool)
-> Eq NewScriptRegistryException
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: NewScriptRegistryException -> NewScriptRegistryException -> Bool
== :: NewScriptRegistryException -> NewScriptRegistryException -> Bool
$c/= :: NewScriptRegistryException -> NewScriptRegistryException -> Bool
/= :: NewScriptRegistryException -> NewScriptRegistryException -> Bool
Eq, Int -> NewScriptRegistryException -> ShowS
[NewScriptRegistryException] -> ShowS
NewScriptRegistryException -> String
(Int -> NewScriptRegistryException -> ShowS)
-> (NewScriptRegistryException -> String)
-> ([NewScriptRegistryException] -> ShowS)
-> Show NewScriptRegistryException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> NewScriptRegistryException -> ShowS
showsPrec :: Int -> NewScriptRegistryException -> ShowS
$cshow :: NewScriptRegistryException -> String
show :: NewScriptRegistryException -> String
$cshowList :: [NewScriptRegistryException] -> ShowS
showList :: [NewScriptRegistryException] -> ShowS
Show)

instance Exception NewScriptRegistryException

-- | Create a script registry from a UTxO containing outputs with reference
-- scripts. This will return 'Nothing' if one or all of the references could not
-- be found.
newScriptRegistry :: UTxO -> Either NewScriptRegistryException ScriptRegistry
newScriptRegistry :: UTxO -> Either NewScriptRegistryException ScriptRegistry
newScriptRegistry =
  Map ScriptHash (TxIn, TxOut CtxUTxO)
-> Either NewScriptRegistryException ScriptRegistry
resolve (Map ScriptHash (TxIn, TxOut CtxUTxO)
 -> Either NewScriptRegistryException ScriptRegistry)
-> (UTxO -> Map ScriptHash (TxIn, TxOut CtxUTxO))
-> UTxO
-> Either NewScriptRegistryException ScriptRegistry
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TxIn -> TxOut CtxUTxO -> Map ScriptHash (TxIn, TxOut CtxUTxO))
-> Map TxIn (TxOut CtxUTxO) -> Map ScriptHash (TxIn, TxOut CtxUTxO)
forall m k a. Monoid m => (k -> a -> m) -> Map k a -> m
Map.foldMapWithKey TxIn -> TxOut CtxUTxO -> Map ScriptHash (TxIn, TxOut CtxUTxO)
collect (Map TxIn (TxOut CtxUTxO) -> Map ScriptHash (TxIn, TxOut CtxUTxO))
-> (UTxO -> Map TxIn (TxOut CtxUTxO))
-> UTxO
-> Map ScriptHash (TxIn, TxOut CtxUTxO)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UTxO -> Map TxIn (TxOut CtxUTxO)
forall out. UTxO' out -> Map TxIn out
UTxO.toMap
 where
  collect ::
    TxIn ->
    TxOut CtxUTxO ->
    Map ScriptHash (TxIn, TxOut CtxUTxO)
  collect :: TxIn -> TxOut CtxUTxO -> Map ScriptHash (TxIn, TxOut CtxUTxO)
collect TxIn
i TxOut CtxUTxO
o =
    case TxOut CtxUTxO -> ReferenceScript
forall ctx. TxOut ctx -> ReferenceScript
txOutReferenceScript TxOut CtxUTxO
o of
      ReferenceScript
ReferenceScriptNone -> Map ScriptHash (TxIn, TxOut CtxUTxO)
forall a. Monoid a => a
mempty
      ReferenceScript ScriptInAnyLang
script -> ScriptHash
-> (TxIn, TxOut CtxUTxO) -> Map ScriptHash (TxIn, TxOut CtxUTxO)
forall k a. k -> a -> Map k a
Map.singleton (ScriptInAnyLang -> ScriptHash
hashScriptInAnyLang ScriptInAnyLang
script) (TxIn
i, TxOut CtxUTxO
o)

  resolve ::
    Map ScriptHash (TxIn, TxOut CtxUTxO) ->
    Either NewScriptRegistryException ScriptRegistry
  resolve :: Map ScriptHash (TxIn, TxOut CtxUTxO)
-> Either NewScriptRegistryException ScriptRegistry
resolve Map ScriptHash (TxIn, TxOut CtxUTxO)
m = do
    (TxIn, TxOut CtxUTxO)
initialReference <- Text
-> ScriptHash
-> Map ScriptHash (TxIn, TxOut CtxUTxO)
-> Either NewScriptRegistryException (TxIn, TxOut CtxUTxO)
forall {b}.
Text
-> ScriptHash
-> Map ScriptHash b
-> Either NewScriptRegistryException b
lookupScriptHash Text
"νInitial" ScriptHash
initialScriptHash Map ScriptHash (TxIn, TxOut CtxUTxO)
m
    (TxIn, TxOut CtxUTxO)
commitReference <- Text
-> ScriptHash
-> Map ScriptHash (TxIn, TxOut CtxUTxO)
-> Either NewScriptRegistryException (TxIn, TxOut CtxUTxO)
forall {b}.
Text
-> ScriptHash
-> Map ScriptHash b
-> Either NewScriptRegistryException b
lookupScriptHash Text
"νCommit" ScriptHash
commitScriptHash Map ScriptHash (TxIn, TxOut CtxUTxO)
m
    (TxIn, TxOut CtxUTxO)
headReference <- Text
-> ScriptHash
-> Map ScriptHash (TxIn, TxOut CtxUTxO)
-> Either NewScriptRegistryException (TxIn, TxOut CtxUTxO)
forall {b}.
Text
-> ScriptHash
-> Map ScriptHash b
-> Either NewScriptRegistryException b
lookupScriptHash Text
"νHead" ScriptHash
headScriptHash Map ScriptHash (TxIn, TxOut CtxUTxO)
m
    ScriptRegistry -> Either NewScriptRegistryException ScriptRegistry
forall a. a -> Either NewScriptRegistryException a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ScriptRegistry
 -> Either NewScriptRegistryException ScriptRegistry)
-> ScriptRegistry
-> Either NewScriptRegistryException ScriptRegistry
forall a b. (a -> b) -> a -> b
$ ScriptRegistry{(TxIn, TxOut CtxUTxO)
$sel:initialReference:ScriptRegistry :: (TxIn, TxOut CtxUTxO)
initialReference :: (TxIn, TxOut CtxUTxO)
initialReference, (TxIn, TxOut CtxUTxO)
$sel:commitReference:ScriptRegistry :: (TxIn, TxOut CtxUTxO)
commitReference :: (TxIn, TxOut CtxUTxO)
commitReference, (TxIn, TxOut CtxUTxO)
$sel:headReference:ScriptRegistry :: (TxIn, TxOut CtxUTxO)
headReference :: (TxIn, TxOut CtxUTxO)
headReference}

  lookupScriptHash :: Text
-> ScriptHash
-> Map ScriptHash b
-> Either NewScriptRegistryException b
lookupScriptHash Text
name ScriptHash
sh Map ScriptHash b
m =
    case Key (Map ScriptHash b)
-> Map ScriptHash b -> Maybe (Val (Map ScriptHash b))
forall t. StaticMap t => Key t -> t -> Maybe (Val t)
lookup ScriptHash
Key (Map ScriptHash b)
sh Map ScriptHash b
m of
      Maybe (Val (Map ScriptHash b))
Nothing -> NewScriptRegistryException -> Either NewScriptRegistryException b
forall a b. a -> Either a b
Left (NewScriptRegistryException -> Either NewScriptRegistryException b)
-> NewScriptRegistryException
-> Either NewScriptRegistryException b
forall a b. (a -> b) -> a -> b
$ Text -> ScriptHash -> Set ScriptHash -> NewScriptRegistryException
MissingScript Text
name ScriptHash
sh (Map ScriptHash b -> Set ScriptHash
forall k a. Map k a -> Set k
Map.keysSet Map ScriptHash b
m)
      Just Val (Map ScriptHash b)
s -> b -> Either NewScriptRegistryException b
forall a b. b -> Either a b
Right b
Val (Map ScriptHash b)
s

  ScriptInfo
    { ScriptHash
initialScriptHash :: ScriptHash
initialScriptHash :: ScriptInfo -> ScriptHash
initialScriptHash
    , ScriptHash
commitScriptHash :: ScriptHash
commitScriptHash :: ScriptInfo -> ScriptHash
commitScriptHash
    , ScriptHash
headScriptHash :: ScriptHash
headScriptHash :: ScriptInfo -> ScriptHash
headScriptHash
    } = ScriptInfo
scriptInfo

-- | Get the UTxO that corresponds to a script registry.
--
-- **Property**:
--
--     newScriptRegistry (registryUTxO r) === Just r
registryUTxO :: ScriptRegistry -> UTxO
registryUTxO :: ScriptRegistry -> UTxO
registryUTxO ScriptRegistry
scriptRegistry =
  [(TxIn, TxOut CtxUTxO)] -> UTxO
forall out. [(TxIn, out)] -> UTxO' out
UTxO.fromPairs [(TxIn, TxOut CtxUTxO)
initialReference, (TxIn, TxOut CtxUTxO)
commitReference, (TxIn, TxOut CtxUTxO)
headReference]
 where
  ScriptRegistry
    { (TxIn, TxOut CtxUTxO)
$sel:initialReference:ScriptRegistry :: ScriptRegistry -> (TxIn, TxOut CtxUTxO)
initialReference :: (TxIn, TxOut CtxUTxO)
initialReference
    , (TxIn, TxOut CtxUTxO)
$sel:commitReference:ScriptRegistry :: ScriptRegistry -> (TxIn, TxOut CtxUTxO)
commitReference :: (TxIn, TxOut CtxUTxO)
commitReference
    , (TxIn, TxOut CtxUTxO)
$sel:headReference:ScriptRegistry :: ScriptRegistry -> (TxIn, TxOut CtxUTxO)
headReference :: (TxIn, TxOut CtxUTxO)
headReference
    } = ScriptRegistry
scriptRegistry