Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Jump to bottom

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

Merged
merged 2 commits into from
Sep 1, 2020
Merged

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

Show file tree
Hide file tree
Changes from 1 commit
Commits
Show all changes
2 commits
Select commit Hold shift + click to select a range
67e684a
[ADP-416] Allow multiple well-formed values in "/Cardano.Wallet.Api/"…
hasufell Aug 27, 2020
9b7c617
align naming and re-use util functions for consistency
KtorZ Sep 1, 2020
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
20 changes: 11 additions & 9 deletions lib/core/test/unit/Cardano/Wallet/Api/Malformed.hs
View file
Open in desktop
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"
Copy link
Contributor Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

This is where the bech32 wellformed would go

]

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
Open in desktop
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
Copy link
Member

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I mistakenly expected a foldl here but no, foldr is right because of the composition of actions done as such 👍


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))
hasufell marked this conversation as resolved.
Show resolved Hide resolved
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
Copy link
Member

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

👍

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 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))
Copy link
Member

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I find the insideOut version with the list comprehension much more readable

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) }]


Copy link
Member

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Suggested change

https://github.com/input-output-hk/adrestia/wiki/Coding-Standards#use-only-a-single-blank-line-between-top-level-definitions

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]
Copy link
Member

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Would be better to stick to a consistent naming like ts before. These things are actually the same thing so they ought to have the same name.


instance
( KnownSymbol s
Expand Down