diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,3 @@ +* 0.1.0.0 (2012-04-20) + +After years of friendly reminders, a zero version gets finally released =] diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/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/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md diff --git a/gen-src/Agent.hs b/gen-src/Agent.hs new file mode 100644 --- /dev/null +++ b/gen-src/Agent.hs @@ -0,0 +1,190 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-missing-fields #-} +{-# OPTIONS_GHC -fno-warn-missing-signatures #-} +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} +{-# OPTIONS_GHC -fno-warn-unused-imports #-} +{-# OPTIONS_GHC -fno-warn-unused-matches #-} + +----------------------------------------------------------------- +-- Autogenerated by Thrift Compiler (0.11.0) -- +-- -- +-- DO NOT EDIT UNLESS YOU ARE SURE YOU KNOW WHAT YOU ARE DOING -- +----------------------------------------------------------------- + +module Agent where +import Prelude (($), (.), (>>=), (==), (++)) +import qualified Prelude as P +import qualified Control.Exception as X +import qualified Control.Monad as M ( liftM, ap, when ) +import Data.Functor ( (<$>) ) +import qualified Data.ByteString.Lazy as LBS +import qualified Data.Hashable as H +import qualified Data.Int as I +import qualified Data.Maybe as M (catMaybes) +import qualified Data.Text.Lazy.Encoding as E ( decodeUtf8, encodeUtf8 ) +import qualified Data.Text.Lazy as LT +import qualified GHC.Generics as G (Generic) +import qualified Data.Typeable as TY ( Typeable ) +import qualified Data.HashMap.Strict as Map +import qualified Data.HashSet as Set +import qualified Data.Vector as Vector +import qualified Test.QuickCheck.Arbitrary as QC ( Arbitrary(..) ) +import qualified Test.QuickCheck as QC ( elements ) + +import qualified Thrift as T +import qualified Thrift.Types as T +import qualified Thrift.Arbitraries as T + +import qualified Jaeger_Types +import qualified Zipkincore_Types + + +import Agent_Types +import qualified Agent_Iface as Iface +-- HELPER FUNCTIONS AND STRUCTURES -- + +data EmitZipkinBatch_args = EmitZipkinBatch_args { emitZipkinBatch_args_spans :: (Vector.Vector Zipkincore_Types.Span) + } deriving (P.Show,P.Eq,G.Generic,TY.Typeable) +instance H.Hashable EmitZipkinBatch_args where + hashWithSalt salt record = salt `H.hashWithSalt` emitZipkinBatch_args_spans record +instance QC.Arbitrary EmitZipkinBatch_args where + arbitrary = M.liftM EmitZipkinBatch_args (QC.arbitrary) + shrink obj | obj == default_EmitZipkinBatch_args = [] + | P.otherwise = M.catMaybes + [ if obj == default_EmitZipkinBatch_args{emitZipkinBatch_args_spans = emitZipkinBatch_args_spans obj} then P.Nothing else P.Just $ default_EmitZipkinBatch_args{emitZipkinBatch_args_spans = emitZipkinBatch_args_spans obj} + ] +from_EmitZipkinBatch_args :: EmitZipkinBatch_args -> T.ThriftVal +from_EmitZipkinBatch_args record = T.TStruct $ Map.fromList $ M.catMaybes + [ (\_v2 -> P.Just (1, ("spans",T.TList (T.T_STRUCT Zipkincore_Types.typemap_Span) $ P.map (\_v4 -> Zipkincore_Types.from_Span _v4) $ Vector.toList _v2))) $ emitZipkinBatch_args_spans record + ] +write_EmitZipkinBatch_args :: T.Protocol p => p -> EmitZipkinBatch_args -> P.IO () +write_EmitZipkinBatch_args oprot record = T.writeVal oprot $ from_EmitZipkinBatch_args record +encode_EmitZipkinBatch_args :: T.StatelessProtocol p => p -> EmitZipkinBatch_args -> LBS.ByteString +encode_EmitZipkinBatch_args oprot record = T.serializeVal oprot $ from_EmitZipkinBatch_args record +to_EmitZipkinBatch_args :: T.ThriftVal -> EmitZipkinBatch_args +to_EmitZipkinBatch_args (T.TStruct fields) = EmitZipkinBatch_args{ + emitZipkinBatch_args_spans = P.maybe (emitZipkinBatch_args_spans default_EmitZipkinBatch_args) (\(_,_val6) -> (case _val6 of {T.TList _ _val7 -> (Vector.fromList $ P.map (\_v8 -> (case _v8 of {T.TStruct _val9 -> (Zipkincore_Types.to_Span (T.TStruct _val9)); _ -> P.error "wrong type"})) _val7); _ -> P.error "wrong type"})) (Map.lookup (1) fields) + } +to_EmitZipkinBatch_args _ = P.error "not a struct" +read_EmitZipkinBatch_args :: T.Protocol p => p -> P.IO EmitZipkinBatch_args +read_EmitZipkinBatch_args iprot = to_EmitZipkinBatch_args <$> T.readVal iprot (T.T_STRUCT typemap_EmitZipkinBatch_args) +decode_EmitZipkinBatch_args :: T.StatelessProtocol p => p -> LBS.ByteString -> EmitZipkinBatch_args +decode_EmitZipkinBatch_args iprot bs = to_EmitZipkinBatch_args $ T.deserializeVal iprot (T.T_STRUCT typemap_EmitZipkinBatch_args) bs +typemap_EmitZipkinBatch_args :: T.TypeMap +typemap_EmitZipkinBatch_args = Map.fromList [(1,("spans",(T.T_LIST (T.T_STRUCT Zipkincore_Types.typemap_Span))))] +default_EmitZipkinBatch_args :: EmitZipkinBatch_args +default_EmitZipkinBatch_args = EmitZipkinBatch_args{ + emitZipkinBatch_args_spans = Vector.empty} +data EmitZipkinBatch_result = EmitZipkinBatch_result deriving (P.Show,P.Eq,G.Generic,TY.Typeable) +instance H.Hashable EmitZipkinBatch_result where + hashWithSalt salt record = salt +instance QC.Arbitrary EmitZipkinBatch_result where + arbitrary = QC.elements [EmitZipkinBatch_result] +from_EmitZipkinBatch_result :: EmitZipkinBatch_result -> T.ThriftVal +from_EmitZipkinBatch_result record = T.TStruct $ Map.fromList $ M.catMaybes + [] +write_EmitZipkinBatch_result :: T.Protocol p => p -> EmitZipkinBatch_result -> P.IO () +write_EmitZipkinBatch_result oprot record = T.writeVal oprot $ from_EmitZipkinBatch_result record +encode_EmitZipkinBatch_result :: T.StatelessProtocol p => p -> EmitZipkinBatch_result -> LBS.ByteString +encode_EmitZipkinBatch_result oprot record = T.serializeVal oprot $ from_EmitZipkinBatch_result record +to_EmitZipkinBatch_result :: T.ThriftVal -> EmitZipkinBatch_result +to_EmitZipkinBatch_result (T.TStruct fields) = EmitZipkinBatch_result{ + + } +to_EmitZipkinBatch_result _ = P.error "not a struct" +read_EmitZipkinBatch_result :: T.Protocol p => p -> P.IO EmitZipkinBatch_result +read_EmitZipkinBatch_result iprot = to_EmitZipkinBatch_result <$> T.readVal iprot (T.T_STRUCT typemap_EmitZipkinBatch_result) +decode_EmitZipkinBatch_result :: T.StatelessProtocol p => p -> LBS.ByteString -> EmitZipkinBatch_result +decode_EmitZipkinBatch_result iprot bs = to_EmitZipkinBatch_result $ T.deserializeVal iprot (T.T_STRUCT typemap_EmitZipkinBatch_result) bs +typemap_EmitZipkinBatch_result :: T.TypeMap +typemap_EmitZipkinBatch_result = Map.fromList [] +default_EmitZipkinBatch_result :: EmitZipkinBatch_result +default_EmitZipkinBatch_result = EmitZipkinBatch_result{ +} +data EmitBatch_args = EmitBatch_args { emitBatch_args_batch :: Jaeger_Types.Batch + } deriving (P.Show,P.Eq,G.Generic,TY.Typeable) +instance H.Hashable EmitBatch_args where + hashWithSalt salt record = salt `H.hashWithSalt` emitBatch_args_batch record +instance QC.Arbitrary EmitBatch_args where + arbitrary = M.liftM EmitBatch_args (QC.arbitrary) + shrink obj | obj == default_EmitBatch_args = [] + | P.otherwise = M.catMaybes + [ if obj == default_EmitBatch_args{emitBatch_args_batch = emitBatch_args_batch obj} then P.Nothing else P.Just $ default_EmitBatch_args{emitBatch_args_batch = emitBatch_args_batch obj} + ] +from_EmitBatch_args :: EmitBatch_args -> T.ThriftVal +from_EmitBatch_args record = T.TStruct $ Map.fromList $ M.catMaybes + [ (\_v17 -> P.Just (1, ("batch",Jaeger_Types.from_Batch _v17))) $ emitBatch_args_batch record + ] +write_EmitBatch_args :: T.Protocol p => p -> EmitBatch_args -> P.IO () +write_EmitBatch_args oprot record = T.writeVal oprot $ from_EmitBatch_args record +encode_EmitBatch_args :: T.StatelessProtocol p => p -> EmitBatch_args -> LBS.ByteString +encode_EmitBatch_args oprot record = T.serializeVal oprot $ from_EmitBatch_args record +to_EmitBatch_args :: T.ThriftVal -> EmitBatch_args +to_EmitBatch_args (T.TStruct fields) = EmitBatch_args{ + emitBatch_args_batch = P.maybe (emitBatch_args_batch default_EmitBatch_args) (\(_,_val19) -> (case _val19 of {T.TStruct _val20 -> (Jaeger_Types.to_Batch (T.TStruct _val20)); _ -> P.error "wrong type"})) (Map.lookup (1) fields) + } +to_EmitBatch_args _ = P.error "not a struct" +read_EmitBatch_args :: T.Protocol p => p -> P.IO EmitBatch_args +read_EmitBatch_args iprot = to_EmitBatch_args <$> T.readVal iprot (T.T_STRUCT typemap_EmitBatch_args) +decode_EmitBatch_args :: T.StatelessProtocol p => p -> LBS.ByteString -> EmitBatch_args +decode_EmitBatch_args iprot bs = to_EmitBatch_args $ T.deserializeVal iprot (T.T_STRUCT typemap_EmitBatch_args) bs +typemap_EmitBatch_args :: T.TypeMap +typemap_EmitBatch_args = Map.fromList [(1,("batch",(T.T_STRUCT Jaeger_Types.typemap_Batch)))] +default_EmitBatch_args :: EmitBatch_args +default_EmitBatch_args = EmitBatch_args{ + emitBatch_args_batch = Jaeger_Types.default_Batch} +data EmitBatch_result = EmitBatch_result deriving (P.Show,P.Eq,G.Generic,TY.Typeable) +instance H.Hashable EmitBatch_result where + hashWithSalt salt record = salt +instance QC.Arbitrary EmitBatch_result where + arbitrary = QC.elements [EmitBatch_result] +from_EmitBatch_result :: EmitBatch_result -> T.ThriftVal +from_EmitBatch_result record = T.TStruct $ Map.fromList $ M.catMaybes + [] +write_EmitBatch_result :: T.Protocol p => p -> EmitBatch_result -> P.IO () +write_EmitBatch_result oprot record = T.writeVal oprot $ from_EmitBatch_result record +encode_EmitBatch_result :: T.StatelessProtocol p => p -> EmitBatch_result -> LBS.ByteString +encode_EmitBatch_result oprot record = T.serializeVal oprot $ from_EmitBatch_result record +to_EmitBatch_result :: T.ThriftVal -> EmitBatch_result +to_EmitBatch_result (T.TStruct fields) = EmitBatch_result{ + + } +to_EmitBatch_result _ = P.error "not a struct" +read_EmitBatch_result :: T.Protocol p => p -> P.IO EmitBatch_result +read_EmitBatch_result iprot = to_EmitBatch_result <$> T.readVal iprot (T.T_STRUCT typemap_EmitBatch_result) +decode_EmitBatch_result :: T.StatelessProtocol p => p -> LBS.ByteString -> EmitBatch_result +decode_EmitBatch_result iprot bs = to_EmitBatch_result $ T.deserializeVal iprot (T.T_STRUCT typemap_EmitBatch_result) bs +typemap_EmitBatch_result :: T.TypeMap +typemap_EmitBatch_result = Map.fromList [] +default_EmitBatch_result :: EmitBatch_result +default_EmitBatch_result = EmitBatch_result{ +} +process_emitZipkinBatch (seqid, iprot, oprot, handler) = do + args <- read_EmitZipkinBatch_args iprot + (X.catch + (do + Iface.emitZipkinBatch handler (emitZipkinBatch_args_spans args) + P.return ()) + ((\_ -> do + P.return ()) :: X.SomeException -> P.IO ())) +process_emitBatch (seqid, iprot, oprot, handler) = do + args <- read_EmitBatch_args iprot + (X.catch + (do + Iface.emitBatch handler (emitBatch_args_batch args) + P.return ()) + ((\_ -> do + P.return ()) :: X.SomeException -> P.IO ())) +proc_ handler (iprot,oprot) (name,typ,seqid) = case name of + "emitZipkinBatch" -> process_emitZipkinBatch (seqid,iprot,oprot,handler) + "emitBatch" -> process_emitBatch (seqid,iprot,oprot,handler) + _ -> do + _ <- T.readVal iprot (T.T_STRUCT Map.empty) + T.writeMessage oprot (name,T.M_EXCEPTION,seqid) $ + T.writeAppExn oprot (T.AppExn T.AE_UNKNOWN_METHOD ("Unknown function " ++ LT.unpack name)) +process handler (iprot, oprot) = do + T.readMessage iprot ( + proc_ handler (iprot,oprot)) + P.return P.True diff --git a/gen-src/Agent_Client.hs b/gen-src/Agent_Client.hs new file mode 100644 --- /dev/null +++ b/gen-src/Agent_Client.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-missing-fields #-} +{-# OPTIONS_GHC -fno-warn-missing-signatures #-} +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} +{-# OPTIONS_GHC -fno-warn-unused-imports #-} +{-# OPTIONS_GHC -fno-warn-unused-matches #-} + +----------------------------------------------------------------- +-- Autogenerated by Thrift Compiler (0.11.0) -- +-- -- +-- DO NOT EDIT UNLESS YOU ARE SURE YOU KNOW WHAT YOU ARE DOING -- +----------------------------------------------------------------- + +module Agent_Client(emitZipkinBatch,emitBatch) where +import qualified Data.IORef as R +import Prelude (($), (.), (>>=), (==), (++)) +import qualified Prelude as P +import qualified Control.Exception as X +import qualified Control.Monad as M ( liftM, ap, when ) +import Data.Functor ( (<$>) ) +import qualified Data.ByteString.Lazy as LBS +import qualified Data.Hashable as H +import qualified Data.Int as I +import qualified Data.Maybe as M (catMaybes) +import qualified Data.Text.Lazy.Encoding as E ( decodeUtf8, encodeUtf8 ) +import qualified Data.Text.Lazy as LT +import qualified GHC.Generics as G (Generic) +import qualified Data.Typeable as TY ( Typeable ) +import qualified Data.HashMap.Strict as Map +import qualified Data.HashSet as Set +import qualified Data.Vector as Vector +import qualified Test.QuickCheck.Arbitrary as QC ( Arbitrary(..) ) +import qualified Test.QuickCheck as QC ( elements ) + +import qualified Thrift as T +import qualified Thrift.Types as T +import qualified Thrift.Arbitraries as T + +import qualified Jaeger_Types +import qualified Zipkincore_Types + + +import Agent_Types +import Agent +seqid = R.newIORef 0 +emitZipkinBatch (ip,op) arg_spans = do + send_emitZipkinBatch op arg_spans +send_emitZipkinBatch op arg_spans = do + seq <- seqid + seqn <- R.readIORef seq + T.writeMessage op ("emitZipkinBatch", T.M_ONEWAY, seqn) $ + write_EmitZipkinBatch_args op (EmitZipkinBatch_args{emitZipkinBatch_args_spans=arg_spans}) +emitBatch (ip,op) arg_batch = do + send_emitBatch op arg_batch +send_emitBatch op arg_batch = do + seq <- seqid + seqn <- R.readIORef seq + T.writeMessage op ("emitBatch", T.M_ONEWAY, seqn) $ + write_EmitBatch_args op (EmitBatch_args{emitBatch_args_batch=arg_batch}) diff --git a/gen-src/Agent_Iface.hs b/gen-src/Agent_Iface.hs new file mode 100644 --- /dev/null +++ b/gen-src/Agent_Iface.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-missing-fields #-} +{-# OPTIONS_GHC -fno-warn-missing-signatures #-} +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} +{-# OPTIONS_GHC -fno-warn-unused-imports #-} +{-# OPTIONS_GHC -fno-warn-unused-matches #-} + +----------------------------------------------------------------- +-- Autogenerated by Thrift Compiler (0.11.0) -- +-- -- +-- DO NOT EDIT UNLESS YOU ARE SURE YOU KNOW WHAT YOU ARE DOING -- +----------------------------------------------------------------- + +module Agent_Iface where +import Prelude (($), (.), (>>=), (==), (++)) +import qualified Prelude as P +import qualified Control.Exception as X +import qualified Control.Monad as M ( liftM, ap, when ) +import Data.Functor ( (<$>) ) +import qualified Data.ByteString.Lazy as LBS +import qualified Data.Hashable as H +import qualified Data.Int as I +import qualified Data.Maybe as M (catMaybes) +import qualified Data.Text.Lazy.Encoding as E ( decodeUtf8, encodeUtf8 ) +import qualified Data.Text.Lazy as LT +import qualified GHC.Generics as G (Generic) +import qualified Data.Typeable as TY ( Typeable ) +import qualified Data.HashMap.Strict as Map +import qualified Data.HashSet as Set +import qualified Data.Vector as Vector +import qualified Test.QuickCheck.Arbitrary as QC ( Arbitrary(..) ) +import qualified Test.QuickCheck as QC ( elements ) + +import qualified Thrift as T +import qualified Thrift.Types as T +import qualified Thrift.Arbitraries as T + +import qualified Jaeger_Types +import qualified Zipkincore_Types + + +import Agent_Types + +class Agent_Iface a where + emitZipkinBatch :: a -> (Vector.Vector Zipkincore_Types.Span) -> P.IO () + emitBatch :: a -> Jaeger_Types.Batch -> P.IO () diff --git a/gen-src/Agent_Types.hs b/gen-src/Agent_Types.hs new file mode 100644 --- /dev/null +++ b/gen-src/Agent_Types.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-missing-fields #-} +{-# OPTIONS_GHC -fno-warn-missing-signatures #-} +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} +{-# OPTIONS_GHC -fno-warn-unused-imports #-} +{-# OPTIONS_GHC -fno-warn-unused-matches #-} + +----------------------------------------------------------------- +-- Autogenerated by Thrift Compiler (0.11.0) -- +-- -- +-- DO NOT EDIT UNLESS YOU ARE SURE YOU KNOW WHAT YOU ARE DOING -- +----------------------------------------------------------------- + +module Agent_Types where +import Prelude (($), (.), (>>=), (==), (++)) +import qualified Prelude as P +import qualified Control.Exception as X +import qualified Control.Monad as M ( liftM, ap, when ) +import Data.Functor ( (<$>) ) +import qualified Data.ByteString.Lazy as LBS +import qualified Data.Hashable as H +import qualified Data.Int as I +import qualified Data.Maybe as M (catMaybes) +import qualified Data.Text.Lazy.Encoding as E ( decodeUtf8, encodeUtf8 ) +import qualified Data.Text.Lazy as LT +import qualified GHC.Generics as G (Generic) +import qualified Data.Typeable as TY ( Typeable ) +import qualified Data.HashMap.Strict as Map +import qualified Data.HashSet as Set +import qualified Data.Vector as Vector +import qualified Test.QuickCheck.Arbitrary as QC ( Arbitrary(..) ) +import qualified Test.QuickCheck as QC ( elements ) + +import qualified Thrift as T +import qualified Thrift.Types as T +import qualified Thrift.Arbitraries as T + +import qualified Jaeger_Types +import qualified Zipkincore_Types + + diff --git a/gen-src/Jaeger_Consts.hs b/gen-src/Jaeger_Consts.hs new file mode 100644 --- /dev/null +++ b/gen-src/Jaeger_Consts.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-missing-fields #-} +{-# OPTIONS_GHC -fno-warn-missing-signatures #-} +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} +{-# OPTIONS_GHC -fno-warn-unused-imports #-} +{-# OPTIONS_GHC -fno-warn-unused-matches #-} + +----------------------------------------------------------------- +-- Autogenerated by Thrift Compiler (0.11.0) -- +-- -- +-- DO NOT EDIT UNLESS YOU ARE SURE YOU KNOW WHAT YOU ARE DOING -- +----------------------------------------------------------------- + +module Jaeger_Consts where +import Prelude (($), (.), (>>=), (==), (++)) +import qualified Prelude as P +import qualified Control.Exception as X +import qualified Control.Monad as M ( liftM, ap, when ) +import Data.Functor ( (<$>) ) +import qualified Data.ByteString.Lazy as LBS +import qualified Data.Hashable as H +import qualified Data.Int as I +import qualified Data.Maybe as M (catMaybes) +import qualified Data.Text.Lazy.Encoding as E ( decodeUtf8, encodeUtf8 ) +import qualified Data.Text.Lazy as LT +import qualified GHC.Generics as G (Generic) +import qualified Data.Typeable as TY ( Typeable ) +import qualified Data.HashMap.Strict as Map +import qualified Data.HashSet as Set +import qualified Data.Vector as Vector +import qualified Test.QuickCheck.Arbitrary as QC ( Arbitrary(..) ) +import qualified Test.QuickCheck as QC ( elements ) + +import qualified Thrift as T +import qualified Thrift.Types as T +import qualified Thrift.Arbitraries as T + + +import Jaeger_Types diff --git a/gen-src/Jaeger_Types.hs b/gen-src/Jaeger_Types.hs new file mode 100644 --- /dev/null +++ b/gen-src/Jaeger_Types.hs @@ -0,0 +1,434 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-missing-fields #-} +{-# OPTIONS_GHC -fno-warn-missing-signatures #-} +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} +{-# OPTIONS_GHC -fno-warn-unused-imports #-} +{-# OPTIONS_GHC -fno-warn-unused-matches #-} + +----------------------------------------------------------------- +-- Autogenerated by Thrift Compiler (0.11.0) -- +-- -- +-- DO NOT EDIT UNLESS YOU ARE SURE YOU KNOW WHAT YOU ARE DOING -- +----------------------------------------------------------------- + +module Jaeger_Types where +import Prelude (($), (.), (>>=), (==), (++)) +import qualified Prelude as P +import qualified Control.Exception as X +import qualified Control.Monad as M ( liftM, ap, when ) +import Data.Functor ( (<$>) ) +import qualified Data.ByteString.Lazy as LBS +import qualified Data.Hashable as H +import qualified Data.Int as I +import qualified Data.Maybe as M (catMaybes) +import qualified Data.Text.Lazy.Encoding as E ( decodeUtf8, encodeUtf8 ) +import qualified Data.Text.Lazy as LT +import qualified GHC.Generics as G (Generic) +import qualified Data.Typeable as TY ( Typeable ) +import qualified Data.HashMap.Strict as Map +import qualified Data.HashSet as Set +import qualified Data.Vector as Vector +import qualified Test.QuickCheck.Arbitrary as QC ( Arbitrary(..) ) +import qualified Test.QuickCheck as QC ( elements ) + +import qualified Thrift as T +import qualified Thrift.Types as T +import qualified Thrift.Arbitraries as T + + +data TagType = STRING|DOUBLE|BOOL|LONG|BINARY deriving (P.Show, P.Eq, G.Generic, TY.Typeable, P.Ord, P.Bounded) +instance P.Enum TagType where + fromEnum t = case t of + STRING -> 0 + DOUBLE -> 1 + BOOL -> 2 + LONG -> 3 + BINARY -> 4 + toEnum t = case t of + 0 -> STRING + 1 -> DOUBLE + 2 -> BOOL + 3 -> LONG + 4 -> BINARY + _ -> X.throw T.ThriftException +instance H.Hashable TagType where + hashWithSalt salt = H.hashWithSalt salt P.. P.fromEnum +instance QC.Arbitrary TagType where + arbitrary = QC.elements (P.enumFromTo P.minBound P.maxBound) +data SpanRefType = CHILD_OF|FOLLOWS_FROM deriving (P.Show, P.Eq, G.Generic, TY.Typeable, P.Ord, P.Bounded) +instance P.Enum SpanRefType where + fromEnum t = case t of + CHILD_OF -> 0 + FOLLOWS_FROM -> 1 + toEnum t = case t of + 0 -> CHILD_OF + 1 -> FOLLOWS_FROM + _ -> X.throw T.ThriftException +instance H.Hashable SpanRefType where + hashWithSalt salt = H.hashWithSalt salt P.. P.fromEnum +instance QC.Arbitrary SpanRefType where + arbitrary = QC.elements (P.enumFromTo P.minBound P.maxBound) +data Tag = Tag { tag_key :: LT.Text + , tag_vType :: TagType + , tag_vStr :: P.Maybe LT.Text + , tag_vDouble :: P.Maybe P.Double + , tag_vBool :: P.Maybe P.Bool + , tag_vLong :: P.Maybe I.Int64 + , tag_vBinary :: P.Maybe LBS.ByteString + } deriving (P.Show,P.Eq,G.Generic,TY.Typeable) +instance H.Hashable Tag where + hashWithSalt salt record = salt `H.hashWithSalt` tag_key record `H.hashWithSalt` tag_vType record `H.hashWithSalt` tag_vStr record `H.hashWithSalt` tag_vDouble record `H.hashWithSalt` tag_vBool record `H.hashWithSalt` tag_vLong record `H.hashWithSalt` tag_vBinary record +instance QC.Arbitrary Tag where + arbitrary = M.liftM Tag (QC.arbitrary) + `M.ap`(QC.arbitrary) + `M.ap`(M.liftM P.Just QC.arbitrary) + `M.ap`(M.liftM P.Just QC.arbitrary) + `M.ap`(M.liftM P.Just QC.arbitrary) + `M.ap`(M.liftM P.Just QC.arbitrary) + `M.ap`(M.liftM P.Just QC.arbitrary) + shrink obj | obj == default_Tag = [] + | P.otherwise = M.catMaybes + [ if obj == default_Tag{tag_key = tag_key obj} then P.Nothing else P.Just $ default_Tag{tag_key = tag_key obj} + , if obj == default_Tag{tag_vType = tag_vType obj} then P.Nothing else P.Just $ default_Tag{tag_vType = tag_vType obj} + , if obj == default_Tag{tag_vStr = tag_vStr obj} then P.Nothing else P.Just $ default_Tag{tag_vStr = tag_vStr obj} + , if obj == default_Tag{tag_vDouble = tag_vDouble obj} then P.Nothing else P.Just $ default_Tag{tag_vDouble = tag_vDouble obj} + , if obj == default_Tag{tag_vBool = tag_vBool obj} then P.Nothing else P.Just $ default_Tag{tag_vBool = tag_vBool obj} + , if obj == default_Tag{tag_vLong = tag_vLong obj} then P.Nothing else P.Just $ default_Tag{tag_vLong = tag_vLong obj} + , if obj == default_Tag{tag_vBinary = tag_vBinary obj} then P.Nothing else P.Just $ default_Tag{tag_vBinary = tag_vBinary obj} + ] +from_Tag :: Tag -> T.ThriftVal +from_Tag record = T.TStruct $ Map.fromList $ M.catMaybes + [ (\_v2 -> P.Just (1, ("key",T.TString $ E.encodeUtf8 _v2))) $ tag_key record + , (\_v2 -> P.Just (2, ("vType",T.TI32 $ P.fromIntegral $ P.fromEnum _v2))) $ tag_vType record + , (\_v2 -> (3, ("vStr",T.TString $ E.encodeUtf8 _v2))) <$> tag_vStr record + , (\_v2 -> (4, ("vDouble",T.TDouble _v2))) <$> tag_vDouble record + , (\_v2 -> (5, ("vBool",T.TBool _v2))) <$> tag_vBool record + , (\_v2 -> (6, ("vLong",T.TI64 _v2))) <$> tag_vLong record + , (\_v2 -> (7, ("vBinary",T.TBinary _v2))) <$> tag_vBinary record + ] +write_Tag :: T.Protocol p => p -> Tag -> P.IO () +write_Tag oprot record = T.writeVal oprot $ from_Tag record +encode_Tag :: T.StatelessProtocol p => p -> Tag -> LBS.ByteString +encode_Tag oprot record = T.serializeVal oprot $ from_Tag record +to_Tag :: T.ThriftVal -> Tag +to_Tag (T.TStruct fields) = Tag{ + tag_key = P.maybe (P.error "Missing required field: key") (\(_,_val4) -> (case _val4 of {T.TString _val5 -> E.decodeUtf8 _val5; _ -> P.error "wrong type"})) (Map.lookup (1) fields), + tag_vType = P.maybe (P.error "Missing required field: vType") (\(_,_val4) -> (case _val4 of {T.TI32 _val6 -> P.toEnum $ P.fromIntegral _val6; _ -> P.error "wrong type"})) (Map.lookup (2) fields), + tag_vStr = P.maybe (P.Nothing) (\(_,_val4) -> P.Just (case _val4 of {T.TString _val7 -> E.decodeUtf8 _val7; _ -> P.error "wrong type"})) (Map.lookup (3) fields), + tag_vDouble = P.maybe (P.Nothing) (\(_,_val4) -> P.Just (case _val4 of {T.TDouble _val8 -> _val8; _ -> P.error "wrong type"})) (Map.lookup (4) fields), + tag_vBool = P.maybe (P.Nothing) (\(_,_val4) -> P.Just (case _val4 of {T.TBool _val9 -> _val9; _ -> P.error "wrong type"})) (Map.lookup (5) fields), + tag_vLong = P.maybe (P.Nothing) (\(_,_val4) -> P.Just (case _val4 of {T.TI64 _val10 -> _val10; _ -> P.error "wrong type"})) (Map.lookup (6) fields), + tag_vBinary = P.maybe (P.Nothing) (\(_,_val4) -> P.Just (case _val4 of {T.TBinary _val11 -> _val11; T.TString _val11 -> _val11; _ -> P.error "wrong type"})) (Map.lookup (7) fields) + } +to_Tag _ = P.error "not a struct" +read_Tag :: T.Protocol p => p -> P.IO Tag +read_Tag iprot = to_Tag <$> T.readVal iprot (T.T_STRUCT typemap_Tag) +decode_Tag :: T.StatelessProtocol p => p -> LBS.ByteString -> Tag +decode_Tag iprot bs = to_Tag $ T.deserializeVal iprot (T.T_STRUCT typemap_Tag) bs +typemap_Tag :: T.TypeMap +typemap_Tag = Map.fromList [(1,("key",T.T_STRING)),(2,("vType",T.T_I32)),(3,("vStr",T.T_STRING)),(4,("vDouble",T.T_DOUBLE)),(5,("vBool",T.T_BOOL)),(6,("vLong",T.T_I64)),(7,("vBinary",T.T_BINARY))] +default_Tag :: Tag +default_Tag = Tag{ + tag_key = "", + tag_vType = (P.toEnum 0), + tag_vStr = P.Nothing, + tag_vDouble = P.Nothing, + tag_vBool = P.Nothing, + tag_vLong = P.Nothing, + tag_vBinary = P.Nothing} +data Log = Log { log_timestamp :: I.Int64 + , log_fields :: (Vector.Vector Tag) + } deriving (P.Show,P.Eq,G.Generic,TY.Typeable) +instance H.Hashable Log where + hashWithSalt salt record = salt `H.hashWithSalt` log_timestamp record `H.hashWithSalt` log_fields record +instance QC.Arbitrary Log where + arbitrary = M.liftM Log (QC.arbitrary) + `M.ap`(QC.arbitrary) + shrink obj | obj == default_Log = [] + | P.otherwise = M.catMaybes + [ if obj == default_Log{log_timestamp = log_timestamp obj} then P.Nothing else P.Just $ default_Log{log_timestamp = log_timestamp obj} + , if obj == default_Log{log_fields = log_fields obj} then P.Nothing else P.Just $ default_Log{log_fields = log_fields obj} + ] +from_Log :: Log -> T.ThriftVal +from_Log record = T.TStruct $ Map.fromList $ M.catMaybes + [ (\_v14 -> P.Just (1, ("timestamp",T.TI64 _v14))) $ log_timestamp record + , (\_v14 -> P.Just (2, ("fields",T.TList (T.T_STRUCT typemap_Tag) $ P.map (\_v16 -> from_Tag _v16) $ Vector.toList _v14))) $ log_fields record + ] +write_Log :: T.Protocol p => p -> Log -> P.IO () +write_Log oprot record = T.writeVal oprot $ from_Log record +encode_Log :: T.StatelessProtocol p => p -> Log -> LBS.ByteString +encode_Log oprot record = T.serializeVal oprot $ from_Log record +to_Log :: T.ThriftVal -> Log +to_Log (T.TStruct fields) = Log{ + log_timestamp = P.maybe (P.error "Missing required field: timestamp") (\(_,_val18) -> (case _val18 of {T.TI64 _val19 -> _val19; _ -> P.error "wrong type"})) (Map.lookup (1) fields), + log_fields = P.maybe (P.error "Missing required field: fields") (\(_,_val18) -> (case _val18 of {T.TList _ _val20 -> (Vector.fromList $ P.map (\_v21 -> (case _v21 of {T.TStruct _val22 -> (to_Tag (T.TStruct _val22)); _ -> P.error "wrong type"})) _val20); _ -> P.error "wrong type"})) (Map.lookup (2) fields) + } +to_Log _ = P.error "not a struct" +read_Log :: T.Protocol p => p -> P.IO Log +read_Log iprot = to_Log <$> T.readVal iprot (T.T_STRUCT typemap_Log) +decode_Log :: T.StatelessProtocol p => p -> LBS.ByteString -> Log +decode_Log iprot bs = to_Log $ T.deserializeVal iprot (T.T_STRUCT typemap_Log) bs +typemap_Log :: T.TypeMap +typemap_Log = Map.fromList [(1,("timestamp",T.T_I64)),(2,("fields",(T.T_LIST (T.T_STRUCT typemap_Tag))))] +default_Log :: Log +default_Log = Log{ + log_timestamp = 0, + log_fields = Vector.empty} +data SpanRef = SpanRef { spanRef_refType :: SpanRefType + , spanRef_traceIdLow :: I.Int64 + , spanRef_traceIdHigh :: I.Int64 + , spanRef_spanId :: I.Int64 + } deriving (P.Show,P.Eq,G.Generic,TY.Typeable) +instance H.Hashable SpanRef where + hashWithSalt salt record = salt `H.hashWithSalt` spanRef_refType record `H.hashWithSalt` spanRef_traceIdLow record `H.hashWithSalt` spanRef_traceIdHigh record `H.hashWithSalt` spanRef_spanId record +instance QC.Arbitrary SpanRef where + arbitrary = M.liftM SpanRef (QC.arbitrary) + `M.ap`(QC.arbitrary) + `M.ap`(QC.arbitrary) + `M.ap`(QC.arbitrary) + shrink obj | obj == default_SpanRef = [] + | P.otherwise = M.catMaybes + [ if obj == default_SpanRef{spanRef_refType = spanRef_refType obj} then P.Nothing else P.Just $ default_SpanRef{spanRef_refType = spanRef_refType obj} + , if obj == default_SpanRef{spanRef_traceIdLow = spanRef_traceIdLow obj} then P.Nothing else P.Just $ default_SpanRef{spanRef_traceIdLow = spanRef_traceIdLow obj} + , if obj == default_SpanRef{spanRef_traceIdHigh = spanRef_traceIdHigh obj} then P.Nothing else P.Just $ default_SpanRef{spanRef_traceIdHigh = spanRef_traceIdHigh obj} + , if obj == default_SpanRef{spanRef_spanId = spanRef_spanId obj} then P.Nothing else P.Just $ default_SpanRef{spanRef_spanId = spanRef_spanId obj} + ] +from_SpanRef :: SpanRef -> T.ThriftVal +from_SpanRef record = T.TStruct $ Map.fromList $ M.catMaybes + [ (\_v25 -> P.Just (1, ("refType",T.TI32 $ P.fromIntegral $ P.fromEnum _v25))) $ spanRef_refType record + , (\_v25 -> P.Just (2, ("traceIdLow",T.TI64 _v25))) $ spanRef_traceIdLow record + , (\_v25 -> P.Just (3, ("traceIdHigh",T.TI64 _v25))) $ spanRef_traceIdHigh record + , (\_v25 -> P.Just (4, ("spanId",T.TI64 _v25))) $ spanRef_spanId record + ] +write_SpanRef :: T.Protocol p => p -> SpanRef -> P.IO () +write_SpanRef oprot record = T.writeVal oprot $ from_SpanRef record +encode_SpanRef :: T.StatelessProtocol p => p -> SpanRef -> LBS.ByteString +encode_SpanRef oprot record = T.serializeVal oprot $ from_SpanRef record +to_SpanRef :: T.ThriftVal -> SpanRef +to_SpanRef (T.TStruct fields) = SpanRef{ + spanRef_refType = P.maybe (P.error "Missing required field: refType") (\(_,_val27) -> (case _val27 of {T.TI32 _val28 -> P.toEnum $ P.fromIntegral _val28; _ -> P.error "wrong type"})) (Map.lookup (1) fields), + spanRef_traceIdLow = P.maybe (P.error "Missing required field: traceIdLow") (\(_,_val27) -> (case _val27 of {T.TI64 _val29 -> _val29; _ -> P.error "wrong type"})) (Map.lookup (2) fields), + spanRef_traceIdHigh = P.maybe (P.error "Missing required field: traceIdHigh") (\(_,_val27) -> (case _val27 of {T.TI64 _val30 -> _val30; _ -> P.error "wrong type"})) (Map.lookup (3) fields), + spanRef_spanId = P.maybe (P.error "Missing required field: spanId") (\(_,_val27) -> (case _val27 of {T.TI64 _val31 -> _val31; _ -> P.error "wrong type"})) (Map.lookup (4) fields) + } +to_SpanRef _ = P.error "not a struct" +read_SpanRef :: T.Protocol p => p -> P.IO SpanRef +read_SpanRef iprot = to_SpanRef <$> T.readVal iprot (T.T_STRUCT typemap_SpanRef) +decode_SpanRef :: T.StatelessProtocol p => p -> LBS.ByteString -> SpanRef +decode_SpanRef iprot bs = to_SpanRef $ T.deserializeVal iprot (T.T_STRUCT typemap_SpanRef) bs +typemap_SpanRef :: T.TypeMap +typemap_SpanRef = Map.fromList [(1,("refType",T.T_I32)),(2,("traceIdLow",T.T_I64)),(3,("traceIdHigh",T.T_I64)),(4,("spanId",T.T_I64))] +default_SpanRef :: SpanRef +default_SpanRef = SpanRef{ + spanRef_refType = (P.toEnum 0), + spanRef_traceIdLow = 0, + spanRef_traceIdHigh = 0, + spanRef_spanId = 0} +data Span = Span { span_traceIdLow :: I.Int64 + , span_traceIdHigh :: I.Int64 + , span_spanId :: I.Int64 + , span_parentSpanId :: I.Int64 + , span_operationName :: LT.Text + , span_references :: P.Maybe (Vector.Vector SpanRef) + , span_flags :: I.Int32 + , span_startTime :: I.Int64 + , span_duration :: I.Int64 + , span_tags :: P.Maybe (Vector.Vector Tag) + , span_logs :: P.Maybe (Vector.Vector Log) + , span_incomplete :: P.Maybe P.Bool + } deriving (P.Show,P.Eq,G.Generic,TY.Typeable) +instance H.Hashable Span where + hashWithSalt salt record = salt `H.hashWithSalt` span_traceIdLow record `H.hashWithSalt` span_traceIdHigh record `H.hashWithSalt` span_spanId record `H.hashWithSalt` span_parentSpanId record `H.hashWithSalt` span_operationName record `H.hashWithSalt` span_references record `H.hashWithSalt` span_flags record `H.hashWithSalt` span_startTime record `H.hashWithSalt` span_duration record `H.hashWithSalt` span_tags record `H.hashWithSalt` span_logs record `H.hashWithSalt` span_incomplete record +instance QC.Arbitrary Span where + arbitrary = M.liftM Span (QC.arbitrary) + `M.ap`(QC.arbitrary) + `M.ap`(QC.arbitrary) + `M.ap`(QC.arbitrary) + `M.ap`(QC.arbitrary) + `M.ap`(M.liftM P.Just QC.arbitrary) + `M.ap`(QC.arbitrary) + `M.ap`(QC.arbitrary) + `M.ap`(QC.arbitrary) + `M.ap`(M.liftM P.Just QC.arbitrary) + `M.ap`(M.liftM P.Just QC.arbitrary) + `M.ap`(M.liftM P.Just QC.arbitrary) + shrink obj | obj == default_Span = [] + | P.otherwise = M.catMaybes + [ if obj == default_Span{span_traceIdLow = span_traceIdLow obj} then P.Nothing else P.Just $ default_Span{span_traceIdLow = span_traceIdLow obj} + , if obj == default_Span{span_traceIdHigh = span_traceIdHigh obj} then P.Nothing else P.Just $ default_Span{span_traceIdHigh = span_traceIdHigh obj} + , if obj == default_Span{span_spanId = span_spanId obj} then P.Nothing else P.Just $ default_Span{span_spanId = span_spanId obj} + , if obj == default_Span{span_parentSpanId = span_parentSpanId obj} then P.Nothing else P.Just $ default_Span{span_parentSpanId = span_parentSpanId obj} + , if obj == default_Span{span_operationName = span_operationName obj} then P.Nothing else P.Just $ default_Span{span_operationName = span_operationName obj} + , if obj == default_Span{span_references = span_references obj} then P.Nothing else P.Just $ default_Span{span_references = span_references obj} + , if obj == default_Span{span_flags = span_flags obj} then P.Nothing else P.Just $ default_Span{span_flags = span_flags obj} + , if obj == default_Span{span_startTime = span_startTime obj} then P.Nothing else P.Just $ default_Span{span_startTime = span_startTime obj} + , if obj == default_Span{span_duration = span_duration obj} then P.Nothing else P.Just $ default_Span{span_duration = span_duration obj} + , if obj == default_Span{span_tags = span_tags obj} then P.Nothing else P.Just $ default_Span{span_tags = span_tags obj} + , if obj == default_Span{span_logs = span_logs obj} then P.Nothing else P.Just $ default_Span{span_logs = span_logs obj} + , if obj == default_Span{span_incomplete = span_incomplete obj} then P.Nothing else P.Just $ default_Span{span_incomplete = span_incomplete obj} + ] +from_Span :: Span -> T.ThriftVal +from_Span record = T.TStruct $ Map.fromList $ M.catMaybes + [ (\_v34 -> P.Just (1, ("traceIdLow",T.TI64 _v34))) $ span_traceIdLow record + , (\_v34 -> P.Just (2, ("traceIdHigh",T.TI64 _v34))) $ span_traceIdHigh record + , (\_v34 -> P.Just (3, ("spanId",T.TI64 _v34))) $ span_spanId record + , (\_v34 -> P.Just (4, ("parentSpanId",T.TI64 _v34))) $ span_parentSpanId record + , (\_v34 -> P.Just (5, ("operationName",T.TString $ E.encodeUtf8 _v34))) $ span_operationName record + , (\_v34 -> (6, ("references",T.TList (T.T_STRUCT typemap_SpanRef) $ P.map (\_v36 -> from_SpanRef _v36) $ Vector.toList _v34))) <$> span_references record + , (\_v34 -> P.Just (7, ("flags",T.TI32 _v34))) $ span_flags record + , (\_v34 -> P.Just (8, ("startTime",T.TI64 _v34))) $ span_startTime record + , (\_v34 -> P.Just (9, ("duration",T.TI64 _v34))) $ span_duration record + , (\_v34 -> (10, ("tags",T.TList (T.T_STRUCT typemap_Tag) $ P.map (\_v38 -> from_Tag _v38) $ Vector.toList _v34))) <$> span_tags record + , (\_v34 -> (11, ("logs",T.TList (T.T_STRUCT typemap_Log) $ P.map (\_v40 -> from_Log _v40) $ Vector.toList _v34))) <$> span_logs record + , (\_v34 -> (12, ("incomplete",T.TBool _v34))) <$> span_incomplete record + ] +write_Span :: T.Protocol p => p -> Span -> P.IO () +write_Span oprot record = T.writeVal oprot $ from_Span record +encode_Span :: T.StatelessProtocol p => p -> Span -> LBS.ByteString +encode_Span oprot record = T.serializeVal oprot $ from_Span record +to_Span :: T.ThriftVal -> Span +to_Span (T.TStruct fields) = Span{ + span_traceIdLow = P.maybe (P.error "Missing required field: traceIdLow") (\(_,_val42) -> (case _val42 of {T.TI64 _val43 -> _val43; _ -> P.error "wrong type"})) (Map.lookup (1) fields), + span_traceIdHigh = P.maybe (P.error "Missing required field: traceIdHigh") (\(_,_val42) -> (case _val42 of {T.TI64 _val44 -> _val44; _ -> P.error "wrong type"})) (Map.lookup (2) fields), + span_spanId = P.maybe (P.error "Missing required field: spanId") (\(_,_val42) -> (case _val42 of {T.TI64 _val45 -> _val45; _ -> P.error "wrong type"})) (Map.lookup (3) fields), + span_parentSpanId = P.maybe (P.error "Missing required field: parentSpanId") (\(_,_val42) -> (case _val42 of {T.TI64 _val46 -> _val46; _ -> P.error "wrong type"})) (Map.lookup (4) fields), + span_operationName = P.maybe (P.error "Missing required field: operationName") (\(_,_val42) -> (case _val42 of {T.TString _val47 -> E.decodeUtf8 _val47; _ -> P.error "wrong type"})) (Map.lookup (5) fields), + span_references = P.maybe (P.Nothing) (\(_,_val42) -> P.Just (case _val42 of {T.TList _ _val48 -> (Vector.fromList $ P.map (\_v49 -> (case _v49 of {T.TStruct _val50 -> (to_SpanRef (T.TStruct _val50)); _ -> P.error "wrong type"})) _val48); _ -> P.error "wrong type"})) (Map.lookup (6) fields), + span_flags = P.maybe (P.error "Missing required field: flags") (\(_,_val42) -> (case _val42 of {T.TI32 _val51 -> _val51; _ -> P.error "wrong type"})) (Map.lookup (7) fields), + span_startTime = P.maybe (P.error "Missing required field: startTime") (\(_,_val42) -> (case _val42 of {T.TI64 _val52 -> _val52; _ -> P.error "wrong type"})) (Map.lookup (8) fields), + span_duration = P.maybe (P.error "Missing required field: duration") (\(_,_val42) -> (case _val42 of {T.TI64 _val53 -> _val53; _ -> P.error "wrong type"})) (Map.lookup (9) fields), + span_tags = P.maybe (P.Nothing) (\(_,_val42) -> P.Just (case _val42 of {T.TList _ _val54 -> (Vector.fromList $ P.map (\_v55 -> (case _v55 of {T.TStruct _val56 -> (to_Tag (T.TStruct _val56)); _ -> P.error "wrong type"})) _val54); _ -> P.error "wrong type"})) (Map.lookup (10) fields), + span_logs = P.maybe (P.Nothing) (\(_,_val42) -> P.Just (case _val42 of {T.TList _ _val57 -> (Vector.fromList $ P.map (\_v58 -> (case _v58 of {T.TStruct _val59 -> (to_Log (T.TStruct _val59)); _ -> P.error "wrong type"})) _val57); _ -> P.error "wrong type"})) (Map.lookup (11) fields), + span_incomplete = P.maybe (P.Nothing) (\(_,_val42) -> P.Just (case _val42 of {T.TBool _val60 -> _val60; _ -> P.error "wrong type"})) (Map.lookup (12) fields) + } +to_Span _ = P.error "not a struct" +read_Span :: T.Protocol p => p -> P.IO Span +read_Span iprot = to_Span <$> T.readVal iprot (T.T_STRUCT typemap_Span) +decode_Span :: T.StatelessProtocol p => p -> LBS.ByteString -> Span +decode_Span iprot bs = to_Span $ T.deserializeVal iprot (T.T_STRUCT typemap_Span) bs +typemap_Span :: T.TypeMap +typemap_Span = Map.fromList [(1,("traceIdLow",T.T_I64)),(2,("traceIdHigh",T.T_I64)),(3,("spanId",T.T_I64)),(4,("parentSpanId",T.T_I64)),(5,("operationName",T.T_STRING)),(6,("references",(T.T_LIST (T.T_STRUCT typemap_SpanRef)))),(7,("flags",T.T_I32)),(8,("startTime",T.T_I64)),(9,("duration",T.T_I64)),(10,("tags",(T.T_LIST (T.T_STRUCT typemap_Tag)))),(11,("logs",(T.T_LIST (T.T_STRUCT typemap_Log)))),(12,("incomplete",T.T_BOOL))] +default_Span :: Span +default_Span = Span{ + span_traceIdLow = 0, + span_traceIdHigh = 0, + span_spanId = 0, + span_parentSpanId = 0, + span_operationName = "", + span_references = P.Nothing, + span_flags = 0, + span_startTime = 0, + span_duration = 0, + span_tags = P.Nothing, + span_logs = P.Nothing, + span_incomplete = P.Nothing} +data Process = Process { process_serviceName :: LT.Text + , process_tags :: P.Maybe (Vector.Vector Tag) + } deriving (P.Show,P.Eq,G.Generic,TY.Typeable) +instance H.Hashable Process where + hashWithSalt salt record = salt `H.hashWithSalt` process_serviceName record `H.hashWithSalt` process_tags record +instance QC.Arbitrary Process where + arbitrary = M.liftM Process (QC.arbitrary) + `M.ap`(M.liftM P.Just QC.arbitrary) + shrink obj | obj == default_Process = [] + | P.otherwise = M.catMaybes + [ if obj == default_Process{process_serviceName = process_serviceName obj} then P.Nothing else P.Just $ default_Process{process_serviceName = process_serviceName obj} + , if obj == default_Process{process_tags = process_tags obj} then P.Nothing else P.Just $ default_Process{process_tags = process_tags obj} + ] +from_Process :: Process -> T.ThriftVal +from_Process record = T.TStruct $ Map.fromList $ M.catMaybes + [ (\_v63 -> P.Just (1, ("serviceName",T.TString $ E.encodeUtf8 _v63))) $ process_serviceName record + , (\_v63 -> (2, ("tags",T.TList (T.T_STRUCT typemap_Tag) $ P.map (\_v65 -> from_Tag _v65) $ Vector.toList _v63))) <$> process_tags record + ] +write_Process :: T.Protocol p => p -> Process -> P.IO () +write_Process oprot record = T.writeVal oprot $ from_Process record +encode_Process :: T.StatelessProtocol p => p -> Process -> LBS.ByteString +encode_Process oprot record = T.serializeVal oprot $ from_Process record +to_Process :: T.ThriftVal -> Process +to_Process (T.TStruct fields) = Process{ + process_serviceName = P.maybe (P.error "Missing required field: serviceName") (\(_,_val67) -> (case _val67 of {T.TString _val68 -> E.decodeUtf8 _val68; _ -> P.error "wrong type"})) (Map.lookup (1) fields), + process_tags = P.maybe (P.Nothing) (\(_,_val67) -> P.Just (case _val67 of {T.TList _ _val69 -> (Vector.fromList $ P.map (\_v70 -> (case _v70 of {T.TStruct _val71 -> (to_Tag (T.TStruct _val71)); _ -> P.error "wrong type"})) _val69); _ -> P.error "wrong type"})) (Map.lookup (2) fields) + } +to_Process _ = P.error "not a struct" +read_Process :: T.Protocol p => p -> P.IO Process +read_Process iprot = to_Process <$> T.readVal iprot (T.T_STRUCT typemap_Process) +decode_Process :: T.StatelessProtocol p => p -> LBS.ByteString -> Process +decode_Process iprot bs = to_Process $ T.deserializeVal iprot (T.T_STRUCT typemap_Process) bs +typemap_Process :: T.TypeMap +typemap_Process = Map.fromList [(1,("serviceName",T.T_STRING)),(2,("tags",(T.T_LIST (T.T_STRUCT typemap_Tag))))] +default_Process :: Process +default_Process = Process{ + process_serviceName = "", + process_tags = P.Nothing} +data Batch = Batch { batch_process :: Process + , batch_spans :: (Vector.Vector Span) + } deriving (P.Show,P.Eq,G.Generic,TY.Typeable) +instance H.Hashable Batch where + hashWithSalt salt record = salt `H.hashWithSalt` batch_process record `H.hashWithSalt` batch_spans record +instance QC.Arbitrary Batch where + arbitrary = M.liftM Batch (QC.arbitrary) + `M.ap`(QC.arbitrary) + shrink obj | obj == default_Batch = [] + | P.otherwise = M.catMaybes + [ if obj == default_Batch{batch_process = batch_process obj} then P.Nothing else P.Just $ default_Batch{batch_process = batch_process obj} + , if obj == default_Batch{batch_spans = batch_spans obj} then P.Nothing else P.Just $ default_Batch{batch_spans = batch_spans obj} + ] +from_Batch :: Batch -> T.ThriftVal +from_Batch record = T.TStruct $ Map.fromList $ M.catMaybes + [ (\_v74 -> P.Just (1, ("process",from_Process _v74))) $ batch_process record + , (\_v74 -> P.Just (2, ("spans",T.TList (T.T_STRUCT typemap_Span) $ P.map (\_v76 -> from_Span _v76) $ Vector.toList _v74))) $ batch_spans record + ] +write_Batch :: T.Protocol p => p -> Batch -> P.IO () +write_Batch oprot record = T.writeVal oprot $ from_Batch record +encode_Batch :: T.StatelessProtocol p => p -> Batch -> LBS.ByteString +encode_Batch oprot record = T.serializeVal oprot $ from_Batch record +to_Batch :: T.ThriftVal -> Batch +to_Batch (T.TStruct fields) = Batch{ + batch_process = P.maybe (P.error "Missing required field: process") (\(_,_val78) -> (case _val78 of {T.TStruct _val79 -> (to_Process (T.TStruct _val79)); _ -> P.error "wrong type"})) (Map.lookup (1) fields), + batch_spans = P.maybe (P.error "Missing required field: spans") (\(_,_val78) -> (case _val78 of {T.TList _ _val80 -> (Vector.fromList $ P.map (\_v81 -> (case _v81 of {T.TStruct _val82 -> (to_Span (T.TStruct _val82)); _ -> P.error "wrong type"})) _val80); _ -> P.error "wrong type"})) (Map.lookup (2) fields) + } +to_Batch _ = P.error "not a struct" +read_Batch :: T.Protocol p => p -> P.IO Batch +read_Batch iprot = to_Batch <$> T.readVal iprot (T.T_STRUCT typemap_Batch) +decode_Batch :: T.StatelessProtocol p => p -> LBS.ByteString -> Batch +decode_Batch iprot bs = to_Batch $ T.deserializeVal iprot (T.T_STRUCT typemap_Batch) bs +typemap_Batch :: T.TypeMap +typemap_Batch = Map.fromList [(1,("process",(T.T_STRUCT typemap_Process))),(2,("spans",(T.T_LIST (T.T_STRUCT typemap_Span))))] +default_Batch :: Batch +default_Batch = Batch{ + batch_process = default_Process, + batch_spans = Vector.empty} +data BatchSubmitResponse = BatchSubmitResponse { batchSubmitResponse_ok :: P.Bool + } deriving (P.Show,P.Eq,G.Generic,TY.Typeable) +instance H.Hashable BatchSubmitResponse where + hashWithSalt salt record = salt `H.hashWithSalt` batchSubmitResponse_ok record +instance QC.Arbitrary BatchSubmitResponse where + arbitrary = M.liftM BatchSubmitResponse (QC.arbitrary) + shrink obj | obj == default_BatchSubmitResponse = [] + | P.otherwise = M.catMaybes + [ if obj == default_BatchSubmitResponse{batchSubmitResponse_ok = batchSubmitResponse_ok obj} then P.Nothing else P.Just $ default_BatchSubmitResponse{batchSubmitResponse_ok = batchSubmitResponse_ok obj} + ] +from_BatchSubmitResponse :: BatchSubmitResponse -> T.ThriftVal +from_BatchSubmitResponse record = T.TStruct $ Map.fromList $ M.catMaybes + [ (\_v85 -> P.Just (1, ("ok",T.TBool _v85))) $ batchSubmitResponse_ok record + ] +write_BatchSubmitResponse :: T.Protocol p => p -> BatchSubmitResponse -> P.IO () +write_BatchSubmitResponse oprot record = T.writeVal oprot $ from_BatchSubmitResponse record +encode_BatchSubmitResponse :: T.StatelessProtocol p => p -> BatchSubmitResponse -> LBS.ByteString +encode_BatchSubmitResponse oprot record = T.serializeVal oprot $ from_BatchSubmitResponse record +to_BatchSubmitResponse :: T.ThriftVal -> BatchSubmitResponse +to_BatchSubmitResponse (T.TStruct fields) = BatchSubmitResponse{ + batchSubmitResponse_ok = P.maybe (P.error "Missing required field: ok") (\(_,_val87) -> (case _val87 of {T.TBool _val88 -> _val88; _ -> P.error "wrong type"})) (Map.lookup (1) fields) + } +to_BatchSubmitResponse _ = P.error "not a struct" +read_BatchSubmitResponse :: T.Protocol p => p -> P.IO BatchSubmitResponse +read_BatchSubmitResponse iprot = to_BatchSubmitResponse <$> T.readVal iprot (T.T_STRUCT typemap_BatchSubmitResponse) +decode_BatchSubmitResponse :: T.StatelessProtocol p => p -> LBS.ByteString -> BatchSubmitResponse +decode_BatchSubmitResponse iprot bs = to_BatchSubmitResponse $ T.deserializeVal iprot (T.T_STRUCT typemap_BatchSubmitResponse) bs +typemap_BatchSubmitResponse :: T.TypeMap +typemap_BatchSubmitResponse = Map.fromList [(1,("ok",T.T_BOOL))] +default_BatchSubmitResponse :: BatchSubmitResponse +default_BatchSubmitResponse = BatchSubmitResponse{ + batchSubmitResponse_ok = P.False} diff --git a/gen-src/Zipkincore_Types.hs b/gen-src/Zipkincore_Types.hs new file mode 100644 --- /dev/null +++ b/gen-src/Zipkincore_Types.hs @@ -0,0 +1,325 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-missing-fields #-} +{-# OPTIONS_GHC -fno-warn-missing-signatures #-} +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} +{-# OPTIONS_GHC -fno-warn-unused-imports #-} +{-# OPTIONS_GHC -fno-warn-unused-matches #-} + +----------------------------------------------------------------- +-- Autogenerated by Thrift Compiler (0.11.0) -- +-- -- +-- DO NOT EDIT UNLESS YOU ARE SURE YOU KNOW WHAT YOU ARE DOING -- +----------------------------------------------------------------- + +module Zipkincore_Types where +import Prelude (($), (.), (>>=), (==), (++)) +import qualified Prelude as P +import qualified Control.Exception as X +import qualified Control.Monad as M ( liftM, ap, when ) +import Data.Functor ( (<$>) ) +import qualified Data.ByteString.Lazy as LBS +import qualified Data.Hashable as H +import qualified Data.Int as I +import qualified Data.Maybe as M (catMaybes) +import qualified Data.Text.Lazy.Encoding as E ( decodeUtf8, encodeUtf8 ) +import qualified Data.Text.Lazy as LT +import qualified GHC.Generics as G (Generic) +import qualified Data.Typeable as TY ( Typeable ) +import qualified Data.HashMap.Strict as Map +import qualified Data.HashSet as Set +import qualified Data.Vector as Vector +import qualified Test.QuickCheck.Arbitrary as QC ( Arbitrary(..) ) +import qualified Test.QuickCheck as QC ( elements ) + +import qualified Thrift as T +import qualified Thrift.Types as T +import qualified Thrift.Arbitraries as T + + +data AnnotationType = BOOL|BYTES|I16|I32|I64|DOUBLE|STRING deriving (P.Show, P.Eq, G.Generic, TY.Typeable, P.Ord, P.Bounded) +instance P.Enum AnnotationType where + fromEnum t = case t of + BOOL -> 0 + BYTES -> 1 + I16 -> 2 + I32 -> 3 + I64 -> 4 + DOUBLE -> 5 + STRING -> 6 + toEnum t = case t of + 0 -> BOOL + 1 -> BYTES + 2 -> I16 + 3 -> I32 + 4 -> I64 + 5 -> DOUBLE + 6 -> STRING + _ -> X.throw T.ThriftException +instance H.Hashable AnnotationType where + hashWithSalt salt = H.hashWithSalt salt P.. P.fromEnum +instance QC.Arbitrary AnnotationType where + arbitrary = QC.elements (P.enumFromTo P.minBound P.maxBound) +data Endpoint = Endpoint { endpoint_ipv4 :: I.Int32 + , endpoint_port :: I.Int16 + , endpoint_service_name :: LT.Text + , endpoint_ipv6 :: P.Maybe LBS.ByteString + } deriving (P.Show,P.Eq,G.Generic,TY.Typeable) +instance H.Hashable Endpoint where + hashWithSalt salt record = salt `H.hashWithSalt` endpoint_ipv4 record `H.hashWithSalt` endpoint_port record `H.hashWithSalt` endpoint_service_name record `H.hashWithSalt` endpoint_ipv6 record +instance QC.Arbitrary Endpoint where + arbitrary = M.liftM Endpoint (QC.arbitrary) + `M.ap`(QC.arbitrary) + `M.ap`(QC.arbitrary) + `M.ap`(M.liftM P.Just QC.arbitrary) + shrink obj | obj == default_Endpoint = [] + | P.otherwise = M.catMaybes + [ if obj == default_Endpoint{endpoint_ipv4 = endpoint_ipv4 obj} then P.Nothing else P.Just $ default_Endpoint{endpoint_ipv4 = endpoint_ipv4 obj} + , if obj == default_Endpoint{endpoint_port = endpoint_port obj} then P.Nothing else P.Just $ default_Endpoint{endpoint_port = endpoint_port obj} + , if obj == default_Endpoint{endpoint_service_name = endpoint_service_name obj} then P.Nothing else P.Just $ default_Endpoint{endpoint_service_name = endpoint_service_name obj} + , if obj == default_Endpoint{endpoint_ipv6 = endpoint_ipv6 obj} then P.Nothing else P.Just $ default_Endpoint{endpoint_ipv6 = endpoint_ipv6 obj} + ] +from_Endpoint :: Endpoint -> T.ThriftVal +from_Endpoint record = T.TStruct $ Map.fromList $ M.catMaybes + [ (\_v2 -> P.Just (1, ("ipv4",T.TI32 _v2))) $ endpoint_ipv4 record + , (\_v2 -> P.Just (2, ("port",T.TI16 _v2))) $ endpoint_port record + , (\_v2 -> P.Just (3, ("service_name",T.TString $ E.encodeUtf8 _v2))) $ endpoint_service_name record + , (\_v2 -> (4, ("ipv6",T.TBinary _v2))) <$> endpoint_ipv6 record + ] +write_Endpoint :: T.Protocol p => p -> Endpoint -> P.IO () +write_Endpoint oprot record = T.writeVal oprot $ from_Endpoint record +encode_Endpoint :: T.StatelessProtocol p => p -> Endpoint -> LBS.ByteString +encode_Endpoint oprot record = T.serializeVal oprot $ from_Endpoint record +to_Endpoint :: T.ThriftVal -> Endpoint +to_Endpoint (T.TStruct fields) = Endpoint{ + endpoint_ipv4 = P.maybe (endpoint_ipv4 default_Endpoint) (\(_,_val4) -> (case _val4 of {T.TI32 _val5 -> _val5; _ -> P.error "wrong type"})) (Map.lookup (1) fields), + endpoint_port = P.maybe (endpoint_port default_Endpoint) (\(_,_val4) -> (case _val4 of {T.TI16 _val6 -> _val6; _ -> P.error "wrong type"})) (Map.lookup (2) fields), + endpoint_service_name = P.maybe (endpoint_service_name default_Endpoint) (\(_,_val4) -> (case _val4 of {T.TString _val7 -> E.decodeUtf8 _val7; _ -> P.error "wrong type"})) (Map.lookup (3) fields), + endpoint_ipv6 = P.maybe (P.Nothing) (\(_,_val4) -> P.Just (case _val4 of {T.TBinary _val8 -> _val8; T.TString _val8 -> _val8; _ -> P.error "wrong type"})) (Map.lookup (4) fields) + } +to_Endpoint _ = P.error "not a struct" +read_Endpoint :: T.Protocol p => p -> P.IO Endpoint +read_Endpoint iprot = to_Endpoint <$> T.readVal iprot (T.T_STRUCT typemap_Endpoint) +decode_Endpoint :: T.StatelessProtocol p => p -> LBS.ByteString -> Endpoint +decode_Endpoint iprot bs = to_Endpoint $ T.deserializeVal iprot (T.T_STRUCT typemap_Endpoint) bs +typemap_Endpoint :: T.TypeMap +typemap_Endpoint = Map.fromList [(1,("ipv4",T.T_I32)),(2,("port",T.T_I16)),(3,("service_name",T.T_STRING)),(4,("ipv6",T.T_BINARY))] +default_Endpoint :: Endpoint +default_Endpoint = Endpoint{ + endpoint_ipv4 = 0, + endpoint_port = 0, + endpoint_service_name = "", + endpoint_ipv6 = P.Nothing} +data Annotation = Annotation { annotation_timestamp :: I.Int64 + , annotation_value :: LT.Text + , annotation_host :: P.Maybe Endpoint + } deriving (P.Show,P.Eq,G.Generic,TY.Typeable) +instance H.Hashable Annotation where + hashWithSalt salt record = salt `H.hashWithSalt` annotation_timestamp record `H.hashWithSalt` annotation_value record `H.hashWithSalt` annotation_host record +instance QC.Arbitrary Annotation where + arbitrary = M.liftM Annotation (QC.arbitrary) + `M.ap`(QC.arbitrary) + `M.ap`(M.liftM P.Just QC.arbitrary) + shrink obj | obj == default_Annotation = [] + | P.otherwise = M.catMaybes + [ if obj == default_Annotation{annotation_timestamp = annotation_timestamp obj} then P.Nothing else P.Just $ default_Annotation{annotation_timestamp = annotation_timestamp obj} + , if obj == default_Annotation{annotation_value = annotation_value obj} then P.Nothing else P.Just $ default_Annotation{annotation_value = annotation_value obj} + , if obj == default_Annotation{annotation_host = annotation_host obj} then P.Nothing else P.Just $ default_Annotation{annotation_host = annotation_host obj} + ] +from_Annotation :: Annotation -> T.ThriftVal +from_Annotation record = T.TStruct $ Map.fromList $ M.catMaybes + [ (\_v11 -> P.Just (1, ("timestamp",T.TI64 _v11))) $ annotation_timestamp record + , (\_v11 -> P.Just (2, ("value",T.TString $ E.encodeUtf8 _v11))) $ annotation_value record + , (\_v11 -> (3, ("host",from_Endpoint _v11))) <$> annotation_host record + ] +write_Annotation :: T.Protocol p => p -> Annotation -> P.IO () +write_Annotation oprot record = T.writeVal oprot $ from_Annotation record +encode_Annotation :: T.StatelessProtocol p => p -> Annotation -> LBS.ByteString +encode_Annotation oprot record = T.serializeVal oprot $ from_Annotation record +to_Annotation :: T.ThriftVal -> Annotation +to_Annotation (T.TStruct fields) = Annotation{ + annotation_timestamp = P.maybe (annotation_timestamp default_Annotation) (\(_,_val13) -> (case _val13 of {T.TI64 _val14 -> _val14; _ -> P.error "wrong type"})) (Map.lookup (1) fields), + annotation_value = P.maybe (annotation_value default_Annotation) (\(_,_val13) -> (case _val13 of {T.TString _val15 -> E.decodeUtf8 _val15; _ -> P.error "wrong type"})) (Map.lookup (2) fields), + annotation_host = P.maybe (P.Nothing) (\(_,_val13) -> P.Just (case _val13 of {T.TStruct _val16 -> (to_Endpoint (T.TStruct _val16)); _ -> P.error "wrong type"})) (Map.lookup (3) fields) + } +to_Annotation _ = P.error "not a struct" +read_Annotation :: T.Protocol p => p -> P.IO Annotation +read_Annotation iprot = to_Annotation <$> T.readVal iprot (T.T_STRUCT typemap_Annotation) +decode_Annotation :: T.StatelessProtocol p => p -> LBS.ByteString -> Annotation +decode_Annotation iprot bs = to_Annotation $ T.deserializeVal iprot (T.T_STRUCT typemap_Annotation) bs +typemap_Annotation :: T.TypeMap +typemap_Annotation = Map.fromList [(1,("timestamp",T.T_I64)),(2,("value",T.T_STRING)),(3,("host",(T.T_STRUCT typemap_Endpoint)))] +default_Annotation :: Annotation +default_Annotation = Annotation{ + annotation_timestamp = 0, + annotation_value = "", + annotation_host = P.Nothing} +data BinaryAnnotation = BinaryAnnotation { binaryAnnotation_key :: LT.Text + , binaryAnnotation_value :: LBS.ByteString + , binaryAnnotation_annotation_type :: AnnotationType + , binaryAnnotation_host :: P.Maybe Endpoint + } deriving (P.Show,P.Eq,G.Generic,TY.Typeable) +instance H.Hashable BinaryAnnotation where + hashWithSalt salt record = salt `H.hashWithSalt` binaryAnnotation_key record `H.hashWithSalt` binaryAnnotation_value record `H.hashWithSalt` binaryAnnotation_annotation_type record `H.hashWithSalt` binaryAnnotation_host record +instance QC.Arbitrary BinaryAnnotation where + arbitrary = M.liftM BinaryAnnotation (QC.arbitrary) + `M.ap`(QC.arbitrary) + `M.ap`(QC.arbitrary) + `M.ap`(M.liftM P.Just QC.arbitrary) + shrink obj | obj == default_BinaryAnnotation = [] + | P.otherwise = M.catMaybes + [ if obj == default_BinaryAnnotation{binaryAnnotation_key = binaryAnnotation_key obj} then P.Nothing else P.Just $ default_BinaryAnnotation{binaryAnnotation_key = binaryAnnotation_key obj} + , if obj == default_BinaryAnnotation{binaryAnnotation_value = binaryAnnotation_value obj} then P.Nothing else P.Just $ default_BinaryAnnotation{binaryAnnotation_value = binaryAnnotation_value obj} + , if obj == default_BinaryAnnotation{binaryAnnotation_annotation_type = binaryAnnotation_annotation_type obj} then P.Nothing else P.Just $ default_BinaryAnnotation{binaryAnnotation_annotation_type = binaryAnnotation_annotation_type obj} + , if obj == default_BinaryAnnotation{binaryAnnotation_host = binaryAnnotation_host obj} then P.Nothing else P.Just $ default_BinaryAnnotation{binaryAnnotation_host = binaryAnnotation_host obj} + ] +from_BinaryAnnotation :: BinaryAnnotation -> T.ThriftVal +from_BinaryAnnotation record = T.TStruct $ Map.fromList $ M.catMaybes + [ (\_v19 -> P.Just (1, ("key",T.TString $ E.encodeUtf8 _v19))) $ binaryAnnotation_key record + , (\_v19 -> P.Just (2, ("value",T.TBinary _v19))) $ binaryAnnotation_value record + , (\_v19 -> P.Just (3, ("annotation_type",T.TI32 $ P.fromIntegral $ P.fromEnum _v19))) $ binaryAnnotation_annotation_type record + , (\_v19 -> (4, ("host",from_Endpoint _v19))) <$> binaryAnnotation_host record + ] +write_BinaryAnnotation :: T.Protocol p => p -> BinaryAnnotation -> P.IO () +write_BinaryAnnotation oprot record = T.writeVal oprot $ from_BinaryAnnotation record +encode_BinaryAnnotation :: T.StatelessProtocol p => p -> BinaryAnnotation -> LBS.ByteString +encode_BinaryAnnotation oprot record = T.serializeVal oprot $ from_BinaryAnnotation record +to_BinaryAnnotation :: T.ThriftVal -> BinaryAnnotation +to_BinaryAnnotation (T.TStruct fields) = BinaryAnnotation{ + binaryAnnotation_key = P.maybe (binaryAnnotation_key default_BinaryAnnotation) (\(_,_val21) -> (case _val21 of {T.TString _val22 -> E.decodeUtf8 _val22; _ -> P.error "wrong type"})) (Map.lookup (1) fields), + binaryAnnotation_value = P.maybe (binaryAnnotation_value default_BinaryAnnotation) (\(_,_val21) -> (case _val21 of {T.TBinary _val23 -> _val23; T.TString _val23 -> _val23; _ -> P.error "wrong type"})) (Map.lookup (2) fields), + binaryAnnotation_annotation_type = P.maybe (binaryAnnotation_annotation_type default_BinaryAnnotation) (\(_,_val21) -> (case _val21 of {T.TI32 _val24 -> P.toEnum $ P.fromIntegral _val24; _ -> P.error "wrong type"})) (Map.lookup (3) fields), + binaryAnnotation_host = P.maybe (P.Nothing) (\(_,_val21) -> P.Just (case _val21 of {T.TStruct _val25 -> (to_Endpoint (T.TStruct _val25)); _ -> P.error "wrong type"})) (Map.lookup (4) fields) + } +to_BinaryAnnotation _ = P.error "not a struct" +read_BinaryAnnotation :: T.Protocol p => p -> P.IO BinaryAnnotation +read_BinaryAnnotation iprot = to_BinaryAnnotation <$> T.readVal iprot (T.T_STRUCT typemap_BinaryAnnotation) +decode_BinaryAnnotation :: T.StatelessProtocol p => p -> LBS.ByteString -> BinaryAnnotation +decode_BinaryAnnotation iprot bs = to_BinaryAnnotation $ T.deserializeVal iprot (T.T_STRUCT typemap_BinaryAnnotation) bs +typemap_BinaryAnnotation :: T.TypeMap +typemap_BinaryAnnotation = Map.fromList [(1,("key",T.T_STRING)),(2,("value",T.T_BINARY)),(3,("annotation_type",T.T_I32)),(4,("host",(T.T_STRUCT typemap_Endpoint)))] +default_BinaryAnnotation :: BinaryAnnotation +default_BinaryAnnotation = BinaryAnnotation{ + binaryAnnotation_key = "", + binaryAnnotation_value = "", + binaryAnnotation_annotation_type = (P.toEnum 0), + binaryAnnotation_host = P.Nothing} +data Span = Span { span_trace_id :: I.Int64 + , span_name :: LT.Text + , span_id :: I.Int64 + , span_parent_id :: P.Maybe I.Int64 + , span_annotations :: (Vector.Vector Annotation) + , span_binary_annotations :: (Vector.Vector BinaryAnnotation) + , span_debug :: P.Maybe P.Bool + , span_timestamp :: P.Maybe I.Int64 + , span_duration :: P.Maybe I.Int64 + , span_trace_id_high :: P.Maybe I.Int64 + } deriving (P.Show,P.Eq,G.Generic,TY.Typeable) +instance H.Hashable Span where + hashWithSalt salt record = salt `H.hashWithSalt` span_trace_id record `H.hashWithSalt` span_name record `H.hashWithSalt` span_id record `H.hashWithSalt` span_parent_id record `H.hashWithSalt` span_annotations record `H.hashWithSalt` span_binary_annotations record `H.hashWithSalt` span_debug record `H.hashWithSalt` span_timestamp record `H.hashWithSalt` span_duration record `H.hashWithSalt` span_trace_id_high record +instance QC.Arbitrary Span where + arbitrary = M.liftM Span (QC.arbitrary) + `M.ap`(QC.arbitrary) + `M.ap`(QC.arbitrary) + `M.ap`(M.liftM P.Just QC.arbitrary) + `M.ap`(QC.arbitrary) + `M.ap`(QC.arbitrary) + `M.ap`(M.liftM P.Just QC.arbitrary) + `M.ap`(M.liftM P.Just QC.arbitrary) + `M.ap`(M.liftM P.Just QC.arbitrary) + `M.ap`(M.liftM P.Just QC.arbitrary) + shrink obj | obj == default_Span = [] + | P.otherwise = M.catMaybes + [ if obj == default_Span{span_trace_id = span_trace_id obj} then P.Nothing else P.Just $ default_Span{span_trace_id = span_trace_id obj} + , if obj == default_Span{span_name = span_name obj} then P.Nothing else P.Just $ default_Span{span_name = span_name obj} + , if obj == default_Span{span_id = span_id obj} then P.Nothing else P.Just $ default_Span{span_id = span_id obj} + , if obj == default_Span{span_parent_id = span_parent_id obj} then P.Nothing else P.Just $ default_Span{span_parent_id = span_parent_id obj} + , if obj == default_Span{span_annotations = span_annotations obj} then P.Nothing else P.Just $ default_Span{span_annotations = span_annotations obj} + , if obj == default_Span{span_binary_annotations = span_binary_annotations obj} then P.Nothing else P.Just $ default_Span{span_binary_annotations = span_binary_annotations obj} + , if obj == default_Span{span_debug = span_debug obj} then P.Nothing else P.Just $ default_Span{span_debug = span_debug obj} + , if obj == default_Span{span_timestamp = span_timestamp obj} then P.Nothing else P.Just $ default_Span{span_timestamp = span_timestamp obj} + , if obj == default_Span{span_duration = span_duration obj} then P.Nothing else P.Just $ default_Span{span_duration = span_duration obj} + , if obj == default_Span{span_trace_id_high = span_trace_id_high obj} then P.Nothing else P.Just $ default_Span{span_trace_id_high = span_trace_id_high obj} + ] +from_Span :: Span -> T.ThriftVal +from_Span record = T.TStruct $ Map.fromList $ M.catMaybes + [ (\_v28 -> P.Just (1, ("trace_id",T.TI64 _v28))) $ span_trace_id record + , (\_v28 -> P.Just (3, ("name",T.TString $ E.encodeUtf8 _v28))) $ span_name record + , (\_v28 -> P.Just (4, ("id",T.TI64 _v28))) $ span_id record + , (\_v28 -> (5, ("parent_id",T.TI64 _v28))) <$> span_parent_id record + , (\_v28 -> P.Just (6, ("annotations",T.TList (T.T_STRUCT typemap_Annotation) $ P.map (\_v30 -> from_Annotation _v30) $ Vector.toList _v28))) $ span_annotations record + , (\_v28 -> P.Just (8, ("binary_annotations",T.TList (T.T_STRUCT typemap_BinaryAnnotation) $ P.map (\_v32 -> from_BinaryAnnotation _v32) $ Vector.toList _v28))) $ span_binary_annotations record + , (\_v28 -> (9, ("debug",T.TBool _v28))) <$> span_debug record + , (\_v28 -> (10, ("timestamp",T.TI64 _v28))) <$> span_timestamp record + , (\_v28 -> (11, ("duration",T.TI64 _v28))) <$> span_duration record + , (\_v28 -> (12, ("trace_id_high",T.TI64 _v28))) <$> span_trace_id_high record + ] +write_Span :: T.Protocol p => p -> Span -> P.IO () +write_Span oprot record = T.writeVal oprot $ from_Span record +encode_Span :: T.StatelessProtocol p => p -> Span -> LBS.ByteString +encode_Span oprot record = T.serializeVal oprot $ from_Span record +to_Span :: T.ThriftVal -> Span +to_Span (T.TStruct fields) = Span{ + span_trace_id = P.maybe (span_trace_id default_Span) (\(_,_val34) -> (case _val34 of {T.TI64 _val35 -> _val35; _ -> P.error "wrong type"})) (Map.lookup (1) fields), + span_name = P.maybe (span_name default_Span) (\(_,_val34) -> (case _val34 of {T.TString _val36 -> E.decodeUtf8 _val36; _ -> P.error "wrong type"})) (Map.lookup (3) fields), + span_id = P.maybe (span_id default_Span) (\(_,_val34) -> (case _val34 of {T.TI64 _val37 -> _val37; _ -> P.error "wrong type"})) (Map.lookup (4) fields), + span_parent_id = P.maybe (P.Nothing) (\(_,_val34) -> P.Just (case _val34 of {T.TI64 _val38 -> _val38; _ -> P.error "wrong type"})) (Map.lookup (5) fields), + span_annotations = P.maybe (span_annotations default_Span) (\(_,_val34) -> (case _val34 of {T.TList _ _val39 -> (Vector.fromList $ P.map (\_v40 -> (case _v40 of {T.TStruct _val41 -> (to_Annotation (T.TStruct _val41)); _ -> P.error "wrong type"})) _val39); _ -> P.error "wrong type"})) (Map.lookup (6) fields), + span_binary_annotations = P.maybe (span_binary_annotations default_Span) (\(_,_val34) -> (case _val34 of {T.TList _ _val42 -> (Vector.fromList $ P.map (\_v43 -> (case _v43 of {T.TStruct _val44 -> (to_BinaryAnnotation (T.TStruct _val44)); _ -> P.error "wrong type"})) _val42); _ -> P.error "wrong type"})) (Map.lookup (8) fields), + span_debug = P.maybe (span_debug default_Span) (\(_,_val34) -> P.Just (case _val34 of {T.TBool _val45 -> _val45; _ -> P.error "wrong type"})) (Map.lookup (9) fields), + span_timestamp = P.maybe (P.Nothing) (\(_,_val34) -> P.Just (case _val34 of {T.TI64 _val46 -> _val46; _ -> P.error "wrong type"})) (Map.lookup (10) fields), + span_duration = P.maybe (P.Nothing) (\(_,_val34) -> P.Just (case _val34 of {T.TI64 _val47 -> _val47; _ -> P.error "wrong type"})) (Map.lookup (11) fields), + span_trace_id_high = P.maybe (P.Nothing) (\(_,_val34) -> P.Just (case _val34 of {T.TI64 _val48 -> _val48; _ -> P.error "wrong type"})) (Map.lookup (12) fields) + } +to_Span _ = P.error "not a struct" +read_Span :: T.Protocol p => p -> P.IO Span +read_Span iprot = to_Span <$> T.readVal iprot (T.T_STRUCT typemap_Span) +decode_Span :: T.StatelessProtocol p => p -> LBS.ByteString -> Span +decode_Span iprot bs = to_Span $ T.deserializeVal iprot (T.T_STRUCT typemap_Span) bs +typemap_Span :: T.TypeMap +typemap_Span = Map.fromList [(1,("trace_id",T.T_I64)),(3,("name",T.T_STRING)),(4,("id",T.T_I64)),(5,("parent_id",T.T_I64)),(6,("annotations",(T.T_LIST (T.T_STRUCT typemap_Annotation)))),(8,("binary_annotations",(T.T_LIST (T.T_STRUCT typemap_BinaryAnnotation)))),(9,("debug",T.T_BOOL)),(10,("timestamp",T.T_I64)),(11,("duration",T.T_I64)),(12,("trace_id_high",T.T_I64))] +default_Span :: Span +default_Span = Span{ + span_trace_id = 0, + span_name = "", + span_id = 0, + span_parent_id = P.Nothing, + span_annotations = Vector.empty, + span_binary_annotations = Vector.empty, + span_debug = P.Just P.False, + span_timestamp = P.Nothing, + span_duration = P.Nothing, + span_trace_id_high = P.Nothing} +data Response = Response { response_ok :: P.Bool + } deriving (P.Show,P.Eq,G.Generic,TY.Typeable) +instance H.Hashable Response where + hashWithSalt salt record = salt `H.hashWithSalt` response_ok record +instance QC.Arbitrary Response where + arbitrary = M.liftM Response (QC.arbitrary) + shrink obj | obj == default_Response = [] + | P.otherwise = M.catMaybes + [ if obj == default_Response{response_ok = response_ok obj} then P.Nothing else P.Just $ default_Response{response_ok = response_ok obj} + ] +from_Response :: Response -> T.ThriftVal +from_Response record = T.TStruct $ Map.fromList $ M.catMaybes + [ (\_v51 -> P.Just (1, ("ok",T.TBool _v51))) $ response_ok record + ] +write_Response :: T.Protocol p => p -> Response -> P.IO () +write_Response oprot record = T.writeVal oprot $ from_Response record +encode_Response :: T.StatelessProtocol p => p -> Response -> LBS.ByteString +encode_Response oprot record = T.serializeVal oprot $ from_Response record +to_Response :: T.ThriftVal -> Response +to_Response (T.TStruct fields) = Response{ + response_ok = P.maybe (P.error "Missing required field: ok") (\(_,_val53) -> (case _val53 of {T.TBool _val54 -> _val54; _ -> P.error "wrong type"})) (Map.lookup (1) fields) + } +to_Response _ = P.error "not a struct" +read_Response :: T.Protocol p => p -> P.IO Response +read_Response iprot = to_Response <$> T.readVal iprot (T.T_STRUCT typemap_Response) +decode_Response :: T.StatelessProtocol p => p -> LBS.ByteString -> Response +decode_Response iprot bs = to_Response $ T.deserializeVal iprot (T.T_STRUCT typemap_Response) bs +typemap_Response :: T.TypeMap +typemap_Response = Map.fromList [(1,("ok",T.T_BOOL))] +default_Response :: Response +default_Response = Response{ + response_ok = P.False} diff --git a/opentracing-jaeger.cabal b/opentracing-jaeger.cabal new file mode 100644 --- /dev/null +++ b/opentracing-jaeger.cabal @@ -0,0 +1,64 @@ +cabal-version: 2.2 + +name: opentracing-jaeger +version: 0.1.0.0 +synopsis: Jaeger backend for OpenTracing +homepage: https://github.com/kim/opentracing +bug-reports: https://github.com/kim/opentracing/issues +author: Kim Altintop +maintainer: Kim Altintop +copyright: Copyright (c) 2017-2018 Kim Altintop +license: Apache-2.0 +license-file: LICENSE +build-type: Simple +extra-source-files: + CHANGELOG.md + README.md + +source-repository head + type: git + location: git@github.com:kim/opentracing.git + +library + exposed-modules: + OpenTracing.Jaeger + OpenTracing.Jaeger.AgentReporter + OpenTracing.Jaeger.CollectorReporter + OpenTracing.Jaeger.Propagation + OpenTracing.Jaeger.Thrift + other-modules: + Jaeger_Consts + Jaeger_Types + Agent + Agent_Client + Agent_Types + Agent_Iface + Zipkincore_Types + hs-source-dirs: + src + gen-src + ghc-options: + -Wall + -funbox-small-strict-fields + -Wincomplete-uni-patterns + -Wincomplete-record-updates + -Wcompat + -Wnoncanonical-monad-instances + build-depends: + QuickCheck + , base >= 4.9 && < 4.16 + , bytestring >= 0.10 + , exceptions >= 0.8 + , hashable >= 1.2 + , http-client >= 0.5 + , http-types >= 0.9 + , lens >= 4.19 + , mtl >= 2.2 + , network >= 2.8 + , opentracing >= 0.1 + , safe-exceptions >= 0.1 + , text >= 1.2 + , thrift == 0.13.0 + , unordered-containers >= 0.2 + , vector >= 0.12 + default-language: Haskell2010 diff --git a/src/OpenTracing/Jaeger.hs b/src/OpenTracing/Jaeger.hs new file mode 100644 --- /dev/null +++ b/src/OpenTracing/Jaeger.hs @@ -0,0 +1,10 @@ +module OpenTracing.Jaeger + ( module OpenTracing.Jaeger.AgentReporter + , module OpenTracing.Jaeger.CollectorReporter + , module OpenTracing.Jaeger.Propagation + ) +where + +import OpenTracing.Jaeger.AgentReporter +import OpenTracing.Jaeger.CollectorReporter +import OpenTracing.Jaeger.Propagation diff --git a/src/OpenTracing/Jaeger/AgentReporter.hs b/src/OpenTracing/Jaeger/AgentReporter.hs new file mode 100644 --- /dev/null +++ b/src/OpenTracing/Jaeger/AgentReporter.hs @@ -0,0 +1,137 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE StrictData #-} +{-# LANGUAGE TemplateHaskell #-} + +module OpenTracing.Jaeger.AgentReporter + ( JaegerAgentOptions + , jaegerAgentOptions + , jaoServiceName + , jaoServiceTags + , jaoAddr + , jaoErrorLog + + , defaultJaegerAgentAddr + + , JaegerAgent + , newJaegerAgent + , closeJaegerAgent + , withJaegerAgent + + , jaegerAgentReporter + + , jaegerPropagation + ) +where + +import qualified Agent_Client as Thrift +import Control.Exception.Safe +import Control.Lens (makeLenses, view) +import Control.Monad.IO.Class +import Data.ByteString.Builder +import Data.Semigroup +import Data.Text (Text) +import qualified Data.Vector as Vector +import qualified Jaeger_Types as Thrift +import Network.Socket +import qualified Network.Socket.ByteString.Lazy as Net +import OpenTracing.Jaeger.Propagation (jaegerPropagation) +import OpenTracing.Jaeger.Thrift +import OpenTracing.Reporting (defaultErrorLog) +import OpenTracing.Span +import OpenTracing.Tags +import OpenTracing.Types +import qualified Thrift +import qualified Thrift.Protocol.Compact as Thrift +import qualified Thrift.Transport.IOBuffer as Thrift + + +data JaegerAgent = JaegerAgent + { envLocalProcess :: Thrift.Process + , envErrorLog :: Builder -> IO () + , envTransport :: AgentTransport + } + +data AgentTransport = AgentTransport + { transSock :: Socket + , transBuf :: Thrift.WriteBuffer + } + +instance Thrift.Transport AgentTransport where + tIsOpen = const (pure True) + tWrite = Thrift.writeBuf . transBuf + + tFlush AgentTransport{..} = + Thrift.flushBuf transBuf >>= Net.sendAll transSock + + tClose = error "tClose undefined" + tRead = error "tRead undefined" + tPeek = error "tPeek undefined" + tReadAll = error "tReadAll undefined" + +data JaegerAgentOptions = JaegerAgentOptions + { _jaoServiceName :: Text + , _jaoServiceTags :: Tags + , _jaoAddr :: Addr 'UDP + , _jaoErrorLog :: Builder -> IO () + } + +jaegerAgentOptions :: Text -> JaegerAgentOptions +jaegerAgentOptions srv = JaegerAgentOptions + { _jaoServiceName = srv + , _jaoServiceTags = mempty + , _jaoAddr = defaultJaegerAgentAddr + , _jaoErrorLog = defaultErrorLog + } + +defaultJaegerAgentAddr :: Addr 'UDP +defaultJaegerAgentAddr = UDPAddr "127.0.0.1" 6831 + + +newJaegerAgent :: JaegerAgentOptions -> IO JaegerAgent +newJaegerAgent JaegerAgentOptions{..} = + let tproc = toThriftProcess _jaoServiceName _jaoServiceTags + in JaegerAgent tproc _jaoErrorLog <$> openAgentTransport _jaoAddr + +closeJaegerAgent :: JaegerAgent -> IO () +closeJaegerAgent JaegerAgent{envTransport} = + handleAny (const (return ())) $ + Thrift.tFlush envTransport *> Thrift.tClose envTransport + +withJaegerAgent + :: ( MonadIO m + , MonadMask m + ) + => JaegerAgentOptions + -> (JaegerAgent -> m a) + -> m a +withJaegerAgent opts = + bracket (liftIO $ newJaegerAgent opts) (liftIO . closeJaegerAgent) + +openAgentTransport :: Addr 'UDP -> IO AgentTransport +openAgentTransport addr = do + AddrInfo{..} : _ <- getAddrInfo (Just defaultHints { addrSocketType = Datagram }) + (Just . view addrHostName $ addr) + (Just . show . view addrPort $ addr) + sock <- socket addrFamily addrSocketType addrProtocol + connect sock addrAddress + buf <- Thrift.newWriteBuffer + return AgentTransport + { transSock = sock + , transBuf = buf + } + +jaegerAgentReporter :: MonadIO m => JaegerAgent -> FinishedSpan -> m () +jaegerAgentReporter JaegerAgent{..} s = liftIO $ emit `catchAny` err + where + proto = Thrift.CompactProtocol envTransport + emit = Thrift.emitBatch (undefined, proto) batch + batch = toThriftBatch envLocalProcess (Vector.singleton s) + err e = envErrorLog $ shortByteString "Jaeger Agent Thrift error: " + <> string8 (show e) + <> char8 '\n' + +makeLenses ''JaegerAgentOptions diff --git a/src/OpenTracing/Jaeger/CollectorReporter.hs b/src/OpenTracing/Jaeger/CollectorReporter.hs new file mode 100644 --- /dev/null +++ b/src/OpenTracing/Jaeger/CollectorReporter.hs @@ -0,0 +1,131 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ViewPatterns #-} + +module OpenTracing.Jaeger.CollectorReporter + ( JaegerCollectorOptions + , jaegerCollectorOptions + , jcoManager + , jcoServiceName + , jcoServiceTags + , jcoAddr + , jcoErrorLog + + , defaultJaegerCollectorAddr + + , JaegerCollector + , newJaegerCollector + , closeJaegerCollector + , withJaegerCollector + + , jaegerCollectorReporter + + , jaegerPropagation + + , newManager + , defaultManagerSettings + ) +where + +import Control.Lens (makeLenses, set, view) +import Control.Monad (unless) +import Control.Monad.Catch +import Control.Monad.IO.Class +import Data.ByteString.Builder +import Data.Monoid +import Data.Text (Text) +import Data.Vector (fromList) +import qualified Jaeger_Types as Thrift +import Network.HTTP.Client +import Network.HTTP.Types.Status +import OpenTracing.Jaeger.Propagation (jaegerPropagation) +import OpenTracing.Jaeger.Thrift +import OpenTracing.Reporting +import OpenTracing.Span +import OpenTracing.Tags +import OpenTracing.Types +import Thrift.Protocol.Binary +import Thrift.Transport.Empty + + +newtype JaegerCollector = JaegerCollector { fromJaegerCollector :: BatchEnv } + +data JaegerCollectorOptions = JaegerCollectorOptions + { _jcoManager :: Manager + , _jcoServiceName :: Text + , _jcoServiceTags :: Tags + , _jcoAddr :: Addr 'HTTP + , _jcoErrorLog :: Builder -> IO () + } + +makeLenses ''JaegerCollectorOptions + +jaegerCollectorOptions :: Manager -> Text -> JaegerCollectorOptions +jaegerCollectorOptions mgr srv = JaegerCollectorOptions + { _jcoManager = mgr + , _jcoServiceName = srv + , _jcoServiceTags = mempty + , _jcoAddr = defaultJaegerCollectorAddr + , _jcoErrorLog = defaultErrorLog + } + +defaultJaegerCollectorAddr :: Addr 'HTTP +defaultJaegerCollectorAddr = HTTPAddr "127.0.0.1" 14268 False + +newJaegerCollector :: JaegerCollectorOptions -> IO JaegerCollector +newJaegerCollector opt@JaegerCollectorOptions{..} = do + rq <- mkReq + fmap JaegerCollector + . newBatchEnv + . set boptErrorLog _jcoErrorLog . batchOptions + $ reporter _jcoManager _jcoErrorLog rq tproc + where + mkReq = do + rq <- parseRequest + $ "http://" <> view (jcoAddr . addrHostName) opt + <> ":" + <> show (view (jcoAddr . addrPort) opt) + <> "/api/traces?format=jaeger.thrift" + pure rq { method = "POST", secure = view (jcoAddr . addrSecure) opt } + + tproc = toThriftProcess _jcoServiceName _jcoServiceTags + + +closeJaegerCollector :: JaegerCollector -> IO () +closeJaegerCollector = closeBatchEnv . fromJaegerCollector + +withJaegerCollector + :: ( MonadIO m + , MonadMask m + ) + => JaegerCollectorOptions + -> (JaegerCollector -> m a) + -> m a +withJaegerCollector opts = + bracket (liftIO $ newJaegerCollector opts) (liftIO . closeJaegerCollector) + + +jaegerCollectorReporter :: MonadIO m => JaegerCollector -> FinishedSpan -> m () +jaegerCollectorReporter = batchReporter . fromJaegerCollector + + +reporter + :: Manager + -> (Builder -> IO ()) + -> Request + -> Thrift.Process + -> [FinishedSpan] + -> IO () +reporter mgr errlog rq tproc (fromList -> spans) = do + rs <- responseStatus <$> httpLbs rq { requestBody = body } mgr + unless (statusIsSuccessful rs) $ + errlog $ shortByteString "Error from Jaeger Collector: " + <> intDec (statusCode rs) + <> char8 '\n' + where + body = RequestBodyLBS . serializeBatch $ toThriftBatch tproc spans + + -- nb. collector accepts 'BinaryProtocol', but agent 'CompactProtocol' + serializeBatch = Thrift.encode_Batch (BinaryProtocol EmptyTransport) diff --git a/src/OpenTracing/Jaeger/Propagation.hs b/src/OpenTracing/Jaeger/Propagation.hs new file mode 100644 --- /dev/null +++ b/src/OpenTracing/Jaeger/Propagation.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module OpenTracing.Jaeger.Propagation + ( jaegerPropagation + + , _JaegerTextMap + , _JaegerHeaders + + , _UberTraceId + ) +where + +import Control.Lens +import Data.Bits +import qualified Data.HashMap.Strict as HashMap +import Data.Monoid +import Data.Text (Text, isPrefixOf) +import qualified Data.Text as Text +import qualified Data.Text.Read as Text +import OpenTracing.Propagation +import OpenTracing.Span +import OpenTracing.Types + + +jaegerPropagation :: Propagation '[TextMap, Headers] +jaegerPropagation = Carrier _JaegerTextMap :& Carrier _JaegerHeaders :& RNil + + +_JaegerTextMap :: Prism' TextMap SpanContext +_JaegerTextMap = prism' fromCtx toCtx + where + fromCtx c = HashMap.fromList $ + ("uber-trace-id", review _UberTraceId c) + : map (over _1 ("uberctx-" <>)) (view (ctxBaggage . to HashMap.toList) c) + + toCtx m = + fmap (set ctxBaggage + (HashMap.filterWithKey (\k _ -> "uberctx-" `isPrefixOf` k) m)) + $ HashMap.lookup "uber-trace-id" m >>= preview _UberTraceId + +_JaegerHeaders :: Prism' Headers SpanContext +_JaegerHeaders = _HeadersTextMap . _JaegerTextMap + +_UberTraceId :: Prism' Text SpanContext +_UberTraceId = prism' fromCtx toCtx + where + fromCtx c@SpanContext{..} = + let traceid = view hexText ctxTraceID + spanid = view hexText ctxSpanID + parent = maybe mempty (view hexText) ctxParentSpanID + flags = if view (ctxSampled . re _IsSampled) c then "1" else "0" + in Text.intercalate ":" [traceid, spanid, parent, flags] + + toCtx t = + let sampledFlag = 1 :: Word + debugFlag = 2 :: Word + shouldSample fs = fs .&. sampledFlag > 0 || fs .&. debugFlag > 0 + in case Text.split (==':') t of + [traceid, spanid, _, flags] -> SpanContext + <$> preview _Hex (knownHex traceid) + <*> preview _Hex (knownHex spanid) + <*> pure Nothing + <*> either (const $ Just NotSampled) + (Just . view _IsSampled . shouldSample . fst) + (Text.decimal flags) + <*> pure mempty + + _ -> Nothing diff --git a/src/OpenTracing/Jaeger/Thrift.hs b/src/OpenTracing/Jaeger/Thrift.hs new file mode 100644 --- /dev/null +++ b/src/OpenTracing/Jaeger/Thrift.hs @@ -0,0 +1,138 @@ +{-# LANGUAGE TupleSections #-} + +module OpenTracing.Jaeger.Thrift + ( toThriftSpan + , toThriftTags + , toThriftProcess + , toThriftBatch + ) +where + +import Control.Lens +import Data.Bool (bool) +import Data.Foldable +import Data.Int (Int64) +import Data.Text (Text) +import Data.Text.Lazy.Builder (toLazyText) +import Data.Text.Lazy.Builder.Int (decimal) +import Data.Text.Lens +import Data.Vector (Vector) +import qualified Data.Vector as Vector +import Data.Vector.Lens (vector) +import GHC.Stack (prettyCallStack) +import Jaeger_Types + ( Batch (..) + , Log (..) + , Process (..) + , Span (..) + , SpanRef (..) + , Tag (..) + ) +import qualified Jaeger_Types as Thrift +import OpenTracing.Log +import OpenTracing.Span +import OpenTracing.Tags +import OpenTracing.Time +import OpenTracing.Types (TraceID (..)) + + +toThriftSpan :: FinishedSpan -> Thrift.Span +toThriftSpan s = Thrift.Span + { span_traceIdLow = view (spanContext . to traceIdLo') s + , span_traceIdHigh = view (spanContext . to traceIdHi') s + , span_spanId = view (spanContext . to ctxSpanID') s + , span_parentSpanId = maybe 0 (ctxSpanID' . refCtx) . findParent + $ view spanRefs s + , span_operationName = view (spanOperation . lazy) s + , span_references = view ( spanRefs + . to (map toThriftSpanRef . toList) + . vector + . re _Just + ) + s + , span_flags = view ( spanContext + . ctxSampled + . re _IsSampled + . to (bool 0 1) + ) + s + , span_startTime = view (spanStart . to micros) s + , span_duration = view (spanDuration . to micros) s + , span_tags = view (spanTags . to toThriftTags . re _Just) s + , span_logs = Just + . Vector.fromList + . foldr' (\r acc -> toThriftLog r : acc) [] + $ view spanLogs s + , span_incomplete = Just False + } + +toThriftSpanRef :: Reference -> Thrift.SpanRef +toThriftSpanRef ref = Thrift.SpanRef + { spanRef_refType = toThriftRefType ref + , spanRef_traceIdLow = traceIdLo' (refCtx ref) + , spanRef_traceIdHigh = traceIdHi' (refCtx ref) + , spanRef_spanId = ctxSpanID' (refCtx ref) + } + +toThriftRefType :: Reference -> Thrift.SpanRefType +toThriftRefType (ChildOf _) = Thrift.CHILD_OF +toThriftRefType (FollowsFrom _) = Thrift.FOLLOWS_FROM + +toThriftTags :: Tags -> Vector Thrift.Tag +toThriftTags = ifoldMap (\k v -> Vector.singleton (toThriftTag k v)) . fromTags + +toThriftTag :: Text -> TagVal -> Thrift.Tag +-- acc. to https://github.com/opentracing/specification/blob/8d634bc7e3e73050f6ac1006858cddac8d9e0abe/semantic_conventions.yaml +-- "http.status_code" is supposed to be integer-valued. Jaeger, however, drops +-- the value (nb. _not_ the tag key) unless it is a string. +toThriftTag HttpStatusCodeKey (IntT v) = Thrift.default_Tag + { tag_key = view lazy HttpStatusCodeKey + , tag_vStr = Just . toLazyText . decimal $ v + } +toThriftTag k v = + let t = Thrift.default_Tag { tag_key = view lazy k } + in case v of + BoolT x -> t { tag_vBool = Just x } + StringT x -> t { tag_vStr = Just (view lazy x) } + IntT x -> t { tag_vLong = Just x } + DoubleT x -> t { tag_vDouble = Just x } + BinaryT x -> t { tag_vBinary = Just x } + +toThriftLog :: LogRecord -> Thrift.Log +toThriftLog r = Thrift.Log + { log_timestamp = view (logTime . to micros) r + , log_fields = foldMap ( Vector.singleton + . uncurry toThriftTag + . asTag + ) + $ view logFields r + } + where + asTag f = (logFieldLabel f,) . StringT $ case f of + LogField _ v -> view packed (show v) + Event v -> v + Message v -> v + Stack v -> view packed (prettyCallStack v) + ErrKind v -> v + ErrObj v -> view packed (show v) + +toThriftProcess :: Text -> Tags -> Thrift.Process +toThriftProcess srv tags = Thrift.Process + { process_serviceName = view lazy srv + , process_tags = Just $ toThriftTags tags + } + +toThriftBatch :: Thrift.Process -> Vector FinishedSpan -> Thrift.Batch +toThriftBatch tproc spans = Thrift.Batch + { batch_process = tproc + , batch_spans = toThriftSpan <$> spans + } + +traceIdLo' :: SpanContext -> Int64 +traceIdLo' = fromIntegral . traceIdLo . ctxTraceID + +traceIdHi' :: SpanContext -> Int64 +traceIdHi' = maybe 0 fromIntegral . traceIdHi . ctxTraceID + +ctxSpanID' :: SpanContext -> Int64 +ctxSpanID' = fromIntegral . ctxSpanID