@@ -1,250 +0,0 @@
1−{-# LANGUAGE AllowAmbiguousTypes #-}
2−{-# LANGUAGE DataKinds #-}
3−{-# LANGUAGE DerivingStrategies #-}
4−{-# LANGUAGE FlexibleContexts #-}
5−{-# LANGUAGE FlexibleInstances #-}
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 #-}
19−module Roboservant.StateMachine where
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)
35−import qualified Hedgehog.Gen as Gen
36−import qualified Hedgehog.Range as Range
38−import Type.Reflection (SomeTypeRep)
42− { stateRefs :: Map TypeRep (NonEmpty (Var (Opaque (IORef Dynamic)) v))
45−class FlattenServer api where
46− flattenServer :: Server api -> Bundled (Endpoints api)
49− ( Endpoints (endpoint :<|> api) ~ (endpoint ': Endpoints api),
50− Server (endpoint :<|> api) ~ (Server endpoint :<|> Server api),
53− FlattenServer (endpoint :<|> api)
55− flattenServer (endpoint :<|> server) = endpoint `AnEndpoint` flattenServer @api server
58− ( HasServer (x :> api) '[],
59− Endpoints (x :> api) ~ '[x :> api]
61− FlattenServer (x :> api)
63− flattenServer server = server `AnEndpoint` NoEndpoints
66− ( HasServer (Verb method statusCode contentTypes responseType) '[],
67− Endpoints (Verb method statusCode contentTypes responseType) ~ '[Verb method statusCode contentTypes responseType]
69− FlattenServer (Verb method statusCode contentTypes responseType)
71− flattenServer server = server `AnEndpoint` NoEndpoints
73−type ReifiedEndpoint = ([TypeRep], TypeRep, Dynamic)
75−type ReifiedApi = [(ApiOffset, [TypeRep], TypeRep, Dynamic)]
77−data Bundled endpoints where
78− AnEndpoint :: Server endpoint -> Bundled endpoints -> Bundled (endpoint ': endpoints)
79− NoEndpoints :: Bundled '[]
81−class ToReifiedApi (endpoints :: [*]) where
82− toReifiedApi :: Bundled endpoints -> Proxy endpoints -> ReifiedApi
84−class ToReifiedEndpoint (endpoint :: *) where
85− toReifiedEndpoint :: Dynamic -> Proxy endpoint -> ReifiedEndpoint
87−instance ToReifiedApi '[] where
88− toReifiedApi NoEndpoints _ = []
91− (Typeable (Normal (ServerT endpoint Handler)), NormalizeFunction (ServerT endpoint Handler), ToReifiedEndpoint endpoint, ToReifiedApi endpoints, Typeable (ServerT endpoint Handler)) =>
92− ToReifiedApi (endpoint : endpoints)
94− toReifiedApi (endpoint `AnEndpoint` endpoints) _ =
95− withOffset (toReifiedEndpoint (toDyn (normalize endpoint)) (Proxy @endpoint))
97− (\(n, x, y, z) -> (n + 1, x, y, z))
98− (toReifiedApi endpoints (Proxy @endpoints))
100− withOffset (x, y, z) = (0, x, y, z)
102−class NormalizeFunction m where
104− normalize :: m -> Normal m
106−instance NormalizeFunction x => NormalizeFunction (r -> x) where
107− type Normal (r -> x) = r -> Normal x
108− normalize = fmap normalize
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))
117− Typeable responseType =>
118− ToReifiedEndpoint (Verb method statusCode contentTypes responseType)
120− toReifiedEndpoint endpoint _ =
121− ([], typeRep (Proxy @responseType), endpoint)
124− (ToReifiedEndpoint endpoint) =>
125− ToReifiedEndpoint ((x :: Symbol) :> endpoint)
127− toReifiedEndpoint endpoint _ =
128− toReifiedEndpoint endpoint (Proxy @endpoint)
131− (Typeable requestType, ToReifiedEndpoint endpoint) =>
132− ToReifiedEndpoint (Capture name requestType :> endpoint)
134− toReifiedEndpoint endpoint _ =
135− toReifiedEndpoint endpoint (Proxy @endpoint)
136− & \(args, result, typeRepMap) -> (typeRep (Proxy @requestType) : args, result, typeRepMap)
139− (Typeable requestType, ToReifiedEndpoint endpoint) =>
140− ToReifiedEndpoint (ReqBody contentTypes requestType :> endpoint)
142− toReifiedEndpoint endpoint _ =
143− toReifiedEndpoint endpoint (Proxy @endpoint)
144− & \(args, result, typeRepMap) -> (typeRep (Proxy @requestType) : args, result, typeRepMap)
146−newtype ApiOffset = ApiOffset Int
148− deriving newtype (Enum, Num)
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)]
154−deriving instance Show (Op Symbolic)
156−instance HTraversable Op where
157− htraverse r (Op offset args) = Op offset <$> traverse (\(t, v) -> (t,) <$> htraverse r v) args
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))
163− | any null options = Nothing
164− | otherwise = Just $ do
165− uncurry Op <$> chooseOne options
170− [(TypeRep, [Var (Opaque (IORef Dynamic)) Symbolic])]
175− [(TypeRep, Var (Opaque (IORef Dynamic)) Symbolic)]
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])])]
183− ( \(offset, argreps, _retType, _dynCall) -> (offset,) <$> do
184− mapM (\x -> (x,) <$> fillableWith x) argreps
187− fillableWith :: TypeRep -> Maybe [Var (Opaque (IORef Dynamic)) Symbolic]
188− fillableWith tr = NEL.toList <$> Map.lookup tr stateRefs
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)
203− Nothing -> error ("all screwed up: " <> maybe ("nothing: " <> show showable) (show . dynTypeRep) func)
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
213− [ Update $ \s@State {..} (Op (ApiOffset offset) _args) o' ->
216− let (_, _, tr, _) = staticRoutes !! offset
223− -- , Ensure (no-500 here)
226−prop_sequential :: ReifiedApi -> Property
227−prop_sequential reifiedApi = do
229− let initialState = State mempty
233− (Range.linear 1 100)
235− [callEndpoint reifiedApi]
236− executeSequential initialState actions
238−prop_concurrent :: ReifiedApi -> Property
239−prop_concurrent reifiedApi =
240− let initialState = State mempty
241− in withTests 1000 . withRetries 10 . property $ do
248− [callEndpoint reifiedApi]
250− executeParallel initialState actions