opentracing-zipkin-v1 0.1.0.0 → 0.2.0
raw patch · 9 files changed
+305/−446 lines, 9 filesdep +pinchdep +vector-instancesdep −thriftPVP ok
version bump matches the API change (PVP)
Dependencies added: pinch, vector-instances
Dependencies removed: thrift
API changes (from Hackage documentation)
- OpenTracing.Zipkin.V1.HttpReporter: zoLogfmt :: forall t_atZs. Foldable t_atZs => Getter ZipkinOptions (t_atZs LogField -> Builder)
+ OpenTracing.Zipkin.V1.HttpReporter: zoLogfmt :: forall t_aoCi. Foldable t_aoCi => Getter ZipkinOptions (t_aoCi LogField -> Builder)
Files
- CHANGELOG.md +12/−2
- gen-src/ZipkinCore_Consts.hs +0/−116
- gen-src/ZipkinCore_Types.hs +0/−293
- gen-src/Zipkincore/Client.hs +25/−0
- gen-src/Zipkincore/Server.hs +30/−0
- gen-src/Zipkincore/Types.hs +209/−0
- opentracing-zipkin-v1.cabal +6/−4
- src/OpenTracing/Zipkin/V1/HttpReporter.hs +2/−1
- src/OpenTracing/Zipkin/V1/Thrift.hs +21/−30
CHANGELOG.md view
@@ -1,3 +1,13 @@-* 0.1.0.0 (2012-04-20)+* 0.2.0 (2021-06-03) -After years of friendly reminders, a zero version gets finally released =]+ - Drop support for GHC 8.0 (#35)+ - Add support for GHC 9.0 (#36)+ - Replace the unmaintained `thrift` package with `pinch` (#34)+ - wai: Better default operation name, and allow customising it (#33, #37)++ The major version is bumped because the packages won't compile with GHC 8.0+ anymore.++* 0.1.0.0 (2021-04-20)++ After years of friendly reminders, a zero version gets finally released =]
− gen-src/ZipkinCore_Consts.hs
@@ -1,116 +0,0 @@-{-# 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"-
− gen-src/ZipkinCore_Types.hs
@@ -1,293 +0,0 @@-{-# 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}
+ gen-src/Zipkincore/Client.hs view
@@ -0,0 +1,25 @@+{-# LANGUAGE TypeFamilies, DeriveGeneric, TypeApplications, OverloadedLists, OverloadedStrings #-}+{-# OPTIONS_GHC -fno-warn-unused-imports -fno-warn-name-shadowing -fno-warn-unused-matches #-}++module Zipkincore.Client where++import Zipkincore.Types+import qualified Pinch.Client+import qualified Prelude+import qualified Control.Applicative+import qualified Control.Exception+import qualified Pinch+import qualified Pinch.Server+import qualified Pinch.Internal.RPC+import qualified Data.Text+import qualified Data.ByteString+import qualified Data.Int+import qualified Data.Vector+import qualified Data.HashMap.Strict+import qualified Data.HashSet+import qualified GHC.Generics+import qualified Data.Hashable+import Data.Vector.Instances ()++submitZipkinBatch :: ((Data.Vector.Vector Span)) -> (Pinch.Client.ThriftCall SubmitZipkinBatch_Result)+submitZipkinBatch spans = Pinch.Client.TCall ("submitZipkinBatch") (SubmitZipkinBatch_Args (spans))
+ gen-src/Zipkincore/Server.hs view
@@ -0,0 +1,30 @@+{-# LANGUAGE TypeFamilies, DeriveGeneric, TypeApplications, OverloadedLists, OverloadedStrings #-}+{-# OPTIONS_GHC -fno-warn-unused-imports -fno-warn-name-shadowing -fno-warn-unused-matches #-}++module Zipkincore.Server where++import Zipkincore.Types+import qualified Pinch.Server+import qualified Prelude+import qualified Control.Applicative+import qualified Control.Exception+import qualified Pinch+import qualified Pinch.Server+import qualified Pinch.Internal.RPC+import qualified Data.Text+import qualified Data.ByteString+import qualified Data.Int+import qualified Data.Vector+import qualified Data.HashMap.Strict+import qualified Data.HashSet+import qualified GHC.Generics+import qualified Data.Hashable+import Data.Vector.Instances ()++data ZipkinCollector+ = ZipkinCollector { submitZipkinBatch :: (Pinch.Server.Context) -> ((Data.Vector.Vector Span)) -> (Prelude.IO (Data.Vector.Vector Response)) }+++zipkinCollector_mkServer :: (ZipkinCollector) -> Pinch.Server.ThriftServer+zipkinCollector_mkServer server = let functions = Data.HashMap.Strict.fromList ([ ( "submitZipkinBatch"+ , Pinch.Server.CallHandler ((\ctx (SubmitZipkinBatch_Args a) -> Pinch.Internal.RPC.wrap @(SubmitZipkinBatch_Result) (submitZipkinBatch (server) (ctx) (a)))) ) ]) in Pinch.Server.createServer ((\nm -> Data.HashMap.Strict.lookup (nm) (functions)))
+ gen-src/Zipkincore/Types.hs view
@@ -0,0 +1,209 @@+{-# LANGUAGE TypeFamilies, DeriveGeneric, TypeApplications, OverloadedLists, OverloadedStrings #-}+{-# OPTIONS_GHC -fno-warn-unused-imports -fno-warn-name-shadowing -fno-warn-unused-matches #-}++module Zipkincore.Types where++import qualified Prelude+import qualified Control.Applicative+import qualified Control.Exception+import qualified Pinch+import qualified Pinch.Server+import qualified Pinch.Internal.RPC+import qualified Data.Text+import qualified Data.ByteString+import qualified Data.Int+import qualified Data.Vector+import qualified Data.HashMap.Strict+import qualified Data.HashSet+import qualified GHC.Generics+import qualified Data.Hashable+import Data.Vector.Instances ()++cLIENT_SEND :: Data.Text.Text+cLIENT_SEND = "cs"+cLIENT_RECV :: Data.Text.Text+cLIENT_RECV = "cr"+sERVER_SEND :: Data.Text.Text+sERVER_SEND = "ss"+sERVER_RECV :: Data.Text.Text+sERVER_RECV = "sr"+mESSAGE_SEND :: Data.Text.Text+mESSAGE_SEND = "ms"+mESSAGE_RECV :: Data.Text.Text+mESSAGE_RECV = "mr"+wIRE_SEND :: Data.Text.Text+wIRE_SEND = "ws"+wIRE_RECV :: Data.Text.Text+wIRE_RECV = "wr"+cLIENT_SEND_FRAGMENT :: Data.Text.Text+cLIENT_SEND_FRAGMENT = "csf"+cLIENT_RECV_FRAGMENT :: Data.Text.Text+cLIENT_RECV_FRAGMENT = "crf"+sERVER_SEND_FRAGMENT :: Data.Text.Text+sERVER_SEND_FRAGMENT = "ssf"+sERVER_RECV_FRAGMENT :: Data.Text.Text+sERVER_RECV_FRAGMENT = "srf"+lOCAL_COMPONENT :: Data.Text.Text+lOCAL_COMPONENT = "lc"+cLIENT_ADDR :: Data.Text.Text+cLIENT_ADDR = "ca"+sERVER_ADDR :: Data.Text.Text+sERVER_ADDR = "sa"+mESSAGE_ADDR :: Data.Text.Text+mESSAGE_ADDR = "ma"+data Endpoint+ = Endpoint { endpoint_ipv4 :: Data.Int.Int32, endpoint_port :: Data.Int.Int16, endpoint_service_name :: Data.Text.Text, endpoint_ipv6 :: (Prelude.Maybe Data.ByteString.ByteString) }+ deriving (Prelude.Eq, GHC.Generics.Generic, Prelude.Show)++instance Pinch.Pinchable Endpoint where+ type (Tag Endpoint) = Pinch.TStruct++ pinch (Endpoint endpoint_ipv4 endpoint_port endpoint_service_name endpoint_ipv6) = Pinch.struct ([ (1 Pinch..= endpoint_ipv4), (2 Pinch..= endpoint_port), (3 Pinch..= endpoint_service_name), (4 Pinch.?= endpoint_ipv6) ])++ unpinch value = ((((Prelude.pure (Endpoint) Prelude.<*> (value Pinch..: 1)) Prelude.<*> (value Pinch..: 2)) Prelude.<*> (value Pinch..: 3)) Prelude.<*> (value Pinch..:? 4))+++instance Data.Hashable.Hashable Endpoint where++data Annotation+ = Annotation { annotation_timestamp :: Data.Int.Int64, annotation_value :: Data.Text.Text, annotation_host :: (Prelude.Maybe Endpoint) }+ deriving (Prelude.Eq, GHC.Generics.Generic, Prelude.Show)++instance Pinch.Pinchable Annotation where+ type (Tag Annotation) = Pinch.TStruct++ pinch (Annotation annotation_timestamp annotation_value annotation_host) = Pinch.struct ([ (1 Pinch..= annotation_timestamp), (2 Pinch..= annotation_value), (3 Pinch.?= annotation_host) ])++ unpinch value = (((Prelude.pure (Annotation) Prelude.<*> (value Pinch..: 1)) Prelude.<*> (value Pinch..: 2)) Prelude.<*> (value Pinch..:? 3))+++instance Data.Hashable.Hashable Annotation where++data AnnotationType+ = BOOL+ | BYTES+ | I16+ | I32+ | I64+ | DOUBLE+ | STRING+ deriving (Prelude.Eq, Prelude.Ord, GHC.Generics.Generic, Prelude.Show, Prelude.Bounded)++instance Pinch.Pinchable AnnotationType where+ type (Tag AnnotationType) = Pinch.TEnum++ pinch BOOL = Pinch.pinch ((0 :: Data.Int.Int32))+ pinch BYTES = Pinch.pinch ((1 :: Data.Int.Int32))+ pinch I16 = Pinch.pinch ((2 :: Data.Int.Int32))+ pinch I32 = Pinch.pinch ((3 :: Data.Int.Int32))+ pinch I64 = Pinch.pinch ((4 :: Data.Int.Int32))+ pinch DOUBLE = Pinch.pinch ((5 :: Data.Int.Int32))+ pinch STRING = Pinch.pinch ((6 :: Data.Int.Int32))++ unpinch v = do+ val <- Pinch.unpinch (v)+ case (val :: Data.Int.Int32) of+ 0 -> Prelude.pure (BOOL)+ 1 -> Prelude.pure (BYTES)+ 2 -> Prelude.pure (I16)+ 3 -> Prelude.pure (I32)+ 4 -> Prelude.pure (I64)+ 5 -> Prelude.pure (DOUBLE)+ 6 -> Prelude.pure (STRING)+ _ -> Prelude.fail (("Unknown value for type AnnotationType: " Prelude.<> Prelude.show (val)))+++instance Prelude.Enum AnnotationType where+ fromEnum BOOL = 0+ fromEnum BYTES = 1+ fromEnum I16 = 2+ fromEnum I32 = 3+ fromEnum I64 = 4+ fromEnum DOUBLE = 5+ fromEnum STRING = 6++ toEnum 0 = BOOL+ toEnum 1 = BYTES+ toEnum 2 = I16+ toEnum 3 = I32+ toEnum 4 = I64+ toEnum 5 = DOUBLE+ toEnum 6 = STRING+ toEnum _ = Prelude.error ("Unknown value for enum AnnotationType.")+++instance Data.Hashable.Hashable AnnotationType where++data BinaryAnnotation+ = BinaryAnnotation { binaryAnnotation_key :: Data.Text.Text, binaryAnnotation_value :: Data.ByteString.ByteString, binaryAnnotation_annotation_type :: AnnotationType, binaryAnnotation_host :: (Prelude.Maybe Endpoint) }+ deriving (Prelude.Eq, GHC.Generics.Generic, Prelude.Show)++instance Pinch.Pinchable BinaryAnnotation where+ type (Tag BinaryAnnotation) = Pinch.TStruct++ pinch (BinaryAnnotation binaryAnnotation_key binaryAnnotation_value binaryAnnotation_annotation_type binaryAnnotation_host) = Pinch.struct ([ (1 Pinch..= binaryAnnotation_key), (2 Pinch..= binaryAnnotation_value), (3 Pinch..= binaryAnnotation_annotation_type), (4 Pinch.?= binaryAnnotation_host) ])++ unpinch value = ((((Prelude.pure (BinaryAnnotation) Prelude.<*> (value Pinch..: 1)) Prelude.<*> (value Pinch..: 2)) Prelude.<*> (value Pinch..: 3)) Prelude.<*> (value Pinch..:? 4))+++instance Data.Hashable.Hashable BinaryAnnotation where++data Span+ = Span { span_trace_id :: Data.Int.Int64, span_name :: Data.Text.Text, span_id :: Data.Int.Int64, span_parent_id :: (Prelude.Maybe Data.Int.Int64), span_annotations :: (Data.Vector.Vector Annotation), span_binary_annotations :: (Data.Vector.Vector BinaryAnnotation), span_debug :: (Prelude.Maybe Prelude.Bool), span_timestamp :: (Prelude.Maybe Data.Int.Int64), span_duration :: (Prelude.Maybe Data.Int.Int64), span_trace_id_high :: (Prelude.Maybe Data.Int.Int64) }+ deriving (Prelude.Eq, GHC.Generics.Generic, Prelude.Show)++instance Pinch.Pinchable Span where+ type (Tag Span) = Pinch.TStruct++ pinch (Span span_trace_id span_name span_id span_parent_id span_annotations span_binary_annotations span_debug span_timestamp span_duration span_trace_id_high) = Pinch.struct ([ (1 Pinch..= span_trace_id), (3 Pinch..= span_name), (4 Pinch..= span_id), (5 Pinch.?= span_parent_id), (6 Pinch..= span_annotations), (8 Pinch..= span_binary_annotations), (9 Pinch.?= span_debug), (10 Pinch.?= span_timestamp), (11 Pinch.?= span_duration), (12 Pinch.?= span_trace_id_high) ])++ unpinch value = ((((((((((Prelude.pure (Span) Prelude.<*> (value Pinch..: 1)) Prelude.<*> (value Pinch..: 3)) Prelude.<*> (value Pinch..: 4)) Prelude.<*> (value Pinch..:? 5)) Prelude.<*> (value Pinch..: 6)) Prelude.<*> (value Pinch..: 8)) Prelude.<*> (value Pinch..:? 9)) Prelude.<*> (value Pinch..:? 10)) Prelude.<*> (value Pinch..:? 11)) Prelude.<*> (value Pinch..:? 12))+++instance Data.Hashable.Hashable Span where++data Response+ = Response { response_ok :: Prelude.Bool }+ deriving (Prelude.Eq, GHC.Generics.Generic, Prelude.Show)++instance Pinch.Pinchable Response where+ type (Tag Response) = Pinch.TStruct++ pinch (Response response_ok) = Pinch.struct ([ (1 Pinch..= response_ok) ])++ unpinch value = (Prelude.pure (Response) Prelude.<*> (value Pinch..: 1))+++instance Data.Hashable.Hashable Response where++data SubmitZipkinBatch_Args+ = SubmitZipkinBatch_Args { submitZipkinBatch_Args_spans :: (Data.Vector.Vector Span) }+ deriving (Prelude.Eq, GHC.Generics.Generic, Prelude.Show)++instance Pinch.Pinchable SubmitZipkinBatch_Args where+ type (Tag SubmitZipkinBatch_Args) = Pinch.TStruct++ pinch (SubmitZipkinBatch_Args submitZipkinBatch_Args_spans) = Pinch.struct ([ (1 Pinch..= submitZipkinBatch_Args_spans) ])++ unpinch value = (Prelude.pure (SubmitZipkinBatch_Args) Prelude.<*> (value Pinch..: 1))+++instance Pinch.Internal.RPC.ThriftResult SubmitZipkinBatch_Result where+ type (ResultType SubmitZipkinBatch_Result) = (Data.Vector.Vector Response)++ unwrap (SubmitZipkinBatch_Result_Success x) = Prelude.pure (x)++ wrap m = Control.Exception.catches ((SubmitZipkinBatch_Result_Success Prelude.<$> m)) ([ ])+++data SubmitZipkinBatch_Result+ = SubmitZipkinBatch_Result_Success (Data.Vector.Vector Response)+ deriving (Prelude.Eq, GHC.Generics.Generic, Prelude.Show)++instance Pinch.Pinchable SubmitZipkinBatch_Result where+ type (Tag SubmitZipkinBatch_Result) = Pinch.TUnion++ pinch (SubmitZipkinBatch_Result_Success x) = Pinch.union (0) (x)++ unpinch v = (Control.Applicative.empty Control.Applicative.<|> (SubmitZipkinBatch_Result_Success Prelude.<$> (v Pinch..: 0)))+
opentracing-zipkin-v1.cabal view
@@ -1,7 +1,7 @@ cabal-version: 2.2 name: opentracing-zipkin-v1-version: 0.1.0.0+version: 0.2.0 synopsis: Zipkin V1 backend for OpenTracing homepage: https://github.com/kim/opentracing bug-reports: https://github.com/kim/opentracing/issues@@ -25,8 +25,9 @@ OpenTracing.Zipkin.V1.HttpReporter OpenTracing.Zipkin.V1.Thrift other-modules:- ZipkinCore_Consts- ZipkinCore_Types+ Zipkincore.Client+ Zipkincore.Server+ Zipkincore.Types hs-source-dirs: src gen-src@@ -49,8 +50,9 @@ , lens >= 4.19 , opentracing >= 0.1 , opentracing-zipkin-common >= 0.1+ , pinch >= 0.4.0.0 , text >= 1.2- , thrift == 0.13.0 , unordered-containers >= 0.2 , vector >= 0.12+ , vector-instances default-language: Haskell2010
src/OpenTracing/Zipkin/V1/HttpReporter.hs view
@@ -37,7 +37,7 @@ import Control.Monad.Catch import Control.Monad.IO.Class import Data.ByteString.Builder-import Data.Monoid+import Data.ByteString.Lazy (fromStrict) import Network.HTTP.Client hiding (port) import Network.HTTP.Types import OpenTracing.Log@@ -115,6 +115,7 @@ <> char8 '\n' where body = RequestBodyLBS+ . fromStrict . thriftEncodeSpans . map (toThriftSpan _zoLocalEndpoint _zoLogfmt) $ spans
src/OpenTracing/Zipkin/V1/Thrift.hs view
@@ -18,6 +18,7 @@ import Data.Bifunctor import Data.Bits import Data.ByteString.Builder+import Data.ByteString (ByteString) import qualified Data.ByteString.Lazy as Lazy import Data.ByteString.Lens import Data.Foldable (foldl', toList)@@ -25,8 +26,7 @@ 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 Data.Text.Encoding (decodeUtf8, encodeUtf8) import qualified Data.Vector as Vector import OpenTracing.Log import OpenTracing.Span@@ -34,12 +34,8 @@ 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+import qualified Pinch+import Zipkincore.Types ( Annotation (..) , BinaryAnnotation (..) , Span (..)@@ -48,7 +44,7 @@ , endpoint_port , endpoint_service_name )-import qualified ZipkinCore_Types as Thrift+import qualified Zipkincore.Types as Thrift toThriftSpan@@ -59,7 +55,7 @@ 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_name = view spanOperation s , span_id = view (spanContext . to ctxSpanID') s , span_parent_id = view (spanContext . to ctxParentSpanID') s , span_annotations = annotations@@ -94,7 +90,7 @@ go acc (k,v) = let (anntyp, annval) = toThriftTag v ann = Thrift.BinaryAnnotation- { binaryAnnotation_key = view lazy k+ { binaryAnnotation_key = k , binaryAnnotation_value = annval , binaryAnnotation_annotation_type = anntyp , binaryAnnotation_host = Just loc@@ -118,36 +114,31 @@ { 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+ (Event x :| []) -> x -- proper zipkin annotation+ fields -> decodeUtf8 . Lazy.toStrict . toLazyByteString $ logfmt fields } : acc -thriftEncodeSpan :: Thrift.Span -> Lazy.ByteString-thriftEncodeSpan = Thrift.encode_Span (BinaryProtocol EmptyTransport)+thriftEncodeSpan :: Thrift.Span -> ByteString+thriftEncodeSpan = Pinch.encode Pinch.binaryProtocol -thriftEncodeSpans :: Traversable t => t Thrift.Span -> Lazy.ByteString+thriftEncodeSpans :: Traversable t => t Thrift.Span -> ByteString thriftEncodeSpans- = thriftEncodeVal- . TList (T_STRUCT Thrift.typemap_Span)- . toList- . fmap Thrift.from_Span--thriftEncodeVal :: ThriftVal -> Lazy.ByteString-thriftEncodeVal = Thrift.serializeVal (BinaryProtocol EmptyTransport)+ = Pinch.encode Pinch.binaryProtocol+ . toList -toThriftTag :: TagVal -> (Thrift.AnnotationType, Lazy.ByteString)+toThriftTag :: TagVal -> (Thrift.AnnotationType, 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)+toThriftTag (StringT v) = (Thrift.STRING, view (to encodeUtf8) v)+toThriftTag (IntT v) = (Thrift.I64, Lazy.toStrict . toLazyByteString . int64BE $ v)+toThriftTag (DoubleT v) = (Thrift.DOUBLE, Lazy.toStrict . toLazyByteString . doubleBE $ v)+toThriftTag (BinaryT v) = (Thrift.BYTES, Lazy.toStrict 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_service_name = serviceName , endpoint_ipv6 = packIPv6 . fromIPv6 <$> ipv6 } where@@ -156,7 +147,7 @@ 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 :: IP.IPv6 -> ByteString packIPv6 = view packedBytes . map fromIntegral . IP.fromIPv6b