diff --git a/roboservant.cabal b/roboservant.cabal index c7dbb6e..46640d9 100644 --- a/roboservant.cabal +++ b/roboservant.cabal @@ -1,10 +1,10 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.33.0. +-- This file has been generated from package.yaml by hpack version 0.34.4. -- -- see: https://github.com/sol/hpack -- --- hash: 76f10a967a70cffa900bcc3464a1fd973642332b3a86d22a19f5e3d1d8879f4d +-- hash: df9bc2d503c0e20b2f3edd45f6b63a5fa751b4b0254cfbb1b5e3209e5cf8de2c name: roboservant version: 0.1.0.2 @@ -73,7 +73,7 @@ test-suite example other-modules: Paths_roboservant hs-source-dirs: - ./. + ./ ghc-options: -Wall -fwrite-ide-info -hiedir=.hie -pgmL markdown-unlit build-tool-depends: markdown-unlit:markdown-unlit diff --git a/src/Roboservant/Client.hs b/src/Roboservant/Client.hs index ab9a704..23f02e5 100644 --- a/src/Roboservant/Client.hs +++ b/src/Roboservant/Client.hs @@ -8,7 +8,7 @@ {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} + {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} @@ -97,7 +97,7 @@ instance (Typeable x, Hashable x, Breakdown x) => NormalizeFunction (ClientM x) where renderClientError :: ClientError -> InteractionError renderClientError err = case err of - FailureResponse _ (Response{responseStatusCode}) -> InteractionError textual (responseStatusCode == status500) + FailureResponse _ Response{responseStatusCode} -> InteractionError textual (responseStatusCode == status500) _ -> InteractionError textual True where textual = T.pack $ show err diff --git a/src/Roboservant/Direct.hs b/src/Roboservant/Direct.hs index 47e5808..972cfae 100644 --- a/src/Roboservant/Direct.hs +++ b/src/Roboservant/Direct.hs @@ -7,7 +7,7 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeApplications #-} + {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} @@ -150,12 +150,12 @@ fuzz' reifiedApi Config {..} = handle (pure . Just . formatException) $ do Report (unlines [show failureType, show exception]) r - displayDiagnostics FuzzState {..} = liftIO $ do + displayDiagnostics FuzzState {..} = liftIO $ logInfo $ unlines $ - ["api endpoints covered"] - <> (map show . Set.toList . Set.fromList $ map apiOffset path) - <> ["", "types in stash"] - <> DM.foldrWithKey (\_ v r -> (show . NEL.length . getStashValue $ v) : r) [] (getStash stash) + ["api endpoints covered"] + <> (map show . Set.toList . Set.fromList $ map apiOffset path) + <> ["", "types in stash"] + <> DM.foldrWithKey (\_ v r -> (show . NEL.length . getStashValue $ v) : r) [] (getStash stash) -- <> (map (show . NEL.length . getStashValue ) $ DM.assocs (getStash stash)) -- $ \_k v -> -- (show . NEL.length $ getStashValue v)) @@ -246,11 +246,11 @@ fuzz' reifiedApi Config {..} = handle (pure . Just . formatException) $ do if fatalError e then throw e else pure () - Right (dyn :: NEL.NonEmpty (Dynamic, Int)) -> do + Right (dyn :: NEL.NonEmpty (Dynamic, Int)) -> modify' - ( \fs@FuzzState {..} -> - fs {stash = addToStash (NEL.toList dyn) stash} - ) + ( \fs@FuzzState {..} -> + fs {stash = addToStash (NEL.toList dyn) stash} + ) where argVals = V.rmap (\(_ :*: V.Identity x) -> V.Identity x) args -- argTypes = recordToList' (\(tr :*: _) -> R.SomeTypeRep tr) args @@ -262,8 +262,7 @@ fuzz' reifiedApi Config {..} = handle (pure . Just . formatException) $ do (execute op func args) [ Handler (\(e :: SomeAsyncException) -> throw e), Handler - ( \(e :: SomeException) -> do - -- displayDiagnostics =<< get + ( \(e :: SomeException) -> throw . RoboservantException ServerCrashed (Just e) =<< get ) ] diff --git a/src/Roboservant/Server.hs b/src/Roboservant/Server.hs index 7b4ea0e..1591e8a 100644 --- a/src/Roboservant/Server.hs +++ b/src/Roboservant/Server.hs @@ -5,7 +5,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE PolyKinds #-} -{-# LANGUAGE RankNTypes #-} + {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} @@ -27,7 +27,7 @@ fuzz :: forall 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 diff --git a/src/Roboservant/Types/ReifiedApi/Server.hs b/src/Roboservant/Types/ReifiedApi/Server.hs index df041bb..b054b3b 100644 --- a/src/Roboservant/Types/ReifiedApi/Server.hs +++ b/src/Roboservant/Types/ReifiedApi/Server.hs @@ -6,7 +6,7 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE PolyKinds #-} -{-# LANGUAGE RankNTypes #-} + {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} diff --git a/test/Breakdown.hs b/test/Breakdown.hs index a086bce..4a7a919 100644 --- a/test/Breakdown.hs +++ b/test/Breakdown.hs @@ -1,7 +1,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} + {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeOperators #-} diff --git a/test/Nested.hs b/test/Nested.hs index 2f6be69..16e1fc2 100644 --- a/test/Nested.hs +++ b/test/Nested.hs @@ -1,7 +1,7 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} + {-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} + {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeOperators #-} diff --git a/test/Post.hs b/test/Post.hs index 330b3a9..dc286bd 100644 --- a/test/Post.hs +++ b/test/Post.hs @@ -1,8 +1,8 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE OverloadedStrings #-} + + {-# LANGUAGE TypeOperators #-} module Post where diff --git a/test/Product.hs b/test/Product.hs index aebd279..9c0ffbd 100644 --- a/test/Product.hs +++ b/test/Product.hs @@ -1,7 +1,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} + {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeOperators #-} diff --git a/test/Put.hs b/test/Put.hs index 8e1b41b..78f27c2 100644 --- a/test/Put.hs +++ b/test/Put.hs @@ -1,8 +1,8 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE OverloadedStrings #-} + + {-# LANGUAGE TypeOperators #-} module Put where diff --git a/test/QueryParams.hs b/test/QueryParams.hs index 1207a11..e345e27 100644 --- a/test/QueryParams.hs +++ b/test/QueryParams.hs @@ -1,8 +1,8 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} + {-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE OverloadedStrings #-} + + {-# LANGUAGE TypeOperators #-} module QueryParams where diff --git a/test/Spec.hs b/test/Spec.hs index 00ea782..00b5b9f 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -37,6 +37,7 @@ import Servant.Client(ClientEnv, mkClientEnv, baseUrlPort, parseBaseUrl,HasClien import Network.Wai(Application) import qualified Network.Wai.Handler.Warp as Warp import Network.HTTP.Client (newManager, defaultManagerSettings) +import Control.Monad((>=>)) main :: IO () main = hspec spec @@ -47,15 +48,15 @@ fuzzBoth HasClient ClientM a) => String -> Server a -> R.Config -> (Maybe R.Report -> IO ()) -> Spec fuzzBoth name server config condition = do - it (name <> " via server") $ do + it (name <> " via server") $ RS.fuzz @a server config >>= condition - around (withServer (serve (Proxy :: Proxy a) server)) $ do + around (withServer (serve (Proxy :: Proxy a) server)) $ it (name <> " via client") $ \(clientEnv::ClientEnv) -> do - RC.fuzz @a clientEnv config >>= condition + RC.fuzz @a clientEnv config >>= condition withServer :: Application -> ActionWith ClientEnv -> IO () -withServer app action = Warp.testWithApplication (pure app) (\p -> genClientEnv p >>= action) +withServer app action = Warp.testWithApplication (pure app) (genClientEnv >=> action) where genClientEnv port = do baseUrl <- parseBaseUrl "http://localhost" manager <- newManager defaultManagerSettings @@ -74,14 +75,14 @@ spec = do Just (R.InsufficientCoverage _) -> True _ -> False )) - describe "posted body" $ do + describe "posted body" $ fuzzBoth @Post.Api "passes a coverage check using a posted body" Post.server R.defaultConfig {R.coverageThreshold = 0.99} - (`shouldSatisfy` isNothing) + (`shouldSatisfy` isNothing) - describe "PUTted body" $ do + describe "PUTted body" $ fuzzBoth @Put.Api "passes a coverage check using a posted body" Put.server R.defaultConfig {R.coverageThreshold = 0.99} - (`shouldSatisfy` isNothing) + (`shouldSatisfy` isNothing) describe "seeded" $ do @@ -90,31 +91,29 @@ spec = do (R.defaultConfig {R.seed = [(toDyn res, hash res)]}) (`shouldSatisfy` isNothing) - describe "Foo" $ do + describe "Foo" $ fuzzBoth @Foo.Api "finds an error in a basic app" Foo.server R.defaultConfig (`shouldSatisfy` serverFailure) - describe "QueryParams" $ do + describe "QueryParams" $ fuzzBoth @QueryParams.Api "can handle query params" QueryParams.server R.defaultConfig { R.seed = [R.hashedDyn (12::Int)] } - (`shouldSatisfy` isNothing) + (`shouldSatisfy` isNothing) describe "BuildFrom" $ do - describe "headers (and sum types)" $ do + describe "headers (and sum types)" $ fuzzBoth @Headers.Api "should find a failure that's dependent on using header info" Headers.server R.defaultConfig - (`shouldSatisfy` serverFailure) - describe "product types" $ do + (`shouldSatisfy` serverFailure) + describe "product types" $ 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) + R.defaultConfig {R.seed = [R.hashedDyn 'a', R.hashedDyn (1 :: Int)]} + (`shouldSatisfy` serverFailure) describe "Breakdown" $ do fuzzBoth @Breakdown.ProductApi "handles products" Breakdown.productServer R.defaultConfig (`shouldSatisfy` serverFailure) fuzzBoth @Breakdown.SumApi "handles sums" Breakdown.sumServer R.defaultConfig (`shouldSatisfy` serverFailure) - describe "flattening" $ do - -- we don't actually do much here, this is just here to document the appropriate response - -- if you get a type error with a nested api. + describe "flattening" $ fuzzBoth @Nested.FlatApi "can handle nested apis" Nested.server R.defaultConfig {R.coverageThreshold = 0.99} - (`shouldSatisfy` isNothing) + (`shouldSatisfy` isNothing) serverFailure :: Maybe R.Report -> Bool serverFailure = \case @@ -159,7 +158,7 @@ shouldFail = ( \i -> i { itemExample = \p a cb -> do - r <- (itemExample i) p a cb + r <- itemExample i p a cb pure r { resultStatus = case resultStatus r of diff --git a/test/UnsafeIO.hs b/test/UnsafeIO.hs index 01c53c3..cefcb1a 100644 --- a/test/UnsafeIO.hs +++ b/test/UnsafeIO.hs @@ -1,7 +1,7 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} + {-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} + {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeOperators #-} @@ -22,7 +22,7 @@ healthcheck ref = do t <- liftIO $ readIORef ref case t of 0 -> pure () - n -> throwError $ err500 {errBody = "observed inconsistency: " <> (BL8.pack $ show n)} + n -> throwError $ err500 {errBody = "observed inconsistency: " <> BL8.pack (show n)} makeServer :: IO (Server UnsafeApi) makeServer = do diff --git a/test/Valid.hs b/test/Valid.hs index c55b777..8c04dcc 100644 --- a/test/Valid.hs +++ b/test/Valid.hs @@ -1,7 +1,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} + {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeOperators #-}