@@ -1,342 +0,0 @@
1−{-# LANGUAGE UndecidableInstances #-}
2−{-# LANGUAGE TypeFamilies #-}
3−{-# LANGUAGE GADTs #-}
4−{-# LANGUAGE PolyKinds #-}
5−{-# LANGUAGE TypeApplications #-}
6−{-# LANGUAGE MultiParamTypeClasses #-}
7−{-# LANGUAGE AllowAmbiguousTypes #-}
8−{-# LANGUAGE DataKinds #-}
9−{-# LANGUAGE DeriveAnyClass #-}
10−{-# LANGUAGE DeriveGeneric #-}
11−{-# LANGUAGE DerivingStrategies #-}
12−{-# LANGUAGE ExistentialQuantification #-}
13−{-# LANGUAGE FlexibleContexts #-}
14−{-# LANGUAGE FlexibleInstances #-}
15−{-# LANGUAGE GeneralizedNewtypeDeriving #-}
16−{-# LANGUAGE KindSignatures #-}
17−{-# LANGUAGE LambdaCase #-}
18−{-# LANGUAGE OverloadedStrings #-}
19−{-# LANGUAGE PartialTypeSignatures #-}
20−{-# LANGUAGE RankNTypes #-}
21−{-# LANGUAGE RecordWildCards #-}
22−{-# LANGUAGE ScopedTypeVariables #-}
23−{-# LANGUAGE StandaloneDeriving #-}
24−{-# LANGUAGE TemplateHaskell #-}
25−{-# LANGUAGE TupleSections #-}
26−{-# LANGUAGE TypeOperators #-}
27−
28−-- for servant
29−
30−module Roboservant.StateMachine where
31−
32−import Control.Arrow (second)
33−-- import Data.Dynamic (Dynamic, fromDynamic)
34−
35−--import Test.QuickCheck (Property)
36−-- import Test.StateMachine
37−
38−import Type.Reflection (SomeTypeRep)
39−import Servant.API.Flatten (Flat)
40−import GHC.TypeLits (Nat, Symbol)
41−import Data.Function ((&))
42−import Control.Concurrent (forkIO)
43−import Control.Monad ((<=<))
44−import Control.Monad.IO.Class
45−import Data.Aeson
46−import Data.Dynamic
47−import Data.IORef (IORef, newIORef)
48−import qualified Data.List.NonEmpty as NEL
49−import Data.List.NonEmpty (NonEmpty)
50−import Data.Map.Strict (Map)
51−import qualified Data.Map.Strict as Map
52−import Data.Maybe
53−import Data.Type.HasClass
54−import Data.Type.HasClassPreludeInstances
55−import Data.Typeable (TypeRep, Typeable, typeOf, typeRep)
56−import Debug.Trace (traceM, traceShowM)
57−import GHC.Generics (Generic)
58−import GHC.Generics
59−import GHC.IORef (readIORef)
60−import Control.Monad.Except (runExceptT)
61−import Hedgehog
62−import Hedgehog
63−import qualified Hedgehog.Gen as Gen
64−import qualified Hedgehog.Range as Range
65−import Network.HTTP.Client (defaultManagerSettings, newManager)
66−import Network.Wai
67−import Network.Wai.Handler.Warp
68−import Roboservant.ContextualGenRequest
69−import Servant
70−import Servant.Client
71−import Servant.Server (Server)
72−
73−-- | can then use either `forAllParallelCommands` or `forAllCommands` to turn
74−-- this into a property
75−--
76−-- TODO: how do we tie the model, command and response types to the Server?
77−-- genStateMachine :: HasContextualGenRequest a => Server a -> StateMachine Model Command IO Response
78−-- genStateMachine = StateMachine initModel _transition _precondition _postcondition
79−-- Nothing _generator _shrinker _semantics _mock
80−
81−-- initModel :: Model r
82−-- initModel = Model mempty
83−
84−-- newtype Model r = Model (Map TypeRep Dynamic)
85−
86−-- data Command r
87−-- = CallEndpoint
88−-- | Read (Reference (Opaque (IORef Int)) r)
89−-- | Write (Reference (Opaque (IORef Int)) r) Int
90−-- | Increment (Reference (Opaque (IORef Int)) r)
91−
92−-- data Response r
93−-- = Created (Reference (Opaque (IORef Int)) r)
94−-- | ReadValue Int
95−-- | Written
96−-- | Incremented
97−
98−-- deriving Show
99−
100−-- instance Eq MyDyn where
101−-- MyDyn a == MyDyn b = show a == show b
102−
103−data State v
104− = State
105− { stateRefs :: Map TypeRep (NonEmpty (Var (Opaque (IORef Dynamic)) v))
106− }
107−
108−class FlattenServer api where
109− flattenServer :: Server api -> Bundled (Endpoints api)
110−
111−instance
112− ( Endpoints (endpoint :<|> api) ~ (endpoint ': Endpoints api)
113− , Server (endpoint :<|> api) ~ (Server endpoint :<|> Server api)
114− , FlattenServer api
115− ) => FlattenServer (endpoint :<|> api) where
116− flattenServer (endpoint :<|> server) = endpoint `AnEndpoint` flattenServer @api server
117−
118−instance
119− ( HasServer (x :> api) '[]
120− , Endpoints (x :> api) ~ '[x :> api]
121− ) => FlattenServer (x :> api) where
122− flattenServer server = server `AnEndpoint` NoEndpoints
123−
124−instance
125− ( HasServer (Verb method statusCode contentTypes responseType) '[],
126− Endpoints (Verb method statusCode contentTypes responseType) ~ '[Verb method statusCode contentTypes responseType]
127− ) => FlattenServer (Verb method statusCode contentTypes responseType) where
128− flattenServer server = server `AnEndpoint` NoEndpoints
129−
130−type ReifiedEndpoint = ([TypeRep], TypeRep, Dynamic)
131−
132−type ReifiedApi = [(ApiOffset, [TypeRep], TypeRep, Dynamic)]
133−
134−data Bundled endpoints where
135− AnEndpoint :: Server endpoint -> Bundled endpoints -> Bundled (endpoint ': endpoints)
136− NoEndpoints :: Bundled '[]
137−
138−class ToReifiedApi (endpoints :: [*]) where
139− toReifiedApi :: Bundled endpoints -> Proxy endpoints -> ReifiedApi
140−
141−class ToReifiedEndpoint (endpoint :: *) where
142− toReifiedEndpoint :: Dynamic -> Proxy endpoint -> ReifiedEndpoint
143−
144−instance ToReifiedApi '[] where
145− toReifiedApi NoEndpoints _ = []
146−
147−instance (Typeable (Normal (ServerT endpoint Handler)), NormalizeFunction (ServerT endpoint Handler), ToReifiedEndpoint endpoint, ToReifiedApi endpoints, Typeable (ServerT endpoint Handler))
148− => ToReifiedApi (endpoint : endpoints)
149− where
150− toReifiedApi (endpoint `AnEndpoint` endpoints) _ =
151− withOffset (toReifiedEndpoint (toDyn (normalize endpoint)) (Proxy @endpoint))
152− : map (\(n, x, y, z) -> (n + 1, x, y, z))
153− (toReifiedApi endpoints (Proxy @endpoints))
154− where
155− withOffset (x, y, z) = (0, x, y, z)
156−
157−class NormalizeFunction m where
158− type Normal m
159− normalize :: m -> Normal m
160−
161−instance NormalizeFunction x => NormalizeFunction (r -> x) where
162− type Normal (r -> x) = r -> Normal x
163− normalize = fmap normalize
164−
165−instance Typeable x => NormalizeFunction (Handler x) where
166− type Normal (Handler x) = IO (Either ServerError (TypeRep, Dynamic))
167− normalize handler = (runExceptT . runHandler') handler >>= \case
168− Left serverError -> pure (Left serverError)
169− Right x -> pure (Right (typeRep (Proxy @x), toDyn x))
170−
171−instance Typeable responseType
172− => ToReifiedEndpoint (Verb method statusCode contentTypes responseType)
173− where
174− toReifiedEndpoint endpoint _ =
175− ([], typeRep (Proxy @responseType), endpoint)
176−
177−instance (ToReifiedEndpoint endpoint)
178− => ToReifiedEndpoint ((x :: Symbol) :> endpoint)
179− where
180− toReifiedEndpoint endpoint _ =
181− toReifiedEndpoint endpoint (Proxy @endpoint)
182−
183−instance (Typeable requestType, ToReifiedEndpoint endpoint)
184− => ToReifiedEndpoint (Capture name requestType :> endpoint)
185− where
186− toReifiedEndpoint endpoint _ =
187− toReifiedEndpoint endpoint (Proxy @endpoint)
188− & \(args, result, typeRepMap) -> (typeRep (Proxy @requestType) : args, result, typeRepMap)
189−
190−instance (Typeable requestType, ToReifiedEndpoint endpoint)
191− => ToReifiedEndpoint (ReqBody contentTypes requestType :> endpoint)
192− where
193− toReifiedEndpoint endpoint _ =
194− toReifiedEndpoint endpoint (Proxy @endpoint)
195− & \(args, result, typeRepMap) -> (typeRep (Proxy @requestType) : args, result, typeRepMap)
196−
197−newtype ApiOffset = ApiOffset Int
198− deriving (Eq, Show)
199− deriving newtype (Enum, Num)
200−
201−-- | we need to specify an offset because it's entirely possible to have two
202−-- functions with the same arguments that do different things.
203−data Op (v :: * -> *) = Op ApiOffset [(TypeRep, Var (Opaque (IORef Dynamic)) v)]
204−
205−deriving instance Show (Op Symbolic)
206−
207−instance HTraversable Op where
208− htraverse r op@(Op offset args) = Op offset <$> traverse (\(t, v) -> (t,) <$> htraverse r v) args
209−
210−callEndpoint :: (MonadGen n, MonadIO m) => ReifiedApi -> Command n m State
211−callEndpoint staticRoutes =
212− let gen :: MonadGen n => State Symbolic -> Maybe (n (Op Symbolic))
213− gen State {..}
214− | any null options = Nothing
215− | otherwise = Just $ do
216− uncurry Op <$> chooseOne options
217− where
218− chooseOne ::
219− MonadGen n =>
220− [ ( ApiOffset,
221− [(TypeRep, [Var (Opaque (IORef Dynamic)) Symbolic])]
222− )
223− ] ->
224− n
225− ( ApiOffset,
226− [(TypeRep, Var (Opaque (IORef Dynamic)) Symbolic)]
227− )
228− chooseOne opts = do
229− (offset, args) <- Gen.element opts
230− (offset,) <$> mapM (\(tr, argOpts) -> (tr,) <$> Gen.element argOpts) args
231− options :: [(ApiOffset, [(TypeRep, [Var (Opaque (IORef Dynamic)) Symbolic])])]
232− options =
233− mapMaybe
234− ( \(offset, argreps, retType, dynCall) -> (offset,) <$> do
235− mapM (\x -> (x,) <$> fillableWith x) argreps
236− )
237− staticRoutes
238− fillableWith :: TypeRep -> Maybe [Var (Opaque (IORef Dynamic)) Symbolic]
239− fillableWith tr = NEL.toList <$> Map.lookup tr stateRefs
240− execute ::
241− (MonadIO m) =>
242− Op Concrete ->
243− m (Opaque (IORef Dynamic))
244− execute (Op (ApiOffset offset) args) = do
245− -- traceM (show (offset, args))
246− fmap Opaque . liftIO $ do
247− realArgs <- mapM (\(tr, v) -> readIORef (opaque v)) args
248− let (_offset, staticArgs, ret, endpoint) = staticRoutes !! offset
249− -- now, magic happens: we apply some dynamic arguments to a dynamic
250− -- function and hopefully somtehing useful pops out the end.
251− func = foldr (\arg curr -> flip dynApply arg =<< curr) (Just endpoint) realArgs
252− let showable = map dynTypeRep (endpoint : realArgs)
253− case func of
254− Nothing -> error ("all screwed up: " <> maybe ("nothing: " <> show showable) (show . dynTypeRep) func)
255− Just (f') -> do
256− case fromDynamic f' of
257− Nothing -> error ("all screwed up: " <> maybe ("nothing: " <> show showable) (show . dynTypeRep) func)
258− Just f -> liftIO f >>= \case
259− Left (serverError :: ServerError) -> error (show serverError)
260− Right (typeRep :: SomeTypeRep, (dyn :: Dynamic)) -> newIORef dyn
261− in Command
262− gen
263− execute
264− [ Update $ \s@State {..} (Op (ApiOffset offset) args) o' ->
265− -- let foo :: Var (Opaque Dynamic) v -> Var (Opaque (IORef Dynamic)) v
266− -- foo = _ . opaque
267− -- in
268− s
269− { stateRefs =
270− let (_, _, tr, _) = staticRoutes !! offset
271− in Map.insertWith
272− (<>)
273− tr
274− (pure o')
275− stateRefs
276− }
277− -- , Ensure (no-500 here)
278− ]
279−
280−prop_sm_sequential :: ReifiedApi -> Property
281−prop_sm_sequential reifiedApi = do
282− property $ do
283− let initialState = State mempty
284− actions <-
285− forAll $
286− Gen.sequential
287− (Range.linear 1 100)
288− initialState
289− [callEndpoint reifiedApi]
290− executeSequential initialState actions
291−
292−newtype Foo = Foo Int
293− deriving (Generic, Eq, Show, Typeable)
294− deriving newtype (FromHttpApiData, ToHttpApiData)
295−
296−instance ToJSON Foo
297−
298−instance FromJSON Foo
299−
300−type FooApi =
301− "item" :> Get '[JSON] Foo
302− :<|> "itemAdd" :> Capture "one" Foo :> Capture "two" Foo :> Get '[JSON] Foo
303− :<|> "item" :> Capture "itemId" Foo :> Get '[JSON] ()
304−
305−intro = pure (Foo 1)
306−
307−combine = (\(Foo a) (Foo b) -> pure (Foo (a + b)))
308−
309−eliminate =
310− ( \(Foo a) ->
311− if a > 10
312− then error "eliminate blew up, oh no!"
313− else pure ()
314− )
315−
316−fooServer :: Server FooApi
317−fooServer =
318− intro
319− :<|> combine
320− :<|> eliminate
321−
322−bundledFooServer :: Bundled (Endpoints FooApi)
323−bundledFooServer = flattenServer @FooApi fooServer
324−
325−runServer :: IO ()
326−runServer = do
327− let port = 3000
328− settings =
329− setPort port
330− $ setBeforeMainLoop (putStrLn ("listening on port " ++ show port))
331− $ defaultSettings
332− runSettings settings (serve fooApi fooServer)
333−
334−fooApi :: Proxy FooApi
335−fooApi = Proxy
336−
337−introC :<|> combineC :<|> eliminateC = Servant.Client.client fooApi
338−
339−tests :: IO Bool
340−tests = do
341− let reifiedApi = toReifiedApi (flattenServer @FooApi fooServer) (Proxy @(Endpoints FooApi))
342− checkParallel $ Group "props" [("aprop", prop_sm_sequential reifiedApi)]