diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,214 @@ +Copyright (c) 2008, Christopher Edward Kuklewicz +All rights reserved. + +Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. + * Neither the name of the copyright holder nor the names of the contributors may be used to endorse or promote products derived from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +The descriptor.proto, unittest.proto, unittest_import.proto, and addressbook.proto files from google's code are under the Apache license (2.0): + + Apache License + Version 2.0, January 2004 + http://www.apache.org/licenses/ + + TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION + + 1. Definitions. + + "License" shall mean the terms and conditions for use, reproduction, + and distribution as defined by Sections 1 through 9 of this document. + + "Licensor" shall mean the copyright owner or entity authorized by + the copyright owner that is granting the License. + + "Legal Entity" shall mean the union of the acting entity and all + other entities that control, are controlled by, or are under common + control with that entity. For the purposes of this definition, + "control" means (i) the power, direct or indirect, to cause the + direction or management of such entity, whether by contract or + otherwise, or (ii) ownership of fifty percent (50%) or more of the + outstanding shares, or (iii) beneficial ownership of such entity. + + "You" (or "Your") shall mean an individual or Legal Entity + exercising permissions granted by this License. + + "Source" form shall mean the preferred form for making modifications, + including but not limited to software source code, documentation + source, and configuration files. + + "Object" form shall mean any form resulting from mechanical + transformation or translation of a Source form, including but + not limited to compiled object code, generated documentation, + and conversions to other media types. + + "Work" shall mean the work of authorship, whether in Source or + Object form, made available under the License, as indicated by a + copyright notice that is included in or attached to the work + (an example is provided in the Appendix below). + + "Derivative Works" shall mean any work, whether in Source or Object + form, that is based on (or derived from) the Work and for which the + editorial revisions, annotations, elaborations, or other modifications + represent, as a whole, an original work of authorship. For the purposes + of this License, Derivative Works shall not include works that remain + separable from, or merely link (or bind by name) to the interfaces of, + the Work and Derivative Works thereof. + + "Contribution" shall mean any work of authorship, including + the original version of the Work and any modifications or additions + to that Work or Derivative Works thereof, that is intentionally + submitted to Licensor for inclusion in the Work by the copyright owner + or by an individual or Legal Entity authorized to submit on behalf of + the copyright owner. For the purposes of this definition, "submitted" + means any form of electronic, verbal, or written communication sent + to the Licensor or its representatives, including but not limited to + communication on electronic mailing lists, source code control systems, + and issue tracking systems that are managed by, or on behalf of, the + Licensor for the purpose of discussing and improving the Work, but + excluding communication that is conspicuously marked or otherwise + designated in writing by the copyright owner as "Not a Contribution." + + "Contributor" shall mean Licensor and any individual or Legal Entity + on behalf of whom a Contribution has been received by Licensor and + subsequently incorporated within the Work. + + 2. Grant of Copyright License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + copyright license to reproduce, prepare Derivative Works of, + publicly display, publicly perform, sublicense, and distribute the + Work and such Derivative Works in Source or Object form. + + 3. Grant of Patent License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + (except as stated in this section) patent license to make, have made, + use, offer to sell, sell, import, and otherwise transfer the Work, + where such license applies only to those patent claims licensable + by such Contributor that are necessarily infringed by their + Contribution(s) alone or by combination of their Contribution(s) + with the Work to which such Contribution(s) was submitted. If You + institute patent litigation against any entity (including a + cross-claim or counterclaim in a lawsuit) alleging that the Work + or a Contribution incorporated within the Work constitutes direct + or contributory patent infringement, then any patent licenses + granted to You under this License for that Work shall terminate + as of the date such litigation is filed. + + 4. Redistribution. You may reproduce and distribute copies of the + Work or Derivative Works thereof in any medium, with or without + modifications, and in Source or Object form, provided that You + meet the following conditions: + + (a) You must give any other recipients of the Work or + Derivative Works a copy of this License; and + + (b) You must cause any modified files to carry prominent notices + stating that You changed the files; and + + (c) You must retain, in the Source form of any Derivative Works + that You distribute, all copyright, patent, trademark, and + attribution notices from the Source form of the Work, + excluding those notices that do not pertain to any part of + the Derivative Works; and + + (d) If the Work includes a "NOTICE" text file as part of its + distribution, then any Derivative Works that You distribute must + include a readable copy of the attribution notices contained + within such NOTICE file, excluding those notices that do not + pertain to any part of the Derivative Works, in at least one + of the following places: within a NOTICE text file distributed + as part of the Derivative Works; within the Source form or + documentation, if provided along with the Derivative Works; or, + within a display generated by the Derivative Works, if and + wherever such third-party notices normally appear. The contents + of the NOTICE file are for informational purposes only and + do not modify the License. You may add Your own attribution + notices within Derivative Works that You distribute, alongside + or as an addendum to the NOTICE text from the Work, provided + that such additional attribution notices cannot be construed + as modifying the License. + + You may add Your own copyright statement to Your modifications and + may provide additional or different license terms and conditions + for use, reproduction, or distribution of Your modifications, or + for any such Derivative Works as a whole, provided Your use, + reproduction, and distribution of the Work otherwise complies with + the conditions stated in this License. + + 5. Submission of Contributions. Unless You explicitly state otherwise, + any Contribution intentionally submitted for inclusion in the Work + by You to the Licensor shall be under the terms and conditions of + this License, without any additional terms or conditions. + Notwithstanding the above, nothing herein shall supersede or modify + the terms of any separate license agreement you may have executed + with Licensor regarding such Contributions. + + 6. Trademarks. This License does not grant permission to use the trade + names, trademarks, service marks, or product names of the Licensor, + except as required for reasonable and customary use in describing the + origin of the Work and reproducing the content of the NOTICE file. + + 7. Disclaimer of Warranty. Unless required by applicable law or + agreed to in writing, Licensor provides the Work (and each + Contributor provides its Contributions) on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or + implied, including, without limitation, any warranties or conditions + of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A + PARTICULAR PURPOSE. You are solely responsible for determining the + appropriateness of using or redistributing the Work and assume any + risks associated with Your exercise of permissions under this License. + + 8. Limitation of Liability. In no event and under no legal theory, + whether in tort (including negligence), contract, or otherwise, + unless required by applicable law (such as deliberate and grossly + negligent acts) or agreed to in writing, shall any Contributor be + liable to You for damages, including any direct, indirect, special, + incidental, or consequential damages of any character arising as a + result of this License or out of the use or inability to use the + Work (including but not limited to damages for loss of goodwill, + work stoppage, computer failure or malfunction, or any and all + other commercial damages or losses), even if such Contributor + has been advised of the possibility of such damages. + + 9. Accepting Warranty or Additional Liability. While redistributing + the Work or Derivative Works thereof, You may choose to offer, + and charge a fee for, acceptance of support, warranty, indemnity, + or other liability obligations and/or rights consistent with this + License. However, in accepting such obligations, You may act only + on Your own behalf and on Your sole responsibility, not on behalf + of any other Contributor, and only if You agree to indemnify, + defend, and hold each Contributor harmless for any liability + incurred by, or claims asserted against, such Contributor by reason + of your accepting any such warranty or additional liability. + + END OF TERMS AND CONDITIONS + + APPENDIX: How to apply the Apache License to your work. + + To apply the Apache License to your work, attach the following + boilerplate notice, with the fields enclosed by brackets "[]" + replaced with your own identifying information. (Don't include + the brackets!) The text should be enclosed in the appropriate + comment syntax for the file format. We also recommend that a + file or class name and description of purpose be included on the + same "printed page" as the copyright notice for easier + identification within third-party archives. + + Copyright [yyyy] [name of copyright owner] + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. diff --git a/README b/README new file mode 100644 --- /dev/null +++ b/README @@ -0,0 +1,212 @@ +This the README file for protocol-buffers, protocol-buffers-descriptors, and hprotoc. +These are three interdependent Haskell packages by Chris Kuklewicz. +This README was updated most recently to reflect version 2.0.7 +This code should be compatible with Google protobuf version 2.3.0 +Changes to keep up with Google protobuf version 2.4.0 are being considered. + + +Questions and answers: + +Whats up with version 2.0.7 ? + +Version 2.0.5 and 2.0.6 had compile problems with GHC 7.4, this is now warning-free (as free as possible). + +The lack of a package name caused problems. Hopefully the new handling works for everyone. + +What is new in 1.8.0 ? + +Submitted bug fixes! +Fix for compiling generated haskell that uses packed fields. +Fix to mangling default value Enum names. +Fix for using "group" when in plug-in mode. + +I also changed the directory layout for the source code of protocol-buffers-descriptor. The +auto-generated code is now in "src-auto-generated" and the API for accessing options is under +"src-hand-written". I also added a README file to the descriptor package explaining the commands to +recreate src-auto-generated. + +What is new in 1.7.0 ? + +This version adds a patch from George van den Driessche to allow hprotoc to work as a plug-in to +protoc. You must copy the hprotoc to be named protoc-gen-haskell (not a symlink) and call it as: + +/opt/protobuf-2.3.0/bin/protoc --plugin=./protoc-gen-haskell --haskell_out=DirOut test.proto + +What is new in 1.6.0 ? + +This version is now caught up with the official protobuf-2.3.0 release. + The highlights of the changes are (cribbing from Kenton's announcement): + +> General +> * Parsers for repeated numeric fields now always accept both packed and +> unpacked input. The [packed=true] option only affects serializers. +> Therefore, it is possible to switch a field to packed format without +> breaking backwards-compatibility -- as long as all parties are using +> protobuf 2.3.0 or above, at least. +and +> * inf, -inf, and nan can now be used as default values for float and double +> fields. +have been added to 1.6.0. + +I did not add support for plugin code generators or for writing directly +to a compressed zip or jar file. No service related code is ever +generated so the "option *_generic_services" changes were ignored. + + +What is new in 1.5.0 ? + + The "packed" repeated fields should work on the wire, "deprecated" fields are parsed properly but + not nothing is otherwise done about this flag. The parser should disambiguate references to + messages/groups/enums by ignoring fields with the same name (for types of normal fields and + extension fields). The Lexar has had a few fixes courtesy of George van den Driessche (newlines + after numeric literals in proto files should now be handled). + +What is this for? What does it do? Why? + + It is a pure Haskell re-implementation of the Google code at +http://code.Google.com/apis/protocolbuffers/docs/overview.html + which is "...a language-neutral, platform-neutral, extensible way of serializing structured data for use in communications protocols, data storage, and more." + Google's project produces C++, Java, and Python code. This one produces Haskell code. + +How well does this Haskell package duplicate Google's project? + + This provides non-mutable messages that ought to be wire-compatible with Google. + These messages support extensions. + These messages support unknown fields if hprotoc is passed the proper flag (-u or --unknown_fields). + This does not generate anything for Services/Methods. + + Adding support for services has not been considered. + + I think that Google's code checks for some policy violations that are not well documented enough for me to reverse engineer. + Some (all?) of Google's APIs include the possibility of mutable messages. + I suspect that my message reflection is not as useful at runtime as in some of Google's APIs. + +What is protocol-buffers? + + The protocol-buffers part is the main library which has two faces: + + 1) It provides an external API exported by module Text.ProtocolBuffers for users to read and write the binary format and manipulate the message data structures created by hprotoc. + 2) It provides an internal API for the messages under module Text.ProtocolBuffers.Header to implement their tasks. + +What is protocol-buffers-descriptor? + + 1) It uses the protocol-buffers package. + 2) It provides the code generated by hprotoc from "descriptor.proto" under module Text.DescriptorProtos. + 3) This supports hprotoc which is used to describe proto files and the code they will generate. + 4) It provides Text.DescriptorProtos.Options which help in looking up the new style custom options. + +What is hprotoc? + + 1) It uses protocol-buffers and protocol-buffers-descriptor above. + 2) It is a command line tool that reads in ".proto" files and produces Haskell source trees like Google's protoc. + 3) ...and it contains a very nice lexer and parser for the ".proto" file... + + The hprotoc part is a executable program which reads ".proto" files and uses the protocol-buffers package to produce a tree of Haskell source files. The program is called "hprotoc". Usage is given by the program itself, the options themselves are processed in order. It can take several input search paths, and allow an additional module prefix, a selectable output directory, and ends with a list of of proto file to generate from. + + The output has to be a tree of modules since each message is given its own namespace, and a module is the only partitioning of namespace in Haskell. The keys for extension fields are defined alongside the message whose namespace they share. Since message names are both a data type and a namespace the filename and the message name match (aside from the .hs file extension). + +And what are the examples and tests sub-directories? + + The examples sub-directory is for duplicating the addressbook.proto example that Google has with its code. The ABF and ABF2 file are included as binary addressbooks. These can be read by the C++ examples from Google, and vice-versa. + + The tests sub-directory is where I have written some test code to drive the UnittestProto code generated from Google's unittest.proto (and unittest_import.proto) files. The 'patchBoot' file has the needed file patches to fix up the recursive imports (no longer needed!). + +What do I need to compile the code? + + I use ghc (version 6.10.3) and cabal (version 1.6.0.3). + + The dependencies are listed in the .cabal files, and these currently require you to go to hackage.haskell.org and get packages "binary" (I use version 0.5.0.1) and "utf8-string" (I use version 0.3.5) and hprotoc needs haskell-src-exts (exactly version 0.4.8 at the moment). + + The hprotoc Lexer.hs is produced from Lexer.x by the alex program (I use version 2.3.1) which can be downloaded from http://www.haskell.org/alex/ if you edit Lexer.x and need to regenerate Lexer.hs. + + The usual cabal configure/buid/install works for the protocol-buffers library (and haddock for API docs): + runhaskell Setup.hs configure + runhaskell Setup.hs build + runhaskell Setup.hs haddock + runhaskell Setup.hs install + After installing protocol-buffers go into the describe sub-directory and configure/build/install the protocol-buffers-descriptor library. + After installing protocol-buffers and protocol-buffers-descriptor go into the hprotoc sub-directory and configure/build/install the hprotoc executable. + + Note: Patches to support other compilers are welcome. + +How mature is this code? + + It can write the wire encoding and read it back. It will has been tested for interoperability against Google's read/write code with addressbook.proto. + + hprotoc generates and uses the Text.DescriptorProtos tree from Google "descriptor.proto" file. + + hprotoc has generated code from Google/protobuf/unittest.proto and Google/protobuf.unittest_import. These compile after adding hs-boot files TestAllExtensions.hs-boot, TestFieldOrderings.hs-boot, and TestMutualRecursionA.hs-boot to resolve mutual recursion. The TestEnumWithDupValue has duplicated values which cause a compilation warning. + + There has been QuickCheck tests done for UnittestProto/TestAllType.hs and UnittestProto/TestAllExtensions.hs in the tests subdirectory. These pass as of 2008-09-19 for version 0.2.7 (which has been tagged right after writing this). These test that random messages can be roundtripped to the wire format without changing — with the caveat that the new extension keys are read back as raw bytes but compare equal because of the parsing done by (==). + +Mutual recursion is a problem? + + Not using ghc. The haskell-src-exts let me generate code with {-# SOURCE #-} annotated imports. And hprotoc generates the needed hs-boot files for ghc. And key import cycles are broken by creating 'Key.hs files, which users can ignore. + +How stable is the API? + + This is the first working release of the code. I do not promise to keep any of the API but I am lazy so most things will not change. The reflection capabilities may get improved/altered. Stricter warnings and error detection may be added. Code will move between protocol-buffers and hprotoc projects. The internals of reading from the wire may be improved. + +Where is the API documentation? + + These file should be able to have cabal run the haddock generation. I am using Haddock version 2.4.2 at the moment. The imports of Text.ProtocolBuffers are the public API. The generated code's API is Text.ProtocolBuffers.Header. The only usage examples are in the examples sub-directory and the tests sub-directory. Since the messages are simply Haskell data types most of the manipulation should be easy. + + The main thing that is weird is that messages with extension ranges get an ExtField record field that holds ... an internal data structure. This is currently a Map from field number to a rather complicated existential + GADT combination that should really only be touched by the ExtKey and MessageAPI type class methods. The ExtField data constructor is not hidden, though it could be and probably ought to be. + + Note that extension fields are inherently slower, especially in ghci (though ghc's -O2 helps quite a bit). + + The entire proto file is stored in the top level module in wire-encoded form and can be accessed as a FileDescriptorProto. The Haskell code also defines its own reflection data types, with one stored in each generated module and also in a master data type in the top level module (via Show and Read). + +Who reads this far? + + I suspect no one ever will. + +Why define your own Haskell reflection types in addition to FileDescriptorProto's types? + + This allows for the protocol-buffers library package to not depend on a single thing defined in the protocol-buffers-descriptor package. This lack of recursion made for much simpler bootstrapping and allows the descriptor.proto generated files to be build separately. + + While descriptor.proto files are a great fit as output from parsing a proto file they are not as good a fit for code generation. They mix fields and extension keys, they have all optional fields even though some things (especially names) are compulsory. They obscure which descriptors are groups. They have a nested structure which is useful when resolving the names but not for iterating over for code generation. + +What are the pieces of protocol-buffers doing? + + Basic.hs defines the core data types (that are not already in Prelude) and many classes. + Mergeable.hs defines the standard instances of Mergeable for combining types. + Default.hs defines the standard default of the basic data types. + Reflections.hs defines the Haskell reflection data types (stored with each generated module). + Get.hs is here because I needed a slightly different style of binary Get monad (see binary and binary-strict packages). + This is standalone and could be put into any project. It has long comments inside. + WireMessage.hs defines 3 things: + (1) The Wire instances for the basic data types + (2) The API for the generated module to use to define their own Wire instances + (3) The API for the user to load and save messages + This file would not compile with ghc-6.8.3 on a G4 (Mac OS X 10.5.4, XCode 3.1) without -fvia-C as the cabal file states. + Extensions.hs is rather large because it add everything needed for extension fields (see haddock API docs). + It should not export ExtField's constructor, but it currently does. + Header.hs re-exports what is needed for the instance messages. + ProtocolBuffer.hs re-exports what is needed for the user API. + +What are the pieces of hprotoc doing? + + alex uses Lexer.x to generated Lexer.hs which slices up the ".proto" file into tokens. + The ".proto" layout is well designed, quite unambiguous, and easy to tokenize. + The lexer also does the jobs of decoding the backslash escape codes in quotes strings, and interpreting floating point numbers. + Errors and unexpected input are inserted into the token list, with at least line number level precision. + The Parser.hs file has a Parsec parser which are really used as nested parsers (allowing for the type of the user state to change). + The ".proto" grammar is well designed and the system never needs to backtrack over tokens. + The default values and options' values parsed according to the expected type, and string default are check for valid utf8 encoding. + (This also import the Instances.hs file) + The Resolve.hs has code to resolve all the names to a fully qualified form, including name mangling where necessary. + This includes code to load and parse all the imported ".proto" files, reusing parses for efficiency, and detecting import loops. + The context built from each imported file is combined to change the FileDescriptorProto into a modified FileDescriptorProto. + This stage also determines that extension keys are in a valid extensions range declaration, and enum default values exists. + The MakeReflections.hs file converts the nested FileDescriptorProto into a flatter Haskell reflection data structure. + This includes parsing the default value stored in the FileDescriptorProto. + The BreakRecursion.hs file builds graphs describing the imports and works out whether and how to create hs-boot and 'Key.hs files + to allow allow for warning-free compilation with ghc (as of 6.10.1). + The Gen.hs file takes a Haskell data structure from MakeReflections and builds a module syntax data structure. + The syntax data is quite verbose and several helper functions are used to help with the composition. + The result is easy to print as a string to a file. + The ProtoCompile.hs file is the Main module which defines the command line program 'hprotoc'. + This manages most of the interaction with the file system (aside from import loading in Resolve). + Everything that is needed is collected into the Options data type which is passed to "run". + The output style can be tweaked by changing "style" and "myMode". diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMainWithHooks defaultUserHooks diff --git a/TODO b/TODO new file mode 100644 --- /dev/null +++ b/TODO @@ -0,0 +1,136 @@ +make changes to align with protocol-buffer 2.3.0 -- done + +http://protobuf.googlecode.com/svn/trunk/CHANGES.txt + + General + * Parsers for repeated numeric fields now always accept both packed and + unpacked input. The [packed=true] option only affects serializers. + Therefore, it is possible to switch a field to packed format without + breaking backwards-compatibility -- as long as all parties are using + protobuf 2.3.0 or above, at least. + +Should be possible to do this. +Reflection: + add "FieldInfo.packedTag :: Maybe WireTag" + need to make FieldInfo.wireTag always unpacked + note that FieldInfo.wireTagLength is the same for both + +Above may work except for loading previously unknown packed extensions +Need to change Unknown.loadUnknown to tolerate the same field'Number with different wire types + +MakeReflections: + toFieldInfo' + +Gen: allowed'wire'Tags gets both packed and unpacked codes for repeated + update'Self must switch on wire'Tag not field'Number + and have both packed and unpacked cases for repeated + +Gen: Clean up the generated wireGet code. + +currently: + wireGet ft' + = case ft' of + 10 -> P'.getBareMessageWith check'allowed + 11 -> P'.getMessageWith check'allowed + _ -> P'.wireGetErr ft' + where + update'Self wire'Tag old'Self + = case wire'Tag of + 90 -> P'.wireGetKey UnittestProto.packed_int32_extension old'Self + _ -> P'.unknownField old'Self (P'.fieldIdOf wire'Tag) + + check'allowed wire'Tag field'Number wire'Type old'Self + = P'.catchError + (if P'.member wire'Tag allowed'wire'Tags then update'Self wire'Tag old'Self else + if P'.or [1 <= field'Number && field'Number <= 18999, 20000 <= field'Number] then + P'.loadExtension (P'.fieldIdOf wire'Tag) wire'Type old'Self else + P'.unknown (P'.fieldIdOf wire'Tag) wire'Type old'Self) + (\ _ -> P'.loadUnknown (P'.fieldIdOf wire'Tag) wire'Type old'Self) + +desired: + update'Self wire'Tag old'Self + = case wire'Tag of + 90 -> P'.wireGetKey UnittestProto.packed_int32_extension old'Self + _ -> let (field'Number,wire'Type) = splitWireTag wire'Tag + in if P'.or [1 <= field'Number && field'Number <= 18999, 20000 <= field'Number] + then P'.loadExtension field'Number wire'Type old'Self + else P'.unknown field'Number wire'Type old'Self + check'allowed wire'Tag old'Self + = P'.catchError (update'Self wire'Tag old'Self) (\ _ -> P'.loadUnknown wire'Tag old'Self) + +without --unknown the code was + + check'allowed wire'Tag field'Number wire'Type old'Self + = if P'.member wire'Tag allowed'wire'Tags then update'Self wire'Tag old'Self else + if P'.or [1 <= field'Number && field'Number <= 18999, 20000 <= field'Number] then + P'.loadExtension (P'.fieldIdOf wire'Tag) wire'Type old'Self else P'.unknown (P'.fieldIdOf wire'Tag) wire'Type old'Self + +and should become + + _ -> let (field'Number,wire'Type) = splitWireTag wire'Tag + in if P'.or [1 <= field'Number && field'Number <= 18999, 20000 <= field'Number] + then P'.loadExtension field'Number wire'Type old'Self + else P'.unknown field'Number wire'Type old'Self + + check'allowed = update'Self + +Note that "unknownField", which was impossible, is no longer present. +check'allowed and update'Self and loadUnknown just takes the wire'Tag and old'Self, +while loadExtension and unknown are unchanged. +And allowed'wire'Tags can be dropped altogether. + +The check'allowed is no longer needed when there is no catchError! +Thus rename to catch'Unknown ? Still generate or put in library with INLINE ? +Put in library, now it will be + + wireGet ft' + = case ft' of + 10 -> P'.getBareMessageWith (catch'Unknown update'Self) + 11 -> P'.getMessageWith (catch'Unknown update'Self) + _ -> P'.wireGetErr ft' + + + * The generic RPC service code generated by the C++, Java, and Python + generators can be disabled via file options: + option cc_generic_services = false; + option java_generic_services = false; + option py_generic_services = false; + This allows plugins to generate alternative code, possibly specific to some + particular RPC implementation. + +Heh. It is always false for hprotoc + + protoc + * Now supports a plugin system for code generators. Plugins can generate + code for new languages or inject additional code into the output of other + code generators. Plugins are just binaries which accept a protocol buffer + on stdin and write a protocol buffer to stdout, so they may be written in + any language. See src/google/protobuf/compiler/plugin.proto. + **WARNING**: Plugins are experimental. The interface may change in a + future version. + +Nope. + + * If the output location ends in .zip or .jar, protoc will write its output + to a zip/jar archive instead of a directory. For example: + protoc --java_out=myproto_srcs.jar --python_out=myproto.zip myproto.proto + Currently the archive contents are not compressed, though this could change + in the future. + +Nope. + + * inf, -inf, and nan can now be used as default values for float and double + fields. + +Should be possible to do this. +Done; required changes to the Lexer.x to recognize "-inf" as a discrete symbol. +NOT TESTED + +---- + + +Add even more of the documentation for the public API. +delete commented out code +add strictness annotations to internal data types. +benchmark +performance measure diff --git a/Text/ProtocolBuffers.hs b/Text/ProtocolBuffers.hs new file mode 100644 --- /dev/null +++ b/Text/ProtocolBuffers.hs @@ -0,0 +1,64 @@ +{- | + +"Text.ProtocolBuffers" exposes the client API. This merely re-exports parts of the +other modules in protocol-buffers. The exposed parts are: + +@ +import Text.ProtocolBuffers.Basic + ( Seq,isValidUTF8,toUtf8,utf8,Utf8(Utf8),Int32,Int64,Word32,Word64 + , WireTag,FieldId,WireType,FieldType,EnumCode,WireSize + , Mergeable(mergeAppend,mergeConcat),Default(defaultValue)) +import Text.ProtocolBuffers.Extensions + ( Key,ExtKey(getExt,putExt,clearExt),MessageAPI(getVal,isSet) + , getKeyFieldId,getKeyFieldType,getKeyDefaultValue) +import Text.ProtocolBuffers.Identifiers +import Text.ProtocolBuffers.Reflections + ( ReflectDescriptor(..),ReflectEnum(..),ProtoName(..),HsDefault(..),EnumInfoApp + , KeyInfo,FieldInfo(..),DescriptorInfo(..),EnumInfo(..),ProtoInfo(..),makePNF ) +import Text.ProtocolBuffers.WireMessage + ( Wire,Put,Get,runPut,runGet,runGetOnLazy + , messageSize,messagePut,messageGet,messagePutM,messageGetM + , messageWithLengthSize,messageWithLengthPut,messageWithLengthGet,messageWithLengthPutM,messageWithLengthGetM + , messageAsFieldSize,messageAsFieldPutM,messageAsFieldGetM) +@ + +The message serialization is taken care of by "WireMessage" +operations, especially 'messagePut' and 'messageGet'. The +'MessageAPI' provides the useful polymorphic 'getVal' and 'isSet' +where 'getVal' looks up default values and also works with extension +keys. The 'Utf8' newtype is used to indicate the format in the +underlying lazy 'ByteString'. Messages and values can be combined +with the right-biased 'Mergeable' operations. The 'mergeEmpty' should +not be used as required values are filled in with undefined errors, +please use 'defaultValue' instead. + +The Utf8 type is a newtype of the Lazy ByteString. It can be safely +constructed by checking for errors with 'toUtf8', which returns 'Left +Int' indicating the index where an error is detected. It can be +deconstructed with 'utf8'. + +-} +module Text.ProtocolBuffers( + module Text.ProtocolBuffers.Basic + , module Text.ProtocolBuffers.Extensions + , module Text.ProtocolBuffers.Identifiers + , module Text.ProtocolBuffers.Reflections + , module Text.ProtocolBuffers.WireMessage + ) where + +import Text.ProtocolBuffers.Basic + ( Seq,isValidUTF8,toUtf8,utf8,Utf8(Utf8),Int32,Int64,Word32,Word64 + , WireTag,FieldId,WireType,FieldType,EnumCode,WireSize + , Mergeable(mergeAppend,mergeConcat),Default(defaultValue)) +import Text.ProtocolBuffers.Extensions + ( Key,ExtKey(getExt,putExt,clearExt),MessageAPI(getVal,isSet) + , getKeyFieldId,getKeyFieldType,getKeyDefaultValue) +import Text.ProtocolBuffers.Identifiers +import Text.ProtocolBuffers.Reflections + ( ReflectDescriptor(..),ReflectEnum(..),ProtoName(..),HsDefault(..),EnumInfoApp + , KeyInfo,FieldInfo(..),DescriptorInfo(..),EnumInfo(..),ProtoInfo(..),makePNF ) +import Text.ProtocolBuffers.WireMessage + ( Wire,Put,Get,runPut,runGet,runGetOnLazy + , messageSize,messagePut,messageGet,messagePutM,messageGetM + , messageWithLengthSize,messageWithLengthPut,messageWithLengthGet,messageWithLengthPutM,messageWithLengthGetM + , messageAsFieldSize,messageAsFieldPutM,messageAsFieldGetM) diff --git a/Text/ProtocolBuffers/Basic.hs b/Text/ProtocolBuffers/Basic.hs new file mode 100644 --- /dev/null +++ b/Text/ProtocolBuffers/Basic.hs @@ -0,0 +1,260 @@ +{-# LANGUAGE DeriveDataTypeable,GeneralizedNewtypeDeriving #-} +-- | "Text.ProtocolBuffers.Basic" defines or re-exports most of the +-- basic field types; 'Maybe','Bool', 'Double', and 'Float' come from +-- the Prelude instead. This module also defined the 'Mergeable' and +-- 'Default' classes. The 'Wire' class is not defined here to avoid orphans. +module Text.ProtocolBuffers.Basic + ( -- * Basic types for protocol buffer fields in Haskell + Double,Float,Bool,Maybe,Seq,Utf8(Utf8),ByteString,Int32,Int64,Word32,Word64 + -- * Haskell types that act in the place of DescritorProto values + , WireTag(..),FieldId(..),WireType(..),FieldType(..),EnumCode(..),WireSize + -- * Some of the type classes implemented messages and fields + , Mergeable(..),Default(..) -- ,Wire(..) + , isValidUTF8, toUtf8, utf8, uToString, uFromString + ) where + +import Data.Bits(Bits) +import Data.ByteString.Lazy(ByteString) +import Data.Foldable as F(Foldable(foldl)) +import Data.Generics(Data(..)) +import Data.Int(Int32,Int64) +import Data.Ix(Ix) +import Data.Monoid(Monoid(..)) +import Data.Sequence(Seq,(><)) +import Data.Typeable(Typeable(..)) +import Data.Word(Word8,Word32,Word64) + +import qualified Data.ByteString.Lazy as L(unpack) +import Data.ByteString.Lazy.UTF8 as U (toString,fromString) + +-- Num instances are derived below for the purpose of getting fromInteger for case matching + +-- | 'Utf8' is used to mark 'ByteString' values that (should) contain +-- valud utf8 encoded strings. This type is used to represent +-- 'TYPE_STRING' values. +newtype Utf8 = Utf8 ByteString deriving (Data,Typeable,Eq,Ord) + +utf8 :: Utf8 -> ByteString +utf8 (Utf8 bs) = bs + +instance Read Utf8 where + readsPrec d xs = let r :: Int -> ReadS String + r = readsPrec + f :: (String,String) -> (Utf8,String) + f (a,b) = (Utf8 (U.fromString a),b) + in map f . r d $ xs + +instance Show Utf8 where + showsPrec d (Utf8 bs) = let s :: Int -> String -> ShowS + s = showsPrec + in s d (U.toString bs) + +instance Monoid Utf8 where + mempty = Utf8 mempty + mappend (Utf8 x) (Utf8 y) = Utf8 (mappend x y) + +-- | 'WireTag' is the 32 bit value with the upper 29 bits being the +-- 'FieldId' and the lower 3 bits being the 'WireType' +newtype WireTag = WireTag { getWireTag :: Word32 } -- bit concatenation of FieldId and WireType + deriving (Eq,Ord,Enum,Read,Show,Num,Bits,Bounded,Data,Typeable) + +-- | 'FieldId' is the field number which can be in the range 1 to +-- 2^29-1 but the value from 19000 to 19999 are forbidden (so sayeth +-- Google). +newtype FieldId = FieldId { getFieldId :: Int32 } -- really 29 bits + deriving (Eq,Ord,Enum,Read,Show,Num,Data,Typeable,Ix) + +-- Note that values 19000-19999 are forbidden for FieldId +instance Bounded FieldId where + minBound = 1 + maxBound = 536870911 -- 2^29-1 + +-- | 'WireType' is the 3 bit wire encoding value, and is currently in +-- the range 0 to 5, leaving 6 and 7 currently invalid. +-- +-- * 0 /Varint/ : int32, int64, uint32, uint64, sint32, sint64, bool, enum +-- +-- * 1 /64-bit/ : fixed64, sfixed64, double +-- +-- * 2 /Length-delimited/ : string, bytes, embedded messages +-- +-- * 3 /Start group/ : groups (deprecated) +-- +-- * 4 /End group/ : groups (deprecated) +-- +-- * 5 /32-bit/ : fixed32, sfixed32, float +-- +newtype WireType = WireType { getWireType :: Word32 } -- really 3 bits + deriving (Eq,Ord,Enum,Read,Show,Num,Data,Typeable) + +instance Bounded WireType where + minBound = 0 + maxBound = 5 + +{- | 'FieldType' is the integer associated with the + FieldDescriptorProto's Type. The allowed range is currently 1 to + 18, as shown below (excerpt from descritor.proto) + +> // 0 is reserved for errors. +> // Order is weird for historical reasons. +> TYPE_DOUBLE = 1; +> TYPE_FLOAT = 2; +> TYPE_INT64 = 3; // Not ZigZag encoded. Negative numbers +> // take 10 bytes. Use TYPE_SINT64 if negative +> // values are likely. +> TYPE_UINT64 = 4; +> TYPE_INT32 = 5; // Not ZigZag encoded. Negative numbers +> // take 10 bytes. Use TYPE_SINT32 if negative +> // values are likely. +> TYPE_FIXED64 = 6; +> TYPE_FIXED32 = 7; +> TYPE_BOOL = 8; +> TYPE_STRING = 9; +> TYPE_GROUP = 10; // Tag-delimited aggregate. +> TYPE_MESSAGE = 11; // Length-delimited aggregate. +> +> // New in version 2. +> TYPE_BYTES = 12; +> TYPE_UINT32 = 13; +> TYPE_ENUM = 14; +> TYPE_SFIXED32 = 15; +> TYPE_SFIXED64 = 16; +> TYPE_SINT32 = 17; // Uses ZigZag encoding. +> TYPE_SINT64 = 18; // Uses ZigZag encoding. + +-} + +newtype FieldType = FieldType { getFieldType :: Int } -- really [1..18] as fromEnum of Type from Type.hs + deriving (Eq,Ord,Enum,Read,Show,Num,Data,Typeable) + +instance Bounded FieldType where + minBound = 1 + maxBound = 18 + +-- | 'EnumCode' is the Int32 assoicated with a +-- EnumValueDescriptorProto and is in the range 0 to 2^31-1. +newtype EnumCode = EnumCode { getEnumCode :: Int32 } -- really [0..maxBound::Int32] of some .proto defined enumeration + deriving (Eq,Ord,Read,Show,Num,Data,Typeable) + +instance Bounded EnumCode where + minBound = 0 + maxBound = 2147483647 -- 2^-31 -1 + +-- | 'WireSize' is the Int64 size type associate with the lazy +-- bytestrings used in the 'Put' and 'Get' monads. +type WireSize = Int64 + +-- | The 'Mergeable' class is not a 'Monoid', 'mergeEmpty' is not a +-- left or right unit like 'mempty'. The default 'mergeAppend' is to +-- take the second parameter and discard the first one. The +-- 'mergeConcat' defaults to @foldl@ associativity. +-- +-- NOTE: 'mergeEmpty' has been removed in protocol buffers version 2. +-- Use defaultValue instead. New strict fields would mean that required +-- fields in messages will be automatic errors with 'mergeEmpty'. +class Default a => Mergeable a where +{- + -- | The 'mergeEmpty' value of a basic type or a message with + -- required fields will be undefined and a runtime error to + -- evaluate. These are only handy for reading the wire encoding and + -- users should employ 'defaultValue' instead. + mergeEmpty :: a + mergeEmpty = error "You did not define Mergeable.mergeEmpty!" +-} + -- | 'mergeAppend' is the right-biased merge of two values. A + -- message (or group) is merged recursively. Required field are + -- always taken from the second message. Optional field values are + -- taken from the most defined message or the second message if + -- both are set. Repeated fields have the sequences concatenated. + -- Note that strings and bytes are NOT concatenated. + mergeAppend :: a -> a -> a + mergeAppend _a b = b + + -- | 'mergeConcat' is @ F.foldl mergeAppend defaultValue @ and this + -- default definition is not overridden in any of the code except + -- for the (Seq a) instance. + mergeConcat :: F.Foldable t => t a -> a + mergeConcat = F.foldl mergeAppend defaultValue + +-- | The Default class has the default-default values of types. See +-- +-- and also note that 'Enum' types have a 'defaultValue' that is the +-- first one in the @.proto@ file (there is always at least one +-- value). Instances of this for messages hold any default value +-- defined in the @.proto@ file. 'defaultValue' is where the +-- 'MessageAPI' function 'getVal' looks when an optional field is not +-- set. +class Default a where + -- | The 'defaultValue' is never undefined or an error to evalute. + -- This makes it much more useful compared to 'mergeEmpty'. In a + -- default message all Optional field values are set to 'Nothing' + -- and Repeated field values are empty. + defaultValue :: a + +-- Returns Nothing if valid, and the position of the error if invalid +isValidUTF8 :: ByteString -> Maybe Int +isValidUTF8 bs = go 0 (L.unpack bs) 0 where + go :: Int -> [Word8] -> Int -> Maybe Int + go 0 [] _ = Nothing + go 0 (x:xs) n | x <= 127 = go 0 xs $! succ n -- binary 01111111 + | x <= 193 = Just n -- binary 11000001, decodes to <=127, should not be here + | x <= 223 = go 1 xs $! succ n -- binary 11011111 + | x <= 239 = go 2 xs $! succ n -- binary 11101111 + | x <= 243 = go 3 xs $! succ n -- binary 11110011 + | x == 244 = high xs $! succ n -- binary 11110100 + | otherwise = Just n + go i (x:xs) n | 128 <= x && x <= 191 = go (pred i) xs $! succ n + go _ _ n = Just n + -- leading 3 bits are 100, so next 6 are at most 001111, i.e. 10001111 + high (x:xs) n | 128 <= x && x <= 143 = go 2 xs $! succ n + | otherwise = Just n + high [] n = Just n + +toUtf8 :: ByteString -> Either Int Utf8 +toUtf8 bs = maybe (Right (Utf8 bs)) Left (isValidUTF8 bs) + +uToString :: Utf8 -> String +uToString (Utf8 bs) = U.toString bs + +uFromString :: String -> Utf8 +uFromString s = Utf8 (U.fromString s) + + +-- Base types are not very mergeable, but their Maybe and Seq versions are: +instance Mergeable a => Mergeable (Maybe a) where +-- mergeEmpty = Nothing + mergeAppend = mayMerge + +{-# INLINE mayMerge #-} +mayMerge :: (Mergeable b) => Maybe b -> Maybe b -> Maybe b +mayMerge Nothing y = y +mayMerge x Nothing = x +mayMerge (Just x) (Just y) = Just (mergeAppend x y) + +instance Mergeable (Seq a) where +-- mergeEmpty = empty + mergeAppend = (><) + +-- These all have errors as mergeEmpty and use the second paramater for mergeAppend +instance Mergeable Bool +instance Mergeable Utf8 +instance Mergeable ByteString +instance Mergeable Double +instance Mergeable Float +instance Mergeable Int32 +instance Mergeable Int64 +instance Mergeable Word32 +instance Mergeable Word64 + +instance Default Word64 where defaultValue = 0 +instance Default Word32 where defaultValue = 0 +instance Default Int64 where defaultValue = 0 +instance Default Int32 where defaultValue = 0 +instance Default Float where defaultValue = 0 +instance Default Double where defaultValue = 0 +instance Default Bool where defaultValue = False +instance Default (Maybe a) where defaultValue = Nothing +instance Default (Seq a) where defaultValue = mempty +instance Default ByteString where defaultValue = mempty +instance Default Utf8 where defaultValue = mempty + diff --git a/Text/ProtocolBuffers/Extensions.hs b/Text/ProtocolBuffers/Extensions.hs new file mode 100644 --- /dev/null +++ b/Text/ProtocolBuffers/Extensions.hs @@ -0,0 +1,928 @@ +{-# LANGUAGE GADTs,MultiParamTypeClasses,FunctionalDependencies,FlexibleInstances,DeriveDataTypeable,ScopedTypeVariables,CPP #-} +-- | The "Extensions" module contributes two main things. The first +-- is the definition and implementation of extensible message +-- features. This means that the 'ExtField' data type is exported but +-- its constructor is (in an ideal world) hidden. +-- +-- This first part also includes the keys for the extension fields: +-- the 'Key' data type. These are typically defined in code generated +-- by 'hprotoc' from '.proto' file definitions. +-- +-- The second main part is the 'MessageAPI' class which defines +-- 'getVal' and 'isSet'. These allow uniform access to normal and +-- extension fields for users. +-- +-- Access to extension fields is strictly though keys. There is not +-- currently any way to query or change or clear any other extension +-- field data. +-- +-- This module is likely to get broken up into pieces. +module Text.ProtocolBuffers.Extensions + ( -- * Query functions for 'Key' + getKeyFieldId,getKeyFieldType,getKeyDefaultValue + -- * External types and classes + , Key(..),ExtKey(..),MessageAPI(..) + , PackedSeq(..), EP(..) + -- * Internal types, functions, and classes + , wireSizeExtField,wirePutExtField,loadExtension,notExtension + , wireGetKeyToUnPacked, wireGetKeyToPacked + , GPB,ExtField(..),ExtendMessage(..),ExtFieldValue(..) + ) where + +import Control.Monad.Error.Class(throwError) +import qualified Data.ByteString.Lazy as L +import qualified Data.Foldable as F +import Data.Map(Map) +import qualified Data.Map as M +import Data.Maybe(fromMaybe,isJust) +import Data.Monoid(mappend,mconcat) +import Data.Sequence((|>),(><),viewl,ViewL(..)) +import qualified Data.Sequence as Seq(singleton,null,empty) +#if MIN_VERSION_base(4,7,0) +import Data.Typeable(Typeable,typeOf,TypeRep,mkTyConApp,mkTyCon3,cast) +#else +import Data.Typeable(Typeable(typeOf),Typeable1(typeOf1),Typeable2(typeOf2),TypeRep,mkTyConApp,mkTyCon3,cast) +#endif +import Data.Data(Data(gfoldl,gunfold,toConstr),Constr,DataType,Fixity(Prefix),mkDataType,mkConstr,constrIndex,dataTypeOf) + +import Text.ProtocolBuffers.Basic +import Text.ProtocolBuffers.WireMessage +import Text.ProtocolBuffers.Reflections +import Text.ProtocolBuffers.Get as Get (Result(..),bytesRead) + +err :: String -> b +err msg = error $ "Text.ProtocolBuffers.Extensions error\n"++msg + +-- | The 'Key' data type is used with the 'ExtKey' class to put, get, +-- and clear external fields of messages. The 'Key' can also be used +-- with the 'MessagesAPI' to get a possibly default value and to check +-- whether a key has been set in a message. +-- +-- The 'Key' type (opaque to the user) has a phantom type of Maybe +-- or Seq that corresponds to Optional or Repeated fields. And a +-- second phantom type that matches the message type it must be used +-- with. The third type parameter corresonds to the Haskell value +-- type. +-- +-- The 'Key' is a GADT that puts all the needed class instances into +-- scope. The actual content is the 'FieldId' ( numeric key), the +-- 'FieldType' (for sanity checks), and @Maybe v@ (a non-standard +-- default value). +-- +-- When code is generated all of the known keys are taken into account +-- in the deserialization from the wire. Unknown extension fields are +-- read as a collection of raw byte sequences. If a key is then +-- presented it will be used to parse the bytes. +-- +-- There is no guarantee for what happens if two Keys disagree about +-- the type of a field; in particular there may be undefined values +-- and runtime errors. The data constructor for 'Key' has to be +-- exported to the generated code, but is not exposed to the user by +-- "Text.ProtocolBuffers". +-- +data Key c msg v where + Key :: (ExtKey c,ExtendMessage msg,GPB v) => FieldId -> FieldType -> (Maybe v) -> Key c msg v +#if MIN_VERSION_base(4,7,0) + deriving (Typeable) +#endif + +-- | This allows reflection, in this case it gives the numerical +-- 'FieldId' of the key, from 1 to 2^29-1 (excluding 19,000 through +-- 19,999). +getKeyFieldId :: Key c msg v -> FieldId +getKeyFieldId (Key fi _ _) = fi + +-- | This allows reflection, in this case it gives the 'FieldType' +-- enumeration value (1 to 18) of the +-- "Text.DescriptorProtos.FieldDescriptorProto.Type" of the field. +getKeyFieldType :: Key c msg v -> FieldType +getKeyFieldType (Key _ ft _) = ft + +-- | This will return the default value for a given 'Key', which is +-- set in the '.proto' file, or if unset it is the 'defaultValue' of +-- that type. +getKeyDefaultValue :: Key c msg v -> v +getKeyDefaultValue (Key _ _ md) = fromMaybe defaultValue md + +#if !MIN_VERSION_base(4,7,0) +instance Typeable1 c => Typeable2 (Key c) where + typeOf2 _ = mkTyConApp (mkTyCon3 "protocol-buffers" "Text.ProtocolBuffers.Extensions" "Key") [typeOf1 (undefined :: c ())] +#endif + +#if MIN_VERSION_base(4,7,0) +instance (Typeable c, Typeable msg, Typeable v) => Show (Key c msg v) where +#else +instance (Typeable1 c, Typeable msg, Typeable v) => Show (Key c msg v) where +#endif + show key@(Key fieldId fieldType maybeDefaultValue) = + concat ["(Key (",show fieldId + ,") (",show fieldType + ,") (",show maybeDefaultValue + ,") :: ",show (typeOf key) + ,")"] + +-- | 'GPWitness' is an instance witness for the 'GPB' classes. This +-- exists mainly to be a part of 'GPDyn' or 'GPDynSeq'. +data GPWitness a where GPWitness :: (GPB a) => GPWitness a + deriving (Typeable) + +-- | The 'GPDyn' is my specialization of 'Dynamic'. It hides the type +-- with an existential but the 'GPWitness' brings the class instances +-- into scope. This is used in 'ExtOptional' for optional fields. +data GPDyn = forall a . GPDyn !(GPWitness a) !a + deriving (Typeable) + +-- | The 'GPDynSeq' is another specialization of 'Dynamic' and is used +-- in 'ExtRepeated' for repeated fields. +data GPDynSeq = forall a . GPDynSeq !(GPWitness a) !(Seq a) + deriving (Typeable) + +-- | The 'PackedSeq' is needed to distinguish the packed repeated format from the repeated format. +-- This is only used in the phantom type of Key. +newtype PackedSeq a = PackedSeq { unPackedSeq :: (Seq a) } + deriving (Typeable) + +-- | The WireType is used to ensure the Seq is homogenous. +-- The ByteString is the unparsed input after the tag. +data ExtFieldValue = ExtFromWire !(Seq EP) -- XXX must store wiretype with ByteString + | ExtOptional !FieldType !GPDyn + | ExtRepeated !FieldType !GPDynSeq + | ExtPacked !FieldType !GPDynSeq + deriving (Typeable,Ord,Show) + +-- For making a Data instance for ExtField +data ExtDataPair = ExtDataPair FieldId (Seq EP) + deriving (Typeable,Data,Show) + +data EP = EP {-# UNPACK #-} !WireType !ByteString + deriving (Typeable,Data,Eq,Ord,Show) + +data DummyMessageType deriving (Typeable) + +-- | ExtField is a newtype'd map from the numeric FieldId key to the +-- ExtFieldValue. This allows for the needed class instances. +newtype ExtField = ExtField (Map FieldId ExtFieldValue) +#if MIN_VERSION_base(4,7,0) + deriving (Eq,Ord,Show,Typeable) +#else + deriving (Eq,Ord,Show) +#endif + +-- Used only in gfoldl for Data instance of ExtField +dataToList :: ExtField -> [ExtDataPair] +dataToList (ExtField ef) = map toEDP . M.toList $ ef where + toEDP (fi,ExtFromWire eps) = ExtDataPair fi eps + toEDP (fi,ExtOptional ft (GPDyn GPWitness d)) = + let p = wirePutOpt (toWireTag fi ft) ft (Just d) + ep = EP (toWireType ft) (runPut p) + in ExtDataPair fi (Seq.singleton ep) + toEDP (fi,ExtRepeated ft (GPDynSeq GPWitness s)) = + let f :: forall w. Wire w => w -> EP + f = EP (toWireType ft) . runPut . wirePutReq (toWireTag fi ft) ft + in ExtDataPair fi (fmap f s) + toEDP (fi,ExtPacked ft (GPDynSeq GPWitness s)) = + let p = wirePutPacked (toPackedWireTag fi) ft s + ep = EP (snd. splitWireTag $ toPackedWireTag fi) (runPut p) + in ExtDataPair fi (Seq.singleton ep) + +-- Used only in gfoldl and gunfold for Data instance of ExtField +dataFromList :: [ExtDataPair] -> ExtField +dataFromList = ExtField . M.fromList . map fromEDP where + fromEDP (ExtDataPair fid eps) = (fid,ExtFromWire eps) + +#if !MIN_VERSION_base(4,7,0) +instance Typeable ExtField where + typeOf _ = tr_ExtField +#endif + +tr_ExtField :: TypeRep +tr_ExtField = mkTyConApp (mkTyCon3 "protocol-buffers" "Text.ProtocolBuffers.Extensions" "ExtField") [] + +ty_ExtField :: DataType +ty_ExtField = mkDataType "Text.ProtocolBuffers.Extensions.ExtField" [con_ExtField] +con_ExtField :: Constr +con_ExtField = mkConstr ty_ExtField "ExtField" [] Prefix + +instance Data ExtField where + gfoldl f z m = z dataFromList `f` dataToList m + gunfold k z c = case constrIndex c of + _ -> k (z dataFromList) + toConstr (ExtField _) = con_ExtField + dataTypeOf _ = ty_ExtField + +instance ExtendMessage DummyMessageType where + getExtField = undefined + putExtField = undefined + validExtRanges = undefined + +-- I want a complicated comparison here to at least allow testing of +-- setting a field, writing to wire, reading back from wire, and +-- comparing. +-- +-- The comparison of ExtFromWire with ExtFromWire is conservative +-- about returning True. It is entirely possible that if both value +-- were interpreted by the same Key that their resulting values would +-- compare True. +instance Eq ExtFieldValue where + (==) (ExtFromWire b) (ExtFromWire b') = b==b' + (==) (ExtOptional a b) (ExtOptional a' b') = a==a' && b==b' + (==) (ExtRepeated a b) (ExtRepeated a' b') = a==a' && b==b' + (==) (ExtPacked a b) (ExtPacked a' b') = a==a' && b==b' + (==) x@(ExtOptional ft (GPDyn w@GPWitness _)) (ExtFromWire s') = + let wt = toWireType ft + makeKeyType :: GPWitness a -> Key Maybe DummyMessageType a + makeKeyType = undefined + key = Key 0 ft Nothing `asTypeOf` makeKeyType w + in case parseWireExtMaybe key wt s' of + Right (_,y) -> x==y + _ -> False + (==) y@(ExtFromWire {}) x@(ExtOptional {}) = x == y + (==) x@(ExtRepeated ft (GPDynSeq w@GPWitness _)) (ExtFromWire s') = + let wt = toWireType ft + makeKeyType :: GPWitness a -> Key Seq DummyMessageType a + makeKeyType = undefined + key = Key 0 ft Nothing `asTypeOf` makeKeyType w + in case parseWireExtSeq key wt s' of + Right (_,y) -> x==y + _ -> False + (==) y@(ExtFromWire {}) x@(ExtRepeated {}) = x == y + (==) x@(ExtPacked ft (GPDynSeq w@GPWitness _)) (ExtFromWire s') = + let wt = 2 -- all packed types have wire type 2, length delimited + makeKeyType :: GPWitness a -> Key PackedSeq DummyMessageType a + makeKeyType = undefined + key = Key 0 ft Nothing `asTypeOf` makeKeyType w + in case parseWireExtPackedSeq key wt s' of + Right (_,y) -> x==y + _ -> False + (==) y@(ExtFromWire {}) x@(ExtPacked {}) = x == y + (==) _ _ = False + +-- | 'ExtendMessage' abstracts the operations of storing and +-- retrieving the 'ExtField' from the message, and provides the +-- reflection needed to know the valid field numbers. +-- +-- This only used internally. +class Typeable msg => ExtendMessage msg where + getExtField :: msg -> ExtField + putExtField :: ExtField -> msg -> msg + validExtRanges :: msg -> [(FieldId,FieldId)] + +-- wireKeyToUnPacked is used to load a repeated packed format into a repeated non-packed extension key +-- wireKeyToPacked is used to load a repeated unpacked format into a repeated packed extension key +wireGetKeyToUnPacked :: (ExtendMessage msg,GPB v) => Key Seq msg v -> msg -> Get msg +wireGetKeyToUnPacked k@(Key i t mv) msg = do + let myCast :: Maybe a -> Get (Seq a) + myCast = undefined + vv <- wireGetPacked t `asTypeOf` (myCast mv) + let (ExtField ef) = getExtField msg + v' <- case M.lookup i ef of + Nothing -> return $ ExtRepeated t (GPDynSeq GPWitness vv) + Just (ExtRepeated t' (GPDynSeq GPWitness s)) | t/=t' -> + fail $ "wireGetKeyToUnPacked: Key mismatch! found wrong field type: "++show (k,t,t') + | otherwise -> + case cast s of + Nothing -> fail $ "wireGetKeyToUnPacked: previous Seq value cast failed: "++show (k,typeOf s) + Just s' -> return $ ExtRepeated t (GPDynSeq GPWitness (s' >< vv)) + Just (ExtFromWire raw) -> + case parseWireExtSeq k (toWireType t) raw of -- was wt from ExtFromWire + Left errMsg -> fail $ "wireGetKeyToUnPacked: Could not parseWireExtSeq: "++show k++"\n"++errMsg + Right (_,ExtRepeated t' (GPDynSeq GPWitness s)) | t/=t' -> + fail $ "wireGetKeyToUnPacked:: Key mismatch! parseWireExtSeq returned wrong field type: "++show (k,t,t') + | otherwise -> + case cast s of + Nothing -> fail $ "wireGetKey Seq: previous Seq value cast failed: "++show (k,typeOf s) + Just s' -> return $ ExtRepeated t (GPDynSeq GPWitness (s' >< vv)) + wtf -> fail $ "wireGetKeyToUnPacked: Weird parseWireExtSeq return value: "++show (k,wtf) + Just wtf@(ExtOptional {}) -> fail $ "wireGetKeyToUnPacked: ExtOptional found when ExtRepeated expected: "++show (k,wtf) + Just wtf@(ExtPacked {}) -> fail $ "wireGetKeyToUnPacked: ExtPacked found when ExtRepeated expected: "++show (k,wtf) + let ef' = M.insert i v' ef + seq v' $ seq ef' $ return (putExtField (ExtField ef') msg) + +wireGetKeyToPacked :: (ExtendMessage msg,GPB v) => Key PackedSeq msg v -> msg -> Get msg +wireGetKeyToPacked k@(Key i t mv) msg = do + let wt = toWireType t + myCast :: Maybe a -> Get a + myCast = undefined + v <- wireGet t `asTypeOf` (myCast mv) + let (ExtField ef) = getExtField msg + v' <- case M.lookup i ef of + Nothing -> return $ ExtPacked t (GPDynSeq GPWitness (Seq.singleton v)) + Just (ExtPacked t' (GPDynSeq GPWitness s)) | t/=t' -> + fail $ "wireGetKeyToPacked: Key mismatch! found wrong field type: "++show (k,t,t') + | otherwise -> + case cast s of + Nothing -> fail $ "wireGetKeyToPacked: previous Seq value cast failed: "++show (k,typeOf s) + Just s' -> seq v $ return $ ExtRepeated t (GPDynSeq GPWitness (s' |> v)) + Just (ExtFromWire raw) -> + case parseWireExtPackedSeq k wt raw of + Left errMsg -> fail $ "wireGetKeyToPacked: Could not parseWireExtPackedSeq: "++show k++"\n"++errMsg + Right (_,ExtPacked t' (GPDynSeq GPWitness s)) | t/=t' -> + fail $ "wireGetKeyToPacked: Key mismatch! parseWireExtPackedSeq returned wrong field type: "++show (k,t,t') + | otherwise -> + case cast s of + Nothing -> fail $ "wireGetKeyToPacked: previous Seq value cast failed: "++show (k,typeOf s) + Just s' -> seq v $ return $ ExtRepeated t (GPDynSeq GPWitness (s' |> v)) + wtf -> fail $ "wireGetKeyToPacked: Weird parseWireExtPackedSeq return value: "++show (k,wtf) + Just wtf@(ExtOptional {}) -> fail $ "wireGetKeyToPacked: ExtOptional found when ExtPacked expected: "++show (k,wtf) + Just wtf@(ExtRepeated {}) -> fail $ "wireGetKeyToPacked: ExtRepeated found when ExtPacked expected: "++show (k,wtf) + let ef' = M.insert i v' ef + seq v' $ seq ef' $ return (putExtField (ExtField ef') msg) + +-- | The 'ExtKey' class has three functions for user of the API: +-- 'putExt', 'getExt', and 'clearExt'. The 'wireGetKey' is used in +-- generated code. +-- +-- There are two instances of this class, 'Maybe' for optional message +-- fields and 'Seq' for repeated message fields. This class allows +-- for uniform treatment of these two kinds of extension fields. +class ExtKey c where + -- | Change or clear the value of a key in a message. Passing + -- 'Nothing' with an optional key or an empty 'Seq' with a repeated + -- key clears the value. This function thus maintains the invariant + -- that having a field number in the 'ExtField' map means that the + -- field is set and not empty. + -- + -- This should be only way to set the contents of a extension field. + putExt :: Key c msg v -> c v -> msg -> msg + -- | Access the key in the message. Optional have type @(Key Maybe + -- msg v)@ and return type @(Maybe v)@ while repeated fields have + -- type @(Key Seq msg v)@ and return type @(Seq v)@. + -- + -- There are a few sources of errors with the lookup of the key: + -- + -- * It may find unparsed bytes from loading the message. 'getExt' + -- will attempt to parse the bytes as the key\'s value type, and + -- may fail. The parsing is done with the 'parseWireExt' method + -- (which is not exported to user API). + -- + -- * The wrong optional-key versus repeated-key type is a failure + -- + -- * The wrong type of the value might be found in the map and + -- * cause a failure + -- + -- The failures above should only happen if two different keys are + -- used with the same field number. + getExt :: Key c msg v -> msg -> Either String (c v) + -- 'clearExt' unsets the field of the 'Key' if it is present. + clearExt :: Key c msg v -> msg -> msg + -- 'wireGetKey' is used in generated code to load extension fields + -- which are defined in the same '.proto' file as the message. This + -- results in the storing the parsed type instead of the raw bytes + -- inside the message. + wireGetKey :: Key c msg v -> msg -> Get msg + +-- | The 'Key' and 'GPWitness' GADTs use 'GPB' as a shorthand for many +-- classes. +class (Mergeable a,Default a,Wire a,Show a,Typeable a,Eq a,Ord a) => GPB a + +instance GPB Bool +instance GPB ByteString +instance GPB Utf8 +instance GPB Double +instance GPB Float +instance GPB Int32 +instance GPB Int64 +instance GPB Word32 +instance GPB Word64 + +instance Mergeable ExtField where +-- mergeEmpty = ExtField M.empty + mergeAppend (ExtField m1) (ExtField m2) = ExtField (M.unionWith mergeExtFieldValue m1 m2) + +mergeExtFieldValue :: ExtFieldValue -> ExtFieldValue -> ExtFieldValue +mergeExtFieldValue (ExtFromWire s1) (ExtFromWire s2) = ExtFromWire (mappend s1 s2) + +mergeExtFieldValue (ExtOptional ft1 (GPDyn GPWitness d1)) + (ExtOptional ft2 (GPDyn GPWitness d2)) = + if ft1 /= ft2 then err $ "mergeExtFieldValue : ExtOptional FieldType mismatch "++show (ft1,ft2) + else case cast d2 of + Nothing -> err $ "mergeExtFieldValue : ExtOptional cast failed, FieldType "++show (ft2,typeOf d1,typeOf d2) + Just d2' -> ExtOptional ft2 (GPDyn GPWitness (mergeAppend d1 d2')) + +mergeExtFieldValue (ExtRepeated ft1 (GPDynSeq GPWitness s1)) + (ExtRepeated ft2 (GPDynSeq GPWitness s2)) = + if ft1 /= ft2 then err $ "mergeExtFieldValue : ExtRepeated FieldType mismatch "++show (ft1,ft2) + else case cast s2 of + Nothing -> err $ "mergeExtFieldValue : ExtRepeated cast failed, FieldType "++show (ft2,typeOf s1,typeOf s2) + Just s2' -> ExtRepeated ft2 (GPDynSeq GPWitness (mappend s1 s2')) + +mergeExtFieldValue (ExtPacked ft1 (GPDynSeq GPWitness s1)) + (ExtPacked ft2 (GPDynSeq GPWitness s2)) = + if ft1 /= ft2 then err $ "mergeExtFieldValue : ExtPacked FieldType mismatch "++show (ft1,ft2) + else case cast s2 of + Nothing -> err $ "mergeExtFieldValue : ExtPacked cast failed, FieldType "++show (ft2,typeOf s1,typeOf s2) + Just s2' -> ExtPacked ft2 (GPDynSeq GPWitness (mappend s1 s2')) + +mergeExtFieldValue a b = err $ "mergeExtFieldValue : mismatch of constructors "++show (a,b) + +instance Default ExtField where + defaultValue = ExtField M.empty + +instance Show (GPWitness a) where + showsPrec _n GPWitness = ("(GPWitness :: GPWitness ("++) . shows (typeOf (undefined :: a)) . (')':) . (')':) + +instance Eq (GPWitness a) where + (==) GPWitness GPWitness = True + (/=) GPWitness GPWitness = False + +instance Ord (GPWitness a) where + compare GPWitness GPWitness = EQ + +instance (GPB a) => Data (GPWitness a) where + gunfold _k z c = case constrIndex c of + 1 -> z GPWitness + _ -> err "gunfold of GPWitness error" + toConstr GPWitness = gpWitnessC + dataTypeOf _ = gpWitnessDT + +gpWitnessC :: Constr +gpWitnessC = mkConstr gpWitnessDT "GPWitness" [] Prefix +gpWitnessDT :: DataType +gpWitnessDT = mkDataType "GPWitness" [gpWitnessC] + +{- +gpDynC :: Constr +gpDynC = mkConstr gpDynDT "GPDyn" ["a"] Prefix +gpDynDT :: DataType +gpDynDT = mkDataType "GPDyn" [gpDynC] + +fromGPDyn :: (GPB a) => GPDyn -> Maybe a +fromGPDyn (GPDyn GPWitness a) = cast a + +typeOfGPDyn :: GPDyn -> TypeRep +typeOfGPDyn (GPDyn GPWitness a) = typeOf a + +defaultValueGPDyn :: GPWitness a -> GPDyn +defaultValueGPDyn x@GPWitness = GPDyn x defaultValue + +mergeEmptyGPDyn :: GPWitness a -> GPDyn +mergeEmptyGPDyn x@GPWitness = GPDyn x mergeEmpty + +mergeAppendGPDyn :: GPDyn -> GPDyn -> Maybe GPDyn +mergeAppendGPDyn (GPDyn GPWitness a1) (GPDyn GPWitness a2) = fmap (GPDyn GPWitness . mergeAppend a1) (cast a2) +-} + +instance Eq GPDyn where + (==) a b = fromMaybe False (eqGPDyn a b) + +instance Ord GPDyn where + compare a b = fromMaybe (compare (show a) (show b)) (ordGPDyn a b) + +instance Show GPDyn where + showsPrec _n (GPDyn x@GPWitness a) = ("(GPDyn "++) . shows x . (" ("++) . shows a . ("))"++) + +instance Eq GPDynSeq where + (==) a b = fromMaybe False (eqGPDynSeq a b) + +instance Ord GPDynSeq where + compare a b = fromMaybe (compare (show a) (show b)) (ordGPDynSeq a b) + +instance Show GPDynSeq where + showsPrec _n (GPDynSeq x@GPWitness s) = ("(GPDynSeq "++) . shows x . (" ("++) . shows s . ("))"++) + +ordGPDyn :: GPDyn -> GPDyn -> Maybe Ordering +ordGPDyn (GPDyn GPWitness a1) (GPDyn GPWitness a2) = fmap (compare a1) (cast a2) + +eqGPDyn :: GPDyn -> GPDyn -> Maybe Bool +eqGPDyn (GPDyn GPWitness a1) (GPDyn GPWitness a2) = fmap (a1==) (cast a2) + +-- showGPDyn :: GPDyn -> String +-- showGPDyn (GPDyn GPWitness s) = show s + +ordGPDynSeq :: GPDynSeq -> GPDynSeq -> Maybe Ordering +ordGPDynSeq (GPDynSeq GPWitness a1) (GPDynSeq GPWitness a2) = fmap (compare a1) (cast a2) + +eqGPDynSeq :: GPDynSeq -> GPDynSeq -> Maybe Bool +eqGPDynSeq (GPDynSeq GPWitness a1) (GPDynSeq GPWitness a2) = fmap (a1==) (cast a2) + +-- showGPDynSeq :: GPDynSeq -> String +-- showGPDynSeq (GPDynSeq GPWitness s) = show s + +-- wireSizeGPDyn :: FieldType -> GPDyn -> WireSize +-- wireSizeGPDyn ft (GPDyn GPWitness a) = wireSize ft a + +-- wirePutGPDyn :: FieldType -> GPDyn -> Put +-- wirePutGPDyn ft (GPDyn GPWitness a) = wirePut ft a + +-- wireGetGPDyn :: forall a. GPWitness a -> FieldType -> Get GPDyn +-- wireGetGPDyn GPWitness ft = fmap (GPDyn GPWitness) (wireGet ft :: Get a) + +-- getWitness :: (GPB a) => GPDyn -> Maybe (GPWitness a) +-- getWitness (GPDyn x@GPWitness _) = cast x + +-- readGPDyn :: forall a . Read a => GPWitness a -> String -> GPDyn +-- readGPDyn x@(GPWitness) s = +-- let t :: a; t = read s +-- in GPDyn x t + +instance ExtKey Maybe where + putExt key Nothing msg = clearExt key msg + putExt (Key i t _) (Just v) msg = + let (ExtField ef) = getExtField msg + v' = ExtOptional t (GPDyn GPWitness v) + ef' = M.insert i v' ef + in seq v' $ seq ef' (putExtField (ExtField ef') msg) + + clearExt (Key i _ _ ) msg = + let (ExtField ef) = getExtField msg + ef' = M.delete i ef + in seq ef' (putExtField (ExtField ef') msg) + + getExt k@(Key i t _) msg = + let wt = toWireType t + (ExtField ef) = getExtField msg + in case M.lookup i ef of + Nothing -> Right Nothing + Just (ExtFromWire raw) -> either Left (getExt' . snd) (parseWireExtMaybe k wt raw) + Just x -> getExt' x + where getExt' (ExtRepeated t' _) = Left $ "getExt Maybe: ExtField has repeated type: "++show (k,t') + getExt' (ExtPacked t' _) = Left $ "getExt Maybe: ExtField has packed type: "++show (k,t') + getExt' (ExtOptional t' (GPDyn GPWitness d)) | t/=t' = + Left $ "getExt Maybe: Key's FieldType does not match ExtField's: "++show (k,t') + | otherwise = + case cast d of + Nothing -> Left $ "getExt Maybe: Key's value cast failed: "++show (k,typeOf d) + Just d' -> Right (Just d') + getExt' (ExtFromWire {}) = err $ "Impossible? getExt.getExt' Maybe should not have ExtFromWire case (after parseWireExt)!" + + wireGetKey k@(Key i t mv) msg = do + let wt = toWireType t + myCast :: Maybe a -> Get a + myCast = undefined + v <- wireGet t `asTypeOf` (myCast mv) + let (ExtField ef) = getExtField msg + v' <- case M.lookup i ef of + Nothing -> return $ ExtOptional t (GPDyn GPWitness v) + Just (ExtOptional t' (GPDyn GPWitness vOld)) | t /= t' -> + fail $ "wireGetKey Maybe: Key mismatch! found wrong field type: "++show (k,t,t') + | otherwise -> + case cast vOld of + Nothing -> fail $ "wireGetKey Maybe: previous Maybe value case failed: "++show (k,typeOf vOld) + Just vOld' -> return $ ExtOptional t (GPDyn GPWitness (mergeAppend vOld' v)) + Just (ExtFromWire raw) -> + case parseWireExtMaybe k wt raw of + Left errMsg -> fail $ "wireGetKey Maybe: Could not parseWireExtMaybe: "++show k++"\n"++errMsg + Right (_,ExtOptional t' (GPDyn GPWitness vOld)) | t/=t' -> + fail $ "wireGetKey Maybe: Key mismatch! found wrong field type: "++show (k,t,t') + | otherwise -> + case cast vOld of + Nothing -> fail $ "wireGetKey Maybe: previous Maybe value case failed: "++show (k,typeOf vOld) + Just vOld' -> return $ ExtOptional t (GPDyn GPWitness (mergeAppend vOld' v)) + wtf -> fail $ "wireGetKey Maybe: Weird parseGetWireMaybe return value: "++show (k,wtf) + Just wtf@(ExtRepeated {}) -> fail $ "wireGetKey Maybe: ExtRepeated found with ExtOptional expected: "++show (k,wtf) + Just wtf@(ExtPacked {}) -> fail $ "wireGetKey Maybe: ExtPacked found with ExtOptional expected: "++show (k,wtf) + let ef' = M.insert i v' ef + seq v' $ seq ef' $ return (putExtField (ExtField ef') msg) + +-- | used by 'getVal' and 'wireGetKey' for the 'Maybe' instance +parseWireExtMaybe :: Key Maybe msg v -> WireType -> Seq EP -> Either String (FieldId,ExtFieldValue) +parseWireExtMaybe k@(Key fi ft mv) wt raw | wt /= toWireType ft = + Left $ "parseWireExt Maybe: Key's FieldType does not match ExtField's wire type: "++show (k,toWireType ft,wt) + | otherwise = do + let mkWitType :: Maybe a -> GPWitness a + mkWitType = undefined + witness = GPWitness `asTypeOf` (mkWitType mv) +-- parsed = map (applyGet (wireGet ft)) . F.toList $ raw + parsed = map (chooseGet ft) . F.toList $ raw + errs = [ m | Left m <- parsed ] + if null errs + then case viewl (mconcat [ a | Right a <- parsed ]) of + EmptyL -> Left "Text.ProtocolBuffers.Extensions.parseWireExtMaybe: impossible empty parsed list" + x :< xs -> Right (fi,(ExtOptional ft (GPDyn witness (F.foldl' mergeAppend x xs)))) + else Left (unlines errs) + +-- 'chooseGet' is an intermediate handler between parseWireExt* and applyGet. This does not know +-- whether the EP will result in a single r or repeat r, so it always returns a Seq. It may also +-- realize that there is a mismatch between the desired FieldType and the WireType +chooseGet :: (Wire r) => FieldType -> EP -> Either String (Seq r) +chooseGet ft (EP wt bsIn) = + if (2==wt) && (isValidPacked ft) + then applyGet (wireGetPacked ft) bsIn + else if (wt == toWireType ft) + then applyGet (fmap Seq.singleton $ wireGet ft) bsIn + else Left $ "Text.ProtocolBuffers.Extensions.chooseGet: wireType mismatch "++show(wt,ft) + +-- | Converts the the 'Result' into an 'Either' type and enforces +-- consumption of entire 'ByteString'. Used by 'parseWireExtMaybe' +-- and 'parseWireExtSeq' to process raw wire input that has been +-- stored in an 'ExtField'. +applyGet :: Get r -> ByteString -> Either String r +applyGet g bsIn = resolveEOF (runGet g bsIn) where + resolveEOF :: Result r -> Either String r + resolveEOF (Failed i s) = Left ("Failed at "++show i++" : "++s) + resolveEOF (Finished bs _i r) | L.null bs = Right r + | otherwise = Left "Not all input consumed" + resolveEOF (Partial {}) = Left "Not enough input" + +instance ExtKey Seq where + putExt key@(Key i t _) s msg | Seq.null s = clearExt key msg + | otherwise = + let (ExtField ef) = getExtField msg + v' = ExtRepeated t (GPDynSeq GPWitness s) + ef' = M.insert i v' ef + in seq v' $ seq ef' (putExtField (ExtField ef') msg) + + clearExt (Key i _ _) msg = + let (ExtField ef) = getExtField msg + ef' = M.delete i ef + in seq ef' (putExtField (ExtField ef') msg) + + getExt k@(Key i t _) msg = + let wt = toWireType t + (ExtField ef) = getExtField msg + in case M.lookup i ef of + Nothing -> Right Seq.empty + Just (ExtFromWire raw) -> either Left (getExt' . snd) (parseWireExtSeq k wt raw) + Just x -> getExt' x + where getExt' (ExtOptional t' _) = Left $ "getExt Seq: ExtField has optional type: "++show (k,t') + getExt' (ExtPacked t' _) = Left $ "getExt Seq: ExtField has packed type: "++show (k,t') + getExt' (ExtRepeated t' (GPDynSeq GPWitness s)) | t'/=t = + Left $ "getExt Seq: Key's FieldType does not match ExtField's: "++show (k,t') + | otherwise = + case cast s of + Nothing -> Left $ "getExt Seq: Key's Seq value cast failed: "++show (k,typeOf s) + Just s' -> Right s' + getExt' (ExtFromWire {}) = err $ "Impossible? getExt.getExt' Seq should not have ExtFromWire case (after parseWireExtSeq)!" + + -- This is more complicated than the Maybe instance because the old + -- Seq needs to be retrieved and perhaps parsed and then appended + -- to. All sanity checks are included below. TODO: do enough + -- testing to be confident in removing some checks. + wireGetKey k@(Key i t mv) msg = do + let wt = toWireType t + myCast :: Maybe a -> Get a + myCast = undefined + v <- wireGet t `asTypeOf` (myCast mv) + let (ExtField ef) = getExtField msg + v' <- case M.lookup i ef of + Nothing -> return $ ExtRepeated t (GPDynSeq GPWitness (Seq.singleton v)) + Just (ExtRepeated t' (GPDynSeq GPWitness s)) | t/=t' -> + fail $ "wireGetKey Seq: Key mismatch! found wrong field type: "++show (k,t,t') + | otherwise -> + case cast s of + Nothing -> fail $ "wireGetKey Seq: previous Seq value cast failed: "++show (k,typeOf s) + Just s' -> seq v $ return $ ExtRepeated t (GPDynSeq GPWitness (s' |> v)) + Just (ExtFromWire raw) -> + case parseWireExtSeq k wt raw of + Left errMsg -> fail $ "wireGetKey Seq: Could not parseWireExtSeq: "++show k++"\n"++errMsg + Right (_,ExtRepeated t' (GPDynSeq GPWitness s)) | t/=t' -> + fail $ "wireGetKey Seq: Key mismatch! parseWireExtSeq returned wrong field type: "++show (k,t,t') + | otherwise -> + case cast s of + Nothing -> fail $ "wireGetKey Seq: previous Seq value cast failed: "++show (k,typeOf s) + Just s' -> seq v $ return $ ExtRepeated t (GPDynSeq GPWitness (s' |> v)) + wtf -> fail $ "wireGetKey Seq: Weird parseWireExtSeq return value: "++show (k,wtf) + Just wtf@(ExtOptional {}) -> fail $ "wireGetKey Seq: ExtOptional found when ExtRepeated expected: "++show (k,wtf) + Just wtf@(ExtPacked {}) -> fail $ "wireGetKey Seq: ExtPacked found when ExtRepeated expected: "++show (k,wtf) + let ef' = M.insert i v' ef + seq v' $ seq ef' $ return (putExtField (ExtField ef') msg) + +-- | used by 'getVal' and 'wireGetKey' for the 'Seq' instance +parseWireExtSeq :: Key Seq msg v -> WireType -> Seq EP -> Either String (FieldId,ExtFieldValue) +parseWireExtSeq k@(Key i t mv) wt raw | wt /= toWireType t = + Left $ "parseWireExtSeq: Key mismatch! Key's FieldType does not match ExtField's wire type: "++show (k,toWireType t,wt) + | otherwise = do + let mkWitType :: Maybe a -> GPWitness a + mkWitType = undefined + witness = GPWitness `asTypeOf` (mkWitType mv) +-- parsed = map (applyGet (wireGet t)) . F.toList $ raw + parsed = map (chooseGet t) . F.toList $ raw + errs = [ m | Left m <- parsed ] + if null errs then Right (i,(ExtRepeated t (GPDynSeq witness (mconcat [ a | Right a <- parsed ])))) + else Left (unlines errs) + +instance ExtKey PackedSeq where + putExt key@(Key i t _) (PackedSeq s) msg | Seq.null s = clearExt key msg + | otherwise = + let (ExtField ef) = getExtField msg + v' = ExtPacked t (GPDynSeq GPWitness s) + ef' = M.insert i v' ef + in seq v' $ seq ef' (putExtField (ExtField ef') msg) + + clearExt (Key i _ _) msg = + let (ExtField ef) = getExtField msg + ef' = M.delete i ef + in seq ef' (putExtField (ExtField ef') msg) + + getExt k@(Key i t _) msg = + let wt = toWireType t + (ExtField ef) = getExtField msg + in case M.lookup i ef of + Nothing -> Right (PackedSeq Seq.empty) + Just (ExtFromWire raw) -> either Left (getExt' . snd) (parseWireExtPackedSeq k wt raw) + Just x -> getExt' x + where getExt' (ExtOptional t' _) = Left $ "getExt PackedSeq: ExtField has optional type: "++show (k,t') + getExt' (ExtRepeated t' _) = Left $ "getExt PackedSeq: ExtField has repeated type: "++show (k,t') + getExt' (ExtPacked t' (GPDynSeq GPWitness s)) | t'/=t = + Left $ "getExt PackedSeq: Key's FieldType does not match ExtField's: "++show (k,t') + | otherwise = + case cast s of + Nothing -> Left $ "getExt PackedSeq: Key's Seq value cast failed: "++show (k,typeOf s) + Just s' -> Right (PackedSeq s') + getExt' (ExtFromWire {}) = err $ "Impossible? getExt.getExt' PackedSeq should not have ExtFromWire case (after parseWireExtSeq)!" + + wireGetKey k@(Key i t mv) msg = do + let wt = toWireType t + myCast :: Maybe a -> Get (Seq a) + myCast = undefined + vv <- wireGetPacked t `asTypeOf` (myCast mv) + let (ExtField ef) = getExtField msg + v' <- case M.lookup i ef of + Nothing -> return $ ExtPacked t (GPDynSeq GPWitness vv) + Just (ExtPacked t' (GPDynSeq GPWitness s)) | t/=t' -> + fail $ "wireGetKey PackedSeq: Key mismatch! found wrong field type: "++show (k,t,t') + | otherwise -> + case cast s of + Nothing -> fail $ "wireGetKey PackedSeq: previous Seq value cast failed: "++show (k,typeOf s) + Just s' -> return $ ExtRepeated t (GPDynSeq GPWitness (s' >< vv)) + Just (ExtFromWire raw) -> + case parseWireExtPackedSeq k wt raw of + Left errMsg -> fail $ "wireGetKey PackedSeq: Could not parseWireExtPackedSeq: "++show k++"\n"++errMsg + Right (_,ExtPacked t' (GPDynSeq GPWitness s)) | t/=t' -> + fail $ "wireGetKey PackedSeq: Key mismatch! parseWireExtPackedSeq returned wrong field type: "++show (k,t,t') + | otherwise -> + case cast s of + Nothing -> fail $ "wireGetKey PackedSeq: previous Seq value cast failed: "++show (k,typeOf s) + Just s' -> return $ ExtRepeated t (GPDynSeq GPWitness (s' >< vv)) + wtf -> fail $ "wireGetKey PackedSeq: Weird parseWireExtPackedSeq return value: "++show (k,wtf) + Just wtf@(ExtOptional {}) -> fail $ "wireGetKey PackedSeq: ExtOptional found when ExtPacked expected: "++show (k,wtf) +-- XXX XXX XXX 2.3.0 need to add handling to the next line? + Just wtf@(ExtRepeated {}) -> fail $ "wireGetKey PackedSeq: ExtRepeated found when ExtPacked expected: "++show (k,wtf) + let ef' = M.insert i v' ef + seq v' $ seq ef' $ return (putExtField (ExtField ef') msg) + +parseWireExtPackedSeq :: Key PackedSeq msg v -> WireType -> Seq EP -> Either String (FieldId,ExtFieldValue) +parseWireExtPackedSeq k@(Key i t mv) wt raw | wt /= 2 {- packed wire type is 2, length delimited -} = + Left $ "parseWireExtPackedSeq: Key mismatch! Key's FieldType does not match ExtField's wire type: "++show (k,toWireType t,wt) + | otherwise = do + let mkWitType :: Maybe a -> GPWitness a + mkWitType = undefined + witness = GPWitness `asTypeOf` (mkWitType mv) +-- parsed = map (applyGet (wireGetPacked t)) . F.toList $ raw + parsed = map (chooseGet t) . F.toList $ raw + errs = [ m | Left m <- parsed ] + if null errs then Right (i,(ExtPacked t (GPDynSeq witness (mconcat [ a | Right a <- parsed ])))) + else Left (unlines errs) + +-- | This is used by the generated code +wireSizeExtField :: ExtField -> WireSize +wireSizeExtField (ExtField m) = F.foldl' aSize 0 (M.assocs m) where + aSize old (fi,(ExtFromWire raw)) = + let toSize (EP wt bs) = size'WireTag (mkWireTag fi wt) + L.length bs + in F.foldl' (\oldVal new -> oldVal + toSize new) old raw +{- + aSize old (fi,(ExtFromWire raw)) = old + + let tagSize = size'WireTag (mkWireTag fi wt) + in F.foldl' (\oldVal new -> oldVal + L.length new) (fromIntegral (Seq.length raw) * tagSize) raw +-} + aSize old (fi,(ExtOptional ft (GPDyn GPWitness d))) = old + + let tagSize = size'WireTag (toWireTag fi ft) + in wireSizeReq tagSize ft d + aSize old (fi,(ExtRepeated ft (GPDynSeq GPWitness s))) = old + + let tagSize = size'WireTag (toWireTag fi ft) + in wireSizeRep tagSize ft s + aSize old (fi,(ExtPacked ft (GPDynSeq GPWitness s))) = old + + let tagSize = size'WireTag (toPackedWireTag fi) + in wireSizePacked tagSize ft s + +-- | This is used by the generated code. The data is serialized in +-- order of increasing field number. +wirePutExtField :: ExtField -> Put +wirePutExtField (ExtField m) = mapM_ aPut (M.assocs m) where + aPut (fi,(ExtFromWire raw)) = F.mapM_ (\(EP wt bs) -> putVarUInt (getWireTag $ mkWireTag fi wt) >> putLazyByteString bs) raw + aPut (fi,(ExtOptional ft (GPDyn GPWitness d))) = wirePutOpt (toWireTag fi ft) ft (Just d) + aPut (fi,(ExtRepeated ft (GPDynSeq GPWitness s))) = wirePutRep (toWireTag fi ft) ft s + aPut (fi,(ExtPacked ft (GPDynSeq GPWitness s))) = wirePutPacked (toPackedWireTag fi) ft s + +notExtension :: (ReflectDescriptor a, ExtendMessage a,Typeable a) => FieldId -> WireType -> a -> Get a +notExtension fieldId _wireType msg = throwError ("Field id "++show fieldId++" is not a valid extension field id for "++show (typeOf (undefined `asTypeOf` msg))) + +-- | get a value from the wire into the message's ExtField. This is used by generated code for +-- extensions that were not known at compile time. +loadExtension :: (ReflectDescriptor a, ExtendMessage a) => FieldId -> WireType -> a -> Get a +--loadExtension fieldId wireType msg | isValidExt fieldId msg = do -- XXX check moved to generated code +--loadExtension fieldId wireType msg = unknown fieldId wireType msg -- XXX +loadExtension fieldId wireType msg = do + let (ExtField ef) = getExtField msg + badwt :: WireType -> Get a + badwt wt = do here <- bytesRead + fail $ "Conflicting wire types at byte position "++show here ++ " for extension to message: "++show (typeOf msg,fieldId,wireType,wt) + case M.lookup fieldId ef of + Nothing -> do + bs <- wireGetFromWire fieldId wireType + let v' = ExtFromWire (Seq.singleton (EP wireType bs)) + ef' = M.insert fieldId v' ef + seq v' $ seq ef' $ return $ putExtField (ExtField ef') msg + Just (ExtFromWire raw) -> do + bs <- wireGetFromWire fieldId wireType + let v' = seq bs $ ExtFromWire (raw |> (EP wireType bs)) + ef' = M.insert fieldId v' ef + seq v' $ seq ef' $ return (putExtField (ExtField ef') msg) + Just (ExtOptional ft (GPDyn x@GPWitness a)) | toWireType ft /= wireType -> badwt (toWireType ft) + | otherwise -> do + b <- wireGet ft + let v' = ExtOptional ft (GPDyn x (mergeAppend a b)) + ef' = M.insert fieldId v' ef + seq v' $ seq ef' $ return (putExtField (ExtField ef') msg) +-- handle wireType of "2" when toWireType ft is not "2" but ft could be packed by using wireGetPacked ft + Just (ExtRepeated ft (GPDynSeq x@GPWitness s)) | toWireType ft /= wireType -> if (wireType==2) && (isValidPacked ft) + then do + aa <- wireGetPacked ft + let v' = ExtRepeated ft (GPDynSeq x (s >< aa)) + ef' = M.insert fieldId v' ef + seq v' $ seq ef' $ return (putExtField (ExtField ef') msg) + else badwt (toWireType ft) + | otherwise -> do + a <- wireGet ft + let v' = seq a $ ExtRepeated ft (GPDynSeq x (s |> a)) + ef' = M.insert fieldId v' ef + seq v' $ seq ef' $ return (putExtField (ExtField ef') msg) +-- handle wireType of NOT "2" when wireType is good match for ft by using wireGet ft + Just (ExtPacked ft (GPDynSeq x@GPWitness s)) | 2 /= wireType -> if (toWireType ft) == wireType + then do + a <- wireGet ft + let v' = seq a $ ExtPacked ft (GPDynSeq x (s |> a)) + ef' = M.insert fieldId v' ef + seq v' $ seq ef' $ return (putExtField (ExtField ef') msg) + else badwt 2 {- packed uses length delimited: 2 -} + | otherwise -> do + aa <- wireGetPacked ft + let v' = ExtPacked ft (GPDynSeq x (s >< aa)) + ef' = M.insert fieldId v' ef + seq v' $ seq ef' $ return (putExtField (ExtField ef') msg) + +class MessageAPI msg a b | msg a -> b where + -- | Access data in a message. The first argument is always the + -- message. The second argument can be one of 4 categories. + -- + -- * The field name of a required field acts a simple retrieval of + -- the data from the message. + -- + -- * The field name of an optional field will retreive the data if + -- it is set or lookup the default value if it is not set. + -- + -- * The field name of a repeated field always retrieves the + -- (possibly empty) 'Seq' of values. + -- + -- * A Key for an optional or repeated value will act as the field + -- name does above, but if there is a type mismatch or parse error + -- it will use the defaultValue for optional types and an empty + -- sequence for repeated types. + getVal :: msg -> a -> b + + -- | Check whether data is present in the message. + -- + -- * Required fields always return 'True'. + -- + -- * Optional fields return whether a value is present. + -- + -- * Repeated field return 'False' if there are no values, otherwise + -- they return 'True'. + -- + -- * Keys return as optional or repeated, but checks only if the + -- field # is present. This assumes that there are no collisions + -- where more that one key refers to the same field number of this + -- message type. + isSet :: msg -> a -> Bool + isSet _ _ = True + +instance (Default msg,Default a) => MessageAPI msg (msg -> Maybe a) a where + getVal m f = fromMaybe (fromMaybe defaultValue (f defaultValue)) (f m) + isSet m f = isJust (f m) + +instance MessageAPI msg (msg -> (Seq a)) (Seq a) where + getVal m f = f m + isSet m f = not (Seq.null (f m)) + +instance (Default v) => MessageAPI msg (Key Maybe msg v) v where + getVal m k@(Key _ _ md) = case getExt k m of + Right (Just v) -> v + _ -> fromMaybe defaultValue md + isSet m (Key fid _ _) = let (ExtField x) = getExtField m + in M.member fid x + +instance (Default v) => MessageAPI msg (Key Seq msg v) (Seq v) where + getVal m k@(Key _ _ _) = case getExt k m of + Right s -> s + _ -> Seq.empty + isSet m (Key fid _ _) = let (ExtField x) = getExtField m + in M.member fid x + +instance MessageAPI msg (msg -> ByteString) ByteString where getVal m f = f m +instance MessageAPI msg (msg -> Utf8) Utf8 where getVal m f = f m +instance MessageAPI msg (msg -> Double) Double where getVal m f = f m +instance MessageAPI msg (msg -> Float) Float where getVal m f = f m +instance MessageAPI msg (msg -> Int32) Int32 where getVal m f = f m +instance MessageAPI msg (msg -> Int64) Int64 where getVal m f = f m +instance MessageAPI msg (msg -> Word32) Word32 where getVal m f = f m +instance MessageAPI msg (msg -> Word64) Word64 where getVal m f = f m + +-- Must keep synchronized with Parser.isValidPacked +isValidPacked :: FieldType -> Bool +isValidPacked fieldType = + case fieldType of + 9 -> False + 10 -> False + 11 -> False -- Impossible value for typeCode from parseType, but here for completeness + 12 -> False + _ -> True diff --git a/Text/ProtocolBuffers/Get.hs b/Text/ProtocolBuffers/Get.hs new file mode 100644 --- /dev/null +++ b/Text/ProtocolBuffers/Get.hs @@ -0,0 +1,879 @@ +{-# LANGUAGE CPP,MagicHash,ScopedTypeVariables,FlexibleInstances,RankNTypes,TypeSynonymInstances,MultiParamTypeClasses,BangPatterns #-} +-- | By Chris Kuklewicz, drawing heavily from binary and binary-strict, +-- but all the bugs are my own. +-- +-- This file is under the usual BSD3 licence, copyright 2008. +-- +-- Modified the monad to be strict for version 2.0.0 +-- +-- This started out as an improvement to +-- "Data.Binary.Strict.IncrementalGet" with slightly better internals. +-- The simplified 'Get', 'runGet', 'Result' trio with the +-- "Data.Binary.Strict.Class.BinaryParser" instance are an _untested_ +-- upgrade from IncrementalGet. Especially untested are the +-- strictness properties. +-- +-- 'Get' usefully implements Applicative and Monad, MonadError, +-- Alternative and MonadPlus. Unhandled errors are reported along +-- with the number of bytes successfully consumed. Effects of +-- 'suspend' and 'putAvailable' are visible after +-- fail/throwError/mzero. +-- +-- Each time the parser reaches the end of the input it will return a +-- Partial wrapped continuation which requests a (Maybe +-- Lazy.ByteString). Passing (Just bs) will append bs to the input so +-- far and continue processing. If you pass Nothing to the +-- continuation then you are declaring that there will never be more +-- input and that the parser should never again return a partial +-- contination; it should return failure or finished. +-- +-- 'suspendUntilComplete' repeatedly uses a partial continuation to +-- ask for more input until 'Nothing' is passed and then it proceeds +-- with parsing. +-- +-- The 'getAvailable' command returns the lazy byte string the parser +-- has remaining before calling 'suspend'. The 'putAvailable' +-- replaces this input and is a bit fancy: it also replaces the input +-- at the current offset for all the potential catchError/mplus +-- handlers. This change is _not_ reverted by fail/throwError/mzero. +-- +-- The three 'lookAhead' and 'lookAheadM' and 'lookAheadE' functions are +-- very similar to the ones in binary's Data.Binary.Get. +-- +-- +-- Add specialized high-bit-run +module Text.ProtocolBuffers.Get + (Get,runGet,runGetAll,Result(..) + -- main primitives + ,ensureBytes,getStorable,getLazyByteString,suspendUntilComplete + -- parser state manipulation + ,getAvailable,putAvailable + -- lookAhead capabilities + ,lookAhead,lookAheadM,lookAheadE + -- below is for implementation of BinaryParser (for Int64 and Lazy bytestrings) + ,skip,bytesRead,isEmpty,isReallyEmpty,remaining,spanOf,highBitRun + ,getWord8,getByteString + ,getWord16be,getWord32be,getWord64be + ,getWord16le,getWord32le,getWord64le + ,getWordhost,getWord16host,getWord32host,getWord64host + -- + -- ,scan + ,decode7,decode7size,decode7unrolled + ) where + +-- The Get monad is an instance of binary-strict's BinaryParser: +-- import qualified Data.Binary.Strict.Class as P(BinaryParser(..)) +-- The Get monad is an instance of all of these library classes: +import Control.Applicative(Applicative(pure,(<*>)),Alternative(empty,(<|>))) +import Control.Monad(MonadPlus(mzero,mplus),when) +import Control.Monad.Error.Class(MonadError(throwError,catchError),Error(strMsg)) +-- It can be a MonadCont, but the semantics are too broken without a ton of work. + +-- implementation imports +--import Control.Monad(replicateM,(>=>)) -- XXX testing +--import qualified Data.ByteString as S(unpack) -- XXX testing +--import qualified Data.ByteString.Lazy as L(pack) -- XXX testing +import Control.Monad(ap) -- instead of Functor.fmap; ap for Applicative +import Data.Bits(Bits((.|.),(.&.)),shiftL) +import qualified Data.ByteString as S(concat,length,null,splitAt,findIndex) +import qualified Data.ByteString.Internal as S(ByteString(..),toForeignPtr,inlinePerformIO) +import qualified Data.ByteString.Unsafe as S(unsafeIndex,unsafeDrop {-,unsafeTake-}) +import qualified Data.ByteString.Lazy as L(take,drop,length,span,toChunks,fromChunks,null,findIndex) +import qualified Data.ByteString.Lazy.Internal as L(ByteString(..),chunk) +import qualified Data.Foldable as F(foldr,foldr1) -- used with Seq +import Data.Int(Int32,Int64) -- index type for L.ByteString +import Data.Monoid(Monoid(mempty,mappend)) -- Writer has a Monoid contraint +import Data.Sequence(Seq,null,(|>)) -- used for future queue in handler state +import Data.Word(Word,Word8,Word16,Word32,Word64) +import Foreign.ForeignPtr(withForeignPtr) +import Foreign.Ptr(Ptr,castPtr,plusPtr,minusPtr,nullPtr) +import Foreign.Storable(Storable(peek,sizeOf)) +import System.IO.Unsafe(unsafePerformIO) +#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__) +import GHC.Base(Int(..),uncheckedShiftL#) +import GHC.Word(Word16(..),Word32(..),Word64(..),uncheckedShiftL64#) +#endif +--import Debug.Trace(trace) + +trace :: a -> b -> b +trace _ = id + +-- Simple external return type +data Result a = Failed {-# UNPACK #-} !Int64 String + | Finished !L.ByteString {-# UNPACK #-} !Int64 a + | Partial (Maybe L.ByteString -> Result a) + +-- Internal state type, not exposed to the user. +-- Invariant: (S.null _top) implies (L.null _current) +data S = S { _top :: {-# UNPACK #-} !S.ByteString + , _current :: !L.ByteString + , consumed :: {-# UNPACK #-} !Int64 + } deriving Show + +data T3 s = T3 !Int !s !Int + +--data TU s = TU'OK !s !Int | TU'DO (Get s) +data TU s = TU'OK !s !Int + +{-# SPECIALIZE decode7unrolled :: Get Int64 #-} +{-# SPECIALIZE decode7unrolled :: Get Int32 #-} +{-# SPECIALIZE decode7unrolled :: Get Word64 #-} +{-# SPECIALIZE decode7unrolled :: Get Word32 #-} +{-# SPECIALIZE decode7unrolled :: Get Int #-} +{-# SPECIALIZE decode7unrolled :: Get Integer #-} +decode7unrolled :: forall s. (Num s,Integral s, Bits s) => Get s +{-# NOINLINE decode7unrolled #-} +decode7unrolled = Get $ \ sc sIn@(S ss@(S.PS fp off len) bs n) pc -> trace ("decode7unrolled: "++show (len,n)) $ + if S.null ss + then trace ("decode7unrolled: S.null ss") $ unGet decode7 sc sIn pc -- decode7 will try suspend then will fail if still bad + else + let (TU'OK x i) = + unsafePerformIO $ withForeignPtr fp $ \ptr0 -> do + if ptr0 == nullPtr || len < 1 then error "Get.decode7unrolled: ByteString invariant failed" else do + let ok :: s -> Int -> IO (TU s) + ok x0 i0 = return (TU'OK x0 i0) + more,err :: IO (TU s) + more = return (TU'OK 0 0) -- decode7 + err = return (TU'OK 0 (-1)) -- throwError + {-# INLINE ok #-} + {-# INLINE more #-} + {-# INLINE err #-} + +-- -- Next line is segfault fix for null bytestrings from Nathan Howell +-- if ptr0 == nullPtr then more else do + + let start = ptr0 `plusPtr` off :: Ptr Word8 + b'1 <- peek start + if b'1 < 128 then ok (fromIntegral b'1) 1 else do + let !val'1 = fromIntegral (b'1 .&. 0x7F) + !end = start `plusPtr` len + !ptr2 = start `plusPtr` 1 :: Ptr Word8 + if ptr2 >= end then more else do + + b'2 <- peek ptr2 + if b'2 < 128 then ok (val'1 .|. (fromIntegral b'2 `shiftL` 7)) 2 else do + let !val'2 = (val'1 .|. (fromIntegral (b'2 .&. 0x7F) `shiftL` 7)) + !ptr3 = ptr2 `plusPtr` 1 + if ptr3 >= end then more else do + + b'3 <- peek ptr3 + if b'3 < 128 then ok (val'2 .|. (fromIntegral b'3 `shiftL` 14)) 3 else do + let !val'3 = (val'2 .|. (fromIntegral (b'3 .&. 0x7F) `shiftL` 14)) + !ptr4 = ptr3 `plusPtr` 1 + if ptr4 >= end then more else do + + b'4 <- peek ptr4 + if b'4 < 128 then ok (val'3 .|. (fromIntegral b'4 `shiftL` 21)) 4 else do + let !val'4 = (val'3 .|. (fromIntegral (b'4 .&. 0x7F) `shiftL` 21)) + !ptr5 = ptr4 `plusPtr` 1 + if ptr5 >= end then more else do + + b'5 <- peek ptr5 + if b'5 < 128 then ok (val'4 .|. (fromIntegral b'5 `shiftL` 28)) 5 else do + let !val'5 = (val'4 .|. (fromIntegral (b'5 .&. 0x7F) `shiftL` 28)) + !ptr6 = ptr5 `plusPtr` 1 + if ptr6 >= end then more else do + + b'6 <- peek ptr6 + if b'6 < 128 then ok (val'5 .|. (fromIntegral b'6 `shiftL` 35)) 6 else do + let !val'6 = (val'5 .|. (fromIntegral (b'6 .&. 0x7F) `shiftL` 35)) + !ptr7 = ptr6 `plusPtr` 1 + if ptr7 >= end then more else do + + b'7 <- peek ptr7 + if b'7 < 128 then ok (val'6 .|. (fromIntegral b'7 `shiftL` 42)) 7 else do + let !val'7 = (val'6 .|. (fromIntegral (b'7 .&. 0x7F) `shiftL` 42)) + !ptr8 = ptr7 `plusPtr` 1 + if ptr8 >= end then more else do + + b'8 <- peek ptr8 + if b'8 < 128 then ok (val'7 .|. (fromIntegral b'8 `shiftL` 49)) 8 else do + let !val'8 = (val'7 .|. (fromIntegral (b'8 .&. 0x7F) `shiftL` 49)) + !ptr9 = ptr8 `plusPtr` 1 + if ptr9 >= end then more else do + + b'9 <- peek ptr9 + if b'9 < 128 then ok (val'8 .|. (fromIntegral b'9 `shiftL` 56)) 9 else do + let !val'9 = (val'8 .|. (fromIntegral (b'9 .&. 0x7F) `shiftL` 56)) + !ptrA = ptr9 `plusPtr` 1 + if ptrA >= end then more else do + + b'A <- peek ptrA + if b'A < 128 then ok (val'9 .|. (fromIntegral b'A `shiftL` 63)) 10 else do + err + + in if i > 0 + then let ss' = (S.unsafeDrop i ss) + n' = n+fromIntegral i + s'safe = make_safe (S ss' bs n') + in sc x s'safe pc + else if i==0 then unGet decode7 sc sIn pc + else unGet (throwError $ "Text.ProtocolBuffers.Get.decode7unrolled: more than 10 bytes needed at bytes read of "++show n) sc sIn pc + +{-# SPECIALIZE decode7 :: Get Int64 #-} +{-# SPECIALIZE decode7 :: Get Int32 #-} +{-# SPECIALIZE decode7 :: Get Word64 #-} +{-# SPECIALIZE decode7 :: Get Word32 #-} +{-# SPECIALIZE decode7 :: Get Int #-} +{-# SPECIALIZE decode7 :: Get Integer #-} +decode7 :: forall s. (Integral s, Bits s) => Get s +{-# NOINLINE decode7 #-} +decode7 = go 0 0 + where + go !s1 !shift1 = trace ("decode7.go: "++show (toInteger s1, shift1)) $ do + let -- scanner's inner loop decodes only in current top strict bytestring, does not advance input state + scanner (S.PS fp off len) = + withForeignPtr fp $ \ptr0 -> do + if ptr0 == nullPtr || len < 1 then error "Get.decode7: ByteString invariant failed" else do + let start = ptr0 `plusPtr` off -- start is a pointer to the next valid byte + end = start `plusPtr` len -- end is a pointer one byte past the last valid byte + inner :: (Ptr Word8) -> s -> Int -> IO (T3 s) + inner !ptr !s !shift + | ptr < end = do + w <- peek ptr + trace ("w: " ++ show w) $ do + if (128>) w + then return $ T3 (succ (ptr `minusPtr` start) ) -- length of capture + (s .|. ((fromIntegral w) `shiftL` shift)) -- put the last bits into high position + (-1) -- negative shift indicates satisfied + else inner (ptr `plusPtr` 1) -- loop on next byte + (s .|. ((fromIntegral (w .&. 0x7F)) `shiftL` shift)) -- put the new bits into high position + (shift+7) -- increase high position for next loop + | otherwise = return $ T3 (ptr `minusPtr` start) -- length so far (ptr past end-of-string so no succ) + s -- value so far + shift -- next shift to use + inner start s1 shift1 + (S ss bs n) <- getFull + trace ("getFull says: "++ show ((S.length ss,ss),(L.length bs),n)) $ do + if S.null ss + then do + continue <- suspend + if continue + then go s1 shift1 + else fail "Get.decode7: Zero length input" -- XXX can be triggered! + else do + let (T3 i sOut shiftOut) = unsafePerformIO $ scanner ss + t = S.unsafeDrop i ss -- Warning: 't' may be mempty + n' = n + fromIntegral i + trace ("scanner says "++show ((i,toInteger sOut,shiftOut),(S.length t,n'))) $ do + if 0 <= shiftOut + then do + putFull_unsafe (make_state bs n') + if L.null bs + then do + continue <- suspend + if continue + then go sOut shiftOut + else return sOut + else do + go sOut shiftOut + else do + putFull_safe (S t bs n') -- bs from getFull is still valid + return sOut + +data T2 = T2 !Int64 !Bool + +decode7size :: Get Int64 +decode7size = go 0 + where + go !len1 = do + let scanner (S.PS fp off len) = + withForeignPtr fp $ \ptr0 -> do + if ptr0 == nullPtr || len < 1 then error "Get.decode7size: ByteString invariant failed" else do + let start = ptr0 `plusPtr` off + end = start `plusPtr` len + inner :: (Ptr Word8) -> IO T2 + inner !ptr + | ptr < end = do + w <- peek ptr + if (128>) w + then return $ T2 (fromIntegral (ptr `minusPtr` start)) True + else inner (ptr `plusPtr` 1) + | otherwise = return $ T2 (fromIntegral (ptr `minusPtr` start)) False + inner start + (S ss bs n) <- getFull + if S.null ss + then do + continue <- suspend + if continue + then go len1 + else fail "Get.decode7size: zero length input" + else do + let (T2 i ok) = unsafePerformIO $ scanner ss + t = S.unsafeDrop (fromIntegral i) ss + n' = n + i + len2 = len1 + i + if ok + then do + putFull_unsafe (S t bs n') + return len2 + else do + putFull_unsafe (make_state bs n') + if L.null bs + then do + continue <- suspend + if continue + then go len2 + else return len2 + else + go len2 + +-- Private Internal error handling stack type +-- This must NOT be exposed by this module +-- +-- The ErrorFrame is the top-level error handler setup when execution begins. +-- It starts with the Bool set to True: meaning suspend can ask for more input. +-- Once suspend get 'Nothing' in reply the Bool is set to False, which means +-- that 'suspend' should no longer ask for input -- the input is finished. +-- Why store the Bool there? It was handy when I needed to add it. +data FrameStack b = ErrorFrame (String -> S -> Result b) -- top level handler + Bool -- True at start, False if Nothing passed to suspend continuation + | HandlerFrame (Maybe ( S -> FrameStack b -> String -> Result b )) -- encapsulated handler + S -- stored state to pass to handler + (Seq L.ByteString) -- additional input to hass to handler + (FrameStack b) -- earlier/shallower/outer handlers + +type Success b a = (a -> S -> FrameStack b -> Result b) + +-- Internal monad type +newtype Get a = Get { + unGet :: forall b. -- the forall hides the CPS style (and prevents use of MonadCont) + Success b a -- main continuation + -> S -- parser state + -> FrameStack b -- error handler stack + -> Result b -- operation + } + +-- These implement the checkponting needed to store and revive the +-- state for lookAhead. They are fragile because the setCheckpoint +-- must preceed either useCheckpoint or clearCheckpoint but not both. +-- The FutureFrame must be the most recent handler, so the commands +-- must be in the same scope depth. Because of these constraints, the reader +-- value 'r' does not need to be stored and can be taken from the Get +-- parameter. +-- +-- IMPORTANT: Any FutureFrame at the top level(s) is discarded by throwError. +setCheckpoint,useCheckpoint,clearCheckpoint :: Get () +setCheckpoint = Get $ \ sc s pc -> sc () s (HandlerFrame Nothing s mempty pc) + +useCheckpoint = Get $ \ sc (S _ _ _) frame -> + case frame of + (HandlerFrame Nothing s future pc) -> sc () (collect s future) pc + _ -> error "Text.ProtocolBuffers.Get: Impossible useCheckpoint frame!" + +clearCheckpoint = Get $ \ sc s frame -> + case frame of + (HandlerFrame Nothing _s _future pc) -> sc () s pc + _ -> error "Text.ProtocolBuffers.Get: Impossible clearCheckpoint frame!" + +-- | 'lookAhead' runs the @todo@ action and then rewinds only the +-- BinaryParser state. Any new input from 'suspend' or changes from +-- 'putAvailable' are kept. Changes to the user state (MonadState) +-- are kept. The MonadWriter output is retained. +-- +-- If an error is thrown then the entire monad state is reset to last +-- catchError as usual. +lookAhead :: Get a -> Get a +lookAhead todo = do + setCheckpoint + a <- todo + useCheckpoint + return a + +-- | 'lookAheadM' runs the @todo@ action. If the action returns 'Nothing' then the +-- BinaryParser state is rewound (as in 'lookAhead'). If the action return 'Just' then +-- the BinaryParser is not rewound, and lookAheadM acts as an identity. +-- +-- If an error is thrown then the entire monad state is reset to last +-- catchError as usual. +lookAheadM :: Get (Maybe a) -> Get (Maybe a) +lookAheadM todo = do + setCheckpoint + a <- todo + maybe useCheckpoint (const clearCheckpoint) a + return a + +-- | 'lookAheadE' runs the @todo@ action. If the action returns 'Left' then the +-- BinaryParser state is rewound (as in 'lookAhead'). If the action return 'Right' then +-- the BinaryParser is not rewound, and lookAheadE acts as an identity. +-- +-- If an error is thrown then the entire monad state is reset to last +-- catchError as usual. +lookAheadE :: Get (Either a b) -> Get (Either a b) +lookAheadE todo = do + setCheckpoint + a <- todo + either (const useCheckpoint) (const clearCheckpoint) a + return a + +-- 'collect' is used by 'putCheckpoint' and 'throwError' +collect :: S -> Seq L.ByteString -> S +collect s@(S ss bs n) future | Data.Sequence.null future = make_safe $ s + | otherwise = make_safe $ S ss (mappend bs (F.foldr1 mappend future)) n + +-- Put the Show instances here + +instance (Show a) => Show (Result a) where + showsPrec _ (Failed n msg) = ("(Failed "++) . shows n . (' ':) . shows msg . (")"++) + showsPrec _ (Finished bs n a) = + ("(CFinished ("++) + . shows bs . (") ("++) + . shows n . (") ("++) + . shows a . ("))"++) + showsPrec _ (Partial {}) = ("(Partial Result a)"++) + +instance Show (FrameStack b) where + showsPrec _ (ErrorFrame _ p) =(++) "(ErrorFrame s->m b> " . shows p . (")"++) + showsPrec _ (HandlerFrame _ s future pc) = ("(HandlerFrame <> ("++) + . shows s . (") ("++) . shows future . (") ("++) + . shows pc . (")"++) + +-- | 'runGet' is the simple executor +runGet :: Get a -> L.ByteString -> Result a +runGet (Get f) bsIn = f scIn sIn (ErrorFrame ec True) + where scIn a (S ss bs n) _pc = Finished (L.chunk ss bs) n a + sIn = make_state bsIn 0 + ec msg sOut = Failed (consumed sOut) msg + +-- | 'runGetAll' is the simple executor, and will not ask for any continuation because this lazy bytestring is all the input +runGetAll :: Get a -> L.ByteString -> Result a +runGetAll (Get f) bsIn = f scIn sIn (ErrorFrame ec False) + where scIn a (S ss bs n) _pc = Finished (L.chunk ss bs) n a + sIn = make_state bsIn 0 + ec msg sOut = Failed (consumed sOut) msg + +-- | Get the input currently available to the parser. +getAvailable :: Get L.ByteString +getAvailable = Get $ \ sc s@(S ss bs _) pc -> sc (L.chunk ss bs) s pc + +-- | 'putAvailable' replaces the bytestream past the current # of read +-- bytes. This will also affect pending MonadError handler and +-- MonadPlus branches. I think all pending branches have to have +-- fewer bytesRead than the current one. If this is wrong then an +-- error will be thrown. +-- +-- WARNING : 'putAvailable' is still untested. +putAvailable :: L.ByteString -> Get () +putAvailable !bsNew = Get $ \ sc (S _ss _bs n) pc -> + let !s' = make_state bsNew n + rebuild (HandlerFrame catcher (S ss1 bs1 n1) future pc') = + HandlerFrame catcher sNew mempty (rebuild pc') + where balance = n - n1 + whole | balance < 0 = error "Impossible? Cannot rebuild HandlerFrame in MyGet.putAvailable: balance is negative!" + | otherwise = L.take balance $ L.chunk ss1 bs1 `mappend` F.foldr mappend mempty future + sNew | balance /= L.length whole = error "Impossible? MyGet.putAvailable.rebuild.sNew HandlerFrame assertion failed." + | otherwise = make_state (mappend whole bsNew) n1 + rebuild x@(ErrorFrame {}) = x + in sc () s' (rebuild pc) + +-- Internal access to full internal state, as helper functions +getFull :: Get S +getFull = Get $ \ sc s pc -> sc s s pc + +{-# INLINE putFull_unsafe #-} +putFull_unsafe :: S -> Get () +putFull_unsafe !s = Get $ \ sc _s pc -> sc () s pc + +{-# INLINE make_safe #-} +make_safe :: S -> S +make_safe s@(S ss bs n) = + if S.null ss + then make_state bs n + else s + +{-# INLINE make_state #-} +make_state :: L.ByteString -> Int64 -> S +make_state L.Empty n = S mempty mempty n +make_state (L.Chunk ss bs) n = S ss bs n + +putFull_safe :: S -> Get () +putFull_safe= putFull_unsafe . make_safe + +-- | Keep calling 'suspend' until Nothing is passed to the 'Partial' +-- continuation. This ensures all the data has been loaded into the +-- state of the parser. +suspendUntilComplete :: Get () +suspendUntilComplete = do + continue <- suspend + when continue suspendUntilComplete + +-- | Call suspend and throw and error with the provided @msg@ if +-- Nothing has been passed to the 'Partial' continuation. Otherwise +-- return (). +suspendMsg :: String -> Get () +suspendMsg msg = do continue <- suspend + if continue then return () + else throwError msg + +-- | check that there are at least @n@ bytes available in the input. +-- This will suspend if there is to little data. +ensureBytes :: Int64 -> Get () +ensureBytes n = do + (S ss bs _read) <- getFull + if S.null ss + then suspendMsg "ensureBytes failed" >> ensureBytes n + else do + if n < fromIntegral (S.length ss) + then return () + else do if n == L.length (L.take n (L.chunk ss bs)) + then return () + else suspendMsg "ensureBytes failed" >> ensureBytes n +{-# INLINE ensureBytes #-} + +-- | Pull @n@ bytes from the input, as a lazy ByteString. This will +-- suspend if there is too little data. +getLazyByteString :: Int64 -> Get L.ByteString +getLazyByteString n | n<=0 = return mempty + | otherwise = do + (S ss bs offset) <- getFull + if S.null ss + then do + suspendMsg ("getLazyByteString S.null ss failed with "++show (n,(S.length ss,L.length bs,offset))) + getLazyByteString n + else do + case splitAtOrDie n (L.chunk ss bs) of -- safe use of L.chunk because of S.null ss check above + Just (consume,rest) -> do + putFull_unsafe (make_state rest (offset+n)) + return $! consume + Nothing -> do + suspendMsg ("getLazyByteString (Nothing from splitAtOrDie) failed with "++show (n,(S.length ss,L.length bs,offset))) + getLazyByteString n +{-# INLINE getLazyByteString #-} -- important + +-- | 'suspend' is supposed to allow the execution of the monad to be +-- halted, awaiting more input. The computation is supposed to +-- continue normally if this returns True, and is supposed to halt +-- without calling suspend again if this returns False. All future +-- calls to suspend will return False automatically and no nothing +-- else. +-- +-- These semantics are too specialized to let this escape this module. +class MonadSuspend m where + suspend :: m Bool + +-- The instance here is fairly specific to the stack manipluation done +-- by 'addFuture' to ('S' user) and to the packaging of the resumption +-- function in 'IResult'('IPartial'). +instance MonadSuspend Get where + suspend = Get ( + let checkBool (ErrorFrame _ b) = b + checkBool (HandlerFrame _ _ _ pc) = checkBool pc + -- addFuture puts the new data in 'future' where throwError's collect can find and use it + addFuture bs (HandlerFrame catcher s future pc) = + HandlerFrame catcher s (future |> bs) (addFuture bs pc) + addFuture _bs x@(ErrorFrame {}) = x + -- Once suspend is given Nothing, it remembers this and always returns False + rememberFalse (ErrorFrame ec _) = ErrorFrame ec False + rememberFalse (HandlerFrame catcher s future pc) = + HandlerFrame catcher s future (rememberFalse pc) + in \ sc sIn pcIn -> + if checkBool pcIn -- Has Nothing ever been given to a partial continuation? + then let f Nothing = let pcOut = rememberFalse pcIn + in sc False sIn pcOut + f (Just bs') = let sOut = appendBS sIn bs' + pcOut = addFuture bs' pcIn + in sc True sOut pcOut + in Partial f + else sc False sIn pcIn -- once Nothing has been given suspend is a no-op + ) + where appendBS (S ss bs n) bs' = make_safe (S ss (mappend bs bs') n) + +-- A unique sort of command... + +-- | 'discardInnerHandler' causes the most recent catchError to be +-- discarded, i.e. this reduces the stack of error handlers by removing +-- the top one. These are the same handlers which Alternative((<|>)) and +-- MonadPlus(mplus) use. This is useful to commit to the current branch and let +-- the garbage collector release the suspended handler and its hold on +-- the earlier input. +discardInnerHandler :: Get () +discardInnerHandler = Get $ \ sc s pcIn -> + let pcOut = case pcIn of ErrorFrame {} -> pcIn + HandlerFrame _ _ _ pc' -> pc' + in sc () s pcOut +{-# INLINE discardInnerHandler #-} + +{- Currently unused, commented out to satisfy -Wall + +-- | 'discardAllHandlers' causes all catchError handler to be +-- discarded, i.e. this reduces the stack of error handlers to the top +-- level handler. These are the same handlers which Alternative((<|>)) +-- and MonadPlus(mplus) use. This is useful to commit to the current +-- branch and let the garbage collector release the suspended handlers +-- and their hold on the earlier input. +discardAllHandlers :: Get () +discardAllHandlers = Get $ \ sc s pcIn -> + let base pc@(ErrorFrame {}) = pc + base (HandlerFrame _ _ _ pc) = base pc + in sc () s (base pcIn) +{-# INLINE discardAllHandlers #-} +-} +-- The BinaryParser instance: + +-- | Discard the next @m@ bytes +skip :: Int64 -> Get () +skip m | m <=0 = return () + | otherwise = do + ensureBytes m + (S ss bs n) <- getFull + -- Could ignore impossible S.null ss due to (ensureBytes m) and (0 < m) but be paranoid + let lbs = L.chunk ss bs -- L.chunk is safe + putFull_unsafe (make_state (L.drop m lbs) (n+m)) -- drop will not perform less than 'm' bytes due to ensureBytes above + +-- | Return the number of 'bytesRead' so far. Initially 0, never negative. +bytesRead :: Get Int64 +bytesRead = fmap consumed getFull + +-- | Return the number of bytes 'remaining' before the current input +-- runs out and 'suspend' might be called. +remaining :: Get Int64 +remaining = do (S ss bs _) <- getFull + return $ fromIntegral (S.length ss) + (L.length bs) + +-- | Return True if the number of bytes 'remaining' is 0. Any futher +-- attempts to read an empty parser will call 'suspend' which might +-- result in more input to consume. +-- +-- Compare with 'isReallyEmpty' +isEmpty :: Get Bool +isEmpty = do (S ss _bs _n) <- getFull + return (S.null ss) -- && (L.null bs) + +-- | Return True if the input is exhausted and will never be added to. +-- Returns False if there is input left to consume. +-- +-- Compare with 'isEmpty' +isReallyEmpty :: Get Bool +isReallyEmpty = isEmpty >>= loop + where loop False = return False + loop True = do + continue <- suspend + if continue + then isReallyEmpty + else return True + +-- | get the longest prefix of the input where the high bit is set as well as following byte. +-- This made getVarInt slower. +highBitRun :: Get Int64 +{-# INLINE highBitRun #-} +highBitRun = loop where + loop :: Get Int64 + {-# INLINE loop #-} + loop = do + (S ss bs _n) <- getFull + -- S.null ss is okay, will lead to Nothing, Nothing, suspend below + let mi = S.findIndex (128>) ss + case mi of + Just i -> return (succ $ fromIntegral i) + Nothing -> do + let mj = L.findIndex (128>) bs + case mj of + Just j -> return (fromIntegral (S.length ss) + succ j) + Nothing -> do + continue <- suspend + if continue then loop + else fail "highBitRun has failed" + +-- | get the longest prefix of the input where all the bytes satisfy the predicate. +spanOf :: (Word8 -> Bool) -> Get (L.ByteString) +spanOf f = do let loop = do (S ss bs n) <- getFull + let (pre,post) = L.span f (L.chunk ss bs) -- L.chunk is safe + putFull_unsafe (make_state post (n + L.length pre)) + if L.null post + then do continue <- suspend + if continue then fmap ((L.toChunks pre)++) loop + else return (L.toChunks pre) + else return (L.toChunks pre) + fmap L.fromChunks loop +{-# INLINE spanOf #-} + +-- | Pull @n@ bytes from the input, as a strict ByteString. This will +-- suspend if there is too little data. If the result spans multiple +-- lazy chunks then the result occupies a freshly allocated strict +-- bytestring, otherwise it fits in a single chunk and refers to the +-- same immutable memory block as the whole chunk. +getByteString :: Int -> Get S.ByteString +getByteString nIn | nIn <= 0 = return mempty + | otherwise = do + (S ss bs n) <- getFull + if nIn < S.length ss -- Leave at least one character of 'ss' in 'post' allowing putFull_unsafe below + then do let (pre,post) = S.splitAt nIn ss + putFull_unsafe (S post bs (n+fromIntegral nIn)) + return $! pre + -- Expect nIn to be less than S.length ss the vast majority of times + -- so do not worry about doing anything fancy here. + else do now <- fmap (S.concat . L.toChunks) (getLazyByteString (fromIntegral nIn)) + return $! now +{-# INLINE getByteString #-} -- important + +getWordhost :: Get Word +getWordhost = getStorable +{-# INLINE getWordhost #-} + +getWord8 :: Get Word8 +getWord8 = getPtr 1 +{-# INLINE getWord8 #-} + +getWord16be,getWord16le,getWord16host :: Get Word16 +getWord16be = do + s <- getByteString 2 + return $! (fromIntegral (s `S.unsafeIndex` 0) `shiftl_w16` 8) .|. + (fromIntegral (s `S.unsafeIndex` 1)) +{-# INLINE getWord16be #-} +getWord16le = do + s <- getByteString 2 + return $! (fromIntegral (s `S.unsafeIndex` 1) `shiftl_w16` 8) .|. + (fromIntegral (s `S.unsafeIndex` 0) ) +{-# INLINE getWord16le #-} +getWord16host = getStorable +{-# INLINE getWord16host #-} + +getWord32be,getWord32le,getWord32host :: Get Word32 +getWord32be = do + s <- getByteString 4 + return $! (fromIntegral (s `S.unsafeIndex` 0) `shiftl_w32` 24) .|. + (fromIntegral (s `S.unsafeIndex` 1) `shiftl_w32` 16) .|. + (fromIntegral (s `S.unsafeIndex` 2) `shiftl_w32` 8) .|. + (fromIntegral (s `S.unsafeIndex` 3) ) +{-# INLINE getWord32be #-} +getWord32le = do + s <- getByteString 4 + return $! (fromIntegral (s `S.unsafeIndex` 3) `shiftl_w32` 24) .|. + (fromIntegral (s `S.unsafeIndex` 2) `shiftl_w32` 16) .|. + (fromIntegral (s `S.unsafeIndex` 1) `shiftl_w32` 8) .|. + (fromIntegral (s `S.unsafeIndex` 0) ) +{-# INLINE getWord32le #-} +getWord32host = getStorable +{-# INLINE getWord32host #-} + + +getWord64be,getWord64le,getWord64host :: Get Word64 +getWord64be = do + s <- getByteString 8 + return $! (fromIntegral (s `S.unsafeIndex` 0) `shiftl_w64` 56) .|. + (fromIntegral (s `S.unsafeIndex` 1) `shiftl_w64` 48) .|. + (fromIntegral (s `S.unsafeIndex` 2) `shiftl_w64` 40) .|. + (fromIntegral (s `S.unsafeIndex` 3) `shiftl_w64` 32) .|. + (fromIntegral (s `S.unsafeIndex` 4) `shiftl_w64` 24) .|. + (fromIntegral (s `S.unsafeIndex` 5) `shiftl_w64` 16) .|. + (fromIntegral (s `S.unsafeIndex` 6) `shiftl_w64` 8) .|. + (fromIntegral (s `S.unsafeIndex` 7) ) +{-# INLINE getWord64be #-} +getWord64le = do + s <- getByteString 8 + return $! (fromIntegral (s `S.unsafeIndex` 7) `shiftl_w64` 56) .|. + (fromIntegral (s `S.unsafeIndex` 6) `shiftl_w64` 48) .|. + (fromIntegral (s `S.unsafeIndex` 5) `shiftl_w64` 40) .|. + (fromIntegral (s `S.unsafeIndex` 4) `shiftl_w64` 32) .|. + (fromIntegral (s `S.unsafeIndex` 3) `shiftl_w64` 24) .|. + (fromIntegral (s `S.unsafeIndex` 2) `shiftl_w64` 16) .|. + (fromIntegral (s `S.unsafeIndex` 1) `shiftl_w64` 8) .|. + (fromIntegral (s `S.unsafeIndex` 0) ) +{-# INLINE getWord64le #-} +getWord64host = getStorable +{-# INLINE getWord64host #-} + +-- Below here are the class instances + +instance Functor Get where + fmap f m = Get (\sc -> unGet m (sc . f)) + {-# INLINE fmap #-} + +instance Monad Get where + return a = seq a $ Get (\sc -> sc a) + {-# INLINE return #-} + m >>= k = Get (\sc -> unGet m (\ a -> seq a $ unGet (k a) sc)) + {-# INLINE (>>=) #-} + fail = throwError . strMsg + +instance MonadError String Get where + throwError msg = Get $ \_sc s pcIn -> + let go (ErrorFrame ec _) = ec msg s + go (HandlerFrame (Just catcher) s1 future pc1) = catcher (collect s1 future) pc1 msg + go (HandlerFrame Nothing _s1 _future pc1) = go pc1 + in go pcIn + + catchError mayFail handler = Get $ \sc s pc -> + let pcWithHandler = let catcher s1 pc1 e1 = unGet (handler e1) sc s1 pc1 + in HandlerFrame (Just catcher) s mempty pc + actionWithCleanup = mayFail >>= \a -> discardInnerHandler >> return a + in unGet actionWithCleanup sc s pcWithHandler + +instance MonadPlus Get where + mzero = throwError (strMsg "[mzero:no message]") + mplus m1 m2 = catchError m1 (const m2) + +instance Applicative Get where + pure = return + (<*>) = ap + +instance Alternative Get where + empty = mzero + (<|>) = mplus + +-- | I use "splitAt" without tolerating too few bytes, so write a Maybe version. +-- This is the only place I invoke L.Chunk as constructor instead of pattern matching. +-- I claim that the first argument cannot be empty. +splitAtOrDie :: Int64 -> L.ByteString -> Maybe (L.ByteString, L.ByteString) +splitAtOrDie i ps | i <= 0 = Just (mempty, ps) +splitAtOrDie _i L.Empty = Nothing +splitAtOrDie i (L.Chunk x xs) | i < len = let (pre,post) = S.splitAt (fromIntegral i) x + in Just (L.chunk pre mempty, L.chunk post xs) + | otherwise = case splitAtOrDie (i-len) xs of + Nothing -> Nothing + Just (y1,y2) -> Just (L.chunk x y1,y2) + where len = fromIntegral (S.length x) +{-# INLINE splitAtOrDie #-} + +------------------------------------------------------------------------ +-- getPtr copied from binary's Get.hs + +-- helper, get a raw Ptr onto a strict ByteString copied out of the +-- underlying lazy byteString. So many indirections from the raw parser +-- state that my head hurts... + +-- Assume n>0 +getPtr :: (Storable a) => Int -> Get a +getPtr n = do + (fp,o,_) <- fmap S.toForeignPtr (getByteString n) + return . S.inlinePerformIO $ withForeignPtr fp $ \p -> peek (castPtr $ p `plusPtr` o) +{-# INLINE getPtr #-} + +-- I pushed the sizeOf into here (uses ScopedTypeVariables) +-- Assume sizeOf (undefined :: a)) > 0 +getStorable :: forall a. (Storable a) => Get a +getStorable = do + (fp,o,_) <- fmap S.toForeignPtr (getByteString (sizeOf (undefined :: a))) + return . S.inlinePerformIO $ withForeignPtr fp $ \p -> peek (castPtr $ p `plusPtr` o) +{-# INLINE getStorable #-} + +------------------------------------------------------------------------ +------------------------------------------------------------------------ +-- Unchecked shifts copied from binary's Get.hs + +shiftl_w16 :: Word16 -> Int -> Word16 +shiftl_w32 :: Word32 -> Int -> Word32 +shiftl_w64 :: Word64 -> Int -> Word64 + +#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__) +shiftl_w16 (W16# w) (I# i) = W16# (w `uncheckedShiftL#` i) +shiftl_w32 (W32# w) (I# i) = W32# (w `uncheckedShiftL#` i) + +#if WORD_SIZE_IN_BITS < 64 +shiftl_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftL64#` i) + +#if __GLASGOW_HASKELL__ <= 606 +-- Exported by GHC.Word in GHC 6.8 and higher +foreign import ccall unsafe "stg_uncheckedShiftL64" + uncheckedShiftL64# :: Word64# -> Int# -> Word64# +#endif + +#else +shiftl_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftL#` i) +#endif + +#else +shiftl_w16 = shiftL +shiftl_w32 = shiftL +shiftl_w64 = shiftL +#endif diff --git a/Text/ProtocolBuffers/Header.hs b/Text/ProtocolBuffers/Header.hs new file mode 100644 --- /dev/null +++ b/Text/ProtocolBuffers/Header.hs @@ -0,0 +1,55 @@ +-- | This provides what is needed for the output of 'hprotoc' to +-- compile. This and the Prelude will both be imported qualified as +-- P', the prime ensuring no name conflicts are possible. +module Text.ProtocolBuffers.Header + ( append, emptyBS + , pack, fromMaybe, ap + , fromDistinctAscList, member + , throwError,catchError + , module Data.Generics + , module Text.ProtocolBuffers.Basic + , module Text.ProtocolBuffers.Extensions + , module Text.ProtocolBuffers.Identifiers + , module Text.ProtocolBuffers.Reflections + , module Text.ProtocolBuffers.Unknown + , module Text.ProtocolBuffers.WireMessage + ) where + +import Control.Monad(ap) +import Control.Monad.Error.Class(throwError,catchError) +import Data.ByteString.Lazy(empty) +import Data.ByteString.Lazy.Char8(pack) +import Data.Generics(Data(..)) +import Data.Maybe(fromMaybe) +import Data.Sequence((|>)) -- for append, see below +import Data.Set(fromDistinctAscList,member) + +import Text.ProtocolBuffers.Basic -- all +import Text.ProtocolBuffers.Extensions + ( wireSizeExtField,wirePutExtField,loadExtension,notExtension + , wireGetKeyToUnPacked, wireGetKeyToPacked + , GPB,Key(..),ExtField,ExtendMessage(..),MessageAPI(..),ExtKey(wireGetKey),PackedSeq ) +import Text.ProtocolBuffers.Identifiers(FIName(..),MName(..),FName(..)) +import Text.ProtocolBuffers.Reflections + ( ReflectDescriptor(..),ReflectEnum(..),EnumInfo(..),ProtoName(..) + , GetMessageInfo(GetMessageInfo),DescriptorInfo(extRanges),makePNF ) +import Text.ProtocolBuffers.Unknown + ( UnknownField,UnknownMessage(..),wireSizeUnknownField,wirePutUnknownField,catch'Unknown ) +import Text.ProtocolBuffers.WireMessage + ( Wire(..) + , prependMessageSize,putSize,splitWireTag + , wireSizeReq,wireSizeOpt,wireSizeRep + , wirePutReq,wirePutOpt,wirePutRep + , wirePutPacked,wireSizePacked + , getMessageWith,getBareMessageWith,wireGetEnum,wireGetPackedEnum + , wireSizeErr,wirePutErr,wireGetErr + , unknown,unknownField + , fieldIdOf) + +{-# INLINE append #-} +append :: Seq a -> a -> Seq a +append = (|>) + +{-# INLINE emptyBS #-} +emptyBS :: ByteString +emptyBS = Data.ByteString.Lazy.empty diff --git a/Text/ProtocolBuffers/Identifiers.hs b/Text/ProtocolBuffers/Identifiers.hs new file mode 100644 --- /dev/null +++ b/Text/ProtocolBuffers/Identifiers.hs @@ -0,0 +1,348 @@ +{-# LANGUAGE MultiParamTypeClasses,TypeSynonymInstances,FlexibleInstances,DeriveDataTypeable #-} +-- | This modules colelct utility routines related to the different +-- incarnations of identifiers in the code. The basic identifier is +-- always ASCII, but because of the self generated DescriptorProto +-- data structures it is stored in 'Utf8' tagged lazy bytestrings. +-- +-- An 'identifier' is a non-empty ASCII string made of [a-zA-Z0-9_] +-- where the first character is never in [0-9]. +-- +-- A 'field' is a mangled identifer that is a valid Haskell name that +-- begins with lower case, and which may have a single quote at the +-- end if needed to avoid a reserved word. These may also start with +-- '_', though just a "_" is mangled to "_'". +-- +-- A 'module' is a mangled identifier that is a valid Haskell name +-- that begins with upper case. These never have a single quote. A +-- leading '_' is replaced with a leading "U'_" to make a valid +-- identifier. +module Text.ProtocolBuffers.Identifiers + ( unull,toString,fromString + , IName(..),DIName(..),FIName(..) + , MName(..),FMName(..),PMName(..) + , FName(..),FFName(..),PFName(..) + , Dotted(..),Mangle(..) + , joinPM,joinPF,difi,splitDI,splitFI,splitFM + , checkDIString,checkDIUtf8 + , promoteDI,promoteFI,promoteFM,promoteFF,dotFM,dotFF,fqAppend + ) where + +import qualified Data.ByteString.Lazy.Char8 as LC +import qualified Data.ByteString.Lazy.UTF8 as U +import Data.Char +import Data.List +import Data.Monoid +import Data.Generics(Data) +import Data.Typeable(Typeable) +import Data.Set(Set) +import qualified Data.Set as S +import Text.ProtocolBuffers.Basic + +-- basic utilities to export + +unull :: Utf8 -> Bool +unull = LC.null . utf8 + +toString :: Utf8 -> String +toString = U.toString . utf8 + +fromString :: String -> Utf8 +fromString = Utf8 . U.fromString + +-- | Contains one identifier name +newtype IName a = IName {iName::a} deriving (Data,Typeable,Eq,Ord) +-- | Contains one module name, non-empty +newtype MName a = MName {mName::a} deriving (Data,Typeable,Eq,Ord) +-- | Contains one field name, non-empty +newtype FName a = FName {fName::a} deriving (Data,Typeable,Eq,Ord) +-- | '.' separated identifier which may or may start with a dot. There +-- are never two or more '.'s in a row. There is always at least one identifier. +newtype DIName a = DIName {diName :: a} deriving (Data,Typeable,Eq,Ord) +-- | Fully qualified identifier: repeated ('.' then identifier) +newtype FIName a = FIName {fiName::a} deriving (Data,Typeable,Eq,Ord) +-- | Full Haskell module name: MNames separated by '.', ending with a module +newtype FMName a = FMName {fmName::a} deriving (Data,Typeable,Eq,Ord) +-- | Full Haskell field name: MNames separated by '.', ending with a field +newtype FFName a = FFName {ffName::a} deriving (Data,Typeable,Eq,Ord) +-- | Parsed Haskell name ending with MName. Good contructor to use. +data PMName a = PMName [MName a] (MName a) deriving (Show,Data,Typeable,Read,Eq,Ord) +-- | Parsed Haskell name ending with FName. Good constructor to use. +data PFName a = PFName [MName a] (FName a) deriving (Show,Data,Typeable,Read,Eq,Ord) + +app_prec,max_prec :: Int +app_prec = 10 +max_prec = 11 + +{-# INLINE readIt #-} +readIt :: (Read a) => (a -> a1) -> String -> Int -> String -> [(a1, String)] +readIt con name d = readParen (d > app_prec) (\r -> [(con m,t) | (name',s) <- lex r, name==name', (m,t) <- readsPrec max_prec s]) + +{-# INLINE showIt #-} +showIt :: (Show a) => Int -> [Char] -> a -> String -> String +showIt d name a = showParen (d > app_prec) $ (name++) . (' ':) . showsPrec max_prec a + +instance Read a => Read (IName a) where readsPrec = readIt IName "IName" +instance Read a => Read (MName a) where readsPrec = readIt MName "MName" +instance Read a => Read (FName a) where readsPrec = readIt FName "FName" +instance Read a => Read (DIName a) where readsPrec = readIt DIName "DIName" +instance Read a => Read (FIName a) where readsPrec = readIt FIName "FIName" +instance Read a => Read (FFName a) where readsPrec = readIt FFName "FFName" +instance Read a => Read (FMName a) where readsPrec = readIt FMName "FMName" + +instance Show a => Show (IName a) where showsPrec d (IName a) = showIt d "IName" a +instance Show a => Show (MName a) where showsPrec d (MName a) = showIt d "MName" a +instance Show a => Show (FName a) where showsPrec d (FName a) = showIt d "FName" a +instance Show a => Show (DIName a) where showsPrec d (DIName a) = showIt d "DIName" a +instance Show a => Show (FIName a) where showsPrec d (FIName a) = showIt d "FIName" a +instance Show a => Show (FMName a) where showsPrec d (FMName a) = showIt d "FMName" a +instance Show a => Show (FFName a) where showsPrec d (FFName a) = showIt d "FFName" a + +-- | This is used to abstract over Utf8 and String. The important +-- entry point is 'validDI'. +class (Monoid a) => Dotted a where + uncons :: a -> Maybe (Char,a) + cons :: Char -> a -> a + dot :: a -> a -> a + validI :: a -> Maybe (IName a) + -- | 'validDI' ensures the DIName is + validDI :: a -> Maybe (DIName a) + -- | 'split' returns a list of non-empty 'a' with all '.' characters removed + split :: a -> [a] + +-- These are also part of the external API, they are abstracted over +-- Dotted. + +joinPM :: Dotted a => PMName a -> FMName a +joinPM (PMName xs (MName x)) = FMName (foldr dot x . map mName $ xs) + +joinPF :: Dotted a => PFName a -> FFName a +joinPF (PFName xs (FName x)) = FFName (foldr dot x . map mName $ xs) + +-- | 'difi' examines the 'DIName' and prepend a '.' if absent, promoting +-- it to a 'FIName'. +difi :: Dotted a => DIName a -> FIName a +difi (DIName a) = case uncons a of + Just ('.',_) -> FIName a + _ -> FIName (cons '.' a) + +-- | Typed 'split' +splitDI :: Dotted a => DIName a -> [IName a] +splitDI = map IName . split . diName + +-- | Typed 'split' +splitFI :: Dotted a => FIName a -> [IName a] +splitFI = map IName . split . fiName + +-- | Typed 'split' +splitFM :: Dotted a => FMName a -> [MName a] +splitFM = map MName . split . fmName + +promoteDI :: Dotted a => IName a -> DIName a +promoteDI = DIName . iName + +promoteFI :: Dotted a => IName a -> FIName a +promoteFI = FIName . cons '.' . iName + +promoteFM :: Dotted a => MName a -> FMName a +promoteFM = FMName . mName + +promoteFF :: Dotted a => FName a -> FFName a +promoteFF = FFName . fName + +dotFM :: Dotted a => FMName a -> FMName a -> FMName a +dotFM (FMName a) (FMName b) = FMName (a `dot` b) + +dotFF :: Dotted a => FMName a -> FFName a -> FFName a +dotFF (FMName a) (FFName b) = FFName (a `dot` b) + +fqAppend :: Dotted a => FIName a -> [IName a] -> FIName a +fqAppend (FIName base) xs = FIName (foldl' dot base . map iName $ xs) + +-- The two checkDI* functions give better error messages than validDI + +-- | Right (True,_) means the input is a FIName. +-- Right (False,_) means the input is a DIName (without leading '.') +-- +-- This creates useful error messages for the user. +checkDIString :: String -> Either String (Bool,[IName String]) +checkDIString "" = Left $ "Invalid empty identifier: "++show "" +checkDIString "." = Left $ "Invalid identifier of just a period: "++show "." +checkDIString xs | ('.':ys) <- xs = fmap ((,) True) $ parts id (span ('.'/=) ys) + | otherwise = fmap ((,) False) $ parts id (span ('.'/=) xs) + where parts _f ("","") = Left $ "Invalid identifier because it ends with a period: "++show xs + parts _f ("",_) = Left $ "Invalid identifier because is contains two periods in a row: "++show xs + parts f (a,"") = Right (f [IName a]) + parts f (a,b) = parts (f . (IName a:)) (span ('.'/=) (tail b)) + +-- | Right (True,_) means the input is a FIName. +-- Right (False,_) means the input is a DIName (without leading '.') +-- +-- This creates useful error messages for the user. +checkDIUtf8 :: Utf8 -> Either String (Bool,[IName Utf8]) +checkDIUtf8 s@(Utf8 xs) = + case U.uncons xs of + Nothing -> Left $ "Invalid empty identifier: "++show "" + Just ('.',ys) | LC.null ys -> Left $ "Invalid identifier of just a period: "++show "." + | otherwise -> fmap ((,) True) $ parts id (U.span ('.'/=) ys) + Just _ -> fmap ((,) False) $ parts id (U.span ('.'/=) xs) + where parts f (a,b) = case (LC.null a,LC.null b) of + (True,True) -> Left $ "Invalid identifier because it ends with a period: "++show (toString s) + (True,_) -> Left $ "Invalid identifier because is contains two periods in a row: "++show (toString s) + (_,True) -> Right (f [IName (Utf8 a)]) + _ -> parts (f . (IName (Utf8 a):)) (U.span ('.'/=) (U.drop 1 b)) + +-- | The 'mangle' transformation has instances for several combiantions +-- of input and output. These allow one to construct the Haskell types +-- of MName/FMName/PMName and FName/FFName/PFName out of the protobuf +-- types IName/DIName/FIName. Currently, all the Haskell instances +-- are for the String base type. + +class Mangle a b where mangle :: a -> b + +instance Mangle (IName String) (MName String) where + mangle (IName s) = MName (fixUp s) + +instance Mangle (IName Utf8) (MName String) where + mangle (IName s) = MName (fixUp . toString $ s) + +instance Mangle (FName String) (MName String) where + mangle (FName s) = MName (fixUp s) + +instance Mangle (IName String) (FName String) where + mangle (IName s) = FName (fixLow s) + +instance Mangle (IName Utf8) (FName String) where + mangle (IName s) = FName (fixLow . toString $ s) + +instance Mangle (MName String) (FName String) where + mangle (MName s) = FName (fixLow s) + +instance Mangle (DIName Utf8) (PMName String) where + mangle s = let ms = splitDI s in PMName (map mangle $ init ms) (mangle $ last ms) + +instance Mangle (FIName Utf8) (PMName String) where + mangle s = let ms = splitFI s in PMName (map mangle $ init ms) (mangle $ last ms) + +instance Mangle (DIName Utf8) (PFName String) where + mangle s = let ms = splitDI s in PFName (map mangle $ init ms) (mangle $ last ms) + +instance Mangle (FIName Utf8) (PFName String) where + mangle s = let ms = splitFI s in PFName (map mangle $ init ms) (mangle $ last ms) + +-- implementation details follow + +dotUtf8 :: Utf8 -> Utf8 -> Utf8 +dotUtf8 (Utf8 a) (Utf8 b) = Utf8 (LC.append a (LC.cons '.' b)) + +dotString :: String -> String -> String +dotString a b = a ++ ('.':b) + +-- | Return list of nonempty Utf8, with all '.' removed +splitUtf8 :: Utf8 -> [Utf8] +splitUtf8 = unfoldr s . utf8 where + s :: ByteString -> Maybe (Utf8,ByteString) + s y = case LC.uncons y of + Nothing -> Nothing + Just ('.',xs) -> s xs -- delete all '.' in the input + _ -> Just (let (a,b) = U.span ('.'/=) y in (Utf8 a,b)) + +-- | Return list of nonempty String, with all '.' removed +splitString :: String -> [String] +splitString = unfoldr s where + s [] = Nothing + s ('.':xs) = s xs -- delete all '.' in the input + s xs = Just (span ('.'/=) xs) + +validIUtf8 :: Utf8 -> Maybe (IName Utf8) +validIUtf8 xs | unull xs = Nothing +validIUtf8 xs@(Utf8 bs) = if LC.all (`S.member` validISet) bs + then Just (IName xs) + else Nothing + +validIString :: String -> Maybe (IName String) +validIString [] = Nothing +validIString xs = if all (`S.member` validISet) xs + then Just (IName xs) + else Nothing + +validDIUtf8 :: Utf8 -> Maybe (DIName Utf8) +validDIUtf8 xs | unull xs = Nothing +validDIUtf8 xs@(Utf8 bs) = + if LC.all (`S.member` validDISet) bs && LC.any ('.'/=) bs && LC.last bs /= '.' + && (all (\(x,y) -> '.'/=x || '.'/=y) . (\x -> zip (init x) (tail x)) . toString $ xs) + then Just (DIName xs) + else Nothing + +validDIString :: String -> Maybe (DIName String) +validDIString [] = Nothing +validDIString xs = + if all (`S.member` validDISet) xs && any ('.'/=) xs && last xs /= '.' + && all (\(x,y) -> '.'/=x || '.'/=y) (zip (init xs) (tail xs)) + then Just (DIName xs) + else Nothing + +validISet :: Set Char +validISet = S.fromDistinctAscList "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ_abcdefghijklmnopqrstuvwxyz" + +validDISet :: Set Char +validDISet = S.fromDistinctAscList ".0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ_abcdefghijklmnopqrstuvwxyz" + +instance Dotted Utf8 where + uncons x = case U.uncons (utf8 x) of + Nothing -> Nothing + Just (c,b) -> Just (c,Utf8 b) + cons b (Utf8 bs) | fromEnum b < 128 = Utf8 (LC.cons b bs) + | otherwise = Utf8 ((U.fromString [b]) `mappend` bs) + dot = dotUtf8 + split = splitUtf8 + validI = validIUtf8 + validDI = validDIUtf8 + +instance Dotted String where + uncons [] = Nothing + uncons (x:xs) = Just (x,xs) + cons = (:) + dot = dotString + split = splitString + validI = validIString + validDI = validDIString + +err :: String -> a +err s = error ("Text.ProtocolBuffers.ProtoCompile.Identifiers: "++s) + +-- make leading upper case letter, and leanding "_" becomes "U'_" +fixUp :: String -> String +fixUp xs | last xs == '\'' = fixUp (init xs) -- in case this is mangling after "fixLow" +fixUp ('_':xs) = "U'"++xs +fixUp i@(x:xs) | isLower x = + let x' = toUpper x + in if isLower x' then err ("fixUp: stubborn lower case"++show i) + else x': xs +fixUp xs = xs + +-- make leading '_' or lower case letter, may end with added single quote. +fixLow :: String -> String +fixLow [] = [] +fixLow ('U':'\'':xs@('_':_))= fixLow xs +fixLow i@(x:xs) | i `S.member` reserved = i ++ "'" + | isUpper x = let x' = toLower x + in if isUpper x' then err ("fixLow: stubborn upper case: "++show i) + else let i' = (x':xs) + in if i' `S.member` reserved then i' ++ "'" else i' + | otherwise = i + +-- | 'reserved' is a set of strings which are Haskell keywords and +-- should not be valid field names. +-- +-- I do not protect these values: +-- "mdo","foreign","rec","proc" ( GHC manual section 8.3.16 ) +-- because I do not anticipate using these extensions in the generated +-- Haskell code. +reserved :: Set String +reserved = S.fromDistinctAscList + ["_" + ,"case","class","data","default","deriving","do","else" + ,"forall" {- extension keyword -} + ,"if","import","in","infix","infixl","infixr","instance" + ,"let","module","newtype","of","then","type","where" + ] diff --git a/Text/ProtocolBuffers/Reflections.hs b/Text/ProtocolBuffers/Reflections.hs new file mode 100644 --- /dev/null +++ b/Text/ProtocolBuffers/Reflections.hs @@ -0,0 +1,175 @@ +{-# LANGUAGE DeriveDataTypeable #-} +-- | A strong feature of the protocol-buffers package is that it does +-- not contain any structures defined by descriptor.proto! This +-- prevents me hitting any annoying circular dependencies. The +-- structures defined here are included in each module created by +-- 'hprotoc'. They are optimized for use in code generation. +-- +-- These values can be inspected at runtime by the user's code, but I +-- have yet to write much documentation. Luckily the record field +-- names are somewhat descriptive. +-- +-- The other reflection is using the 'fileDescriptorProto' which +-- is put into the top level module created by hprotoc. +module Text.ProtocolBuffers.Reflections + ( ProtoName(..),ProtoFName(..),ProtoInfo(..),DescriptorInfo(..),FieldInfo(..),KeyInfo + , HsDefault(..),SomeRealFloat(..),EnumInfo(..),EnumInfoApp + , ReflectDescriptor(..),ReflectEnum(..),GetMessageInfo(..) + , makePNF, toRF, fromRF + ) where + +import Text.ProtocolBuffers.Basic +import Text.ProtocolBuffers.Identifiers + +import Data.List(sort) +import qualified Data.Foldable as F(toList) +import Data.Set(Set) +import qualified Data.Set as Set(fromDistinctAscList) +import Data.Generics(Data) +import Data.Typeable(Typeable) +import Data.Map(Map) + +-- | 'makePNF' is used by the generated code to create a ProtoName with less newtype noise. +makePNF :: ByteString -> [String] -> [String] -> String -> ProtoName +makePNF a bs cs d = + ProtoName (FIName (Utf8 a)) + (map MName bs) + (map MName cs) + (MName d) + +-- | This is fully qualified name data type for code generation. The +-- 'haskellPrefix' was possibly specified on the 'hprotoc' command +-- line. The 'parentModule' is a combination of the module prefix +-- from the '.proto' file and any nested levels of definition. +-- +-- The name components are likely to have been mangled to ensure the +-- 'baseName' started with an uppercase letter, in @ ['A'..'Z'] @. +data ProtoName = ProtoName { protobufName :: FIName Utf8 -- ^ fully qualified name using "package" prefix (no mangling) + , haskellPrefix :: [MName String] -- ^ Haskell specific prefix to module hierarchy (e.g. Text.Foo) + , parentModule :: [MName String] -- ^ .proto specified namespace (like Com.Google.Bar) + , baseName :: MName String + } + deriving (Show,Read,Eq,Ord,Data,Typeable) + +data ProtoFName = ProtoFName { protobufName' :: FIName Utf8 -- ^ fully qualified name using "package" prefix (no mangling) + , haskellPrefix' :: [MName String] -- ^ Haskell specific prefix to module hierarchy (e.g. Text.Foo) + , parentModule' :: [MName String] -- ^ .proto specified namespace (like Com.Google.Bar) + , baseName' :: FName String + } + deriving (Show,Read,Eq,Ord,Data,Typeable) + +data ProtoInfo = ProtoInfo { protoMod :: ProtoName -- ^ blank protobufName, maybe blank haskellPrefix and/or parentModule + , protoFilePath :: [FilePath] -- ^ path to haskell module + , protoSource :: FilePath -- ^ filename without path of .proto file + , extensionKeys :: Seq KeyInfo -- ^ top level keys + , messages :: [DescriptorInfo] -- ^ all messages and groups + , enums :: [EnumInfo] -- ^ all enums + , knownKeyMap :: Map ProtoName (Seq FieldInfo) -- all keys in namespace + } + deriving (Show,Read,Eq,Ord,Data,Typeable) + +data DescriptorInfo = DescriptorInfo { descName :: ProtoName + , descFilePath :: [FilePath] + , isGroup :: Bool + , fields :: Seq FieldInfo + , keys :: Seq KeyInfo + , extRanges :: [(FieldId,FieldId)] + , knownKeys :: Seq FieldInfo + , storeUnknown :: Bool + , lazyFields :: Bool + } + deriving (Show,Read,Eq,Ord,Data,Typeable) + +-- | 'GetMessageInfo' is used in getting messages from the wire. It +-- supplies the 'Set' of precomposed wire tags that must be found in +-- the message as well as a 'Set' of all allowed tags (including known +-- extension fields and all required wire tags). +-- +-- Extension fields not in the allowedTags set are still loaded, but +-- only as 'ByteString' blobs that will have to interpreted later. +data GetMessageInfo = GetMessageInfo { requiredTags :: Set WireTag + , allowedTags :: Set WireTag + } + deriving (Show,Read,Eq,Ord,Data,Typeable) + +type KeyInfo = (ProtoName,FieldInfo) -- Extendee and FieldInfo + +data FieldInfo = FieldInfo { fieldName :: ProtoFName + , fieldNumber :: FieldId + , wireTag :: WireTag -- ^ Used for writing and reading if packedTag is Nothing + , packedTag :: Maybe (WireTag,WireTag) -- ^ used for reading when Just {} instead of wireTag + , wireTagLength :: WireSize -- ^ Bytes required in the Varint formatted wireTag + , isPacked :: Bool + , isRequired :: Bool + , canRepeat :: Bool -- ^ True if repeated is the field type + , mightPack :: Bool -- ^ True if packed would be valid for this field type + , typeCode :: FieldType -- ^ fromEnum of Text.DescriptorProtos.FieldDescriptorProto.Type + , typeName :: Maybe ProtoName -- ^ Set for Messages,Groups,and Enums + , hsRawDefault :: Maybe ByteString -- ^ crappy, but not escaped, thing + , hsDefault :: Maybe HsDefault -- ^ nice parsed thing + } + deriving (Show,Read,Eq,Ord,Data,Typeable) + +-- | 'HsDefault' stores the parsed default from the proto file in a +-- form that will make a nice literal in the +-- "Language.Haskell.Exts.Syntax" code generation by 'hprotoc'. +-- +-- Note that Utf8 labeled byte sequences have been stripped to just +-- 'ByteString' here as this is sufficient for code generation. +-- +-- On 25 August 2010 20:12, George van den Driessche sent Chris Kuklewicz a +-- patch to MakeReflections.parseDefEnum to ensure that HsDef'Enum holds the mangled form of the +-- name. +data HsDefault = HsDef'Bool Bool + | HsDef'ByteString ByteString + | HsDef'RealFloat SomeRealFloat + | HsDef'Integer Integer + | HsDef'Enum String + deriving (Show,Read,Eq,Ord,Data,Typeable) + +-- | 'SomeRealFloat' projects Double/Float to Rational or a special IEEE type. +-- This is needed to track protobuf-2.3.0 which allows nan and inf and -inf default values. +data SomeRealFloat = SRF'Rational Rational | SRF'nan | SRF'ninf | SRF'inf + deriving (Show,Read,Eq,Ord,Data,Typeable) + +toRF :: (RealFloat a, Fractional a) => SomeRealFloat -> a +toRF (SRF'Rational r) = fromRational r +toRF SRF'nan = (0/0) +toRF SRF'ninf = (-1/0) +toRF SRF'inf = (1/0) + +fromRF :: (RealFloat a, Fractional a) => a -> SomeRealFloat +fromRF x | isNaN x = SRF'nan + | isInfinite x = if 0 < x then SRF'inf else SRF'ninf + | otherwise = SRF'Rational (toRational x) + +data EnumInfo = EnumInfo { enumName :: ProtoName + , enumFilePath :: [FilePath] + , enumValues :: [(EnumCode,String)] -- ^ The String is the Haskell name to write into the generated source files + } + deriving (Show,Read,Eq,Ord,Data,Typeable) + +type EnumInfoApp e = [(EnumCode,String,e)] + +class ReflectEnum e where + reflectEnum :: EnumInfoApp e + reflectEnumInfo :: e -> EnumInfo -- ^ Must not inspect argument + parentOfEnum :: e -> Maybe DescriptorInfo -- ^ Must not inspect argument + parentOfEnum _ = Nothing + +class ReflectDescriptor m where + -- | This is obtained via 'read' on the stored 'show' output of the 'DescriptorInfo' in + -- the module file. It is used in getting messages from the wire. + -- + -- Must not inspect argument + getMessageInfo :: m -> GetMessageInfo + getMessageInfo x = cached + where cached = makeMessageInfo (reflectDescriptorInfo (undefined `asTypeOf` x)) + makeMessageInfo :: DescriptorInfo -> GetMessageInfo + makeMessageInfo di = GetMessageInfo { requiredTags = Set.fromDistinctAscList . sort $ + [ wireTag f | f <- F.toList (fields di), isRequired f] + , allowedTags = Set.fromDistinctAscList . sort $ + [ wireTag f | f <- F.toList (fields di)] ++ + [ wireTag f | f <- F.toList (knownKeys di)] + } + reflectDescriptorInfo :: m -> DescriptorInfo -- ^ Must not inspect argument diff --git a/Text/ProtocolBuffers/Unknown.hs b/Text/ProtocolBuffers/Unknown.hs new file mode 100644 --- /dev/null +++ b/Text/ProtocolBuffers/Unknown.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE DeriveDataTypeable,RankNTypes #-} +-- | This module add unknown field support to the library. There are no user API things here, +-- except for advanced spelunking into the data structures which can and have changed with no +-- notice. Importer beware. +module Text.ProtocolBuffers.Unknown + ( UnknownField(..),UnknownMessage(..),UnknownFieldValue(..) + , wireSizeUnknownField,wirePutUnknownField,catch'Unknown + ) where + +import qualified Data.ByteString.Lazy as L +import qualified Data.Foldable as F +import Data.Generics +import Data.Monoid(mempty,mappend) +import Data.Sequence((|>)) +import Data.Typeable() +import Control.Monad.Error.Class(catchError) + +import Text.ProtocolBuffers.Basic +import Text.ProtocolBuffers.WireMessage + +-- err :: String -> b +-- err msg = error $ "Text.ProtocolBuffers.Unknown error\n"++msg + +-- | Messages that can store unknown fields implement this interface. +-- UnknownField is a supposedly opaque type. +class UnknownMessage msg where + getUnknownField :: msg -> UnknownField + putUnknownField :: UnknownField -> msg -> msg + +-- | This is a suposedly opaque type +newtype UnknownField = UnknownField (Seq UnknownFieldValue) + deriving (Eq,Ord,Show,Read,Data,Typeable) + +data UnknownFieldValue = UFV {-# UNPACK #-} !WireTag !ByteString + deriving (Eq,Ord,Show,Read,Data,Typeable) + +instance Mergeable UnknownField where +-- mergeEmpty = UnknownField mempty + mergeAppend (UnknownField m1) (UnknownField m2) = UnknownField (mappend m1 m2) + +instance Default UnknownField where + defaultValue = UnknownField mempty + +-- | This is used by the generated code +wireSizeUnknownField :: UnknownField -> WireSize +wireSizeUnknownField (UnknownField m) = F.foldl' aSize 0 m where + aSize old (UFV tag bs) = old + size'WireTag tag + L.length bs + +-- | This is used by the generated code +wirePutUnknownField :: UnknownField -> Put +wirePutUnknownField (UnknownField m) = F.mapM_ aPut m where + aPut (UFV tag bs) = putVarUInt (getWireTag tag) >> putLazyByteString bs + +{-# INLINE catch'Unknown #-} +-- | This is used by the generated code +catch'Unknown :: (Typeable a, UnknownMessage a) => (WireTag -> a -> Get a) -> (WireTag -> a -> Get a) +catch'Unknown update'Self = \wire'Tag old'Self -> catchError (update'Self wire'Tag old'Self) (\_ -> loadUnknown wire'Tag old'Self) + where loadUnknown :: (Typeable a, UnknownMessage a) => WireTag -> a -> Get a + loadUnknown tag msg = do + let (fieldId,wireType) = splitWireTag tag + (UnknownField uf) = getUnknownField msg + bs <- wireGetFromWire fieldId wireType + let v' = seq bs $ UFV tag bs + uf' = seq v' $ uf |> v' + seq uf' $ return $ putUnknownField (UnknownField uf') msg + diff --git a/Text/ProtocolBuffers/WireMessage.hs b/Text/ProtocolBuffers/WireMessage.hs new file mode 100644 --- /dev/null +++ b/Text/ProtocolBuffers/WireMessage.hs @@ -0,0 +1,897 @@ +{-# Language BangPatterns #-} +{-# Language CPP #-} +{- | +Here are the serialization and deserialization functions. + +This module cooperates with the generated code to implement the Wire +instances. The encoding is mostly documented at +. + +The user API functions are grouped into sections and documented. The +rest are for internal use. The main functions are 'messageGet' and +'messagePut' (and 'messageSize'). There are then several 'message*' +variants which allow for finer control and for making delimited +messages. +-} +module Text.ProtocolBuffers.WireMessage + ( -- * User API functions + -- ** Main encoding and decoding operations (non-delimited message encoding) + messageSize,messagePut,messageGet,messagePutM,messageGetM + -- ** These should agree with the length delimited message format of protobuf-2.10, where the message size preceeds the data. + , messageWithLengthSize,messageWithLengthPut,messageWithLengthGet,messageWithLengthPutM,messageWithLengthGetM + -- ** Encoding to write or read a single message field (good for delimited messages or incremental use) + , messageAsFieldSize,messageAsFieldPutM,messageAsFieldGetM + -- ** The Put monad from the binary package, and a custom binary Get monad ("Text.ProtocolBuffers.Get") + , Put,Get,runPut,runGet,runGetOnLazy,getFromBS + -- * The Wire monad itself. Users should beware that passing an incompatible 'FieldType' is a runtime error or fail + , Wire(..) + -- * The internal exports, for use by generated code and the "Text.ProtcolBuffer.Extensions" module + , size'WireTag,toWireType,toWireTag,toPackedWireTag,mkWireTag + , prependMessageSize,putSize,putVarUInt,getVarInt,putLazyByteString,splitWireTag,fieldIdOf + , wireSizeReq,wireSizeOpt,wireSizeRep,wireSizePacked + , wirePutReq,wirePutOpt,wirePutRep,wirePutPacked + , wireSizeErr,wirePutErr,wireGetErr + , getMessageWith,getBareMessageWith,wireGetEnum,wireGetPackedEnum + , unknownField,unknown,wireGetFromWire + , castWord64ToDouble,castWord32ToFloat,castDoubleToWord64,castFloatToWord32 + , zzEncode64,zzEncode32,zzDecode64,zzDecode32 + ) where + +import Control.Monad(when) +import Control.Monad.Error.Class(throwError) +import Control.Monad.ST +import Data.Array.ST(newArray,readArray) +import Data.Array.Unsafe(castSTUArray) +import Data.Bits (Bits(..)) +--import qualified Data.ByteString as S(last) +--import qualified Data.ByteString.Unsafe as S(unsafeIndex) +import qualified Data.ByteString.Lazy as BS (length) +import qualified Data.Foldable as F(foldl',forM_) +--import Data.List (genericLength) +import Data.Maybe(fromMaybe) +import Data.Sequence ((|>)) +import qualified Data.Sequence as Seq(length,empty) +import qualified Data.Set as Set(delete,null) +#if MIN_VERSION_base(4,7,0) +import Data.Typeable (Typeable, typeOf) +#else +import Data.Typeable (Typeable(..)) +#endif +-- GHC internals for getting at Double and Float representation as Word64 and Word32 +-- This has been superceded by the ST array trick (ugly, but promised to work) +--import GHC.Exts (Double(D#),Float(F#),unsafeCoerce#) +--import GHC.Word (Word64(W64#)) -- ,Word32(W32#)) +-- binary package +import Data.Binary.Put (Put,runPut,putWord8,putWord32le,putWord64le,putLazyByteString) + +import Text.ProtocolBuffers.Basic +import Text.ProtocolBuffers.Get as Get (Result(..),Get,runGet,runGetAll,bytesRead,isReallyEmpty,decode7unrolled + ,spanOf,skip,lookAhead,highBitRun -- ,getByteString,getWord8,decode7 + ,getWord32le,getWord64le,getLazyByteString) +import Text.ProtocolBuffers.Reflections(ReflectDescriptor(reflectDescriptorInfo,getMessageInfo) + ,DescriptorInfo(..),GetMessageInfo(..)) + +-- import Debug.Trace(trace) + +trace :: a -> b -> b +trace _ = id + +-- External user API for writing and reading messages + +-- | This computes the size of the message's fields with tags on the +-- wire with no initial tag or length (in bytes). This is also the +-- length of the message as placed between group start and stop tags. +messageSize :: (ReflectDescriptor msg,Wire msg) => msg -> WireSize +messageSize msg = wireSize 10 msg + +-- | This computes the size of the message fields as in 'messageSize' +-- and add the length of the encoded size to the total. Thus this is +-- the the length of the message including the encoded length header, +-- but without any leading tag. +messageWithLengthSize :: (ReflectDescriptor msg,Wire msg) => msg -> WireSize +messageWithLengthSize msg = wireSize 11 msg + +-- | This computes the size of the 'messageWithLengthSize' and then +-- adds the length an initial tag with the given 'FieldId'. +messageAsFieldSize :: (ReflectDescriptor msg,Wire msg) => FieldId -> msg -> WireSize +messageAsFieldSize fi msg = let headerSize = size'WireTag (toWireTag fi 11) + in headerSize + messageWithLengthSize msg + +-- | This is 'runPut' applied to 'messagePutM'. It result in a +-- 'ByteString' with a length of 'messageSize' bytes. +messagePut :: (ReflectDescriptor msg, Wire msg) => msg -> ByteString +messagePut msg = runPut (messagePutM msg) + +-- | This is 'runPut' applied to 'messageWithLengthPutM'. It results +-- in a 'ByteString' with a length of 'messageWithLengthSize' bytes. +messageWithLengthPut :: (ReflectDescriptor msg, Wire msg) => msg -> ByteString +messageWithLengthPut msg = runPut (messageWithLengthPutM msg) + +-- | This writes just the message's fields with tags to the wire. This +-- 'Put' monad can be composed and eventually executed with 'runPut'. +-- +-- This is actually @ wirePut 10 msg @ +messagePutM :: (ReflectDescriptor msg, Wire msg) => msg -> Put +messagePutM msg = wirePut 10 msg + +-- | This writes the encoded length of the message's fields and then +-- the message's fields with tags to the wire. This 'Put' monad can +-- be composed and eventually executed with 'runPut'. +-- +-- This is actually @ wirePut 11 msg @ +messageWithLengthPutM :: (ReflectDescriptor msg, Wire msg) => msg -> Put +messageWithLengthPutM msg = wirePut 11 msg + +-- | This writes an encoded wire tag with the given 'FieldId' and then +-- the encoded length of the message's fields and then the message's +-- fields with tags to the wire. This 'Put' monad can be composed +-- and eventually executed with 'runPut'. +messageAsFieldPutM :: (ReflectDescriptor msg, Wire msg) => FieldId -> msg -> Put +messageAsFieldPutM fi msg = let wireTag = toWireTag fi 11 + in wirePutReq wireTag 11 msg + +-- | This consumes the 'ByteString' to decode a message. It assumes +-- the 'ByteString' is merely a sequence of the tagged fields of the +-- message, and consumes until a group stop tag is detected or the +-- entire input is consumed. Any 'ByteString' past the end of the +-- stop tag is returned as well. +-- +-- This is 'runGetOnLazy' applied to 'messageGetM'. +messageGet :: (ReflectDescriptor msg, Wire msg) => ByteString -> Either String (msg,ByteString) +messageGet bs = runGetOnLazy messageGetM bs + +-- | This 'runGetOnLazy' applied to 'messageWithLengthGetM'. +-- +-- This first reads the encoded length of the message and will then +-- succeed when it has consumed precisely this many additional bytes. +-- The 'ByteString' after this point will be returned. +messageWithLengthGet :: (ReflectDescriptor msg, Wire msg) => ByteString -> Either String (msg,ByteString) +messageWithLengthGet bs = runGetOnLazy messageWithLengthGetM bs + +-- | This reads the tagged message fields until the stop tag or the +-- end of input is reached. +-- +-- This is actually @ wireGet 10 msg @ +messageGetM :: (ReflectDescriptor msg, Wire msg) => Get msg +messageGetM = wireGet 10 + +-- | This reads the encoded message length and then the message. +-- +-- This is actually @ wireGet 11 msg @ +messageWithLengthGetM :: (ReflectDescriptor msg, Wire msg) => Get msg +messageWithLengthGetM = wireGet 11 + +-- | This reads a wire tag (must be of type '2') to get the 'FieldId'. +-- Then the encoded message length is read, followed by the message +-- itself. Both the 'FieldId' and the message are returned. +-- +-- This allows for incremental reading and processing. +messageAsFieldGetM :: (ReflectDescriptor msg, Wire msg) => Get (FieldId,msg) +messageAsFieldGetM = do + wireTag <- fmap WireTag getVarInt + let (fieldId,wireType) = splitWireTag wireTag + when (wireType /= 2) (throwError $ "messageAsFieldGetM: wireType was not 2 "++show (fieldId,wireType)) + msg <- wireGet 11 + return (fieldId,msg) + +-- more functions + +-- | This is 'runGetOnLazy' with the 'Left' results converted to +-- 'error' calls and the trailing 'ByteString' discarded. This use of +-- runtime errors is discouraged, but may be convenient. +getFromBS :: Get r -> ByteString -> r +getFromBS parser bs = case runGetOnLazy parser bs of + Left msg -> error msg + Right (r,_) -> r + +-- This is like 'runGet', without the ability to pass in more input +-- beyond the initial ByteString. Thus the 'ByteString' argument is +-- taken to be the entire input. To be able to incrementally feed in +-- more input you should use 'runGet' and respond to 'Partial' +-- differently. +runGetOnLazy :: Get r -> ByteString -> Either String (r,ByteString) +runGetOnLazy parser bs = resolve (runGetAll parser bs) + where resolve :: Result r -> Either String (r,ByteString) + resolve (Failed i s) = Left ("Failed at "++show i++" : "++s) + resolve (Finished bsOut _i r) = Right (r,bsOut) + resolve (Partial op) = resolve (op Nothing) -- should be impossible + +-- | Used in generated code. +prependMessageSize :: WireSize -> WireSize +prependMessageSize n = n + size'WireSize n + +{-# INLINE wirePutReq #-} +-- | Used in generated code. +wirePutReq :: Wire v => WireTag -> FieldType -> v -> Put +wirePutReq wireTag 10 v = let startTag = getWireTag wireTag + endTag = succ startTag + in putVarUInt startTag >> wirePut 10 v >> putVarUInt endTag +wirePutReq wireTag fieldType v = putVarUInt (getWireTag wireTag) >> wirePut fieldType v + +{-# INLINE wirePutOpt #-} +-- | Used in generated code. +wirePutOpt :: Wire v => WireTag -> FieldType -> Maybe v -> Put +wirePutOpt _wireTag _fieldType Nothing = return () +wirePutOpt wireTag fieldType (Just v) = wirePutReq wireTag fieldType v + +{-# INLINE wirePutRep #-} +-- | Used in generated code. +wirePutRep :: Wire v => WireTag -> FieldType -> Seq v -> Put +wirePutRep wireTag fieldType vs = F.forM_ vs (\v -> wirePutReq wireTag fieldType v) + +{-# INLINE wirePutPacked #-} +-- | Used in generated code. +wirePutPacked :: Wire v => WireTag -> FieldType -> Seq v -> Put +wirePutPacked wireTag fieldType vs = do + putVarUInt (getWireTag wireTag) + let size = F.foldl' (\n v -> n + wireSize fieldType v) 0 vs + putSize size + F.forM_ vs (\v -> wirePut fieldType v) + +{-# INLINE wireSizeReq #-} +-- | Used in generated code. +wireSizeReq :: Wire v => Int64 -> FieldType -> v -> Int64 +wireSizeReq tagSize 10 v = tagSize + wireSize 10 v + tagSize +wireSizeReq tagSize fieldType v = tagSize + wireSize fieldType v + +{-# INLINE wireSizeOpt #-} +-- | Used in generated code. +wireSizeOpt :: Wire v => Int64 -> FieldType -> Maybe v -> Int64 +wireSizeOpt _tagSize _i Nothing = 0 +wireSizeOpt tagSize i (Just v) = wireSizeReq tagSize i v + +{-# INLINE wireSizeRep #-} +-- | Used in generated code. +wireSizeRep :: Wire v => Int64 -> FieldType -> Seq v -> Int64 +wireSizeRep tagSize i vs = F.foldl' (\n v -> n + wireSizeReq tagSize i v) 0 vs + +{-# INLINE wireSizePacked #-} +-- | Used in generated code. +wireSizePacked :: Wire v => Int64 -> FieldType -> Seq v -> Int64 +wireSizePacked tagSize i vs = tagSize + prependMessageSize (F.foldl' (\n v -> n + wireSize i v) 0 vs) + +{-# INLINE putSize #-} +-- | Used in generated code. +putSize :: WireSize -> Put +putSize = putVarUInt + +toPackedWireTag :: FieldId -> WireTag +toPackedWireTag fieldId = mkWireTag fieldId 2 {- packed always uses Length delimited and has wire type of 2 -} + +toWireTag :: FieldId -> FieldType -> WireTag +toWireTag fieldId fieldType + = mkWireTag fieldId (toWireType fieldType) + +mkWireTag :: FieldId -> WireType -> WireTag +mkWireTag fieldId wireType + = ((fromIntegral . getFieldId $ fieldId) `shiftL` 3) .|. (fromIntegral . getWireType $ wireType) + +splitWireTag :: WireTag -> (FieldId,WireType) +splitWireTag (WireTag wireTag) = ( FieldId . fromIntegral $ wireTag `shiftR` 3 + , WireType . fromIntegral $ wireTag .&. 7 ) + +fieldIdOf :: WireTag -> FieldId +fieldIdOf = fst . splitWireTag + +{-# INLINE wireGetPackedEnum #-} +wireGetPackedEnum :: (Typeable e,Enum e) => (Int -> Maybe e) -> Get (Seq e) +wireGetPackedEnum toMaybe'Enum = do + packedLength <- getVarInt + start <- bytesRead + let stop = packedLength+start + next !soFar = do + here <- bytesRead + case compare stop here of + EQ -> return soFar + LT -> tooMuchData packedLength soFar start here + GT -> do + value <- wireGetEnum toMaybe'Enum + seq value $ next (soFar |> value) + next Seq.empty + where + Just e = undefined `asTypeOf` (toMaybe'Enum undefined) + tooMuchData packedLength soFar start here = + throwError ("Text.ProtocolBuffers.WireMessage.wireGetPackedEnum: overran expected length." + ++ "\n The type and count of values so far is " ++ show (typeOf (undefined `asTypeOf` e),Seq.length soFar) + ++ "\n at (packedLength,start,here) == " ++ show (packedLength,start,here)) + +{-# INLINE genericPacked #-} +genericPacked :: Wire a => FieldType -> Get (Seq a) +genericPacked ft = do + packedLength <- getVarInt + start <- bytesRead + let stop = packedLength+start + next !soFar = do + here <- bytesRead + case compare stop here of + EQ -> return soFar + LT -> tooMuchData packedLength soFar start here + GT -> do + value <- wireGet ft + seq value $! next $! soFar |> value + next Seq.empty + where + tooMuchData packedLength soFar start here = + throwError ("Text.ProtocolBuffers.WireMessage.genericPacked: overran expected length." + ++ "\n The FieldType and count of values so far are " ++ show (ft,Seq.length soFar) + ++ "\n at (packedLength,start,here) == " ++ show (packedLength,start,here)) + +-- getMessageWith assumes the wireTag for the message, if it existed, has already been read. +-- getMessageWith assumes that it still needs to read the Varint encoded length of the message. +getMessageWith :: (Default message, ReflectDescriptor message) +-- => (WireTag -> FieldId -> WireType -> message -> Get message) + => (WireTag -> message -> Get message) + -> Get message +{- manyTAT.bin testing INLINE getMessageWith but made slower -} +getMessageWith updater = do + messageLength <- getVarInt + start <- bytesRead + let stop = messageLength+start + -- switch from go to go' once all the required fields have been found + go reqs !message | Set.null reqs = go' message + | otherwise = do + here <- bytesRead + case compare stop here of + EQ -> notEnoughData messageLength start + LT -> tooMuchData messageLength start here + GT -> do + wireTag <- fmap WireTag getVarInt -- get tag off wire + let -- (fieldId,wireType) = splitWireTag wireTag + reqs' = Set.delete wireTag reqs + updater wireTag {- fieldId wireType -} message >>= go reqs' + go' !message = do + here <- bytesRead + case compare stop here of + EQ -> return message + LT -> tooMuchData messageLength start here + GT -> do + wireTag <- fmap WireTag getVarInt -- get tag off wire +-- let (fieldId,wireType) = splitWireTag wireTag + updater wireTag {- fieldId wireType -} message >>= go' + go required initialMessage + where + initialMessage = defaultValue + (GetMessageInfo {requiredTags=required}) = getMessageInfo initialMessage + notEnoughData messageLength start = + throwError ("Text.ProtocolBuffers.WireMessage.getMessageWith: Required fields missing when processing " + ++ (show . descName . reflectDescriptorInfo $ initialMessage) + ++ "\n at (messageLength,start) == " ++ show (messageLength,start)) + tooMuchData messageLength start here = + throwError ("Text.ProtocolBuffers.WireMessage.getMessageWith: overran expected length when processing" + ++ (show . descName . reflectDescriptorInfo $ initialMessage) + ++ "\n at (messageLength,start,here) == " ++ show (messageLength,start,here)) + +-- | Used by generated code +-- getBareMessageWith assumes the wireTag for the message, if it existed, has already been read. +-- getBareMessageWith assumes that it does needs to read the Varint encoded length of the message. +-- getBareMessageWith will consume the entire ByteString it is operating on, or until it +-- finds any STOP_GROUP tag (wireType == 4) +getBareMessageWith :: (Default message, ReflectDescriptor message) +-- => (WireTag -> FieldId -> WireType -> message -> Get message) -- handle wireTags that are unknown or produce errors + => (WireTag -> message -> Get message) -- handle wireTags that are unknown or produce errors + -> Get message +{- manyTAT.bin testing INLINE getBareMessageWith but made slower -} +getBareMessageWith updater = go required initialMessage + where + go reqs !message | Set.null reqs = go' message + | otherwise = do + done <- isReallyEmpty + if done then notEnoughData + else do + wireTag <- fmap WireTag getVarInt -- get tag off wire + let (_fieldId,wireType) = splitWireTag wireTag + if wireType == 4 then notEnoughData -- END_GROUP too soon + else let reqs' = Set.delete wireTag reqs + in updater wireTag {- fieldId wireType -} message >>= go reqs' + go' !message = do + done <- isReallyEmpty + if done then return message + else do + wireTag <- fmap WireTag getVarInt -- get tag off wire + let (_fieldId,wireType) = splitWireTag wireTag + if wireType == 4 then return message + else updater wireTag {- fieldId wireType -} message >>= go' + initialMessage = defaultValue + (GetMessageInfo {requiredTags=required}) = getMessageInfo initialMessage + notEnoughData = throwError ("Text.ProtocolBuffers.WireMessage.getBareMessageWith: Required fields missing when processing " + ++ (show . descName . reflectDescriptorInfo $ initialMessage)) + +unknownField :: Typeable a => a -> FieldId -> Get a +unknownField msg fieldId = do + here <- bytesRead + throwError ("Impossible? Text.ProtocolBuffers.WireMessage.unknownField" + ++"\n Updater for "++show (typeOf msg)++" claims there is an unknown field id on wire: "++show fieldId + ++"\n at a position just before byte location "++show here) + + +unknown :: (Typeable a,ReflectDescriptor a) => FieldId -> WireType -> a -> Get a +unknown fieldId wireType initialMessage = do + here <- bytesRead + throwError ("Text.ProtocolBuffers.WireMessage.unknown: Unknown field found or failure parsing field (e.g. unexpected Enum value):" + ++ "\n (message type name,field id number,wire type code,bytes read) == " + ++ show (typeOf initialMessage,fieldId,wireType,here) + ++ "\n when processing " + ++ (show . descName . reflectDescriptorInfo $ initialMessage)) + +{-# INLINE castWord32ToFloat #-} +castWord32ToFloat :: Word32 -> Float +--castWord32ToFloat (W32# w) = F# (unsafeCoerce# w) +--castWord32ToFloat x = unsafePerformIO $ alloca $ \p -> poke p x >> peek (castPtr p) +castWord32ToFloat x = runST (newArray (0::Int,0) x >>= castSTUArray >>= flip readArray 0) +{-# INLINE castFloatToWord32 #-} +castFloatToWord32 :: Float -> Word32 +--castFloatToWord32 (F# f) = W32# (unsafeCoerce# f) +castFloatToWord32 x = runST (newArray (0::Int,0) x >>= castSTUArray >>= flip readArray 0) + +{-# INLINE castWord64ToDouble #-} +castWord64ToDouble :: Word64 -> Double +-- castWord64ToDouble (W64# w) = D# (unsafeCoerce# w) +castWord64ToDouble x = runST (newArray (0::Int,0) x >>= castSTUArray >>= flip readArray 0) +{-# INLINE castDoubleToWord64 #-} +castDoubleToWord64 :: Double -> Word64 +-- castDoubleToWord64 (D# d) = W64# (unsafeCoerce# d) +castDoubleToWord64 x = runST (newArray (0::Int,0) x >>= castSTUArray >>= flip readArray 0) + +-- These error handlers are exported to the generated code +wireSizeErr :: Typeable a => FieldType -> a -> WireSize +wireSizeErr ft x = error $ concat [ "Impossible? wireSize field type mismatch error: Field type number ", show ft + , " does not match internal type ", show (typeOf x) ] +wirePutErr :: Typeable a => FieldType -> a -> Put +wirePutErr ft x = fail $ concat [ "Impossible? wirePut field type mismatch error: Field type number ", show ft + , " does not match internal type ", show (typeOf x) ] +wireGetErr :: Typeable a => FieldType -> Get a +wireGetErr ft = answer where + answer = throwError $ concat [ "Impossible? wireGet field type mismatch error: Field type number ", show ft + , " does not match internal type ", show (typeOf (undefined `asTypeOf` typeHack answer)) ] + typeHack :: Get a -> a + typeHack = undefined + +-- | The 'Wire' class is for internal use, and may change. If there +-- is a mis-match between the 'FieldType' and the type of @b@ then you +-- will get a failure at runtime. +-- +-- Users should stick to the message functions defined in +-- "Text.ProtocolBuffers.WireMessage" and exported to use user by +-- "Text.ProtocolBuffers". These are less likely to change. +class Wire b where + wireSize :: FieldType -> b -> WireSize + wirePut :: FieldType -> b -> Put + wireGet :: FieldType -> Get b + {-# INLINE wireGetPacked #-} + wireGetPacked :: FieldType -> Get (Seq b) + wireGetPacked ft = throwError ("Text.ProtocolBuffers.ProtoCompile.Basic: wireGetPacked default:" + ++ "\n There is no way to get a packed FieldType of "++show ft + ++ ".\n Either there is a bug in this library or the wire format is has been updated.") + +instance Wire Double where + {-# INLINE wireSize #-} + wireSize {- TYPE_DOUBLE -} 1 _ = 8 + wireSize ft x = wireSizeErr ft x + {-# INLINE wirePut #-} + wirePut {- TYPE_DOUBLE -} 1 x = putWord64le (castDoubleToWord64 x) + wirePut ft x = wirePutErr ft x + {-# INLINE wireGet #-} + wireGet {- TYPE_DOUBLE -} 1 = fmap castWord64ToDouble getWord64le + wireGet ft = wireGetErr ft + {-# INLINE wireGetPacked #-} + wireGetPacked 1 = genericPacked 1 + wireGetPacked ft = wireGetErr ft + +instance Wire Float where + {-# INLINE wireSize #-} + wireSize {- TYPE_FLOAT -} 2 _ = 4 + wireSize ft x = wireSizeErr ft x + {-# INLINE wirePut #-} + wirePut {- TYPE_FLOAT -} 2 x = putWord32le (castFloatToWord32 x) + wirePut ft x = wirePutErr ft x + {-# INLINE wireGet #-} + wireGet {- TYPE_FLOAT -} 2 = fmap castWord32ToFloat getWord32le + wireGet ft = wireGetErr ft + {-# INLINE wireGetPacked #-} + wireGetPacked 2 = genericPacked 2 + wireGetPacked ft = wireGetErr ft + +instance Wire Int64 where + {-# INLINE wireSize #-} + wireSize {- TYPE_INT64 -} 3 x = size'Int64 x + wireSize {- TYPE_SINT64 -} 18 x = size'Word64 (zzEncode64 x) + wireSize {- TYPE_SFIXED64 -} 16 _ = 8 + wireSize ft x = wireSizeErr ft x + {-# INLINE wirePut #-} + wirePut {- TYPE_INT64 -} 3 x = putVarSInt x + wirePut {- TYPE_SINT64 -} 18 x = putVarUInt (zzEncode64 x) + wirePut {- TYPE_SFIXED64 -} 16 x = putWord64le (fromIntegral x) + wirePut ft x = wirePutErr ft x + {-# INLINE wireGet #-} + wireGet {- TYPE_INT64 -} 3 = getVarInt + wireGet {- TYPE_SINT64 -} 18 = fmap zzDecode64 getVarInt + wireGet {- TYPE_SFIXED64 -} 16 = fmap fromIntegral getWord64le + wireGet ft = wireGetErr ft + {-# INLINE wireGetPacked #-} + wireGetPacked 3 = genericPacked 3 + wireGetPacked 18 = genericPacked 18 + wireGetPacked 16 = genericPacked 16 + wireGetPacked ft = wireGetErr ft + +instance Wire Int32 where + {-# INLINE wireSize #-} + wireSize {- TYPE_INT32 -} 5 x = size'Int32 x + wireSize {- TYPE_SINT32 -} 17 x = size'Word32 (zzEncode32 x) + wireSize {- TYPE_SFIXED32 -} 15 _ = 4 + wireSize ft x = wireSizeErr ft x + {-# INLINE wirePut #-} + wirePut {- TYPE_INT32 -} 5 x = putVarSInt x + wirePut {- TYPE_SINT32 -} 17 x = putVarUInt (zzEncode32 x) + wirePut {- TYPE_SFIXED32 -} 15 x = putWord32le (fromIntegral x) + wirePut ft x = wirePutErr ft x + {-# INLINE wireGet #-} + wireGet {- TYPE_INT32 -} 5 = getVarInt + wireGet {- TYPE_SINT32 -} 17 = fmap zzDecode32 getVarInt + wireGet {- TYPE_SFIXED32 -} 15 = fmap fromIntegral getWord32le + wireGet ft = wireGetErr ft + {-# INLINE wireGetPacked #-} + wireGetPacked 5 = genericPacked 5 + wireGetPacked 17 = genericPacked 17 + wireGetPacked 15 = genericPacked 15 + wireGetPacked ft = wireGetErr ft + +instance Wire Word64 where + {-# INLINE wireSize #-} + wireSize {- TYPE_UINT64 -} 4 x = size'Word64 x + wireSize {- TYPE_FIXED64 -} 6 _ = 8 + wireSize ft x = wireSizeErr ft x + {-# INLINE wirePut #-} + wirePut {- TYPE_UINT64 -} 4 x = putVarUInt x + wirePut {- TYPE_FIXED64 -} 6 x = putWord64le x + wirePut ft x = wirePutErr ft x + {-# INLINE wireGet #-} + wireGet {- TYPE_FIXED64 -} 6 = getWord64le + wireGet {- TYPE_UINT64 -} 4 = getVarInt + wireGet ft = wireGetErr ft + {-# INLINE wireGetPacked #-} + wireGetPacked 6 = genericPacked 6 + wireGetPacked 4 = genericPacked 4 + wireGetPacked ft = wireGetErr ft + +instance Wire Word32 where + {-# INLINE wireSize #-} + wireSize {- TYPE_UINT32 -} 13 x = size'Word32 x + wireSize {- TYPE_FIXED32 -} 7 _ = 4 + wireSize ft x = wireSizeErr ft x + {-# INLINE wirePut #-} + wirePut {- TYPE_UINT32 -} 13 x = putVarUInt x + wirePut {- TYPE_FIXED32 -} 7 x = putWord32le x + wirePut ft x = wirePutErr ft x + {-# INLINE wireGet #-} + wireGet {- TYPE_UINT32 -} 13 = getVarInt + wireGet {- TYPE_FIXED32 -} 7 = getWord32le + wireGet ft = wireGetErr ft + {-# INLINE wireGetPacked #-} + wireGetPacked 13 = genericPacked 13 + wireGetPacked 7 = genericPacked 7 + wireGetPacked ft = wireGetErr ft + +instance Wire Bool where + {-# INLINE wireSize #-} + wireSize {- TYPE_BOOL -} 8 _ = 1 + wireSize ft x = wireSizeErr ft x + {-# INLINE wirePut #-} + wirePut {- TYPE_BOOL -} 8 False = putWord8 0 + wirePut {- TYPE_BOOL -} 8 True = putWord8 1 -- google's wire_format_lite_inl.h + wirePut ft x = wirePutErr ft x + {-# INLINE wireGet #-} + wireGet {- TYPE_BOOL -} 8 = do + x <- getVarInt :: Get Int32 -- google's wire_format_lit_inl.h line 155 + case x of + 0 -> return False + _ -> return True +-- x' | x' < 128 -> return True +-- _ -> throwError ("TYPE_BOOL read failure : " ++ show x) + wireGet ft = wireGetErr ft + {-# INLINE wireGetPacked #-} + wireGetPacked 8 = genericPacked 8 + wireGetPacked ft = wireGetErr ft + +instance Wire Utf8 where +-- items of TYPE_STRING is already in a UTF8 encoded Data.ByteString.Lazy + {-# INLINE wireSize #-} + wireSize {- TYPE_STRING -} 9 x = prependMessageSize $ BS.length (utf8 x) + wireSize ft x = wireSizeErr ft x + {-# INLINE wirePut #-} + wirePut {- TYPE_STRING -} 9 x = putVarUInt (BS.length (utf8 x)) >> putLazyByteString (utf8 x) + wirePut ft x = wirePutErr ft x + {-# INLINE wireGet #-} + wireGet {- TYPE_STRING -} 9 = getVarInt >>= getLazyByteString >>= verifyUtf8 + wireGet ft = wireGetErr ft + +instance Wire ByteString where +-- items of TYPE_BYTES is an untyped binary Data.ByteString.Lazy + {-# INLINE wireSize #-} + wireSize {- TYPE_BYTES -} 12 x = prependMessageSize $ BS.length x + wireSize ft x = wireSizeErr ft x + {-# INLINE wirePut #-} + wirePut {- TYPE_BYTES -} 12 x = putVarUInt (BS.length x) >> putLazyByteString x + wirePut ft x = wirePutErr ft x + {-# INLINE wireGet #-} + wireGet {- TYPE_BYTES -} 12 = getVarInt >>= getLazyByteString + wireGet ft = wireGetErr ft + +-- Wrap a protocol-buffer Enum in fromEnum or toEnum and serialize the Int: +instance Wire Int where + {-# INLINE wireSize #-} + wireSize {- TYPE_ENUM -} 14 x = size'Int x + wireSize ft x = wireSizeErr ft x + {-# INLINE wirePut #-} + wirePut {- TYPE_ENUM -} 14 x = putVarSInt x + wirePut ft x = wirePutErr ft x + {-# INLINE wireGet #-} + wireGet {- TYPE_ENUM -} 14 = getVarInt + wireGet ft = wireGetErr ft + {-# INLINE wireGetPacked #-} + wireGetPacked 14 = genericPacked 14 -- Should not actually be used, see wireGetPackedEnum, though this ought to work if it were used (e.g. genericPacked) + wireGetPacked ft = wireGetErr ft + +{-# INLINE verifyUtf8 #-} +verifyUtf8 :: ByteString -> Get Utf8 +verifyUtf8 bs = case isValidUTF8 bs of + Nothing -> return (Utf8 bs) + Just i -> throwError $ "Text.ProtocolBuffers.WireMessage.verifyUtf8: ByteString is not valid utf8 at position "++show i + +{-# INLINE wireGetEnum #-} +wireGetEnum :: (Typeable e, Enum e) => (Int -> Maybe e) -> Get e +wireGetEnum toMaybe'Enum = do + int <- wireGet 14 -- uses the "instance Wire Int" defined above + case toMaybe'Enum int of + Just !v -> return v + Nothing -> throwError (msg ++ show int) + where msg = "Bad wireGet of Enum "++show (typeOf (undefined `asTypeOf` typeHack toMaybe'Enum))++", unrecognized Int value is " + typeHack :: (Int -> Maybe e) -> e + typeHack f = fromMaybe undefined (f undefined) + +-- This will have to examine the value of positive numbers to get the size +size'WireTag :: WireTag -> Int64 +size'WireTag = size'Word32 . getWireTag + +size'Word32 :: Word32 -> Int64 +size'Word32 b | b <= 0x7F = 1 + | b <= 0x3FFF = 2 + | b <= 0x1FFFFF = 3 + | b <= 0xFFFFFFF = 4 + | otherwise = 5 + +size'Int32 :: Int32 -> Int64 +size'Int32 b | b < 0 = 10 + | b <= 0x7F = 1 + | b <= 0x3FFF = 2 + | b <= 0x1FFFFF = 3 + | b <= 0xFFFFFFF = 4 + | otherwise = 5 + + +size'Word64 :: Word64 -> Int64 +size'Word64 b | b <= 0x7F = 1 + | b <= 0x3FFF = 2 + | b <= 0x1FFFFF = 3 + | b <= 0xFFFFFFF = 4 + | b <= 0X7FFFFFFFF = 5 + | b <= 0x3FFFFFFFFFF = 6 + | b <= 0x1FFFFFFFFFFFF = 7 + | b <= 0xFFFFFFFFFFFFFF = 8 + | b <= 0x7FFFFFFFFFFFFFFF = 9 + | otherwise = 10 + +-- Should work for Int of 32 and 64 bits +size'Int :: Int -> Int64 +size'Int b | b < 0 = 10 + | b <= 0x7F = 1 + | b <= 0x3FFF = 2 + | b <= 0x1FFFFF = 3 + | b <= 0xFFFFFFF = 4 + | b <= 0x7FFFFFFF = 5 -- maxBound :: Int32 + | b <= 0x7FFFFFFFF = 5 + | b <= 0x3FFFFFFFFFF = 6 + | b <= 0x1FFFFFFFFFFFF = 7 + | b <= 0xFFFFFFFFFFFFFF = 8 + | otherwise = 9 + +size'Int64,size'WireSize :: Int64 -> Int64 +size'WireSize = size'Int64 +size'Int64 b | b < 0 = 10 + | b <= 0x7F = 1 + | b <= 0x3FFF = 2 + | b <= 0x1FFFFF = 3 + | b <= 0xFFFFFFF = 4 + | b <= 0x7FFFFFFFF = 5 + | b <= 0x3FFFFFFFFFF = 6 + | b <= 0x1FFFFFFFFFFFF = 7 + | b <= 0xFFFFFFFFFFFFFF = 8 + | otherwise = 9 + +{- +size'Varint :: (Integral b, Bits b) => b -> Int64 +{-# INLINE size'Varint #-} +size'Varint b = case compare b 0 of + LT -> 10 -- fromIntegral (divBy (bitSize b) 7) + EQ -> 1 + GT -> genericLength . takeWhile (0<) . iterate (`shiftR` 7) $ b +-} + +-- Taken from google's code, but I had to explcitly add fromIntegral in the right places: +zzEncode32 :: Int32 -> Word32 +zzEncode32 x = fromIntegral ((x `shiftL` 1) `xor` (x `shiftR` 31)) +zzEncode64 :: Int64 -> Word64 +zzEncode64 x = fromIntegral ((x `shiftL` 1) `xor` (x `shiftR` 63)) +zzDecode32 :: Word32 -> Int32 +zzDecode32 w = (fromIntegral (w `shiftR` 1)) `xor` (negate (fromIntegral (w .&. 1))) +zzDecode64 :: Word64 -> Int64 +zzDecode64 w = (fromIntegral (w `shiftR` 1)) `xor` (negate (fromIntegral (w .&. 1))) + +{- +-- The above is tricky, so the testing roundtrips and versus examples is needed: +testZZ :: Bool +testZZ = and (concat testsZZ) + where testsZZ = [ map (\v -> v ==zzEncode64 (zzDecode64 v)) values + , map (\v -> v ==zzEncode32 (zzDecode32 v)) values + , map (\v -> v ==zzDecode64 (zzEncode64 v)) values + , map (\v -> v ==zzDecode32 (zzEncode32 v)) values + , [ zzEncode32 minBound == maxBound + , zzEncode32 maxBound == pred maxBound + , zzEncode64 minBound == maxBound + , zzEncode64 maxBound == pred maxBound + , zzEncode64 0 == 0, zzEncode32 0 == 0 + , zzEncode64 (-1) == 1, zzEncode32 (-1) == 1 + , zzEncode64 1 == 2, zzEncode32 1 == 2 + ] ] +let values :: (Bounded a,Integral a) => [a]; values = [minBound,div minBound 2 - 1,div minBound 2, div minBound 2 + 1,-257,-256,-255,-129,-128,-127,-3,-2,-1,0,1,2,3,127,128,129,255,256,257,div maxBound 2 - 1, div maxBound 2, div maxBound 2 + 1, maxBound] +-} + +getVarInt :: (Show a, Integral a, Bits a) => Get a +{-# INLINE getVarInt #-} +--getVarInt = decode7unrolled -- decode7 -- getVarInt below +getVarInt = do + a <- decode7unrolled + trace ("getVarInt: "++show a) $ return a + +{- +getVarInt = do -- optimize first read instead of calling (go 0 0) + b <- getWord8 + if testBit b 7 then go 7 (fromIntegral (b .&. 0x7F)) + else return (fromIntegral b) + where + go n val = do + b <- getWord8 + if testBit b 7 then go (n+7) (val .|. ((fromIntegral (b .&. 0x7F)) `shiftL` n)) + else return (val .|. ((fromIntegral b) `shiftL` n)) +-} + +-- This can be used on any Integral type and is needed for signed types; unsigned can use putVarUInt below. +-- This has been changed to handle only up to 64 bit integral values (to match documentation). +{-# INLINE putVarSInt #-} +putVarSInt :: (Integral a, Bits a) => a -> Put +putVarSInt bIn = + case compare bIn 0 of + LT -> let b :: Int64 -- upcast to 64 bit to match documentation of 10 bytes for all negative values + b = fromIntegral bIn + len :: Int + len = 10 -- (pred 10)*7 < 64 <= 10*7 + last'Mask = 1 -- pred (1 `shiftL` 1) + go !i 1 = putWord8 (fromIntegral (i .&. last'Mask)) + go !i n = putWord8 (fromIntegral (i .&. 0x7F) .|. 0x80) >> go (i `shiftR` 7) (pred n) + in go b len + EQ -> putWord8 0 + GT -> putVarUInt bIn + +-- This should be used on unsigned Integral types only (not checked) +{-# INLINE putVarUInt #-} +putVarUInt :: (Integral a, Bits a) => a -> Put +putVarUInt i | i < 0x80 = putWord8 (fromIntegral i) + | otherwise = putWord8 (fromIntegral (i .&. 0x7F) .|. 0x80) >> putVarUInt (i `shiftR` 7) + +-- | This reads in the raw bytestring corresponding to an field known +-- only through the wiretag's 'FieldId' and 'WireType'. +wireGetFromWire :: FieldId -> WireType -> Get ByteString +wireGetFromWire fi wt = getLazyByteString =<< calcLen where + calcLen = case wt of + 0 -> highBitRun -- lenOf (spanOf (>=128) >> skip 1) + 1 -> return 8 + 2 -> lookAhead $ do + here <- bytesRead + len <- getVarInt + there <- bytesRead + return ((there-here)+len) + 3 -> lenOf (skipGroup fi) + 4 -> throwError $ "Cannot wireGetFromWire with wireType of STOP_GROUP: "++show (fi,wt) + 5 -> return 4 + wtf -> throwError $ "Invalid wire type (expected 0,1,2,3,or 5) found: "++show (fi,wtf) + lenOf g = do here <- bytesRead + there <- lookAhead (g >> bytesRead) + trace (":wireGetFromWire.lenOf: "++show ((fi,wt),(here,there,there-here))) $ return (there-here) + +-- | After a group start tag with the given 'FieldId' this will skip +-- ahead in the stream past the end tag of that group. Used by +-- 'wireGetFromWire' to help compule the length of an unknown field +-- when loading an extension. +skipGroup :: FieldId -> Get () +skipGroup start_fi = go where + go = do + (fieldId,wireType) <- fmap (splitWireTag . WireTag) getVarInt + case wireType of + 0 -> spanOf (>=128) >> skip 1 >> go + 1 -> skip 8 >> go + 2 -> getVarInt >>= skip >> go + 3 -> skipGroup fieldId >> go + 4 | start_fi /= fieldId -> throwError $ "skipGroup failed, fieldId mismatch bewteen START_GROUP and STOP_GROUP: "++show (start_fi,(fieldId,wireType)) + | otherwise -> return () + 5 -> skip 4 >> go + wtf -> throwError $ "Invalid wire type (expected 0,1,2,3,4,or 5) found: "++show (fieldId,wtf) + +{- + enum WireType { + WIRETYPE_VARINT = 0, + WIRETYPE_FIXED64 = 1, + WIRETYPE_LENGTH_DELIMITED = 2, + WIRETYPE_START_GROUP = 3, + WIRETYPE_END_GROUP = 4, + WIRETYPE_FIXED32 = 5, }; + + FieldType is + TYPE_DOUBLE = 1; + TYPE_FLOAT = 2; + TYPE_INT64 = 3; + TYPE_UINT64 = 4; + TYPE_INT32 = 5; + TYPE_FIXED64 = 6; + TYPE_FIXED32 = 7; + TYPE_BOOL = 8; + TYPE_STRING = 9; + TYPE_GROUP = 10; // Tag-delimited aggregate. + TYPE_MESSAGE = 11; + TYPE_BYTES = 12; + TYPE_UINT32 = 13; + TYPE_ENUM = 14; + TYPE_SFIXED32 = 15; + TYPE_SFIXED64 = 16; + TYPE_SINT32 = 17; + TYPE_SINT64 = 18; -} +-- http://code.google.com/apis/protocolbuffers/docs/encoding.html + +toWireType :: FieldType -> WireType +toWireType 1 = 1 +toWireType 2 = 5 +toWireType 3 = 0 +toWireType 4 = 0 +toWireType 5 = 0 +toWireType 6 = 1 +toWireType 7 = 5 +toWireType 8 = 0 +toWireType 9 = 2 +toWireType 10 = 3 -- START_GROUP +toWireType 11 = 2 +toWireType 12 = 2 +toWireType 13 = 0 +toWireType 14 = 0 +toWireType 15 = 5 +toWireType 16 = 1 +toWireType 17 = 0 +toWireType 18 = 0 +toWireType x = error $ "Text.ProcolBuffers.Basic.toWireType: Bad FieldType: "++show x + +{- +-- OPTIMIZE attempt: +-- Used in bench-003-highBitrun-and-new-getVarInt and much slower +-- This is a much slower variant than supplied by default in version 1.8.4 +getVarInt :: (Integral a, Bits a) => Get a +getVarInt = do + n <- highBitRun -- n is at least 0, or an error is thrown by highBitRun + s <- getByteString (succ n) -- length of s is at least 1 + let go 0 val = return val + go m val = let m' = pred m -- m' will be [(n-2) .. 0] + val' = (val `shiftL` 7) .|. (fromIntegral (0x7F .&. S.unsafeIndex s m')) + in go m' $! val' + go n (fromIntegral (S.last s)) +-} + +-- OPTIMIZE try inlinining getMessageWith and getBareMessageWith: bench-005, slower + + +-- OPTIMIZE try NO-inlining getMessageWith and getBareMessageWith diff --git a/protocol-buffers-fork.cabal b/protocol-buffers-fork.cabal new file mode 100644 --- /dev/null +++ b/protocol-buffers-fork.cabal @@ -0,0 +1,84 @@ +name: protocol-buffers-fork +version: 2.0.16 +cabal-version: >= 1.6 +build-type: Simple +license: BSD3 +license-file: LICENSE +copyright: (c) 2008-2012 Christopher Edward Kuklewicz +author: Christopher Edward Kuklewicz +maintainer: Stefan Wehr +stability: Good +homepage: http://darcs.factisresearch.com/pub/protocol-buffers-fork/ +package-url: http://hackage.haskell.org/package/protocol-buffers-fork +synopsis: Parse Google Protocol Buffer specifications +description: Parse proto files and generate Haskell code. This is a fork of the protocol-buffers library at http://hackage.haskell.org/package/protocol-buffers +category: Text +Tested-With: GHC == 7.8.3 +extra-source-files: TODO + README + +flag small_base + description: Choose the new smaller, split-up base package. + +Library + -- Added -fspec-constr-count=10 to quiet ghc-7.0.2. + ghc-options: -Wall -O2 -fspec-constr-count=10 + ghc-prof-options: -auto-all -prof + exposed-modules: Text.ProtocolBuffers + Text.ProtocolBuffers.Basic + Text.ProtocolBuffers.Extensions + Text.ProtocolBuffers.Get + Text.ProtocolBuffers.Header + Text.ProtocolBuffers.Identifiers + Text.ProtocolBuffers.Reflections + Text.ProtocolBuffers.Unknown + Text.ProtocolBuffers.WireMessage + + build-depends: array, + binary, + bytestring, + containers, + directory, + filepath, + mtl, + utf8-string + + if flag(small_base) + build-depends: base == 4.*, syb + else + build-depends: base == 3.* + +-- Most of these are needed for protocol-buffers (Get and WireMessage.hs) +-- Nothing especially hazardous in this list + extensions: BangPatterns, + CPP, + DeriveDataTypeable, + EmptyDataDecls, + FlexibleInstances, + FunctionalDependencies, + GADTs, + GeneralizedNewtypeDeriving, + MagicHash, + MultiParamTypeClasses, + PatternGuards, + RankNTypes, + RecordWildCards + ScopedTypeVariables, + TypeSynonymInstances + +-- {- +-- FlexibleContexts, +-- NamedFieldPuns, +-- PatternGuards, +-- BangPatterns +-- CPP +-- DeriveDataTypeable +-- FlexibleInstances +-- FunctionalDependencies +-- GADTs +-- GeneralizedNewtypeDeriving +-- MagicHash +-- MultiParamTypeClasses +-- RankNTypes +-- ScopedTypeVariables +-- TypeSynonymInstances-}