closing the auction

code/english-auction/src/EnglishAuction.hs

@@ -17,9 +17,9 @@
 
 module EnglishAuction
     ( Auction (..)
-    , StartParams (..)
+    , StartParams (..), BidParams (..), CloseParams (..)
     , AuctionSchema
-    , start
+    , start, bid, close
     , endpoints
     , schemas
     , ensureKnownCurrencies
@@ -126,10 +126,16 @@ data BidParams = BidParams
     , bpBid      :: !Integer
     } deriving (Generic, ToJSON, FromJSON, ToSchema)
 
+data CloseParams = CloseParams
+    { cpCurrency :: !CurrencySymbol
+    , cpToken    :: !TokenName
+    } deriving (Generic, ToJSON, FromJSON, ToSchema)
+
 type AuctionSchema =
     BlockchainActions
         .\/ Endpoint "start" StartParams
         .\/ Endpoint "bid"   BidParams
+        .\/ Endpoint "close" CloseParams
 
 start :: (HasBlockchainActions s, AsContractError e) => StartParams -> Contract w s e ()
 start StartParams{..} = do
@@ -151,8 +157,9 @@ start StartParams{..} = do
 
 bid :: forall w s. HasBlockchainActions s => BidParams -> Contract w s Text ()
 bid BidParams{..} = do
-    (oref, o, d@AuctionDatum{..}) <- findAuction
+    (oref, o, d@AuctionDatum{..}) <- findAuction bpCurrency bpToken
     logInfo @String $ printf "found auction utxo with datum %s" (show d)
+
     when (bpBid < minBid d) $
         throwError $ pack $ printf "bid lower than minimal bid %d" (minBid d)
     pkh <- pubKeyHash <$> ownPubKey
@@ -174,14 +181,48 @@ bid BidParams{..} = do
                                     mustSpendScriptOutput oref r
     ledgerTx <- submitTxConstraintsWith lookups tx
     void $ awaitTxConfirmed $ txId ledgerTx
-    logInfo @String ""
-  where
-    findAuction :: Contract w s Text (TxOutRef, TxOutTx, AuctionDatum)
-    findAuction = do
+    logInfo @String $ printf "made bid of %d lovelace in auction %s for token (%s, %s)"
+        bpBid
+        (show adAuction)
+        (show bpCurrency)
+        (show bpToken)
+
+close :: forall w s. HasBlockchainActions s => CloseParams -> Contract w s Text ()
+close CloseParams{..} = do
+    (oref, o, d@AuctionDatum{..}) <- findAuction cpCurrency cpToken
+    logInfo @String $ printf "found auction utxo with datum %s" (show d)
+
+    let t      = Value.singleton cpCurrency cpToken 1
+        r      = Redeemer $ PlutusTx.toData Close
+        seller = aSeller adAuction
+
+        lookups = Constraints.scriptInstanceLookups auctionInstance <>
+                  Constraints.otherScript auctionValidator          <>
+                  Constraints.unspentOutputs (Map.singleton oref o)
+        tx      = case adHighestBid of
+                    Nothing      -> mustPayToPubKey seller t                          <>
+                                    mustValidateIn (from $ aDeadline adAuction)       <>
+                                    mustSpendScriptOutput oref r
+                    Just Bid{..} -> mustPayToPubKey bBidder t                         <>
+                                    mustPayToPubKey seller (Ada.lovelaceValueOf bBid) <>
+                                    mustValidateIn (from $ aDeadline adAuction)       <>
+                                    mustSpendScriptOutput oref r
+    ledgerTx <- submitTxConstraintsWith lookups tx
+    void $ awaitTxConfirmed $ txId ledgerTx
+    logInfo @String $ printf "closed auction %s for token (%s, %s)"
+        (show adAuction)
+        (show cpCurrency)
+        (show cpToken)
+
+findAuction :: HasBlockchainActions s
+            => CurrencySymbol
+            -> TokenName
+            -> Contract w s Text (TxOutRef, TxOutTx, AuctionDatum)
+findAuction cs tn = do
     utxos <- utxoAt $ ScriptAddress auctionHash
     let xs = [ (oref, o)
              | (oref, o) <- Map.toList utxos
-                 , Value.valueOf (txOutValue $ txOutTxOut o) bpCurrency bpToken == 1
+             , Value.valueOf (txOutValue $ txOutTxOut o) cs tn == 1
              ]
     case xs of
         [(oref, o)] -> case txOutType $ txOutTxOut o of
@@ -194,10 +235,11 @@ bid BidParams{..} = do
         _           -> throwError "auction utxo not found"
 
 endpoints :: Contract () AuctionSchema Text ()
-endpoints = (start' `select` bid') >> endpoints
+endpoints = (start' `select` bid' `select` close') >> endpoints
   where
     start' = endpoint @"start" >>= start
     bid'   = endpoint @"bid"   >>= bid
+    close' = endpoint @"close" >>= close
 
 mkSchemaDefinitions ''AuctionSchema