Merge pull request #105 from mlabs-haskell/misha/issue-100-time-conversions

Misha/issue 100 time conversions

Author: mikekeke

README.md

@@ -84,8 +84,6 @@ main = do
           , pcPort = 9080
           , pcProtocolParams = protocolParams
           , pcTipPollingInterval = 10_000_000
-          , -- | Slot configuration of the network, the default value can be used for the mainnet
-            pcSlotConfig = def
           , pcOwnPubKeyHash = "0f45aaf1b2959db6e5ff94dbb1f823bf257680c3c723ac2d49f97546"
           , pcOwnStakePubKeyHash = Nothing
           , -- Directory name of the script and data files

bot-plutus-interface.cabal

@@ -87,6 +87,7 @@ library
     BotPlutusInterface.Helpers
     BotPlutusInterface.QueryNode
     BotPlutusInterface.Server
+    BotPlutusInterface.TimeSlot
     BotPlutusInterface.Types
     BotPlutusInterface.UtxoParser
 
@@ -97,6 +98,7 @@ library
     , cardano-api
     , cardano-crypto
     , cardano-ledger-alonzo
+    , cardano-ledger-core
     , cardano-prelude
     , cardano-slotting
     , containers
@@ -113,6 +115,7 @@ library
     , lens
     , memory
     , mtl
+    , ouroboros-consensus
     , playground-common
     , plutus-chain-index
     , plutus-chain-index-core
@@ -136,6 +139,7 @@ library
     , split
     , stm
     , text                       ^>=1.2.4.0
+    , time
     , transformers
     , transformers-either
     , transformers-except

examples/plutus-game/app/Main.hs

@@ -22,7 +22,6 @@ import Cardano.PlutusExample.Game (
 import Data.Aeson qualified as JSON
 import Data.Aeson.TH (defaultOptions, deriveJSON)
 import Data.ByteString.Lazy qualified as LazyByteString
-import Data.Default (def)
 import Data.Maybe (fromMaybe)
 import Playground.Types (FunctionSchema)
 import Schema (FormSchema)
@@ -59,7 +58,6 @@ main = do
           , pcPort = 9080
           , pcProtocolParams = protocolParams
           , pcTipPollingInterval = 10_000_000
-          , pcSlotConfig = def
           , pcOwnPubKeyHash = "0f45aaf1b2959db6e5ff94dbb1f823bf257680c3c723ac2d49f97546"
           , pcOwnStakePubKeyHash = Nothing
           , pcScriptFileDir = "./scripts"

examples/plutus-nft/app/Main.hs

@@ -17,7 +17,6 @@ import Cardano.PlutusExample.NFT
 import Data.Aeson qualified as JSON
 import Data.Aeson.TH (defaultOptions, deriveJSON)
 import Data.ByteString.Lazy qualified as LazyByteString
-import Data.Default (def)
 import Data.Maybe (fromMaybe)
 import Playground.Types (FunctionSchema)
 import Schema (FormSchema)
@@ -55,7 +54,6 @@ main = do
           , pcPort = 9080
           , pcProtocolParams = protocolParams
           , pcTipPollingInterval = 10_000_000
-          , pcSlotConfig = def
           , pcOwnPubKeyHash = "0f45aaf1b2959db6e5ff94dbb1f823bf257680c3c723ac2d49f97546"
           , pcOwnStakePubKeyHash = Nothing
           , pcScriptFileDir = "./scripts"

examples/plutus-transfer/app/Main.hs

@@ -21,7 +21,6 @@ import Cardano.PlutusExample.Transfer (
 import Data.Aeson qualified as JSON
 import Data.Aeson.TH (defaultOptions, deriveJSON)
 import Data.ByteString.Lazy qualified as LazyByteString
-import Data.Default (def)
 import Data.Maybe (fromMaybe)
 import Playground.Types (FunctionSchema)
 import Schema (FormSchema)
@@ -58,7 +57,6 @@ main = do
           , pcPort = 9080
           , pcProtocolParams = protocolParams
           , pcTipPollingInterval = 10_000_000
-          , pcSlotConfig = def
           , pcOwnPubKeyHash = "0f45aaf1b2959db6e5ff94dbb1f823bf257680c3c723ac2d49f97546"
           , pcOwnStakePubKeyHash = Nothing
           , pcScriptFileDir = "./scripts"

src/BotPlutusInterface/Balance.hs

@@ -8,7 +8,12 @@ module BotPlutusInterface.Balance (
 ) where
 
 import BotPlutusInterface.CardanoCLI qualified as CardanoCLI
-import BotPlutusInterface.Effects (PABEffect, createDirectoryIfMissingCLI, printBpiLog)
+import BotPlutusInterface.Effects (
+  PABEffect,
+  createDirectoryIfMissingCLI,
+  posixTimeRangeToContainedSlotRange,
+  printBpiLog,
+ )
 import BotPlutusInterface.Files (DummyPrivKey, unDummyPrivateKey)
 import BotPlutusInterface.Files qualified as Files
 import BotPlutusInterface.Types (LogLevel (Debug), PABConfig)
@@ -43,7 +48,6 @@ import Ledger.Interval (
  )
 import Ledger.Scripts (Datum, DatumHash)
 import Ledger.Time (POSIXTimeRange)
-import Ledger.TimeSlot (posixTimeRangeToContainedSlotRange)
 import Ledger.Tx (
   Tx (..),
   TxIn (..),
@@ -61,6 +65,7 @@ import Plutus.V1.Ledger.Api (
  )
 
 import BotPlutusInterface.BodyBuilder qualified as BodyBuilder
+import Data.Bifunctor (bimap)
 import Prettyprinter (pretty, viaShow, (<+>))
 import Prelude
 
@@ -81,10 +86,10 @@ balanceTxIO pabConf ownPkh unbalancedTx =
       privKeys <- newEitherT $ Files.readPrivateKeys @w pabConf
       let utxoIndex = fmap Tx.toTxOut utxos <> unBalancedTxUtxoIndex unbalancedTx
           requiredSigs = map Ledger.unPaymentPubKeyHash $ Map.keys (unBalancedTxRequiredSignatories unbalancedTx)
+
       tx <-
-        hoistEither $
-          addValidRange
-            pabConf
+        newEitherT $
+          addValidRange @w
             (unBalancedTxValidityTimeRange unbalancedTx)
             (unBalancedTxTx unbalancedTx)
 
@@ -361,11 +366,20 @@ addSignatories ownPkh privKeys pkhs tx =
     tx
     (ownPkh : pkhs)
 
-addValidRange :: PABConfig -> POSIXTimeRange -> Tx -> Either Text Tx
-addValidRange pabConf timeRange tx =
+addValidRange ::
+  forall (w :: Type) (effs :: [Type -> Type]).
+  Member (PABEffect w) effs =>
+  POSIXTimeRange ->
+  Tx ->
+  Eff effs (Either Text Tx)
+addValidRange timeRange tx =
   if validateRange timeRange
-    then Right $ tx {txValidRange = posixTimeRangeToContainedSlotRange pabConf.pcSlotConfig timeRange}
-    else Left "Invalid validity interval."
+    then
+      bimap (Text.pack . show) (setRange tx)
+        <$> posixTimeRangeToContainedSlotRange @w timeRange
+    else pure $ Left "Invalid validity interval."
+  where
+    setRange tx' range = tx' {txValidRange = range}
 
 validateRange :: forall (a :: Type). Ord a => Interval a -> Bool
 validateRange (Interval (LowerBound PosInf _) _) = False

src/BotPlutusInterface/Contract.hs

@@ -16,10 +16,13 @@ import BotPlutusInterface.Effects (
   handleContractLog,
   handlePABEffect,
   logToContract,
+  posixTimeRangeToContainedSlotRange,
+  posixTimeToSlot,
   printBpiLog,
   queryChainIndex,
   readFileTextEnvelope,
   saveBudget,
+  slotToPOSIXTime,
   threadDelay,
   uploadDir,
  )
@@ -55,7 +58,6 @@ import Ledger qualified
 import Ledger.Address (PaymentPubKeyHash (PaymentPubKeyHash))
 import Ledger.Constraints.OffChain (UnbalancedTx (..))
 import Ledger.Slot (Slot (Slot))
-import Ledger.TimeSlot (posixTimeRangeToContainedSlotRange, posixTimeToEnclosingSlot, slotToEndPOSIXTime)
 import Ledger.Tx (CardanoTx)
 import Ledger.Tx qualified as Tx
 import Plutus.ChainIndex.TxIdState (fromTx, transactionStatus)
@@ -184,10 +186,8 @@ handlePABReq contractEnv req = do
     CurrentSlotReq -> CurrentSlotResp <$> currentSlot @w contractEnv
     CurrentTimeReq -> CurrentTimeResp <$> currentTime @w contractEnv
     PosixTimeRangeToContainedSlotRangeReq posixTimeRange ->
-      pure $
-        PosixTimeRangeToContainedSlotRangeResp $
-          Right $
-            posixTimeRangeToContainedSlotRange contractEnv.cePABConfig.pcSlotConfig posixTimeRange
+      either (error . show) (PosixTimeRangeToContainedSlotRangeResp . Right)
+        <$> posixTimeRangeToContainedSlotRange @w posixTimeRange
     AwaitTxStatusChangeReq txId -> AwaitTxStatusChangeResp txId <$> awaitTxStatusChange @w contractEnv txId
     ------------------------
     -- Unhandled requests --
@@ -384,10 +384,12 @@ awaitTime ::
   ContractEnvironment w ->
   POSIXTime ->
   Eff effs POSIXTime
-awaitTime ce = fmap fromSlot . awaitSlot ce . toSlot
+awaitTime ce pTime = do
+  slotFromTime <- rightOrErr <$> posixTimeToSlot @w pTime
+  slot' <- awaitSlot ce slotFromTime
+  rightOrErr <$> slotToPOSIXTime @w slot'
   where
-    toSlot = posixTimeToEnclosingSlot ce.cePABConfig.pcSlotConfig
-    fromSlot = slotToEndPOSIXTime ce.cePABConfig.pcSlotConfig
+    rightOrErr = either (error . show) id
 
 currentSlot ::
   forall (w :: Type) (effs :: [Type -> Type]).
@@ -411,4 +413,6 @@ currentTime ::
   ContractEnvironment w ->
   Eff effs POSIXTime
 currentTime contractEnv =
-  slotToEndPOSIXTime contractEnv.cePABConfig.pcSlotConfig <$> currentSlot @w contractEnv
+  currentSlot @w contractEnv
+    >>= slotToPOSIXTime @w
+    >>= either (error . show) return

src/BotPlutusInterface/Effects.hs

@@ -24,10 +24,14 @@ module BotPlutusInterface.Effects (
   callCommand,
   estimateBudget,
   saveBudget,
+  slotToPOSIXTime,
+  posixTimeToSlot,
+  posixTimeRangeToContainedSlotRange,
 ) where
 
 import BotPlutusInterface.ChainIndex (handleChainIndexReq)
 import BotPlutusInterface.ExBudget qualified as ExBudget
+import BotPlutusInterface.TimeSlot qualified as TimeSlot
 import BotPlutusInterface.Types (
   BudgetEstimationError,
   CLILocation (..),
@@ -106,6 +110,13 @@ data PABEffect (w :: Type) (r :: Type) where
   QueryChainIndex :: ChainIndexQuery -> PABEffect w ChainIndexResponse
   EstimateBudget :: TxFile -> PABEffect w (Either BudgetEstimationError TxBudget)
   SaveBudget :: Ledger.TxId -> TxBudget -> PABEffect w ()
+  SlotToPOSIXTime ::
+    Ledger.Slot ->
+    PABEffect w (Either TimeSlot.TimeSlotConversionError Ledger.POSIXTime)
+  POSIXTimeToSlot :: Ledger.POSIXTime -> PABEffect w (Either TimeSlot.TimeSlotConversionError Ledger.Slot)
+  POSIXTimeRangeToSlotRange ::
+    Ledger.POSIXTimeRange ->
+    PABEffect w (Either TimeSlot.TimeSlotConversionError Ledger.SlotRange)
 
 handlePABEffect ::
   forall (w :: Type) (effs :: [Type -> Type]).
@@ -155,6 +166,12 @@ handlePABEffect contractEnv =
         EstimateBudget txPath ->
           ExBudget.estimateBudget contractEnv.cePABConfig txPath
         SaveBudget txId exBudget -> saveBudgetImpl contractEnv txId exBudget
+        SlotToPOSIXTime slot ->
+          TimeSlot.slotToPOSIXTimeIO contractEnv.cePABConfig slot
+        POSIXTimeToSlot pTime ->
+          TimeSlot.posixTimeToSlotIO contractEnv.cePABConfig pTime
+        POSIXTimeRangeToSlotRange pTimeRange ->
+          TimeSlot.posixTimeRangeToContainedSlotRangeIO contractEnv.cePABConfig pTimeRange
     )
 
 printLog' :: LogLevel -> LogContext -> LogLevel -> PP.Doc () -> IO ()
@@ -345,3 +362,24 @@ saveBudget ::
   TxBudget ->
   Eff effs ()
 saveBudget txId budget = send @(PABEffect w) $ SaveBudget txId budget
+
+slotToPOSIXTime ::
+  forall (w :: Type) (effs :: [Type -> Type]).
+  Member (PABEffect w) effs =>
+  Ledger.Slot ->
+  Eff effs (Either TimeSlot.TimeSlotConversionError Ledger.POSIXTime)
+slotToPOSIXTime = send @(PABEffect w) . SlotToPOSIXTime
+
+posixTimeToSlot ::
+  forall (w :: Type) (effs :: [Type -> Type]).
+  Member (PABEffect w) effs =>
+  Ledger.POSIXTime ->
+  Eff effs (Either TimeSlot.TimeSlotConversionError Ledger.Slot)
+posixTimeToSlot = send @(PABEffect w) . POSIXTimeToSlot
+
+posixTimeRangeToContainedSlotRange ::
+  forall (w :: Type) (effs :: [Type -> Type]).
+  Member (PABEffect w) effs =>
+  Ledger.POSIXTimeRange ->
+  Eff effs (Either TimeSlot.TimeSlotConversionError Ledger.SlotRange)
+posixTimeRangeToContainedSlotRange = send @(PABEffect w) . POSIXTimeRangeToSlotRange

src/BotPlutusInterface/ExBudget.hs

@@ -30,9 +30,9 @@ import Prelude
  minting to `MintingPolicyHash`'es
 -}
 estimateBudget :: PABConfig -> TxFile -> IO (Either BudgetEstimationError TxBudget)
-estimateBudget bapConf txFile = do
+estimateBudget pabConf txFile = do
   sock <- getEnv "CARDANO_NODE_SOCKET_PATH"
-  let debugNodeInf = NodeInfo (pcNetwork bapConf) sock
+  let debugNodeInf = NodeInfo (pcNetwork pabConf) sock
   txBody <- case txFile of
     Raw rp -> deserialiseRaw rp
     Signed sp -> fmap CAPI.getTxBody <$> deserialiseSigned sp
@@ -151,7 +151,7 @@ mkBudgetMaps exUnitsMap txBody = do
         CAPI.TxMintValue _ value _ ->
           {- The minting policies are indexed in policy id order in the value
              reference:
-             https://github.com/input-output-hk/cardano-node/blob/e31455eaeca98530ce561b79687a8e465ebb3fdd/cardano-api/src/Cardano/Api/TxBody.hs#L2851
+             https://github.com/input-output-hk/cardano-node/blob/e31455eaeca98530ce561b79687a8e465ebb3fdd/cardano-api/src/Cardano/Api/TxBody.hs#L2881
           -}
           let CAPI.ValueNestedRep bundle = CAPI.valueToNestedRep value
            in Map.fromList