Skip to content

Commit

Permalink
[ADP-416] Allow multiple well-formed values in "/Cardano.Wallet.Api/"…
Browse files Browse the repository at this point in the history 
… specs
  • Loading branch information
@hasufell
hasufell committed Aug 31, 2020
1 parent b35d737 commit a9d46b3
Show file tree
Hide file tree
Showing 2 changed files with 69 additions and 52 deletions.
20 changes: 11 additions & 9 deletions lib/core/test/unit/Cardano/Wallet/Api/Malformed.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -117,7 +117,7 @@ newtype Header (headerName :: Symbol) (contentType :: *) =
--

class Wellformed t where
wellformed :: t
wellformed :: [t]

class Malformed t where
malformed :: [(t, ExpectedError)]
Expand All @@ -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 <$>
Expand All @@ -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 <$>
Expand All @@ -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 <$>
Expand All @@ -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 = []
Expand Down Expand Up @@ -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 <$>
Expand All @@ -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 <$>
Expand All @@ -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 <$>
Expand Down
101 changes: 58 additions & 43 deletions lib/core/test/unit/Cardano/Wallet/ApiSpec.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -72,7 +72,7 @@ import Data.Function
import Data.IORef
( atomicModifyIORef, newIORef )
import Data.List
( (\\) )
( foldl', (\\) )
import Data.Map.Strict
( Map )
import Data.Maybe
Expand Down Expand Up @@ -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
Expand All @@ -251,25 +258,32 @@ instance
traverseLeft fn xs =
fmap swap <$> traverse (traverse fn) (swap <$> xs)

insideOut :: [([x], y)] -> [(x, y)]
insideOut = foldl' (\y (xs, b) -> y ++ fmap (, b) 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
Expand Down Expand Up @@ -417,63 +431,64 @@ 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)
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
Expand Down

0 comments on commit a9d46b3

Please sign in to comment.