├── .gitattributes ├── .gitignore ├── .hlint.yaml ├── .stylish-haskell.yaml ├── CHANGELOG.md ├── CONTRIBUTING.md ├── CONTRIBUTORS ├── LICENSE.md ├── README.md ├── Setup.hs ├── bench └── Main.hs ├── cabal.project ├── capnp-examples ├── ChangeLog.md ├── LICENSE ├── README.md ├── Setup.hs ├── addressbook.capnp ├── calculator.capnp ├── capnp-examples.cabal ├── cmd │ └── Main.hs ├── echo.capnp ├── gen │ └── lib │ │ └── .gitignore └── lib │ └── Examples │ ├── Rpc │ ├── CalculatorClient.hs │ ├── CalculatorServer.hs │ ├── EchoClient.hs │ └── EchoServer.hs │ └── Serialization │ ├── HighLevel │ ├── Read.hs │ └── Write.hs │ └── LowLevel │ ├── Read.hs │ └── Write.hs ├── capnp-tests ├── capnp-tests.cabal ├── gen │ └── tests │ │ └── .gitignore └── tests │ ├── CalculatorExample.hs │ ├── Constants.hs │ ├── Instances.hs │ ├── Main.hs │ ├── Module │ └── Capnp │ │ ├── Basics.hs │ │ ├── Bits.hs │ │ ├── Canonicalize.hs │ │ ├── Gen │ │ └── Capnp │ │ │ ├── Schema.hs │ │ │ └── Schema │ │ │ └── Pure.hs │ │ ├── Pointer.hs │ │ ├── Rpc.hs │ │ ├── Untyped.hs │ │ └── Untyped │ │ └── Pure.hs │ ├── PointerOOB.hs │ ├── Regression.hs │ ├── Rpc │ └── Unwrap.hs │ ├── SchemaGeneration.hs │ ├── SchemaQuickCheck.hs │ ├── Util.hs │ ├── WalkSchemaCodeGenRequest.hs │ └── data │ ├── README.md │ ├── aircraft.capnp │ ├── generics.capnp │ ├── schema-codegenreq │ └── schema.capnp ├── capnp ├── capnp.cabal ├── cmd │ └── capnpc-haskell │ │ ├── Check.hs │ │ ├── IR │ │ ├── AbstractOp.hs │ │ ├── Common.hs │ │ ├── Flat.hs │ │ ├── Haskell.hs │ │ ├── Name.hs │ │ ├── Pure.hs │ │ ├── Raw.hs │ │ └── Stage1.hs │ │ ├── Main.hs │ │ ├── README.md │ │ └── Trans │ │ ├── AbstractOpToHaskell.hs │ │ ├── CgrToStage1.hs │ │ ├── FlatToAbstractOp.hs │ │ ├── FlatToPure.hs │ │ ├── FlatToRaw.hs │ │ ├── HaskellToText.hs │ │ ├── PureToHaskell.hs │ │ ├── RawToHaskell.hs │ │ ├── Stage1ToFlat.hs │ │ └── ToHaskellCommon.hs ├── gen │ ├── lib │ │ └── Capnp │ │ │ └── Gen │ │ │ ├── ById │ │ │ ├── X86c366a91393f3f8.hs │ │ │ ├── X8ef99297a43a5e34.hs │ │ │ ├── Xa184c7885cdaf2a1.hs │ │ │ ├── Xa93fc509624c72d9.hs │ │ │ ├── Xb312981b2552a250.hs │ │ │ ├── Xb8630836983feed7.hs │ │ │ └── Xbdf87d7bb8304e81.hs │ │ │ └── Capnp │ │ │ ├── Compat │ │ │ └── Json.hs │ │ │ ├── Cxx.hs │ │ │ ├── Persistent.hs │ │ │ ├── Rpc.hs │ │ │ ├── RpcTwoparty.hs │ │ │ ├── Schema.hs │ │ │ └── Stream.hs │ └── tests │ │ └── .gitignore └── lib │ ├── Capnp.hs │ ├── Capnp │ ├── Accessors.hs │ ├── Address.hs │ ├── Basics.hs │ ├── Bits.hs │ ├── Canonicalize.hs │ ├── Classes.hs │ ├── Constraints.hs │ ├── Convert.hs │ ├── Errors.hs │ ├── Fields.hs │ ├── Gen.hs │ ├── Gen │ │ └── Capnp.hs │ ├── GenHelpers.hs │ ├── GenHelpers │ │ └── Rpc.hs │ ├── IO.hs │ ├── Message.hs │ ├── Mutability.hs │ ├── Pointer.hs │ ├── Repr.hs │ ├── Repr │ │ ├── Methods.hs │ │ └── Parsed.hs │ ├── Rpc.hs │ ├── Rpc │ │ ├── Common.hs │ │ ├── Errors.hs │ │ ├── Membrane.hs │ │ ├── Promise.hs │ │ ├── Revoke.hs │ │ ├── Server.hs │ │ ├── Transport.hs │ │ └── Untyped.hs │ ├── TraversalLimit.hs │ ├── Tutorial.hs │ └── Untyped.hs │ ├── Data │ └── Mutable.hs │ └── Internal │ ├── AppendVec.hs │ ├── BuildPure.hs │ ├── Rc.hs │ ├── Rpc │ ├── Breaker.hs │ └── Export.hs │ ├── STE.hs │ ├── SnocList.hs │ └── TCloseQ.hs ├── ci ├── Dockerfile └── README.md ├── core-schema ├── README.md └── capnp │ ├── c++.capnp │ ├── compat │ └── json.capnp │ ├── persistent.capnp │ ├── rpc-twoparty.capnp │ ├── rpc.capnp │ ├── schema.capnp │ └── stream.capnp └── scripts ├── README.md ├── format.sh ├── hlint.sh └── regen.sh /.gitattributes: -------------------------------------------------------------------------------- 1 | # Mark generated output as such for GitHub diffs: 2 | /gen/ linguist-generated=true 3 | /examples/gen/ linguist-generated=true 4 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | dist-newstyle 3 | *.swp 4 | .cabal-sandbox 5 | cabal.sandbox.config 6 | cabal.project.local 7 | cabal.project.local~ 8 | 9 | # Profiler outputs (and formatted reports): 10 | *.prof 11 | *.hp 12 | *.aux 13 | *.ps 14 | 15 | .ghc.* 16 | result* 17 | 18 | .hspec 19 | .hspec-failures 20 | 21 | # Code coverage: 22 | .hpc 23 | *.tix 24 | 25 | # Generated code for examples & test suite. Note that we do *not* 26 | # ignore generated code for the main library, as there are cyclic 27 | # dependencies between it and the rest of the library. 28 | /examples/Capnp 29 | /tests/Capnp 30 | 31 | # I sometimes leave notes for myself in my working directory: 32 | /NOTES 33 | 34 | # Benchmark outputs: 35 | *.html 36 | -------------------------------------------------------------------------------- /.hlint.yaml: -------------------------------------------------------------------------------- 1 | - ignore: {name: Use list comprehension} 2 | - ignore: {name: Use <=<} 3 | - ignore: {name: Redundant <&>} 4 | # Temporarily disabled due to https://github.com/ndmitchell/hlint/issues/1276; 5 | # turn this back on when that issue is fixed: 6 | - ignore: {name: Unused LANGUAGE pragma} 7 | -------------------------------------------------------------------------------- /.stylish-haskell.yaml: -------------------------------------------------------------------------------- 1 | steps: 2 | - simple_align: 3 | cases: true 4 | top_level_patterns: true 5 | records: true 6 | - imports: 7 | align: group 8 | list_align: after_alias 9 | pad_module_names: true 10 | long_list_align: new_line_multiline 11 | empty_list_align: right_after 12 | list_padding: 4 13 | separate_lists: false 14 | space_surround: false 15 | - language_pragmas: 16 | style: vertical 17 | align: true 18 | remove_redundant: true 19 | spaces: 4 20 | - trailing_whitespace: {} 21 | columns: 80 22 | newline: lf 23 | language_extensions: 24 | # stylish-haskell's parser (really haskell-src-exts) and GHC disagree about 25 | # when some of the following are needed, so some of our modules will build 26 | # without these extensions, but stylish-haskell needs them for parsing: 27 | - ExplicitForAll 28 | - FlexibleContexts 29 | - MultiParamTypeClasses 30 | -------------------------------------------------------------------------------- /CONTRIBUTING.md: -------------------------------------------------------------------------------- 1 | Firstly, thanks! 2 | 3 | The easiest way to contribute is just feedback: use the library, let me 4 | know how the experience was. Tell me how you're using the library. Open 5 | issues if you find them. 6 | 7 | If you're looking to hack on the library, great! If you don't have 8 | something specific in mind and you're looking for a task to get your 9 | feet wet, there are a number of open issues labeled 10 | ["good first issue"](https://github.com/zenhack/haskell-capnp/issues?q=is%3Aopen+is%3Aissue+label%3A%22good+first+issue%22); 11 | these are self-contained, well-defined tasks that touch a relatively 12 | small portion of the code, and so don't require deep understanding of 13 | the structure of the library as a whole; as such they're great for new 14 | contributors. If you want to work on an existing issue, leave a comment 15 | on the issue saying you're planning on tacking a whack at it. I'll 16 | probably reply before too long. Send a pull request when you've got 17 | something to review. 18 | 19 | # Comments 20 | 21 | A couple guidelines re comments: 22 | 23 | * For implementation notes inside the code, we adopt GHC's [Note 24 | convention][2]. 25 | * Each thing that is exported from a module must have a haddock comment 26 | briefly describing what it does and how to use it. Most non-exported 27 | top level identifiers should have these as well, but this is more 28 | flexible. 29 | * Prefer end-of-line (`--`) comments over block comments; very large 30 | block comments can confuse syntax highlighting in some editors. 31 | 32 | # Style Guide 33 | 34 | Generally, do what the rest of the code does. Much of this section is 35 | bikeshed, but consistency is worth a bit of that. 36 | 37 | ## Formatting/Layout 38 | 39 | * [stylish-haskell][1] takes care of most formatting issues. If it wants 40 | to change your code, let it; this solves a lot of consistency issues 41 | without us needing to remember anything, and it gets run as part of 42 | our CI, so failing to use it will likely cause failures. Running 43 | `./format.sh` will apply it to the entire source tree, using this 44 | project's rules, but we recommend you configure your editor to use it 45 | automatically. 46 | * Use a tabstop of 4 spaces in Haskell source code, 2 spaces in the 47 | cabal file. 48 | 49 | Where stylish-haskell doesn't contradict you, use more regular 50 | indentation. Bad: 51 | 52 | ```haskell 53 | data MyVariant = Apples Int 54 | | Oranges Bool 55 | ``` 56 | 57 | Good: 58 | 59 | ```haskell 60 | data MyVariant 61 | = Apples Int 62 | | Oranges Bool 63 | ``` 64 | 65 | Bad: 66 | 67 | ```haskell 68 | myAction val = do print val 69 | c <- getChar 70 | putChar (toUpper c) 71 | ``` 72 | 73 | Good: 74 | 75 | ```haskell 76 | myAction Val = do 77 | print val 78 | c <- getChar 79 | putChar (toUpper c) 80 | ``` 81 | 82 | This goes for cabal files as well. Bad: 83 | 84 | ```haskell 85 | build-depends: base >= 4.8 && < 5.0 86 | , text >= 1.2 && < 2.0 87 | , bytestring >= 0.10 && < 0.11 88 | , array >= 0.5 && < 0.6 89 | ... 90 | ``` 91 | 92 | Good: 93 | 94 | ```haskell 95 | build-depends: 96 | base >= 4.8 && < 5.0 97 | , text >= 1.2 && < 2.0 98 | , bytestring >= 0.10 && < 0.11 99 | , array >= 0.5 && < 0.6 100 | ... 101 | ``` 102 | 103 | The same rule applies for other constructs. 104 | 105 | ## Imports 106 | 107 | Some guidelines re: imports: 108 | 109 | * Favor qualified imports or importing specific items. Unqualified 110 | imports are acceptable in a few cases, where you're using a ton of 111 | stuff from a single module, but try to avoid them, especially with 112 | libraries whose API is not very very stable. 113 | * Wildcard imports of all of a type's data constructors/type class's 114 | methods (`MonadThrow(..)`) are more acceptable, though still prefer 115 | specifying specific ones if you're only using a couple. 116 | * Separate imports of modules within our own codebase from ones from 117 | outside of it. 118 | * Within each of those groups, group imports into four distinct 119 | sections, separated by a single blank line (some of these may be 120 | absent): 121 | 122 | ```haskell 123 | -- "negative" imports: 124 | import Prelude hiding (length) 125 | 126 | -- unqualified imports; try to avoid these, but sometimes if you've got 127 | -- a module that's doing nothing but bitwhacking, it can make sense: 128 | import Data.Bits 129 | import Data.Word 130 | 131 | -- imports of specific values 132 | import Control.Monad(when, void) 133 | import Control.Monad.Catch(throwM) 134 | 135 | -- qualified module imports: 136 | import qualified Data.ByteString as BS 137 | 138 | -- same structure for modules within our library: 139 | 140 | import Capnp.Untyped hiding (length) 141 | 142 | import Capnp.Bits 143 | 144 | import Capnp.TraversalLimit(defaultLimit, evalLimitT) 145 | 146 | import qualified Capnp.Message as M 147 | import qualified Capnp.Basics as B 148 | ``` 149 | 150 | The formatter will take care of formatting the sections correctly, as 151 | long as you keep the line-breaks right. 152 | 153 | [1]: https://github.com/jaspervdj/stylish-haskell 154 | [2]: https://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Commentsinthesourcecode 155 | -------------------------------------------------------------------------------- /CONTRIBUTORS: -------------------------------------------------------------------------------- 1 | # This file lists the people who have contributed to the haskell-capnp 2 | # repository. Please keep this list sorted. 3 | Andrew D'Angelo 4 | Ian Denhardt 5 | Patrick Chilton 6 | Remy Goldschmidt 7 | -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | Copyright (c) 2016 Ian Denhardt 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining 4 | a copy of this software and associated documentation files (the 5 | "Software"), to deal in the Software without restriction, including 6 | without limitation the rights to use, copy, modify, merge, publish, 7 | distribute, sublicense, and/or sell copies of the Software, and to 8 | permit persons to whom the Software is furnished to do so, subject to 9 | the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be included 12 | in all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 17 | IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY 18 | CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, 19 | TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE 20 | SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | [![hackage][hackage-img]][hackage] 2 | 3 | A Haskell library for the [Cap'N Proto][1] Cerialization and RPC 4 | protocol. 5 | 6 | Note, this project's official home is [on 7 | codeberg](https://codeberg.org/zenhack/haskell-capnp); if you're viewing 8 | this elsewhere, this is a mirror. For trivial changes we'll still accept 9 | patches here, but please file issues and submit more substantial changes 10 | via codeberg. 11 | 12 | # Getting Started 13 | 14 | There is a module `Capnp.Tutorial` which contains an introduction 15 | to the library; users are *strongly* encouraged to read this first, as 16 | the reference documentation can be bewildering without that context. 17 | 18 | # Status 19 | 20 | Serialization support works, with some limitations: 21 | 22 | * We do not support defining custom default values for fields of pointer 23 | type; see ([#28][issue28]). 24 | * We currently do not correctly handle decoding lists of structs from 25 | non-composite lists ([#27][issue27]). This means that, contrary to the 26 | [protocol evolution rules][2], it is not safe to change a field from 27 | type List(T) (where T is any non-struct type) to a list of a struct 28 | type. 29 | 30 | Level 1 RPC support is implemented and usable, though it should be 31 | considered alpha quality for now. Specific things to be aware of: 32 | 33 | * The implementation is *not* robust against resource exhaustion 34 | attacks; for now users are strongly discouraged from using it to do 35 | RPC with untrusted peers. 36 | 37 | The API is considered unstable. It will likely see changes, for the 38 | sake of polish, consistency, etc. as well as to improve performance and 39 | accommodate more features as we add them. 40 | 41 | [1]: https://capnproto.org/ 42 | [2]: https://capnproto.org/language.html#evolving-your-protocol 43 | 44 | [issue27]: https://codeberg.org/zenhack/haskell-capnp/issues/27 45 | [issue28]: https://codeberg.org/zenhack/haskell-capnp/issues/28 46 | 47 | [hackage-img]: https://img.shields.io/hackage/v/capnp.svg 48 | [hackage]: https://hackage.haskell.org/package/capnp 49 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /bench/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE QuasiQuotes #-} 3 | {-# LANGUAGE TypeApplications #-} 4 | 5 | module Main (main) where 6 | 7 | import qualified Capnp as C 8 | import Capnp.Mutability (thaw) 9 | import qualified Capnp.Untyped as U 10 | import Control.DeepSeq (NFData (..)) 11 | import Control.Monad (unless) 12 | import Criterion.Main 13 | import qualified Data.ByteString as BS 14 | import System.Exit (ExitCode (..)) 15 | import qualified System.Process.ByteString as PB 16 | 17 | -- Get the raw bytes of a CodeGeneratorRequest for all of the bundled 18 | -- capnproto core schema. Useful as a source of generic test data. 19 | getCGRBytes :: IO BS.ByteString 20 | getCGRBytes = do 21 | (exit, cgrBytes, _) <- 22 | PB.readProcessWithExitCode 23 | "capnp" 24 | [ "compile", 25 | "-o-", 26 | "-I", 27 | "core-schema/", 28 | "--src-prefix=core-schema/", 29 | "core-schema/capnp/schema.capnp", 30 | "core-schema/capnp/stream.capnp", 31 | "core-schema/capnp/rpc-twoparty.capnp", 32 | "core-schema/capnp/persistent.capnp", 33 | "core-schema/capnp/rpc.capnp", 34 | "core-schema/capnp/compat/json.capnp", 35 | "core-schema/capnp/c++.capnp" 36 | ] 37 | "" 38 | unless (exit == ExitSuccess) $ error "capnp compile failed" 39 | pure cgrBytes 40 | 41 | instance NFData (C.Message mut) where 42 | rnf = (`seq` ()) 43 | 44 | main :: IO () 45 | main = do 46 | cgrBytes <- getCGRBytes 47 | msg <- C.bsToMsg cgrBytes 48 | let whnfLTIO = whnfIO . C.evalLimitT maxBound 49 | defaultMain 50 | [ bench "canonicalize/IO" $ whnfLTIO $ do 51 | root <- U.rootPtr msg 52 | C.canonicalize root, 53 | bench "canonicalize/PureBuilder" $ whnfLTIO $ do 54 | C.createPure maxBound $ do 55 | root <- U.rootPtr msg 56 | (msg, _seg) <- C.canonicalize root 57 | pure msg, 58 | env 59 | ( C.evalLimitT maxBound $ do 60 | mutMsg <- thaw msg 61 | newMsg <- C.newMessage Nothing 62 | pure (mutMsg, newMsg) 63 | ) 64 | ( \ ~(mutMsg, newMsg) -> bench "copy" $ whnfLTIO $ do 65 | root <- U.rootPtr mutMsg 66 | U.copyPtr newMsg (Just (U.PtrStruct root)) 67 | ) 68 | ] 69 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | packages: */*.cabal 2 | -------------------------------------------------------------------------------- /capnp-examples/ChangeLog.md: -------------------------------------------------------------------------------- 1 | # Revision history for capnp-examples 2 | 3 | ## 0.1.0.0 -- YYYY-mm-dd 4 | 5 | * First version. Released on an unsuspecting world. 6 | -------------------------------------------------------------------------------- /capnp-examples/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2018 Ian Denhardt 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining 4 | a copy of this software and associated documentation files (the 5 | "Software"), to deal in the Software without restriction, including 6 | without limitation the rights to use, copy, modify, merge, publish, 7 | distribute, sublicense, and/or sell copies of the Software, and to 8 | permit persons to whom the Software is furnished to do so, subject to 9 | the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be included 12 | in all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 17 | IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY 18 | CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, 19 | TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE 20 | SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /capnp-examples/README.md: -------------------------------------------------------------------------------- 1 | This directory contains examples programs using the capnp library. 2 | 3 | The structure of this directory tries to strike a balance between 4 | serving as good documentation and also being usable as part of our test 5 | suite. To serve the latter use case, the example programs are packaged 6 | as a library; each is actually a module under `lib/`. `cmd/Main.hs` can 7 | be used to actually run the examples. 8 | 9 | Note that generated modules for the schema in this directory are not 10 | checked in to revision control; you will first need to generate them by 11 | running `../scripts/regen.sh`. 12 | -------------------------------------------------------------------------------- /capnp-examples/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | 3 | main = defaultMain 4 | -------------------------------------------------------------------------------- /capnp-examples/addressbook.capnp: -------------------------------------------------------------------------------- 1 | # addressbook.capnp 2 | @0xcd6db6afb4a0cf5c; 3 | 4 | struct Person { 5 | id @0 :UInt32; 6 | name @1 :Text; 7 | email @2 :Text; 8 | phones @3 :List(PhoneNumber); 9 | 10 | struct PhoneNumber { 11 | number @0 :Text; 12 | type @1 :Type; 13 | 14 | enum Type { 15 | mobile @0; 16 | home @1; 17 | work @2; 18 | } 19 | } 20 | 21 | employment :union { 22 | unemployed @4 :Void; 23 | employer @5 :Text; 24 | school @6 :Text; 25 | selfEmployed @7 :Void; 26 | # We assume that a person is only one of these. 27 | } 28 | } 29 | 30 | struct AddressBook { 31 | people @0 :List(Person); 32 | } 33 | -------------------------------------------------------------------------------- /capnp-examples/calculator.capnp: -------------------------------------------------------------------------------- 1 | # Copyright (c) 2013-2014 Sandstorm Development Group, Inc. and contributors 2 | # Licensed under the MIT License: 3 | # 4 | # Permission is hereby granted, free of charge, to any person obtaining a copy 5 | # of this software and associated documentation files (the "Software"), to deal 6 | # in the Software without restriction, including without limitation the rights 7 | # to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 8 | # copies of the Software, and to permit persons to whom the Software is 9 | # furnished to do so, subject to the following conditions: 10 | # 11 | # The above copyright notice and this permission notice shall be included in 12 | # all copies or substantial portions of the Software. 13 | # 14 | # THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 15 | # IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 16 | # FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 17 | # AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 18 | # LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 19 | # OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 20 | # THE SOFTWARE. 21 | 22 | @0x85150b117366d14b; 23 | 24 | interface Calculator { 25 | # A "simple" mathematical calculator, callable via RPC. 26 | # 27 | # But, to show off Cap'n Proto, we add some twists: 28 | # 29 | # - You can use the result from one call as the input to the next 30 | # without a network round trip. To accomplish this, evaluate() 31 | # returns a `Value` object wrapping the actual numeric value. 32 | # This object may be used in a subsequent expression. With 33 | # promise pipelining, the Value can actually be used before 34 | # the evaluate() call that creates it returns! 35 | # 36 | # - You can define new functions, and then call them. This again 37 | # shows off pipelining, but it also gives the client the 38 | # opportunity to define a function on the client side and have 39 | # the server call back to it. 40 | # 41 | # - The basic arithmetic operators are exposed as Functions, and 42 | # you have to call getOperator() to obtain them from the server. 43 | # This again demonstrates pipelining -- using getOperator() to 44 | # get each operator and then using them in evaluate() still 45 | # only takes one network round trip. 46 | 47 | evaluate @0 (expression :Expression) -> (value :Value); 48 | # Evaluate the given expression and return the result. The 49 | # result is returned wrapped in a Value interface so that you 50 | # may pass it back to the server in a pipelined request. To 51 | # actually get the numeric value, you must call read() on the 52 | # Value -- but again, this can be pipelined so that it incurs 53 | # no additional latency. 54 | 55 | 56 | defFunction @1 (paramCount :Int32, body :Expression) 57 | -> (func :Function); 58 | # Define a function that takes `paramCount` parameters and returns the 59 | # evaluation of `body` after substituting these parameters. 60 | 61 | getOperator @2 (op :Operator) -> (func :Function); 62 | # Get a Function representing an arithmetic operator, which can then be 63 | # used in Expressions. 64 | } 65 | 66 | struct Expression @0xd438d7caf5548d15 { 67 | # A numeric expression. 68 | 69 | union { 70 | literal @0 :Float64; 71 | # A literal numeric value. 72 | 73 | previousResult @1 :Value; 74 | # A value that was (or, will be) returned by a previous 75 | # evaluate(). 76 | 77 | parameter @2 :UInt32; 78 | # A parameter to the function (only valid in function bodies; 79 | # see defFunction). 80 | 81 | call :group { 82 | # Call a function on a list of parameters. 83 | function @3 :Function; 84 | params @4 :List(Expression); 85 | } 86 | } 87 | } 88 | 89 | interface Value @0xc3e69d34d3ee48d2 { 90 | # Wraps a numeric value in an RPC object. This allows the value 91 | # to be used in subsequent evaluate() requests without the client 92 | # waiting for the evaluate() that returns the Value to finish. 93 | 94 | read @0 () -> (value :Float64); 95 | # Read back the raw numeric value. 96 | } 97 | 98 | interface Function @0xede83a3d96840394 { 99 | # An algebraic function. Can be called directly, or can be used inside 100 | # an Expression. 101 | # 102 | # A client can create a Function that runs on the server side using 103 | # `defFunction()` or `getOperator()`. Alternatively, a client can 104 | # implement a Function on the client side and the server will call back 105 | # to it. However, a function defined on the client side will require a 106 | # network round trip whenever the server needs to call it, whereas 107 | # functions defined on the server and then passed back to it are called 108 | # locally. 109 | 110 | call @0 (params :List(Float64)) -> (value :Float64); 111 | # Call the function on the given parameters. 112 | } 113 | 114 | enum Operator @0x8793407861e6dfe6 { 115 | add @0; 116 | subtract @1; 117 | multiply @2; 118 | divide @3; 119 | } 120 | -------------------------------------------------------------------------------- /capnp-examples/capnp-examples.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.2 2 | name: capnp-examples 3 | version: 0.1.0.0 4 | synopsis: Examples for haskell-capnp 5 | -- description: 6 | homepage: https://github.com/zenhack/haskell-capnp 7 | license: MIT 8 | license-file: LICENSE 9 | author: Ian Denhardt 10 | maintainer: ian@zenhack.net 11 | -- copyright: 12 | -- category: 13 | build-type: Simple 14 | extra-source-files: ChangeLog.md 15 | 16 | library 17 | build-depends: 18 | base >=4.11 && <5.0 19 | , capnp 20 | , stm ^>= 2.5.0 21 | , bytestring >=0.10 && <0.12 22 | , data-default ^>=0.7 23 | , exceptions ^>=0.10 24 | , vector >=0.12 && <0.14 25 | , mtl >=2.2.2 && <2.4 26 | , network ^>= 3.1 27 | , network-simple ^>= 0.4 28 | , supervisors ^>= 0.2 29 | , text >= 1.2.3 && <2.1 30 | hs-source-dirs: 31 | lib 32 | gen/lib 33 | exposed-modules: 34 | Examples.Rpc.EchoClient 35 | , Examples.Rpc.EchoServer 36 | , Examples.Rpc.CalculatorClient 37 | , Examples.Rpc.CalculatorServer 38 | , Examples.Serialization.HighLevel.Read 39 | , Examples.Serialization.HighLevel.Write 40 | , Examples.Serialization.LowLevel.Read 41 | , Examples.Serialization.LowLevel.Write 42 | 43 | -- Generated code 44 | , Capnp.Gen.Addressbook 45 | , Capnp.Gen.ById.X85150b117366d14b 46 | , Capnp.Gen.ById.Xcd6db6afb4a0cf5c 47 | , Capnp.Gen.ById.Xd0a87f36fa0182f5 48 | , Capnp.Gen.Calculator 49 | , Capnp.Gen.Echo 50 | ghc-options: 51 | -Wall 52 | -Wno-name-shadowing 53 | default-language: Haskell2010 54 | 55 | executable run-capnp-example 56 | build-depends: 57 | base 58 | , capnp-examples 59 | hs-source-dirs: 60 | cmd 61 | main-is: 62 | Main.hs 63 | ghc-options: 64 | -Wall 65 | default-language: Haskell2010 66 | -------------------------------------------------------------------------------- /capnp-examples/cmd/Main.hs: -------------------------------------------------------------------------------- 1 | module Main (main) where 2 | 3 | import Data.List (intercalate) 4 | import qualified Examples.Rpc.CalculatorClient 5 | import qualified Examples.Rpc.CalculatorServer 6 | import qualified Examples.Rpc.EchoClient 7 | import qualified Examples.Rpc.EchoServer 8 | import qualified Examples.Serialization.HighLevel.Read 9 | import qualified Examples.Serialization.HighLevel.Write 10 | import qualified Examples.Serialization.LowLevel.Read 11 | import qualified Examples.Serialization.LowLevel.Write 12 | import System.Environment (getArgs) 13 | import System.Exit (exitFailure) 14 | import System.IO (hPutStrLn, stderr) 15 | 16 | main :: IO () 17 | main = do 18 | args <- getArgs 19 | case args of 20 | ["calculator-client"] -> Examples.Rpc.CalculatorClient.main 21 | ["calculator-server"] -> Examples.Rpc.CalculatorServer.main 22 | ["echo-client"] -> Examples.Rpc.EchoClient.main 23 | ["echo-server"] -> Examples.Rpc.EchoServer.main 24 | ["highlevel-read"] -> Examples.Serialization.HighLevel.Read.main 25 | ["highlevel-write"] -> Examples.Serialization.HighLevel.Write.main 26 | ["lowlevel-read"] -> Examples.Serialization.LowLevel.Read.main 27 | ["lowlevel-write"] -> Examples.Serialization.LowLevel.Write.main 28 | _ -> usageErr 29 | 30 | usageErr :: IO () 31 | usageErr = do 32 | hPutStrLn 33 | stderr 34 | ( "Usage: run-capnp-example ( " 35 | ++ intercalate 36 | " | " 37 | [ "calculator-client", 38 | "calculator-server", 39 | "echo-client", 40 | "echo-server", 41 | "highlevel-read", 42 | "highlevel-write", 43 | "lowlevel-read", 44 | "lowlevel-write" 45 | ] 46 | ++ " )" 47 | ) 48 | exitFailure 49 | -------------------------------------------------------------------------------- /capnp-examples/echo.capnp: -------------------------------------------------------------------------------- 1 | @0xd0a87f36fa0182f5; 2 | 3 | interface Echo { 4 | echo @0 (query :Text) -> (reply :Text); 5 | } 6 | -------------------------------------------------------------------------------- /capnp-examples/gen/lib/.gitignore: -------------------------------------------------------------------------------- 1 | *.hs 2 | -------------------------------------------------------------------------------- /capnp-examples/lib/Examples/Rpc/CalculatorClient.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DuplicateRecordFields #-} 2 | {-# LANGUAGE NamedFieldPuns #-} 3 | {-# LANGUAGE OverloadedLabels #-} 4 | 5 | module Examples.Rpc.CalculatorClient (main) where 6 | 7 | import qualified Capnp as C 8 | import Capnp.Gen.Calculator 9 | import Capnp.Rpc 10 | ( ConnConfig (..), 11 | fromClient, 12 | requestBootstrap, 13 | socketTransport, 14 | withConn, 15 | ) 16 | import Control.Monad (when) 17 | import Data.Function ((&)) 18 | import Data.Functor ((<&>)) 19 | import Network.Simple.TCP (connect) 20 | 21 | main :: IO () 22 | main = connect "localhost" "4000" $ \(sock, _addr) -> 23 | withConn (socketTransport sock C.defaultLimit) C.def {debugMode = True} $ \conn -> do 24 | client <- requestBootstrap conn 25 | let calc :: C.Client Calculator 26 | calc = fromClient client 27 | 28 | value <- 29 | calc 30 | & C.callP #evaluate C.def {expression = Expression $ Expression'literal 123} 31 | <&> C.pipe #value 32 | >>= C.callR #read C.def 33 | >>= C.waitPipeline 34 | >>= C.evalLimitT C.defaultLimit . C.parseField #value 35 | assertEq value 123 36 | 37 | let getOp op = 38 | calc 39 | & C.callP #getOperator C.def {op} 40 | <&> C.pipe #func 41 | >>= C.asClient 42 | 43 | add <- getOp Operator'add 44 | subtract <- getOp Operator'subtract 45 | 46 | value <- 47 | calc 48 | & C.callP 49 | #evaluate 50 | C.def 51 | { expression = 52 | Expression $ 53 | Expression'call 54 | Expression'call' 55 | { function = subtract, 56 | params = 57 | [ Expression $ 58 | Expression'call 59 | Expression'call' 60 | { function = add, 61 | params = 62 | [ Expression $ Expression'literal 123, 63 | Expression $ Expression'literal 45 64 | ] 65 | }, 66 | Expression $ Expression'literal 67 67 | ] 68 | } 69 | } 70 | <&> C.pipe #value 71 | >>= C.callR #read C.def 72 | >>= C.waitPipeline 73 | >>= C.evalLimitT C.defaultLimit . C.parseField #value 74 | assertEq value 101 75 | putStrLn "PASS" 76 | 77 | assertEq :: (Show a, Eq a) => a -> a -> IO () 78 | assertEq got want = 79 | when (got /= want) $ 80 | error $ 81 | "Got " ++ show got ++ " but wanted " ++ show want 82 | -------------------------------------------------------------------------------- /capnp-examples/lib/Examples/Rpc/CalculatorServer.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DuplicateRecordFields #-} 2 | {-# LANGUAGE MultiParamTypeClasses #-} 3 | {-# LANGUAGE NamedFieldPuns #-} 4 | {-# LANGUAGE OverloadedLabels #-} 5 | {-# LANGUAGE OverloadedStrings #-} 6 | {-# LANGUAGE RecordWildCards #-} 7 | {-# LANGUAGE TypeApplications #-} 8 | 9 | module Examples.Rpc.CalculatorServer (main) where 10 | 11 | import Capnp 12 | ( Client, 13 | Pipeline, 14 | SomeServer, 15 | callP, 16 | def, 17 | defaultLimit, 18 | export, 19 | getField, 20 | handleParsed, 21 | waitPipeline, 22 | ) 23 | import Capnp.Gen.Calculator 24 | import Capnp.Rpc 25 | ( ConnConfig (..), 26 | handleConn, 27 | socketTransport, 28 | throwFailed, 29 | toClient, 30 | ) 31 | import Control.Concurrent.STM (atomically) 32 | import Control.Monad (when) 33 | import Data.Function ((&)) 34 | import Data.Functor ((<&>)) 35 | import Data.Int 36 | import Network.Simple.TCP (serve) 37 | import Supervisors (Supervisor, withSupervisor) 38 | import Prelude hiding (subtract) 39 | 40 | newtype LitValue = LitValue Double 41 | 42 | instance SomeServer LitValue 43 | 44 | instance Value'server_ LitValue where 45 | value'read (LitValue val) = handleParsed $ \_ -> 46 | pure Value'read'results {value = val} 47 | 48 | newtype OpFunc = OpFunc (Double -> Double -> Double) 49 | 50 | instance SomeServer OpFunc 51 | 52 | instance Function'server_ OpFunc where 53 | function'call (OpFunc op) = handleParsed $ \Function'call'params {params} -> 54 | case params of 55 | [l, r] -> 56 | pure Function'call'results {value = l `op` r} 57 | _ -> 58 | throwFailed "Wrong number of parameters." 59 | 60 | data ExprFunc = ExprFunc 61 | { paramCount :: !Int32, 62 | body :: Parsed Expression 63 | } 64 | 65 | instance SomeServer ExprFunc 66 | 67 | instance Function'server_ ExprFunc where 68 | function'call ExprFunc {..} = 69 | handleParsed $ \Function'call'params {params} -> do 70 | when (fromIntegral (length params) /= paramCount) $ 71 | throwFailed "Wrong number of parameters." 72 | eval params body 73 | >>= waitResult 74 | <&> Function'call'results 75 | 76 | data MyCalc = MyCalc 77 | { add :: Client Function, 78 | subtract :: Client Function, 79 | multiply :: Client Function, 80 | divide :: Client Function, 81 | sup :: Supervisor 82 | } 83 | 84 | instance SomeServer MyCalc 85 | 86 | instance Calculator'server_ MyCalc where 87 | calculator'evaluate MyCalc {sup} = 88 | handleParsed $ \Calculator'evaluate'params {expression} -> do 89 | eval [] expression 90 | >>= waitResult 91 | >>= export @Value sup . LitValue 92 | <&> Calculator'evaluate'results 93 | 94 | calculator'getOperator MyCalc {..} = 95 | handleParsed $ \Calculator'getOperator'params {op} -> 96 | Calculator'getOperator'results <$> case op of 97 | Operator'add -> pure add 98 | Operator'subtract -> pure subtract 99 | Operator'multiply -> pure multiply 100 | Operator'divide -> pure divide 101 | Operator'unknown' _ -> 102 | throwFailed "Unknown operator" 103 | 104 | calculator'defFunction MyCalc {sup} = 105 | handleParsed $ \Calculator'defFunction'params {..} -> 106 | Calculator'defFunction'results 107 | <$> atomically (export @Function sup ExprFunc {..}) 108 | 109 | newCalculator :: Supervisor -> IO (Client Calculator) 110 | newCalculator sup = do 111 | add <- export @Function sup $ OpFunc (+) 112 | subtract <- export @Function sup $ OpFunc (-) 113 | multiply <- export @Function sup $ OpFunc (*) 114 | divide <- export @Function sup $ OpFunc (/) 115 | export @Calculator sup MyCalc {..} 116 | 117 | data EvalResult 118 | = Immediate Double 119 | | CallResult (Pipeline Function'call'results) 120 | | ReadResult (Pipeline Value'read'results) 121 | 122 | waitResult :: EvalResult -> IO Double 123 | waitResult (Immediate v) = pure v 124 | waitResult (CallResult p) = getField #value <$> waitPipeline p 125 | waitResult (ReadResult p) = getField #value <$> waitPipeline p 126 | 127 | eval :: [Double] -> Parsed Expression -> IO EvalResult 128 | eval outerParams (Expression exp) = go outerParams exp 129 | where 130 | go _ (Expression'literal lit) = 131 | pure $ Immediate lit 132 | go _ (Expression'previousResult val) = do 133 | val 134 | & callP #read def 135 | <&> ReadResult 136 | go args (Expression'parameter idx) 137 | | fromIntegral idx >= length args = 138 | throwFailed "Parameter index out of bounds" 139 | | otherwise = 140 | pure $ Immediate $ args !! fromIntegral idx 141 | go outerParams (Expression'call Expression'call' {function, params = innerParams}) = do 142 | argPipelines <- traverse (eval outerParams) innerParams 143 | argValues <- traverse waitResult argPipelines 144 | function 145 | & callP #call Function'call'params {params = argValues} 146 | <&> CallResult 147 | go _ (Expression'unknown' _) = 148 | throwFailed "Unknown expression type" 149 | 150 | main :: IO () 151 | main = withSupervisor $ \sup -> do 152 | boot <- newCalculator sup 153 | serve "localhost" "4000" $ \(sock, _addr) -> 154 | handleConn 155 | (socketTransport sock defaultLimit) 156 | def 157 | { debugMode = True, 158 | bootstrap = Just (toClient boot) 159 | } 160 | -------------------------------------------------------------------------------- /capnp-examples/lib/Examples/Rpc/EchoClient.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedLabels #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | 4 | module Examples.Rpc.EchoClient (main) where 5 | 6 | import qualified Capnp as C 7 | import Capnp.Gen.Echo 8 | import Capnp.Rpc 9 | ( ConnConfig (..), 10 | fromClient, 11 | requestBootstrap, 12 | socketTransport, 13 | withConn, 14 | ) 15 | import Data.Function ((&)) 16 | import Data.Functor ((<&>)) 17 | import Network.Simple.TCP (connect) 18 | 19 | main :: IO () 20 | main = connect "localhost" "4000" $ \(sock, _addr) -> 21 | withConn 22 | (socketTransport sock C.defaultLimit) 23 | (C.def {debugMode = True}) 24 | $ \conn -> do 25 | client <- requestBootstrap conn 26 | let echoClient :: C.Client Echo 27 | echoClient = fromClient client 28 | echoClient 29 | & C.callP #echo C.def {query = "Hello, World!"} 30 | <&> C.pipe #reply 31 | >>= C.waitPipeline 32 | >>= C.evalLimitT C.defaultLimit . C.parse 33 | >>= print 34 | -------------------------------------------------------------------------------- /capnp-examples/lib/Examples/Rpc/EchoServer.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiParamTypeClasses #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE TypeApplications #-} 4 | 5 | module Examples.Rpc.EchoServer (main) where 6 | 7 | import Capnp (SomeServer, def, defaultLimit, export, handleParsed) 8 | import Capnp.Gen.Echo 9 | import Capnp.Rpc (ConnConfig (..), handleConn, socketTransport, toClient) 10 | import Network.Simple.TCP (serve) 11 | import Supervisors (withSupervisor) 12 | 13 | data MyEchoServer = MyEchoServer 14 | 15 | instance SomeServer MyEchoServer 16 | 17 | instance Echo'server_ MyEchoServer where 18 | echo'echo MyEchoServer = handleParsed $ \params -> 19 | pure def {reply = query params} 20 | 21 | main :: IO () 22 | main = 23 | withSupervisor $ \sup -> do 24 | boot <- export @Echo sup MyEchoServer 25 | serve "localhost" "4000" $ \(sock, _addr) -> 26 | handleConn 27 | (socketTransport sock defaultLimit) 28 | def 29 | { debugMode = True, 30 | bootstrap = Just (toClient boot) 31 | } 32 | -------------------------------------------------------------------------------- /capnp-examples/lib/Examples/Serialization/HighLevel/Read.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DuplicateRecordFields #-} 2 | {-# LANGUAGE TypeApplications #-} 3 | 4 | module Examples.Serialization.HighLevel.Read (main) where 5 | 6 | import Capnp.Gen.Addressbook 7 | import Capnp (defaultLimit, getParsed) 8 | 9 | main :: IO () 10 | main = do 11 | value <- getParsed @AddressBook defaultLimit 12 | print value 13 | -------------------------------------------------------------------------------- /capnp-examples/lib/Examples/Serialization/HighLevel/Write.hs: -------------------------------------------------------------------------------- 1 | -- Note that DuplicateRecordFields is usually needed, as the generated 2 | -- code relys on it to resolve collisions in capnproto struct field 3 | -- names: 4 | {-# LANGUAGE DuplicateRecordFields #-} 5 | {-# LANGUAGE OverloadedStrings #-} 6 | 7 | module Examples.Serialization.HighLevel.Write (main) where 8 | 9 | -- Note that Capnp re-exports `def`, as a convienence 10 | import Capnp (def, putParsed) 11 | import Capnp.Gen.Addressbook 12 | 13 | main :: IO () 14 | main = 15 | putParsed 16 | AddressBook 17 | { people = 18 | [ Person 19 | { id = 123, 20 | name = "Alice", 21 | email = "alice@example.com", 22 | phones = 23 | [ def 24 | { number = "555-1212", 25 | type_ = Person'PhoneNumber'Type'mobile 26 | } 27 | ], 28 | employment = Person'employment' $ Person'employment'school "MIT" 29 | }, 30 | Person 31 | { id = 456, 32 | name = "Bob", 33 | email = "bob@example.com", 34 | phones = 35 | [ def 36 | { number = "555-4567", 37 | type_ = Person'PhoneNumber'Type'home 38 | }, 39 | def 40 | { number = "555-7654", 41 | type_ = Person'PhoneNumber'Type'work 42 | } 43 | ], 44 | employment = Person'employment' Person'employment'selfEmployed 45 | } 46 | ] 47 | } 48 | -------------------------------------------------------------------------------- /capnp-examples/lib/Examples/Serialization/LowLevel/Read.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedLabels #-} 2 | {-# LANGUAGE TypeApplications #-} 3 | 4 | module Examples.Serialization.LowLevel.Read (main) where 5 | 6 | import Capnp.Gen.Addressbook 7 | import qualified Capnp as C 8 | import Control.Monad (forM_) 9 | import Control.Monad.Trans (lift) 10 | import Data.Function ((&)) 11 | import qualified Data.Text as T 12 | 13 | main :: IO () 14 | main = do 15 | addressbook <- C.getRaw @AddressBook C.defaultLimit 16 | C.evalLimitT C.defaultLimit $ do 17 | people <- C.readField #people addressbook 18 | forM_ [0 .. C.length people - 1] $ \i -> do 19 | people 20 | & C.index i 21 | >>= C.parseField #name 22 | >>= lift . putStrLn . T.unpack 23 | -------------------------------------------------------------------------------- /capnp-examples/lib/Examples/Serialization/LowLevel/Write.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE OverloadedLabels #-} 3 | {-# LANGUAGE TypeApplications #-} 4 | 5 | module Examples.Serialization.LowLevel.Write (main) where 6 | 7 | import Capnp.Gen.Addressbook 8 | import qualified Capnp as C 9 | import Data.Function ((&)) 10 | import qualified Data.Text as T 11 | 12 | main :: IO () 13 | main = 14 | let Right msg = C.createPure C.defaultLimit buildMsg 15 | in C.putMsg msg 16 | 17 | buildMsg :: C.PureBuilder s (C.Message ('C.Mut s)) 18 | buildMsg = do 19 | -- newMessage allocates a new, initially empty, mutable message. It 20 | -- takes an optional size hint: 21 | msg <- C.newMessage Nothing 22 | 23 | -- newRoot allocates a new struct as the root object of the message. 24 | -- The unit argument is a hint to the allocator to determine the size 25 | -- of the object; for types whose size is not fixed (e.g. untyped structs, 26 | -- lists), this may be something more meaningful. 27 | addressbook <- C.newRoot @AddressBook () msg 28 | 29 | -- newField can be used to allocate the value of a field, for pointer 30 | -- types like lists. The number is the allocation hint, as used by newRoot. 31 | -- We can use the OverloadedLabels extension to pass in fields by name. 32 | people <- C.newField #people 2 addressbook 33 | 34 | -- Index gets an object at a specified location in a list. Cap'N Proto 35 | -- lists are flat arrays, and in the case of structs the structs are 36 | -- unboxed, so there is no need to allocate each element: 37 | alice <- C.index 0 people 38 | 39 | -- encodeField takes the parsed form of a value and marshals it into 40 | -- the specified field. For basic types like integers & booleans, this 41 | -- is almost always what you want. For larger values, you may want to 42 | -- use newField as above, or separately create the value and use setField, 43 | -- as shown below. 44 | C.encodeField #id 123 alice 45 | C.encodeField #name (T.pack "Alice") alice 46 | C.encodeField #email (T.pack "alice@example.com") alice 47 | 48 | -- We would probably use newField here, but to demonstrate, we can allocate 49 | -- the value separately with new, and then set it with setField. 50 | phones <- C.new @(C.List Person'PhoneNumber) 1 msg 51 | C.setField #phones phones alice 52 | 53 | mobilePhone <- C.index 0 phones 54 | -- It is sometimes more ergonomic to use (&) from Data.Function. You might 55 | -- ask why not just make the container the first argument, but it works 56 | -- out better this way for the read examples. 57 | mobilePhone & C.encodeField #number (T.pack "555-1212") 58 | mobilePhone & C.encodeField #type_ Person'PhoneNumber'Type'mobile 59 | 60 | -- Since named unions act like unnamed unions inside a group, we first have 61 | -- to get the group field: 62 | employment <- C.readField #employment alice 63 | 64 | -- Then, we can use encodeVariant to set both the tag of the union and the 65 | -- value: 66 | employment & C.encodeVariant #school (T.pack "MIT") 67 | 68 | bob <- C.index 1 people 69 | bob & C.encodeField #id 456 70 | bob & C.encodeField #name (T.pack "Bob") 71 | bob & C.encodeField #email (T.pack "bob@example.com") 72 | 73 | phones <- bob & C.newField #phones 2 74 | homePhone <- phones & C.index 0 75 | homePhone & C.encodeField #number (T.pack "555-4567") 76 | homePhone & C.encodeField #type_ Person'PhoneNumber'Type'home 77 | workPhone <- phones & C.index 1 78 | workPhone & C.encodeField #number (T.pack "555-7654") 79 | workPhone & C.encodeField #type_ Person'PhoneNumber'Type'work 80 | employment <- bob & C.readField #employment 81 | employment & C.encodeVariant #selfEmployed () -- Note the (), since selfEmploy is Void. 82 | pure msg 83 | -------------------------------------------------------------------------------- /capnp-tests/capnp-tests.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.2 2 | name: capnp-tests 3 | version: 0.18.0.0 4 | category: Data, Serialization, Network, Rpc 5 | copyright: 2016-2023 haskell-capnp contributors (see CONTRIBUTORS file). 6 | author: Ian Denhardt 7 | maintainer: ian@zenhack.net 8 | license: MIT 9 | license-file: LICENSE.md 10 | homepage: https://codeberg.org/zenhack/haskell-capnp 11 | bug-reports: https://codeberg.org/zenhack/haskell-capnp/issues 12 | synopsis: Cap'n Proto for Haskell 13 | description: 14 | A native Haskell implementation of the Cap'N Proto cerialization format and 15 | RPC protocol. 16 | . 17 | The library implements serialization and level 1 RPC. 18 | . 19 | The "Capnp.Tutorial" module is the best place to start reading; the 20 | reference documentation can seem bewildering without that context. 21 | build-type: Simple 22 | 23 | -------------------------------------------------------------------------------- 24 | 25 | source-repository head 26 | type: git 27 | branch: master 28 | location: https://codeberg.org/zenhack/haskell-capnp.git 29 | 30 | -------------------------------------------------------------------------------- 31 | 32 | common shared-opts 33 | build-depends: 34 | base >= 4.14 && < 5 35 | , bytes >= 0.15.4 && <0.18 36 | , bytestring >= 0.10 && <0.12 37 | , containers >= 0.5.9 && <0.7 38 | , data-default ^>= 0.7.1 39 | , exceptions ^>= 0.10.0 40 | , ghc-prim >= 0.6.1 && <0.11 41 | , mtl >= 2.2.2 && <2.4 42 | , primitive >= 0.6.3 && <0.9 43 | , safe-exceptions ^>= 0.1.7 44 | , text >= 1.2 && < 2.1 45 | , transformers >= 0.5.2 && <0.7 46 | , vector >= 0.12.0 && <0.14 47 | , monad-stm ^>= 0.1 48 | ghc-options: 49 | -Wall 50 | 51 | -- This warning is triggered by normal use of NamedFieldPuns, so it's a no-go 52 | -- for us: 53 | -Wno-name-shadowing 54 | 55 | -- I(zenhack) find it rather odd that orphan instances are flagged when the 56 | -- class and the type are in different modules but, the same *package*. We do 57 | -- this in a number of places in the capnp package, so we disable this 58 | -- warning. It's not super easy to write a package-level orphan by accident, 59 | -- so we're not losing much. 60 | -Wno-orphans 61 | default-language: Haskell2010 62 | 63 | -------------------------------------------------------------------------------- 64 | 65 | test-suite tests 66 | import: shared-opts 67 | type: exitcode-stdio-1.0 68 | main-is: Main.hs 69 | hs-source-dirs: 70 | tests 71 | gen/tests 72 | examples/lib 73 | examples/gen/lib 74 | ghc-options: 75 | -threaded 76 | other-modules: 77 | -- Utilities 78 | Util 79 | , Instances 80 | , SchemaGeneration 81 | 82 | -- generated from tests/data/aircraft.capnp 83 | , Capnp.Gen.Aircraft 84 | , Capnp.Gen.ById.X832bcc6686a26d56 85 | 86 | -- generated from tests/data/generics.capnp 87 | , Capnp.Gen.Generics 88 | , Capnp.Gen.ById.Xb6421fb8e478d144 89 | 90 | -- Actual tests: 91 | , Module.Capnp.Gen.Capnp.Schema 92 | , Module.Capnp.Gen.Capnp.Schema.Pure 93 | , Module.Capnp.Rpc 94 | , Module.Capnp.Untyped 95 | , Module.Capnp.Untyped.Pure 96 | , Module.Capnp.Pointer 97 | , Module.Capnp.Bits 98 | , Module.Capnp.Basics 99 | , Module.Capnp.Canonicalize 100 | , PointerOOB 101 | , Regression 102 | , WalkSchemaCodeGenRequest 103 | , SchemaQuickCheck 104 | , CalculatorExample 105 | , Constants 106 | , Rpc.Unwrap 107 | build-depends: 108 | capnp 109 | , capnp-examples 110 | , network 111 | , network-simple 112 | , stm 113 | , async 114 | , process 115 | , process-extras 116 | , QuickCheck 117 | , quickcheck-io 118 | , quickcheck-instances 119 | , hspec 120 | , directory 121 | , resourcet 122 | , heredoc 123 | , deepseq 124 | , pretty-show 125 | , supervisors 126 | 127 | 128 | benchmark bench 129 | import: shared-opts 130 | type: exitcode-stdio-1.0 131 | main-is: Main.hs 132 | hs-source-dirs: bench 133 | build-depends: 134 | capnp 135 | , criterion >=1.5.9 && <0.7 136 | , deepseq 137 | , process-extras 138 | -------------------------------------------------------------------------------- /capnp-tests/gen/tests/.gitignore: -------------------------------------------------------------------------------- 1 | *.hs 2 | -------------------------------------------------------------------------------- /capnp-tests/tests/CalculatorExample.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | 5 | module CalculatorExample (tests) where 6 | 7 | import Capnp.Rpc (ConnConfig (..), handleConn, requestBootstrap, withConn) 8 | import Capnp.Rpc.Transport (socketTransport) 9 | import Capnp.TraversalLimit (defaultLimit) 10 | import Control.Concurrent (threadDelay) 11 | import Control.Concurrent.Async (race_) 12 | import Control.Exception.Safe (throwIO, try) 13 | import Data.Default (def) 14 | import Data.Foldable (for_) 15 | import Data.String (fromString) 16 | import Data.Word 17 | import qualified Examples.Rpc.CalculatorClient 18 | import qualified Examples.Rpc.CalculatorServer 19 | import Network.Simple.TCP (connect, serve) 20 | import System.Environment (getEnv) 21 | import System.Exit (ExitCode (ExitSuccess)) 22 | import System.IO.Error (isDoesNotExistError) 23 | import System.Process (callProcess, readProcessWithExitCode) 24 | import Test.Hspec 25 | 26 | getExe :: String -> IO (Maybe FilePath) 27 | getExe varName = 28 | try (getEnv varName) >>= \case 29 | Left e 30 | | isDoesNotExistError e -> do 31 | putStrLn $ varName ++ " not set; skipping." 32 | pure Nothing 33 | | otherwise -> 34 | throwIO e 35 | Right path -> 36 | pure (Just path) 37 | 38 | tests :: Spec 39 | tests = describe "Check our example against the C++ implementation" $ do 40 | clientPath <- runIO $ getExe "CXX_CALCULATOR_CLIENT" 41 | serverPath <- runIO $ getExe "CXX_CALCULATOR_SERVER" 42 | for_ clientPath $ \clientPath -> 43 | it "Should pass when run against our server" $ 44 | Examples.Rpc.CalculatorServer.main 45 | `race_` (waitForServer >> cxxClient clientPath 4000) 46 | for_ serverPath $ \serverPath -> 47 | it "Should pass when run against our client" $ 48 | cxxServer serverPath 4000 49 | `race_` (waitForServer >> Examples.Rpc.CalculatorClient.main) 50 | for_ ((,) <$> clientPath <*> serverPath) $ \(clientPath, serverPath) -> 51 | it "Should pass when run aginst the C++ server, proxied through us." $ 52 | cxxServer serverPath 4000 53 | `race_` (waitForServer >> runProxy 4000 6000) 54 | -- we wait twice, so that the proxy also has time to start: 55 | `race_` (waitForServer >> waitForServer >> cxxClient clientPath 6000) 56 | where 57 | -- \| Give the server a bit of time to start up. 58 | waitForServer :: IO () 59 | waitForServer = threadDelay 100000 60 | 61 | cxxServer :: FilePath -> Word16 -> IO () 62 | cxxServer path port = 63 | callProcess path ["localhost:" ++ show port] 64 | cxxClient :: FilePath -> Word16 -> IO () 65 | cxxClient path port = do 66 | (eStatus, out, err) <- readProcessWithExitCode path ["localhost:" ++ show port] "" 67 | (eStatus, out, err) 68 | `shouldBe` ( ExitSuccess, 69 | unlines 70 | [ "Evaluating a literal... PASS", 71 | "Using add and subtract... PASS", 72 | "Pipelining eval() calls... PASS", 73 | "Defining functions... PASS", 74 | "Using a callback... PASS" 75 | ], 76 | "" 77 | ) 78 | 79 | -- | @'runProxy' serverPort clientPort@ connects to the server listening at 80 | -- localhost:serverPort, requests its bootstrap interface, and then listens 81 | -- on clientPort, offering a proxy of the server's bootstrap interface as our 82 | -- own. 83 | runProxy :: Word16 -> Word16 -> IO () 84 | runProxy serverPort clientPort = 85 | connect "localhost" (fromString $ show serverPort) $ \(serverSock, _addr) -> 86 | withConn (socketTransport serverSock defaultLimit) def {debugMode = True} $ \conn -> do 87 | client <- requestBootstrap conn 88 | serve "localhost" (fromString $ show clientPort) $ \(clientSock, _addr) -> 89 | handleConn 90 | (socketTransport clientSock defaultLimit) 91 | def 92 | { bootstrap = Just client, 93 | debugMode = True 94 | } 95 | -------------------------------------------------------------------------------- /capnp-tests/tests/Constants.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | 4 | module Constants (tests) where 5 | 6 | import Capnp 7 | import Capnp.Gen.Aircraft hiding (Parsed) 8 | import Data.Default 9 | import Test.Hspec 10 | 11 | tests :: Spec 12 | tests = do 13 | describe "parsing defaults" $ do 14 | defTest "structs" Zdate {year = 0, month = 0, day = 0} 15 | defTest "struct lists" ([] :: [Parsed Zdate]) 16 | -- defTest "enums" Airport'none 17 | defTest "enum lists" ([] :: [Airport]) 18 | describe "parsing constants" $ do 19 | it "should parse enums correctly" $ 20 | constEnum `shouldBe` Airport'jfk 21 | constTest "structs" constDate Zdate {year = 2015, month = 8, day = 27} 22 | constTest 23 | "lists" 24 | constList 25 | [ Zdate {year = 2015, month = 8, day = 27}, 26 | Zdate {year = 2015, month = 8, day = 28} 27 | ] 28 | 29 | defTest :: (Default a, Eq a, Show a) => String -> a -> Spec 30 | defTest name expected = 31 | it ("should parse the default for " ++ name ++ " correctly") $ do 32 | def `shouldBe` expected 33 | 34 | constTest :: (Parse a (Parsed a), Show (Parsed a), Eq (Parsed a)) => String -> Raw a 'Const -> Parsed a -> Spec 35 | constTest name input expected = 36 | it ("should parse " ++ name ++ " correctly") $ do 37 | actual <- evalLimitT maxBound $ parse input 38 | actual `shouldBe` expected 39 | -------------------------------------------------------------------------------- /capnp-tests/tests/Main.hs: -------------------------------------------------------------------------------- 1 | module Main (main) where 2 | 3 | import qualified CalculatorExample 4 | import qualified Constants 5 | import Module.Capnp.Basics (basicsTests) 6 | import Module.Capnp.Bits (bitsTests) 7 | import Module.Capnp.Canonicalize (canonicalizeTests) 8 | import Module.Capnp.Gen.Capnp.Schema (schemaTests) 9 | import Module.Capnp.Gen.Capnp.Schema.Pure (pureSchemaTests) 10 | import Module.Capnp.Pointer (ptrTests) 11 | import Module.Capnp.Rpc (rpcTests) 12 | import Module.Capnp.Untyped (untypedTests) 13 | import Module.Capnp.Untyped.Pure (pureUntypedTests) 14 | import qualified PointerOOB 15 | import Regression (regressionTests) 16 | import Rpc.Unwrap (unwrapTests) 17 | import SchemaQuickCheck (schemaCGRQuickCheck) 18 | import Test.Hspec 19 | import WalkSchemaCodeGenRequest (walkSchemaCodeGenRequestTest) 20 | 21 | main :: IO () 22 | main = hspec $ do 23 | describe "Tests for specific modules" $ do 24 | describe "Capnp.Basics" basicsTests 25 | describe "Capnp.Bits" bitsTests 26 | describe "Capnp.Pointer" ptrTests 27 | describe "Capnp.Rpc" rpcTests 28 | describe "Capnp.Untyped" untypedTests 29 | describe "Capnp.Untyped.Pure" pureUntypedTests 30 | describe "Capnp.Canonicalize" canonicalizeTests 31 | describe "Tests for generated output" $ do 32 | describe "low-level output" schemaTests 33 | describe "high-level output" pureSchemaTests 34 | describe "Tests relate to schema" $ do 35 | describe "tests using tests/data/schema-codegenreq" walkSchemaCodeGenRequestTest 36 | describe "property tests for schema" schemaCGRQuickCheck 37 | describe "Regression tests" regressionTests 38 | CalculatorExample.tests 39 | PointerOOB.tests 40 | Constants.tests 41 | describe "Tests for client unwrapping" unwrapTests 42 | -------------------------------------------------------------------------------- /capnp-tests/tests/Module/Capnp/Basics.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | {-# OPTIONS_GHC -Wno-error=deprecations #-} 4 | 5 | module Module.Capnp.Basics (basicsTests) where 6 | 7 | import Capnp 8 | ( List, 9 | Mutability (..), 10 | Raw (..), 11 | encode, 12 | evalLimitT, 13 | length, 14 | newMessage, 15 | ) 16 | import Capnp.Basics 17 | import Capnp.Mutability (freeze) 18 | import Control.Monad.IO.Class (liftIO) 19 | import qualified Data.ByteString as BS 20 | import qualified Data.Text as T 21 | import Data.Word 22 | import GHC.Prim (coerce) 23 | import Test.Hspec 24 | import Test.QuickCheck 25 | import Test.QuickCheck.IO (propertyIO) 26 | import Test.QuickCheck.Instances () 27 | import Prelude hiding (length) 28 | 29 | -- import Data.Mutable (freeze) 30 | 31 | basicsTests :: Spec 32 | basicsTests = 33 | describe "textBuffer and textBytes agree" $ 34 | it "Should return the same number of bytes" $ 35 | property $ \(text :: T.Text) -> propertyIO $ evalLimitT maxBound $ do 36 | msg <- newMessage Nothing 37 | Raw untyped <- encode msg text 38 | raw :: Raw Text 'Const <- Raw <$> freeze untyped 39 | buf <- textBuffer raw 40 | bytes <- textBytes raw 41 | liftIO $ BS.length bytes `shouldBe` length (coerce buf :: Raw (List Word8) 'Const) 42 | -------------------------------------------------------------------------------- /capnp-tests/tests/Module/Capnp/Bits.hs: -------------------------------------------------------------------------------- 1 | module Module.Capnp.Bits (bitsTests) where 2 | 3 | import Capnp.Bits 4 | import Data.Bits 5 | import Data.Foldable (traverse_) 6 | import Data.Word 7 | import Test.Hspec 8 | 9 | bitsTests :: Spec 10 | bitsTests = do 11 | describe "bitRange" bitRangeExamples 12 | describe "replaceBits" replaceBitsExamples 13 | 14 | bitRangeExamples :: Spec 15 | bitRangeExamples = do 16 | it "Should get single bits correctly" $ 17 | traverse_ bitRangeTest ones 18 | it "Should work on this extra example" $ 19 | bitRangeTest 20 | (0x0000000200000000, 32, 48, 2) 21 | where 22 | bitRangeTest :: (Word64, Int, Int, Word64) -> IO () 23 | bitRangeTest (word, lo, hi, expected) = 24 | bitRange word lo hi `shouldBe` expected 25 | ones = map (\bit -> (1 `shiftL` bit, bit, bit + 1, 1)) [0 .. 63] 26 | 27 | replaceBitsExamples :: Spec 28 | replaceBitsExamples = 29 | it "Should work with several examples" $ 30 | sequence_ 31 | [ replaceTest (0xf :: Word8) 0 0 0xf, 32 | replaceTest (0x1 :: Word8) 0xf 0 0x1, 33 | replaceTest (0x2 :: Word8) 0x1 0 0x2, 34 | replaceTest (0x1 :: Word8) 0xf 0 0x1, 35 | replaceTest (0x2 :: Word8) 0x10 4 0x20, 36 | replaceTest (0x1 :: Word8) 0x10 8 0x0110, 37 | replaceTest (0xa :: Word8) 0xffff 8 0x0aff, 38 | replaceTest (0x0 :: Word1) 0xff 4 0xef 39 | ] 40 | where 41 | replaceTest :: 42 | (Bounded a, Integral a, Show a) => 43 | a -> 44 | Word64 -> 45 | Int -> 46 | Word64 -> 47 | Expectation 48 | replaceTest new orig shift expected = 49 | replaceBits new orig shift `shouldBe` expected 50 | -------------------------------------------------------------------------------- /capnp-tests/tests/Module/Capnp/Canonicalize.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | {-# LANGUAGE ViewPatterns #-} 4 | 5 | module Module.Capnp.Canonicalize 6 | ( canonicalizeTests, 7 | ) 8 | where 9 | 10 | import Capnp (Parsed, Raw (..), createPure, encode, msgToLBS) 11 | import qualified Capnp.Basics as B 12 | import Capnp.Canonicalize 13 | import qualified Capnp.Message as M 14 | import qualified Capnp.Untyped as U 15 | import Control.Monad (unless) 16 | import qualified Data.ByteString.Lazy as LBS 17 | import qualified Data.Vector as V 18 | import Instances () 19 | import Test.Hspec 20 | import Test.QuickCheck (property) 21 | import Test.QuickCheck.IO (propertyIO) 22 | import Util (capnpCanonicalize) 23 | 24 | canonicalizeTests :: Spec 25 | canonicalizeTests = 26 | describe "canonicalization tests" $ do 27 | it "agrees with reference implementation" $ 28 | property $ \case 29 | B.Struct (V.toList -> []) (V.toList -> []) -> 30 | -- skip this; it fails due to a bug in the reference implementation: 31 | -- 32 | -- https://github.com/capnproto/capnproto/issues/1084 33 | -- 34 | -- TODO: when that issue is fixed, stop skipping this case. 35 | propertyIO $ pure () 36 | struct -> 37 | propertyIO $ implsAgreeOn struct 38 | 39 | implsAgreeOn :: Parsed B.AnyStruct -> IO () 40 | implsAgreeOn struct = do 41 | let Just ourMsg = ourImplCanonicalize struct 42 | refMsg <- refImplCanonicalize struct 43 | unless (ourMsg == refMsg) $ 44 | error $ 45 | concat 46 | [ "Our implementation disagrees with the reference implementation on " ++ show struct, 47 | ".\n\nWe produce:\n\n", 48 | show $ LBS.unpack $ msgToLBS ourMsg, 49 | "\n\n", 50 | "But the reference implementation generates:\n\n", 51 | show $ LBS.unpack $ msgToLBS refMsg 52 | ] 53 | 54 | ourImplCanonicalize :: Parsed B.AnyStruct -> Maybe (M.Message 'M.Const) 55 | ourImplCanonicalize struct = createPure maxBound $ do 56 | msg <- M.newMessage Nothing 57 | Raw rawStruct <- encode msg struct 58 | (msg, _) <- canonicalizeMut rawStruct 59 | pure msg 60 | 61 | refImplCanonicalize :: Parsed B.AnyStruct -> IO (M.Message 'M.Const) 62 | refImplCanonicalize struct = do 63 | msg <- createPure maxBound $ do 64 | msg <- M.newMessage Nothing 65 | Raw rawStruct <- encode msg struct 66 | U.setRoot rawStruct 67 | pure msg 68 | lbs <- capnpCanonicalize (msgToLBS msg) 69 | let segment = M.fromByteString $ LBS.toStrict lbs 70 | pure $ M.singleSegment segment 71 | -------------------------------------------------------------------------------- /capnp-tests/tests/Module/Capnp/Gen/Capnp/Schema.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE OverloadedLabels #-} 3 | {-# LANGUAGE RecordWildCards #-} 4 | {-# LANGUAGE TypeApplications #-} 5 | 6 | module Module.Capnp.Gen.Capnp.Schema (schemaTests) where 7 | 8 | import Capnp (encodeField, encodeVariant, initVariant, readField) 9 | import qualified Capnp.Classes as C 10 | import qualified Capnp.Gen.Capnp.Schema as S 11 | import qualified Capnp.Message as M 12 | import Capnp.Mutability (freeze) 13 | import Capnp.TraversalLimit (LimitT, evalLimitT) 14 | import Control.Monad.Primitive (RealWorld) 15 | import Data.Foldable (traverse_) 16 | import Data.Function ((&)) 17 | import Test.Hspec 18 | import Util (decodeValue, schemaSchemaSrc) 19 | 20 | data BuildTest = BuildTest 21 | { typeName :: String, 22 | expected :: String, 23 | builder :: M.Message ('M.Mut RealWorld) -> LimitT IO () 24 | } 25 | 26 | schemaTests :: Spec 27 | schemaTests = 28 | describe "tests for typed setters" $ 29 | traverse_ 30 | testCase 31 | [ BuildTest 32 | { typeName = "Field", 33 | expected = 34 | concat 35 | [ "( codeOrder = 4,\n", 36 | " discriminantValue = 6,\n", 37 | " group = (typeId = 322),\n", 38 | " ordinal = (explicit = 22) )\n" 39 | ], 40 | builder = \msg -> do 41 | field <- C.newRoot @S.Field () msg 42 | field & encodeField #codeOrder 4 43 | field & encodeField #discriminantValue 6 44 | field 45 | & initVariant #group 46 | >>= encodeField #typeId 322 47 | field 48 | & readField #ordinal 49 | >>= encodeVariant #explicit 22 50 | } 51 | ] 52 | where 53 | testCase BuildTest {..} = it ("Should build " ++ expected) $ do 54 | msg <- M.newMessage Nothing 55 | evalLimitT maxBound $ builder msg 56 | constMsg <- freeze msg 57 | actual <- decodeValue schemaSchemaSrc typeName constMsg 58 | actual `shouldBe` expected 59 | -------------------------------------------------------------------------------- /capnp-tests/tests/Module/Capnp/Pointer.hs: -------------------------------------------------------------------------------- 1 | module Module.Capnp.Pointer (ptrTests) where 2 | 3 | import Capnp.Pointer 4 | import Data.Bits 5 | import Data.Int 6 | import Data.Word 7 | import Test.Hspec 8 | import Test.QuickCheck 9 | 10 | instance Arbitrary EltSpec where 11 | arbitrary = 12 | oneof 13 | [ EltNormal <$> arbitrary <*> arbitraryU29, 14 | EltComposite <$> arbitraryI29 15 | ] 16 | 17 | instance Arbitrary ElementSize where 18 | arbitrary = 19 | oneof $ 20 | map 21 | return 22 | [ Sz0, 23 | Sz1, 24 | Sz8, 25 | Sz16, 26 | Sz32, 27 | Sz64, 28 | SzPtr 29 | ] 30 | 31 | -- | arbitraryIN is an arbitrary N bit signed integer as an Int32. 32 | arbitraryI32, arbitraryI30, arbitraryI29 :: Gen Int32 33 | arbitraryI32 = arbitrary 34 | arbitraryI30 = (`shiftR` 2) <$> arbitraryI32 35 | arbitraryI29 = (`shiftR` 3) <$> arbitraryI32 36 | 37 | -- | arbitraryUN is an arbitrary N bit unsigned integer as a Word32. 38 | arbitraryU32, arbitraryU29 :: Gen Word32 39 | arbitraryU32 = arbitrary 40 | arbitraryU29 = (`shiftR` 3) <$> arbitraryU32 41 | 42 | instance Arbitrary Ptr where 43 | arbitrary = 44 | oneof 45 | [ StructPtr 46 | <$> arbitraryI30 47 | <*> arbitrary 48 | <*> arbitrary, 49 | ListPtr 50 | <$> arbitraryI30 51 | <*> arbitrary, 52 | FarPtr 53 | <$> arbitrary 54 | <*> arbitraryU29 55 | <*> arbitrary, 56 | CapPtr <$> arbitrary 57 | ] 58 | 59 | ptrTests :: Spec 60 | ptrTests = do 61 | ptrProps 62 | parsePtrExamples 63 | 64 | ptrProps :: Spec 65 | ptrProps = describe "Pointer Properties" $ do 66 | it "Should satisfy: parseEltSpec . serializeEltSpec == id" $ 67 | property $ 68 | \spec -> parseEltSpec (serializeEltSpec spec) == spec 69 | it "Should satisfy: parsePtr . serializePtr == id" $ 70 | property $ \ptr -> 71 | case ptr of 72 | (Just (StructPtr 0 0 0)) -> True -- we skip this one, since it's 73 | -- the same bits as a null, so this 74 | -- shouldn't hold. TODO: the name 75 | -- of this test is a bit misleading 76 | -- because of this case; should fix 77 | -- that. 78 | _ -> parsePtr (serializePtr ptr) == ptr 79 | 80 | parsePtrExamples :: Spec 81 | parsePtrExamples = 82 | describe "parsePtr (examples)" $ 83 | it "Should parse this example correctly" $ 84 | parsePtr 0x0000000200000000 `shouldBe` Just (StructPtr 0 2 0) 85 | -------------------------------------------------------------------------------- /capnp-tests/tests/Module/Capnp/Untyped/Pure.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE OverloadedLists #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | {-# LANGUAGE QuasiQuotes #-} 5 | 6 | -- TODO(cleanup): the raw/pure split no longer exists, so this module path doesn't 7 | -- make a lot of sense anymore; reorganize. 8 | module Module.Capnp.Untyped.Pure (pureUntypedTests) where 9 | 10 | import Capnp (msgToRaw, parse) 11 | import Capnp.Basics 12 | import Capnp.TraversalLimit (runLimitT) 13 | import GHC.Float (castDoubleToWord64) 14 | import Test.Hspec 15 | import Text.Heredoc (here) 16 | import Util 17 | 18 | -- This is analogous to Tests.Module.Capnp.Untyped.untypedTests, but 19 | -- using the Pure module: 20 | pureUntypedTests :: Spec 21 | pureUntypedTests = 22 | describe "high-level untyped decoding" $ 23 | it "Should agree with `capnp decode`" $ do 24 | msg <- 25 | encodeValue 26 | aircraftSchemaSrc 27 | "Aircraft" 28 | [here|(f16 = (base = ( 29 | name = "bob", 30 | homes = [], 31 | rating = 7, 32 | canFly = true, 33 | capacity = 5173, 34 | maxSpeed = 12.0 35 | )))|] 36 | (actual, 117) <- runLimitT 128 $ msgToRaw msg >>= parse 37 | actual 38 | `shouldBe` Struct 39 | [3] 40 | [ Just $ 41 | PtrStruct $ 42 | Struct 43 | [] 44 | [ Just $ 45 | PtrStruct $ 46 | Struct 47 | [ 7, 48 | 1, 49 | 5173, 50 | castDoubleToWord64 12.0 51 | ] 52 | [ Just $ PtrList $ List8 $ map (fromIntegral . fromEnum) "bob\0", 53 | Just $ PtrList $ List16 [] 54 | ] 55 | ] 56 | ] 57 | -------------------------------------------------------------------------------- /capnp-tests/tests/PointerOOB.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | 3 | module PointerOOB (tests) where 4 | 5 | import qualified Capnp as Capnp 6 | import qualified Capnp.Errors as E 7 | import qualified Capnp.Message as M 8 | import qualified Capnp.Pointer as P 9 | import qualified Capnp.Untyped as U 10 | import Control.Category ((>>>)) 11 | import Control.Exception.Safe (try) 12 | import Control.Monad.IO.Class (MonadIO (liftIO)) 13 | import qualified Data.ByteString as BS 14 | import qualified Data.ByteString.Builder as BB 15 | import qualified Data.ByteString.Lazy as LBS 16 | import Data.Foldable (for_) 17 | import Data.Function ((&)) 18 | import Test.Hspec 19 | 20 | errPtrs :: [(P.Ptr, E.Error)] 21 | errPtrs = 22 | [ ( P.ListPtr 0 (P.EltNormal P.Sz1 1), 23 | E.BoundsError {E.index = 2, E.maxIndex = 1} 24 | ), 25 | ( P.ListPtr 0 (P.EltNormal P.Sz32 4), 26 | E.BoundsError {E.index = 3, E.maxIndex = 1} 27 | ), 28 | ( P.ListPtr (-3) (P.EltNormal P.Sz1 1), 29 | E.BoundsError {E.index = -1, E.maxIndex = 1} 30 | ), 31 | ( P.ListPtr (-4) (P.EltNormal P.Sz1 1), 32 | E.BoundsError {E.index = -2, E.maxIndex = 1} 33 | ), 34 | ( P.StructPtr 0 1 0, 35 | E.BoundsError {E.index = 2, E.maxIndex = 1} 36 | ), 37 | ( P.StructPtr 0 0 1, 38 | E.BoundsError {E.index = 2, E.maxIndex = 1} 39 | ), 40 | ( P.StructPtr 0 1 1, 41 | E.BoundsError {E.index = 3, E.maxIndex = 1} 42 | ) 43 | ] 44 | 45 | wrapPtr :: P.Ptr -> BS.ByteString 46 | wrapPtr p = 47 | [Just (P.StructPtr 0 0 1), Just p] 48 | & map (P.serializePtr >>> BB.word64LE) 49 | & mconcat 50 | & BB.toLazyByteString 51 | & LBS.toStrict 52 | 53 | tests :: Spec 54 | tests = describe "Test correct handling of out of bound pointers" $ do 55 | describe "pointers that go off the end of the message" $ do 56 | for_ errPtrs $ \(p, err) -> do 57 | it ("Should catch the issue for " <> show p) $ do 58 | let testPtrBounds :: P.Ptr -> Capnp.LimitT IO () 59 | testPtrBounds p = do 60 | let msg = M.singleSegment $ Capnp.fromByteString (wrapPtr p) 61 | root <- U.rootPtr msg 62 | v <- try $ U.getPtr 0 root 63 | case v of 64 | Right _ -> fail "should have signaled an error" 65 | Left e -> liftIO $ e `shouldBe` err 66 | Capnp.evalLimitT maxBound (testPtrBounds p) 67 | -------------------------------------------------------------------------------- /capnp-tests/tests/Regression.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DuplicateRecordFields #-} 2 | {-# LANGUAGE NamedFieldPuns #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | 5 | module Regression (regressionTests) where 6 | 7 | import Capnp (bsToParsed, def, evalLimitT) 8 | import Capnp.Gen.Aircraft 9 | import Capnp.Gen.Capnp.Rpc 10 | import Test.Hspec 11 | 12 | regressionTests :: Spec 13 | regressionTests = describe "Regression tests" $ do 14 | it "Should decode abort message successfully (issue #56)" $ do 15 | let bytes = 16 | "\NUL\NUL\NUL\NUL\ETB\NUL\NUL\NUL\NUL\NUL\NUL\NUL\SOH\NUL" 17 | <> "\SOH\NUL\SOH\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL" 18 | <> "\SOH\NUL\SOH\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\SOH\NUL" 19 | <> "\NUL\NULz\EOT\NUL\NULYour vat sent an 'unimplemented' " 20 | <> "message for an abort message that its remote peer never " 21 | <> "sent. This is likely a bug in your capnproto library.\NUL\NUL" 22 | msg <- evalLimitT maxBound $ bsToParsed bytes 23 | msg 24 | `shouldBe` Message 25 | ( Message'abort 26 | def 27 | { reason = 28 | "Your vat sent an 'unimplemented' message for an abort " 29 | <> "message that its remote peer never sent. This is likely " 30 | <> "a bug in your capnproto library.", 31 | type_ = Exception'Type'failed 32 | } 33 | ) 34 | it "Should decode negative default values correctly (issue #55)" $ do 35 | -- Note that this was never actually broken, but we were getting 36 | -- a warning about a literal overflowing the bounds of its type. 37 | -- It worked anyway, since it became the right value after casting, 38 | -- but the warning has been fixed and this test makes sure it still 39 | -- actually works. 40 | let Defaults {int} = def 41 | int `shouldBe` (-123) 42 | -------------------------------------------------------------------------------- /capnp-tests/tests/Rpc/Unwrap.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE MultiParamTypeClasses #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | {-# LANGUAGE TypeApplications #-} 5 | 6 | module Rpc.Unwrap (unwrapTests) where 7 | 8 | import Capnp 9 | ( SomeServer (..), 10 | export, 11 | methodUnimplemented, 12 | ) 13 | import qualified Capnp.Gen.Aircraft as Aircraft 14 | import qualified Capnp.Rpc as Rpc 15 | import Data.Typeable (Typeable) 16 | import qualified Data.Typeable as Typeable 17 | import qualified Supervisors 18 | import Test.Hspec 19 | 20 | data OpaqueEcho = OpaqueEcho 21 | deriving (Show, Read, Eq, Ord, Enum, Bounded) 22 | 23 | instance SomeServer OpaqueEcho 24 | 25 | instance Aircraft.Echo'server_ OpaqueEcho where 26 | echo'echo _ = methodUnimplemented 27 | 28 | newtype TransparentEcho = TransparentEcho Int 29 | deriving (Show, Read, Eq, Ord, Bounded, Typeable) 30 | 31 | instance SomeServer TransparentEcho where 32 | unwrap = Typeable.cast 33 | 34 | instance Aircraft.Echo'server_ TransparentEcho where 35 | echo'echo _ = methodUnimplemented 36 | 37 | unwrapTests :: Spec 38 | unwrapTests = describe "Tests for client unwrapping" $ do 39 | it "Should return nothing for OpaqueEcho." $ do 40 | r :: Maybe OpaqueEcho <- exportAndUnwrap OpaqueEcho 41 | r `shouldBe` Nothing 42 | it "Should return nothing for the wrong type." $ do 43 | r :: Maybe () <- exportAndUnwrap (TransparentEcho 4) 44 | r `shouldBe` Nothing 45 | it "Should return the value for TransparentEcho." $ do 46 | r <- exportAndUnwrap (TransparentEcho 4) 47 | r `shouldBe` Just (TransparentEcho 4) 48 | 49 | exportAndUnwrap :: (SomeServer a, Aircraft.Echo'server_ a, Typeable b) => a -> IO (Maybe b) 50 | exportAndUnwrap srv = Supervisors.withSupervisor $ \sup -> do 51 | client <- export @Aircraft.Echo sup srv 52 | pure $ Rpc.unwrapServer client 53 | -------------------------------------------------------------------------------- /capnp-tests/tests/SchemaGeneration.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 2 | 3 | module SchemaGeneration 4 | ( Schema (..), 5 | genSchema, 6 | ) 7 | where 8 | 9 | import Control.Monad.State.Strict 10 | import Data.List.NonEmpty (NonEmpty ((:|))) 11 | import qualified Data.List.NonEmpty as NE 12 | import qualified Test.QuickCheck as QC 13 | 14 | -- Definitions 15 | 16 | newtype FieldName 17 | = FieldName String 18 | 19 | instance Show FieldName where 20 | show (FieldName fn) = fn 21 | 22 | newtype StructName 23 | = StructName String 24 | 25 | instance Show StructName where 26 | show (StructName fn) = fn 27 | 28 | data Field 29 | = FieldDef FieldName Int FieldType 30 | | StructDef StructName [Field] 31 | 32 | data BuiltIn 33 | = Void 34 | | Bool 35 | | Int8 36 | | Int16 37 | | Int32 38 | | Int64 39 | | UInt8 40 | | UInt16 41 | | UInt32 42 | | UInt64 43 | | Float32 44 | | Float64 45 | | Text 46 | | Data 47 | deriving (Show, Enum) 48 | 49 | data FieldType 50 | = BasicType BuiltIn 51 | | ListType FieldType 52 | | StructType StructName 53 | 54 | instance Show FieldType where 55 | show (BasicType bi) = show bi 56 | show (ListType ft) = "List(" ++ show ft ++ ")" 57 | show (StructType sn) = show sn 58 | 59 | instance Show Field where 60 | show (FieldDef name order entryType) = 61 | concat 62 | [ show name, 63 | " @", 64 | show order, 65 | " :", 66 | show entryType, 67 | ";\n" 68 | ] 69 | show (StructDef name content) = 70 | concat 71 | [ "struct ", 72 | show name, 73 | " {\n", 74 | concatMap (('\t' :) . show) content, 75 | "}\n\n" 76 | ] 77 | 78 | data Schema = Schema 79 | { schemaId :: String, 80 | schemaContent :: [Field] 81 | } 82 | 83 | instance Show Schema where 84 | show s = 85 | concat 86 | [ "@0x", 87 | schemaId s, 88 | ";\n\n", 89 | concatMap show (schemaContent s) 90 | ] 91 | 92 | -- Helper generators 93 | 94 | genSafeLCChar :: QC.Gen Char 95 | genSafeLCChar = QC.elements ['a' .. 'z'] 96 | 97 | genSafeUCChar :: QC.Gen Char 98 | genSafeUCChar = QC.elements ['A' .. 'Z'] 99 | 100 | genSafeHexChar :: QC.Gen Char 101 | genSafeHexChar = QC.elements (['0' .. '9'] ++ ['a' .. 'f']) 102 | 103 | newtype FieldGen a 104 | = FieldGen (StateT (NonEmpty (Int, Int)) QC.Gen a) 105 | deriving (Functor, Applicative, Monad) 106 | 107 | liftGen :: QC.Gen a -> FieldGen a 108 | liftGen m = FieldGen (lift m) 109 | 110 | runFieldGen :: FieldGen a -> QC.Gen a 111 | runFieldGen (FieldGen m) = fst <$> runStateT m ((0, 0) :| []) 112 | 113 | pushFieldGen :: FieldGen () 114 | pushFieldGen = FieldGen $ modify (NE.cons (0, 0)) 115 | 116 | popFieldGen :: FieldGen () 117 | popFieldGen = FieldGen $ do 118 | original <- get 119 | case original of 120 | (_ :| (y : rest)) -> put (y :| rest) 121 | (x :| []) -> put (x :| []) 122 | 123 | getStructOrder :: FieldGen Int 124 | getStructOrder = FieldGen $ do 125 | current <- get 126 | let (result, _) = NE.head current 127 | case current of 128 | ((x, y) :| rest) -> put ((x + 1, y) :| rest) 129 | return result 130 | 131 | getOrder :: FieldGen Int 132 | getOrder = FieldGen $ do 133 | current <- get 134 | let (_, result) = NE.head current 135 | case current of 136 | ((x, y) :| rest) -> put ((x + 1, y + 1) :| rest) 137 | return result 138 | 139 | -- Field types 140 | 141 | -- need to enumerate each field; this will be performed during struct 142 | -- generation where the number of fields is known (numberDefs) 143 | genFieldDef :: [FieldType] -> FieldGen Field 144 | genFieldDef structTypes = do 145 | order <- getOrder 146 | fieldName <- do 147 | str <- liftGen $ QC.listOf1 genSafeLCChar 148 | return $ FieldName (str ++ show order) 149 | fieldType <- liftGen $ QC.elements (map BasicType [Bool ..] ++ structTypes) 150 | return $ FieldDef fieldName order fieldType 151 | 152 | -- Struct type 153 | 154 | -- like fields, we enumerate each struct during generation for uniqueness 155 | genStructDef :: Int -> FieldGen Field 156 | genStructDef depth = do 157 | order <- getStructOrder 158 | 159 | pushFieldGen 160 | 161 | -- generate the struct's name 162 | structName <- do 163 | fc <- liftGen genSafeUCChar 164 | rest <- liftGen (QC.listOf genSafeLCChar) 165 | return $ StructName ((fc : rest) ++ show order) 166 | 167 | -- generate the nested structs 168 | structNum <- 169 | if depth <= 0 170 | then pure 0 171 | else liftGen (QC.choose (0, 3)) 172 | structDefs <- replicateM structNum (genStructDef (depth - 1)) 173 | 174 | -- extract the available struct types 175 | let structTypes = map (\(StructDef sn _) -> StructType sn) structDefs 176 | 177 | -- generate the fields using available struct types 178 | fieldNum <- liftGen (QC.sized (\n -> QC.choose (1, 1 `max` n))) 179 | fieldDefs <- replicateM fieldNum (genFieldDef structTypes) 180 | 181 | popFieldGen 182 | 183 | return $ StructDef structName (fieldDefs ++ structDefs) 184 | 185 | -- Schema type 186 | genSchema :: QC.Gen Schema 187 | genSchema = do 188 | id1st <- QC.elements ['a' .. 'f'] 189 | idrest <- QC.vectorOf 15 genSafeHexChar 190 | -- multiple structs make tests take too long 191 | content <- runFieldGen (genStructDef 3) 192 | return $ Schema (id1st : idrest) [content] 193 | -------------------------------------------------------------------------------- /capnp-tests/tests/SchemaQuickCheck.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | {-# LANGUAGE TypeApplications #-} 4 | 5 | module SchemaQuickCheck (schemaCGRQuickCheck) where 6 | 7 | import Capnp.Convert (bsToParsed) 8 | import Capnp.Errors (Error) 9 | import qualified Capnp.Gen.Capnp.Schema as Schema 10 | import Capnp.TraversalLimit (defaultLimit, evalLimitT) 11 | -- Testing framework imports 12 | 13 | -- Schema generation imports 14 | 15 | -- Schema validation imports 16 | import Control.Monad.Catch as C 17 | import qualified Data.ByteString as BS 18 | import SchemaGeneration 19 | import Test.Hspec 20 | import Test.QuickCheck 21 | import Util 22 | 23 | -- Functions to generate valid CGRs 24 | 25 | generateCGR :: Schema -> IO BS.ByteString 26 | generateCGR schema = capnpCompile (show schema) "-" 27 | 28 | -- Functions to validate CGRs 29 | 30 | decodeCGR :: BS.ByteString -> IO () 31 | decodeCGR bytes = do 32 | _ <- evalLimitT defaultLimit (bsToParsed @Schema.CodeGeneratorRequest bytes) 33 | pure () 34 | 35 | -- QuickCheck properties 36 | 37 | prop_schemaValid :: Schema -> Property 38 | prop_schemaValid schema = ioProperty $ do 39 | compiled <- generateCGR schema 40 | decoded <- try $ decodeCGR compiled 41 | return $ case (decoded :: Either Error ()) of 42 | Left _ -> False 43 | Right _ -> True 44 | 45 | schemaCGRQuickCheck :: Spec 46 | schemaCGRQuickCheck = 47 | describe "generateCGR an decodeCGR agree" $ 48 | it "successfully decodes generated schema" $ 49 | property $ 50 | prop_schemaValid <$> genSchema 51 | -------------------------------------------------------------------------------- /capnp-tests/tests/Util.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE QuasiQuotes #-} 4 | {-# LANGUAGE TypeFamilies #-} 5 | 6 | module Util 7 | ( MsgMetaData (..), 8 | capnpEncode, 9 | capnpDecode, 10 | capnpCompile, 11 | capnpCanonicalize, 12 | decodeValue, 13 | encodeValue, 14 | aircraftSchemaSrc, 15 | schemaSchemaSrc, 16 | ) 17 | where 18 | 19 | import qualified Capnp.Message as M 20 | import Control.Monad.Trans (lift) 21 | import Control.Monad.Trans.Resource (ResourceT, allocate, runResourceT) 22 | import qualified Data.ByteString as BS 23 | import qualified Data.ByteString.Builder as BB 24 | import qualified Data.ByteString.Lazy as LBS 25 | import qualified Data.ByteString.Lazy.Char8 as LBSC8 26 | import System.Directory (removeFile) 27 | import System.Exit (ExitCode (..)) 28 | import System.IO 29 | import System.Process hiding (readCreateProcessWithExitCode) 30 | import System.Process.ByteString.Lazy (readCreateProcessWithExitCode) 31 | import Text.Heredoc (there) 32 | 33 | aircraftSchemaSrc, schemaSchemaSrc :: String 34 | aircraftSchemaSrc = [there|tests/data/aircraft.capnp|] 35 | schemaSchemaSrc = [there|tests/data/schema.capnp|] 36 | 37 | -- | Information about the contents of a capnp message. This is enough 38 | -- to encode/decode both textual and binary forms. 39 | data MsgMetaData = MsgMetaData 40 | { -- | The source of the schema 41 | msgSchema :: String, 42 | -- | The name of the root struct's type 43 | msgType :: String 44 | } 45 | deriving (Show) 46 | 47 | capnpCanonicalize :: LBS.ByteString -> IO LBS.ByteString 48 | capnpCanonicalize stdInBytes = do 49 | (exitStatus, stdOut, stdErr) <- 50 | readCreateProcessWithExitCode 51 | (proc "capnp" ["convert", "binary:canonical"]) 52 | stdInBytes 53 | case exitStatus of 54 | ExitSuccess -> pure stdOut 55 | ExitFailure code -> 56 | fail $ 57 | concat 58 | [ "capnp convert binary:canonical failed with exit code ", 59 | show code, 60 | ":\n", 61 | show stdErr 62 | ] 63 | 64 | -- | @capnpEncode msg meta@ runs @capnp encode@ on the message, providing 65 | -- the needed metadata and returning the output 66 | capnpEncode :: String -> MsgMetaData -> IO BS.ByteString 67 | capnpEncode msgValue meta = do 68 | (exitStatus, stdOut, stdErr) <- 69 | runResourceT $ 70 | interactCapnpWithSchema "encode" (msgSchema meta) (LBSC8.pack msgValue) [msgType meta] 71 | case exitStatus of 72 | ExitSuccess -> return (LBS.toStrict stdOut) 73 | ExitFailure code -> fail ("`capnp encode` failed with exit code " ++ show code ++ ":\n" ++ show stdErr) 74 | 75 | -- | @capnpDecode msg meta@ runs @capnp decode@ on the message, providing 76 | -- the needed metadata and returning the output 77 | capnpDecode :: BS.ByteString -> MsgMetaData -> IO String 78 | capnpDecode encodedMsg meta = do 79 | (exitStatus, stdOut, stdErr) <- 80 | runResourceT $ 81 | interactCapnpWithSchema "decode" (msgSchema meta) (LBS.fromStrict encodedMsg) [msgType meta] 82 | case exitStatus of 83 | ExitSuccess -> return (LBSC8.unpack stdOut) 84 | ExitFailure code -> fail ("`capnp decode` failed with exit code " ++ show code ++ ":\n" ++ show stdErr) 85 | 86 | -- | @capnpCompile msg meta@ runs @capnp compile@ on the schema, providing 87 | -- the needed metadata and returning the output 88 | capnpCompile :: String -> String -> IO BS.ByteString 89 | capnpCompile msgSchema outputArg = do 90 | (exitStatus, stdOut, stdErr) <- 91 | runResourceT $ 92 | interactCapnpWithSchema "compile" msgSchema LBSC8.empty ["-o", outputArg] 93 | case exitStatus of 94 | ExitSuccess -> return (LBS.toStrict stdOut) 95 | ExitFailure code -> fail ("`capnp compile` failed with exit code " ++ show code ++ ":\n" ++ show stdErr) 96 | 97 | -- | A helper for @capnpEncode@ and @capnpDecode@. Launches the capnp command 98 | -- with the given subcommand (either "encode" or "decode") and metadata, 99 | -- returning handles to its standard in and standard out. This runs inside 100 | -- ResourceT, and sets the handles up to be closed and the process to be reaped 101 | -- when the ResourceT exits. 102 | interactCapnpWithSchema :: String -> String -> LBS.ByteString -> [String] -> ResourceT IO (ExitCode, LBS.ByteString, LBS.ByteString) 103 | interactCapnpWithSchema subCommand msgSchema stdInBytes args = do 104 | let writeTempFile = runResourceT $ do 105 | (_, (path, hndl)) <- 106 | allocate 107 | (openTempFile "/tmp" "schema.capnp") 108 | (\(_, hndl) -> hClose hndl) 109 | lift $ hPutStr hndl msgSchema 110 | return path 111 | schemaFile <- snd <$> allocate writeTempFile removeFile 112 | lift $ readCreateProcessWithExitCode (proc "capnp" ([subCommand, schemaFile] ++ args)) stdInBytes 113 | 114 | -- | @'decodeValue' schema typename message@ decodes the value at the root of 115 | -- the message and converts it to text. This is a thin wrapper around 116 | -- 'capnpDecode'. 117 | decodeValue :: String -> String -> M.Message 'M.Const -> IO String 118 | decodeValue schema typename msg = 119 | let bytes = M.encode msg 120 | in capnpDecode 121 | (LBS.toStrict $ BB.toLazyByteString bytes) 122 | (MsgMetaData schema typename) 123 | 124 | -- | @'encodeValue' schema typename value@ encodes the textual value @value@ 125 | -- as a capnp message. This is a thin wrapper around 'capnpEncode'. 126 | encodeValue :: String -> String -> String -> IO (M.Message 'M.Const) 127 | encodeValue schema typename value = 128 | let meta = MsgMetaData schema typename 129 | in capnpEncode value meta >>= M.decode 130 | -------------------------------------------------------------------------------- /capnp-tests/tests/WalkSchemaCodeGenRequest.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE OverloadedLabels #-} 4 | {-# LANGUAGE OverloadedStrings #-} 5 | {-# LANGUAGE ScopedTypeVariables #-} 6 | {-# LANGUAGE TypeFamilies #-} 7 | 8 | -- | This module defines a test that tries to walk over the 9 | -- CodeGeneratorRequest in `tests/data/schema-codegenreq`, 10 | -- failing if any of the data is not as expected. 11 | module WalkSchemaCodeGenRequest (walkSchemaCodeGenRequestTest) where 12 | 13 | import Capnp 14 | ( Raw, 15 | bsToRaw, 16 | hasField, 17 | index, 18 | length, 19 | parseField, 20 | readField, 21 | textBytes, 22 | ) 23 | import qualified Capnp.Gen.Capnp.Schema as Schema 24 | import qualified Capnp.Message as M 25 | import Capnp.TraversalLimit (LimitT, evalLimitT, execLimitT) 26 | import Control.Monad (when) 27 | import Control.Monad.Trans.Class (lift) 28 | import qualified Data.ByteString as BS 29 | import Data.Function ((&)) 30 | import qualified Data.Vector as V 31 | import Test.Hspec 32 | import Prelude hiding (length) 33 | 34 | nodeNames :: V.Vector BS.ByteString 35 | nodeNames = 36 | V.fromList 37 | [ "Import", 38 | "annotation", 39 | "Value", 40 | "Type" 41 | ] 42 | 43 | -- TODO: This contains a bit of copypasta from some of the untyped tests; should 44 | -- factor that out. 45 | walkSchemaCodeGenRequestTest :: Spec 46 | walkSchemaCodeGenRequestTest = 47 | describe "Various sanity checks on a known schema CodeGeneratorRequest" $ 48 | it "Should match misc. expectations" $ do 49 | -- TODO: the above description betrays that this test isn't 50 | -- especially well defined at a granularity that I(zenhack) 51 | -- know how to tell hspec about, because there are data 52 | -- dependencies between conceptual tests (we walk over the 53 | -- data checking various things as we go). 54 | -- 55 | -- It would be nice if we could mark off individual checks for 56 | -- hspec's reporting somehow. 57 | bytes <- BS.readFile "tests/data/schema-codegenreq" 58 | root <- evalLimitT maxBound (bsToRaw bytes) 59 | endQuota <- execLimitT 4096 (reader root) 60 | endQuota `shouldBe` 3409 61 | where 62 | reader :: Raw Schema.CodeGeneratorRequest 'M.Const -> LimitT IO () 63 | reader req = do 64 | nodes <- req & readField #nodes 65 | requestedFiles <- req & readField #requestedFiles 66 | lift $ length nodes `shouldBe` 37 67 | lift $ length requestedFiles `shouldBe` 1 68 | mapM_ (walkNode nodes) [0, 1 .. 36] 69 | walkNode nodes i = do 70 | node <- index i nodes 71 | -- None of the nodes in the schema have parameters: 72 | False <- node & hasField #parameters 73 | -- And none of them are generic: 74 | False <- node & parseField #isGeneric 75 | 76 | nameList <- node & readField #displayName 77 | name <- textBytes nameList 78 | prefixLen <- parseField #displayNamePrefixLength node 79 | let baseName = BS.drop (fromIntegral prefixLen) name 80 | 81 | when (i < V.length nodeNames && baseName /= (nodeNames V.! i)) $ 82 | error "Incorrect name." 83 | 84 | has <- node & hasField #annotations 85 | 86 | -- there are two annotations in all of the nodes, at these indicies: 87 | case (has, i `elem` [4, 9]) of 88 | (False, False) -> return () 89 | (True, True) -> do 90 | 1 <- length <$> readField #annotations node 91 | return () 92 | (False, True) -> 93 | error $ 94 | "Node at index " 95 | ++ show i 96 | ++ " should have had" 97 | ++ "an annotation." 98 | (True, False) -> 99 | error $ 100 | "Node at index " 101 | ++ show i 102 | ++ " should not " 103 | ++ "have had an annotation." 104 | -------------------------------------------------------------------------------- /capnp-tests/tests/data/README.md: -------------------------------------------------------------------------------- 1 | This directory contains data for use with the test suite: 2 | 3 | * `aircraft.capnp` is a schema with many useful datatypes 4 | * `schema-codegenreq` is the output of 5 | `capnp compile /usr/include/capnp/schema.capnp -o-`. It would be nice 6 | to keep this in textual form and convert it with capnp encode, so it 7 | could be viewed more easily, but unfortunately it contains 8 | `AnyPointer`s, so `capnp decode` -> `capnp encode` fails. 9 | -------------------------------------------------------------------------------- /capnp-tests/tests/data/generics.capnp: -------------------------------------------------------------------------------- 1 | @0xb6421fb8e478d144; 2 | # Schema used for testing generics support. 3 | 4 | struct Maybe(T) { 5 | union { 6 | nothing @0 :Void; 7 | just @1 :T; 8 | } 9 | } 10 | 11 | struct Either(A, B) { 12 | union { 13 | left @0 :A; 14 | right @1 :B; 15 | } 16 | } 17 | 18 | struct Pair(A, B) { 19 | fst @0 :A; 20 | snd @1 :B; 21 | } 22 | 23 | struct Nested(T) { 24 | struct SomeStruct { 25 | value @0 :T; 26 | } 27 | 28 | interface SomeInterface { 29 | method @0 (arg :T) -> (result :T); 30 | } 31 | } 32 | 33 | struct Specialized(T) { 34 | either @0 :Either(Text, T); 35 | nestedStruct @1 :Nested(Data).SomeStruct; 36 | } 37 | 38 | struct HasGroup(T) { 39 | theGroup :group { 40 | value @0 :T; 41 | } 42 | } 43 | -------------------------------------------------------------------------------- /capnp-tests/tests/data/schema-codegenreq: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/zenhack/haskell-capnp/15b89a2de4c5b897b35783ede25fa645d310e5a7/capnp-tests/tests/data/schema-codegenreq -------------------------------------------------------------------------------- /capnp/cmd/capnpc-haskell/Check.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DuplicateRecordFields #-} 2 | {-# LANGUAGE NamedFieldPuns #-} 3 | 4 | module Check (reportIssues) where 5 | 6 | import Capnp.Gen.Capnp.Schema 7 | import Data.Foldable (for_) 8 | import System.IO (hPutStrLn, stderr) 9 | 10 | -- | Scan the code generator request for certain issues, and warn the user 11 | -- if found. 12 | -- 13 | -- We still assume the input is *valid*, so these are issues regarding things 14 | -- that our implementation can't handle. 15 | reportIssues :: Parsed CodeGeneratorRequest -> IO () 16 | reportIssues CodeGeneratorRequest {nodes} = 17 | let problemFields = 18 | [ (displayName, name) 19 | | Node {displayName, union' = Node'struct Node'struct' {fields}} <- nodes, 20 | Field 21 | { name, 22 | union' = Field'slot Field'slot' {hadExplicitDefault, defaultValue} 23 | } <- 24 | fields, 25 | hadExplicitDefault && isPtrValue defaultValue 26 | ] 27 | in for_ problemFields $ \(displayName, name) -> 28 | hPutStrLn stderr $ 29 | concat 30 | [ "WARNING: the field ", 31 | show name, 32 | " in ", 33 | show displayName, 34 | "\n", 35 | " has a custom default value, but haskell-capnp does not\n", 36 | " support this for pointer-valued fields. The custom\n", 37 | " default will be ignored; please be careful. See:\n", 38 | "\n", 39 | "https://codeberg.org/zenhack/haskell-capnp/issues/28\n", 40 | "\n", 41 | "for more information.\n" 42 | ] 43 | 44 | isPtrValue :: Parsed Value -> Bool 45 | isPtrValue (Value v) = case v of 46 | Value'void -> False 47 | Value'bool _ -> False 48 | Value'int8 _ -> False 49 | Value'int16 _ -> False 50 | Value'int32 _ -> False 51 | Value'int64 _ -> False 52 | Value'uint8 _ -> False 53 | Value'uint16 _ -> False 54 | Value'uint32 _ -> False 55 | Value'uint64 _ -> False 56 | Value'float32 _ -> False 57 | Value'float64 _ -> False 58 | Value'enum _ -> False 59 | _ -> True 60 | -------------------------------------------------------------------------------- /capnp/cmd/capnpc-haskell/IR/AbstractOp.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DuplicateRecordFields #-} 2 | 3 | module IR.AbstractOp where 4 | 5 | import qualified Capnp.Repr as R 6 | import Data.Word 7 | import qualified IR.Common as C 8 | import qualified IR.Name as Name 9 | 10 | type Brand = C.ListBrand Name.CapnpQ 11 | 12 | data File = File 13 | { fileId :: !Word64, 14 | decls :: [Decl], 15 | fileName :: FilePath, 16 | usesRpc :: !Bool 17 | } 18 | 19 | data Decl 20 | = TypeDecl 21 | { name :: Name.LocalQ, 22 | nodeId :: !Word64, 23 | params :: [Name.UnQ], 24 | repr :: R.Repr, 25 | extraTypeInfo :: Maybe ExtraTypeInfo 26 | } 27 | | FieldDecl 28 | { containerType :: Name.LocalQ, 29 | typeParams :: [Name.UnQ], 30 | fieldName :: Name.UnQ, 31 | fieldLocType :: C.FieldLocType Brand Name.CapnpQ 32 | } 33 | | UnionDecl 34 | { name :: Name.LocalQ, 35 | typeParams :: [Name.UnQ], 36 | tagLoc :: C.DataLoc, 37 | variants :: [UnionVariant] 38 | } 39 | | MethodDecl 40 | { interfaceName :: Name.LocalQ, 41 | interfaceId :: !Word64, 42 | methodId :: !Word16, 43 | methodInfo :: MethodInfo 44 | } 45 | | SuperDecl 46 | { subName :: Name.LocalQ, 47 | typeParams :: [Name.UnQ], 48 | superType :: C.InterfaceType Brand Name.CapnpQ 49 | } 50 | | ParsedInstanceDecl 51 | { typeName :: Name.LocalQ, 52 | typeParams :: [Name.UnQ], 53 | parsedInstances :: ParsedInstances 54 | } 55 | | ConstDecl 56 | { name :: Name.LocalQ, 57 | value :: C.Value Brand Name.CapnpQ 58 | } 59 | 60 | -- | Data needed for declaring a Parsed instance, and instances 61 | -- of related classes. 62 | data ParsedInstances 63 | = ParsedStruct 64 | { fields :: [(Name.UnQ, C.FieldLocType Brand Name.CapnpQ)], 65 | hasUnion :: !Bool, 66 | dataCtorName :: Name.LocalQ 67 | } 68 | | ParsedUnion 69 | { variants :: [(Name.UnQ, C.FieldLocType Brand Name.CapnpQ)] 70 | } 71 | 72 | data MethodInfo = MethodInfo 73 | { typeParams :: [Name.UnQ], 74 | methodName :: Name.UnQ, 75 | paramType :: C.CompositeType Brand Name.CapnpQ, 76 | resultType :: C.CompositeType Brand Name.CapnpQ 77 | } 78 | 79 | data ExtraTypeInfo 80 | = StructTypeInfo 81 | { nWords :: !Word16, 82 | nPtrs :: !Word16 83 | } 84 | | EnumTypeInfo [Name.UnQ] 85 | | InterfaceTypeInfo 86 | { methods :: [MethodInfo], 87 | supers :: [C.InterfaceType Brand Name.CapnpQ] 88 | } 89 | 90 | data UnionVariant = UnionVariant 91 | { variantName :: Name.UnQ, 92 | tagValue :: !Word16, 93 | fieldLocType :: C.FieldLocType Brand Name.CapnpQ 94 | } 95 | -------------------------------------------------------------------------------- /capnp/cmd/capnpc-haskell/IR/Flat.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DuplicateRecordFields #-} 2 | 3 | module IR.Flat 4 | ( File (..), 5 | CodeGenReq (..), 6 | Node (..), 7 | Node' (..), 8 | Field (..), 9 | Method (..), 10 | Variant (..), 11 | Union (..), 12 | ) 13 | where 14 | 15 | import Data.Word 16 | import qualified IR.Common as Common 17 | import qualified IR.Name as Name 18 | 19 | type Brand = Common.ListBrand Node 20 | 21 | data CodeGenReq = CodeGenReq 22 | { allNodes :: [Node], 23 | reqFiles :: [File] 24 | } 25 | deriving (Show, Eq) 26 | 27 | data File = File 28 | { nodes :: [Node], 29 | fileId :: !Word64, 30 | fileName :: FilePath 31 | } 32 | deriving (Show, Eq) 33 | 34 | data Node = Node 35 | { name :: Name.CapnpQ, 36 | nodeId :: !Word64, 37 | union_ :: Node', 38 | typeParams :: [Common.TypeParamRef Node] 39 | } 40 | deriving (Show, Eq) 41 | 42 | data Node' 43 | = Enum [Name.UnQ] 44 | | Struct 45 | { -- | The struct's fields, excluding an anonymous union, if any. 46 | fields :: [Field], 47 | isGroup :: !Bool, 48 | dataWordCount :: !Word16, 49 | pointerCount :: !Word16, 50 | -- | The struct's anonymous union, if any. 51 | union :: Maybe Union 52 | } 53 | | Interface 54 | { methods :: [Method], 55 | supers :: [Common.InterfaceType Brand Node] 56 | } 57 | | Constant 58 | { value :: Common.Value Brand Node 59 | } 60 | | Other 61 | deriving (Show, Eq) 62 | 63 | data Method = Method 64 | { name :: Name.UnQ, 65 | paramType :: Common.CompositeType Brand Node, 66 | resultType :: Common.CompositeType Brand Node 67 | } 68 | deriving (Show, Eq) 69 | 70 | data Union = Union 71 | { tagOffset :: !Word32, 72 | variants :: [Variant] 73 | } 74 | deriving (Show, Eq) 75 | 76 | data Field = Field 77 | { fieldName :: Name.CapnpQ, 78 | fieldLocType :: Common.FieldLocType Brand Node 79 | } 80 | deriving (Show, Eq) 81 | 82 | data Variant = Variant 83 | { tagValue :: !Word16, 84 | -- | The field's name is really the name of the variant. 85 | field :: Field 86 | } 87 | deriving (Show, Eq) 88 | -------------------------------------------------------------------------------- /capnp/cmd/capnpc-haskell/IR/Name.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DuplicateRecordFields #-} 2 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 3 | {-# LANGUAGE NamedFieldPuns #-} 4 | {-# LANGUAGE OverloadedStrings #-} 5 | {-# LANGUAGE RecordWildCards #-} 6 | 7 | module IR.Name where 8 | 9 | import Data.Char (toLower) 10 | import Data.List (intersperse) 11 | import qualified Data.Set as S 12 | import Data.String (IsString (fromString)) 13 | import qualified Data.Text as T 14 | import Data.Word 15 | 16 | class HasUnQ a where 17 | getUnQ :: a -> UnQ 18 | 19 | class MkSub a where 20 | mkSub :: a -> UnQ -> a 21 | 22 | instance HasUnQ UnQ where 23 | getUnQ = id 24 | 25 | instance HasUnQ LocalQ where 26 | getUnQ = localUnQ 27 | 28 | instance HasUnQ CapnpQ where 29 | getUnQ CapnpQ {local} = getUnQ local 30 | 31 | instance HasUnQ GlobalQ where 32 | getUnQ GlobalQ {local} = getUnQ local 33 | 34 | newtype UnQ = UnQ T.Text 35 | deriving (Show, Read, Eq, Ord, IsString, Semigroup) 36 | 37 | newtype NS = NS [T.Text] 38 | deriving (Show, Read, Eq, Ord) 39 | 40 | data LocalQ = LocalQ 41 | { localUnQ :: UnQ, 42 | localNS :: NS 43 | } 44 | deriving (Show, Read, Eq, Ord) 45 | 46 | instance IsString LocalQ where 47 | fromString s = 48 | LocalQ 49 | { localUnQ = fromString s, 50 | localNS = emptyNS 51 | } 52 | 53 | -- | A fully qualified name for something defined in a capnproto schema. 54 | -- this includes a local name within a file, and the file's capnp id. 55 | data CapnpQ = CapnpQ 56 | { local :: LocalQ, 57 | fileId :: !Word64 58 | } 59 | deriving (Show, Read, Eq, Ord) 60 | 61 | data GlobalQ = GlobalQ 62 | { local :: LocalQ, 63 | globalNS :: NS 64 | } 65 | deriving (Show, Read, Eq, Ord) 66 | 67 | emptyNS :: NS 68 | emptyNS = NS [] 69 | 70 | mkLocal :: NS -> UnQ -> LocalQ 71 | mkLocal localNS localUnQ = LocalQ {localNS, localUnQ} 72 | 73 | unQToLocal :: UnQ -> LocalQ 74 | unQToLocal = mkLocal emptyNS 75 | 76 | instance MkSub LocalQ where 77 | mkSub q = mkLocal (localQToNS q) 78 | 79 | instance MkSub GlobalQ where 80 | mkSub GlobalQ {local, ..} unQ = GlobalQ {local = mkSub local unQ, ..} 81 | 82 | instance MkSub CapnpQ where 83 | mkSub CapnpQ {local, ..} unQ = CapnpQ {local = mkSub local unQ, ..} 84 | 85 | localQToNS :: LocalQ -> NS 86 | localQToNS LocalQ {localUnQ = UnQ part, localNS = NS parts} = NS (part : parts) 87 | 88 | localToUnQ :: LocalQ -> UnQ 89 | localToUnQ LocalQ {localUnQ, localNS} 90 | | localNS == emptyNS = localUnQ 91 | | otherwise = UnQ (renderLocalNS localNS <> "'" <> renderUnQ localUnQ) 92 | 93 | renderUnQ :: UnQ -> T.Text 94 | renderUnQ (UnQ name) 95 | | name `S.member` keywords = name <> "_" 96 | | otherwise = name 97 | where 98 | keywords = 99 | S.fromList 100 | [ "as", 101 | "case", 102 | "of", 103 | "class", 104 | "data", 105 | "family", 106 | "instance", 107 | "default", 108 | "deriving", 109 | "do", 110 | "forall", 111 | "foreign", 112 | "hiding", 113 | "if", 114 | "then", 115 | "else", 116 | "import", 117 | "infix", 118 | "infixl", 119 | "infixr", 120 | "let", 121 | "in", 122 | "mdo", 123 | "module", 124 | "newtype", 125 | "proc", 126 | "qualified", 127 | "rec", 128 | "type", 129 | "where" 130 | ] 131 | 132 | renderLocalQ :: LocalQ -> T.Text 133 | renderLocalQ = renderUnQ . localToUnQ 134 | 135 | renderLocalNS :: NS -> T.Text 136 | renderLocalNS (NS parts) = mconcat $ intersperse "'" $ reverse parts 137 | 138 | getterName, setterName, hasFnName, newFnName :: LocalQ -> UnQ 139 | getterName = accessorName "get_" 140 | setterName = accessorName "set_" 141 | hasFnName = accessorName "has_" 142 | newFnName = accessorName "new_" 143 | 144 | accessorName :: T.Text -> LocalQ -> UnQ 145 | accessorName prefix = UnQ . (prefix <>) . renderLocalQ 146 | 147 | -- | Lower-case the first letter of a name, making it legal as the name of a 148 | -- variable (as opposed to a type or data constructor). 149 | valueName :: LocalQ -> UnQ 150 | valueName = lowerFstName 151 | 152 | typeVarName :: UnQ -> T.Text 153 | typeVarName (UnQ txt) = lowerFst txt 154 | 155 | -- | Lower-case the first letter of a name 156 | lowerFstName :: LocalQ -> UnQ 157 | lowerFstName name = UnQ $ lowerFst $ renderLocalQ name 158 | 159 | lowerFst :: T.Text -> T.Text 160 | lowerFst txt = case T.unpack txt of 161 | [] -> "" 162 | (c : cs) -> T.pack $ toLower c : cs 163 | -------------------------------------------------------------------------------- /capnp/cmd/capnpc-haskell/IR/Pure.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DuplicateRecordFields #-} 2 | 3 | module IR.Pure where 4 | 5 | import Data.Word 6 | import qualified IR.Common as C 7 | import qualified IR.Name as Name 8 | 9 | type Brand = C.ListBrand Name.CapnpQ 10 | 11 | data File = File 12 | { fileId :: !Word64, 13 | fileName :: FilePath, 14 | decls :: [Decl], 15 | -- | A list of enums that we should re-export from this module. 16 | reExportEnums :: [Name.LocalQ], 17 | -- | Whether or not the module uses rpc features. If not, we skip 18 | -- the rpc related imports. This is mainly important to avoid a 19 | -- cyclic dependency with rpc.capnp. 20 | usesRpc :: !Bool 21 | } 22 | 23 | data Decl 24 | = DataDecl Data 25 | | ConstDecl Constant 26 | | IFaceDecl Interface 27 | 28 | data Data = Data 29 | { typeName :: Name.LocalQ, 30 | typeParams :: [Name.UnQ], 31 | -- | Whether this is a "first class" type, i.e. it is a type in the 32 | -- capnproto sense, rather than an auxiliary type defined for a group 33 | -- or an anonymous union. 34 | -- 35 | -- Note that this *can* be set for unions, if they subsume the whole 36 | -- struct, since in that case we collapse the two types in the 37 | -- high-level API. 38 | firstClass :: !Bool, 39 | -- | The name of the type our 'Cerial' should be. This will only be 40 | -- different from typeName if we're an anonymous union in a struct 41 | -- that also has other fields; in this case our Cerial should be 42 | -- the same as our parent struct. 43 | cerialName :: Name.LocalQ, 44 | def :: DataDef 45 | } 46 | 47 | data DataDef 48 | = Sum [Variant] 49 | | Product [Field] 50 | 51 | data Constant = Constant 52 | { name :: Name.LocalQ, 53 | value :: C.Value Brand Name.CapnpQ 54 | } 55 | 56 | data Interface = IFace 57 | { name :: Name.CapnpQ, 58 | typeParams :: [C.TypeParamRef Name.CapnpQ], 59 | interfaceId :: !Word64, 60 | methods :: [Method], 61 | -- | Immediate superclasses 62 | supers :: [(Interface, Brand)], 63 | -- | All ancestors, including 'supers'. 64 | ancestors :: [(Interface, Brand)] 65 | } 66 | 67 | -- TODO(cleanup): this same type exists in IR.Flat; it doesn't make sense for 68 | -- IR.Common, but we should factor this out. 69 | data Method = Method 70 | { name :: Name.UnQ, 71 | paramType :: C.CompositeType Brand Name.CapnpQ, 72 | resultType :: C.CompositeType Brand Name.CapnpQ 73 | } 74 | 75 | data Field = Field 76 | { -- | The name of the field. 77 | name :: Name.UnQ, 78 | -- | The type of the field. 79 | type_ :: C.Type Brand Name.CapnpQ 80 | } 81 | 82 | data Variant = Variant 83 | { name :: Name.LocalQ, 84 | arg :: Maybe (C.Type Brand Name.CapnpQ) 85 | } 86 | -------------------------------------------------------------------------------- /capnp/cmd/capnpc-haskell/IR/Raw.hs: -------------------------------------------------------------------------------- 1 | -- IR for a high-level representation of the low-level API modules. 2 | -- 3 | -- This talks about things like getters, setters, wrapper types for structs, 4 | -- etc. It's still not at the level of detail of actual Haskell, but encodes 5 | -- the constructs to be generated, as opposed to the declarative description 6 | -- of the schema. 7 | {-# LANGUAGE DuplicateRecordFields #-} 8 | 9 | module IR.Raw (File (..), Decl (..), Variant (..), TagSetter (..), NewFnType (..), tagOffsetToDataLoc) where 10 | 11 | import Data.Word 12 | import qualified IR.Common as Common 13 | import qualified IR.Name as Name 14 | 15 | type Brand = Common.ListBrand Name.CapnpQ 16 | 17 | data File = File 18 | { fileId :: !Word64, 19 | fileName :: FilePath, 20 | decls :: [Decl] 21 | } 22 | deriving (Show, Eq) 23 | 24 | data Decl 25 | = -- | Define a newtype wrapper around a struct. This also defines 26 | -- some instances of type classes that exist for all such wrappers. 27 | StructWrapper 28 | { typeCtor :: Name.LocalQ, 29 | typeParams :: [Name.UnQ] 30 | } 31 | | -- | Define instances of several type classes which should only 32 | -- exist for "real" structs, i.e. not groups. 33 | StructInstances 34 | { -- | The type constructor for the type to generate instances for. 35 | typeCtor :: Name.LocalQ, 36 | typeParams :: [Name.UnQ], 37 | -- Needed for some instances: 38 | dataWordCount :: !Word16, 39 | pointerCount :: !Word16 40 | } 41 | | InterfaceWrapper 42 | { typeCtor :: Name.LocalQ, 43 | typeParams :: [Name.UnQ] 44 | } 45 | | UnionVariant 46 | { -- | The type constructor of the parent, i.e. the enclosing struct. 47 | -- we can derive the type constructor for the union proper from this, 48 | -- and it is useful to have for other things (like unknown' variants). 49 | parentTypeCtor :: Name.LocalQ, 50 | tagOffset :: !Word32, 51 | typeParams :: [Name.UnQ], 52 | unionDataCtors :: [Variant] 53 | } 54 | | Enum 55 | { typeCtor :: Name.LocalQ, 56 | dataCtors :: [Name.LocalQ] 57 | } 58 | | Getter -- get_* function 59 | { fieldName :: Name.LocalQ, 60 | containerType :: Name.LocalQ, 61 | typeParams :: [Name.UnQ], 62 | fieldLocType :: Common.FieldLocType Brand Name.CapnpQ 63 | } 64 | | Setter -- set_* function 65 | { fieldName :: Name.LocalQ, 66 | containerType :: Name.LocalQ, 67 | typeParams :: [Name.UnQ], 68 | fieldLocType :: Common.FieldLocType Brand Name.CapnpQ, 69 | -- | Info for setting the tag, if this is a union. 70 | tag :: Maybe TagSetter 71 | } 72 | | HasFn -- has_* function 73 | { fieldName :: Name.LocalQ, 74 | containerType :: Name.LocalQ, 75 | typeParams :: [Name.UnQ], 76 | ptrIndex :: !Word16 77 | } 78 | | NewFn -- new_* function 79 | { fieldName :: Name.LocalQ, 80 | containerType :: Name.LocalQ, 81 | typeParams :: [Name.UnQ], 82 | fieldLocType :: Common.FieldLocType Brand Name.CapnpQ, 83 | newFnType :: NewFnType 84 | } 85 | | Constant 86 | { name :: Name.LocalQ, 87 | value :: Common.Value Brand Name.CapnpQ 88 | } 89 | deriving (Show, Eq) 90 | 91 | data NewFnType 92 | = NewList 93 | | NewText 94 | | NewData 95 | | NewStruct 96 | deriving (Show, Eq) 97 | 98 | data TagSetter = TagSetter 99 | { tagOffset :: !Word32, 100 | tagValue :: !Word16 101 | } 102 | deriving (Show, Eq) 103 | 104 | -- | Convert a tag offset (as in the 'tagOffset' field of 'TagSetter') to a 105 | -- corresponding 'Common.DataLoc', with the default value set to zero. 106 | tagOffsetToDataLoc :: Word32 -> Common.DataLoc 107 | tagOffsetToDataLoc tagOffset = 108 | Common.DataLoc 109 | { dataIdx = fromIntegral tagOffset `div` 4, 110 | dataOff = (fromIntegral tagOffset `mod` 4) * 16, 111 | dataDef = 0 112 | } 113 | 114 | data Variant = Variant 115 | { name :: Name.LocalQ, 116 | tagValue :: !Word16, 117 | locType :: Common.FieldLocType Brand Name.CapnpQ 118 | } 119 | deriving (Show, Eq) 120 | -------------------------------------------------------------------------------- /capnp/cmd/capnpc-haskell/IR/Stage1.hs: -------------------------------------------------------------------------------- 1 | -- First stage IR. This models the data structures in schema.capnp more closely 2 | -- than the other intermediate forms. Differences: 3 | -- 4 | -- \* Lots of information which we won't use is discarded. 5 | -- \* Nodes no longer reference eachother by ID; instead we include direct 6 | -- references to the objects. 7 | -- \* The details of some structures are tweaked to make them more ergonomic 8 | -- to use and/or more idiomatic Haskell. 9 | {-# LANGUAGE DuplicateRecordFields #-} 10 | 11 | module IR.Stage1 12 | ( File (..), 13 | ReqFile (..), 14 | Interface (..), 15 | Method (..), 16 | Node (..), 17 | NodeCommon (..), 18 | NodeUnion (..), 19 | Struct (..), 20 | Field (..), 21 | CodeGenReq (..), 22 | Brand, 23 | ) 24 | where 25 | 26 | import Data.Word 27 | import qualified IR.Common as Common 28 | import qualified IR.Name as Name 29 | 30 | type Brand = Common.MapBrand Node 31 | 32 | data CodeGenReq = CodeGenReq 33 | { reqFiles :: [ReqFile], 34 | allFiles :: [File] 35 | } 36 | 37 | data ReqFile = ReqFile 38 | { file :: File, 39 | fileName :: FilePath 40 | } 41 | 42 | data File = File 43 | { fileNodes :: [(Name.UnQ, Node)], 44 | fileId :: !Word64 45 | } 46 | deriving (Show, Eq) 47 | 48 | data Node = Node 49 | { nodeCommon :: NodeCommon, 50 | nodeUnion :: NodeUnion 51 | } 52 | deriving (Show, Eq) 53 | 54 | data NodeCommon = NodeCommon 55 | { nodeNested :: [(Name.UnQ, Node)], 56 | nodeParent :: Maybe Node, 57 | nodeId :: !Word64, 58 | nodeParams :: [Name.UnQ] 59 | } 60 | deriving (Show, Eq) 61 | 62 | data NodeUnion 63 | = NodeEnum [Name.UnQ] 64 | | NodeStruct Struct 65 | | NodeInterface Interface 66 | | NodeConstant (Common.Value Brand Node) 67 | | NodeOther 68 | deriving (Show, Eq) 69 | 70 | data Interface = Interface 71 | { methods :: [Method], 72 | supers :: [Common.InterfaceType Brand Node] 73 | } 74 | deriving (Show, Eq) 75 | 76 | data Method = Method 77 | { name :: Name.UnQ, 78 | paramType :: Common.CompositeType Brand Node, 79 | resultType :: Common.CompositeType Brand Node 80 | } 81 | deriving (Show, Eq) 82 | 83 | data Struct = Struct 84 | { dataWordCount :: !Word16, 85 | pointerCount :: !Word16, 86 | isGroup :: !Bool, 87 | tagOffset :: !Word32, 88 | fields :: [Field] 89 | } 90 | deriving (Show, Eq) 91 | 92 | data Field = Field 93 | { name :: Name.UnQ, 94 | tag :: Maybe Word16, 95 | locType :: Common.FieldLocType Brand Node 96 | } 97 | deriving (Show, Eq) 98 | -------------------------------------------------------------------------------- /capnp/cmd/capnpc-haskell/Main.hs: -------------------------------------------------------------------------------- 1 | -- This module is the main entry point for the capnpc-haskell code 2 | -- generator plugin. 3 | module Main (main) where 4 | 5 | import Capnp (Parsed, defaultLimit, getParsed) 6 | import Capnp.Gen.Capnp.Schema (CodeGeneratorRequest) 7 | import qualified Check 8 | import Control.Category ((>>>)) 9 | import Data.Foldable (for_) 10 | import qualified Data.Text.Lazy as LT 11 | import qualified Data.Text.Lazy.IO as TIO 12 | import qualified IR.Haskell as Haskell 13 | import System.Directory (createDirectoryIfMissing) 14 | import System.FilePath (takeDirectory) 15 | import System.IO (IOMode (WriteMode), withFile) 16 | import qualified Trans.AbstractOpToHaskell 17 | import qualified Trans.CgrToStage1 18 | import qualified Trans.FlatToAbstractOp 19 | import qualified Trans.HaskellToText 20 | import qualified Trans.Stage1ToFlat 21 | 22 | main :: IO () 23 | main = do 24 | cgr <- getParsed defaultLimit 25 | Check.reportIssues cgr 26 | for_ (handleCGR cgr) $ \(path, contents) -> do 27 | createDirectoryIfMissing True (takeDirectory path) 28 | withFile path WriteMode $ \h -> 29 | TIO.hPutStr h contents 30 | 31 | -- | Convert a 'CodeGeneratorRequest' to a list of files to create. 32 | handleCGR :: Parsed CodeGeneratorRequest -> [(FilePath, LT.Text)] 33 | handleCGR = 34 | Trans.CgrToStage1.cgrToCgr 35 | >>> Trans.Stage1ToFlat.cgrToCgr 36 | >>> Trans.FlatToAbstractOp.cgrToFiles 37 | >>> concatMap Trans.AbstractOpToHaskell.fileToModules 38 | >>> map 39 | ( \mod -> 40 | ( Haskell.modFilePath mod, 41 | Trans.HaskellToText.moduleToText mod 42 | ) 43 | ) 44 | -------------------------------------------------------------------------------- /capnp/cmd/capnpc-haskell/README.md: -------------------------------------------------------------------------------- 1 | This directory contains the code generator plugin, which is run when you 2 | do `capnp compile -o haskell`. This document provides a high-level 3 | overview of its internals. 4 | 5 | Like all capnproto code generator plugins, it accepts a 6 | capnproto-serialized `CodeGenratorRequest` (defined in `schema.capnp`) 7 | on standard input, and emits code accordingly. For an overview on *what* 8 | exactly is emitted, see `Capnp.Tutorial`. 9 | 10 | The data read from standard input transitions through several 11 | intermediate forms before finally being written out to disk as Haskell 12 | source code. The `IR/` subdirectory defines the intermediate forms 13 | themselves, while each transition is defined in a module under `Trans/`. 14 | `Main` ties ties the whole thing together. 15 | 16 | # The Pipeline 17 | 18 | 19 | ``` 20 | CGR ---> Stage1 ---> Flat ---> NEW ---> Haskell (IR) --> Haskell (source code) 21 | ``` 22 | 23 | The flow is as follows: 24 | 25 | * First, we read in the data from standard in, and parse it as a 26 | `CodeGeneratorRequest` (henceforth `CGR`). We use the high-level API 27 | for this. 28 | * Next, we translate to the IR defined in `IR.Stage1`. This represents 29 | essentially the same information as the CGR, but: 30 | * Information we won't use has been discarded. 31 | * It is more type safe, in that the structure of the IR cannot 32 | represent certain illegal structures that are representable in the 33 | CGR. 34 | * Whereas the CGR contains a list of nodes by id, and entries in the 35 | CGR reference each other by ID, in the Stage1 IR we have tied the 36 | knot, and the referenced nodes are available directly as fields of 37 | their referers. 38 | * Then, we translate to the `Flat` IR. This is still a declarative 39 | representation of the information in the schema, but it is in a form 40 | that maps more nicely to Haskell. The goal of this stage is to massage 41 | the information into a form such that later stages don't have to do any 42 | work to find out basic facts about the schema. 43 | For example: 44 | * We have flattened the namespace, all definitions are at top level; 45 | Haskell doesn't support nested namespaces, so this solves an 46 | impedence mismatch. The hierarchical structure is recoverable, as 47 | the names themselves encode the structure; see `IR.Name`. 48 | * Unions are now represented more cleanly as sums, rather than being 49 | mixed in with other fields. 50 | * Interfaces now contain a full list of their ancestors, not just 51 | immediate superclasses. This is useful when genrating instance 52 | declarations later on. 53 | * Next, we translate to the `AbstractOp` IR. This form encodes the 54 | Haskell structures to be generated, rather than what is declared in 55 | the schema -- but the it is still abstract in the sense that it 56 | only specifies what constructs should be generated. Thus, Abstract 57 | and Operational. Examples: 58 | * Type declaration for this capnp type 59 | * An instance for 'Parse' for this type 60 | * etc 61 | * Then, we translate this form into a Haskell AST, defined in 62 | `IR.Haskell`. We use our own AST instead of an off-the-shelf 63 | library for a couple reasons: 64 | * We want to eventually insert comments from the schema into the 65 | code as Haddock comments, and the libraries I(zenhack) was able 66 | to find do not support comments. 67 | * The full Haskell syntax is quite complicated, and we don't need 68 | most of it; our AST has just the parts we need, and so is simpler 69 | to work with. 70 | * It is useful when generating code to be able treat certain 71 | constructs as primitive syntax which really aren't. For example: 72 | * Our AST does not reflect the fact that function application is 73 | curried; 74 | * Our expression type treats "functorial" application, e.g. 75 | `f <$> x <*> y <*> z`, as primitive, which is convienent for 76 | our purposes. 77 | * Finally, we translate the Haskell AST into text, and write it out 78 | to disk. 79 | 80 | # Misc notes 81 | 82 | * There are a couple modules that are shared between more than one phase 83 | and/or IR: 84 | 85 | * `IR.Name` and `IR.Common` are used by multiple of the IRs. 86 | * `Trans.ToHaskellCommon` used to be used by multiple modules. It should 87 | be folded into `Trans.AbstractOpToHaskell`. 88 | 89 | * The names of some of the IRs are not very good. 90 | * `IR.Stage1` latter is not terribly descriptive. 91 | * `IR.Flat` reflects an out of date notion of what the flat IR's 92 | purpose is (it does more than just flatten the namespace). 93 | -------------------------------------------------------------------------------- /capnp/cmd/capnpc-haskell/Trans/FlatToAbstractOp.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DuplicateRecordFields #-} 2 | {-# LANGUAGE NamedFieldPuns #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | 5 | module Trans.FlatToAbstractOp (cgrToFiles) where 6 | 7 | import qualified Capnp.Repr as R 8 | import Data.Bifunctor (Bifunctor (..)) 9 | import Data.Maybe (isJust) 10 | import qualified IR.AbstractOp as AO 11 | import qualified IR.Common as C 12 | import qualified IR.Flat as Flat 13 | import qualified IR.Name as Name 14 | 15 | cgrToFiles :: Flat.CodeGenReq -> [AO.File] 16 | cgrToFiles = map fileToFile . Flat.reqFiles 17 | 18 | fileToFile :: Flat.File -> AO.File 19 | fileToFile Flat.File {fileId, fileName, nodes} = 20 | AO.File 21 | { fileId, 22 | fileName, 23 | decls = concatMap nodeToDecls nodes, 24 | usesRpc = not $ null [() | Flat.Node {union_ = Flat.Interface {}} <- nodes] 25 | } 26 | 27 | mapTypes :: (Bifunctor p, Functor f) => p (f Flat.Node) Flat.Node -> p (f Name.CapnpQ) Name.CapnpQ 28 | mapTypes = C.bothMap (\Flat.Node {name} -> name) 29 | 30 | nodeToDecls :: Flat.Node -> [AO.Decl] 31 | nodeToDecls Flat.Node {nodeId, name = Name.CapnpQ {local}, typeParams, union_} = 32 | let mkType repr extraTypeInfo = 33 | AO.TypeDecl 34 | { name = local, 35 | nodeId, 36 | params = map C.paramName typeParams, 37 | repr, 38 | extraTypeInfo 39 | } 40 | mkField field = 41 | fieldToDecl local typeParams field 42 | 43 | mkMethodInfo Flat.Method {name, paramType, resultType} = 44 | AO.MethodInfo 45 | { typeParams = map C.paramName typeParams, 46 | methodName = name, 47 | paramType = mapTypes paramType, 48 | resultType = mapTypes resultType 49 | } 50 | 51 | parsedStructNode fields hasUnion isGroup = 52 | AO.ParsedInstanceDecl 53 | { typeName = local, 54 | typeParams = map C.paramName typeParams, 55 | parsedInstances = 56 | AO.ParsedStruct 57 | { fields = 58 | [ ( Name.getUnQ fieldName, 59 | mapTypes fieldLocType 60 | ) 61 | | Flat.Field {fieldName, fieldLocType} <- fields 62 | ], 63 | hasUnion, 64 | dataCtorName = dataCtorName isGroup 65 | } 66 | } 67 | 68 | parsedUnionNode Flat.Union {variants} = 69 | AO.ParsedInstanceDecl 70 | { typeName = local, 71 | typeParams = map C.paramName typeParams, 72 | parsedInstances = 73 | AO.ParsedUnion 74 | { variants = 75 | [ ( Name.getUnQ fieldName, 76 | mapTypes fieldLocType 77 | ) 78 | | Flat.Variant {field = Flat.Field {fieldName, fieldLocType}} <- variants 79 | ] 80 | } 81 | } 82 | 83 | dataCtorName isGroup 84 | | isGroup = Name.mkSub local "" 85 | | otherwise = local 86 | 87 | structUnionNodes Nothing = [] 88 | structUnionNodes (Just union@Flat.Union {tagOffset, variants}) = 89 | [ AO.UnionDecl 90 | { name = local, 91 | typeParams = map C.paramName typeParams, 92 | tagLoc = 93 | C.DataLoc 94 | { dataIdx = fromIntegral $ tagOffset `div` 4, 95 | dataOff = fromIntegral $ (tagOffset `mod` 4) * 16, 96 | dataDef = 0 97 | }, 98 | variants = map variantToVariant variants 99 | }, 100 | parsedUnionNode union 101 | ] 102 | in case union_ of 103 | Flat.Other -> [] 104 | Flat.Constant {value} -> 105 | [AO.ConstDecl {name = local, value = mapTypes value}] 106 | Flat.Enum enumerants -> 107 | [mkType (R.Data R.Sz16) $ Just $ AO.EnumTypeInfo enumerants] 108 | Flat.Interface {methods, supers} -> 109 | let methodInfos = map mkMethodInfo methods 110 | superTypes = map mapTypes supers 111 | in mkType 112 | (R.Ptr (Just R.Cap)) 113 | ( Just 114 | AO.InterfaceTypeInfo 115 | { methods = methodInfos, 116 | supers = superTypes 117 | } 118 | ) 119 | : [ AO.SuperDecl 120 | { subName = local, 121 | typeParams = map C.paramName typeParams, 122 | superType = superType 123 | } 124 | | superType <- superTypes 125 | ] 126 | ++ [ AO.MethodDecl 127 | { interfaceName = local, 128 | interfaceId = nodeId, 129 | methodId, 130 | methodInfo 131 | } 132 | | (methodId, methodInfo) <- zip [0 ..] methodInfos 133 | ] 134 | Flat.Struct {isGroup, fields, union, dataWordCount = nWords, pointerCount = nPtrs} -> 135 | mkType (R.Ptr (Just R.Struct)) (Just AO.StructTypeInfo {nWords, nPtrs}) 136 | : parsedStructNode fields (isJust union) isGroup 137 | : (structUnionNodes union ++ map mkField fields) 138 | 139 | fieldToDecl :: Name.LocalQ -> [C.TypeParamRef Flat.Node] -> Flat.Field -> AO.Decl 140 | fieldToDecl containerType typeParams Flat.Field {fieldName, fieldLocType} = 141 | AO.FieldDecl 142 | { containerType, 143 | typeParams = map C.paramName typeParams, 144 | fieldName = Name.getUnQ fieldName, 145 | fieldLocType = mapTypes fieldLocType 146 | } 147 | 148 | variantToVariant :: Flat.Variant -> AO.UnionVariant 149 | variantToVariant Flat.Variant {tagValue, field = Flat.Field {fieldName, fieldLocType}} = 150 | AO.UnionVariant 151 | { variantName = Name.getUnQ fieldName, 152 | tagValue, 153 | fieldLocType = mapTypes fieldLocType 154 | } 155 | -------------------------------------------------------------------------------- /capnp/gen/lib/Capnp/Gen/ById/X86c366a91393f3f8.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wno-unused-imports #-} 2 | {-# OPTIONS_GHC -Wno-dodgy-exports #-} 3 | {-# OPTIONS_GHC -Wno-unused-matches #-} 4 | {-# OPTIONS_GHC -Wno-orphans #-} 5 | {-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} 6 | {-# OPTIONS_GHC -Wno-name-shadowing #-} 7 | module Capnp.Gen.ById.X86c366a91393f3f8(module Capnp.Gen.Capnp.Stream) where 8 | import Capnp.Gen.Capnp.Stream 9 | import qualified Prelude as Std_ 10 | import qualified Data.Word as Std_ 11 | import qualified Data.Int as Std_ 12 | import Prelude ((<$>), (<*>), (>>=)) -------------------------------------------------------------------------------- /capnp/gen/lib/Capnp/Gen/ById/X8ef99297a43a5e34.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wno-unused-imports #-} 2 | {-# OPTIONS_GHC -Wno-dodgy-exports #-} 3 | {-# OPTIONS_GHC -Wno-unused-matches #-} 4 | {-# OPTIONS_GHC -Wno-orphans #-} 5 | {-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} 6 | {-# OPTIONS_GHC -Wno-name-shadowing #-} 7 | module Capnp.Gen.ById.X8ef99297a43a5e34(module Capnp.Gen.Capnp.Compat.Json) where 8 | import Capnp.Gen.Capnp.Compat.Json 9 | import qualified Prelude as Std_ 10 | import qualified Data.Word as Std_ 11 | import qualified Data.Int as Std_ 12 | import Prelude ((<$>), (<*>), (>>=)) -------------------------------------------------------------------------------- /capnp/gen/lib/Capnp/Gen/ById/Xa184c7885cdaf2a1.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wno-unused-imports #-} 2 | {-# OPTIONS_GHC -Wno-dodgy-exports #-} 3 | {-# OPTIONS_GHC -Wno-unused-matches #-} 4 | {-# OPTIONS_GHC -Wno-orphans #-} 5 | {-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} 6 | {-# OPTIONS_GHC -Wno-name-shadowing #-} 7 | module Capnp.Gen.ById.Xa184c7885cdaf2a1(module Capnp.Gen.Capnp.RpcTwoparty) where 8 | import Capnp.Gen.Capnp.RpcTwoparty 9 | import qualified Prelude as Std_ 10 | import qualified Data.Word as Std_ 11 | import qualified Data.Int as Std_ 12 | import Prelude ((<$>), (<*>), (>>=)) -------------------------------------------------------------------------------- /capnp/gen/lib/Capnp/Gen/ById/Xa93fc509624c72d9.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wno-unused-imports #-} 2 | {-# OPTIONS_GHC -Wno-dodgy-exports #-} 3 | {-# OPTIONS_GHC -Wno-unused-matches #-} 4 | {-# OPTIONS_GHC -Wno-orphans #-} 5 | {-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} 6 | {-# OPTIONS_GHC -Wno-name-shadowing #-} 7 | module Capnp.Gen.ById.Xa93fc509624c72d9(module Capnp.Gen.Capnp.Schema) where 8 | import Capnp.Gen.Capnp.Schema 9 | import qualified Prelude as Std_ 10 | import qualified Data.Word as Std_ 11 | import qualified Data.Int as Std_ 12 | import Prelude ((<$>), (<*>), (>>=)) -------------------------------------------------------------------------------- /capnp/gen/lib/Capnp/Gen/ById/Xb312981b2552a250.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wno-unused-imports #-} 2 | {-# OPTIONS_GHC -Wno-dodgy-exports #-} 3 | {-# OPTIONS_GHC -Wno-unused-matches #-} 4 | {-# OPTIONS_GHC -Wno-orphans #-} 5 | {-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} 6 | {-# OPTIONS_GHC -Wno-name-shadowing #-} 7 | module Capnp.Gen.ById.Xb312981b2552a250(module Capnp.Gen.Capnp.Rpc) where 8 | import Capnp.Gen.Capnp.Rpc 9 | import qualified Prelude as Std_ 10 | import qualified Data.Word as Std_ 11 | import qualified Data.Int as Std_ 12 | import Prelude ((<$>), (<*>), (>>=)) -------------------------------------------------------------------------------- /capnp/gen/lib/Capnp/Gen/ById/Xb8630836983feed7.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wno-unused-imports #-} 2 | {-# OPTIONS_GHC -Wno-dodgy-exports #-} 3 | {-# OPTIONS_GHC -Wno-unused-matches #-} 4 | {-# OPTIONS_GHC -Wno-orphans #-} 5 | {-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} 6 | {-# OPTIONS_GHC -Wno-name-shadowing #-} 7 | module Capnp.Gen.ById.Xb8630836983feed7(module Capnp.Gen.Capnp.Persistent) where 8 | import Capnp.Gen.Capnp.Persistent 9 | import qualified Prelude as Std_ 10 | import qualified Data.Word as Std_ 11 | import qualified Data.Int as Std_ 12 | import Prelude ((<$>), (<*>), (>>=)) -------------------------------------------------------------------------------- /capnp/gen/lib/Capnp/Gen/ById/Xbdf87d7bb8304e81.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wno-unused-imports #-} 2 | {-# OPTIONS_GHC -Wno-dodgy-exports #-} 3 | {-# OPTIONS_GHC -Wno-unused-matches #-} 4 | {-# OPTIONS_GHC -Wno-orphans #-} 5 | {-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} 6 | {-# OPTIONS_GHC -Wno-name-shadowing #-} 7 | module Capnp.Gen.ById.Xbdf87d7bb8304e81(module Capnp.Gen.Capnp.Cxx) where 8 | import Capnp.Gen.Capnp.Cxx 9 | import qualified Prelude as Std_ 10 | import qualified Data.Word as Std_ 11 | import qualified Data.Int as Std_ 12 | import Prelude ((<$>), (<*>), (>>=)) -------------------------------------------------------------------------------- /capnp/gen/lib/Capnp/Gen/Capnp/Cxx.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilies #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE DeriveGeneric #-} 4 | {-# LANGUAGE DuplicateRecordFields #-} 5 | {-# LANGUAGE EmptyDataDeriving #-} 6 | {-# LANGUAGE FlexibleContexts #-} 7 | {-# LANGUAGE FlexibleInstances #-} 8 | {-# LANGUAGE MultiParamTypeClasses #-} 9 | {-# LANGUAGE UndecidableInstances #-} 10 | {-# LANGUAGE UndecidableSuperClasses #-} 11 | {-# LANGUAGE OverloadedLabels #-} 12 | {-# LANGUAGE OverloadedStrings #-} 13 | {-# LANGUAGE StandaloneDeriving #-} 14 | {-# LANGUAGE RecordWildCards #-} 15 | {-# LANGUAGE TypeApplications #-} 16 | {-# LANGUAGE ScopedTypeVariables #-} 17 | {-# OPTIONS_GHC -Wno-unused-imports #-} 18 | {-# OPTIONS_GHC -Wno-dodgy-exports #-} 19 | {-# OPTIONS_GHC -Wno-unused-matches #-} 20 | {-# OPTIONS_GHC -Wno-orphans #-} 21 | {-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} 22 | {-# OPTIONS_GHC -Wno-name-shadowing #-} 23 | module Capnp.Gen.Capnp.Cxx where 24 | import qualified Capnp.Repr as R 25 | import qualified Capnp.Repr.Parsed as RP 26 | import qualified Capnp.Basics as Basics 27 | import qualified GHC.OverloadedLabels as OL 28 | import qualified Capnp.GenHelpers as GH 29 | import qualified Capnp.Classes as C 30 | import qualified GHC.Generics as Generics 31 | import qualified Prelude as Std_ 32 | import qualified Data.Word as Std_ 33 | import qualified Data.Int as Std_ 34 | import Prelude ((<$>), (<*>), (>>=)) -------------------------------------------------------------------------------- /capnp/gen/lib/Capnp/Gen/Capnp/Stream.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilies #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE DeriveGeneric #-} 4 | {-# LANGUAGE DuplicateRecordFields #-} 5 | {-# LANGUAGE EmptyDataDeriving #-} 6 | {-# LANGUAGE FlexibleContexts #-} 7 | {-# LANGUAGE FlexibleInstances #-} 8 | {-# LANGUAGE MultiParamTypeClasses #-} 9 | {-# LANGUAGE UndecidableInstances #-} 10 | {-# LANGUAGE UndecidableSuperClasses #-} 11 | {-# LANGUAGE OverloadedLabels #-} 12 | {-# LANGUAGE OverloadedStrings #-} 13 | {-# LANGUAGE StandaloneDeriving #-} 14 | {-# LANGUAGE RecordWildCards #-} 15 | {-# LANGUAGE TypeApplications #-} 16 | {-# LANGUAGE ScopedTypeVariables #-} 17 | {-# OPTIONS_GHC -Wno-unused-imports #-} 18 | {-# OPTIONS_GHC -Wno-dodgy-exports #-} 19 | {-# OPTIONS_GHC -Wno-unused-matches #-} 20 | {-# OPTIONS_GHC -Wno-orphans #-} 21 | {-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} 22 | {-# OPTIONS_GHC -Wno-name-shadowing #-} 23 | module Capnp.Gen.Capnp.Stream where 24 | import qualified Capnp.Repr as R 25 | import qualified Capnp.Repr.Parsed as RP 26 | import qualified Capnp.Basics as Basics 27 | import qualified GHC.OverloadedLabels as OL 28 | import qualified Capnp.GenHelpers as GH 29 | import qualified Capnp.Classes as C 30 | import qualified GHC.Generics as Generics 31 | import qualified Prelude as Std_ 32 | import qualified Data.Word as Std_ 33 | import qualified Data.Int as Std_ 34 | import Prelude ((<$>), (<*>), (>>=)) 35 | data StreamResult 36 | type instance (R.ReprFor StreamResult) = (R.Ptr (Std_.Just R.Struct)) 37 | instance (C.HasTypeId StreamResult) where 38 | typeId = 11051721556433613166 39 | instance (C.TypedStruct StreamResult) where 40 | numStructWords = 0 41 | numStructPtrs = 0 42 | instance (C.Allocate StreamResult) where 43 | type AllocHint StreamResult = () 44 | new _ = C.newTypedStruct 45 | instance (C.EstimateAlloc StreamResult (C.Parsed StreamResult)) 46 | instance (C.AllocateList StreamResult) where 47 | type ListAllocHint StreamResult = Std_.Int 48 | newList = C.newTypedStructList 49 | instance (C.EstimateListAlloc StreamResult (C.Parsed StreamResult)) 50 | data instance C.Parsed StreamResult 51 | = StreamResult 52 | {} 53 | deriving(Generics.Generic) 54 | deriving instance (Std_.Show (C.Parsed StreamResult)) 55 | deriving instance (Std_.Eq (C.Parsed StreamResult)) 56 | instance (C.Parse StreamResult (C.Parsed StreamResult)) where 57 | parse raw_ = (Std_.pure StreamResult) 58 | instance (C.Marshal StreamResult (C.Parsed StreamResult)) where 59 | marshalInto _raw (StreamResult) = (Std_.pure ()) -------------------------------------------------------------------------------- /capnp/gen/tests/.gitignore: -------------------------------------------------------------------------------- 1 | *.hs 2 | -------------------------------------------------------------------------------- /capnp/lib/Capnp.hs: -------------------------------------------------------------------------------- 1 | -- | Module: Capnp 2 | -- Description: Re-export commonly used things from elsewhere in the library. 3 | module Capnp 4 | ( module X, 5 | Parsed, 6 | 7 | -- * Working with raw values 8 | R.Raw (..), 9 | 10 | -- ** Working with raw lists 11 | R.List, 12 | R.index, 13 | R.setIndex, 14 | R.length, 15 | 16 | -- * Working with fields 17 | F.Field, 18 | F.FieldKind, 19 | F.HasField (..), 20 | F.HasUnion (..), 21 | F.HasVariant (..), 22 | 23 | -- * Working with messages 24 | Message.Message, 25 | Message.Segment, 26 | Message.Mutability (..), 27 | Message.MonadReadMessage (..), 28 | Message.newMessage, 29 | Message.fromByteString, 30 | Message.toByteString, 31 | 32 | -- * Building messages in pure code 33 | PureBuilder, 34 | createPure, 35 | 36 | -- * Canonicalizing messages 37 | canonicalize, 38 | 39 | -- * Implementing RPC servers 40 | MethodHandler, 41 | SomeServer (..), 42 | Export (Server), 43 | export, 44 | handleParsed, 45 | handleRaw, 46 | methodUnimplemented, 47 | 48 | -- * Shorthands for types 49 | R.IsStruct, 50 | R.IsCap, 51 | R.IsPtr, 52 | 53 | -- * Re-exported from "Data.Default", for convienence. 54 | def, 55 | ) 56 | where 57 | 58 | -- TODO: be more intentional about the ordering of the stuff we're 59 | -- currently exposing as X, so the haddocks are clearer. 60 | 61 | import Capnp.Accessors as X 62 | import Capnp.Basics as X hiding (Parsed) 63 | import Capnp.Canonicalize (canonicalize) 64 | import Capnp.Classes as X hiding (Parsed) 65 | import Capnp.Constraints as X 66 | import Capnp.Convert as X 67 | import qualified Capnp.Fields as F 68 | import Capnp.IO as X 69 | import qualified Capnp.Message as Message 70 | import qualified Capnp.Repr as R 71 | import Capnp.Repr.Methods as X 72 | import Capnp.Repr.Parsed (Parsed) 73 | import Capnp.Rpc.Server 74 | import Capnp.TraversalLimit as X 75 | import Data.Default (def) 76 | import Internal.BuildPure (PureBuilder, createPure) 77 | import Internal.Rpc.Export (export) 78 | -------------------------------------------------------------------------------- /capnp/lib/Capnp/Address.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards #-} 2 | 3 | -- | 4 | -- Module: Capnp.Address 5 | -- Description: Utilities for manipulating addresses within capnproto messages. 6 | -- 7 | -- This module provides facilities for manipulating raw addresses within 8 | -- Cap'N Proto messages. 9 | -- 10 | -- This is a low level module that very few users will need to use directly. 11 | module Capnp.Address 12 | ( WordAddr (..), 13 | CapAddr (..), 14 | Addr (..), 15 | OffsetError (..), 16 | computeOffset, 17 | pointerFrom, 18 | resolveOffset, 19 | ) 20 | where 21 | 22 | import Capnp.Bits (WordCount) 23 | import qualified Capnp.Pointer as P 24 | import Data.Bits 25 | import Data.Int 26 | import Data.Word 27 | 28 | -- | The address of a word within a message 29 | data WordAddr = WordAt 30 | { -- | Segment number 31 | segIndex :: !Int, 32 | -- | offset in words from the start of the segment. 33 | wordIndex :: !WordCount 34 | } 35 | deriving (Show, Eq) 36 | 37 | -- | The "address" of a capability 38 | newtype CapAddr = Cap Word32 deriving (Show, Eq) 39 | 40 | -- | An address, i.e. a location that a pointer may point at. 41 | data Addr 42 | = -- | The address of some data in the message. 43 | WordAddr !WordAddr 44 | | -- | The "address" of a capability. 45 | CapAddr !CapAddr 46 | deriving (Show, Eq) 47 | 48 | -- | An error returned by 'computeOffset'; this describes the reason why a 49 | -- value cannot be directly addressed from a given location. 50 | data OffsetError 51 | = -- | The pointer and the value are in different segments. 52 | DifferentSegments 53 | | -- | The pointer is in the correct segment, but too far away to encode the 54 | -- offset. (more than 30 bits would be required). This can only happen with 55 | -- segments that are > 8 GiB, which this library refuses to either decode 56 | -- or generate, so this should not come up in practice. 57 | OutOfRange 58 | 59 | -- | @'computeOffset' ptrAddr valueAddr@ computes the offset that should be 60 | -- stored in a struct or list pointer located at @ptrAddr@, in order to point 61 | -- at a value located at @valueAddr@. If the value cannot be directly addressed 62 | -- by a pointer at @ptrAddr@, then this returns 'Left', with the 'OffsetError' 63 | -- describing the problem. 64 | computeOffset :: WordAddr -> WordAddr -> Either OffsetError WordCount 65 | computeOffset ptrAddr valueAddr 66 | | segIndex ptrAddr /= segIndex valueAddr = Left DifferentSegments 67 | | otherwise = 68 | let offset = wordIndex valueAddr - (wordIndex ptrAddr + 1) 69 | in if offset >= 1 `shiftL` 30 70 | then Left OutOfRange 71 | else Right offset 72 | 73 | -- | @'pointerFrom' ptrAddr targetAddr ptr@ updates @ptr@, such that it is 74 | -- correct to target a value located at @targetAddr@ given that the pointer 75 | -- itself is located at @ptrAddr@. Returns 'Left' if this is not possible. 76 | -- 77 | -- It is illegal to call this on a capability pointer. 78 | -- 79 | -- For far pointers, @targetAddr@ is taken to be the address of the landing pad, 80 | -- rather than the final value. 81 | pointerFrom :: WordAddr -> WordAddr -> P.Ptr -> Either OffsetError P.Ptr 82 | pointerFrom _ _ (P.CapPtr _) = error "pointerFrom called on a capability pointer." 83 | pointerFrom _ WordAt {..} (P.FarPtr twoWords _ _) = 84 | Right $ P.FarPtr twoWords (fromIntegral wordIndex) (fromIntegral segIndex) 85 | pointerFrom ptrAddr targetAddr (P.StructPtr _ dataSz ptrSz) = 86 | flip fmap (computeOffset ptrAddr targetAddr) $ 87 | \off -> P.StructPtr (fromIntegral off) dataSz ptrSz 88 | pointerFrom ptrAddr targetAddr (P.ListPtr _ eltSpec) = 89 | flip fmap (computeOffset ptrAddr targetAddr) $ 90 | \off -> P.ListPtr (fromIntegral off) eltSpec 91 | 92 | -- | Add an offset to a WordAddr. 93 | resolveOffset :: WordAddr -> Int32 -> WordAddr 94 | resolveOffset addr@WordAt {..} off = 95 | addr {wordIndex = wordIndex + fromIntegral off + 1} 96 | -------------------------------------------------------------------------------- /capnp/lib/Capnp/Bits.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 2 | 3 | -- | 4 | -- Module: Capnp.Bits 5 | -- Description: Utilities for bitwhacking useful for capnproto. 6 | -- 7 | -- This module provides misc. utilities for bitwhacking that are useful 8 | -- in dealing with low-level details of the Cap'N Proto wire format. 9 | -- 10 | -- This is mostly an implementation detail; users are unlikely to need 11 | -- to use this module directly. 12 | module Capnp.Bits 13 | ( BitCount (..), 14 | ByteCount (..), 15 | WordCount (..), 16 | Word1 (..), 17 | bitsToBytesCeil, 18 | bytesToWordsCeil, 19 | bytesToWordsFloor, 20 | wordsToBytes, 21 | lo, 22 | hi, 23 | i32, 24 | i30, 25 | i29, 26 | fromLo, 27 | fromHi, 28 | fromI32, 29 | fromI30, 30 | fromI29, 31 | bitRange, 32 | replaceBits, 33 | ) 34 | where 35 | 36 | import Data.Bits 37 | import Data.Int 38 | import Data.Word 39 | 40 | -- | Wrapper type for a quantity of bits. This along with 'ByteCount' and 41 | -- 'WordCount' are helpful for avoiding mixing up units 42 | newtype BitCount = BitCount Int 43 | deriving (Num, Real, Integral, Bits, Ord, Eq, Enum, Show, Bounded) 44 | 45 | -- | A quantity of bytes 46 | newtype ByteCount = ByteCount Int 47 | deriving (Num, Real, Integral, Bits, Ord, Eq, Enum, Show, Bounded) 48 | 49 | -- | A quantity of 64-bit words 50 | newtype WordCount = WordCount Int 51 | deriving (Num, Real, Integral, Bits, Ord, Eq, Enum, Show, Bounded) 52 | 53 | -- | Convert bits to bytes. Rounds up. 54 | bitsToBytesCeil :: BitCount -> ByteCount 55 | bitsToBytesCeil (BitCount n) = ByteCount ((n + 7) `div` 8) 56 | 57 | -- | Convert bytes to words. Rounds up. 58 | bytesToWordsCeil :: ByteCount -> WordCount 59 | bytesToWordsCeil (ByteCount n) = WordCount ((n + 7) `div` 8) 60 | 61 | -- | Convert bytes to words. Rounds down. 62 | bytesToWordsFloor :: ByteCount -> WordCount 63 | bytesToWordsFloor (ByteCount n) = WordCount (n `div` 8) 64 | 65 | -- | Convert words to bytes. 66 | wordsToBytes :: WordCount -> ByteCount 67 | wordsToBytes (WordCount n) = ByteCount (n * 8) 68 | 69 | -- | lo and hi extract the low and high 32 bits of a 64-bit word, respectively. 70 | lo, hi :: Word64 -> Word32 71 | 72 | -- | iN (where N is 32, 30, or 29) extracts the high N bits of its argument, 73 | -- and treats them as a signed 32-bit integer. 74 | i32, i30, i29 :: Word32 -> Int32 75 | 76 | -- | fromLo and fromHi convert a 32-bit word to the low or high portion of 77 | -- a 64-bit word. In general, @fromHi (hi w) .|. fromLo (lo w) == w@. 78 | fromLo, fromHi :: Word32 -> Word64 79 | 80 | -- | fromIN (where N is 32, 30, or 29) treats its argument as the high N bits of 81 | -- a 32-bit word, returning the word. If @w < 2 ** N@ then @fromIN (iN w) == w@. 82 | fromI32, fromI30, fromI29 :: Int32 -> Word32 83 | 84 | lo w = fromIntegral (w `shiftR` 0) 85 | 86 | hi w = fromIntegral (w `shiftR` 32) 87 | 88 | i32 = fromIntegral 89 | 90 | i30 w = i32 w `shiftR` 2 91 | 92 | i29 w = i32 w `shiftR` 3 93 | 94 | fromLo w = fromIntegral w `shiftL` 0 95 | 96 | fromHi w = fromIntegral w `shiftL` 32 97 | 98 | fromI32 = fromIntegral 99 | 100 | fromI30 w = fromI32 (w `shiftL` 2) 101 | 102 | fromI29 w = fromI32 (w `shiftL` 3) 103 | 104 | -- | @bitRange word lo hi@ is the unsigned integer represented by the 105 | -- bits of @word@ in the range [lo, hi) 106 | bitRange :: (Integral a => Word64 -> Int -> Int -> a) 107 | bitRange word lo hi = 108 | fromIntegral $ 109 | (word .&. ((1 `shiftL` hi) - 1)) `shiftR` lo 110 | 111 | -- | @replaceBits new orig shift@ replaces the bits [shift, shift+N) in 112 | -- @orig@ with the N bit integer @new@. 113 | replaceBits :: 114 | (Bounded a, Integral a) => 115 | a -> 116 | Word64 -> 117 | Int -> 118 | Word64 119 | replaceBits new orig shift = 120 | (orig .&. mask) .|. (fromIntegral new `shiftL` shift) 121 | where 122 | mask = complement $ fromIntegral (maxBound `asTypeOf` new) `shiftL` shift 123 | {-# INLINE replaceBits #-} 124 | 125 | -- | 1 bit datatype, in the tradition of Word8, Word16 et al. 126 | newtype Word1 = Word1 {word1ToBool :: Bool} 127 | deriving (Ord, Eq, Enum, Bounded, Bits, FiniteBits) 128 | 129 | instance Num Word1 where 130 | (+) = w1ThruEnum (+) 131 | (*) = w1ThruEnum (*) 132 | abs = id 133 | signum = id 134 | negate = id 135 | fromInteger x = toEnum (fromIntegral x `mod` 2) 136 | 137 | instance Real Word1 where 138 | toRational = fromIntegral . fromEnum 139 | 140 | instance Integral Word1 where 141 | toInteger = toInteger . fromEnum 142 | quotRem x y = 143 | let (x', y') = quotRem (fromEnum x) (fromEnum y) 144 | in (toEnum x', toEnum y') 145 | 146 | instance Show Word1 where 147 | show = show . fromEnum 148 | 149 | -- TODO: implement Read? 150 | 151 | w1ThruEnum :: (Int -> Int -> Int) -> Word1 -> Word1 -> Word1 152 | w1ThruEnum op l r = toEnum $ (fromEnum l `op` fromEnum r) `mod` 2 153 | -------------------------------------------------------------------------------- /capnp/lib/Capnp/Constraints.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ConstraintKinds #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE TypeFamilies #-} 4 | 5 | -- | Module: Capnp.Constraints 6 | -- Description: convenience shorthands for various constraints. 7 | module Capnp.Constraints where 8 | 9 | import qualified Capnp.Classes as C 10 | import qualified Capnp.Repr as R 11 | import qualified Capnp.Repr.Parsed as RP 12 | 13 | -- | Constraints needed for @a@ to be a capnproto type parameter. 14 | type TypeParam a = 15 | ( R.IsPtr a, 16 | C.Parse a (RP.Parsed a) 17 | ) 18 | -------------------------------------------------------------------------------- /capnp/lib/Capnp/Errors.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE UndecidableInstances #-} 3 | 4 | -- | 5 | -- Module: Capnp.Errors 6 | -- Description: Error handling utilities 7 | module Capnp.Errors 8 | ( Error (..), 9 | ) 10 | where 11 | 12 | import Control.Monad.Catch (Exception) 13 | import Data.Text.Encoding.Error (UnicodeException) 14 | 15 | -- | An error that may occur when processing a capnproto message. 16 | data Error 17 | = -- | A 'BoundsError' indicates an attempt to access an illegal 18 | -- index 'index' within a sequence of length 'maxIndex'. 19 | BoundsError 20 | { index :: !Int, 21 | maxIndex :: !Int 22 | -- TODO: choose a better name than maxIndex; this is confusing 23 | -- since it's supposed to be the length, rather than the maximum 24 | -- legal index. The latter would make it impossible to represent 25 | -- an error for an empty sequence. I(zenhack) also think there may 26 | -- be places in the library where we are misusing this field. 27 | } 28 | | -- | A 'RecursionLimitError' indicates that the recursion depth limit 29 | -- was exceeded. 30 | RecursionLimitError 31 | | -- | A 'TraversalLimitError' indicates that the traversal limit was 32 | -- exceeded. 33 | TraversalLimitError 34 | | -- | An 'InvalidDataError' indicates that a part of a message being 35 | -- parsed was malformed. The argument to the data constructor is a 36 | -- human-readable error message. 37 | InvalidDataError String 38 | | -- | A 'SizeError' indicates that an operation would have resulted in 39 | -- a message that violated the library's limit on either segment size 40 | -- or number of segments. 41 | SizeError 42 | | -- | A 'SchemaViolationError' indicates that part of the message does 43 | -- not match the schema. The argument to the data construtor is a 44 | -- human-readable error message. 45 | SchemaViolationError String 46 | | -- | An 'InvalidUtf8Error' indicates that a text value in the message 47 | -- was invalid utf8. 48 | -- 49 | -- Note well: Most parts of the library don't actually check for valid 50 | -- utf8 -- don't assume the check is made unless an interface says it is. 51 | InvalidUtf8Error UnicodeException 52 | deriving (Show, Eq) 53 | 54 | instance Exception Error 55 | -------------------------------------------------------------------------------- /capnp/lib/Capnp/Fields.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE FunctionalDependencies #-} 6 | {-# LANGUAGE GADTs #-} 7 | {-# LANGUAGE ScopedTypeVariables #-} 8 | {-# LANGUAGE TypeApplications #-} 9 | {-# LANGUAGE TypeFamilies #-} 10 | {-# LANGUAGE TypeOperators #-} 11 | {-# LANGUAGE UndecidableInstances #-} 12 | 13 | -- | Module: Capnp.Fields 14 | -- Description: Support for working with struct fields 15 | module Capnp.Fields 16 | ( HasField (..), 17 | Field (..), 18 | FieldLoc (..), 19 | DataFieldLoc (..), 20 | FieldKind (..), 21 | HasUnion (..), 22 | Variant (..), 23 | HasVariant (..), 24 | ) 25 | where 26 | 27 | import Capnp.Bits 28 | import qualified Capnp.Classes as C 29 | import qualified Capnp.Message as M 30 | import qualified Capnp.Repr as R 31 | import qualified Capnp.Untyped as U 32 | import Data.Word 33 | import GHC.OverloadedLabels (IsLabel (..)) 34 | import GHC.TypeLits (Symbol) 35 | 36 | -- | What sort of field is this? This corresponds to the slot/group variants 37 | -- in the @Field@ type in schema.capnp. Mostly used at the type level with 38 | -- the @DataKinds@ extension. 39 | -- 40 | -- (Note that this has nothing to do with kinds in the usual type system sense 41 | -- of the word). 42 | data FieldKind 43 | = -- | The field is a normal slot; it can be read and written as an 44 | -- individual value. 45 | Slot 46 | | -- | The field is a group. Since this shares space with its parent struct 47 | -- access patterns are a bit different. 48 | Group 49 | deriving (Show, Read, Eq) 50 | 51 | -- | @'Field' k a b@ is a first-class representation of a field of type @b@ within 52 | -- an @a@, where @a@ must be a struct type. 53 | newtype Field (k :: FieldKind) a b = Field (FieldLoc k (R.ReprFor b)) 54 | 55 | -- | The location of a field within a message. 56 | data FieldLoc (k :: FieldKind) (r :: R.Repr) where 57 | GroupField :: FieldLoc 'Group ('R.Ptr ('Just 'R.Struct)) 58 | PtrField :: R.IsPtrRepr a => Word16 -> FieldLoc 'Slot ('R.Ptr a) 59 | DataField :: C.IsWord (R.UntypedData a) => DataFieldLoc a -> FieldLoc 'Slot ('R.Data a) 60 | VoidField :: FieldLoc 'Slot ('R.Data 'R.Sz0) 61 | 62 | -- | The location of a data (non-pointer) field. 63 | data DataFieldLoc (sz :: R.DataSz) = DataFieldLoc 64 | { shift :: !BitCount, 65 | index :: !Word16, 66 | mask :: !Word64, 67 | defaultValue :: !Word64 68 | } 69 | 70 | -- | An instance of 'HasUnion' indicates that the given type is a capnproto struct 71 | -- (or group) with an anonymous union. 72 | class R.IsStruct a => HasUnion a where 73 | -- | 'unionField' is a field holding the union's tag. 74 | unionField :: Field 'Slot a Word16 75 | 76 | -- | 'Which' is the abstract capnproto type of the union itself. Like 77 | -- generated struct types (in this case @a@), this is typically 78 | -- uninhabitied, and used to define instances and/or act as a phantom type. 79 | data Which a 80 | 81 | -- | Concrete view into a union embedded in a message. This will be a sum 82 | -- type with other 'Raw' values as arguments. 83 | data RawWhich a (mut :: M.Mutability) 84 | 85 | -- | Helper used in generated code to extract a 'RawWhich' from its 86 | -- surrounding struct. 87 | internalWhich :: U.ReadCtx m mut => Word16 -> R.Raw a mut -> m (RawWhich a mut) 88 | 89 | type instance R.ReprFor (Which a) = 'R.Ptr ('Just 'R.Struct) 90 | 91 | instance (C.Allocate a, HasUnion a, R.IsStruct (Which a)) => C.Allocate (Which a) where 92 | type AllocHint (Which a) = C.AllocHint a 93 | new hint msg = do 94 | R.Raw struct <- C.new @a hint msg 95 | pure (R.Raw struct) 96 | 97 | instance 98 | ( C.Allocate (Which a), 99 | C.AllocHint (Which a) ~ (), 100 | C.Parse (Which a) p 101 | ) => 102 | C.EstimateAlloc (Which a) p 103 | 104 | -- | @'Variant' k a b@ is a first-class representation of a variant of @a@'s 105 | -- anonymous union, whose argument is of type @b@. 106 | data Variant (k :: FieldKind) a b = Variant 107 | { field :: !(Field k a b), 108 | tagValue :: !Word16 109 | } 110 | 111 | -- | An instance @'HasField' name k a b@ indicates that the struct type @a@ 112 | -- has a field named @name@ with type @b@ (with @k@ being the 'FieldKind' for 113 | -- the field). The generated code includes instances of this for each field 114 | -- in the schema. 115 | class R.IsStruct a => HasField (name :: Symbol) k a b | a name -> k b where 116 | fieldByLabel :: Field k a b 117 | 118 | instance HasField name k a b => IsLabel name (Field k a b) where 119 | fromLabel = fieldByLabel @name @k @a @b 120 | 121 | -- | An instance @'HasVariant name k a b@ indicates that the struct type @a@ 122 | -- has an anonymous union with a variant named @name@, whose argument is of type 123 | -- @b@. 124 | class HasUnion a => HasVariant (name :: Symbol) k a b | a name -> k b where 125 | variantByLabel :: Variant k a b 126 | 127 | instance HasVariant name k a b => IsLabel name (Variant k a b) where 128 | fromLabel = variantByLabel @name @k @a @b 129 | -------------------------------------------------------------------------------- /capnp/lib/Capnp/Gen.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module: Capnp.Gen 3 | -- Description: Code generated by the schema compiler. 4 | -- 5 | -- The @Capnp.Gen@ module hierarchy contains code generated by the schema compiler. 6 | -- See "Capnp.Tutorial" for a description of what code is generated for 7 | -- each schema, as well as a general introduction to the library. 8 | module Capnp.Gen () where 9 | -------------------------------------------------------------------------------- /capnp/lib/Capnp/Gen/Capnp.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module: Capnp.Gen.Capnp 3 | -- Description: Generated modules for the schema that ship with Cap'N Proto 4 | -- 5 | -- The modules under 'Capnp.Gen.Capnp' are generated code for the schema files that 6 | -- ship with the Cap'N Proto reference implementation. 7 | module Capnp.Gen.Capnp () where 8 | -------------------------------------------------------------------------------- /capnp/lib/Capnp/GenHelpers.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ConstraintKinds #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE DuplicateRecordFields #-} 4 | {-# LANGUAGE FlexibleContexts #-} 5 | {-# LANGUAGE NamedFieldPuns #-} 6 | {-# LANGUAGE ScopedTypeVariables #-} 7 | {-# LANGUAGE TypeApplications #-} 8 | {-# LANGUAGE TypeFamilies #-} 9 | 10 | module Capnp.GenHelpers 11 | ( dataField, 12 | ptrField, 13 | groupField, 14 | voidField, 15 | readVariant, 16 | Mutability (..), 17 | TypeParam, 18 | newStruct, 19 | parseEnum, 20 | encodeEnum, 21 | getPtrConst, 22 | BS.ByteString, 23 | module F, 24 | module Capnp.Accessors, 25 | 26 | -- * Re-exports from the standard library. 27 | Proxy (..), 28 | ) 29 | where 30 | 31 | import Capnp.Accessors 32 | import qualified Capnp.Basics as NB 33 | import Capnp.Bits 34 | import qualified Capnp.Classes as NC 35 | import Capnp.Constraints (TypeParam) 36 | import Capnp.Convert (bsToRaw) 37 | import Capnp.Fields as F 38 | import Capnp.Message (Mutability (..)) 39 | import qualified Capnp.Message as M 40 | import qualified Capnp.Repr as R 41 | import Capnp.TraversalLimit (evalLimitT) 42 | import qualified Capnp.Untyped as U 43 | import Data.Bits 44 | import qualified Data.ByteString as BS 45 | import Data.Functor ((<&>)) 46 | import Data.Maybe (fromJust) 47 | import Data.Proxy (Proxy (..)) 48 | import Data.Word 49 | 50 | dataField :: 51 | forall b a sz. 52 | ( R.ReprFor b ~ 'R.Data sz, 53 | NC.IsWord (R.UntypedData sz) 54 | ) => 55 | BitCount -> 56 | Word16 -> 57 | BitCount -> 58 | Word64 -> 59 | F.Field 'F.Slot a b 60 | dataField shift index nbits defaultValue = 61 | F.Field $ 62 | F.DataField @sz 63 | F.DataFieldLoc 64 | { shift, 65 | index, 66 | mask = ((1 `shiftL` fromIntegral nbits) - 1) `shiftL` fromIntegral shift, 67 | defaultValue 68 | } 69 | 70 | ptrField :: forall a b. R.IsPtr b => Word16 -> F.Field 'F.Slot a b 71 | ptrField = F.Field . F.PtrField @(R.PtrReprFor (R.ReprFor b)) 72 | 73 | groupField :: (R.ReprFor b ~ 'R.Ptr ('Just 'R.Struct)) => F.Field 'F.Group a b 74 | groupField = F.Field F.GroupField 75 | 76 | voidField :: (R.ReprFor b ~ 'R.Data 'R.Sz0) => F.Field 'F.Slot a b 77 | voidField = F.Field F.VoidField 78 | 79 | -- | Like 'readField', but accepts a variant. Warning: *DOES NOT CHECK* that the 80 | -- variant is the one that is set. This should only be used by generated code. 81 | readVariant :: 82 | forall k a b mut m. 83 | ( R.IsStruct a, 84 | U.ReadCtx m mut 85 | ) => 86 | F.Variant k a b -> 87 | R.Raw a mut -> 88 | m (R.Raw b mut) 89 | readVariant F.Variant {field} = readField field 90 | 91 | newStruct :: forall a m s. (U.RWCtx m s, NC.TypedStruct a) => () -> M.Message ('Mut s) -> m (R.Raw a ('Mut s)) 92 | newStruct () msg = R.Raw . R.fromRaw <$> NC.new @NB.AnyStruct (NC.numStructWords @a, NC.numStructPtrs @a) msg 93 | 94 | parseEnum :: 95 | (R.ReprFor a ~ 'R.Data 'R.Sz16, Enum a, Applicative m) => 96 | R.Raw a 'Const -> 97 | m a 98 | parseEnum (R.Raw n) = pure $ toEnum $ fromIntegral n 99 | 100 | encodeEnum :: 101 | forall a m s. 102 | (R.ReprFor a ~ 'R.Data 'R.Sz16, Enum a, U.RWCtx m s) => 103 | M.Message ('Mut s) -> 104 | a -> 105 | m (R.Raw a ('Mut s)) 106 | encodeEnum _msg value = pure $ R.Raw $ fromIntegral $ fromEnum @a value 107 | 108 | -- | Get a pointer from a ByteString, where the root object is a struct with 109 | -- one pointer, which is the pointer we will retrieve. This is only safe for 110 | -- trusted inputs; it reads the message with a traversal limit of 'maxBound' 111 | -- (and so is suseptable to denial of service attacks), and it calls 'error' 112 | -- if decoding is not successful. 113 | -- 114 | -- The purpose of this is for defining constants of pointer type from a schema. 115 | getPtrConst :: forall a. R.IsPtr a => BS.ByteString -> R.Raw a 'Const 116 | getPtrConst bytes = fromJust $ evalLimitT maxBound $ do 117 | R.Raw root <- bsToRaw @NB.AnyStruct bytes 118 | U.getPtr 0 root 119 | >>= R.fromPtr @(R.PtrReprFor (R.ReprFor a)) (U.message @U.Struct root) 120 | <&> R.Raw 121 | -------------------------------------------------------------------------------- /capnp/lib/Capnp/GenHelpers/Rpc.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE TypeFamilies #-} 4 | 5 | module Capnp.GenHelpers.Rpc 6 | ( module Capnp.Rpc.Server, 7 | module Capnp.Repr.Methods, 8 | parseCap, 9 | encodeCap, 10 | ) 11 | where 12 | 13 | import Capnp.Message (Mutability (..)) 14 | import qualified Capnp.Message as M 15 | import qualified Capnp.Repr as R 16 | import Capnp.Repr.Methods 17 | import Capnp.Rpc.Server 18 | import qualified Capnp.Untyped as U 19 | 20 | parseCap :: (R.IsCap a, U.ReadCtx m 'Const) => R.Raw a 'Const -> m (Client a) 21 | parseCap (R.Raw cap) = Client <$> U.getClient cap 22 | 23 | encodeCap :: (R.IsCap a, U.RWCtx m s) => M.Message ('Mut s) -> Client a -> m (R.Raw a ('Mut s)) 24 | encodeCap msg (Client c) = R.Raw <$> U.appendCap msg c 25 | -------------------------------------------------------------------------------- /capnp/lib/Capnp/IO.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE ScopedTypeVariables #-} 5 | {-# LANGUAGE TypeApplications #-} 6 | {-# LANGUAGE TypeFamilies #-} 7 | 8 | -- | 9 | -- Module: Capnp.IO 10 | -- Description: Utilities for reading and writing values to handles. 11 | -- 12 | -- This module provides utilities for reading and writing values to and 13 | -- from file 'Handle's. 14 | module Capnp.IO 15 | ( sGetMsg, 16 | sPutMsg, 17 | M.hGetMsg, 18 | M.getMsg, 19 | M.hPutMsg, 20 | M.putMsg, 21 | hGetParsed, 22 | sGetParsed, 23 | getParsed, 24 | hPutParsed, 25 | sPutParsed, 26 | putParsed, 27 | hGetRaw, 28 | getRaw, 29 | sGetRaw, 30 | ) 31 | where 32 | 33 | import Capnp.Bits (WordCount, wordsToBytes) 34 | import Capnp.Classes (Parse) 35 | import Capnp.Convert 36 | ( msgToLBS, 37 | msgToParsed, 38 | msgToRaw, 39 | parsedToBuilder, 40 | parsedToLBS, 41 | ) 42 | import Capnp.Message (Mutability (..)) 43 | import qualified Capnp.Message as M 44 | import qualified Capnp.Repr as R 45 | import Capnp.TraversalLimit (evalLimitT) 46 | import Control.Exception (throwIO) 47 | import Control.Monad.Trans.Class (lift) 48 | import Data.Bits 49 | import qualified Data.ByteString as BS 50 | import qualified Data.ByteString.Builder as BB 51 | import Network.Simple.TCP (Socket, recv, sendLazy) 52 | import System.IO (Handle, stdin, stdout) 53 | import System.IO.Error (eofErrorType, mkIOError) 54 | 55 | -- | Like 'hGetMsg', except that it takes a socket instead of a 'Handle'. 56 | sGetMsg :: Socket -> WordCount -> IO (M.Message 'Const) 57 | sGetMsg socket limit = 58 | evalLimitT limit $ M.readMessage (lift read32) (lift . readSegment) 59 | where 60 | read32 = do 61 | bytes <- recvFull 4 62 | pure $ 63 | (fromIntegral (bytes `BS.index` 0) `shiftL` 0) 64 | .|. (fromIntegral (bytes `BS.index` 1) `shiftL` 8) 65 | .|. (fromIntegral (bytes `BS.index` 2) `shiftL` 16) 66 | .|. (fromIntegral (bytes `BS.index` 3) `shiftL` 24) 67 | readSegment !words = 68 | M.fromByteString <$> recvFull (fromIntegral $ wordsToBytes words) 69 | 70 | -- \| Like recv, but (1) never returns less than `count` bytes, (2) 71 | -- uses `socket`, rather than taking the socket as an argument, and (3) 72 | -- throws an EOF exception when the connection is closed. 73 | recvFull :: Int -> IO BS.ByteString 74 | recvFull !count = do 75 | maybeBytes <- recv socket count 76 | case maybeBytes of 77 | Nothing -> 78 | throwIO $ mkIOError eofErrorType "Remote socket closed" Nothing Nothing 79 | Just bytes 80 | | BS.length bytes == count -> 81 | pure bytes 82 | | otherwise -> 83 | (bytes <>) <$> recvFull (count - BS.length bytes) 84 | 85 | -- | Like 'hPutMsg', except that it takes a 'Socket' instead of a 'Handle'. 86 | sPutMsg :: Socket -> M.Message 'Const -> IO () 87 | sPutMsg socket = sendLazy socket . msgToLBS 88 | 89 | -- | Read a struct from the handle in its parsed form, using the supplied 90 | -- read limit. 91 | hGetParsed :: forall a pa. (R.IsStruct a, Parse a pa) => Handle -> WordCount -> IO pa 92 | hGetParsed handle limit = do 93 | msg <- M.hGetMsg handle limit 94 | evalLimitT limit $ msgToParsed @a msg 95 | 96 | -- | Read a struct from the socket in its parsed form, using the supplied 97 | -- read limit. 98 | sGetParsed :: forall a pa. (R.IsStruct a, Parse a pa) => Socket -> WordCount -> IO pa 99 | sGetParsed socket limit = do 100 | msg <- sGetMsg socket limit 101 | evalLimitT limit $ msgToParsed @a msg 102 | 103 | -- | Read a struct from stdin in its parsed form, using the supplied 104 | -- read limit. 105 | getParsed :: (R.IsStruct a, Parse a pa) => WordCount -> IO pa 106 | getParsed = hGetParsed stdin 107 | 108 | -- | Write the parsed form of a struct to the handle 109 | hPutParsed :: (R.IsStruct a, Parse a pa) => Handle -> pa -> IO () 110 | hPutParsed h value = do 111 | bb <- evalLimitT maxBound $ parsedToBuilder value 112 | BB.hPutBuilder h bb 113 | 114 | -- | Write the parsed form of a struct to stdout 115 | putParsed :: (R.IsStruct a, Parse a pa) => pa -> IO () 116 | putParsed = hPutParsed stdout 117 | 118 | -- | Write the parsed form of a struct to the socket. 119 | sPutParsed :: (R.IsStruct a, Parse a pa) => Socket -> pa -> IO () 120 | sPutParsed socket value = do 121 | lbs <- evalLimitT maxBound $ parsedToLBS value 122 | sendLazy socket lbs 123 | 124 | -- | Read a struct from the handle using the supplied read limit, 125 | -- and return its root pointer. 126 | hGetRaw :: R.IsStruct a => Handle -> WordCount -> IO (R.Raw a 'Const) 127 | hGetRaw h limit = do 128 | msg <- M.hGetMsg h limit 129 | evalLimitT limit $ msgToRaw msg 130 | 131 | -- | Read a struct from stdin using the supplied read limit, 132 | -- and return its root pointer. 133 | getRaw :: R.IsStruct a => WordCount -> IO (R.Raw a 'Const) 134 | getRaw = hGetRaw stdin 135 | 136 | -- | Read a struct from the socket using the supplied read limit, 137 | -- and return its root pointer. 138 | sGetRaw :: R.IsStruct a => Socket -> WordCount -> IO (R.Raw a 'Const) 139 | sGetRaw socket limit = do 140 | msg <- sGetMsg socket limit 141 | evalLimitT limit $ msgToRaw msg 142 | -------------------------------------------------------------------------------- /capnp/lib/Capnp/Mutability.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE KindSignatures #-} 3 | {-# LANGUAGE RankNTypes #-} 4 | {-# LANGUAGE TypeFamilies #-} 5 | 6 | module Capnp.Mutability 7 | ( Mutability (..), 8 | MaybeMutable (..), 9 | create, 10 | createT, 11 | ) 12 | where 13 | 14 | import Control.Monad.Primitive (PrimMonad (PrimState)) 15 | import Control.Monad.ST (ST, runST) 16 | import Data.Kind (Type) 17 | 18 | -- | 'Mutability' is used as a type parameter (with the DataKinds extension) 19 | -- to indicate the mutability of some values in this library; 'Const' denotes 20 | -- an immutable value, while @'Mut' s@ denotes a value that can be mutated 21 | -- in the scope of the state token @s@. 22 | data Mutability = Const | Mut Type 23 | 24 | -- | 'MaybeMutable' relates mutable and immutable versions of a type. 25 | class MaybeMutable (f :: Mutability -> Type) where 26 | -- | Convert an immutable value to a mutable one. 27 | thaw :: (PrimMonad m, PrimState m ~ s) => f 'Const -> m (f ('Mut s)) 28 | 29 | -- | Convert a mutable value to an immutable one. 30 | freeze :: (PrimMonad m, PrimState m ~ s) => f ('Mut s) -> m (f 'Const) 31 | 32 | -- | Like 'thaw', except that the caller is responsible for ensuring that 33 | -- the original value is not subsequently used; doing so may violate 34 | -- referential transparency. 35 | -- 36 | -- The default implementation of this is just the same as 'thaw', but 37 | -- typically an instance will override this with a trivial (unsafe) cast, 38 | -- hence the obligation described above. 39 | unsafeThaw :: (PrimMonad m, PrimState m ~ s) => f 'Const -> m (f ('Mut s)) 40 | unsafeThaw = thaw 41 | 42 | -- | Unsafe version of 'freeze' analagous to 'unsafeThaw'. The caller must 43 | -- ensure that the original value is not used after this call. 44 | unsafeFreeze :: (PrimMonad m, PrimState m ~ s) => f ('Mut s) -> m (f 'Const) 45 | unsafeFreeze = freeze 46 | 47 | -- | Create and freeze a mutable value, safely, without doing a full copy. 48 | -- internally, 'create' calls unsafeFreeze, but it cannot be directly used to 49 | -- violate referential transparency, as the value is not available to the 50 | -- caller after freezing. 51 | create :: MaybeMutable f => (forall s. ST s (f ('Mut s))) -> f 'Const 52 | create st = runST (st >>= unsafeFreeze) 53 | 54 | -- | Like 'create', but the result is wrapped in an instance of 'Traversable'. 55 | createT :: (Traversable t, MaybeMutable f) => (forall s. ST s (t (f ('Mut s)))) -> t (f 'Const) 56 | createT st = runST (st >>= traverse unsafeFreeze) 57 | -------------------------------------------------------------------------------- /capnp/lib/Capnp/Repr/Parsed.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE TypeFamilies #-} 3 | {-# LANGUAGE UndecidableInstances #-} 4 | 5 | module Capnp.Repr.Parsed (Parsed) where 6 | 7 | import qualified Capnp.Basics as B 8 | import qualified Capnp.Classes as C 9 | import Capnp.Repr (List, PtrRepr (..), Repr (..), ReprFor) 10 | import Capnp.Rpc.Common (Client) 11 | import qualified Data.ByteString as BS 12 | import Data.Kind (Type) 13 | import qualified Data.Text as T 14 | 15 | -- | @'Parsed' a@ is the high-level/ADT representation of the capnproto 16 | -- type @a@. For struct types this is equivalent to @'C.Parsed' a@, but 17 | -- we special case other types, such that e.g. 18 | -- @'Parsed' 'B.Data'@ = 'BS.ByteString'. 19 | type Parsed a = ParsedByRepr (ReprFor a) a 20 | 21 | -- Helper for 'Parsed' 22 | type family ParsedByRepr (r :: Repr) (a :: Type) where 23 | ParsedByRepr ('Data _) a = a 24 | ParsedByRepr ('Ptr ('Just 'Cap)) a = Client a 25 | ParsedByRepr _ B.Data = BS.ByteString 26 | ParsedByRepr _ B.Text = T.Text 27 | ParsedByRepr _ (List a) = [Parsed a] 28 | ParsedByRepr _ (Maybe B.AnyPointer) = Maybe (C.Parsed B.AnyPointer) 29 | ParsedByRepr _ a = C.Parsed a 30 | -------------------------------------------------------------------------------- /capnp/lib/Capnp/Rpc.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module: Capnp.Rpc 3 | -- Description: Cap'n Proto RPC system 4 | -- 5 | -- This module exposes the most commonly used parts of the RPC subsystem. 6 | module Capnp.Rpc 7 | ( -- * Establishing connections 8 | Conn, 9 | ConnConfig (..), 10 | acquireConn, 11 | handleConn, 12 | withConn, 13 | requestBootstrap, 14 | 15 | -- * throwing errors 16 | throwFailed, 17 | 18 | -- * Transmitting messages 19 | Transport (..), 20 | socketTransport, 21 | handleTransport, 22 | tracingTransport, 23 | 24 | -- * Promises 25 | module Capnp.Rpc.Promise, 26 | 27 | -- * Clients 28 | Client, 29 | IsClient (..), 30 | newPromiseClient, 31 | waitClient, 32 | 33 | -- ** Reflection 34 | Untyped.unwrapServer, 35 | 36 | -- * Supervisors 37 | module Supervisors, 38 | 39 | -- * Misc. 40 | ) 41 | where 42 | 43 | import Capnp.Rpc.Errors (throwFailed) 44 | import Capnp.Rpc.Promise 45 | import Capnp.Rpc.Transport 46 | ( Transport (..), 47 | handleTransport, 48 | socketTransport, 49 | tracingTransport, 50 | ) 51 | import Capnp.Rpc.Untyped 52 | ( Client, 53 | Conn, 54 | ConnConfig (..), 55 | IsClient (..), 56 | acquireConn, 57 | handleConn, 58 | newPromiseClient, 59 | requestBootstrap, 60 | waitClient, 61 | withConn, 62 | ) 63 | import qualified Capnp.Rpc.Untyped as Untyped 64 | import Supervisors 65 | -------------------------------------------------------------------------------- /capnp/lib/Capnp/Rpc/Common.hs: -------------------------------------------------------------------------------- 1 | module Capnp.Rpc.Common 2 | ( Client (..), 3 | Pipeline (..), 4 | ) 5 | where 6 | 7 | import qualified Internal.Rpc.Breaker as Rpc 8 | 9 | -- | A @'Pipeline' a@ is a reference to possibly-not-resolved result from 10 | -- a method call. 11 | newtype Pipeline a = Pipeline Rpc.Pipeline 12 | 13 | newtype Client a = Client Rpc.Client 14 | deriving (Show, Eq) 15 | -------------------------------------------------------------------------------- /capnp/lib/Capnp/Rpc/Errors.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | 4 | -- | 5 | -- Module: Capnp.Rpc.Errors 6 | -- Description: helpers for working with capnproto exceptions. 7 | -- 8 | -- In addition to the values exposed in the API, this module also 9 | -- defines an instance of Haskell's 'E.Exception' type class, for 10 | -- Cap'n Proto's 'Exception'. 11 | module Capnp.Rpc.Errors 12 | ( -- * Converting arbitrary exceptions to capnproto exceptions 13 | wrapException, 14 | 15 | -- * Helpers for constructing exceptions 16 | eMethodUnimplemented, 17 | eUnimplemented, 18 | eDisconnected, 19 | eFailed, 20 | throwFailed, 21 | ) 22 | where 23 | 24 | import Capnp.Gen.Capnp.Rpc 25 | import qualified Control.Exception.Safe as E 26 | import Data.Default (Default (def)) 27 | import Data.Maybe (fromMaybe) 28 | import Data.String (fromString) 29 | import Data.Text (Text) 30 | 31 | -- | Construct an exception with a type field of failed and the 32 | -- given text as its reason. 33 | eFailed :: Text -> Parsed Exception 34 | eFailed reason = 35 | def 36 | { type_ = Exception'Type'failed, 37 | reason = reason 38 | } 39 | 40 | -- | An exception with type = disconnected 41 | eDisconnected :: Parsed Exception 42 | eDisconnected = 43 | def 44 | { type_ = Exception'Type'disconnected, 45 | reason = "Disconnected" 46 | } 47 | 48 | -- | An exception indicating an unimplemented method. 49 | eMethodUnimplemented :: Parsed Exception 50 | eMethodUnimplemented = 51 | eUnimplemented "Method unimplemented" 52 | 53 | -- | An @unimplemented@ exception with a custom reason message. 54 | eUnimplemented :: Text -> Parsed Exception 55 | eUnimplemented reason = 56 | def 57 | { type_ = Exception'Type'unimplemented, 58 | reason = reason 59 | } 60 | 61 | instance E.Exception (Parsed Exception) 62 | 63 | -- | @'wrapException' debugMode e@ converts an arbitrary haskell exception 64 | -- @e@ into an rpc exception, which can be communicated to a remote vat. 65 | -- If @debugMode@ is true, the returned exception's reason field will include 66 | -- the text of @show e@. 67 | wrapException :: Bool -> E.SomeException -> Parsed Exception 68 | wrapException debugMode e = 69 | fromMaybe 70 | def 71 | { type_ = Exception'Type'failed, 72 | reason = 73 | if debugMode 74 | then "Unhandled exception: " <> fromString (show e) 75 | else "Unhandled exception" 76 | } 77 | (E.fromException e) 78 | 79 | -- | Throw an exception with a type field of 'Exception'Type'failed' and 80 | -- the argument as a reason. 81 | throwFailed :: E.MonadThrow m => Text -> m a 82 | throwFailed = E.throwM . eFailed 83 | -------------------------------------------------------------------------------- /capnp/lib/Capnp/Rpc/Promise.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DuplicateRecordFields #-} 2 | {-# LANGUAGE NamedFieldPuns #-} 3 | 4 | -- | 5 | -- Module: Capnp.Rpc.Promise 6 | -- Description: Promises 7 | -- 8 | -- This module defines a 'Promise' type, represents a value which is not yet 9 | -- available, and related utilities. 10 | module Capnp.Rpc.Promise 11 | ( Promise, 12 | Fulfiller, 13 | 14 | -- * Creating promises 15 | newPromise, 16 | newReadyPromise, 17 | newPromiseWithCallback, 18 | newCallback, 19 | 20 | -- * Fulfilling or breaking promises 21 | fulfill, 22 | breakPromise, 23 | breakOrFulfill, 24 | ErrAlreadyResolved (..), 25 | 26 | -- * Getting the value of a promise 27 | wait, 28 | ) 29 | where 30 | 31 | import Capnp.Gen.Capnp.Rpc 32 | -- For exception instance: 33 | import Capnp.Rpc.Errors () 34 | import Control.Concurrent.STM 35 | import qualified Control.Exception.Safe as HsExn 36 | import Control.Monad.STM.Class 37 | import Data.Functor.Contravariant (Contravariant (..)) 38 | 39 | -- | An exception thrown if 'breakPromise' or 'fulfill' is called on an 40 | -- already-resolved fulfiller. 41 | data ErrAlreadyResolved = ErrAlreadyResolved deriving (Show) 42 | 43 | instance HsExn.Exception ErrAlreadyResolved 44 | 45 | -- | A 'Fulfiller' is used to fulfill a promise. 46 | newtype Fulfiller a = Fulfiller 47 | { callback :: Either (Parsed Exception) a -> STM () 48 | } 49 | 50 | instance Contravariant Fulfiller where 51 | contramap f Fulfiller {callback} = 52 | Fulfiller {callback = callback . fmap f} 53 | 54 | -- | Fulfill a promise by supplying the specified value. It is an error to 55 | -- call 'fulfill' if the promise has already been fulfilled (or broken). 56 | fulfill :: MonadSTM m => Fulfiller a -> a -> m () 57 | fulfill f val = breakOrFulfill f (Right val) 58 | 59 | -- | Break a promise. When the user of the promise executes 'wait', the 60 | -- specified exception will be raised. It is an error to call 'breakPromise' 61 | -- if the promise has already been fulfilled (or broken). 62 | breakPromise :: MonadSTM m => Fulfiller a -> Parsed Exception -> m () 63 | breakPromise f exn = breakOrFulfill f (Left exn) 64 | 65 | -- | 'breakOrFulfill' calls either 'breakPromise' or 'fulfill', depending 66 | -- on the argument. 67 | breakOrFulfill :: MonadSTM m => Fulfiller a -> Either (Parsed Exception) a -> m () 68 | breakOrFulfill Fulfiller {callback} result = liftSTM $ callback result 69 | 70 | -- | Wait for a promise to resolve, and return the result. If the promise 71 | -- is broken, this raises an exception instead (see 'breakPromise'). 72 | wait :: MonadSTM m => Promise a -> m a 73 | wait Promise {var} = liftSTM $ do 74 | val <- readTVar var 75 | case val of 76 | Nothing -> 77 | retry 78 | Just (Right result) -> 79 | pure result 80 | Just (Left exn) -> 81 | throwSTM exn 82 | 83 | -- | Create a promise that is already fulfilled, with the given value. 84 | newReadyPromise :: MonadSTM m => a -> m (Promise a) 85 | newReadyPromise value = liftSTM $ Promise <$> newTVar (Just (Right value)) 86 | 87 | -- | Create a new promise and an associated fulfiller. 88 | newPromise :: MonadSTM m => m (Promise a, Fulfiller a) 89 | newPromise = liftSTM $ do 90 | var <- newTVar Nothing 91 | pure 92 | ( Promise {var}, 93 | Fulfiller 94 | { callback = \result -> do 95 | val <- readTVar var 96 | case val of 97 | Nothing -> 98 | writeTVar var (Just result) 99 | Just _ -> 100 | throwSTM ErrAlreadyResolved 101 | } 102 | ) 103 | 104 | -- | Create a new promise which also excecutes an STM action when it is resolved. 105 | newPromiseWithCallback :: MonadSTM m => (Either (Parsed Exception) a -> STM ()) -> m (Promise a, Fulfiller a) 106 | newPromiseWithCallback callback = liftSTM $ do 107 | (promise, Fulfiller {callback = oldCallback}) <- newPromise 108 | pure 109 | ( promise, 110 | Fulfiller 111 | { callback = \result -> oldCallback result >> callback result 112 | } 113 | ) 114 | 115 | -- | Like 'newPromiseWithCallback', but doesn't return the promise. 116 | newCallback :: MonadSTM m => (Either (Parsed Exception) a -> STM ()) -> m (Fulfiller a) 117 | newCallback = liftSTM . fmap snd . newPromiseWithCallback 118 | 119 | -- | A promise is a value that may not be ready yet. 120 | newtype Promise a = Promise 121 | { var :: TVar (Maybe (Either (Parsed Exception) a)) 122 | } 123 | deriving (Eq) 124 | -------------------------------------------------------------------------------- /capnp/lib/Capnp/Rpc/Revoke.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | -- | Module: Capnp.Rpc.Revoke 4 | -- Description: support for revocable capababilities 5 | module Capnp.Rpc.Revoke 6 | ( makeRevocable, 7 | ) 8 | where 9 | 10 | import Capnp.Rpc.Errors (eFailed) 11 | import qualified Capnp.Rpc.Membrane as Membrane 12 | import Capnp.Rpc.Promise (breakPromise) 13 | import qualified Capnp.Rpc.Server as Server 14 | import Capnp.Rpc.Untyped (IsClient) 15 | import Control.Concurrent.STM 16 | import Control.Monad.STM.Class (MonadSTM, liftSTM) 17 | import Supervisors (Supervisor) 18 | 19 | -- | @'makeRevocable' sup cap@ returns a pair @(wrappedCap, revoke)@, such that 20 | -- @wrappedCap@ is @cap@ wrapped by a membrane which forwards all method invocations 21 | -- along until @revoke@ is executed, after which all methods that cross the membrane 22 | -- (in either direction) will return errors. 23 | -- 24 | -- Note that, as per usual with membranes, the membrane will wrap any objects returned 25 | -- by method calls. So revoke cuts off access to the entire object graph reached through 26 | -- @cap@. 27 | makeRevocable :: (MonadSTM m, IsClient c) => Supervisor -> c -> m (c, STM ()) 28 | makeRevocable sup client = liftSTM $ do 29 | isRevoked <- newTVar False 30 | wrappedClient <- Membrane.enclose sup client (revokerPolicy isRevoked) 31 | pure (wrappedClient, writeTVar isRevoked True) 32 | 33 | revokerPolicy :: TVar Bool -> Membrane.Policy 34 | revokerPolicy isRevoked _call = do 35 | revoked <- readTVar isRevoked 36 | pure $ 37 | if revoked 38 | then Membrane.Handle revokedHandler 39 | else Membrane.Forward 40 | 41 | revokedHandler :: Server.UntypedMethodHandler 42 | revokedHandler _ response = breakPromise response (eFailed "revoked") 43 | -------------------------------------------------------------------------------- /capnp/lib/Capnp/Rpc/Transport.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE DuplicateRecordFields #-} 3 | {-# LANGUAGE RecordWildCards #-} 4 | {-# LANGUAGE TypeApplications #-} 5 | 6 | -- | 7 | -- Module: Capnp.Rpc.Transport 8 | -- Description: Support for exchanging messages with remote vats. 9 | -- 10 | -- This module provides a 'Transport' type, which provides operations 11 | -- used to transmit messages between vats in the RPC protocol. 12 | module Capnp.Rpc.Transport 13 | ( Transport (..), 14 | handleTransport, 15 | socketTransport, 16 | tracingTransport, 17 | TraceConfig (..), 18 | ) 19 | where 20 | 21 | import Capnp.Bits (WordCount) 22 | import Capnp.Classes (Parsed) 23 | import Capnp.Convert (msgToParsed) 24 | import qualified Capnp.Gen.Capnp.Rpc as R 25 | import Capnp.IO (hGetMsg, hPutMsg, sGetMsg, sPutMsg) 26 | import Capnp.Message (Message, Mutability (Const)) 27 | import Capnp.TraversalLimit (evalLimitT) 28 | import Data.Default (def) 29 | import Network.Socket (Socket) 30 | import System.IO (Handle) 31 | import Text.Show.Pretty (ppShow) 32 | import Prelude hiding (log) 33 | 34 | -- | A @'Transport'@ handles transmitting RPC messages. 35 | data Transport = Transport 36 | { -- | Send a message 37 | sendMsg :: Message 'Const -> IO (), 38 | -- | Receive a message 39 | recvMsg :: IO (Message 'Const) 40 | } 41 | 42 | -- | @'handleTransport' handle limit@ is a transport which reads and writes 43 | -- messages from/to @handle@. It uses @limit@ as the traversal limit when 44 | -- reading messages and decoding. 45 | handleTransport :: Handle -> WordCount -> Transport 46 | handleTransport handle limit = 47 | Transport 48 | { sendMsg = hPutMsg handle, 49 | recvMsg = hGetMsg handle limit 50 | } 51 | 52 | -- | @'socketTransport' socket limit@ is a transport which reads and writes 53 | -- messages to/from a socket. It uses @limit@ as the traversal limit when 54 | -- reading messages and decoing. 55 | socketTransport :: Socket -> WordCount -> Transport 56 | socketTransport socket limit = 57 | Transport 58 | { sendMsg = sPutMsg socket, 59 | recvMsg = sGetMsg socket limit 60 | } 61 | 62 | data TraceConfig = TraceConfig 63 | { log :: String -> IO (), 64 | showPayloads :: !Bool 65 | } 66 | 67 | -- | @'tracingTransport' log trans@ wraps another transport @trans@, loging 68 | -- messages when they are sent or received (using the @log@ function). This 69 | -- can be useful for debugging. 70 | tracingTransport :: TraceConfig -> Transport -> Transport 71 | tracingTransport tcfg trans = 72 | Transport 73 | { sendMsg = \msg -> do 74 | rpcMsg <- evalLimitT maxBound $ msgToParsed @R.Message msg 75 | log tcfg $ "sending message: " ++ ppShow (editForTrace tcfg rpcMsg) 76 | sendMsg trans msg, 77 | recvMsg = do 78 | msg <- recvMsg trans 79 | rpcMsg <- evalLimitT maxBound $ msgToParsed @R.Message msg 80 | log tcfg $ "received message: " ++ ppShow (editForTrace tcfg rpcMsg) 81 | pure msg 82 | } 83 | 84 | editForTrace :: TraceConfig -> Parsed R.Message -> Parsed R.Message 85 | editForTrace tcfg rpcMsg = 86 | if showPayloads tcfg 87 | then rpcMsg 88 | else 89 | ( case rpcMsg of 90 | R.Message (R.Message'call call) -> 91 | R.Message $ 92 | R.Message'call $ 93 | call {R.params = def} 94 | R.Message (R.Message'return R.Return {union' = R.Return'results _, ..}) -> 95 | R.Message $ 96 | R.Message'return $ 97 | R.Return {R.union' = R.Return'results def, ..} 98 | _ -> 99 | rpcMsg 100 | ) 101 | -------------------------------------------------------------------------------- /capnp/lib/Capnp/TraversalLimit.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 3 | {-# LANGUAGE MultiParamTypeClasses #-} 4 | {-# LANGUAGE TypeFamilies #-} 5 | {-# LANGUAGE UndecidableInstances #-} 6 | 7 | -- | 8 | -- Module: Capnp.TraversalLimit 9 | -- Description: Support for managing message traversal limits. 10 | -- 11 | -- This module is used to mitigate several pitfalls with the capnproto format, 12 | -- which could potentially lead to denial of service vulnerabilities. 13 | -- 14 | -- In particular, while they are illegal according to the spec, it is possible to 15 | -- encode objects which have many pointers pointing the same place, or even 16 | -- cycles. A naive traversal therefore could involve quite a lot of computation 17 | -- for a message that is very small on the wire. 18 | -- 19 | -- Accordingly, most implementations of the format keep track of how many bytes 20 | -- of a message have been accessed, and start signaling errors after a certain 21 | -- value (the "traversal limit") has been reached. The Haskell implementation is 22 | -- no exception; this module implements that logic. We provide a monad 23 | -- transformer and mtl-style type class to track the limit; reading from the 24 | -- message happens inside of this monad. 25 | module Capnp.TraversalLimit 26 | ( MonadLimit (..), 27 | LimitT, 28 | runLimitT, 29 | evalLimitT, 30 | execLimitT, 31 | defaultLimit, 32 | ) 33 | where 34 | 35 | -- Just to define 'MonadLimit' instances: 36 | 37 | import Capnp.Bits (WordCount) 38 | import Capnp.Errors (Error (TraversalLimitError)) 39 | import Control.Monad (when) 40 | import Control.Monad.Catch (MonadCatch (catch), MonadThrow (throwM)) 41 | import Control.Monad.Fail (MonadFail (..)) 42 | import Control.Monad.IO.Class (MonadIO (..)) 43 | import Control.Monad.Primitive (PrimMonad (primitive), PrimState) 44 | import Control.Monad.RWS (RWST) 45 | import Control.Monad.Reader (ReaderT) 46 | import qualified Control.Monad.State.Lazy as LazyState 47 | import Control.Monad.State.Strict 48 | ( MonadState, 49 | StateT, 50 | evalStateT, 51 | execStateT, 52 | get, 53 | put, 54 | runStateT, 55 | ) 56 | import Control.Monad.Trans.Class (MonadTrans (lift)) 57 | import Control.Monad.Writer (WriterT) 58 | import Prelude hiding (fail) 59 | 60 | -- | mtl-style type class to track the traversal limit. This is used 61 | -- by other parts of the library which actually do the reading. 62 | class Monad m => MonadLimit m where 63 | -- | @'invoice' n@ deducts @n@ from the traversal limit, signaling 64 | -- an error if the limit is exhausted. 65 | invoice :: WordCount -> m () 66 | 67 | -- | Monad transformer implementing 'MonadLimit'. The underlying monad 68 | -- must implement 'MonadThrow'. 'invoice' calls @'throwM' 'TraversalLimitError'@ 69 | -- when the limit is exhausted. 70 | newtype LimitT m a = LimitT (StateT WordCount m a) 71 | deriving (Functor, Applicative, Monad) 72 | 73 | -- | Run a 'LimitT', returning the value from the computation and the remaining 74 | -- traversal limit. 75 | runLimitT :: MonadThrow m => WordCount -> LimitT m a -> m (a, WordCount) 76 | runLimitT limit (LimitT stateT) = runStateT stateT limit 77 | 78 | -- | Run a 'LimitT', returning the value from the computation. 79 | evalLimitT :: MonadThrow m => WordCount -> LimitT m a -> m a 80 | evalLimitT limit (LimitT stateT) = evalStateT stateT limit 81 | 82 | -- | Run a 'LimitT', returning the remaining traversal limit. 83 | execLimitT :: MonadThrow m => WordCount -> LimitT m a -> m WordCount 84 | execLimitT limit (LimitT stateT) = execStateT stateT limit 85 | 86 | -- | A sensible default traversal limit. Currently 64 MiB. 87 | defaultLimit :: WordCount 88 | defaultLimit = (64 * 1024 * 1024) `div` 8 89 | 90 | ------ Instances of mtl type classes for 'LimitT'. 91 | 92 | instance MonadThrow m => MonadThrow (LimitT m) where 93 | throwM = lift . throwM 94 | 95 | instance MonadCatch m => MonadCatch (LimitT m) where 96 | catch (LimitT m) f = LimitT $ do 97 | catch m $ \e -> 98 | let LimitT m' = f e 99 | in m' 100 | 101 | instance MonadThrow m => MonadLimit (LimitT m) where 102 | invoice deduct = LimitT $ do 103 | limit <- get 104 | when (limit < deduct) $ throwM TraversalLimitError 105 | put (limit - deduct) 106 | 107 | instance MonadTrans LimitT where 108 | lift = LimitT . lift 109 | 110 | instance MonadState s m => MonadState s (LimitT m) where 111 | get = lift get 112 | put = lift . put 113 | 114 | instance (PrimMonad m, s ~ PrimState m) => PrimMonad (LimitT m) where 115 | type PrimState (LimitT m) = PrimState m 116 | primitive = lift . primitive 117 | 118 | instance MonadFail m => MonadFail (LimitT m) where 119 | fail = lift . fail 120 | 121 | instance MonadIO m => MonadIO (LimitT m) where 122 | liftIO = lift . liftIO 123 | 124 | ------ Instances of 'MonadLimit' for standard monad transformers 125 | 126 | instance MonadLimit m => MonadLimit (StateT s m) where 127 | invoice = lift . invoice 128 | 129 | instance MonadLimit m => MonadLimit (LazyState.StateT s m) where 130 | invoice = lift . invoice 131 | 132 | instance (Monoid w, MonadLimit m) => MonadLimit (WriterT w m) where 133 | invoice = lift . invoice 134 | 135 | instance (MonadLimit m) => MonadLimit (ReaderT r m) where 136 | invoice = lift . invoice 137 | 138 | instance (Monoid w, MonadLimit m) => MonadLimit (RWST r w s m) where 139 | invoice = lift . invoice 140 | -------------------------------------------------------------------------------- /capnp/lib/Data/Mutable.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Rank2Types #-} 2 | {-# LANGUAGE TypeFamilies #-} 3 | 4 | -- | 5 | -- Module: Data.Mutable 6 | -- Description: Generic support for converting between mutable and immutable values. 7 | -- 8 | -- There is a common pattern in Haskell libraries that work with mutable data: 9 | -- 10 | -- * Two types, a mutable and an immutable variant of the same structure. 11 | -- * @thaw@ and @freeze@ functions to convert between these. 12 | -- * Sometimes unsafe variants of @thaw@ and @freeze@, which avoid a copy but 13 | -- can break referential transparency if misused. 14 | -- 15 | -- This module abstracts out the above pattern into a generic type family 'Thaw', 16 | -- and provides some of the common higher-level tools built on top of these 17 | -- primitives. 18 | -- 19 | -- Note that there's nothing terribly Cap'N Proto specific about this module; we 20 | -- may even factor it out into a separate package at some point. 21 | module Data.Mutable {-# DEPRECATED "use Capnp.Mutability instead" #-} where 22 | 23 | import Control.Monad.Primitive (PrimMonad, PrimState) 24 | import Control.Monad.ST (ST, runST) 25 | 26 | -- | The 'Thaw' type class relates mutable and immutable versions of a type. 27 | -- The instance is defined on the immutable variant; @'Mutable' s a@ is the 28 | -- mutable version of an immutable type @a@, bound to the state token @s@. 29 | class Thaw a where 30 | -- | The mutable version of @a@, bound to the state token @s@. 31 | type Mutable s a 32 | 33 | -- | Convert an immutable value to a mutable one. 34 | thaw :: (PrimMonad m, PrimState m ~ s) => a -> m (Mutable s a) 35 | 36 | -- | Convert a mutable value to an immutable one. 37 | freeze :: (PrimMonad m, PrimState m ~ s) => Mutable s a -> m a 38 | 39 | -- | Like 'thaw', except that the caller is responsible for ensuring that 40 | -- the original value is not subsequently used; doing so may violate 41 | -- referential transparency. 42 | -- 43 | -- The default implementation of this is just the same as 'thaw', but 44 | -- typically an instance will override this with a trivial (unsafe) cast, 45 | -- hence the obligation described above. 46 | unsafeThaw :: (PrimMonad m, PrimState m ~ s) => a -> m (Mutable s a) 47 | unsafeThaw = thaw 48 | 49 | -- | Unsafe version of 'freeze' analagous to 'unsafeThaw'. The caller must 50 | -- ensure that the original value is not used after this call. 51 | unsafeFreeze :: (PrimMonad m, PrimState m ~ s) => Mutable s a -> m a 52 | unsafeFreeze = freeze 53 | 54 | -- | Create and freeze a mutable value, safely, without doing a full copy. 55 | -- internally, 'create' calls unsafeFreeze, but it cannot be directly used to 56 | -- violate referential transparency, as the value is not available to the 57 | -- caller after freezing. 58 | create :: Thaw a => (forall s. ST s (Mutable s a)) -> a 59 | create st = runST (st >>= unsafeFreeze) 60 | 61 | -- | Like 'create', but the result is wrapped in an instance of 'Traversable'. 62 | createT :: (Traversable f, Thaw a) => (forall s. ST s (f (Mutable s a))) -> f a 63 | createT st = runST (st >>= traverse unsafeFreeze) 64 | -------------------------------------------------------------------------------- /capnp/lib/Internal/AppendVec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NamedFieldPuns #-} 2 | {-# LANGUAGE TypeFamilies #-} 3 | 4 | -- | 5 | -- Module: Internal.AppendVec 6 | -- Description: Helpers for efficient appending to vectors. 7 | module Internal.AppendVec 8 | ( AppendVec, 9 | fromVector, 10 | makeEmpty, 11 | getVector, 12 | getCapacity, 13 | grow, 14 | canGrowWithoutCopy, 15 | ) 16 | where 17 | 18 | import Capnp.Errors (Error (SizeError)) 19 | import Control.Monad (when) 20 | import Control.Monad.Catch (MonadThrow (throwM)) 21 | import Control.Monad.Primitive (PrimMonad, PrimState) 22 | import qualified Data.Vector.Generic.Mutable as GMV 23 | 24 | -- | 'AppendVec' wraps a mutable vector, and affords amortized O(1) appending. 25 | data AppendVec v s a = AppendVec 26 | { mutVec :: v s a, 27 | mutVecLen :: !Int 28 | } 29 | 30 | -- | 'fromVector' wraps a mutable vector in an appendVector, with no initial 31 | -- spare capacity. 32 | fromVector :: GMV.MVector v a => v s a -> AppendVec v s a 33 | fromVector vec = 34 | AppendVec 35 | { mutVec = vec, 36 | mutVecLen = GMV.length vec 37 | } 38 | 39 | -- | 'makeEmpty' makes an initially empty 'AppendVec', using the argument 40 | -- as allocation space for 'grow'. 41 | makeEmpty :: GMV.MVector v a => v s a -> AppendVec v s a 42 | makeEmpty vec = 43 | AppendVec 44 | { mutVec = vec, 45 | mutVecLen = 0 46 | } 47 | 48 | -- | 'getVector' returns the valid portion of the underlying mutable vector. 49 | getVector :: GMV.MVector v a => AppendVec v s a -> v s a 50 | getVector AppendVec {mutVec, mutVecLen} = GMV.slice 0 mutVecLen mutVec 51 | 52 | getCapacity :: GMV.MVector v a => AppendVec v s a -> Int 53 | getCapacity AppendVec {mutVec} = GMV.length mutVec 54 | 55 | -- | @'grow' vec amount maxSize@ grows the vector @vec@ by @amount@ elements, 56 | -- provided the result does not exceed @maxSize@. Amortized O(@amount@). Returns 57 | -- the new vector; the original should not be used. 58 | -- . 59 | -- If the result does exceed @maxSize@, throws 'SizeError'. 60 | grow :: 61 | (MonadThrow m, PrimMonad m, s ~ PrimState m, GMV.MVector v a) => 62 | AppendVec v s a -> 63 | Int -> 64 | Int -> 65 | m (AppendVec v s a) 66 | grow vec@AppendVec {mutVec, mutVecLen} amount maxSize = do 67 | when (maxSize - amount < mutVecLen) $ 68 | throwM SizeError 69 | mutVec <- 70 | if canGrowWithoutCopy vec amount 71 | then -- we have enough un-allocated space already; leave the vector 72 | -- itself alone. 73 | pure mutVec 74 | else -- Allocate some more space. we at least double the underlying 75 | -- vector's size, to make appending amortized O(1), but if the 76 | -- vector is small enough and the allocation is big enough, we 77 | -- may need to do more to satisfy the request: 78 | GMV.grow mutVec (max amount (mutVecLen * 2)) 79 | pure 80 | AppendVec 81 | { mutVec = mutVec, 82 | mutVecLen = mutVecLen + amount 83 | } 84 | 85 | canGrowWithoutCopy :: (GMV.MVector v a) => AppendVec v s a -> Int -> Bool 86 | canGrowWithoutCopy AppendVec {mutVec, mutVecLen} amount = 87 | mutVecLen + amount <= GMV.length mutVec 88 | -------------------------------------------------------------------------------- /capnp/lib/Internal/BuildPure.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 3 | {-# LANGUAGE Rank2Types #-} 4 | {-# LANGUAGE TypeFamilies #-} 5 | 6 | -- | 7 | -- Module: Internal.BuildPure 8 | -- Description: Helpers for building capnproto messages in pure code. 9 | -- 10 | -- This module provides some helpers for building capnproto messages and values 11 | -- in pure code, using the low-level API. 12 | module Internal.BuildPure 13 | ( PureBuilder, 14 | createPure, 15 | ) 16 | where 17 | 18 | import Capnp.Bits (WordCount) 19 | import Capnp.Mutability 20 | import Capnp.TraversalLimit (LimitT, MonadLimit, evalLimitT) 21 | import Control.Monad.Catch (Exception, MonadThrow (..), SomeException) 22 | import Control.Monad.Primitive (PrimMonad (..)) 23 | import Control.Monad.ST (ST) 24 | import Internal.STE 25 | 26 | -- | 'PureBuilder' is a monad transformer stack with the instnaces needed 27 | -- manipulate mutable messages. @'PureBuilder' s a@ is morally equivalent 28 | -- to @'LimitT' ('CatchT' ('ST' s)) a@ 29 | newtype PureBuilder s a = PureBuilder (LimitT (STE SomeException s) a) 30 | deriving (Functor, Applicative, Monad, MonadThrow, MonadLimit) 31 | 32 | instance PrimMonad (PureBuilder s) where 33 | type PrimState (PureBuilder s) = s 34 | primitive = PureBuilder . primitive 35 | 36 | runPureBuilder :: WordCount -> PureBuilder s a -> ST s (Either SomeException a) 37 | runPureBuilder limit (PureBuilder m) = steToST $ evalLimitT limit m 38 | 39 | -- | @'createPure' limit m@ creates a capnproto value in pure code according 40 | -- to @m@, then freezes it without copying. If @m@ calls 'throwM' then 41 | -- 'createPure' rethrows the exception in the specified monad. 42 | createPure :: (MonadThrow m, MaybeMutable f) => WordCount -> (forall s. PureBuilder s (f ('Mut s))) -> m (f 'Const) 43 | createPure limit m = throwLeft $ createT (runPureBuilder limit m) 44 | where 45 | -- I(zenhack) am surprised not to have found this in one of the various 46 | -- exception packages: 47 | throwLeft :: (Exception e, MonadThrow m) => Either e a -> m a 48 | throwLeft (Left e) = throwM e 49 | throwLeft (Right a) = pure a 50 | -------------------------------------------------------------------------------- /capnp/lib/Internal/Rc.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | {-# LANGUAGE NamedFieldPuns #-} 3 | 4 | -- | 5 | -- Module: Internal.Rc 6 | -- Description: Reference counted boxes. 7 | -- 8 | -- This module provides a reference-counted cell type 'Rc', which contains a 9 | -- value and a finalizer. When the reference count reaches zero, the value is 10 | -- dropped and the finalizer is run. 11 | module Internal.Rc 12 | ( Rc, 13 | new, 14 | get, 15 | incr, 16 | decr, 17 | release, 18 | ) 19 | where 20 | 21 | import Control.Concurrent.STM 22 | 23 | -- | A reference-counted container for a value of type @a@. 24 | newtype Rc a 25 | = Rc (TVar (Maybe (RcState a))) 26 | deriving (Eq) 27 | 28 | data RcState a = RcState 29 | { refCount :: !Int, 30 | value :: a, 31 | finalizer :: STM () 32 | } 33 | 34 | -- | @'new' val finalizer@ creates a new 'Rc' containing the value @val@, with 35 | -- an initial reference count of 1. When the reference count drops to zero, the 36 | -- finalizer will be run. 37 | new :: a -> STM () -> STM (Rc a) 38 | new value finalizer = 39 | fmap Rc $ 40 | newTVar $ 41 | Just 42 | RcState 43 | { refCount = 1, 44 | value, 45 | finalizer 46 | } 47 | 48 | -- | Increment the reference count. 49 | incr :: Rc a -> STM () 50 | incr (Rc tv) = modifyTVar' tv $ 51 | fmap $ 52 | \s@RcState {refCount} -> s {refCount = refCount + 1} 53 | 54 | -- | Decrement the reference count. If this brings the count to zero, run the 55 | -- finalizer and release the value. 56 | decr :: Rc a -> STM () 57 | decr (Rc tv) = 58 | readTVar tv >>= \case 59 | Nothing -> 60 | pure () 61 | Just RcState {refCount = 1, finalizer} -> do 62 | writeTVar tv Nothing 63 | finalizer 64 | Just s@RcState {refCount} -> 65 | writeTVar tv $ Just s {refCount = refCount - 1} 66 | 67 | -- | Release the value immediately, and run the finalizer, regardless of the 68 | -- current reference count. 69 | release :: Rc a -> STM () 70 | release (Rc tv) = 71 | readTVar tv >>= \case 72 | Nothing -> 73 | pure () 74 | Just RcState {finalizer} -> do 75 | finalizer 76 | writeTVar tv Nothing 77 | 78 | -- | Fetch the value, or 'Nothing' if it has been released. 79 | get :: Rc a -> STM (Maybe a) 80 | get (Rc tv) = fmap value <$> readTVar tv 81 | -------------------------------------------------------------------------------- /capnp/lib/Internal/Rpc/Breaker.hs: -------------------------------------------------------------------------------- 1 | -- | Module: Internal.Rpc.Breaker 2 | -- 3 | -- This module serves to break a dependency cycle between the rpc 4 | -- system and the serialization code; see Note [Breaker] in 5 | -- "Capnp.Rpc.Untyped" for details. 6 | module Internal.Rpc.Breaker 7 | ( Client (..), 8 | Pipeline (..), 9 | nullClient, 10 | invalidClient, 11 | -- | ** Internals 12 | Opaque, 13 | makeOpaque, 14 | reflectOpaque, 15 | ) 16 | where 17 | 18 | import Data.Dynamic (Dynamic, Typeable, fromDynamic, toDyn) 19 | 20 | -- | A reference to a capability, which may be live either in the current vat 21 | -- or elsewhere. Holding a client affords making method calls on a capability 22 | -- or modifying the local vat's reference count to it. 23 | newtype Client = Client Opaque 24 | deriving (Eq) 25 | 26 | instance Show Client where 27 | show client@(Client opaque) = 28 | if client == nullClient 29 | then "nullClient" 30 | else case fromDynamic (reflectOpaque opaque) of 31 | Just (InvalidClient errMsg) -> "(invalidClient" ++ show errMsg ++ ")" 32 | Nothing -> "({- capability; not statically representable -})" 33 | 34 | -- | A 'Pipeline' is a reference to a value within a message that has not yet arrived. 35 | newtype Pipeline = Pipeline Opaque 36 | 37 | -- | A null client. This is the only client value that can be represented 38 | -- statically. Throws exceptions in response to all method calls. 39 | nullClient :: Client 40 | nullClient = Client $ makeOpaque () 41 | 42 | newtype InvalidClient = InvalidClient String 43 | deriving (Show, Read, Eq, Typeable) 44 | 45 | -- | Returns a client which is "invalid;" it behaves like 'nullClient', 46 | -- but can be given a custom error message that is displayed by 'show'. 47 | invalidClient :: String -> Client 48 | invalidClient = Client . makeOpaque . InvalidClient 49 | 50 | data Opaque = Opaque 51 | { opDyn :: Dynamic, 52 | opEq :: Opaque -> Bool 53 | } 54 | 55 | makeOpaque :: (Typeable a, Eq a) => a -> Opaque 56 | makeOpaque v = 57 | Opaque 58 | { opDyn = toDyn v, 59 | opEq = \o -> fromDynamic (opDyn o) == Just v 60 | } 61 | 62 | reflectOpaque :: Opaque -> Dynamic 63 | reflectOpaque = opDyn 64 | 65 | instance Eq Opaque where 66 | x == y = opEq x y 67 | -------------------------------------------------------------------------------- /capnp/lib/Internal/Rpc/Export.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RankNTypes #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | {-# LANGUAGE TypeApplications #-} 4 | 5 | module Internal.Rpc.Export (export) where 6 | 7 | import Capnp.Rpc.Common (Client (..)) 8 | import Capnp.Rpc.Server 9 | import qualified Capnp.Rpc.Untyped as URpc 10 | import Control.Monad.STM.Class (MonadSTM (liftSTM)) 11 | import Data.Proxy (Proxy (..)) 12 | import Supervisors (Supervisor) 13 | 14 | -- | Export the server as a client for interface @i@. Spawns a server thread 15 | -- with its lifetime bound to the supervisor. 16 | export :: forall i s m. (MonadSTM m, Export i, Server i s, SomeServer s) => Supervisor -> s -> m (Client i) 17 | export sup srv = liftSTM $ Client <$> URpc.export sup (exportToServerOps (Proxy @i) srv) 18 | -------------------------------------------------------------------------------- /capnp/lib/Internal/STE.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | {-# LANGUAGE DerivingStrategies #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 5 | {-# LANGUAGE RankNTypes #-} 6 | {-# LANGUAGE ScopedTypeVariables #-} 7 | {-# LANGUAGE TypeFamilies #-} 8 | 9 | -- | Simplified implementation of the monad-ste package, 10 | -- with a few extras. 11 | module Internal.STE 12 | ( STE, 13 | throwSTE, 14 | runSTE, 15 | liftST, 16 | steToST, 17 | steToIO, 18 | ) 19 | where 20 | 21 | import Control.Exception 22 | import Control.Monad.Catch (MonadThrow (..)) 23 | import Control.Monad.Primitive (PrimMonad (..)) 24 | import Control.Monad.ST 25 | import Control.Monad.ST.Unsafe 26 | import Data.Typeable (Typeable) 27 | 28 | newtype InternalErr e = InternalErr e 29 | deriving stock (Typeable) 30 | 31 | instance Show (InternalErr e) where 32 | show _ = "(InternalErr _)" 33 | 34 | instance Typeable e => Exception (InternalErr e) 35 | 36 | newtype STE e s a = STE (IO a) 37 | deriving newtype (Functor, Applicative, Monad) 38 | 39 | instance PrimMonad (STE e s) where 40 | type PrimState (STE e s) = s 41 | primitive = liftST . primitive 42 | 43 | liftST :: ST s a -> STE e s a 44 | liftST st = STE (unsafeSTToIO st) 45 | 46 | throwSTE :: Exception e => e -> STE e s a 47 | throwSTE e = STE (throwIO (InternalErr e)) 48 | 49 | runSTE :: Exception e => (forall s. STE e s a) -> Either e a 50 | runSTE ste = runST (steToST ste) 51 | 52 | steToST :: Typeable e => STE e s a -> ST s (Either e a) 53 | steToST (STE io) = unsafeIOToST $ do 54 | res <- try io 55 | case res of 56 | Left (InternalErr e) -> pure $ Left e 57 | Right v -> pure $ Right v 58 | 59 | steToIO :: forall e a. Exception e => STE e RealWorld a -> IO a 60 | steToIO (STE io) = do 61 | res <- try io 62 | case res of 63 | Left (InternalErr (e :: e)) -> throwIO e 64 | Right v -> pure v 65 | 66 | instance MonadThrow (STE SomeException s) where 67 | throwM = throwSTE . toException 68 | -------------------------------------------------------------------------------- /capnp/lib/Internal/SnocList.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 2 | 3 | module Internal.SnocList 4 | ( SnocList, 5 | fromList, 6 | empty, 7 | snoc, 8 | singleton, 9 | ) 10 | where 11 | 12 | import Data.Foldable 13 | import Data.Hashable (Hashable) 14 | 15 | -- | A 'SnocList' is just a list, but with efficient appending instead of 16 | -- prepending. The indended use case is when you want to append a bunch of 17 | -- things to a list, and then get the final list to work with. 18 | -- 19 | -- A standard trick for this is to cons each element onto the *front* of 20 | -- the list, and then reverse the list before processing. A SnocList 21 | -- just packages up this trick so you can't forget to do the reverse. 22 | newtype SnocList a = SnocList [a] 23 | deriving (Eq, Hashable) 24 | 25 | -- | Convert a list to a 'SnocList'. O(n) 26 | fromList :: [a] -> SnocList a 27 | fromList = SnocList . reverse 28 | 29 | -- | A one-element 'SnocList'. 30 | singleton :: a -> SnocList a 31 | singleton x = SnocList [x] 32 | 33 | -- | The empty 'SnocList'. 34 | empty :: SnocList a 35 | empty = SnocList [] 36 | 37 | -- | Append a value to the 'SnocList'. A note on the name: 'snoc' is @cons@ 38 | -- backwards. 39 | snoc :: SnocList a -> a -> SnocList a 40 | snoc (SnocList xs) x = SnocList (x : xs) 41 | 42 | instance Foldable SnocList where 43 | foldMap f = foldMap f . toList 44 | toList (SnocList xs) = reverse xs 45 | 46 | instance Semigroup (SnocList a) where 47 | (SnocList l) <> (SnocList r) = SnocList (r <> l) 48 | 49 | instance Monoid (SnocList a) where 50 | mempty = empty 51 | -------------------------------------------------------------------------------- /capnp/lib/Internal/TCloseQ.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NamedFieldPuns #-} 2 | {-# LANGUAGE RecordWildCards #-} 3 | 4 | -- | 5 | -- Module: Internal.TCloseQ 6 | -- Description: Transactional queues with a close operation. 7 | -- 8 | -- This module provides a thin layer over 'TQueue', which affords "closing" 9 | -- queues. Reading from a closed queue returns 'Nothing'. 10 | module Internal.TCloseQ 11 | ( Q, 12 | ErrClosed (..), 13 | new, 14 | read, 15 | write, 16 | close, 17 | ) 18 | where 19 | 20 | import Control.Concurrent.STM 21 | import Control.Exception (Exception) 22 | import Control.Monad (unless, when) 23 | import Data.Maybe (isNothing) 24 | import Prelude hiding (read) 25 | 26 | -- | A Queue with a close operation, with element type @a@. 27 | data Q a = Q 28 | { q :: TQueue (Maybe a), 29 | isClosed :: TVar Bool 30 | } 31 | 32 | -- | An exception which is thrown if a caller tries to write to a closed queue. 33 | data ErrClosed = ErrClosed 34 | deriving (Show) 35 | 36 | instance Exception ErrClosed 37 | 38 | -- | Create a new empty queue. 39 | new :: STM (Q a) 40 | new = do 41 | q <- newTQueue 42 | isClosed <- newTVar False 43 | pure Q {..} 44 | 45 | -- | Read a value from the queue. Returns Nothing if the queue is closed. 46 | read :: Q a -> STM (Maybe a) 47 | read Q {q} = do 48 | ret <- readTQueue q 49 | when (isNothing ret) $ 50 | -- put it back in, so future reads also return nothing: 51 | writeTQueue q ret 52 | pure ret 53 | 54 | -- | Write a value to the queue, which must not be closed. If it is closed, 55 | -- this will throw 'ErrClosed'. 56 | write :: Q a -> a -> STM () 57 | write Q {q, isClosed} v = do 58 | c <- readTVar isClosed 59 | when c $ throwSTM ErrClosed 60 | writeTQueue q (Just v) 61 | 62 | -- | Close a queue. It is safe to close a queue more than once; subsequent 63 | -- closes will have no effect. 64 | close :: Q a -> STM () 65 | close Q {q, isClosed} = do 66 | c <- readTVar isClosed 67 | unless c $ do 68 | writeTVar isClosed True 69 | writeTQueue q Nothing 70 | -------------------------------------------------------------------------------- /ci/Dockerfile: -------------------------------------------------------------------------------- 1 | FROM alpine:3.12 2 | WORKDIR /usr/src/ 3 | 4 | # Cabal does not like busybox's wget: 5 | RUN apk add wget 6 | 7 | RUN apk add curl 8 | RUN apk add build-base 9 | RUN apk add ghc cabal 10 | 11 | # Install the linters up front; this saves a lot of build time during the actual 12 | # CI run. 13 | RUN cabal update 14 | RUN cabal install happy alex 15 | RUN cabal install hlint stylish-haskell 16 | 17 | # We're getting an error from cabal re: creating these symlinks automatically, 18 | # so we just do it ourselves. TODO: figure out why this is happening 19 | 20 | RUN ln -s /root/.cabal/bin/hlint /usr/local/bin/hlint 21 | RUN ln -s /root/.cabal/bin/stylish-haskell /usr/local/bin/stylish-haskell 22 | 23 | # Install stuff needed to build capnproto: 24 | RUN apk add \ 25 | autoconf \ 26 | automake \ 27 | libtool \ 28 | linux-headers 29 | 30 | # Build and install a recent version of capnproto; the distro version is 31 | # outdated. Furthermore, we use the calculator-client & server examples as 32 | # part of our test suite, so we need to build that anyway: 33 | RUN wget "https://github.com/capnproto/capnproto/archive/v0.8.0.tar.gz" 34 | RUN tar -xvf *.tar.gz 35 | RUN cd capnproto-*/c++ && \ 36 | autoreconf -i && \ 37 | ./configure --prefix=/usr/local && \ 38 | make -j && \ 39 | make install 40 | 41 | # Build and install the C++ calculator example client & server, which 42 | # we'll use to validate our own implementations: 43 | RUN cd capnproto-*/c++/samples && \ 44 | capnpc -oc++ calculator.capnp && \ 45 | c++ \ 46 | calculator-client.c++ \ 47 | -std=c++14 \ 48 | calculator.capnp.c++ \ 49 | $(pkg-config --cflags --libs capnp-rpc) \ 50 | -o calculator-client && \ 51 | c++ \ 52 | calculator-server.c++ \ 53 | -std=c++14 \ 54 | calculator.capnp.c++ \ 55 | $(pkg-config --cflags --libs capnp-rpc) \ 56 | -o calculator-server && \ 57 | install -Dm755 calculator-client /usr/local/bin/c++-calculator-client && \ 58 | install -Dm755 calculator-server /usr/local/bin/c++-calculator-server 59 | 60 | # Add other tools we use during the run: 61 | RUN apk add \ 62 | git 63 | -------------------------------------------------------------------------------- /ci/README.md: -------------------------------------------------------------------------------- 1 | This directory contains the Dockerfile used to build: 2 | 3 | 4 | 5 | ...which is used by ../.gitlab-ci.yml. 6 | -------------------------------------------------------------------------------- /core-schema/README.md: -------------------------------------------------------------------------------- 1 | This directory contains the unmodified schema shipped with the capnproto 2 | (C++) reference implementation. They are used to generate the modules 3 | under `../lib/Capnp/Gen`. 4 | -------------------------------------------------------------------------------- /core-schema/capnp/c++.capnp: -------------------------------------------------------------------------------- 1 | # Copyright (c) 2013-2014 Sandstorm Development Group, Inc. and contributors 2 | # Licensed under the MIT License: 3 | # 4 | # Permission is hereby granted, free of charge, to any person obtaining a copy 5 | # of this software and associated documentation files (the "Software"), to deal 6 | # in the Software without restriction, including without limitation the rights 7 | # to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 8 | # copies of the Software, and to permit persons to whom the Software is 9 | # furnished to do so, subject to the following conditions: 10 | # 11 | # The above copyright notice and this permission notice shall be included in 12 | # all copies or substantial portions of the Software. 13 | # 14 | # THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 15 | # IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 16 | # FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 17 | # AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 18 | # LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 19 | # OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 20 | # THE SOFTWARE. 21 | 22 | @0xbdf87d7bb8304e81; 23 | $namespace("capnp::annotations"); 24 | 25 | annotation namespace(file): Text; 26 | annotation name(field, enumerant, struct, enum, interface, method, param, group, union): Text; 27 | -------------------------------------------------------------------------------- /core-schema/capnp/compat/json.capnp: -------------------------------------------------------------------------------- 1 | # Copyright (c) 2015 Sandstorm Development Group, Inc. and contributors 2 | # Licensed under the MIT License: 3 | # 4 | # Permission is hereby granted, free of charge, to any person obtaining a copy 5 | # of this software and associated documentation files (the "Software"), to deal 6 | # in the Software without restriction, including without limitation the rights 7 | # to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 8 | # copies of the Software, and to permit persons to whom the Software is 9 | # furnished to do so, subject to the following conditions: 10 | # 11 | # The above copyright notice and this permission notice shall be included in 12 | # all copies or substantial portions of the Software. 13 | # 14 | # THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 15 | # IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 16 | # FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 17 | # AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 18 | # LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 19 | # OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 20 | # THE SOFTWARE. 21 | 22 | @0x8ef99297a43a5e34; 23 | 24 | $import "/capnp/c++.capnp".namespace("capnp::json"); 25 | 26 | struct Value { 27 | union { 28 | null @0 :Void; 29 | boolean @1 :Bool; 30 | number @2 :Float64; 31 | string @3 :Text; 32 | array @4 :List(Value); 33 | object @5 :List(Field); 34 | # Standard JSON values. 35 | 36 | call @6 :Call; 37 | # Non-standard: A "function call", applying a named function (named by a single identifier) 38 | # to a parameter list. Examples: 39 | # 40 | # BinData(0, "Zm9vCg==") 41 | # ISODate("2015-04-15T08:44:50.218Z") 42 | # 43 | # Mongo DB users will recognize the above as exactly the syntax Mongo uses to represent BSON 44 | # "binary" and "date" types in text, since JSON has no analog of these. This is basically the 45 | # reason this extension exists. We do NOT recommend using `call` unless you specifically need 46 | # to be compatible with some silly format that uses this syntax. 47 | } 48 | 49 | struct Field { 50 | name @0 :Text; 51 | value @1 :Value; 52 | } 53 | 54 | struct Call { 55 | function @0 :Text; 56 | params @1 :List(Value); 57 | } 58 | } 59 | 60 | # ======================================================================================== 61 | # Annotations to control parsing. Typical usage: 62 | # 63 | # using Json = import "/capnp/compat/json.capnp"; 64 | # 65 | # And then later on: 66 | # 67 | # myField @0 :Text $Json.name("my_field"); 68 | 69 | annotation name @0xfa5b1fd61c2e7c3d (field, enumerant, method, group, union) :Text; 70 | # Define an alternative name to use when encoding the given item in JSON. This can be used, for 71 | # example, to use snake_case names where needed, even though Cap'n Proto uses strictly camelCase. 72 | # 73 | # (However, because JSON is derived from JavaScript, you *should* use camelCase names when 74 | # defining JSON-based APIs. But, when supporting a pre-existing API you may not have a choice.) 75 | 76 | annotation flatten @0x82d3e852af0336bf (field, group, union) :FlattenOptions; 77 | # Specifies that an aggregate field should be flattened into its parent. 78 | # 79 | # In order to flatten a member of a union, the union (or, for an anonymous union, the parent 80 | # struct type) must have the $jsonDiscriminator annotation. 81 | # 82 | # TODO(someday): Maybe support "flattening" a List(Value.Field) as a way to support unknown JSON 83 | # fields? 84 | 85 | struct FlattenOptions { 86 | prefix @0 :Text = ""; 87 | # Optional: Adds the given prefix to flattened field names. 88 | } 89 | 90 | annotation discriminator @0xcfa794e8d19a0162 (struct, union) :DiscriminatorOptions; 91 | # Specifies that a union's variant will be decided not by which fields are present, but instead 92 | # by a special discriminator field. The value of the discriminator field is a string naming which 93 | # variant is active. This allows the members of the union to have the $jsonFlatten annotation, or 94 | # to all have the same name. 95 | 96 | struct DiscriminatorOptions { 97 | name @0 :Text; 98 | # The name of the discriminator field. Defaults to matching the name of the union. 99 | 100 | valueName @1 :Text; 101 | # If non-null, specifies that the union's value shall have the given field name, rather than the 102 | # value's name. In this case the union's variant can only be determined by looking at the 103 | # discriminant field, not by inspecting which value field is present. 104 | # 105 | # It is an error to use `valueName` while also declaring some variants as $flatten. 106 | } 107 | 108 | annotation base64 @0xd7d879450a253e4b (field) :Void; 109 | # Place on a field of type `Data` to indicate that its JSON representation is a Base64 string. 110 | 111 | annotation hex @0xf061e22f0ae5c7b5 (field) :Void; 112 | # Place on a field of type `Data` to indicate that its JSON representation is a hex string. 113 | 114 | annotation notification @0xa0a054dea32fd98c (method) :Void; 115 | # Indicates that this method is a JSON-RPC "notification", meaning it expects no response. 116 | -------------------------------------------------------------------------------- /core-schema/capnp/stream.capnp: -------------------------------------------------------------------------------- 1 | # Copyright (c) 2019 Cloudflare, Inc. and contributors 2 | # Licensed under the MIT License: 3 | # 4 | # Permission is hereby granted, free of charge, to any person obtaining a copy 5 | # of this software and associated documentation files (the "Software"), to deal 6 | # in the Software without restriction, including without limitation the rights 7 | # to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 8 | # copies of the Software, and to permit persons to whom the Software is 9 | # furnished to do so, subject to the following conditions: 10 | # 11 | # The above copyright notice and this permission notice shall be included in 12 | # all copies or substantial portions of the Software. 13 | # 14 | # THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 15 | # IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 16 | # FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 17 | # AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 18 | # LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 19 | # OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 20 | # THE SOFTWARE. 21 | 22 | @0x86c366a91393f3f8; 23 | # Defines placeholder types used to provide backwards-compatibility while introducing streaming 24 | # to the language. The goal is that old code generators that don't know about streaming can still 25 | # generate code that functions, leaving it up to the application to implement flow control 26 | # manually. 27 | 28 | $import "/capnp/c++.capnp".namespace("capnp"); 29 | 30 | struct StreamResult @0x995f9a3377c0b16e { 31 | # Empty struct that serves as the return type for "streaming" methods. 32 | # 33 | # Defining a method like: 34 | # 35 | # write @0 (bytes :Data) -> stream; 36 | # 37 | # Is equivalent to: 38 | # 39 | # write @0 (bytes :Data) -> import "/capnp/stream.capnp".StreamResult; 40 | # 41 | # However, implementations that recognize streaming will elide the reference to StreamResult 42 | # and instead give write() a different signature appropriate for streaming. 43 | # 44 | # Streaming methods do not return a result -- that is, they return Promise. This promise 45 | # resolves not to indicate that the call was actually delivered, but instead to provide 46 | # backpressure. When the previous call's promise resolves, it is time to make another call. On 47 | # the client side, the RPC system will resolve promises immediately until an appropriate number 48 | # of requests are in-flight, and then will delay promise resolution to apply back-pressure. 49 | # On the server side, the RPC system will deliver one call at a time. 50 | } 51 | -------------------------------------------------------------------------------- /scripts/README.md: -------------------------------------------------------------------------------- 1 | This directory contains a few helper scripts for development. 2 | 3 | * `regen.sh` rebuilds the schema compiler plugin, and uses it to 4 | re-generate modules for the core capnproto schema. 5 | * `format.sh` runs `stylish-haskell` on the source tree (except for 6 | generated code). 7 | * `hlint.sh` runs `hlint` on the source tree (except for generated 8 | code). 9 | * `gen-basic-instances.hs` generates the module 10 | `Internal.Gen.Instances`, which contains a lot of boilerplate. 11 | -------------------------------------------------------------------------------- /scripts/format.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env sh 2 | # 3 | # Format the whole source tree with stylish-haskell. Skip generated output. 4 | set -e 5 | cd "$(dirname $0)/.." 6 | stylish-haskell -i $(find lib examples cmd tests scripts -name '*.hs' | grep -v /gen/) 7 | -------------------------------------------------------------------------------- /scripts/hlint.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env sh 2 | # 3 | # Run hlint on most of the codebase. 4 | # 5 | # We skip generated files, since we somtimes deliberately use conventions 6 | # in the output that hlint will flag, to make codegen easier. 7 | cd "$(dirname $0)/.." 8 | exec hlint $(find lib examples cmd tests scripts -name '*.hs' | grep -v /gen/) 9 | -------------------------------------------------------------------------------- /scripts/regen.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env sh 2 | # 3 | # Regenerate generated modules. 4 | set -e 5 | 6 | # Some helpers for reporting info to the caller: 7 | log() { 8 | printf '%s\n' "$@" >&2 9 | } 10 | 11 | err() { 12 | log $@ 13 | exit 1 14 | } 15 | 16 | repo_root="$(realpath $(dirname $0)/..)" 17 | cd "$repo_root" 18 | 19 | # Make sure the compiler plugin is up to date. 20 | log "Rebuilding schema compiler plugin..." 21 | cabal new-build capnpc-haskell 22 | 23 | # We run the code generator from inside gen/lib/, so that it outputs 24 | # modules to the right locations: 25 | cd "$repo_root/capnp/gen/lib/" 26 | 27 | # Find the compiler plugin executable. It would be nice to just 28 | # use new-run here, but doing so from a subdirectory is a bit fiddly 29 | # and I(zenhack) haven't found a nice way to do it. 30 | exe="$(find $repo_root/dist-newstyle -type f -name capnpc-haskell)" 31 | 32 | # Make sure we only found one file: 33 | argslen() { 34 | echo $# 35 | } 36 | case $(argslen $exe) in 37 | 0) err "Error: capnpc-haskell executable not found in dist-newstyle." ;; 38 | 1) : ;; # Just one file; we're okay. 39 | *) err "Error: more than one capnpc-haskell executable found in dist-newstyle." ;; 40 | esac 41 | 42 | core_inc=$repo_root/core-schema/ 43 | 44 | # Ok -- do the codegen. Add the compiler plugin to our path and invoke 45 | # capnp compile. 46 | log "Generating schema modules for main library..." 47 | export PATH="$(dirname $exe):$PATH" 48 | capnp compile \ 49 | -I $core_inc \ 50 | --src-prefix=$core_inc/ \ 51 | -ohaskell \ 52 | $core_inc/capnp/*.capnp \ 53 | $core_inc/capnp/compat/*.capnp 54 | 55 | log "Generating schema modules for test suite..." 56 | cd "$repo_root/capnp-tests/gen/tests" 57 | capnp compile \ 58 | -I $core_inc \ 59 | --src-prefix=../../tests/data/ \ 60 | -ohaskell \ 61 | ../../tests/data/aircraft.capnp \ 62 | ../../tests/data/generics.capnp 63 | 64 | log "Generating schema modules for examples..." 65 | cd "$repo_root/capnp-examples/gen/lib" 66 | capnp compile \ 67 | -I $core_inc \ 68 | --src-prefix=../../ \ 69 | -ohaskell \ 70 | ../../*.capnp 71 | 72 | # vim: set ts=2 sw=2 noet : 73 | --------------------------------------------------------------------------------