From 67e684ae5e71e293ebeab5cfd611f850ead595d2 Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Thu, 27 Aug 2020 20:01:03 +0200 Subject: [PATCH 1/2] [ADP-416] Allow multiple well-formed values in "/Cardano.Wallet.Api/" specs --- .../test/unit/Cardano/Wallet/Api/Malformed.hs | 20 ++-- lib/core/test/unit/Cardano/Wallet/ApiSpec.hs | 101 ++++++++++-------- 2 files changed, 69 insertions(+), 52 deletions(-) diff --git a/lib/core/test/unit/Cardano/Wallet/Api/Malformed.hs b/lib/core/test/unit/Cardano/Wallet/Api/Malformed.hs index 7af99d3be70..b1f14c94d88 100644 --- a/lib/core/test/unit/Cardano/Wallet/Api/Malformed.hs +++ b/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 <$> diff --git a/lib/core/test/unit/Cardano/Wallet/ApiSpec.hs b/lib/core/test/unit/Cardano/Wallet/ApiSpec.hs index 33517703c6c..d7a9d5051dc 100644 --- a/lib/core/test/unit/Cardano/Wallet/ApiSpec.hs +++ b/lib/core/test/unit/Cardano/Wallet/ApiSpec.hs @@ -72,7 +72,7 @@ import Data.Function import Data.IORef ( atomicModifyIORef, newIORef ) import Data.List - ( (\\) ) + ( foldl', (\\) ) import Data.Map.Strict ( Map ) import Data.Maybe @@ -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) . insideOut =<< traverseLeft runIO tests where -- e.g. [IO Request, ExpectedError] -> IO [Request, ExpectedError] traverseLeft @@ -251,25 +258,32 @@ instance traverseLeft fn xs = fmap swap <$> traverse (traverse fn) (swap <$> xs) + insideOut :: [([x], y)] -> [(x, y)] + insideOut zs = [(x, y) | (xs, y) <- zs, x <- xs] + 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 = fmap (\(xs, e) -> fmap (,e) xs) + (first toRequest <$> malformed @(Header h ct)) + forM_ tests (toSpec . SomeTest (Proxy @h)) 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,19 +431,19 @@ 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)) @@ -437,17 +451,18 @@ instance 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) @@ -455,25 +470,25 @@ instance ) => 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) + fmap (\t' -> gEveryBodyParam (Proxy @sub) (addPathFragment t' req)) t where - t = wellformed :: PathParam t + t = 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) + fmap (\t' -> gEveryHeader (Proxy @sub) (addPathFragment t' req)) t where - t = wellformed :: PathParam t + t = wellformed :: [PathParam t] instance ( KnownSymbol s From 9b7c617fc228d21a77721fc9196495262451f978 Mon Sep 17 00:00:00 2001 From: KtorZ Date: Tue, 1 Sep 2020 12:25:19 +0200 Subject: [PATCH 2/2] align naming and re-use util functions for consistency --- lib/core/test/unit/Cardano/Wallet/ApiSpec.hs | 30 +++++++++++--------- 1 file changed, 16 insertions(+), 14 deletions(-) diff --git a/lib/core/test/unit/Cardano/Wallet/ApiSpec.hs b/lib/core/test/unit/Cardano/Wallet/ApiSpec.hs index d7a9d5051dc..d2f21c11ddb 100644 --- a/lib/core/test/unit/Cardano/Wallet/ApiSpec.hs +++ b/lib/core/test/unit/Cardano/Wallet/ApiSpec.hs @@ -72,7 +72,7 @@ import Data.Function import Data.IORef ( atomicModifyIORef, newIORef ) import Data.List - ( foldl', (\\) ) + ( (\\) ) import Data.Map.Strict ( Map ) import Data.Maybe @@ -249,7 +249,7 @@ instance gSpec toRequest toSpec = do let tests :: [(IO [Request], ExpectedError)] tests = first toRequest <$> malformed @(BodyParam a) - toSpec . SomeTest (Proxy @a) . insideOut =<< traverseLeft runIO tests + toSpec . SomeTest (Proxy @a) . distributeFirst =<< traverseLeft runIO tests where -- e.g. [IO Request, ExpectedError] -> IO [Request, ExpectedError] traverseLeft @@ -258,9 +258,6 @@ instance traverseLeft fn xs = fmap swap <$> traverse (traverse fn) (swap <$> xs) - insideOut :: [([x], y)] -> [(x, y)] - insideOut zs = [(x, y) | (xs, y) <- zs, x <- xs] - instance ( KnownSymbol h , Typeable ct @@ -268,9 +265,9 @@ instance ) => GenericApiSpec (Header h ct -> [Request]) where gSpec toRequest toSpec = do - let tests = fmap (\(xs, e) -> fmap (,e) xs) - (first toRequest <$> malformed @(Header h ct)) - forM_ tests (toSpec . SomeTest (Proxy @h)) + let tests :: [([Request], ExpectedError)] + tests = first toRequest <$> malformed @(Header h ct) + toSpec . SomeTest (Proxy @h) . distributeFirst $ tests instance ( Typeable ct0 @@ -443,7 +440,10 @@ instance gEveryHeader _ req (Header h) = [req { requestMethod = reflectMethod $ Proxy @m , requestHeaders = requestHeaders req ++ [ (hAccept, h) ] - }] + } + ] + + instance ( ReflectMethod m ) => GEveryEndpoints (NoContentVerb (m :: StdMethod)) @@ -463,7 +463,6 @@ instance gEveryHeader _ req = [req { requestMethod = reflectMethod (Proxy @m) }] - instance ( Wellformed (PathParam t) , GEveryEndpoints sub @@ -480,15 +479,15 @@ instance type MkBodyRequest (Capture p t :> sub) = [MkBodyRequest sub] gEveryBodyParam _ req = - fmap (\t' -> gEveryBodyParam (Proxy @sub) (addPathFragment t' req)) t + gEveryBodyParam (Proxy @sub) . (`addPathFragment` req) <$> ts where - t = wellformed :: [PathParam t] + ts = wellformed :: [PathParam t] type MkHeaderRequest (Capture p t :> sub) = [MkHeaderRequest sub] gEveryHeader _ req = - fmap (\t' -> gEveryHeader (Proxy @sub) (addPathFragment t' req)) t + gEveryHeader (Proxy @sub) . (`addPathFragment` req) <$> ts where - t = wellformed :: [PathParam t] + ts = wellformed :: [PathParam t] instance ( KnownSymbol s @@ -580,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] }