mirror of
https://github.com/ilyakooo0/roboservant.git
synced 2024-08-15 19:10:24 +03:00
queryparams
This commit is contained in:
parent
1728c99798
commit
601694a30e
@ -19,6 +19,7 @@ dependencies:
|
||||
- containers
|
||||
- random
|
||||
- hashable
|
||||
- http-types
|
||||
- lifted-base
|
||||
- monad-control
|
||||
- mtl
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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 {..} ->
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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]
|
||||
|
@ -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
|
||||
|
15
test/QueryParams.hs
Normal file
15
test/QueryParams.hs
Normal file
@ -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
|
13
test/Spec.hs
13
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
|
||||
|
@ -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] ()
|
||||
|
Loading…
Reference in New Issue
Block a user