-----------------------------------------------------------------------------
--
-- Module      :  $Headers
-- Copyright   :  (c) 2021 Brian W Bush
-- License     :  MIT
--
-- Maintainer  :  Brian W Bush <code@functionally.io>
-- Stability   :  Experimental
-- Portability :  Portable
--
-- | Extracting scripts from witnesses.
--
-----------------------------------------------------------------------------


module Mantra.Chain.Internal (
-- * Scripts
  interpretAsScript
, toScript
, toSimpleScriptV2
) where


import Control.Monad (guard)
import Data.List (isPrefixOf)
import Data.List.Extra (replace)
import Data.Word (Word64)

import qualified Data.ByteString.Char8              as BS        (pack)
import qualified Cardano.Api                        as API
import qualified Cardano.Ledger.Crypto              as Ledger    (StandardCrypto)
import qualified Cardano.Ledger.ShelleyMA.Timelocks as ShelleyMA (Timelock)


-- | Convert a witness to a script.
interpretAsScript :: ShelleyMA.Timelock Ledger.StandardCrypto                    -- ^ The witness.
                  -> Maybe (API.SimpleScript API.SimpleScriptV2, API.ScriptHash) -- ^ The script and its hash, if the witness was a script.
interpretAsScript :: Timelock StandardCrypto
-> Maybe (SimpleScript SimpleScriptV2, ScriptHash)
interpretAsScript Timelock StandardCrypto
witness =
  do
    let
      text :: String
text = Timelock StandardCrypto -> String
forall a. Show a => a -> String
show Timelock StandardCrypto
witness -- FIXME: Find a less crude way to deal with the existential type `Witness`.
    Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard
      (String
"TimelockConstr " String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
text)
    SimpleScript SimpleScriptV2
-> (SimpleScript SimpleScriptV2, ScriptHash)
toScript
      (SimpleScript SimpleScriptV2
 -> (SimpleScript SimpleScriptV2, ScriptHash))
-> Maybe (SimpleScript SimpleScriptV2)
-> Maybe (SimpleScript SimpleScriptV2, ScriptHash)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Maybe (SimpleScript SimpleScriptV2)
toSimpleScriptV2 String
text


-- | Convert a simple script to a script and its hash.
toScript :: API.SimpleScript API.SimpleScriptV2             -- ^ The simple script.
         -> (API.SimpleScript API.SimpleScriptV2, API.ScriptHash) -- ^ The script and its hash.
toScript :: SimpleScript SimpleScriptV2
-> (SimpleScript SimpleScriptV2, ScriptHash)
toScript SimpleScript SimpleScriptV2
script =
  let
    script' :: Script SimpleScriptV2
script' = SimpleScriptVersion SimpleScriptV2
-> SimpleScript SimpleScriptV2 -> Script SimpleScriptV2
forall lang.
SimpleScriptVersion lang -> SimpleScript lang -> Script lang
API.SimpleScript SimpleScriptVersion SimpleScriptV2
API.SimpleScriptV2 SimpleScript SimpleScriptV2
script
  in
    (
      SimpleScript SimpleScriptV2
script
    , Script SimpleScriptV2 -> ScriptHash
forall lang. Script lang -> ScriptHash
API.hashScript Script SimpleScriptV2
script'
    )


-- | Parse a string representation of a simple script.
toSimpleScriptV2 :: String                                      -- ^ The string representation.
                 -> Maybe (API.SimpleScript API.SimpleScriptV2) -- ^ The simple script, if the parsing succeeded.
toSimpleScriptV2 :: String -> Maybe (SimpleScript SimpleScriptV2)
toSimpleScriptV2 =
  Timelock -> Maybe (SimpleScript SimpleScriptV2)
rewriteScript
    (Timelock -> Maybe (SimpleScript SimpleScriptV2))
-> (String -> Timelock)
-> String
-> Maybe (SimpleScript SimpleScriptV2)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Timelock
forall a. Read a => String -> a
read
    (String -> Timelock) -> (String -> String) -> String -> Timelock
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String -> String
forall a. (Partial, Eq a) => [a] -> [a] -> [a] -> [a]
replace String
"TimelockConstr " String
""
    (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String -> String
forall a. (Partial, Eq a) => [a] -> [a] -> [a] -> [a]
replace String
"fromList " String
""


-- Functions for parsing scripts.


rewriteScript :: Timelock -> Maybe (API.SimpleScript API.SimpleScriptV2)
rewriteScript :: Timelock -> Maybe (SimpleScript SimpleScriptV2)
rewriteScript (Signature (KeyHash String
h)) = Hash PaymentKey -> SimpleScript SimpleScriptV2
forall lang. Hash PaymentKey -> SimpleScript lang
API.RequireSignature (Hash PaymentKey -> SimpleScript SimpleScriptV2)
-> Maybe (Hash PaymentKey) -> Maybe (SimpleScript SimpleScriptV2)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Maybe (Hash PaymentKey)
readSignature String
h
rewriteScript (AllOf StrictSeq Timelock
Empty          ) = SimpleScript SimpleScriptV2 -> Maybe (SimpleScript SimpleScriptV2)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SimpleScript SimpleScriptV2
 -> Maybe (SimpleScript SimpleScriptV2))
-> SimpleScript SimpleScriptV2
-> Maybe (SimpleScript SimpleScriptV2)
forall a b. (a -> b) -> a -> b
$ [SimpleScript SimpleScriptV2] -> SimpleScript SimpleScriptV2
forall lang. [SimpleScript lang] -> SimpleScript lang
API.RequireAllOf []
rewriteScript (AllOf (StrictSeq [Timelock]
ss) ) = [SimpleScript SimpleScriptV2] -> SimpleScript SimpleScriptV2
forall lang. [SimpleScript lang] -> SimpleScript lang
API.RequireAllOf ([SimpleScript SimpleScriptV2] -> SimpleScript SimpleScriptV2)
-> Maybe [SimpleScript SimpleScriptV2]
-> Maybe (SimpleScript SimpleScriptV2)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Timelock -> Maybe (SimpleScript SimpleScriptV2))
-> [Timelock] -> Maybe [SimpleScript SimpleScriptV2]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Timelock -> Maybe (SimpleScript SimpleScriptV2)
rewriteScript [Timelock]
ss
rewriteScript (AnyOf StrictSeq Timelock
Empty          ) = SimpleScript SimpleScriptV2 -> Maybe (SimpleScript SimpleScriptV2)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SimpleScript SimpleScriptV2
 -> Maybe (SimpleScript SimpleScriptV2))
-> SimpleScript SimpleScriptV2
-> Maybe (SimpleScript SimpleScriptV2)
forall a b. (a -> b) -> a -> b
$ [SimpleScript SimpleScriptV2] -> SimpleScript SimpleScriptV2
forall lang. [SimpleScript lang] -> SimpleScript lang
API.RequireAnyOf []
rewriteScript (AnyOf (StrictSeq [Timelock]
ss) ) = [SimpleScript SimpleScriptV2] -> SimpleScript SimpleScriptV2
forall lang. [SimpleScript lang] -> SimpleScript lang
API.RequireAnyOf ([SimpleScript SimpleScriptV2] -> SimpleScript SimpleScriptV2)
-> Maybe [SimpleScript SimpleScriptV2]
-> Maybe (SimpleScript SimpleScriptV2)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Timelock -> Maybe (SimpleScript SimpleScriptV2))
-> [Timelock] -> Maybe [SimpleScript SimpleScriptV2]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Timelock -> Maybe (SimpleScript SimpleScriptV2)
rewriteScript [Timelock]
ss
rewriteScript (MOfN Int
i StrictSeq Timelock
Empty         ) = SimpleScript SimpleScriptV2 -> Maybe (SimpleScript SimpleScriptV2)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SimpleScript SimpleScriptV2
 -> Maybe (SimpleScript SimpleScriptV2))
-> SimpleScript SimpleScriptV2
-> Maybe (SimpleScript SimpleScriptV2)
forall a b. (a -> b) -> a -> b
$ Int -> [SimpleScript SimpleScriptV2] -> SimpleScript SimpleScriptV2
forall lang. Int -> [SimpleScript lang] -> SimpleScript lang
API.RequireMOf Int
i []
rewriteScript (MOfN Int
i (StrictSeq [Timelock]
ss)) = Int -> [SimpleScript SimpleScriptV2] -> SimpleScript SimpleScriptV2
forall lang. Int -> [SimpleScript lang] -> SimpleScript lang
API.RequireMOf Int
i ([SimpleScript SimpleScriptV2] -> SimpleScript SimpleScriptV2)
-> Maybe [SimpleScript SimpleScriptV2]
-> Maybe (SimpleScript SimpleScriptV2)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Timelock -> Maybe (SimpleScript SimpleScriptV2))
-> [Timelock] -> Maybe [SimpleScript SimpleScriptV2]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Timelock -> Maybe (SimpleScript SimpleScriptV2)
rewriteScript [Timelock]
ss
rewriteScript (TimeStart (SlotNo Word64
t) ) = SimpleScript SimpleScriptV2 -> Maybe (SimpleScript SimpleScriptV2)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SimpleScript SimpleScriptV2
 -> Maybe (SimpleScript SimpleScriptV2))
-> (SlotNo -> SimpleScript SimpleScriptV2)
-> SlotNo
-> Maybe (SimpleScript SimpleScriptV2)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TimeLocksSupported SimpleScriptV2
-> SlotNo -> SimpleScript SimpleScriptV2
forall lang. TimeLocksSupported lang -> SlotNo -> SimpleScript lang
API.RequireTimeAfter  TimeLocksSupported SimpleScriptV2
API.TimeLocksInSimpleScriptV2 (SlotNo -> Maybe (SimpleScript SimpleScriptV2))
-> SlotNo -> Maybe (SimpleScript SimpleScriptV2)
forall a b. (a -> b) -> a -> b
$ Word64 -> SlotNo
API.SlotNo Word64
t
rewriteScript (TimeExpire (SlotNo Word64
t)) = SimpleScript SimpleScriptV2 -> Maybe (SimpleScript SimpleScriptV2)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SimpleScript SimpleScriptV2
 -> Maybe (SimpleScript SimpleScriptV2))
-> (SlotNo -> SimpleScript SimpleScriptV2)
-> SlotNo
-> Maybe (SimpleScript SimpleScriptV2)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TimeLocksSupported SimpleScriptV2
-> SlotNo -> SimpleScript SimpleScriptV2
forall lang. TimeLocksSupported lang -> SlotNo -> SimpleScript lang
API.RequireTimeBefore TimeLocksSupported SimpleScriptV2
API.TimeLocksInSimpleScriptV2 (SlotNo -> Maybe (SimpleScript SimpleScriptV2))
-> SlotNo -> Maybe (SimpleScript SimpleScriptV2)
forall a b. (a -> b) -> a -> b
$ Word64 -> SlotNo
API.SlotNo Word64
t


readSignature :: String -> Maybe (API.Hash API.PaymentKey)
readSignature :: String -> Maybe (Hash PaymentKey)
readSignature = AsType (Hash PaymentKey) -> ByteString -> Maybe (Hash PaymentKey)
forall a.
SerialiseAsRawBytes a =>
AsType a -> ByteString -> Maybe a
API.deserialiseFromRawBytesHex (AsType PaymentKey -> AsType (Hash PaymentKey)
forall a. AsType a -> AsType (Hash a)
API.AsHash AsType PaymentKey
API.AsPaymentKey) (ByteString -> Maybe (Hash PaymentKey))
-> (String -> ByteString) -> String -> Maybe (Hash PaymentKey)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ByteString
BS.pack


data Timelock =
    Signature KeyHash
  | AllOf (StrictSeq Timelock)
  | AnyOf (StrictSeq Timelock)
  | MOfN Int (StrictSeq Timelock)
  | TimeStart SlotNo
  | TimeExpire SlotNo
    deriving (ReadPrec [Timelock]
ReadPrec Timelock
Int -> ReadS Timelock
ReadS [Timelock]
(Int -> ReadS Timelock)
-> ReadS [Timelock]
-> ReadPrec Timelock
-> ReadPrec [Timelock]
-> Read Timelock
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Timelock]
$creadListPrec :: ReadPrec [Timelock]
readPrec :: ReadPrec Timelock
$creadPrec :: ReadPrec Timelock
readList :: ReadS [Timelock]
$creadList :: ReadS [Timelock]
readsPrec :: Int -> ReadS Timelock
$creadsPrec :: Int -> ReadS Timelock
Read, Int -> Timelock -> String -> String
[Timelock] -> String -> String
Timelock -> String
(Int -> Timelock -> String -> String)
-> (Timelock -> String)
-> ([Timelock] -> String -> String)
-> Show Timelock
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [Timelock] -> String -> String
$cshowList :: [Timelock] -> String -> String
show :: Timelock -> String
$cshow :: Timelock -> String
showsPrec :: Int -> Timelock -> String -> String
$cshowsPrec :: Int -> Timelock -> String -> String
Show)


newtype KeyHash = KeyHash String
  deriving (ReadPrec [KeyHash]
ReadPrec KeyHash
Int -> ReadS KeyHash
ReadS [KeyHash]
(Int -> ReadS KeyHash)
-> ReadS [KeyHash]
-> ReadPrec KeyHash
-> ReadPrec [KeyHash]
-> Read KeyHash
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [KeyHash]
$creadListPrec :: ReadPrec [KeyHash]
readPrec :: ReadPrec KeyHash
$creadPrec :: ReadPrec KeyHash
readList :: ReadS [KeyHash]
$creadList :: ReadS [KeyHash]
readsPrec :: Int -> ReadS KeyHash
$creadsPrec :: Int -> ReadS KeyHash
Read, Int -> KeyHash -> String -> String
[KeyHash] -> String -> String
KeyHash -> String
(Int -> KeyHash -> String -> String)
-> (KeyHash -> String)
-> ([KeyHash] -> String -> String)
-> Show KeyHash
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [KeyHash] -> String -> String
$cshowList :: [KeyHash] -> String -> String
show :: KeyHash -> String
$cshow :: KeyHash -> String
showsPrec :: Int -> KeyHash -> String -> String
$cshowsPrec :: Int -> KeyHash -> String -> String
Show)


newtype SlotNo = SlotNo Word64
  deriving (ReadPrec [SlotNo]
ReadPrec SlotNo
Int -> ReadS SlotNo
ReadS [SlotNo]
(Int -> ReadS SlotNo)
-> ReadS [SlotNo]
-> ReadPrec SlotNo
-> ReadPrec [SlotNo]
-> Read SlotNo
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [SlotNo]
$creadListPrec :: ReadPrec [SlotNo]
readPrec :: ReadPrec SlotNo
$creadPrec :: ReadPrec SlotNo
readList :: ReadS [SlotNo]
$creadList :: ReadS [SlotNo]
readsPrec :: Int -> ReadS SlotNo
$creadsPrec :: Int -> ReadS SlotNo
Read, Int -> SlotNo -> String -> String
[SlotNo] -> String -> String
SlotNo -> String
(Int -> SlotNo -> String -> String)
-> (SlotNo -> String)
-> ([SlotNo] -> String -> String)
-> Show SlotNo
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [SlotNo] -> String -> String
$cshowList :: [SlotNo] -> String -> String
show :: SlotNo -> String
$cshow :: SlotNo -> String
showsPrec :: Int -> SlotNo -> String -> String
$cshowsPrec :: Int -> SlotNo -> String -> String
Show)


data StrictSeq a =
    Empty
  | StrictSeq {StrictSeq a -> [a]
fromStrict :: [a]}
    deriving (ReadPrec [StrictSeq a]
ReadPrec (StrictSeq a)
Int -> ReadS (StrictSeq a)
ReadS [StrictSeq a]
(Int -> ReadS (StrictSeq a))
-> ReadS [StrictSeq a]
-> ReadPrec (StrictSeq a)
-> ReadPrec [StrictSeq a]
-> Read (StrictSeq a)
forall a. Read a => ReadPrec [StrictSeq a]
forall a. Read a => ReadPrec (StrictSeq a)
forall a. Read a => Int -> ReadS (StrictSeq a)
forall a. Read a => ReadS [StrictSeq a]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [StrictSeq a]
$creadListPrec :: forall a. Read a => ReadPrec [StrictSeq a]
readPrec :: ReadPrec (StrictSeq a)
$creadPrec :: forall a. Read a => ReadPrec (StrictSeq a)
readList :: ReadS [StrictSeq a]
$creadList :: forall a. Read a => ReadS [StrictSeq a]
readsPrec :: Int -> ReadS (StrictSeq a)
$creadsPrec :: forall a. Read a => Int -> ReadS (StrictSeq a)
Read, Int -> StrictSeq a -> String -> String
[StrictSeq a] -> String -> String
StrictSeq a -> String
(Int -> StrictSeq a -> String -> String)
-> (StrictSeq a -> String)
-> ([StrictSeq a] -> String -> String)
-> Show (StrictSeq a)
forall a. Show a => Int -> StrictSeq a -> String -> String
forall a. Show a => [StrictSeq a] -> String -> String
forall a. Show a => StrictSeq a -> String
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [StrictSeq a] -> String -> String
$cshowList :: forall a. Show a => [StrictSeq a] -> String -> String
show :: StrictSeq a -> String
$cshow :: forall a. Show a => StrictSeq a -> String
showsPrec :: Int -> StrictSeq a -> String -> String
$cshowsPrec :: forall a. Show a => Int -> StrictSeq a -> String -> String
Show)