[CBR-26] Re-introduce generic approach for serializing wallet errors

KtorZ · KtorZ · commit d764f0440129 · 2018-08-18T19:22:50.000+02:00
This is done through the combination of 'SOP.Generic', 'Generic' and
'HasDiagnostic' classe. Basically, what we miss from the old
implementation are the names of all the partial reccord fields that were
used to wrap the diagnostic part of the JSEnd response.
These names are now provided by the 'HasDiagnostic' class that need to
be implemented for each JSEnd error. From there, we provide two generic
functions to convert a type 'a' to a JSON value and respectively, to
parse any value to a type a.

The main trick for the parsing is to leverage the 'Generic' instance and
to construct a JSON value as Aeson would have serialized it in a first
place. The serialization becomes quite straighforward once we can
serialize the diagnostic which is done via an internal Generic class,
working with a few type representations (not all, we don't need them).

This approach is much more readable and maintainable than previously and
will save us some errors due to typos or wrong formatting.
diff --git a/wallet-new/src/Cardano/Wallet/API/Response.hs b/wallet-new/src/Cardano/Wallet/API/Response.hs
@@ -23,13 +23,11 @@ import           Prelude
 import           Universum (Buildable, Exception, Text, decodeUtf8, toText,
                      (<>))
 
-import           Control.Lens hiding ((.=))
-import           Data.Aeson (FromJSON (..), ToJSON (..), eitherDecode, encode,
-                     object, pairs, withObject, (.:), (.=))
+import           Control.Lens
+import           Data.Aeson (FromJSON (..), ToJSON (..), eitherDecode, encode)
 import           Data.Aeson.Encode.Pretty (encodePretty)
 import qualified Data.Aeson.Options as Serokell
 import           Data.Aeson.TH
-import           Data.Aeson.Types (Value (..))
 import qualified Data.Char as Char
 import           Data.Swagger as S hiding (Example, example)
 import           Data.Typeable
@@ -50,9 +48,12 @@ import           Cardano.Wallet.API.Request.Pagination (Page (..),
                      PerPage (..))
 import           Cardano.Wallet.API.Request.Sort (SortOperations (..))
 import           Cardano.Wallet.API.Response.Filter.IxSet as FilterBackend
-import           Cardano.Wallet.API.Response.JSend (ResponseStatus (..))
+import           Cardano.Wallet.API.Response.JSend (HasDiagnostic (..),
+                     ResponseStatus (..))
 import           Cardano.Wallet.API.Response.Sort.IxSet as SortBackend
 import           Cardano.Wallet.API.V1.Errors (ToServantError (..))
+import           Cardano.Wallet.API.V1.Generic (jsendErrorGenericParseJSON,
+                     jsendErrorGenericToJSON)
 import           Cardano.Wallet.API.V1.Swagger.Example (Example, example)
 
 -- | Extra information associated with an HTTP response.
@@ -237,43 +238,32 @@ instance ToJSON a => MimeRender ValidJSON a where
 
 newtype JSONValidationError
     = JSONValidationFailed Text
-    deriving (Generic, Show, Eq)
+    deriving (Eq, Show, Generic)
 
 deriveGeneric ''JSONValidationError
 
 instance ToJSON JSONValidationError where
-    toEncoding (JSONValidationFailed weValidationError) = pairs $ mconcat
-        [ "status"     .= ErrorStatus
-        , "diagnostic" .= object
-            [ "validationError" .= weValidationError
-            ]
-        , "message"    .= String "JSONValidationFailed"
-        ]
+    toJSON =
+        jsendErrorGenericToJSON
 
 instance FromJSON JSONValidationError where
-    parseJSON = withObject "JSONValidationError" $ \o -> do
-        message <- o .: "message"
-        case message :: Text of
-            "JSONValidationFailed" -> do
-                diag <- o .: "diagnostic"
-                err <- diag .: "validationError"
-                pure $ JSONValidationFailed err
-            _ ->
-                fail "Incorrect JSON encoding for JSONValidationError"
+    parseJSON =
+        jsendErrorGenericParseJSON
 
 instance Exception JSONValidationError
 
 instance Arbitrary JSONValidationError where
-    arbitrary = oneof
-        [ pure $ JSONValidationFailed "JSON validation failed."
-        ]
+    arbitrary =
+        pure (JSONValidationFailed "JSON validation failed.")
 
 instance Buildable JSONValidationError where
-    build = \case
-        JSONValidationFailed _ ->
-            bprint "Couldn't decode a JSON input."
+    build _ =
+        bprint "Couldn't decode a JSON input."
+
+instance HasDiagnostic JSONValidationError where
+    getDiagnosticKey _ =
+        "validationError"
 
 instance ToServantError JSONValidationError where
-    declareServantError = \case
-        JSONValidationFailed _ ->
-            err400
+    declareServantError _ =
+        err400
diff --git a/wallet-new/src/Cardano/Wallet/API/Response/JSend.hs b/wallet-new/src/Cardano/Wallet/API/Response/JSend.hs
@@ -17,6 +17,13 @@ data ResponseStatus =
 
 deriveJSON defaultOptions { Data.Aeson.TH.constructorTagModifier = map Char.toLower . reverse . drop 6 . reverse } ''ResponseStatus
 
+class HasDiagnostic a where
+    getDiagnosticKey :: a -> Text
+
+noDiagnosticKey :: Text
+noDiagnosticKey =
+    error "Contructor has declared no diagnostic key but apparently requires one! Have a look at HasDiagnostic instances!"
+
 instance Arbitrary ResponseStatus where
     arbitrary = elements [minBound .. maxBound]
 
diff --git a/wallet-new/src/Cardano/Wallet/API/V1/Generic.hs b/wallet-new/src/Cardano/Wallet/API/V1/Generic.hs
@@ -1,43 +1,120 @@
 {-# LANGUAGE PolyKinds #-}
 
 module Cardano.Wallet.API.V1.Generic
-       ( gconsNames
-       , gconsName
-       ) where
+    ( jsendErrorGenericToJSON
+    , jsendErrorGenericParseJSON
+    , gconsNames
+    , gconsName
+    ) where
 
 import           Universum hiding (All, Generic)
 
+import           Data.Aeson (GFromJSON, Object, ToJSON, Value (..), Zero,
+                     genericParseJSON, object, tagSingleConstructors,
+                     withObject, (.:), (.=))
+import           Data.Aeson.Types (Parser)
 import           Data.List ((!!))
-import           Generics.SOP
+import           GHC.Generics
+
+import           Cardano.Wallet.API.Response.JSend (HasDiagnostic (..),
+                     ResponseStatus (..))
+
+import qualified Data.Aeson as Aeson
+import qualified Data.HashMap.Lazy as HM
+import qualified Generics.SOP as SOP
 
 --
 -- Misc
 --
 
+-- | Get the ADT constructor's name of the given value
+gconsName
+  :: forall a. (SOP.Generic a, SOP.HasDatatypeInfo a)
+  => a -> Text
+gconsName a =
+  gconsNames (Proxy @a) !! SOP.hindex (SOP.from a)
+
 -- | Get all constructors names available of an ADT
 gconsNames
-    :: forall a. (HasDatatypeInfo a, SListI (Code a))
+    :: forall a. (SOP.HasDatatypeInfo a, SOP.SListI (SOP.Code a))
     => Proxy a -> [Text]
 gconsNames =
-  map toText . hcollapse . hliftA (K . constructorName) . gconsInfos
+    map toText . SOP.hcollapse . SOP.hliftA (SOP.K . SOP.constructorName) . gconsInfos
 
 
--- | Get the ADT constructor's name of the given value
-gconsName
-  :: forall a. (Generic a, HasDatatypeInfo a)
-  => a -> Text
-gconsName a =
-  gconsNames (Proxy @a) !! hindex (from a)
+--
+-- JSendError Encoding helper
+--
+jsendErrorGenericToJSON ::
+    ( GDiagnosticToJSON (Rep a)
+    , HasDiagnostic a
+    , Generic a
+    , SOP.Generic a
+    , SOP.HasDatatypeInfo a
+    ) => a -> Value
+jsendErrorGenericToJSON a = object
+    [ "message"     .= gconsName a
+    , "status"      .= ErrorStatus
+    , "diagnostic"  .= gDiagnosticToJSON (getDiagnosticKey a) (from a)
+    ]
+
+jsendErrorGenericParseJSON ::
+    ( Generic a
+    , GFromJSON Zero (Rep a)
+    ) => Value
+    -> Parser a
+jsendErrorGenericParseJSON = withObject "JSEndError" $ \o -> do
+    message    <- o .: "message"
+    diagnostic <- o .: "diagnostic" >>= parseDiagnostic
+    genericParseJSON opts $  object
+        [ "tag"      .= String message
+        , "contents" .= diagnostic
+        ]
+  where
+    opts :: Aeson.Options
+    opts = Aeson.defaultOptions { tagSingleConstructors = True }
+
+    parseDiagnostic :: Object -> Parser Value
+    parseDiagnostic hm =
+        case HM.toList hm of
+            []           -> pure (object mempty)
+            [(_, value)] -> pure value
+            _            -> fail "Invalid ToJSON encoding for JSEndError"
 
 
 --
 -- INTERNALS
 --
 
 gconsInfos
-    :: forall a. (HasDatatypeInfo a)
-    => Proxy a -> NP ConstructorInfo (Code a)
-gconsInfos pa = case datatypeInfo pa of
-    Newtype _ _ conInfo -> conInfo :* Nil
-    ADT _ _ consInfo    -> consInfo
+    :: forall a. (SOP.HasDatatypeInfo a)
+    => Proxy a
+    -> SOP.NP SOP.ConstructorInfo (SOP.Code a)
+gconsInfos pa = case SOP.datatypeInfo pa of
+    SOP.Newtype _ _ conInfo -> conInfo SOP.:* SOP.Nil
+    SOP.ADT _ _ consInfo    -> consInfo
+
+
+-- | This class helps us define generically errors JSON instances without
+-- relying on partial field in records.
+-- This is used to encode the diagnostic object of an error, as a singleton
+-- with field 'Text' whenever there's one.
+--
+-- NOTE: We haven't defined instances for everything because we do not want to
+-- suppport all kind of error structures, but only sums with a unary or
+-- nullary constructors.
+class GDiagnosticToJSON (f :: * -> *) where
+    gDiagnosticToJSON :: Text -> f a -> Value
+
+instance (GDiagnosticToJSON f) => GDiagnosticToJSON (M1 i c f) where
+    gDiagnosticToJSON k (M1 f) = gDiagnosticToJSON k f
+
+instance (GDiagnosticToJSON f, GDiagnosticToJSON g) => GDiagnosticToJSON (f :+: g) where
+    gDiagnosticToJSON k (L1 f) = gDiagnosticToJSON k f
+    gDiagnosticToJSON k (R1 g) = gDiagnosticToJSON k g
+
+instance (ToJSON c) => GDiagnosticToJSON (K1 i c) where
+    gDiagnosticToJSON k (K1 c) = object [ k .= c ]
 
+instance GDiagnosticToJSON U1 where
+    gDiagnosticToJSON _ _ = object mempty
diff --git a/wallet-new/src/Cardano/Wallet/API/V1/Migration/Types.hs b/wallet-new/src/Cardano/Wallet/API/V1/Migration/Types.hs
@@ -14,9 +14,7 @@ import           Universum hiding (elems)
 
 import qualified Control.Lens as Lens
 import qualified Control.Monad.Catch as Catch
-import           Data.Aeson (FromJSON (..), ToJSON (..), object, pairs,
-                     withObject, (.:), (.=))
-import           Data.Aeson.Types (Value (..))
+import           Data.Aeson (FromJSON (..), ToJSON (..))
 import           Data.Map (elems)
 import           Data.Time.Clock.POSIX (POSIXTime)
 import           Data.Time.Units (fromMicroseconds, toMicroseconds)
@@ -27,10 +25,11 @@ import           Generics.SOP.TH (deriveGeneric)
 import           GHC.Generics (Generic)
 import           Servant (err422)
 import           Test.QuickCheck (Arbitrary (..))
-import           Test.QuickCheck.Gen (oneof)
 
-import           Cardano.Wallet.API.Response.JSend (ResponseStatus (..))
+import           Cardano.Wallet.API.Response.JSend (HasDiagnostic (..))
 import           Cardano.Wallet.API.V1.Errors (ToServantError (..))
+import           Cardano.Wallet.API.V1.Generic (jsendErrorGenericParseJSON,
+                     jsendErrorGenericToJSON)
 import           Cardano.Wallet.API.V1.Types (V1 (..))
 import qualified Cardano.Wallet.API.V1.Types as V1
 import qualified Pos.Chain.Txp as V0
@@ -350,35 +349,27 @@ newtype MigrationError
 deriveGeneric ''MigrationError
 
 instance ToJSON MigrationError where
-    toEncoding (MigrationFailed weDescription) = pairs $ mconcat
-        [ "status"     .= ErrorStatus
-        , "diagnostic" .= object
-            [ "description" .= weDescription
-            ]
-        , "message"    .= String "MigrationFailed"
-        ]
+    toJSON =
+        jsendErrorGenericToJSON
 
 instance FromJSON MigrationError where
-    parseJSON = withObject "MigrationError" $ \o -> do
-        message <- o .: "message"
-        case message :: Text of
-            "MigrationFailed" -> do
-                diag <- o .: "diagnostic"
-                desc <- diag .: "description"
-                pure $ MigrationFailed desc
-            _ ->
-                fail "Incorrect JSON encoding for MigrationError"
+    parseJSON =
+        jsendErrorGenericParseJSON
 
 instance Exception MigrationError
 
 instance Arbitrary MigrationError where
-    arbitrary = oneof
-        [ pure $ MigrationFailed "Migration failed."
-        ]
+    arbitrary =
+        pure (MigrationFailed "Migration failed.")
 
 instance Buildable MigrationError where
     build _ =
         bprint "Error while migrating a legacy type into the current version."
 
+instance HasDiagnostic MigrationError where
+    getDiagnosticKey _ =
+        "description"
+
 instance ToServantError MigrationError where
-    declareServantError _ = err422
+    declareServantError _ =
+        err422
diff --git a/wallet-new/src/Cardano/Wallet/API/V1/Swagger.hs b/wallet-new/src/Cardano/Wallet/API/V1/Swagger.hs
@@ -28,7 +28,7 @@ import           Control.Lens ((?~))
 import           Data.Aeson (encode)
 import           Data.Aeson.Encode.Pretty
 import           Data.Map (Map)
-import           Data.Swagger hiding (Example, Header, example)
+import           Data.Swagger hiding (Example, Header)
 import           Data.Typeable
 import           Formatting (build, sformat)
 import           NeatInterpolation
diff --git a/wallet-new/src/Cardano/Wallet/API/V1/Types.hs b/wallet-new/src/Cardano/Wallet/API/V1/Types.hs
