@@ -21,182 +21,21 @@ module Roboservant.StateMachine
2121, prop_concurrent
2222) where
2323
24−import Control.Monad.Except (runExceptT)
2524import Control.Monad.IO.Class (MonadIO, liftIO)
26−import Data.Dynamic (Dynamic, dynApply, dynTypeRep, fromDynamic, toDyn)
27−import Data.Function ((&))
25+import Data.Dynamic (Dynamic, dynApply, dynTypeRep, fromDynamic)
2826import Data.IORef (IORef, newIORef)
2927import qualified Data.List.NonEmpty as NEL
30−import Data.List.NonEmpty (NonEmpty)
31−import Data.Map.Strict (Map)
3228import qualified Data.Map.Strict as Map
3329import Data.Maybe (mapMaybe)
34−import Data.Typeable (TypeRep, Typeable, typeRep)
30+import Data.Typeable (TypeRep)
3531import GHC.IORef (readIORef)
36−import GHC.TypeLits (Symbol)
3732import Hedgehog
3833import qualified Hedgehog.Gen as Gen
3934import qualified Hedgehog.Range as Range
4035import Servant
41−import Servant.API.Modifiers
4236import Type.Reflection (SomeTypeRep)
4337
44−data State v
45− = State
46− { stateRefs :: Map TypeRep (NonEmpty (Var (Opaque (IORef Dynamic)) v))
47− }
48−
49−class FlattenServer api where
50− flattenServer :: Server api -> Bundled (Endpoints api)
51−
52−instance
53− ( Endpoints (endpoint :<|> api) ~ (endpoint ': Endpoints api),
54− Server (endpoint :<|> api) ~ (Server endpoint :<|> Server api),
55− FlattenServer api
56− ) =>
57− FlattenServer (endpoint :<|> api)
58− where
59− flattenServer (endpoint :<|> server) = endpoint `AnEndpoint` flattenServer @api server
60−
61−instance
62− ( HasServer (x :> api) '[],
63− Endpoints (x :> api) ~ '[x :> api]
64− ) =>
65− FlattenServer (x :> api)
66− where
67− flattenServer server = server `AnEndpoint` NoEndpoints
68−
69−instance
70− ( HasServer (Verb method statusCode contentTypes responseType) '[],
71− Endpoints (Verb method statusCode contentTypes responseType) ~ '[Verb method statusCode contentTypes responseType]
72− ) =>
73− FlattenServer (Verb method statusCode contentTypes responseType)
74− where
75− flattenServer server = server `AnEndpoint` NoEndpoints
76−
77−type ReifiedEndpoint = ([TypeRep], TypeRep, Dynamic)
78−
79−type ReifiedApi = [(ApiOffset, [TypeRep], TypeRep, Dynamic)]
80−
81−data Bundled endpoints where
82− AnEndpoint :: Server endpoint -> Bundled endpoints -> Bundled (endpoint ': endpoints)
83− NoEndpoints :: Bundled '[]
84−
85−class ToReifiedApi (endpoints :: [*]) where
86− toReifiedApi :: Bundled endpoints -> Proxy endpoints -> ReifiedApi
87−
88−class ToReifiedEndpoint (endpoint :: *) where
89− toReifiedEndpoint :: Dynamic -> Proxy endpoint -> ReifiedEndpoint
90−
91−instance ToReifiedApi '[] where
92− toReifiedApi NoEndpoints _ = []
93−
94−instance
95− (Typeable (Normal (ServerT endpoint Handler)), NormalizeFunction (ServerT endpoint Handler), ToReifiedEndpoint endpoint, ToReifiedApi endpoints, Typeable (ServerT endpoint Handler)) =>
96− ToReifiedApi (endpoint : endpoints)
97− where
98− toReifiedApi (endpoint `AnEndpoint` endpoints) _ =
99− withOffset (toReifiedEndpoint (toDyn (normalize endpoint)) (Proxy @endpoint))
100− : map
101− (\(n, x, y, z) -> (n + 1, x, y, z))
102− (toReifiedApi endpoints (Proxy @endpoints))
103− where
104− withOffset (x, y, z) = (0, x, y, z)
105−
106−class NormalizeFunction m where
107− type Normal m
108− normalize :: m -> Normal m
109−
110−instance NormalizeFunction x => NormalizeFunction (r -> x) where
111− type Normal (r -> x) = r -> Normal x
112− normalize = fmap normalize
113−
114−instance Typeable x => NormalizeFunction (Handler x) where
115− type Normal (Handler x) = IO (Either ServerError (TypeRep, Dynamic))
116− normalize handler = (runExceptT . runHandler') handler >>= \case
117− Left serverError -> pure (Left serverError)
118− Right x -> pure (Right (typeRep (Proxy @x), toDyn x))
119−
120−instance
121− Typeable responseType =>
122− ToReifiedEndpoint (Verb method statusCode contentTypes responseType)
123− where
124− toReifiedEndpoint endpoint _ =
125− ([], typeRep (Proxy @responseType), endpoint)
126−
127−instance
128− (ToReifiedEndpoint endpoint) =>
129− ToReifiedEndpoint ((x :: Symbol) :> endpoint)
130− where
131− toReifiedEndpoint endpoint _ =
132− toReifiedEndpoint endpoint (Proxy @endpoint)
133−
134−instance
135− (ToReifiedEndpoint endpoint) =>
136− ToReifiedEndpoint (Description s :> endpoint)
137− where
138− toReifiedEndpoint endpoint _ =
139− toReifiedEndpoint endpoint (Proxy @endpoint)
140−
141−instance
142− (ToReifiedEndpoint endpoint) =>
143− ToReifiedEndpoint (Summary s :> endpoint)
144− where
145− toReifiedEndpoint endpoint _ =
146− toReifiedEndpoint endpoint (Proxy @endpoint)
147−
148−instance
149− (Typeable requestType, ToReifiedEndpoint endpoint) =>
150− ToReifiedEndpoint (QueryFlag name :> endpoint)
151− where
152− toReifiedEndpoint endpoint _ =
153− toReifiedEndpoint endpoint (Proxy @endpoint)
154− & \(args, result, typeRepMap) -> (typeRep (Proxy @Bool) : args, result, typeRepMap)
155−
156−instance
157− (Typeable (If (FoldRequired mods) paramType (Maybe paramType)), ToReifiedEndpoint endpoint, SBoolI (FoldRequired mods)) =>
158− ToReifiedEndpoint (QueryParam' mods name paramType :> endpoint)
159− where
160− toReifiedEndpoint endpoint _ =
161− toReifiedEndpoint endpoint (Proxy @endpoint)
162− & \(args, result, typeRepMap) -> (typeRep (Proxy @(If (FoldRequired mods) paramType (Maybe paramType))) : args, result, typeRepMap)
163−
164−instance
165− (Typeable (If (FoldRequired mods) headerType (Maybe headerType)), ToReifiedEndpoint endpoint, SBoolI (FoldRequired mods)) =>
166− ToReifiedEndpoint (Header' mods headerName headerType :> endpoint)
167− where
168− toReifiedEndpoint endpoint _ =
169− toReifiedEndpoint endpoint (Proxy @endpoint)
170− & \(args, result, typeRepMap) -> (typeRep (Proxy @(If (FoldRequired mods) headerType (Maybe headerType))) : args, result, typeRepMap)
171−
172−instance
173− (Typeable captureType, ToReifiedEndpoint endpoint) =>
174− ToReifiedEndpoint (Capture' mods name captureType :> endpoint)
175− where
176− toReifiedEndpoint endpoint _ =
177− toReifiedEndpoint endpoint (Proxy @endpoint)
178− & \(args, result, typeRepMap) -> (typeRep (Proxy @captureType) : args, result, typeRepMap)
179−
180−instance
181− (Typeable (If (FoldLenient mods) (Either String requestType) requestType), ToReifiedEndpoint endpoint, SBoolI (FoldLenient mods)) =>
182− ToReifiedEndpoint (ReqBody' mods contentTypes requestType :> endpoint)
183− where
184− toReifiedEndpoint endpoint _ =
185− toReifiedEndpoint endpoint (Proxy @endpoint)
186− & \(args, result, typeRepMap) -> (typeRep (Proxy @(If (FoldLenient mods) (Either String requestType) requestType)) : args, result, typeRepMap)
187−
188−newtype ApiOffset = ApiOffset Int
189− deriving (Eq, Show)
190− deriving newtype (Enum, Num)
191−
192−-- | we need to specify an offset because it's entirely possible to have two
193−-- functions with the same arguments that do different things.
194−data Op (v :: * -> *) = Op ApiOffset [(TypeRep, Var (Opaque (IORef Dynamic)) v)]
195−
196−deriving instance Show (Op Symbolic)
197−
198−instance HTraversable Op where
199− htraverse r (Op offset args) = Op offset <$> traverse (\(t, v) -> (t,) <$> htraverse r v) args
38+import Roboservant.Types
20039
20140callEndpoint :: (MonadGen n, MonadIO m) => ReifiedApi -> Command n m State
20241callEndpoint staticRoutes =