@@ -1,3 +1,7 @@
1+{-# LANGUAGE TemplateHaskell #-}
2+{-# LANGUAGE FlexibleContexts #-}
3+{-# LANGUAGE DeriveAnyClass #-}
4+{-# LANGUAGE OverloadedStrings #-}
15{-# LANGUAGE LambdaCase #-}
26{-# LANGUAGE AllowAmbiguousTypes #-}
37{-# LANGUAGE DataKinds #-}
@@ -10,6 +14,11 @@
1014{-# LANGUAGE RecordWildCards #-}
1115{-# LANGUAGE StandaloneDeriving #-}
1216{-# LANGUAGE TupleSections #-}
17+
18+-- for servant
19+{-# LANGUAGE TypeOperators #-}
20+{-# LANGUAGE DeriveGeneric #-}
21+{-# LANGUAGE ScopedTypeVariables #-}
1322module Roboservant.StateMachine where
1423
1524import Data.Maybe
@@ -20,12 +29,14 @@ import Data.IORef (IORef)
2029-- import Data.Dynamic (Dynamic, fromDynamic)
2130import Data.Map.Strict (Map)
2231import qualified Data.Map.Strict as Map
23−import Data.Typeable (TypeRep, Typeable, typeRep)
32+import Data.Typeable (typeOf, TypeRep, Typeable, typeRep)
2433import Roboservant.ContextualGenRequest
2534import Servant.Server (Server)
2635--import Test.QuickCheck (Property)
2736-- import Test.StateMachine
2837
38+import Hedgehog
39+
2940import qualified Data.List.NonEmpty as NEL
3041import Data.List.NonEmpty(NonEmpty)
3142import Data.Dynamic
@@ -35,7 +46,16 @@ import Hedgehog
3546import qualified Hedgehog.Gen as Gen
3647import Control.Monad ((<=<))
3748import GHC.IORef (readIORef)
49+import qualified Hedgehog.Range as Range
3850
51+import Servant
52+import GHC.Generics(Generic)
53+import Data.Aeson
54+import GHC.Generics
55+import Network.Wai
56+import Network.Wai.Handler.Warp
57+import Control.Concurrent(forkIO)
58+import Network.HTTP.Client(newManager, defaultManagerSettings)
3959
4060-- | can then use either `forAllParallelCommands` or `forAllCommands` to turn
4161-- this into a property
@@ -131,10 +151,8 @@ callEndpoint staticRoutes env =
131151 -- function and hopefully somtehing useful pops out the end.
132152 func = foldr ( \arg curr -> dynApply arg =<< curr ) (Just endpoint) realArgs
133153 case func >>= fromDynamic of
134− Nothing -> error "all screwed up"
135− Just f -> runClientM f env >>= either (error . show) (pure . toDyn)
136−
137− undefined -- case fromDynamic
154+ Nothing -> error ("all screwed up: " <> maybe "nothing" (show . dynTypeRep) func)
155+ Just (f :: ClientM a) -> runClientM f env >>= either (error . show) pure
138156
139157 in Command gen execute
140158 [ Update $ \s@State{..} (Op (ApiOffset offset) args) o ->
@@ -143,3 +161,89 @@ callEndpoint staticRoutes env =
143161 }
144162 -- , Ensure (no-500 here)
145163 ]
164+
165+
166+
167+prop_sm_sequential :: ReifiedApi -> ClientEnv -> Property
168+prop_sm_sequential reifiedApi clientEnv = do
169+ property $ do
170+ let
171+ initialState = State mempty clientEnv
172+ actions <- forAll $ Gen.sequential (Range.linear 1 100) initialState
173+ [callEndpoint reifiedApi clientEnv]
174+ executeSequential initialState actions
175+
176+
177+
178+newtype Foo = Foo Int
179+ deriving (Generic, Eq, Show)
180+ deriving newtype (FromHttpApiData,ToHttpApiData)
181+
182+instance ToJSON Foo
183+instance FromJSON Foo
184+
185+type FooApi
186+ = "item" :> Get '[JSON] Foo
187+ :<|> "itemAdd" :> Capture "one" Foo :> Capture "two" Foo :> Get '[JSON] Foo
188+ :<|> "item" :> Capture "itemId" Foo :> Get '[JSON] ()
189+
190+
191+intro = pure (Foo 1)
192+combine = (\(Foo a) (Foo b) -> pure (Foo (a+b)))
193+eliminate = (\(Foo a) -> if a > 10
194+ then error "fuck"
195+ else pure ())
196+
197+fooServer :: Server FooApi
198+fooServer = intro
199+ :<|> combine
200+ :<|> eliminate
201+
202+
203+runServer :: IO ()
204+runServer = do
205+ let port = 3000
206+ settings =
207+ setPort port $
208+ setBeforeMainLoop (putStrLn ("listening on port " ++ show port)) $
209+ defaultSettings
210+ runSettings settings (serve fooApi fooServer)
211+
212+fooApi :: Proxy FooApi
213+fooApi = Proxy
214+
215+introC :<|> combineC :<|> eliminateC = Servant.Client.client fooApi
216+
217+tests :: IO Bool
218+tests = do
219+ withServantServer fooApi (pure fooServer) $ \burl -> do
220+ manager <- newManager defaultManagerSettings
221+ let clientEnv = mkClientEnv manager burl
222+ -- faking this out for now.
223+ footype = typeOf Foo
224+ reifiedApi = [(ApiOffset 0, [],footype,toDyn introC)
225+ ,(ApiOffset 1, [footype, footype],footype,toDyn combineC)
226+ ,(ApiOffset 2, [footype],(typeOf ()),toDyn eliminateC)]
227+
228+ -- type ReifiedApi = [(ApiOffset, [TypeRep], TypeRep, MyDyn)]
229+ checkParallel $ Group "props" [("aprop", prop_sm_sequential reifiedApi clientEnv )]
230+
231+
232+
233+-- | Start a servant application on an open port, run the provided function,
234+-- then stop the application.
235+--
236+-- /Since 0.0.0.0/
237+withServantServer :: HasServer a '[] => Proxy a -> IO (Server a)
238+ -> (BaseUrl -> IO r) -> IO r
239+withServantServer api = withServantServerAndContext api EmptyContext
240+
241+-- | Like 'withServantServer', but allows passing in a 'Context' to the
242+-- application.
243+--
244+-- /Since 0.0.0.0/
245+withServantServerAndContext :: (HasServer a ctx)
246+ => Proxy a -> Context ctx -> IO (Server a) -> (BaseUrl -> IO r) -> IO r
247+withServantServerAndContext api ctx server t
248+ = withApplication (return . serveWithContext api ctx =<< server) $ \port ->
249+ t (BaseUrl Http "localhost" port "")