@@ -0,0 +1,229 @@
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.Direct
20+ ( fuzz
21+ )
22+where
23+
24+import Control.Monad.Trans.Control
25+import Control.Monad.State.Strict
26+import Control.Exception.Lifted(throw,Exception,SomeException,catch)
27+import System.Random
28+import System.Timeout.Lifted
29+import Control.Monad (guard)
30+import Control.Monad.IO.Class (MonadIO, liftIO)
31+import Data.Dynamic (Dynamic, dynApply, dynTypeRep, fromDynamic)
32+import qualified Data.List.NonEmpty as NEL
33+import qualified Data.Map.Strict as Map
34+import Data.Map.Strict(Map)
35+import Data.Maybe (mapMaybe)
36+import Data.Typeable (TypeRep)
37+import Hedgehog
38+ ( Callback (Update),
39+ Command (Command),
40+ Concrete,
41+ MonadGen,
42+ Opaque (Opaque),
43+ PropertyT,
44+ Symbolic,
45+ Var,
46+ executeSequential,
47+ forAll,
48+ opaque,
49+ )
50+import qualified Hedgehog.Gen as Gen
51+import qualified Hedgehog.Range as Range
52+import Roboservant.Hedgehog (elementOrFail)
53+import Roboservant.Types
54+ ( ApiOffset (..),
55+ FlattenServer (..),
56+ Op (..),
57+ ReifiedApi,
58+ State (..),
59+ ToReifiedApi (..),
60+ emptyState,
61+ )
62+import Servant (Endpoints, Proxy (Proxy), Server, ServerError)
63+import Type.Reflection (SomeTypeRep)
64+
65+-- prop_concurrent,
66+import Control.Monad (guard)
67+import Control.Monad.IO.Class (MonadIO, liftIO)
68+import Data.Dynamic (Dynamic, dynApply, dynTypeRep, fromDynamic)
69+import qualified Data.List.NonEmpty as NEL
70+import qualified Data.Map.Strict as Map
71+import Data.Maybe (mapMaybe)
72+import Data.Typeable (TypeRep)
73+import qualified Hedgehog.Gen as Gen
74+import qualified Hedgehog.Range as Range
75+import Roboservant.Hedgehog (elementOrFail)
76+import Roboservant.Types
77+ ( ApiOffset (..),
78+ FlattenServer (..),
79+ Op (..),
80+ ReifiedApi,
81+ State (..),
82+ ToReifiedApi (..),
83+ emptyState,
84+ )
85+import Servant (Endpoints, Proxy (Proxy), Server, ServerError)
86+import Type.Reflection (SomeTypeRep)
87+
88+data RoboservantException
89+ = RoboservantException FailureType SomeException FuzzOp FuzzState
90+ deriving (Show)
91+-- we believe in nussink, lebowski
92+instance Exception RoboservantException
93+
94+data FailureType
95+ = ServerCrashed
96+ | CheckerFailed
97+ | NoPossibleMoves
98+ deriving (Show,Eq)
99+
100+-- update :: Callback Op (Opaque (NEL.NonEmpty Dynamic)) State
101+-- update = Update $ \s@State {..} op o' ->
102+-- case op of
103+-- Chewable offset tr v -> case _extract offset trs chewable of
104+-- Nothing -> error "internal error"
105+-- Just (tr, _extracted, rest) ->
106+-- s
107+-- { stateRefs =
108+-- -- so, what's going on here... we need to be able to grab and merge
109+-- -- a list of (typeref, var). this means that we need to be able to pull
110+-- -- out typereps symbolically too, we can't just rely on the dynamic being there.
111+-- -- Map.insertWith (<>) (dynTypeRep v) _ (pure o') stateRefs,
112+-- Map.insertWith (<>) tr (_ o') stateRefs,
113+-- chewable = rest
114+-- }
115+-- (Op (ApiOffset _offset) _args) ->
116+-- s
117+-- { chewable = _ o' : chewable
118+-- -- Map.insertWith
119+-- -- (<>)
120+-- -- tr
121+-- -- (pure o')
122+-- -- stateRefs
123+-- }
124+
125+
126+data Reference = Reference
127+ { tr :: TypeRep
128+ , offset :: Int
129+ } deriving (Show,Eq)
130+
131+data FuzzOp = FuzzOp ApiOffset [Reference]
132+ deriving (Show,Eq)
133+
134+data Config
135+ = Config
136+ { seed :: [Dynamic]
137+ , maxRuntime :: Int -- seconds to test for
138+ , rngSeed :: Int
139+ , currentRng :: StdGen
140+ }
141+
142+data FuzzState = FuzzState
143+ { path :: [FuzzOp]
144+ , stash :: Map TypeRep (NEL.NonEmpty (Reference,Dynamic))
145+ }
146+ deriving (Show)
147+
148+fuzz :: forall api. (FlattenServer api, ToReifiedApi (Endpoints api))
149+ => Server api
150+ -> Config
151+ -> IO ()
152+ -> IO ()
153+fuzz server Config{..} checker =
154+ -- either we time out without finding an error, which is fine, or we find an error
155+ -- and throw an exception that propagates through this.
156+ void $ timeout (maxRuntime * 1000000) ( execStateT (forever go) FuzzState{..})
157+
158+ where
159+
160+ reifiedApi = toReifiedApi (flattenServer @api server) (Proxy @(Endpoints api))
161+
162+ elementOrFail :: MonadState FuzzState m
163+ => [a] -> m a
164+ elementOrFail = undefined
165+
166+ genOp :: MonadState FuzzState m
167+ => m FuzzOp
168+ genOp = do -- fs@FuzzState{..} = do
169+ -- choose a call to make, from the endpoints with fillable arguments.
170+ (offset, args) <- elementOrFail . options =<< get
171+ -- choose a (symbolic) argument from each. we drop the Dynamic here because it's
172+ -- not showable, which is no good for tests - though possibly it would make sense
173+ -- to use the constrained-dynamic stuff here? (or even just stash the string form)
174+ r <- (FuzzOp offset) <$> mapM (elementOrFail . fmap fst . NEL.toList) args
175+ modify' (\f -> f { path = r:path f })
176+ pure r
177+
178+
179+-- chooseOne opts = do
180+--
181+-- (offset,) <$> mapM elementOrFail args
182+ where
183+ options :: FuzzState -> [(ApiOffset, [NEL.NonEmpty (Reference, Dynamic)])]
184+ options FuzzState{..} =
185+ mapMaybe
186+ ( \(offset, (argreps, _dynCall)) -> (offset,) <$> do
187+ mapM (flip Map.lookup stash) argreps
188+ )
189+ reifiedApi
190+ execute :: MonadState FuzzState m
191+ => FuzzOp -> m ()
192+ execute = undefined
193+
194+
195+
196+ -- execute (Op (ApiOffset offset) args) = do
197+ -- fmap Opaque . liftIO $ do
198+ -- let realArgs = map opaque args
199+ -- let (_offset, (_staticArgs, endpoint)) = staticRoutes !! offset
200+ -- -- now, magic happens: we apply some dynamic arguments to a dynamic
201+ -- -- function and hopefully something useful pops out the end.
202+ -- func = foldr (\arg curr -> flip dynApply arg =<< curr) (Just endpoint) realArgs
203+ -- let showable = "blah" -- map dynTypeRep (_endpoint : realArgs)
204+ -- case func of
205+ -- Nothing -> error ("all screwed up: " <> maybe ("nothing: " <> show showable) (show . dynTypeRep) func)
206+ -- Just (f') -> do
207+ -- case fromDynamic f' of
208+ -- Nothing -> error ("all screwed up: " <> maybe ("nothing: " <> show showable) (show . dynTypeRep) func)
209+ -- Just f -> liftIO f >>= \case
210+ -- Left (serverError :: ServerError) -> error (show serverError)
211+ -- Right (_typeRep :: SomeTypeRep, (dyn :: NEL.NonEmpty Dynamic)) -> pure dyn
212+
213+
214+ go :: (MonadState FuzzState m, MonadIO m, MonadBaseControl IO m)
215+ => m ()
216+ go = do
217+ fuzzOp <- genOp
218+ catch (execute fuzzOp)
219+ (\(e :: SomeException) -> throw . RoboservantException ServerCrashed e fuzzOp =<< get)
220+ catch (liftIO checker)
221+ (\(e :: SomeException) -> throw . RoboservantException CheckerFailed e fuzzOp =<< get)
222+
223+ -- actions <-
224+ -- forAll $ do
225+ -- Gen.sequential
226+ -- (Range.linear 1 100)
227+ -- emptyState
228+ -- (fmap preload seed <> [callEndpoint reifiedApi])
229+ -- executeSequential emptyState actions