From 601694a30e15a6fb34e3dc6081b1ed67fa3ca992 Mon Sep 17 00:00:00 2001 From: Mark Wotton Date: Thu, 18 Mar 2021 12:44:43 -0400 Subject: [PATCH] queryparams --- package.yaml | 1 + roboservant.cabal | 6 +++- src/Roboservant/Client.hs | 21 ++++++++---- src/Roboservant/Direct.hs | 7 ++-- src/Roboservant/Types/BuildFrom.hs | 8 +++-- src/Roboservant/Types/ReifiedApi.hs | 39 ++++++++++++++++++++-- src/Roboservant/Types/ReifiedApi/Server.hs | 5 +-- test/Nested.hs | 2 +- test/QueryParams.hs | 15 +++++++++ test/Spec.hs | 13 +++++--- test/Valid.hs | 2 +- 11 files changed, 95 insertions(+), 24 deletions(-) create mode 100644 test/QueryParams.hs diff --git a/package.yaml b/package.yaml index 6beb6e4..ca0eef9 100644 --- a/package.yaml +++ b/package.yaml @@ -19,6 +19,7 @@ dependencies: - containers - random - hashable +- http-types - lifted-base - monad-control - mtl diff --git a/roboservant.cabal b/roboservant.cabal index c3fe651..1f31157 100644 --- a/roboservant.cabal +++ b/roboservant.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: 4c71b6b9460f4719791bb8e67f4a5398b807cd8d17c43dc69da806bb5ba9fb4b +-- hash: 596d33d4f2e29f15b48525514def52b101c9e89b6193275bd5c0a4c253de8d5c name: roboservant version: 0.1.0.2 @@ -50,6 +50,7 @@ library , dependent-map , dependent-sum , hashable + , http-types , lifted-base , monad-control , mtl @@ -86,6 +87,7 @@ test-suite example , hspec , hspec-core , http-client + , http-types , lifted-base , monad-control , mtl @@ -113,6 +115,7 @@ test-suite roboservant-test Nested Post Product + QueryParams Seeded UnsafeIO Valid @@ -133,6 +136,7 @@ test-suite roboservant-test , hspec-wai , http-api-data , http-client + , http-types , lifted-base , monad-control , mtl diff --git a/src/Roboservant/Client.hs b/src/Roboservant/Client.hs index 337f944..145ef07 100644 --- a/src/Roboservant/Client.hs +++ b/src/Roboservant/Client.hs @@ -11,7 +11,7 @@ {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} --- should all the NormalizeFunction instances be in one place? +-- should all the NormalizeFunction instances be in one place? {-# OPTIONS_GHC -fno-warn-orphans #-} module Roboservant.Client where @@ -27,13 +27,14 @@ import qualified Data.Vinyl.Curry as V import qualified Data.Text as T import Control.Monad.Reader import Data.Hashable +import Network.HTTP.Types.Status -- fuzz :: forall api. -- (FlattenServer api, ToReifiedApi (Endpoints api)) => -- Server api -> -- Config -> -- IO (Maybe Report) --- fuzz s = fuzz' (reifyServer s) +-- fuzz s = fuzz' (reifyServer s) -- -- todo: how do we pull reifyServer out? -- where reifyServer :: (FlattenServer api, ToReifiedApi (Endpoints api)) -- => Server api -> ReifiedApi @@ -80,7 +81,7 @@ instance foo :: V.Curried (EndpointArgs endpoint) (ReaderT ClientEnv IO ResultType) -> V.Curried (EndpointArgs endpoint) (IO ResultType) foo = mapCurried @(EndpointArgs endpoint) @(ReaderT ClientEnv IO ResultType) (`runReaderT` clientEnv) - + mapCurried :: forall ts a b. V.RecordCurry' ts => (a -> b) -> V.Curried ts a -> V.Curried ts b mapCurried f g = V.rcurry' @ts $ f . V.runcurry' g @@ -90,10 +91,15 @@ type ResultType = Either InteractionError (NonEmpty (Dynamic,Int)) instance (Typeable x, Hashable x, Breakdown x) => NormalizeFunction (ClientM x) where type Normal (ClientM x) = ReaderT ClientEnv IO (Either InteractionError (NonEmpty (Dynamic,Int))) - normalize c = ReaderT $ - fmap (bimap (InteractionError . T.pack . show) breakdown) . runClientM c --- + normalize c = ReaderT $ + fmap (bimap renderClientError breakdown) . runClientM c + where + renderClientError :: ClientError -> InteractionError + renderClientError err = case err of + FailureResponse _ (Response{responseStatusCode}) -> InteractionError textual (responseStatusCode == status500) + _ -> InteractionError textual True + where textual = T.pack $ show err instance ToReifiedClientApi '[] where toReifiedClientApi NoClientEndpoints _ _ = [] @@ -105,7 +111,7 @@ instance FlattenClient (endpoint :<|> api) where flattenClient (endpoint :<|> c) = endpoint `AClientEndpoint` flattenClient @api c - + instance ( Endpoints api ~ '[api] @@ -114,6 +120,7 @@ instance where flattenClient c = c `AClientEndpoint` NoClientEndpoints + instance FlattenClient (Verb method statusCode contentTypes responseType) where flattenClient c = c `AClientEndpoint` NoClientEndpoints diff --git a/src/Roboservant/Direct.hs b/src/Roboservant/Direct.hs index 4eed837..47e5808 100644 --- a/src/Roboservant/Direct.hs +++ b/src/Roboservant/Direct.hs @@ -56,7 +56,7 @@ import GHC.Generics ((:*:) (..)) import Roboservant.Types ( ApiOffset (..), Argument (..), - InteractionError, + InteractionError(..), Provenance (..), ReifiedApi, ReifiedEndpoint (..), @@ -242,7 +242,10 @@ fuzz' reifiedApi Config {..} = handle (pure . Just . formatException) $ do execute fuzzop func args = do (liftIO . logInfo . show . (fuzzop,) . stash) =<< get liftIO (V.runcurry' func argVals) >>= \case - Left (e::InteractionError) -> throw e + Left (e::InteractionError) -> + if fatalError e + then throw e + else pure () Right (dyn :: NEL.NonEmpty (Dynamic, Int)) -> do modify' ( \fs@FuzzState {..} -> diff --git a/src/Roboservant/Types/BuildFrom.hs b/src/Roboservant/Types/BuildFrom.hs index c3cc5b8..50f0403 100644 --- a/src/Roboservant/Types/BuildFrom.hs +++ b/src/Roboservant/Types/BuildFrom.hs @@ -12,6 +12,7 @@ module Roboservant.Types.BuildFrom where +import Data.List(nub) import qualified Data.Dependent.Map as DM import Data.Hashable import qualified Data.IntSet as IntSet @@ -59,11 +60,12 @@ deriving via (Compound (Maybe x)) instance (Typeable x, Hashable x, BuildFrom x) -- this isn't wonderful, but we need a hand-rolled instance for recursive datatypes right now. -- with an arbitrary-ish interface, we could use a size parameter, rng access etc. -instance (BuildFrom x) => BuildFrom [x] where - extras stash = map (\xs -> (concatMap fst xs, map snd xs)) $ notpowerset $ extras @x stash +instance (Eq x, BuildFrom x) => BuildFrom [x] where + extras stash = + nub $ map (\xs -> (concatMap fst xs, map snd xs)) $ notpowerset $ buildFrom' @x stash where -- powerset creates way too much stuff. something better here eventually. - notpowerset xs = xs:map pure xs + notpowerset xs = []:xs:map pure xs instance (Hashable x, Typeable x, Generic x, GBuildFrom (Rep x)) => BuildFrom (Compound (x :: Type)) where diff --git a/src/Roboservant/Types/ReifiedApi.hs b/src/Roboservant/Types/ReifiedApi.hs index 95678ef..a395e8e 100644 --- a/src/Roboservant/Types/ReifiedApi.hs +++ b/src/Roboservant/Types/ReifiedApi.hs @@ -28,7 +28,7 @@ import GHC.Generics ((:*:)(..)) import Roboservant.Types.Internal import Roboservant.Types.Breakdown import Roboservant.Types.BuildFrom -import Data.Kind +import Data.Kind(Type) import Servant import Servant.API.Modifiers(FoldRequired,FoldLenient) import GHC.TypeLits (Symbol) @@ -52,6 +52,9 @@ data ReifiedEndpoint = forall as. (V.RecordToList as, V.RMap as) => ReifiedEndpo , reEndpointFunc :: V.Curried as (IO (Either InteractionError (NonEmpty (Dynamic,Int)))) } +instance Show ReifiedEndpoint where + show _ = "lol" + class ( V.RecordToList (EndpointArgs endpoint) , V.RMap (EndpointArgs endpoint) ) => ToReifiedEndpoint (endpoint :: *) where @@ -64,13 +67,15 @@ class ( V.RecordToList (EndpointArgs endpoint) tagType :: Typeable a => f a -> TypedF f a tagType = (R.typeRep :*:) -newtype InteractionError = InteractionError T.Text +data InteractionError = InteractionError + { errorMessage :: T.Text + , fatalError :: Bool + } deriving Show instance Exception InteractionError - instance (Typeable responseType, Breakdown responseType) => ToReifiedEndpoint (Verb method statusCode contentTypes responseType) @@ -87,6 +92,16 @@ instance type EndpointRes ((x :: Symbol) :> endpoint) = EndpointRes endpoint reifiedEndpointArguments = reifiedEndpointArguments @endpoint +instance + (ToReifiedEndpoint endpoint) => + ToReifiedEndpoint (RemoteHost :> endpoint) + where + type EndpointArgs (RemoteHost :> endpoint) = EndpointArgs endpoint + type EndpointRes (RemoteHost :> endpoint) = EndpointRes endpoint + reifiedEndpointArguments = reifiedEndpointArguments @endpoint + + + instance (ToReifiedEndpoint endpoint) => ToReifiedEndpoint (Description s :> endpoint) @@ -129,6 +144,24 @@ instance tagType (Argument (buildFrom @(IfRequiredLenient T.Text mods paramType))) V.:& reifiedEndpointArguments @endpoint + +instance + ( BuildFrom paramType + , ToReifiedEndpoint endpoint + , Show paramType + , Eq paramType + ) => + ToReifiedEndpoint (QueryParams name paramType :> endpoint) + where + type EndpointArgs (QueryParams name paramType :> endpoint) = [paramType] ': EndpointArgs endpoint + type EndpointRes (QueryParams name paramType :> endpoint) = EndpointRes endpoint + reifiedEndpointArguments = + tagType (Argument (buildFrom @[paramType])) + V.:& reifiedEndpointArguments @endpoint + + + + instance ( BuildFrom (IfRequiredLenient T.Text mods headerType) , ToReifiedEndpoint endpoint diff --git a/src/Roboservant/Types/ReifiedApi/Server.hs b/src/Roboservant/Types/ReifiedApi/Server.hs index 08c6764..df041bb 100644 --- a/src/Roboservant/Types/ReifiedApi/Server.hs +++ b/src/Roboservant/Types/ReifiedApi/Server.hs @@ -66,7 +66,8 @@ instance (Typeable x, Hashable x, Breakdown x) => NormalizeFunction (Handler x) where -- | TODO improve this renderServerError :: ServerError -> InteractionError - renderServerError = InteractionError . T.pack . show + renderServerError s = InteractionError (T.pack $ show s) (errHTTPCode serverError == 500) + Right x -> pure $ Right $ breakdown x @@ -91,7 +92,7 @@ instance FlattenServer (endpoint :<|> api) where flattenServer (endpoint :<|> server) = endpoint `AnEndpoint` flattenServer @api server - + instance ( Endpoints api ~ '[api] diff --git a/test/Nested.hs b/test/Nested.hs index 9f17d0d..2f6be69 100644 --- a/test/Nested.hs +++ b/test/Nested.hs @@ -11,7 +11,7 @@ import Servant import Servant.API.Flatten type Api = - ( "one" :> Post '[JSON] Int + ( "one" :> Summary "foo" :> Post '[JSON] Int :<|> "two" :> Post '[JSON] Int ) :<|> ( "three" :> Post '[JSON] Int diff --git a/test/QueryParams.hs b/test/QueryParams.hs new file mode 100644 index 0000000..1207a11 --- /dev/null +++ b/test/QueryParams.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeOperators #-} + +module QueryParams where + +import Servant + +type Api = QueryParams "ints" Int :> Get '[JSON] [Int] + +server :: Server Api +server = pure diff --git a/test/Spec.hs b/test/Spec.hs index c6db160..f4431a0 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -22,6 +22,7 @@ import qualified Headers import qualified Nested import qualified Post import qualified Product +import qualified QueryParams import qualified Roboservant as R import qualified Roboservant.Server as RS import qualified Roboservant.Client as RC @@ -41,7 +42,7 @@ main :: IO () main = hspec spec fuzzBoth - :: forall a . + :: forall a . (R.ToReifiedApi (Endpoints a), HasServer a '[], RS.FlattenServer a, RC.ToReifiedClientApi (Endpoints a), RC.FlattenClient a, HasClient ClientM a) => String -> Server a -> R.Config -> (Maybe R.Report -> IO ()) -> Spec @@ -76,22 +77,26 @@ spec = do describe "posted body" $ do fuzzBoth @Post.Api "passes a coverage check using a posted body" Post.server R.defaultConfig {R.coverageThreshold = 0.99} (`shouldSatisfy` isNothing) - + describe "seeded" $ do let res = Seeded.Seed 1 shouldFail $ fuzzBoth @Seeded.Api "finds an error using information passed in" Seeded.server (R.defaultConfig {R.seed = [(toDyn res, hash res)]}) (`shouldSatisfy` isNothing) - + describe "Foo" $ do fuzzBoth @Foo.Api "finds an error in a basic app" Foo.server R.defaultConfig (`shouldSatisfy` serverFailure) + describe "QueryParams" $ do + fuzzBoth @QueryParams.Api "can handle query params" QueryParams.server R.defaultConfig { R.seed = [R.hashedDyn (12::Int)] } + (`shouldSatisfy` isNothing) + describe "BuildFrom" $ do describe "headers (and sum types)" $ do fuzzBoth @Headers.Api "should find a failure that's dependent on using header info" Headers.server R.defaultConfig (`shouldSatisfy` serverFailure) describe "product types" $ do - fuzzBoth @Product.Api "should find a failure that's dependent on creating a product" Product.server + fuzzBoth @Product.Api "should find a failure that's dependent on creating a product" Product.server R.defaultConfig {R.seed = [R.hashedDyn 'a', R.hashedDyn (1 :: Int)]} (`shouldSatisfy` serverFailure) describe "Breakdown" $ do diff --git a/test/Valid.hs b/test/Valid.hs index d5638f1..c55b777 100644 --- a/test/Valid.hs +++ b/test/Valid.hs @@ -21,7 +21,7 @@ data Routes route = Routes { getInt :: route - :- Get '[JSON] Int, + :- Summary "i'm a summary!" :> Get '[JSON] Int, captureIt :: route :- Capture "void" Void :> Get '[JSON] ()