summaryrefslogtreecommitdiffstats
path: root/src/jaegertracing/thrift/lib/hs
diff options
context:
space:
mode:
authorDaniel Baumann <daniel.baumann@progress-linux.org>2024-04-07 18:45:59 +0000
committerDaniel Baumann <daniel.baumann@progress-linux.org>2024-04-07 18:45:59 +0000
commit19fcec84d8d7d21e796c7624e521b60d28ee21ed (patch)
tree42d26aa27d1e3f7c0b8bd3fd14e7d7082f5008dc /src/jaegertracing/thrift/lib/hs
parentInitial commit. (diff)
downloadceph-19fcec84d8d7d21e796c7624e521b60d28ee21ed.tar.xz
ceph-19fcec84d8d7d21e796c7624e521b60d28ee21ed.zip
Adding upstream version 16.2.11+ds.upstream/16.2.11+dsupstream
Signed-off-by: Daniel Baumann <daniel.baumann@progress-linux.org>
Diffstat (limited to 'src/jaegertracing/thrift/lib/hs')
-rw-r--r--src/jaegertracing/thrift/lib/hs/CMakeLists.txt93
-rw-r--r--src/jaegertracing/thrift/lib/hs/LICENSE202
-rw-r--r--src/jaegertracing/thrift/lib/hs/Makefile.am53
-rw-r--r--src/jaegertracing/thrift/lib/hs/README.md113
-rwxr-xr-xsrc/jaegertracing/thrift/lib/hs/Setup.lhs21
-rw-r--r--src/jaegertracing/thrift/lib/hs/TODO2
-rw-r--r--src/jaegertracing/thrift/lib/hs/coding_standards.md1
-rw-r--r--src/jaegertracing/thrift/lib/hs/src/Thrift.hs114
-rw-r--r--src/jaegertracing/thrift/lib/hs/src/Thrift/Arbitraries.hs55
-rw-r--r--src/jaegertracing/thrift/lib/hs/src/Thrift/Protocol.hs136
-rw-r--r--src/jaegertracing/thrift/lib/hs/src/Thrift/Protocol/Binary.hs212
-rw-r--r--src/jaegertracing/thrift/lib/hs/src/Thrift/Protocol/Compact.hs311
-rw-r--r--src/jaegertracing/thrift/lib/hs/src/Thrift/Protocol/Header.hs141
-rw-r--r--src/jaegertracing/thrift/lib/hs/src/Thrift/Protocol/JSON.hs362
-rw-r--r--src/jaegertracing/thrift/lib/hs/src/Thrift/Server.hs66
-rw-r--r--src/jaegertracing/thrift/lib/hs/src/Thrift/Transport.hs65
-rw-r--r--src/jaegertracing/thrift/lib/hs/src/Thrift/Transport/Empty.hs36
-rw-r--r--src/jaegertracing/thrift/lib/hs/src/Thrift/Transport/Framed.hs99
-rw-r--r--src/jaegertracing/thrift/lib/hs/src/Thrift/Transport/Handle.hs78
-rw-r--r--src/jaegertracing/thrift/lib/hs/src/Thrift/Transport/Header.hs354
-rw-r--r--src/jaegertracing/thrift/lib/hs/src/Thrift/Transport/HttpClient.hs101
-rw-r--r--src/jaegertracing/thrift/lib/hs/src/Thrift/Transport/IOBuffer.hs69
-rw-r--r--src/jaegertracing/thrift/lib/hs/src/Thrift/Transport/Memory.hs77
-rw-r--r--src/jaegertracing/thrift/lib/hs/src/Thrift/Types.hs130
-rw-r--r--src/jaegertracing/thrift/lib/hs/test/BinarySpec.hs91
-rw-r--r--src/jaegertracing/thrift/lib/hs/test/CompactSpec.hs81
-rw-r--r--src/jaegertracing/thrift/lib/hs/test/JSONSpec.hs225
-rw-r--r--src/jaegertracing/thrift/lib/hs/test/Spec.hs38
-rw-r--r--src/jaegertracing/thrift/lib/hs/thrift.cabal84
29 files changed, 3410 insertions, 0 deletions
diff --git a/src/jaegertracing/thrift/lib/hs/CMakeLists.txt b/src/jaegertracing/thrift/lib/hs/CMakeLists.txt
new file mode 100644
index 000000000..1a5b8fd32
--- /dev/null
+++ b/src/jaegertracing/thrift/lib/hs/CMakeLists.txt
@@ -0,0 +1,93 @@
+#
+# Licensed to the Apache Software Foundation (ASF) under one
+# or more contributor license agreements. See the NOTICE file
+# distributed with this work for additional information
+# regarding copyright ownership. The ASF licenses this file
+# to you 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.
+#
+
+# Rebuild when any of these files changes
+set(haskell_sources
+ src/Thrift.hs
+ src/Thrift/Arbitraries.hs
+ src/Thrift/Protocol.hs
+ src/Thrift/Protocol/Binary.hs
+ src/Thrift/Protocol/Compact.hs
+ src/Thrift/Protocol/JSON.hs
+ src/Thrift/Server.hs
+ src/Thrift/Transport.hs
+ src/Thrift/Transport/Empty.hs
+ src/Thrift/Transport/Framed.hs
+ src/Thrift/Transport/Handle.hs
+ src/Thrift/Transport/HttpClient.hs
+ src/Thrift/Transport/IOBuffer.hs
+ src/Thrift/Types.hs
+ thrift.cabal
+)
+
+if(BUILD_TESTING)
+ list(APPEND haskell_soruces
+ test/Spec.hs
+ test/BinarySpec.hs
+ test/CompactSpec.hs
+ test/JSONSpec.hs
+ )
+ set(hs_enable_test "--enable-tests")
+endif()
+
+set(haskell_artifacts thrift_cabal.stamp)
+# Adding *.hi files so that any missing file triggers the build
+foreach(SRC ${haskell_sources})
+ get_filename_component(EX ${SRC} EXT)
+ if(${EX} STREQUAL ".hs")
+ file(RELATIVE_PATH REL ${CMAKE_CURRENT_SOURCE_DIR}/src ${CMAKE_CURRENT_SOURCE_DIR}/${SRC})
+ get_filename_component(DIR ${REL} DIRECTORY)
+ get_filename_component(BASE ${REL} NAME_WE)
+ list(APPEND haskell_artifacts dist/build/${DIR}/${BASE}.hi)
+ endif()
+endforeach()
+
+if(CMAKE_BUILD_TYPE STREQUAL "Debug")
+ set(hs_optimize -O0)
+else()
+ set(hs_optimize -O1)
+endif()
+
+add_custom_command(
+ OUTPUT ${haskell_artifacts}
+ COMMAND ${CABAL} update
+ # Build dependencies first without --builddir, otherwise it fails.
+ COMMAND ${CABAL} install --only-dependencies ${hs_enable_test}
+ COMMAND ${CABAL} configure ${hs_optimize} ${hs_enable_test} --builddir=${CMAKE_CURRENT_BINARY_DIR}/dist
+ COMMAND ${CABAL} build --builddir=${CMAKE_CURRENT_BINARY_DIR}/dist
+ COMMAND ${CABAL} install --builddir=${CMAKE_CURRENT_BINARY_DIR}/dist
+ COMMAND ${CMAKE_COMMAND} -E touch ${CMAKE_CURRENT_BINARY_DIR}/thrift_cabal.stamp
+ WORKING_DIRECTORY ${CMAKE_CURRENT_SOURCE_DIR}
+ DEPENDS ${haskell_sources}
+ COMMENT "Building Haskell library")
+
+add_custom_target(haskell_library ALL
+ DEPENDS ${haskell_artifacts})
+
+if(BUILD_TESTING)
+ add_test(NAME HaskellCabalCheck
+ COMMAND ${CABAL} check
+ WORKING_DIRECTORY ${CMAKE_CURRENT_SOURCE_DIR})
+ add_test(NAME HaskellCabalTest
+ # Cabal fails to find built executable when --builddir is specified.
+ # So we invoke the executable directly.
+ # COMMAND ${CABAL} test --builddir=${CMAKE_CURRENT_BINARY_DIR}/dist
+ # WORKING_DIRECTORY ${CMAKE_CURRENT_SOURCE_DIR})
+ COMMAND dist/build/spec/spec)
+endif()
diff --git a/src/jaegertracing/thrift/lib/hs/LICENSE b/src/jaegertracing/thrift/lib/hs/LICENSE
new file mode 100644
index 000000000..d64569567
--- /dev/null
+++ b/src/jaegertracing/thrift/lib/hs/LICENSE
@@ -0,0 +1,202 @@
+
+ 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/src/jaegertracing/thrift/lib/hs/Makefile.am b/src/jaegertracing/thrift/lib/hs/Makefile.am
new file mode 100644
index 000000000..ba156a130
--- /dev/null
+++ b/src/jaegertracing/thrift/lib/hs/Makefile.am
@@ -0,0 +1,53 @@
+#
+# Licensed to the Apache Software Foundation (ASF) under one
+# or more contributor license agreements. See the NOTICE file
+# distributed with this work for additional information
+# regarding copyright ownership. The ASF licenses this file
+# to you 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.
+#
+
+EXTRA_DIST = \
+ coding_standards.md \
+ CMakeLists.txt \
+ LICENSE \
+ README.md \
+ Setup.lhs \
+ TODO \
+ thrift.cabal \
+ src \
+ test
+
+all-local:
+ $(CABAL) update
+ $(CABAL) install
+
+install-exec-hook:
+ $(CABAL) install
+
+# Make sure this doesn't fail if Haskell is not configured.
+clean-local:
+ $(CABAL) clean
+
+dist-local:
+ $(CABAL) sdist
+
+maintainer-clean-local:
+ $(CABAL) clean
+
+check-local:
+ $(CABAL) check
+ $(CABAL) install --only-dependencies --enable-tests
+ $(CABAL) configure --enable-tests
+ $(CABAL) build
+ $(CABAL) test
diff --git a/src/jaegertracing/thrift/lib/hs/README.md b/src/jaegertracing/thrift/lib/hs/README.md
new file mode 100644
index 000000000..10bdeff1e
--- /dev/null
+++ b/src/jaegertracing/thrift/lib/hs/README.md
@@ -0,0 +1,113 @@
+Haskell Thrift Bindings
+
+License
+=======
+
+Licensed to the Apache Software Foundation (ASF) under one
+or more contributor license agreements. See the NOTICE file
+distributed with this work for additional information
+regarding copyright ownership. The ASF licenses this file
+to you 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.
+
+Compile
+=======
+
+Use Cabal to compile and install; ./configure uses Cabal underneath, and that
+path is not yet well tested. Thrift's library and generated code should compile
+with pretty much any GHC extensions or warnings you enable (or disable).
+Please report this not being the case as a bug on
+https://issues.apache.org/jira/secure/CreateIssue!default.jspa
+
+Chances you'll need to muck a bit with Cabal flags to install Thrift:
+
+CABAL_CONFIGURE_FLAGS="--user" ./configure
+
+Base Types
+==========
+
+The mapping from Thrift types to Haskell's is:
+
+ * double -> Double
+ * byte -> Data.Int.Int8
+ * i16 -> Data.Int.Int16
+ * i32 -> Data.Int.Int32
+ * i64 -> Data.Int.Int64
+ * string -> Text
+ * binary -> Data.ByteString.Lazy
+ * bool -> Boolean
+
+Enums
+=====
+
+Become Haskell 'data' types. Use fromEnum to get out the int value.
+
+Lists
+=====
+
+Become Data.Vector.Vector from the vector package.
+
+Maps and Sets
+=============
+
+Become Data.HashMap.Strict.Map and Data.HashSet.Set from the
+unordered-containers package.
+
+Structs
+=======
+
+Become records. Field labels are ugly, of the form f_STRUCTNAME_FIELDNAME. All
+fields are Maybe types.
+
+Exceptions
+==========
+
+Identical to structs. Use them with throw and catch from Control.Exception.
+
+Client
+======
+
+Just a bunch of functions. You may have to import a bunch of client files to
+deal with inheritance.
+
+Interface
+=========
+
+You should only have to import the last one in the chain of inheritors. To make
+an interface, declare a label:
+
+ data MyIface = MyIface
+
+and then declare it an instance of each iface class, starting with the superest
+class and proceeding down (all the while defining the methods). Then pass your
+label to process as the handler.
+
+Processor
+=========
+
+Just a function that takes a handler label, protocols. It calls the
+superclasses process if there is a superclass.
+
+Releasing to Hackage
+====================
+
+Using the [Docker Container for Ubuntu Bionic](../../build/docker/README.md), run:
+
+ root@e941f5311545:/thrift/src# ./bootstrap.sh && ./configure
+ root@e941f5311545:/thrift/src# cd lib/hs && make dist-local
+
+This will produce a `lib/hs/dist/thrift-<version>.tar.gz` file. Take this
+file and upload it as a Haskell Hackage
+[package candidate](https://hackage.haskell.org/upload#candidates) and
+check to make sure all the information is correct. Assuming all is satisfactory,
+you can upload the package as official using the link at the top of the page.
diff --git a/src/jaegertracing/thrift/lib/hs/Setup.lhs b/src/jaegertracing/thrift/lib/hs/Setup.lhs
new file mode 100755
index 000000000..d52ae9455
--- /dev/null
+++ b/src/jaegertracing/thrift/lib/hs/Setup.lhs
@@ -0,0 +1,21 @@
+#!/usr/bin/env runhaskell
+
+> -- Licensed to the Apache Software Foundation (ASF) under one
+> -- or more contributor license agreements. See the NOTICE file
+> -- distributed with this work for additional information
+> -- regarding copyright ownership. The ASF licenses this file
+> -- to you 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.
+
+> import Distribution.Simple
+> main = defaultMain
diff --git a/src/jaegertracing/thrift/lib/hs/TODO b/src/jaegertracing/thrift/lib/hs/TODO
new file mode 100644
index 000000000..136817321
--- /dev/null
+++ b/src/jaegertracing/thrift/lib/hs/TODO
@@ -0,0 +1,2 @@
+The library could stand to be built up more.
+Many modules need export lists.
diff --git a/src/jaegertracing/thrift/lib/hs/coding_standards.md b/src/jaegertracing/thrift/lib/hs/coding_standards.md
new file mode 100644
index 000000000..fa0390bb5
--- /dev/null
+++ b/src/jaegertracing/thrift/lib/hs/coding_standards.md
@@ -0,0 +1 @@
+Please follow [General Coding Standards](/doc/coding_standards.md)
diff --git a/src/jaegertracing/thrift/lib/hs/src/Thrift.hs b/src/jaegertracing/thrift/lib/hs/src/Thrift.hs
new file mode 100644
index 000000000..658020991
--- /dev/null
+++ b/src/jaegertracing/thrift/lib/hs/src/Thrift.hs
@@ -0,0 +1,114 @@
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes #-}
+--
+-- Licensed to the Apache Software Foundation (ASF) under one
+-- or more contributor license agreements. See the NOTICE file
+-- distributed with this work for additional information
+-- regarding copyright ownership. The ASF licenses this file
+-- to you 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.
+--
+
+module Thrift
+ ( module Thrift.Transport
+ , module Thrift.Protocol
+ , AppExnType(..)
+ , AppExn(..)
+ , readAppExn
+ , writeAppExn
+ , ThriftException(..)
+ ) where
+
+import Control.Exception
+
+import Data.Int
+import Data.Text.Lazy ( Text, pack, unpack )
+import Data.Text.Lazy.Encoding
+import Data.Typeable ( Typeable )
+import qualified Data.HashMap.Strict as Map
+
+import Thrift.Protocol
+import Thrift.Transport
+import Thrift.Types
+
+data ThriftException = ThriftException
+ deriving ( Show, Typeable )
+instance Exception ThriftException
+
+data AppExnType
+ = AE_UNKNOWN
+ | AE_UNKNOWN_METHOD
+ | AE_INVALID_MESSAGE_TYPE
+ | AE_WRONG_METHOD_NAME
+ | AE_BAD_SEQUENCE_ID
+ | AE_MISSING_RESULT
+ | AE_INTERNAL_ERROR
+ | AE_PROTOCOL_ERROR
+ | AE_INVALID_TRANSFORM
+ | AE_INVALID_PROTOCOL
+ | AE_UNSUPPORTED_CLIENT_TYPE
+ deriving ( Eq, Show, Typeable )
+
+instance Enum AppExnType where
+ toEnum 0 = AE_UNKNOWN
+ toEnum 1 = AE_UNKNOWN_METHOD
+ toEnum 2 = AE_INVALID_MESSAGE_TYPE
+ toEnum 3 = AE_WRONG_METHOD_NAME
+ toEnum 4 = AE_BAD_SEQUENCE_ID
+ toEnum 5 = AE_MISSING_RESULT
+ toEnum 6 = AE_INTERNAL_ERROR
+ toEnum 7 = AE_PROTOCOL_ERROR
+ toEnum 8 = AE_INVALID_TRANSFORM
+ toEnum 9 = AE_INVALID_PROTOCOL
+ toEnum 10 = AE_UNSUPPORTED_CLIENT_TYPE
+ toEnum t = error $ "Invalid AppExnType " ++ show t
+
+ fromEnum AE_UNKNOWN = 0
+ fromEnum AE_UNKNOWN_METHOD = 1
+ fromEnum AE_INVALID_MESSAGE_TYPE = 2
+ fromEnum AE_WRONG_METHOD_NAME = 3
+ fromEnum AE_BAD_SEQUENCE_ID = 4
+ fromEnum AE_MISSING_RESULT = 5
+ fromEnum AE_INTERNAL_ERROR = 6
+ fromEnum AE_PROTOCOL_ERROR = 7
+ fromEnum AE_INVALID_TRANSFORM = 8
+ fromEnum AE_INVALID_PROTOCOL = 9
+ fromEnum AE_UNSUPPORTED_CLIENT_TYPE = 10
+
+data AppExn = AppExn { ae_type :: AppExnType, ae_message :: String }
+ deriving ( Show, Typeable )
+instance Exception AppExn
+
+writeAppExn :: Protocol p => p -> AppExn -> IO ()
+writeAppExn pt ae = writeVal pt $ TStruct $ Map.fromList
+ [ (1, ("message", TString $ encodeUtf8 $ pack $ ae_message ae))
+ , (2, ("type", TI32 $ fromIntegral $ fromEnum (ae_type ae)))
+ ]
+
+readAppExn :: Protocol p => p -> IO AppExn
+readAppExn pt = do
+ let typemap = Map.fromList [(1,("message",T_STRING)),(2,("type",T_I32))]
+ TStruct fields <- readVal pt $ T_STRUCT typemap
+ return $ readAppExnFields fields
+
+readAppExnFields :: Map.HashMap Int16 (Text, ThriftVal) -> AppExn
+readAppExnFields fields = AppExn{
+ ae_message = maybe undefined unwrapMessage $ Map.lookup 1 fields,
+ ae_type = maybe undefined unwrapType $ Map.lookup 2 fields
+ }
+ where
+ unwrapMessage (_, TString s) = unpack $ decodeUtf8 s
+ unwrapMessage _ = undefined
+ unwrapType (_, TI32 i) = toEnum $ fromIntegral i
+ unwrapType _ = undefined
diff --git a/src/jaegertracing/thrift/lib/hs/src/Thrift/Arbitraries.hs b/src/jaegertracing/thrift/lib/hs/src/Thrift/Arbitraries.hs
new file mode 100644
index 000000000..e9c0fc3ee
--- /dev/null
+++ b/src/jaegertracing/thrift/lib/hs/src/Thrift/Arbitraries.hs
@@ -0,0 +1,55 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Thrift.Arbitraries where
+
+import Data.Bits()
+
+import Test.QuickCheck.Arbitrary
+
+import Control.Applicative ((<$>))
+import Data.Map (Map)
+import qualified Data.Map as Map
+import qualified Data.Set as Set
+import qualified Data.Vector as Vector
+import qualified Data.Text.Lazy as Text
+import qualified Data.HashSet as HSet
+import qualified Data.HashMap.Strict as HMap
+import Data.Hashable (Hashable)
+
+import Data.ByteString.Lazy (ByteString)
+import qualified Data.ByteString.Lazy as BS
+
+-- String has an Arbitrary instance already
+-- Bool has an Arbitrary instance already
+-- A Thrift 'list' is a Vector.
+
+instance Arbitrary ByteString where
+ arbitrary = BS.pack . filter (/= 0) <$> arbitrary
+
+instance (Arbitrary k) => Arbitrary (Vector.Vector k) where
+ arbitrary = Vector.fromList <$> arbitrary
+
+instance Arbitrary Text.Text where
+ arbitrary = Text.pack . filter (/= '\0') <$> arbitrary
+
+instance (Eq k, Hashable k, Arbitrary k) => Arbitrary (HSet.HashSet k) where
+ arbitrary = HSet.fromList <$> arbitrary
+
+instance (Eq k, Hashable k, Arbitrary k, Arbitrary v) =>
+ Arbitrary (HMap.HashMap k v) where
+ arbitrary = HMap.fromList <$> arbitrary
+
+{-
+ To handle Thrift 'enum' we would ideally use something like:
+
+instance (Enum a, Bounded a) => Arbitrary a
+ where arbitrary = elements (enumFromTo minBound maxBound)
+
+Unfortunately this doesn't play nicely with the type system.
+Instead we'll generate an arbitrary instance along with the code.
+-}
+
+{-
+ There might be some way to introspect on the Haskell structure of a
+ Thrift 'struct' or 'exception' but generating the code directly is simpler.
+-}
diff --git a/src/jaegertracing/thrift/lib/hs/src/Thrift/Protocol.hs b/src/jaegertracing/thrift/lib/hs/src/Thrift/Protocol.hs
new file mode 100644
index 000000000..67a9175cb
--- /dev/null
+++ b/src/jaegertracing/thrift/lib/hs/src/Thrift/Protocol.hs
@@ -0,0 +1,136 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE OverloadedStrings #-}
+--
+-- Licensed to the Apache Software Foundation (ASF) under one
+-- or more contributor license agreements. See the NOTICE file
+-- distributed with this work for additional information
+-- regarding copyright ownership. The ASF licenses this file
+-- to you 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.
+--
+
+module Thrift.Protocol
+ ( Protocol(..)
+ , StatelessProtocol(..)
+ , ProtocolExn(..)
+ , ProtocolExnType(..)
+ , getTypeOf
+ , runParser
+ , bsToDouble
+ , bsToDoubleLE
+ ) where
+
+import Control.Exception
+import Data.Attoparsec.ByteString
+import Data.Bits
+import Data.ByteString.Unsafe
+import Data.Functor ((<$>))
+import Data.Int
+import Data.Monoid (mempty)
+import Data.Text.Lazy (Text)
+import Data.Typeable (Typeable)
+import Data.Word
+import Foreign.Ptr (castPtr)
+import Foreign.Storable (peek, poke)
+import System.IO.Unsafe
+import qualified Data.ByteString as BS
+import qualified Data.HashMap.Strict as Map
+import qualified Data.ByteString.Lazy as LBS
+
+import Thrift.Transport
+import Thrift.Types
+
+class Protocol a where
+ readByte :: a -> IO LBS.ByteString
+ readVal :: a -> ThriftType -> IO ThriftVal
+ readMessage :: a -> ((Text, MessageType, Int32) -> IO b) -> IO b
+
+ writeVal :: a -> ThriftVal -> IO ()
+ writeMessage :: a -> (Text, MessageType, Int32) -> IO () -> IO ()
+
+class Protocol a => StatelessProtocol a where
+ serializeVal :: a -> ThriftVal -> LBS.ByteString
+ deserializeVal :: a -> ThriftType -> LBS.ByteString -> ThriftVal
+
+data ProtocolExnType
+ = PE_UNKNOWN
+ | PE_INVALID_DATA
+ | PE_NEGATIVE_SIZE
+ | PE_SIZE_LIMIT
+ | PE_BAD_VERSION
+ | PE_NOT_IMPLEMENTED
+ | PE_MISSING_REQUIRED_FIELD
+ deriving ( Eq, Show, Typeable )
+
+data ProtocolExn = ProtocolExn ProtocolExnType String
+ deriving ( Show, Typeable )
+instance Exception ProtocolExn
+
+getTypeOf :: ThriftVal -> ThriftType
+getTypeOf v = case v of
+ TStruct{} -> T_STRUCT Map.empty
+ TMap{} -> T_MAP T_VOID T_VOID
+ TList{} -> T_LIST T_VOID
+ TSet{} -> T_SET T_VOID
+ TBool{} -> T_BOOL
+ TByte{} -> T_BYTE
+ TI16{} -> T_I16
+ TI32{} -> T_I32
+ TI64{} -> T_I64
+ TString{} -> T_STRING
+ TBinary{} -> T_BINARY
+ TDouble{} -> T_DOUBLE
+
+runParser :: (Protocol p, Show a) => p -> Parser a -> IO a
+runParser prot p = refill >>= getResult . parse p
+ where
+ refill = handle handleEOF $ LBS.toStrict <$> readByte prot
+ getResult (Done _ a) = return a
+ getResult (Partial k) = refill >>= getResult . k
+ getResult f = throw $ ProtocolExn PE_INVALID_DATA (show f)
+
+handleEOF :: SomeException -> IO BS.ByteString
+handleEOF = const $ return mempty
+
+-- | Converts a ByteString to a Floating point number
+-- The ByteString is assumed to be encoded in network order (Big Endian)
+-- therefore the behavior of this function varies based on whether the local
+-- machine is big endian or little endian.
+bsToDouble :: BS.ByteString -> Double
+bsToDoubleLE :: BS.ByteString -> Double
+#if __BYTE_ORDER == __LITTLE_ENDIAN
+bsToDouble bs = unsafeDupablePerformIO $ unsafeUseAsCString bs castBsSwapped
+bsToDoubleLE bs = unsafeDupablePerformIO $ unsafeUseAsCString bs castBs
+#else
+bsToDouble bs = unsafeDupablePerformIO $ unsafeUseAsCString bs castBs
+bsToDoubleLE bs = unsafeDupablePerformIO $ unsafeUseAsCString bs castBsSwapped
+#endif
+
+
+castBsSwapped chrPtr = do
+ w <- peek (castPtr chrPtr)
+ poke (castPtr chrPtr) (byteSwap w)
+ peek (castPtr chrPtr)
+castBs = peek . castPtr
+
+-- | Swap endianness of a 64-bit word
+byteSwap :: Word64 -> Word64
+byteSwap w = (w `shiftL` 56 .&. 0xFF00000000000000) .|.
+ (w `shiftL` 40 .&. 0x00FF000000000000) .|.
+ (w `shiftL` 24 .&. 0x0000FF0000000000) .|.
+ (w `shiftL` 8 .&. 0x000000FF00000000) .|.
+ (w `shiftR` 8 .&. 0x00000000FF000000) .|.
+ (w `shiftR` 24 .&. 0x0000000000FF0000) .|.
+ (w `shiftR` 40 .&. 0x000000000000FF00) .|.
+ (w `shiftR` 56 .&. 0x00000000000000FF)
diff --git a/src/jaegertracing/thrift/lib/hs/src/Thrift/Protocol/Binary.hs b/src/jaegertracing/thrift/lib/hs/src/Thrift/Protocol/Binary.hs
new file mode 100644
index 000000000..7b0acd9d4
--- /dev/null
+++ b/src/jaegertracing/thrift/lib/hs/src/Thrift/Protocol/Binary.hs
@@ -0,0 +1,212 @@
+--
+-- Licensed to the Apache Software Foundation (ASF) under one
+-- or more contributor license agreements. See the NOTICE file
+-- distributed with this work for additional information
+-- regarding copyright ownership. The ASF licenses this file
+-- to you 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.
+--
+
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Thrift.Protocol.Binary
+ ( module Thrift.Protocol
+ , BinaryProtocol(..)
+ , versionMask
+ , version1
+ ) where
+
+import Control.Exception ( throw )
+import Control.Monad
+import Data.Bits
+import Data.ByteString.Lazy.Builder
+import Data.Functor
+import Data.Int
+import Data.Monoid
+import Data.Text.Lazy.Encoding ( decodeUtf8, encodeUtf8 )
+import Data.Word
+
+import Thrift.Protocol
+import Thrift.Transport
+import Thrift.Types
+
+import qualified Data.Attoparsec.ByteString as P
+import qualified Data.Attoparsec.ByteString.Lazy as LP
+import qualified Data.Binary as Binary
+import qualified Data.ByteString.Lazy as LBS
+import qualified Data.HashMap.Strict as Map
+import qualified Data.Text.Lazy as LT
+
+versionMask :: Int32
+versionMask = fromIntegral (0xffff0000 :: Word32)
+
+version1 :: Int32
+version1 = fromIntegral (0x80010000 :: Word32)
+
+data BinaryProtocol a = Transport a => BinaryProtocol a
+
+getTransport :: Transport t => BinaryProtocol t -> t
+getTransport (BinaryProtocol t) = t
+
+-- NOTE: Reading and Writing functions rely on Builders and Data.Binary to
+-- encode and decode data. Data.Binary assumes that the binary values it is
+-- encoding to and decoding from are in BIG ENDIAN format, and converts the
+-- endianness as necessary to match the local machine.
+instance Transport t => Protocol (BinaryProtocol t) where
+ readByte p = tReadAll (getTransport p) 1
+ -- flushTransport p = tFlush (getTransport p)
+ writeMessage p (n, t, s) f = do
+ tWrite (getTransport p) messageBegin
+ f
+ tFlush $ getTransport p
+ where
+ messageBegin = toLazyByteString $
+ buildBinaryValue (TI32 (version1 .|. fromIntegral (fromEnum t))) <>
+ buildBinaryValue (TString $ encodeUtf8 n) <>
+ buildBinaryValue (TI32 s)
+
+ readMessage p = (readMessageBegin p >>=)
+ where
+ readMessageBegin p = runParser p $ do
+ TI32 ver <- parseBinaryValue T_I32
+ if ver .&. versionMask /= version1
+ then throw $ ProtocolExn PE_BAD_VERSION "Missing version identifier"
+ else do
+ TString s <- parseBinaryValue T_STRING
+ TI32 sz <- parseBinaryValue T_I32
+ return (decodeUtf8 s, toEnum $ fromIntegral $ ver .&. 0xFF, sz)
+
+ writeVal p = tWrite (getTransport p) . toLazyByteString . buildBinaryValue
+ readVal p = runParser p . parseBinaryValue
+
+instance Transport t => StatelessProtocol (BinaryProtocol t) where
+ serializeVal _ = toLazyByteString . buildBinaryValue
+ deserializeVal _ ty bs =
+ case LP.eitherResult $ LP.parse (parseBinaryValue ty) bs of
+ Left s -> error s
+ Right val -> val
+
+-- | Writing Functions
+buildBinaryValue :: ThriftVal -> Builder
+buildBinaryValue (TStruct fields) = buildBinaryStruct fields <> buildType T_STOP
+buildBinaryValue (TMap ky vt entries) =
+ buildType ky <>
+ buildType vt <>
+ int32BE (fromIntegral (length entries)) <>
+ buildBinaryMap entries
+buildBinaryValue (TList ty entries) =
+ buildType ty <>
+ int32BE (fromIntegral (length entries)) <>
+ buildBinaryList entries
+buildBinaryValue (TSet ty entries) =
+ buildType ty <>
+ int32BE (fromIntegral (length entries)) <>
+ buildBinaryList entries
+buildBinaryValue (TBool b) =
+ word8 $ toEnum $ if b then 1 else 0
+buildBinaryValue (TByte b) = int8 b
+buildBinaryValue (TI16 i) = int16BE i
+buildBinaryValue (TI32 i) = int32BE i
+buildBinaryValue (TI64 i) = int64BE i
+buildBinaryValue (TDouble d) = doubleBE d
+buildBinaryValue (TString s) = int32BE len <> lazyByteString s
+ where
+ len :: Int32 = fromIntegral (LBS.length s)
+buildBinaryValue (TBinary s) = buildBinaryValue (TString s)
+
+buildBinaryStruct :: Map.HashMap Int16 (LT.Text, ThriftVal) -> Builder
+buildBinaryStruct = Map.foldrWithKey combine mempty
+ where
+ combine fid (_,val) s =
+ buildTypeOf val <> int16BE fid <> buildBinaryValue val <> s
+
+buildBinaryMap :: [(ThriftVal, ThriftVal)] -> Builder
+buildBinaryMap = foldl combine mempty
+ where
+ combine s (key, val) = s <> buildBinaryValue key <> buildBinaryValue val
+
+buildBinaryList :: [ThriftVal] -> Builder
+buildBinaryList = foldr (mappend . buildBinaryValue) mempty
+
+-- | Reading Functions
+parseBinaryValue :: ThriftType -> P.Parser ThriftVal
+parseBinaryValue (T_STRUCT tmap) = TStruct <$> parseBinaryStruct tmap
+parseBinaryValue (T_MAP _ _) = do
+ kt <- parseType
+ vt <- parseType
+ n <- Binary.decode . LBS.fromStrict <$> P.take 4
+ TMap kt vt <$> parseBinaryMap kt vt n
+parseBinaryValue (T_LIST _) = do
+ t <- parseType
+ n <- Binary.decode . LBS.fromStrict <$> P.take 4
+ TList t <$> parseBinaryList t n
+parseBinaryValue (T_SET _) = do
+ t <- parseType
+ n <- Binary.decode . LBS.fromStrict <$> P.take 4
+ TSet t <$> parseBinaryList t n
+parseBinaryValue T_BOOL = TBool . (/=0) <$> P.anyWord8
+parseBinaryValue T_BYTE = TByte . Binary.decode . LBS.fromStrict <$> P.take 1
+parseBinaryValue T_I16 = TI16 . Binary.decode . LBS.fromStrict <$> P.take 2
+parseBinaryValue T_I32 = TI32 . Binary.decode . LBS.fromStrict <$> P.take 4
+parseBinaryValue T_I64 = TI64 . Binary.decode . LBS.fromStrict <$> P.take 8
+parseBinaryValue T_DOUBLE = TDouble . bsToDouble <$> P.take 8
+parseBinaryValue T_STRING = parseBinaryString TString
+parseBinaryValue T_BINARY = parseBinaryString TBinary
+parseBinaryValue ty = error $ "Cannot read value of type " ++ show ty
+
+parseBinaryString ty = do
+ i :: Int32 <- Binary.decode . LBS.fromStrict <$> P.take 4
+ ty . LBS.fromStrict <$> P.take (fromIntegral i)
+
+parseBinaryStruct :: TypeMap -> P.Parser (Map.HashMap Int16 (LT.Text, ThriftVal))
+parseBinaryStruct tmap = Map.fromList <$> P.manyTill parseField (matchType T_STOP)
+ where
+ parseField = do
+ t <- parseType
+ n <- Binary.decode . LBS.fromStrict <$> P.take 2
+ v <- case (t, Map.lookup n tmap) of
+ (T_STRING, Just (_, T_BINARY)) -> parseBinaryValue T_BINARY
+ _ -> parseBinaryValue t
+ return (n, ("", v))
+
+parseBinaryMap :: ThriftType -> ThriftType -> Int32 -> P.Parser [(ThriftVal, ThriftVal)]
+parseBinaryMap kt vt n | n <= 0 = return []
+ | otherwise = do
+ k <- parseBinaryValue kt
+ v <- parseBinaryValue vt
+ ((k,v) :) <$> parseBinaryMap kt vt (n-1)
+
+parseBinaryList :: ThriftType -> Int32 -> P.Parser [ThriftVal]
+parseBinaryList ty n | n <= 0 = return []
+ | otherwise = liftM2 (:) (parseBinaryValue ty)
+ (parseBinaryList ty (n-1))
+
+
+
+-- | Write a type as a byte
+buildType :: ThriftType -> Builder
+buildType t = word8 $ fromIntegral $ fromEnum t
+
+-- | Write type of a ThriftVal as a byte
+buildTypeOf :: ThriftVal -> Builder
+buildTypeOf = buildType . getTypeOf
+
+-- | Read a byte as though it were a ThriftType
+parseType :: P.Parser ThriftType
+parseType = toEnum . fromIntegral <$> P.anyWord8
+
+matchType :: ThriftType -> P.Parser ThriftType
+matchType t = t <$ P.word8 (fromIntegral $ fromEnum t)
diff --git a/src/jaegertracing/thrift/lib/hs/src/Thrift/Protocol/Compact.hs b/src/jaegertracing/thrift/lib/hs/src/Thrift/Protocol/Compact.hs
new file mode 100644
index 000000000..f23970a82
--- /dev/null
+++ b/src/jaegertracing/thrift/lib/hs/src/Thrift/Protocol/Compact.hs
@@ -0,0 +1,311 @@
+--
+-- Licensed to the Apache Software Foundation (ASF) under one
+-- or more contributor license agreements. See the NOTICE file
+-- distributed with this work for additional information
+-- regarding copyright ownership. The ASF licenses this file
+-- to you 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.
+--
+
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Thrift.Protocol.Compact
+ ( module Thrift.Protocol
+ , CompactProtocol(..)
+ , parseVarint
+ , buildVarint
+ ) where
+
+import Control.Applicative
+import Control.Monad
+import Data.Attoparsec.ByteString as P
+import Data.Attoparsec.ByteString.Lazy as LP
+import Data.Bits
+import Data.ByteString.Lazy.Builder as B
+import Data.Int
+import Data.List as List
+import Data.Monoid
+import Data.Word
+import Data.Text.Lazy.Encoding ( decodeUtf8, encodeUtf8 )
+
+import Thrift.Protocol
+import Thrift.Transport
+import Thrift.Types
+
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Lazy as LBS
+import qualified Data.HashMap.Strict as Map
+import qualified Data.Text.Lazy as LT
+
+-- | the Compact Protocol implements the standard Thrift 'TCompactProcotol'
+-- which is similar to the 'TBinaryProtocol', but takes less space on the wire.
+-- Integral types are encoded using as varints.
+data CompactProtocol a = CompactProtocol a
+ -- ^ Constuct a 'CompactProtocol' with a 'Transport'
+
+protocolID, version, versionMask, typeMask, typeBits :: Word8
+protocolID = 0x82 -- 1000 0010
+version = 0x01
+versionMask = 0x1f -- 0001 1111
+typeMask = 0xe0 -- 1110 0000
+typeBits = 0x07 -- 0000 0111
+typeShiftAmount :: Int
+typeShiftAmount = 5
+
+getTransport :: Transport t => CompactProtocol t -> t
+getTransport (CompactProtocol t) = t
+
+instance Transport t => Protocol (CompactProtocol t) where
+ readByte p = tReadAll (getTransport p) 1
+ writeMessage p (n, t, s) f = do
+ tWrite (getTransport p) messageBegin
+ f
+ tFlush $ getTransport p
+ where
+ messageBegin = toLazyByteString $
+ B.word8 protocolID <>
+ B.word8 ((version .&. versionMask) .|.
+ (((fromIntegral $ fromEnum t) `shiftL`
+ typeShiftAmount) .&. typeMask)) <>
+ buildVarint (i32ToZigZag s) <>
+ buildCompactValue (TString $ encodeUtf8 n)
+
+ readMessage p f = readMessageBegin >>= f
+ where
+ readMessageBegin = runParser p $ do
+ pid <- fromIntegral <$> P.anyWord8
+ when (pid /= protocolID) $ error "Bad Protocol ID"
+ w <- fromIntegral <$> P.anyWord8
+ let ver = w .&. versionMask
+ when (ver /= version) $ error "Bad Protocol version"
+ let typ = (w `shiftR` typeShiftAmount) .&. typeBits
+ seqId <- parseVarint zigZagToI32
+ TString name <- parseCompactValue T_STRING
+ return (decodeUtf8 name, toEnum $ fromIntegral $ typ, seqId)
+
+ writeVal p = tWrite (getTransport p) . toLazyByteString . buildCompactValue
+ readVal p ty = runParser p $ parseCompactValue ty
+
+instance Transport t => StatelessProtocol (CompactProtocol t) where
+ serializeVal _ = toLazyByteString . buildCompactValue
+ deserializeVal _ ty bs =
+ case LP.eitherResult $ LP.parse (parseCompactValue ty) bs of
+ Left s -> error s
+ Right val -> val
+
+-- | Writing Functions
+buildCompactValue :: ThriftVal -> Builder
+buildCompactValue (TStruct fields) = buildCompactStruct fields
+buildCompactValue (TMap kt vt entries) =
+ let len = fromIntegral $ length entries :: Word32 in
+ if len == 0
+ then B.word8 0x00
+ else buildVarint len <>
+ B.word8 (fromTType kt `shiftL` 4 .|. fromTType vt) <>
+ buildCompactMap entries
+buildCompactValue (TList ty entries) =
+ let len = length entries in
+ (if len < 15
+ then B.word8 $ (fromIntegral len `shiftL` 4) .|. fromTType ty
+ else B.word8 (0xF0 .|. fromTType ty) <>
+ buildVarint (fromIntegral len :: Word32)) <>
+ buildCompactList entries
+buildCompactValue (TSet ty entries) = buildCompactValue (TList ty entries)
+buildCompactValue (TBool b) =
+ B.word8 $ toEnum $ if b then 1 else 0
+buildCompactValue (TByte b) = int8 b
+buildCompactValue (TI16 i) = buildVarint $ i16ToZigZag i
+buildCompactValue (TI32 i) = buildVarint $ i32ToZigZag i
+buildCompactValue (TI64 i) = buildVarint $ i64ToZigZag i
+buildCompactValue (TDouble d) = doubleLE d
+buildCompactValue (TString s) = buildVarint len <> lazyByteString s
+ where
+ len = fromIntegral (LBS.length s) :: Word32
+buildCompactValue (TBinary s) = buildCompactValue (TString s)
+
+buildCompactStruct :: Map.HashMap Int16 (LT.Text, ThriftVal) -> Builder
+buildCompactStruct = flip (loop 0) mempty . Map.toList
+ where
+ loop _ [] acc = acc <> B.word8 (fromTType T_STOP)
+ loop lastId ((fid, (_,val)) : fields) acc = loop fid fields $ acc <>
+ (if fid > lastId && fid - lastId <= 15
+ then B.word8 $ fromIntegral ((fid - lastId) `shiftL` 4) .|. typeOf val
+ else B.word8 (typeOf val) <> buildVarint (i16ToZigZag fid)) <>
+ (if typeOf val > 0x02 -- Not a T_BOOL
+ then buildCompactValue val
+ else mempty) -- T_BOOLs are encoded in the type
+buildCompactMap :: [(ThriftVal, ThriftVal)] -> Builder
+buildCompactMap = foldl combine mempty
+ where
+ combine s (key, val) = buildCompactValue key <> buildCompactValue val <> s
+
+buildCompactList :: [ThriftVal] -> Builder
+buildCompactList = foldr (mappend . buildCompactValue) mempty
+
+-- | Reading Functions
+parseCompactValue :: ThriftType -> Parser ThriftVal
+parseCompactValue (T_STRUCT tmap) = TStruct <$> parseCompactStruct tmap
+parseCompactValue (T_MAP kt' vt') = do
+ n <- parseVarint id
+ if n == 0
+ then return $ TMap kt' vt' []
+ else do
+ w <- P.anyWord8
+ let kt = typeFrom $ w `shiftR` 4
+ vt = typeFrom $ w .&. 0x0F
+ TMap kt vt <$> parseCompactMap kt vt n
+parseCompactValue (T_LIST ty) = TList ty <$> parseCompactList
+parseCompactValue (T_SET ty) = TSet ty <$> parseCompactList
+parseCompactValue T_BOOL = TBool . (/=0) <$> P.anyWord8
+parseCompactValue T_BYTE = TByte . fromIntegral <$> P.anyWord8
+parseCompactValue T_I16 = TI16 <$> parseVarint zigZagToI16
+parseCompactValue T_I32 = TI32 <$> parseVarint zigZagToI32
+parseCompactValue T_I64 = TI64 <$> parseVarint zigZagToI64
+parseCompactValue T_DOUBLE = TDouble . bsToDoubleLE <$> P.take 8
+parseCompactValue T_STRING = parseCompactString TString
+parseCompactValue T_BINARY = parseCompactString TBinary
+parseCompactValue ty = error $ "Cannot read value of type " ++ show ty
+
+parseCompactString ty = do
+ len :: Word32 <- parseVarint id
+ ty . LBS.fromStrict <$> P.take (fromIntegral len)
+
+parseCompactStruct :: TypeMap -> Parser (Map.HashMap Int16 (LT.Text, ThriftVal))
+parseCompactStruct tmap = Map.fromList <$> parseFields 0
+ where
+ parseFields :: Int16 -> Parser [(Int16, (LT.Text, ThriftVal))]
+ parseFields lastId = do
+ w <- P.anyWord8
+ if w == 0x00
+ then return []
+ else do
+ let ty = typeFrom (w .&. 0x0F)
+ modifier = (w .&. 0xF0) `shiftR` 4
+ fid <- if modifier /= 0
+ then return (lastId + fromIntegral modifier)
+ else parseVarint zigZagToI16
+ val <- if ty == T_BOOL
+ then return (TBool $ (w .&. 0x0F) == 0x01)
+ else case (ty, Map.lookup fid tmap) of
+ (T_STRING, Just (_, T_BINARY)) -> parseCompactValue T_BINARY
+ _ -> parseCompactValue ty
+ ((fid, (LT.empty, val)) : ) <$> parseFields fid
+
+parseCompactMap :: ThriftType -> ThriftType -> Int32 ->
+ Parser [(ThriftVal, ThriftVal)]
+parseCompactMap kt vt n | n <= 0 = return []
+ | otherwise = do
+ k <- parseCompactValue kt
+ v <- parseCompactValue vt
+ ((k,v) :) <$> parseCompactMap kt vt (n-1)
+
+parseCompactList :: Parser [ThriftVal]
+parseCompactList = do
+ w <- P.anyWord8
+ let ty = typeFrom $ w .&. 0x0F
+ lsize = w `shiftR` 4
+ size <- if lsize == 0xF
+ then parseVarint id
+ else return $ fromIntegral lsize
+ loop ty size
+ where
+ loop :: ThriftType -> Int32 -> Parser [ThriftVal]
+ loop ty n | n <= 0 = return []
+ | otherwise = liftM2 (:) (parseCompactValue ty)
+ (loop ty (n-1))
+
+-- Signed numbers must be converted to "Zig Zag" format before they can be
+-- serialized in the Varint format
+i16ToZigZag :: Int16 -> Word16
+i16ToZigZag n = fromIntegral $ (n `shiftL` 1) `xor` (n `shiftR` 15)
+
+zigZagToI16 :: Word16 -> Int16
+zigZagToI16 n = fromIntegral $ (n `shiftR` 1) `xor` negate (n .&. 0x1)
+
+i32ToZigZag :: Int32 -> Word32
+i32ToZigZag n = fromIntegral $ (n `shiftL` 1) `xor` (n `shiftR` 31)
+
+zigZagToI32 :: Word32 -> Int32
+zigZagToI32 n = fromIntegral $ (n `shiftR` 1) `xor` negate (n .&. 0x1)
+
+i64ToZigZag :: Int64 -> Word64
+i64ToZigZag n = fromIntegral $ (n `shiftL` 1) `xor` (n `shiftR` 63)
+
+zigZagToI64 :: Word64 -> Int64
+zigZagToI64 n = fromIntegral $ (n `shiftR` 1) `xor` negate (n .&. 0x1)
+
+buildVarint :: (Bits a, Integral a) => a -> Builder
+buildVarint n | n .&. complement 0x7F == 0 = B.word8 $ fromIntegral n
+ | otherwise = B.word8 (0x80 .|. (fromIntegral n .&. 0x7F)) <>
+ buildVarint (n `shiftR` 7)
+
+parseVarint :: (Bits a, Integral a, Ord a) => (a -> b) -> Parser b
+parseVarint fromZigZag = do
+ bytestemp <- BS.unpack <$> P.takeTill (not . flip testBit 7)
+ lsb <- P.anyWord8
+ let bytes = lsb : List.reverse bytestemp
+ return $ fromZigZag $ List.foldl' combine 0x00 bytes
+ where combine a b = (a `shiftL` 7) .|. (fromIntegral b .&. 0x7f)
+
+-- | Compute the Compact Type
+fromTType :: ThriftType -> Word8
+fromTType ty = case ty of
+ T_STOP -> 0x00
+ T_BOOL -> 0x01
+ T_BYTE -> 0x03
+ T_I16 -> 0x04
+ T_I32 -> 0x05
+ T_I64 -> 0x06
+ T_DOUBLE -> 0x07
+ T_STRING -> 0x08
+ T_BINARY -> 0x08
+ T_LIST{} -> 0x09
+ T_SET{} -> 0x0A
+ T_MAP{} -> 0x0B
+ T_STRUCT{} -> 0x0C
+ T_VOID -> error "No Compact type for T_VOID"
+
+typeOf :: ThriftVal -> Word8
+typeOf v = case v of
+ TBool True -> 0x01
+ TBool False -> 0x02
+ TByte _ -> 0x03
+ TI16 _ -> 0x04
+ TI32 _ -> 0x05
+ TI64 _ -> 0x06
+ TDouble _ -> 0x07
+ TString _ -> 0x08
+ TBinary _ -> 0x08
+ TList{} -> 0x09
+ TSet{} -> 0x0A
+ TMap{} -> 0x0B
+ TStruct{} -> 0x0C
+
+typeFrom :: Word8 -> ThriftType
+typeFrom w = case w of
+ 0x01 -> T_BOOL
+ 0x02 -> T_BOOL
+ 0x03 -> T_BYTE
+ 0x04 -> T_I16
+ 0x05 -> T_I32
+ 0x06 -> T_I64
+ 0x07 -> T_DOUBLE
+ 0x08 -> T_STRING
+ 0x09 -> T_LIST T_VOID
+ 0x0A -> T_SET T_VOID
+ 0x0B -> T_MAP T_VOID T_VOID
+ 0x0C -> T_STRUCT Map.empty
+ n -> error $ "typeFrom: " ++ show n ++ " is not a compact type"
diff --git a/src/jaegertracing/thrift/lib/hs/src/Thrift/Protocol/Header.hs b/src/jaegertracing/thrift/lib/hs/src/Thrift/Protocol/Header.hs
new file mode 100644
index 000000000..5f42db45d
--- /dev/null
+++ b/src/jaegertracing/thrift/lib/hs/src/Thrift/Protocol/Header.hs
@@ -0,0 +1,141 @@
+--
+-- Licensed to the Apache Software Foundation (ASF) under one
+-- or more contributor license agreements. See the NOTICE file
+-- distributed with this work for additional information
+-- regarding copyright ownership. The ASF licenses this file
+-- to you 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.
+--
+
+
+module Thrift.Protocol.Header
+ ( module Thrift.Protocol
+ , HeaderProtocol(..)
+ , getProtocolType
+ , setProtocolType
+ , getHeaders
+ , getWriteHeaders
+ , setHeader
+ , setHeaders
+ , createHeaderProtocol
+ , createHeaderProtocol1
+ ) where
+
+import Thrift.Protocol
+import Thrift.Protocol.Binary
+import Thrift.Protocol.JSON
+import Thrift.Protocol.Compact
+import Thrift.Transport
+import Thrift.Transport.Header
+import Data.IORef
+import qualified Data.Map as Map
+
+data ProtocolWrap = forall a. (Protocol a) => ProtocolWrap(a)
+
+instance Protocol ProtocolWrap where
+ readByte (ProtocolWrap p) = readByte p
+ readVal (ProtocolWrap p) = readVal p
+ readMessage (ProtocolWrap p) = readMessage p
+ writeVal (ProtocolWrap p) = writeVal p
+ writeMessage (ProtocolWrap p) = writeMessage p
+
+data HeaderProtocol i o = (Transport i, Transport o) => HeaderProtocol {
+ trans :: HeaderTransport i o,
+ wrappedProto :: IORef ProtocolWrap
+ }
+
+createProtocolWrap :: Transport t => ProtocolType -> t -> ProtocolWrap
+createProtocolWrap typ t =
+ case typ of
+ TBinary -> ProtocolWrap $ BinaryProtocol t
+ TCompact -> ProtocolWrap $ CompactProtocol t
+ TJSON -> ProtocolWrap $ JSONProtocol t
+
+createHeaderProtocol :: (Transport i, Transport o) => i -> o -> IO(HeaderProtocol i o)
+createHeaderProtocol i o = do
+ t <- openHeaderTransport i o
+ pid <- readIORef $ protocolType t
+ proto <- newIORef $ createProtocolWrap pid t
+ return $ HeaderProtocol { trans = t, wrappedProto = proto }
+
+createHeaderProtocol1 :: Transport t => t -> IO(HeaderProtocol t t)
+createHeaderProtocol1 t = createHeaderProtocol t t
+
+resetProtocol :: (Transport i, Transport o) => HeaderProtocol i o -> IO ()
+resetProtocol p = do
+ pid <- readIORef $ protocolType $ trans p
+ writeIORef (wrappedProto p) $ createProtocolWrap pid $ trans p
+
+getWrapped = readIORef . wrappedProto
+
+setTransport :: (Transport i, Transport o) => HeaderProtocol i o -> HeaderTransport i o -> HeaderProtocol i o
+setTransport p t = p { trans = t }
+
+updateTransport :: (Transport i, Transport o) => HeaderProtocol i o -> (HeaderTransport i o -> HeaderTransport i o)-> HeaderProtocol i o
+updateTransport p f = setTransport p (f $ trans p)
+
+type Headers = Map.Map String String
+
+-- TODO: we want to set headers without recreating client...
+setHeader :: (Transport i, Transport o) => HeaderProtocol i o -> String -> String -> HeaderProtocol i o
+setHeader p k v = updateTransport p $ \t -> t { writeHeaders = Map.insert k v $ writeHeaders t }
+
+setHeaders :: (Transport i, Transport o) => HeaderProtocol i o -> Headers -> HeaderProtocol i o
+setHeaders p h = updateTransport p $ \t -> t { writeHeaders = h }
+
+-- TODO: make it public once we have first transform implementation for Haskell
+setTransforms :: (Transport i, Transport o) => HeaderProtocol i o -> [TransformType] -> HeaderProtocol i o
+setTransforms p trs = updateTransport p $ \t -> t { writeTransforms = trs }
+
+setTransform :: (Transport i, Transport o) => HeaderProtocol i o -> TransformType -> HeaderProtocol i o
+setTransform p tr = updateTransport p $ \t -> t { writeTransforms = tr:(writeTransforms t) }
+
+getWriteHeaders :: (Transport i, Transport o) => HeaderProtocol i o -> Headers
+getWriteHeaders = writeHeaders . trans
+
+getHeaders :: (Transport i, Transport o) => HeaderProtocol i o -> IO [(String, String)]
+getHeaders = readIORef . headers . trans
+
+getProtocolType :: (Transport i, Transport o) => HeaderProtocol i o -> IO ProtocolType
+getProtocolType p = readIORef $ protocolType $ trans p
+
+setProtocolType :: (Transport i, Transport o) => HeaderProtocol i o -> ProtocolType -> IO ()
+setProtocolType p typ = do
+ typ0 <- getProtocolType p
+ if typ == typ0
+ then return ()
+ else do
+ tSetProtocol (trans p) typ
+ resetProtocol p
+
+instance (Transport i, Transport o) => Protocol (HeaderProtocol i o) where
+ readByte p = tReadAll (trans p) 1
+
+ readVal p tp = do
+ proto <- getWrapped p
+ readVal proto tp
+
+ readMessage p f = do
+ tResetProtocol (trans p)
+ resetProtocol p
+ proto <- getWrapped p
+ readMessage proto f
+
+ writeVal p v = do
+ proto <- getWrapped p
+ writeVal proto v
+
+ writeMessage p x f = do
+ proto <- getWrapped p
+ writeMessage proto x f
+
diff --git a/src/jaegertracing/thrift/lib/hs/src/Thrift/Protocol/JSON.hs b/src/jaegertracing/thrift/lib/hs/src/Thrift/Protocol/JSON.hs
new file mode 100644
index 000000000..839eddc84
--- /dev/null
+++ b/src/jaegertracing/thrift/lib/hs/src/Thrift/Protocol/JSON.hs
@@ -0,0 +1,362 @@
+--
+-- Licensed to the Apache Software Foundation (ASF) under one
+-- or more contributor license agreements. See the NOTICE file
+-- distributed with this work for additional information
+-- regarding copyright ownership. The ASF licenses this file
+-- to you 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.
+--
+
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TupleSections #-}
+
+module Thrift.Protocol.JSON
+ ( module Thrift.Protocol
+ , JSONProtocol(..)
+ ) where
+
+import Control.Applicative
+import Control.Exception (bracket)
+import Control.Monad
+import Data.Attoparsec.ByteString as P
+import Data.Attoparsec.ByteString.Char8 as PC
+import Data.Attoparsec.ByteString.Lazy as LP
+import Data.ByteString.Base64.Lazy as B64C
+import Data.ByteString.Lazy.Builder as B
+import Data.ByteString.Internal (c2w, w2c)
+import Data.Functor
+import Data.Int
+import Data.List
+import Data.Maybe (catMaybes)
+import Data.Monoid
+import Data.Text.Lazy.Encoding
+import Data.Word
+import qualified Data.HashMap.Strict as Map
+
+import Thrift.Protocol
+import Thrift.Transport
+import Thrift.Types
+
+import qualified Data.ByteString.Lazy as LBS
+import qualified Data.ByteString.Lazy.Char8 as LBSC
+import qualified Data.Text.Lazy as LT
+
+-- | The JSON Protocol data uses the standard 'TJSONProtocol'. Data is
+-- encoded as a JSON 'ByteString'
+data JSONProtocol t = JSONProtocol t
+ -- ^ Construct a 'JSONProtocol' with a 'Transport'
+getTransport :: Transport t => JSONProtocol t -> t
+getTransport (JSONProtocol t) = t
+
+instance Transport t => Protocol (JSONProtocol t) where
+ readByte p = tReadAll (getTransport p) 1
+
+ writeMessage (JSONProtocol t) (s, ty, sq) = bracket readMessageBegin readMessageEnd . const
+ where
+ readMessageBegin = tWrite t $ toLazyByteString $
+ B.char8 '[' <> buildShowable (1 :: Int32) <>
+ B.string8 ",\"" <> escape (encodeUtf8 s) <> B.char8 '\"' <>
+ B.char8 ',' <> buildShowable (fromEnum ty) <>
+ B.char8 ',' <> buildShowable sq <>
+ B.char8 ','
+ readMessageEnd _ = do
+ tWrite t "]"
+ tFlush t
+
+ readMessage p = bracket readMessageBegin readMessageEnd
+ where
+ readMessageBegin = runParser p $ skipSpace *> do
+ _ver :: Int32 <- lexeme (PC.char8 '[') *> lexeme (signed decimal)
+ bs <- lexeme (PC.char8 ',') *> lexeme escapedString
+ case decodeUtf8' bs of
+ Left _ -> fail "readMessage: invalid text encoding"
+ Right str -> do
+ ty <- toEnum <$> (lexeme (PC.char8 ',') *> lexeme (signed decimal))
+ seqNum <- lexeme (PC.char8 ',') *> lexeme (signed decimal)
+ _ <- PC.char8 ','
+ return (str, ty, seqNum)
+ readMessageEnd _ = void $ runParser p (PC.char8 ']')
+
+ writeVal p = tWrite (getTransport p) . toLazyByteString . buildJSONValue
+ readVal p ty = runParser p $ skipSpace *> parseJSONValue ty
+
+instance Transport t => StatelessProtocol (JSONProtocol t) where
+ serializeVal _ = toLazyByteString . buildJSONValue
+ deserializeVal _ ty bs =
+ case LP.eitherResult $ LP.parse (parseJSONValue ty) bs of
+ Left s -> error s
+ Right val -> val
+
+-- Writing Functions
+
+buildJSONValue :: ThriftVal -> Builder
+buildJSONValue (TStruct fields) = B.char8 '{' <> buildJSONStruct fields <> B.char8 '}'
+buildJSONValue (TMap kt vt entries) =
+ B.char8 '[' <> B.char8 '"' <> getTypeName kt <> B.char8 '"' <>
+ B.char8 ',' <> B.char8 '"' <> getTypeName vt <> B.char8 '"' <>
+ B.char8 ',' <> buildShowable (length entries) <>
+ B.char8 ',' <> B.char8 '{' <> buildJSONMap entries <> B.char8 '}' <>
+ B.char8 ']'
+buildJSONValue (TList ty entries) =
+ B.char8 '[' <> B.char8 '"' <> getTypeName ty <> B.char8 '"' <>
+ B.char8 ',' <> buildShowable (length entries) <>
+ (if length entries > 0
+ then B.char8 ',' <> buildJSONList entries
+ else mempty) <>
+ B.char8 ']'
+buildJSONValue (TSet ty entries) = buildJSONValue (TList ty entries)
+buildJSONValue (TBool b) = if b then B.char8 '1' else B.char8 '0'
+buildJSONValue (TByte b) = buildShowable b
+buildJSONValue (TI16 i) = buildShowable i
+buildJSONValue (TI32 i) = buildShowable i
+buildJSONValue (TI64 i) = buildShowable i
+buildJSONValue (TDouble d) = buildShowable d
+buildJSONValue (TString s) = B.char8 '\"' <> escape s <> B.char8 '\"'
+buildJSONValue (TBinary s) = B.char8 '\"' <> (B.lazyByteString . B64C.encode $ s) <> B.char8 '\"'
+
+buildJSONStruct :: Map.HashMap Int16 (LT.Text, ThriftVal) -> Builder
+buildJSONStruct = mconcat . intersperse (B.char8 ',') . Map.foldrWithKey buildField []
+ where
+ buildField fid (_,val) = (:) $
+ B.char8 '"' <> buildShowable fid <> B.string8 "\":" <>
+ B.char8 '{' <>
+ B.char8 '"' <> getTypeName (getTypeOf val) <> B.string8 "\":" <>
+ buildJSONValue val <>
+ B.char8 '}'
+
+buildJSONMap :: [(ThriftVal, ThriftVal)] -> Builder
+buildJSONMap = mconcat . intersperse (B.char8 ',') . map buildKV
+ where
+ buildKV (key@(TString _), val) =
+ buildJSONValue key <> B.char8 ':' <> buildJSONValue val
+ buildKV (key, val) =
+ B.char8 '\"' <> buildJSONValue key <> B.string8 "\":" <> buildJSONValue val
+buildJSONList :: [ThriftVal] -> Builder
+buildJSONList = mconcat . intersperse (B.char8 ',') . map buildJSONValue
+
+buildShowable :: Show a => a -> Builder
+buildShowable = B.string8 . show
+
+-- Reading Functions
+
+parseJSONValue :: ThriftType -> Parser ThriftVal
+parseJSONValue (T_STRUCT tmap) =
+ TStruct <$> (lexeme (PC.char8 '{') *> parseJSONStruct tmap <* PC.char8 '}')
+parseJSONValue (T_MAP kt vt) = fmap (TMap kt vt) $
+ between '[' ']' $
+ lexeme escapedString *> lexeme (PC.char8 ',') *>
+ lexeme escapedString *> lexeme (PC.char8 ',') *>
+ lexeme decimal *> lexeme (PC.char8 ',') *>
+ between '{' '}' (parseJSONMap kt vt)
+parseJSONValue (T_LIST ty) = fmap (TList ty) $
+ between '[' ']' $ do
+ len <- lexeme escapedString *> lexeme (PC.char8 ',') *> lexeme decimal
+ if len > 0
+ then lexeme (PC.char8 ',') *> parseJSONList ty
+ else return []
+parseJSONValue (T_SET ty) = fmap (TSet ty) $
+ between '[' ']' $ do
+ len <- lexeme escapedString *> lexeme (PC.char8 ',') *> lexeme decimal
+ if len > 0
+ then lexeme (PC.char8 ',') *> parseJSONList ty
+ else return []
+parseJSONValue T_BOOL =
+ (TBool True <$ PC.char8 '1') <|> (TBool False <$ PC.char8 '0')
+parseJSONValue T_BYTE = TByte <$> signed decimal
+parseJSONValue T_I16 = TI16 <$> signed decimal
+parseJSONValue T_I32 = TI32 <$> signed decimal
+parseJSONValue T_I64 = TI64 <$> signed decimal
+parseJSONValue T_DOUBLE = TDouble <$> double
+parseJSONValue T_STRING = TString <$> escapedString
+parseJSONValue T_BINARY = TBinary <$> base64String
+parseJSONValue T_STOP = fail "parseJSONValue: cannot parse type T_STOP"
+parseJSONValue T_VOID = fail "parseJSONValue: cannot parse type T_VOID"
+
+parseAnyValue :: Parser ()
+parseAnyValue = choice $
+ skipBetween '{' '}' :
+ skipBetween '[' ']' :
+ map (void . parseJSONValue)
+ [ T_BOOL
+ , T_I16
+ , T_I32
+ , T_I64
+ , T_DOUBLE
+ , T_STRING
+ , T_BINARY
+ ]
+ where
+ skipBetween :: Char -> Char -> Parser ()
+ skipBetween a b = between a b $ void (PC.satisfy (\c -> c /= a && c /= b))
+ <|> skipBetween a b
+
+parseJSONStruct :: TypeMap -> Parser (Map.HashMap Int16 (LT.Text, ThriftVal))
+parseJSONStruct tmap = Map.fromList . catMaybes <$> parseField
+ `sepBy` lexeme (PC.char8 ',')
+ where
+ parseField = do
+ fid <- lexeme (between '"' '"' decimal) <* lexeme (PC.char8 ':')
+ case Map.lookup fid tmap of
+ Just (str, ftype) -> between '{' '}' $ do
+ _ <- lexeme (escapedString) *> lexeme (PC.char8 ':')
+ val <- lexeme (parseJSONValue ftype)
+ return $ Just (fid, (str, val))
+ Nothing -> lexeme parseAnyValue *> return Nothing
+
+parseJSONMap :: ThriftType -> ThriftType -> Parser [(ThriftVal, ThriftVal)]
+parseJSONMap kt vt =
+ ((,) <$> lexeme (parseJSONKey kt) <*>
+ (lexeme (PC.char8 ':') *> lexeme (parseJSONValue vt))) `sepBy`
+ lexeme (PC.char8 ',')
+ where
+ parseJSONKey T_STRING = parseJSONValue T_STRING
+ parseJSONKey T_BINARY = parseJSONValue T_BINARY
+ parseJSONKey kt = PC.char8 '"' *> parseJSONValue kt <* PC.char8 '"'
+
+parseJSONList :: ThriftType -> Parser [ThriftVal]
+parseJSONList ty = lexeme (parseJSONValue ty) `sepBy` lexeme (PC.char8 ',')
+
+escapedString :: Parser LBS.ByteString
+escapedString = PC.char8 '"' *>
+ (LBS.pack <$> P.many' (escapedChar <|> notChar8 '"')) <*
+ PC.char8 '"'
+
+base64String :: Parser LBS.ByteString
+base64String = PC.char8 '"' *>
+ (decodeBase64 . LBSC.pack <$> P.many' (PC.notChar '"')) <*
+ PC.char8 '"'
+ where
+ decodeBase64 b =
+ let padded = case (LBS.length b) `mod` 4 of
+ 2 -> LBS.append b "=="
+ 3 -> LBS.append b "="
+ _ -> b in
+ case B64C.decode padded of
+ Right s -> s
+ Left x -> error x
+
+escapedChar :: Parser Word8
+escapedChar = PC.char8 '\\' *> (c2w <$> choice
+ [ '\SOH' <$ P.string "u0001"
+ , '\STX' <$ P.string "u0002"
+ , '\ETX' <$ P.string "u0003"
+ , '\EOT' <$ P.string "u0004"
+ , '\ENQ' <$ P.string "u0005"
+ , '\ACK' <$ P.string "u0006"
+ , '\BEL' <$ P.string "u0007"
+ , '\BS' <$ P.string "u0008"
+ , '\VT' <$ P.string "u000b"
+ , '\FF' <$ P.string "u000c"
+ , '\CR' <$ P.string "u000d"
+ , '\SO' <$ P.string "u000e"
+ , '\SI' <$ P.string "u000f"
+ , '\DLE' <$ P.string "u0010"
+ , '\DC1' <$ P.string "u0011"
+ , '\DC2' <$ P.string "u0012"
+ , '\DC3' <$ P.string "u0013"
+ , '\DC4' <$ P.string "u0014"
+ , '\NAK' <$ P.string "u0015"
+ , '\SYN' <$ P.string "u0016"
+ , '\ETB' <$ P.string "u0017"
+ , '\CAN' <$ P.string "u0018"
+ , '\EM' <$ P.string "u0019"
+ , '\SUB' <$ P.string "u001a"
+ , '\ESC' <$ P.string "u001b"
+ , '\FS' <$ P.string "u001c"
+ , '\GS' <$ P.string "u001d"
+ , '\RS' <$ P.string "u001e"
+ , '\US' <$ P.string "u001f"
+ , '\DEL' <$ P.string "u007f"
+ , '\0' <$ PC.char '0'
+ , '\a' <$ PC.char 'a'
+ , '\b' <$ PC.char 'b'
+ , '\f' <$ PC.char 'f'
+ , '\n' <$ PC.char 'n'
+ , '\r' <$ PC.char 'r'
+ , '\t' <$ PC.char 't'
+ , '\v' <$ PC.char 'v'
+ , '\"' <$ PC.char '"'
+ , '\'' <$ PC.char '\''
+ , '\\' <$ PC.char '\\'
+ , '/' <$ PC.char '/'
+ ])
+
+escape :: LBS.ByteString -> Builder
+escape = LBS.foldl' escapeChar mempty
+ where
+ escapeChar b w = b <> (B.lazyByteString $ case w2c w of
+ '\0' -> "\\0"
+ '\b' -> "\\b"
+ '\f' -> "\\f"
+ '\n' -> "\\n"
+ '\r' -> "\\r"
+ '\t' -> "\\t"
+ '\"' -> "\\\""
+ '\\' -> "\\\\"
+ '\SOH' -> "\\u0001"
+ '\STX' -> "\\u0002"
+ '\ETX' -> "\\u0003"
+ '\EOT' -> "\\u0004"
+ '\ENQ' -> "\\u0005"
+ '\ACK' -> "\\u0006"
+ '\BEL' -> "\\u0007"
+ '\VT' -> "\\u000b"
+ '\SO' -> "\\u000e"
+ '\SI' -> "\\u000f"
+ '\DLE' -> "\\u0010"
+ '\DC1' -> "\\u0011"
+ '\DC2' -> "\\u0012"
+ '\DC3' -> "\\u0013"
+ '\DC4' -> "\\u0014"
+ '\NAK' -> "\\u0015"
+ '\SYN' -> "\\u0016"
+ '\ETB' -> "\\u0017"
+ '\CAN' -> "\\u0018"
+ '\EM' -> "\\u0019"
+ '\SUB' -> "\\u001a"
+ '\ESC' -> "\\u001b"
+ '\FS' -> "\\u001c"
+ '\GS' -> "\\u001d"
+ '\RS' -> "\\u001e"
+ '\US' -> "\\u001f"
+ '\DEL' -> "\\u007f"
+ _ -> LBS.singleton w)
+
+lexeme :: Parser a -> Parser a
+lexeme = (<* skipSpace)
+
+notChar8 :: Char -> Parser Word8
+notChar8 c = P.satisfy (/= c2w c)
+
+between :: Char -> Char -> Parser a -> Parser a
+between a b p = lexeme (PC.char8 a) *> lexeme p <* lexeme (PC.char8 b)
+
+getTypeName :: ThriftType -> Builder
+getTypeName ty = B.string8 $ case ty of
+ T_STRUCT _ -> "rec"
+ T_MAP _ _ -> "map"
+ T_LIST _ -> "lst"
+ T_SET _ -> "set"
+ T_BOOL -> "tf"
+ T_BYTE -> "i8"
+ T_I16 -> "i16"
+ T_I32 -> "i32"
+ T_I64 -> "i64"
+ T_DOUBLE -> "dbl"
+ T_STRING -> "str"
+ T_BINARY -> "str"
+ _ -> error "Unrecognized Type"
+
diff --git a/src/jaegertracing/thrift/lib/hs/src/Thrift/Server.hs b/src/jaegertracing/thrift/lib/hs/src/Thrift/Server.hs
new file mode 100644
index 000000000..543f33850
--- /dev/null
+++ b/src/jaegertracing/thrift/lib/hs/src/Thrift/Server.hs
@@ -0,0 +1,66 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+--
+-- Licensed to the Apache Software Foundation (ASF) under one
+-- or more contributor license agreements. See the NOTICE file
+-- distributed with this work for additional information
+-- regarding copyright ownership. The ASF licenses this file
+-- to you 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.
+--
+
+module Thrift.Server
+ ( runBasicServer
+ , runThreadedServer
+ ) where
+
+import Control.Concurrent ( forkIO )
+import Control.Exception
+import Control.Monad ( forever, when )
+
+import Network
+
+import System.IO
+
+import Thrift
+import Thrift.Transport.Handle()
+import Thrift.Protocol.Binary
+
+
+-- | A threaded sever that is capable of using any Transport or Protocol
+-- instances.
+runThreadedServer :: (Protocol i, Protocol o)
+ => (Socket -> IO (i, o))
+ -> h
+ -> (h -> (i, o) -> IO Bool)
+ -> PortID
+ -> IO a
+runThreadedServer accepter hand proc_ port = do
+ socket <- listenOn port
+ acceptLoop (accepter socket) (proc_ hand)
+
+-- | A basic threaded binary protocol socket server.
+runBasicServer :: h
+ -> (h -> (BinaryProtocol Handle, BinaryProtocol Handle) -> IO Bool)
+ -> PortNumber
+ -> IO a
+runBasicServer hand proc_ port = runThreadedServer binaryAccept hand proc_ (PortNumber port)
+ where binaryAccept s = do
+ (h, _, _) <- accept s
+ return (BinaryProtocol h, BinaryProtocol h)
+
+acceptLoop :: IO t -> (t -> IO Bool) -> IO a
+acceptLoop accepter proc_ = forever $
+ do ps <- accepter
+ forkIO $ handle (\(_ :: SomeException) -> return ())
+ (loop $ proc_ ps)
+ where loop m = do { continue <- m; when continue (loop m) }
diff --git a/src/jaegertracing/thrift/lib/hs/src/Thrift/Transport.hs b/src/jaegertracing/thrift/lib/hs/src/Thrift/Transport.hs
new file mode 100644
index 000000000..306edc208
--- /dev/null
+++ b/src/jaegertracing/thrift/lib/hs/src/Thrift/Transport.hs
@@ -0,0 +1,65 @@
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+--
+-- Licensed to the Apache Software Foundation (ASF) under one
+-- or more contributor license agreements. See the NOTICE file
+-- distributed with this work for additional information
+-- regarding copyright ownership. The ASF licenses this file
+-- to you 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.
+--
+
+module Thrift.Transport
+ ( Transport(..)
+ , TransportExn(..)
+ , TransportExnType(..)
+ ) where
+
+import Control.Monad ( when )
+import Control.Exception ( Exception, throw )
+import Data.Functor ( (<$>) )
+import Data.Typeable ( Typeable )
+import Data.Word
+
+import qualified Data.ByteString.Lazy as LBS
+import Data.Monoid
+
+class Transport a where
+ tIsOpen :: a -> IO Bool
+ tClose :: a -> IO ()
+ tRead :: a -> Int -> IO LBS.ByteString
+ tPeek :: a -> IO (Maybe Word8)
+ tWrite :: a -> LBS.ByteString -> IO ()
+ tFlush :: a -> IO ()
+ tReadAll :: a -> Int -> IO LBS.ByteString
+
+ tReadAll _ 0 = return mempty
+ tReadAll a len = do
+ result <- tRead a len
+ let rlen = fromIntegral $ LBS.length result
+ when (rlen == 0) (throw $ TransportExn "Cannot read. Remote side has closed." TE_UNKNOWN)
+ if len <= rlen
+ then return result
+ else (result `mappend`) <$> tReadAll a (len - rlen)
+
+data TransportExn = TransportExn String TransportExnType
+ deriving ( Show, Typeable )
+instance Exception TransportExn
+
+data TransportExnType
+ = TE_UNKNOWN
+ | TE_NOT_OPEN
+ | TE_ALREADY_OPEN
+ | TE_TIMED_OUT
+ | TE_END_OF_FILE
+ deriving ( Eq, Show, Typeable )
diff --git a/src/jaegertracing/thrift/lib/hs/src/Thrift/Transport/Empty.hs b/src/jaegertracing/thrift/lib/hs/src/Thrift/Transport/Empty.hs
new file mode 100644
index 000000000..47af5fe88
--- /dev/null
+++ b/src/jaegertracing/thrift/lib/hs/src/Thrift/Transport/Empty.hs
@@ -0,0 +1,36 @@
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+--
+-- Licensed to the Apache Software Foundation (ASF) under one
+-- or more contributor license agreements. See the NOTICE file
+-- distributed with this work for additional information
+-- regarding copyright ownership. The ASF licenses this file
+-- to you 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.
+--
+
+module Thrift.Transport.Empty
+ ( EmptyTransport(..)
+ ) where
+
+import Thrift.Transport
+
+data EmptyTransport = EmptyTransport
+
+instance Transport EmptyTransport where
+ tIsOpen = const $ return False
+ tClose = const $ return ()
+ tRead _ _ = return ""
+ tPeek = const $ return Nothing
+ tWrite _ _ = return ()
+ tFlush = const$ return ()
diff --git a/src/jaegertracing/thrift/lib/hs/src/Thrift/Transport/Framed.hs b/src/jaegertracing/thrift/lib/hs/src/Thrift/Transport/Framed.hs
new file mode 100644
index 000000000..42fc43f39
--- /dev/null
+++ b/src/jaegertracing/thrift/lib/hs/src/Thrift/Transport/Framed.hs
@@ -0,0 +1,99 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+--
+-- Licensed to the Apache Software Foundation (ASF) under one
+-- or more contributor license agreements. See the NOTICE file
+-- distributed with this work for additional information
+-- regarding copyright ownership. The ASF licenses this file
+-- to you 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.
+--
+
+module Thrift.Transport.Framed
+ ( module Thrift.Transport
+ , FramedTransport
+ , openFramedTransport
+ ) where
+
+import Thrift.Transport
+import Thrift.Transport.IOBuffer
+
+import Data.Int (Int32)
+import qualified Data.Binary as B
+import qualified Data.ByteString.Lazy as LBS
+
+
+-- | FramedTransport wraps a given transport in framed mode.
+data FramedTransport t = FramedTransport {
+ wrappedTrans :: t, -- ^ Underlying transport.
+ writeBuffer :: WriteBuffer, -- ^ Write buffer.
+ readBuffer :: ReadBuffer -- ^ Read buffer.
+ }
+
+-- | Create a new framed transport which wraps the given transport.
+openFramedTransport :: Transport t => t -> IO (FramedTransport t)
+openFramedTransport trans = do
+ wbuf <- newWriteBuffer
+ rbuf <- newReadBuffer
+ return FramedTransport{ wrappedTrans = trans, writeBuffer = wbuf, readBuffer = rbuf }
+
+instance Transport t => Transport (FramedTransport t) where
+
+ tClose = tClose . wrappedTrans
+
+ tRead trans n = do
+ -- First, check the read buffer for any data.
+ bs <- readBuf (readBuffer trans) n
+ if LBS.null bs
+ then
+ -- When the buffer is empty, read another frame from the
+ -- underlying transport.
+ do len <- readFrame trans
+ if len > 0
+ then tRead trans n
+ else return bs
+ else return bs
+ tPeek trans = do
+ mw <- peekBuf (readBuffer trans)
+ case mw of
+ Just _ -> return mw
+ Nothing -> do
+ len <- readFrame trans
+ if len > 0
+ then tPeek trans
+ else return Nothing
+
+ tWrite = writeBuf . writeBuffer
+
+ tFlush trans = do
+ bs <- flushBuf (writeBuffer trans)
+ let szBs = B.encode $ (fromIntegral $ LBS.length bs :: Int32)
+ tWrite (wrappedTrans trans) szBs
+ tWrite (wrappedTrans trans) bs
+ tFlush (wrappedTrans trans)
+
+ tIsOpen = tIsOpen . wrappedTrans
+
+readFrame :: Transport t => FramedTransport t -> IO Int
+readFrame trans = do
+ -- Read and decode the frame size.
+ szBs <- tRead (wrappedTrans trans) 4
+ let sz = fromIntegral (B.decode szBs :: Int32)
+
+ -- Read the frame and stuff it into the read buffer.
+ bs <- tRead (wrappedTrans trans) sz
+ fillBuf (readBuffer trans) bs
+
+ -- Return the frame size so that the caller knows whether to expect
+ -- something in the read buffer or not.
+ return sz
diff --git a/src/jaegertracing/thrift/lib/hs/src/Thrift/Transport/Handle.hs b/src/jaegertracing/thrift/lib/hs/src/Thrift/Transport/Handle.hs
new file mode 100644
index 000000000..ff6295b67
--- /dev/null
+++ b/src/jaegertracing/thrift/lib/hs/src/Thrift/Transport/Handle.hs
@@ -0,0 +1,78 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+--
+-- Licensed to the Apache Software Foundation (ASF) under one
+-- or more contributor license agreements. See the NOTICE file
+-- distributed with this work for additional information
+-- regarding copyright ownership. The ASF licenses this file
+-- to you 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.
+--
+
+module Thrift.Transport.Handle
+ ( module Thrift.Transport
+ , HandleSource(..)
+ ) where
+
+import Control.Exception ( catch, throw )
+import Data.ByteString.Internal (c2w)
+import Data.Functor
+
+import Network
+
+import System.IO
+import System.IO.Error ( isEOFError )
+
+import Thrift.Transport
+
+import qualified Data.ByteString.Lazy as LBS
+import Data.Monoid
+
+instance Transport Handle where
+ tIsOpen = hIsOpen
+ tClose = hClose
+ tRead h n = read `Control.Exception.catch` handleEOF mempty
+ where
+ read = do
+ hLookAhead h
+ LBS.hGetNonBlocking h n
+ tReadAll _ 0 = return mempty
+ tReadAll h n = LBS.hGet h n `Control.Exception.catch` throwTransportExn
+ tPeek h = (Just . c2w <$> hLookAhead h) `Control.Exception.catch` handleEOF Nothing
+ tWrite = LBS.hPut
+ tFlush = hFlush
+
+
+-- | Type class for all types that can open a Handle. This class is used to
+-- replace tOpen in the Transport type class.
+class HandleSource s where
+ hOpen :: s -> IO Handle
+
+instance HandleSource FilePath where
+ hOpen s = openFile s ReadWriteMode
+
+instance HandleSource (HostName, PortID) where
+ hOpen = uncurry connectTo
+
+throwTransportExn :: IOError -> IO a
+throwTransportExn e = if isEOFError e
+ then throw $ TransportExn "Cannot read. Remote side has closed." TE_UNKNOWN
+ else throw $ TransportExn "Handle tReadAll: Could not read" TE_UNKNOWN
+
+handleEOF :: a -> IOError -> IO a
+handleEOF a e = if isEOFError e
+ then return a
+ else throw $ TransportExn "Handle: Could not read" TE_UNKNOWN
diff --git a/src/jaegertracing/thrift/lib/hs/src/Thrift/Transport/Header.hs b/src/jaegertracing/thrift/lib/hs/src/Thrift/Transport/Header.hs
new file mode 100644
index 000000000..2dacad25f
--- /dev/null
+++ b/src/jaegertracing/thrift/lib/hs/src/Thrift/Transport/Header.hs
@@ -0,0 +1,354 @@
+--
+-- Licensed to the Apache Software Foundation (ASF) under one
+-- or more contributor license agreements. See the NOTICE file
+-- distributed with this work for additional information
+-- regarding copyright ownership. The ASF licenses this file
+-- to you 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.
+--
+
+module Thrift.Transport.Header
+ ( module Thrift.Transport
+ , HeaderTransport(..)
+ , openHeaderTransport
+ , ProtocolType(..)
+ , TransformType(..)
+ , ClientType(..)
+ , tResetProtocol
+ , tSetProtocol
+ ) where
+
+import Thrift.Transport
+import Thrift.Protocol.Compact
+import Control.Applicative
+import Control.Exception ( throw )
+import Control.Monad
+import Data.Bits
+import Data.IORef
+import Data.Int
+import Data.Monoid
+import Data.Word
+
+import qualified Data.Attoparsec.ByteString as P
+import qualified Data.Binary as Binary
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Char8 as C
+import qualified Data.ByteString.Lazy as LBS
+import qualified Data.ByteString.Lazy.Builder as B
+import qualified Data.Map as Map
+
+data ProtocolType = TBinary | TCompact | TJSON deriving (Enum, Eq)
+data ClientType = HeaderClient | Framed | Unframed deriving (Enum, Eq)
+
+infoIdKeyValue = 1
+
+type Headers = Map.Map String String
+
+data TransformType = ZlibTransform deriving (Enum, Eq)
+
+fromTransportType :: TransformType -> Int16
+fromTransportType ZlibTransform = 1
+
+toTransportType :: Int16 -> TransformType
+toTransportType 1 = ZlibTransform
+toTransportType _ = throw $ TransportExn "HeaderTransport: Unknown transform ID" TE_UNKNOWN
+
+data HeaderTransport i o = (Transport i, Transport o) => HeaderTransport
+ { readBuffer :: IORef LBS.ByteString
+ , writeBuffer :: IORef B.Builder
+ , inTrans :: i
+ , outTrans :: o
+ , clientType :: IORef ClientType
+ , protocolType :: IORef ProtocolType
+ , headers :: IORef [(String, String)]
+ , writeHeaders :: Headers
+ , transforms :: IORef [TransformType]
+ , writeTransforms :: [TransformType]
+ }
+
+openHeaderTransport :: (Transport i, Transport o) => i -> o -> IO (HeaderTransport i o)
+openHeaderTransport i o = do
+ pid <- newIORef TCompact
+ rBuf <- newIORef LBS.empty
+ wBuf <- newIORef mempty
+ cType <- newIORef HeaderClient
+ h <- newIORef []
+ trans <- newIORef []
+ return HeaderTransport
+ { readBuffer = rBuf
+ , writeBuffer = wBuf
+ , inTrans = i
+ , outTrans = o
+ , clientType = cType
+ , protocolType = pid
+ , headers = h
+ , writeHeaders = Map.empty
+ , transforms = trans
+ , writeTransforms = []
+ }
+
+isFramed t = (/= Unframed) <$> readIORef (clientType t)
+
+readFrame :: (Transport i, Transport o) => HeaderTransport i o -> IO Bool
+readFrame t = do
+ let input = inTrans t
+ let rBuf = readBuffer t
+ let cType = clientType t
+ lsz <- tRead input 4
+ let sz = LBS.toStrict lsz
+ case P.parseOnly P.endOfInput sz of
+ Right _ -> do return False
+ Left _ -> do
+ case parseBinaryMagic sz of
+ Right _ -> do
+ writeIORef rBuf $ lsz
+ writeIORef cType Unframed
+ writeIORef (protocolType t) TBinary
+ return True
+ Left _ -> do
+ case parseCompactMagic sz of
+ Right _ -> do
+ writeIORef rBuf $ lsz
+ writeIORef cType Unframed
+ writeIORef (protocolType t) TCompact
+ return True
+ Left _ -> do
+ let len = Binary.decode lsz :: Int32
+ lbuf <- tReadAll input $ fromIntegral len
+ let buf = LBS.toStrict lbuf
+ case parseBinaryMagic buf of
+ Right _ -> do
+ writeIORef cType Framed
+ writeIORef (protocolType t) TBinary
+ writeIORef rBuf lbuf
+ return True
+ Left _ -> do
+ case parseCompactMagic buf of
+ Right _ -> do
+ writeIORef cType Framed
+ writeIORef (protocolType t) TCompact
+ writeIORef rBuf lbuf
+ return True
+ Left _ -> do
+ case parseHeaderMagic buf of
+ Right flags -> do
+ let (flags, seqNum, header, body) = extractHeader buf
+ writeIORef cType HeaderClient
+ handleHeader t header
+ payload <- untransform t body
+ writeIORef rBuf $ LBS.fromStrict $ payload
+ return True
+ Left _ ->
+ throw $ TransportExn "HeaderTransport: unkonwn client type" TE_UNKNOWN
+
+parseBinaryMagic = P.parseOnly $ P.word8 0x80 *> P.word8 0x01 *> P.word8 0x00 *> P.anyWord8
+parseCompactMagic = P.parseOnly $ P.word8 0x82 *> P.satisfy (\b -> b .&. 0x1f == 0x01)
+parseHeaderMagic = P.parseOnly $ P.word8 0x0f *> P.word8 0xff *> (P.count 2 P.anyWord8)
+
+parseI32 :: P.Parser Int32
+parseI32 = Binary.decode . LBS.fromStrict <$> P.take 4
+parseI16 :: P.Parser Int16
+parseI16 = Binary.decode . LBS.fromStrict <$> P.take 2
+
+extractHeader :: BS.ByteString -> (Int16, Int32, BS.ByteString, BS.ByteString)
+extractHeader bs =
+ case P.parse extractHeader_ bs of
+ P.Done remain (flags, seqNum, header) -> (flags, seqNum, header, remain)
+ _ -> throw $ TransportExn "HeaderTransport: Invalid header" TE_UNKNOWN
+ where
+ extractHeader_ = do
+ magic <- P.word8 0x0f *> P.word8 0xff
+ flags <- parseI16
+ seqNum <- parseI32
+ (headerSize :: Int) <- (* 4) . fromIntegral <$> parseI16
+ header <- P.take headerSize
+ return (flags, seqNum, header)
+
+handleHeader t header =
+ case P.parseOnly parseHeader header of
+ Right (pType, trans, info) -> do
+ writeIORef (protocolType t) pType
+ writeIORef (transforms t) trans
+ writeIORef (headers t) info
+ _ -> throw $ TransportExn "HeaderTransport: Invalid header" TE_UNKNOWN
+
+
+iw16 :: Int16 -> Word16
+iw16 = fromIntegral
+iw32 :: Int32 -> Word32
+iw32 = fromIntegral
+wi16 :: Word16 -> Int16
+wi16 = fromIntegral
+wi32 :: Word32 -> Int32
+wi32 = fromIntegral
+
+parseHeader :: P.Parser (ProtocolType, [TransformType], [(String, String)])
+parseHeader = do
+ protocolType <- toProtocolType <$> parseVarint wi16
+ numTrans <- fromIntegral <$> parseVarint wi16
+ trans <- replicateM numTrans parseTransform
+ info <- parseInfo
+ return (protocolType, trans, info)
+
+toProtocolType :: Int16 -> ProtocolType
+toProtocolType 0 = TBinary
+toProtocolType 1 = TJSON
+toProtocolType 2 = TCompact
+
+fromProtocolType :: ProtocolType -> Int16
+fromProtocolType TBinary = 0
+fromProtocolType TJSON = 1
+fromProtocolType TCompact = 2
+
+parseTransform :: P.Parser TransformType
+parseTransform = toTransportType <$> parseVarint wi16
+
+parseInfo :: P.Parser [(String, String)]
+parseInfo = do
+ n <- P.eitherP P.endOfInput (parseVarint wi32)
+ case n of
+ Left _ -> return []
+ Right n0 ->
+ replicateM (fromIntegral n0) $ do
+ klen <- parseVarint wi16
+ k <- P.take $ fromIntegral klen
+ vlen <- parseVarint wi16
+ v <- P.take $ fromIntegral vlen
+ return (C.unpack k, C.unpack v)
+
+parseString :: P.Parser BS.ByteString
+parseString = parseVarint wi32 >>= (P.take . fromIntegral)
+
+buildHeader :: HeaderTransport i o -> IO B.Builder
+buildHeader t = do
+ pType <- readIORef $ protocolType t
+ let pId = buildVarint $ iw16 $ fromProtocolType pType
+ let headerContent = pId <> (buildTransforms t) <> (buildInfo t)
+ let len = fromIntegral $ LBS.length $ B.toLazyByteString headerContent
+ -- TODO: length limit check
+ let padding = mconcat $ replicate (mod len 4) $ B.word8 0
+ let codedLen = B.int16BE (fromIntegral $ (quot (len - 1) 4) + 1)
+ let flags = 0
+ let seqNum = 0
+ return $ B.int16BE 0x0fff <> B.int16BE flags <> B.int32BE seqNum <> codedLen <> headerContent <> padding
+
+buildTransforms :: HeaderTransport i o -> B.Builder
+-- TODO: check length limit
+buildTransforms t =
+ let trans = writeTransforms t in
+ (buildVarint $ iw16 $ fromIntegral $ length trans) <>
+ (mconcat $ map (buildVarint . iw16 . fromTransportType) trans)
+
+buildInfo :: HeaderTransport i o -> B.Builder
+buildInfo t =
+ let h = Map.assocs $ writeHeaders t in
+ -- TODO: check length limit
+ case length h of
+ 0 -> mempty
+ len -> (buildVarint $ iw16 $ fromIntegral $ len) <> (mconcat $ map buildInfoEntry h)
+ where
+ buildInfoEntry (k, v) = buildVarStr k <> buildVarStr v
+ -- TODO: check length limit
+ buildVarStr s = (buildVarint $ iw16 $ fromIntegral $ length s) <> B.string8 s
+
+tResetProtocol :: (Transport i, Transport o) => HeaderTransport i o -> IO Bool
+tResetProtocol t = do
+ rBuf <- readIORef $ readBuffer t
+ writeIORef (clientType t) HeaderClient
+ readFrame t
+
+tSetProtocol :: (Transport i, Transport o) => HeaderTransport i o -> ProtocolType -> IO ()
+tSetProtocol t = writeIORef (protocolType t)
+
+transform :: HeaderTransport i o -> LBS.ByteString -> LBS.ByteString
+transform t bs =
+ foldr applyTransform bs $ writeTransforms t
+ where
+ -- applyTransform bs ZlibTransform =
+ -- throw $ TransportExn "HeaderTransport: not implemented: ZlibTransform " TE_UNKNOWN
+ applyTransform bs _ =
+ throw $ TransportExn "HeaderTransport: Unknown transform" TE_UNKNOWN
+
+untransform :: HeaderTransport i o -> BS.ByteString -> IO BS.ByteString
+untransform t bs = do
+ trans <- readIORef $ transforms t
+ return $ foldl unapplyTransform bs trans
+ where
+ -- unapplyTransform bs ZlibTransform =
+ -- throw $ TransportExn "HeaderTransport: not implemented: ZlibTransform " TE_UNKNOWN
+ unapplyTransform bs _ =
+ throw $ TransportExn "HeaderTransport: Unknown transform" TE_UNKNOWN
+
+instance (Transport i, Transport o) => Transport (HeaderTransport i o) where
+ tIsOpen t = do
+ tIsOpen (inTrans t)
+ tIsOpen (outTrans t)
+
+ tClose t = do
+ tClose(outTrans t)
+ tClose(inTrans t)
+
+ tRead t len = do
+ rBuf <- readIORef $ readBuffer t
+ if not $ LBS.null rBuf
+ then do
+ let (consumed, remain) = LBS.splitAt (fromIntegral len) rBuf
+ writeIORef (readBuffer t) remain
+ return consumed
+ else do
+ framed <- isFramed t
+ if not framed
+ then tRead (inTrans t) len
+ else do
+ ok <- readFrame t
+ if ok
+ then tRead t len
+ else return LBS.empty
+
+ tPeek t = do
+ rBuf <- readIORef (readBuffer t)
+ if not $ LBS.null rBuf
+ then return $ Just $ LBS.head rBuf
+ else do
+ framed <- isFramed t
+ if not framed
+ then tPeek (inTrans t)
+ else do
+ ok <- readFrame t
+ if ok
+ then tPeek t
+ else return Nothing
+
+ tWrite t buf = do
+ let wBuf = writeBuffer t
+ framed <- isFramed t
+ if framed
+ then modifyIORef wBuf (<> B.lazyByteString buf)
+ else
+ -- TODO: what should we do when switched to unframed in the middle ?
+ tWrite(outTrans t) buf
+
+ tFlush t = do
+ cType <- readIORef $ clientType t
+ case cType of
+ Unframed -> tFlush $ outTrans t
+ Framed -> flushBuffer t id mempty
+ HeaderClient -> buildHeader t >>= flushBuffer t (transform t)
+ where
+ flushBuffer t f header = do
+ wBuf <- readIORef $ writeBuffer t
+ writeIORef (writeBuffer t) mempty
+ let payload = B.toLazyByteString (header <> wBuf)
+ tWrite (outTrans t) $ Binary.encode (fromIntegral $ LBS.length payload :: Int32)
+ tWrite (outTrans t) $ f payload
+ tFlush (outTrans t)
diff --git a/src/jaegertracing/thrift/lib/hs/src/Thrift/Transport/HttpClient.hs b/src/jaegertracing/thrift/lib/hs/src/Thrift/Transport/HttpClient.hs
new file mode 100644
index 000000000..edeb3208d
--- /dev/null
+++ b/src/jaegertracing/thrift/lib/hs/src/Thrift/Transport/HttpClient.hs
@@ -0,0 +1,101 @@
+{-# LANGUAGE FlexibleInstances #-}
+--
+-- Licensed to the Apache Software Foundation (ASF) under one
+-- or more contributor license agreements. See the NOTICE file
+-- distributed with this work for additional information
+-- regarding copyright ownership. The ASF licenses this file
+-- to you 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.
+--
+
+module Thrift.Transport.HttpClient
+ ( module Thrift.Transport
+ , HttpClient (..)
+ , openHttpClient
+) where
+
+import Thrift.Transport
+import Thrift.Transport.IOBuffer
+import Network.URI
+import Network.HTTP hiding (port, host)
+
+import Data.Maybe (fromJust)
+import Data.Monoid (mempty)
+import Control.Exception (throw)
+import qualified Data.ByteString.Lazy as LBS
+
+
+-- | 'HttpClient', or THttpClient implements the Thrift Transport
+-- | Layer over http or https.
+data HttpClient =
+ HttpClient {
+ hstream :: HandleStream LBS.ByteString,
+ uri :: URI,
+ writeBuffer :: WriteBuffer,
+ readBuffer :: ReadBuffer
+ }
+
+uriAuth :: URI -> URIAuth
+uriAuth = fromJust . uriAuthority
+
+host :: URI -> String
+host = uriRegName . uriAuth
+
+port :: URI -> Int
+port uri_ =
+ if portStr == mempty then
+ httpPort
+ else
+ read portStr
+ where
+ portStr = dropWhile (== ':') $ uriPort $ uriAuth uri_
+ httpPort = 80
+
+-- | Use 'openHttpClient' to create an HttpClient connected to @uri@
+openHttpClient :: URI -> IO HttpClient
+openHttpClient uri_ = do
+ stream <- openTCPConnection (host uri_) (port uri_)
+ wbuf <- newWriteBuffer
+ rbuf <- newReadBuffer
+ return $ HttpClient stream uri_ wbuf rbuf
+
+instance Transport HttpClient where
+
+ tClose = close . hstream
+
+ tPeek = peekBuf . readBuffer
+
+ tRead = readBuf . readBuffer
+
+ tWrite = writeBuf . writeBuffer
+
+ tFlush hclient = do
+ body <- flushBuf $ writeBuffer hclient
+ let request = Request {
+ rqURI = uri hclient,
+ rqHeaders = [
+ mkHeader HdrContentType "application/x-thrift",
+ mkHeader HdrContentLength $ show $ LBS.length body],
+ rqMethod = POST,
+ rqBody = body
+ }
+
+ res <- sendHTTP (hstream hclient) request
+ case res of
+ Right response ->
+ fillBuf (readBuffer hclient) (rspBody response)
+ Left _ ->
+ throw $ TransportExn "THttpConnection: HTTP failure from server" TE_UNKNOWN
+ return ()
+
+ tIsOpen _ = return True
diff --git a/src/jaegertracing/thrift/lib/hs/src/Thrift/Transport/IOBuffer.hs b/src/jaegertracing/thrift/lib/hs/src/Thrift/Transport/IOBuffer.hs
new file mode 100644
index 000000000..7ebd7d899
--- /dev/null
+++ b/src/jaegertracing/thrift/lib/hs/src/Thrift/Transport/IOBuffer.hs
@@ -0,0 +1,69 @@
+--
+-- Licensed to the Apache Software Foundation (ASF) under one
+-- or more contributor license agreements. See the NOTICE file
+-- distributed with this work for additional information
+-- regarding copyright ownership. The ASF licenses this file
+-- to you 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.
+--
+
+module Thrift.Transport.IOBuffer
+ ( WriteBuffer
+ , newWriteBuffer
+ , writeBuf
+ , flushBuf
+ , ReadBuffer
+ , newReadBuffer
+ , fillBuf
+ , readBuf
+ , peekBuf
+ ) where
+
+import Data.ByteString.Lazy.Builder
+import Data.Functor
+import Data.IORef
+import Data.Monoid
+import Data.Word
+
+import qualified Data.ByteString.Lazy as LBS
+
+type WriteBuffer = IORef Builder
+type ReadBuffer = IORef LBS.ByteString
+
+newWriteBuffer :: IO WriteBuffer
+newWriteBuffer = newIORef mempty
+
+writeBuf :: WriteBuffer -> LBS.ByteString -> IO ()
+writeBuf w s = modifyIORef w ( <> lazyByteString s)
+
+flushBuf :: WriteBuffer -> IO LBS.ByteString
+flushBuf w = do
+ buf <- readIORef w
+ writeIORef w mempty
+ return $ toLazyByteString buf
+
+newReadBuffer :: IO ReadBuffer
+newReadBuffer = newIORef mempty
+
+fillBuf :: ReadBuffer -> LBS.ByteString -> IO ()
+fillBuf = writeIORef
+
+readBuf :: ReadBuffer -> Int -> IO LBS.ByteString
+readBuf r n = do
+ bs <- readIORef r
+ let (hd, tl) = LBS.splitAt (fromIntegral n) bs
+ writeIORef r tl
+ return hd
+
+peekBuf :: ReadBuffer -> IO (Maybe Word8)
+peekBuf r = (fmap fst . LBS.uncons) <$> readIORef r
diff --git a/src/jaegertracing/thrift/lib/hs/src/Thrift/Transport/Memory.hs b/src/jaegertracing/thrift/lib/hs/src/Thrift/Transport/Memory.hs
new file mode 100644
index 000000000..1c93af695
--- /dev/null
+++ b/src/jaegertracing/thrift/lib/hs/src/Thrift/Transport/Memory.hs
@@ -0,0 +1,77 @@
+--
+-- Licensed to the Apache Software Foundation (ASF) under one
+-- or more contributor license agreements. See the NOTICE file
+-- distributed with this work for additional information
+-- regarding copyright ownership. The ASF licenses this file
+-- to you 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.
+--
+
+module Thrift.Transport.Memory
+ ( openMemoryBuffer
+ , MemoryBuffer(..)
+ ) where
+
+import Data.ByteString.Lazy.Builder
+import Data.Functor
+import Data.IORef
+import Data.Monoid
+import qualified Data.ByteString.Lazy as LBS
+
+import Thrift.Transport
+
+
+data MemoryBuffer = MemoryBuffer {
+ writeBuffer :: IORef Builder,
+ readBuffer :: IORef LBS.ByteString
+}
+
+openMemoryBuffer :: IO MemoryBuffer
+openMemoryBuffer = do
+ wbuf <- newIORef mempty
+ rbuf <- newIORef mempty
+ return MemoryBuffer {
+ writeBuffer = wbuf,
+ readBuffer = rbuf
+ }
+
+instance Transport MemoryBuffer where
+ tIsOpen = const $ return False
+ tClose = const $ return ()
+ tFlush trans = do
+ let wBuf = writeBuffer trans
+ wb <- readIORef wBuf
+ modifyIORef (readBuffer trans) $ \rb -> mappend rb $ toLazyByteString wb
+ writeIORef wBuf mempty
+
+ tRead _ 0 = return mempty
+ tRead trans n = do
+ let rbuf = readBuffer trans
+ rb <- readIORef rbuf
+ let len = fromIntegral $ LBS.length rb
+ if len == 0
+ then do
+ tFlush trans
+ rb2 <- readIORef (readBuffer trans)
+ if (fromIntegral $ LBS.length rb2) == 0
+ then return mempty
+ else tRead trans n
+ else do
+ let (ret, remain) = LBS.splitAt (fromIntegral n) rb
+ writeIORef rbuf remain
+ return ret
+
+ tPeek trans = (fmap fst . LBS.uncons) <$> readIORef (readBuffer trans)
+
+ tWrite trans v = do
+ modifyIORef (writeBuffer trans) (<> lazyByteString v)
diff --git a/src/jaegertracing/thrift/lib/hs/src/Thrift/Types.hs b/src/jaegertracing/thrift/lib/hs/src/Thrift/Types.hs
new file mode 100644
index 000000000..2a200253d
--- /dev/null
+++ b/src/jaegertracing/thrift/lib/hs/src/Thrift/Types.hs
@@ -0,0 +1,130 @@
+-- Licensed to the Apache Software Foundation (ASF) under one
+-- or more contributor license agreements. See the NOTICE file
+-- distributed with this work for additional information
+-- regarding copyright ownership. The ASF licenses this file
+-- to you 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.
+--
+
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Thrift.Types where
+
+import Data.Foldable (foldl')
+import Data.Hashable ( Hashable, hashWithSalt )
+import Data.Int
+import Test.QuickCheck.Arbitrary
+import Test.QuickCheck.Gen (elements)
+import Data.Text.Lazy (Text)
+import qualified Data.ByteString.Lazy as LBS
+import qualified Data.HashMap.Strict as Map
+import qualified Data.HashSet as Set
+import qualified Data.Vector as Vector
+
+instance (Hashable a) => Hashable (Vector.Vector a) where
+ hashWithSalt = Vector.foldl' hashWithSalt
+
+
+type TypeMap = Map.HashMap Int16 (Text, ThriftType)
+
+data ThriftVal = TStruct (Map.HashMap Int16 (Text, ThriftVal))
+ | TMap ThriftType ThriftType [(ThriftVal, ThriftVal)]
+ | TList ThriftType [ThriftVal]
+ | TSet ThriftType [ThriftVal]
+ | TBool Bool
+ | TByte Int8
+ | TI16 Int16
+ | TI32 Int32
+ | TI64 Int64
+ | TString LBS.ByteString
+ | TBinary LBS.ByteString
+ | TDouble Double
+ deriving (Eq, Show)
+
+-- Information is needed here for collection types (ie T_STRUCT, T_MAP,
+-- T_LIST, and T_SET) so that we know what types those collections are
+-- parameterized by. In most protocols, this cannot be discerned directly
+-- from the data being read.
+data ThriftType
+ = T_STOP
+ | T_VOID
+ | T_BOOL
+ | T_BYTE
+ | T_DOUBLE
+ | T_I16
+ | T_I32
+ | T_I64
+ | T_STRING
+ | T_BINARY
+ | T_STRUCT TypeMap
+ | T_MAP ThriftType ThriftType
+ | T_SET ThriftType
+ | T_LIST ThriftType
+ deriving ( Eq, Show )
+
+-- NOTE: when using toEnum information about parametized types is NOT preserved.
+-- This design choice is consistent woth the Thrift implementation in other
+-- languages
+instance Enum ThriftType where
+ fromEnum T_STOP = 0
+ fromEnum T_VOID = 1
+ fromEnum T_BOOL = 2
+ fromEnum T_BYTE = 3
+ fromEnum T_DOUBLE = 4
+ fromEnum T_I16 = 6
+ fromEnum T_I32 = 8
+ fromEnum T_I64 = 10
+ fromEnum T_STRING = 11
+ fromEnum T_BINARY = 11
+ fromEnum (T_STRUCT _) = 12
+ fromEnum (T_MAP _ _) = 13
+ fromEnum (T_SET _) = 14
+ fromEnum (T_LIST _) = 15
+
+ toEnum 0 = T_STOP
+ toEnum 1 = T_VOID
+ toEnum 2 = T_BOOL
+ toEnum 3 = T_BYTE
+ toEnum 4 = T_DOUBLE
+ toEnum 6 = T_I16
+ toEnum 8 = T_I32
+ toEnum 10 = T_I64
+ toEnum 11 = T_STRING
+ -- toEnum 11 = T_BINARY
+ toEnum 12 = T_STRUCT Map.empty
+ toEnum 13 = T_MAP T_VOID T_VOID
+ toEnum 14 = T_SET T_VOID
+ toEnum 15 = T_LIST T_VOID
+ toEnum t = error $ "Invalid ThriftType " ++ show t
+
+data MessageType
+ = M_CALL
+ | M_REPLY
+ | M_EXCEPTION
+ | M_ONEWAY
+ deriving ( Eq, Show )
+
+instance Enum MessageType where
+ fromEnum M_CALL = 1
+ fromEnum M_REPLY = 2
+ fromEnum M_EXCEPTION = 3
+ fromEnum M_ONEWAY = 4
+
+ toEnum 1 = M_CALL
+ toEnum 2 = M_REPLY
+ toEnum 3 = M_EXCEPTION
+ toEnum 4 = M_ONEWAY
+ toEnum t = error $ "Invalid MessageType " ++ show t
+
+instance Arbitrary MessageType where
+ arbitrary = elements [M_CALL, M_REPLY, M_EXCEPTION, M_ONEWAY]
diff --git a/src/jaegertracing/thrift/lib/hs/test/BinarySpec.hs b/src/jaegertracing/thrift/lib/hs/test/BinarySpec.hs
new file mode 100644
index 000000000..d692fabe3
--- /dev/null
+++ b/src/jaegertracing/thrift/lib/hs/test/BinarySpec.hs
@@ -0,0 +1,91 @@
+--
+-- Licensed to the Apache Software Foundation (ASF) under one
+-- or more contributor license agreements. See the NOTICE file
+-- distributed with this work for additional information
+-- regarding copyright ownership. The ASF licenses this file
+-- to you 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.
+--
+
+module BinarySpec where
+
+import Test.Hspec
+import Test.Hspec.QuickCheck (prop)
+
+import qualified Data.ByteString.Lazy as LBS
+import qualified Data.ByteString.Lazy.Char8 as C
+
+import Thrift.Types
+import Thrift.Transport
+import Thrift.Transport.Memory
+import Thrift.Protocol
+import Thrift.Protocol.Binary
+
+spec :: Spec
+spec = do
+ describe "BinaryProtocol" $ do
+ describe "double" $ do
+ it "writes in big endian order" $ do
+ let val = 2 ** 53
+ trans <- openMemoryBuffer
+ let proto = BinaryProtocol trans
+ writeVal proto (TDouble val)
+ bin <- tRead trans 8
+ (LBS.unpack bin) `shouldBe`[67, 64, 0, 0, 0, 0, 0, 0]
+
+ it "reads in big endian order" $ do
+ let bin = LBS.pack [67, 64, 0, 0, 0, 0, 0, 0]
+ trans <- openMemoryBuffer
+ let proto = BinaryProtocol trans
+ tWrite trans bin
+ val <- readVal proto T_DOUBLE
+ val `shouldBe` (TDouble $ 2 ** 53)
+
+ prop "round trip" $ \val -> do
+ trans <- openMemoryBuffer
+ let proto = BinaryProtocol trans
+ writeVal proto $ TDouble val
+ val2 <- readVal proto T_DOUBLE
+ val2 `shouldBe` (TDouble val)
+
+ describe "string" $ do
+ it "writes" $ do
+ let val = C.pack "aaa"
+ trans <- openMemoryBuffer
+ let proto = BinaryProtocol trans
+ writeVal proto (TString val)
+ bin <- tRead trans 7
+ (LBS.unpack bin) `shouldBe` [0, 0, 0, 3, 97, 97, 97]
+
+ describe "binary" $ do
+ it "writes" $ do
+ trans <- openMemoryBuffer
+ let proto = BinaryProtocol trans
+ writeVal proto (TBinary $ LBS.pack [42, 43, 44])
+ bin <- tRead trans 100
+ (LBS.unpack bin) `shouldBe` [0, 0, 0, 3, 42, 43, 44]
+
+ it "reads" $ do
+ trans <- openMemoryBuffer
+ let proto = BinaryProtocol trans
+ tWrite trans $ LBS.pack [0, 0, 0, 3, 42, 43, 44]
+ val <- readVal proto (T_BINARY)
+ val `shouldBe` (TBinary $ LBS.pack [42, 43, 44])
+
+ prop "round trip" $ \val -> do
+ trans <- openMemoryBuffer
+ let proto = BinaryProtocol trans
+ writeVal proto (TBinary $ LBS.pack val)
+ val2 <- readVal proto (T_BINARY)
+ val2 `shouldBe` (TBinary $ LBS.pack val)
+
diff --git a/src/jaegertracing/thrift/lib/hs/test/CompactSpec.hs b/src/jaegertracing/thrift/lib/hs/test/CompactSpec.hs
new file mode 100644
index 000000000..5540e7b5e
--- /dev/null
+++ b/src/jaegertracing/thrift/lib/hs/test/CompactSpec.hs
@@ -0,0 +1,81 @@
+--
+-- Licensed to the Apache Software Foundation (ASF) under one
+-- or more contributor license agreements. See the NOTICE file
+-- distributed with this work for additional information
+-- regarding copyright ownership. The ASF licenses this file
+-- to you 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.
+--
+
+module CompactSpec where
+
+import Test.Hspec
+import Test.Hspec.QuickCheck (prop)
+
+import qualified Data.ByteString.Lazy as LBS
+
+import Thrift.Types
+import Thrift.Transport
+import Thrift.Transport.Memory
+import Thrift.Protocol
+import Thrift.Protocol.Compact
+
+spec :: Spec
+spec = do
+ describe "CompactProtocol" $ do
+ describe "double" $ do
+ it "writes in little endian order" $ do
+ let val = 2 ** 53
+ trans <- openMemoryBuffer
+ let proto = CompactProtocol trans
+ writeVal proto (TDouble val)
+ bin <- tReadAll trans 8
+ (LBS.unpack bin) `shouldBe`[0, 0, 0, 0, 0, 0, 64, 67]
+
+ it "reads in little endian order" $ do
+ let bin = LBS.pack [0, 0, 0, 0, 0, 0, 64, 67]
+ trans <- openMemoryBuffer
+ let proto = CompactProtocol trans
+ tWrite trans bin
+ val <- readVal proto T_DOUBLE
+ val `shouldBe` (TDouble $ 2 ** 53)
+
+ prop "round trip" $ \val -> do
+ trans <- openMemoryBuffer
+ let proto = CompactProtocol trans
+ writeVal proto $ TDouble val
+ val2 <- readVal proto T_DOUBLE
+ val2 `shouldBe` (TDouble val)
+
+ describe "binary" $ do
+ it "writes" $ do
+ trans <- openMemoryBuffer
+ let proto = CompactProtocol trans
+ writeVal proto (TBinary $ LBS.pack [42, 43, 44])
+ bin <- tRead trans 100
+ (LBS.unpack bin) `shouldBe` [3, 42, 43, 44]
+
+ it "reads" $ do
+ trans <- openMemoryBuffer
+ let proto = CompactProtocol trans
+ tWrite trans $ LBS.pack [3, 42, 43, 44]
+ val <- readVal proto (T_BINARY)
+ val `shouldBe` (TBinary $ LBS.pack [42, 43, 44])
+
+ prop "round trip" $ \val -> do
+ trans <- openMemoryBuffer
+ let proto = CompactProtocol trans
+ writeVal proto (TBinary $ LBS.pack val)
+ val2 <- readVal proto (T_BINARY)
+ val2 `shouldBe` (TBinary $ LBS.pack val)
+
diff --git a/src/jaegertracing/thrift/lib/hs/test/JSONSpec.hs b/src/jaegertracing/thrift/lib/hs/test/JSONSpec.hs
new file mode 100644
index 000000000..022c8265e
--- /dev/null
+++ b/src/jaegertracing/thrift/lib/hs/test/JSONSpec.hs
@@ -0,0 +1,225 @@
+--
+-- Licensed to the Apache Software Foundation (ASF) under one
+-- or more contributor license agreements. See the NOTICE file
+-- distributed with this work for additional information
+-- regarding copyright ownership. The ASF licenses this file
+-- to you 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.
+--
+
+module JSONSpec where
+
+import Test.Hspec
+import Test.Hspec.QuickCheck (prop)
+
+import qualified Data.ByteString.Lazy as LBS
+import qualified Data.ByteString.Lazy.Char8 as C
+
+import Thrift.Types
+import Thrift.Transport
+import Thrift.Transport.Memory
+import Thrift.Protocol
+import Thrift.Protocol.JSON
+
+tString :: [Char] -> ThriftVal
+tString = TString . C.pack
+
+spec :: Spec
+spec = do
+ describe "JSONProtocol" $ do
+ describe "bool" $ do
+ it "writes true as 1" $ do
+ let val = True
+ trans <- openMemoryBuffer
+ let proto = JSONProtocol trans
+ writeVal proto (TBool val)
+ bin <-tRead trans 100
+ (C.unpack bin) `shouldBe` ['1']
+
+ it "writes false as 0" $ do
+ let val = False
+ trans <- openMemoryBuffer
+ let proto = JSONProtocol trans
+ writeVal proto (TBool val)
+ bin <- tRead trans 100
+ (C.unpack bin) `shouldBe` ['0']
+
+ prop "round trip" $ \val -> do
+ trans <- openMemoryBuffer
+ let proto = JSONProtocol trans
+ writeVal proto $ TBool val
+ val2 <- readVal proto T_BOOL
+ val2 `shouldBe` (TBool val)
+
+ describe "string" $ do
+ it "writes" $ do
+ trans <- openMemoryBuffer
+ let proto = JSONProtocol trans
+ writeVal proto (TString $ C.pack "\"a")
+ bin <- tRead trans 100
+ (C.unpack bin) `shouldBe` "\"\\\"a\""
+
+ it "reads" $ do
+ trans <- openMemoryBuffer
+ let proto = JSONProtocol trans
+ tWrite trans $ C.pack "\"\\\"a\""
+ val <- readVal proto (T_STRING)
+ val `shouldBe` (TString $ C.pack "\"a")
+
+ prop "round trip" $ \val -> do
+ trans <- openMemoryBuffer
+ let proto = JSONProtocol trans
+ writeVal proto (TString $ C.pack val)
+ val2 <- readVal proto (T_STRING)
+ val2 `shouldBe` (TString $ C.pack val)
+
+ describe "binary" $ do
+ it "writes with padding" $ do
+ trans <- openMemoryBuffer
+ let proto = JSONProtocol trans
+ writeVal proto (TBinary $ LBS.pack [1])
+ bin <- tRead trans 100
+ (C.unpack bin) `shouldBe` "\"AQ==\""
+
+ it "reads with padding" $ do
+ trans <- openMemoryBuffer
+ let proto = JSONProtocol trans
+ tWrite trans $ C.pack "\"AQ==\""
+ val <- readVal proto (T_BINARY)
+ val `shouldBe` (TBinary $ LBS.pack [1])
+
+ it "reads without padding" $ do
+ trans <- openMemoryBuffer
+ let proto = JSONProtocol trans
+ tWrite trans $ C.pack "\"AQ\""
+ val <- readVal proto (T_BINARY)
+ val `shouldBe` (TBinary $ LBS.pack [1])
+
+ prop "round trip" $ \val -> do
+ trans <- openMemoryBuffer
+ let proto = JSONProtocol trans
+ writeVal proto (TBinary $ LBS.pack val)
+ val2 <- readVal proto (T_BINARY)
+ val2 `shouldBe` (TBinary $ LBS.pack val)
+
+ describe "list" $ do
+ it "writes empty list" $ do
+ trans <- openMemoryBuffer
+ let proto = JSONProtocol trans
+ writeVal proto (TList T_BYTE [])
+ bin <- tRead trans 100
+ (C.unpack bin) `shouldBe` "[\"i8\",0]"
+
+ it "reads empty" $ do
+ trans <- openMemoryBuffer
+ let proto = JSONProtocol trans
+ tWrite trans (C.pack "[\"i8\",0]")
+ val <- readVal proto (T_LIST T_BYTE)
+ val `shouldBe` (TList T_BYTE [])
+
+ it "writes single element" $ do
+ trans <- openMemoryBuffer
+ let proto = JSONProtocol trans
+ writeVal proto (TList T_BYTE [TByte 0])
+ bin <- tRead trans 100
+ (C.unpack bin) `shouldBe` "[\"i8\",1,0]"
+
+ it "reads single element" $ do
+ trans <- openMemoryBuffer
+ let proto = JSONProtocol trans
+ tWrite trans (C.pack "[\"i8\",1,0]")
+ val <- readVal proto (T_LIST T_BYTE)
+ val `shouldBe` (TList T_BYTE [TByte 0])
+
+ it "reads elements" $ do
+ trans <- openMemoryBuffer
+ let proto = JSONProtocol trans
+ tWrite trans (C.pack "[\"i8\",2,42, 43]")
+ val <- readVal proto (T_LIST T_BYTE)
+ val `shouldBe` (TList T_BYTE [TByte 42, TByte 43])
+
+ prop "round trip" $ \val -> do
+ trans <- openMemoryBuffer
+ let proto = JSONProtocol trans
+ writeVal proto $ (TList T_STRING $ map tString val)
+ val2 <- readVal proto $ T_LIST T_STRING
+ val2 `shouldBe` (TList T_STRING $ map tString val)
+
+ describe "set" $ do
+ it "writes empty" $ do
+ trans <- openMemoryBuffer
+ let proto = JSONProtocol trans
+ writeVal proto (TSet T_BYTE [])
+ bin <- tRead trans 100
+ (C.unpack bin) `shouldBe` "[\"i8\",0]"
+
+ it "reads empty" $ do
+ trans <- openMemoryBuffer
+ let proto = JSONProtocol trans
+ tWrite trans (C.pack "[\"i8\",0]")
+ val <- readVal proto (T_SET T_BYTE)
+ val `shouldBe` (TSet T_BYTE [])
+
+ it "reads single element" $ do
+ trans <- openMemoryBuffer
+ let proto = JSONProtocol trans
+ tWrite trans (C.pack "[\"i8\",1,0]")
+ val <- readVal proto (T_SET T_BYTE)
+ val `shouldBe` (TSet T_BYTE [TByte 0])
+
+ it "reads elements" $ do
+ trans <- openMemoryBuffer
+ let proto = JSONProtocol trans
+ tWrite trans (C.pack "[\"i8\",2,42, 43]")
+ val <- readVal proto (T_SET T_BYTE)
+ val `shouldBe` (TSet T_BYTE [TByte 42, TByte 43])
+
+ prop "round trip" $ \val -> do
+ trans <- openMemoryBuffer
+ let proto = JSONProtocol trans
+ writeVal proto $ (TSet T_STRING $ map tString val)
+ val2 <- readVal proto $ T_SET T_STRING
+ val2 `shouldBe` (TSet T_STRING $ map tString val)
+
+ describe "map" $ do
+ it "writes empty" $ do
+ trans <- openMemoryBuffer
+ let proto = JSONProtocol trans
+ writeVal proto (TMap T_BYTE T_BYTE [])
+ bin <- tRead trans 100
+ (C.unpack bin) `shouldBe`"[\"i8\",\"i8\",0,{}]"
+
+ it "reads empty" $ do
+ trans <- openMemoryBuffer
+ let proto = JSONProtocol trans
+ tWrite trans (C.pack "[\"i8\",\"i8\",0,{}]")
+ val <- readVal proto (T_MAP T_BYTE T_BYTE)
+ val `shouldBe` (TMap T_BYTE T_BYTE [])
+
+ it "reads string-string" $ do
+ let bin = "[\"str\",\"str\",2,{\"a\":\"2\",\"b\":\"blah\"}]"
+ trans <- openMemoryBuffer
+ let proto = JSONProtocol trans
+ tWrite trans (C.pack bin)
+ val <- readVal proto (T_MAP T_STRING T_STRING)
+ val`shouldBe` (TMap T_STRING T_STRING [(tString "a", tString "2"), (tString "b", tString "blah")])
+
+ prop "round trip" $ \val -> do
+ trans <- openMemoryBuffer
+ let proto = JSONProtocol trans
+ writeVal proto $ (TMap T_STRING T_STRING $ map toKV val)
+ val2 <- readVal proto $ T_MAP T_STRING T_STRING
+ val2 `shouldBe` (TMap T_STRING T_STRING $ map toKV val)
+ where
+ toKV v = (tString v, tString v)
+
diff --git a/src/jaegertracing/thrift/lib/hs/test/Spec.hs b/src/jaegertracing/thrift/lib/hs/test/Spec.hs
new file mode 100644
index 000000000..7ec9a990b
--- /dev/null
+++ b/src/jaegertracing/thrift/lib/hs/test/Spec.hs
@@ -0,0 +1,38 @@
+--
+-- Licensed to the Apache Software Foundation (ASF) under one
+-- or more contributor license agreements. See the NOTICE file
+-- distributed with this work for additional information
+-- regarding copyright ownership. The ASF licenses this file
+-- to you 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.
+--
+
+-- Our CI does not work well with auto discover.
+-- Need to add build-time PATH variable to hspec-discover dir from CMake
+-- or install hspec system-wide for the following to work.
+-- {-# OPTIONS_GHC -F -pgmF hspec-discover #-}
+
+import Test.Hspec
+
+import qualified BinarySpec
+import qualified CompactSpec
+import qualified JSONSpec
+
+main :: IO ()
+main = hspec spec
+
+spec :: Spec
+spec = do
+ describe "Binary" BinarySpec.spec
+ describe "Compact" CompactSpec.spec
+ describe "JSON" JSONSpec.spec
diff --git a/src/jaegertracing/thrift/lib/hs/thrift.cabal b/src/jaegertracing/thrift/lib/hs/thrift.cabal
new file mode 100644
index 000000000..dd30d89f1
--- /dev/null
+++ b/src/jaegertracing/thrift/lib/hs/thrift.cabal
@@ -0,0 +1,84 @@
+--
+-- Licensed to the Apache Software Foundation (ASF) under one
+-- or more contributor license agreements. See the NOTICE file
+-- distributed with this work for additional information
+-- regarding copyright ownership. The ASF licenses this file
+-- to you 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.
+--
+
+Name: thrift
+Version: 0.13.0
+Cabal-Version: 1.24
+License: Apache
+Category: Foreign
+Build-Type: Simple
+Synopsis: Haskell bindings for the Apache Thrift RPC system
+Homepage: http://thrift.apache.org
+Bug-Reports: https://issues.apache.org/jira/browse/THRIFT
+Maintainer: dev@thrift.apache.org
+License-File: LICENSE
+
+Description:
+ Haskell bindings for the Apache Thrift RPC system. Requires the use of the thrift code generator.
+
+flag network-uri
+ description: Get Network.URI from the network-uri package
+ default: True
+
+Library
+ Hs-Source-Dirs:
+ src
+ Build-Depends:
+ base >= 4, base < 5, containers, ghc-prim, attoparsec, binary, bytestring >= 0.10, base64-bytestring, hashable, HTTP, text, hspec-core > 2.4.0, unordered-containers >= 0.2.6, vector >= 0.10.12.2, QuickCheck >= 2.8.2, split
+ if flag(network-uri)
+ build-depends: network-uri >= 2.6, network >= 2.6 && < 3.0
+ else
+ build-depends: network < 2.6
+ Exposed-Modules:
+ Thrift,
+ Thrift.Arbitraries
+ Thrift.Protocol,
+ Thrift.Protocol.Header,
+ Thrift.Protocol.Binary,
+ Thrift.Protocol.Compact,
+ Thrift.Protocol.JSON,
+ Thrift.Server,
+ Thrift.Transport,
+ Thrift.Transport.Empty,
+ Thrift.Transport.Framed,
+ Thrift.Transport.Handle,
+ Thrift.Transport.Header,
+ Thrift.Transport.HttpClient,
+ Thrift.Transport.IOBuffer,
+ Thrift.Transport.Memory,
+ Thrift.Types
+ Default-Language: Haskell2010
+ Default-Extensions:
+ DeriveDataTypeable,
+ ExistentialQuantification,
+ FlexibleInstances,
+ KindSignatures,
+ MagicHash,
+ RankNTypes,
+ RecordWildCards,
+ ScopedTypeVariables,
+ TypeSynonymInstances
+
+Test-Suite spec
+ Type: exitcode-stdio-1.0
+ Hs-Source-Dirs: test
+ Ghc-Options: -Wall
+ main-is: Spec.hs
+ Build-Depends: base, thrift, hspec, QuickCheck >= 2.8.2, bytestring >= 0.10, unordered-containers >= 0.2.6
+ Default-Language: Haskell2010