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/ZipkinCore_Consts.hs b/gen-src/ZipkinCore_Consts.hs new file mode 100644 --- /dev/null +++ b/gen-src/ZipkinCore_Consts.hs @@ -0,0 +1,116 @@ +{-# 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_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 ZipkinCore_Types +cLIENT_SEND :: LT.Text +cLIENT_SEND = "cs" + +cLIENT_RECV :: LT.Text +cLIENT_RECV = "cr" + +sERVER_SEND :: LT.Text +sERVER_SEND = "ss" + +sERVER_RECV :: LT.Text +sERVER_RECV = "sr" + +mESSAGE_SEND :: LT.Text +mESSAGE_SEND = "ms" + +mESSAGE_RECV :: LT.Text +mESSAGE_RECV = "mr" + +wIRE_SEND :: LT.Text +wIRE_SEND = "ws" + +wIRE_RECV :: LT.Text +wIRE_RECV = "wr" + +cLIENT_SEND_FRAGMENT :: LT.Text +cLIENT_SEND_FRAGMENT = "csf" + +cLIENT_RECV_FRAGMENT :: LT.Text +cLIENT_RECV_FRAGMENT = "crf" + +sERVER_SEND_FRAGMENT :: LT.Text +sERVER_SEND_FRAGMENT = "ssf" + +sERVER_RECV_FRAGMENT :: LT.Text +sERVER_RECV_FRAGMENT = "srf" + +hTTP_HOST :: LT.Text +hTTP_HOST = "http.host" + +hTTP_METHOD :: LT.Text +hTTP_METHOD = "http.method" + +hTTP_PATH :: LT.Text +hTTP_PATH = "http.path" + +hTTP_ROUTE :: LT.Text +hTTP_ROUTE = "http.route" + +hTTP_URL :: LT.Text +hTTP_URL = "http.url" + +hTTP_STATUS_CODE :: LT.Text +hTTP_STATUS_CODE = "http.status_code" + +hTTP_REQUEST_SIZE :: LT.Text +hTTP_REQUEST_SIZE = "http.request.size" + +hTTP_RESPONSE_SIZE :: LT.Text +hTTP_RESPONSE_SIZE = "http.response.size" + +lOCAL_COMPONENT :: LT.Text +lOCAL_COMPONENT = "lc" + +eRROR :: LT.Text +eRROR = "error" + +cLIENT_ADDR :: LT.Text +cLIENT_ADDR = "ca" + +sERVER_ADDR :: LT.Text +sERVER_ADDR = "sa" + +mESSAGE_ADDR :: LT.Text +mESSAGE_ADDR = "ma" + 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,293 @@ +{-# 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} diff --git a/opentracing-zipkin-v1.cabal b/opentracing-zipkin-v1.cabal new file mode 100644 --- /dev/null +++ b/opentracing-zipkin-v1.cabal @@ -0,0 +1,56 @@ +cabal-version: 2.2 + +name: opentracing-zipkin-v1 +version: 0.1.0.0 +synopsis: Zipkin V1 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.Zipkin.V1 + OpenTracing.Zipkin.V1.HttpReporter + OpenTracing.Zipkin.V1.Thrift + other-modules: + ZipkinCore_Consts + 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 >= 2.14 + , base >= 4.9 && < 4.16 + , bytestring >= 0.10 + , exceptions >= 0.8 + , hashable >= 1.2 + , http-client >= 0.5 + , http-types >= 0.9 + , iproute >= 1.7 + , lens >= 4.19 + , opentracing >= 0.1 + , opentracing-zipkin-common >= 0.1 + , text >= 1.2 + , thrift == 0.13.0 + , unordered-containers >= 0.2 + , vector >= 0.12 + default-language: Haskell2010 diff --git a/src/OpenTracing/Zipkin/V1.hs b/src/OpenTracing/Zipkin/V1.hs new file mode 100644 --- /dev/null +++ b/src/OpenTracing/Zipkin/V1.hs @@ -0,0 +1,6 @@ +module OpenTracing.Zipkin.V1 + ( module OpenTracing.Zipkin.V1.HttpReporter + ) +where + +import OpenTracing.Zipkin.V1.HttpReporter diff --git a/src/OpenTracing/Zipkin/V1/HttpReporter.hs b/src/OpenTracing/Zipkin/V1/HttpReporter.hs new file mode 100644 --- /dev/null +++ b/src/OpenTracing/Zipkin/V1/HttpReporter.hs @@ -0,0 +1,120 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE StrictData #-} +{-# LANGUAGE TemplateHaskell #-} + +module OpenTracing.Zipkin.V1.HttpReporter + ( ZipkinOptions + , zipkinOptions + , zoManager + , zoLocalEndpoint + , zoEndpoint + , zoLogfmt + , zoErrorLog + + , defaultZipkinEndpoint + , defaultZipkinAddr + + , Zipkin + , newZipkin + , closeZipkin + , withZipkin + + , zipkinHttpReporter + + , Endpoint(..) + + , newManager + , defaultManagerSettings + ) +where + +import Control.Lens hiding (Context) +import Control.Monad (unless) +import Control.Monad.Catch +import Control.Monad.IO.Class +import Data.ByteString.Builder +import Data.Monoid +import Network.HTTP.Client hiding (port) +import Network.HTTP.Types +import OpenTracing.Log +import OpenTracing.Reporting +import OpenTracing.Span +import OpenTracing.Types +import OpenTracing.Zipkin.Types +import OpenTracing.Zipkin.V1.Thrift + + +newtype Zipkin = Zipkin { fromZipkin :: BatchEnv } + +data ZipkinOptions = ZipkinOptions + { _zoManager :: Manager + , _zoLocalEndpoint :: Endpoint + , _zoEndpoint :: String + , _zoLogfmt :: forall t. Foldable t => t LogField -> Builder -- == LogFieldsFormatter + , _zoErrorLog :: Builder -> IO () + } + +makeLenses ''ZipkinOptions + +zipkinOptions :: Manager -> Endpoint -> ZipkinOptions +zipkinOptions mgr loc = ZipkinOptions + { _zoManager = mgr + , _zoLocalEndpoint = loc + , _zoEndpoint = defaultZipkinEndpoint + , _zoLogfmt = jsonMap + , _zoErrorLog = defaultErrorLog + } + +defaultZipkinEndpoint :: String +defaultZipkinEndpoint = "http://" + <> view addrHostName addr + <> ":" + <> show (view addrPort addr) + <> "/api/v1/spans" + where + addr = defaultZipkinAddr + +newZipkin :: ZipkinOptions -> IO Zipkin +newZipkin opts@ZipkinOptions{_zoEndpoint=endpoint, _zoErrorLog=errlog} = do + rq <- mkReq + fmap Zipkin + . newBatchEnv + . set boptErrorLog errlog . batchOptions + $ reporter opts rq + where + mkReq = do + rq <- parseRequest endpoint + return rq { requestHeaders = [(hContentType, "application/x-thrift")] } + +closeZipkin :: Zipkin -> IO () +closeZipkin = closeBatchEnv . fromZipkin + +withZipkin + :: ( MonadIO m + , MonadMask m + ) + => ZipkinOptions + -> (Zipkin -> m a) + -> m a +withZipkin opts = bracket (liftIO $ newZipkin opts) (liftIO . closeZipkin) + + +zipkinHttpReporter :: MonadIO m => Zipkin -> FinishedSpan -> m () +zipkinHttpReporter = batchReporter . fromZipkin + +reporter :: ZipkinOptions -> Request -> [FinishedSpan] -> IO () +reporter ZipkinOptions{..} rq spans = do + rs <- responseStatus <$> httpLbs rq { requestBody = body } _zoManager + unless (statusIsSuccessful rs) $ + _zoErrorLog $ shortByteString "Error from Zipkin server: " + <> intDec (statusCode rs) + <> char8 '\n' + where + body = RequestBodyLBS + . thriftEncodeSpans + . map (toThriftSpan _zoLocalEndpoint _zoLogfmt) + $ spans diff --git a/src/OpenTracing/Zipkin/V1/Thrift.hs b/src/OpenTracing/Zipkin/V1/Thrift.hs new file mode 100644 --- /dev/null +++ b/src/OpenTracing/Zipkin/V1/Thrift.hs @@ -0,0 +1,173 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE ViewPatterns #-} + +{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-} + +module OpenTracing.Zipkin.V1.Thrift + ( toThriftSpan + + , thriftEncodeSpan + , thriftEncodeSpans + ) +where + +import Control.Lens +import Data.Bifunctor +import Data.Bits +import Data.ByteString.Builder +import qualified Data.ByteString.Lazy as Lazy +import Data.ByteString.Lens +import Data.Foldable (foldl', toList) +import qualified Data.HashMap.Strict as HashMap +import Data.Int +import qualified Data.IP as IP +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Semigroup ((<>)) +import Data.Text.Lazy.Encoding (decodeUtf8, encodeUtf8) +import qualified Data.Vector as Vector +import OpenTracing.Log +import OpenTracing.Span +import OpenTracing.Tags +import OpenTracing.Time +import OpenTracing.Types +import OpenTracing.Zipkin.Types (Endpoint (..)) +import qualified Thrift +import Thrift.Protocol.Binary +import Thrift.Transport.Empty +import Thrift.Types +import qualified ZipkinCore_Consts as Thrift +import ZipkinCore_Types + ( Annotation (..) + , BinaryAnnotation (..) + , Span (..) + , endpoint_ipv4 + , endpoint_ipv6 + , endpoint_port + , endpoint_service_name + ) +import qualified ZipkinCore_Types as Thrift + + +toThriftSpan + :: Endpoint + -> LogFieldsFormatter + -> FinishedSpan + -> Thrift.Span +toThriftSpan (toThriftEndpoint -> loc) logfmt s = Thrift.Span + { span_trace_id = view (spanContext . to traceIdLo') s + , span_trace_id_high = view (spanContext . to traceIdHi') s + , span_name = view (spanOperation . lazy) s + , span_id = view (spanContext . to ctxSpanID') s + , span_parent_id = view (spanContext . to ctxParentSpanID') s + , span_annotations = annotations + , span_binary_annotations = binaryAnnotations + , span_debug = Nothing + , span_timestamp = Just tstart + , span_duration = view (spanDuration . to micros . re _Just) s + } + where + tstart = view (spanStart . to micros) s + + (annotations, binaryAnnotations) + = bimap Vector.fromList Vector.fromList + . first (<> annFromLogs (view spanLogs s)) + $ annFromTags (view spanTags s) + + annFromTags :: Tags -> ([Thrift.Annotation], [Thrift.BinaryAnnotation]) + annFromTags = perhapsLocal . foldl' go ([],[]) . HashMap.toList . fromTags + where + go acc (SpanKind sk) = + let ann = Thrift.Annotation + { annotation_timestamp = tstart + , annotation_host = Just loc + , annotation_value = case sk of + RPCClient -> Thrift.cLIENT_SEND + RPCServer -> Thrift.sERVER_RECV + Producer -> Thrift.mESSAGE_SEND + Consumer -> Thrift.mESSAGE_RECV + } + in first (ann:) acc + + go acc (k,v) = + let (anntyp, annval) = toThriftTag v + ann = Thrift.BinaryAnnotation + { binaryAnnotation_key = view lazy k + , binaryAnnotation_value = annval + , binaryAnnotation_annotation_type = anntyp + , binaryAnnotation_host = Just loc + } + in second (ann:) acc + + -- if we don't have a 'SpanKind', we're supposed to tell Zipkin about us + -- via a 'BinaryAnnotation' + perhapsLocal ([],bs) = ([],) . (:bs) $ Thrift.BinaryAnnotation + { binaryAnnotation_key = Thrift.lOCAL_COMPONENT + , binaryAnnotation_value = encodeUtf8 $ endpoint_service_name loc + , binaryAnnotation_annotation_type = Thrift.STRING + , binaryAnnotation_host = Just loc + } + perhapsLocal xs = xs + + annFromLogs :: [LogRecord] -> [Thrift.Annotation] + annFromLogs = foldl' go [] + where + go acc (LogRecord t fs) = Thrift.Annotation + { annotation_timestamp = micros t + , annotation_host = Just loc + , annotation_value = case fs of + (Event x :| []) -> view lazy x -- proper zipkin annotation + fields -> decodeUtf8 . toLazyByteString $ logfmt fields + } + : acc + +thriftEncodeSpan :: Thrift.Span -> Lazy.ByteString +thriftEncodeSpan = Thrift.encode_Span (BinaryProtocol EmptyTransport) + +thriftEncodeSpans :: Traversable t => t Thrift.Span -> Lazy.ByteString +thriftEncodeSpans + = thriftEncodeVal + . TList (T_STRUCT Thrift.typemap_Span) + . toList + . fmap Thrift.from_Span + +thriftEncodeVal :: ThriftVal -> Lazy.ByteString +thriftEncodeVal = Thrift.serializeVal (BinaryProtocol EmptyTransport) + +toThriftTag :: TagVal -> (Thrift.AnnotationType, Lazy.ByteString) +toThriftTag (BoolT v) = (Thrift.BOOL, if v then "1" else "0") +toThriftTag (StringT v) = (Thrift.STRING, view (lazy . to encodeUtf8) v) +toThriftTag (IntT v) = (Thrift.I64, toLazyByteString . int64BE $ v) +toThriftTag (DoubleT v) = (Thrift.DOUBLE, toLazyByteString . doubleBE $ v) +toThriftTag (BinaryT v) = (Thrift.BYTES, v) + +toThriftEndpoint :: Endpoint -> Thrift.Endpoint +toThriftEndpoint Endpoint{..} = Thrift.Endpoint + { endpoint_ipv4 = packIPv4 $ fromIPv4 ipv4 + , endpoint_port = maybe 0 (fromIntegral . fromPort) port + , endpoint_service_name = view lazy serviceName + , endpoint_ipv6 = packIPv6 . fromIPv6 <$> ipv6 + } + where + packIPv4 :: IP.IPv4 -> Int32 + packIPv4 ip = + let [a,b,c,d] = IP.fromIPv4 ip + in fromIntegral $ a `shiftL` 24 .|. b `shiftL` 16 .|. c `shiftL` 8 .|. d + + packIPv6 :: IP.IPv6 -> Lazy.ByteString + packIPv6 = view packedBytes . map fromIntegral . IP.fromIPv6b + + +traceIdLo' :: SpanContext -> Int64 +traceIdLo' = fromIntegral . traceIdLo . ctxTraceID + +traceIdHi' :: SpanContext -> Maybe Int64 +traceIdHi' = fmap fromIntegral . traceIdHi . ctxTraceID + +ctxSpanID' :: SpanContext -> Int64 +ctxSpanID' = fromIntegral . ctxSpanID + +ctxParentSpanID' :: SpanContext -> Maybe Int64 +ctxParentSpanID' = fmap fromIntegral . ctxParentSpanID