@@ -1,255 +0,0 @@
1−{-# LANGUAGE AllowAmbiguousTypes #-}
2−{-# LANGUAGE DataKinds #-}
3−{-# LANGUAGE DerivingStrategies #-}
4−{-# LANGUAGE FlexibleContexts #-}
5−{-# LANGUAGE FlexibleInstances #-}
6−{-# LANGUAGE GADTs #-}
7−{-# LANGUAGE GeneralizedNewtypeDeriving #-}
8−{-# LANGUAGE LambdaCase #-}
9−{-# LANGUAGE PolyKinds #-}
10−{-# LANGUAGE RecordWildCards #-}
11−{-# LANGUAGE ScopedTypeVariables #-}
12−{-# LANGUAGE StandaloneDeriving #-}
13−{-# LANGUAGE TupleSections #-}
14−{-# LANGUAGE TypeApplications #-}
15−{-# LANGUAGE TypeFamilies #-}
16−{-# LANGUAGE TypeOperators #-}
17−{-# LANGUAGE UndecidableInstances #-}
18−
19−module Roboservant.StateMachine
20−( prop_sequential
21−, prop_concurrent
22−) where
23−
24−import Control.Monad.Except (runExceptT)
25−import Control.Monad.IO.Class (MonadIO, liftIO)
26−import Data.Dynamic (Dynamic, dynApply, dynTypeRep, fromDynamic, toDyn)
27−import Data.Function ((&))
28−import Data.IORef (IORef, newIORef)
29−import qualified Data.List.NonEmpty as NEL
30−import Data.List.NonEmpty (NonEmpty)
31−import Data.Map.Strict (Map)
32−import qualified Data.Map.Strict as Map
33−import Data.Maybe (mapMaybe)
34−import Data.Typeable (TypeRep, Typeable, typeRep)
35−import GHC.IORef (readIORef)
36−import GHC.TypeLits (Symbol)
37−import Hedgehog
38−import qualified Hedgehog.Gen as Gen
39−import qualified Hedgehog.Range as Range
40−import Servant
41−import Type.Reflection (SomeTypeRep)
42−
43−data State v
44− = State
45− { stateRefs :: Map TypeRep (NonEmpty (Var (Opaque (IORef Dynamic)) v))
46− }
47−
48−class FlattenServer api where
49− flattenServer :: Server api -> Bundled (Endpoints api)
50−
51−instance
52− ( Endpoints (endpoint :<|> api) ~ (endpoint ': Endpoints api),
53− Server (endpoint :<|> api) ~ (Server endpoint :<|> Server api),
54− FlattenServer api
55− ) =>
56− FlattenServer (endpoint :<|> api)
57− where
58− flattenServer (endpoint :<|> server) = endpoint `AnEndpoint` flattenServer @api server
59−
60−instance
61− ( HasServer (x :> api) '[],
62− Endpoints (x :> api) ~ '[x :> api]
63− ) =>
64− FlattenServer (x :> api)
65− where
66− flattenServer server = server `AnEndpoint` NoEndpoints
67−
68−instance
69− ( HasServer (Verb method statusCode contentTypes responseType) '[],
70− Endpoints (Verb method statusCode contentTypes responseType) ~ '[Verb method statusCode contentTypes responseType]
71− ) =>
72− FlattenServer (Verb method statusCode contentTypes responseType)
73− where
74− flattenServer server = server `AnEndpoint` NoEndpoints
75−
76−type ReifiedEndpoint = ([TypeRep], TypeRep, Dynamic)
77−
78−type ReifiedApi = [(ApiOffset, [TypeRep], TypeRep, Dynamic)]
79−
80−data Bundled endpoints where
81− AnEndpoint :: Server endpoint -> Bundled endpoints -> Bundled (endpoint ': endpoints)
82− NoEndpoints :: Bundled '[]
83−
84−class ToReifiedApi (endpoints :: [*]) where
85− toReifiedApi :: Bundled endpoints -> Proxy endpoints -> ReifiedApi
86−
87−class ToReifiedEndpoint (endpoint :: *) where
88− toReifiedEndpoint :: Dynamic -> Proxy endpoint -> ReifiedEndpoint
89−
90−instance ToReifiedApi '[] where
91− toReifiedApi NoEndpoints _ = []
92−
93−instance
94− (Typeable (Normal (ServerT endpoint Handler)), NormalizeFunction (ServerT endpoint Handler), ToReifiedEndpoint endpoint, ToReifiedApi endpoints, Typeable (ServerT endpoint Handler)) =>
95− ToReifiedApi (endpoint : endpoints)
96− where
97− toReifiedApi (endpoint `AnEndpoint` endpoints) _ =
98− withOffset (toReifiedEndpoint (toDyn (normalize endpoint)) (Proxy @endpoint))
99− : map
100− (\(n, x, y, z) -> (n + 1, x, y, z))
101− (toReifiedApi endpoints (Proxy @endpoints))
102− where
103− withOffset (x, y, z) = (0, x, y, z)
104−
105−class NormalizeFunction m where
106− type Normal m
107− normalize :: m -> Normal m
108−
109−instance NormalizeFunction x => NormalizeFunction (r -> x) where
110− type Normal (r -> x) = r -> Normal x
111− normalize = fmap normalize
112−
113−instance Typeable x => NormalizeFunction (Handler x) where
114− type Normal (Handler x) = IO (Either ServerError (TypeRep, Dynamic))
115− normalize handler = (runExceptT . runHandler') handler >>= \case
116− Left serverError -> pure (Left serverError)
117− Right x -> pure (Right (typeRep (Proxy @x), toDyn x))
118−
119−instance
120− Typeable responseType =>
121− ToReifiedEndpoint (Verb method statusCode contentTypes responseType)
122− where
123− toReifiedEndpoint endpoint _ =
124− ([], typeRep (Proxy @responseType), endpoint)
125−
126−instance
127− (ToReifiedEndpoint endpoint) =>
128− ToReifiedEndpoint ((x :: Symbol) :> endpoint)
129− where
130− toReifiedEndpoint endpoint _ =
131− toReifiedEndpoint endpoint (Proxy @endpoint)
132−
133−instance
134− (Typeable requestType, ToReifiedEndpoint endpoint) =>
135− ToReifiedEndpoint (Capture name requestType :> endpoint)
136− where
137− toReifiedEndpoint endpoint _ =
138− toReifiedEndpoint endpoint (Proxy @endpoint)
139− & \(args, result, typeRepMap) -> (typeRep (Proxy @requestType) : args, result, typeRepMap)
140−
141−instance
142− (Typeable requestType, ToReifiedEndpoint endpoint) =>
143− ToReifiedEndpoint (ReqBody contentTypes requestType :> endpoint)
144− where
145− toReifiedEndpoint endpoint _ =
146− toReifiedEndpoint endpoint (Proxy @endpoint)
147− & \(args, result, typeRepMap) -> (typeRep (Proxy @requestType) : args, result, typeRepMap)
148−
149−newtype ApiOffset = ApiOffset Int
150− deriving (Eq, Show)
151− deriving newtype (Enum, Num)
152−
153−-- | we need to specify an offset because it's entirely possible to have two
154−-- functions with the same arguments that do different things.
155−data Op (v :: * -> *) = Op ApiOffset [(TypeRep, Var (Opaque (IORef Dynamic)) v)]
156−
157−deriving instance Show (Op Symbolic)
158−
159−instance HTraversable Op where
160− htraverse r (Op offset args) = Op offset <$> traverse (\(t, v) -> (t,) <$> htraverse r v) args
161−
162−callEndpoint :: (MonadGen n, MonadIO m) => ReifiedApi -> Command n m State
163−callEndpoint staticRoutes =
164− let gen :: MonadGen n => State Symbolic -> Maybe (n (Op Symbolic))
165− gen State {..}
166− | any null options = Nothing
167− | otherwise = Just $ do
168− uncurry Op <$> chooseOne options
169− where
170− chooseOne ::
171− MonadGen n =>
172− [ ( ApiOffset,
173− [(TypeRep, [Var (Opaque (IORef Dynamic)) Symbolic])]
174− )
175− ] ->
176− n
177− ( ApiOffset,
178− [(TypeRep, Var (Opaque (IORef Dynamic)) Symbolic)]
179− )
180− chooseOne opts = do
181− (offset, args) <- Gen.element opts
182− (offset,) <$> mapM (\(tr, argOpts) -> (tr,) <$> Gen.element argOpts) args
183− options :: [(ApiOffset, [(TypeRep, [Var (Opaque (IORef Dynamic)) Symbolic])])]
184− options =
185− mapMaybe
186− ( \(offset, argreps, _retType, _dynCall) -> (offset,) <$> do
187− mapM (\x -> (x,) <$> fillableWith x) argreps
188− )
189− staticRoutes
190− fillableWith :: TypeRep -> Maybe [Var (Opaque (IORef Dynamic)) Symbolic]
191− fillableWith tr = NEL.toList <$> Map.lookup tr stateRefs
192− execute ::
193− (MonadIO m) =>
194− Op Concrete ->
195− m (Opaque (IORef Dynamic))
196− execute (Op (ApiOffset offset) args) = do
197− -- traceM (show (offset, args))
198− fmap Opaque . liftIO $ do
199− realArgs <- mapM (\(_tr, v) -> readIORef (opaque v)) args
200− let (_offset, _staticArgs, _ret, endpoint) = staticRoutes !! offset
201− -- now, magic happens: we apply some dynamic arguments to a dynamic
202− -- function and hopefully somtehing useful pops out the end.
203− func = foldr (\arg curr -> flip dynApply arg =<< curr) (Just endpoint) realArgs
204− let showable = map dynTypeRep (endpoint : realArgs)
205− case func of
206− Nothing -> error ("all screwed up: " <> maybe ("nothing: " <> show showable) (show . dynTypeRep) func)
207− Just (f') -> do
208− case fromDynamic f' of
209− Nothing -> error ("all screwed up: " <> maybe ("nothing: " <> show showable) (show . dynTypeRep) func)
210− Just f -> liftIO f >>= \case
211− Left (serverError :: ServerError) -> error (show serverError)
212− Right (_typeRep :: SomeTypeRep, (dyn :: Dynamic)) -> newIORef dyn
213− in Command
214− gen
215− execute
216− [ Update $ \s@State {..} (Op (ApiOffset offset) _args) o' ->
217− s
218− { stateRefs =
219− let (_, _, tr, _) = staticRoutes !! offset
220− in Map.insertWith
221− (<>)
222− tr
223− (pure o')
224− stateRefs
225− }
226− -- , Ensure (no-500 here)
227− ]
228−
229−prop_sequential :: forall api. (FlattenServer api, ToReifiedApi (Endpoints api)) => Server api -> Property
230−prop_sequential server = do
231− let reifiedApi = toReifiedApi (flattenServer @api server) (Proxy @(Endpoints api))
232− property $ do
233− let initialState = State mempty
234− actions <-
235− forAll $
236− Gen.sequential
237− (Range.linear 1 100)
238− initialState
239− [callEndpoint reifiedApi]
240− executeSequential initialState actions
241−
242−prop_concurrent :: forall api. (FlattenServer api, ToReifiedApi (Endpoints api)) => Server api -> Property
243−prop_concurrent server =
244− let reifiedApi = toReifiedApi (flattenServer @api server) (Proxy @(Endpoints api)) in
245− let initialState = State mempty
246− in withTests 1000 . withRetries 10 . property $ do
247− actions <-
248− forAll $
249− Gen.parallel
250− (Range.linear 1 50)
251− (Range.linear 1 10)
252− initialState
253− [callEndpoint reifiedApi]
254− test $
255− executeParallel initialState actions