diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 =] diff --git a/gen-src/ZipkinCore_Consts.hs b/gen-src/ZipkinCore_Consts.hs deleted file mode 100644 --- a/gen-src/ZipkinCore_Consts.hs +++ /dev/null @@ -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" - diff --git a/gen-src/ZipkinCore_Types.hs b/gen-src/ZipkinCore_Types.hs deleted file mode 100644 --- a/gen-src/ZipkinCore_Types.hs +++ /dev/null @@ -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} diff --git a/gen-src/Zipkincore/Client.hs b/gen-src/Zipkincore/Client.hs new file mode 100644 --- /dev/null +++ b/gen-src/Zipkincore/Client.hs @@ -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)) diff --git a/gen-src/Zipkincore/Server.hs b/gen-src/Zipkincore/Server.hs new file mode 100644 --- /dev/null +++ b/gen-src/Zipkincore/Server.hs @@ -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))) 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,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))) + diff --git a/opentracing-zipkin-v1.cabal b/opentracing-zipkin-v1.cabal --- a/opentracing-zipkin-v1.cabal +++ b/opentracing-zipkin-v1.cabal @@ -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 diff --git a/src/OpenTracing/Zipkin/V1/HttpReporter.hs b/src/OpenTracing/Zipkin/V1/HttpReporter.hs --- a/src/OpenTracing/Zipkin/V1/HttpReporter.hs +++ b/src/OpenTracing/Zipkin/V1/HttpReporter.hs @@ -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 diff --git a/src/OpenTracing/Zipkin/V1/Thrift.hs b/src/OpenTracing/Zipkin/V1/Thrift.hs --- a/src/OpenTracing/Zipkin/V1/Thrift.hs +++ b/src/OpenTracing/Zipkin/V1/Thrift.hs @@ -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