1728c99..master · roboservant

.github/workflows/cabal.ymlnew file+64

since splitsnapshots

unifiedsplit

@@ -0,0 +1,64 @@

1+# modified from https://github.com/jgm/pandoc/blob/master/.github/workflows/ci.yml

2+name: Cabal CI

3+

4+on:

5+ push:

6+ branches:

7+ - '**'

8+ paths-ignore: []

9+ pull_request:

10+ paths-ignore: []

11+

12+jobs:

13+ linux:

14+

15+ runs-on: ubuntu-20.04

16+ strategy:

17+ fail-fast: false

18+ matrix:

19+ versions:

20+ - ghc: '8.8.4'

21+ cabal: '3.4'

22+ - ghc: '8.10.4'

23+ cabal: '3.4'

24+ steps:

25+ - uses: actions/checkout@v2

26+

27+ # need to install older cabal/ghc versions from ppa repository

28+

29+ - name: Install recent cabal/ghc

30+ uses: actions/setup-haskell@v1.1.3

31+ with:

32+ ghc-version: ${{ matrix.versions.ghc }}

33+ cabal-version: ${{ matrix.versions.cabal }}

34+

35+ # declare/restore cached things

36+ # caching doesn't work for scheduled runs yet

37+ # https://github.com/actions/cache/issues/63

38+

39+ - name: Cache cabal global package db

40+ id: cabal-global

41+ uses: actions/cache@v2

42+ with:

43+ path: |

44+ ~/.cabal

45+ key: ${{ runner.os }}-${{ matrix.versions.ghc }}-${{ matrix.versions.cabal }}-cabal-global-${{ hashFiles('cabal.project') }}

46+

47+ - name: Cache cabal work

48+ id: cabal-local

49+ uses: actions/cache@v2

50+ with:

51+ path: |

52+ dist-newstyle

53+ key: ${{ runner.os }}-${{ matrix.versions.ghc }}-${{ matrix.versions.cabal }}-cabal-local

54+

55+ - name: Install dependencies

56+ run: |

57+ cabal update

58+ cabal build all --dependencies-only --enable-tests --disable-optimization

59+ - name: Build

60+ run: |

61+ cabal build all --enable-tests --disable-optimization 2>&1 | tee build.log

62+ - name: Test

63+ run: |

64+ cabal test all --disable-optimization

.github/workflows/ci.yml+2−2

@@ -1,4 +1,4 @@

1−name: CI

1+name: Stack CI

2

3# Trigger the workflow on push or pull request, but only for the master branch

4on:

@@ -12,7 +12,7 @@ jobs:

12 strategy:

13 matrix:

14 stack: ["2.3.3"]

15− ghc: ["8.8.3"]

15+ ghc: ["8.10.4"]

16 os: [ubuntu-latest]

17 steps:

18 - uses: actions/checkout@v2

README.md+2−1

@@ -2,7 +2,8 @@

2

3Automatically fuzz your servant apis in a contextually-aware way.

4

5−![CI](https://github.com/mwotton/roboservant/workflows/CI/badge.svg)

5+[![Stack CI](https://github.com/mwotton/roboservant/actions/workflows/ci.yml/badge.svg)](https://github.com/mwotton/roboservant/actions/workflows/ci.yml)

6+[![Cabal CI](https://github.com/mwotton/roboservant/actions/workflows/cabal.yml/badge.svg)](https://github.com/mwotton/roboservant/actions/workflows/cabal.yml)

6

7

7## example

8## example

8

9

package.yaml+2−1

@@ -1,6 +1,6 @@

1

2name: roboservant

3−version: 0.1.0.2

3+version: 0.1.0.3

4github: "mwotton/roboservant"

5license: BSD3

6copyright: "2020 Mark Wotton, Samuel Schlesinger"

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

19- containers

20- random

21- hashable

22+- http-types

22- lifted-base

23- lifted-base

23- monad-control

24- monad-control

24- mtl

25- mtl

roboservant.cabal+10−4

@@ -1,13 +1,13 @@

1cabal-version: 1.12

2

3−-- This file has been generated from package.yaml by hpack version 0.33.0.

3+-- This file has been generated from package.yaml by hpack version 0.35.0.

4--

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

6--

7−-- hash: 4c71b6b9460f4719791bb8e67f4a5398b807cd8d17c43dc69da806bb5ba9fb4b

7+-- hash: 0c0c35e1dca1d6c52e5bc61591cbd8c0da9d811b83341bbc676c5f8b93b0b20d

8

9name: roboservant

10−version: 0.1.0.2

10+version: 0.1.0.3

11synopsis: Automatic session-aware servant testing

12description: Please see the README on GitHub at <https://github.com/mwotton/roboservant#readme>

13category: Web

@@ -36,6 +36,7 @@ library

36 Roboservant.Types.BuildFrom

37 Roboservant.Types.Config

38 Roboservant.Types.Internal

39+ Roboservant.Types.Orphans

39 Roboservant.Types.ReifiedApi

40 Roboservant.Types.ReifiedApi

40 Roboservant.Types.ReifiedApi.Server

41 Roboservant.Types.ReifiedApi.Server

41 other-modules:

42 other-modules:

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

50 , dependent-map

51 , dependent-map

51 , dependent-sum

52 , dependent-sum

52 , hashable

53 , hashable

54+ , http-types

53 , lifted-base

55 , lifted-base

54 , monad-control

56 , monad-control

55 , mtl

57 , mtl

@@ -71,7 +73,7 @@ test-suite example

71 other-modules:

73 other-modules:

72 Paths_roboservant

74 Paths_roboservant

73 hs-source-dirs:

75 hs-source-dirs:

74− ./.

76+ ./

75 ghc-options: -Wall -fwrite-ide-info -hiedir=.hie -pgmL markdown-unlit

77 ghc-options: -Wall -fwrite-ide-info -hiedir=.hie -pgmL markdown-unlit

76 build-tool-depends:

78 build-tool-depends:

77 markdown-unlit:markdown-unlit

79 markdown-unlit:markdown-unlit

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

86 , hspec

88 , hspec

87 , hspec-core

89 , hspec-core

88 , http-client

90 , http-client

91+ , http-types

89 , lifted-base

92 , lifted-base

90 , monad-control

93 , monad-control

91 , mtl

94 , mtl

@@ -113,6 +116,8 @@ test-suite roboservant-test

113 Nested

116 Nested

114 Post

117 Post

115 Product

118 Product

119+ Put

120+ QueryParams

116 Seeded

121 Seeded

117 UnsafeIO

122 UnsafeIO

118 Valid

123 Valid

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

133 , hspec-wai

138 , hspec-wai

134 , http-api-data

139 , http-api-data

135 , http-client

140 , http-client

141+ , http-types

136 , lifted-base

142 , lifted-base

137 , monad-control

143 , monad-control

138 , mtl

144 , mtl

src/Roboservant/Client.hs+16−8

@@ -1,5 +1,6 @@

1{-# LANGUAGE RankNTypes #-}

2{-# LANGUAGE TypeOperators #-}

3+{-# LANGUAGE NamedFieldPuns #-}

3{-# LANGUAGE DataKinds #-}

4{-# LANGUAGE DataKinds #-}

4{-# LANGUAGE AllowAmbiguousTypes #-}

5{-# LANGUAGE AllowAmbiguousTypes #-}

5{-# LANGUAGE DataKinds #-}

6{-# LANGUAGE DataKinds #-}

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

7{-# LANGUAGE PolyKinds #-}

8{-# LANGUAGE PolyKinds #-}

8{-# LANGUAGE ScopedTypeVariables #-}

9{-# LANGUAGE ScopedTypeVariables #-}

9{-# LANGUAGE TypeApplications #-}

10{-# LANGUAGE TypeApplications #-}

10−{-# LANGUAGE TypeOperators #-}

11+

11{-# LANGUAGE UndecidableInstances #-}

12{-# LANGUAGE UndecidableInstances #-}

12{-# LANGUAGE TypeFamilies #-}

13{-# LANGUAGE TypeFamilies #-}

13{-# LANGUAGE FlexibleContexts #-}

14{-# LANGUAGE FlexibleContexts #-}

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

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

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

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

16module Roboservant.Client where

17module Roboservant.Client where

17

18

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

27import qualified Data.Text as T

28import qualified Data.Text as T

28import Control.Monad.Reader

29import Control.Monad.Reader

29import Data.Hashable

30import Data.Hashable

31+import Network.HTTP.Types.Status

30

32

31-- fuzz :: forall api.

33-- fuzz :: forall api.

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

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

33-- Server api ->

35-- Server api ->

34-- Config ->

36-- Config ->

35-- IO (Maybe Report)

37-- IO (Maybe Report)

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

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

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

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

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

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

39-- => Server api -> ReifiedApi

41-- => Server api -> ReifiedApi

@@ -80,7 +82,7 @@ instance

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

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

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

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

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

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

83−

85+

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

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

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

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

86

88

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

90

92

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

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

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

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

93− normalize c = ReaderT $

95+ normalize c = ReaderT $

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

96+ fmap (bimap renderClientError breakdown) . runClientM c

95−--

97+ where

98+ renderClientError :: ClientError -> InteractionError

99+ renderClientError err = case err of

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

101+ _ -> InteractionError textual True

96

102

103+ where textual = T.pack $ show err

97instance ToReifiedClientApi '[] where

104instance ToReifiedClientApi '[] where

98 toReifiedClientApi NoClientEndpoints _ _ = []

105 toReifiedClientApi NoClientEndpoints _ _ = []

99

106

@@ -105,7 +112,7 @@ instance

105 FlattenClient (endpoint :<|> api)

112 FlattenClient (endpoint :<|> api)

106 where

113 where

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

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

108−

115+

109instance

116instance

110 (

117 (

111 Endpoints api ~ '[api]

118 Endpoints api ~ '[api]

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

114 where

121 where

115 flattenClient c = c `AClientEndpoint` NoClientEndpoints

122 flattenClient c = c `AClientEndpoint` NoClientEndpoints

116

123

124+

117instance FlattenClient (Verb method statusCode contentTypes responseType)

125instance FlattenClient (Verb method statusCode contentTypes responseType)

118 where

126 where

119 flattenClient c = c `AClientEndpoint` NoClientEndpoints

127 flattenClient c = c `AClientEndpoint` NoClientEndpoints

src/Roboservant/Direct.hs+16−14

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

7{-# LANGUAGE RecordWildCards #-}

8{-# LANGUAGE ScopedTypeVariables #-}

9{-# LANGUAGE TupleSections #-}

10−{-# LANGUAGE TypeApplications #-}

10+

11{-# LANGUAGE TypeFamilies #-}

12{-# LANGUAGE UndecidableInstances #-}

13

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

56import Roboservant.Types

57 ( ApiOffset (..),

58 Argument (..),

59− InteractionError,

59+ InteractionError(..),

60 Provenance (..),

61 ReifiedApi,

62 ReifiedEndpoint (..),

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

150 Report

151 (unlines [show failureType, show exception])

152 r

153− displayDiagnostics FuzzState {..} = liftIO $ do

153+ displayDiagnostics FuzzState {..} = liftIO $

154 logInfo $ unlines $

155− ["api endpoints covered"]

155+ ["api endpoints covered"]

156− <> (map show . Set.toList . Set.fromList $ map apiOffset path)

156+ <> (map show . Set.toList . Set.fromList $ map apiOffset path)

157− <> ["", "types in stash"]

157+ <> ["", "types in stash"]

158− <> DM.foldrWithKey (\_ v r -> (show . NEL.length . getStashValue $ v) : r) [] (getStash stash)

158+ <> DM.foldrWithKey (\_ v r -> (show . NEL.length . getStashValue $ v) : r) [] (getStash stash)

159 -- <> (map (show . NEL.length . getStashValue ) $ DM.assocs (getStash stash))

160 -- $ \_k v ->

161 -- (show . NEL.length $ getStashValue v))

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

242 execute fuzzop func args = do

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

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

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

249+ Right (dyn :: NEL.NonEmpty (Dynamic, Int)) ->

247 modify'

250 modify'

248− ( \fs@FuzzState {..} ->

251+ ( \fs@FuzzState {..} ->

249− fs {stash = addToStash (NEL.toList dyn) stash}

252+ fs {stash = addToStash (NEL.toList dyn) stash}

250− )

253+ )

251 where

254 where

252 argVals = V.rmap (\(_ :*: V.Identity x) -> V.Identity x) args

255 argVals = V.rmap (\(_ :*: V.Identity x) -> V.Identity x) args

253 -- argTypes = recordToList' (\(tr :*: _) -> R.SomeTypeRep tr) args

256 -- argTypes = recordToList' (\(tr :*: _) -> R.SomeTypeRep tr) args

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

259 (execute op func args)

262 (execute op func args)

260 [ Handler (\(e :: SomeAsyncException) -> throw e),

263 [ Handler (\(e :: SomeAsyncException) -> throw e),

261 Handler

264 Handler

262− ( \(e :: SomeException) -> do

265+ ( \(e :: SomeException) ->

263− -- displayDiagnostics =<< get

264 throw . RoboservantException ServerCrashed (Just e) =<< get

266 throw . RoboservantException ServerCrashed (Just e) =<< get

265 )

267 )

266 ]

268 ]

src/Roboservant/Server.hs+2−2

@@ -5,7 +5,7 @@

5{-# LANGUAGE FlexibleContexts #-}

6{-# LANGUAGE GADTs #-}

7{-# LANGUAGE PolyKinds #-}

8−{-# LANGUAGE RankNTypes #-}

8+

9{-# LANGUAGE ScopedTypeVariables #-}

10{-# LANGUAGE TypeApplications #-}

11{-# LANGUAGE TypeFamilies #-}

@@ -27,7 +27,7 @@ fuzz :: forall api.

27 Server api ->

28 Config ->

29 IO (Maybe Report)

30−fuzz s = fuzz' (reifyServer s)

30+fuzz s = fuzz' (reifyServer s)

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

32 where reifyServer :: (FlattenServer api, ToReifiedApi (Endpoints api))

33 => Server api -> ReifiedApi

src/Roboservant/Types.hs+1

@@ -23,3 +23,4 @@ import Roboservant.Types.Config

23import Roboservant.Types.Internal

24import Roboservant.Types.ReifiedApi

25import Roboservant.Types.ReifiedApi.Server

26+import Roboservant.Types.Orphans()

src/Roboservant/Types/Breakdown.hs+6−1

@@ -1,5 +1,6 @@

1{-# LANGUAGE AllowAmbiguousTypes #-}

2{-# LANGUAGE DataKinds #-}

3+{-# LANGUAGE FlexibleContexts #-}

3{-# LANGUAGE DerivingVia #-}

4{-# LANGUAGE DerivingVia #-}

4{-# LANGUAGE FlexibleInstances #-}

5{-# LANGUAGE FlexibleInstances #-}

5{-# LANGUAGE GADTs #-}

6{-# LANGUAGE GADTs #-}

@@ -22,6 +23,8 @@ import qualified Data.List.NonEmpty as NEL

22import Data.Typeable (Typeable)

23import Data.Typeable (Typeable)

23import GHC.Generics

24import GHC.Generics

24import Roboservant.Types.Internal

25import Roboservant.Types.Internal

26+import Servant

27+import Roboservant.Types.Orphans()

25

28

26breakdown ::

29breakdown ::

27 (Hashable x, Typeable x, Breakdown x) =>

30 (Hashable x, Typeable x, Breakdown x) =>

@@ -46,7 +49,7 @@ instance (Hashable x, Typeable x, Breakdown x) => Breakdown [x] where

46 breakdownExtras stash = concatMap (NEL.toList . breakdown) stash

49 breakdownExtras stash = concatMap (NEL.toList . breakdown) stash

47

50

48

51

49−class GBreakdown (f :: k -> *) where

52+class GBreakdown (f :: k -> Type) where

50 gBreakdownExtras :: f a -> [(Dynamic, Int)]

53 gBreakdownExtras :: f a -> [(Dynamic, Int)]

51

54

52instance (Hashable x, Typeable x, Generic x, GBreakdown (Rep x)) => Breakdown (Compound (x :: Type)) where

55instance (Hashable x, Typeable x, Generic x, GBreakdown (Rep x)) => Breakdown (Compound (x :: Type)) where

@@ -74,3 +77,5 @@ instance (Hashable a, Typeable a, Breakdown a) => GBreakdown (K1 R a) where

74

77

75instance GBreakdown U1 where

78instance GBreakdown U1 where

76 gBreakdownExtras U1 = []

79 gBreakdownExtras U1 = []

80+

81+deriving via (Atom NoContent) instance Breakdown NoContent

src/Roboservant/Types/BuildFrom.hs+10−4

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

12

13module Roboservant.Types.BuildFrom where

14

15+import Data.List(nub)

15import qualified Data.Dependent.Map as DM

16import qualified Data.Dependent.Map as DM

16import Data.Hashable

17import Data.Hashable

17import qualified Data.IntSet as IntSet

18import qualified Data.IntSet as IntSet

@@ -22,6 +23,8 @@ import Data.Typeable (Typeable)

22import GHC.Generics

23import GHC.Generics

23import Roboservant.Types.Internal

24import Roboservant.Types.Internal

24import qualified Type.Reflection as R

25import qualified Type.Reflection as R

26+import Servant(NoContent)

27+import Roboservant.Types.Orphans()

25

28

26buildFrom :: forall x. (Hashable x, BuildFrom x, Typeable x) => Stash -> Maybe (StashValue x)

29buildFrom :: forall x. (Hashable x, BuildFrom x, Typeable x) => Stash -> Maybe (StashValue x)

27buildFrom = buildStash . buildFrom'

30buildFrom = buildStash . buildFrom'

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

59

62

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

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

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

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

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

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

66+ extras stash =

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

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

64 where

68 where

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

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

66− notpowerset xs = xs:map pure xs

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

67

71

68

72

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

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

@@ -73,7 +77,7 @@ deriving via (Atom Int) instance BuildFrom Int

73

77

74deriving via (Atom Char) instance BuildFrom Char

78deriving via (Atom Char) instance BuildFrom Char

75

79

76−class GBuildFrom (f :: k -> *) where

80+class GBuildFrom (f :: k -> Type) where

77 gExtras :: Stash -> [([Provenance], f a)]

81 gExtras :: Stash -> [([Provenance], f a)]

78

82

79instance GBuildFrom b => GBuildFrom (M1 D a b) where

83instance GBuildFrom b => GBuildFrom (M1 D a b) where

@@ -99,3 +103,5 @@ instance BuildFrom a => GBuildFrom (K1 i a) where

99

103

100instance GBuildFrom U1 where

104instance GBuildFrom U1 where

101 gExtras _ = [([], U1)]

105 gExtras _ = [([], U1)]

106+

107+deriving via (Atom NoContent) instance BuildFrom NoContent

src/Roboservant/Types/Internal.hs+2−2

@@ -43,11 +43,11 @@ instance Show Stash where

43

44-- | Can't be built up from parts, can't be broken down further.

45newtype Atom x = Atom {unAtom :: x}

46− deriving newtype (Hashable, Typeable)

46+ deriving newtype (Hashable, Typeable,Eq)

47

48-- | can be broken down and built up from generic pieces

49newtype Compound x = Compound {unCompound :: x}

50− deriving newtype (Hashable, Typeable)

50+ deriving newtype (Hashable, Typeable, Eq)

51

52hashedDyn :: (Hashable a, Typeable a) => a -> (Dynamic, Int)

53hashedDyn a = (toDyn a, hash a)

src/Roboservant/Types/Orphans.hsnew file+7

@@ -0,0 +1,7 @@

1+{-# OPTIONS_GHC -fno-warn-orphans #-}

2+module Roboservant.Types.Orphans where

3+

4+import Servant

5+import Data.Hashable

6+

7+instance Hashable NoContent

src/Roboservant/Types/ReifiedApi.hs+43−4

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

28import Roboservant.Types.Internal

29import Roboservant.Types.Breakdown

30import Roboservant.Types.BuildFrom

31−import Data.Kind

31+import Data.Kind(Type)

32import Servant

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

34import GHC.TypeLits (Symbol)

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

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

53 }

54

55+instance Show ReifiedEndpoint where

56+ show _ = "lol"

57+

55class ( V.RecordToList (EndpointArgs endpoint)

58class ( V.RecordToList (EndpointArgs endpoint)

56 , V.RMap (EndpointArgs endpoint)

59 , V.RMap (EndpointArgs endpoint)

57− ) => ToReifiedEndpoint (endpoint :: *) where

60+ ) => ToReifiedEndpoint (endpoint :: Type) where

58 type EndpointArgs endpoint :: [Type]

61 type EndpointArgs endpoint :: [Type]

59 type EndpointRes endpoint :: Type

62 type EndpointRes endpoint :: Type

60

63

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

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

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

65tagType = (R.typeRep :*:)

68tagType = (R.typeRep :*:)

66

69

67−newtype InteractionError = InteractionError T.Text

70+data InteractionError = InteractionError

71+ { errorMessage :: T.Text

72+ , fatalError :: Bool

73+ }

68 deriving Show

74 deriving Show

69instance Exception InteractionError

75instance Exception InteractionError

70

76

71

77

72

78

73−

74instance

79instance

75 (Typeable responseType, Breakdown responseType) =>

80 (Typeable responseType, Breakdown responseType) =>

76 ToReifiedEndpoint (Verb method statusCode contentTypes responseType)

81 ToReifiedEndpoint (Verb method statusCode contentTypes responseType)

@@ -79,6 +84,12 @@ instance

79 type EndpointRes (Verb method statusCode contentTypes responseType) = responseType

84 type EndpointRes (Verb method statusCode contentTypes responseType) = responseType

80 reifiedEndpointArguments = V.RNil

85 reifiedEndpointArguments = V.RNil

81

86

87+instance ToReifiedEndpoint (NoContentVerb method)

88+ where

89+ type EndpointArgs (NoContentVerb method) = '[]

90+ type EndpointRes (NoContentVerb method) = NoContent

91+ reifiedEndpointArguments = V.RNil

92+

82instance

93instance

83 (ToReifiedEndpoint endpoint) =>

94 (ToReifiedEndpoint endpoint) =>

84 ToReifiedEndpoint ((x :: Symbol) :> endpoint)

95 ToReifiedEndpoint ((x :: Symbol) :> endpoint)

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

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

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

88 reifiedEndpointArguments = reifiedEndpointArguments @endpoint

99 reifiedEndpointArguments = reifiedEndpointArguments @endpoint

89

100

101+instance

102+ (ToReifiedEndpoint endpoint) =>

103+ ToReifiedEndpoint (RemoteHost :> endpoint)

104+ where

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

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

107+ reifiedEndpointArguments = reifiedEndpointArguments @endpoint

108+

109+

110+

90instance

111instance

91 (ToReifiedEndpoint endpoint) =>

112 (ToReifiedEndpoint endpoint) =>

92 ToReifiedEndpoint (Description s :> endpoint)

113 ToReifiedEndpoint (Description s :> endpoint)

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

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

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

130 V.:& reifiedEndpointArguments @endpoint

151 V.:& reifiedEndpointArguments @endpoint

131

152

153+

154+instance

155+ ( BuildFrom paramType

156+ , ToReifiedEndpoint endpoint

157+ , Show paramType

158+ , Eq paramType

159+ ) =>

160+ ToReifiedEndpoint (QueryParams name paramType :> endpoint)

161+ where

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

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

164+ reifiedEndpointArguments =

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

166+ V.:& reifiedEndpointArguments @endpoint

167+

168+

169+

170+

132instance

171instance

133 ( BuildFrom (IfRequiredLenient T.Text mods headerType)

172 ( BuildFrom (IfRequiredLenient T.Text mods headerType)

134 , ToReifiedEndpoint endpoint

173 , ToReifiedEndpoint endpoint

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

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

6{-# LANGUAGE GADTs #-}

7{-# LANGUAGE LambdaCase #-}

8{-# LANGUAGE PolyKinds #-}

9−{-# LANGUAGE RankNTypes #-}

9+

10{-# LANGUAGE ScopedTypeVariables #-}

11{-# LANGUAGE TypeApplications #-}

12{-# LANGUAGE TypeFamilies #-}

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

66 where

67 -- | TODO improve this

68 renderServerError :: ServerError -> InteractionError

69− renderServerError = InteractionError . T.pack . show

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

70+

70 Right x -> pure $ Right $ breakdown x

71 Right x -> pure $ Right $ breakdown x

71

72

73

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

91 FlattenServer (endpoint :<|> api)

92 FlattenServer (endpoint :<|> api)

92 where

93 where

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

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

94−

95+

95instance

96instance

96 (

97 (

97 Endpoints api ~ '[api]

98 Endpoints api ~ '[api]

stack.yaml+5−10

@@ -1,15 +1,10 @@

1−resolver: lts-16.27

1+resolver: lts-20.4

2packages:

3- .

4

5extra-deps:

6+# - dependent-map-0.4.0.0@sha256:ca2b131046f4340a1c35d138c5a003fe4a5be96b14efc26291ed35fd08c62221,1657

7+# - dependent-sum-0.7.1.0@sha256:5599aa89637db434431b1dd3fa7c34bc3d565ee44f0519bfbc877be1927c2531,2068

6- servant-flatten-0.2@sha256:276896f7c5cdec5b8f8493f6205fded0cc602d050b58fdb09a6d7c85c3bb0837,1234

8- servant-flatten-0.2@sha256:276896f7c5cdec5b8f8493f6205fded0cc602d050b58fdb09a6d7c85c3bb0837,1234

7−- vinyl-0.13.0

9+# - constraints-extras-0.3.0.2@sha256:013b8d0392582c6ca068e226718a4fe8be8e22321cc0634f6115505bf377ad26,1853

8−- dependent-sum-0.7.1.0

10+- some-1.0.3

9−- constraints-extras-0.3.0.2

10−- dependent-map-0.4.0.0

11−

12−- servant-0.18.2

13−- servant-client-0.18.2

14−- servant-client-core-0.18.2

15−- servant-server-0.18.2

stack.yaml.lock+9−58

@@ -7,69 +7,20 @@ packages:

7- completed:

8 hackage: servant-flatten-0.2@sha256:276896f7c5cdec5b8f8493f6205fded0cc602d050b58fdb09a6d7c85c3bb0837,1234

9 pantry-tree:

10− size: 325

11 sha256: 04f12c7bef2c3f9a25d94eb9489752ed498db8e243069fe95838dbb51df1dcb3

10 sha256: 04f12c7bef2c3f9a25d94eb9489752ed498db8e243069fe95838dbb51df1dcb3

11+ size: 325

12 original:

13 hackage: servant-flatten-0.2@sha256:276896f7c5cdec5b8f8493f6205fded0cc602d050b58fdb09a6d7c85c3bb0837,1234

14- completed:

15− hackage: vinyl-0.13.0@sha256:0f247cd3f8682b30881a07de18e6fec52d540646fbcb328420049cc8d63cd407,3724

15+ hackage: some-1.0.3@sha256:938cec5fc0d3a08dde34cfc0acd5a0aa2e9fd489c9dbb64417f16588dfb47af0,2399

16− pantry-tree:

17− size: 1857

18− sha256: 860fb95820b595161cdbdec5f376100ebae2d14e5ef0dbe311546202f7525d01

19− original:

20− hackage: vinyl-0.13.0

21−- completed:

22− hackage: dependent-sum-0.7.1.0@sha256:5599aa89637db434431b1dd3fa7c34bc3d565ee44f0519bfbc877be1927c2531,2068

23− pantry-tree:

24− size: 290

25− sha256: 9cbfb32b5a8a782b7a1c941803fd517633cb699159b851c1d82267a9e9391b50

26− original:

27− hackage: dependent-sum-0.7.1.0

28−- completed:

29− hackage: constraints-extras-0.3.0.2@sha256:013b8d0392582c6ca068e226718a4fe8be8e22321cc0634f6115505bf377ad26,1853

30− pantry-tree:

31− size: 594

32− sha256: 3ce1012bfb02e4d7def9df19ce80b8cd2b472c691b25b181d9960638673fecd1

33− original:

34− hackage: constraints-extras-0.3.0.2

35−- completed:

36− hackage: dependent-map-0.4.0.0@sha256:ca2b131046f4340a1c35d138c5a003fe4a5be96b14efc26291ed35fd08c62221,1657

37− pantry-tree:

38− size: 551

39− sha256: 5defa30010904d2ad05a036f3eaf83793506717c93cbeb599f40db1a3632cfc5

40− original:

41− hackage: dependent-map-0.4.0.0

42−- completed:

43− hackage: servant-0.18.2@sha256:f8c9f0e9891a3ada1337a3c0b369333a3b5a2d0909dd3cd09d79bc26adeaca44,5298

44− pantry-tree:

45− size: 2662

46− sha256: e930e814de1aa4d24274bdf18341a50b7ed38604ae4734f730e09238ac5bf7e2

47− original:

48− hackage: servant-0.18.2

49−- completed:

50− hackage: servant-client-0.18.2@sha256:82578ade7468873259bb2fdc9d62290a0f998550900683e1410a237ed4b05410,4591

51− pantry-tree:

52− size: 1300

53− sha256: 6324892c77bedbce32f0d6f1612fc2cb0d82c163d3be39efb951d3cc3792ce4a

54− original:

55− hackage: servant-client-0.18.2

56−- completed:

57− hackage: servant-client-core-0.18.2@sha256:ad63ae0f227373fea7e547d4c2a7b0b69e112ff409a83cbadffc9f6ee049926f,3763

58− pantry-tree:

59− size: 1444

60− sha256: 9e37bc5f8cbb70cf1accb20bd6f83fca4c2ca42472cd0fc4b22183c2c57cbe3b

61− original:

62− hackage: servant-client-core-0.18.2

63−- completed:

64− hackage: servant-server-0.18.2@sha256:56679af62ab8820a2108da6153d9ae9dde37199e62172365bdaea1458c3f7c2d,5482

65 pantry-tree:

16 pantry-tree:

17+ sha256: b88dddc6b991cd570c6750f8d309a9feb76938b29a690abdabc4ababb8c7b2f8

66− size: 2614

18+ size: 709

67− sha256: 3ac7430134439e4b67f0f5333f63b89d0cb7de5e2e07f0af7801c8e223942b9c

68 original:

19 original:

69− hackage: servant-server-0.18.2

20+ hackage: some-1.0.3

70snapshots:

21snapshots:

71- completed:

22- completed:

23+ sha256: 3770dfd79f5aed67acdcc65c4e7730adddffe6dba79ea723cfb0918356fc0f94

72− size: 533252

24+ size: 648660

73− url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/16/27.yaml

25+ url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/20/4.yaml

74− sha256: c2aaae52beeacf6a5727c1010f50e89d03869abfab6d2c2658ade9da8ed50c73

75− original: lts-16.27

26+ original: lts-20.4

test/Breakdown.hs+1−1

@@ -1,7 +1,7 @@

1{-# LANGUAGE DataKinds #-}

2{-# LANGUAGE DeriveGeneric #-}

3{-# LANGUAGE DerivingStrategies #-}

4−{-# LANGUAGE GeneralizedNewtypeDeriving #-}

4+

5{-# LANGUAGE OverloadedStrings #-}

6{-# LANGUAGE TypeOperators #-}

7

test/Nested.hs+3−3

@@ -1,7 +1,7 @@

1{-# LANGUAGE DataKinds #-}

2−{-# LANGUAGE DeriveGeneric #-}

2+

3{-# LANGUAGE DerivingStrategies #-}

4−{-# LANGUAGE GeneralizedNewtypeDeriving #-}

4+

5{-# LANGUAGE OverloadedStrings #-}

6{-# LANGUAGE TypeOperators #-}

7

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

11import Servant.API.Flatten

12

13type Api =

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

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

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

16 )

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

test/Post.hs+2−2

@@ -1,8 +1,8 @@

1{-# LANGUAGE DataKinds #-}

2{-# LANGUAGE DeriveGeneric #-}

3{-# LANGUAGE DerivingStrategies #-}

4−{-# LANGUAGE GeneralizedNewtypeDeriving #-}

4+

5−{-# LANGUAGE OverloadedStrings #-}

5+

6{-# LANGUAGE TypeOperators #-}

7

8module Post where

test/Product.hs+1−1

@@ -1,7 +1,7 @@

1{-# LANGUAGE DataKinds #-}

2{-# LANGUAGE DeriveGeneric #-}

3{-# LANGUAGE DerivingStrategies #-}

4−{-# LANGUAGE GeneralizedNewtypeDeriving #-}

4+

5{-# LANGUAGE OverloadedStrings #-}

6{-# LANGUAGE TypeOperators #-}

7

test/Put.hsnew file+33

@@ -0,0 +1,33 @@

1+{-# LANGUAGE DataKinds #-}

2+{-# LANGUAGE DeriveGeneric #-}

3+{-# LANGUAGE DerivingStrategies #-}

4+

5+

6+{-# LANGUAGE TypeOperators #-}

7+

8+module Put where

9+

10+import Data.Aeson

11+import Data.Hashable

12+import GHC.Generics (Generic)

13+import Servant

14+

15+type Api =

16+ Get '[JSON] Foo

17+ :<|> ReqBody '[JSON] Foo :> Put '[JSON] ()

18+ :<|> ReqBody '[JSON] Foo :> Put '[JSON] NoContent

19+

20+data Foo = Foo

21+ deriving (Eq, Show, Generic)

22+

23+instance Hashable Foo

24+

25+instance ToJSON Foo

26+

27+instance FromJSON Foo

28+

29+server :: Server Api

30+server =

31+ pure Foo

32+ :<|> const (pure ())

33+ :<|> const (pure NoContent)

test/QueryParams.hsnew file+15

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

1+{-# LANGUAGE DataKinds #-}

2+

3+{-# LANGUAGE DerivingStrategies #-}

4+

5+

6+{-# LANGUAGE TypeOperators #-}

7+

8+module QueryParams where

9+

10+import Servant

11+

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

13+

14+server :: Server Api

15+server = pure

test/Spec.hs+37−23

@@ -21,7 +21,9 @@ import qualified Foo

21import qualified Headers

22import qualified Nested

23import qualified Post

24+import qualified Put

24import qualified Product

25import qualified Product

26+import qualified QueryParams

25import qualified Roboservant as R

27import qualified Roboservant as R

26import qualified Roboservant.Server as RS

28import qualified Roboservant.Server as RS

27import qualified Roboservant.Client as RC

29import qualified Roboservant.Client as RC

@@ -35,26 +37,26 @@ import Servant.Client(ClientEnv, mkClientEnv, baseUrlPort, parseBaseUrl,HasClien

35import Network.Wai(Application)

37import Network.Wai(Application)

36import qualified Network.Wai.Handler.Warp as Warp

38import qualified Network.Wai.Handler.Warp as Warp

37import Network.HTTP.Client (newManager, defaultManagerSettings)

39import Network.HTTP.Client (newManager, defaultManagerSettings)

38−import Servant(Endpoints,HasServer)

40+import Control.Monad((>=>))

39

41

40main :: IO ()

42main :: IO ()

41main = hspec spec

43main = hspec spec

42

44

43fuzzBoth

45fuzzBoth

44− :: forall a .

46+ :: forall a .

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

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

46 HasClient ClientM a)

48 HasClient ClientM a)

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

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

48fuzzBoth name server config condition = do

50fuzzBoth name server config condition = do

49− it (name <> " via server") $ do

51+ it (name <> " via server") $

50 RS.fuzz @a server config >>= condition

52 RS.fuzz @a server config >>= condition

51

53

52− around (withServer (serve (Proxy :: Proxy a) server)) $ do

54+ around (withServer (serve (Proxy :: Proxy a) server)) $

53 it (name <> " via client") $ \(clientEnv::ClientEnv) -> do

55 it (name <> " via client") $ \(clientEnv::ClientEnv) -> do

54− RC.fuzz @a clientEnv config >>= condition

56+ RC.fuzz @a clientEnv config >>= condition

55

57

56withServer :: Application -> ActionWith ClientEnv -> IO ()

58withServer :: Application -> ActionWith ClientEnv -> IO ()

57−withServer app action = Warp.testWithApplication (pure app) (\p -> genClientEnv p >>= action)

59+withServer app action = Warp.testWithApplication (pure app) (genClientEnv >=> action)

58 where genClientEnv port = do

60 where genClientEnv port = do

59 baseUrl <- parseBaseUrl "http://localhost"

61 baseUrl <- parseBaseUrl "http://localhost"

60 manager <- newManager defaultManagerSettings

62 manager <- newManager defaultManagerSettings

@@ -73,37 +75,45 @@ spec = do

73 Just (R.InsufficientCoverage _) -> True

75 Just (R.InsufficientCoverage _) -> True

74 _ -> False

76 _ -> False

75 ))

77 ))

76− describe "posted body" $ do

78+ describe "posted body" $

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

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

80+ (`shouldSatisfy` isNothing)

81+

82+

83+ describe "PUTted body" $

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

78− (`shouldSatisfy` isNothing)

85+ (`shouldSatisfy` isNothing)

79−

86+

87+

80 describe "seeded" $ do

88 describe "seeded" $ do

81 let res = Seeded.Seed 1

89 let res = Seeded.Seed 1

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

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

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

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

84 (`shouldSatisfy` isNothing)

92 (`shouldSatisfy` isNothing)

85−

93+

86− describe "Foo" $ do

94+ describe "Foo" $

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

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

88

96

97+ describe "QueryParams" $

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

99+ (`shouldSatisfy` isNothing)

100+

89 describe "BuildFrom" $ do

101 describe "BuildFrom" $ do

90− describe "headers (and sum types)" $ do

102+ describe "headers (and sum types)" $

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

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

92− (`shouldSatisfy` serverFailure)

104+ (`shouldSatisfy` serverFailure)

93− describe "product types" $ do

105+ describe "product types" $

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

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

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

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

96− (`shouldSatisfy` serverFailure)

108+ (`shouldSatisfy` serverFailure)

97 describe "Breakdown" $ do

109 describe "Breakdown" $ do

98 fuzzBoth @Breakdown.ProductApi "handles products" Breakdown.productServer R.defaultConfig

110 fuzzBoth @Breakdown.ProductApi "handles products" Breakdown.productServer R.defaultConfig

99 (`shouldSatisfy` serverFailure)

111 (`shouldSatisfy` serverFailure)

100 fuzzBoth @Breakdown.SumApi "handles sums" Breakdown.sumServer R.defaultConfig

112 fuzzBoth @Breakdown.SumApi "handles sums" Breakdown.sumServer R.defaultConfig

101 (`shouldSatisfy` serverFailure)

113 (`shouldSatisfy` serverFailure)

102− describe "flattening" $ do

114+ describe "flattening" $

103− -- we don't actually do much here, this is just here to document the appropriate response

104− -- if you get a type error with a nested api.

105 fuzzBoth @Nested.FlatApi "can handle nested apis" Nested.server R.defaultConfig {R.coverageThreshold = 0.99}

115 fuzzBoth @Nested.FlatApi "can handle nested apis" Nested.server R.defaultConfig {R.coverageThreshold = 0.99}

106− (`shouldSatisfy` isNothing)

116+ (`shouldSatisfy` isNothing)

107

117

108serverFailure :: Maybe R.Report -> Bool

118serverFailure :: Maybe R.Report -> Bool

109serverFailure = \case

119serverFailure = \case

@@ -127,9 +137,13 @@ deriving via (R.Atom Seeded.Seed) instance R.BuildFrom Seeded.Seed

127deriving via (R.Atom Void) instance R.BuildFrom Void

137deriving via (R.Atom Void) instance R.BuildFrom Void

128

138

129deriving via (R.Atom Post.FooPost) instance R.Breakdown Post.FooPost

139deriving via (R.Atom Post.FooPost) instance R.Breakdown Post.FooPost

130−

131deriving via (R.Atom Post.FooPost) instance R.BuildFrom Post.FooPost

140deriving via (R.Atom Post.FooPost) instance R.BuildFrom Post.FooPost

132

141

142+deriving via (R.Atom Put.Foo) instance R.Breakdown Put.Foo

143+deriving via (R.Atom Put.Foo) instance R.BuildFrom Put.Foo

144+

145+

146+

133deriving via (R.Compound Breakdown.Foo) instance R.Breakdown Breakdown.Foo

147deriving via (R.Compound Breakdown.Foo) instance R.Breakdown Breakdown.Foo

134

148

135deriving via (R.Compound Product.Foo) instance R.BuildFrom Product.Foo

149deriving via (R.Compound Product.Foo) instance R.BuildFrom Product.Foo

@@ -144,7 +158,7 @@ shouldFail =

144 ( \i ->

158 ( \i ->

145 i

159 i

146 { itemExample = \p a cb -> do

160 { itemExample = \p a cb -> do

147− r <- (itemExample i) p a cb

161+ r <- itemExample i p a cb

148 pure

162 pure

149 r

163 r

150 { resultStatus = case resultStatus r of

164 { resultStatus = case resultStatus r of

test/UnsafeIO.hs+3−3

@@ -1,7 +1,7 @@

1{-# LANGUAGE DataKinds #-}

2−{-# LANGUAGE DeriveGeneric #-}

2+

3{-# LANGUAGE DerivingStrategies #-}

4−{-# LANGUAGE GeneralizedNewtypeDeriving #-}

4+

5{-# LANGUAGE OverloadedStrings #-}

6{-# LANGUAGE TypeOperators #-}

7

@@ -22,7 +22,7 @@ healthcheck ref = do

22 t <- liftIO $ readIORef ref

23 case t of

24 0 -> pure ()

25− n -> throwError $ err500 {errBody = "observed inconsistency: " <> (BL8.pack $ show n)}

25+ n -> throwError $ err500 {errBody = "observed inconsistency: " <> BL8.pack (show n)}

26

27makeServer :: IO (Server UnsafeApi)

28makeServer = do

test/Valid.hs+2−3

@@ -1,7 +1,7 @@

1{-# LANGUAGE DataKinds #-}

2{-# LANGUAGE DeriveGeneric #-}

3{-# LANGUAGE DerivingStrategies #-}

4−{-# LANGUAGE GeneralizedNewtypeDeriving #-}

4+

5{-# LANGUAGE OverloadedStrings #-}

6{-# LANGUAGE TypeOperators #-}

7

@@ -10,7 +10,6 @@ module Valid where

10import Data.Void

11import GHC.Generics

12import Servant

13−import Servant.API.Generic

14import Servant.Server.Generic

13import Servant.Server.Generic

15

14

16type Api =

15type Api =

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

21 = Routes

20 = Routes

22 { getInt ::

21 { getInt ::

23 route

22 route

24− :- Get '[JSON] Int,

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

25 captureIt ::

24 captureIt ::

26 route

25 route

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

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