diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,18 @@ +# 0.6.0.0 + +## RPC + +* Fix a serious bug in `newPromiseClient`, resulting in dropped calls + made on the promise before it is resolved. +* There is now a `Server` class, which all RPC servers must implement. + All of its methods have default implementations, so adding an instance + to existing servers is straightforward. +* It is now possible to "unwrap" clients that point to a local server + using the new 'Capnp.Rpc.unwrapServer' function, if the server + implements support for it with the new 'Server' type class. +* Servers can now specify a hook to be run when the server is shut down, + using the server class's 'shutdown' method. + # 0.5.0.0 ## Serialization diff --git a/capnp.cabal b/capnp.cabal --- a/capnp.cabal +++ b/capnp.cabal @@ -1,6 +1,6 @@ cabal-version: 2.2 name: capnp -version: 0.5.0.0 +version: 0.6.0.0 category: Data, Serialization, Network, Rpc copyright: 2016-2020 haskell-capnp contributors (see CONTRIBUTORS file). author: Ian Denhardt @@ -270,6 +270,7 @@ , WalkSchemaCodeGenRequest , SchemaQuickCheck , CalculatorExample + , Rpc.Unwrap build-depends: capnp , network diff --git a/cmd/capnpc-haskell/Trans/PureToHaskell.hs b/cmd/capnpc-haskell/Trans/PureToHaskell.hs --- a/cmd/capnpc-haskell/Trans/PureToHaskell.hs +++ b/cmd/capnpc-haskell/Trans/PureToHaskell.hs @@ -48,6 +48,7 @@ , ImportAs { importAs = "Supervisors", parts = reExp ["Supervisors"] } ] +reExp :: [Name.UnQ] -> [Name.UnQ] reExp parts = ["Capnp", "GenHelpers", "ReExports"] ++ parts -- | Whether the serialized and unserialized forms of this type @@ -426,13 +427,20 @@ ifaceClassDecl thisMod P.IFace { name=Name.CapnpQ{local=name}, methods, supers } = DcClass { ctx = + let superConstraints = + -- Add class constraints for superclasses: + [ let superClass = pureTName thisMod fileId (Name.mkSub local "server_") + in TApp superClass [tuName "m", tuName "cap"] + | P.IFace{name=Name.CapnpQ{local, fileId}} <- supers + ] + in TApp (tgName ["MonadIO"] "MonadIO") [tuName "m"] - : - -- Add class constraints for superclasses: - [ let superClass = pureTName thisMod fileId (Name.mkSub local "server_") - in TApp superClass [tuName "m", tuName "cap"] - | P.IFace{name=Name.CapnpQ{local, fileId}} <- supers - ] + : case superConstraints of + -- If this interface doesn't have any superclasses, then we need to + -- specify a constraint for the 'Server' class. Otherwise, it's + -- implied by the supers. + [] -> [ TApp (tgName ["Server"] "Server") [tuName "m", tuName "cap"] ] + _ -> superConstraints , name = Name.mkSub name "server_" , params = ["m", "cap"] , decls = @@ -488,9 +496,12 @@ [ EApp (egName ["Rpc"] "export") [ euName "sup_" , ERecord (egName ["Server"] "ServerOps") - [ ( "handleStop" - , ePureUnit - ) -- TODO + [ ( "handleCast" + , EApp (egName ["Server"] "unwrap") [ELName "server_"] + ) + , ( "handleStop" + , EApp (egName ["Server"] "shutdown") [ELName "server_"] + ) , ( "handleCall" , ELambda [PVar "interfaceId_", PVar "methodId_"] $ ECase (euName "interfaceId_") $ @@ -596,7 +607,12 @@ -- and those of its ancestors. ifaceServerInstances :: Word64 -> P.Interface -> [Decl] ifaceServerInstances thisMod iface@P.IFace{ name=Name.CapnpQ{local=name}, ancestors } = - map go (iface:ancestors) + DcInstance + { ctx = [] + , typ = TApp (tgName ["Server"] "Server") [tStd_ "IO", TLName name] + , defs = [] + } + : map go (iface:ancestors) where go P.IFace { name=Name.CapnpQ{local, fileId}, interfaceId, methods } = let className = Name.mkSub local "server_" diff --git a/examples/gen/lib/Capnp/Gen/Calculator/Pure.hs b/examples/gen/lib/Capnp/Gen/Calculator/Pure.hs --- a/examples/gen/lib/Capnp/Gen/Calculator/Pure.hs +++ b/examples/gen/lib/Capnp/Gen/Calculator/Pure.hs @@ -59,7 +59,8 @@ deriving(Std_.Show ,Std_.Eq ,Generics.Generic) -class ((MonadIO.MonadIO m)) => (Calculator'server_ m cap) where +class ((MonadIO.MonadIO m) + ,(Server.Server m cap)) => (Calculator'server_ m cap) where {-# MINIMAL calculator'evaluate,calculator'defFunction,calculator'getOperator #-} calculator'evaluate :: cap -> (Server.MethodHandler m Calculator'evaluate'params Calculator'evaluate'results) calculator'evaluate _ = Server.methodUnimplemented @@ -69,7 +70,8 @@ calculator'getOperator _ = Server.methodUnimplemented export_Calculator :: ((Calculator'server_ Std_.IO a) ,(STM.MonadSTM m)) => Supervisors.Supervisor -> a -> (m Calculator) -export_Calculator sup_ server_ = (STM.liftSTM (Calculator <$> (Rpc.export sup_ Server.ServerOps{handleStop = (Std_.pure ()) +export_Calculator sup_ server_ = (STM.liftSTM (Calculator <$> (Rpc.export sup_ Server.ServerOps{handleCast = (Server.unwrap server_) + ,handleStop = (Server.shutdown server_) ,handleCall = (\interfaceId_ methodId_ -> case interfaceId_ of 10923537602090224694 -> case methodId_ of @@ -99,6 +101,7 @@ (Calculator <$> (Untyped.getClient cap)) instance (Classes.Cerialize Calculator) where cerialize msg (Calculator client) = (Capnp.Gen.ById.X85150b117366d14b.Calculator'newtype_ <$> (Std_.Just <$> (Untyped.appendCap msg client))) +instance (Server.Server Std_.IO Calculator) instance (Calculator'server_ Std_.IO Calculator) where calculator'evaluate (Calculator client) = (Rpc.clientMethodHandler 10923537602090224694 0 client) calculator'defFunction (Calculator client) = (Rpc.clientMethodHandler 10923537602090224694 1 client) @@ -403,13 +406,15 @@ deriving(Std_.Show ,Std_.Eq ,Generics.Generic) -class ((MonadIO.MonadIO m)) => (Value'server_ m cap) where +class ((MonadIO.MonadIO m) + ,(Server.Server m cap)) => (Value'server_ m cap) where {-# MINIMAL value'read #-} value'read :: cap -> (Server.MethodHandler m Value'read'params Value'read'results) value'read _ = Server.methodUnimplemented export_Value :: ((Value'server_ Std_.IO a) ,(STM.MonadSTM m)) => Supervisors.Supervisor -> a -> (m Value) -export_Value sup_ server_ = (STM.liftSTM (Value <$> (Rpc.export sup_ Server.ServerOps{handleStop = (Std_.pure ()) +export_Value sup_ server_ = (STM.liftSTM (Value <$> (Rpc.export sup_ Server.ServerOps{handleCast = (Server.unwrap server_) + ,handleStop = (Server.shutdown server_) ,handleCall = (\interfaceId_ methodId_ -> case interfaceId_ of 14116142932258867410 -> case methodId_ of @@ -435,6 +440,7 @@ (Value <$> (Untyped.getClient cap)) instance (Classes.Cerialize Value) where cerialize msg (Value client) = (Capnp.Gen.ById.X85150b117366d14b.Value'newtype_ <$> (Std_.Just <$> (Untyped.appendCap msg client))) +instance (Server.Server Std_.IO Value) instance (Value'server_ Std_.IO Value) where value'read (Value client) = (Rpc.clientMethodHandler 14116142932258867410 0 client) data Value'read'params @@ -511,13 +517,15 @@ deriving(Std_.Show ,Std_.Eq ,Generics.Generic) -class ((MonadIO.MonadIO m)) => (Function'server_ m cap) where +class ((MonadIO.MonadIO m) + ,(Server.Server m cap)) => (Function'server_ m cap) where {-# MINIMAL function'call #-} function'call :: cap -> (Server.MethodHandler m Function'call'params Function'call'results) function'call _ = Server.methodUnimplemented export_Function :: ((Function'server_ Std_.IO a) ,(STM.MonadSTM m)) => Supervisors.Supervisor -> a -> (m Function) -export_Function sup_ server_ = (STM.liftSTM (Function <$> (Rpc.export sup_ Server.ServerOps{handleStop = (Std_.pure ()) +export_Function sup_ server_ = (STM.liftSTM (Function <$> (Rpc.export sup_ Server.ServerOps{handleCast = (Server.unwrap server_) + ,handleStop = (Server.shutdown server_) ,handleCall = (\interfaceId_ methodId_ -> case interfaceId_ of 17143016017778443156 -> case methodId_ of @@ -543,6 +551,7 @@ (Function <$> (Untyped.getClient cap)) instance (Classes.Cerialize Function) where cerialize msg (Function client) = (Capnp.Gen.ById.X85150b117366d14b.Function'newtype_ <$> (Std_.Just <$> (Untyped.appendCap msg client))) +instance (Server.Server Std_.IO Function) instance (Function'server_ Std_.IO Function) where function'call (Function client) = (Rpc.clientMethodHandler 17143016017778443156 0 client) data Function'call'params diff --git a/examples/gen/lib/Capnp/Gen/Echo/Pure.hs b/examples/gen/lib/Capnp/Gen/Echo/Pure.hs --- a/examples/gen/lib/Capnp/Gen/Echo/Pure.hs +++ b/examples/gen/lib/Capnp/Gen/Echo/Pure.hs @@ -42,13 +42,15 @@ deriving(Std_.Show ,Std_.Eq ,Generics.Generic) -class ((MonadIO.MonadIO m)) => (Echo'server_ m cap) where +class ((MonadIO.MonadIO m) + ,(Server.Server m cap)) => (Echo'server_ m cap) where {-# MINIMAL echo'echo #-} echo'echo :: cap -> (Server.MethodHandler m Echo'echo'params Echo'echo'results) echo'echo _ = Server.methodUnimplemented export_Echo :: ((Echo'server_ Std_.IO a) ,(STM.MonadSTM m)) => Supervisors.Supervisor -> a -> (m Echo) -export_Echo sup_ server_ = (STM.liftSTM (Echo <$> (Rpc.export sup_ Server.ServerOps{handleStop = (Std_.pure ()) +export_Echo sup_ server_ = (STM.liftSTM (Echo <$> (Rpc.export sup_ Server.ServerOps{handleCast = (Server.unwrap server_) + ,handleStop = (Server.shutdown server_) ,handleCall = (\interfaceId_ methodId_ -> case interfaceId_ of 16940812395455687611 -> case methodId_ of @@ -74,6 +76,7 @@ (Echo <$> (Untyped.getClient cap)) instance (Classes.Cerialize Echo) where cerialize msg (Echo client) = (Capnp.Gen.ById.Xd0a87f36fa0182f5.Echo'newtype_ <$> (Std_.Just <$> (Untyped.appendCap msg client))) +instance (Server.Server Std_.IO Echo) instance (Echo'server_ Std_.IO Echo) where echo'echo (Echo client) = (Rpc.clientMethodHandler 16940812395455687611 0 client) data Echo'echo'params diff --git a/examples/lib/Examples/Rpc/CalculatorServer.hs b/examples/lib/Examples/Rpc/CalculatorServer.hs --- a/examples/lib/Examples/Rpc/CalculatorServer.hs +++ b/examples/lib/Examples/Rpc/CalculatorServer.hs @@ -19,6 +19,7 @@ import Capnp (def, defaultLimit) import Capnp.Rpc ( ConnConfig(..) + , Server , handleConn , pureHandler , socketTransport @@ -32,12 +33,16 @@ newtype LitValue = LitValue Double +instance Server IO LitValue + instance Value'server_ IO LitValue where value'read = pureHandler $ \(LitValue val) _ -> pure Value'read'results { value = val } newtype OpFunc = OpFunc (Double -> Double -> Double) +instance Server IO OpFunc + instance Function'server_ IO OpFunc where function'call = pureHandler $ \(OpFunc op) Function'call'params{params} -> do when (V.length params /= 2) $ @@ -50,6 +55,8 @@ , body :: Expression } +instance Server IO ExprFunc + instance Function'server_ IO ExprFunc where function'call = pureHandler $ \ExprFunc{..} Function'call'params{params} -> do @@ -64,6 +71,8 @@ , divide :: Function , sup :: Supervisor } + +instance Server IO MyCalc instance Calculator'server_ IO MyCalc where calculator'evaluate = diff --git a/gen/lib/Capnp/Gen/Capnp/Persistent/Pure.hs b/gen/lib/Capnp/Gen/Capnp/Persistent/Pure.hs --- a/gen/lib/Capnp/Gen/Capnp/Persistent/Pure.hs +++ b/gen/lib/Capnp/Gen/Capnp/Persistent/Pure.hs @@ -47,13 +47,15 @@ deriving(Std_.Show ,Std_.Eq ,Generics.Generic) -class ((MonadIO.MonadIO m)) => (Persistent'server_ m cap) where +class ((MonadIO.MonadIO m) + ,(Server.Server m cap)) => (Persistent'server_ m cap) where {-# MINIMAL persistent'save #-} persistent'save :: cap -> (Server.MethodHandler m Persistent'SaveParams Persistent'SaveResults) persistent'save _ = Server.methodUnimplemented export_Persistent :: ((Persistent'server_ Std_.IO a) ,(STM.MonadSTM m)) => Supervisors.Supervisor -> a -> (m Persistent) -export_Persistent sup_ server_ = (STM.liftSTM (Persistent <$> (Rpc.export sup_ Server.ServerOps{handleStop = (Std_.pure ()) +export_Persistent sup_ server_ = (STM.liftSTM (Persistent <$> (Rpc.export sup_ Server.ServerOps{handleCast = (Server.unwrap server_) + ,handleStop = (Server.shutdown server_) ,handleCall = (\interfaceId_ methodId_ -> case interfaceId_ of 14468694717054801553 -> case methodId_ of @@ -79,6 +81,7 @@ (Persistent <$> (Untyped.getClient cap)) instance (Classes.Cerialize Persistent) where cerialize msg (Persistent client) = (Capnp.Gen.ById.Xb8630836983feed7.Persistent'newtype_ <$> (Std_.Just <$> (Untyped.appendCap msg client))) +instance (Server.Server Std_.IO Persistent) instance (Persistent'server_ Std_.IO Persistent) where persistent'save (Persistent client) = (Rpc.clientMethodHandler 14468694717054801553 0 client) data Persistent'SaveParams @@ -156,7 +159,8 @@ deriving(Std_.Show ,Std_.Eq ,Generics.Generic) -class ((MonadIO.MonadIO m)) => (RealmGateway'server_ m cap) where +class ((MonadIO.MonadIO m) + ,(Server.Server m cap)) => (RealmGateway'server_ m cap) where {-# MINIMAL realmGateway'import_,realmGateway'export #-} realmGateway'import_ :: cap -> (Server.MethodHandler m RealmGateway'import'params Persistent'SaveResults) realmGateway'import_ _ = Server.methodUnimplemented @@ -164,7 +168,8 @@ realmGateway'export _ = Server.methodUnimplemented export_RealmGateway :: ((RealmGateway'server_ Std_.IO a) ,(STM.MonadSTM m)) => Supervisors.Supervisor -> a -> (m RealmGateway) -export_RealmGateway sup_ server_ = (STM.liftSTM (RealmGateway <$> (Rpc.export sup_ Server.ServerOps{handleStop = (Std_.pure ()) +export_RealmGateway sup_ server_ = (STM.liftSTM (RealmGateway <$> (Rpc.export sup_ Server.ServerOps{handleCast = (Server.unwrap server_) + ,handleStop = (Server.shutdown server_) ,handleCall = (\interfaceId_ methodId_ -> case interfaceId_ of 9583422979879616212 -> case methodId_ of @@ -192,6 +197,7 @@ (RealmGateway <$> (Untyped.getClient cap)) instance (Classes.Cerialize RealmGateway) where cerialize msg (RealmGateway client) = (Capnp.Gen.ById.Xb8630836983feed7.RealmGateway'newtype_ <$> (Std_.Just <$> (Untyped.appendCap msg client))) +instance (Server.Server Std_.IO RealmGateway) instance (RealmGateway'server_ Std_.IO RealmGateway) where realmGateway'import_ (RealmGateway client) = (Rpc.clientMethodHandler 9583422979879616212 0 client) realmGateway'export (RealmGateway client) = (Rpc.clientMethodHandler 9583422979879616212 1 client) diff --git a/gen/tests/Capnp/Gen/Aircraft/Pure.hs b/gen/tests/Capnp/Gen/Aircraft/Pure.hs --- a/gen/tests/Capnp/Gen/Aircraft/Pure.hs +++ b/gen/tests/Capnp/Gen/Aircraft/Pure.hs @@ -1718,13 +1718,15 @@ deriving(Std_.Show ,Std_.Eq ,Generics.Generic) -class ((MonadIO.MonadIO m)) => (Echo'server_ m cap) where +class ((MonadIO.MonadIO m) + ,(Server.Server m cap)) => (Echo'server_ m cap) where {-# MINIMAL echo'echo #-} echo'echo :: cap -> (Server.MethodHandler m Echo'echo'params Echo'echo'results) echo'echo _ = Server.methodUnimplemented export_Echo :: ((Echo'server_ Std_.IO a) ,(STM.MonadSTM m)) => Supervisors.Supervisor -> a -> (m Echo) -export_Echo sup_ server_ = (STM.liftSTM (Echo <$> (Rpc.export sup_ Server.ServerOps{handleStop = (Std_.pure ()) +export_Echo sup_ server_ = (STM.liftSTM (Echo <$> (Rpc.export sup_ Server.ServerOps{handleCast = (Server.unwrap server_) + ,handleStop = (Server.shutdown server_) ,handleCall = (\interfaceId_ methodId_ -> case interfaceId_ of 10255578992688506164 -> case methodId_ of @@ -1750,6 +1752,7 @@ (Echo <$> (Untyped.getClient cap)) instance (Classes.Cerialize Echo) where cerialize msg (Echo client) = (Capnp.Gen.ById.X832bcc6686a26d56.Echo'newtype_ <$> (Std_.Just <$> (Untyped.appendCap msg client))) +instance (Server.Server Std_.IO Echo) instance (Echo'server_ Std_.IO Echo) where echo'echo (Echo client) = (Rpc.clientMethodHandler 10255578992688506164 0 client) data Echo'echo'params @@ -2043,13 +2046,15 @@ deriving(Std_.Show ,Std_.Eq ,Generics.Generic) -class ((MonadIO.MonadIO m)) => (CallSequence'server_ m cap) where +class ((MonadIO.MonadIO m) + ,(Server.Server m cap)) => (CallSequence'server_ m cap) where {-# MINIMAL callSequence'getNumber #-} callSequence'getNumber :: cap -> (Server.MethodHandler m CallSequence'getNumber'params CallSequence'getNumber'results) callSequence'getNumber _ = Server.methodUnimplemented export_CallSequence :: ((CallSequence'server_ Std_.IO a) ,(STM.MonadSTM m)) => Supervisors.Supervisor -> a -> (m CallSequence) -export_CallSequence sup_ server_ = (STM.liftSTM (CallSequence <$> (Rpc.export sup_ Server.ServerOps{handleStop = (Std_.pure ()) +export_CallSequence sup_ server_ = (STM.liftSTM (CallSequence <$> (Rpc.export sup_ Server.ServerOps{handleCast = (Server.unwrap server_) + ,handleStop = (Server.shutdown server_) ,handleCall = (\interfaceId_ methodId_ -> case interfaceId_ of 12371070827563042848 -> case methodId_ of @@ -2075,6 +2080,7 @@ (CallSequence <$> (Untyped.getClient cap)) instance (Classes.Cerialize CallSequence) where cerialize msg (CallSequence client) = (Capnp.Gen.ById.X832bcc6686a26d56.CallSequence'newtype_ <$> (Std_.Just <$> (Untyped.appendCap msg client))) +instance (Server.Server Std_.IO CallSequence) instance (CallSequence'server_ Std_.IO CallSequence) where callSequence'getNumber (CallSequence client) = (Rpc.clientMethodHandler 12371070827563042848 0 client) data CallSequence'getNumber'params @@ -2151,13 +2157,15 @@ deriving(Std_.Show ,Std_.Eq ,Generics.Generic) -class ((MonadIO.MonadIO m)) => (CounterFactory'server_ m cap) where +class ((MonadIO.MonadIO m) + ,(Server.Server m cap)) => (CounterFactory'server_ m cap) where {-# MINIMAL counterFactory'newCounter #-} counterFactory'newCounter :: cap -> (Server.MethodHandler m CounterFactory'newCounter'params CounterFactory'newCounter'results) counterFactory'newCounter _ = Server.methodUnimplemented export_CounterFactory :: ((CounterFactory'server_ Std_.IO a) ,(STM.MonadSTM m)) => Supervisors.Supervisor -> a -> (m CounterFactory) -export_CounterFactory sup_ server_ = (STM.liftSTM (CounterFactory <$> (Rpc.export sup_ Server.ServerOps{handleStop = (Std_.pure ()) +export_CounterFactory sup_ server_ = (STM.liftSTM (CounterFactory <$> (Rpc.export sup_ Server.ServerOps{handleCast = (Server.unwrap server_) + ,handleStop = (Server.shutdown server_) ,handleCall = (\interfaceId_ methodId_ -> case interfaceId_ of 15610220054254702620 -> case methodId_ of @@ -2183,6 +2191,7 @@ (CounterFactory <$> (Untyped.getClient cap)) instance (Classes.Cerialize CounterFactory) where cerialize msg (CounterFactory client) = (Capnp.Gen.ById.X832bcc6686a26d56.CounterFactory'newtype_ <$> (Std_.Just <$> (Untyped.appendCap msg client))) +instance (Server.Server Std_.IO CounterFactory) instance (CounterFactory'server_ Std_.IO CounterFactory) where counterFactory'newCounter (CounterFactory client) = (Rpc.clientMethodHandler 15610220054254702620 0 client) data CounterFactory'newCounter'params @@ -2260,13 +2269,15 @@ deriving(Std_.Show ,Std_.Eq ,Generics.Generic) -class ((MonadIO.MonadIO m)) => (CounterAcceptor'server_ m cap) where +class ((MonadIO.MonadIO m) + ,(Server.Server m cap)) => (CounterAcceptor'server_ m cap) where {-# MINIMAL counterAcceptor'accept #-} counterAcceptor'accept :: cap -> (Server.MethodHandler m CounterAcceptor'accept'params CounterAcceptor'accept'results) counterAcceptor'accept _ = Server.methodUnimplemented export_CounterAcceptor :: ((CounterAcceptor'server_ Std_.IO a) ,(STM.MonadSTM m)) => Supervisors.Supervisor -> a -> (m CounterAcceptor) -export_CounterAcceptor sup_ server_ = (STM.liftSTM (CounterAcceptor <$> (Rpc.export sup_ Server.ServerOps{handleStop = (Std_.pure ()) +export_CounterAcceptor sup_ server_ = (STM.liftSTM (CounterAcceptor <$> (Rpc.export sup_ Server.ServerOps{handleCast = (Server.unwrap server_) + ,handleStop = (Server.shutdown server_) ,handleCall = (\interfaceId_ methodId_ -> case interfaceId_ of 14317498215560924065 -> case methodId_ of @@ -2292,6 +2303,7 @@ (CounterAcceptor <$> (Untyped.getClient cap)) instance (Classes.Cerialize CounterAcceptor) where cerialize msg (CounterAcceptor client) = (Capnp.Gen.ById.X832bcc6686a26d56.CounterAcceptor'newtype_ <$> (Std_.Just <$> (Untyped.appendCap msg client))) +instance (Server.Server Std_.IO CounterAcceptor) instance (CounterAcceptor'server_ Std_.IO CounterAcceptor) where counterAcceptor'accept (CounterAcceptor client) = (Rpc.clientMethodHandler 14317498215560924065 0 client) data CounterAcceptor'accept'params @@ -2368,13 +2380,15 @@ deriving(Std_.Show ,Std_.Eq ,Generics.Generic) -class ((MonadIO.MonadIO m)) => (Top'server_ m cap) where +class ((MonadIO.MonadIO m) + ,(Server.Server m cap)) => (Top'server_ m cap) where {-# MINIMAL top'top #-} top'top :: cap -> (Server.MethodHandler m Top'top'params Top'top'results) top'top _ = Server.methodUnimplemented export_Top :: ((Top'server_ Std_.IO a) ,(STM.MonadSTM m)) => Supervisors.Supervisor -> a -> (m Top) -export_Top sup_ server_ = (STM.liftSTM (Top <$> (Rpc.export sup_ Server.ServerOps{handleStop = (Std_.pure ()) +export_Top sup_ server_ = (STM.liftSTM (Top <$> (Rpc.export sup_ Server.ServerOps{handleCast = (Server.unwrap server_) + ,handleStop = (Server.shutdown server_) ,handleCall = (\interfaceId_ methodId_ -> case interfaceId_ of 17861645508359101525 -> case methodId_ of @@ -2400,6 +2414,7 @@ (Top <$> (Untyped.getClient cap)) instance (Classes.Cerialize Top) where cerialize msg (Top client) = (Capnp.Gen.ById.X832bcc6686a26d56.Top'newtype_ <$> (Std_.Just <$> (Untyped.appendCap msg client))) +instance (Server.Server Std_.IO Top) instance (Top'server_ Std_.IO Top) where top'top (Top client) = (Rpc.clientMethodHandler 17861645508359101525 0 client) data Top'top'params @@ -2482,7 +2497,8 @@ left'left _ = Server.methodUnimplemented export_Left :: ((Left'server_ Std_.IO a) ,(STM.MonadSTM m)) => Supervisors.Supervisor -> a -> (m Left) -export_Left sup_ server_ = (STM.liftSTM (Left <$> (Rpc.export sup_ Server.ServerOps{handleStop = (Std_.pure ()) +export_Left sup_ server_ = (STM.liftSTM (Left <$> (Rpc.export sup_ Server.ServerOps{handleCast = (Server.unwrap server_) + ,handleStop = (Server.shutdown server_) ,handleCall = (\interfaceId_ methodId_ -> case interfaceId_ of 17679152961798450446 -> case methodId_ of @@ -2514,6 +2530,7 @@ (Left <$> (Untyped.getClient cap)) instance (Classes.Cerialize Left) where cerialize msg (Left client) = (Capnp.Gen.ById.X832bcc6686a26d56.Left'newtype_ <$> (Std_.Just <$> (Untyped.appendCap msg client))) +instance (Server.Server Std_.IO Left) instance (Left'server_ Std_.IO Left) where left'left (Left client) = (Rpc.clientMethodHandler 17679152961798450446 0 client) instance (Top'server_ Std_.IO Left) where @@ -2598,7 +2615,8 @@ right'right _ = Server.methodUnimplemented export_Right :: ((Right'server_ Std_.IO a) ,(STM.MonadSTM m)) => Supervisors.Supervisor -> a -> (m Right) -export_Right sup_ server_ = (STM.liftSTM (Right <$> (Rpc.export sup_ Server.ServerOps{handleStop = (Std_.pure ()) +export_Right sup_ server_ = (STM.liftSTM (Right <$> (Rpc.export sup_ Server.ServerOps{handleCast = (Server.unwrap server_) + ,handleStop = (Server.shutdown server_) ,handleCall = (\interfaceId_ methodId_ -> case interfaceId_ of 14712639595305348988 -> case methodId_ of @@ -2630,6 +2648,7 @@ (Right <$> (Untyped.getClient cap)) instance (Classes.Cerialize Right) where cerialize msg (Right client) = (Capnp.Gen.ById.X832bcc6686a26d56.Right'newtype_ <$> (Std_.Just <$> (Untyped.appendCap msg client))) +instance (Server.Server Std_.IO Right) instance (Right'server_ Std_.IO Right) where right'right (Right client) = (Rpc.clientMethodHandler 14712639595305348988 0 client) instance (Top'server_ Std_.IO Right) where @@ -2715,7 +2734,8 @@ bottom'bottom _ = Server.methodUnimplemented export_Bottom :: ((Bottom'server_ Std_.IO a) ,(STM.MonadSTM m)) => Supervisors.Supervisor -> a -> (m Bottom) -export_Bottom sup_ server_ = (STM.liftSTM (Bottom <$> (Rpc.export sup_ Server.ServerOps{handleStop = (Std_.pure ()) +export_Bottom sup_ server_ = (STM.liftSTM (Bottom <$> (Rpc.export sup_ Server.ServerOps{handleCast = (Server.unwrap server_) + ,handleStop = (Server.shutdown server_) ,handleCall = (\interfaceId_ methodId_ -> case interfaceId_ of 18402872613340521775 -> case methodId_ of @@ -2759,6 +2779,7 @@ (Bottom <$> (Untyped.getClient cap)) instance (Classes.Cerialize Bottom) where cerialize msg (Bottom client) = (Capnp.Gen.ById.X832bcc6686a26d56.Bottom'newtype_ <$> (Std_.Just <$> (Untyped.appendCap msg client))) +instance (Server.Server Std_.IO Bottom) instance (Bottom'server_ Std_.IO Bottom) where bottom'bottom (Bottom client) = (Rpc.clientMethodHandler 18402872613340521775 0 client) instance (Right'server_ Std_.IO Bottom) where diff --git a/lib/Capnp/Rpc.hs b/lib/Capnp/Rpc.hs --- a/lib/Capnp/Rpc.hs +++ b/lib/Capnp/Rpc.hs @@ -13,6 +13,7 @@ , (?) -- * Handling method calls + , Server(..) , MethodHandler , pureHandler , rawHandler @@ -36,6 +37,8 @@ , Client , IsClient(..) , newPromiseClient + -- ** Reflection + , Untyped.unwrapServer -- * Supervisors , module Supervisors @@ -50,6 +53,7 @@ import Capnp.Rpc.Promise import Capnp.Rpc.Server ( MethodHandler + , Server(..) , methodThrow , methodUnimplemented , pureHandler @@ -60,3 +64,5 @@ (Transport(..), handleTransport, socketTransport, tracingTransport) import Capnp.Rpc.Untyped (Client, ConnConfig(..), IsClient(..), handleConn, newPromiseClient) + +import qualified Capnp.Rpc.Untyped as Untyped diff --git a/lib/Capnp/Rpc/Server.hs b/lib/Capnp/Rpc/Server.hs --- a/lib/Capnp/Rpc/Server.hs +++ b/lib/Capnp/Rpc/Server.hs @@ -1,9 +1,11 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} {-| Module: Capnp.Rpc.Server Description: handlers for incoming method calls. @@ -13,7 +15,8 @@ clients and servers). -} module Capnp.Rpc.Server - ( ServerOps(..) + ( Server(..) + , ServerOps(..) , CallInfo(..) , runServer @@ -43,6 +46,7 @@ import Control.Exception.Safe (MonadCatch, finally, try) import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.Primitive (PrimMonad, PrimState) +import Data.Typeable (Typeable) import Capnp.Classes ( Cerialize @@ -206,6 +210,23 @@ methodUnimplemented :: MonadIO m => MethodHandler m p r methodUnimplemented = methodThrow eMethodUnimplemented +-- | Base class for things that can act as capnproto servers. +class Monad m => Server m a | a -> m where + -- | Called when the last live reference to a server is dropped. + shutdown :: a -> m () + shutdown _ = pure () + + -- | Try to extract a value of a given type. The default implementation + -- always fails (returns 'Nothing'). If an instance chooses to implement + -- this, it will be possible to use "reflection" on clients that point + -- at local servers to dynamically unwrap the server value. A typical + -- implementation will just call Typeable's @cast@ method, but this + -- needn't be the case -- a server may wish to allow local peers to + -- unwrap some value that is not exactly the data the server has access + -- to. + unwrap :: Typeable b => a -> Maybe b + unwrap _ = Nothing + -- | The operations necessary to receive and handle method calls, i.e. -- to implement an object. It is parametrized over the monadic context -- in which methods are serviced. @@ -219,6 +240,8 @@ , handleStop :: m () -- ^ Handle shutting-down the receiver; this is called when the last -- reference to the capability is dropped. + , handleCast :: forall a. Typeable a => Maybe a + -- ^ used to unwrap the server when reflecting on a local client. } -- | A 'CallInfo' contains information about a method call. diff --git a/lib/Capnp/Rpc/Untyped.hs b/lib/Capnp/Rpc/Untyped.hs --- a/lib/Capnp/Rpc/Untyped.hs +++ b/lib/Capnp/Rpc/Untyped.hs @@ -5,6 +5,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecursiveDo #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -34,6 +35,9 @@ , export , clientMethodHandler + -- * Unwrapping local clients + , unwrapServer + -- * Errors , RpcError(..) , R.Exception(..) @@ -57,6 +61,7 @@ import Data.Maybe (catMaybes) import Data.String (fromString) import Data.Text (Text) +import Data.Typeable (Typeable) import GHC.Generics (Generic) import Supervisors (Supervisor, superviseSTM, withSupervisor) import System.Mem.StableName (StableName, hashStableName, makeStableName) @@ -567,6 +572,7 @@ -- in a reference counted cell, whose finalizer stops the server. , finalizerKey :: Fin.Cell () -- ^ Finalizer key; when this is collected, qCall will be released. + , unwrapper :: forall a. Typeable a => Maybe a } -- | A client which will resolve to some other capability at -- some point. @@ -862,8 +868,8 @@ pState <- newTVar Pending { tmpDest } exportMap <- ExportMap <$> M.new f <- newCallback $ \case - Left e -> writeTVar pState (Error e) - Right v -> writeTVar pState Ready { target = toClient v } + Left e -> resolveClientExn tmpDest (writeTVar pState) e + Right v -> resolveClientClient tmpDest (writeTVar pState) (toClient v) let p = Client $ Just $ PromiseClient { pState , exportMap @@ -872,6 +878,21 @@ pure (fromClient p, f) +-- | Attempt to unwrap a client, to get at an underlying value from the +-- server. Returns 'Nothing' on failure. +-- +-- This shells out to the underlying server's implementation of +-- 'Server.unwrap'. It will fail with 'Nothing' if any of these are true: +-- +-- * The client is a promise. +-- * The client points to an object in a remote vat. +-- * The underlying Server's 'unwrap' method returns 'Nothing' for type 'a'. +unwrapServer :: (IsClient c, Typeable a) => c -> Maybe a +unwrapServer c = case toClient c of + Client (Just LocalClient { unwrapper }) -> unwrapper + _ -> Nothing + + -- | Spawn a local server with its lifetime bound to the supervisor, -- and return a client for it. When the client is garbage collected, -- the server will be stopped (if it is still running). @@ -885,6 +906,7 @@ { qCall , exportMap , finalizerKey + , unwrapper = Server.handleCast ops } superviseSTM sup $ do Fin.addFinalizer finalizerKey $ atomically $ Rc.release qCall diff --git a/tests/Main.hs b/tests/Main.hs --- a/tests/Main.hs +++ b/tests/Main.hs @@ -11,6 +11,7 @@ import Module.Capnp.Untyped (untypedTests) import Module.Capnp.Untyped.Pure (pureUntypedTests) import Regression (regressionTests) +import Rpc.Unwrap (unwrapTests) import SchemaQuickCheck (schemaCGRQuickCheck) import WalkSchemaCodeGenRequest (walkSchemaCodeGenRequestTest) @@ -33,3 +34,4 @@ describe "property tests for schema" schemaCGRQuickCheck describe "Regression tests" regressionTests CalculatorExample.tests + describe "Tests for client unwrapping" unwrapTests diff --git a/tests/Module/Capnp/Rpc.hs b/tests/Module/Capnp/Rpc.hs --- a/tests/Module/Capnp/Rpc.hs +++ b/tests/Module/Capnp/Rpc.hs @@ -22,6 +22,7 @@ import qualified Data.ByteString.Builder as BB import qualified Data.Text as T import qualified Network.Socket as Socket +import qualified Supervisors import Capnp ( createPure @@ -71,6 +72,7 @@ data TestEchoServer = TestEchoServer +instance Server IO TestEchoServer instance E.Echo'server_ IO TestEchoServer where echo'echo = pureHandler $ \_ params -> pure def { E.reply = E.query params } @@ -82,10 +84,32 @@ -- | Bump a counter n times, returning a list of the results. bumpN :: CallSequence -> Int -> IO [CallSequence'getNumber'results] -bumpN ctr n = replicateM n (callSequence'getNumber ctr ? def) >>= traverse wait +bumpN ctr n = bumpNPromise ctr n >>= traverse wait +-- | Like 'bumpN', but doesn't wait for the results -- returns a list of promises. +bumpNPromise :: CallSequence -> Int -> IO [Promise CallSequence'getNumber'results] +bumpNPromise ctr n = replicateM n (callSequence'getNumber ctr ? def) + aircraftTests :: Spec aircraftTests = describe "aircraft.capnp rpc tests" $ do + describe "newPromiseClient" $ + it "Should preserve E-order" $ + Supervisors.withSupervisor $ \sup -> do + (pc, f) <- newPromiseClient + firsts <- bumpNPromise pc 2 + atomically (newTestCtr 0) + >>= export_CallSequence sup + >>= fulfill f + nexts <- bumpN pc 2 + firstsResolved <- traverse wait firsts + firstsResolved `shouldBe` + [ def { n = 1 } + , def { n = 2 } + ] + nexts `shouldBe` + [ def { n = 3 } + , def { n = 4 } + ] it "Should propogate server-side exceptions to client method calls" $ runVatPair (`export_CallSequence` ExnCtrServer) (\_sup -> expectException @@ -125,8 +149,7 @@ it "A counter should maintain state" $ runVatPair (\sup -> newTestCtr 0 >>= export_CallSequence sup) (\_sup ctr -> do - results <- replicateM 4 (callSequence'getNumber ctr ? def) - >>= traverse wait + results <- bumpN ctr 4 liftIO $ results `shouldBe` [ def { n = 1 } , def { n = 2 } @@ -191,6 +214,7 @@ data TestCtrAcceptor = TestCtrAcceptor +instance Server IO TestCtrAcceptor instance CounterAcceptor'server_ IO TestCtrAcceptor where counterAcceptor'accept = pureHandler $ \_ CounterAcceptor'accept'params{counter} -> do @@ -210,6 +234,7 @@ newtype TestCtrFactory = TestCtrFactory { sup :: Supervisor } +instance Server IO TestCtrFactory instance CounterFactory'server_ IO TestCtrFactory where counterFactory'newCounter = pureHandler $ \TestCtrFactory{sup} CounterFactory'newCounter'params{start} -> do @@ -221,6 +246,7 @@ newtype TestCtrServer = TestCtrServer (TVar Word32) +instance Server IO TestCtrServer instance CallSequence'server_ IO TestCtrServer where callSequence'getNumber = pureHandler $ \(TestCtrServer tvar) _ -> do ret <- liftIO $ atomically $ do @@ -231,6 +257,7 @@ -- a 'CallSequence' which always throws an exception. data ExnCtrServer = ExnCtrServer +instance Server IO ExnCtrServer instance CallSequence'server_ IO ExnCtrServer where callSequence'getNumber = pureHandler $ \_ _ -> throwM def @@ -241,11 +268,13 @@ -- a 'CallSequence' which doesn't implement its methods. data NoImplServer = NoImplServer +instance Server IO NoImplServer instance CallSequence'server_ IO NoImplServer -- TODO: can we silence the warning somehow? -- Server that throws some non-rpc exception. data NonRpcExnServer = NonRpcExnServer +instance Server IO NonRpcExnServer instance CallSequence'server_ IO NonRpcExnServer where callSequence'getNumber = pureHandler $ \_ _ -> error "OOPS" @@ -253,7 +282,7 @@ -- Tests for unusual patterns of messages . -- -- Some of these will never come up when talking to a correct implementation of --- capnproto, and others just won't come up when talking to Haskell +-- capnproto, and others just won't come up when talking to the Haskell -- implementation. Accordingly, these tests start a vat in one thread and -- directly manipulate the transport in the other. ------------------------------------------------------------------------------- diff --git a/tests/Rpc/Unwrap.hs b/tests/Rpc/Unwrap.hs new file mode 100644 --- /dev/null +++ b/tests/Rpc/Unwrap.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Rpc.Unwrap (unwrapTests) where + +import Test.Hspec + +import qualified Data.Typeable as Typeable + +import Data.Typeable (Typeable) + +import qualified Capnp.Gen.Aircraft.Pure as Aircraft +import qualified Capnp.Rpc as Rpc +import qualified Supervisors + +data OpaqueEcho = OpaqueEcho + deriving(Show, Read, Eq, Ord, Enum, Bounded) + +instance Rpc.Server IO OpaqueEcho + +instance Aircraft.Echo'server_ IO OpaqueEcho where + echo'echo _ = Rpc.methodUnimplemented + +newtype TransparentEcho = TransparentEcho Int + deriving(Show, Read, Eq, Ord, Bounded, Typeable) + +instance Rpc.Server IO TransparentEcho where + unwrap = Typeable.cast + +instance Aircraft.Echo'server_ IO TransparentEcho where + echo'echo _ = Rpc.methodUnimplemented + + +unwrapTests :: Spec +unwrapTests = describe "Tests for client unwrapping" $ do + it "Should return nothing for OpaqueEcho." $ do + r :: Maybe OpaqueEcho <- exportAndUnwrap OpaqueEcho + r `shouldBe` Nothing + it "Should return nothing for the wrong type." $ do + r :: Maybe () <- exportAndUnwrap (TransparentEcho 4) + r `shouldBe` Nothing + it "Should return the value for TransparentEcho." $ do + r <- exportAndUnwrap (TransparentEcho 4) + r `shouldBe` Just (TransparentEcho 4) + +exportAndUnwrap :: (Aircraft.Echo'server_ IO a, Typeable b) => a -> IO (Maybe b) +exportAndUnwrap srv = Supervisors.withSupervisor $ \sup -> do + client <- Aircraft.export_Echo sup srv + pure $ Rpc.unwrapServer client