diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,20 @@ +# 0.18.0.0 + +- The connection setup APIs have been slightly reworked. + - The `getBootstrap` field of `ConnConfig` has been replaced with a + `bootstrap` field that takes the capability itself, which must now + be constructed before spawning the connection. + - The `withBootstrarp` field in `ConnConfig` has been removed, Instead + use the new `requestBootstrap` function to get the bootstrap + interface, using a connection reference supplied by `withConn` + or `acquireConn`. +- The high level API now maps Cap'n Proto lists to `[]`, rather than + `Vector`. +- `Fulfiller` now has an instance of `Contravariant`. +- The Client type's Show instance now distinguishes between a null + capability and a capability whose index was outside of a message's + cap table's bounds when it was read. + # 0.17.0.0 - Get rid of the New qualifier in module paths, now that the old diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -3,6 +3,12 @@ A Haskell library for the [Cap'N Proto][1] Cerialization and RPC protocol. +Note, this project's official home is [on +codeberg](https://codeberg.org/zenhack/haskell-capnp); if you're viewing +this elsewhere, this is a mirror. For trivial changes we'll still accept +patches here, but please file issues and submit more substantial changes +via codeberg. + # Getting Started There is a module `Capnp.Tutorial` which contains an introduction @@ -35,8 +41,8 @@ [1]: https://capnproto.org/ [2]: https://capnproto.org/language.html#evolving-your-protocol -[issue27]: https://github.com/zenhack/haskell-capnp/issues/27 -[issue28]: https://github.com/zenhack/haskell-capnp/issues/28 +[issue27]: https://codeberg.org/zenhack/haskell-capnp/issues/27 +[issue28]: https://codeberg.org/zenhack/haskell-capnp/issues/28 [hackage-img]: https://img.shields.io/hackage/v/capnp.svg [hackage]: https://hackage.haskell.org/package/capnp diff --git a/capnp.cabal b/capnp.cabal --- a/capnp.cabal +++ b/capnp.cabal @@ -1,14 +1,14 @@ cabal-version: 2.2 name: capnp -version: 0.17.0.0 +version: 0.18.0.0 category: Data, Serialization, Network, Rpc copyright: 2016-2023 haskell-capnp contributors (see CONTRIBUTORS file). author: Ian Denhardt maintainer: ian@zenhack.net license: MIT license-file: LICENSE.md -homepage: https://github.com/zenhack/haskell-capnp -bug-reports: https://github.com/zenhack/haskell-capnp/issues +homepage: https://codeberg.org/zenhack/haskell-capnp +bug-reports: https://codeberg.org/zenhack/haskell-capnp/issues synopsis: Cap'n Proto for Haskell description: A native Haskell implementation of the Cap'N Proto cerialization format and @@ -46,7 +46,7 @@ source-repository head type: git branch: master - location: https://github.com/zenhack/haskell-capnp.git + location: https://codeberg.org/zenhack/haskell-capnp.git -------------------------------------------------------------------------------- @@ -58,9 +58,9 @@ , containers >= 0.5.9 && <0.7 , data-default ^>= 0.7.1 , exceptions ^>= 0.10.0 - , ghc-prim >= 0.6.1 && <0.10 + , ghc-prim >= 0.6.1 && <0.11 , mtl >= 2.2.2 && <2.4 - , primitive >= 0.6.3 && <0.8 + , primitive >= 0.6.3 && <0.9 , safe-exceptions ^>= 0.1.7 , text >= 1.2 && < 2.1 , transformers >= 0.5.2 && <0.7 @@ -101,9 +101,8 @@ , Capnp.Constraints , Capnp.Rpc.Common , Capnp.Rpc.Membrane - , Capnp.Rpc.Server , Capnp.Rpc.Revoke - , Capnp.New.Rpc.Server + , Capnp.Rpc.Server , Capnp.Convert , Capnp.Errors , Capnp.Fields @@ -155,6 +154,7 @@ , Internal.BuildPure , Internal.STE , Internal.Rpc.Breaker + , Internal.Rpc.Export -- other-extensions: build-depends: hashable >= 1.2.7 && <1.5 @@ -167,9 +167,9 @@ , network-simple ^>= 0.4 , network >= 3 && <3.2 , supervisors ^>= 0.2.1 - , lifetimes ^>= 0.1 + , lifetimes ^>= 0.2 , pretty-show >= 1.9.5 && <1.11 - , template-haskell >=2.18 && <2.20 + , template-haskell >=2.18 && <2.21 -------------------------------------------------------------------------------- @@ -197,7 +197,7 @@ , wl-pprint-text ^>= 1.2 , filepath ^>= 1.4.2 , directory ^>= 1.3.0 - , bifunctors ^>= 5.5.8 + , bifunctors >= 5.5.8 && <5.7 -------------------------------------------------------------------------------- @@ -252,6 +252,7 @@ , WalkSchemaCodeGenRequest , SchemaQuickCheck , CalculatorExample + , Constants , Rpc.Unwrap build-depends: capnp diff --git a/cmd/capnpc-haskell/Check.hs b/cmd/capnpc-haskell/Check.hs --- a/cmd/capnpc-haskell/Check.hs +++ b/cmd/capnpc-haskell/Check.hs @@ -5,7 +5,6 @@ import Capnp.Gen.Capnp.Schema import Data.Foldable (for_) -import qualified Data.Vector as V import System.IO (hPutStrLn, stderr) -- | Scan the code generator request for certain issues, and warn the user @@ -17,12 +16,12 @@ reportIssues CodeGeneratorRequest {nodes} = let problemFields = [ (displayName, name) - | Node {displayName, union' = Node'struct Node'struct' {fields}} <- V.toList nodes, + | Node {displayName, union' = Node'struct Node'struct' {fields}} <- nodes, Field { name, union' = Field'slot Field'slot' {hadExplicitDefault, defaultValue} } <- - V.toList fields, + fields, hadExplicitDefault && isPtrValue defaultValue ] in for_ problemFields $ \(displayName, name) -> @@ -37,7 +36,7 @@ " support this for pointer-valued fields. The custom\n", " default will be ignored; please be careful. See:\n", "\n", - "https://github.com/zenhack/haskell-capnp/issues/28\n", + "https://codeberg.org/zenhack/haskell-capnp/issues/28\n", "\n", "for more information.\n" ] diff --git a/cmd/capnpc-haskell/IR/Common.hs b/cmd/capnpc-haskell/IR/Common.hs --- a/cmd/capnpc-haskell/IR/Common.hs +++ b/cmd/capnpc-haskell/IR/Common.hs @@ -10,7 +10,6 @@ import Capnp.Repr.Parsed (Parsed) import Data.Bifunctor (Bifunctor (..)) import qualified Data.Map.Strict as M -import qualified Data.Vector as V import Data.Word import qualified IR.Name as Name @@ -66,7 +65,7 @@ instance Functor MapBrand where fmap f (MapBrand m) = MapBrand $ fmap (fmap f) m -newtype BrandScope r = Bind (V.Vector (Binding r)) +newtype BrandScope r = Bind [Binding r] deriving (Show, Eq) instance Functor BrandScope where diff --git a/cmd/capnpc-haskell/IR/Stage1.hs b/cmd/capnpc-haskell/IR/Stage1.hs --- a/cmd/capnpc-haskell/IR/Stage1.hs +++ b/cmd/capnpc-haskell/IR/Stage1.hs @@ -23,7 +23,6 @@ ) where -import qualified Data.Vector as V import Data.Word import qualified IR.Common as Common import qualified IR.Name as Name @@ -56,7 +55,7 @@ { nodeNested :: [(Name.UnQ, Node)], nodeParent :: Maybe Node, nodeId :: !Word64, - nodeParams :: V.Vector Name.UnQ + nodeParams :: [Name.UnQ] } deriving (Show, Eq) diff --git a/cmd/capnpc-haskell/Main.hs b/cmd/capnpc-haskell/Main.hs --- a/cmd/capnpc-haskell/Main.hs +++ b/cmd/capnpc-haskell/Main.hs @@ -5,10 +5,10 @@ import Capnp (Parsed, defaultLimit, getParsed) import Capnp.Gen.Capnp.Schema (CodeGeneratorRequest) import qualified Check +import Control.Category ((>>>)) import Data.Foldable (for_) import qualified Data.Text.Lazy as LT import qualified Data.Text.Lazy.IO as TIO -import qualified IR.Flat as Flat import qualified IR.Haskell as Haskell import System.Directory (createDirectoryIfMissing) import System.FilePath (takeDirectory) @@ -30,20 +30,14 @@ -- | Convert a 'CodeGeneratorRequest' to a list of files to create. handleCGR :: Parsed CodeGeneratorRequest -> [(FilePath, LT.Text)] -handleCGR cgr = - let flat = - Trans.Stage1ToFlat.cgrToCgr $ - Trans.CgrToStage1.cgrToCgr cgr - modules = handleFlatNew flat - in map - ( \mod -> - ( Haskell.modFilePath mod, - Trans.HaskellToText.moduleToText mod - ) - ) - modules - -handleFlatNew :: Flat.CodeGenReq -> [Haskell.Module] -handleFlatNew = - concatMap Trans.AbstractOpToHaskell.fileToModules - . Trans.FlatToAbstractOp.cgrToFiles +handleCGR = + Trans.CgrToStage1.cgrToCgr + >>> Trans.Stage1ToFlat.cgrToCgr + >>> Trans.FlatToAbstractOp.cgrToFiles + >>> concatMap Trans.AbstractOpToHaskell.fileToModules + >>> map + ( \mod -> + ( Haskell.modFilePath mod, + Trans.HaskellToText.moduleToText mod + ) + ) diff --git a/cmd/capnpc-haskell/Trans/CgrToStage1.hs b/cmd/capnpc-haskell/Trans/CgrToStage1.hs --- a/cmd/capnpc-haskell/Trans/CgrToStage1.hs +++ b/cmd/capnpc-haskell/Trans/CgrToStage1.hs @@ -17,7 +17,6 @@ import Data.Maybe (mapMaybe) import qualified Data.Text as T import Data.Text.Encoding (encodeUtf8) -import qualified Data.Vector as V import Data.Word import GHC.Float (castDoubleToWord64, castFloatToWord32) import qualified IR.Common as C @@ -38,7 +37,7 @@ { nodeId = id, nodeNested = [ (Name.UnQ name, node) - | Schema.Node'NestedNode {name, id} <- V.toList nestedNodes, + | Schema.Node'NestedNode {name, id} <- nestedNodes, Just node <- [M.lookup id outMap] ], nodeParent = @@ -46,14 +45,13 @@ then Nothing else Just (outMap M.! id), nodeParams = - V.fromList - [ Name.UnQ name - | Schema.Node'Parameter {name} <- V.toList parameters - ] + [ Name.UnQ name + | Schema.Node'Parameter {name} <- parameters + ] }, nodeUnion = case union' of Schema.Node'enum Schema.Node'enum' {enumerants} -> - Stage1.NodeEnum $ map enumerantToName $ V.toList enumerants + Stage1.NodeEnum $ map enumerantToName enumerants Schema.Node'struct Schema.Node'struct' { dataWordCount, @@ -68,15 +66,15 @@ pointerCount, isGroup, tagOffset = discriminantOffset, - fields = map (fieldToField outMap) (V.toList fields) + fields = map (fieldToField outMap) fields } Schema.Node'interface Schema.Node'interface' {methods, superclasses} -> Stage1.NodeInterface Stage1.Interface - { methods = map (methodToMethod outMap) (V.toList methods), + { methods = map (methodToMethod outMap) methods, supers = [ C.InterfaceType (outMap M.! id) (brandToBrand outMap brand) - | Schema.Superclass {id, brand} <- V.toList superclasses + | Schema.Superclass {id, brand} <- superclasses ] } Schema.Node'const Schema.Node'const' {type_ = Schema.Type type_, value = Schema.Value value} -> @@ -115,14 +113,12 @@ encodeUtf8 v & BS.unpack & (++ [0]) - & V.fromList Schema.Value'data_ v -> C.PtrValue (C.PrimPtr C.PrimText) $ Just $ B.PtrList $ B.List8 $ BS.unpack v - & V.fromList Schema.Value'list v -> case type_ of Schema.Type'list (Schema.Type'list' (Schema.Type elementType)) -> @@ -169,7 +165,7 @@ brandToBrand :: NodeMap Stage1.Node -> Parsed Schema.Brand -> Stage1.Brand brandToBrand nodeMap Schema.Brand {scopes} = - C.MapBrand $ M.fromList $ mapMaybe scopeToScope (V.toList scopes) + C.MapBrand $ M.fromList $ mapMaybe scopeToScope scopes where scopeToScope Schema.Brand'Scope {scopeId, union'} = case union' of Schema.Brand'Scope'unknown' _ -> Nothing @@ -179,7 +175,7 @@ ( scopeId, C.Bind $ bindings - & V.map + & map ( \(Schema.Brand'Binding b) -> case b of Schema.Brand'Binding'type_ (Schema.Type typ) -> case typeToType nodeMap typ of @@ -307,12 +303,12 @@ cgrToCgr Schema.CodeGeneratorRequest {nodes, requestedFiles} = Stage1.CodeGenReq {allFiles, reqFiles} where - nodeMap = nodesToNodes $ M.fromList [(id, node) | node@Schema.Node {id} <- V.toList nodes] - reqFiles = map (reqFileToReqFile nodeMap) $ V.toList requestedFiles + nodeMap = nodesToNodes $ M.fromList [(id, node) | node@Schema.Node {id} <- nodes] + reqFiles = map (reqFileToReqFile nodeMap) requestedFiles allFiles = [ let fileNodes = [ (Name.UnQ name, nodeMap M.! id) - | Schema.Node'NestedNode {name, id} <- V.toList nestedNodes, + | Schema.Node'NestedNode {name, id} <- nestedNodes, -- If the file is an import (i.e. not part of requestedFiles), then -- the code generator will sometimes omit parts of it that are not -- used. We need to check that the nestedNodes are actually included; @@ -320,7 +316,7 @@ M.member id nodeMap ] in Stage1.File {fileId, fileNodes} - | Schema.Node {union' = Schema.Node'file, id = fileId, nestedNodes} <- V.toList nodes + | Schema.Node {union' = Schema.Node'file, id = fileId, nestedNodes} <- nodes ] structTypeToType :: @@ -366,7 +362,7 @@ C.TypeParamRef { paramScope, paramIndex = fromIntegral parameterIndex, - paramName = Stage1.nodeParams (Stage1.nodeCommon paramScope) V.! fromIntegral parameterIndex + paramName = Stage1.nodeParams (Stage1.nodeCommon paramScope) !! fromIntegral parameterIndex } Schema.Type'anyPointer'unconstrained (Schema.Type'anyPointer'unconstrained' unconstrained) -> diff --git a/cmd/capnpc-haskell/Trans/Stage1ToFlat.hs b/cmd/capnpc-haskell/Trans/Stage1ToFlat.hs --- a/cmd/capnpc-haskell/Trans/Stage1ToFlat.hs +++ b/cmd/capnpc-haskell/Trans/Stage1ToFlat.hs @@ -9,7 +9,6 @@ module Trans.Stage1ToFlat (cgrToCgr) where import qualified Data.Map as M -import qualified Data.Vector as V import Data.Word import qualified IR.Common as C import qualified IR.Flat as Flat @@ -74,7 +73,7 @@ case M.lookup nodeId m of Nothing -> C.PtrParam param Just (C.Bind bindings) -> - let binding = bindings V.! paramIndex + let binding = bindings !! paramIndex in case binding of C.Unbound -> C.PtrParam param C.BoundType ty -> applyBrandPtrType ty @@ -130,7 +129,7 @@ typeParams = mine ++ kids where - myParams = typeParams ++ paramsToParams nodeMap nodeId (V.toList nodeParams) + myParams = typeParams ++ paramsToParams nodeMap nodeId nodeParams kidsNS = Name.localQToNS localName kids = concatMap diff --git a/examples/gen/lib/Capnp/Gen/ById/X85150b117366d14b.hs b/examples/gen/lib/Capnp/Gen/ById/X85150b117366d14b.hs --- a/examples/gen/lib/Capnp/Gen/ById/X85150b117366d14b.hs +++ b/examples/gen/lib/Capnp/Gen/ById/X85150b117366d14b.hs @@ -1,14 +1,12 @@ +{-# OPTIONS_GHC -Wno-unused-imports #-} {-# OPTIONS_GHC -Wno-dodgy-exports #-} -{-# OPTIONS_GHC -Wno-name-shadowing #-} +{-# OPTIONS_GHC -Wno-unused-matches #-} {-# OPTIONS_GHC -Wno-orphans #-} {-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} -{-# OPTIONS_GHC -Wno-unused-imports #-} -{-# OPTIONS_GHC -Wno-unused-matches #-} - -module Capnp.Gen.ById.X85150b117366d14b (module Capnp.Gen.Calculator) where - +{-# OPTIONS_GHC -Wno-name-shadowing #-} +module Capnp.Gen.ById.X85150b117366d14b(module Capnp.Gen.Calculator) where import Capnp.Gen.Calculator -import qualified Data.Int as Std_ +import qualified Prelude as Std_ import qualified Data.Word as Std_ +import qualified Data.Int as Std_ import Prelude ((<$>), (<*>), (>>=)) -import qualified Prelude as Std_ diff --git a/examples/gen/lib/Capnp/Gen/ById/Xd0a87f36fa0182f5.hs b/examples/gen/lib/Capnp/Gen/ById/Xd0a87f36fa0182f5.hs --- a/examples/gen/lib/Capnp/Gen/ById/Xd0a87f36fa0182f5.hs +++ b/examples/gen/lib/Capnp/Gen/ById/Xd0a87f36fa0182f5.hs @@ -1,14 +1,12 @@ +{-# OPTIONS_GHC -Wno-unused-imports #-} {-# OPTIONS_GHC -Wno-dodgy-exports #-} -{-# OPTIONS_GHC -Wno-name-shadowing #-} +{-# OPTIONS_GHC -Wno-unused-matches #-} {-# OPTIONS_GHC -Wno-orphans #-} {-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} -{-# OPTIONS_GHC -Wno-unused-imports #-} -{-# OPTIONS_GHC -Wno-unused-matches #-} - -module Capnp.Gen.ById.Xd0a87f36fa0182f5 (module Capnp.Gen.Echo) where - +{-# OPTIONS_GHC -Wno-name-shadowing #-} +module Capnp.Gen.ById.Xd0a87f36fa0182f5(module Capnp.Gen.Echo) where import Capnp.Gen.Echo -import qualified Data.Int as Std_ +import qualified Prelude as Std_ import qualified Data.Word as Std_ +import qualified Data.Int as Std_ import Prelude ((<$>), (<*>), (>>=)) -import qualified Prelude as Std_ diff --git a/examples/gen/lib/Capnp/Gen/Calculator.hs b/examples/gen/lib/Capnp/Gen/Calculator.hs --- a/examples/gen/lib/Capnp/Gen/Calculator.hs +++ b/examples/gen/lib/Capnp/Gen/Calculator.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DuplicateRecordFields #-} @@ -5,789 +6,561 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableSuperClasses #-} {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE UndecidableSuperClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -Wno-unused-imports #-} {-# OPTIONS_GHC -Wno-dodgy-exports #-} -{-# OPTIONS_GHC -Wno-name-shadowing #-} +{-# OPTIONS_GHC -Wno-unused-matches #-} {-# OPTIONS_GHC -Wno-orphans #-} {-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} -{-# OPTIONS_GHC -Wno-unused-imports #-} -{-# OPTIONS_GHC -Wno-unused-matches #-} - +{-# OPTIONS_GHC -Wno-name-shadowing #-} module Capnp.Gen.Calculator where - +import qualified Capnp.Repr as R +import qualified Capnp.Repr.Parsed as RP import qualified Capnp.Basics as Basics -import qualified Capnp.Classes as C +import qualified GHC.OverloadedLabels as OL import qualified Capnp.GenHelpers as GH +import qualified Capnp.Classes as C +import qualified GHC.Generics as Generics import qualified Capnp.GenHelpers.Rpc as GH -import qualified Capnp.Repr as R -import qualified Capnp.Repr.Parsed as RP -import qualified Data.Int as Std_ +import qualified Prelude as Std_ import qualified Data.Word as Std_ -import qualified GHC.Generics as Generics -import qualified GHC.OverloadedLabels as OL +import qualified Data.Int as Std_ import Prelude ((<$>), (<*>), (>>=)) -import qualified Prelude as Std_ - -data Calculator - -type instance R.ReprFor Calculator = (R.Ptr (Std_.Just R.Cap)) - +data Calculator +type instance (R.ReprFor Calculator) = (R.Ptr (Std_.Just R.Cap)) instance (C.HasTypeId Calculator) where - typeId = 10923537602090224694 - + typeId = 10923537602090224694 instance (C.Parse Calculator (GH.Client Calculator)) where - parse = GH.parseCap - encode = GH.encodeCap - + parse = GH.parseCap + encode = GH.encodeCap instance (GH.Export Calculator) where - type Server Calculator = Calculator'server_ - methodHandlerTree _ s_ = - ( GH.MethodHandlerTree - (C.typeId @(Calculator)) - [ (GH.toUntypedMethodHandler ((calculator'evaluate) s_)), - (GH.toUntypedMethodHandler ((calculator'defFunction) s_)), - (GH.toUntypedMethodHandler ((calculator'getOperator) s_)) - ] - [] - ) - -class Calculator'server_ s_ where - {-# MINIMAL calculator'evaluate, calculator'defFunction, calculator'getOperator #-} - calculator'evaluate :: s_ -> (GH.MethodHandler Calculator'evaluate'params Calculator'evaluate'results) - calculator'evaluate _ = GH.methodUnimplemented - calculator'defFunction :: s_ -> (GH.MethodHandler Calculator'defFunction'params Calculator'defFunction'results) - calculator'defFunction _ = GH.methodUnimplemented - calculator'getOperator :: s_ -> (GH.MethodHandler Calculator'getOperator'params Calculator'getOperator'results) - calculator'getOperator _ = GH.methodUnimplemented - + type Server Calculator = Calculator'server_ + methodHandlerTree _ s_ = (GH.MethodHandlerTree (C.typeId @(Calculator)) [(GH.toUntypedMethodHandler ((calculator'evaluate) s_)) + ,(GH.toUntypedMethodHandler ((calculator'defFunction) s_)) + ,(GH.toUntypedMethodHandler ((calculator'getOperator) s_))] []) +class (Calculator'server_ s_) where + {-# MINIMAL calculator'evaluate,calculator'defFunction,calculator'getOperator #-} + calculator'evaluate :: s_ -> (GH.MethodHandler Calculator'evaluate'params Calculator'evaluate'results) + calculator'evaluate _ = GH.methodUnimplemented + calculator'defFunction :: s_ -> (GH.MethodHandler Calculator'defFunction'params Calculator'defFunction'results) + calculator'defFunction _ = GH.methodUnimplemented + calculator'getOperator :: s_ -> (GH.MethodHandler Calculator'getOperator'params Calculator'getOperator'results) + calculator'getOperator _ = GH.methodUnimplemented instance (GH.HasMethod "evaluate" Calculator Calculator'evaluate'params Calculator'evaluate'results) where - methodByLabel = (GH.Method 10923537602090224694 0) - + methodByLabel = (GH.Method 10923537602090224694 0) instance (GH.HasMethod "defFunction" Calculator Calculator'defFunction'params Calculator'defFunction'results) where - methodByLabel = (GH.Method 10923537602090224694 1) - + methodByLabel = (GH.Method 10923537602090224694 1) instance (GH.HasMethod "getOperator" Calculator Calculator'getOperator'params Calculator'getOperator'results) where - methodByLabel = (GH.Method 10923537602090224694 2) - -data Calculator'evaluate'params - -type instance R.ReprFor Calculator'evaluate'params = (R.Ptr (Std_.Just R.Struct)) - + methodByLabel = (GH.Method 10923537602090224694 2) +data Calculator'evaluate'params +type instance (R.ReprFor Calculator'evaluate'params) = (R.Ptr (Std_.Just R.Struct)) instance (C.HasTypeId Calculator'evaluate'params) where - typeId = 13478898619544909524 - + typeId = 13478898619544909524 instance (C.TypedStruct Calculator'evaluate'params) where - numStructWords = 0 - numStructPtrs = 1 - + numStructWords = 0 + numStructPtrs = 1 instance (C.Allocate Calculator'evaluate'params) where - type AllocHint Calculator'evaluate'params = () - new _ = C.newTypedStruct - + type AllocHint Calculator'evaluate'params = () + new _ = C.newTypedStruct instance (C.EstimateAlloc Calculator'evaluate'params (C.Parsed Calculator'evaluate'params)) - instance (C.AllocateList Calculator'evaluate'params) where - type ListAllocHint Calculator'evaluate'params = Std_.Int - newList = C.newTypedStructList - + type ListAllocHint Calculator'evaluate'params = Std_.Int + newList = C.newTypedStructList instance (C.EstimateListAlloc Calculator'evaluate'params (C.Parsed Calculator'evaluate'params)) - -data instance C.Parsed Calculator'evaluate'params = Calculator'evaluate'params - {expression :: (RP.Parsed Expression)} - deriving (Generics.Generic) - +data instance C.Parsed Calculator'evaluate'params + = Calculator'evaluate'params + {expression :: (RP.Parsed Expression)} + deriving(Generics.Generic) deriving instance (Std_.Show (C.Parsed Calculator'evaluate'params)) - deriving instance (Std_.Eq (C.Parsed Calculator'evaluate'params)) - instance (C.Parse Calculator'evaluate'params (C.Parsed Calculator'evaluate'params)) where - parse raw_ = (Calculator'evaluate'params <$> (GH.parseField #expression raw_)) - + parse raw_ = (Calculator'evaluate'params <$> (GH.parseField #expression raw_)) instance (C.Marshal Calculator'evaluate'params (C.Parsed Calculator'evaluate'params)) where - marshalInto raw_ Calculator'evaluate'params {..} = - ( do + marshalInto raw_ Calculator'evaluate'params{..} = (do (GH.encodeField #expression expression raw_) (Std_.pure ()) - ) - + ) instance (GH.HasField "expression" GH.Slot Calculator'evaluate'params Expression) where - fieldByLabel = (GH.ptrField 0) - -data Calculator'evaluate'results - -type instance R.ReprFor Calculator'evaluate'results = (R.Ptr (Std_.Just R.Struct)) - + fieldByLabel = (GH.ptrField 0) +data Calculator'evaluate'results +type instance (R.ReprFor Calculator'evaluate'results) = (R.Ptr (Std_.Just R.Struct)) instance (C.HasTypeId Calculator'evaluate'results) where - typeId = 9345430975918089745 - + typeId = 9345430975918089745 instance (C.TypedStruct Calculator'evaluate'results) where - numStructWords = 0 - numStructPtrs = 1 - + numStructWords = 0 + numStructPtrs = 1 instance (C.Allocate Calculator'evaluate'results) where - type AllocHint Calculator'evaluate'results = () - new _ = C.newTypedStruct - + type AllocHint Calculator'evaluate'results = () + new _ = C.newTypedStruct instance (C.EstimateAlloc Calculator'evaluate'results (C.Parsed Calculator'evaluate'results)) - instance (C.AllocateList Calculator'evaluate'results) where - type ListAllocHint Calculator'evaluate'results = Std_.Int - newList = C.newTypedStructList - + type ListAllocHint Calculator'evaluate'results = Std_.Int + newList = C.newTypedStructList instance (C.EstimateListAlloc Calculator'evaluate'results (C.Parsed Calculator'evaluate'results)) - -data instance C.Parsed Calculator'evaluate'results = Calculator'evaluate'results - {value :: (RP.Parsed Value)} - deriving (Generics.Generic) - +data instance C.Parsed Calculator'evaluate'results + = Calculator'evaluate'results + {value :: (RP.Parsed Value)} + deriving(Generics.Generic) deriving instance (Std_.Show (C.Parsed Calculator'evaluate'results)) - deriving instance (Std_.Eq (C.Parsed Calculator'evaluate'results)) - instance (C.Parse Calculator'evaluate'results (C.Parsed Calculator'evaluate'results)) where - parse raw_ = (Calculator'evaluate'results <$> (GH.parseField #value raw_)) - + parse raw_ = (Calculator'evaluate'results <$> (GH.parseField #value raw_)) instance (C.Marshal Calculator'evaluate'results (C.Parsed Calculator'evaluate'results)) where - marshalInto raw_ Calculator'evaluate'results {..} = - ( do + marshalInto raw_ Calculator'evaluate'results{..} = (do (GH.encodeField #value value raw_) (Std_.pure ()) - ) - + ) instance (GH.HasField "value" GH.Slot Calculator'evaluate'results Value) where - fieldByLabel = (GH.ptrField 0) - -data Calculator'defFunction'params - -type instance R.ReprFor Calculator'defFunction'params = (R.Ptr (Std_.Just R.Struct)) - + fieldByLabel = (GH.ptrField 0) +data Calculator'defFunction'params +type instance (R.ReprFor Calculator'defFunction'params) = (R.Ptr (Std_.Just R.Struct)) instance (C.HasTypeId Calculator'defFunction'params) where - typeId = 17476144387247758473 - + typeId = 17476144387247758473 instance (C.TypedStruct Calculator'defFunction'params) where - numStructWords = 1 - numStructPtrs = 1 - + numStructWords = 1 + numStructPtrs = 1 instance (C.Allocate Calculator'defFunction'params) where - type AllocHint Calculator'defFunction'params = () - new _ = C.newTypedStruct - + type AllocHint Calculator'defFunction'params = () + new _ = C.newTypedStruct instance (C.EstimateAlloc Calculator'defFunction'params (C.Parsed Calculator'defFunction'params)) - instance (C.AllocateList Calculator'defFunction'params) where - type ListAllocHint Calculator'defFunction'params = Std_.Int - newList = C.newTypedStructList - + type ListAllocHint Calculator'defFunction'params = Std_.Int + newList = C.newTypedStructList instance (C.EstimateListAlloc Calculator'defFunction'params (C.Parsed Calculator'defFunction'params)) - -data instance C.Parsed Calculator'defFunction'params = Calculator'defFunction'params - { paramCount :: (RP.Parsed Std_.Int32), - body :: (RP.Parsed Expression) - } - deriving (Generics.Generic) - +data instance C.Parsed Calculator'defFunction'params + = Calculator'defFunction'params + {paramCount :: (RP.Parsed Std_.Int32) + ,body :: (RP.Parsed Expression)} + deriving(Generics.Generic) deriving instance (Std_.Show (C.Parsed Calculator'defFunction'params)) - deriving instance (Std_.Eq (C.Parsed Calculator'defFunction'params)) - instance (C.Parse Calculator'defFunction'params (C.Parsed Calculator'defFunction'params)) where - parse raw_ = - ( Calculator'defFunction'params - <$> (GH.parseField #paramCount raw_) - <*> (GH.parseField #body raw_) - ) - + parse raw_ = (Calculator'defFunction'params <$> (GH.parseField #paramCount raw_) + <*> (GH.parseField #body raw_)) instance (C.Marshal Calculator'defFunction'params (C.Parsed Calculator'defFunction'params)) where - marshalInto raw_ Calculator'defFunction'params {..} = - ( do + marshalInto raw_ Calculator'defFunction'params{..} = (do (GH.encodeField #paramCount paramCount raw_) (GH.encodeField #body body raw_) (Std_.pure ()) - ) - + ) instance (GH.HasField "paramCount" GH.Slot Calculator'defFunction'params Std_.Int32) where - fieldByLabel = (GH.dataField 0 0 32 0) - + fieldByLabel = (GH.dataField 0 0 32 0) instance (GH.HasField "body" GH.Slot Calculator'defFunction'params Expression) where - fieldByLabel = (GH.ptrField 0) - -data Calculator'defFunction'results - -type instance R.ReprFor Calculator'defFunction'results = (R.Ptr (Std_.Just R.Struct)) - + fieldByLabel = (GH.ptrField 0) +data Calculator'defFunction'results +type instance (R.ReprFor Calculator'defFunction'results) = (R.Ptr (Std_.Just R.Struct)) instance (C.HasTypeId Calculator'defFunction'results) where - typeId = 10170522573213587144 - + typeId = 10170522573213587144 instance (C.TypedStruct Calculator'defFunction'results) where - numStructWords = 0 - numStructPtrs = 1 - + numStructWords = 0 + numStructPtrs = 1 instance (C.Allocate Calculator'defFunction'results) where - type AllocHint Calculator'defFunction'results = () - new _ = C.newTypedStruct - + type AllocHint Calculator'defFunction'results = () + new _ = C.newTypedStruct instance (C.EstimateAlloc Calculator'defFunction'results (C.Parsed Calculator'defFunction'results)) - instance (C.AllocateList Calculator'defFunction'results) where - type ListAllocHint Calculator'defFunction'results = Std_.Int - newList = C.newTypedStructList - + type ListAllocHint Calculator'defFunction'results = Std_.Int + newList = C.newTypedStructList instance (C.EstimateListAlloc Calculator'defFunction'results (C.Parsed Calculator'defFunction'results)) - -data instance C.Parsed Calculator'defFunction'results = Calculator'defFunction'results - {func :: (RP.Parsed Function)} - deriving (Generics.Generic) - +data instance C.Parsed Calculator'defFunction'results + = Calculator'defFunction'results + {func :: (RP.Parsed Function)} + deriving(Generics.Generic) deriving instance (Std_.Show (C.Parsed Calculator'defFunction'results)) - deriving instance (Std_.Eq (C.Parsed Calculator'defFunction'results)) - instance (C.Parse Calculator'defFunction'results (C.Parsed Calculator'defFunction'results)) where - parse raw_ = (Calculator'defFunction'results <$> (GH.parseField #func raw_)) - + parse raw_ = (Calculator'defFunction'results <$> (GH.parseField #func raw_)) instance (C.Marshal Calculator'defFunction'results (C.Parsed Calculator'defFunction'results)) where - marshalInto raw_ Calculator'defFunction'results {..} = - ( do + marshalInto raw_ Calculator'defFunction'results{..} = (do (GH.encodeField #func func raw_) (Std_.pure ()) - ) - + ) instance (GH.HasField "func" GH.Slot Calculator'defFunction'results Function) where - fieldByLabel = (GH.ptrField 0) - -data Calculator'getOperator'params - -type instance R.ReprFor Calculator'getOperator'params = (R.Ptr (Std_.Just R.Struct)) - + fieldByLabel = (GH.ptrField 0) +data Calculator'getOperator'params +type instance (R.ReprFor Calculator'getOperator'params) = (R.Ptr (Std_.Just R.Struct)) instance (C.HasTypeId Calculator'getOperator'params) where - typeId = 9983863225544066352 - + typeId = 9983863225544066352 instance (C.TypedStruct Calculator'getOperator'params) where - numStructWords = 1 - numStructPtrs = 0 - + numStructWords = 1 + numStructPtrs = 0 instance (C.Allocate Calculator'getOperator'params) where - type AllocHint Calculator'getOperator'params = () - new _ = C.newTypedStruct - + type AllocHint Calculator'getOperator'params = () + new _ = C.newTypedStruct instance (C.EstimateAlloc Calculator'getOperator'params (C.Parsed Calculator'getOperator'params)) - instance (C.AllocateList Calculator'getOperator'params) where - type ListAllocHint Calculator'getOperator'params = Std_.Int - newList = C.newTypedStructList - + type ListAllocHint Calculator'getOperator'params = Std_.Int + newList = C.newTypedStructList instance (C.EstimateListAlloc Calculator'getOperator'params (C.Parsed Calculator'getOperator'params)) - -data instance C.Parsed Calculator'getOperator'params = Calculator'getOperator'params - {op :: (RP.Parsed Operator)} - deriving (Generics.Generic) - +data instance C.Parsed Calculator'getOperator'params + = Calculator'getOperator'params + {op :: (RP.Parsed Operator)} + deriving(Generics.Generic) deriving instance (Std_.Show (C.Parsed Calculator'getOperator'params)) - deriving instance (Std_.Eq (C.Parsed Calculator'getOperator'params)) - instance (C.Parse Calculator'getOperator'params (C.Parsed Calculator'getOperator'params)) where - parse raw_ = (Calculator'getOperator'params <$> (GH.parseField #op raw_)) - + parse raw_ = (Calculator'getOperator'params <$> (GH.parseField #op raw_)) instance (C.Marshal Calculator'getOperator'params (C.Parsed Calculator'getOperator'params)) where - marshalInto raw_ Calculator'getOperator'params {..} = - ( do + marshalInto raw_ Calculator'getOperator'params{..} = (do (GH.encodeField #op op raw_) (Std_.pure ()) - ) - + ) instance (GH.HasField "op" GH.Slot Calculator'getOperator'params Operator) where - fieldByLabel = (GH.dataField 0 0 16 0) - -data Calculator'getOperator'results - -type instance R.ReprFor Calculator'getOperator'results = (R.Ptr (Std_.Just R.Struct)) - + fieldByLabel = (GH.dataField 0 0 16 0) +data Calculator'getOperator'results +type instance (R.ReprFor Calculator'getOperator'results) = (R.Ptr (Std_.Just R.Struct)) instance (C.HasTypeId Calculator'getOperator'results) where - typeId = 15100494197045627936 - + typeId = 15100494197045627936 instance (C.TypedStruct Calculator'getOperator'results) where - numStructWords = 0 - numStructPtrs = 1 - + numStructWords = 0 + numStructPtrs = 1 instance (C.Allocate Calculator'getOperator'results) where - type AllocHint Calculator'getOperator'results = () - new _ = C.newTypedStruct - + type AllocHint Calculator'getOperator'results = () + new _ = C.newTypedStruct instance (C.EstimateAlloc Calculator'getOperator'results (C.Parsed Calculator'getOperator'results)) - instance (C.AllocateList Calculator'getOperator'results) where - type ListAllocHint Calculator'getOperator'results = Std_.Int - newList = C.newTypedStructList - + type ListAllocHint Calculator'getOperator'results = Std_.Int + newList = C.newTypedStructList instance (C.EstimateListAlloc Calculator'getOperator'results (C.Parsed Calculator'getOperator'results)) - -data instance C.Parsed Calculator'getOperator'results = Calculator'getOperator'results - {func :: (RP.Parsed Function)} - deriving (Generics.Generic) - +data instance C.Parsed Calculator'getOperator'results + = Calculator'getOperator'results + {func :: (RP.Parsed Function)} + deriving(Generics.Generic) deriving instance (Std_.Show (C.Parsed Calculator'getOperator'results)) - deriving instance (Std_.Eq (C.Parsed Calculator'getOperator'results)) - instance (C.Parse Calculator'getOperator'results (C.Parsed Calculator'getOperator'results)) where - parse raw_ = (Calculator'getOperator'results <$> (GH.parseField #func raw_)) - + parse raw_ = (Calculator'getOperator'results <$> (GH.parseField #func raw_)) instance (C.Marshal Calculator'getOperator'results (C.Parsed Calculator'getOperator'results)) where - marshalInto raw_ Calculator'getOperator'results {..} = - ( do + marshalInto raw_ Calculator'getOperator'results{..} = (do (GH.encodeField #func func raw_) (Std_.pure ()) - ) - + ) instance (GH.HasField "func" GH.Slot Calculator'getOperator'results Function) where - fieldByLabel = (GH.ptrField 0) - -data Expression - -type instance R.ReprFor Expression = (R.Ptr (Std_.Just R.Struct)) - + fieldByLabel = (GH.ptrField 0) +data Expression +type instance (R.ReprFor Expression) = (R.Ptr (Std_.Just R.Struct)) instance (C.HasTypeId Expression) where - typeId = 15292209801435843861 - + typeId = 15292209801435843861 instance (C.TypedStruct Expression) where - numStructWords = 2 - numStructPtrs = 2 - + numStructWords = 2 + numStructPtrs = 2 instance (C.Allocate Expression) where - type AllocHint Expression = () - new _ = C.newTypedStruct - + type AllocHint Expression = () + new _ = C.newTypedStruct instance (C.EstimateAlloc Expression (C.Parsed Expression)) - instance (C.AllocateList Expression) where - type ListAllocHint Expression = Std_.Int - newList = C.newTypedStructList - + type ListAllocHint Expression = Std_.Int + newList = C.newTypedStructList instance (C.EstimateListAlloc Expression (C.Parsed Expression)) - -data instance C.Parsed Expression = Expression - {union' :: (C.Parsed (GH.Which Expression))} - deriving (Generics.Generic) - +data instance C.Parsed Expression + = Expression + {union' :: (C.Parsed (GH.Which Expression))} + deriving(Generics.Generic) deriving instance (Std_.Show (C.Parsed Expression)) - deriving instance (Std_.Eq (C.Parsed Expression)) - instance (C.Parse Expression (C.Parsed Expression)) where - parse raw_ = (Expression <$> (C.parse (GH.structUnion raw_))) - + parse raw_ = (Expression <$> (C.parse (GH.structUnion raw_))) instance (C.Marshal Expression (C.Parsed Expression)) where - marshalInto raw_ Expression {..} = - ( do + marshalInto raw_ Expression{..} = (do (C.marshalInto (GH.structUnion raw_) union') - ) - + ) instance (GH.HasUnion Expression) where - unionField = (GH.dataField 0 1 16 0) - data RawWhich Expression mut_ - = RW_Expression'literal (R.Raw Std_.Double mut_) - | RW_Expression'previousResult (R.Raw Value mut_) - | RW_Expression'parameter (R.Raw Std_.Word32 mut_) - | RW_Expression'call (R.Raw Expression'call mut_) - | RW_Expression'unknown' Std_.Word16 - internalWhich tag_ struct_ = case tag_ of - 0 -> - (RW_Expression'literal <$> (GH.readVariant #literal struct_)) - 1 -> - (RW_Expression'previousResult <$> (GH.readVariant #previousResult struct_)) - 2 -> - (RW_Expression'parameter <$> (GH.readVariant #parameter struct_)) - 3 -> - (RW_Expression'call <$> (GH.readVariant #call struct_)) - _ -> - (Std_.pure (RW_Expression'unknown' tag_)) - data Which Expression - + unionField = (GH.dataField 0 1 16 0) + data RawWhich Expression mut_ + = RW_Expression'literal (R.Raw Std_.Double mut_) + | RW_Expression'previousResult (R.Raw Value mut_) + | RW_Expression'parameter (R.Raw Std_.Word32 mut_) + | RW_Expression'call (R.Raw Expression'call mut_) + | RW_Expression'unknown' Std_.Word16 + internalWhich tag_ struct_ = case tag_ of + 0 -> + (RW_Expression'literal <$> (GH.readVariant #literal struct_)) + 1 -> + (RW_Expression'previousResult <$> (GH.readVariant #previousResult struct_)) + 2 -> + (RW_Expression'parameter <$> (GH.readVariant #parameter struct_)) + 3 -> + (RW_Expression'call <$> (GH.readVariant #call struct_)) + _ -> + (Std_.pure (RW_Expression'unknown' tag_)) + data Which Expression instance (GH.HasVariant "literal" GH.Slot Expression Std_.Double) where - variantByLabel = (GH.Variant (GH.dataField 0 0 64 0) 0) - + variantByLabel = (GH.Variant (GH.dataField 0 0 64 0) 0) instance (GH.HasVariant "previousResult" GH.Slot Expression Value) where - variantByLabel = (GH.Variant (GH.ptrField 0) 1) - + variantByLabel = (GH.Variant (GH.ptrField 0) 1) instance (GH.HasVariant "parameter" GH.Slot Expression Std_.Word32) where - variantByLabel = (GH.Variant (GH.dataField 0 0 32 0) 2) - + variantByLabel = (GH.Variant (GH.dataField 0 0 32 0) 2) instance (GH.HasVariant "call" GH.Group Expression Expression'call) where - variantByLabel = (GH.Variant GH.groupField 3) - + variantByLabel = (GH.Variant GH.groupField 3) data instance C.Parsed (GH.Which Expression) - = Expression'literal (RP.Parsed Std_.Double) - | Expression'previousResult (RP.Parsed Value) - | Expression'parameter (RP.Parsed Std_.Word32) - | Expression'call (RP.Parsed Expression'call) - | Expression'unknown' Std_.Word16 - deriving (Generics.Generic) - + = Expression'literal (RP.Parsed Std_.Double) + | Expression'previousResult (RP.Parsed Value) + | Expression'parameter (RP.Parsed Std_.Word32) + | Expression'call (RP.Parsed Expression'call) + | Expression'unknown' Std_.Word16 + deriving(Generics.Generic) deriving instance (Std_.Show (C.Parsed (GH.Which Expression))) - deriving instance (Std_.Eq (C.Parsed (GH.Which Expression))) - instance (C.Parse (GH.Which Expression) (C.Parsed (GH.Which Expression))) where - parse raw_ = - ( do + parse raw_ = (do rawWhich_ <- (GH.unionWhich raw_) case rawWhich_ of - (RW_Expression'literal rawArg_) -> - (Expression'literal <$> (C.parse rawArg_)) - (RW_Expression'previousResult rawArg_) -> - (Expression'previousResult <$> (C.parse rawArg_)) - (RW_Expression'parameter rawArg_) -> - (Expression'parameter <$> (C.parse rawArg_)) - (RW_Expression'call rawArg_) -> - (Expression'call <$> (C.parse rawArg_)) - (RW_Expression'unknown' tag_) -> - (Std_.pure (Expression'unknown' tag_)) - ) - + (RW_Expression'literal rawArg_) -> + (Expression'literal <$> (C.parse rawArg_)) + (RW_Expression'previousResult rawArg_) -> + (Expression'previousResult <$> (C.parse rawArg_)) + (RW_Expression'parameter rawArg_) -> + (Expression'parameter <$> (C.parse rawArg_)) + (RW_Expression'call rawArg_) -> + (Expression'call <$> (C.parse rawArg_)) + (RW_Expression'unknown' tag_) -> + (Std_.pure (Expression'unknown' tag_)) + ) instance (C.Marshal (GH.Which Expression) (C.Parsed (GH.Which Expression))) where - marshalInto raw_ parsed_ = case parsed_ of - (Expression'literal arg_) -> - (GH.encodeVariant #literal arg_ (GH.unionStruct raw_)) - (Expression'previousResult arg_) -> - (GH.encodeVariant #previousResult arg_ (GH.unionStruct raw_)) - (Expression'parameter arg_) -> - (GH.encodeVariant #parameter arg_ (GH.unionStruct raw_)) - (Expression'call arg_) -> - ( do - rawGroup_ <- (GH.initVariant #call (GH.unionStruct raw_)) - (C.marshalInto rawGroup_ arg_) - ) - (Expression'unknown' tag_) -> - (GH.encodeField GH.unionField tag_ (GH.unionStruct raw_)) - -data Expression'call - -type instance R.ReprFor Expression'call = (R.Ptr (Std_.Just R.Struct)) - + marshalInto raw_ parsed_ = case parsed_ of + (Expression'literal arg_) -> + (GH.encodeVariant #literal arg_ (GH.unionStruct raw_)) + (Expression'previousResult arg_) -> + (GH.encodeVariant #previousResult arg_ (GH.unionStruct raw_)) + (Expression'parameter arg_) -> + (GH.encodeVariant #parameter arg_ (GH.unionStruct raw_)) + (Expression'call arg_) -> + (do + rawGroup_ <- (GH.initVariant #call (GH.unionStruct raw_)) + (C.marshalInto rawGroup_ arg_) + ) + (Expression'unknown' tag_) -> + (GH.encodeField GH.unionField tag_ (GH.unionStruct raw_)) +data Expression'call +type instance (R.ReprFor Expression'call) = (R.Ptr (Std_.Just R.Struct)) instance (C.HasTypeId Expression'call) where - typeId = 15678475764784139622 - + typeId = 15678475764784139622 instance (C.TypedStruct Expression'call) where - numStructWords = 2 - numStructPtrs = 2 - + numStructWords = 2 + numStructPtrs = 2 instance (C.Allocate Expression'call) where - type AllocHint Expression'call = () - new _ = C.newTypedStruct - + type AllocHint Expression'call = () + new _ = C.newTypedStruct instance (C.EstimateAlloc Expression'call (C.Parsed Expression'call)) - instance (C.AllocateList Expression'call) where - type ListAllocHint Expression'call = Std_.Int - newList = C.newTypedStructList - + type ListAllocHint Expression'call = Std_.Int + newList = C.newTypedStructList instance (C.EstimateListAlloc Expression'call (C.Parsed Expression'call)) - -data instance C.Parsed Expression'call = Expression'call' - { function :: (RP.Parsed Function), - params :: (RP.Parsed (R.List Expression)) - } - deriving (Generics.Generic) - +data instance C.Parsed Expression'call + = Expression'call' + {function :: (RP.Parsed Function) + ,params :: (RP.Parsed (R.List Expression))} + deriving(Generics.Generic) deriving instance (Std_.Show (C.Parsed Expression'call)) - deriving instance (Std_.Eq (C.Parsed Expression'call)) - instance (C.Parse Expression'call (C.Parsed Expression'call)) where - parse raw_ = - ( Expression'call' - <$> (GH.parseField #function raw_) - <*> (GH.parseField #params raw_) - ) - + parse raw_ = (Expression'call' <$> (GH.parseField #function raw_) + <*> (GH.parseField #params raw_)) instance (C.Marshal Expression'call (C.Parsed Expression'call)) where - marshalInto raw_ Expression'call' {..} = - ( do + marshalInto raw_ Expression'call'{..} = (do (GH.encodeField #function function raw_) (GH.encodeField #params params raw_) (Std_.pure ()) - ) - + ) instance (GH.HasField "function" GH.Slot Expression'call Function) where - fieldByLabel = (GH.ptrField 0) - + fieldByLabel = (GH.ptrField 0) instance (GH.HasField "params" GH.Slot Expression'call (R.List Expression)) where - fieldByLabel = (GH.ptrField 1) - -data Value - -type instance R.ReprFor Value = (R.Ptr (Std_.Just R.Cap)) - + fieldByLabel = (GH.ptrField 1) +data Value +type instance (R.ReprFor Value) = (R.Ptr (Std_.Just R.Cap)) instance (C.HasTypeId Value) where - typeId = 14116142932258867410 - + typeId = 14116142932258867410 instance (C.Parse Value (GH.Client Value)) where - parse = GH.parseCap - encode = GH.encodeCap - + parse = GH.parseCap + encode = GH.encodeCap instance (GH.Export Value) where - type Server Value = Value'server_ - methodHandlerTree _ s_ = (GH.MethodHandlerTree (C.typeId @(Value)) [(GH.toUntypedMethodHandler ((value'read) s_))] []) - -class Value'server_ s_ where - {-# MINIMAL value'read #-} - value'read :: s_ -> (GH.MethodHandler Value'read'params Value'read'results) - value'read _ = GH.methodUnimplemented - + type Server Value = Value'server_ + methodHandlerTree _ s_ = (GH.MethodHandlerTree (C.typeId @(Value)) [(GH.toUntypedMethodHandler ((value'read) s_))] []) +class (Value'server_ s_) where + {-# MINIMAL value'read #-} + value'read :: s_ -> (GH.MethodHandler Value'read'params Value'read'results) + value'read _ = GH.methodUnimplemented instance (GH.HasMethod "read" Value Value'read'params Value'read'results) where - methodByLabel = (GH.Method 14116142932258867410 0) - -data Value'read'params - -type instance R.ReprFor Value'read'params = (R.Ptr (Std_.Just R.Struct)) - + methodByLabel = (GH.Method 14116142932258867410 0) +data Value'read'params +type instance (R.ReprFor Value'read'params) = (R.Ptr (Std_.Just R.Struct)) instance (C.HasTypeId Value'read'params) where - typeId = 15227555948799047000 - + typeId = 15227555948799047000 instance (C.TypedStruct Value'read'params) where - numStructWords = 0 - numStructPtrs = 0 - + numStructWords = 0 + numStructPtrs = 0 instance (C.Allocate Value'read'params) where - type AllocHint Value'read'params = () - new _ = C.newTypedStruct - + type AllocHint Value'read'params = () + new _ = C.newTypedStruct instance (C.EstimateAlloc Value'read'params (C.Parsed Value'read'params)) - instance (C.AllocateList Value'read'params) where - type ListAllocHint Value'read'params = Std_.Int - newList = C.newTypedStructList - + type ListAllocHint Value'read'params = Std_.Int + newList = C.newTypedStructList instance (C.EstimateListAlloc Value'read'params (C.Parsed Value'read'params)) - -data instance C.Parsed Value'read'params = Value'read'params - {} - deriving (Generics.Generic) - +data instance C.Parsed Value'read'params + = Value'read'params + {} + deriving(Generics.Generic) deriving instance (Std_.Show (C.Parsed Value'read'params)) - deriving instance (Std_.Eq (C.Parsed Value'read'params)) - instance (C.Parse Value'read'params (C.Parsed Value'read'params)) where - parse raw_ = (Std_.pure Value'read'params) - + parse raw_ = (Std_.pure Value'read'params) instance (C.Marshal Value'read'params (C.Parsed Value'read'params)) where - marshalInto _raw (Value'read'params) = (Std_.pure ()) - -data Value'read'results - -type instance R.ReprFor Value'read'results = (R.Ptr (Std_.Just R.Struct)) - + marshalInto _raw (Value'read'params) = (Std_.pure ()) +data Value'read'results +type instance (R.ReprFor Value'read'results) = (R.Ptr (Std_.Just R.Struct)) instance (C.HasTypeId Value'read'results) where - typeId = 16626840274624768034 - + typeId = 16626840274624768034 instance (C.TypedStruct Value'read'results) where - numStructWords = 1 - numStructPtrs = 0 - + numStructWords = 1 + numStructPtrs = 0 instance (C.Allocate Value'read'results) where - type AllocHint Value'read'results = () - new _ = C.newTypedStruct - + type AllocHint Value'read'results = () + new _ = C.newTypedStruct instance (C.EstimateAlloc Value'read'results (C.Parsed Value'read'results)) - instance (C.AllocateList Value'read'results) where - type ListAllocHint Value'read'results = Std_.Int - newList = C.newTypedStructList - + type ListAllocHint Value'read'results = Std_.Int + newList = C.newTypedStructList instance (C.EstimateListAlloc Value'read'results (C.Parsed Value'read'results)) - -data instance C.Parsed Value'read'results = Value'read'results - {value :: (RP.Parsed Std_.Double)} - deriving (Generics.Generic) - +data instance C.Parsed Value'read'results + = Value'read'results + {value :: (RP.Parsed Std_.Double)} + deriving(Generics.Generic) deriving instance (Std_.Show (C.Parsed Value'read'results)) - deriving instance (Std_.Eq (C.Parsed Value'read'results)) - instance (C.Parse Value'read'results (C.Parsed Value'read'results)) where - parse raw_ = (Value'read'results <$> (GH.parseField #value raw_)) - + parse raw_ = (Value'read'results <$> (GH.parseField #value raw_)) instance (C.Marshal Value'read'results (C.Parsed Value'read'results)) where - marshalInto raw_ Value'read'results {..} = - ( do + marshalInto raw_ Value'read'results{..} = (do (GH.encodeField #value value raw_) (Std_.pure ()) - ) - + ) instance (GH.HasField "value" GH.Slot Value'read'results Std_.Double) where - fieldByLabel = (GH.dataField 0 0 64 0) - -data Function - -type instance R.ReprFor Function = (R.Ptr (Std_.Just R.Cap)) - + fieldByLabel = (GH.dataField 0 0 64 0) +data Function +type instance (R.ReprFor Function) = (R.Ptr (Std_.Just R.Cap)) instance (C.HasTypeId Function) where - typeId = 17143016017778443156 - + typeId = 17143016017778443156 instance (C.Parse Function (GH.Client Function)) where - parse = GH.parseCap - encode = GH.encodeCap - + parse = GH.parseCap + encode = GH.encodeCap instance (GH.Export Function) where - type Server Function = Function'server_ - methodHandlerTree _ s_ = (GH.MethodHandlerTree (C.typeId @(Function)) [(GH.toUntypedMethodHandler ((function'call) s_))] []) - -class Function'server_ s_ where - {-# MINIMAL function'call #-} - function'call :: s_ -> (GH.MethodHandler Function'call'params Function'call'results) - function'call _ = GH.methodUnimplemented - + type Server Function = Function'server_ + methodHandlerTree _ s_ = (GH.MethodHandlerTree (C.typeId @(Function)) [(GH.toUntypedMethodHandler ((function'call) s_))] []) +class (Function'server_ s_) where + {-# MINIMAL function'call #-} + function'call :: s_ -> (GH.MethodHandler Function'call'params Function'call'results) + function'call _ = GH.methodUnimplemented instance (GH.HasMethod "call" Function Function'call'params Function'call'results) where - methodByLabel = (GH.Method 17143016017778443156 0) - -data Function'call'params - -type instance R.ReprFor Function'call'params = (R.Ptr (Std_.Just R.Struct)) - + methodByLabel = (GH.Method 17143016017778443156 0) +data Function'call'params +type instance (R.ReprFor Function'call'params) = (R.Ptr (Std_.Just R.Struct)) instance (C.HasTypeId Function'call'params) where - typeId = 12795114529121400599 - + typeId = 12795114529121400599 instance (C.TypedStruct Function'call'params) where - numStructWords = 0 - numStructPtrs = 1 - + numStructWords = 0 + numStructPtrs = 1 instance (C.Allocate Function'call'params) where - type AllocHint Function'call'params = () - new _ = C.newTypedStruct - + type AllocHint Function'call'params = () + new _ = C.newTypedStruct instance (C.EstimateAlloc Function'call'params (C.Parsed Function'call'params)) - instance (C.AllocateList Function'call'params) where - type ListAllocHint Function'call'params = Std_.Int - newList = C.newTypedStructList - + type ListAllocHint Function'call'params = Std_.Int + newList = C.newTypedStructList instance (C.EstimateListAlloc Function'call'params (C.Parsed Function'call'params)) - -data instance C.Parsed Function'call'params = Function'call'params - {params :: (RP.Parsed (R.List Std_.Double))} - deriving (Generics.Generic) - +data instance C.Parsed Function'call'params + = Function'call'params + {params :: (RP.Parsed (R.List Std_.Double))} + deriving(Generics.Generic) deriving instance (Std_.Show (C.Parsed Function'call'params)) - deriving instance (Std_.Eq (C.Parsed Function'call'params)) - instance (C.Parse Function'call'params (C.Parsed Function'call'params)) where - parse raw_ = (Function'call'params <$> (GH.parseField #params raw_)) - + parse raw_ = (Function'call'params <$> (GH.parseField #params raw_)) instance (C.Marshal Function'call'params (C.Parsed Function'call'params)) where - marshalInto raw_ Function'call'params {..} = - ( do + marshalInto raw_ Function'call'params{..} = (do (GH.encodeField #params params raw_) (Std_.pure ()) - ) - + ) instance (GH.HasField "params" GH.Slot Function'call'params (R.List Std_.Double)) where - fieldByLabel = (GH.ptrField 0) - -data Function'call'results - -type instance R.ReprFor Function'call'results = (R.Ptr (Std_.Just R.Struct)) - + fieldByLabel = (GH.ptrField 0) +data Function'call'results +type instance (R.ReprFor Function'call'results) = (R.Ptr (Std_.Just R.Struct)) instance (C.HasTypeId Function'call'results) where - typeId = 13898297529173597869 - + typeId = 13898297529173597869 instance (C.TypedStruct Function'call'results) where - numStructWords = 1 - numStructPtrs = 0 - + numStructWords = 1 + numStructPtrs = 0 instance (C.Allocate Function'call'results) where - type AllocHint Function'call'results = () - new _ = C.newTypedStruct - + type AllocHint Function'call'results = () + new _ = C.newTypedStruct instance (C.EstimateAlloc Function'call'results (C.Parsed Function'call'results)) - instance (C.AllocateList Function'call'results) where - type ListAllocHint Function'call'results = Std_.Int - newList = C.newTypedStructList - + type ListAllocHint Function'call'results = Std_.Int + newList = C.newTypedStructList instance (C.EstimateListAlloc Function'call'results (C.Parsed Function'call'results)) - -data instance C.Parsed Function'call'results = Function'call'results - {value :: (RP.Parsed Std_.Double)} - deriving (Generics.Generic) - +data instance C.Parsed Function'call'results + = Function'call'results + {value :: (RP.Parsed Std_.Double)} + deriving(Generics.Generic) deriving instance (Std_.Show (C.Parsed Function'call'results)) - deriving instance (Std_.Eq (C.Parsed Function'call'results)) - instance (C.Parse Function'call'results (C.Parsed Function'call'results)) where - parse raw_ = (Function'call'results <$> (GH.parseField #value raw_)) - + parse raw_ = (Function'call'results <$> (GH.parseField #value raw_)) instance (C.Marshal Function'call'results (C.Parsed Function'call'results)) where - marshalInto raw_ Function'call'results {..} = - ( do + marshalInto raw_ Function'call'results{..} = (do (GH.encodeField #value value raw_) (Std_.pure ()) - ) - + ) instance (GH.HasField "value" GH.Slot Function'call'results Std_.Double) where - fieldByLabel = (GH.dataField 0 0 64 0) - -data Operator - = Operator'add - | Operator'subtract - | Operator'multiply - | Operator'divide - | Operator'unknown' Std_.Word16 - deriving - ( Std_.Eq, - Std_.Show, - Generics.Generic - ) - -type instance R.ReprFor Operator = (R.Data R.Sz16) - + fieldByLabel = (GH.dataField 0 0 64 0) +data Operator + = Operator'add + | Operator'subtract + | Operator'multiply + | Operator'divide + | Operator'unknown' Std_.Word16 + deriving(Std_.Eq + ,Std_.Show + ,Generics.Generic) +type instance (R.ReprFor Operator) = (R.Data R.Sz16) instance (C.HasTypeId Operator) where - typeId = 9769222902479511526 - + typeId = 9769222902479511526 instance (Std_.Enum Operator) where - toEnum n_ = case n_ of - 0 -> - Operator'add - 1 -> - Operator'subtract - 2 -> - Operator'multiply - 3 -> - Operator'divide - tag_ -> - (Operator'unknown' (Std_.fromIntegral tag_)) - fromEnum value_ = case value_ of - (Operator'add) -> - 0 - (Operator'subtract) -> - 1 - (Operator'multiply) -> - 2 - (Operator'divide) -> - 3 - (Operator'unknown' tag_) -> - (Std_.fromIntegral tag_) - + toEnum n_ = case n_ of + 0 -> + Operator'add + 1 -> + Operator'subtract + 2 -> + Operator'multiply + 3 -> + Operator'divide + tag_ -> + (Operator'unknown' (Std_.fromIntegral tag_)) + fromEnum value_ = case value_ of + (Operator'add) -> + 0 + (Operator'subtract) -> + 1 + (Operator'multiply) -> + 2 + (Operator'divide) -> + 3 + (Operator'unknown' tag_) -> + (Std_.fromIntegral tag_) instance (C.IsWord Operator) where - fromWord w_ = (Std_.toEnum (Std_.fromIntegral w_)) - toWord v_ = (Std_.fromIntegral (Std_.fromEnum v_)) - + fromWord w_ = (Std_.toEnum (Std_.fromIntegral w_)) + toWord v_ = (Std_.fromIntegral (Std_.fromEnum v_)) instance (C.Parse Operator Operator) where - parse = GH.parseEnum - encode = GH.encodeEnum - + parse = GH.parseEnum + encode = GH.encodeEnum instance (C.AllocateList Operator) where - type ListAllocHint Operator = Std_.Int - + type ListAllocHint Operator = Std_.Int instance (C.EstimateListAlloc Operator Operator) diff --git a/examples/gen/lib/Capnp/Gen/Echo.hs b/examples/gen/lib/Capnp/Gen/Echo.hs --- a/examples/gen/lib/Capnp/Gen/Echo.hs +++ b/examples/gen/lib/Capnp/Gen/Echo.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DuplicateRecordFields #-} @@ -5,144 +6,106 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableSuperClasses #-} {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE UndecidableSuperClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -Wno-unused-imports #-} {-# OPTIONS_GHC -Wno-dodgy-exports #-} -{-# OPTIONS_GHC -Wno-name-shadowing #-} +{-# OPTIONS_GHC -Wno-unused-matches #-} {-# OPTIONS_GHC -Wno-orphans #-} {-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} -{-# OPTIONS_GHC -Wno-unused-imports #-} -{-# OPTIONS_GHC -Wno-unused-matches #-} - +{-# OPTIONS_GHC -Wno-name-shadowing #-} module Capnp.Gen.Echo where - +import qualified Capnp.Repr as R +import qualified Capnp.Repr.Parsed as RP import qualified Capnp.Basics as Basics -import qualified Capnp.Classes as C +import qualified GHC.OverloadedLabels as OL import qualified Capnp.GenHelpers as GH +import qualified Capnp.Classes as C +import qualified GHC.Generics as Generics import qualified Capnp.GenHelpers.Rpc as GH -import qualified Capnp.Repr as R -import qualified Capnp.Repr.Parsed as RP -import qualified Data.Int as Std_ +import qualified Prelude as Std_ import qualified Data.Word as Std_ -import qualified GHC.Generics as Generics -import qualified GHC.OverloadedLabels as OL +import qualified Data.Int as Std_ import Prelude ((<$>), (<*>), (>>=)) -import qualified Prelude as Std_ - -data Echo - -type instance R.ReprFor Echo = (R.Ptr (Std_.Just R.Cap)) - +data Echo +type instance (R.ReprFor Echo) = (R.Ptr (Std_.Just R.Cap)) instance (C.HasTypeId Echo) where - typeId = 16940812395455687611 - + typeId = 16940812395455687611 instance (C.Parse Echo (GH.Client Echo)) where - parse = GH.parseCap - encode = GH.encodeCap - + parse = GH.parseCap + encode = GH.encodeCap instance (GH.Export Echo) where - type Server Echo = Echo'server_ - methodHandlerTree _ s_ = (GH.MethodHandlerTree (C.typeId @(Echo)) [(GH.toUntypedMethodHandler ((echo'echo) s_))] []) - -class Echo'server_ s_ where - {-# MINIMAL echo'echo #-} - echo'echo :: s_ -> (GH.MethodHandler Echo'echo'params Echo'echo'results) - echo'echo _ = GH.methodUnimplemented - + type Server Echo = Echo'server_ + methodHandlerTree _ s_ = (GH.MethodHandlerTree (C.typeId @(Echo)) [(GH.toUntypedMethodHandler ((echo'echo) s_))] []) +class (Echo'server_ s_) where + {-# MINIMAL echo'echo #-} + echo'echo :: s_ -> (GH.MethodHandler Echo'echo'params Echo'echo'results) + echo'echo _ = GH.methodUnimplemented instance (GH.HasMethod "echo" Echo Echo'echo'params Echo'echo'results) where - methodByLabel = (GH.Method 16940812395455687611 0) - -data Echo'echo'params - -type instance R.ReprFor Echo'echo'params = (R.Ptr (Std_.Just R.Struct)) - + methodByLabel = (GH.Method 16940812395455687611 0) +data Echo'echo'params +type instance (R.ReprFor Echo'echo'params) = (R.Ptr (Std_.Just R.Struct)) instance (C.HasTypeId Echo'echo'params) where - typeId = 11805419372138457970 - + typeId = 11805419372138457970 instance (C.TypedStruct Echo'echo'params) where - numStructWords = 0 - numStructPtrs = 1 - + numStructWords = 0 + numStructPtrs = 1 instance (C.Allocate Echo'echo'params) where - type AllocHint Echo'echo'params = () - new _ = C.newTypedStruct - + type AllocHint Echo'echo'params = () + new _ = C.newTypedStruct instance (C.EstimateAlloc Echo'echo'params (C.Parsed Echo'echo'params)) - instance (C.AllocateList Echo'echo'params) where - type ListAllocHint Echo'echo'params = Std_.Int - newList = C.newTypedStructList - + type ListAllocHint Echo'echo'params = Std_.Int + newList = C.newTypedStructList instance (C.EstimateListAlloc Echo'echo'params (C.Parsed Echo'echo'params)) - -data instance C.Parsed Echo'echo'params = Echo'echo'params - {query :: (RP.Parsed Basics.Text)} - deriving (Generics.Generic) - +data instance C.Parsed Echo'echo'params + = Echo'echo'params + {query :: (RP.Parsed Basics.Text)} + deriving(Generics.Generic) deriving instance (Std_.Show (C.Parsed Echo'echo'params)) - deriving instance (Std_.Eq (C.Parsed Echo'echo'params)) - instance (C.Parse Echo'echo'params (C.Parsed Echo'echo'params)) where - parse raw_ = (Echo'echo'params <$> (GH.parseField #query raw_)) - + parse raw_ = (Echo'echo'params <$> (GH.parseField #query raw_)) instance (C.Marshal Echo'echo'params (C.Parsed Echo'echo'params)) where - marshalInto raw_ Echo'echo'params {..} = - ( do + marshalInto raw_ Echo'echo'params{..} = (do (GH.encodeField #query query raw_) (Std_.pure ()) - ) - + ) instance (GH.HasField "query" GH.Slot Echo'echo'params Basics.Text) where - fieldByLabel = (GH.ptrField 0) - -data Echo'echo'results - -type instance R.ReprFor Echo'echo'results = (R.Ptr (Std_.Just R.Struct)) - + fieldByLabel = (GH.ptrField 0) +data Echo'echo'results +type instance (R.ReprFor Echo'echo'results) = (R.Ptr (Std_.Just R.Struct)) instance (C.HasTypeId Echo'echo'results) where - typeId = 9634882973594762090 - + typeId = 9634882973594762090 instance (C.TypedStruct Echo'echo'results) where - numStructWords = 0 - numStructPtrs = 1 - + numStructWords = 0 + numStructPtrs = 1 instance (C.Allocate Echo'echo'results) where - type AllocHint Echo'echo'results = () - new _ = C.newTypedStruct - + type AllocHint Echo'echo'results = () + new _ = C.newTypedStruct instance (C.EstimateAlloc Echo'echo'results (C.Parsed Echo'echo'results)) - instance (C.AllocateList Echo'echo'results) where - type ListAllocHint Echo'echo'results = Std_.Int - newList = C.newTypedStructList - + type ListAllocHint Echo'echo'results = Std_.Int + newList = C.newTypedStructList instance (C.EstimateListAlloc Echo'echo'results (C.Parsed Echo'echo'results)) - -data instance C.Parsed Echo'echo'results = Echo'echo'results - {reply :: (RP.Parsed Basics.Text)} - deriving (Generics.Generic) - +data instance C.Parsed Echo'echo'results + = Echo'echo'results + {reply :: (RP.Parsed Basics.Text)} + deriving(Generics.Generic) deriving instance (Std_.Show (C.Parsed Echo'echo'results)) - deriving instance (Std_.Eq (C.Parsed Echo'echo'results)) - instance (C.Parse Echo'echo'results (C.Parsed Echo'echo'results)) where - parse raw_ = (Echo'echo'results <$> (GH.parseField #reply raw_)) - + parse raw_ = (Echo'echo'results <$> (GH.parseField #reply raw_)) instance (C.Marshal Echo'echo'results (C.Parsed Echo'echo'results)) where - marshalInto raw_ Echo'echo'results {..} = - ( do + marshalInto raw_ Echo'echo'results{..} = (do (GH.encodeField #reply reply raw_) (Std_.pure ()) - ) - + ) instance (GH.HasField "reply" GH.Slot Echo'echo'results Basics.Text) where - fieldByLabel = (GH.ptrField 0) + fieldByLabel = (GH.ptrField 0) diff --git a/examples/lib/Examples/Rpc/CalculatorClient.hs b/examples/lib/Examples/Rpc/CalculatorClient.hs --- a/examples/lib/Examples/Rpc/CalculatorClient.hs +++ b/examples/lib/Examples/Rpc/CalculatorClient.hs @@ -4,82 +4,75 @@ module Examples.Rpc.CalculatorClient (main) where -import Capnp.Gen.Calculator import qualified Capnp as C +import Capnp.Gen.Calculator import Capnp.Rpc ( ConnConfig (..), fromClient, - handleConn, + requestBootstrap, socketTransport, + withConn, ) import Control.Monad (when) import Data.Function ((&)) import Data.Functor ((<&>)) -import qualified Data.Vector as V import Network.Simple.TCP (connect) main :: IO () main = connect "localhost" "4000" $ \(sock, _addr) -> - handleConn - (socketTransport sock C.defaultLimit) - C.def - { debugMode = True, - withBootstrap = Just $ \_sup client -> do - let calc :: C.Client Calculator - calc = fromClient client - - value <- - calc - & C.callP #evaluate C.def {expression = Expression $ Expression'literal 123} - <&> C.pipe #value - >>= C.callR #read C.def - >>= C.waitPipeline - >>= C.evalLimitT C.defaultLimit . C.parseField #value - assertEq value 123 + withConn (socketTransport sock C.defaultLimit) C.def {debugMode = True} $ \conn -> do + client <- requestBootstrap conn + let calc :: C.Client Calculator + calc = fromClient client - let getOp op = - calc - & C.callP #getOperator C.def {op} - <&> C.pipe #func - >>= C.asClient + value <- + calc + & C.callP #evaluate C.def {expression = Expression $ Expression'literal 123} + <&> C.pipe #value + >>= C.callR #read C.def + >>= C.waitPipeline + >>= C.evalLimitT C.defaultLimit . C.parseField #value + assertEq value 123 - add <- getOp Operator'add - subtract <- getOp Operator'subtract + let getOp op = + calc + & C.callP #getOperator C.def {op} + <&> C.pipe #func + >>= C.asClient - value <- - calc - & C.callP - #evaluate - C.def - { expression = - Expression $ - Expression'call - Expression'call' - { function = subtract, - params = - V.fromList - [ Expression $ - Expression'call - Expression'call' - { function = add, - params = - V.fromList - [ Expression $ Expression'literal 123, - Expression $ Expression'literal 45 - ] - }, - Expression $ Expression'literal 67 - ] - } - } - <&> C.pipe #value - >>= C.callR #read C.def - >>= C.waitPipeline - >>= C.evalLimitT C.defaultLimit . C.parseField #value - assertEq value 101 + add <- getOp Operator'add + subtract <- getOp Operator'subtract - putStrLn "PASS" - } + value <- + calc + & C.callP + #evaluate + C.def + { expression = + Expression $ + Expression'call + Expression'call' + { function = subtract, + params = + [ Expression $ + Expression'call + Expression'call' + { function = add, + params = + [ Expression $ Expression'literal 123, + Expression $ Expression'literal 45 + ] + }, + Expression $ Expression'literal 67 + ] + } + } + <&> C.pipe #value + >>= C.callR #read C.def + >>= C.waitPipeline + >>= C.evalLimitT C.defaultLimit . C.parseField #value + assertEq value 101 + putStrLn "PASS" assertEq :: (Show a, Eq a) => a -> a -> IO () assertEq got want = 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 @@ -8,7 +8,6 @@ module Examples.Rpc.CalculatorServer (main) where -import Capnp.Gen.Calculator import Capnp ( Client, Pipeline, @@ -21,6 +20,7 @@ handleParsed, waitPipeline, ) +import Capnp.Gen.Calculator import Capnp.Rpc ( ConnConfig (..), handleConn, @@ -28,14 +28,13 @@ throwFailed, toClient, ) -import Control.Concurrent.STM (STM, atomically) +import Control.Concurrent.STM (atomically) import Control.Monad (when) import Data.Function ((&)) import Data.Functor ((<&>)) import Data.Int -import qualified Data.Vector as V import Network.Simple.TCP (serve) -import Supervisors (Supervisor) +import Supervisors (Supervisor, withSupervisor) import Prelude hiding (subtract) newtype LitValue = LitValue Double @@ -51,13 +50,12 @@ instance SomeServer OpFunc instance Function'server_ OpFunc where - function'call (OpFunc op) = handleParsed $ \Function'call'params {params} -> do - when (V.length params /= 2) $ - throwFailed "Wrong number of parameters." - pure - Function'call'results - { value = (params V.! 0) `op` (params V.! 1) - } + function'call (OpFunc op) = handleParsed $ \Function'call'params {params} -> + case params of + [l, r] -> + pure Function'call'results {value = l `op` r} + _ -> + throwFailed "Wrong number of parameters." data ExprFunc = ExprFunc { paramCount :: !Int32, @@ -69,7 +67,7 @@ instance Function'server_ ExprFunc where function'call ExprFunc {..} = handleParsed $ \Function'call'params {params} -> do - when (fromIntegral (V.length params) /= paramCount) $ + when (fromIntegral (length params) /= paramCount) $ throwFailed "Wrong number of parameters." eval params body >>= waitResult @@ -88,7 +86,7 @@ instance Calculator'server_ MyCalc where calculator'evaluate MyCalc {sup} = handleParsed $ \Calculator'evaluate'params {expression} -> do - eval V.empty expression + eval [] expression >>= waitResult >>= export @Value sup . LitValue <&> Calculator'evaluate'results @@ -108,7 +106,7 @@ Calculator'defFunction'results <$> atomically (export @Function sup ExprFunc {..}) -newCalculator :: Supervisor -> STM (Client Calculator) +newCalculator :: Supervisor -> IO (Client Calculator) newCalculator sup = do add <- export @Function sup $ OpFunc (+) subtract <- export @Function sup $ OpFunc (-) @@ -126,7 +124,7 @@ waitResult (CallResult p) = getField #value <$> waitPipeline p waitResult (ReadResult p) = getField #value <$> waitPipeline p -eval :: V.Vector Double -> Parsed Expression -> IO EvalResult +eval :: [Double] -> Parsed Expression -> IO EvalResult eval outerParams (Expression exp) = go outerParams exp where go _ (Expression'literal lit) = @@ -136,10 +134,10 @@ & callP #read def <&> ReadResult go args (Expression'parameter idx) - | fromIntegral idx >= V.length args = + | fromIntegral idx >= length args = throwFailed "Parameter index out of bounds" | otherwise = - pure $ Immediate $ args V.! fromIntegral idx + pure $ Immediate $ args !! fromIntegral idx go outerParams (Expression'call Expression'call' {function, params = innerParams}) = do argPipelines <- traverse (eval outerParams) innerParams argValues <- traverse waitResult argPipelines @@ -150,10 +148,12 @@ throwFailed "Unknown expression type" main :: IO () -main = serve "localhost" "4000" $ \(sock, _addr) -> - handleConn - (socketTransport sock defaultLimit) - def - { getBootstrap = fmap (Just . toClient) . newCalculator, - debugMode = True - } +main = withSupervisor $ \sup -> do + boot <- newCalculator sup + serve "localhost" "4000" $ \(sock, _addr) -> + handleConn + (socketTransport sock defaultLimit) + def + { debugMode = True, + bootstrap = Just (toClient boot) + } diff --git a/lib/Capnp.hs b/lib/Capnp.hs --- a/lib/Capnp.hs +++ b/lib/Capnp.hs @@ -67,10 +67,11 @@ import qualified Capnp.Fields as F import Capnp.IO as X import qualified Capnp.Message as Message -import Capnp.New.Rpc.Server import qualified Capnp.Repr as R import Capnp.Repr.Methods as X import Capnp.Repr.Parsed (Parsed) +import Capnp.Rpc.Server import Capnp.TraversalLimit as X import Data.Default (def) import Internal.BuildPure (PureBuilder, createPure) +import Internal.Rpc.Export (export) diff --git a/lib/Capnp/Basics.hs b/lib/Capnp/Basics.hs --- a/lib/Capnp/Basics.hs +++ b/lib/Capnp/Basics.hs @@ -151,9 +151,9 @@ instance C.EstimateListAlloc AnyStruct (C.Parsed AnyStruct) where estimateListAlloc structs = - let len = V.length structs - !nWords = foldl' max 0 $ map (V.length . structData) $ V.toList structs - !nPtrs = foldl' max 0 $ map (V.length . structPtrs) $ V.toList structs + let len = length structs + !nWords = foldl' max 0 $ map (V.length . structData) structs + !nPtrs = foldl' max 0 $ map (V.length . structPtrs) structs in (len, (fromIntegral nWords, fromIntegral nPtrs)) instance C.EstimateAlloc AnyStruct (C.Parsed AnyStruct) where @@ -170,19 +170,15 @@ R.Raw ptr <- C.encode (U.message @U.Struct raw) value U.setPtr ptr i raw --- TODO(cleanup): It would be nice if we could reuse Capnp.Repr.Parsed.Parsed --- here, but that would cause a circular import dependency. -type ParsedList a = V.Vector a - data instance C.Parsed AnyList - = ListPtr (ParsedList (Maybe (C.Parsed AnyPointer))) - | ListStruct (ParsedList (C.Parsed AnyStruct)) - | List0 (ParsedList ()) - | List1 (ParsedList Bool) - | List8 (ParsedList Word8) - | List16 (ParsedList Word16) - | List32 (ParsedList Word32) - | List64 (ParsedList Word64) + = ListPtr [Maybe (C.Parsed AnyPointer)] + | ListStruct [C.Parsed AnyStruct] + | List0 [()] + | List1 [Bool] + | List8 [Word8] + | List16 [Word16] + | List32 [Word32] + | List64 [Word64] deriving (Show, Eq, Generic) instance C.Parse AnyList (C.Parsed AnyList) where diff --git a/lib/Capnp/Classes.hs b/lib/Capnp/Classes.hs --- a/lib/Capnp/Classes.hs +++ b/lib/Capnp/Classes.hs @@ -61,7 +61,6 @@ import Data.Default (Default (..)) import Data.Foldable (for_) import Data.Int -import qualified Data.Vector as V import Data.Word import qualified GHC.Float as F import qualified Language.Haskell.TH as TH @@ -165,10 +164,10 @@ type ListAllocHint (R.List a) = Int instance - ( Parse (R.List a) (V.Vector ap), + ( Parse (R.List a) [ap], Allocate (R.List a) ) => - EstimateListAlloc (R.List a) (V.Vector ap) + EstimateListAlloc (R.List a) [ap] -- | Allocate a new typed struct. Mainly used as the value for 'new' for in generated -- instances of 'Allocate'. @@ -260,15 +259,19 @@ parse = pure . F.castWord64ToDouble . R.fromRaw encode _ = pure . R.Raw . F.castDoubleToWord64 -instance MarshalElement a ap => Marshal (R.List a) (V.Vector ap) where +instance MarshalElement a ap => Marshal (R.List a) [ap] where marshalInto raw value = - for_ [0 .. V.length value - 1] $ \i -> - marshalElement raw i (value V.! i) + for_ (zip [0 ..] value) $ \(i, v) -> + marshalElement raw i v -instance MarshalElement a ap => Parse (R.List a) (V.Vector ap) where - parse rawV = - V.generateM (R.length rawV) $ \i -> - R.index i rawV >>= parse +instance MarshalElement a ap => Parse (R.List a) [ap] where + parse rawV = go [] (R.length rawV - 1) + where + go acc i + | i < 0 = pure acc + | otherwise = do + item <- R.index i rawV >>= parse + go (item : acc) (i - 1) -- | Type alias capturing the constraints on a type needed by -- 'marshalElement' @@ -338,12 +341,12 @@ marshalElement = marshalElementByRepr @(R.ListReprFor (R.ReprFor a)) class (Parse a ap, Allocate (R.List a)) => EstimateListAlloc a ap where - estimateListAlloc :: V.Vector ap -> AllocHint (R.List a) - default estimateListAlloc :: (AllocHint (R.List a) ~ Int) => V.Vector ap -> AllocHint (R.List a) - estimateListAlloc = V.length + estimateListAlloc :: [ap] -> AllocHint (R.List a) + default estimateListAlloc :: (AllocHint (R.List a) ~ Int) => [ap] -> AllocHint (R.List a) + estimateListAlloc = length {-# INLINEABLE estimateListAlloc #-} -instance MarshalElement a ap => EstimateAlloc (R.List a) (V.Vector ap) where +instance MarshalElement a ap => EstimateAlloc (R.List a) [ap] where estimateAlloc = estimateListAlloc @a {-# INLINEABLE estimateAlloc #-} @@ -383,7 +386,7 @@ type ListAllocHint $ty = Int instance EstimateListAlloc $ty $ty where - estimateListAlloc = V.length + estimateListAlloc = length {-# INLINEABLE estimateListAlloc #-} |] diff --git a/lib/Capnp/GenHelpers/Rpc.hs b/lib/Capnp/GenHelpers/Rpc.hs --- a/lib/Capnp/GenHelpers/Rpc.hs +++ b/lib/Capnp/GenHelpers/Rpc.hs @@ -3,7 +3,7 @@ {-# LANGUAGE TypeFamilies #-} module Capnp.GenHelpers.Rpc - ( module Capnp.New.Rpc.Server, + ( module Capnp.Rpc.Server, module Capnp.Repr.Methods, parseCap, encodeCap, @@ -12,9 +12,9 @@ import Capnp.Message (Mutability (..)) import qualified Capnp.Message as M -import Capnp.New.Rpc.Server import qualified Capnp.Repr as R import Capnp.Repr.Methods +import Capnp.Rpc.Server import qualified Capnp.Untyped as U parseCap :: (R.IsCap a, U.ReadCtx m 'Const) => R.Raw a 'Const -> m (Client a) diff --git a/lib/Capnp/Message.hs b/lib/Capnp/Message.hs --- a/lib/Capnp/Message.hs +++ b/lib/Capnp/Message.hs @@ -67,6 +67,7 @@ WriteCtx, Client, nullClient, + invalidClient, withCapTable, ) where @@ -98,7 +99,7 @@ import GHC.ByteOrder (ByteOrder (..), targetByteOrder) import Internal.AppendVec (AppendVec) import qualified Internal.AppendVec as AppendVec -import Internal.Rpc.Breaker (Client, nullClient) +import Internal.Rpc.Breaker (Client, invalidClient, nullClient) import System.IO (Handle, stdin, stdout) import Prelude hiding (read) @@ -235,7 +236,7 @@ getCap msg i = do ncaps <- numCaps msg if i >= ncaps || i < 0 - then pure nullClient + then pure (invalidClient $ "capability index out of bounds: " ++ show i) else msg `internalGetCap` i -- | @'setSegment' message index segment@ sets the segment at the given index diff --git a/lib/Capnp/New/Rpc/Server.hs b/lib/Capnp/New/Rpc/Server.hs deleted file mode 100644 --- a/lib/Capnp/New/Rpc/Server.hs +++ /dev/null @@ -1,254 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} - -module Capnp.New.Rpc.Server - ( CallHandler, - MethodHandler, - UntypedMethodHandler, - Export (..), - export, - findMethod, - SomeServer (..), - - -- * Helpers for writing method handlers - handleParsed, - handleRaw, - methodUnimplemented, - toUntypedMethodHandler, - - -- * Internals; exposed only for use by generated code. - MethodHandlerTree (..), - ) -where - -import qualified Capnp.Basics as B -import qualified Capnp.Classes as C -import Capnp.Convert (parsedToRaw) -import Capnp.Message (Mutability (..)) -import qualified Capnp.Repr as R -import Capnp.Repr.Methods (Client (..)) -import Capnp.Rpc.Errors - ( eFailed, - eMethodUnimplemented, - wrapException, - ) -import Capnp.Rpc.Promise - ( Fulfiller, - breakPromise, - fulfill, - newCallback, - ) -import qualified Capnp.Rpc.Server as Legacy -import qualified Capnp.Rpc.Untyped as URpc -import Capnp.TraversalLimit (defaultLimit, evalLimitT) -import qualified Capnp.Untyped as U -import Control.Exception.Safe (withException) -import Control.Monad.STM.Class (MonadSTM (..)) -import Data.Function ((&)) -import Data.Kind (Constraint, Type) -import qualified Data.Map.Strict as M -import Data.Maybe (fromMaybe) -import Data.Proxy (Proxy (..)) -import Data.Typeable (Typeable) -import qualified Data.Vector as V -import Data.Word -import GHC.Prim (coerce) -import Internal.BuildPure (createPure) -import Supervisors (Supervisor) - --- | A handler for arbitrary RPC calls. Maps (interfaceId, methodId) pairs to --- 'UntypedMethodHandler's. -type CallHandler = M.Map Word64 (V.Vector UntypedMethodHandler) - --- | Type alias for a handler for a particular rpc method. -type MethodHandler p r = - R.Raw p 'Const -> - Fulfiller (R.Raw r 'Const) -> - IO () - --- | Type alias for a handler for an untyped RPC method. -type UntypedMethodHandler = MethodHandler B.AnyStruct B.AnyStruct - --- | Base class for things that can act as capnproto servers. -class SomeServer a where - -- | Called when the last live reference to a server is dropped. - shutdown :: a -> IO () - 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 - --- | Generated interface types have instances of 'Export', which allows a server --- for that interface to be exported as a 'Client'. -class (R.IsCap i, C.HasTypeId i) => Export i where - -- | The constraint needed for a server to implement an interface; - -- if @'Server' i s@ is satisfied, @s@ is a server for interface @i@. - -- The code generator generates a type class for each interface, and - -- this will aways be an alias for that type class. - type Server i :: Type -> Constraint - - -- | Convert the server to a 'MethodHandlerTree' populated with appropriate - -- 'MethodHandler's for the interface. This is really only exported for use - -- by generated code; users of the library will generally prefer to use - -- 'export'. - methodHandlerTree :: Server i s => Proxy i -> s -> MethodHandlerTree - --- NB: the proxy helps disambiguate types; for some reason TypeApplications --- doesn't seem to be enough in the face of a type alias of kind 'Constraint'. --- the inconsistency is a bit ugly, but this method isn't intended to called --- by users directly, only by generated code and our helper in this module, --- so it's less of a big deal. - --- | Lazily computed tree of the method handlers exposed by an interface. Only --- of interest to generated code. -data MethodHandlerTree = MethodHandlerTree - { -- | type id for the primary interface - mhtId :: Word64, - -- | method handlers for methods of the primary interface. - mhtHandlers :: [UntypedMethodHandler], - -- | Trees for parent interfaces. In the case of diamond dependencies, - -- there may be duplicates, which are eliminated by 'mhtToCallHandler'. - mhtParents :: [MethodHandlerTree] - } - -mhtToCallHandler :: MethodHandlerTree -> CallHandler -mhtToCallHandler = go M.empty . pure - where - go accum [] = accum - go accum (t : ts) - | mhtId t `M.member` accum = go accum ts -- dedup diamond dependencies - | otherwise = - go (M.insert (mhtId t) (V.fromList (mhtHandlers t)) accum) (mhtParents t ++ ts) - --- | Export the server as a client for interface @i@. Spawns a server thread --- with its lifetime bound to the supervisor. -export :: forall i s m. (MonadSTM m, Export i, Server i s, SomeServer s) => Supervisor -> s -> m (Client i) -export sup srv = - let h = mhtToCallHandler (methodHandlerTree (Proxy @i) srv) - in liftSTM $ Client <$> URpc.export sup (toLegacyServerOps srv h) - --- | Look up a particlar 'MethodHandler' in the 'CallHandler'. -findMethod :: Word64 -> Word16 -> CallHandler -> Maybe UntypedMethodHandler -findMethod interfaceId methodId handler = do - iface <- M.lookup interfaceId handler - iface V.!? fromIntegral methodId - -toLegacyCallHandler :: - CallHandler -> - Word64 -> - Word16 -> - Legacy.MethodHandler (Maybe (U.Ptr 'Const)) (Maybe (U.Ptr 'Const)) -toLegacyCallHandler callHandler interfaceId methodId = - findMethod interfaceId methodId callHandler - & fromMaybe methodUnimplemented - & toLegacyMethodHandler - --- | Convert a typed method handler to an untyped one. Mostly intended for --- use by generated code. -toUntypedMethodHandler :: - forall p r. - (R.IsStruct p, R.IsStruct r) => - MethodHandler p r -> - UntypedMethodHandler -toUntypedMethodHandler = coerce - -toLegacyMethodHandler :: UntypedMethodHandler -> Legacy.MethodHandler (Maybe (U.Ptr 'Const)) (Maybe (U.Ptr 'Const)) -toLegacyMethodHandler handler = - Legacy.untypedHandler $ \args respond -> do - respond' <- newCallback $ \case - Left e -> - breakPromise respond e - Right (R.Raw s) -> - fulfill respond (Just (U.PtrStruct s)) - case args of - Just (U.PtrStruct argStruct) -> - handler (R.Raw argStruct) respond' - _ -> - breakPromise respond $ eFailed "Argument was not a struct" - -toLegacyServerOps :: SomeServer a => a -> CallHandler -> Legacy.ServerOps -toLegacyServerOps srv callHandler = - Legacy.ServerOps - { handleStop = shutdown srv, - handleCast = unwrap srv, - handleCall = toLegacyCallHandler callHandler - } - --- Helpers for writing method handlers - --- | Handle a method, working with the parsed form of parameters and --- results. -handleParsed :: - ( C.Parse p pp, - R.IsStruct p, - C.Parse r pr, - R.IsStruct r - ) => - (pp -> IO pr) -> - MethodHandler p r -handleParsed handler param = propagateExceptions $ \f -> do - p <- evalLimitT defaultLimit $ C.parse param - r <- handler p - -- TODO: Figure out how to add an instance of Thaw for - -- Raw so we can skip the (un)wrapping here. - struct <- createPure maxBound $ R.fromRaw <$> parsedToRaw r - fulfill f (R.Raw struct) - --- | Handle a method, working with the raw (unparsed) form of --- parameters and results. -handleRaw :: - (R.IsStruct p, R.IsStruct r) => - (R.Raw p 'Const -> IO (R.Raw r 'Const)) -> - MethodHandler p r -handleRaw handler param = propagateExceptions $ \f -> - handler param >>= fulfill f - --- Helper for handle*; breaks the promise if the handler throws. -propagateExceptions :: (Fulfiller a -> IO b) -> Fulfiller a -> IO b -propagateExceptions h f = - h f `withException` (breakPromise f . wrapException False) - --- | 'MethodHandler' that always throws unimplemented. -methodUnimplemented :: MethodHandler p r -methodUnimplemented _ f = breakPromise f eMethodUnimplemented - -{- -Sketch of future Async API, might take a bit of internals work to make -this possible: - --- | Handle a method call asynchronously. --- --- When invoked, the handleer will be run synchronously, blocking further --- method calls until the 'IO' returns. The method call does not return --- until the 'Async' resolves, but further method calls can be serviced in --- the meantime. --- --- If a Finish message is received before the Async resolves, it will be --- 'cancel'ed. -handleRawAsync - :: (R.IsStruct p, R.IsStruct r) - => (R.Raw 'Const p -> IO (Async (R.Raw 'Const r))) - -> MethodHandler IO p r - --- | Like 'handleRawAsync', but accepts and returns parsed values. -handleParsedAsync :: - ( C.Parse p pp, R.IsStruct p - , C.Parse r, rr, R.IsStruct r - ) - => (pp -> IO (Async rr)) - -> MethodHandler IO p r --} diff --git a/lib/Capnp/Repr/Parsed.hs b/lib/Capnp/Repr/Parsed.hs --- a/lib/Capnp/Repr/Parsed.hs +++ b/lib/Capnp/Repr/Parsed.hs @@ -11,7 +11,6 @@ import qualified Data.ByteString as BS import Data.Kind (Type) import qualified Data.Text as T -import qualified Data.Vector as V -- | @'Parsed' a@ is the high-level/ADT representation of the capnproto -- type @a@. For struct types this is equivalent to @'C.Parsed' a@, but @@ -25,6 +24,6 @@ ParsedByRepr ('Ptr ('Just 'Cap)) a = Client a ParsedByRepr _ B.Data = BS.ByteString ParsedByRepr _ B.Text = T.Text - ParsedByRepr _ (List a) = V.Vector (Parsed a) + ParsedByRepr _ (List a) = [Parsed a] ParsedByRepr _ (Maybe B.AnyPointer) = Maybe (C.Parsed B.AnyPointer) ParsedByRepr _ a = C.Parsed a diff --git a/lib/Capnp/Rpc.hs b/lib/Capnp/Rpc.hs --- a/lib/Capnp/Rpc.hs +++ b/lib/Capnp/Rpc.hs @@ -5,8 +5,12 @@ -- This module exposes the most commonly used parts of the RPC subsystem. module Capnp.Rpc ( -- * Establishing connections - handleConn, + Conn, ConnConfig (..), + acquireConn, + handleConn, + withConn, + requestBootstrap, -- * throwing errors throwFailed, @@ -46,11 +50,15 @@ ) import Capnp.Rpc.Untyped ( Client, + Conn, ConnConfig (..), IsClient (..), + acquireConn, handleConn, newPromiseClient, + requestBootstrap, waitClient, + withConn, ) import qualified Capnp.Rpc.Untyped as Untyped import Supervisors diff --git a/lib/Capnp/Rpc/Membrane.hs b/lib/Capnp/Rpc/Membrane.hs --- a/lib/Capnp/Rpc/Membrane.hs +++ b/lib/Capnp/Rpc/Membrane.hs @@ -23,6 +23,7 @@ import qualified Capnp.Message as M import Capnp.Mutability (Mutability (..)) +import qualified Capnp.Repr as R import Capnp.Rpc.Promise (breakOrFulfill, newCallback) import qualified Capnp.Rpc.Server as Server import qualified Capnp.Rpc.Untyped as URpc @@ -30,6 +31,7 @@ import Control.Concurrent.STM import Control.Monad (void) import Control.Monad.STM.Class +import Data.Functor.Contravariant (contramap) import Data.Typeable (Typeable, cast) import Data.Word import Supervisors (Supervisor) @@ -110,14 +112,14 @@ x == y = identity x == identity y wrapHandler :: Side -> Supervisor -> Membrane -> Server.UntypedMethodHandler -> Server.UntypedMethodHandler -wrapHandler receiverSide sup mem handler = Server.untypedHandler $ \arguments response -> do +wrapHandler receiverSide sup mem handler = \(R.Raw arguments) response -> do (args, resp) <- atomically $ do args' <- passPtr receiverSide sup mem arguments resp' <- newCallback $ \result -> traverse (passPtr (flipDir receiverSide) sup mem) result - >>= breakOrFulfill response + >>= breakOrFulfill (contramap R.Raw response) pure (args', resp') - Server.handleUntypedMethod handler args resp + handler (R.Raw args) (contramap R.fromRaw resp) passPtr :: MonadSTM m => Direction -> Supervisor -> Membrane -> Maybe (U.Ptr 'Const) -> m (Maybe (U.Ptr 'Const)) passPtr dir sup mem = liftSTM . traverse (U.tMsg $ passMessage dir sup mem) @@ -146,19 +148,18 @@ -- and then the relevant shutdown logic will still be called. -- This introduces latency unfortuantely, but nothing is broken. Server.handleStop = pure (), - Server.handleCall = \interfaceId methodId -> - Server.untypedHandler $ \arguments response -> - do - action <- atomically $ policy mem Call {interfaceId, methodId, direction = dir, target = inClient} - case action of - Handle h -> Server.handleUntypedMethod h arguments response - Forward -> - Server.handleUntypedMethod - ( wrapHandler dir sup mem $ Server.untypedHandler $ \arguments response -> - void $ URpc.call Server.CallInfo {..} inClient - ) - arguments - response + Server.handleCall = \interfaceId methodId arguments response -> + do + action <- atomically $ policy mem Call {interfaceId, methodId, direction = dir, target = inClient} + case action of + Handle h -> h arguments response + Forward -> + ( wrapHandler dir sup mem $ \(R.Raw arguments) resp -> + let response = contramap R.Raw resp + in void $ URpc.call Server.CallInfo {..} inClient + ) + arguments + response } onSide :: Direction -> MembraneWrapped -> Membrane -> Bool diff --git a/lib/Capnp/Rpc/Promise.hs b/lib/Capnp/Rpc/Promise.hs --- a/lib/Capnp/Rpc/Promise.hs +++ b/lib/Capnp/Rpc/Promise.hs @@ -34,6 +34,7 @@ import Control.Concurrent.STM import qualified Control.Exception.Safe as HsExn import Control.Monad.STM.Class +import Data.Functor.Contravariant (Contravariant (..)) -- | An exception thrown if 'breakPromise' or 'fulfill' is called on an -- already-resolved fulfiller. @@ -45,6 +46,10 @@ newtype Fulfiller a = Fulfiller { callback :: Either (Parsed Exception) a -> STM () } + +instance Contravariant Fulfiller where + contramap f Fulfiller {callback} = + Fulfiller {callback = callback . fmap f} -- | Fulfill a promise by supplying the specified value. It is an error to -- call 'fulfill' if the promise has already been fulfilled (or broken). diff --git a/lib/Capnp/Rpc/Revoke.hs b/lib/Capnp/Rpc/Revoke.hs --- a/lib/Capnp/Rpc/Revoke.hs +++ b/lib/Capnp/Rpc/Revoke.hs @@ -39,4 +39,4 @@ else Membrane.Forward revokedHandler :: Server.UntypedMethodHandler -revokedHandler = Server.untypedHandler $ \_ response -> breakPromise response (eFailed "revoked") +revokedHandler _ response = breakPromise response (eFailed "revoked") 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,93 +1,118 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} -{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} --- | --- Module: Capnp.Rpc.Server --- Description: handlers for incoming method calls. --- --- The term server in this context refers to a thread that handles method calls for --- a particular capability (The capnproto rpc protocol itself has no concept of --- clients and servers). module Capnp.Rpc.Server - ( Server (..), - ServerOps (..), + ( CallHandler, + MethodHandler, + UntypedMethodHandler, CallInfo (..), + ServerOps (..), + Export (..), + exportToServerOps, + findMethod, + SomeServer (..), runServer, + castHandler, - -- * Handling methods - MethodHandler, - UntypedMethodHandler, - handleUntypedMethod, + -- * Helpers for writing method handlers + handleParsed, + handleRaw, + methodUnimplemented, + toUntypedMethodHandler, - -- ** Working with untyped data - untypedHandler, - toUntypedHandler, - fromUntypedHandler, + -- * Internals; exposed only for use by generated code. + MethodHandlerTree (..), ) where +import qualified Capnp.Basics as B +import qualified Capnp.Classes as C +import Capnp.Convert (parsedToRaw) import Capnp.Message (Mutability (..)) -import Capnp.Rpc.Promise (Fulfiller) -import Capnp.Untyped (Ptr) -import Control.Concurrent.STM +import qualified Capnp.Repr as R +-- import Capnp.Repr.Methods (Client (..)) +import Capnp.Rpc.Errors + ( eFailed, + eMethodUnimplemented, + wrapException, + ) +import Capnp.Rpc.Promise + ( Fulfiller, + breakPromise, + fulfill, + ) +import Capnp.TraversalLimit (defaultLimit, evalLimitT) +import qualified Capnp.Untyped as U +import Control.Concurrent.STM (atomically) +import Control.Exception.Safe (withException) +import Data.Function ((&)) +import Data.Functor.Contravariant (contramap) +import Data.Kind (Constraint, Type) +import qualified Data.Map.Strict as M +import Data.Maybe (fromMaybe) +import Data.Proxy (Proxy (..)) import Data.Typeable (Typeable) +import qualified Data.Vector as V import Data.Word +import GHC.Prim (coerce) +import Internal.BuildPure (createPure) import qualified Internal.TCloseQ as TCloseQ --- | a @'MethodHandler' p r@ handles a method call with parameters @p@ --- and return type @r@. --- --- The library represents method handlers via an abstract type --- 'MethodHandler', parametrized over parameter (@p@) and return (@r@) --- types, and the monadic context in which it runs (@m@). This allows us --- to provide different strategies for actually handling methods; there --- are various helper functions which construct these handlers. --- --- At some point we will likely additionally provide handlers affording: --- --- * Working directly with the low-level data types. --- * Replying to the method call asynchronously, allowing later method --- calls to be serviced before the current one is finished. -newtype MethodHandler p r = MethodHandler - { handleMethod :: - Maybe (Ptr 'Const) -> - Fulfiller (Maybe (Ptr 'Const)) -> - IO () +-- | A 'CallInfo' contains information about a method call. +data CallInfo = CallInfo + { -- | The id of the interface whose method is being called. + interfaceId :: !Word64, + -- | The method id of the method being called. + methodId :: !Word16, + -- | The arguments to the method call. + arguments :: Maybe (U.Ptr 'Const), + -- | A 'Fulfiller' which accepts the method's return value. + response :: Fulfiller (Maybe (U.Ptr 'Const)) } --- | Alias for a 'MethodHandler' whose parameter and return types are --- untyped pointers. -type UntypedMethodHandler = MethodHandler (Maybe (Ptr 'Const)) (Maybe (Ptr 'Const)) +-- | The operations necessary to receive and handle method calls, i.e. +-- to implement an object. +data ServerOps = ServerOps + { -- | Handle a method call; takes the interface and method id and returns + -- a handler for the specific method. + handleCall :: Word64 -> Word16 -> UntypedMethodHandler, + -- | Handle shutting-down the receiver; this is called when the last + -- reference to the capability is dropped. + handleStop :: IO (), + -- | used to unwrap the server when reflecting on a local client. + handleCast :: forall a. Typeable a => Maybe a + } -handleUntypedMethod :: UntypedMethodHandler -> Maybe (Ptr 'Const) -> Fulfiller (Maybe (Ptr 'Const)) -> IO () -handleUntypedMethod = handleMethod +-- | A handler for arbitrary RPC calls. Maps (interfaceId, methodId) pairs to +-- 'UntypedMethodHandler's. +type CallHandler = M.Map Word64 (V.Vector UntypedMethodHandler) --- | Convert a 'MethodHandler' for any parameter and return types into --- one that deals with untyped pointers. -toUntypedHandler :: MethodHandler p r -> UntypedMethodHandler -toUntypedHandler MethodHandler {..} = MethodHandler {..} +-- | Type alias for a handler for a particular rpc method. +type MethodHandler p r = + R.Raw p 'Const -> + Fulfiller (R.Raw r 'Const) -> + IO () --- | Inverse of 'toUntypedHandler' -fromUntypedHandler :: UntypedMethodHandler -> MethodHandler p r -fromUntypedHandler MethodHandler {..} = MethodHandler {..} +castHandler :: + forall p q r s. + (R.ReprFor p ~ R.ReprFor q, R.ReprFor r ~ R.ReprFor s) => + MethodHandler p r -> + MethodHandler q s +castHandler = coerce --- | Construct a method handler from a function accepting an untyped --- pointer for the method's parameter, and a 'Fulfiller' which accepts --- an untyped pointer for the method's return value. -untypedHandler :: - (Maybe (Ptr 'Const) -> Fulfiller (Maybe (Ptr 'Const)) -> IO ()) -> - MethodHandler (Maybe (Ptr 'Const)) (Maybe (Ptr 'Const)) -untypedHandler = MethodHandler +-- | Type alias for a handler for an untyped RPC method. +type UntypedMethodHandler = MethodHandler (Maybe B.AnyPointer) (Maybe B.AnyPointer) -- | Base class for things that can act as capnproto servers. -class Server a where +class SomeServer a where -- | Called when the last live reference to a server is dropped. shutdown :: a -> IO () shutdown _ = pure () @@ -103,35 +128,126 @@ 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. -data ServerOps = ServerOps - { -- | Handle a method call; takes the interface and method id and returns - -- a handler for the specific method. - handleCall :: - Word64 -> - Word16 -> - MethodHandler (Maybe (Ptr 'Const)) (Maybe (Ptr 'Const)), - -- | Handle shutting-down the receiver; this is called when the last - -- reference to the capability is dropped. - handleStop :: IO (), - -- | used to unwrap the server when reflecting on a local client. - handleCast :: forall a. Typeable a => Maybe a - } +-- | Generated interface types have instances of 'Export', which allows a server +-- for that interface to be exported as a 'Client'. +class (R.IsCap i, C.HasTypeId i) => Export i where + -- | The constraint needed for a server to implement an interface; + -- if @'Server' i s@ is satisfied, @s@ is a server for interface @i@. + -- The code generator generates a type class for each interface, and + -- this will aways be an alias for that type class. + type Server i :: Type -> Constraint --- | A 'CallInfo' contains information about a method call. -data CallInfo = CallInfo - { -- | The id of the interface whose method is being called. - interfaceId :: !Word64, - -- | The method id of the method being called. - methodId :: !Word16, - -- | The arguments to the method call. - arguments :: Maybe (Ptr 'Const), - -- | A 'Fulfiller' which accepts the method's return value. - response :: Fulfiller (Maybe (Ptr 'Const)) + -- | Convert the server to a 'MethodHandlerTree' populated with appropriate + -- 'MethodHandler's for the interface. This is really only exported for use + -- by generated code; users of the library will generally prefer to use + -- 'export'. + methodHandlerTree :: Server i s => Proxy i -> s -> MethodHandlerTree + +-- NB: the proxy helps disambiguate types; for some reason TypeApplications +-- doesn't seem to be enough in the face of a type alias of kind 'Constraint'. +-- the inconsistency is a bit ugly, but this method isn't intended to called +-- by users directly, only by generated code and our helper in this module, +-- so it's less of a big deal. + +-- | Lazily computed tree of the method handlers exposed by an interface. Only +-- of interest to generated code. +data MethodHandlerTree = MethodHandlerTree + { -- | type id for the primary interface + mhtId :: Word64, + -- | method handlers for methods of the primary interface. + mhtHandlers :: [UntypedMethodHandler], + -- | Trees for parent interfaces. In the case of diamond dependencies, + -- there may be duplicates, which are eliminated by 'mhtToCallHandler'. + mhtParents :: [MethodHandlerTree] } +mhtToCallHandler :: MethodHandlerTree -> CallHandler +mhtToCallHandler = go M.empty . pure + where + go accum [] = accum + go accum (t : ts) + | mhtId t `M.member` accum = go accum ts -- dedup diamond dependencies + | otherwise = + go (M.insert (mhtId t) (V.fromList (mhtHandlers t)) accum) (mhtParents t ++ ts) + +-- | Look up a particlar 'MethodHandler' in the 'CallHandler'. +findMethod :: Word64 -> Word16 -> CallHandler -> Maybe UntypedMethodHandler +findMethod interfaceId methodId handler = do + iface <- M.lookup interfaceId handler + iface V.!? fromIntegral methodId + +-- | Convert a typed method handler to an untyped one. Mostly intended for +-- use by generated code. +toUntypedMethodHandler :: + forall p r. + (R.IsStruct p, R.IsStruct r) => + MethodHandler p r -> + UntypedMethodHandler +toUntypedMethodHandler h = + \case + R.Raw (Just (U.PtrStruct param)) -> \ret -> + h + (R.Raw param) + ( contramap + (\(R.Raw s) -> R.Raw $ Just $ U.PtrStruct s) + ret + ) + _ -> + \ret -> breakPromise ret (eFailed "Parameter was not a struct") + +someServerToServerOps :: SomeServer a => a -> CallHandler -> ServerOps +someServerToServerOps srv callHandler = + ServerOps + { handleStop = shutdown srv, + handleCast = unwrap srv, + handleCall = \interfaceId methodId -> + findMethod interfaceId methodId callHandler + & fromMaybe methodUnimplemented + } + +exportToServerOps :: forall i s. (Export i, Server i s, SomeServer s) => Proxy i -> s -> ServerOps +exportToServerOps proxy srv = + mhtToCallHandler (methodHandlerTree proxy srv) + & someServerToServerOps srv + +-- Helpers for writing method handlers + +-- | Handle a method, working with the parsed form of parameters and +-- results. +handleParsed :: + ( C.Parse p pp, + R.IsStruct p, + C.Parse r pr, + R.IsStruct r + ) => + (pp -> IO pr) -> + MethodHandler p r +handleParsed handler param = propagateExceptions $ \f -> do + p <- evalLimitT defaultLimit $ C.parse param + r <- handler p + -- TODO: Figure out how to add an instance of Thaw for + -- Raw so we can skip the (un)wrapping here. + struct <- createPure maxBound $ R.fromRaw <$> parsedToRaw r + fulfill f (R.Raw struct) + +-- | Handle a method, working with the raw (unparsed) form of +-- parameters and results. +handleRaw :: + (R.IsStruct p, R.IsStruct r) => + (R.Raw p 'Const -> IO (R.Raw r 'Const)) -> + MethodHandler p r +handleRaw handler param = propagateExceptions $ \f -> + handler param >>= fulfill f + +-- Helper for handle*; breaks the promise if the handler throws. +propagateExceptions :: (Fulfiller a -> IO b) -> Fulfiller a -> IO b +propagateExceptions h f = + h f `withException` (breakPromise f . wrapException False) + +-- | 'MethodHandler' that always throws unimplemented. +methodUnimplemented :: MethodHandler p r +methodUnimplemented _ f = breakPromise f eMethodUnimplemented + -- | Handle incoming messages for a given object. -- -- Accepts a queue of messages to handle, and 'ServerOps' used to handle them. @@ -143,9 +259,7 @@ atomically (TCloseQ.read q) >>= \case Nothing -> pure () - Just CallInfo {interfaceId, methodId, arguments, response} -> do - handleMethod - (handleCall ops interfaceId methodId) - arguments - response - go + Just CallInfo {interfaceId, methodId, arguments, response} -> + do + handleCall ops interfaceId methodId (R.Raw arguments) (coerce response) + go 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 @@ -23,8 +23,12 @@ -- methods etc. as used here are untyped. module Capnp.Rpc.Untyped ( -- * Connections to other vats + Conn, ConnConfig (..), handleConn, + withConn, + acquireConn, + requestBootstrap, -- * Clients for capabilities Client, @@ -66,7 +70,7 @@ import Capnp.Message (Message) import qualified Capnp.Message as Message import Capnp.Mutability (Mutability (..), thaw) -import Capnp.Repr (Raw (..)) +import Capnp.Repr (Raw (..), ReprFor) import Capnp.Rpc.Errors ( eDisconnected, eFailed, @@ -89,7 +93,7 @@ import Capnp.TraversalLimit (LimitT, defaultLimit, evalLimitT) import qualified Capnp.Untyped as UntypedRaw import Control.Concurrent (threadDelay) -import Control.Concurrent.Async (concurrently_, race_) +import Control.Concurrent.Async (Async, cancel, concurrently_, race, race_, wait, withAsync) import Control.Concurrent.MVar (MVar, newEmptyMVar) import Control.Concurrent.STM import Control.Exception.Safe @@ -108,6 +112,7 @@ import Control.Monad.Trans.Class import Data.Default (Default (def)) import Data.Dynamic (fromDynamic) +import Data.Either (fromLeft) import Data.Foldable (for_, toList, traverse_) import Data.Function ((&)) import Data.Hashable (Hashable, hash, hashWithSalt) @@ -119,6 +124,7 @@ import Data.Word import qualified Focus import GHC.Generics (Generic) +import GHC.Prim (coerce) import Internal.BuildPure (createPure) import Internal.Rc (Rc) import qualified Internal.Rc as Rc @@ -126,6 +132,8 @@ import Internal.SnocList (SnocList) import qualified Internal.SnocList as SnocList import qualified Internal.TCloseQ as TCloseQ +import Lifetimes (Acquire, mkAcquire, withAcquire) +import Lifetimes.Async (acquireAsync) import qualified Lifetimes.Gc as Fin import qualified ListT import qualified StmContainers.Map as M @@ -252,6 +260,9 @@ debugMode :: !Bool, -- whether to include extra (possibly sensitive) info in error messages. + done :: Async (), + -- finished when the connection is shut down. Note: this should not be used + -- by most of the code within this module; see the implementation of acquireConn. liveState :: TVar LiveState } @@ -297,7 +308,7 @@ pendingCallbacks :: TQueue (IO ()), -- See Note [callbacks] - bootstrap :: Maybe Client + myBootstrap :: Maybe Client -- The capability which should be served as this connection's bootstrap -- interface (if any). } @@ -335,22 +346,10 @@ -- -- Defaults to 'False'. debugMode :: !Bool, - -- | Get the bootstrap interface we should serve for this connection. - -- the argument is a supervisor whose lifetime is bound to the - -- connection. If 'getBootstrap' returns 'Nothing', we will respond - -- to bootstrap messages with an exception. - -- - -- The default always returns 'Nothing'. - -- - -- 'getBootstrap' MUST NOT block; the connection will not be serviced - -- and 'withBootstrap' will not be run until this returns. If you need - -- to supply the bootstrap interface later, use 'newPromiseClient'. - getBootstrap :: Supervisor -> STM (Maybe Client), - -- | An action to perform with access to the remote vat's bootstrap - -- interface. The supervisor argument is bound to the lifetime of the - -- connection. If this is 'Nothing' (the default), the bootstrap - -- interface will not be requested. - withBootstrap :: Maybe (Supervisor -> Client -> IO ()) + -- | The bootstrap interface we should serve for this connection. + -- If 'bootstrap' is 'Nothing' (the default), we will respond to + -- bootstrap messages with an exception. + bootstrap :: Maybe Client } instance Default ConnConfig where @@ -360,8 +359,7 @@ maxExports = 8192, maxCallWords = bytesToWordsFloor $ 32 * 1024 * 1024, debugMode = False, - getBootstrap = \_ -> pure Nothing, - withBootstrap = Nothing + bootstrap = Nothing } -- | Queue an IO action to be run some time after this transaction commits. @@ -447,119 +445,131 @@ freeEmbargo :: Conn' -> EmbargoId -> STM () freeEmbargo conn = freeId (exportIdPool conn) . embargoWord +-- | Wait until a connection has shut down, then re-throw the +-- exception that killed it, if any. +waitConn :: Conn -> IO () +waitConn Conn {done} = wait done + -- | Handle a connection to another vat. Returns when the connection is closed. -handleConn :: Transport -> ConnConfig -> IO () -handleConn - transport +handleConn :: + Transport -> + ConnConfig -> + IO () +handleConn transport cfg = + withAcquire (acquireConn transport cfg) waitConn + +-- | Run the function with access to a connection. Shut down the connection +-- when it returns. +withConn :: Transport -> ConnConfig -> (Conn -> IO a) -> IO a +withConn transport cfg f = + withAcquire (acquireConn transport cfg) $ \conn -> do + result <- f conn `race` waitConn conn + case result of + Left v -> pure v + Right () -> + error "BUG: waitConn returned normally" + +acquireConn :: Transport -> ConnConfig -> Acquire Conn +acquireConn transport cfg = do + (conn, conn') <- mkAcquire (newConn cfg) stopConn + done <- acquireAsync $ runConn cfg transport (conn, conn') + pure conn {done = done} + +newConn cfg@ConnConfig { maxQuestions, maxExports, maxCallWords, - withBootstrap, debugMode - } = - withSupervisor $ \sup -> - bracket - (newConn sup) - stopConn - runConn - where - newConn sup = do - stableName <- makeStableName =<< newEmptyMVar - atomically $ do - bootstrap <- getBootstrap cfg sup - questionIdPool <- newIdPool maxQuestions - exportIdPool <- newIdPool maxExports + } = do + stableName <- makeStableName =<< newEmptyMVar + atomically $ do + questionIdPool <- newIdPool maxQuestions + exportIdPool <- newIdPool maxExports - sendQ <- newTChan + sendQ <- newTChan - availableCallWords <- newTVar maxCallWords + availableCallWords <- newTVar maxCallWords - questions <- M.new - answers <- M.new - exports <- M.new - imports <- M.new + questions <- M.new + answers <- M.new + exports <- M.new + imports <- M.new - embargos <- M.new - pendingCallbacks <- newTQueue + embargos <- M.new + pendingCallbacks <- newTQueue - let conn' = - Conn' - { supervisor = sup, - questionIdPool, - exportIdPool, - sendQ, - availableCallWords, - questions, - answers, - exports, - imports, - embargos, - pendingCallbacks, - bootstrap - } - liveState <- newTVar (Live conn') - let conn = - Conn - { stableName, - debugMode, - liveState + let conn' = + Conn' + { questionIdPool, + exportIdPool, + sendQ, + availableCallWords, + questions, + answers, + exports, + imports, + embargos, + pendingCallbacks, + myBootstrap = bootstrap cfg + } + liveState <- newTVar (Live conn') + let conn = + Conn + { stableName, + debugMode, + liveState + } + pure (conn, conn') + +runConn cfg transport (conn, conn') = do + result <- + try $ + recvLoop transport conn + `concurrently_` sendLoop transport conn' + `concurrently_` callbacksLoop conn' + case result of + Left (SentAbort e) -> do + -- We need to actually send it: + rawMsg <- createPure maxBound $ parsedToMsg $ R.Message'abort e + void $ timeout 1000000 $ sendMsg transport rawMsg + throwIO $ SentAbort e + Left e -> + throwIO e + Right _ -> + pure () + +stopConn + ( conn@Conn {liveState}, + conn'@Conn' {questions, exports, embargos} + ) = do + atomically $ do + let walk table = flip ListT.traverse_ (M.listT table) + -- drop the bootstrap interface: + case myBootstrap conn' of + Just (unwrapClient -> Just client') -> dropConnExport conn client' + _ -> pure () + -- Remove everything from the exports table: + walk exports $ \(_, EntryE {client}) -> + dropConnExport conn client + -- Outstanding questions should all throw disconnected: + walk questions $ \(qid, entry) -> + let raiseDisconnected onReturn = + mapQueueSTM conn' onReturn $ + Return + { answerId = qid, + releaseParamCaps = False, + union' = Return'exception eDisconnected } - pure (conn, conn') - runConn (conn, conn') = do - result <- - try $ - ( recvLoop transport conn - `concurrently_` sendLoop transport conn' - `concurrently_` callbacksLoop conn' - ) - `race_` useBootstrap conn conn' - case result of - Left (SentAbort e) -> do - -- We need to actually send it: - rawMsg <- createPure maxBound $ parsedToMsg $ R.Message'abort e - void $ timeout 1000000 $ sendMsg transport rawMsg - throwIO $ SentAbort e - Left e -> - throwIO e - Right _ -> - pure () - stopConn - ( conn@Conn {liveState}, - conn'@Conn' {questions, exports, embargos} - ) = do - atomically $ do - let walk table = flip ListT.traverse_ (M.listT table) - -- drop the bootstrap interface: - case bootstrap conn' of - Just (unwrapClient -> Just client') -> dropConnExport conn client' + in case entry of + NewQA {onReturn} -> raiseDisconnected onReturn + HaveFinish {onReturn} -> raiseDisconnected onReturn _ -> pure () - -- Remove everything from the exports table: - walk exports $ \(_, EntryE {client}) -> - dropConnExport conn client - -- Outstanding questions should all throw disconnected: - walk questions $ \(qid, entry) -> - let raiseDisconnected onReturn = - mapQueueSTM conn' onReturn $ - Return - { answerId = qid, - releaseParamCaps = False, - union' = Return'exception eDisconnected - } - in case entry of - NewQA {onReturn} -> raiseDisconnected onReturn - HaveFinish {onReturn} -> raiseDisconnected onReturn - _ -> pure () - -- same thing with embargos: - walk embargos $ \(_, fulfiller) -> - breakPromise fulfiller eDisconnected - -- mark the connection as dead, making the live state inaccessible: - writeTVar liveState Dead - useBootstrap conn conn' = case withBootstrap of - Nothing -> - forever $ threadDelay maxBound - Just f -> - atomically (requestBootstrap conn) >>= f (supervisor conn') + -- same thing with embargos: + walk embargos $ \(_, fulfiller) -> + breakPromise fulfiller eDisconnected + -- mark the connection as dead, making the live state inaccessible: + writeTVar liveState Dead -- | A pool of ids; used when choosing identifiers for questions and exports. newtype IdPool = IdPool (TVar [Word32]) @@ -930,7 +940,7 @@ data Payload = Payload { content :: RawMPtr, - capTable :: V.Vector (R.Parsed R.CapDescriptor) + capTable :: [R.Parsed R.CapDescriptor] } -- Note [proxies] @@ -1010,7 +1020,7 @@ payload@Payload {capTable} <- makeOutgoingPayload conn arguments -- save these in case the callee sends back releaseParamCaps = True in the return -- message: - let paramCaps = catMaybes $ flip map (V.toList capTable) $ \R.CapDescriptor {union'} -> case union' of + let paramCaps = catMaybes $ flip map capTable $ \R.CapDescriptor {union'} -> case union' of R.CapDescriptor'senderHosted eid -> Just (IEId eid) R.CapDescriptor'senderPromise eid -> Just (IEId eid) _ -> Nothing @@ -1115,10 +1125,9 @@ R.PromisedAnswer { R.questionId = qaWord answerId, R.transform = - V.fromList $ - map - (R.PromisedAnswer'Op . R.PromisedAnswer'Op'getPointerField) - (toList transform) + map + (R.PromisedAnswer'Op . R.PromisedAnswer'Op'getPointerField) + (toList transform) } unmarshalPromisedAnswer :: MonadThrow m => R.Parsed R.PromisedAnswer -> m PromisedAnswer @@ -1223,11 +1232,19 @@ ) pure $ wrapClient (Just client') -clientMethodHandler :: Word64 -> Word16 -> Client -> Server.MethodHandler p r +clientMethodHandler :: + forall p r. + ( ReprFor p ~ ReprFor (Maybe B.AnyPointer), + ReprFor r ~ ReprFor (Maybe B.AnyPointer) + ) => + Word64 -> + Word16 -> + Client -> + Server.MethodHandler p r clientMethodHandler interfaceId methodId client = - Server.fromUntypedHandler $ - Server.untypedHandler $ - \arguments response -> atomically $ void $ call Server.CallInfo {..} client + Server.castHandler @(Maybe B.AnyPointer) @p @(Maybe B.AnyPointer) @r $ + \(Raw arguments) response -> + atomically $ void $ call Server.CallInfo {response = coerce response, ..} client -- | See Note [callbacks] callbacksLoop :: Conn' -> IO () @@ -1328,7 +1345,7 @@ handleBootstrapMsg :: Conn -> R.Parsed R.Bootstrap -> STM () handleBootstrapMsg conn R.Bootstrap {questionId} = getLive conn >>= \conn' -> do - ret <- case bootstrap conn' of + ret <- case myBootstrap conn' of Nothing -> pure Return @@ -1352,8 +1369,7 @@ Payload { content, capTable = - V.singleton - (def {R.union' = capDesc} :: R.Parsed R.CapDescriptor) + [def {R.union' = capDesc} :: R.Parsed R.CapDescriptor] } } M.focus @@ -1375,7 +1391,7 @@ { union' = Return'results Payload - { capTable = (V.toList -> [R.CapDescriptor {union' = R.CapDescriptor'receiverHosted (IEId -> eid)}]) + { capTable = [R.CapDescriptor {union' = R.CapDescriptor'receiverHosted (IEId -> eid)}] } } -> when releaseResultCaps $ @@ -1466,7 +1482,7 @@ { interfaceId, methodId, arguments = callParams, - response = fulfiller + response = coerce fulfiller } -- Finally, figure out where to send it: case target of @@ -1505,9 +1521,9 @@ ptrPathClient is ptr = evalLimitT defaultLimit $ followPtrs is ptr >>= ptrClient -transformClient :: V.Vector (R.Parsed R.PromisedAnswer'Op) -> RawMPtr -> Conn' -> STM Client +transformClient :: [R.Parsed R.PromisedAnswer'Op] -> RawMPtr -> Conn' -> STM Client transformClient transform ptr conn = - (unmarshalOps (V.toList transform) >>= flip ptrPathClient ptr) + (unmarshalOps transform >>= flip ptrPathClient ptr) `catchSTM` abortConn conn ptrClient :: UntypedRaw.ReadCtx m 'Const => RawMPtr -> m Client @@ -1896,15 +1912,15 @@ genSendableCapTableRaw :: Conn -> Maybe (UntypedRaw.Ptr 'Const) -> - STM (V.Vector (R.Parsed R.CapDescriptor)) -genSendableCapTableRaw _ Nothing = pure V.empty + STM [R.Parsed R.CapDescriptor] +genSendableCapTableRaw _ Nothing = pure [] genSendableCapTableRaw conn (Just ptr) = traverse ( \c -> do union' <- emitCap conn c pure (def :: R.Parsed R.CapDescriptor) {R.union' = union'} ) - (Message.getCapTable (UntypedRaw.message @UntypedRaw.Ptr ptr)) + (V.toList $ Message.getCapTable (UntypedRaw.message @UntypedRaw.Ptr ptr)) -- | Convert the pointer into a Payload, including a capability table for -- the clients in the pointer's cap table. @@ -2039,60 +2055,61 @@ Dead -> pure () -- | Request the remote vat's bootstrap interface. -requestBootstrap :: Conn -> STM Client +requestBootstrap :: MonadSTM m => Conn -> m Client requestBootstrap conn@Conn {liveState} = - readTVar liveState >>= \case - Dead -> - pure nullClient - Live conn'@Conn' {questions} -> do - qid <- newQuestion conn' - let tmpDest = - RemoteDest - AnswerDest - { conn, - answer = - PromisedAnswer - { answerId = qid, - transform = SnocList.empty - } - } - pState <- newTVar Pending {tmpDest} + liftSTM $ + readTVar liveState >>= \case + Dead -> + pure nullClient + Live conn'@Conn' {questions} -> do + qid <- newQuestion conn' + let tmpDest = + RemoteDest + AnswerDest + { conn, + answer = + PromisedAnswer + { answerId = qid, + transform = SnocList.empty + } + } + pState <- newTVar Pending {tmpDest} - -- Arguably, we should wait for this promise, since it's analagous - -- to a call in terms of operation, but we only send one of these - -- per connection, so whatever. - (_, onSent) <- newPromise - sendPureMsg - conn' - (R.Message'bootstrap (def {R.questionId = qaWord qid} :: R.Parsed R.Bootstrap)) - onSent + -- Arguably, we should wait for this promise, since it's analagous + -- to a call in terms of operation, but we only send one of these + -- per connection, so whatever. + (_, onSent) <- newPromise + sendPureMsg + conn' + (R.Message'bootstrap (def {R.questionId = qaWord qid} :: R.Parsed R.Bootstrap)) + onSent - M.insert - NewQA - { onReturn = - SnocList.fromList - [ resolveClientReturn tmpDest (writeTVar pState) conn' [], - \_ -> - finishQuestion - conn' - R.Finish - { questionId = qaWord qid, - releaseResultCaps = False - } - ], - onFinish = SnocList.empty - } - qid - questions - exportMap <- ExportMap <$> M.new - pure $ - wrapClient $ - Just - PromiseClient - { pState, - exportMap, - origTarget = tmpDest - } + M.insert + NewQA + { onReturn = + SnocList.fromList + [ resolveClientReturn tmpDest (writeTVar pState) conn' [], + \_ -> + finishQuestion + conn' + R.Finish + { questionId = qaWord qid, + releaseResultCaps = False + } + ], + onFinish = SnocList.empty + } + qid + questions + exportMap <- ExportMap <$> M.new + pure $ + wrapClient $ + Just + PromiseClient + { pState, + exportMap, + origTarget = tmpDest + } -- Note [resolveClient] -- ==================== @@ -2358,7 +2375,7 @@ acceptPayload :: Conn -> Raw R.Payload 'Const -> LimitT STM Payload acceptPayload conn payload = do capTable <- parseField #capTable payload - clients <- lift $ traverse (\R.CapDescriptor {union'} -> acceptCap conn union') capTable + clients <- lift $ V.fromList <$> traverse (\R.CapDescriptor {union'} -> acceptCap conn union') capTable Raw rawContent <- readField #content payload content <- traverse (UntypedRaw.tMsg (pure . Message.withCapTable clients)) rawContent pure Payload {content, capTable} diff --git a/lib/Capnp/Tutorial.hs b/lib/Capnp/Tutorial.hs --- a/lib/Capnp/Tutorial.hs +++ b/lib/Capnp/Tutorial.hs @@ -151,7 +151,7 @@ -- and abbreviated for readability): -- -- > import qualified Capnp.Repr as R --- > import qualified Capnp.New.Classes as C +-- > import qualified Capnp.Classes as C -- > import qualified Capnp.Repr.Parsed as RP -- > import GHC.Generics (Generic) -- > @@ -263,54 +263,57 @@ -- Some additional things are generated for interfaces, but we cover those -- in the RPC section below. -- --- The module "Capnp.New" exposes the most frequently used +-- The module "Capnp" exposes the most frequently used -- functionality from the capnp package. We can write an address book -- message to standard output using the high-level API like so: -- --- > {-# LANGUAGE OverloadedStrings #-} -- > -- Note that DuplicateRecordFields is usually needed, as the generated -- > -- code relys on it to resolve collisions in capnproto struct field -- > -- names: -- > {-# LANGUAGE DuplicateRecordFields #-} --- > import Capnp.Gen.Addressbook.New +-- > {-# LANGUAGE OverloadedStrings #-} -- > --- > -- Note that Capnp.New re-exports `def`, as a convienence --- > import Capnp.New (putParsed, def) +-- > module Examples.Serialization.HighLevel.Write (main) where -- > --- > import qualified Data.Vector as V +-- > -- Note that Capnp re-exports `def`, as a convienence +-- > import Capnp (def, putParsed) +-- > import Capnp.Gen.Addressbook -- > --- > main = putParsed AddressBook --- > { people = V.fromList --- > [ Person --- > { id = 123 --- > , name = "Alice" --- > , email = "alice@example.com" --- > , phones = V.fromList --- > [ def --- > { number = "555-1212" --- > , type_ = Person'PhoneNumber'Type'mobile --- > } --- > ] --- > , employment = Person'employment $ Person'employment'school "MIT" --- > } --- > , Person --- > { id = 456 --- > , name = "Bob" --- > , email = "bob@example.com" --- > , phones = V.fromList --- > [ def --- > { number = "555-4567" --- > , type_ = Person'PhoneNumber'Type'home --- > } --- > , def --- > { number = "555-7654" --- > , type_ = Person'PhoneNumber'Type'work --- > } --- > ] --- > , employment = Person'employment $ Person'employment'selfEmployed --- > } --- > ] --- > } +-- > main :: IO () +-- > main = +-- > putParsed +-- > AddressBook +-- > { people = +-- > [ Person +-- > { id = 123, +-- > name = "Alice", +-- > email = "alice@example.com", +-- > phones = +-- > [ def +-- > { number = "555-1212", +-- > type_ = Person'PhoneNumber'Type'mobile +-- > } +-- > ], +-- > employment = Person'employment' $ Person'employment'school "MIT" +-- > }, +-- > Person +-- > { id = 456, +-- > name = "Bob", +-- > email = "bob@example.com", +-- > phones = +-- > [ def +-- > { number = "555-4567", +-- > type_ = Person'PhoneNumber'Type'home +-- > }, +-- > def +-- > { number = "555-7654", +-- > type_ = Person'PhoneNumber'Type'work +-- > } +-- > ], +-- > employment = Person'employment' Person'employment'selfEmployed +-- > } +-- > ] +-- > } -- -- 'putValue' is equivalent to @'hPutValue' 'stdout'@; 'hPutValue' may be used -- to write to an arbitrary handle. @@ -320,7 +323,7 @@ -- > -- ... -- > -- > {-# LANGUAGE TypeApplications #-} --- > import Capnp.New (getParsed, defaultLimit) +-- > import Capnp (getParsed, defaultLimit) -- > -- > -- ... -- > @@ -361,8 +364,8 @@ -- which accepts as type parameters the mutability of the underlying message, -- and a phantom type indicating the capnproto type. This second type parameter -- will be instantiated with the (for structs, uninhabited) type generated by --- the schema compiler plugin. The accessors in "Capnp.New.Accessors" --- (re-exported by "Capnp.New") are used to read and write the fields. +-- the schema compiler plugin. The accessors in "Capnp.Accessors" +-- (re-exported by "Capnp") are used to read and write the fields. -- This API is much closer in spirit to that of the C++ reference implementation. -- -- Because the low level interfaces do not parse and validate the message @@ -382,112 +385,113 @@ -- > {-# LANGUAGE OverloadedLabels #-} -- > {-# LANGUAGE TypeApplications #-} -- > --- > import Capnp.Gen.Addressbook.New --- > import qualified Capnp.New as C --- > import Control.Monad (forM_) --- > import Control.Monad.Trans (lift) --- > import Data.Function ((&)) --- > import qualified Data.Text as T +-- > module Examples.Serialization.LowLevel.Read (main) where -- > +-- > import Capnp.Gen.Addressbook +-- > import qualified Capnp as C +-- > import Control.Monad (forM_) +-- > import Control.Monad.Trans (lift) +-- > import Data.Function ((&)) +-- > import qualified Data.Text as T +-- > -- > main :: IO () -- > main = do --- > addressbook <- C.getRaw @AddressBook C.defaultLimit --- > C.evalLimitT C.defaultLimit $ do --- > people <- C.readField #people addressbook --- > forM_ [0..C.length people - 1] $ \i -> do --- > people --- > & C.index i --- > >>= C.parseField #name --- > >>= lift . putStrLn . T.unpack +-- > addressbook <- C.getRaw @AddressBook C.defaultLimit +-- > C.evalLimitT C.defaultLimit $ do +-- > people <- C.readField #people addressbook +-- > forM_ [0 .. C.length people - 1] $ \i -> do +-- > people +-- > & C.index i +-- > >>= C.parseField #name +-- > >>= lift . putStrLn . T.unpack -- $lowlevel-write -- -- Writing messages using the low-level API has a similarly imperative feel. -- The below constructs the same message as in our high-level example above: -- --- > {-# LANGUAGE DataKinds #-} +-- > {-# LANGUAGE DataKinds #-} -- > {-# LANGUAGE OverloadedLabels #-} -- > {-# LANGUAGE TypeApplications #-} -- > --- > import Data.Function ((&)) --- > --- > import Capnp.Gen.Addressbook.New +-- > module Examples.Serialization.LowLevel.Write (main) where -- > --- > import qualified Capnp.New as C +-- > import Capnp.Gen.Addressbook +-- > import qualified Capnp as C +-- > import Data.Function ((&)) -- > import qualified Data.Text as T -- > -- > main :: IO () -- > main = --- > let Right msg = C.createPure C.defaultLimit buildMsg --- > in C.putMsg msg +-- > let Right msg = C.createPure C.defaultLimit buildMsg +-- > in C.putMsg msg -- > -- > buildMsg :: C.PureBuilder s (C.Message ('C.Mut s)) -- > buildMsg = do --- > -- newMessage allocates a new, initially empty, mutable message. It --- > -- takes an optional size hint: --- > msg <- C.newMessage Nothing --- > --- > -- newRoot allocates a new struct as the root object of the message. --- > -- The unit argument is a hint to the allocator to determine the size --- > -- of the object; for types whose size is not fixed (e.g. untyped structs, --- > -- lists), this may be something more meaningful. --- > addressbook <- C.newRoot @AddressBook () msg +-- > -- newMessage allocates a new, initially empty, mutable message. It +-- > -- takes an optional size hint: +-- > msg <- C.newMessage Nothing -- > --- > -- newField can be used to allocate the value of a field, for pointer --- > -- types like lists. The number is the allocation hint, as used by newRoot. --- > -- We can use the OverloadedLabels extension to pass in fields by name. --- > people <- C.newField #people 2 addressbook +-- > -- newRoot allocates a new struct as the root object of the message. +-- > -- The unit argument is a hint to the allocator to determine the size +-- > -- of the object; for types whose size is not fixed (e.g. untyped structs, +-- > -- lists), this may be something more meaningful. +-- > addressbook <- C.newRoot @AddressBook () msg -- > --- > -- Index gets an object at a specified location in a list. Cap'N Proto --- > -- lists are flat arrays, and in the case of structs the structs are --- > -- unboxed, so there is no need to allocate each element: --- > alice <- C.index 0 people +-- > -- newField can be used to allocate the value of a field, for pointer +-- > -- types like lists. The number is the allocation hint, as used by newRoot. +-- > -- We can use the OverloadedLabels extension to pass in fields by name. +-- > people <- C.newField #people 2 addressbook -- > --- > -- encodeField takes the parsed form of a value and marshals it into --- > -- the specified field. For basic types like integers & booleans, this --- > -- is almost always what you want. For larger values, you may want to --- > -- use newField as above, or separately create the value and use setField, --- > -- as shown below. --- > C.encodeField #id 123 alice --- > C.encodeField #name (T.pack "Alice") alice --- > C.encodeField #email (T.pack "alice@example.com") alice +-- > -- Index gets an object at a specified location in a list. Cap'N Proto +-- > -- lists are flat arrays, and in the case of structs the structs are +-- > -- unboxed, so there is no need to allocate each element: +-- > alice <- C.index 0 people -- > --- > -- We would probably use newField here, but to demonstrate, we can allocate --- > -- the value separately with new, and then set it with setField. --- > phones <- C.new @(C.List Person'PhoneNumber) 1 msg --- > C.setField #phones phones alice +-- > -- encodeField takes the parsed form of a value and marshals it into +-- > -- the specified field. For basic types like integers & booleans, this +-- > -- is almost always what you want. For larger values, you may want to +-- > -- use newField as above, or separately create the value and use setField, +-- > -- as shown below. +-- > C.encodeField #id 123 alice +-- > C.encodeField #name (T.pack "Alice") alice +-- > C.encodeField #email (T.pack "alice@example.com") alice -- > --- > mobilePhone <- C.index 0 phones --- > -- It is sometimes more ergonomic to use (&) from Data.Function. You might --- > -- ask why not just make the container the first argument, but it works --- > -- out better this way for the read examples. --- > mobilePhone & C.encodeField #number (T.pack "555-1212") --- > mobilePhone & C.encodeField #type_ Person'PhoneNumber'Type'mobile +-- > -- We would probably use newField here, but to demonstrate, we can allocate +-- > -- the value separately with new, and then set it with setField. +-- > phones <- C.new @(C.List Person'PhoneNumber) 1 msg +-- > C.setField #phones phones alice -- > --- > -- Since named unions act like unnamed unions inside a group, we first have --- > -- to get the group field: --- > employment <- C.readField #employment alice +-- > mobilePhone <- C.index 0 phones +-- > -- It is sometimes more ergonomic to use (&) from Data.Function. You might +-- > -- ask why not just make the container the first argument, but it works +-- > -- out better this way for the read examples. +-- > mobilePhone & C.encodeField #number (T.pack "555-1212") +-- > mobilePhone & C.encodeField #type_ Person'PhoneNumber'Type'mobile -- > --- > -- Then, we can use encodeVariant to set both the tag of the union and the --- > -- value: --- > employment & C.encodeVariant #school (T.pack "MIT") +-- > -- Since named unions act like unnamed unions inside a group, we first have +-- > -- to get the group field: +-- > employment <- C.readField #employment alice -- > --- > bob <- C.index 1 people --- > bob & C.encodeField #id 456 --- > bob & C.encodeField #name (T.pack "Bob") --- > bob & C.encodeField #email (T.pack "bob@example.com") +-- > -- Then, we can use encodeVariant to set both the tag of the union and the +-- > -- value: +-- > employment & C.encodeVariant #school (T.pack "MIT") -- > --- > phones <- bob & C.newField #phones 2 --- > homePhone <- phones & C.index 0 --- > homePhone & C.encodeField #number (T.pack "555-4567") --- > homePhone & C.encodeField #type_ Person'PhoneNumber'Type'home --- > workPhone <- phones & C.index 1 --- > workPhone & C.encodeField #number (T.pack "555-7654") --- > workPhone & C.encodeField #type_ Person'PhoneNumber'Type'work --- > employment <- bob & C.readField #employment --- > employment & C.encodeVariant #selfEmployed () -- Note the (), since selfEmploy is Void. +-- > bob <- C.index 1 people +-- > bob & C.encodeField #id 456 +-- > bob & C.encodeField #name (T.pack "Bob") +-- > bob & C.encodeField #email (T.pack "bob@example.com") -- > --- > pure msg +-- > phones <- bob & C.newField #phones 2 +-- > homePhone <- phones & C.index 0 +-- > homePhone & C.encodeField #number (T.pack "555-4567") +-- > homePhone & C.encodeField #type_ Person'PhoneNumber'Type'home +-- > workPhone <- phones & C.index 1 +-- > workPhone & C.encodeField #number (T.pack "555-7654") +-- > workPhone & C.encodeField #type_ Person'PhoneNumber'Type'work +-- > employment <- bob & C.readField #employment +-- > employment & C.encodeVariant #selfEmployed () -- Note the (), since selfEmploy is Void. +-- > pure msg -- $rpc -- @@ -534,44 +538,51 @@ -- 'handleRaw' to construct these, which can be more ergonomic and less error -- prone. In particular, they prevent you from forgetting to use the 'Fulfiller'. -- --- Once you have an instance of the server class, the 'Capnp.New.export' function +-- Once you have an instance of the server class, the 'Capnp.export' function -- is used to convert such an instance into a handle to the object that can be -- passed around. -- -- Here is an an echo (networking) server using this interface: -- --- > {-# LANGUAGE MultiParamTypeClasses #-} --- > {-# LANGUAGE OverloadedStrings #-} --- > {-# LANGUAGE TypeApplications #-} -- > --- > import Network.Simple.TCP (serve) +-- > {-# LANGUAGE MultiParamTypeClasses #-} +-- > {-# LANGUAGE OverloadedStrings #-} +-- > {-# LANGUAGE TypeApplications #-} -- > --- > import Capnp.New (SomeServer, def, defaultLimit, export, handleParsed) --- > import Capnp.Rpc (ConnConfig(..), handleConn, socketTransport, toClient) +-- > module Examples.Rpc.EchoServer (main) where -- > --- > import Capnp.Gen.Echo.New +-- > import Capnp (SomeServer, def, defaultLimit, export, handleParsed) +-- > import Capnp.Gen.Echo +-- > import Capnp.Rpc (ConnConfig (..), handleConn, socketTransport, toClient) +-- > import Network.Simple.TCP (serve) +-- > import Supervisors (withSupervisor) -- > -- > data MyEchoServer = MyEchoServer -- > -- > instance SomeServer MyEchoServer -- > -- > instance Echo'server_ MyEchoServer where --- > echo'echo MyEchoServer = handleParsed $ \params -> --- > pure def { reply = query params } +-- > echo'echo MyEchoServer = handleParsed $ \params -> +-- > pure def {reply = query params} -- > -- > main :: IO () --- > main = serve "localhost" "4000" $ \(sock, _addr) -> --- > handleConn (socketTransport sock defaultLimit) def --- > { debugMode = True --- > , getBootstrap = \sup -> Just . toClient <$> export @Echo sup MyEchoServer --- > } +-- > main = +-- > withSupervisor $ \sup -> do +-- > boot <- export @Echo sup MyEchoServer +-- > serve "localhost" "4000" $ \(sock, _addr) -> +-- > handleConn +-- > (socketTransport sock defaultLimit) +-- > def +-- > { debugMode = True, +-- > bootstrap = Just (toClient boot) +-- > } -- --- For RPC clients, there is a 'Client' type exported by "Capnp.New", which is +-- For RPC clients, there is a 'Client' type exported by "Capnp", which is -- parametrized over a phantom type indicating the type of the remote capability. -- So a @'Client' Echo@ allows you to call methods on an @Echo@ interface. -- -- Actually invoking methods uses the functions in "Capnp.Repr.Methods", --- re-exported by "Capnp.New". 'callP', 'callB', and 'callR' provide different +-- re-exported by "Capnp". 'callP', 'callB', and 'callR' provide different -- ways of supplying arguments to a call, but all are intended to be used with -- the OverloadedLabels extension for specifying the method name. -- @@ -579,32 +590,37 @@ -- 'waitPipeline' blocks until the result is available. -- -- Here is an an echo client using this interface: --- --- > {-# LANGUAGE OverloadedLabels #-} + +-- > {-# LANGUAGE OverloadedLabels #-} -- > {-# LANGUAGE OverloadedStrings #-} -- > --- > import Data.Function ((&)) --- > import Data.Functor ((<&>)) --- > import Network.Simple.TCP (connect) --- > --- > import qualified Capnp.New as C --- > import Capnp.Rpc --- > (ConnConfig(..), fromClient, handleConn, socketTransport) +-- > module Examples.Rpc.EchoClient (main) where -- > --- > import Capnp.Gen.Echo.New +-- > import qualified Capnp as C +-- > import Capnp.Gen.Echo +-- > import Capnp.Rpc +-- > ( ConnConfig (..), +-- > fromClient, +-- > requestBootstrap, +-- > socketTransport, +-- > withConn, +-- > ) +-- > import Data.Function ((&)) +-- > import Data.Functor ((<&>)) +-- > import Network.Simple.TCP (connect) -- > -- > main :: IO () -- > main = connect "localhost" "4000" $ \(sock, _addr) -> --- > handleConn (socketTransport sock C.defaultLimit) C.def --- > { debugMode = True --- > , withBootstrap = Just $ \_sup client -> --- > let echoClient :: C.Client Echo --- > echoClient = fromClient client --- > in --- > echoClient --- > & C.callP #echo C.def { query = "Hello, World!" } --- > <&> C.pipe #reply --- > >>= C.waitPipeline --- > >>= C.evalLimitT C.defaultLimit . C.parse --- > >>= print --- > } +-- > withConn +-- > (socketTransport sock C.defaultLimit) +-- > (C.def {debugMode = True}) +-- > $ \conn -> do +-- > client <- requestBootstrap conn +-- > let echoClient :: C.Client Echo +-- > echoClient = fromClient client +-- > echoClient +-- > & C.callP #echo C.def {query = "Hello, World!"} +-- > <&> C.pipe #reply +-- > >>= C.waitPipeline +-- > >>= C.evalLimitT C.defaultLimit . C.parse +-- > >>= print diff --git a/lib/Internal/Rpc/Breaker.hs b/lib/Internal/Rpc/Breaker.hs --- a/lib/Internal/Rpc/Breaker.hs +++ b/lib/Internal/Rpc/Breaker.hs @@ -7,6 +7,7 @@ ( Client (..), Pipeline (..), nullClient, + invalidClient, -- | ** Internals Opaque, makeOpaque, @@ -23,10 +24,12 @@ deriving (Eq) instance Show Client where - show client = + show client@(Client opaque) = if client == nullClient then "nullClient" - else "({- capability; not statically representable -})" + else case fromDynamic (reflectOpaque opaque) of + Just (InvalidClient errMsg) -> "(invalidClient" ++ show errMsg ++ ")" + Nothing -> "({- capability; not statically representable -})" -- | A 'Pipeline' is a reference to a value within a message that has not yet arrived. newtype Pipeline = Pipeline Opaque @@ -35,6 +38,14 @@ -- statically. Throws exceptions in response to all method calls. nullClient :: Client nullClient = Client $ makeOpaque () + +newtype InvalidClient = InvalidClient String + deriving (Show, Read, Eq, Typeable) + +-- | Returns a client which is "invalid;" it behaves like 'nullClient', +-- but can be given a custom error message that is displayed by 'show'. +invalidClient :: String -> Client +invalidClient = Client . makeOpaque . InvalidClient data Opaque = Opaque { opDyn :: Dynamic, diff --git a/lib/Internal/Rpc/Export.hs b/lib/Internal/Rpc/Export.hs new file mode 100644 --- /dev/null +++ b/lib/Internal/Rpc/Export.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +module Internal.Rpc.Export (export) where + +import Capnp.Rpc.Common (Client (..)) +import Capnp.Rpc.Server +import qualified Capnp.Rpc.Untyped as URpc +import Control.Monad.STM.Class (MonadSTM (liftSTM)) +import Data.Proxy (Proxy (..)) +import Supervisors (Supervisor) + +-- | Export the server as a client for interface @i@. Spawns a server thread +-- with its lifetime bound to the supervisor. +export :: forall i s m. (MonadSTM m, Export i, Server i s, SomeServer s) => Supervisor -> s -> m (Client i) +export sup srv = liftSTM $ Client <$> URpc.export sup (exportToServerOps (Proxy @i) srv) diff --git a/tests/CalculatorExample.hs b/tests/CalculatorExample.hs --- a/tests/CalculatorExample.hs +++ b/tests/CalculatorExample.hs @@ -4,8 +4,8 @@ module CalculatorExample (tests) where +import Capnp.Rpc (ConnConfig (..), handleConn, requestBootstrap, withConn) import Capnp.Rpc.Transport (socketTransport) -import Capnp.Rpc.Untyped (ConnConfig (..), handleConn) import Capnp.TraversalLimit (defaultLimit) import Control.Concurrent (threadDelay) import Control.Concurrent.Async (race_) @@ -83,16 +83,12 @@ runProxy :: Word16 -> Word16 -> IO () runProxy serverPort clientPort = connect "localhost" (fromString $ show serverPort) $ \(serverSock, _addr) -> - handleConn - (socketTransport serverSock defaultLimit) - def - { debugMode = True, - withBootstrap = Just $ \_sup client -> - serve "localhost" (fromString $ show clientPort) $ \(clientSock, _addr) -> - handleConn - (socketTransport clientSock defaultLimit) - def - { getBootstrap = \_sup -> pure $ Just client, - debugMode = True - } - } + withConn (socketTransport serverSock defaultLimit) def {debugMode = True} $ \conn -> do + client <- requestBootstrap conn + serve "localhost" (fromString $ show clientPort) $ \(clientSock, _addr) -> + handleConn + (socketTransport clientSock defaultLimit) + def + { bootstrap = Just client, + debugMode = True + } diff --git a/tests/Constants.hs b/tests/Constants.hs new file mode 100644 --- /dev/null +++ b/tests/Constants.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} + +module Constants (tests) where + +import Capnp +import Capnp.Gen.Aircraft hiding (Parsed) +import Data.Default +import Test.Hspec + +tests :: Spec +tests = do + describe "parsing defaults" $ do + defTest "structs" Zdate {year = 0, month = 0, day = 0} + defTest "struct lists" ([] :: [Parsed Zdate]) + -- defTest "enums" Airport'none + defTest "enum lists" ([] :: [Airport]) + describe "parsing constants" $ do + it "should parse enums correctly" $ + constEnum `shouldBe` Airport'jfk + constTest "structs" constDate Zdate {year = 2015, month = 8, day = 27} + constTest + "lists" + constList + [ Zdate {year = 2015, month = 8, day = 27}, + Zdate {year = 2015, month = 8, day = 28} + ] + +defTest :: (Default a, Eq a, Show a) => String -> a -> Spec +defTest name expected = + it ("should parse the default for " ++ name ++ " correctly") $ do + def `shouldBe` expected + +constTest :: (Parse a (Parsed a), Show (Parsed a), Eq (Parsed a)) => String -> Raw a 'Const -> Parsed a -> Spec +constTest name input expected = + it ("should parse " ++ name ++ " correctly") $ do + actual <- evalLimitT maxBound $ parse input + actual `shouldBe` expected diff --git a/tests/Instances.hs b/tests/Instances.hs --- a/tests/Instances.hs +++ b/tests/Instances.hs @@ -32,10 +32,10 @@ displayName <- arbitrary displayNamePrefixLength <- arbitrary scopeId <- arbitrary - parameters <- arbitrarySmallerVec + parameters <- arbitrarySmallerList isGeneric <- arbitrary - nestedNodes <- arbitrarySmallerVec - annotations <- arbitrarySmallerVec + nestedNodes <- arbitrarySmallerList + annotations <- arbitrarySmallerList union' <- arbitrary pure Node {..} @@ -44,7 +44,7 @@ arbitrary = do id <- arbitrary docComment <- arbitrary - members <- arbitrarySmallerVec + members <- arbitrarySmallerList pure Node'SourceInfo {..} instance Arbitrary (Parsed Node'SourceInfo'Member) where @@ -66,7 +66,7 @@ instance Arbitrary (Parsed Node'enum) where shrink = genericShrink - arbitrary = Node'enum' <$> arbitrarySmallerVec + arbitrary = Node'enum' <$> arbitrarySmallerList instance Arbitrary (Parsed Node'struct) where shrink = genericShrink @@ -77,12 +77,12 @@ isGroup <- arbitrary discriminantCount <- arbitrary discriminantOffset <- arbitrary - fields <- arbitrarySmallerVec + fields <- arbitrarySmallerList pure Node'struct' {..} instance Arbitrary (Parsed Node'interface) where shrink = genericShrink - arbitrary = Node'interface' <$> arbitrarySmallerVec <*> arbitrarySmallerVec + arbitrary = Node'interface' <$> arbitrarySmallerList <*> arbitrarySmallerList instance Arbitrary (Parsed Node'const) where shrink = genericShrink @@ -163,7 +163,7 @@ Enumerant <$> arbitrary <*> arbitrary - <*> arbitrarySmallerVec + <*> arbitrarySmallerList instance Arbitrary (Parsed Superclass) where shrink = genericShrink @@ -199,7 +199,7 @@ instance Arbitrary (Parsed Brand) where shrink = genericShrink - arbitrary = Brand <$> arbitrarySmallerVec + arbitrary = Brand <$> arbitrarySmallerList instance Arbitrary (Parsed Brand'Scope) where shrink = genericShrink @@ -212,7 +212,7 @@ shrink = genericShrink arbitrary = oneof - [ Brand'Scope'bind <$> arbitrarySmallerVec, + [ Brand'Scope'bind <$> arbitrarySmallerList, pure Brand'Scope'inherit, Brand'Scope'unknown' <$> arbitraryTag 2 ] @@ -370,9 +370,9 @@ shrink = genericShrink arbitrary = do capnpVersion <- arbitrary - nodes <- arbitrarySmallerVec - requestedFiles <- arbitrarySmallerVec - sourceInfo <- arbitrarySmallerVec + nodes <- arbitrarySmallerList + requestedFiles <- arbitrarySmallerList + sourceInfo <- arbitrarySmallerList pure CodeGeneratorRequest {..} instance Arbitrary (Parsed CodeGeneratorRequest'RequestedFile) where @@ -390,33 +390,33 @@ <$> arbitrary <*> arbitrary -arbitrarySmallerVec :: Arbitrary a => Gen (V.Vector a) -arbitrarySmallerVec = sized $ \size -> do +arbitrarySmallerList :: Arbitrary a => Gen [a] +arbitrarySmallerList = sized $ \size -> do -- Make sure the elements are scaled down relative to - -- the size of the vector: - vec <- arbitrary :: Gen (V.Vector ()) - let gen = resize (size `div` V.length vec) arbitrary + -- the size of the list: + vec <- arbitrary :: Gen [()] + let gen = resize (size `div` length vec) arbitrary traverse (const gen) vec instance Arbitrary (Parsed B.AnyStruct) where shrink = genericShrink arbitrary = sized $ \_ -> B.Struct - <$> arbitrarySmallerVec - <*> arbitrarySmallerVec + <$> (V.fromList <$> arbitrarySmallerList) + <*> (V.fromList <$> arbitrarySmallerList) instance Arbitrary (Parsed B.AnyList) where shrink = genericShrink arbitrary = oneof - [ B.List0 <$> arbitrarySmallerVec, - B.List1 <$> arbitrarySmallerVec, - B.List8 <$> arbitrarySmallerVec, - B.List16 <$> arbitrarySmallerVec, - B.List32 <$> arbitrarySmallerVec, - B.List64 <$> arbitrarySmallerVec, - B.ListPtr <$> arbitrarySmallerVec, - B.ListStruct <$> arbitrarySmallerVec + [ B.List0 <$> arbitrarySmallerList, + B.List1 <$> arbitrarySmallerList, + B.List8 <$> arbitrarySmallerList, + B.List16 <$> arbitrarySmallerList, + B.List32 <$> arbitrarySmallerList, + B.List64 <$> arbitrarySmallerList, + B.ListPtr <$> arbitrarySmallerList, + B.ListStruct <$> arbitrarySmallerList ] instance Arbitrary (Parsed B.AnyPointer) where diff --git a/tests/Main.hs b/tests/Main.hs --- a/tests/Main.hs +++ b/tests/Main.hs @@ -1,6 +1,7 @@ module Main (main) where import qualified CalculatorExample +import qualified Constants import Module.Capnp.Basics (basicsTests) import Module.Capnp.Bits (bitsTests) import Module.Capnp.Canonicalize (canonicalizeTests) @@ -18,7 +19,7 @@ import WalkSchemaCodeGenRequest (walkSchemaCodeGenRequestTest) main :: IO () -main = hspec $ parallel $ do +main = hspec $ do describe "Tests for specific modules" $ do describe "Capnp.Basics" basicsTests describe "Capnp.Bits" bitsTests @@ -36,4 +37,5 @@ describe "Regression tests" regressionTests CalculatorExample.tests PointerOOB.tests + Constants.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 @@ -478,15 +478,10 @@ in concurrently_ ( do Left (e :: RpcError) <- - try $ - handleConn - (vatTrans defaultLimit) - def - { debugMode = True, - withBootstrap = Just $ \_sup client -> - let ctr :: Client CallSequence = fromClient client - in void $ (ctr & callR #getNumber def) >>= waitPipeline - } + try $ withConn (vatTrans defaultLimit) def {debugMode = True} $ \conn -> do + client <- requestBootstrap conn + let ctr :: Client CallSequence = fromClient client + void $ (ctr & callR #getNumber def) >>= waitPipeline e `shouldBe` SentAbort wantExn ) ( do @@ -577,19 +572,18 @@ runVatPair :: IsClient c => (Supervisor -> STM c) -> (Supervisor -> c -> IO ()) -> IO () runVatPair getBootstrap withBootstrap = withTransportPair $ \(clientTrans, serverTrans) -> do let runClient = - handleConn - (clientTrans defaultLimit) - def - { debugMode = True, - withBootstrap = Just $ \sup -> withBootstrap sup . fromClient - } + withConn (clientTrans defaultLimit) def {debugMode = True} $ \conn -> do + boot <- requestBootstrap conn + withSupervisor $ \sup -> withBootstrap sup (fromClient boot) runServer = - handleConn - (serverTrans defaultLimit) - def - { debugMode = True, - getBootstrap = fmap (Just . toClient) . getBootstrap - } + withSupervisor $ \sup -> do + boot <- atomically (getBootstrap sup) + handleConn + (serverTrans defaultLimit) + def + { debugMode = True, + bootstrap = Just (toClient boot) + } race_ runServer runClient expectException :: diff --git a/tests/Module/Capnp/Untyped.hs b/tests/Module/Capnp/Untyped.hs --- a/tests/Module/Capnp/Untyped.hs +++ b/tests/Module/Capnp/Untyped.hs @@ -334,7 +334,7 @@ otherMessageTest :: Spec otherMessageTest = describe "Setting pointers in other messages" $ it "Should copy them if needed." $ - property $ \(name :: Text) (params :: V.Vector (Parsed Node'Parameter)) (brand :: Parsed Brand) -> + property $ \(name :: Text) (params :: [Parsed Node'Parameter]) (brand :: Parsed Brand) -> propertyIO $ do let expected = def diff --git a/tests/Module/Capnp/Untyped/Pure.hs b/tests/Module/Capnp/Untyped/Pure.hs --- a/tests/Module/Capnp/Untyped/Pure.hs +++ b/tests/Module/Capnp/Untyped/Pure.hs @@ -10,7 +10,6 @@ import Capnp (msgToRaw, parse) import Capnp.Basics import Capnp.TraversalLimit (runLimitT) -import qualified Data.Vector as V import GHC.Float (castDoubleToWord64) import Test.Hspec import Text.Heredoc (here) @@ -50,7 +49,7 @@ 5173, castDoubleToWord64 12.0 ] - [ Just $ PtrList $ List8 $ V.fromList $ map (fromIntegral . fromEnum) "bob\0", + [ Just $ PtrList $ List8 $ map (fromIntegral . fromEnum) "bob\0", Just $ PtrList $ List16 [] ] ]