git.iko.soy/roboservant
on master help sign in
add some examples, remove old code
commit0724d7aa743694c6ffc8d90aa0fe681be546361e authorMark Wotton <mwotton@gmail.com> dateSun 13 Sep 2020, 13:42 (6 years ago) parent3bd7a49
9 files changed+220−648
compare with master
unifiedsplit
package.yaml+14−20 roboservant.cabal+14−17 src/Roboservant.hs+1−108 src/Roboservant/ContextualGenRequest.hs−238 src/Roboservant/Hedgehog.hs−41 src/Roboservant/StateMachine.hs+82−174 test/Foo.hs+43 test/Spec.hs+25−50 test/UnsafeIO.hs+41
package.yaml+14−20
@@ -1,48 +1,42 @@
11name: roboservant
22version: 0.1.0.0
3−github: "githubuser/roboservant"
3+github: "mwotton/roboservant"
44license: BSD3
5−author: "Author name here"
6−maintainer: "example@example.com"
7−copyright: "2020 Author name here"
5+author: "Mark Wotton, Samuel Schlesinger"
6+maintainer: "mwotton@gmail.com"
7+copyright: "2020 Mark Wotton, Samuel Schlesinger"
8+synopsis: Automatic session-aware servant testing
9+category: Web
10+description: Please see the README on GitHub at <https://github.com/githubuser/roboservant#readme>
811
912extra-source-files:
1013- README.md
1114- ChangeLog.md
1215
13−# Metadata used when publishing your package
14−# synopsis: Short description of your package
15−# category: Web
16−
17−# To avoid duplicated efforts in documentation and dealing with the
18−# complications of embedding Haddock markup inside cabal files, it is
19−# common to point users to the README.md file.
20−description: Please see the README on GitHub at <https://github.com/githubuser/roboservant#readme>
21−
2216dependencies:
2317- base >= 4.7 && < 5
2418
25−
19+- QuickCheck
2620- bytestring
27−- hedgehog
28−- constrained-dynamic
2921- containers
22+- hedgehog
3023- http-client
3124- http-media
32−- QuickCheck
33−- quickcheck-state-machine >= 0.7
3425- mtl
26+- quickcheck-state-machine >= 0.7
3527- servant >= 0.17
3628- servant-client >= 0.17
3729- servant-flatten
3830- servant-server >= 0.17
3931- string-conversions
32+
4033# test deps
4134- hspec
4235- QuickCheck
43−- warp
4436- aeson
45−- wai
37+
38+ghc-options: -Wall
39+
4640library:
4741 source-dirs: src
4842
roboservant.cabal+14−17
@@ -1,19 +1,21 @@
11cabal-version: 1.12
22
3−-- This file has been generated from package.yaml by hpack version 0.31.2.
3+-- This file has been generated from package.yaml by hpack version 0.33.0.
44--
55-- see: https://github.com/sol/hpack
66--
7−-- hash: 9d15f4554f9f8ea8913a6766643b63ee6633016374fc98164e81058799204a87
7+-- hash: 51154f1c866aea92673a52985de6810cebda3b2662fddd7b7f88a56725e30041
88
99name: roboservant
1010version: 0.1.0.0
11+synopsis: Automatic session-aware servant testing
1112description: Please see the README on GitHub at <https://github.com/githubuser/roboservant#readme>
12−homepage: https://github.com/githubuser/roboservant#readme
13−bug-reports: https://github.com/githubuser/roboservant/issues
14−author: Author name here
15−maintainer: example@example.com
16−copyright: 2020 Author name here
13+category: Web
14+homepage: https://github.com/mwotton/roboservant#readme
15+bug-reports: https://github.com/mwotton/roboservant/issues
16+author: Mark Wotton, Samuel Schlesinger
17+maintainer: mwotton@gmail.com
18+copyright: 2020 Mark Wotton, Samuel Schlesinger
1719license: BSD3
1820license-file: LICENSE
1921build-type: Simple
@@ -23,24 +25,22 @@ extra-source-files:
2325
2426source-repository head
2527 type: git
26− location: https://github.com/githubuser/roboservant
28+ location: https://github.com/mwotton/roboservant
2729
2830library
2931 exposed-modules:
3032 Roboservant
31− Roboservant.ContextualGenRequest
32− Roboservant.Hedgehog
3333 Roboservant.StateMachine
3434 other-modules:
3535 Paths_roboservant
3636 hs-source-dirs:
3737 src
38+ ghc-options: -Wall
3839 build-depends:
3940 QuickCheck
4041 , aeson
4142 , base >=4.7 && <5
4243 , bytestring
43− , constrained-dynamic
4444 , containers
4545 , hedgehog
4646 , hspec
@@ -53,24 +53,23 @@ library
5353 , servant-flatten
5454 , servant-server >=0.17
5555 , string-conversions
56− , wai
57− , warp
5856 default-language: Haskell2010
5957
6058test-suite roboservant-test
6159 type: exitcode-stdio-1.0
6260 main-is: Spec.hs
6361 other-modules:
62+ Foo
63+ UnsafeIO
6464 Paths_roboservant
6565 hs-source-dirs:
6666 test
67− ghc-options: -threaded -rtsopts -with-rtsopts=-N
67+ ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N
6868 build-depends:
6969 QuickCheck
7070 , aeson
7171 , base >=4.7 && <5
7272 , bytestring
73− , constrained-dynamic
7473 , containers
7574 , hedgehog
7675 , hspec
@@ -84,6 +83,4 @@ test-suite roboservant-test
8483 , servant-flatten
8584 , servant-server >=0.17
8685 , string-conversions
87− , wai
88− , warp
8986 default-language: Haskell2010
src/Roboservant.hs+1−108
@@ -1,110 +1,3 @@
1−{-# LANGUAGE LambdaCase #-}
2−{-# LANGUAGE StandaloneDeriving #-}
3−{-# LANGUAGE AllowAmbiguousTypes #-}
4−{-# LANGUAGE DataKinds #-}
5−{-# LANGUAGE FlexibleContexts #-}
6−{-# LANGUAGE FlexibleInstances #-}
7−{-# LANGUAGE GADTs #-}
8−{-# LANGUAGE KindSignatures #-}
9−{-# LANGUAGE MultiParamTypeClasses #-}
10−{-# LANGUAGE PolyKinds #-}
11−{-# LANGUAGE QuantifiedConstraints #-}
12−{-# LANGUAGE RankNTypes #-}
13−{-# LANGUAGE ScopedTypeVariables #-}
14−{-# LANGUAGE TypeApplications #-}
15−{-# LANGUAGE TypeFamilies #-}
16−{-# LANGUAGE TypeOperators #-}
17−{-# LANGUAGE UndecidableInstances #-}
18−{-# LANGUAGE FunctionalDependencies #-}
19−module Roboservant where
1+module Roboservant (module Roboservant.StateMachine) where
202
21−import Prelude hiding (lookup)
22−import GHC.TypeLits
23−import Servant.API
24−
25−import Roboservant.ContextualGenRequest
263import Roboservant.StateMachine
27−
28−
29−-- | Extract the response types from a single servant endpoint, i.e. one
30−-- without any ':<|>' type constructors in it.
31−type family ExtractRespType (path :: *) :: * where
32− ExtractRespType (_ :> b) = ExtractRespType b
33− ExtractRespType (Verb (method :: StdMethod) (responseCode :: Nat) (contentTypes :: [*]) (respType :: *)) = respType
34−
35−-- | Extract the response types from a flattened servant API, i.e. one
36−-- which has the distributive law (modulo isomorphism) applied to it until
37−-- it reaches a normal form.
38−type family ExtractRespTypes (paths :: *) :: [*] where
39− ExtractRespTypes (a :<|> b) = ExtractRespTypes a <> ExtractRespTypes b
40− ExtractRespTypes a = '[ExtractRespType a]
41−
42−-- | Append two type level lists.
43−type family (<>) (xs :: [k]) (ys :: [k]) :: [k] where
44− (x ': xs) <> ys = x ': (xs <> ys)
45− '[] <> ys = ys
46−
47−-- | A homogeneous-functor-list, I guess.
48−data List :: (* -> *) -> [*] -> * where
49− Cons :: f a -> List f as -> List f (a ': as)
50− Nil :: List f '[]
51−
52−-- | So we can use efficient container types for specific types if the need
53−-- arises.
54−class Listy f a where
55− cons :: a -> f a -> f a
56− empty :: f a
57− uncons :: f a -> Maybe (a, f a)
58−
59−instance Listy [] a where
60− cons = (:)
61− empty = []
62− uncons = \case
63− a : as -> Just (a, as)
64− [] -> Nothing
65−
66−-- | A function for inserting elements into their slot in the store.
67−class Insert f a as where
68− insert :: a -> List f as -> List f as
69−instance {-# OVERLAPPABLE #-} Listy f a => Insert f a (a ': as) where
70− insert a (Cons as ls) = Cons (cons a as) ls
71−instance {-# OVERLAPPABLE #-} Insert f a as => Insert f a (b ': as) where
72− insert a (Cons as ls) = Cons as (insert a ls)
73−
74−-- | A function for looking up the container of elements for a specific
75−-- type in the store.
76−class Lookup f a as where
77− lookup :: List f as -> f a
78−
79−instance {-# OVERLAPPABLE #-} Lookup f a (a ': as) where
80− lookup (Cons fa ls) = fa
81−instance {-# OVERLAPPABLE #-} Lookup f a as => Lookup f a (b ': as) where
82− lookup (Cons fa ls) = lookup ls
83−
84−deriving instance (Show (List f as), forall a. Show a => Show (f a), Show a)
85− => Show (List f (a ': as))
86−
87−instance Show (List f '[]) where show _ = "Nil"
88−
89−storeOfApi :: BuildStore [] (ExtractRespTypes api) => List [] (ExtractRespTypes api)
90−storeOfApi = buildStore
91−
92−class BuildStore f xs where
93− buildStore :: List f xs
94−
95−instance BuildStore f '[] where
96− buildStore = Nil
97−
98−instance (BuildStore f as, Listy f a) => BuildStore f (a ': as) where
99− buildStore = Cons empty buildStore
100−-- 1.
101−-- Instead of just the resptype, let's return a tuple of (resptype, '[]::[ ? respType])
102−
103−-- 2.
104−-- break down respType into "useful" components
105−-- data Baz = Baz { key1 :: Key Foo, key2 :: Key Bar }
106−-- should insert into type-indexed list three elements
107−-- 'Baz -> whole value
108−-- '(Key Bar) -> key2
109−-- '(Key Foo) -> key1
110−--
src/Roboservant/ContextualGenRequest.hsdeleted−238
@@ -1,238 +0,0 @@
1−{-# LANGUAGE AllowAmbiguousTypes #-}
2−{-# LANGUAGE DataKinds #-}
3−{-# LANGUAGE FlexibleContexts #-}
4−{-# LANGUAGE FlexibleInstances #-}
5−{-# LANGUAGE GADTs #-}
6−{-# LANGUAGE KindSignatures #-}
7−{-# LANGUAGE LambdaCase #-}
8−{-# LANGUAGE MultiParamTypeClasses #-}
9−{-# LANGUAGE OverloadedStrings #-}
10−{-# LANGUAGE PolyKinds #-}
11−{-# LANGUAGE QuantifiedConstraints #-}
12−{-# LANGUAGE RankNTypes #-}
13−{-# LANGUAGE ScopedTypeVariables #-}
14−{-# LANGUAGE TupleSections #-}
15−{-# LANGUAGE TypeApplications #-}
16−{-# LANGUAGE TypeFamilies #-}
17−{-# LANGUAGE TypeOperators #-}
18−{-# LANGUAGE UndecidableInstances #-}
19−module Roboservant.ContextualGenRequest where
20−
21−import qualified Data.ByteString as BS
22−import qualified Data.ByteString.Internal as BS (c2w)
23−import Data.Data (Proxy (Proxy))
24−import Data.String (IsString (fromString))
25−import Data.String.Conversions (cs)
26−import GHC.TypeLits (KnownSymbol, Nat, symbolVal)
27−import Network.HTTP.Client (Request,
28− RequestBody (RequestBodyLBS),
29− defaultRequest, host, method, path,
30− port, queryString, requestBody,
31− requestHeaders, secure)
32−import Network.HTTP.Media (renderHeader)
33−import Servant
34−import Servant.API
35−import Servant.API.ContentTypes (AllMimeRender, allMimeRender)
36−import Servant.Client
37−-- import Test.QuickCheck (Arbitrary, Gen, elements, frequency)
38−
39−import Data.Dynamic (Dynamic, fromDynamic)
40−import Data.Map.Strict (Map)
41−import qualified Data.Map.Strict as Map
42−import Data.Maybe
43−import Data.Typeable (TypeRep, Typeable, typeRep)
44−import Hedgehog
45−import qualified Hedgehog.Gen as Gen
46−import Roboservant.Hedgehog
47−
48−class HasContextualGenRequest a where
49− genContextualRequest :: Proxy a -> Map TypeRep Dynamic -> Maybe (Int, Gen ( BaseUrl -> Request))
50−
51−-- | Generatable is functionally equivalent to Arbitrary with a default.
52−-- It is separate because we want to allow overwriting at will.
53−class Generatable a where
54− generator :: Gen [a]
55− generator = pure []
56−
57−instance ( HasContextualGenRequest a
58− , HasContextualGenRequest b)
59− => HasContextualGenRequest (a :<|> b) where
60− genContextualRequest _ store
61− = case sub of
62− [] -> Nothing
63− _ -> Just (newfreq, Gen.frequency sub)
64− where
65− newfreq = sum (map fst sub)
66− sub = catMaybes [l,r]
67− l = genContextualRequest (Proxy :: Proxy a) store
68− r = genContextualRequest (Proxy :: Proxy b) store
69−
70−withGeneratable p store cont = cont <$> genContextualRequest p store
71−
72−getCandidates p st cont =
73− case Map.lookup (typeRep p) st of
74− Nothing -> (0,error "shouldn't ever be invoked")
75− Just x -> do
76− case fromDynamic x of
77− Nothing -> (0,error "shouldn't ever be invoked")
78− Just candidates -> cont candidates
79−
80−instance (KnownSymbol path, HasContextualGenRequest b )
81− => HasContextualGenRequest (path :> b) where
82− genContextualRequest _ store =
83− withGeneratable (Proxy :: Proxy b) store $ \(oldf,old') -> do
84− ( oldf, do
85− old <- old'
86− pure $ \burl ->
87− let r = old burl
88− oldPath = path r
89− oldPath' = BS.dropWhile (== BS.c2w '/') oldPath
90− paths = filter (not . BS.null) [new, oldPath']
91− in r { path = "/" <> BS.intercalate "/" paths }
92−
93− )
94− where
95− -- (oldf, old) = genContextualRequest (Proxy :: Proxy b) store
96− new = cs $ symbolVal (Proxy :: Proxy path)
97−
98−instance HasContextualGenRequest EmptyAPI where
99− genContextualRequest _ _ = Nothing
100−
101−instance HasContextualGenRequest api => HasContextualGenRequest (Summary d :> api) where
102− genContextualRequest _ = genContextualRequest (Proxy :: Proxy api)
103−
104−instance HasContextualGenRequest api => HasContextualGenRequest (Description d :> api) where
105− genContextualRequest _ = genContextualRequest (Proxy :: Proxy api)
106−
107−instance (HasContextualGenRequest b, Typeable c, ToHttpApiData c )
108− => HasContextualGenRequest (Capture' mods x c :> b) where
109− genContextualRequest _ st = withGeneratable (Proxy :: Proxy b) st $ \(oldf,old) ->
110− getCandidates (Proxy :: Proxy c) st $ \candidates ->
111− (oldf
112− ,do
113− piece :: c <- Gen.choice candidates
114− old' <- old
115− pure $ \burl ->
116− let r = old' burl
117− in r { path = cs (toUrlPiece piece) <> path r })
118−
119−-- unsure how CaptureAll works, finish later.
120−-- instance (HasContextualGenRequest b, ToHttpApiData c, Typeable c )
121−-- => HasContextualGenRequest (CaptureAll x c :> b) where
122−-- genContextualRequest _ st = withGeneratable (Proxy :: Proxy b) st $ \(oldf,old) ->
123−-- getCandidates (Proxy :: Proxy c) st $ \candidates ->
124−-- (oldf, do
125−-- old' <- old
126−-- piece :: c <- Gen.choice candidates
127−-- let new'' = BS.intercalate "/" . fmap (cs . toUrlPiece) $ piece
128−
129−
130−
131−-- return $ \burl -> let r = old' burl
132−-- in r { path = new'' <> path r })
133−
134−-- -- (oldf, old) = genContextualRequest (Proxy :: Proxy b)
135−-- -- new = _arbitrary :: Gen [c]
136−
137−-- instance (KnownSymbol h, HasContextualGenRequest b st, ToHttpApiData c)
138−-- => HasContextualGenRequest (Header' mods h c :> b) st where
139−-- genContextualRequest _ = (oldf, do
140−-- old' <- old
141−-- new' <- toUrlPiece <$> new -- TODO: generate lenient or/and optional
142−-- return $ \burl st -> let r = old' burl st in r {
143−-- requestHeaders = (hdr, cs new') : requestHeaders r })
144−-- where
145−-- (oldf, old) = genContextualRequest (Proxy :: Proxy b)
146−-- hdr = fromString $ symbolVal (Proxy :: Proxy h)
147−-- new = _arbitrary :: Gen c
148−
149−-- instance (AllMimeRender x c, HasContextualGenRequest b st)
150−-- => HasContextualGenRequest (ReqBody' mods x c :> b) st where
151−-- genContextualRequest _ = (oldf, do
152−-- old' <- old -- TODO: generate lenient
153−-- new' <- new
154−-- (ct, bd) <- elements $ allMimeRender (Proxy :: Proxy x) new'
155−-- return $ \burl st -> let r = old' burl st in r {
156−-- requestBody = RequestBodyLBS bd
157−-- , requestHeaders = ("Content-Type", renderHeader ct) : requestHeaders r
158−-- })
159−-- where
160−-- (oldf, old) = genContextualRequest (Proxy :: Proxy b)
161−-- new = _arbitrary :: Gen c
162−
163−-- instance (KnownSymbol x, ToHttpApiData c, HasContextualGenRequest b st)
164−-- => HasContextualGenRequest (QueryParam' mods x c :> b) st where
165−-- genContextualRequest _ = (oldf, do
166−-- new' <- new -- TODO: generate lenient or/and optional
167−-- old' <- old
168−-- return $ \burl st -> let
169−-- r = old' burl st
170−-- newExpr = param <> "=" <> cs (toQueryParam new')
171−-- qs = queryString r in r {
172−-- queryString = if BS.null qs then newExpr else newExpr <> "&" <> qs })
173−-- where
174−-- (oldf, old) = genContextualRequest (Proxy :: Proxy b)
175−-- param = cs $ symbolVal (Proxy :: Proxy x)
176−-- new = _arbitrary :: Gen c
177−
178−-- instance (KnownSymbol x, ToHttpApiData c, HasContextualGenRequest b st)
179−-- => HasContextualGenRequest (QueryParams x c :> b) st where
180−-- genContextualRequest _ = (oldf, do
181−-- (new' :: c) <- _fetch
182−-- old' <- old
183−-- return $ \burl st -> let r = old' burl st in r {
184−-- queryString = queryString r
185−-- <> if length new' > 0 then fold (toParam <$> new') else ""})
186−-- where
187−-- (oldf, old) = genContextualRequest (Proxy :: Proxy b)
188−-- param = cs $ symbolVal (Proxy :: Proxy x)
189−-- toParam c = param <> "[]=" <> cs (toQueryParam c)
190−-- fold = foldr1 (\a b -> a <> "&" <> b)
191−
192−-- instance (KnownSymbol x, HasContextualGenRequest b st)
193−-- => HasContextualGenRequest (QueryFlag x :> b) st where
194−-- genContextualRequest _ = (oldf, do
195−-- old' <- old
196−-- return $ \burl st -> let r = old' burl st
197−-- qs = queryString r in r {
198−-- queryString = if BS.null qs then param else param <> "&" <> qs })
199−-- where
200−-- (oldf, old) = genContextualRequest (Proxy :: Proxy b)
201−-- param = cs $ symbolVal (Proxy :: Proxy x)
202−
203−-- instance (ReflectMethod method)
204−-- => HasContextualGenRequest (Verb (method :: k) (status :: Nat) (cts :: [*]) a) st where
205−-- genContextualRequest _ = (1, return $ \burl st -> defaultRequest
206−-- { host = cs $ baseUrlHost burl
207−-- , port = baseUrlPort burl
208−-- , secure = baseUrlScheme burl == Https
209−-- , method = reflectMethod (Proxy :: Proxy method)
210−-- })
211−
212−-- instance (ReflectMethod method)
213−-- => HasContextualGenRequest (NoContentVerb (method :: k)) st where
214−-- genContextualRequest _ = (1, return $ \burl st -> defaultRequest
215−-- { host = cs $ baseUrlHost burl
216−-- , port = baseUrlPort burl
217−-- , secure = baseUrlScheme burl == Https
218−-- , method = reflectMethod (Proxy :: Proxy method)
219−-- })
220−
221−-- instance (HasContextualGenRequest a st) => HasContextualGenRequest (RemoteHost :> a) st where
222−-- genContextualRequest _ = genContextualRequest (Proxy :: Proxy a)
223−
224−-- instance (HasContextualGenRequest a st) => HasContextualGenRequest (IsSecure :> a) st where
225−-- genContextualRequest _ = genContextualRequest (Proxy :: Proxy a)
226−
227−-- instance (HasContextualGenRequest a st) => HasContextualGenRequest (HttpVersion :> a) st where
228−-- genContextualRequest _ = genContextualRequest (Proxy :: Proxy a)
229−
230−-- instance (HasContextualGenRequest a st) => HasContextualGenRequest (Vault :> a) st where
231−-- genContextualRequest _ = genContextualRequest (Proxy :: Proxy a)
232−
233−-- instance (HasContextualGenRequest a st) => HasContextualGenRequest (WithNamedContext x y a) st where
234−-- genContextualRequest _ = genContextualRequest (Proxy :: Proxy a)
235−
236−-- -- TODO: Try logging in
237−-- instance (HasContextualGenRequest a st) => HasContextualGenRequest (BasicAuth x y :> a) st where
238−-- genContextualRequest _ = genContextualRequest (Proxy :: Proxy a)
src/Roboservant/Hedgehog.hsdeleted−41
@@ -1,41 +0,0 @@
1−{-# LANGUAGE LambdaCase #-}
2−module Roboservant.Hedgehog where
3−
4−import Hedgehog
5−import Hedgehog.Gen
6−import qualified Hedgehog.Range as Range
7−
8−-- | Uses a weighted distribution to randomly select one of the generators in
9−-- the list.
10−--
11−-- This generator shrinks towards the first generator in the list.
12−--
13−-- This is to be used when the generator returning a Nothing indicates
14−-- that it will never succeed so should be abandoned entirely.
15−--
16−-- /The input list must be non-empty./
17−--
18−frequencyM :: MonadGen m => [(Int, m (Maybe a))] -> m (Maybe a)
19−frequencyM = \case
20− [] -> pure Nothing
21− -- error "Hedgehog.Gen.frequency: used with empty list"
22− xs0 -> do
23− let
24− pick acc n = \case
25− [] -> pure Nothing
26−-- error "Hedgehog.Gen.frequency/pick: used with empty list"
27− (k, x) : xs ->
28− if n <= k then
29− x >>= \case
30− Nothing -> do
31− -- this one will never come out right, so reassemble list without it
32− frequencyM (acc <> xs)
33− Just y -> pure $ Just y
34− else
35− pick ((k,x):acc) (n - k) xs
36−
37− total =
38− sum (fmap fst xs0)
39−
40− n <- integral $ Range.constant 1 total
41− pick [] n xs0
src/Roboservant/StateMachine.hs+82−174
@@ -1,104 +1,41 @@
1−{-# LANGUAGE UndecidableInstances #-}
2−{-# LANGUAGE TypeFamilies #-}
3−{-# LANGUAGE GADTs #-}
4−{-# LANGUAGE PolyKinds #-}
5−{-# LANGUAGE TypeApplications #-}
6−{-# LANGUAGE MultiParamTypeClasses #-}
71{-# LANGUAGE AllowAmbiguousTypes #-}
82{-# LANGUAGE DataKinds #-}
9−{-# LANGUAGE DeriveAnyClass #-}
10−{-# LANGUAGE DeriveGeneric #-}
113{-# LANGUAGE DerivingStrategies #-}
12−{-# LANGUAGE ExistentialQuantification #-}
134{-# LANGUAGE FlexibleContexts #-}
145{-# LANGUAGE FlexibleInstances #-}
6+{-# LANGUAGE GADTs #-}
157{-# LANGUAGE GeneralizedNewtypeDeriving #-}
16−{-# LANGUAGE KindSignatures #-}
178{-# LANGUAGE LambdaCase #-}
18−{-# LANGUAGE OverloadedStrings #-}
19−{-# LANGUAGE PartialTypeSignatures #-}
20−{-# LANGUAGE RankNTypes #-}
9+{-# LANGUAGE PolyKinds #-}
2110{-# LANGUAGE RecordWildCards #-}
2211{-# LANGUAGE ScopedTypeVariables #-}
2312{-# LANGUAGE StandaloneDeriving #-}
24−{-# LANGUAGE TemplateHaskell #-}
2513{-# LANGUAGE TupleSections #-}
14+{-# LANGUAGE TypeApplications #-}
15+{-# LANGUAGE TypeFamilies #-}
2616{-# LANGUAGE TypeOperators #-}
27−
28−-- for servant
17+{-# LANGUAGE UndecidableInstances #-}
2918
3019module Roboservant.StateMachine where
3120
32−import Control.Arrow (second)
33−-- import Data.Dynamic (Dynamic, fromDynamic)
34−
35−--import Test.QuickCheck (Property)
36−-- import Test.StateMachine
37−
38−import Type.Reflection (SomeTypeRep)
39−import Servant.API.Flatten (Flat)
40−import GHC.TypeLits (Nat, Symbol)
21+import Control.Monad.Except (runExceptT)
22+import Control.Monad.IO.Class (MonadIO, liftIO)
23+import Data.Dynamic (Dynamic, dynApply, dynTypeRep, fromDynamic, toDyn)
4124import Data.Function ((&))
42−import Control.Concurrent (forkIO)
43−import Control.Monad ((<=<))
44−import Control.Monad.IO.Class
45−import Data.Aeson
46−import Data.Dynamic
4725import Data.IORef (IORef, newIORef)
4826import qualified Data.List.NonEmpty as NEL
4927import Data.List.NonEmpty (NonEmpty)
5028import Data.Map.Strict (Map)
5129import qualified Data.Map.Strict as Map
52−import Data.Maybe
53−import Data.Type.HasClass
54−import Data.Type.HasClassPreludeInstances
55−import Data.Typeable (TypeRep, Typeable, typeOf, typeRep)
56−import Debug.Trace (traceM, traceShowM)
57−import GHC.Generics (Generic)
58−import GHC.Generics
30+import Data.Maybe (mapMaybe)
31+import Data.Typeable (TypeRep, Typeable, typeRep)
5932import GHC.IORef (readIORef)
60−import Control.Monad.Except (runExceptT)
61−import Hedgehog
33+import GHC.TypeLits (Symbol)
6234import Hedgehog
6335import qualified Hedgehog.Gen as Gen
6436import qualified Hedgehog.Range as Range
65−import Network.HTTP.Client (defaultManagerSettings, newManager)
66−import Network.Wai
67−import Network.Wai.Handler.Warp
68−import Roboservant.ContextualGenRequest
6937import Servant
70−import Servant.Client
71−import Servant.Server (Server)
72−
73−-- | can then use either `forAllParallelCommands` or `forAllCommands` to turn
74−-- this into a property
75−--
76−-- TODO: how do we tie the model, command and response types to the Server?
77−-- genStateMachine :: HasContextualGenRequest a => Server a -> StateMachine Model Command IO Response
78−-- genStateMachine = StateMachine initModel _transition _precondition _postcondition
79−-- Nothing _generator _shrinker _semantics _mock
80−
81−-- initModel :: Model r
82−-- initModel = Model mempty
83−
84−-- newtype Model r = Model (Map TypeRep Dynamic)
85−
86−-- data Command r
87−-- = CallEndpoint
88−-- | Read (Reference (Opaque (IORef Int)) r)
89−-- | Write (Reference (Opaque (IORef Int)) r) Int
90−-- | Increment (Reference (Opaque (IORef Int)) r)
91−
92−-- data Response r
93−-- = Created (Reference (Opaque (IORef Int)) r)
94−-- | ReadValue Int
95−-- | Written
96−-- | Incremented
97−
98−-- deriving Show
99−
100−-- instance Eq MyDyn where
101−-- MyDyn a == MyDyn b = show a == show b
38+import Type.Reflection (SomeTypeRep)
10239
10340data State v
10441 = State
@@ -109,24 +46,30 @@ class FlattenServer api where
10946 flattenServer :: Server api -> Bundled (Endpoints api)
11047
11148instance
112− ( Endpoints (endpoint :<|> api) ~ (endpoint ': Endpoints api)
113− , Server (endpoint :<|> api) ~ (Server endpoint :<|> Server api)
114− , FlattenServer api
115− ) => FlattenServer (endpoint :<|> api) where
49+ ( Endpoints (endpoint :<|> api) ~ (endpoint ': Endpoints api),
50+ Server (endpoint :<|> api) ~ (Server endpoint :<|> Server api),
51+ FlattenServer api
52+ ) =>
53+ FlattenServer (endpoint :<|> api)
54+ where
11655 flattenServer (endpoint :<|> server) = endpoint `AnEndpoint` flattenServer @api server
11756
11857instance
119− ( HasServer (x :> api) '[]
120− , Endpoints (x :> api) ~ '[x :> api]
121− ) => FlattenServer (x :> api) where
58+ ( HasServer (x :> api) '[],
59+ Endpoints (x :> api) ~ '[x :> api]
60+ ) =>
61+ FlattenServer (x :> api)
62+ where
12263 flattenServer server = server `AnEndpoint` NoEndpoints
12364
12465instance
12566 ( HasServer (Verb method statusCode contentTypes responseType) '[],
12667 Endpoints (Verb method statusCode contentTypes responseType) ~ '[Verb method statusCode contentTypes responseType]
127− ) => FlattenServer (Verb method statusCode contentTypes responseType) where
68+ ) =>
69+ FlattenServer (Verb method statusCode contentTypes responseType)
70+ where
12871 flattenServer server = server `AnEndpoint` NoEndpoints
129−
72+
13073type ReifiedEndpoint = ([TypeRep], TypeRep, Dynamic)
13174
13275type ReifiedApi = [(ApiOffset, [TypeRep], TypeRep, Dynamic)]
@@ -144,18 +87,20 @@ class ToReifiedEndpoint (endpoint :: *) where
14487instance ToReifiedApi '[] where
14588 toReifiedApi NoEndpoints _ = []
14689
147−instance (Typeable (Normal (ServerT endpoint Handler)), NormalizeFunction (ServerT endpoint Handler), ToReifiedEndpoint endpoint, ToReifiedApi endpoints, Typeable (ServerT endpoint Handler))
148− => ToReifiedApi (endpoint : endpoints)
90+instance
91+ (Typeable (Normal (ServerT endpoint Handler)), NormalizeFunction (ServerT endpoint Handler), ToReifiedEndpoint endpoint, ToReifiedApi endpoints, Typeable (ServerT endpoint Handler)) =>
92+ ToReifiedApi (endpoint : endpoints)
14993 where
150− toReifiedApi (endpoint `AnEndpoint` endpoints) _ =
151− withOffset (toReifiedEndpoint (toDyn (normalize endpoint)) (Proxy @endpoint))
152− : map (\(n, x, y, z) -> (n + 1, x, y, z))
153− (toReifiedApi endpoints (Proxy @endpoints))
154− where
155− withOffset (x, y, z) = (0, x, y, z)
94+ toReifiedApi (endpoint `AnEndpoint` endpoints) _ =
95+ withOffset (toReifiedEndpoint (toDyn (normalize endpoint)) (Proxy @endpoint))
96+ : map
97+ (\(n, x, y, z) -> (n + 1, x, y, z))
98+ (toReifiedApi endpoints (Proxy @endpoints))
99+ where
100+ withOffset (x, y, z) = (0, x, y, z)
156101
157102class NormalizeFunction m where
158− type Normal m
103+ type Normal m
159104 normalize :: m -> Normal m
160105
161106instance NormalizeFunction x => NormalizeFunction (r -> x) where
@@ -167,32 +112,36 @@ instance Typeable x => NormalizeFunction (Handler x) where
167112 normalize handler = (runExceptT . runHandler') handler >>= \case
168113 Left serverError -> pure (Left serverError)
169114 Right x -> pure (Right (typeRep (Proxy @x), toDyn x))
170−
171−instance Typeable responseType
172− => ToReifiedEndpoint (Verb method statusCode contentTypes responseType)
115+
116+instance
117+ Typeable responseType =>
118+ ToReifiedEndpoint (Verb method statusCode contentTypes responseType)
173119 where
174− toReifiedEndpoint endpoint _ =
175− ([], typeRep (Proxy @responseType), endpoint)
120+ toReifiedEndpoint endpoint _ =
121+ ([], typeRep (Proxy @responseType), endpoint)
176122
177−instance (ToReifiedEndpoint endpoint)
178− => ToReifiedEndpoint ((x :: Symbol) :> endpoint)
123+instance
124+ (ToReifiedEndpoint endpoint) =>
125+ ToReifiedEndpoint ((x :: Symbol) :> endpoint)
179126 where
180− toReifiedEndpoint endpoint _ =
181− toReifiedEndpoint endpoint (Proxy @endpoint)
127+ toReifiedEndpoint endpoint _ =
128+ toReifiedEndpoint endpoint (Proxy @endpoint)
182129
183−instance (Typeable requestType, ToReifiedEndpoint endpoint)
184− => ToReifiedEndpoint (Capture name requestType :> endpoint)
130+instance
131+ (Typeable requestType, ToReifiedEndpoint endpoint) =>
132+ ToReifiedEndpoint (Capture name requestType :> endpoint)
185133 where
186− toReifiedEndpoint endpoint _ =
187− toReifiedEndpoint endpoint (Proxy @endpoint)
188− & \(args, result, typeRepMap) -> (typeRep (Proxy @requestType) : args, result, typeRepMap)
134+ toReifiedEndpoint endpoint _ =
135+ toReifiedEndpoint endpoint (Proxy @endpoint)
136+ & \(args, result, typeRepMap) -> (typeRep (Proxy @requestType) : args, result, typeRepMap)
189137
190−instance (Typeable requestType, ToReifiedEndpoint endpoint)
191− => ToReifiedEndpoint (ReqBody contentTypes requestType :> endpoint)
138+instance
139+ (Typeable requestType, ToReifiedEndpoint endpoint) =>
140+ ToReifiedEndpoint (ReqBody contentTypes requestType :> endpoint)
192141 where
193− toReifiedEndpoint endpoint _ =
194− toReifiedEndpoint endpoint (Proxy @endpoint)
195− & \(args, result, typeRepMap) -> (typeRep (Proxy @requestType) : args, result, typeRepMap)
142+ toReifiedEndpoint endpoint _ =
143+ toReifiedEndpoint endpoint (Proxy @endpoint)
144+ & \(args, result, typeRepMap) -> (typeRep (Proxy @requestType) : args, result, typeRepMap)
196145
197146newtype ApiOffset = ApiOffset Int
198147 deriving (Eq, Show)
@@ -205,7 +154,7 @@ data Op (v :: * -> *) = Op ApiOffset [(TypeRep, Var (Opaque (IORef Dynamic)) v)]
205154deriving instance Show (Op Symbolic)
206155
207156instance HTraversable Op where
208− htraverse r op@(Op offset args) = Op offset <$> traverse (\(t, v) -> (t,) <$> htraverse r v) args
157+ htraverse r (Op offset args) = Op offset <$> traverse (\(t, v) -> (t,) <$> htraverse r v) args
209158
210159callEndpoint :: (MonadGen n, MonadIO m) => ReifiedApi -> Command n m State
211160callEndpoint staticRoutes =
@@ -231,7 +180,7 @@ callEndpoint staticRoutes =
231180 options :: [(ApiOffset, [(TypeRep, [Var (Opaque (IORef Dynamic)) Symbolic])])]
232181 options =
233182 mapMaybe
234− ( \(offset, argreps, retType, dynCall) -> (offset,) <$> do
183+ ( \(offset, argreps, _retType, _dynCall) -> (offset,) <$> do
235184 mapM (\x -> (x,) <$> fillableWith x) argreps
236185 )
237186 staticRoutes
@@ -244,8 +193,8 @@ callEndpoint staticRoutes =
244193 execute (Op (ApiOffset offset) args) = do
245194 -- traceM (show (offset, args))
246195 fmap Opaque . liftIO $ do
247− realArgs <- mapM (\(tr, v) -> readIORef (opaque v)) args
248− let (_offset, staticArgs, ret, endpoint) = staticRoutes !! offset
196+ realArgs <- mapM (\(_tr, v) -> readIORef (opaque v)) args
197+ let (_offset, _staticArgs, _ret, endpoint) = staticRoutes !! offset
249198 -- now, magic happens: we apply some dynamic arguments to a dynamic
250199 -- function and hopefully somtehing useful pops out the end.
251200 func = foldr (\arg curr -> flip dynApply arg =<< curr) (Just endpoint) realArgs
@@ -257,14 +206,11 @@ callEndpoint staticRoutes =
257206 Nothing -> error ("all screwed up: " <> maybe ("nothing: " <> show showable) (show . dynTypeRep) func)
258207 Just f -> liftIO f >>= \case
259208 Left (serverError :: ServerError) -> error (show serverError)
260− Right (typeRep :: SomeTypeRep, (dyn :: Dynamic)) -> newIORef dyn
209+ Right (_typeRep :: SomeTypeRep, (dyn :: Dynamic)) -> newIORef dyn
261210 in Command
262211 gen
263212 execute
264− [ Update $ \s@State {..} (Op (ApiOffset offset) args) o' ->
265− -- let foo :: Var (Opaque Dynamic) v -> Var (Opaque (IORef Dynamic)) v
266− -- foo = _ . opaque
267− -- in
213+ [ Update $ \s@State {..} (Op (ApiOffset offset) _args) o' ->
268214 s
269215 { stateRefs =
270216 let (_, _, tr, _) = staticRoutes !! offset
@@ -277,8 +223,8 @@ callEndpoint staticRoutes =
277223 -- , Ensure (no-500 here)
278224 ]
279225
280−prop_sm_sequential :: ReifiedApi -> Property
281−prop_sm_sequential reifiedApi = do
226+prop_sequential :: ReifiedApi -> Property
227+prop_sequential reifiedApi = do
282228 property $ do
283229 let initialState = State mempty
284230 actions <-
@@ -289,54 +235,16 @@ prop_sm_sequential reifiedApi = do
289235 [callEndpoint reifiedApi]
290236 executeSequential initialState actions
291237
292−newtype Foo = Foo Int
293− deriving (Generic, Eq, Show, Typeable)
294− deriving newtype (FromHttpApiData, ToHttpApiData)
295−
296−instance ToJSON Foo
297−
298−instance FromJSON Foo
299−
300−type FooApi =
301− "item" :> Get '[JSON] Foo
302− :<|> "itemAdd" :> Capture "one" Foo :> Capture "two" Foo :> Get '[JSON] Foo
303− :<|> "item" :> Capture "itemId" Foo :> Get '[JSON] ()
304−
305−intro = pure (Foo 1)
306−
307−combine = (\(Foo a) (Foo b) -> pure (Foo (a + b)))
308−
309−eliminate =
310− ( \(Foo a) ->
311− if a > 10
312− then error "eliminate blew up, oh no!"
313− else pure ()
314− )
315−
316−fooServer :: Server FooApi
317−fooServer =
318− intro
319− :<|> combine
320− :<|> eliminate
321−
322−bundledFooServer :: Bundled (Endpoints FooApi)
323−bundledFooServer = flattenServer @FooApi fooServer
324−
325−runServer :: IO ()
326−runServer = do
327− let port = 3000
328− settings =
329− setPort port
330− $ setBeforeMainLoop (putStrLn ("listening on port " ++ show port))
331− $ defaultSettings
332− runSettings settings (serve fooApi fooServer)
333−
334−fooApi :: Proxy FooApi
335−fooApi = Proxy
336−
337−introC :<|> combineC :<|> eliminateC = Servant.Client.client fooApi
338−
339−tests :: IO Bool
340−tests = do
341− let reifiedApi = toReifiedApi (flattenServer @FooApi fooServer) (Proxy @(Endpoints FooApi))
342− checkParallel $ Group "props" [("aprop", prop_sm_sequential reifiedApi)]
238+prop_concurrent :: ReifiedApi -> Property
239+prop_concurrent reifiedApi =
240+ let initialState = State mempty
241+ in withTests 1000 . withRetries 10 . property $ do
242+ actions <-
243+ forAll $
244+ Gen.parallel
245+ (Range.linear 1 50)
246+ (Range.linear 1 10)
247+ initialState
248+ [callEndpoint reifiedApi]
249+ test $
250+ executeParallel initialState actions
test/Foo.hsnew file+43
@@ -0,0 +1,43 @@
1+{-# LANGUAGE DataKinds #-}
2+{-# LANGUAGE DeriveGeneric #-}
3+{-# LANGUAGE DerivingStrategies #-}
4+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
5+{-# LANGUAGE OverloadedStrings #-}
6+{-# LANGUAGE TypeOperators #-}
7+
8+module Foo where
9+
10+import Data.Aeson
11+import Data.Typeable (Typeable)
12+import GHC.Generics (Generic)
13+import Servant
14+
15+newtype Foo = Foo Int
16+ deriving (Generic, Eq, Show, Typeable)
17+ deriving newtype (FromHttpApiData, ToHttpApiData)
18+
19+instance ToJSON Foo
20+
21+instance FromJSON Foo
22+
23+type FooApi =
24+ "item" :> Get '[JSON] Foo
25+ :<|> "itemAdd" :> Capture "one" Foo :> Capture "two" Foo :> Get '[JSON] Foo
26+ :<|> "item" :> Capture "itemId" Foo :> Get '[JSON] ()
27+
28+intro :: Handler Foo
29+intro = pure (Foo 1)
30+
31+combine :: Foo -> Foo -> Handler Foo
32+combine (Foo a) (Foo b) = pure (Foo (a + b))
33+
34+eliminate :: Foo -> Handler ()
35+eliminate (Foo a)
36+ | a > 10 = throwError $ err500 {errBody = "eliminate blew up, oh no!"}
37+ | otherwise = pure ()
38+
39+fooServer :: Server FooApi
40+fooServer =
41+ intro
42+ :<|> combine
43+ :<|> eliminate
test/Spec.hs+25−50
@@ -1,52 +1,27 @@
1−{-# LANGUAGE AllowAmbiguousTypes #-}
2−{-# LANGUAGE DataKinds #-}
3−{-# LANGUAGE FlexibleContexts #-}
4−{-# LANGUAGE FlexibleInstances #-}
5−{-# LANGUAGE GADTs #-}
6−{-# LANGUAGE KindSignatures #-}
7−{-# LANGUAGE MultiParamTypeClasses #-}
8−{-# LANGUAGE PolyKinds #-}
9−{-# LANGUAGE QuantifiedConstraints #-}
10−{-# LANGUAGE RankNTypes #-}
11−{-# LANGUAGE ScopedTypeVariables #-}
12−{-# LANGUAGE TypeApplications #-}
13−{-# LANGUAGE TypeFamilies #-}
14−{-# LANGUAGE TypeOperators #-}
15−{-# LANGUAGE UndecidableInstances #-}
16−
17−import Roboservant
18−import Servant.API
19−import Test.Hspec
20−import qualified Roboservant.StateMachine as SM
21−
22−newtype Foo = Foo Int
23− deriving (Show)
24−
25−newtype Bar = Bar String
26− deriving (Show)
27−
28−type FooApi = "foo" :> "fle" :> "far" :> Get '[JSON] Foo
29−
30−type BarApi = "bar" :> ReqBody '[JSON] Foo :> Post '[JSON] Bar
31−
32−type Api =
33− FooApi :<|> BarApi
34−
35−type Foo' = ExtractRespType FooApi
36−
37−test :: ()
38−test = foo'EqualFoo
39− where
40− foo'EqualFoo :: Foo' ~ Foo => ()
41− foo'EqualFoo = ()
42−
43−test' :: ()
44−test' = blah
45− where
46− blah :: ExtractRespTypes Api ~ '[Foo, Bar] => ()
47− blah = ()
48−
49−storeOfOurApi = storeOfApi @Api
1+{-# LANGUAGE OverloadedStrings #-}
2+{-# LANGUAGE TypeApplications #-}
3+
4+import Data.Proxy (Proxy (..))
5+import qualified Foo
6+import Hedgehog (Group (..), checkSequential)
7+import qualified Roboservant as RS
8+import Servant (Endpoints)
9+import qualified UnsafeIO
10+
11+-- | this is pretty bad. hopefully Jacob knows a better way of doing this.
12+-- https://twitter.com/mwotton/status/1305189249646460933
13+assert :: String -> Bool -> IO ()
14+assert _ True = pure ()
15+assert err False = ioError $ userError err
5016
5117main :: IO ()
52−main = SM.tests >>= print
18+main = do
19+ let reifiedApi = RS.toReifiedApi (RS.flattenServer @Foo.FooApi Foo.fooServer) (Proxy @(Endpoints Foo.FooApi))
20+ assert "should find an error in Foo" . not
21+ =<< checkSequential (Group "Foo" [("Foo", RS.prop_sequential reifiedApi)])
22+ unsafeServer <- UnsafeIO.makeServer
23+ let unsafeApi = RS.toReifiedApi (RS.flattenServer @UnsafeIO.UnsafeApi unsafeServer) (Proxy @(Endpoints UnsafeIO.UnsafeApi))
24+ -- this will not detect the error, as it requires concurrency.
25+ assert "should find nothing" =<< checkSequential (Group "Unsafe" [("Sequential", RS.prop_sequential unsafeApi)])
26+ assert "should find with parallel check" . not
27+ =<< checkSequential (Group "Unsafe" [("Parallel", RS.prop_concurrent unsafeApi)])
test/UnsafeIO.hsnew file+41
@@ -0,0 +1,41 @@
1+{-# LANGUAGE DataKinds #-}
2+{-# LANGUAGE DeriveGeneric #-}
3+{-# LANGUAGE DerivingStrategies #-}
4+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
5+{-# LANGUAGE OverloadedStrings #-}
6+{-# LANGUAGE TypeOperators #-}
7+
8+module UnsafeIO where
9+
10+import Data.Aeson()
11+import Servant
12+import Data.IORef (writeIORef, IORef, readIORef, newIORef)
13+import Control.Monad.Trans (MonadIO(liftIO))
14+import qualified Data.ByteString.Lazy.Char8 as BL8
15+
16+
17+type UnsafeApi =
18+ "add" :> Get '[JSON] ()
19+ :<|> "healthcheck" :> Get '[JSON] ()
20+
21+healthcheck :: IORef Int -> Handler ()
22+healthcheck ref = do
23+ t <- liftIO $ readIORef ref
24+ case t of
25+ 0 -> pure ()
26+ n -> throwError $ err500 {errBody = "observed inconsistency: " <> (BL8.pack $ show n)}
27+
28+
29+
30+makeServer :: IO (Server UnsafeApi)
31+makeServer = do
32+ ref <- newIORef 0
33+ pure $ unsafeMunge ref
34+ :<|> healthcheck ref
35+
36+unsafeMunge :: IORef Int -> Handler ()
37+unsafeMunge ref = liftIO $ do
38+ t <- readIORef ref
39+ writeIORef ref (t+1)
40+ t2 <- readIORef ref
41+ writeIORef ref (t2-1)