git.iko.soy/roboservant
on master help sign in
wip
commit022f3f6fd63f4e29fc8cd936515f6a9ece70ede0 authorMark Wotton <mwotton@gmail.com> dateSun 23 Aug 2020, 11:58 (6 years ago) parenta59a92a
6 files changed+163−43
compare with master
unifiedsplit
Makefile+1−1 package.yaml+2−1 roboservant.cabal+5−3 src/Roboservant/ContextualGenRequest.hs+46−30 src/Roboservant/StateMachine.hs+108−7 stack.yaml+1−1
Makefile+1−1
@@ -1,2 +1,2 @@
11testwatch:
2− ghcid -c 'stack repl --test --ghc-options=-fobject-code' --allow-eval --restart="stack.yaml" --restart="package.yaml"
2+ ghcid -c 'stack repl --test --ghc-options=-fobject-code roboservant' --allow-eval --restart="stack.yaml" --restart="package.yaml" -W
package.yaml+2−1
@@ -25,11 +25,12 @@ dependencies:
2525
2626- bytestring
2727- hedgehog
28+- constrained-dynamic
2829- containers
2930- http-client
3031- http-media
3132- QuickCheck
32−- quickcheck-state-machine
33+- quickcheck-state-machine >= 0.7
3334- servant >= 0.17
3435- servant-client >= 0.17
3536- servant-flatten
roboservant.cabal+5−3
@@ -4,7 +4,7 @@ cabal-version: 1.12
44--
55-- see: https://github.com/sol/hpack
66--
7−-- hash: a191221847f306a37d41754b238e8ccc040f3279c30853f21542d4bdf5ab60d3
7+-- hash: a0b4b884d775a2096c422d6abaf66301ece323e26ea570df76ffc92b15ab89ba
88
99name: roboservant
1010version: 0.1.0.0
@@ -39,12 +39,13 @@ library
3939 QuickCheck
4040 , base >=4.7 && <5
4141 , bytestring
42+ , constrained-dynamic
4243 , containers
4344 , hedgehog
4445 , hspec
4546 , http-client
4647 , http-media
47− , quickcheck-state-machine
48+ , quickcheck-state-machine >=0.7
4849 , servant >=0.17
4950 , servant-client >=0.17
5051 , servant-flatten
@@ -64,12 +65,13 @@ test-suite roboservant-test
6465 QuickCheck
6566 , base >=4.7 && <5
6667 , bytestring
68+ , constrained-dynamic
6769 , containers
6870 , hedgehog
6971 , hspec
7072 , http-client
7173 , http-media
72− , quickcheck-state-machine
74+ , quickcheck-state-machine >=0.7
7375 , roboservant
7476 , servant >=0.17
7577 , servant-client >=0.17
src/Roboservant/ContextualGenRequest.hs+46−30
@@ -35,10 +35,12 @@ import Servant.API
3535import Servant.API.ContentTypes (AllMimeRender, allMimeRender)
3636import Servant.Client
3737-- import Test.QuickCheck (Arbitrary, Gen, elements, frequency)
38−import Data.Dynamic (Dynamic)
38+
39+import Data.Dynamic (Dynamic, fromDynamic)
3940import Data.Map.Strict (Map)
41+import qualified Data.Map.Strict as Map
4042import Data.Maybe
41−import Data.Typeable (TypeRep)
43+import Data.Typeable (TypeRep, Typeable, typeRep)
4244import Hedgehog
4345import qualified Hedgehog.Gen as Gen
4446import Roboservant.Hedgehog
@@ -67,6 +69,14 @@ instance ( HasContextualGenRequest a
6769
6870withGeneratable p store cont = cont <$> genContextualRequest p store
6971
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+
7080instance (KnownSymbol path, HasContextualGenRequest b )
7181 => HasContextualGenRequest (path :> b) where
7282 genContextualRequest _ store =
@@ -81,42 +91,48 @@ instance (KnownSymbol path, HasContextualGenRequest b )
8191 in r { path = "/" <> BS.intercalate "/" paths }
8292
8393 )
84−-- , pure ( \burl -> do
85−-- _
86− -- fmap (Just . (1,)) $ return $ \burl st ->
8794 where
8895 -- (oldf, old) = genContextualRequest (Proxy :: Proxy b) store
8996 new = cs $ symbolVal (Proxy :: Proxy path)
9097
91−-- instance HasContextualGenRequest EmptyAPI st where
92−-- genContextualRequest _ = (0, error "EmptyAPIs cannot be queried.")
98+instance HasContextualGenRequest EmptyAPI where
99+ genContextualRequest _ _ = Nothing
93100
94−-- instance HasContextualGenRequest api st => HasContextualGenRequest (Summary d :> api) st where
95−-- genContextualRequest _ = genContextualRequest (Proxy :: Proxy api)
101+instance HasContextualGenRequest api => HasContextualGenRequest (Summary d :> api) where
102+ genContextualRequest _ = genContextualRequest (Proxy :: Proxy api)
96103
97−-- instance HasContextualGenRequest api st => HasContextualGenRequest (Description d :> api) st where
98−-- genContextualRequest _ = genContextualRequest (Proxy :: Proxy api)
104+instance HasContextualGenRequest api => HasContextualGenRequest (Description d :> api) where
105+ genContextualRequest _ = genContextualRequest (Proxy :: Proxy api)
99106
100−-- instance (HasContextualGenRequest b st, ToHttpApiData c )
101−-- => HasContextualGenRequest (Capture' mods x c :> b) st where
102−-- genContextualRequest _ = (oldf, do
103−-- old' <- old
104−-- new' <- toUrlPiece <$> _generator
105−-- return $ \burl st -> let r = old' burl st in r { path = cs new' <> path r })
106−-- where
107−-- (oldf, old) = genContextualRequest (Proxy :: Proxy b)
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 })
108118
109−-- instance (HasContextualGenRequest b st, ToHttpApiData c )
110−-- => HasContextualGenRequest (CaptureAll x c :> b) st where
111−-- genContextualRequest _ = (oldf, do
112−-- old' <- old
113−-- new' <- fmap (cs . toUrlPiece) <$> new
114−-- let new'' = BS.intercalate "/" new'
115−-- return $ \burl st -> let r = old' burl st
116−-- in r { path = new'' <> path r })
117−-- where
118−-- (oldf, old) = genContextualRequest (Proxy :: Proxy b)
119−-- new = _arbitrary :: Gen [c]
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]
120136
121137-- instance (KnownSymbol h, HasContextualGenRequest b st, ToHttpApiData c)
122138-- => HasContextualGenRequest (Header' mods h c :> b) st where
src/Roboservant/StateMachine.hs+108−7
@@ -1,16 +1,117 @@
1−{-# LANGUAGE AllowAmbiguousTypes #-}
2−{-# LANGUAGE RankNTypes #-}
1+{-# LANGUAGE LambdaCase #-}
2+{-# LANGUAGE AllowAmbiguousTypes #-}
3+{-# LANGUAGE DataKinds #-}
4+{-# LANGUAGE DerivingStrategies #-}
5+{-# LANGUAGE FlexibleInstances #-}
6+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
7+{-# LANGUAGE KindSignatures #-}
8+{-# LANGUAGE PartialTypeSignatures #-}
9+{-# LANGUAGE RankNTypes #-}
10+{-# LANGUAGE RecordWildCards #-}
11+{-# LANGUAGE StandaloneDeriving #-}
12+{-# LANGUAGE TupleSections #-}
313module Roboservant.StateMachine where
414
15+import Servant.Client
16+import Control.Arrow (second)
17+import Control.Monad.IO.Class
18+import Data.IORef (IORef)
19+-- import Data.Dynamic (Dynamic, fromDynamic)
20+import Data.Map.Strict (Map)
21+import qualified Data.Map.Strict as Map
22+import Data.Typeable (TypeRep, Typeable, typeRep)
523import Roboservant.ContextualGenRequest
6−import Servant.Server (Server)
7−import Test.QuickCheck (Property)
8−import Test.StateMachine
24+import Servant.Server (Server)
25+--import Test.QuickCheck (Property)
26+-- import Test.StateMachine
27+
28+import qualified Data.List.NonEmpty as NEL
29+import Data.List.NonEmpty(NonEmpty)
30+import Data.ConstrainedDynamic
31+import qualified Data.MultiConstrainedDynamic as MCD
32+import Data.Type.HasClass
33+import Data.Type.HasClassPreludeInstances
34+import Hedgehog
35+import qualified Hedgehog.Gen as Gen
936
1037
1138-- | can then use either `forAllParallelCommands` or `forAllCommands` to turn
1239-- this into a property
1340--
1441-- TODO: how do we tie the model, command and response types to the Server?
15−genStateMachine :: HasContextualGenRequest a => Server a -> StateMachine model command IO response
16−genStateMachine = undefined
42+-- genStateMachine :: HasContextualGenRequest a => Server a -> StateMachine Model Command IO Response
43+-- genStateMachine = StateMachine initModel _transition _precondition _postcondition
44+-- Nothing _generator _shrinker _semantics _mock
45+
46+-- initModel :: Model r
47+-- initModel = Model mempty
48+
49+-- newtype Model r = Model (Map TypeRep Dynamic)
50+
51+-- data Command r
52+-- = CallEndpoint
53+-- | Read (Reference (Opaque (IORef Int)) r)
54+-- | Write (Reference (Opaque (IORef Int)) r) Int
55+-- | Increment (Reference (Opaque (IORef Int)) r)
56+
57+-- data Response r
58+-- = Created (Reference (Opaque (IORef Int)) r)
59+-- | ReadValue Int
60+-- | Written
61+-- | Incremented
62+
63+
64+newtype MyDyn = MyDyn (ConstrainedDynamic Show)
65+ deriving Show
66+
67+instance Eq MyDyn where
68+ MyDyn a == MyDyn b = show a == show b
69+
70+data State v =
71+ State
72+ { stateRefs :: Map TypeRep (NonEmpty (Var (Opaque (IORef MyDyn)) v))
73+ } deriving (Show)
74+
75+type ReifiedApi = [([TypeRep], TypeRep, MyDyn)]
76+
77+-- newtype ApiOffset = ApiOffset Int
78+-- deriving (Eq,Show)
79+-- deriving newtype (Enum,Num)
80+data Op (v :: * -> * ) = Op [(TypeRep, Var (Opaque MyDyn) v)]
81+
82+deriving instance Show (Op Symbolic)
83+
84+instance HTraversable Op where
85+ htraverse r op@(Op args) = Op <$> traverse (\(t,v) -> (t,) <$> htraverse r v )args
86+
87+callEndpoint :: (MonadGen n, MonadIO m) => ReifiedApi -> ClientEnv -> Command n m State
88+callEndpoint staticRoutes env =
89+ let
90+
91+ gen :: MonadGen n => State Symbolic -> Maybe (n (Op Symbolic))
92+ gen State{..}
93+ | any null options = Nothing
94+ | otherwise = Just $ (mapM Gen.element options >>= pure . Op . _) -- fmap Op (mapM (_ <$> Gen.element) options)
95+
96+ where
97+ options = map (\(args,typerep,_) -> map selectByType args) staticRoutes
98+ -- | given a reified type sig for an operation, work out what
99+ -- options there are for each
100+ selectByType typerep = case Map.lookup typerep stateRefs of
101+ Nothing -> []
102+ Just xs -> fmap (typerep,) (NEL.toList xs)
103+
104+
105+ execute (Op args) =
106+ fmap Opaque . liftIO $ undefined -- case fromDynamic
107+
108+ in Command gen execute [ Update $ undefined
109+ -- , Ensure (no-500 here)
110+ ]
111+
112+
113+ -- -- [
114+-- -- Update $ \(State xs) _i o ->
115+-- -- State $
116+-- -- xs ++ [(o, 0)]
117+-- -- ]
stack.yaml+1−1
@@ -10,4 +10,4 @@ extra-deps:
1010- servant-client-0.17
1111- servant-client-core-0.17
1212- servant-server-0.17
13−
13+- constrained-dynamic-0.1.0.0@sha256:3516d3b95c8180f8904671aa982af2fae55a185b18642192f5c8f50657108e82,1207