Skip to content

Commit b68dfca

Browse files
samuel-williams-dasamuel-williams-da
authored
Add tryFailureStatus to daml-script (#21038)
* Add tryFailureStatus to daml-script * Update docs * Add tests * Comments
1 parent 79003ba commit b68dfca

File tree

13 files changed

+342
-51
lines changed

13 files changed

+342
-51
lines changed

‎sdk/compiler/damlc/daml-preprocessor/src/DA/Daml/Preprocessor.hs‎

Lines changed: 0 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -97,7 +97,6 @@ allowedToImportInternal :: Map.Map LF.PackageName (Set.Set GHC.ModuleName)
9797
allowedToImportInternal = Map.fromList $ fmap (bimap LF.PackageName $ Set.fromList . map GHC.mkModuleName)
9898
[ ( "daml-script"
9999
, [ "Daml.Script.Internal.LowLevel"
100-
, "Daml.Script.Internal.Questions.Testing"
101100
, "Daml.Script.Internal.Questions.UserManagement"
102101
]
103102
)

‎sdk/compiler/damlc/tests/daml-test-files/TryCommands.daml‎

Lines changed: 12 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -12,6 +12,7 @@ import Daml.Script
1212
import Daml.Script.Internal
1313
import DA.Assert
1414
import DA.Text
15+
import qualified DA.TextMap as Map
1516

1617
template Name
1718
with
@@ -60,6 +61,14 @@ tryCommandsContractNotActive = do
6061
-- Check that the lifted error can be caught
6162
liftedFailedCmdException : Script ()
6263
liftedFailedCmdException = do
63-
try
64-
liftFailedCommandToException $ failedAuthScript ()
65-
catch (e : FailedCmd) -> e === failedAuthError
64+
res <- tryFailureStatus $ liftFailedCommandToFailureStatus $ failedAuthScript ()
65+
case res of
66+
Right _ -> fail "Expected failure, got success"
67+
Left fs
68+
| fs.message == getErrorMessage failedAuthError.errorMessage
69+
, fs.meta == Map.fromList
70+
[ ("commandName", getCommandName failedAuthError.commandName)
71+
, ("className", getErrorClassName failedAuthError.errorClassName)
72+
]
73+
-> pure ()
74+
Left _ -> fail "Incorrect failure status reported"

‎sdk/compiler/damlc/tests/daml-test-files/TryFailureStatus.daml‎

Lines changed: 137 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,137 @@
1+
-- Copyright (c) 2025 Digital Asset (Switzerland) GmbH and/or its affiliates. All rights reserved.
2+
-- SPDX-License-Identifier: Apache-2.0
3+
4+
{-# OPTIONS_GHC -Wno-x-exceptions #-}
5+
6+
module TryFailureStatus where
7+
8+
import Daml.Script
9+
import DA.Exception
10+
import DA.Fail
11+
import DA.TextMap
12+
13+
-- Can catch failure status
14+
-- Can catch regular exception
15+
-- Can catch daml pseudo exception
16+
-- works in a tryToEither
17+
-- tryToEither works in it
18+
-- ^ above two for pseudo exception
19+
--
20+
21+
exampleFailureStatus : FailureStatus
22+
exampleFailureStatus = FailureStatus "my-error-code" InvalidGivenCurrentSystemStateOther "Something went wrong!" $ fromList [("thing-that-went-wrong", "something")]
23+
24+
exampleGeneralError : GeneralError
25+
exampleGeneralError = GeneralError "my-general-error"
26+
27+
exampleGeneralErrorFailureStatus : FailureStatus
28+
exampleGeneralErrorFailureStatus = FailureStatus "UNHANDLED_EXCEPTION/DA.Exception.GeneralError:GeneralError" InvalidGivenCurrentSystemStateOther "my-general-error" mempty
29+
30+
exampleInvalidUserId : InvalidUserId
31+
exampleInvalidUserId = InvalidUserId "invalid-user-id"
32+
33+
exampleInvalidUserIdFailureStatus : FailureStatus
34+
exampleInvalidUserIdFailureStatus = FailureStatus "UNHANDLED_EXCEPTION/Daml.Script.Internal.Questions.UserManagement:InvalidUserId" InvalidGivenCurrentSystemStateOther "invalid-user-id" mempty
35+
36+
canCatchPureFailureStatus : Script ()
37+
canCatchPureFailureStatus = do
38+
res <- tryFailureStatus $ pure $ failWithStatusPure @() exampleFailureStatus
39+
case res of
40+
Left fs | fs == exampleFailureStatus -> pure ()
41+
_ -> fail $ "Expected exampleFailureStatus but got " <> show res
42+
43+
canCatchPureException : Script ()
44+
canCatchPureException = do
45+
res <- tryFailureStatus $ pure $ throwPure @_ @() exampleGeneralError
46+
case res of
47+
Left fs | fs == exampleGeneralErrorFailureStatus -> pure ()
48+
_ -> fail $ "Expected exampleGeneralErrorFailureStatus but got " <> show res
49+
50+
canCatchFailureStatus : Script ()
51+
canCatchFailureStatus = do
52+
res <- tryFailureStatus $ failWithStatus @_ @() exampleFailureStatus
53+
case res of
54+
Left fs | fs == exampleFailureStatus -> pure ()
55+
_ -> fail $ "Expected exampleFailureStatus but got " <> show res
56+
57+
canCatchException : Script ()
58+
canCatchException = do
59+
res <- tryFailureStatus $ (throw exampleGeneralError : Script ())
60+
case res of
61+
Left fs | fs == exampleGeneralErrorFailureStatus -> pure ()
62+
_ -> fail $ "Expected exampleGeneralErrorFailureStatus but got " <> show res
63+
64+
65+
canCatchDamlScriptException : Script ()
66+
canCatchDamlScriptException = do
67+
res <- tryFailureStatus $ (throw exampleInvalidUserId : Script ())
68+
case res of
69+
Left fs | fs == exampleInvalidUserIdFailureStatus -> pure ()
70+
_ -> fail $ "Expected exampleInvalidUserIdFailureStatus but got " <> show res
71+
72+
73+
tryToEitherWorksWithin : Script ()
74+
tryToEitherWorksWithin = do
75+
res <- tryFailureStatus $ do
76+
try
77+
throw exampleGeneralError
78+
catch
79+
GeneralError _ -> pure ()
80+
case res of
81+
Right _ -> pure ()
82+
_ -> fail $ "Expected success but got " <> show res
83+
84+
worksWithinTryToEither : Script ()
85+
worksWithinTryToEither = do
86+
try do
87+
res <- tryFailureStatus $ (throw exampleGeneralError : Script ())
88+
case res of
89+
Left fs | fs == exampleGeneralErrorFailureStatus -> pure ()
90+
_ -> fail $ "Expected exampleGeneralErrorFailureStatus but got " <> show res
91+
catch
92+
93+
doubleTryToEitherWorksWithin : Script ()
94+
doubleTryToEitherWorksWithin = do
95+
res <- tryFailureStatus $ do
96+
try
97+
try
98+
throw exampleGeneralError
99+
catch
100+
catch
101+
GeneralError _ -> pure ()
102+
case res of
103+
Right _ -> pure ()
104+
_ -> fail $ "Expected success but got " <> show res
105+
106+
tryToEitherWorksWithinDamlScriptException : Script ()
107+
tryToEitherWorksWithinDamlScriptException = do
108+
res <- tryFailureStatus $ do
109+
try
110+
throw exampleInvalidUserId
111+
catch
112+
InvalidUserId _ -> pure ()
113+
case res of
114+
Right _ -> pure ()
115+
_ -> fail $ "Expected success but got " <> show res
116+
117+
worksWithinTryToEitherDamlScriptException : Script ()
118+
worksWithinTryToEitherDamlScriptException = do
119+
try do
120+
res <- tryFailureStatus $ (throw exampleInvalidUserId : Script ())
121+
case res of
122+
Left fs | fs == exampleInvalidUserIdFailureStatus -> pure ()
123+
_ -> fail $ "Expected exampleInvalidUserIdFailureStatus but got " <> show res
124+
catch
125+
126+
doubleTryToEitherWorksWithinDamlScriptException : Script ()
127+
doubleTryToEitherWorksWithinDamlScriptException = do
128+
res <- tryFailureStatus $ do
129+
try
130+
try
131+
throw exampleInvalidUserId
132+
catch
133+
catch
134+
InvalidUserId _ -> pure ()
135+
case res of
136+
Right _ -> pure ()
137+
_ -> fail $ "Expected success but got " <> show res

‎sdk/daml-lf/ide-ledger/src/main/scala/com/digitalasset/daml/lf/script/Error.scala‎

Lines changed: 3 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -88,7 +88,9 @@ object Error {
8888
err: language.LookupError,
8989
packageMeta: Option[PackageMetadata],
9090
packageId: PackageId,
91-
) extends Error
91+
) extends Error {
92+
override def toString = s"LookupError: $err\n$packageMeta\n$packageId"
93+
}
9294

9395
final case class DisclosureDecoding(message: String) extends Error
9496
}

‎sdk/daml-script/daml/Daml/Script.daml‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -113,6 +113,7 @@ module Daml.Script
113113
, submitUser
114114
, submitUserOn
115115
, tryToEither
116+
, tryFailureStatus
116117

117118
#ifdef DAML_CRYPTO
118119
, Secp256k1KeyPair

‎sdk/daml-script/daml/Daml/Script/Internal.daml‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -9,7 +9,7 @@ module Daml.Script.Internal
99
, ErrorMessage (..)
1010
, tryCommands
1111
, FailedCmd (..)
12-
, liftFailedCommandToException
12+
, liftFailedCommandToFailureStatus
1313

1414
, -- Packages
1515
PackageName (..)

‎sdk/daml-script/daml/Daml/Script/Internal/Questions/Exceptions.daml‎

Lines changed: 13 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -11,9 +11,12 @@ import DA.Exception
1111
import DA.Optional
1212
import Daml.Script.Internal.LowLevel
1313
import DA.Fail
14+
import DA.Stack
1415

1516
data Catch = Catch with
1617
act : () -> LedgerValue
18+
-- Dummy value needed to ensure this record isn't treated as an old-style typeclass by data-deps
19+
-- (defined as any record where all definitions are () -> X)
1720
dummy : ()
1821
instance IsQuestion Catch (Either AnyException x) where command = "Catch"
1922

@@ -59,3 +62,13 @@ instance IsQuestion FailWithStatus t where command = "FailWithStatus"
5962

6063
instance ActionFailWithStatus Script where
6164
failWithStatus = lift . FailWithStatus
65+
66+
data TryFailureStatus = TryFailureStatus with
67+
act : () -> LedgerValue
68+
dummy : ()
69+
instance IsQuestion TryFailureStatus (Either FailureStatus x) where command = "TryFailureStatus"
70+
71+
tryFailureStatus : (HasCallStack => Script a) -> Script (Either FailureStatus a)
72+
tryFailureStatus act = lift TryFailureStatus with
73+
act = \() -> toLedgerValue act
74+
dummy = ()

‎sdk/daml-script/daml/Daml/Script/Internal/Questions/Testing.daml‎

Lines changed: 15 additions & 24 deletions
Original file line numberDiff line numberDiff line change
@@ -6,9 +6,8 @@ module Daml.Script.Internal.Questions.Testing where
66
import Daml.Script.Internal.LowLevel
77
import Daml.Script.Internal.Questions.Exceptions ()
88
import DA.Bifunctor
9-
import DA.Exception
10-
import GHC.Types (primitive)
11-
import DA.Record
9+
import qualified DA.TextMap as TextMap
10+
import DA.Fail
1211

1312
newtype CommandName = CommandName
1413
with getCommandName : Text
@@ -45,25 +44,17 @@ data FailedCmd = FailedCmd with
4544
errorMessage : ErrorMessage
4645
deriving (Eq, Show)
4746

48-
instance HasThrow FailedCmd where
49-
throwPure _ = error "Tried to throw daml-script pseudo-exception"
50-
51-
instance GetField "message" FailedCmd Text where
52-
getField (FailedCmd _ _ msg) = getErrorMessage msg
53-
54-
instance HasMessage FailedCmd where
55-
message (FailedCmd _ _ msg) = getErrorMessage msg
56-
57-
-- These primitives do not check that the type arguments are real templates
58-
-- they also use the same internal representation in the engine as exceptions
59-
-- (SBToAny, SBFromAny)
60-
-- So we hijack them until Daml 3.4, where either exceptions are removed, or not serializable
61-
instance HasToAnyException FailedCmd where
62-
toAnyException = anyToAnyException . primitive @"EToAnyTemplate"
63-
64-
instance HasFromAnyException FailedCmd where
65-
fromAnyException = primitive @"EFromAnyTemplate" . anyExceptionToAny
66-
6747
-- Runs a script and lifts FailedCmd scala exceptions into the FailedCmd daml exception, which can be caught via try-catch
68-
liftFailedCommandToException : Script a -> Script a
69-
liftFailedCommandToException act = tryCommands act >>= either throw pure
48+
liftFailedCommandToFailureStatus : Script a -> Script a
49+
liftFailedCommandToFailureStatus act = tryCommands act >>= either (failWithStatus . failedCmdToFailureStatus) pure
50+
where
51+
failedCmdToFailureStatus : FailedCmd -> FailureStatus
52+
failedCmdToFailureStatus (FailedCmd cmdName className errMessage) =
53+
FailureStatus with
54+
errorId = "UNHANDLED_EXCEPTION/Daml.Script:FailedCmd"
55+
category = InvalidGivenCurrentSystemStateOther
56+
message = getErrorMessage errMessage
57+
meta = TextMap.fromList
58+
[ ("commandName", getCommandName cmdName)
59+
, ("className", getErrorClassName className)
60+
]

0 commit comments

Comments
 (0)