master..1728c99 · roboservant

.github/workflows/cabal.ymldeleted−64

since splitsnapshots

unifiedsplit

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

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: Stack CI

1+name: 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.10.4"]

15+ ghc: ["8.8.3"]

16 os: [ubuntu-latest]

17 steps:

18 - uses: actions/checkout@v2

README.md+1−2

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

2

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

4

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

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

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

7

6

8## example

7## example

9

8

package.yaml+1−2

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

1

2name: roboservant

3−version: 0.1.0.3

3+version: 0.1.0.2

4github: "mwotton/roboservant"

5license: BSD3

6copyright: "2020 Mark Wotton, Samuel Schlesinger"

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

19- containers

20- random

21- hashable

22−- http-types

23- lifted-base

22- lifted-base

24- monad-control

23- monad-control

25- mtl

24- mtl

roboservant.cabal+4−10

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

1cabal-version: 1.12

2

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

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

4--

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

6--

7−-- hash: 0c0c35e1dca1d6c52e5bc61591cbd8c0da9d811b83341bbc676c5f8b93b0b20d

7+-- hash: 4c71b6b9460f4719791bb8e67f4a5398b807cd8d17c43dc69da806bb5ba9fb4b

8

9name: roboservant

10−version: 0.1.0.3

10+version: 0.1.0.2

11synopsis: Automatic session-aware servant testing

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

13category: Web

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

36 Roboservant.Types.BuildFrom

37 Roboservant.Types.Config

38 Roboservant.Types.Internal

39− Roboservant.Types.Orphans

40 Roboservant.Types.ReifiedApi

39 Roboservant.Types.ReifiedApi

41 Roboservant.Types.ReifiedApi.Server

40 Roboservant.Types.ReifiedApi.Server

42 other-modules:

41 other-modules:

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

51 , dependent-map

50 , dependent-map

52 , dependent-sum

51 , dependent-sum

53 , hashable

52 , hashable

54− , http-types

55 , lifted-base

53 , lifted-base

56 , monad-control

54 , monad-control

57 , mtl

55 , mtl

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

73 other-modules:

71 other-modules:

74 Paths_roboservant

72 Paths_roboservant

75 hs-source-dirs:

73 hs-source-dirs:

76− ./

74+ ./.

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

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

78 build-tool-depends:

76 build-tool-depends:

79 markdown-unlit:markdown-unlit

77 markdown-unlit:markdown-unlit

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

88 , hspec

86 , hspec

89 , hspec-core

87 , hspec-core

90 , http-client

88 , http-client

91− , http-types

92 , lifted-base

89 , lifted-base

93 , monad-control

90 , monad-control

94 , mtl

91 , mtl

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

116 Nested

113 Nested

117 Post

114 Post

118 Product

115 Product

119− Put

120− QueryParams

121 Seeded

116 Seeded

122 UnsafeIO

117 UnsafeIO

123 Valid

118 Valid

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

138 , hspec-wai

133 , hspec-wai

139 , http-api-data

134 , http-api-data

140 , http-client

135 , http-client

141− , http-types

142 , lifted-base

136 , lifted-base

143 , monad-control

137 , monad-control

144 , mtl

138 , mtl

src/Roboservant/Client.hs+8−16

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

1{-# LANGUAGE RankNTypes #-}

2{-# LANGUAGE TypeOperators #-}

3−{-# LANGUAGE NamedFieldPuns #-}

4{-# LANGUAGE DataKinds #-}

3{-# LANGUAGE DataKinds #-}

5{-# LANGUAGE AllowAmbiguousTypes #-}

4{-# LANGUAGE AllowAmbiguousTypes #-}

6{-# LANGUAGE DataKinds #-}

5{-# LANGUAGE DataKinds #-}

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

8{-# LANGUAGE PolyKinds #-}

7{-# LANGUAGE PolyKinds #-}

9{-# LANGUAGE ScopedTypeVariables #-}

8{-# LANGUAGE ScopedTypeVariables #-}

10{-# LANGUAGE TypeApplications #-}

9{-# LANGUAGE TypeApplications #-}

11−

10+{-# LANGUAGE TypeOperators #-}

12{-# LANGUAGE UndecidableInstances #-}

11{-# LANGUAGE UndecidableInstances #-}

13{-# LANGUAGE TypeFamilies #-}

12{-# LANGUAGE TypeFamilies #-}

14{-# LANGUAGE FlexibleContexts #-}

13{-# LANGUAGE FlexibleContexts #-}

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

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

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

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

17module Roboservant.Client where

16module Roboservant.Client where

18

17

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

28import qualified Data.Text as T

27import qualified Data.Text as T

29import Control.Monad.Reader

28import Control.Monad.Reader

30import Data.Hashable

29import Data.Hashable

31−import Network.HTTP.Types.Status

32

30

33-- fuzz :: forall api.

31-- fuzz :: forall api.

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

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

35-- Server api ->

33-- Server api ->

36-- Config ->

34-- Config ->

37-- IO (Maybe Report)

35-- IO (Maybe Report)

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

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

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

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

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

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

41-- => Server api -> ReifiedApi

39-- => Server api -> ReifiedApi

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

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

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

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

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

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

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

85−

83+

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

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

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

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

88

86

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

92

90

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

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

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

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

95− normalize c = ReaderT $

93+ normalize c = ReaderT $

96− fmap (bimap renderClientError breakdown) . runClientM c

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

97− where

95+--

98− renderClientError :: ClientError -> InteractionError

99− renderClientError err = case err of

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

101− _ -> InteractionError textual True

102

96

103− where textual = T.pack $ show err

104instance ToReifiedClientApi '[] where

97instance ToReifiedClientApi '[] where

105 toReifiedClientApi NoClientEndpoints _ _ = []

98 toReifiedClientApi NoClientEndpoints _ _ = []

106

99

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

112 FlattenClient (endpoint :<|> api)

105 FlattenClient (endpoint :<|> api)

113 where

106 where

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

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

115−

108+

116instance

109instance

117 (

110 (

118 Endpoints api ~ '[api]

111 Endpoints api ~ '[api]

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

121 where

114 where

122 flattenClient c = c `AClientEndpoint` NoClientEndpoints

115 flattenClient c = c `AClientEndpoint` NoClientEndpoints

123

116

124−

125instance FlattenClient (Verb method statusCode contentTypes responseType)

117instance FlattenClient (Verb method statusCode contentTypes responseType)

126 where

118 where

127 flattenClient c = c `AClientEndpoint` NoClientEndpoints

119 flattenClient c = c `AClientEndpoint` NoClientEndpoints

src/Roboservant/Direct.hs+14−16

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

7{-# LANGUAGE RecordWildCards #-}

8{-# LANGUAGE ScopedTypeVariables #-}

9{-# LANGUAGE TupleSections #-}

10−

10+{-# LANGUAGE TypeApplications #-}

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 $

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

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,15 +242,12 @@ 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) ->

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

246− if fatalError e

247− then throw e

248− else pure ()

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

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

250 modify'

247 modify'

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

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

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

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

253− )

250+ )

254 where

251 where

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

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

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

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

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

262 (execute op func args)

259 (execute op func args)

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

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

264 Handler

261 Handler

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

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

263+ -- displayDiagnostics =<< get

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

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

267 )

265 )

268 ]

266 ]

src/Roboservant/Server.hs+2−2

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

5{-# LANGUAGE FlexibleContexts #-}

6{-# LANGUAGE GADTs #-}

7{-# LANGUAGE PolyKinds #-}

8−

8+{-# LANGUAGE RankNTypes #-}

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,4 +23,3 @@ 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+1−6

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

1{-# LANGUAGE AllowAmbiguousTypes #-}

2{-# LANGUAGE DataKinds #-}

3−{-# LANGUAGE FlexibleContexts #-}

4{-# LANGUAGE DerivingVia #-}

3{-# LANGUAGE DerivingVia #-}

5{-# LANGUAGE FlexibleInstances #-}

4{-# LANGUAGE FlexibleInstances #-}

6{-# LANGUAGE GADTs #-}

5{-# LANGUAGE GADTs #-}

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

23import Data.Typeable (Typeable)

22import Data.Typeable (Typeable)

24import GHC.Generics

23import GHC.Generics

25import Roboservant.Types.Internal

24import Roboservant.Types.Internal

26−import Servant

27−import Roboservant.Types.Orphans()

28

25

29breakdown ::

26breakdown ::

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

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

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

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

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

50

47

51

48

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

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

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

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

54

51

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

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

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

77

74

78instance GBreakdown U1 where

75instance GBreakdown U1 where

79 gBreakdownExtras U1 = []

76 gBreakdownExtras U1 = []

80−

81−deriving via (Atom NoContent) instance Breakdown NoContent

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

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

12

13module Roboservant.Types.BuildFrom where

14

15−import Data.List(nub)

16import qualified Data.Dependent.Map as DM

15import qualified Data.Dependent.Map as DM

17import Data.Hashable

16import Data.Hashable

18import qualified Data.IntSet as IntSet

17import qualified Data.IntSet as IntSet

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

23import GHC.Generics

22import GHC.Generics

24import Roboservant.Types.Internal

23import Roboservant.Types.Internal

25import qualified Type.Reflection as R

24import qualified Type.Reflection as R

26−import Servant(NoContent)

27−import Roboservant.Types.Orphans()

28

25

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

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

30buildFrom = buildStash . buildFrom'

27buildFrom = buildStash . buildFrom'

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

62

59

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

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

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

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

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

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

66− extras stash =

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

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

68 where

64 where

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

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

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

66+ notpowerset xs = xs:map pure xs

71

67

72

68

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

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

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

77

73

78deriving via (Atom Char) instance BuildFrom Char

74deriving via (Atom Char) instance BuildFrom Char

79

75

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

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

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

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

82

78

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

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

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

103

99

104instance GBuildFrom U1 where

100instance GBuildFrom U1 where

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

101 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,Eq)

46+ deriving newtype (Hashable, Typeable)

47

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

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

50− deriving newtype (Hashable, Typeable, Eq)

50+ deriving newtype (Hashable, Typeable)

51

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

53hashedDyn a = (toDyn a, hash a)

src/Roboservant/Types/Orphans.hsdeleted−7

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

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+4−43

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

28import Roboservant.Types.Internal

29import Roboservant.Types.Breakdown

30import Roboservant.Types.BuildFrom

31−import Data.Kind(Type)

31+import Data.Kind

32import Servant

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

34import GHC.TypeLits (Symbol)

@@ -52,12 +52,9 @@ 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−

58class ( V.RecordToList (EndpointArgs endpoint)

55class ( V.RecordToList (EndpointArgs endpoint)

59 , V.RMap (EndpointArgs endpoint)

56 , V.RMap (EndpointArgs endpoint)

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

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

61 type EndpointArgs endpoint :: [Type]

58 type EndpointArgs endpoint :: [Type]

62 type EndpointRes endpoint :: Type

59 type EndpointRes endpoint :: Type

63

60

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

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

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

68tagType = (R.typeRep :*:)

65tagType = (R.typeRep :*:)

69

66

70−data InteractionError = InteractionError

67+newtype InteractionError = InteractionError T.Text

71− { errorMessage :: T.Text

72− , fatalError :: Bool

73− }

74 deriving Show

68 deriving Show

75instance Exception InteractionError

69instance Exception InteractionError

76

70

77

71

78

72

73+

79instance

74instance

80 (Typeable responseType, Breakdown responseType) =>

75 (Typeable responseType, Breakdown responseType) =>

81 ToReifiedEndpoint (Verb method statusCode contentTypes responseType)

76 ToReifiedEndpoint (Verb method statusCode contentTypes responseType)

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

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

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

85 reifiedEndpointArguments = V.RNil

80 reifiedEndpointArguments = V.RNil

86

81

87−instance ToReifiedEndpoint (NoContentVerb method)

88− where

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

90− type EndpointRes (NoContentVerb method) = NoContent

91− reifiedEndpointArguments = V.RNil

92−

93instance

82instance

94 (ToReifiedEndpoint endpoint) =>

83 (ToReifiedEndpoint endpoint) =>

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

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

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

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

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

99 reifiedEndpointArguments = reifiedEndpointArguments @endpoint

88 reifiedEndpointArguments = reifiedEndpointArguments @endpoint

100

89

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−

111instance

90instance

112 (ToReifiedEndpoint endpoint) =>

91 (ToReifiedEndpoint endpoint) =>

113 ToReifiedEndpoint (Description s :> endpoint)

92 ToReifiedEndpoint (Description s :> endpoint)

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

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

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

151 V.:& reifiedEndpointArguments @endpoint

130 V.:& reifiedEndpointArguments @endpoint

152

131

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−

171instance

132instance

172 ( BuildFrom (IfRequiredLenient T.Text mods headerType)

133 ( BuildFrom (IfRequiredLenient T.Text mods headerType)

173 , ToReifiedEndpoint endpoint

134 , ToReifiedEndpoint endpoint

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

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

6{-# LANGUAGE GADTs #-}

7{-# LANGUAGE LambdaCase #-}

8{-# LANGUAGE PolyKinds #-}

9−

9+{-# LANGUAGE RankNTypes #-}

10{-# LANGUAGE ScopedTypeVariables #-}

11{-# LANGUAGE TypeApplications #-}

12{-# LANGUAGE TypeFamilies #-}

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

66 where

67 -- | TODO improve this

68 renderServerError :: ServerError -> InteractionError

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

69+ renderServerError = InteractionError . T.pack . show

70−

71 Right x -> pure $ Right $ breakdown x

70 Right x -> pure $ Right $ breakdown x

72

71

73

72

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

92 FlattenServer (endpoint :<|> api)

91 FlattenServer (endpoint :<|> api)

93 where

92 where

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

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

95−

94+

96instance

95instance

97 (

96 (

98 Endpoints api ~ '[api]

97 Endpoints api ~ '[api]

stack.yaml+10−5

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

1−resolver: lts-20.4

1+resolver: lts-16.27

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

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

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

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

7+- vinyl-0.13.0

10−- some-1.0.3

8+- dependent-sum-0.7.1.0

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+58−9

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

7- completed:

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

9 pantry-tree:

10− sha256: 04f12c7bef2c3f9a25d94eb9489752ed498db8e243069fe95838dbb51df1dcb3

11 size: 325

10 size: 325

11+ sha256: 04f12c7bef2c3f9a25d94eb9489752ed498db8e243069fe95838dbb51df1dcb3

12 original:

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

14- completed:

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

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

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

16 pantry-tree:

65 pantry-tree:

17− sha256: b88dddc6b991cd570c6750f8d309a9feb76938b29a690abdabc4ababb8c7b2f8

66+ size: 2614

18− size: 709

67+ sha256: 3ac7430134439e4b67f0f5333f63b89d0cb7de5e2e07f0af7801c8e223942b9c

19 original:

68 original:

20− hackage: some-1.0.3

69+ hackage: servant-server-0.18.2

21snapshots:

70snapshots:

22- completed:

71- completed:

23− sha256: 3770dfd79f5aed67acdcc65c4e7730adddffe6dba79ea723cfb0918356fc0f94

24− size: 648660

72+ size: 533252

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

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

74+ sha256: c2aaae52beeacf6a5727c1010f50e89d03869abfab6d2c2658ade9da8ed50c73

26− original: lts-20.4

75+ original: lts-16.27

test/Breakdown.hs+1−1

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

1{-# LANGUAGE DataKinds #-}

2{-# LANGUAGE DeriveGeneric #-}

3{-# LANGUAGE DerivingStrategies #-}

4−

4+{-# LANGUAGE GeneralizedNewtypeDeriving #-}

5{-# LANGUAGE OverloadedStrings #-}

6{-# LANGUAGE TypeOperators #-}

7

test/Nested.hs+3−3

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

1{-# LANGUAGE DataKinds #-}

2−

2+{-# LANGUAGE DeriveGeneric #-}

3{-# LANGUAGE DerivingStrategies #-}

4−

4+{-# LANGUAGE GeneralizedNewtypeDeriving #-}

5{-# LANGUAGE OverloadedStrings #-}

6{-# LANGUAGE TypeOperators #-}

7

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

11import Servant.API.Flatten

12

13type Api =

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

14+ ( "one" :> 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−

4+{-# LANGUAGE GeneralizedNewtypeDeriving #-}

5−

5+{-# LANGUAGE OverloadedStrings #-}

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−

4+{-# LANGUAGE GeneralizedNewtypeDeriving #-}

5{-# LANGUAGE OverloadedStrings #-}

6{-# LANGUAGE TypeOperators #-}

7

test/Put.hsdeleted−33

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

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.hsdeleted−15

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

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+23−37

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

21import qualified Headers

22import qualified Nested

23import qualified Post

24−import qualified Put

25import qualified Product

24import qualified Product

26−import qualified QueryParams

27import qualified Roboservant as R

25import qualified Roboservant as R

28import qualified Roboservant.Server as RS

26import qualified Roboservant.Server as RS

29import qualified Roboservant.Client as RC

27import qualified Roboservant.Client as RC

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

37import Network.Wai(Application)

35import Network.Wai(Application)

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

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

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

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

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

38+import Servant(Endpoints,HasServer)

41

39

42main :: IO ()

40main :: IO ()

43main = hspec spec

41main = hspec spec

44

42

45fuzzBoth

43fuzzBoth

46− :: forall a .

44+ :: forall a .

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

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

48 HasClient ClientM a)

46 HasClient ClientM a)

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

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

50fuzzBoth name server config condition = do

48fuzzBoth name server config condition = do

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

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

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

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

53

51

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

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

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

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

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

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

57

55

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

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

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

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

60 where genClientEnv port = do

58 where genClientEnv port = do

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

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

62 manager <- newManager defaultManagerSettings

60 manager <- newManager defaultManagerSettings

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

75 Just (R.InsufficientCoverage _) -> True

73 Just (R.InsufficientCoverage _) -> True

76 _ -> False

74 _ -> False

77 ))

75 ))

78− describe "posted body" $

76+ describe "posted body" $ do

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

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

80− (`shouldSatisfy` isNothing)

78+ (`shouldSatisfy` isNothing)

81−

79+

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}

85− (`shouldSatisfy` isNothing)

86−

87−

88 describe "seeded" $ do

80 describe "seeded" $ do

89 let res = Seeded.Seed 1

81 let res = Seeded.Seed 1

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

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

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

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

92 (`shouldSatisfy` isNothing)

84 (`shouldSatisfy` isNothing)

93−

85+

94− describe "Foo" $

86+ describe "Foo" $ do

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

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

96

88

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−

101 describe "BuildFrom" $ do

89 describe "BuildFrom" $ do

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

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

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

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

104− (`shouldSatisfy` serverFailure)

92+ (`shouldSatisfy` serverFailure)

105− describe "product types" $

93+ describe "product types" $ do

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

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

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

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

108− (`shouldSatisfy` serverFailure)

96+ (`shouldSatisfy` serverFailure)

109 describe "Breakdown" $ do

97 describe "Breakdown" $ do

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

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

111 (`shouldSatisfy` serverFailure)

99 (`shouldSatisfy` serverFailure)

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

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

113 (`shouldSatisfy` serverFailure)

101 (`shouldSatisfy` serverFailure)

114− describe "flattening" $

102+ describe "flattening" $ do

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.

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

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

116− (`shouldSatisfy` isNothing)

106+ (`shouldSatisfy` isNothing)

117

107

118serverFailure :: Maybe R.Report -> Bool

108serverFailure :: Maybe R.Report -> Bool

119serverFailure = \case

109serverFailure = \case

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

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

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

138

128

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

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

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

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

130

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

146

132

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

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

148

134

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

158 ( \i ->

144 ( \i ->

159 i

145 i

160 { itemExample = \p a cb -> do

146 { itemExample = \p a cb -> do

161− r <- itemExample i p a cb

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

162 pure

148 pure

163 r

149 r

164 { resultStatus = case resultStatus r of

150 { resultStatus = case resultStatus r of

test/UnsafeIO.hs+3−3

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

1{-# LANGUAGE DataKinds #-}

2−

2+{-# LANGUAGE DeriveGeneric #-}

3{-# LANGUAGE DerivingStrategies #-}

4−

4+{-# LANGUAGE GeneralizedNewtypeDeriving #-}

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+3−2

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

1{-# LANGUAGE DataKinds #-}

2{-# LANGUAGE DeriveGeneric #-}

3{-# LANGUAGE DerivingStrategies #-}

4−

4+{-# LANGUAGE GeneralizedNewtypeDeriving #-}

5{-# LANGUAGE OverloadedStrings #-}

6{-# LANGUAGE TypeOperators #-}

7

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

10import Data.Void

11import GHC.Generics

12import Servant

13+import Servant.API.Generic

13import Servant.Server.Generic

14import Servant.Server.Generic

14

15

15type Api =

16type Api =

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

20 = Routes

21 = Routes

21 { getInt ::

22 { getInt ::

22 route

23 route

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

24+ :- Get '[JSON] Int,

24 captureIt ::

25 captureIt ::

25 route

26 route

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

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