[CO-319] Correctly format (jsend) newtype errors

This is rather ugly and could probably be achieved nicely with a better understanding of the
Generics.SOP library. As far as I could tell, there's no easy way to retrieve 'Tag' for single
constructor

(cf: 'For a datatype with a single constructor we do not need to tag values with their constructor; but for a datatype with multiple constructors we do.  ')

Author: KtorZ

wallet-new/src/Cardano/Wallet/API/Response.hs

@@ -208,6 +208,11 @@ instance FromJSON JSONValidationError where
 
 instance Exception JSONValidationError
 
+instance Arbitrary JSONValidationError where
+    arbitrary = oneof
+        [ pure $ JSONValidationFailed "JSON validation failed."
+        ]
+
 instance Buildable JSONValidationError where
     build = \case
         JSONValidationFailed _ ->

wallet-new/src/Cardano/Wallet/API/V1/Generic.hs

@@ -14,8 +14,7 @@ import           Data.Aeson.Types (Parser)
 import qualified Data.HashMap.Strict as HM
 import qualified Data.Vector as V
 import           Generics.SOP
-import           Generics.SOP.JSON (JsonInfo (..), JsonOptions (..), Tag (..), defaultJsonOptions,
-                                    jsonInfo)
+import           Generics.SOP.JSON (JsonInfo (..), JsonOptions (..), Tag (..), defaultJsonOptions)
 
 import           Cardano.Wallet.API.Response.JSend (ResponseStatus (..))
 import           Cardano.Wallet.Util (mkJsonKey)
@@ -42,24 +41,46 @@ allpf = Proxy
 -- JSON encoding/decoding
 --
 
--- | Returns `JsonInfo` for type (from `json-sop` package)
--- for representing a type in a JSend format.
-jsendInfo
-    :: forall a. (HasDatatypeInfo a, SListI (Code a))
-    => Proxy a -> NP JsonInfo (Code a)
-jsendInfo pa = jsonInfo pa $ defaultJsonOptions
-    { jsonFieldName = const mkJsonKey
-    }
-
 -- | Generic method which makes JSON `Value` from a Haskell value in
 -- JSend format.
 gtoJsend
     :: forall a. (Generic a, HasDatatypeInfo a, All2 ToJSON (Code a))
     => ResponseStatus -> a -> Value
-gtoJsend rs a = hcollapse $
-    hcliftA2 allpt (gtoJsend' rs)
-    (jsendInfo (Proxy :: Proxy a))
-    (unSOP $ from a)
+gtoJsend rs a =
+    hcollapse $
+        hcliftA2 allpt (gtoJsend' rs)
+        (jsendInfo (Proxy :: Proxy a) jsendOptions)
+        (unSOP $ from a)
+
+-- | Our custom naming options
+jsendOptions :: JsonOptions
+jsendOptions = defaultJsonOptions
+    { jsonFieldName = const mkJsonKey
+    }
+
+-- | Slightly modified version compared to Generics.SOP.JSON, we also tag
+-- single-constructor (ADT with one constructor and newtype) because we
+-- rely on that information to wrap the corresponding json in a jsend payload.
+jsendInfo :: forall a. (HasDatatypeInfo a, SListI (Code a))
+         => Proxy a -> JsonOptions -> NP JsonInfo (Code a)
+jsendInfo pa opts =
+  case datatypeInfo pa of
+    Newtype _ t _  -> JsonOne (Tag $ jsonTagName opts t) :* Nil
+    ADT     _ n cs -> hliftA (jsonInfoFor opts n (Tag . jsonTagName opts)) cs
+
+-- Extracted from Generics.SOP.JSON
+jsonInfoFor :: forall xs. JsonOptions -> DatatypeName -> (ConstructorName -> Tag) -> ConstructorInfo xs -> JsonInfo xs
+jsonInfoFor _    _ tag (Infix n _ _)   = JsonMultiple (tag n)
+jsonInfoFor _    _ tag (Constructor n) =
+  case shape :: Shape xs of
+    ShapeNil           -> JsonZero     n
+    ShapeCons ShapeNil -> JsonOne      (tag n)
+    _                  -> JsonMultiple (tag n)
+jsonInfoFor opts d tag (Record n fields) =
+    JsonRecord (tag n) (hliftA jfieldName fields)
+  where
+    jfieldName :: FieldInfo a -> K String a
+    jfieldName (FieldInfo name) = K (jsonFieldName opts d name)
 
 gtoJsend'
     :: All ToJSON xs
@@ -79,7 +100,7 @@ gtoJsend' rs (JsonRecord tag fields) cs =
 gparseJsend
     :: forall a. (Generic a, HasDatatypeInfo a, All2 FromJSON (Code a))
     => Value -> Parser a
-gparseJsend v = to <$> gparseJsend' v (jsendInfo (Proxy :: Proxy a))
+gparseJsend v = to <$> gparseJsend' v (jsendInfo (Proxy :: Proxy a) jsendOptions)
 
 gparseJsend'
     :: forall (xss :: [[*]]). All2 FromJSON xss

wallet-new/src/Cardano/Wallet/API/V1/Migration/Types.hs

@@ -27,6 +27,8 @@ import           Pos.Crypto (decodeHash)
 import           Pos.Wallet.Web.ClientTypes.Instances ()
 import           Pos.Wallet.Web.Tracking.Sync (calculateEstimatedRemainingTime)
 import           Servant (err422)
+import           Test.QuickCheck (Arbitrary (..))
+import           Test.QuickCheck.Gen (oneof)
 
 import qualified Cardano.Wallet.API.V1.Types as V1
 import qualified Control.Lens as Lens
@@ -347,6 +349,11 @@ instance FromJSON MigrationError where
 
 instance Exception MigrationError
 
+instance Arbitrary MigrationError where
+    arbitrary = oneof
+        [ pure $ MigrationFailed "Migration failed."
+        ]
+
 instance Buildable MigrationError where
     build = \case
         MigrationFailed _ ->

wallet-new/test/MarshallingSpec.hs

@@ -24,8 +24,8 @@ import qualified Pos.Core as Core
 
 import           Cardano.Wallet.API.Indices
 import           Cardano.Wallet.API.Request.Pagination (Page, PerPage)
-import           Cardano.Wallet.API.V1.Errors (WalletError)
-import           Cardano.Wallet.API.V1.Migration.Types (Migrate (..))
+import           Cardano.Wallet.API.Response (JSONValidationError)
+import           Cardano.Wallet.API.V1.Migration.Types (Migrate (..), MigrationError)
 import           Cardano.Wallet.API.V1.Types
 import           Cardano.Wallet.Orphans ()
 import qualified Cardano.Wallet.Util as Util
@@ -53,6 +53,8 @@ spec = parallel $ describe "Marshalling & Unmarshalling" $ do
         aesonRoundtripProp @TransactionType Proxy
         aesonRoundtripProp @TransactionStatus Proxy
         aesonRoundtripProp @WalletError Proxy
+        aesonRoundtripProp @JSONValidationError Proxy
+        aesonRoundtripProp @MigrationError Proxy
         aesonRoundtripProp @WalletId Proxy
         aesonRoundtripProp @Wallet Proxy
         aesonRoundtripProp @SlotDuration Proxy
@@ -145,7 +147,7 @@ migrateRoundtrip :: (Arbitrary from, Migrate from to, Migrate to from, Eq from,
 migrateRoundtrip (_ :: proxy from) (_ :: proxy to) = forAll arbitrary $ \(arbitraryFrom :: from) -> do
     (eitherMigrate =<< migrateTo arbitraryFrom) === Right arbitraryFrom
   where
-    migrateTo x = eitherMigrate x :: Either WalletError to
+    migrateTo x = eitherMigrate x :: Either MigrationError to
 
 migrateRoundtripProp
     :: (Arbitrary from, Migrate from to, Migrate to from, Eq from, Show from, Typeable from, Typeable to)