{-# LANGUAGE DataKinds          #-}
{-# LANGUAGE DeriveAnyClass     #-}
{-# LANGUAGE DeriveGeneric      #-}
{-# LANGUAGE DerivingVia        #-}
{-# LANGUAGE GADTs              #-}
{-# LANGUAGE LambdaCase         #-}
{-# LANGUAGE NamedFieldPuns     #-}
{-# LANGUAGE NoImplicitPrelude  #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedStrings  #-}
{-# LANGUAGE TemplateHaskell    #-}
{-# LANGUAGE TypeApplications   #-}
{-# LANGUAGE TypeOperators      #-}
{-# LANGUAGE ViewPatterns       #-}
{-# OPTIONS_GHC -g -fplugin-opt PlutusTx.Plugin:coverage-all #-}
module Plutus.Contracts.Auction(
    AuctionState(..),
    AuctionInput(..),
    BuyerSchema,
    SellerSchema,
    AuctionParams(..),
    HighestBid(..),
    auctionBuyer,
    auctionSeller,
    AuctionOutput(..),
    AuctionError(..),
    ThreadToken,
    SM.getThreadToken,
    covIdx
    ) where

import Control.Lens (makeClassyPrisms)
import Data.Aeson (FromJSON, ToJSON)
import Data.Monoid (Last (..))
import Data.Semigroup.Generic (GenericSemigroupMonoid (..))
import GHC.Generics (Generic)
import Ledger (Address, POSIXTime, toPlutusAddress)
import Ledger.Tx.Constraints (TxConstraints)
import Ledger.Tx.Constraints qualified as Constraints
import Ledger.Tx.Constraints.ValidityInterval qualified as Interval
import Ledger.Typed.Scripts qualified as Scripts
import Plutus.Contract
import Plutus.Contract.StateMachine (State (..), StateMachine (..), StateMachineClient, ThreadToken, Void,
                                     WaitingResult (..))
import Plutus.Contract.StateMachine qualified as SM
import Plutus.Contract.Util (loopM)
import Plutus.Script.Utils.Ada qualified as Ada
import Plutus.Script.Utils.V2.Typed.Scripts qualified as V2
import Plutus.Script.Utils.Value qualified as Value
import PlutusTx qualified
import PlutusTx.Code
import PlutusTx.Coverage
import PlutusTx.Prelude
import Prelude qualified as Haskell

-- | Definition of an auction
data AuctionParams
    = AuctionParams
        { AuctionParams -> Address
apOwner   :: Address -- ^ Current owner of the asset. This is where the proceeds of the auction will be sent.
        , AuctionParams -> Value
apAsset   :: Value.Value -- ^ The asset itself. This value is going to be locked by the auction script output.
        , AuctionParams -> POSIXTime
apEndTime :: POSIXTime -- ^ When the time window for bidding ends.
        }
        deriving stock (AuctionParams -> AuctionParams -> Bool
(AuctionParams -> AuctionParams -> Bool)
-> (AuctionParams -> AuctionParams -> Bool) -> Eq AuctionParams
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: AuctionParams -> AuctionParams -> Bool
$c/= :: AuctionParams -> AuctionParams -> Bool
== :: AuctionParams -> AuctionParams -> Bool
$c== :: AuctionParams -> AuctionParams -> Bool
Haskell.Eq, Int -> AuctionParams -> ShowS
[AuctionParams] -> ShowS
AuctionParams -> String
(Int -> AuctionParams -> ShowS)
-> (AuctionParams -> String)
-> ([AuctionParams] -> ShowS)
-> Show AuctionParams
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [AuctionParams] -> ShowS
$cshowList :: [AuctionParams] -> ShowS
show :: AuctionParams -> String
$cshow :: AuctionParams -> String
showsPrec :: Int -> AuctionParams -> ShowS
$cshowsPrec :: Int -> AuctionParams -> ShowS
Haskell.Show, (forall x. AuctionParams -> Rep AuctionParams x)
-> (forall x. Rep AuctionParams x -> AuctionParams)
-> Generic AuctionParams
forall x. Rep AuctionParams x -> AuctionParams
forall x. AuctionParams -> Rep AuctionParams x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep AuctionParams x -> AuctionParams
$cfrom :: forall x. AuctionParams -> Rep AuctionParams x
Generic)
        deriving anyclass ([AuctionParams] -> Encoding
[AuctionParams] -> Value
AuctionParams -> Encoding
AuctionParams -> Value
(AuctionParams -> Value)
-> (AuctionParams -> Encoding)
-> ([AuctionParams] -> Value)
-> ([AuctionParams] -> Encoding)
-> ToJSON AuctionParams
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [AuctionParams] -> Encoding
$ctoEncodingList :: [AuctionParams] -> Encoding
toJSONList :: [AuctionParams] -> Value
$ctoJSONList :: [AuctionParams] -> Value
toEncoding :: AuctionParams -> Encoding
$ctoEncoding :: AuctionParams -> Encoding
toJSON :: AuctionParams -> Value
$ctoJSON :: AuctionParams -> Value
ToJSON, Value -> Parser [AuctionParams]
Value -> Parser AuctionParams
(Value -> Parser AuctionParams)
-> (Value -> Parser [AuctionParams]) -> FromJSON AuctionParams
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [AuctionParams]
$cparseJSONList :: Value -> Parser [AuctionParams]
parseJSON :: Value -> Parser AuctionParams
$cparseJSON :: Value -> Parser AuctionParams
FromJSON)

PlutusTx.makeLift ''AuctionParams


data HighestBid =
    HighestBid
        { HighestBid -> Ada
highestBid    :: Ada.Ada
        , HighestBid -> Address
highestBidder :: Address
        }
    deriving stock (HighestBid -> HighestBid -> Bool
(HighestBid -> HighestBid -> Bool)
-> (HighestBid -> HighestBid -> Bool) -> Eq HighestBid
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: HighestBid -> HighestBid -> Bool
$c/= :: HighestBid -> HighestBid -> Bool
== :: HighestBid -> HighestBid -> Bool
$c== :: HighestBid -> HighestBid -> Bool
Haskell.Eq, Int -> HighestBid -> ShowS
[HighestBid] -> ShowS
HighestBid -> String
(Int -> HighestBid -> ShowS)
-> (HighestBid -> String)
-> ([HighestBid] -> ShowS)
-> Show HighestBid
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [HighestBid] -> ShowS
$cshowList :: [HighestBid] -> ShowS
show :: HighestBid -> String
$cshow :: HighestBid -> String
showsPrec :: Int -> HighestBid -> ShowS
$cshowsPrec :: Int -> HighestBid -> ShowS
Haskell.Show, (forall x. HighestBid -> Rep HighestBid x)
-> (forall x. Rep HighestBid x -> HighestBid) -> Generic HighestBid
forall x. Rep HighestBid x -> HighestBid
forall x. HighestBid -> Rep HighestBid x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep HighestBid x -> HighestBid
$cfrom :: forall x. HighestBid -> Rep HighestBid x
Generic)
    deriving anyclass ([HighestBid] -> Encoding
[HighestBid] -> Value
HighestBid -> Encoding
HighestBid -> Value
(HighestBid -> Value)
-> (HighestBid -> Encoding)
-> ([HighestBid] -> Value)
-> ([HighestBid] -> Encoding)
-> ToJSON HighestBid
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [HighestBid] -> Encoding
$ctoEncodingList :: [HighestBid] -> Encoding
toJSONList :: [HighestBid] -> Value
$ctoJSONList :: [HighestBid] -> Value
toEncoding :: HighestBid -> Encoding
$ctoEncoding :: HighestBid -> Encoding
toJSON :: HighestBid -> Value
$ctoJSON :: HighestBid -> Value
ToJSON, Value -> Parser [HighestBid]
Value -> Parser HighestBid
(Value -> Parser HighestBid)
-> (Value -> Parser [HighestBid]) -> FromJSON HighestBid
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [HighestBid]
$cparseJSONList :: Value -> Parser [HighestBid]
parseJSON :: Value -> Parser HighestBid
$cparseJSON :: Value -> Parser HighestBid
FromJSON)

PlutusTx.unstableMakeIsData ''HighestBid

-- | The states of the auction
data AuctionState
    = Ongoing HighestBid -- Bids can be submitted.
    | Finished HighestBid -- The auction is finished
    deriving stock ((forall x. AuctionState -> Rep AuctionState x)
-> (forall x. Rep AuctionState x -> AuctionState)
-> Generic AuctionState
forall x. Rep AuctionState x -> AuctionState
forall x. AuctionState -> Rep AuctionState x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep AuctionState x -> AuctionState
$cfrom :: forall x. AuctionState -> Rep AuctionState x
Generic, Int -> AuctionState -> ShowS
[AuctionState] -> ShowS
AuctionState -> String
(Int -> AuctionState -> ShowS)
-> (AuctionState -> String)
-> ([AuctionState] -> ShowS)
-> Show AuctionState
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [AuctionState] -> ShowS
$cshowList :: [AuctionState] -> ShowS
show :: AuctionState -> String
$cshow :: AuctionState -> String
showsPrec :: Int -> AuctionState -> ShowS
$cshowsPrec :: Int -> AuctionState -> ShowS
Haskell.Show, AuctionState -> AuctionState -> Bool
(AuctionState -> AuctionState -> Bool)
-> (AuctionState -> AuctionState -> Bool) -> Eq AuctionState
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: AuctionState -> AuctionState -> Bool
$c/= :: AuctionState -> AuctionState -> Bool
== :: AuctionState -> AuctionState -> Bool
$c== :: AuctionState -> AuctionState -> Bool
Haskell.Eq)
    deriving anyclass ([AuctionState] -> Encoding
[AuctionState] -> Value
AuctionState -> Encoding
AuctionState -> Value
(AuctionState -> Value)
-> (AuctionState -> Encoding)
-> ([AuctionState] -> Value)
-> ([AuctionState] -> Encoding)
-> ToJSON AuctionState
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [AuctionState] -> Encoding
$ctoEncodingList :: [AuctionState] -> Encoding
toJSONList :: [AuctionState] -> Value
$ctoJSONList :: [AuctionState] -> Value
toEncoding :: AuctionState -> Encoding
$ctoEncoding :: AuctionState -> Encoding
toJSON :: AuctionState -> Value
$ctoJSON :: AuctionState -> Value
ToJSON, Value -> Parser [AuctionState]
Value -> Parser AuctionState
(Value -> Parser AuctionState)
-> (Value -> Parser [AuctionState]) -> FromJSON AuctionState
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [AuctionState]
$cparseJSONList :: Value -> Parser [AuctionState]
parseJSON :: Value -> Parser AuctionState
$cparseJSON :: Value -> Parser AuctionState
FromJSON)

-- | Observable state of the auction app
data AuctionOutput =
    AuctionOutput
        { AuctionOutput -> Last AuctionState
auctionState       :: Last AuctionState
        , AuctionOutput -> Last ThreadToken
auctionThreadToken :: Last ThreadToken
        }
        deriving stock ((forall x. AuctionOutput -> Rep AuctionOutput x)
-> (forall x. Rep AuctionOutput x -> AuctionOutput)
-> Generic AuctionOutput
forall x. Rep AuctionOutput x -> AuctionOutput
forall x. AuctionOutput -> Rep AuctionOutput x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep AuctionOutput x -> AuctionOutput
$cfrom :: forall x. AuctionOutput -> Rep AuctionOutput x
Generic, Int -> AuctionOutput -> ShowS
[AuctionOutput] -> ShowS
AuctionOutput -> String
(Int -> AuctionOutput -> ShowS)
-> (AuctionOutput -> String)
-> ([AuctionOutput] -> ShowS)
-> Show AuctionOutput
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [AuctionOutput] -> ShowS
$cshowList :: [AuctionOutput] -> ShowS
show :: AuctionOutput -> String
$cshow :: AuctionOutput -> String
showsPrec :: Int -> AuctionOutput -> ShowS
$cshowsPrec :: Int -> AuctionOutput -> ShowS
Haskell.Show, AuctionOutput -> AuctionOutput -> Bool
(AuctionOutput -> AuctionOutput -> Bool)
-> (AuctionOutput -> AuctionOutput -> Bool) -> Eq AuctionOutput
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: AuctionOutput -> AuctionOutput -> Bool
$c/= :: AuctionOutput -> AuctionOutput -> Bool
== :: AuctionOutput -> AuctionOutput -> Bool
$c== :: AuctionOutput -> AuctionOutput -> Bool
Haskell.Eq)
        deriving anyclass ([AuctionOutput] -> Encoding
[AuctionOutput] -> Value
AuctionOutput -> Encoding
AuctionOutput -> Value
(AuctionOutput -> Value)
-> (AuctionOutput -> Encoding)
-> ([AuctionOutput] -> Value)
-> ([AuctionOutput] -> Encoding)
-> ToJSON AuctionOutput
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [AuctionOutput] -> Encoding
$ctoEncodingList :: [AuctionOutput] -> Encoding
toJSONList :: [AuctionOutput] -> Value
$ctoJSONList :: [AuctionOutput] -> Value
toEncoding :: AuctionOutput -> Encoding
$ctoEncoding :: AuctionOutput -> Encoding
toJSON :: AuctionOutput -> Value
$ctoJSON :: AuctionOutput -> Value
ToJSON, Value -> Parser [AuctionOutput]
Value -> Parser AuctionOutput
(Value -> Parser AuctionOutput)
-> (Value -> Parser [AuctionOutput]) -> FromJSON AuctionOutput
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [AuctionOutput]
$cparseJSONList :: Value -> Parser [AuctionOutput]
parseJSON :: Value -> Parser AuctionOutput
$cparseJSON :: Value -> Parser AuctionOutput
FromJSON)
        deriving (b -> AuctionOutput -> AuctionOutput
NonEmpty AuctionOutput -> AuctionOutput
AuctionOutput -> AuctionOutput -> AuctionOutput
(AuctionOutput -> AuctionOutput -> AuctionOutput)
-> (NonEmpty AuctionOutput -> AuctionOutput)
-> (forall b. Integral b => b -> AuctionOutput -> AuctionOutput)
-> Semigroup AuctionOutput
forall b. Integral b => b -> AuctionOutput -> AuctionOutput
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
stimes :: b -> AuctionOutput -> AuctionOutput
$cstimes :: forall b. Integral b => b -> AuctionOutput -> AuctionOutput
sconcat :: NonEmpty AuctionOutput -> AuctionOutput
$csconcat :: NonEmpty AuctionOutput -> AuctionOutput
<> :: AuctionOutput -> AuctionOutput -> AuctionOutput
$c<> :: AuctionOutput -> AuctionOutput -> AuctionOutput
Haskell.Semigroup, Semigroup AuctionOutput
AuctionOutput
Semigroup AuctionOutput
-> AuctionOutput
-> (AuctionOutput -> AuctionOutput -> AuctionOutput)
-> ([AuctionOutput] -> AuctionOutput)
-> Monoid AuctionOutput
[AuctionOutput] -> AuctionOutput
AuctionOutput -> AuctionOutput -> AuctionOutput
forall a.
Semigroup a -> a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
mconcat :: [AuctionOutput] -> AuctionOutput
$cmconcat :: [AuctionOutput] -> AuctionOutput
mappend :: AuctionOutput -> AuctionOutput -> AuctionOutput
$cmappend :: AuctionOutput -> AuctionOutput -> AuctionOutput
mempty :: AuctionOutput
$cmempty :: AuctionOutput
$cp1Monoid :: Semigroup AuctionOutput
Haskell.Monoid) via (GenericSemigroupMonoid AuctionOutput)

auctionStateOut :: AuctionState -> AuctionOutput
auctionStateOut :: AuctionState -> AuctionOutput
auctionStateOut AuctionState
s = AuctionOutput
forall a. Monoid a => a
Haskell.mempty { auctionState :: Last AuctionState
auctionState = Maybe AuctionState -> Last AuctionState
forall a. Maybe a -> Last a
Last (AuctionState -> Maybe AuctionState
forall a. a -> Maybe a
Just AuctionState
s) }

threadTokenOut :: ThreadToken -> AuctionOutput
threadTokenOut :: ThreadToken -> AuctionOutput
threadTokenOut ThreadToken
t = AuctionOutput
forall a. Monoid a => a
Haskell.mempty { auctionThreadToken :: Last ThreadToken
auctionThreadToken = Maybe ThreadToken -> Last ThreadToken
forall a. Maybe a -> Last a
Last (ThreadToken -> Maybe ThreadToken
forall a. a -> Maybe a
Just ThreadToken
t) }

-- | Initial 'AuctionState'. In the beginning the highest bid is 0 and the
--   highest bidder is seller of the asset. So if nobody submits
--   any bids, the seller gets the asset back after the auction has ended.
initialState :: Address -> AuctionState
initialState :: Address -> AuctionState
initialState Address
self = HighestBid -> AuctionState
Ongoing HighestBid :: Ada -> Address -> HighestBid
HighestBid{highestBid :: Ada
highestBid = Ada
0, highestBidder :: Address
highestBidder = Address
self}

PlutusTx.unstableMakeIsData ''AuctionState

-- | Transition between auction states
data AuctionInput
    = Bid { AuctionInput -> Ada
newBid :: Ada.Ada, AuctionInput -> Address
newBidder :: Address } -- Increase the price
    | Payout
    deriving stock ((forall x. AuctionInput -> Rep AuctionInput x)
-> (forall x. Rep AuctionInput x -> AuctionInput)
-> Generic AuctionInput
forall x. Rep AuctionInput x -> AuctionInput
forall x. AuctionInput -> Rep AuctionInput x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep AuctionInput x -> AuctionInput
$cfrom :: forall x. AuctionInput -> Rep AuctionInput x
Generic, Int -> AuctionInput -> ShowS
[AuctionInput] -> ShowS
AuctionInput -> String
(Int -> AuctionInput -> ShowS)
-> (AuctionInput -> String)
-> ([AuctionInput] -> ShowS)
-> Show AuctionInput
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [AuctionInput] -> ShowS
$cshowList :: [AuctionInput] -> ShowS
show :: AuctionInput -> String
$cshow :: AuctionInput -> String
showsPrec :: Int -> AuctionInput -> ShowS
$cshowsPrec :: Int -> AuctionInput -> ShowS
Haskell.Show)
    deriving anyclass ([AuctionInput] -> Encoding
[AuctionInput] -> Value
AuctionInput -> Encoding
AuctionInput -> Value
(AuctionInput -> Value)
-> (AuctionInput -> Encoding)
-> ([AuctionInput] -> Value)
-> ([AuctionInput] -> Encoding)
-> ToJSON AuctionInput
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [AuctionInput] -> Encoding
$ctoEncodingList :: [AuctionInput] -> Encoding
toJSONList :: [AuctionInput] -> Value
$ctoJSONList :: [AuctionInput] -> Value
toEncoding :: AuctionInput -> Encoding
$ctoEncoding :: AuctionInput -> Encoding
toJSON :: AuctionInput -> Value
$ctoJSON :: AuctionInput -> Value
ToJSON, Value -> Parser [AuctionInput]
Value -> Parser AuctionInput
(Value -> Parser AuctionInput)
-> (Value -> Parser [AuctionInput]) -> FromJSON AuctionInput
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [AuctionInput]
$cparseJSONList :: Value -> Parser [AuctionInput]
parseJSON :: Value -> Parser AuctionInput
$cparseJSON :: Value -> Parser AuctionInput
FromJSON)

PlutusTx.unstableMakeIsData ''AuctionInput

type AuctionMachine = StateMachine AuctionState AuctionInput

{-# INLINABLE auctionTransition #-}
-- | The transitions of the auction state machine.
auctionTransition
    :: AuctionParams
    -> State AuctionState
    -> AuctionInput
    -> Maybe (TxConstraints Void Void, State AuctionState)
auctionTransition :: AuctionParams
-> State AuctionState
-> AuctionInput
-> Maybe (TxConstraints Void Void, State AuctionState)
auctionTransition AuctionParams{Address
apOwner :: Address
apOwner :: AuctionParams -> Address
apOwner, Value
apAsset :: Value
apAsset :: AuctionParams -> Value
apAsset, POSIXTime
apEndTime :: POSIXTime
apEndTime :: AuctionParams -> POSIXTime
apEndTime} State{stateData :: forall s. State s -> s
stateData=AuctionState
oldStateData, stateValue :: forall s. State s -> Value
stateValue=Value
oldStateValue} AuctionInput
input =
    case (AuctionState
oldStateData, AuctionInput
input) of

        (Ongoing HighestBid{Ada
highestBid :: Ada
highestBid :: HighestBid -> Ada
highestBid, Address
highestBidder :: Address
highestBidder :: HighestBid -> Address
highestBidder}, Bid{Ada
newBid :: Ada
newBid :: AuctionInput -> Ada
newBid, Address
newBidder :: Address
newBidder :: AuctionInput -> Address
newBidder}) | Ada
newBid Ada -> Ada -> Bool
forall a. Ord a => a -> a -> Bool
> Ada
highestBid -> -- if the new bid is higher,
            let constraints :: TxConstraints Void Void
constraints = if Ada
highestBid Ada -> Ada -> Bool
forall a. Eq a => a -> a -> Bool
== Ada
0 then TxConstraints Void Void
forall a. Monoid a => a
mempty else
                    Address -> Value -> TxConstraints Void Void
forall i o. Address -> Value -> TxConstraints i o
Constraints.mustPayToAddress Address
highestBidder (Ada -> Value
Ada.toValue Ada
highestBid) -- we pay back the previous highest bid
                    TxConstraints Void Void
-> TxConstraints Void Void -> TxConstraints Void Void
forall a. Semigroup a => a -> a -> a
<> ValidityInterval POSIXTime -> TxConstraints Void Void
forall i o. ValidityInterval POSIXTime -> TxConstraints i o
Constraints.mustValidateInTimeRange (POSIXTime -> ValidityInterval POSIXTime
forall a. a -> ValidityInterval a
Interval.lessThan (POSIXTime -> ValidityInterval POSIXTime)
-> POSIXTime -> ValidityInterval POSIXTime
forall a b. (a -> b) -> a -> b
$ POSIXTime
1 POSIXTime -> POSIXTime -> POSIXTime
forall a. AdditiveSemigroup a => a -> a -> a
+ POSIXTime
apEndTime) -- but only if we haven't gone past 'apEndTime'
                newState :: State AuctionState
newState =
                    State :: forall s. s -> Value -> State s
State
                        { stateData :: AuctionState
stateData = HighestBid -> AuctionState
Ongoing HighestBid :: Ada -> Address -> HighestBid
HighestBid{highestBid :: Ada
highestBid = Ada
newBid, highestBidder :: Address
highestBidder = Address
newBidder}
                        , stateValue :: Value
stateValue = Value -> Value
Value.noAdaValue Value
oldStateValue
                                    Value -> Value -> Value
forall a. Semigroup a => a -> a -> a
<> Ada -> Value
Ada.toValue (Value -> Ada
Ada.fromValue Value
oldStateValue Ada -> Ada -> Ada
forall a. AdditiveGroup a => a -> a -> a
- Ada
highestBid)
                                    Value -> Value -> Value
forall a. Semigroup a => a -> a -> a
<> Ada -> Value
Ada.toValue Ada
newBid -- and lock the new bid in the script output
                        }
            in (TxConstraints Void Void, State AuctionState)
-> Maybe (TxConstraints Void Void, State AuctionState)
forall a. a -> Maybe a
Just (TxConstraints Void Void
constraints, State AuctionState
newState)

        (Ongoing h :: HighestBid
h@HighestBid{Address
highestBidder :: Address
highestBidder :: HighestBid -> Address
highestBidder, Ada
highestBid :: Ada
highestBid :: HighestBid -> Ada
highestBid}, AuctionInput
Payout) ->
            let constraints :: TxConstraints Void Void
constraints =
                    ValidityInterval POSIXTime -> TxConstraints Void Void
forall i o. ValidityInterval POSIXTime -> TxConstraints i o
Constraints.mustValidateInTimeRange (POSIXTime -> ValidityInterval POSIXTime
forall a. a -> ValidityInterval a
Interval.from POSIXTime
apEndTime) -- When the auction has ended,
                    TxConstraints Void Void
-> TxConstraints Void Void -> TxConstraints Void Void
forall a. Semigroup a => a -> a -> a
<> Address -> Value -> TxConstraints Void Void
forall i o. Address -> Value -> TxConstraints i o
Constraints.mustPayToAddress Address
apOwner (Ada -> Value
Ada.toValue Ada
highestBid) -- the owner receives the payment
                    TxConstraints Void Void
-> TxConstraints Void Void -> TxConstraints Void Void
forall a. Semigroup a => a -> a -> a
<> Address -> Value -> TxConstraints Void Void
forall i o. Address -> Value -> TxConstraints i o
Constraints.mustPayToAddress Address
highestBidder Value
apAsset -- and the highest bidder the asset
                newState :: State AuctionState
newState = State :: forall s. s -> Value -> State s
State { stateData :: AuctionState
stateData = HighestBid -> AuctionState
Finished HighestBid
h, stateValue :: Value
stateValue = Value
forall a. Monoid a => a
mempty }
            in (TxConstraints Void Void, State AuctionState)
-> Maybe (TxConstraints Void Void, State AuctionState)
forall a. a -> Maybe a
Just (TxConstraints Void Void
constraints, State AuctionState
newState)

        -- Any other combination of 'AuctionState' and 'AuctionInput' is disallowed.
        -- This rules out new bids that don't go over the current highest bid.
        (AuctionState, AuctionInput)
_ -> Maybe (TxConstraints Void Void, State AuctionState)
forall a. Maybe a
Nothing


{-# INLINABLE auctionStateMachine #-}
auctionStateMachine :: (ThreadToken, AuctionParams) -> AuctionMachine
auctionStateMachine :: (ThreadToken, AuctionParams) -> AuctionMachine
auctionStateMachine (ThreadToken
threadToken, AuctionParams
auctionParams) =
    Maybe ThreadToken
-> (State AuctionState
    -> AuctionInput
    -> Maybe (TxConstraints Void Void, State AuctionState))
-> (AuctionState -> Bool)
-> AuctionMachine
forall s i.
Maybe ThreadToken
-> (State s -> i -> Maybe (TxConstraints Void Void, State s))
-> (s -> Bool)
-> StateMachine s i
SM.mkStateMachine (ThreadToken -> Maybe ThreadToken
forall a. a -> Maybe a
Just ThreadToken
threadToken) (AuctionParams
-> State AuctionState
-> AuctionInput
-> Maybe (TxConstraints Void Void, State AuctionState)
auctionTransition AuctionParams
auctionParams) AuctionState -> Bool
isFinal
  where
    isFinal :: AuctionState -> Bool
isFinal Finished{} = Bool
True
    isFinal AuctionState
_          = Bool
False

{-# INLINABLE mkValidator #-}
mkValidator :: (ThreadToken, AuctionParams) -> V2.ValidatorType AuctionMachine
mkValidator :: (ThreadToken, AuctionParams) -> ValidatorType AuctionMachine
mkValidator = AuctionMachine
-> AuctionState -> AuctionInput -> ScriptContext -> Bool
forall s i.
ToData s =>
StateMachine s i -> ValidatorType (StateMachine s i)
SM.mkValidator (AuctionMachine
 -> AuctionState -> AuctionInput -> ScriptContext -> Bool)
-> ((ThreadToken, AuctionParams) -> AuctionMachine)
-> (ThreadToken, AuctionParams)
-> AuctionState
-> AuctionInput
-> ScriptContext
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ThreadToken, AuctionParams) -> AuctionMachine
auctionStateMachine

-- | The script instance of the auction state machine. It contains the state
--   machine compiled to a Plutus core validator script.
typedValidator :: (ThreadToken, AuctionParams) -> V2.TypedValidator AuctionMachine
typedValidator :: (ThreadToken, AuctionParams) -> TypedValidator AuctionMachine
typedValidator = CompiledCode
  ((ThreadToken, AuctionParams) -> ValidatorType AuctionMachine)
-> CompiledCode (ValidatorType AuctionMachine -> UntypedValidator)
-> (ThreadToken, AuctionParams)
-> TypedValidator AuctionMachine
forall a param.
Lift DefaultUni param =>
CompiledCode (param -> ValidatorType a)
-> CompiledCode (ValidatorType a -> UntypedValidator)
-> param
-> TypedValidator a
V2.mkTypedValidatorParam @AuctionMachine
    $$(PlutusTx.compile [|| mkValidator ||])
    $$(PlutusTx.compile [|| wrap ||])
    where
        wrap :: (AuctionState -> AuctionInput -> ScriptContext -> Bool)
-> UntypedValidator
wrap = (AuctionState -> AuctionInput -> ScriptContext -> Bool)
-> UntypedValidator
forall sc d r.
(IsScriptContext sc, UnsafeFromData d, UnsafeFromData r) =>
(d -> r -> sc -> Bool) -> UntypedValidator
Scripts.mkUntypedValidator

-- | The machine client of the auction state machine. It contains the script instance
--   with the on-chain code, and the Haskell definition of the state machine for
--   off-chain use.
machineClient
    :: V2.TypedValidator AuctionMachine
    -> ThreadToken -- ^ Thread token of the instance
    -> AuctionParams
    -> StateMachineClient AuctionState AuctionInput
machineClient :: TypedValidator AuctionMachine
-> ThreadToken
-> AuctionParams
-> StateMachineClient AuctionState AuctionInput
machineClient TypedValidator AuctionMachine
inst ThreadToken
threadToken AuctionParams
auctionParams =
    let machine :: AuctionMachine
machine = (ThreadToken, AuctionParams) -> AuctionMachine
auctionStateMachine (ThreadToken
threadToken, AuctionParams
auctionParams)
    in StateMachineInstance AuctionState AuctionInput
-> StateMachineClient AuctionState AuctionInput
forall state input.
StateMachineInstance state input -> StateMachineClient state input
SM.mkStateMachineClient (AuctionMachine
-> TypedValidator AuctionMachine
-> StateMachineInstance AuctionState AuctionInput
forall s i.
StateMachine s i
-> TypedValidator (StateMachine s i) -> StateMachineInstance s i
SM.StateMachineInstance AuctionMachine
machine TypedValidator AuctionMachine
inst)

type BuyerSchema = Endpoint "bid" Ada.Ada
type SellerSchema = EmptySchema -- Don't need any endpoints: the contract runs automatically until the auction is finished.

data AuctionLog =
    AuctionStarted AuctionParams
    | AuctionFailed SM.SMContractError
    | BidSubmitted HighestBid
    | AuctionEnded HighestBid
    | CurrentStateNotFound
    | TransitionFailed (SM.InvalidTransition AuctionState AuctionInput)
    deriving stock (Int -> AuctionLog -> ShowS
[AuctionLog] -> ShowS
AuctionLog -> String
(Int -> AuctionLog -> ShowS)
-> (AuctionLog -> String)
-> ([AuctionLog] -> ShowS)
-> Show AuctionLog
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [AuctionLog] -> ShowS
$cshowList :: [AuctionLog] -> ShowS
show :: AuctionLog -> String
$cshow :: AuctionLog -> String
showsPrec :: Int -> AuctionLog -> ShowS
$cshowsPrec :: Int -> AuctionLog -> ShowS
Haskell.Show, (forall x. AuctionLog -> Rep AuctionLog x)
-> (forall x. Rep AuctionLog x -> AuctionLog) -> Generic AuctionLog
forall x. Rep AuctionLog x -> AuctionLog
forall x. AuctionLog -> Rep AuctionLog x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep AuctionLog x -> AuctionLog
$cfrom :: forall x. AuctionLog -> Rep AuctionLog x
Generic)
    deriving anyclass ([AuctionLog] -> Encoding
[AuctionLog] -> Value
AuctionLog -> Encoding
AuctionLog -> Value
(AuctionLog -> Value)
-> (AuctionLog -> Encoding)
-> ([AuctionLog] -> Value)
-> ([AuctionLog] -> Encoding)
-> ToJSON AuctionLog
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [AuctionLog] -> Encoding
$ctoEncodingList :: [AuctionLog] -> Encoding
toJSONList :: [AuctionLog] -> Value
$ctoJSONList :: [AuctionLog] -> Value
toEncoding :: AuctionLog -> Encoding
$ctoEncoding :: AuctionLog -> Encoding
toJSON :: AuctionLog -> Value
$ctoJSON :: AuctionLog -> Value
ToJSON, Value -> Parser [AuctionLog]
Value -> Parser AuctionLog
(Value -> Parser AuctionLog)
-> (Value -> Parser [AuctionLog]) -> FromJSON AuctionLog
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [AuctionLog]
$cparseJSONList :: Value -> Parser [AuctionLog]
parseJSON :: Value -> Parser AuctionLog
$cparseJSON :: Value -> Parser AuctionLog
FromJSON)

data AuctionError =
    StateMachineContractError SM.SMContractError -- ^ State machine operation failed
    | AuctionContractError ContractError -- ^ Endpoint, coin selection, etc. failed
    deriving stock (AuctionError -> AuctionError -> Bool
(AuctionError -> AuctionError -> Bool)
-> (AuctionError -> AuctionError -> Bool) -> Eq AuctionError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: AuctionError -> AuctionError -> Bool
$c/= :: AuctionError -> AuctionError -> Bool
== :: AuctionError -> AuctionError -> Bool
$c== :: AuctionError -> AuctionError -> Bool
Haskell.Eq, Int -> AuctionError -> ShowS
[AuctionError] -> ShowS
AuctionError -> String
(Int -> AuctionError -> ShowS)
-> (AuctionError -> String)
-> ([AuctionError] -> ShowS)
-> Show AuctionError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [AuctionError] -> ShowS
$cshowList :: [AuctionError] -> ShowS
show :: AuctionError -> String
$cshow :: AuctionError -> String
showsPrec :: Int -> AuctionError -> ShowS
$cshowsPrec :: Int -> AuctionError -> ShowS
Haskell.Show, (forall x. AuctionError -> Rep AuctionError x)
-> (forall x. Rep AuctionError x -> AuctionError)
-> Generic AuctionError
forall x. Rep AuctionError x -> AuctionError
forall x. AuctionError -> Rep AuctionError x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep AuctionError x -> AuctionError
$cfrom :: forall x. AuctionError -> Rep AuctionError x
Generic)
    deriving anyclass ([AuctionError] -> Encoding
[AuctionError] -> Value
AuctionError -> Encoding
AuctionError -> Value
(AuctionError -> Value)
-> (AuctionError -> Encoding)
-> ([AuctionError] -> Value)
-> ([AuctionError] -> Encoding)
-> ToJSON AuctionError
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [AuctionError] -> Encoding
$ctoEncodingList :: [AuctionError] -> Encoding
toJSONList :: [AuctionError] -> Value
$ctoJSONList :: [AuctionError] -> Value
toEncoding :: AuctionError -> Encoding
$ctoEncoding :: AuctionError -> Encoding
toJSON :: AuctionError -> Value
$ctoJSON :: AuctionError -> Value
ToJSON, Value -> Parser [AuctionError]
Value -> Parser AuctionError
(Value -> Parser AuctionError)
-> (Value -> Parser [AuctionError]) -> FromJSON AuctionError
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [AuctionError]
$cparseJSONList :: Value -> Parser [AuctionError]
parseJSON :: Value -> Parser AuctionError
$cparseJSON :: Value -> Parser AuctionError
FromJSON)

makeClassyPrisms ''AuctionError

instance AsContractError AuctionError where
    _ContractError :: p ContractError (f ContractError)
-> p AuctionError (f AuctionError)
_ContractError = p ContractError (f ContractError)
-> p AuctionError (f AuctionError)
forall r. AsAuctionError r => Prism' r ContractError
_AuctionContractError (p ContractError (f ContractError)
 -> p AuctionError (f AuctionError))
-> (p ContractError (f ContractError)
    -> p ContractError (f ContractError))
-> p ContractError (f ContractError)
-> p AuctionError (f AuctionError)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. p ContractError (f ContractError)
-> p ContractError (f ContractError)
forall r. AsContractError r => Prism' r ContractError
_ContractError

instance SM.AsSMContractError AuctionError where
    _SMContractError :: p SMContractError (f SMContractError)
-> p AuctionError (f AuctionError)
_SMContractError = p SMContractError (f SMContractError)
-> p AuctionError (f AuctionError)
forall r. AsAuctionError r => Prism' r SMContractError
_StateMachineContractError (p SMContractError (f SMContractError)
 -> p AuctionError (f AuctionError))
-> (p SMContractError (f SMContractError)
    -> p SMContractError (f SMContractError))
-> p SMContractError (f SMContractError)
-> p AuctionError (f AuctionError)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. p SMContractError (f SMContractError)
-> p SMContractError (f SMContractError)
forall r. AsSMContractError r => Prism' r SMContractError
SM._SMContractError

-- | Client code for the seller
auctionSeller :: Value.Value -> POSIXTime -> Contract AuctionOutput SellerSchema AuctionError ()
auctionSeller :: Value
-> POSIXTime -> Contract AuctionOutput SellerSchema AuctionError ()
auctionSeller Value
value POSIXTime
time = do
    ThreadToken
threadToken <- Contract AuctionOutput SellerSchema AuctionError ThreadToken
forall e w (schema :: Row *).
AsSMContractError e =>
Contract w schema e ThreadToken
SM.getThreadToken
    AuctionOutput
-> Contract AuctionOutput SellerSchema AuctionError ()
forall w (s :: Row *) e. w -> Contract w s e ()
tell (AuctionOutput
 -> Contract AuctionOutput SellerSchema AuctionError ())
-> AuctionOutput
-> Contract AuctionOutput SellerSchema AuctionError ()
forall a b. (a -> b) -> a -> b
$ ThreadToken -> AuctionOutput
threadTokenOut ThreadToken
threadToken
    Address
self <- AddressInEra BabbageEra -> Address
forall era. AddressInEra era -> Address
toPlutusAddress (AddressInEra BabbageEra -> Address)
-> Contract
     AuctionOutput SellerSchema AuctionError (AddressInEra BabbageEra)
-> Contract AuctionOutput SellerSchema AuctionError Address
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Contract
  AuctionOutput SellerSchema AuctionError (AddressInEra BabbageEra)
forall w (s :: Row *) e.
AsContractError e =>
Contract w s e (AddressInEra BabbageEra)
ownAddress
    let params :: AuctionParams
params       = AuctionParams :: Address -> Value -> POSIXTime -> AuctionParams
AuctionParams{apOwner :: Address
apOwner = Address
self, apAsset :: Value
apAsset = Value
value, apEndTime :: POSIXTime
apEndTime = POSIXTime
time }
        inst :: TypedValidator AuctionMachine
inst         = (ThreadToken, AuctionParams) -> TypedValidator AuctionMachine
typedValidator (ThreadToken
threadToken, AuctionParams
params)
        client :: StateMachineClient AuctionState AuctionInput
client       = TypedValidator AuctionMachine
-> ThreadToken
-> AuctionParams
-> StateMachineClient AuctionState AuctionInput
machineClient TypedValidator AuctionMachine
inst ThreadToken
threadToken AuctionParams
params

    AuctionState
_ <- (SMContractError
 -> Contract AuctionOutput SellerSchema AuctionError AuctionState)
-> Contract AuctionOutput SellerSchema SMContractError AuctionState
-> Contract AuctionOutput SellerSchema AuctionError AuctionState
forall w (s :: Row *) e e' a.
(e -> Contract w s e' a) -> Contract w s e a -> Contract w s e' a
handleError
            (\SMContractError
e -> do { AuctionLog -> Contract AuctionOutput SellerSchema AuctionError ()
forall a w (s :: Row *) e. ToJSON a => a -> Contract w s e ()
logError (SMContractError -> AuctionLog
AuctionFailed SMContractError
e); AuctionError
-> Contract AuctionOutput SellerSchema AuctionError AuctionState
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (SMContractError -> AuctionError
StateMachineContractError SMContractError
e) })
            (StateMachineClient AuctionState AuctionInput
-> AuctionState
-> Value
-> Contract AuctionOutput SellerSchema SMContractError AuctionState
forall w e state (schema :: Row *) input.
(FromData state, ToData state, ToData input,
 AsSMContractError e) =>
StateMachineClient state input
-> state -> Value -> Contract w schema e state
SM.runInitialise StateMachineClient AuctionState AuctionInput
client (Address -> AuctionState
initialState Address
self) Value
value)

    AuctionLog -> Contract AuctionOutput SellerSchema AuctionError ()
forall a w (s :: Row *) e. ToJSON a => a -> Contract w s e ()
logInfo (AuctionLog -> Contract AuctionOutput SellerSchema AuctionError ())
-> AuctionLog
-> Contract AuctionOutput SellerSchema AuctionError ()
forall a b. (a -> b) -> a -> b
$ AuctionParams -> AuctionLog
AuctionStarted AuctionParams
params
    POSIXTime
_ <- POSIXTime
-> Contract AuctionOutput SellerSchema AuctionError POSIXTime
forall w (s :: Row *) e.
AsContractError e =>
POSIXTime -> Contract w s e POSIXTime
awaitTime POSIXTime
time

    TransitionResult AuctionState AuctionInput
r <- StateMachineClient AuctionState AuctionInput
-> AuctionInput
-> Contract
     AuctionOutput
     SellerSchema
     AuctionError
     (TransitionResult AuctionState AuctionInput)
forall w e state (schema :: Row *) input.
(AsSMContractError e, FromData state, ToData state,
 ToData input) =>
StateMachineClient state input
-> input -> Contract w schema e (TransitionResult state input)
SM.runStep StateMachineClient AuctionState AuctionInput
client AuctionInput
Payout
    case TransitionResult AuctionState AuctionInput
r of
        SM.TransitionFailure InvalidTransition AuctionState AuctionInput
i            -> AuctionLog -> Contract AuctionOutput SellerSchema AuctionError ()
forall a w (s :: Row *) e. ToJSON a => a -> Contract w s e ()
logError (InvalidTransition AuctionState AuctionInput -> AuctionLog
TransitionFailed InvalidTransition AuctionState AuctionInput
i) -- TODO: Add an endpoint "retry" to the seller?
        SM.TransitionSuccess (Finished HighestBid
h) -> AuctionLog -> Contract AuctionOutput SellerSchema AuctionError ()
forall a w (s :: Row *) e. ToJSON a => a -> Contract w s e ()
logInfo (AuctionLog -> Contract AuctionOutput SellerSchema AuctionError ())
-> AuctionLog
-> Contract AuctionOutput SellerSchema AuctionError ()
forall a b. (a -> b) -> a -> b
$ HighestBid -> AuctionLog
AuctionEnded HighestBid
h
        SM.TransitionSuccess AuctionState
s            -> String -> Contract AuctionOutput SellerSchema AuctionError ()
forall a w (s :: Row *) e. ToJSON a => a -> Contract w s e ()
logWarn (String
"Unexpected state after Payout transition: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> AuctionState -> String
forall a. Show a => a -> String
Haskell.show AuctionState
s)


-- | Get the current state of the contract and log it.
currentState
    :: StateMachineClient AuctionState AuctionInput
    -> Contract AuctionOutput BuyerSchema AuctionError (Maybe HighestBid)
currentState :: StateMachineClient AuctionState AuctionInput
-> Contract
     AuctionOutput BuyerSchema AuctionError (Maybe HighestBid)
currentState StateMachineClient AuctionState AuctionInput
client = do
  Maybe
  (OnChainState AuctionState AuctionInput,
   Map TxOutRef DecoratedTxOut)
mOcs <- (SMContractError -> AuctionError)
-> Contract
     AuctionOutput
     ('R '[ "bid" ':-> (EndpointValue Ada, ActiveEndpoint)])
     SMContractError
     (Maybe
        (OnChainState AuctionState AuctionInput,
         Map TxOutRef DecoratedTxOut))
-> Contract
     AuctionOutput
     ('R '[ "bid" ':-> (EndpointValue Ada, ActiveEndpoint)])
     AuctionError
     (Maybe
        (OnChainState AuctionState AuctionInput,
         Map TxOutRef DecoratedTxOut))
forall w (s :: Row *) e e' a.
(e -> e') -> Contract w s e a -> Contract w s e' a
mapError SMContractError -> AuctionError
StateMachineContractError (StateMachineClient AuctionState AuctionInput
-> Contract
     AuctionOutput
     ('R '[ "bid" ':-> (EndpointValue Ada, ActiveEndpoint)])
     SMContractError
     (Maybe
        (OnChainState AuctionState AuctionInput,
         Map TxOutRef DecoratedTxOut))
forall e state i w (schema :: Row *).
(AsSMContractError e, FromData state, ToData state) =>
StateMachineClient state i
-> Contract
     w
     schema
     e
     (Maybe (OnChainState state i, Map TxOutRef DecoratedTxOut))
SM.getOnChainState StateMachineClient AuctionState AuctionInput
client)
  case Maybe
  (OnChainState AuctionState AuctionInput,
   Map TxOutRef DecoratedTxOut)
mOcs of
    Just (OnChainState AuctionState AuctionInput -> AuctionState
forall s i. OnChainState s i -> s
SM.getStateData -> Ongoing HighestBid
s, Map TxOutRef DecoratedTxOut
_) -> do
        AuctionOutput
-> Contract
     AuctionOutput
     ('R '[ "bid" ':-> (EndpointValue Ada, ActiveEndpoint)])
     AuctionError
     ()
forall w (s :: Row *) e. w -> Contract w s e ()
tell (AuctionOutput
 -> Contract
      AuctionOutput
      ('R '[ "bid" ':-> (EndpointValue Ada, ActiveEndpoint)])
      AuctionError
      ())
-> AuctionOutput
-> Contract
     AuctionOutput
     ('R '[ "bid" ':-> (EndpointValue Ada, ActiveEndpoint)])
     AuctionError
     ()
forall a b. (a -> b) -> a -> b
$ AuctionState -> AuctionOutput
auctionStateOut (AuctionState -> AuctionOutput) -> AuctionState -> AuctionOutput
forall a b. (a -> b) -> a -> b
$ HighestBid -> AuctionState
Ongoing HighestBid
s
        Maybe HighestBid
-> Contract
     AuctionOutput
     ('R '[ "bid" ':-> (EndpointValue Ada, ActiveEndpoint)])
     AuctionError
     (Maybe HighestBid)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HighestBid -> Maybe HighestBid
forall a. a -> Maybe a
Just HighestBid
s)
    Maybe
  (OnChainState AuctionState AuctionInput,
   Map TxOutRef DecoratedTxOut)
_ -> do
        AuctionLog
-> Contract
     AuctionOutput
     ('R '[ "bid" ':-> (EndpointValue Ada, ActiveEndpoint)])
     AuctionError
     ()
forall a w (s :: Row *) e. ToJSON a => a -> Contract w s e ()
logWarn AuctionLog
CurrentStateNotFound
        Maybe HighestBid
-> Contract
     AuctionOutput
     ('R '[ "bid" ':-> (EndpointValue Ada, ActiveEndpoint)])
     AuctionError
     (Maybe HighestBid)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe HighestBid
forall a. Maybe a
Nothing

{- Note [Buyer client]

In the buyer client we want to keep track of the on-chain state of the auction
to give our user a chance to react if they are outbid by somebody else.

At the same time we want to have the "bid" endpoint active for any bids of our
own, and we want to stop the client when the auction is over.

To achieve this, we have a loop where we wait for one of several events to
happen and then deal with the event. The waiting is implemented in
@waitForChange@ and the event handling is in @handleEvent@.

Updates to the user are provided via 'tell'.

-}

data BuyerEvent =
        AuctionIsOver HighestBid -- ^ The auction has ended with the highest bid
        | SubmitOwnBid Ada.Ada -- ^ We want to submit a new bid
        | OtherBid HighestBid -- ^ Another buyer submitted a higher bid
        | NoChange HighestBid -- ^ Nothing has changed

waitForChange
    :: AuctionParams
    -> StateMachineClient AuctionState AuctionInput
    -> HighestBid
    -> Contract AuctionOutput BuyerSchema AuctionError BuyerEvent
waitForChange :: AuctionParams
-> StateMachineClient AuctionState AuctionInput
-> HighestBid
-> Contract AuctionOutput BuyerSchema AuctionError BuyerEvent
waitForChange AuctionParams{POSIXTime
apEndTime :: POSIXTime
apEndTime :: AuctionParams -> POSIXTime
apEndTime} StateMachineClient AuctionState AuctionInput
client HighestBid
lastHighestBid = do
    -- Create a Promise that waits for either an update to the state machine's
    -- on chain state, or until the end of the auction
    Promise
  AuctionOutput
  ('R '[ "bid" ':-> (EndpointValue Ada, ActiveEndpoint)])
  AuctionError
  (WaitingResult
     POSIXTime AuctionInput (OnChainState AuctionState AuctionInput))
smUpdatePromise <- StateMachineClient AuctionState AuctionInput
-> Promise
     AuctionOutput
     ('R '[ "bid" ':-> (EndpointValue Ada, ActiveEndpoint)])
     AuctionError
     POSIXTime
-> Contract
     AuctionOutput
     ('R '[ "bid" ':-> (EndpointValue Ada, ActiveEndpoint)])
     AuctionError
     (Promise
        AuctionOutput
        ('R '[ "bid" ':-> (EndpointValue Ada, ActiveEndpoint)])
        AuctionError
        (WaitingResult
           POSIXTime AuctionInput (OnChainState AuctionState AuctionInput)))
forall state i t w (schema :: Row *) e.
(AsSMContractError e, AsContractError e, FromData state,
 ToData state, FromData i) =>
StateMachineClient state i
-> Promise w schema e t
-> Contract
     w
     schema
     e
     (Promise w schema e (WaitingResult t i (OnChainState state i)))
SM.waitForUpdateTimeout StateMachineClient AuctionState AuctionInput
client (POSIXTime
-> Promise
     AuctionOutput
     ('R '[ "bid" ':-> (EndpointValue Ada, ActiveEndpoint)])
     AuctionError
     POSIXTime
forall w (s :: Row *) e.
AsContractError e =>
POSIXTime -> Promise w s e POSIXTime
isTime POSIXTime
apEndTime)

    let
        auctionOver :: Promise
  AuctionOutput
  ('R '[ "bid" ':-> (EndpointValue Ada, ActiveEndpoint)])
  AuctionError
  BuyerEvent
auctionOver = HighestBid -> BuyerEvent
AuctionIsOver HighestBid
lastHighestBid BuyerEvent
-> Promise
     AuctionOutput
     ('R '[ "bid" ':-> (EndpointValue Ada, ActiveEndpoint)])
     AuctionError
     POSIXTime
-> Promise
     AuctionOutput
     ('R '[ "bid" ':-> (EndpointValue Ada, ActiveEndpoint)])
     AuctionError
     BuyerEvent
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
Haskell.<$ POSIXTime
-> Promise
     AuctionOutput
     ('R '[ "bid" ':-> (EndpointValue Ada, ActiveEndpoint)])
     AuctionError
     POSIXTime
forall w (s :: Row *) e.
AsContractError e =>
POSIXTime -> Promise w s e POSIXTime
isTime POSIXTime
apEndTime
        submitOwnBid :: Promise
  w
  ('R '[ "bid" ':-> (EndpointValue Ada, ActiveEndpoint)])
  AuctionError
  BuyerEvent
submitOwnBid = forall a w (s :: Row *) e b.
(HasEndpoint "bid" a s, AsContractError e, FromJSON a) =>
(a -> Contract w s e b) -> Promise w s e b
forall (l :: Symbol) a w (s :: Row *) e b.
(HasEndpoint l a s, AsContractError e, FromJSON a) =>
(a -> Contract w s e b) -> Promise w s e b
endpoint @"bid" ((Ada
  -> Contract
       w
       ('R '[ "bid" ':-> (EndpointValue Ada, ActiveEndpoint)])
       AuctionError
       BuyerEvent)
 -> Promise
      w
      ('R '[ "bid" ':-> (EndpointValue Ada, ActiveEndpoint)])
      AuctionError
      BuyerEvent)
-> (Ada
    -> Contract
         w
         ('R '[ "bid" ':-> (EndpointValue Ada, ActiveEndpoint)])
         AuctionError
         BuyerEvent)
-> Promise
     w
     ('R '[ "bid" ':-> (EndpointValue Ada, ActiveEndpoint)])
     AuctionError
     BuyerEvent
forall a b. (a -> b) -> a -> b
$ BuyerEvent
-> Contract
     w
     ('R '[ "bid" ':-> (EndpointValue Ada, ActiveEndpoint)])
     AuctionError
     BuyerEvent
forall (f :: * -> *) a. Applicative f => a -> f a
pure (BuyerEvent
 -> Contract
      w
      ('R '[ "bid" ':-> (EndpointValue Ada, ActiveEndpoint)])
      AuctionError
      BuyerEvent)
-> (Ada -> BuyerEvent)
-> Ada
-> Contract
     w
     ('R '[ "bid" ':-> (EndpointValue Ada, ActiveEndpoint)])
     AuctionError
     BuyerEvent
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ada -> BuyerEvent
SubmitOwnBid
        otherBid :: Promise
  AuctionOutput
  ('R '[ "bid" ':-> (EndpointValue Ada, ActiveEndpoint)])
  AuctionError
  BuyerEvent
otherBid = do
            Promise
  AuctionOutput
  ('R '[ "bid" ':-> (EndpointValue Ada, ActiveEndpoint)])
  AuctionError
  (WaitingResult
     POSIXTime AuctionInput (OnChainState AuctionState AuctionInput))
-> (WaitingResult
      POSIXTime AuctionInput (OnChainState AuctionState AuctionInput)
    -> Contract
         AuctionOutput
         ('R '[ "bid" ':-> (EndpointValue Ada, ActiveEndpoint)])
         AuctionError
         BuyerEvent)
-> Promise
     AuctionOutput
     ('R '[ "bid" ':-> (EndpointValue Ada, ActiveEndpoint)])
     AuctionError
     BuyerEvent
forall w (s :: Row *) e a b.
Promise w s e a -> (a -> Contract w s e b) -> Promise w s e b
promiseBind
                Promise
  AuctionOutput
  ('R '[ "bid" ':-> (EndpointValue Ada, ActiveEndpoint)])
  AuctionError
  (WaitingResult
     POSIXTime AuctionInput (OnChainState AuctionState AuctionInput))
smUpdatePromise
                ((WaitingResult
    POSIXTime AuctionInput (OnChainState AuctionState AuctionInput)
  -> Contract
       AuctionOutput
       ('R '[ "bid" ':-> (EndpointValue Ada, ActiveEndpoint)])
       AuctionError
       BuyerEvent)
 -> Promise
      AuctionOutput
      ('R '[ "bid" ':-> (EndpointValue Ada, ActiveEndpoint)])
      AuctionError
      BuyerEvent)
-> (WaitingResult
      POSIXTime AuctionInput (OnChainState AuctionState AuctionInput)
    -> Contract
         AuctionOutput
         ('R '[ "bid" ':-> (EndpointValue Ada, ActiveEndpoint)])
         AuctionError
         BuyerEvent)
-> Promise
     AuctionOutput
     ('R '[ "bid" ':-> (EndpointValue Ada, ActiveEndpoint)])
     AuctionError
     BuyerEvent
forall a b. (a -> b) -> a -> b
$ \case
                  -- If the state machine instance ended, then the auction is over.
                  -- In this case match, 'currentState client' should always be
                  -- 'Nothing'.
                  ContractEnded {} -> BuyerEvent
-> (HighestBid -> BuyerEvent) -> Maybe HighestBid -> BuyerEvent
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (HighestBid -> BuyerEvent
AuctionIsOver HighestBid
lastHighestBid) HighestBid -> BuyerEvent
OtherBid (Maybe HighestBid -> BuyerEvent)
-> Contract
     AuctionOutput
     ('R '[ "bid" ':-> (EndpointValue Ada, ActiveEndpoint)])
     AuctionError
     (Maybe HighestBid)
-> Contract
     AuctionOutput
     ('R '[ "bid" ':-> (EndpointValue Ada, ActiveEndpoint)])
     AuctionError
     BuyerEvent
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateMachineClient AuctionState AuctionInput
-> Contract
     AuctionOutput BuyerSchema AuctionError (Maybe HighestBid)
currentState StateMachineClient AuctionState AuctionInput
client
                  -- The state machine transitionned to a new state
                  Transition {} -> do
                    Maybe HighestBid
highestBidMaybe <- StateMachineClient AuctionState AuctionInput
-> Contract
     AuctionOutput BuyerSchema AuctionError (Maybe HighestBid)
currentState StateMachineClient AuctionState AuctionInput
client
                    case Maybe HighestBid
highestBidMaybe of
                      -- If there is no current state, then the auction is over.
                      Maybe HighestBid
Nothing -> BuyerEvent
-> Contract
     AuctionOutput
     ('R '[ "bid" ':-> (EndpointValue Ada, ActiveEndpoint)])
     AuctionError
     BuyerEvent
forall (f :: * -> *) a. Applicative f => a -> f a
pure (BuyerEvent
 -> Contract
      AuctionOutput
      ('R '[ "bid" ':-> (EndpointValue Ada, ActiveEndpoint)])
      AuctionError
      BuyerEvent)
-> BuyerEvent
-> Contract
     AuctionOutput
     ('R '[ "bid" ':-> (EndpointValue Ada, ActiveEndpoint)])
     AuctionError
     BuyerEvent
forall a b. (a -> b) -> a -> b
$ HighestBid -> BuyerEvent
AuctionIsOver HighestBid
lastHighestBid
                      -- If the next state transition contains a new state,
                      -- there is either no change to the current bid, or there
                      -- is a new bid emitted by another wallet.
                      Just HighestBid
highestBid -> do
                        if HighestBid
highestBid HighestBid -> HighestBid -> Bool
forall a. Eq a => a -> a -> Bool
Haskell.== HighestBid
lastHighestBid
                           then BuyerEvent
-> Contract
     AuctionOutput
     ('R '[ "bid" ':-> (EndpointValue Ada, ActiveEndpoint)])
     AuctionError
     BuyerEvent
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HighestBid -> BuyerEvent
NoChange HighestBid
highestBid)
                           else BuyerEvent
-> Contract
     AuctionOutput
     ('R '[ "bid" ':-> (EndpointValue Ada, ActiveEndpoint)])
     AuctionError
     BuyerEvent
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HighestBid -> BuyerEvent
OtherBid HighestBid
highestBid)
                  WaitingResult
  POSIXTime AuctionInput (OnChainState AuctionState AuctionInput)
_ -> BuyerEvent
-> Contract
     AuctionOutput
     ('R '[ "bid" ':-> (EndpointValue Ada, ActiveEndpoint)])
     AuctionError
     BuyerEvent
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HighestBid -> BuyerEvent
NoChange HighestBid
lastHighestBid)

    -- see note [Buyer client]
    --
    -- Also note that the order of the promises in the list is important. When
    -- the auction is over, both 'auctionOver' and 'otherBid' contracts can be
    -- fully executed. However, if 'otherBid' is at the beginning of the list,
    -- it will return "NoChange" event before returning "AuctionIsOver". Thus
    -- the auction never ends and it results in an infinite loop.
    [Promise
   AuctionOutput
   ('R '[ "bid" ':-> (EndpointValue Ada, ActiveEndpoint)])
   AuctionError
   BuyerEvent]
-> Contract
     AuctionOutput
     ('R '[ "bid" ':-> (EndpointValue Ada, ActiveEndpoint)])
     AuctionError
     BuyerEvent
forall w (s :: Row *) e a. [Promise w s e a] -> Contract w s e a
selectList [Promise
  AuctionOutput
  ('R '[ "bid" ':-> (EndpointValue Ada, ActiveEndpoint)])
  AuctionError
  BuyerEvent
auctionOver, Promise
  AuctionOutput
  ('R '[ "bid" ':-> (EndpointValue Ada, ActiveEndpoint)])
  AuctionError
  BuyerEvent
forall w.
Promise
  w
  ('R '[ "bid" ':-> (EndpointValue Ada, ActiveEndpoint)])
  AuctionError
  BuyerEvent
submitOwnBid, Promise
  AuctionOutput
  ('R '[ "bid" ':-> (EndpointValue Ada, ActiveEndpoint)])
  AuctionError
  BuyerEvent
otherBid]

handleEvent
    :: StateMachineClient AuctionState AuctionInput
    -> HighestBid
    -> BuyerEvent
    -> Contract AuctionOutput BuyerSchema AuctionError (Either HighestBid ())
handleEvent :: StateMachineClient AuctionState AuctionInput
-> HighestBid
-> BuyerEvent
-> Contract
     AuctionOutput BuyerSchema AuctionError (Either HighestBid ())
handleEvent StateMachineClient AuctionState AuctionInput
client HighestBid
lastHighestBid BuyerEvent
change =
    let continue :: a
-> Contract
     AuctionOutput
     ('R '[ "bid" ':-> (EndpointValue Ada, ActiveEndpoint)])
     AuctionError
     (Either a b)
continue = Either a b
-> Contract
     AuctionOutput
     ('R '[ "bid" ':-> (EndpointValue Ada, ActiveEndpoint)])
     AuctionError
     (Either a b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either a b
 -> Contract
      AuctionOutput
      ('R '[ "bid" ':-> (EndpointValue Ada, ActiveEndpoint)])
      AuctionError
      (Either a b))
-> (a -> Either a b)
-> a
-> Contract
     AuctionOutput
     ('R '[ "bid" ':-> (EndpointValue Ada, ActiveEndpoint)])
     AuctionError
     (Either a b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Either a b
forall a b. a -> Either a b
Left
        stop :: Contract
  AuctionOutput
  ('R '[ "bid" ':-> (EndpointValue Ada, ActiveEndpoint)])
  AuctionError
  (Either a ())
stop     = Either a ()
-> Contract
     AuctionOutput
     ('R '[ "bid" ':-> (EndpointValue Ada, ActiveEndpoint)])
     AuctionError
     (Either a ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (() -> Either a ()
forall a b. b -> Either a b
Right ())
    -- see note [Buyer client]
    in case BuyerEvent
change of
        AuctionIsOver HighestBid
s -> AuctionOutput
-> Contract
     AuctionOutput
     ('R '[ "bid" ':-> (EndpointValue Ada, ActiveEndpoint)])
     AuctionError
     ()
forall w (s :: Row *) e. w -> Contract w s e ()
tell (AuctionState -> AuctionOutput
auctionStateOut (AuctionState -> AuctionOutput) -> AuctionState -> AuctionOutput
forall a b. (a -> b) -> a -> b
$ HighestBid -> AuctionState
Finished HighestBid
s) Contract
  AuctionOutput
  ('R '[ "bid" ':-> (EndpointValue Ada, ActiveEndpoint)])
  AuctionError
  ()
-> Contract
     AuctionOutput
     ('R '[ "bid" ':-> (EndpointValue Ada, ActiveEndpoint)])
     AuctionError
     (Either HighestBid ())
-> Contract
     AuctionOutput
     ('R '[ "bid" ':-> (EndpointValue Ada, ActiveEndpoint)])
     AuctionError
     (Either HighestBid ())
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Contract
  AuctionOutput
  ('R '[ "bid" ':-> (EndpointValue Ada, ActiveEndpoint)])
  AuctionError
  (Either HighestBid ())
forall a.
Contract
  AuctionOutput
  ('R '[ "bid" ':-> (EndpointValue Ada, ActiveEndpoint)])
  AuctionError
  (Either a ())
stop
        SubmitOwnBid Ada
ada -> do
            String
-> Contract
     AuctionOutput
     ('R '[ "bid" ':-> (EndpointValue Ada, ActiveEndpoint)])
     AuctionError
     ()
forall a w (s :: Row *) e. ToJSON a => a -> Contract w s e ()
logInfo @Haskell.String String
"Submitting bid"
            Address
self <- AddressInEra BabbageEra -> Address
forall era. AddressInEra era -> Address
toPlutusAddress (AddressInEra BabbageEra -> Address)
-> Contract
     AuctionOutput
     ('R '[ "bid" ':-> (EndpointValue Ada, ActiveEndpoint)])
     AuctionError
     (AddressInEra BabbageEra)
-> Contract
     AuctionOutput
     ('R '[ "bid" ':-> (EndpointValue Ada, ActiveEndpoint)])
     AuctionError
     Address
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Contract
  AuctionOutput
  ('R '[ "bid" ':-> (EndpointValue Ada, ActiveEndpoint)])
  AuctionError
  (AddressInEra BabbageEra)
forall w (s :: Row *) e.
AsContractError e =>
Contract w s e (AddressInEra BabbageEra)
ownAddress
            String
-> Contract
     AuctionOutput
     ('R '[ "bid" ':-> (EndpointValue Ada, ActiveEndpoint)])
     AuctionError
     ()
forall a w (s :: Row *) e. ToJSON a => a -> Contract w s e ()
logInfo @Haskell.String String
"Received address"
            TransitionResult AuctionState AuctionInput
r <- StateMachineClient AuctionState AuctionInput
-> AuctionInput
-> Contract
     AuctionOutput
     ('R '[ "bid" ':-> (EndpointValue Ada, ActiveEndpoint)])
     AuctionError
     (TransitionResult AuctionState AuctionInput)
forall w e state (schema :: Row *) input.
(AsSMContractError e, FromData state, ToData state,
 ToData input) =>
StateMachineClient state input
-> input -> Contract w schema e (TransitionResult state input)
SM.runStep StateMachineClient AuctionState AuctionInput
client Bid :: Ada -> Address -> AuctionInput
Bid{newBid :: Ada
newBid = Ada
ada, newBidder :: Address
newBidder = Address
self}
            String
-> Contract
     AuctionOutput
     ('R '[ "bid" ':-> (EndpointValue Ada, ActiveEndpoint)])
     AuctionError
     ()
forall a w (s :: Row *) e. ToJSON a => a -> Contract w s e ()
logInfo @Haskell.String String
"SM: runStep done"
            case TransitionResult AuctionState AuctionInput
r of
                SM.TransitionFailure InvalidTransition AuctionState AuctionInput
i -> AuctionLog
-> Contract
     AuctionOutput
     ('R '[ "bid" ':-> (EndpointValue Ada, ActiveEndpoint)])
     AuctionError
     ()
forall a w (s :: Row *) e. ToJSON a => a -> Contract w s e ()
logError (InvalidTransition AuctionState AuctionInput -> AuctionLog
TransitionFailed InvalidTransition AuctionState AuctionInput
i) Contract
  AuctionOutput
  ('R '[ "bid" ':-> (EndpointValue Ada, ActiveEndpoint)])
  AuctionError
  ()
-> Contract
     AuctionOutput
     ('R '[ "bid" ':-> (EndpointValue Ada, ActiveEndpoint)])
     AuctionError
     (Either HighestBid ())
-> Contract
     AuctionOutput
     ('R '[ "bid" ':-> (EndpointValue Ada, ActiveEndpoint)])
     AuctionError
     (Either HighestBid ())
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> HighestBid
-> Contract
     AuctionOutput
     ('R '[ "bid" ':-> (EndpointValue Ada, ActiveEndpoint)])
     AuctionError
     (Either HighestBid ())
forall a b.
a
-> Contract
     AuctionOutput
     ('R '[ "bid" ':-> (EndpointValue Ada, ActiveEndpoint)])
     AuctionError
     (Either a b)
continue HighestBid
lastHighestBid
                SM.TransitionSuccess (Ongoing HighestBid
newHighestBid) -> AuctionLog
-> Contract
     AuctionOutput
     ('R '[ "bid" ':-> (EndpointValue Ada, ActiveEndpoint)])
     AuctionError
     ()
forall a w (s :: Row *) e. ToJSON a => a -> Contract w s e ()
logInfo (HighestBid -> AuctionLog
BidSubmitted HighestBid
newHighestBid) Contract
  AuctionOutput
  ('R '[ "bid" ':-> (EndpointValue Ada, ActiveEndpoint)])
  AuctionError
  ()
-> Contract
     AuctionOutput
     ('R '[ "bid" ':-> (EndpointValue Ada, ActiveEndpoint)])
     AuctionError
     (Either HighestBid ())
-> Contract
     AuctionOutput
     ('R '[ "bid" ':-> (EndpointValue Ada, ActiveEndpoint)])
     AuctionError
     (Either HighestBid ())
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> HighestBid
-> Contract
     AuctionOutput
     ('R '[ "bid" ':-> (EndpointValue Ada, ActiveEndpoint)])
     AuctionError
     (Either HighestBid ())
forall a b.
a
-> Contract
     AuctionOutput
     ('R '[ "bid" ':-> (EndpointValue Ada, ActiveEndpoint)])
     AuctionError
     (Either a b)
continue HighestBid
newHighestBid

                -- the last case shouldn't happen because the "Bid" transition always results in the "Ongoing"
                -- but you never know :-)
                SM.TransitionSuccess (Finished HighestBid
newHighestBid) -> AuctionLog
-> Contract
     AuctionOutput
     ('R '[ "bid" ':-> (EndpointValue Ada, ActiveEndpoint)])
     AuctionError
     ()
forall a w (s :: Row *) e. ToJSON a => a -> Contract w s e ()
logError (HighestBid -> AuctionLog
AuctionEnded HighestBid
newHighestBid) Contract
  AuctionOutput
  ('R '[ "bid" ':-> (EndpointValue Ada, ActiveEndpoint)])
  AuctionError
  ()
-> Contract
     AuctionOutput
     ('R '[ "bid" ':-> (EndpointValue Ada, ActiveEndpoint)])
     AuctionError
     (Either HighestBid ())
-> Contract
     AuctionOutput
     ('R '[ "bid" ':-> (EndpointValue Ada, ActiveEndpoint)])
     AuctionError
     (Either HighestBid ())
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Contract
  AuctionOutput
  ('R '[ "bid" ':-> (EndpointValue Ada, ActiveEndpoint)])
  AuctionError
  (Either HighestBid ())
forall a.
Contract
  AuctionOutput
  ('R '[ "bid" ':-> (EndpointValue Ada, ActiveEndpoint)])
  AuctionError
  (Either a ())
stop
        OtherBid HighestBid
s -> do
            AuctionOutput
-> Contract
     AuctionOutput
     ('R '[ "bid" ':-> (EndpointValue Ada, ActiveEndpoint)])
     AuctionError
     ()
forall w (s :: Row *) e. w -> Contract w s e ()
tell (AuctionState -> AuctionOutput
auctionStateOut (AuctionState -> AuctionOutput) -> AuctionState -> AuctionOutput
forall a b. (a -> b) -> a -> b
$ HighestBid -> AuctionState
Ongoing HighestBid
s)
            HighestBid
-> Contract
     AuctionOutput
     ('R '[ "bid" ':-> (EndpointValue Ada, ActiveEndpoint)])
     AuctionError
     (Either HighestBid ())
forall a b.
a
-> Contract
     AuctionOutput
     ('R '[ "bid" ':-> (EndpointValue Ada, ActiveEndpoint)])
     AuctionError
     (Either a b)
continue HighestBid
s
        NoChange HighestBid
s -> HighestBid
-> Contract
     AuctionOutput
     ('R '[ "bid" ':-> (EndpointValue Ada, ActiveEndpoint)])
     AuctionError
     (Either HighestBid ())
forall a b.
a
-> Contract
     AuctionOutput
     ('R '[ "bid" ':-> (EndpointValue Ada, ActiveEndpoint)])
     AuctionError
     (Either a b)
continue HighestBid
s

auctionBuyer :: ThreadToken -> AuctionParams -> Contract AuctionOutput BuyerSchema AuctionError ()
auctionBuyer :: ThreadToken
-> AuctionParams
-> Contract AuctionOutput BuyerSchema AuctionError ()
auctionBuyer ThreadToken
currency AuctionParams
params = do
    let inst :: TypedValidator AuctionMachine
inst   = (ThreadToken, AuctionParams) -> TypedValidator AuctionMachine
typedValidator (ThreadToken
currency, AuctionParams
params)
        client :: StateMachineClient AuctionState AuctionInput
client = TypedValidator AuctionMachine
-> ThreadToken
-> AuctionParams
-> StateMachineClient AuctionState AuctionInput
machineClient TypedValidator AuctionMachine
inst ThreadToken
currency AuctionParams
params

        -- the actual loop, see note [Buyer client]
        loop :: HighestBid
-> Contract
     AuctionOutput
     ('R '[ "bid" ':-> (EndpointValue Ada, ActiveEndpoint)])
     AuctionError
     ()
loop   = (HighestBid
 -> Contract
      AuctionOutput
      ('R '[ "bid" ':-> (EndpointValue Ada, ActiveEndpoint)])
      AuctionError
      (Either HighestBid ()))
-> HighestBid
-> Contract
     AuctionOutput
     ('R '[ "bid" ':-> (EndpointValue Ada, ActiveEndpoint)])
     AuctionError
     ()
forall (m :: * -> *) a b.
Monad m =>
(a -> m (Either a b)) -> a -> m b
loopM (\HighestBid
h -> AuctionParams
-> StateMachineClient AuctionState AuctionInput
-> HighestBid
-> Contract AuctionOutput BuyerSchema AuctionError BuyerEvent
waitForChange AuctionParams
params StateMachineClient AuctionState AuctionInput
client HighestBid
h Contract
  AuctionOutput
  ('R '[ "bid" ':-> (EndpointValue Ada, ActiveEndpoint)])
  AuctionError
  BuyerEvent
-> (BuyerEvent
    -> Contract
         AuctionOutput
         ('R '[ "bid" ':-> (EndpointValue Ada, ActiveEndpoint)])
         AuctionError
         (Either HighestBid ()))
-> Contract
     AuctionOutput
     ('R '[ "bid" ':-> (EndpointValue Ada, ActiveEndpoint)])
     AuctionError
     (Either HighestBid ())
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= StateMachineClient AuctionState AuctionInput
-> HighestBid
-> BuyerEvent
-> Contract
     AuctionOutput BuyerSchema AuctionError (Either HighestBid ())
handleEvent StateMachineClient AuctionState AuctionInput
client HighestBid
h)

    AuctionOutput
-> Contract
     AuctionOutput
     ('R '[ "bid" ':-> (EndpointValue Ada, ActiveEndpoint)])
     AuctionError
     ()
forall w (s :: Row *) e. w -> Contract w s e ()
tell (AuctionOutput
 -> Contract
      AuctionOutput
      ('R '[ "bid" ':-> (EndpointValue Ada, ActiveEndpoint)])
      AuctionError
      ())
-> AuctionOutput
-> Contract
     AuctionOutput
     ('R '[ "bid" ':-> (EndpointValue Ada, ActiveEndpoint)])
     AuctionError
     ()
forall a b. (a -> b) -> a -> b
$ ThreadToken -> AuctionOutput
threadTokenOut ThreadToken
currency
    Maybe HighestBid
initial <- StateMachineClient AuctionState AuctionInput
-> Contract
     AuctionOutput BuyerSchema AuctionError (Maybe HighestBid)
currentState StateMachineClient AuctionState AuctionInput
client
    case Maybe HighestBid
initial of
        Just HighestBid
s -> HighestBid
-> Contract
     AuctionOutput
     ('R '[ "bid" ':-> (EndpointValue Ada, ActiveEndpoint)])
     AuctionError
     ()
loop HighestBid
s

        -- If the state can't be found we wait for it to appear.
        Maybe HighestBid
Nothing -> StateMachineClient AuctionState AuctionInput
-> POSIXTime
-> Contract
     AuctionOutput
     ('R '[ "bid" ':-> (EndpointValue Ada, ActiveEndpoint)])
     AuctionError
     (WaitingResult POSIXTime AuctionInput AuctionState)
forall e state i w (schema :: Row *).
(AsSMContractError e, AsContractError e, FromData state,
 ToData state, FromData i) =>
StateMachineClient state i
-> POSIXTime
-> Contract w schema e (WaitingResult POSIXTime i state)
SM.waitForUpdateUntilTime StateMachineClient AuctionState AuctionInput
client (AuctionParams -> POSIXTime
apEndTime AuctionParams
params) Contract
  AuctionOutput
  ('R '[ "bid" ':-> (EndpointValue Ada, ActiveEndpoint)])
  AuctionError
  (WaitingResult POSIXTime AuctionInput AuctionState)
-> (WaitingResult POSIXTime AuctionInput AuctionState
    -> Contract
         AuctionOutput
         ('R '[ "bid" ':-> (EndpointValue Ada, ActiveEndpoint)])
         AuctionError
         ())
-> Contract
     AuctionOutput
     ('R '[ "bid" ':-> (EndpointValue Ada, ActiveEndpoint)])
     AuctionError
     ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Transition AuctionInput
_ (Ongoing HighestBid
s) -> HighestBid
-> Contract
     AuctionOutput
     ('R '[ "bid" ':-> (EndpointValue Ada, ActiveEndpoint)])
     AuctionError
     ()
loop HighestBid
s
            InitialState (Ongoing HighestBid
s) -> HighestBid
-> Contract
     AuctionOutput
     ('R '[ "bid" ':-> (EndpointValue Ada, ActiveEndpoint)])
     AuctionError
     ()
loop HighestBid
s
            WaitingResult POSIXTime AuctionInput AuctionState
_                        -> AuctionLog
-> Contract
     AuctionOutput
     ('R '[ "bid" ':-> (EndpointValue Ada, ActiveEndpoint)])
     AuctionError
     ()
forall a w (s :: Row *) e. ToJSON a => a -> Contract w s e ()
logWarn AuctionLog
CurrentStateNotFound

covIdx :: CoverageIndex
covIdx :: CoverageIndex
covIdx = CompiledCode
  ((ThreadToken, AuctionParams)
   -> AuctionState -> AuctionInput -> ScriptContext -> Bool)
-> CoverageIndex
forall (uni :: * -> *) fun a.
CompiledCodeIn uni fun a -> CoverageIndex
getCovIdx $$(PlutusTx.compile [|| mkValidator ||])