feat: allow optional "error_code" field in responses (#75)

* feat: allow optional "error_code" field in responses

This change relaxes the ic-ref-test suite to allow optional "error_code"
field in query responses and in request statuses as described in
dfinity/interface-spec#38

We also emit error codes in the reference implementation.

Author: roman-kashitsyn

src/IC/Debug/JSON.hs

@@ -80,6 +80,11 @@ instance ToJSON RejectCode where
     toJSON     = genericToJSON customOptions
     toEncoding = genericToEncoding customOptions
 
+deriving instance Generic ErrorCode
+instance ToJSON ErrorCode where
+    toJSON     = genericToJSON customOptions
+    toEncoding = genericToEncoding customOptions
+
 deriving instance Generic Response
 instance ToJSON Response where
     toJSON     = genericToJSON customOptions

src/IC/HTTP/Request.hs

@@ -145,7 +145,8 @@ entitiyId = fmap EntityId <$> blob
 
 -- Printing responses
 response :: ReqResponse -> GenR
-response (QueryResponse (Rejected (c, s))) = rec
+response (QueryResponse (Rejected (c, s, err))) = rec $
+    [ "error_code" =: GText (T.pack $ errorCode c) | c <- maybeToList err] ++
     [ "status" =: GText "rejected"
     , "reject_code" =: GNat (fromIntegral (rejectCode c))
     , "reject_message" =: GText (T.pack s)

src/IC/Ref.hs

@@ -47,6 +47,9 @@ instance Serialise NeedsToRespond where
 deriving instance Generic RejectCode
 instance Serialise RejectCode where
 
+deriving instance Generic ErrorCode
+instance Serialise ErrorCode where
+
 deriving instance Generic Response
 instance Serialise Response where
 

src/IC/Serialise.hs

@@ -402,7 +402,7 @@ validateStateCert' what cert = do
 validateStateCert :: (HasCallStack, HasAgentConfig) => Certificate -> IO ()
 validateStateCert = validateStateCert' "certificate"
 
-data ReqResponse = Reply Blob | Reject Natural T.Text
+data ReqResponse = Reply Blob | Reject Natural T.Text (Maybe T.Text)
   deriving (Eq, Show)
 data ReqStatus = Processing | Pending | Responded ReqResponse | UnknownStatus
   deriving (Eq, Show)
@@ -415,6 +415,14 @@ prettyBlob x =
   let s = map (chr . fromIntegral) (BS.unpack x) in
   if all isPrint s then s else asHex x
 
+maybeCertValue :: HasCallStack => CertVal a => Certificate -> [Blob] -> IO (Maybe a)
+maybeCertValue cert path = case lookupPath (cert_tree cert) path of
+    Found b -> case fromCertVal b of
+      Just x -> return (Just x)
+      Nothing -> assertFailure $ "Cannot parse " ++ prettyPath path ++ " from " ++ show b
+    Absent -> return Nothing
+    x -> assertFailure $ "Expected to find " ++ prettyPath path ++ ", but got " ++ show x
+
 certValue :: HasCallStack => CertVal a => Certificate -> [Blob] -> IO a
 certValue cert path = case lookupPath (cert_tree cert) path of
     Found b -> case fromCertVal b of
@@ -444,7 +452,8 @@ getRequestStatus sender cid rid = do
         certValueAbsent cert ["request_status", rid, "reply"]
         code <- certValue cert ["request_status", rid, "reject_code"]
         msg <- certValue cert ["request_status", rid, "reject_message"]
-        return $ Responded (Reject code msg)
+        errorCode <- maybeCertValue cert ["request_status", rid, "error_code"]
+        return $ Responded (Reject code msg errorCode)
       Found s -> assertFailure $ "Unexpected status " ++ show s
       -- This case should not happen with a compliant IC, but let
       -- us be liberal here, and strict in a dedicated test
@@ -512,13 +521,14 @@ queryResponse = asExceptT . record do
       "rejected" -> do
         code <- field nat "reject_code"
         msg <- field text "reject_message"
-        return $ Reject code msg
+        error_code <- optionalField text "error_code"
+        return $ Reject code msg error_code
       _ -> lift $ throwError $ "Unexpected status " <> T.pack (show s)
 
 isReject :: HasCallStack => [Natural] -> ReqResponse -> IO ()
 isReject _ (Reply r) =
   assertFailure $ "Expected reject, got reply:" ++ prettyBlob r
-isReject codes (Reject n msg) = do
+isReject codes (Reject n msg _) = do
   assertBool
     ("Reject code " ++ show n ++ " not in " ++ show codes ++ "\n" ++ T.unpack msg)
     (n `elem` codes)
@@ -534,8 +544,9 @@ isErrOrReject codes (Right res) = isReject codes res
 
 isReply :: HasCallStack => ReqResponse -> IO Blob
 isReply (Reply b) = return b
-isReply (Reject n msg) =
-  assertFailure $ "Unexpected reject (code " ++ show n ++ "): " ++ T.unpack msg
+isReply (Reject n msg error_code) =
+  assertFailure $ "Unexpected reject (code " ++ show n ++ (maybe "" showErrCode error_code) ++ "): " ++ T.unpack msg
+  where showErrCode ec = ", error_code: " ++ T.unpack ec
 
 -- Convenience decoders
 

src/IC/Test/Agent.hs

@@ -2692,7 +2692,7 @@ isRelay = runGet $ Get.getWord32le >>= \case
     0x4c444944 -> fail "Encountered Candid when expectin relayed data. Did you forget to use isRelay?"
     c -> do
       msg <- Get.getRemainingLazyByteString
-      return $ Reject (fromIntegral c) (T.decodeUtf8With T.lenientDecode (BS.toStrict msg))
+      return $ Reject (fromIntegral c) (T.decodeUtf8With T.lenientDecode (BS.toStrict msg)) Nothing
 
 
 -- Shortcut for test cases that just need one canister.

src/IC/Test/Spec.hs

@@ -20,6 +20,7 @@ import Data.List
 import Data.List.Split (chunksOf)
 import Numeric.Natural
 import Control.Monad.Except
+import Text.Printf (printf)
 
 type (↦) = M.Map
 
@@ -72,6 +73,26 @@ rejectCode RC_DESTINATION_INVALID = 3
 rejectCode RC_CANISTER_REJECT     = 4
 rejectCode RC_CANISTER_ERROR      = 5
 
+data ErrorCode
+    = EC_CANISTER_NOT_FOUND
+    | EC_METHOD_NOT_FOUND
+    | EC_CANISTER_EMPTY
+    | EC_CANISTER_NOT_EMPTY
+    | EC_CANISTER_STOPPED
+    | EC_CANISTER_NOT_STOPPED
+    | EC_CANISTER_NOT_RUNNING
+    | EC_CANISTER_RESTARTED
+    | EC_CANISTER_TRAPPED
+    | EC_CANISTER_REJECTED
+    | EC_CANISTER_DID_NOT_REPLY
+    | EC_INVALID_ENCODING
+    | EC_INVALID_ARGUMENT
+    | EC_INVALID_MODULE
+    | EC_NOT_AUTHORIZED
+  deriving (Show, Enum)
+
+errorCode :: ErrorCode -> String
+errorCode = printf "ICHS%04d" . fromEnum
 
 data Response = Reply Blob | Reject (RejectCode, String)
   deriving Show

src/IC/Types.hs

@@ -59,7 +59,7 @@ printQueryRequest (QueryRequest _ _ method arg) =
     printf "→ query %s%s\n" method (shorten 60 (candidOrPretty arg))
 
 printCallResponse :: CallResponse -> IO ()
-printCallResponse (Rejected (c, s)) =
+printCallResponse (Rejected (c, s, _err)) =
     printf "← rejected (%s): %s\n" (show c) s
 printCallResponse (Replied blob) =
     printf "← replied: %s\n" (shorten 100 (candidOrPretty blob))