@@ -1,294 +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 Servant.API.Modifiers
42−import Type.Reflection (SomeTypeRep)
43−
44−data State v
45− = State
46− { stateRefs :: Map TypeRep (NonEmpty (Var (Opaque (IORef Dynamic)) v))
47− }
48−
49−class FlattenServer api where
50− flattenServer :: Server api -> Bundled (Endpoints api)
51−
52−instance
53− ( Endpoints (endpoint :<|> api) ~ (endpoint ': Endpoints api),
54− Server (endpoint :<|> api) ~ (Server endpoint :<|> Server api),
55− FlattenServer api
56− ) =>
57− FlattenServer (endpoint :<|> api)
58− where
59− flattenServer (endpoint :<|> server) = endpoint `AnEndpoint` flattenServer @api server
60−
61−instance
62− ( HasServer (x :> api) '[],
63− Endpoints (x :> api) ~ '[x :> api]
64− ) =>
65− FlattenServer (x :> api)
66− where
67− flattenServer server = server `AnEndpoint` NoEndpoints
68−
69−instance
70− ( HasServer (Verb method statusCode contentTypes responseType) '[],
71− Endpoints (Verb method statusCode contentTypes responseType) ~ '[Verb method statusCode contentTypes responseType]
72− ) =>
73− FlattenServer (Verb method statusCode contentTypes responseType)
74− where
75− flattenServer server = server `AnEndpoint` NoEndpoints
76−
77−type ReifiedEndpoint = ([TypeRep], TypeRep, Dynamic)
78−
79−type ReifiedApi = [(ApiOffset, [TypeRep], TypeRep, Dynamic)]
80−
81−data Bundled endpoints where
82− AnEndpoint :: Server endpoint -> Bundled endpoints -> Bundled (endpoint ': endpoints)
83− NoEndpoints :: Bundled '[]
84−
85−class ToReifiedApi (endpoints :: [*]) where
86− toReifiedApi :: Bundled endpoints -> Proxy endpoints -> ReifiedApi
87−
88−class ToReifiedEndpoint (endpoint :: *) where
89− toReifiedEndpoint :: Dynamic -> Proxy endpoint -> ReifiedEndpoint
90−
91−instance ToReifiedApi '[] where
92− toReifiedApi NoEndpoints _ = []
93−
94−instance
95− (Typeable (Normal (ServerT endpoint Handler)), NormalizeFunction (ServerT endpoint Handler), ToReifiedEndpoint endpoint, ToReifiedApi endpoints, Typeable (ServerT endpoint Handler)) =>
96− ToReifiedApi (endpoint : endpoints)
97− where
98− toReifiedApi (endpoint `AnEndpoint` endpoints) _ =
99− withOffset (toReifiedEndpoint (toDyn (normalize endpoint)) (Proxy @endpoint))
100− : map
101− (\(n, x, y, z) -> (n + 1, x, y, z))
102− (toReifiedApi endpoints (Proxy @endpoints))
103− where
104− withOffset (x, y, z) = (0, x, y, z)
105−
106−class NormalizeFunction m where
107− type Normal m
108− normalize :: m -> Normal m
109−
110−instance NormalizeFunction x => NormalizeFunction (r -> x) where
111− type Normal (r -> x) = r -> Normal x
112− normalize = fmap normalize
113−
114−instance Typeable x => NormalizeFunction (Handler x) where
115− type Normal (Handler x) = IO (Either ServerError (TypeRep, Dynamic))
116− normalize handler = (runExceptT . runHandler') handler >>= \case
117− Left serverError -> pure (Left serverError)
118− Right x -> pure (Right (typeRep (Proxy @x), toDyn x))
119−
120−instance
121− Typeable responseType =>
122− ToReifiedEndpoint (Verb method statusCode contentTypes responseType)
123− where
124− toReifiedEndpoint endpoint _ =
125− ([], typeRep (Proxy @responseType), endpoint)
126−
127−instance
128− (ToReifiedEndpoint endpoint) =>
129− ToReifiedEndpoint ((x :: Symbol) :> endpoint)
130− where
131− toReifiedEndpoint endpoint _ =
132− toReifiedEndpoint endpoint (Proxy @endpoint)
133−
134−instance
135− (ToReifiedEndpoint endpoint) =>
136− ToReifiedEndpoint (Description s :> endpoint)
137− where
138− toReifiedEndpoint endpoint _ =
139− toReifiedEndpoint endpoint (Proxy @endpoint)
140−
141−instance
142− (ToReifiedEndpoint endpoint) =>
143− ToReifiedEndpoint (Summary s :> endpoint)
144− where
145− toReifiedEndpoint endpoint _ =
146− toReifiedEndpoint endpoint (Proxy @endpoint)
147−
148−instance
149− (Typeable requestType, ToReifiedEndpoint endpoint) =>
150− ToReifiedEndpoint (QueryFlag name :> endpoint)
151− where
152− toReifiedEndpoint endpoint _ =
153− toReifiedEndpoint endpoint (Proxy @endpoint)
154− & \(args, result, typeRepMap) -> (typeRep (Proxy @Bool) : args, result, typeRepMap)
155−
156−instance
157− (Typeable (If (FoldRequired mods) paramType (Maybe paramType)), ToReifiedEndpoint endpoint, SBoolI (FoldRequired mods)) =>
158− ToReifiedEndpoint (QueryParam' mods name paramType :> endpoint)
159− where
160− toReifiedEndpoint endpoint _ =
161− toReifiedEndpoint endpoint (Proxy @endpoint)
162− & \(args, result, typeRepMap) -> (typeRep (Proxy @(If (FoldRequired mods) paramType (Maybe paramType))) : args, result, typeRepMap)
163−
164−instance
165− (Typeable (If (FoldRequired mods) headerType (Maybe headerType)), ToReifiedEndpoint endpoint, SBoolI (FoldRequired mods)) =>
166− ToReifiedEndpoint (Header' mods headerName headerType :> endpoint)
167− where
168− toReifiedEndpoint endpoint _ =
169− toReifiedEndpoint endpoint (Proxy @endpoint)
170− & \(args, result, typeRepMap) -> (typeRep (Proxy @(If (FoldRequired mods) headerType (Maybe headerType))) : args, result, typeRepMap)
171−
172−instance
173− (Typeable captureType, ToReifiedEndpoint endpoint) =>
174− ToReifiedEndpoint (Capture' mods name captureType :> endpoint)
175− where
176− toReifiedEndpoint endpoint _ =
177− toReifiedEndpoint endpoint (Proxy @endpoint)
178− & \(args, result, typeRepMap) -> (typeRep (Proxy @captureType) : args, result, typeRepMap)
179−
180−instance
181− (Typeable (If (FoldLenient mods) (Either String requestType) requestType), ToReifiedEndpoint endpoint, SBoolI (FoldLenient mods)) =>
182− ToReifiedEndpoint (ReqBody' mods contentTypes requestType :> endpoint)
183− where
184− toReifiedEndpoint endpoint _ =
185− toReifiedEndpoint endpoint (Proxy @endpoint)
186− & \(args, result, typeRepMap) -> (typeRep (Proxy @(If (FoldLenient mods) (Either String requestType) requestType)) : args, result, typeRepMap)
187−
188−newtype ApiOffset = ApiOffset Int
189− deriving (Eq, Show)
190− deriving newtype (Enum, Num)
191−
192−-- | we need to specify an offset because it's entirely possible to have two
193−-- functions with the same arguments that do different things.
194−data Op (v :: * -> *) = Op ApiOffset [(TypeRep, Var (Opaque (IORef Dynamic)) v)]
195−
196−deriving instance Show (Op Symbolic)
197−
198−instance HTraversable Op where
199− htraverse r (Op offset args) = Op offset <$> traverse (\(t, v) -> (t,) <$> htraverse r v) args
200−
201−callEndpoint :: (MonadGen n, MonadIO m) => ReifiedApi -> Command n m State
202−callEndpoint staticRoutes =
203− let gen :: MonadGen n => State Symbolic -> Maybe (n (Op Symbolic))
204− gen State {..}
205− | any null options = Nothing
206− | otherwise = Just $ do
207− uncurry Op <$> chooseOne options
208− where
209− chooseOne ::
210− MonadGen n =>
211− [ ( ApiOffset,
212− [(TypeRep, [Var (Opaque (IORef Dynamic)) Symbolic])]
213− )
214− ] ->
215− n
216− ( ApiOffset,
217− [(TypeRep, Var (Opaque (IORef Dynamic)) Symbolic)]
218− )
219− chooseOne opts = do
220− (offset, args) <- Gen.element opts
221− (offset,) <$> mapM (\(tr, argOpts) -> (tr,) <$> Gen.element argOpts) args
222− options :: [(ApiOffset, [(TypeRep, [Var (Opaque (IORef Dynamic)) Symbolic])])]
223− options =
224− mapMaybe
225− ( \(offset, argreps, _retType, _dynCall) -> (offset,) <$> do
226− mapM (\x -> (x,) <$> fillableWith x) argreps
227− )
228− staticRoutes
229− fillableWith :: TypeRep -> Maybe [Var (Opaque (IORef Dynamic)) Symbolic]
230− fillableWith tr = NEL.toList <$> Map.lookup tr stateRefs
231− execute ::
232− (MonadIO m) =>
233− Op Concrete ->
234− m (Opaque (IORef Dynamic))
235− execute (Op (ApiOffset offset) args) = do
236− -- traceM (show (offset, args))
237− fmap Opaque . liftIO $ do
238− realArgs <- mapM (\(_tr, v) -> readIORef (opaque v)) args
239− let (_offset, _staticArgs, _ret, endpoint) = staticRoutes !! offset
240− -- now, magic happens: we apply some dynamic arguments to a dynamic
241− -- function and hopefully somtehing useful pops out the end.
242− func = foldr (\arg curr -> flip dynApply arg =<< curr) (Just endpoint) realArgs
243− let showable = map dynTypeRep (endpoint : realArgs)
244− case func of
245− Nothing -> error ("all screwed up: " <> maybe ("nothing: " <> show showable) (show . dynTypeRep) func)
246− Just (f') -> do
247− case fromDynamic f' of
248− Nothing -> error ("all screwed up: " <> maybe ("nothing: " <> show showable) (show . dynTypeRep) func)
249− Just f -> liftIO f >>= \case
250− Left (serverError :: ServerError) -> error (show serverError)
251− Right (_typeRep :: SomeTypeRep, (dyn :: Dynamic)) -> newIORef dyn
252− in Command
253− gen
254− execute
255− [ Update $ \s@State {..} (Op (ApiOffset offset) _args) o' ->
256− s
257− { stateRefs =
258− let (_, _, tr, _) = staticRoutes !! offset
259− in Map.insertWith
260− (<>)
261− tr
262− (pure o')
263− stateRefs
264− }
265− -- , Ensure (no-500 here)
266− ]
267−
268−prop_sequential :: forall api. (FlattenServer api, ToReifiedApi (Endpoints api)) => Server api -> Property
269−prop_sequential server = do
270− let reifiedApi = toReifiedApi (flattenServer @api server) (Proxy @(Endpoints api))
271− property $ do
272− let initialState = State mempty
273− actions <-
274− forAll $
275− Gen.sequential
276− (Range.linear 1 100)
277− initialState
278− [callEndpoint reifiedApi]
279− executeSequential initialState actions
280−
281−prop_concurrent :: forall api. (FlattenServer api, ToReifiedApi (Endpoints api)) => Server api -> Property
282−prop_concurrent server =
283− let reifiedApi = toReifiedApi (flattenServer @api server) (Proxy @(Endpoints api)) in
284− let initialState = State mempty
285− in withTests 1000 . withRetries 10 . property $ do
286− actions <-
287− forAll $
288− Gen.parallel
289− (Range.linear 1 50)
290− (Range.linear 1 10)
291− initialState
292− [callEndpoint reifiedApi]
293− test $
294− executeParallel initialState actions