{-# LANGUAGE DataKinds          #-}
{-# LANGUAGE DeriveAnyClass     #-}
{-# LANGUAGE DeriveGeneric      #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts   #-}
{-# LANGUAGE MonoLocalBinds     #-}
{-# LANGUAGE OverloadedStrings  #-}
{-# LANGUAGE TemplateHaskell    #-}
{-# LANGUAGE TypeApplications   #-}
{-# LANGUAGE TypeOperators      #-}
module Plutus.Contracts.ErrorHandling(
    Schema
    , MyError(..)
    , AsMyError(..)
    , contract
    ) where

import Control.Lens
import Control.Monad (void)
import Control.Monad.Error.Lens
import Data.Aeson (FromJSON, ToJSON)
import Data.Text (Text)
import GHC.Generics (Generic)

import Cardano.Node.Emulator.Internal.Node (SlotConfig)
import Cardano.Node.Emulator.Internal.Node.TimeSlot qualified as TimeSlot
import Plutus.Contract

-- $errorHandling
-- Demonstrates how to deal with errors in Plutus contracts. We define a custom
-- error type 'MyError' with three constructors and use
-- 'Control.Lens.makeClassyPrisms' to generate the 'AsMyError' class. We can
-- then use 'MyError' in our contracts with the combinators from
-- 'Control.Monad.Error.Lens'. The unit tests in 'Spec.ErrorHandling' show how
-- to write tests for error conditions.

type Schema =
        Endpoint "throwError" ()
        .\/ Endpoint "catchError" ()
        .\/ Endpoint "catchContractError" ()

-- | 'MyError' has a constructor for each type of error that our contract
 --   can throw. The 'MyContractError' constructor wraps a 'ContractError'.
data MyError =
    Error1 Text
    | Error2
    | MyContractError ContractError
    deriving stock (Int -> MyError -> ShowS
[MyError] -> ShowS
MyError -> String
(Int -> MyError -> ShowS)
-> (MyError -> String) -> ([MyError] -> ShowS) -> Show MyError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [MyError] -> ShowS
$cshowList :: [MyError] -> ShowS
show :: MyError -> String
$cshow :: MyError -> String
showsPrec :: Int -> MyError -> ShowS
$cshowsPrec :: Int -> MyError -> ShowS
Show, (forall x. MyError -> Rep MyError x)
-> (forall x. Rep MyError x -> MyError) -> Generic MyError
forall x. Rep MyError x -> MyError
forall x. MyError -> Rep MyError x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep MyError x -> MyError
$cfrom :: forall x. MyError -> Rep MyError x
Generic)
    deriving anyclass ([MyError] -> Encoding
[MyError] -> Value
MyError -> Encoding
MyError -> Value
(MyError -> Value)
-> (MyError -> Encoding)
-> ([MyError] -> Value)
-> ([MyError] -> Encoding)
-> ToJSON MyError
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [MyError] -> Encoding
$ctoEncodingList :: [MyError] -> Encoding
toJSONList :: [MyError] -> Value
$ctoJSONList :: [MyError] -> Value
toEncoding :: MyError -> Encoding
$ctoEncoding :: MyError -> Encoding
toJSON :: MyError -> Value
$ctoJSON :: MyError -> Value
ToJSON, Value -> Parser [MyError]
Value -> Parser MyError
(Value -> Parser MyError)
-> (Value -> Parser [MyError]) -> FromJSON MyError
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [MyError]
$cparseJSONList :: Value -> Parser [MyError]
parseJSON :: Value -> Parser MyError
$cparseJSON :: Value -> Parser MyError
FromJSON)

makeClassyPrisms ''MyError

instance AsContractError MyError where
    -- 'ContractError' is another error type. It is defined in
    -- 'Plutus.Contract.Request'. By making 'MyError' an
    -- instance of 'AsContractError' we can handle 'ContractError's
    -- thrown by other contracts in our code (see 'catchContractError')
    _ContractError :: p ContractError (f ContractError) -> p MyError (f MyError)
_ContractError = p ContractError (f ContractError) -> p MyError (f MyError)
forall r. AsMyError r => Prism' r ContractError
_MyContractError


-- | Throw an 'Error1', using 'Control.Monad.Error.Lens.throwing' and the
--   prism generated by 'makeClassyPrisms'
throw :: AsMyError e => Contract w s e ()
throw :: Contract w s e ()
throw = AReview e Text -> Text -> Contract w s e ()
forall e (m :: * -> *) t x.
MonadError e m =>
AReview e t -> t -> m x
throwing AReview e Text
forall r. AsMyError r => Prism' r Text
_Error1 Text
"something went wrong"

-- | Handle the error from 'throw' using 'Control.Monad.Error.Lens.catching'
throwAndCatch :: AsMyError e => Contract w s e ()
throwAndCatch :: Contract w s e ()
throwAndCatch =
    let handleError1 :: Text -> Contract w s e ()
        handleError1 :: Text -> Contract w s e ()
handleError1 Text
_ = () -> Contract w s e ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    in Getting (First Text) e Text
-> Contract w s e ()
-> (Text -> Contract w s e ())
-> Contract w s e ()
forall e (m :: * -> *) a r.
MonadError e m =>
Getting (First a) e a -> m r -> (a -> m r) -> m r
catching Getting (First Text) e Text
forall r. AsMyError r => Prism' r Text
_Error1 Contract w s e ()
forall e w (s :: Row *). AsMyError e => Contract w s e ()
throw Text -> Contract w s e ()
forall w (s :: Row *) e. Text -> Contract w s e ()
handleError1

-- | Handle an error from another contract (in this case, 'awaitTime)
catchContractError :: (AsMyError e) => SlotConfig -> Contract w s e ()
catchContractError :: SlotConfig -> Contract w s e ()
catchContractError SlotConfig
slotCfg = do
    Getting (First ContractError) e ContractError
-> Contract w s e ()
-> (ContractError -> Contract w s e ())
-> Contract w s e ()
forall e (m :: * -> *) a r.
MonadError e m =>
Getting (First a) e a -> m r -> (a -> m r) -> m r
catching Getting (First ContractError) e ContractError
forall r. AsMyError r => Prism' r ContractError
_MyContractError
        (Contract w s e POSIXTime -> Contract w s e ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Contract w s e POSIXTime -> Contract w s e ())
-> Contract w s e POSIXTime -> Contract w s e ()
forall a b. (a -> b) -> a -> b
$ (ContractError -> e)
-> Contract w s ContractError POSIXTime -> Contract w s e POSIXTime
forall w (s :: Row *) e e' a.
(e -> e') -> Contract w s e a -> Contract w s e' a
mapError (AReview e ContractError -> ContractError -> e
forall b (m :: * -> *) t. MonadReader b m => AReview t b -> m t
review AReview e ContractError
forall r. AsMyError r => Prism' r ContractError
_MyContractError) (Contract w s ContractError POSIXTime -> Contract w s e POSIXTime)
-> Contract w s ContractError POSIXTime -> Contract w s e POSIXTime
forall a b. (a -> b) -> a -> b
$
            POSIXTime -> Contract w s ContractError POSIXTime
forall w (s :: Row *) e.
AsContractError e =>
POSIXTime -> Contract w s e POSIXTime
awaitTime (POSIXTime -> Contract w s ContractError POSIXTime)
-> POSIXTime -> Contract w s ContractError POSIXTime
forall a b. (a -> b) -> a -> b
$ SlotConfig -> POSIXTime
TimeSlot.scSlotZeroTime SlotConfig
slotCfg POSIXTime -> POSIXTime -> POSIXTime
forall a. Num a => a -> a -> a
+ POSIXTime
10000)
        (\ContractError
_ -> AReview e () -> Contract w s e ()
forall e (m :: * -> *) x. MonadError e m => AReview e () -> m x
throwing_ AReview e ()
forall r. AsMyError r => Prism' r ()
_Error2)

contract
    :: ( AsMyError e
       , AsContractError e
       )
    => SlotConfig
    -> Contract w Schema e ()
contract :: SlotConfig -> Contract w Schema e ()
contract SlotConfig
slotCfg = [Promise
   w
   ('R
      '[ "catchContractError" ':-> (EndpointValue (), ActiveEndpoint),
         "catchError" ':-> (EndpointValue (), ActiveEndpoint),
         "throwError" ':-> (EndpointValue (), ActiveEndpoint)])
   e
   ()]
-> Contract
     w
     ('R
        '[ "catchContractError" ':-> (EndpointValue (), ActiveEndpoint),
           "catchError" ':-> (EndpointValue (), ActiveEndpoint),
           "throwError" ':-> (EndpointValue (), ActiveEndpoint)])
     e
     ()
forall w (s :: Row *) e a. [Promise w s e a] -> Contract w s e a
selectList
    [ forall a w (s :: Row *) e b.
(HasEndpoint "throwError" 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 @"throwError" ((()
  -> Contract
       w
       ('R
          '[ "catchContractError" ':-> (EndpointValue (), ActiveEndpoint),
             "catchError" ':-> (EndpointValue (), ActiveEndpoint),
             "throwError" ':-> (EndpointValue (), ActiveEndpoint)])
       e
       ())
 -> Promise
      w
      ('R
         '[ "catchContractError" ':-> (EndpointValue (), ActiveEndpoint),
            "catchError" ':-> (EndpointValue (), ActiveEndpoint),
            "throwError" ':-> (EndpointValue (), ActiveEndpoint)])
      e
      ())
-> (()
    -> Contract
         w
         ('R
            '[ "catchContractError" ':-> (EndpointValue (), ActiveEndpoint),
               "catchError" ':-> (EndpointValue (), ActiveEndpoint),
               "throwError" ':-> (EndpointValue (), ActiveEndpoint)])
         e
         ())
-> Promise
     w
     ('R
        '[ "catchContractError" ':-> (EndpointValue (), ActiveEndpoint),
           "catchError" ':-> (EndpointValue (), ActiveEndpoint),
           "throwError" ':-> (EndpointValue (), ActiveEndpoint)])
     e
     ()
forall a b. (a -> b) -> a -> b
$ Contract
  w
  ('R
     '[ "catchContractError" ':-> (EndpointValue (), ActiveEndpoint),
        "catchError" ':-> (EndpointValue (), ActiveEndpoint),
        "throwError" ':-> (EndpointValue (), ActiveEndpoint)])
  e
  ()
-> ()
-> Contract
     w
     ('R
        '[ "catchContractError" ':-> (EndpointValue (), ActiveEndpoint),
           "catchError" ':-> (EndpointValue (), ActiveEndpoint),
           "throwError" ':-> (EndpointValue (), ActiveEndpoint)])
     e
     ()
forall a b. a -> b -> a
const Contract
  w
  ('R
     '[ "catchContractError" ':-> (EndpointValue (), ActiveEndpoint),
        "catchError" ':-> (EndpointValue (), ActiveEndpoint),
        "throwError" ':-> (EndpointValue (), ActiveEndpoint)])
  e
  ()
forall e w (s :: Row *). AsMyError e => Contract w s e ()
throw
    , forall a w (s :: Row *) e b.
(HasEndpoint "catchError" 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 @"catchError" ((()
  -> Contract
       w
       ('R
          '[ "catchContractError" ':-> (EndpointValue (), ActiveEndpoint),
             "catchError" ':-> (EndpointValue (), ActiveEndpoint),
             "throwError" ':-> (EndpointValue (), ActiveEndpoint)])
       e
       ())
 -> Promise
      w
      ('R
         '[ "catchContractError" ':-> (EndpointValue (), ActiveEndpoint),
            "catchError" ':-> (EndpointValue (), ActiveEndpoint),
            "throwError" ':-> (EndpointValue (), ActiveEndpoint)])
      e
      ())
-> (()
    -> Contract
         w
         ('R
            '[ "catchContractError" ':-> (EndpointValue (), ActiveEndpoint),
               "catchError" ':-> (EndpointValue (), ActiveEndpoint),
               "throwError" ':-> (EndpointValue (), ActiveEndpoint)])
         e
         ())
-> Promise
     w
     ('R
        '[ "catchContractError" ':-> (EndpointValue (), ActiveEndpoint),
           "catchError" ':-> (EndpointValue (), ActiveEndpoint),
           "throwError" ':-> (EndpointValue (), ActiveEndpoint)])
     e
     ()
forall a b. (a -> b) -> a -> b
$ Contract
  w
  ('R
     '[ "catchContractError" ':-> (EndpointValue (), ActiveEndpoint),
        "catchError" ':-> (EndpointValue (), ActiveEndpoint),
        "throwError" ':-> (EndpointValue (), ActiveEndpoint)])
  e
  ()
-> ()
-> Contract
     w
     ('R
        '[ "catchContractError" ':-> (EndpointValue (), ActiveEndpoint),
           "catchError" ':-> (EndpointValue (), ActiveEndpoint),
           "throwError" ':-> (EndpointValue (), ActiveEndpoint)])
     e
     ()
forall a b. a -> b -> a
const Contract
  w
  ('R
     '[ "catchContractError" ':-> (EndpointValue (), ActiveEndpoint),
        "catchError" ':-> (EndpointValue (), ActiveEndpoint),
        "throwError" ':-> (EndpointValue (), ActiveEndpoint)])
  e
  ()
forall e w (s :: Row *). AsMyError e => Contract w s e ()
throwAndCatch
    , forall a w (s :: Row *) e b.
(HasEndpoint "catchContractError" 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 @"catchContractError" ((()
  -> Contract
       w
       ('R
          '[ "catchContractError" ':-> (EndpointValue (), ActiveEndpoint),
             "catchError" ':-> (EndpointValue (), ActiveEndpoint),
             "throwError" ':-> (EndpointValue (), ActiveEndpoint)])
       e
       ())
 -> Promise
      w
      ('R
         '[ "catchContractError" ':-> (EndpointValue (), ActiveEndpoint),
            "catchError" ':-> (EndpointValue (), ActiveEndpoint),
            "throwError" ':-> (EndpointValue (), ActiveEndpoint)])
      e
      ())
-> (()
    -> Contract
         w
         ('R
            '[ "catchContractError" ':-> (EndpointValue (), ActiveEndpoint),
               "catchError" ':-> (EndpointValue (), ActiveEndpoint),
               "throwError" ':-> (EndpointValue (), ActiveEndpoint)])
         e
         ())
-> Promise
     w
     ('R
        '[ "catchContractError" ':-> (EndpointValue (), ActiveEndpoint),
           "catchError" ':-> (EndpointValue (), ActiveEndpoint),
           "throwError" ':-> (EndpointValue (), ActiveEndpoint)])
     e
     ()
forall a b. (a -> b) -> a -> b
$ Contract
  w
  ('R
     '[ "catchContractError" ':-> (EndpointValue (), ActiveEndpoint),
        "catchError" ':-> (EndpointValue (), ActiveEndpoint),
        "throwError" ':-> (EndpointValue (), ActiveEndpoint)])
  e
  ()
-> ()
-> Contract
     w
     ('R
        '[ "catchContractError" ':-> (EndpointValue (), ActiveEndpoint),
           "catchError" ':-> (EndpointValue (), ActiveEndpoint),
           "throwError" ':-> (EndpointValue (), ActiveEndpoint)])
     e
     ()
forall a b. a -> b -> a
const (SlotConfig
-> Contract
     w
     ('R
        '[ "catchContractError" ':-> (EndpointValue (), ActiveEndpoint),
           "catchError" ':-> (EndpointValue (), ActiveEndpoint),
           "throwError" ':-> (EndpointValue (), ActiveEndpoint)])
     e
     ()
forall e w (s :: Row *).
AsMyError e =>
SlotConfig -> Contract w s e ()
catchContractError SlotConfig
slotCfg)
    ]