diff options
author | Daniel Baumann <daniel.baumann@progress-linux.org> | 2024-04-07 18:45:59 +0000 |
---|---|---|
committer | Daniel Baumann <daniel.baumann@progress-linux.org> | 2024-04-07 18:45:59 +0000 |
commit | 19fcec84d8d7d21e796c7624e521b60d28ee21ed (patch) | |
tree | 42d26aa27d1e3f7c0b8bd3fd14e7d7082f5008dc /src/jaegertracing/thrift/lib/hs | |
parent | Initial commit. (diff) | |
download | ceph-upstream.tar.xz ceph-upstream.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')
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 |