[ADP-416] Allow multiple well-formed values in "/Cardano.Wallet.Api/"…

lib/core/test/unit/Cardano/Wallet/Api/Malformed.hs

@@ -117,7 +117,7 @@ newtype Header (headerName :: Symbol) (contentType :: *) =
 --
 
 class Wellformed t where
-    wellformed :: t
+    wellformed :: [t]
 
 class Malformed t where
     malformed :: [(t, ExpectedError)]
@@ -126,7 +126,7 @@ class Malformed t where
 -- Class instances (PathParam)
 --
 instance Wellformed (PathParam (ApiT WalletId)) where
-    wellformed = PathParam $ T.replicate 40 "0"
+    wellformed = [PathParam $ T.replicate 40 "0"]
 
 instance Malformed (PathParam (ApiT WalletId)) where
     malformed = first PathParam <$>
@@ -138,7 +138,7 @@ instance Malformed (PathParam (ApiT WalletId)) where
         msg = "wallet id should be a hex-encoded string of 40 characters"
 
 instance Wellformed (PathParam ApiTxId) where
-    wellformed = PathParam $ T.replicate 64 "0"
+    wellformed = [PathParam $ T.replicate 64 "0"]
 
 instance Malformed (PathParam ApiTxId) where
     malformed = first PathParam <$>
@@ -150,7 +150,9 @@ instance Malformed (PathParam ApiTxId) where
         msg = "Invalid tx hash: expecting a hex-encoded value that is 32 bytes in length."
 
 instance Wellformed (PathParam ApiPoolId) where
-    wellformed = PathParam $ T.replicate 64 "0"
+    wellformed = PathParam <$>
+        [ T.replicate 64 "0"
+        ]
 
 instance Malformed (PathParam ApiPoolId) where
     malformed = first PathParam <$>
@@ -162,8 +164,8 @@ instance Malformed (PathParam ApiPoolId) where
         msg = "Invalid stake pool id: expecting a hex-encoded value that is 28 or 32 bytes in length."
 
 instance Wellformed (PathParam (ApiT Address, Proxy ('Testnet 0))) where
-    wellformed = PathParam
-        "FHnt4NL7yPY7JbfJYSadQVSGJG7EKkN4kpVJMhJ8CN3uDNymGnJuuwcHmyP4ouZ"
+    wellformed = [PathParam
+        "FHnt4NL7yPY7JbfJYSadQVSGJG7EKkN4kpVJMhJ8CN3uDNymGnJuuwcHmyP4ouZ"]
 
 instance Malformed (PathParam (ApiT Address, Proxy ('Testnet 0))) where
     malformed = []
@@ -994,7 +996,7 @@ instance Malformed (BodyParam ApiPostRandomAddressData) where
 --
 instance Wellformed (Header "Content-Type" JSON) where
     wellformed =
-        Header "application/json"
+        [Header "application/json"]
 
 instance Malformed (Header "Content-Type" JSON) where
     malformed = first Header <$>
@@ -1005,7 +1007,7 @@ instance Malformed (Header "Content-Type" JSON) where
 
 instance Wellformed (Header "Content-Type" OctetStream) where
     wellformed =
-        Header "application/octet-stream"
+        [Header "application/octet-stream"]
 
 instance Malformed (Header "Content-Type" OctetStream) where
     malformed = first Header <$>
@@ -1016,7 +1018,7 @@ instance Malformed (Header "Content-Type" OctetStream) where
 
 instance Wellformed (Header "Accept" JSON) where
     wellformed =
-        Header "application/json"
+        [Header "application/json"]
 
 instance Malformed (Header "Accept" JSON) where
     malformed = first Header <$>

lib/core/test/unit/Cardano/Wallet/ApiSpec.hs

@@ -218,31 +218,38 @@ instance (GenericApiSpec a, GenericApiSpec b) => GenericApiSpec (a :<|> b) where
 instance GenericApiSpec Request where
     gSpec _ _ = pure ()
 
+instance GenericApiSpec a => GenericApiSpec [a] where
+    gSpec xs toSpec = foldr (\x y -> gSpec x toSpec >> y) (pure ()) xs
+
 instance
     ( Typeable a, Malformed (PathParam a)
-    ) => GenericApiSpec (PathParam a -> Request)
+    ) => GenericApiSpec (PathParam a -> [Request])
   where
-    gSpec toRequest toSpec = toSpec $
-        SomeTest (Proxy @a) (first toRequest <$> malformed @(PathParam a))
+    gSpec toRequest toSpec = do
+        let tests :: [[(Request, ExpectedError)]]
+            tests = fmap (\(xs, e) -> fmap (,e) xs)
+                (first toRequest <$> malformed @(PathParam a))
+        forM_ tests (toSpec . SomeTest (Proxy @a))
 
 instance
     ( Typeable a, Wellformed (PathParam a)
-    , GenericApiSpec (PathParam a -> Request)
+    , GenericApiSpec (PathParam a -> [Request])
     , Wellformed (PathParam b)
-    , GenericApiSpec (PathParam b -> Request)
-    ) => GenericApiSpec (PathParam a -> PathParam b -> Request)
+    , GenericApiSpec (PathParam b -> [Request])
+    ) => GenericApiSpec (PathParam a -> PathParam b -> [Request])
   where
     gSpec toRequest toSpec = do
-        gSpec (toRequest wellformed) toSpec
-        gSpec (`toRequest` wellformed) toSpec
+        forM_ wellformed $ \w -> gSpec (toRequest w) toSpec
+        forM_ wellformed $ \w -> gSpec (`toRequest` w) toSpec
 
 instance
     ( Typeable a, Malformed (BodyParam a)
-    ) => GenericApiSpec (BodyParam a -> IO Request)
+    ) => GenericApiSpec (BodyParam a -> IO [Request])
   where
     gSpec toRequest toSpec = do
-        let tests = first toRequest <$> malformed @(BodyParam a)
-        toSpec . SomeTest (Proxy @a) =<< traverseLeft runIO tests
+        let tests :: [(IO [Request], ExpectedError)]
+            tests = first toRequest <$> malformed @(BodyParam a)
+        toSpec . SomeTest (Proxy @a) . distributeFirst =<< traverseLeft runIO tests
       where
         -- e.g. [IO Request, ExpectedError] -> IO [Request, ExpectedError]
         traverseLeft
@@ -255,21 +262,25 @@ instance
     ( KnownSymbol h
     , Typeable ct
     , Malformed (Header h ct)
-    ) => GenericApiSpec (Header h ct -> Request)
+    ) => GenericApiSpec (Header h ct -> [Request])
   where
-    gSpec toRequest toSpec = toSpec $
-        SomeTest (Proxy @h) (first toRequest <$> malformed @(Header h ct))
+    gSpec toRequest toSpec = do
+        let tests :: [([Request], ExpectedError)]
+            tests = first toRequest <$> malformed @(Header h ct)
+        toSpec . SomeTest (Proxy @h) . distributeFirst $ tests
 
 instance
-    ( Typeable ct0, KnownSymbol h0, Wellformed (Header h0 ct0)
-    , GenericApiSpec (Header h0 ct0 -> Request)
+    ( Typeable ct0
+    , KnownSymbol h0
+    , Wellformed (Header h0 ct0)
     , Wellformed (Header h1 ct1)
-    , GenericApiSpec (Header h1 ct1 -> Request)
-    ) => GenericApiSpec (Header h0 ct0 -> Header h1 ct1 -> Request)
+    , GenericApiSpec (Header h0 ct0 -> [Request])
+    , GenericApiSpec (Header h1 ct1 -> [Request])
+    ) => GenericApiSpec (Header h0 ct0 -> Header h1 ct1 -> [Request])
   where
     gSpec toRequest toSpec = do
-        gSpec (toRequest wellformed) toSpec
-        gSpec (`toRequest` wellformed) toSpec
+        forM_ wellformed $ \w -> gSpec (toRequest w) toSpec
+        forM_ wellformed $ \w -> gSpec (`toRequest` w) toSpec
 
 instance GenericApiSpec (Map [Text] [Method])
   where
@@ -417,63 +428,66 @@ instance
             }
         ]
 
-    type MkPathRequest (Verb m s '[ct] a) = Request
+    type MkPathRequest (Verb m s '[ct] a) = [Request]
     gEveryPathParam _ req =
-        req { requestMethod = reflectMethod (Proxy @m) }
+        [req { requestMethod = reflectMethod (Proxy @m) }]
 
-    type MkBodyRequest (Verb m s '[ct] a) = Request
+    type MkBodyRequest (Verb m s '[ct] a) = [Request]
     gEveryBodyParam _ req =
-        req { requestMethod = reflectMethod (Proxy @m) }
+        [req { requestMethod = reflectMethod (Proxy @m) }]
 
-    type MkHeaderRequest (Verb m s '[ct] a) = Header "Accept" ct -> Request
+    type MkHeaderRequest (Verb m s '[ct] a) = Header "Accept" ct -> [Request]
     gEveryHeader _ req (Header h) =
-        req { requestMethod = reflectMethod $ Proxy @m
-            , requestHeaders = requestHeaders req ++ [ (hAccept, h) ]
-            }
+        [req { requestMethod = reflectMethod $ Proxy @m
+             , requestHeaders = requestHeaders req ++ [ (hAccept, h) ]
+             }
+        ]
+
+
 instance
     ( ReflectMethod m
     ) => GEveryEndpoints (NoContentVerb (m :: StdMethod))
   where
     gEveryEndpoint _ =
         [defaultRequest { requestMethod = reflectMethod (Proxy @m) }]
 
-    type MkPathRequest (NoContentVerb m) = Request
+    type MkPathRequest (NoContentVerb m) = [Request]
     gEveryPathParam _ req =
-        req { requestMethod = reflectMethod (Proxy @m) }
+        [req { requestMethod = reflectMethod (Proxy @m) }]
 
-    type MkBodyRequest (NoContentVerb m) = Request
+    type MkBodyRequest (NoContentVerb m) = [Request]
     gEveryBodyParam _ req =
-        req { requestMethod = reflectMethod (Proxy @m) }
+        [req { requestMethod = reflectMethod (Proxy @m) }]
 
-    type MkHeaderRequest (NoContentVerb m) = Request
+    type MkHeaderRequest (NoContentVerb m) = [Request]
     gEveryHeader _ req =
-        req { requestMethod = reflectMethod (Proxy @m) }
+        [req { requestMethod = reflectMethod (Proxy @m) }]
 
 instance
     ( Wellformed (PathParam t)
     , GEveryEndpoints sub
     ) => GEveryEndpoints (Capture p t :> sub)
   where
     gEveryEndpoint _ =
-        addPathFragment t <$> gEveryEndpoint (Proxy @sub)
+        concatMap (\t -> addPathFragment t <$> gEveryEndpoint (Proxy @sub)) ts
       where
-        t = wellformed :: PathParam t
+        ts = wellformed :: [PathParam t]
 
     type MkPathRequest (Capture p t :> sub) = PathParam t -> MkPathRequest sub
     gEveryPathParam _ req t =
         gEveryPathParam (Proxy @sub) (addPathFragment t req)
 
-    type MkBodyRequest (Capture p t :> sub) = MkBodyRequest sub
+    type MkBodyRequest (Capture p t :> sub) = [MkBodyRequest sub]
     gEveryBodyParam _ req =
-        gEveryBodyParam (Proxy @sub) (addPathFragment t req)
+        gEveryBodyParam (Proxy @sub) . (`addPathFragment` req) <$> ts
       where
-        t = wellformed :: PathParam t
+        ts = wellformed :: [PathParam t]
 
-    type MkHeaderRequest (Capture p t :> sub) = MkHeaderRequest sub
+    type MkHeaderRequest (Capture p t :> sub) = [MkHeaderRequest sub]
     gEveryHeader _ req =
-        gEveryHeader (Proxy @sub) (addPathFragment t req)
+        gEveryHeader (Proxy @sub) . (`addPathFragment` req) <$> ts
       where
-        t = wellformed :: PathParam t
+        ts = wellformed :: [PathParam t]
 
 instance
     ( KnownSymbol s
@@ -565,6 +579,9 @@ instance
 -- Helpers
 --
 
+distributeFirst :: [([x], y)] -> [(x, y)]
+distributeFirst zs = [(x, y) | (xs, y) <- zs, x <- xs]
+
 addPathFragment :: PathParam t -> Request -> Request
 addPathFragment (PathParam fragment) req = req
     { pathInfo = pathInfo req ++ [fragment] }