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