capnp 0.5.0.0 → 0.6.0.0

raw patch · 14 files changed

+260/−49 lines, 14 filesdep ~basePVP ok

version bump matches the API change (PVP)

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• CHANGELOG.md +15/−0
• capnp.cabal +2/−1
• cmd/capnpc-haskell/Trans/PureToHaskell.hs +26/−10
• examples/gen/lib/Capnp/Gen/Calculator/Pure.hs +15/−6
• examples/gen/lib/Capnp/Gen/Echo/Pure.hs +5/−2
• examples/lib/Examples/Rpc/CalculatorServer.hs +9/−0
• gen/lib/Capnp/Gen/Capnp/Persistent/Pure.hs +10/−4
• gen/tests/Capnp/Gen/Aircraft/Pure.hs +34/−13
• lib/Capnp/Rpc.hs +6/−0
• lib/Capnp/Rpc/Server.hs +30/−7
• lib/Capnp/Rpc/Untyped.hs +24/−2
• tests/Main.hs +2/−0
• tests/Module/Capnp/Rpc.hs +33/−4
• tests/Rpc/Unwrap.hs +49/−0

@@ -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

@@ -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

@@ -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_"

@@ -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 

@@ -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 

@@ -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 =

@@ -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)

@@ -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

@@ -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

@@ -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.

@@ -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

@@ -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

@@ -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. -------------------------------------------------------------------------------

@@ -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