601694a · roboservant · git.iko.soy

git.iko.soy/roboservant

queryparams

commit601694a30e15a6fb34e3dc6081b1ed67fa3ca992 authorMark Wotton <mwotton@gmail.com> dateThu 18 Mar 2021, 12:44 (6 years ago) parent1728c99

11 files changed+95−24

compare with master

unifiedsplit

package.yaml+1 roboservant.cabal+5−1 src/Roboservant/Client.hs+14−7 src/Roboservant/Direct.hs+5−2 src/Roboservant/Types/BuildFrom.hs+5−3 src/Roboservant/Types/ReifiedApi.hs+36−3 src/Roboservant/Types/ReifiedApi/Server.hs+3−2 test/Nested.hs+1−1 test/QueryParams.hs+15 test/Spec.hs+9−4 test/Valid.hs+1−1

package.yaml+1

@@ -19,6 +19,7 @@ dependencies:

1919- containers

2020- random

2121- hashable

22+- http-types

2223- lifted-base

2324- monad-control

2425- mtl

roboservant.cabal+5−1

@@ -4,7 +4,7 @@ cabal-version: 1.12

44--

55-- see: https://github.com/sol/hpack

66--

7−-- hash: 4c71b6b9460f4719791bb8e67f4a5398b807cd8d17c43dc69da806bb5ba9fb4b

7+-- hash: 596d33d4f2e29f15b48525514def52b101c9e89b6193275bd5c0a4c253de8d5c

99name: roboservant

1010version: 0.1.0.2

@@ -50,6 +50,7 @@ library

5050 , dependent-map

5151 , dependent-sum

5252 , hashable

53+ , http-types

5354 , lifted-base

5455 , monad-control

5556 , mtl

@@ -86,6 +87,7 @@ test-suite example

8687 , hspec

8788 , hspec-core

8889 , http-client

90+ , http-types

8991 , lifted-base

9092 , monad-control

9193 , mtl

@@ -113,6 +115,7 @@ test-suite roboservant-test

113115 Nested

114116 Post

115117 Product

118+ QueryParams

116119 Seeded

117120 UnsafeIO

118121 Valid

@@ -133,6 +136,7 @@ test-suite roboservant-test

133136 , hspec-wai

134137 , http-api-data

135138 , http-client

139+ , http-types

136140 , lifted-base

137141 , monad-control

138142 , mtl

src/Roboservant/Client.hs+14−7

@@ -11,7 +11,7 @@

1111{-# LANGUAGE UndecidableInstances #-}

1212{-# LANGUAGE TypeFamilies #-}

1313{-# LANGUAGE FlexibleContexts #-}

14−-- should all the NormalizeFunction instances be in one place?

14+-- should all the NormalizeFunction instances be in one place?

1515{-# OPTIONS_GHC -fno-warn-orphans #-}

1616module Roboservant.Client where

1717

@@ -27,13 +27,14 @@ import qualified Data.Vinyl.Curry as V

2727import qualified Data.Text as T

2828import Control.Monad.Reader

2929import Data.Hashable

30+import Network.HTTP.Types.Status

3031

3132-- fuzz :: forall api.

3233-- (FlattenServer api, ToReifiedApi (Endpoints api)) =>

3334-- Server api ->

3435-- Config ->

3536-- IO (Maybe Report)

36−-- fuzz s = fuzz' (reifyServer s)

37+-- fuzz s = fuzz' (reifyServer s)

3738-- -- todo: how do we pull reifyServer out?

3839-- where reifyServer :: (FlattenServer api, ToReifiedApi (Endpoints api))

3940-- => Server api -> ReifiedApi

@@ -80,7 +81,7 @@ instance

8081 foo :: V.Curried (EndpointArgs endpoint) (ReaderT ClientEnv IO ResultType)

8182 -> V.Curried (EndpointArgs endpoint) (IO ResultType)

8283 foo = mapCurried @(EndpointArgs endpoint) @(ReaderT ClientEnv IO ResultType) (`runReaderT` clientEnv)

83−

84+

8485mapCurried :: forall ts a b. V.RecordCurry' ts => (a -> b) -> V.Curried ts a -> V.Curried ts b

8586mapCurried f g = V.rcurry' @ts $ f . V.runcurry' g

8687

@@ -90,10 +91,15 @@ type ResultType = Either InteractionError (NonEmpty (Dynamic,Int))

9091

9192instance (Typeable x, Hashable x, Breakdown x) => NormalizeFunction (ClientM x) where

9293 type Normal (ClientM x) = ReaderT ClientEnv IO (Either InteractionError (NonEmpty (Dynamic,Int)))

93− normalize c = ReaderT $

94− fmap (bimap (InteractionError . T.pack . show) breakdown) . runClientM c

95−--

94+ normalize c = ReaderT $

95+ fmap (bimap renderClientError breakdown) . runClientM c

96+ where

97+ renderClientError :: ClientError -> InteractionError

98+ renderClientError err = case err of

99+ FailureResponse _ (Response{responseStatusCode}) -> InteractionError textual (responseStatusCode == status500)

100+ _ -> InteractionError textual True

96101

102+ where textual = T.pack $ show err

97103instance ToReifiedClientApi '[] where

98104 toReifiedClientApi NoClientEndpoints _ _ = []

99105

@@ -105,7 +111,7 @@ instance

105111 FlattenClient (endpoint :<|> api)

106112 where

107113 flattenClient (endpoint :<|> c) = endpoint `AClientEndpoint` flattenClient @api c

108−

114+

109115instance

110116 (

111117 Endpoints api ~ '[api]

@@ -114,6 +120,7 @@ instance

114120 where

115121 flattenClient c = c `AClientEndpoint` NoClientEndpoints

116122

123+

117124instance FlattenClient (Verb method statusCode contentTypes responseType)

118125 where

119126 flattenClient c = c `AClientEndpoint` NoClientEndpoints

src/Roboservant/Direct.hs+5−2

@@ -56,7 +56,7 @@ import GHC.Generics ((:*:) (..))

5656import Roboservant.Types

5757 ( ApiOffset (..),

5858 Argument (..),

59− InteractionError,

59+ InteractionError(..),

6060 Provenance (..),

6161 ReifiedApi,

6262 ReifiedEndpoint (..),

@@ -242,7 +242,10 @@ fuzz' reifiedApi Config {..} = handle (pure . Just . formatException) $ do

242242 execute fuzzop func args = do

243243 (liftIO . logInfo . show . (fuzzop,) . stash) =<< get

244244 liftIO (V.runcurry' func argVals) >>= \case

245− Left (e::InteractionError) -> throw e

245+ Left (e::InteractionError) ->

246+ if fatalError e

247+ then throw e

248+ else pure ()

246249 Right (dyn :: NEL.NonEmpty (Dynamic, Int)) -> do

247250 modify'

248251 ( \fs@FuzzState {..} ->

src/Roboservant/Types/BuildFrom.hs+5−3

@@ -12,6 +12,7 @@

1212

1313module Roboservant.Types.BuildFrom where

1414

15+import Data.List(nub)

1516import qualified Data.Dependent.Map as DM

1617import Data.Hashable

1718import qualified Data.IntSet as IntSet

@@ -59,11 +60,12 @@ deriving via (Compound (Maybe x)) instance (Typeable x, Hashable x, BuildFrom x)

5960

6061-- this isn't wonderful, but we need a hand-rolled instance for recursive datatypes right now.

6162-- with an arbitrary-ish interface, we could use a size parameter, rng access etc.

62−instance (BuildFrom x) => BuildFrom [x] where

63− extras stash = map (\xs -> (concatMap fst xs, map snd xs)) $ notpowerset $ extras @x stash

63+instance (Eq x, BuildFrom x) => BuildFrom [x] where

64+ extras stash =

65+ nub $ map (\xs -> (concatMap fst xs, map snd xs)) $ notpowerset $ buildFrom' @x stash

6466 where

6567 -- powerset creates way too much stuff. something better here eventually.

66− notpowerset xs = xs:map pure xs

68+ notpowerset xs = []:xs:map pure xs

6769

6870

6971instance (Hashable x, Typeable x, Generic x, GBuildFrom (Rep x)) => BuildFrom (Compound (x :: Type)) where

src/Roboservant/Types/ReifiedApi.hs+36−3

@@ -28,7 +28,7 @@ import GHC.Generics ((:*:)(..))

2828import Roboservant.Types.Internal

2929import Roboservant.Types.Breakdown

3030import Roboservant.Types.BuildFrom

31−import Data.Kind

31+import Data.Kind(Type)

3232import Servant

3333import Servant.API.Modifiers(FoldRequired,FoldLenient)

3434import GHC.TypeLits (Symbol)

@@ -52,6 +52,9 @@ data ReifiedEndpoint = forall as. (V.RecordToList as, V.RMap as) => ReifiedEndpo

5252 , reEndpointFunc :: V.Curried as (IO (Either InteractionError (NonEmpty (Dynamic,Int))))

5353 }

5454

55+instance Show ReifiedEndpoint where

56+ show _ = "lol"

57+

5558class ( V.RecordToList (EndpointArgs endpoint)

5659 , V.RMap (EndpointArgs endpoint)

5760 ) => ToReifiedEndpoint (endpoint :: *) where

@@ -64,13 +67,15 @@ class ( V.RecordToList (EndpointArgs endpoint)

6467tagType :: Typeable a => f a -> TypedF f a

6568tagType = (R.typeRep :*:)

6669

67−newtype InteractionError = InteractionError T.Text

70+data InteractionError = InteractionError

71+ { errorMessage :: T.Text

72+ , fatalError :: Bool

73+ }

6874 deriving Show

6975instance Exception InteractionError

7076

7177

7278

73−

7479instance

7580 (Typeable responseType, Breakdown responseType) =>

7681 ToReifiedEndpoint (Verb method statusCode contentTypes responseType)

@@ -87,6 +92,16 @@ instance

8792 type EndpointRes ((x :: Symbol) :> endpoint) = EndpointRes endpoint

8893 reifiedEndpointArguments = reifiedEndpointArguments @endpoint

8994

95+instance

96+ (ToReifiedEndpoint endpoint) =>

97+ ToReifiedEndpoint (RemoteHost :> endpoint)

98+ where

99+ type EndpointArgs (RemoteHost :> endpoint) = EndpointArgs endpoint

100+ type EndpointRes (RemoteHost :> endpoint) = EndpointRes endpoint

101+ reifiedEndpointArguments = reifiedEndpointArguments @endpoint

102+

103+

104+

90105instance

91106 (ToReifiedEndpoint endpoint) =>

92107 ToReifiedEndpoint (Description s :> endpoint)

@@ -129,6 +144,24 @@ instance

129144 tagType (Argument (buildFrom @(IfRequiredLenient T.Text mods paramType)))

130145 V.:& reifiedEndpointArguments @endpoint

131146

147+

148+instance

149+ ( BuildFrom paramType

150+ , ToReifiedEndpoint endpoint

151+ , Show paramType

152+ , Eq paramType

153+ ) =>

154+ ToReifiedEndpoint (QueryParams name paramType :> endpoint)

155+ where

156+ type EndpointArgs (QueryParams name paramType :> endpoint) = [paramType] ': EndpointArgs endpoint

157+ type EndpointRes (QueryParams name paramType :> endpoint) = EndpointRes endpoint

158+ reifiedEndpointArguments =

159+ tagType (Argument (buildFrom @[paramType]))

160+ V.:& reifiedEndpointArguments @endpoint

161+

162+

163+

164+

132165instance

133166 ( BuildFrom (IfRequiredLenient T.Text mods headerType)

134167 , ToReifiedEndpoint endpoint

src/Roboservant/Types/ReifiedApi/Server.hs+3−2

@@ -66,7 +66,8 @@ instance (Typeable x, Hashable x, Breakdown x) => NormalizeFunction (Handler x)

6666 where

6767 -- | TODO improve this

6868 renderServerError :: ServerError -> InteractionError

69− renderServerError = InteractionError . T.pack . show

69+ renderServerError s = InteractionError (T.pack $ show s) (errHTTPCode serverError == 500)

70+

7071 Right x -> pure $ Right $ breakdown x

7172

7273

@@ -91,7 +92,7 @@ instance

9192 FlattenServer (endpoint :<|> api)

9293 where

9394 flattenServer (endpoint :<|> server) = endpoint `AnEndpoint` flattenServer @api server

94−

95+

9596instance

9697 (

9798 Endpoints api ~ '[api]

test/Nested.hs+1−1

@@ -11,7 +11,7 @@ import Servant

1111import Servant.API.Flatten

1212

1313type Api =

14− ( "one" :> Post '[JSON] Int

14+ ( "one" :> Summary "foo" :> Post '[JSON] Int

1515 :<|> "two" :> Post '[JSON] Int

1616 )

1717 :<|> ( "three" :> Post '[JSON] Int

test/QueryParams.hsnew file+15

@@ -0,0 +1,15 @@

1+{-# LANGUAGE DataKinds #-}

2+{-# LANGUAGE DeriveGeneric #-}

3+{-# LANGUAGE DerivingStrategies #-}

4+{-# LANGUAGE GeneralizedNewtypeDeriving #-}

5+{-# LANGUAGE OverloadedStrings #-}

6+{-# LANGUAGE TypeOperators #-}

8+module QueryParams where

10+import Servant

11+

12+type Api = QueryParams "ints" Int :> Get '[JSON] [Int]

13+

14+server :: Server Api

15+server = pure

test/Spec.hs+9−4

@@ -22,6 +22,7 @@ import qualified Headers

2222import qualified Nested

2323import qualified Post

2424import qualified Product

25+import qualified QueryParams

2526import qualified Roboservant as R

2627import qualified Roboservant.Server as RS

2728import qualified Roboservant.Client as RC

@@ -41,7 +42,7 @@ main :: IO ()

4142main = hspec spec

4243

4344fuzzBoth

44− :: forall a .

45+ :: forall a .

4546 (R.ToReifiedApi (Endpoints a), HasServer a '[], RS.FlattenServer a, RC.ToReifiedClientApi (Endpoints a), RC.FlattenClient a,

4647 HasClient ClientM a)

4748 => String -> Server a -> R.Config -> (Maybe R.Report -> IO ()) -> Spec

@@ -76,22 +77,26 @@ spec = do

7677 describe "posted body" $ do

7778 fuzzBoth @Post.Api "passes a coverage check using a posted body" Post.server R.defaultConfig {R.coverageThreshold = 0.99}

7879 (`shouldSatisfy` isNothing)

79−

80+

8081 describe "seeded" $ do

8182 let res = Seeded.Seed 1

8283 shouldFail $ fuzzBoth @Seeded.Api "finds an error using information passed in" Seeded.server

8384 (R.defaultConfig {R.seed = [(toDyn res, hash res)]})

8485 (`shouldSatisfy` isNothing)

85−

86+

8687 describe "Foo" $ do

8788 fuzzBoth @Foo.Api "finds an error in a basic app" Foo.server R.defaultConfig (`shouldSatisfy` serverFailure)

8889

90+ describe "QueryParams" $ do

91+ fuzzBoth @QueryParams.Api "can handle query params" QueryParams.server R.defaultConfig { R.seed = [R.hashedDyn (12::Int)] }

92+ (`shouldSatisfy` isNothing)

93+

8994 describe "BuildFrom" $ do

9095 describe "headers (and sum types)" $ do

9196 fuzzBoth @Headers.Api "should find a failure that's dependent on using header info" Headers.server R.defaultConfig

9297 (`shouldSatisfy` serverFailure)

9398 describe "product types" $ do

94− fuzzBoth @Product.Api "should find a failure that's dependent on creating a product" Product.server

99+ fuzzBoth @Product.Api "should find a failure that's dependent on creating a product" Product.server

95100 R.defaultConfig {R.seed = [R.hashedDyn 'a', R.hashedDyn (1 :: Int)]}

96101 (`shouldSatisfy` serverFailure)

97102 describe "Breakdown" $ do

test/Valid.hs+1−1

@@ -21,7 +21,7 @@ data Routes route

2121 = Routes

2222 { getInt ::

2323 route

24− :- Get '[JSON] Int,

24+ :- Summary "i'm a summary!" :> Get '[JSON] Int,

2525 captureIt ::

2626 route

2727 :- Capture "void" Void :> Get '[JSON] ()