{-# LANGUAGE DataKinds          #-}
{-# LANGUAGE DeriveAnyClass     #-}
{-# LANGUAGE DeriveGeneric      #-}
{-# LANGUAGE DerivingVia        #-}
{-# LANGUAGE FlexibleContexts   #-}
{-# LANGUAGE GADTs              #-}
{-# LANGUAGE LambdaCase         #-}
{-# LANGUAGE NamedFieldPuns     #-}
{-# LANGUAGE NoImplicitPrelude  #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedStrings  #-}
{-# LANGUAGE RecordWildCards    #-}
{-# LANGUAGE TemplateHaskell    #-}
{-# LANGUAGE TypeApplications   #-}
{-# LANGUAGE TypeOperators      #-}
module Plutus.Contracts.SealedBidAuction(
  AuctionParams(..)
  , BidArgs(..)
  , RevealArgs(..)
  , AuctionError(..)
  , BidderSchema
  , SellerSchema
  , startAuction
  , bid
  , reveal
  , payout
  , packInteger
  , sellerContract
  , bidderContract
  ) where

import Control.Lens (makeClassyPrisms)
import Control.Monad (void)
import Data.Aeson (FromJSON, ToJSON)
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.Secrets
import Plutus.Contract.StateMachine (State (..), StateMachine (..), StateMachineClient, Void)
import Plutus.Contract.StateMachine qualified as SM
import Plutus.Script.Utils.Ada qualified as Ada
import Plutus.Script.Utils.V2.Typed.Scripts qualified as V2
import Plutus.Script.Utils.Value (Value)
import Plutus.Script.Utils.Value qualified as Value
import PlutusTx qualified
import PlutusTx.Prelude
import Prelude qualified as Haskell

{- Note [Sealed bid auction disclaimer]
   This file implements a sealed bid auction using `SecretArgument`s. In the bidding
   phase of the contract sealed bids appear hashed on the blockchain and hashed
   bids are "claimed" by the participants in the second phase of the auction.

   Because bids are integer lovelace values there is the faint possibility of a
   brute-force attack or lookup table attack on the bids in the bidding phase. An
   implementation intended to be deployed in the real world may consider adding a
   salt to the secret bids or using some other more sophisticated mechanism to
   avoid this attack. In other words, please don't blindly deploy this code
   without understanding the possible attack scenarios.
 -}

newtype BidArgs = BidArgs { BidArgs -> SecretArgument Integer
secretBid :: SecretArgument Integer }
          deriving stock (Int -> BidArgs -> ShowS
[BidArgs] -> ShowS
BidArgs -> String
(Int -> BidArgs -> ShowS)
-> (BidArgs -> String) -> ([BidArgs] -> ShowS) -> Show BidArgs
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [BidArgs] -> ShowS
$cshowList :: [BidArgs] -> ShowS
show :: BidArgs -> String
$cshow :: BidArgs -> String
showsPrec :: Int -> BidArgs -> ShowS
$cshowsPrec :: Int -> BidArgs -> ShowS
Haskell.Show, (forall x. BidArgs -> Rep BidArgs x)
-> (forall x. Rep BidArgs x -> BidArgs) -> Generic BidArgs
forall x. Rep BidArgs x -> BidArgs
forall x. BidArgs -> Rep BidArgs x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep BidArgs x -> BidArgs
$cfrom :: forall x. BidArgs -> Rep BidArgs x
Generic)
          deriving anyclass ([BidArgs] -> Encoding
[BidArgs] -> Value
BidArgs -> Encoding
BidArgs -> Value
(BidArgs -> Value)
-> (BidArgs -> Encoding)
-> ([BidArgs] -> Value)
-> ([BidArgs] -> Encoding)
-> ToJSON BidArgs
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [BidArgs] -> Encoding
$ctoEncodingList :: [BidArgs] -> Encoding
toJSONList :: [BidArgs] -> Value
$ctoJSONList :: [BidArgs] -> Value
toEncoding :: BidArgs -> Encoding
$ctoEncoding :: BidArgs -> Encoding
toJSON :: BidArgs -> Value
$ctoJSON :: BidArgs -> Value
ToJSON, Value -> Parser [BidArgs]
Value -> Parser BidArgs
(Value -> Parser BidArgs)
-> (Value -> Parser [BidArgs]) -> FromJSON BidArgs
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [BidArgs]
$cparseJSONList :: Value -> Parser [BidArgs]
parseJSON :: Value -> Parser BidArgs
$cparseJSON :: Value -> Parser BidArgs
FromJSON)

newtype RevealArgs = RevealArgs { RevealArgs -> Integer
publicBid :: Integer }
          deriving stock (Int -> RevealArgs -> ShowS
[RevealArgs] -> ShowS
RevealArgs -> String
(Int -> RevealArgs -> ShowS)
-> (RevealArgs -> String)
-> ([RevealArgs] -> ShowS)
-> Show RevealArgs
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RevealArgs] -> ShowS
$cshowList :: [RevealArgs] -> ShowS
show :: RevealArgs -> String
$cshow :: RevealArgs -> String
showsPrec :: Int -> RevealArgs -> ShowS
$cshowsPrec :: Int -> RevealArgs -> ShowS
Haskell.Show, (forall x. RevealArgs -> Rep RevealArgs x)
-> (forall x. Rep RevealArgs x -> RevealArgs) -> Generic RevealArgs
forall x. Rep RevealArgs x -> RevealArgs
forall x. RevealArgs -> Rep RevealArgs x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep RevealArgs x -> RevealArgs
$cfrom :: forall x. RevealArgs -> Rep RevealArgs x
Generic)
          deriving anyclass ([RevealArgs] -> Encoding
[RevealArgs] -> Value
RevealArgs -> Encoding
RevealArgs -> Value
(RevealArgs -> Value)
-> (RevealArgs -> Encoding)
-> ([RevealArgs] -> Value)
-> ([RevealArgs] -> Encoding)
-> ToJSON RevealArgs
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [RevealArgs] -> Encoding
$ctoEncodingList :: [RevealArgs] -> Encoding
toJSONList :: [RevealArgs] -> Value
$ctoJSONList :: [RevealArgs] -> Value
toEncoding :: RevealArgs -> Encoding
$ctoEncoding :: RevealArgs -> Encoding
toJSON :: RevealArgs -> Value
$ctoJSON :: RevealArgs -> Value
ToJSON, Value -> Parser [RevealArgs]
Value -> Parser RevealArgs
(Value -> Parser RevealArgs)
-> (Value -> Parser [RevealArgs]) -> FromJSON RevealArgs
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [RevealArgs]
$cparseJSONList :: Value -> Parser [RevealArgs]
parseJSON :: Value -> Parser RevealArgs
$cparseJSON :: Value -> Parser RevealArgs
FromJSON)

type BidderSchema = Endpoint "bid" BidArgs
                    .\/ Endpoint "reveal" RevealArgs
                    .\/ Endpoint "payout" ()
type SellerSchema = Endpoint "payout" ()

-- | 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 -- ^ 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.
        , AuctionParams -> POSIXTime
apPayoutTime :: POSIXTime -- ^ When the time window for revealing your bid 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 SealedBid =
    SealedBid
        { SealedBid -> BuiltinByteString
sealedBid       :: BuiltinByteString
        , SealedBid -> Address
sealedBidBidder :: Address
        }
    deriving stock (SealedBid -> SealedBid -> Bool
(SealedBid -> SealedBid -> Bool)
-> (SealedBid -> SealedBid -> Bool) -> Eq SealedBid
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SealedBid -> SealedBid -> Bool
$c/= :: SealedBid -> SealedBid -> Bool
== :: SealedBid -> SealedBid -> Bool
$c== :: SealedBid -> SealedBid -> Bool
Haskell.Eq, Int -> SealedBid -> ShowS
[SealedBid] -> ShowS
SealedBid -> String
(Int -> SealedBid -> ShowS)
-> (SealedBid -> String)
-> ([SealedBid] -> ShowS)
-> Show SealedBid
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SealedBid] -> ShowS
$cshowList :: [SealedBid] -> ShowS
show :: SealedBid -> String
$cshow :: SealedBid -> String
showsPrec :: Int -> SealedBid -> ShowS
$cshowsPrec :: Int -> SealedBid -> ShowS
Haskell.Show, (forall x. SealedBid -> Rep SealedBid x)
-> (forall x. Rep SealedBid x -> SealedBid) -> Generic SealedBid
forall x. Rep SealedBid x -> SealedBid
forall x. SealedBid -> Rep SealedBid x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep SealedBid x -> SealedBid
$cfrom :: forall x. SealedBid -> Rep SealedBid x
Generic)
    deriving anyclass ([SealedBid] -> Encoding
[SealedBid] -> Value
SealedBid -> Encoding
SealedBid -> Value
(SealedBid -> Value)
-> (SealedBid -> Encoding)
-> ([SealedBid] -> Value)
-> ([SealedBid] -> Encoding)
-> ToJSON SealedBid
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [SealedBid] -> Encoding
$ctoEncodingList :: [SealedBid] -> Encoding
toJSONList :: [SealedBid] -> Value
$ctoJSONList :: [SealedBid] -> Value
toEncoding :: SealedBid -> Encoding
$ctoEncoding :: SealedBid -> Encoding
toJSON :: SealedBid -> Value
$ctoJSON :: SealedBid -> Value
ToJSON, Value -> Parser [SealedBid]
Value -> Parser SealedBid
(Value -> Parser SealedBid)
-> (Value -> Parser [SealedBid]) -> FromJSON SealedBid
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [SealedBid]
$cparseJSONList :: Value -> Parser [SealedBid]
parseJSON :: Value -> Parser SealedBid
$cparseJSON :: Value -> Parser SealedBid
FromJSON)

PlutusTx.unstableMakeIsData ''SealedBid

instance Eq SealedBid where
  (SealedBid BuiltinByteString
bid Address
bidder) == :: SealedBid -> SealedBid -> Bool
== (SealedBid BuiltinByteString
bid' Address
bidder') = BuiltinByteString
bid BuiltinByteString -> BuiltinByteString -> Bool
forall a. Eq a => a -> a -> Bool
== BuiltinByteString
bid' Bool -> Bool -> Bool
&& Address
bidder Address -> Address -> Bool
forall a. Eq a => a -> a -> Bool
== Address
bidder'

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

PlutusTx.unstableMakeIsData ''RevealedBid

-- | The states of the auction
data AuctionState
    = Ongoing [SealedBid] -- Bids can be submitted.
    | AwaitingPayout RevealedBid [SealedBid] -- The bidding is finished and we are awaiting payout
    | 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)

PlutusTx.unstableMakeIsData ''AuctionState

-- | Initial 'AuctionState'. In the beginning there are no bids.
initialState :: AuctionState
initialState :: AuctionState
initialState = [SealedBid] -> AuctionState
Ongoing []

-- | Transition between auction states
data AuctionInput
    = PlaceBid SealedBid -- Register a sealed bid
    | RevealBid RevealedBid -- Reveal a bid
    | 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 packInteger #-}
-- | Pack an integer into a byte string with a leading
-- sign byte in little-endian order
packInteger :: Integer -> BuiltinByteString
packInteger :: Integer -> BuiltinByteString
packInteger Integer
k = if Integer
k Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
0 then Integer -> BuiltinByteString -> BuiltinByteString
consByteString Integer
1 (Integer -> BuiltinByteString -> BuiltinByteString
go (Integer -> Integer
forall a. AdditiveGroup a => a -> a
negate Integer
k) BuiltinByteString
emptyByteString) else Integer -> BuiltinByteString -> BuiltinByteString
consByteString Integer
0 (Integer -> BuiltinByteString -> BuiltinByteString
go Integer
k BuiltinByteString
emptyByteString)
  where
    go :: Integer -> BuiltinByteString -> BuiltinByteString
go Integer
n BuiltinByteString
s
      | Integer
n Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
0            = BuiltinByteString
s
      | Bool
otherwise         = Integer -> BuiltinByteString -> BuiltinByteString
go (Integer
n Integer -> Integer -> Integer
`divide` Integer
256) (Integer -> BuiltinByteString -> BuiltinByteString
consByteString (Integer
n Integer -> Integer -> Integer
`modulo` Integer
256) BuiltinByteString
s)

{-# INLINABLE hashInteger #-}
hashInteger :: Integer -> BuiltinByteString
hashInteger :: Integer -> BuiltinByteString
hashInteger = BuiltinByteString -> BuiltinByteString
sha2_256 (BuiltinByteString -> BuiltinByteString)
-> (Integer -> BuiltinByteString) -> Integer -> BuiltinByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> BuiltinByteString
packInteger

{-# INLINABLE hashSecretInteger #-}
hashSecretInteger :: Secret Integer -> BuiltinByteString
hashSecretInteger :: Secret Integer -> BuiltinByteString
hashSecretInteger = Secret BuiltinByteString -> BuiltinByteString
escape_sha2_256 (Secret BuiltinByteString -> BuiltinByteString)
-> (Secret Integer -> Secret BuiltinByteString)
-> Secret Integer
-> BuiltinByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Integer -> BuiltinByteString)
-> Secret Integer -> Secret BuiltinByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Integer -> BuiltinByteString
packInteger

{-# INLINABLE sealBid #-}
sealBid :: RevealedBid -> SealedBid
sealBid :: RevealedBid -> SealedBid
sealBid RevealedBid{Integer
revealedBid :: Integer
revealedBid :: RevealedBid -> Integer
revealedBid, Address
revealedBidBidder :: Address
revealedBidBidder :: RevealedBid -> Address
revealedBidBidder} = BuiltinByteString -> Address -> SealedBid
SealedBid (Integer -> BuiltinByteString
hashInteger Integer
revealedBid) Address
revealedBidBidder

{-# INLINABLE valueOfBid #-}
valueOfBid :: RevealedBid -> Value
valueOfBid :: RevealedBid -> Value
valueOfBid = Integer -> Value
Ada.lovelaceValueOf (Integer -> Value)
-> (RevealedBid -> Integer) -> RevealedBid -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RevealedBid -> Integer
revealedBid

{-# 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, POSIXTime
apPayoutTime :: POSIXTime
apPayoutTime :: AuctionParams -> POSIXTime
apPayoutTime} 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
    -- A new bid is placed, a bidder is only allowed to bid once
    (Ongoing [SealedBid]
bids, PlaceBid SealedBid
bid)
      | SealedBid -> Address
sealedBidBidder SealedBid
bid Address -> [Address] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` (SealedBid -> Address) -> [SealedBid] -> [Address]
forall a b. (a -> b) -> [a] -> [b]
map SealedBid -> Address
sealedBidBidder [SealedBid]
bids ->
        let validityTimeRange :: ValidityInterval POSIXTime
validityTimeRange = POSIXTime -> ValidityInterval POSIXTime
forall a. a -> ValidityInterval a
Interval.lessThan (POSIXTime -> ValidityInterval POSIXTime)
-> POSIXTime -> ValidityInterval POSIXTime
forall a b. (a -> b) -> a -> b
$ POSIXTime
apEndTime POSIXTime -> POSIXTime -> POSIXTime
forall a. AdditiveGroup a => a -> a -> a
- POSIXTime
1
            constraints :: TxConstraints Void Void
constraints = ValidityInterval POSIXTime -> TxConstraints Void Void
forall i o. ValidityInterval POSIXTime -> TxConstraints i o
Constraints.mustValidateInTimeRange ValidityInterval POSIXTime
validityTimeRange
            newState :: State AuctionState
newState =
              State :: forall s. s -> Value -> State s
State
                  { stateData :: AuctionState
stateData  = [SealedBid] -> AuctionState
Ongoing (SealedBid
bidSealedBid -> [SealedBid] -> [SealedBid]
forall a. a -> [a] -> [a]
:[SealedBid]
bids)
                  , stateValue :: Value
stateValue = Value
oldStateValue
                  }
        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)

    -- The first bid is revealed
    (Ongoing [SealedBid]
bids, RevealBid RevealedBid
bid)
      | RevealedBid -> SealedBid
sealBid RevealedBid
bid SealedBid -> [SealedBid] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [SealedBid]
bids ->
        let validityTimeRange :: ValidityInterval POSIXTime
validityTimeRange = POSIXTime -> POSIXTime -> ValidityInterval POSIXTime
forall a. a -> a -> ValidityInterval a
Interval.interval POSIXTime
apEndTime POSIXTime
apPayoutTime
            constraints :: TxConstraints Void Void
constraints = ValidityInterval POSIXTime -> TxConstraints Void Void
forall i o. ValidityInterval POSIXTime -> TxConstraints i o
Constraints.mustValidateInTimeRange ValidityInterval POSIXTime
validityTimeRange
            newState :: State AuctionState
newState =
              State :: forall s. s -> Value -> State s
State
                  { stateData :: AuctionState
stateData  = RevealedBid -> [SealedBid] -> AuctionState
AwaitingPayout RevealedBid
bid ((SealedBid -> Bool) -> [SealedBid] -> [SealedBid]
forall a. (a -> Bool) -> [a] -> [a]
filter (SealedBid -> SealedBid -> Bool
forall a. Eq a => a -> a -> Bool
/= RevealedBid -> SealedBid
sealBid RevealedBid
bid) [SealedBid]
bids)
                  , stateValue :: Value
stateValue = Value
oldStateValue Value -> Value -> Value
forall a. Semigroup a => a -> a -> a
<> RevealedBid -> Value
valueOfBid RevealedBid
bid
                  }
        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)

    -- Nobody has revealed their bid and the deadline has arrived
    (Ongoing [SealedBid]
_, 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
apPayoutTime)
                      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 Value
apAsset
          newState :: State AuctionState
newState =
            State :: forall s. s -> Value -> State s
State
                { stateData :: AuctionState
stateData  = AuctionState
Finished
                , 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)

    -- We are waiting for the payout deadine and a bid is revealed that is higher
    -- than the current maximum bid
    (AwaitingPayout RevealedBid
highestBid [SealedBid]
sealedBids, RevealBid RevealedBid
bid)
      | RevealedBid -> Integer
revealedBid RevealedBid
bid Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> RevealedBid -> Integer
revealedBid RevealedBid
highestBid
        Bool -> Bool -> Bool
&& RevealedBid -> SealedBid
sealBid RevealedBid
bid SealedBid -> [SealedBid] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [SealedBid]
sealedBids ->
        let validityTimeRange :: ValidityInterval POSIXTime
validityTimeRange = 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
apPayoutTime
            constraints :: TxConstraints Void Void
constraints = ValidityInterval POSIXTime -> TxConstraints Void Void
forall i o. ValidityInterval POSIXTime -> TxConstraints i o
Constraints.mustValidateInTimeRange ValidityInterval POSIXTime
validityTimeRange
                        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 (RevealedBid -> Address
revealedBidBidder RevealedBid
highestBid) (RevealedBid -> Value
valueOfBid RevealedBid
highestBid)
            newState :: State AuctionState
newState =
              State :: forall s. s -> Value -> State s
State
                  { stateData :: AuctionState
stateData = RevealedBid -> [SealedBid] -> AuctionState
AwaitingPayout RevealedBid
bid ((SealedBid -> Bool) -> [SealedBid] -> [SealedBid]
forall a. (a -> Bool) -> [a] -> [a]
filter (SealedBid -> SealedBid -> Bool
forall a. Eq a => a -> a -> Bool
/= RevealedBid -> SealedBid
sealBid RevealedBid
bid) [SealedBid]
sealedBids)
                  , 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
- Integer -> Ada
Ada.lovelaceOf (RevealedBid -> Integer
revealedBid RevealedBid
highestBid)) Value -> Value -> Value
forall a. Semigroup a => a -> a -> a
<> RevealedBid -> Value
valueOfBid RevealedBid
bid
                  }
        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)

    -- At least one bid has been revealed and the payout is triggered
    (AwaitingPayout RevealedBid
highestBid [SealedBid]
_, 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
apPayoutTime)
                      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 (RevealedBid -> Value
valueOfBid RevealedBid
highestBid)
                      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 (RevealedBid -> Address
revealedBidBidder RevealedBid
highestBid) Value
apAsset
          newState :: State AuctionState
newState =
            State :: forall s. s -> Value -> State s
State
                { stateData :: AuctionState
stateData  = AuctionState
Finished
                , 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)

    -- No other combination of inputs makes sense
    (AuctionState, AuctionInput)
_ -> Maybe (TxConstraints Void Void, State AuctionState)
forall a. Maybe a
Nothing

{-# INLINABLE auctionStateMachine #-}
auctionStateMachine :: AuctionParams -> AuctionMachine
auctionStateMachine :: AuctionParams -> AuctionMachine
auctionStateMachine 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 Maybe ThreadToken
forall a. Maybe a
Nothing (AuctionParams
-> State AuctionState
-> AuctionInput
-> Maybe (TxConstraints Void Void, State AuctionState)
auctionTransition AuctionParams
auctionParams) AuctionState -> Bool
isFinal
  where
    isFinal :: AuctionState -> Bool
isFinal AuctionState
Finished = Bool
True
    isFinal AuctionState
_        = Bool
False

{-# INLINABLE mkValidator #-}
mkValidator :: AuctionParams -> V2.ValidatorType AuctionMachine
mkValidator :: 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)
-> (AuctionParams -> AuctionMachine)
-> AuctionParams
-> AuctionState
-> AuctionInput
-> ScriptContext
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AuctionParams -> AuctionMachine
auctionStateMachine

-- | The script instance of the auction state machine. It contains the state
--   machine compiled to a Plutus core validator script.
typedValidator :: AuctionParams -> V2.TypedValidator AuctionMachine
typedValidator :: AuctionParams -> TypedValidator AuctionMachine
typedValidator = CompiledCode (AuctionParams -> ValidatorType AuctionMachine)
-> CompiledCode (ValidatorType AuctionMachine -> UntypedValidator)
-> 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

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 :: AuctionParams -> StateMachineClient AuctionState AuctionInput
client :: AuctionParams -> StateMachineClient AuctionState AuctionInput
client AuctionParams
auctionParams =
    let machine :: AuctionMachine
machine = AuctionParams -> AuctionMachine
auctionStateMachine AuctionParams
auctionParams
        inst :: TypedValidator AuctionMachine
inst    = AuctionParams -> TypedValidator AuctionMachine
typedValidator 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)

startAuction :: Value -> POSIXTime -> POSIXTime -> Contract () SellerSchema AuctionError ()
startAuction :: Value
-> POSIXTime
-> POSIXTime
-> Contract () SellerSchema AuctionError ()
startAuction Value
asset POSIXTime
endTime POSIXTime
payoutTime = do
    Address
self <- AddressInEra BabbageEra -> Address
forall era. AddressInEra era -> Address
toPlutusAddress (AddressInEra BabbageEra -> Address)
-> Contract
     ()
     ('R '[ "payout" ':-> (EndpointValue (), ActiveEndpoint)])
     AuctionError
     (AddressInEra BabbageEra)
-> Contract
     ()
     ('R '[ "payout" ':-> (EndpointValue (), ActiveEndpoint)])
     AuctionError
     Address
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Contract
  ()
  ('R '[ "payout" ':-> (EndpointValue (), ActiveEndpoint)])
  AuctionError
  (AddressInEra BabbageEra)
forall w (s :: Row *) e.
AsContractError e =>
Contract w s e (AddressInEra BabbageEra)
ownAddress
    let params :: AuctionParams
params = Address -> Value -> POSIXTime -> POSIXTime -> AuctionParams
AuctionParams Address
self Value
asset POSIXTime
endTime POSIXTime
payoutTime
    Contract
  ()
  ('R '[ "payout" ':-> (EndpointValue (), ActiveEndpoint)])
  AuctionError
  AuctionState
-> Contract
     ()
     ('R '[ "payout" ':-> (EndpointValue (), ActiveEndpoint)])
     AuctionError
     ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Contract
   ()
   ('R '[ "payout" ':-> (EndpointValue (), ActiveEndpoint)])
   AuctionError
   AuctionState
 -> Contract
      ()
      ('R '[ "payout" ':-> (EndpointValue (), ActiveEndpoint)])
      AuctionError
      ())
-> Contract
     ()
     ('R '[ "payout" ':-> (EndpointValue (), ActiveEndpoint)])
     AuctionError
     AuctionState
-> Contract
     ()
     ('R '[ "payout" ':-> (EndpointValue (), ActiveEndpoint)])
     AuctionError
     ()
forall a b. (a -> b) -> a -> b
$ StateMachineClient AuctionState AuctionInput
-> AuctionState
-> Value
-> Contract
     ()
     ('R '[ "payout" ':-> (EndpointValue (), ActiveEndpoint)])
     AuctionError
     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 (AuctionParams -> StateMachineClient AuctionState AuctionInput
client AuctionParams
params) ([SealedBid] -> AuctionState
Ongoing []) (AuctionParams -> Value
apAsset AuctionParams
params)

bid :: AuctionParams -> Promise () BidderSchema AuctionError ()
bid :: AuctionParams -> Promise () BidderSchema AuctionError ()
bid AuctionParams
params = 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" ((BidArgs
  -> Contract
       ()
       ('R
          '[ "bid" ':-> (EndpointValue BidArgs, ActiveEndpoint),
             "payout" ':-> (EndpointValue (), ActiveEndpoint),
             "reveal" ':-> (EndpointValue RevealArgs, ActiveEndpoint)])
       AuctionError
       ())
 -> Promise
      ()
      ('R
         '[ "bid" ':-> (EndpointValue BidArgs, ActiveEndpoint),
            "payout" ':-> (EndpointValue (), ActiveEndpoint),
            "reveal" ':-> (EndpointValue RevealArgs, ActiveEndpoint)])
      AuctionError
      ())
-> (BidArgs
    -> Contract
         ()
         ('R
            '[ "bid" ':-> (EndpointValue BidArgs, ActiveEndpoint),
               "payout" ':-> (EndpointValue (), ActiveEndpoint),
               "reveal" ':-> (EndpointValue RevealArgs, ActiveEndpoint)])
         AuctionError
         ())
-> Promise
     ()
     ('R
        '[ "bid" ':-> (EndpointValue BidArgs, ActiveEndpoint),
           "payout" ':-> (EndpointValue (), ActiveEndpoint),
           "reveal" ':-> (EndpointValue RevealArgs, ActiveEndpoint)])
     AuctionError
     ()
forall a b. (a -> b) -> a -> b
$ \ BidArgs{SecretArgument Integer
secretBid :: SecretArgument Integer
secretBid :: BidArgs -> SecretArgument Integer
secretBid} -> do
    Address
self <- AddressInEra BabbageEra -> Address
forall era. AddressInEra era -> Address
toPlutusAddress (AddressInEra BabbageEra -> Address)
-> Contract
     ()
     ('R
        '[ "bid" ':-> (EndpointValue BidArgs, ActiveEndpoint),
           "payout" ':-> (EndpointValue (), ActiveEndpoint),
           "reveal" ':-> (EndpointValue RevealArgs, ActiveEndpoint)])
     AuctionError
     (AddressInEra BabbageEra)
-> Contract
     ()
     ('R
        '[ "bid" ':-> (EndpointValue BidArgs, ActiveEndpoint),
           "payout" ':-> (EndpointValue (), ActiveEndpoint),
           "reveal" ':-> (EndpointValue RevealArgs, ActiveEndpoint)])
     AuctionError
     Address
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Contract
  ()
  ('R
     '[ "bid" ':-> (EndpointValue BidArgs, ActiveEndpoint),
        "payout" ':-> (EndpointValue (), ActiveEndpoint),
        "reveal" ':-> (EndpointValue RevealArgs, ActiveEndpoint)])
  AuctionError
  (AddressInEra BabbageEra)
forall w (s :: Row *) e.
AsContractError e =>
Contract w s e (AddressInEra BabbageEra)
ownAddress
    let sBid :: Secret Integer
sBid = SecretArgument Integer -> Secret Integer
forall a. SecretArgument a -> Secret a
extractSecret SecretArgument Integer
secretBid
    Contract
  ()
  ('R
     '[ "bid" ':-> (EndpointValue BidArgs, ActiveEndpoint),
        "payout" ':-> (EndpointValue (), ActiveEndpoint),
        "reveal" ':-> (EndpointValue RevealArgs, ActiveEndpoint)])
  AuctionError
  (TransitionResult AuctionState AuctionInput)
-> Contract
     ()
     ('R
        '[ "bid" ':-> (EndpointValue BidArgs, ActiveEndpoint),
           "payout" ':-> (EndpointValue (), ActiveEndpoint),
           "reveal" ':-> (EndpointValue RevealArgs, ActiveEndpoint)])
     AuctionError
     ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Contract
   ()
   ('R
      '[ "bid" ':-> (EndpointValue BidArgs, ActiveEndpoint),
         "payout" ':-> (EndpointValue (), ActiveEndpoint),
         "reveal" ':-> (EndpointValue RevealArgs, ActiveEndpoint)])
   AuctionError
   (TransitionResult AuctionState AuctionInput)
 -> Contract
      ()
      ('R
         '[ "bid" ':-> (EndpointValue BidArgs, ActiveEndpoint),
            "payout" ':-> (EndpointValue (), ActiveEndpoint),
            "reveal" ':-> (EndpointValue RevealArgs, ActiveEndpoint)])
      AuctionError
      ())
-> Contract
     ()
     ('R
        '[ "bid" ':-> (EndpointValue BidArgs, ActiveEndpoint),
           "payout" ':-> (EndpointValue (), ActiveEndpoint),
           "reveal" ':-> (EndpointValue RevealArgs, ActiveEndpoint)])
     AuctionError
     (TransitionResult AuctionState AuctionInput)
-> Contract
     ()
     ('R
        '[ "bid" ':-> (EndpointValue BidArgs, ActiveEndpoint),
           "payout" ':-> (EndpointValue (), ActiveEndpoint),
           "reveal" ':-> (EndpointValue RevealArgs, ActiveEndpoint)])
     AuctionError
     ()
forall a b. (a -> b) -> a -> b
$ StateMachineClient AuctionState AuctionInput
-> AuctionInput
-> Contract
     ()
     ('R
        '[ "bid" ':-> (EndpointValue BidArgs, ActiveEndpoint),
           "payout" ':-> (EndpointValue (), ActiveEndpoint),
           "reveal" ':-> (EndpointValue RevealArgs, 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 (AuctionParams -> StateMachineClient AuctionState AuctionInput
client AuctionParams
params) (SealedBid -> AuctionInput
PlaceBid (SealedBid -> AuctionInput) -> SealedBid -> AuctionInput
forall a b. (a -> b) -> a -> b
$ BuiltinByteString -> Address -> SealedBid
SealedBid (Secret Integer -> BuiltinByteString
hashSecretInteger Secret Integer
sBid) Address
self)

reveal :: AuctionParams -> Promise () BidderSchema AuctionError ()
reveal :: AuctionParams -> Promise () BidderSchema AuctionError ()
reveal AuctionParams
params = forall a w (s :: Row *) e b.
(HasEndpoint "reveal" 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 @"reveal" ((RevealArgs
  -> Contract
       ()
       ('R
          '[ "bid" ':-> (EndpointValue BidArgs, ActiveEndpoint),
             "payout" ':-> (EndpointValue (), ActiveEndpoint),
             "reveal" ':-> (EndpointValue RevealArgs, ActiveEndpoint)])
       AuctionError
       ())
 -> Promise
      ()
      ('R
         '[ "bid" ':-> (EndpointValue BidArgs, ActiveEndpoint),
            "payout" ':-> (EndpointValue (), ActiveEndpoint),
            "reveal" ':-> (EndpointValue RevealArgs, ActiveEndpoint)])
      AuctionError
      ())
-> (RevealArgs
    -> Contract
         ()
         ('R
            '[ "bid" ':-> (EndpointValue BidArgs, ActiveEndpoint),
               "payout" ':-> (EndpointValue (), ActiveEndpoint),
               "reveal" ':-> (EndpointValue RevealArgs, ActiveEndpoint)])
         AuctionError
         ())
-> Promise
     ()
     ('R
        '[ "bid" ':-> (EndpointValue BidArgs, ActiveEndpoint),
           "payout" ':-> (EndpointValue (), ActiveEndpoint),
           "reveal" ':-> (EndpointValue RevealArgs, ActiveEndpoint)])
     AuctionError
     ()
forall a b. (a -> b) -> a -> b
$ \ RevealArgs{Integer
publicBid :: Integer
publicBid :: RevealArgs -> Integer
publicBid} -> do
    Address
self <- AddressInEra BabbageEra -> Address
forall era. AddressInEra era -> Address
toPlutusAddress (AddressInEra BabbageEra -> Address)
-> Contract
     ()
     ('R
        '[ "bid" ':-> (EndpointValue BidArgs, ActiveEndpoint),
           "payout" ':-> (EndpointValue (), ActiveEndpoint),
           "reveal" ':-> (EndpointValue RevealArgs, ActiveEndpoint)])
     AuctionError
     (AddressInEra BabbageEra)
-> Contract
     ()
     ('R
        '[ "bid" ':-> (EndpointValue BidArgs, ActiveEndpoint),
           "payout" ':-> (EndpointValue (), ActiveEndpoint),
           "reveal" ':-> (EndpointValue RevealArgs, ActiveEndpoint)])
     AuctionError
     Address
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Contract
  ()
  ('R
     '[ "bid" ':-> (EndpointValue BidArgs, ActiveEndpoint),
        "payout" ':-> (EndpointValue (), ActiveEndpoint),
        "reveal" ':-> (EndpointValue RevealArgs, ActiveEndpoint)])
  AuctionError
  (AddressInEra BabbageEra)
forall w (s :: Row *) e.
AsContractError e =>
Contract w s e (AddressInEra BabbageEra)
ownAddress
    Contract
  ()
  ('R
     '[ "bid" ':-> (EndpointValue BidArgs, ActiveEndpoint),
        "payout" ':-> (EndpointValue (), ActiveEndpoint),
        "reveal" ':-> (EndpointValue RevealArgs, ActiveEndpoint)])
  AuctionError
  (TransitionResult AuctionState AuctionInput)
-> Contract
     ()
     ('R
        '[ "bid" ':-> (EndpointValue BidArgs, ActiveEndpoint),
           "payout" ':-> (EndpointValue (), ActiveEndpoint),
           "reveal" ':-> (EndpointValue RevealArgs, ActiveEndpoint)])
     AuctionError
     ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Contract
   ()
   ('R
      '[ "bid" ':-> (EndpointValue BidArgs, ActiveEndpoint),
         "payout" ':-> (EndpointValue (), ActiveEndpoint),
         "reveal" ':-> (EndpointValue RevealArgs, ActiveEndpoint)])
   AuctionError
   (TransitionResult AuctionState AuctionInput)
 -> Contract
      ()
      ('R
         '[ "bid" ':-> (EndpointValue BidArgs, ActiveEndpoint),
            "payout" ':-> (EndpointValue (), ActiveEndpoint),
            "reveal" ':-> (EndpointValue RevealArgs, ActiveEndpoint)])
      AuctionError
      ())
-> Contract
     ()
     ('R
        '[ "bid" ':-> (EndpointValue BidArgs, ActiveEndpoint),
           "payout" ':-> (EndpointValue (), ActiveEndpoint),
           "reveal" ':-> (EndpointValue RevealArgs, ActiveEndpoint)])
     AuctionError
     (TransitionResult AuctionState AuctionInput)
-> Contract
     ()
     ('R
        '[ "bid" ':-> (EndpointValue BidArgs, ActiveEndpoint),
           "payout" ':-> (EndpointValue (), ActiveEndpoint),
           "reveal" ':-> (EndpointValue RevealArgs, ActiveEndpoint)])
     AuctionError
     ()
forall a b. (a -> b) -> a -> b
$ StateMachineClient AuctionState AuctionInput
-> AuctionInput
-> Contract
     ()
     ('R
        '[ "bid" ':-> (EndpointValue BidArgs, ActiveEndpoint),
           "payout" ':-> (EndpointValue (), ActiveEndpoint),
           "reveal" ':-> (EndpointValue RevealArgs, 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 (AuctionParams -> StateMachineClient AuctionState AuctionInput
client AuctionParams
params) (RevealedBid -> AuctionInput
RevealBid (RevealedBid -> AuctionInput) -> RevealedBid -> AuctionInput
forall a b. (a -> b) -> a -> b
$ Integer -> Address -> RevealedBid
RevealedBid Integer
publicBid Address
self)

payout :: (HasEndpoint "payout" () s) => AuctionParams -> Promise () s AuctionError ()
payout :: AuctionParams -> Promise () s AuctionError ()
payout AuctionParams
params = forall a w (s :: Row *) e b.
(HasEndpoint "payout" 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 @"payout" ((() -> Contract () s AuctionError ())
 -> Promise () s AuctionError ())
-> (() -> Contract () s AuctionError ())
-> Promise () s AuctionError ()
forall a b. (a -> b) -> a -> b
$ \() -> do
    Contract
  () s AuctionError (TransitionResult AuctionState AuctionInput)
-> Contract () s AuctionError ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Contract
   () s AuctionError (TransitionResult AuctionState AuctionInput)
 -> Contract () s AuctionError ())
-> Contract
     () s AuctionError (TransitionResult AuctionState AuctionInput)
-> Contract () s AuctionError ()
forall a b. (a -> b) -> a -> b
$ StateMachineClient AuctionState AuctionInput
-> AuctionInput
-> Contract
     () s 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 (AuctionParams -> StateMachineClient AuctionState AuctionInput
client AuctionParams
params) AuctionInput
Payout

-- | Top-level contract for seller
sellerContract :: AuctionParams -> Contract () SellerSchema AuctionError ()
sellerContract :: AuctionParams -> Contract () SellerSchema AuctionError ()
sellerContract params :: AuctionParams
params@AuctionParams{Address
POSIXTime
Value
apPayoutTime :: POSIXTime
apEndTime :: POSIXTime
apAsset :: Value
apOwner :: Address
apPayoutTime :: AuctionParams -> POSIXTime
apEndTime :: AuctionParams -> POSIXTime
apAsset :: AuctionParams -> Value
apOwner :: AuctionParams -> Address
..} = Value
-> POSIXTime
-> POSIXTime
-> Contract () SellerSchema AuctionError ()
startAuction Value
apAsset POSIXTime
apEndTime POSIXTime
apPayoutTime Contract
  ()
  ('R '[ "payout" ':-> (EndpointValue (), ActiveEndpoint)])
  AuctionError
  ()
-> Contract
     ()
     ('R '[ "payout" ':-> (EndpointValue (), ActiveEndpoint)])
     AuctionError
     ()
-> Contract
     ()
     ('R '[ "payout" ':-> (EndpointValue (), ActiveEndpoint)])
     AuctionError
     ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Promise
  ()
  ('R '[ "payout" ':-> (EndpointValue (), ActiveEndpoint)])
  AuctionError
  ()
-> Contract
     ()
     ('R '[ "payout" ':-> (EndpointValue (), ActiveEndpoint)])
     AuctionError
     ()
forall w (s :: Row *) e a. Promise w s e a -> Contract w s e a
awaitPromise (AuctionParams
-> Promise
     ()
     ('R '[ "payout" ':-> (EndpointValue (), ActiveEndpoint)])
     AuctionError
     ()
forall (s :: Row *).
HasEndpoint "payout" () s =>
AuctionParams -> Promise () s AuctionError ()
payout AuctionParams
params)

-- | Top-level contract for buyer
bidderContract :: AuctionParams -> Contract () BidderSchema AuctionError ()
bidderContract :: AuctionParams -> Contract () BidderSchema AuctionError ()
bidderContract AuctionParams
params = [Promise
   ()
   ('R
      '[ "bid" ':-> (EndpointValue BidArgs, ActiveEndpoint),
         "payout" ':-> (EndpointValue (), ActiveEndpoint),
         "reveal" ':-> (EndpointValue RevealArgs, ActiveEndpoint)])
   AuctionError
   ()]
-> Contract
     ()
     ('R
        '[ "bid" ':-> (EndpointValue BidArgs, ActiveEndpoint),
           "payout" ':-> (EndpointValue (), ActiveEndpoint),
           "reveal" ':-> (EndpointValue RevealArgs, ActiveEndpoint)])
     AuctionError
     ()
forall w (s :: Row *) e a. [Promise w s e a] -> Contract w s e a
selectList [AuctionParams -> Promise () BidderSchema AuctionError ()
bid AuctionParams
params, AuctionParams -> Promise () BidderSchema AuctionError ()
reveal AuctionParams
params, AuctionParams
-> Promise
     ()
     ('R
        '[ "bid" ':-> (EndpointValue BidArgs, ActiveEndpoint),
           "payout" ':-> (EndpointValue (), ActiveEndpoint),
           "reveal" ':-> (EndpointValue RevealArgs, ActiveEndpoint)])
     AuctionError
     ()
forall (s :: Row *).
HasEndpoint "payout" () s =>
AuctionParams -> Promise () s AuctionError ()
payout AuctionParams
params] Contract
  ()
  ('R
     '[ "bid" ':-> (EndpointValue BidArgs, ActiveEndpoint),
        "payout" ':-> (EndpointValue (), ActiveEndpoint),
        "reveal" ':-> (EndpointValue RevealArgs, ActiveEndpoint)])
  AuctionError
  ()
-> Contract
     ()
     ('R
        '[ "bid" ':-> (EndpointValue BidArgs, ActiveEndpoint),
           "payout" ':-> (EndpointValue (), ActiveEndpoint),
           "reveal" ':-> (EndpointValue RevealArgs, ActiveEndpoint)])
     AuctionError
     ()
-> Contract
     ()
     ('R
        '[ "bid" ':-> (EndpointValue BidArgs, ActiveEndpoint),
           "payout" ':-> (EndpointValue (), ActiveEndpoint),
           "reveal" ':-> (EndpointValue RevealArgs, ActiveEndpoint)])
     AuctionError
     ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> AuctionParams -> Contract () BidderSchema AuctionError ()
bidderContract AuctionParams
params