queryparams

package.yaml

@@ -19,6 +19,7 @@ dependencies:
 - containers
 - random
 - hashable
+- http-types
 - lifted-base
 - monad-control
 - mtl

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

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 $ 
+  normalize c = ReaderT $
-    fmap (bimap (InteractionError . T.pack . show) breakdown) . runClientM c 
+    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

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 {..} ->

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
+instance (Eq x, BuildFrom x) => BuildFrom [x] where
-  extras stash = map (\xs -> (concatMap fst xs, map snd xs)) $ notpowerset $ extras @x stash
+  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

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

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]

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

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

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

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