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/Agent.hs b/gen-src/Agent.hs deleted file mode 100644 --- a/gen-src/Agent.hs +++ /dev/null @@ -1,190 +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 Agent where -import Prelude (($), (.), (>>=), (==), (++)) -import qualified Prelude as P -import qualified Control.Exception as X -import qualified Control.Monad as M ( liftM, ap, when ) -import Data.Functor ( (<$>) ) -import qualified Data.ByteString.Lazy as LBS -import qualified Data.Hashable as H -import qualified Data.Int as I -import qualified Data.Maybe as M (catMaybes) -import qualified Data.Text.Lazy.Encoding as E ( decodeUtf8, encodeUtf8 ) -import qualified Data.Text.Lazy as LT -import qualified GHC.Generics as G (Generic) -import qualified Data.Typeable as TY ( Typeable ) -import qualified Data.HashMap.Strict as Map -import qualified Data.HashSet as Set -import qualified Data.Vector as Vector -import qualified Test.QuickCheck.Arbitrary as QC ( Arbitrary(..) ) -import qualified Test.QuickCheck as QC ( elements ) - -import qualified Thrift as T -import qualified Thrift.Types as T -import qualified Thrift.Arbitraries as T - -import qualified Jaeger_Types -import qualified Zipkincore_Types - - -import Agent_Types -import qualified Agent_Iface as Iface --- HELPER FUNCTIONS AND STRUCTURES -- - -data EmitZipkinBatch_args = EmitZipkinBatch_args { emitZipkinBatch_args_spans :: (Vector.Vector Zipkincore_Types.Span) - } deriving (P.Show,P.Eq,G.Generic,TY.Typeable) -instance H.Hashable EmitZipkinBatch_args where - hashWithSalt salt record = salt `H.hashWithSalt` emitZipkinBatch_args_spans record -instance QC.Arbitrary EmitZipkinBatch_args where - arbitrary = M.liftM EmitZipkinBatch_args (QC.arbitrary) - shrink obj | obj == default_EmitZipkinBatch_args = [] - | P.otherwise = M.catMaybes - [ if obj == default_EmitZipkinBatch_args{emitZipkinBatch_args_spans = emitZipkinBatch_args_spans obj} then P.Nothing else P.Just $ default_EmitZipkinBatch_args{emitZipkinBatch_args_spans = emitZipkinBatch_args_spans obj} - ] -from_EmitZipkinBatch_args :: EmitZipkinBatch_args -> T.ThriftVal -from_EmitZipkinBatch_args record = T.TStruct $ Map.fromList $ M.catMaybes - [ (\_v2 -> P.Just (1, ("spans",T.TList (T.T_STRUCT Zipkincore_Types.typemap_Span) $ P.map (\_v4 -> Zipkincore_Types.from_Span _v4) $ Vector.toList _v2))) $ emitZipkinBatch_args_spans record - ] -write_EmitZipkinBatch_args :: T.Protocol p => p -> EmitZipkinBatch_args -> P.IO () -write_EmitZipkinBatch_args oprot record = T.writeVal oprot $ from_EmitZipkinBatch_args record -encode_EmitZipkinBatch_args :: T.StatelessProtocol p => p -> EmitZipkinBatch_args -> LBS.ByteString -encode_EmitZipkinBatch_args oprot record = T.serializeVal oprot $ from_EmitZipkinBatch_args record -to_EmitZipkinBatch_args :: T.ThriftVal -> EmitZipkinBatch_args -to_EmitZipkinBatch_args (T.TStruct fields) = EmitZipkinBatch_args{ - emitZipkinBatch_args_spans = P.maybe (emitZipkinBatch_args_spans default_EmitZipkinBatch_args) (\(_,_val6) -> (case _val6 of {T.TList _ _val7 -> (Vector.fromList $ P.map (\_v8 -> (case _v8 of {T.TStruct _val9 -> (Zipkincore_Types.to_Span (T.TStruct _val9)); _ -> P.error "wrong type"})) _val7); _ -> P.error "wrong type"})) (Map.lookup (1) fields) - } -to_EmitZipkinBatch_args _ = P.error "not a struct" -read_EmitZipkinBatch_args :: T.Protocol p => p -> P.IO EmitZipkinBatch_args -read_EmitZipkinBatch_args iprot = to_EmitZipkinBatch_args <$> T.readVal iprot (T.T_STRUCT typemap_EmitZipkinBatch_args) -decode_EmitZipkinBatch_args :: T.StatelessProtocol p => p -> LBS.ByteString -> EmitZipkinBatch_args -decode_EmitZipkinBatch_args iprot bs = to_EmitZipkinBatch_args $ T.deserializeVal iprot (T.T_STRUCT typemap_EmitZipkinBatch_args) bs -typemap_EmitZipkinBatch_args :: T.TypeMap -typemap_EmitZipkinBatch_args = Map.fromList [(1,("spans",(T.T_LIST (T.T_STRUCT Zipkincore_Types.typemap_Span))))] -default_EmitZipkinBatch_args :: EmitZipkinBatch_args -default_EmitZipkinBatch_args = EmitZipkinBatch_args{ - emitZipkinBatch_args_spans = Vector.empty} -data EmitZipkinBatch_result = EmitZipkinBatch_result deriving (P.Show,P.Eq,G.Generic,TY.Typeable) -instance H.Hashable EmitZipkinBatch_result where - hashWithSalt salt record = salt -instance QC.Arbitrary EmitZipkinBatch_result where - arbitrary = QC.elements [EmitZipkinBatch_result] -from_EmitZipkinBatch_result :: EmitZipkinBatch_result -> T.ThriftVal -from_EmitZipkinBatch_result record = T.TStruct $ Map.fromList $ M.catMaybes - [] -write_EmitZipkinBatch_result :: T.Protocol p => p -> EmitZipkinBatch_result -> P.IO () -write_EmitZipkinBatch_result oprot record = T.writeVal oprot $ from_EmitZipkinBatch_result record -encode_EmitZipkinBatch_result :: T.StatelessProtocol p => p -> EmitZipkinBatch_result -> LBS.ByteString -encode_EmitZipkinBatch_result oprot record = T.serializeVal oprot $ from_EmitZipkinBatch_result record -to_EmitZipkinBatch_result :: T.ThriftVal -> EmitZipkinBatch_result -to_EmitZipkinBatch_result (T.TStruct fields) = EmitZipkinBatch_result{ - - } -to_EmitZipkinBatch_result _ = P.error "not a struct" -read_EmitZipkinBatch_result :: T.Protocol p => p -> P.IO EmitZipkinBatch_result -read_EmitZipkinBatch_result iprot = to_EmitZipkinBatch_result <$> T.readVal iprot (T.T_STRUCT typemap_EmitZipkinBatch_result) -decode_EmitZipkinBatch_result :: T.StatelessProtocol p => p -> LBS.ByteString -> EmitZipkinBatch_result -decode_EmitZipkinBatch_result iprot bs = to_EmitZipkinBatch_result $ T.deserializeVal iprot (T.T_STRUCT typemap_EmitZipkinBatch_result) bs -typemap_EmitZipkinBatch_result :: T.TypeMap -typemap_EmitZipkinBatch_result = Map.fromList [] -default_EmitZipkinBatch_result :: EmitZipkinBatch_result -default_EmitZipkinBatch_result = EmitZipkinBatch_result{ -} -data EmitBatch_args = EmitBatch_args { emitBatch_args_batch :: Jaeger_Types.Batch - } deriving (P.Show,P.Eq,G.Generic,TY.Typeable) -instance H.Hashable EmitBatch_args where - hashWithSalt salt record = salt `H.hashWithSalt` emitBatch_args_batch record -instance QC.Arbitrary EmitBatch_args where - arbitrary = M.liftM EmitBatch_args (QC.arbitrary) - shrink obj | obj == default_EmitBatch_args = [] - | P.otherwise = M.catMaybes - [ if obj == default_EmitBatch_args{emitBatch_args_batch = emitBatch_args_batch obj} then P.Nothing else P.Just $ default_EmitBatch_args{emitBatch_args_batch = emitBatch_args_batch obj} - ] -from_EmitBatch_args :: EmitBatch_args -> T.ThriftVal -from_EmitBatch_args record = T.TStruct $ Map.fromList $ M.catMaybes - [ (\_v17 -> P.Just (1, ("batch",Jaeger_Types.from_Batch _v17))) $ emitBatch_args_batch record - ] -write_EmitBatch_args :: T.Protocol p => p -> EmitBatch_args -> P.IO () -write_EmitBatch_args oprot record = T.writeVal oprot $ from_EmitBatch_args record -encode_EmitBatch_args :: T.StatelessProtocol p => p -> EmitBatch_args -> LBS.ByteString -encode_EmitBatch_args oprot record = T.serializeVal oprot $ from_EmitBatch_args record -to_EmitBatch_args :: T.ThriftVal -> EmitBatch_args -to_EmitBatch_args (T.TStruct fields) = EmitBatch_args{ - emitBatch_args_batch = P.maybe (emitBatch_args_batch default_EmitBatch_args) (\(_,_val19) -> (case _val19 of {T.TStruct _val20 -> (Jaeger_Types.to_Batch (T.TStruct _val20)); _ -> P.error "wrong type"})) (Map.lookup (1) fields) - } -to_EmitBatch_args _ = P.error "not a struct" -read_EmitBatch_args :: T.Protocol p => p -> P.IO EmitBatch_args -read_EmitBatch_args iprot = to_EmitBatch_args <$> T.readVal iprot (T.T_STRUCT typemap_EmitBatch_args) -decode_EmitBatch_args :: T.StatelessProtocol p => p -> LBS.ByteString -> EmitBatch_args -decode_EmitBatch_args iprot bs = to_EmitBatch_args $ T.deserializeVal iprot (T.T_STRUCT typemap_EmitBatch_args) bs -typemap_EmitBatch_args :: T.TypeMap -typemap_EmitBatch_args = Map.fromList [(1,("batch",(T.T_STRUCT Jaeger_Types.typemap_Batch)))] -default_EmitBatch_args :: EmitBatch_args -default_EmitBatch_args = EmitBatch_args{ - emitBatch_args_batch = Jaeger_Types.default_Batch} -data EmitBatch_result = EmitBatch_result deriving (P.Show,P.Eq,G.Generic,TY.Typeable) -instance H.Hashable EmitBatch_result where - hashWithSalt salt record = salt -instance QC.Arbitrary EmitBatch_result where - arbitrary = QC.elements [EmitBatch_result] -from_EmitBatch_result :: EmitBatch_result -> T.ThriftVal -from_EmitBatch_result record = T.TStruct $ Map.fromList $ M.catMaybes - [] -write_EmitBatch_result :: T.Protocol p => p -> EmitBatch_result -> P.IO () -write_EmitBatch_result oprot record = T.writeVal oprot $ from_EmitBatch_result record -encode_EmitBatch_result :: T.StatelessProtocol p => p -> EmitBatch_result -> LBS.ByteString -encode_EmitBatch_result oprot record = T.serializeVal oprot $ from_EmitBatch_result record -to_EmitBatch_result :: T.ThriftVal -> EmitBatch_result -to_EmitBatch_result (T.TStruct fields) = EmitBatch_result{ - - } -to_EmitBatch_result _ = P.error "not a struct" -read_EmitBatch_result :: T.Protocol p => p -> P.IO EmitBatch_result -read_EmitBatch_result iprot = to_EmitBatch_result <$> T.readVal iprot (T.T_STRUCT typemap_EmitBatch_result) -decode_EmitBatch_result :: T.StatelessProtocol p => p -> LBS.ByteString -> EmitBatch_result -decode_EmitBatch_result iprot bs = to_EmitBatch_result $ T.deserializeVal iprot (T.T_STRUCT typemap_EmitBatch_result) bs -typemap_EmitBatch_result :: T.TypeMap -typemap_EmitBatch_result = Map.fromList [] -default_EmitBatch_result :: EmitBatch_result -default_EmitBatch_result = EmitBatch_result{ -} -process_emitZipkinBatch (seqid, iprot, oprot, handler) = do - args <- read_EmitZipkinBatch_args iprot - (X.catch - (do - Iface.emitZipkinBatch handler (emitZipkinBatch_args_spans args) - P.return ()) - ((\_ -> do - P.return ()) :: X.SomeException -> P.IO ())) -process_emitBatch (seqid, iprot, oprot, handler) = do - args <- read_EmitBatch_args iprot - (X.catch - (do - Iface.emitBatch handler (emitBatch_args_batch args) - P.return ()) - ((\_ -> do - P.return ()) :: X.SomeException -> P.IO ())) -proc_ handler (iprot,oprot) (name,typ,seqid) = case name of - "emitZipkinBatch" -> process_emitZipkinBatch (seqid,iprot,oprot,handler) - "emitBatch" -> process_emitBatch (seqid,iprot,oprot,handler) - _ -> do - _ <- T.readVal iprot (T.T_STRUCT Map.empty) - T.writeMessage oprot (name,T.M_EXCEPTION,seqid) $ - T.writeAppExn oprot (T.AppExn T.AE_UNKNOWN_METHOD ("Unknown function " ++ LT.unpack name)) -process handler (iprot, oprot) = do - T.readMessage iprot ( - proc_ handler (iprot,oprot)) - P.return P.True diff --git a/gen-src/Agent/Client.hs b/gen-src/Agent/Client.hs new file mode 100644 --- /dev/null +++ b/gen-src/Agent/Client.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE TypeFamilies, DeriveGeneric, TypeApplications, OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-unused-imports -fno-warn-name-shadowing -fno-warn-unused-matches #-} + +module Agent.Client where + +import Agent.Types +import qualified Pinch.Client +import qualified Jaeger.Types +import qualified Zipkincore.Types +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 () + +emitZipkinBatch :: ((Data.Vector.Vector Zipkincore.Types.Span)) -> (Pinch.Client.ThriftCall ()) +emitZipkinBatch spans = Pinch.Client.TOneway ("emitZipkinBatch") (EmitZipkinBatch_Args (spans)) + +emitBatch :: (Jaeger.Types.Batch) -> (Pinch.Client.ThriftCall ()) +emitBatch batch = Pinch.Client.TOneway ("emitBatch") (EmitBatch_Args (batch)) diff --git a/gen-src/Agent/Server.hs b/gen-src/Agent/Server.hs new file mode 100644 --- /dev/null +++ b/gen-src/Agent/Server.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE TypeFamilies, DeriveGeneric, TypeApplications, OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-unused-imports -fno-warn-name-shadowing -fno-warn-unused-matches #-} + +module Agent.Server where + +import Agent.Types +import qualified Pinch.Server +import qualified Jaeger.Types +import qualified Zipkincore.Types +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 Agent + = Agent { emitZipkinBatch :: (Pinch.Server.Context) -> ((Data.Vector.Vector Zipkincore.Types.Span)) -> (Prelude.IO ()), emitBatch :: (Pinch.Server.Context) -> (Jaeger.Types.Batch) -> (Prelude.IO ()) } + + +agent_mkServer :: (Agent) -> Pinch.Server.ThriftServer +agent_mkServer server = let functions = Data.HashMap.Strict.fromList ([ ( "emitZipkinBatch" + , Pinch.Server.OnewayHandler ((\ctx (EmitZipkinBatch_Args a) -> emitZipkinBatch (server) (ctx) (a))) ), ( "emitBatch" + , Pinch.Server.OnewayHandler ((\ctx (EmitBatch_Args a) -> emitBatch (server) (ctx) (a))) ) ]) in Pinch.Server.createServer ((\nm -> Data.HashMap.Strict.lookup (nm) (functions))) diff --git a/gen-src/Agent/Types.hs b/gen-src/Agent/Types.hs new file mode 100644 --- /dev/null +++ b/gen-src/Agent/Types.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE TypeFamilies, DeriveGeneric, TypeApplications, OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-unused-imports -fno-warn-name-shadowing -fno-warn-unused-matches #-} + +module Agent.Types where + +import qualified Jaeger.Types +import qualified Zipkincore.Types +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 EmitZipkinBatch_Args + = EmitZipkinBatch_Args { emitZipkinBatch_Args_spans :: (Data.Vector.Vector Zipkincore.Types.Span) } + deriving (Prelude.Eq, GHC.Generics.Generic, Prelude.Show) + +instance Pinch.Pinchable EmitZipkinBatch_Args where + type (Tag EmitZipkinBatch_Args) = Pinch.TStruct + + pinch (EmitZipkinBatch_Args emitZipkinBatch_Args_spans) = Pinch.struct ([ (1 Pinch..= emitZipkinBatch_Args_spans) ]) + + unpinch value = (Prelude.pure (EmitZipkinBatch_Args) Prelude.<*> (value Pinch..: 1)) + + +data EmitBatch_Args + = EmitBatch_Args { emitBatch_Args_batch :: Jaeger.Types.Batch } + deriving (Prelude.Eq, GHC.Generics.Generic, Prelude.Show) + +instance Pinch.Pinchable EmitBatch_Args where + type (Tag EmitBatch_Args) = Pinch.TStruct + + pinch (EmitBatch_Args emitBatch_Args_batch) = Pinch.struct ([ (1 Pinch..= emitBatch_Args_batch) ]) + + unpinch value = (Prelude.pure (EmitBatch_Args) Prelude.<*> (value Pinch..: 1)) diff --git a/gen-src/Agent_Client.hs b/gen-src/Agent_Client.hs deleted file mode 100644 --- a/gen-src/Agent_Client.hs +++ /dev/null @@ -1,61 +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 Agent_Client(emitZipkinBatch,emitBatch) where -import qualified Data.IORef as R -import Prelude (($), (.), (>>=), (==), (++)) -import qualified Prelude as P -import qualified Control.Exception as X -import qualified Control.Monad as M ( liftM, ap, when ) -import Data.Functor ( (<$>) ) -import qualified Data.ByteString.Lazy as LBS -import qualified Data.Hashable as H -import qualified Data.Int as I -import qualified Data.Maybe as M (catMaybes) -import qualified Data.Text.Lazy.Encoding as E ( decodeUtf8, encodeUtf8 ) -import qualified Data.Text.Lazy as LT -import qualified GHC.Generics as G (Generic) -import qualified Data.Typeable as TY ( Typeable ) -import qualified Data.HashMap.Strict as Map -import qualified Data.HashSet as Set -import qualified Data.Vector as Vector -import qualified Test.QuickCheck.Arbitrary as QC ( Arbitrary(..) ) -import qualified Test.QuickCheck as QC ( elements ) - -import qualified Thrift as T -import qualified Thrift.Types as T -import qualified Thrift.Arbitraries as T - -import qualified Jaeger_Types -import qualified Zipkincore_Types - - -import Agent_Types -import Agent -seqid = R.newIORef 0 -emitZipkinBatch (ip,op) arg_spans = do - send_emitZipkinBatch op arg_spans -send_emitZipkinBatch op arg_spans = do - seq <- seqid - seqn <- R.readIORef seq - T.writeMessage op ("emitZipkinBatch", T.M_ONEWAY, seqn) $ - write_EmitZipkinBatch_args op (EmitZipkinBatch_args{emitZipkinBatch_args_spans=arg_spans}) -emitBatch (ip,op) arg_batch = do - send_emitBatch op arg_batch -send_emitBatch op arg_batch = do - seq <- seqid - seqn <- R.readIORef seq - T.writeMessage op ("emitBatch", T.M_ONEWAY, seqn) $ - write_EmitBatch_args op (EmitBatch_args{emitBatch_args_batch=arg_batch}) diff --git a/gen-src/Agent_Iface.hs b/gen-src/Agent_Iface.hs deleted file mode 100644 --- a/gen-src/Agent_Iface.hs +++ /dev/null @@ -1,48 +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 Agent_Iface where -import Prelude (($), (.), (>>=), (==), (++)) -import qualified Prelude as P -import qualified Control.Exception as X -import qualified Control.Monad as M ( liftM, ap, when ) -import Data.Functor ( (<$>) ) -import qualified Data.ByteString.Lazy as LBS -import qualified Data.Hashable as H -import qualified Data.Int as I -import qualified Data.Maybe as M (catMaybes) -import qualified Data.Text.Lazy.Encoding as E ( decodeUtf8, encodeUtf8 ) -import qualified Data.Text.Lazy as LT -import qualified GHC.Generics as G (Generic) -import qualified Data.Typeable as TY ( Typeable ) -import qualified Data.HashMap.Strict as Map -import qualified Data.HashSet as Set -import qualified Data.Vector as Vector -import qualified Test.QuickCheck.Arbitrary as QC ( Arbitrary(..) ) -import qualified Test.QuickCheck as QC ( elements ) - -import qualified Thrift as T -import qualified Thrift.Types as T -import qualified Thrift.Arbitraries as T - -import qualified Jaeger_Types -import qualified Zipkincore_Types - - -import Agent_Types - -class Agent_Iface a where - emitZipkinBatch :: a -> (Vector.Vector Zipkincore_Types.Span) -> P.IO () - emitBatch :: a -> Jaeger_Types.Batch -> P.IO () diff --git a/gen-src/Agent_Types.hs b/gen-src/Agent_Types.hs deleted file mode 100644 --- a/gen-src/Agent_Types.hs +++ /dev/null @@ -1,43 +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 Agent_Types where -import Prelude (($), (.), (>>=), (==), (++)) -import qualified Prelude as P -import qualified Control.Exception as X -import qualified Control.Monad as M ( liftM, ap, when ) -import Data.Functor ( (<$>) ) -import qualified Data.ByteString.Lazy as LBS -import qualified Data.Hashable as H -import qualified Data.Int as I -import qualified Data.Maybe as M (catMaybes) -import qualified Data.Text.Lazy.Encoding as E ( decodeUtf8, encodeUtf8 ) -import qualified Data.Text.Lazy as LT -import qualified GHC.Generics as G (Generic) -import qualified Data.Typeable as TY ( Typeable ) -import qualified Data.HashMap.Strict as Map -import qualified Data.HashSet as Set -import qualified Data.Vector as Vector -import qualified Test.QuickCheck.Arbitrary as QC ( Arbitrary(..) ) -import qualified Test.QuickCheck as QC ( elements ) - -import qualified Thrift as T -import qualified Thrift.Types as T -import qualified Thrift.Arbitraries as T - -import qualified Jaeger_Types -import qualified Zipkincore_Types - - diff --git a/gen-src/Jaeger/Client.hs b/gen-src/Jaeger/Client.hs new file mode 100644 --- /dev/null +++ b/gen-src/Jaeger/Client.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE TypeFamilies, DeriveGeneric, TypeApplications, OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-unused-imports -fno-warn-name-shadowing -fno-warn-unused-matches #-} + +module Jaeger.Client where + +import Jaeger.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 () + +submitBatches :: ((Data.Vector.Vector Batch)) -> (Pinch.Client.ThriftCall SubmitBatches_Result) +submitBatches batches = Pinch.Client.TCall ("submitBatches") (SubmitBatches_Args (batches)) diff --git a/gen-src/Jaeger/Server.hs b/gen-src/Jaeger/Server.hs new file mode 100644 --- /dev/null +++ b/gen-src/Jaeger/Server.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE TypeFamilies, DeriveGeneric, TypeApplications, OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-unused-imports -fno-warn-name-shadowing -fno-warn-unused-matches #-} + +module Jaeger.Server where + +import Jaeger.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 Collector + = Collector { submitBatches :: (Pinch.Server.Context) -> ((Data.Vector.Vector Batch)) -> (Prelude.IO (Data.Vector.Vector BatchSubmitResponse)) } + + +collector_mkServer :: (Collector) -> Pinch.Server.ThriftServer +collector_mkServer server = let functions = Data.HashMap.Strict.fromList ([ ( "submitBatches" + , Pinch.Server.CallHandler ((\ctx (SubmitBatches_Args a) -> Pinch.Internal.RPC.wrap @(SubmitBatches_Result) (submitBatches (server) (ctx) (a)))) ) ]) in Pinch.Server.createServer ((\nm -> Data.HashMap.Strict.lookup (nm) (functions))) diff --git a/gen-src/Jaeger/Types.hs b/gen-src/Jaeger/Types.hs new file mode 100644 --- /dev/null +++ b/gen-src/Jaeger/Types.hs @@ -0,0 +1,238 @@ +{-# LANGUAGE TypeFamilies, DeriveGeneric, TypeApplications, OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-unused-imports -fno-warn-name-shadowing -fno-warn-unused-matches #-} + +module Jaeger.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 () + +data TagType + = STRING + | DOUBLE + | BOOL + | LONG + | BINARY + deriving (Prelude.Eq, Prelude.Ord, GHC.Generics.Generic, Prelude.Show, Prelude.Bounded) + +instance Pinch.Pinchable TagType where + type (Tag TagType) = Pinch.TEnum + + pinch STRING = Pinch.pinch ((0 :: Data.Int.Int32)) + pinch DOUBLE = Pinch.pinch ((1 :: Data.Int.Int32)) + pinch BOOL = Pinch.pinch ((2 :: Data.Int.Int32)) + pinch LONG = Pinch.pinch ((3 :: Data.Int.Int32)) + pinch BINARY = Pinch.pinch ((4 :: Data.Int.Int32)) + + unpinch v = do + val <- Pinch.unpinch (v) + case (val :: Data.Int.Int32) of + 0 -> Prelude.pure (STRING) + 1 -> Prelude.pure (DOUBLE) + 2 -> Prelude.pure (BOOL) + 3 -> Prelude.pure (LONG) + 4 -> Prelude.pure (BINARY) + _ -> Prelude.fail (("Unknown value for type TagType: " Prelude.<> Prelude.show (val))) + + +instance Prelude.Enum TagType where + fromEnum STRING = 0 + fromEnum DOUBLE = 1 + fromEnum BOOL = 2 + fromEnum LONG = 3 + fromEnum BINARY = 4 + + toEnum 0 = STRING + toEnum 1 = DOUBLE + toEnum 2 = BOOL + toEnum 3 = LONG + toEnum 4 = BINARY + toEnum _ = Prelude.error ("Unknown value for enum TagType.") + + +instance Data.Hashable.Hashable TagType where + +data Tag + = Tag { tag_key :: Data.Text.Text, tag_vType :: TagType, tag_vStr :: (Prelude.Maybe Data.Text.Text), tag_vDouble :: (Prelude.Maybe Prelude.Double), tag_vBool :: (Prelude.Maybe Prelude.Bool), tag_vLong :: (Prelude.Maybe Data.Int.Int64), tag_vBinary :: (Prelude.Maybe Data.ByteString.ByteString) } + deriving (Prelude.Eq, GHC.Generics.Generic, Prelude.Show) + +instance Pinch.Pinchable Tag where + type (Tag Tag) = Pinch.TStruct + + pinch (Tag tag_key tag_vType tag_vStr tag_vDouble tag_vBool tag_vLong tag_vBinary) = Pinch.struct ([ (1 Pinch..= tag_key), (2 Pinch..= tag_vType), (3 Pinch.?= tag_vStr), (4 Pinch.?= tag_vDouble), (5 Pinch.?= tag_vBool), (6 Pinch.?= tag_vLong), (7 Pinch.?= tag_vBinary) ]) + + unpinch value = (((((((Prelude.pure (Tag) Prelude.<*> (value Pinch..: 1)) Prelude.<*> (value Pinch..: 2)) Prelude.<*> (value Pinch..:? 3)) Prelude.<*> (value Pinch..:? 4)) Prelude.<*> (value Pinch..:? 5)) Prelude.<*> (value Pinch..:? 6)) Prelude.<*> (value Pinch..:? 7)) + + +instance Data.Hashable.Hashable Tag where + +data Log + = Log { log_timestamp :: Data.Int.Int64, log_fields :: (Data.Vector.Vector Tag) } + deriving (Prelude.Eq, GHC.Generics.Generic, Prelude.Show) + +instance Pinch.Pinchable Log where + type (Tag Log) = Pinch.TStruct + + pinch (Log log_timestamp log_fields) = Pinch.struct ([ (1 Pinch..= log_timestamp), (2 Pinch..= log_fields) ]) + + unpinch value = ((Prelude.pure (Log) Prelude.<*> (value Pinch..: 1)) Prelude.<*> (value Pinch..: 2)) + + +instance Data.Hashable.Hashable Log where + +data SpanRefType + = CHILD_OF + | FOLLOWS_FROM + deriving (Prelude.Eq, Prelude.Ord, GHC.Generics.Generic, Prelude.Show, Prelude.Bounded) + +instance Pinch.Pinchable SpanRefType where + type (Tag SpanRefType) = Pinch.TEnum + + pinch CHILD_OF = Pinch.pinch ((0 :: Data.Int.Int32)) + pinch FOLLOWS_FROM = Pinch.pinch ((1 :: Data.Int.Int32)) + + unpinch v = do + val <- Pinch.unpinch (v) + case (val :: Data.Int.Int32) of + 0 -> Prelude.pure (CHILD_OF) + 1 -> Prelude.pure (FOLLOWS_FROM) + _ -> Prelude.fail (("Unknown value for type SpanRefType: " Prelude.<> Prelude.show (val))) + + +instance Prelude.Enum SpanRefType where + fromEnum CHILD_OF = 0 + fromEnum FOLLOWS_FROM = 1 + + toEnum 0 = CHILD_OF + toEnum 1 = FOLLOWS_FROM + toEnum _ = Prelude.error ("Unknown value for enum SpanRefType.") + + +instance Data.Hashable.Hashable SpanRefType where + +data SpanRef + = SpanRef { spanRef_refType :: SpanRefType, spanRef_traceIdLow :: Data.Int.Int64, spanRef_traceIdHigh :: Data.Int.Int64, spanRef_spanId :: Data.Int.Int64 } + deriving (Prelude.Eq, GHC.Generics.Generic, Prelude.Show) + +instance Pinch.Pinchable SpanRef where + type (Tag SpanRef) = Pinch.TStruct + + pinch (SpanRef spanRef_refType spanRef_traceIdLow spanRef_traceIdHigh spanRef_spanId) = Pinch.struct ([ (1 Pinch..= spanRef_refType), (2 Pinch..= spanRef_traceIdLow), (3 Pinch..= spanRef_traceIdHigh), (4 Pinch..= spanRef_spanId) ]) + + unpinch value = ((((Prelude.pure (SpanRef) Prelude.<*> (value Pinch..: 1)) Prelude.<*> (value Pinch..: 2)) Prelude.<*> (value Pinch..: 3)) Prelude.<*> (value Pinch..: 4)) + + +instance Data.Hashable.Hashable SpanRef where + +data Span + = Span { span_traceIdLow :: Data.Int.Int64, span_traceIdHigh :: Data.Int.Int64, span_spanId :: Data.Int.Int64, span_parentSpanId :: Data.Int.Int64, span_operationName :: Data.Text.Text, span_references :: (Prelude.Maybe (Data.Vector.Vector SpanRef)), span_flags :: Data.Int.Int32, span_startTime :: Data.Int.Int64, span_duration :: Data.Int.Int64, span_tags :: (Prelude.Maybe (Data.Vector.Vector Tag)), span_logs :: (Prelude.Maybe (Data.Vector.Vector Log)) } + deriving (Prelude.Eq, GHC.Generics.Generic, Prelude.Show) + +instance Pinch.Pinchable Span where + type (Tag Span) = Pinch.TStruct + + pinch (Span span_traceIdLow span_traceIdHigh span_spanId span_parentSpanId span_operationName span_references span_flags span_startTime span_duration span_tags span_logs) = Pinch.struct ([ (1 Pinch..= span_traceIdLow), (2 Pinch..= span_traceIdHigh), (3 Pinch..= span_spanId), (4 Pinch..= span_parentSpanId), (5 Pinch..= span_operationName), (6 Pinch.?= span_references), (7 Pinch..= span_flags), (8 Pinch..= span_startTime), (9 Pinch..= span_duration), (10 Pinch.?= span_tags), (11 Pinch.?= span_logs) ]) + + unpinch value = (((((((((((Prelude.pure (Span) Prelude.<*> (value Pinch..: 1)) Prelude.<*> (value Pinch..: 2)) Prelude.<*> (value Pinch..: 3)) Prelude.<*> (value Pinch..: 4)) Prelude.<*> (value Pinch..: 5)) Prelude.<*> (value Pinch..:? 6)) Prelude.<*> (value Pinch..: 7)) Prelude.<*> (value Pinch..: 8)) Prelude.<*> (value Pinch..: 9)) Prelude.<*> (value Pinch..:? 10)) Prelude.<*> (value Pinch..:? 11)) + + +instance Data.Hashable.Hashable Span where + +data Process + = Process { process_serviceName :: Data.Text.Text, process_tags :: (Prelude.Maybe (Data.Vector.Vector Tag)) } + deriving (Prelude.Eq, GHC.Generics.Generic, Prelude.Show) + +instance Pinch.Pinchable Process where + type (Tag Process) = Pinch.TStruct + + pinch (Process process_serviceName process_tags) = Pinch.struct ([ (1 Pinch..= process_serviceName), (2 Pinch.?= process_tags) ]) + + unpinch value = ((Prelude.pure (Process) Prelude.<*> (value Pinch..: 1)) Prelude.<*> (value Pinch..:? 2)) + + +instance Data.Hashable.Hashable Process where + +data ClientStats + = ClientStats { clientStats_fullQueueDroppedSpans :: Data.Int.Int64, clientStats_tooLargeDroppedSpans :: Data.Int.Int64, clientStats_failedToEmitSpans :: Data.Int.Int64 } + deriving (Prelude.Eq, GHC.Generics.Generic, Prelude.Show) + +instance Pinch.Pinchable ClientStats where + type (Tag ClientStats) = Pinch.TStruct + + pinch (ClientStats clientStats_fullQueueDroppedSpans clientStats_tooLargeDroppedSpans clientStats_failedToEmitSpans) = Pinch.struct ([ (1 Pinch..= clientStats_fullQueueDroppedSpans), (2 Pinch..= clientStats_tooLargeDroppedSpans), (3 Pinch..= clientStats_failedToEmitSpans) ]) + + unpinch value = (((Prelude.pure (ClientStats) Prelude.<*> (value Pinch..: 1)) Prelude.<*> (value Pinch..: 2)) Prelude.<*> (value Pinch..: 3)) + + +instance Data.Hashable.Hashable ClientStats where + +data Batch + = Batch { batch_process :: Process, batch_spans :: (Data.Vector.Vector Span), batch_seqNo :: (Prelude.Maybe Data.Int.Int64), batch_stats :: (Prelude.Maybe ClientStats) } + deriving (Prelude.Eq, GHC.Generics.Generic, Prelude.Show) + +instance Pinch.Pinchable Batch where + type (Tag Batch) = Pinch.TStruct + + pinch (Batch batch_process batch_spans batch_seqNo batch_stats) = Pinch.struct ([ (1 Pinch..= batch_process), (2 Pinch..= batch_spans), (3 Pinch.?= batch_seqNo), (4 Pinch.?= batch_stats) ]) + + unpinch value = ((((Prelude.pure (Batch) Prelude.<*> (value Pinch..: 1)) Prelude.<*> (value Pinch..: 2)) Prelude.<*> (value Pinch..:? 3)) Prelude.<*> (value Pinch..:? 4)) + + +instance Data.Hashable.Hashable Batch where + +data BatchSubmitResponse + = BatchSubmitResponse { batchSubmitResponse_ok :: Prelude.Bool } + deriving (Prelude.Eq, GHC.Generics.Generic, Prelude.Show) + +instance Pinch.Pinchable BatchSubmitResponse where + type (Tag BatchSubmitResponse) = Pinch.TStruct + + pinch (BatchSubmitResponse batchSubmitResponse_ok) = Pinch.struct ([ (1 Pinch..= batchSubmitResponse_ok) ]) + + unpinch value = (Prelude.pure (BatchSubmitResponse) Prelude.<*> (value Pinch..: 1)) + + +instance Data.Hashable.Hashable BatchSubmitResponse where + +data SubmitBatches_Args + = SubmitBatches_Args { submitBatches_Args_batches :: (Data.Vector.Vector Batch) } + deriving (Prelude.Eq, GHC.Generics.Generic, Prelude.Show) + +instance Pinch.Pinchable SubmitBatches_Args where + type (Tag SubmitBatches_Args) = Pinch.TStruct + + pinch (SubmitBatches_Args submitBatches_Args_batches) = Pinch.struct ([ (1 Pinch..= submitBatches_Args_batches) ]) + + unpinch value = (Prelude.pure (SubmitBatches_Args) Prelude.<*> (value Pinch..: 1)) + + +instance Pinch.Internal.RPC.ThriftResult SubmitBatches_Result where + type (ResultType SubmitBatches_Result) = (Data.Vector.Vector BatchSubmitResponse) + + unwrap (SubmitBatches_Result_Success x) = Prelude.pure (x) + + wrap m = Control.Exception.catches ((SubmitBatches_Result_Success Prelude.<$> m)) ([ ]) + + +data SubmitBatches_Result + = SubmitBatches_Result_Success (Data.Vector.Vector BatchSubmitResponse) + deriving (Prelude.Eq, GHC.Generics.Generic, Prelude.Show) + +instance Pinch.Pinchable SubmitBatches_Result where + type (Tag SubmitBatches_Result) = Pinch.TUnion + + pinch (SubmitBatches_Result_Success x) = Pinch.union (0) (x) + + unpinch v = (Control.Applicative.empty Control.Applicative.<|> (SubmitBatches_Result_Success Prelude.<$> (v Pinch..: 0))) diff --git a/gen-src/Jaeger_Consts.hs b/gen-src/Jaeger_Consts.hs deleted file mode 100644 --- a/gen-src/Jaeger_Consts.hs +++ /dev/null @@ -1,41 +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 Jaeger_Consts where -import Prelude (($), (.), (>>=), (==), (++)) -import qualified Prelude as P -import qualified Control.Exception as X -import qualified Control.Monad as M ( liftM, ap, when ) -import Data.Functor ( (<$>) ) -import qualified Data.ByteString.Lazy as LBS -import qualified Data.Hashable as H -import qualified Data.Int as I -import qualified Data.Maybe as M (catMaybes) -import qualified Data.Text.Lazy.Encoding as E ( decodeUtf8, encodeUtf8 ) -import qualified Data.Text.Lazy as LT -import qualified GHC.Generics as G (Generic) -import qualified Data.Typeable as TY ( Typeable ) -import qualified Data.HashMap.Strict as Map -import qualified Data.HashSet as Set -import qualified Data.Vector as Vector -import qualified Test.QuickCheck.Arbitrary as QC ( Arbitrary(..) ) -import qualified Test.QuickCheck as QC ( elements ) - -import qualified Thrift as T -import qualified Thrift.Types as T -import qualified Thrift.Arbitraries as T - - -import Jaeger_Types diff --git a/gen-src/Jaeger_Types.hs b/gen-src/Jaeger_Types.hs deleted file mode 100644 --- a/gen-src/Jaeger_Types.hs +++ /dev/null @@ -1,434 +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 Jaeger_Types where -import Prelude (($), (.), (>>=), (==), (++)) -import qualified Prelude as P -import qualified Control.Exception as X -import qualified Control.Monad as M ( liftM, ap, when ) -import Data.Functor ( (<$>) ) -import qualified Data.ByteString.Lazy as LBS -import qualified Data.Hashable as H -import qualified Data.Int as I -import qualified Data.Maybe as M (catMaybes) -import qualified Data.Text.Lazy.Encoding as E ( decodeUtf8, encodeUtf8 ) -import qualified Data.Text.Lazy as LT -import qualified GHC.Generics as G (Generic) -import qualified Data.Typeable as TY ( Typeable ) -import qualified Data.HashMap.Strict as Map -import qualified Data.HashSet as Set -import qualified Data.Vector as Vector -import qualified Test.QuickCheck.Arbitrary as QC ( Arbitrary(..) ) -import qualified Test.QuickCheck as QC ( elements ) - -import qualified Thrift as T -import qualified Thrift.Types as T -import qualified Thrift.Arbitraries as T - - -data TagType = STRING|DOUBLE|BOOL|LONG|BINARY deriving (P.Show, P.Eq, G.Generic, TY.Typeable, P.Ord, P.Bounded) -instance P.Enum TagType where - fromEnum t = case t of - STRING -> 0 - DOUBLE -> 1 - BOOL -> 2 - LONG -> 3 - BINARY -> 4 - toEnum t = case t of - 0 -> STRING - 1 -> DOUBLE - 2 -> BOOL - 3 -> LONG - 4 -> BINARY - _ -> X.throw T.ThriftException -instance H.Hashable TagType where - hashWithSalt salt = H.hashWithSalt salt P.. P.fromEnum -instance QC.Arbitrary TagType where - arbitrary = QC.elements (P.enumFromTo P.minBound P.maxBound) -data SpanRefType = CHILD_OF|FOLLOWS_FROM deriving (P.Show, P.Eq, G.Generic, TY.Typeable, P.Ord, P.Bounded) -instance P.Enum SpanRefType where - fromEnum t = case t of - CHILD_OF -> 0 - FOLLOWS_FROM -> 1 - toEnum t = case t of - 0 -> CHILD_OF - 1 -> FOLLOWS_FROM - _ -> X.throw T.ThriftException -instance H.Hashable SpanRefType where - hashWithSalt salt = H.hashWithSalt salt P.. P.fromEnum -instance QC.Arbitrary SpanRefType where - arbitrary = QC.elements (P.enumFromTo P.minBound P.maxBound) -data Tag = Tag { tag_key :: LT.Text - , tag_vType :: TagType - , tag_vStr :: P.Maybe LT.Text - , tag_vDouble :: P.Maybe P.Double - , tag_vBool :: P.Maybe P.Bool - , tag_vLong :: P.Maybe I.Int64 - , tag_vBinary :: P.Maybe LBS.ByteString - } deriving (P.Show,P.Eq,G.Generic,TY.Typeable) -instance H.Hashable Tag where - hashWithSalt salt record = salt `H.hashWithSalt` tag_key record `H.hashWithSalt` tag_vType record `H.hashWithSalt` tag_vStr record `H.hashWithSalt` tag_vDouble record `H.hashWithSalt` tag_vBool record `H.hashWithSalt` tag_vLong record `H.hashWithSalt` tag_vBinary record -instance QC.Arbitrary Tag where - arbitrary = M.liftM Tag (QC.arbitrary) - `M.ap`(QC.arbitrary) - `M.ap`(M.liftM P.Just QC.arbitrary) - `M.ap`(M.liftM P.Just QC.arbitrary) - `M.ap`(M.liftM P.Just QC.arbitrary) - `M.ap`(M.liftM P.Just QC.arbitrary) - `M.ap`(M.liftM P.Just QC.arbitrary) - shrink obj | obj == default_Tag = [] - | P.otherwise = M.catMaybes - [ if obj == default_Tag{tag_key = tag_key obj} then P.Nothing else P.Just $ default_Tag{tag_key = tag_key obj} - , if obj == default_Tag{tag_vType = tag_vType obj} then P.Nothing else P.Just $ default_Tag{tag_vType = tag_vType obj} - , if obj == default_Tag{tag_vStr = tag_vStr obj} then P.Nothing else P.Just $ default_Tag{tag_vStr = tag_vStr obj} - , if obj == default_Tag{tag_vDouble = tag_vDouble obj} then P.Nothing else P.Just $ default_Tag{tag_vDouble = tag_vDouble obj} - , if obj == default_Tag{tag_vBool = tag_vBool obj} then P.Nothing else P.Just $ default_Tag{tag_vBool = tag_vBool obj} - , if obj == default_Tag{tag_vLong = tag_vLong obj} then P.Nothing else P.Just $ default_Tag{tag_vLong = tag_vLong obj} - , if obj == default_Tag{tag_vBinary = tag_vBinary obj} then P.Nothing else P.Just $ default_Tag{tag_vBinary = tag_vBinary obj} - ] -from_Tag :: Tag -> T.ThriftVal -from_Tag record = T.TStruct $ Map.fromList $ M.catMaybes - [ (\_v2 -> P.Just (1, ("key",T.TString $ E.encodeUtf8 _v2))) $ tag_key record - , (\_v2 -> P.Just (2, ("vType",T.TI32 $ P.fromIntegral $ P.fromEnum _v2))) $ tag_vType record - , (\_v2 -> (3, ("vStr",T.TString $ E.encodeUtf8 _v2))) <$> tag_vStr record - , (\_v2 -> (4, ("vDouble",T.TDouble _v2))) <$> tag_vDouble record - , (\_v2 -> (5, ("vBool",T.TBool _v2))) <$> tag_vBool record - , (\_v2 -> (6, ("vLong",T.TI64 _v2))) <$> tag_vLong record - , (\_v2 -> (7, ("vBinary",T.TBinary _v2))) <$> tag_vBinary record - ] -write_Tag :: T.Protocol p => p -> Tag -> P.IO () -write_Tag oprot record = T.writeVal oprot $ from_Tag record -encode_Tag :: T.StatelessProtocol p => p -> Tag -> LBS.ByteString -encode_Tag oprot record = T.serializeVal oprot $ from_Tag record -to_Tag :: T.ThriftVal -> Tag -to_Tag (T.TStruct fields) = Tag{ - tag_key = P.maybe (P.error "Missing required field: key") (\(_,_val4) -> (case _val4 of {T.TString _val5 -> E.decodeUtf8 _val5; _ -> P.error "wrong type"})) (Map.lookup (1) fields), - tag_vType = P.maybe (P.error "Missing required field: vType") (\(_,_val4) -> (case _val4 of {T.TI32 _val6 -> P.toEnum $ P.fromIntegral _val6; _ -> P.error "wrong type"})) (Map.lookup (2) fields), - tag_vStr = P.maybe (P.Nothing) (\(_,_val4) -> P.Just (case _val4 of {T.TString _val7 -> E.decodeUtf8 _val7; _ -> P.error "wrong type"})) (Map.lookup (3) fields), - tag_vDouble = P.maybe (P.Nothing) (\(_,_val4) -> P.Just (case _val4 of {T.TDouble _val8 -> _val8; _ -> P.error "wrong type"})) (Map.lookup (4) fields), - tag_vBool = P.maybe (P.Nothing) (\(_,_val4) -> P.Just (case _val4 of {T.TBool _val9 -> _val9; _ -> P.error "wrong type"})) (Map.lookup (5) fields), - tag_vLong = P.maybe (P.Nothing) (\(_,_val4) -> P.Just (case _val4 of {T.TI64 _val10 -> _val10; _ -> P.error "wrong type"})) (Map.lookup (6) fields), - tag_vBinary = P.maybe (P.Nothing) (\(_,_val4) -> P.Just (case _val4 of {T.TBinary _val11 -> _val11; T.TString _val11 -> _val11; _ -> P.error "wrong type"})) (Map.lookup (7) fields) - } -to_Tag _ = P.error "not a struct" -read_Tag :: T.Protocol p => p -> P.IO Tag -read_Tag iprot = to_Tag <$> T.readVal iprot (T.T_STRUCT typemap_Tag) -decode_Tag :: T.StatelessProtocol p => p -> LBS.ByteString -> Tag -decode_Tag iprot bs = to_Tag $ T.deserializeVal iprot (T.T_STRUCT typemap_Tag) bs -typemap_Tag :: T.TypeMap -typemap_Tag = Map.fromList [(1,("key",T.T_STRING)),(2,("vType",T.T_I32)),(3,("vStr",T.T_STRING)),(4,("vDouble",T.T_DOUBLE)),(5,("vBool",T.T_BOOL)),(6,("vLong",T.T_I64)),(7,("vBinary",T.T_BINARY))] -default_Tag :: Tag -default_Tag = Tag{ - tag_key = "", - tag_vType = (P.toEnum 0), - tag_vStr = P.Nothing, - tag_vDouble = P.Nothing, - tag_vBool = P.Nothing, - tag_vLong = P.Nothing, - tag_vBinary = P.Nothing} -data Log = Log { log_timestamp :: I.Int64 - , log_fields :: (Vector.Vector Tag) - } deriving (P.Show,P.Eq,G.Generic,TY.Typeable) -instance H.Hashable Log where - hashWithSalt salt record = salt `H.hashWithSalt` log_timestamp record `H.hashWithSalt` log_fields record -instance QC.Arbitrary Log where - arbitrary = M.liftM Log (QC.arbitrary) - `M.ap`(QC.arbitrary) - shrink obj | obj == default_Log = [] - | P.otherwise = M.catMaybes - [ if obj == default_Log{log_timestamp = log_timestamp obj} then P.Nothing else P.Just $ default_Log{log_timestamp = log_timestamp obj} - , if obj == default_Log{log_fields = log_fields obj} then P.Nothing else P.Just $ default_Log{log_fields = log_fields obj} - ] -from_Log :: Log -> T.ThriftVal -from_Log record = T.TStruct $ Map.fromList $ M.catMaybes - [ (\_v14 -> P.Just (1, ("timestamp",T.TI64 _v14))) $ log_timestamp record - , (\_v14 -> P.Just (2, ("fields",T.TList (T.T_STRUCT typemap_Tag) $ P.map (\_v16 -> from_Tag _v16) $ Vector.toList _v14))) $ log_fields record - ] -write_Log :: T.Protocol p => p -> Log -> P.IO () -write_Log oprot record = T.writeVal oprot $ from_Log record -encode_Log :: T.StatelessProtocol p => p -> Log -> LBS.ByteString -encode_Log oprot record = T.serializeVal oprot $ from_Log record -to_Log :: T.ThriftVal -> Log -to_Log (T.TStruct fields) = Log{ - log_timestamp = P.maybe (P.error "Missing required field: timestamp") (\(_,_val18) -> (case _val18 of {T.TI64 _val19 -> _val19; _ -> P.error "wrong type"})) (Map.lookup (1) fields), - log_fields = P.maybe (P.error "Missing required field: fields") (\(_,_val18) -> (case _val18 of {T.TList _ _val20 -> (Vector.fromList $ P.map (\_v21 -> (case _v21 of {T.TStruct _val22 -> (to_Tag (T.TStruct _val22)); _ -> P.error "wrong type"})) _val20); _ -> P.error "wrong type"})) (Map.lookup (2) fields) - } -to_Log _ = P.error "not a struct" -read_Log :: T.Protocol p => p -> P.IO Log -read_Log iprot = to_Log <$> T.readVal iprot (T.T_STRUCT typemap_Log) -decode_Log :: T.StatelessProtocol p => p -> LBS.ByteString -> Log -decode_Log iprot bs = to_Log $ T.deserializeVal iprot (T.T_STRUCT typemap_Log) bs -typemap_Log :: T.TypeMap -typemap_Log = Map.fromList [(1,("timestamp",T.T_I64)),(2,("fields",(T.T_LIST (T.T_STRUCT typemap_Tag))))] -default_Log :: Log -default_Log = Log{ - log_timestamp = 0, - log_fields = Vector.empty} -data SpanRef = SpanRef { spanRef_refType :: SpanRefType - , spanRef_traceIdLow :: I.Int64 - , spanRef_traceIdHigh :: I.Int64 - , spanRef_spanId :: I.Int64 - } deriving (P.Show,P.Eq,G.Generic,TY.Typeable) -instance H.Hashable SpanRef where - hashWithSalt salt record = salt `H.hashWithSalt` spanRef_refType record `H.hashWithSalt` spanRef_traceIdLow record `H.hashWithSalt` spanRef_traceIdHigh record `H.hashWithSalt` spanRef_spanId record -instance QC.Arbitrary SpanRef where - arbitrary = M.liftM SpanRef (QC.arbitrary) - `M.ap`(QC.arbitrary) - `M.ap`(QC.arbitrary) - `M.ap`(QC.arbitrary) - shrink obj | obj == default_SpanRef = [] - | P.otherwise = M.catMaybes - [ if obj == default_SpanRef{spanRef_refType = spanRef_refType obj} then P.Nothing else P.Just $ default_SpanRef{spanRef_refType = spanRef_refType obj} - , if obj == default_SpanRef{spanRef_traceIdLow = spanRef_traceIdLow obj} then P.Nothing else P.Just $ default_SpanRef{spanRef_traceIdLow = spanRef_traceIdLow obj} - , if obj == default_SpanRef{spanRef_traceIdHigh = spanRef_traceIdHigh obj} then P.Nothing else P.Just $ default_SpanRef{spanRef_traceIdHigh = spanRef_traceIdHigh obj} - , if obj == default_SpanRef{spanRef_spanId = spanRef_spanId obj} then P.Nothing else P.Just $ default_SpanRef{spanRef_spanId = spanRef_spanId obj} - ] -from_SpanRef :: SpanRef -> T.ThriftVal -from_SpanRef record = T.TStruct $ Map.fromList $ M.catMaybes - [ (\_v25 -> P.Just (1, ("refType",T.TI32 $ P.fromIntegral $ P.fromEnum _v25))) $ spanRef_refType record - , (\_v25 -> P.Just (2, ("traceIdLow",T.TI64 _v25))) $ spanRef_traceIdLow record - , (\_v25 -> P.Just (3, ("traceIdHigh",T.TI64 _v25))) $ spanRef_traceIdHigh record - , (\_v25 -> P.Just (4, ("spanId",T.TI64 _v25))) $ spanRef_spanId record - ] -write_SpanRef :: T.Protocol p => p -> SpanRef -> P.IO () -write_SpanRef oprot record = T.writeVal oprot $ from_SpanRef record -encode_SpanRef :: T.StatelessProtocol p => p -> SpanRef -> LBS.ByteString -encode_SpanRef oprot record = T.serializeVal oprot $ from_SpanRef record -to_SpanRef :: T.ThriftVal -> SpanRef -to_SpanRef (T.TStruct fields) = SpanRef{ - spanRef_refType = P.maybe (P.error "Missing required field: refType") (\(_,_val27) -> (case _val27 of {T.TI32 _val28 -> P.toEnum $ P.fromIntegral _val28; _ -> P.error "wrong type"})) (Map.lookup (1) fields), - spanRef_traceIdLow = P.maybe (P.error "Missing required field: traceIdLow") (\(_,_val27) -> (case _val27 of {T.TI64 _val29 -> _val29; _ -> P.error "wrong type"})) (Map.lookup (2) fields), - spanRef_traceIdHigh = P.maybe (P.error "Missing required field: traceIdHigh") (\(_,_val27) -> (case _val27 of {T.TI64 _val30 -> _val30; _ -> P.error "wrong type"})) (Map.lookup (3) fields), - spanRef_spanId = P.maybe (P.error "Missing required field: spanId") (\(_,_val27) -> (case _val27 of {T.TI64 _val31 -> _val31; _ -> P.error "wrong type"})) (Map.lookup (4) fields) - } -to_SpanRef _ = P.error "not a struct" -read_SpanRef :: T.Protocol p => p -> P.IO SpanRef -read_SpanRef iprot = to_SpanRef <$> T.readVal iprot (T.T_STRUCT typemap_SpanRef) -decode_SpanRef :: T.StatelessProtocol p => p -> LBS.ByteString -> SpanRef -decode_SpanRef iprot bs = to_SpanRef $ T.deserializeVal iprot (T.T_STRUCT typemap_SpanRef) bs -typemap_SpanRef :: T.TypeMap -typemap_SpanRef = Map.fromList [(1,("refType",T.T_I32)),(2,("traceIdLow",T.T_I64)),(3,("traceIdHigh",T.T_I64)),(4,("spanId",T.T_I64))] -default_SpanRef :: SpanRef -default_SpanRef = SpanRef{ - spanRef_refType = (P.toEnum 0), - spanRef_traceIdLow = 0, - spanRef_traceIdHigh = 0, - spanRef_spanId = 0} -data Span = Span { span_traceIdLow :: I.Int64 - , span_traceIdHigh :: I.Int64 - , span_spanId :: I.Int64 - , span_parentSpanId :: I.Int64 - , span_operationName :: LT.Text - , span_references :: P.Maybe (Vector.Vector SpanRef) - , span_flags :: I.Int32 - , span_startTime :: I.Int64 - , span_duration :: I.Int64 - , span_tags :: P.Maybe (Vector.Vector Tag) - , span_logs :: P.Maybe (Vector.Vector Log) - , span_incomplete :: P.Maybe P.Bool - } deriving (P.Show,P.Eq,G.Generic,TY.Typeable) -instance H.Hashable Span where - hashWithSalt salt record = salt `H.hashWithSalt` span_traceIdLow record `H.hashWithSalt` span_traceIdHigh record `H.hashWithSalt` span_spanId record `H.hashWithSalt` span_parentSpanId record `H.hashWithSalt` span_operationName record `H.hashWithSalt` span_references record `H.hashWithSalt` span_flags record `H.hashWithSalt` span_startTime record `H.hashWithSalt` span_duration record `H.hashWithSalt` span_tags record `H.hashWithSalt` span_logs record `H.hashWithSalt` span_incomplete record -instance QC.Arbitrary Span where - arbitrary = M.liftM Span (QC.arbitrary) - `M.ap`(QC.arbitrary) - `M.ap`(QC.arbitrary) - `M.ap`(QC.arbitrary) - `M.ap`(QC.arbitrary) - `M.ap`(M.liftM P.Just QC.arbitrary) - `M.ap`(QC.arbitrary) - `M.ap`(QC.arbitrary) - `M.ap`(QC.arbitrary) - `M.ap`(M.liftM P.Just QC.arbitrary) - `M.ap`(M.liftM P.Just QC.arbitrary) - `M.ap`(M.liftM P.Just QC.arbitrary) - shrink obj | obj == default_Span = [] - | P.otherwise = M.catMaybes - [ if obj == default_Span{span_traceIdLow = span_traceIdLow obj} then P.Nothing else P.Just $ default_Span{span_traceIdLow = span_traceIdLow obj} - , if obj == default_Span{span_traceIdHigh = span_traceIdHigh obj} then P.Nothing else P.Just $ default_Span{span_traceIdHigh = span_traceIdHigh obj} - , if obj == default_Span{span_spanId = span_spanId obj} then P.Nothing else P.Just $ default_Span{span_spanId = span_spanId obj} - , if obj == default_Span{span_parentSpanId = span_parentSpanId obj} then P.Nothing else P.Just $ default_Span{span_parentSpanId = span_parentSpanId obj} - , if obj == default_Span{span_operationName = span_operationName obj} then P.Nothing else P.Just $ default_Span{span_operationName = span_operationName obj} - , if obj == default_Span{span_references = span_references obj} then P.Nothing else P.Just $ default_Span{span_references = span_references obj} - , if obj == default_Span{span_flags = span_flags obj} then P.Nothing else P.Just $ default_Span{span_flags = span_flags obj} - , if obj == default_Span{span_startTime = span_startTime obj} then P.Nothing else P.Just $ default_Span{span_startTime = span_startTime obj} - , if obj == default_Span{span_duration = span_duration obj} then P.Nothing else P.Just $ default_Span{span_duration = span_duration obj} - , if obj == default_Span{span_tags = span_tags obj} then P.Nothing else P.Just $ default_Span{span_tags = span_tags obj} - , if obj == default_Span{span_logs = span_logs obj} then P.Nothing else P.Just $ default_Span{span_logs = span_logs obj} - , if obj == default_Span{span_incomplete = span_incomplete obj} then P.Nothing else P.Just $ default_Span{span_incomplete = span_incomplete obj} - ] -from_Span :: Span -> T.ThriftVal -from_Span record = T.TStruct $ Map.fromList $ M.catMaybes - [ (\_v34 -> P.Just (1, ("traceIdLow",T.TI64 _v34))) $ span_traceIdLow record - , (\_v34 -> P.Just (2, ("traceIdHigh",T.TI64 _v34))) $ span_traceIdHigh record - , (\_v34 -> P.Just (3, ("spanId",T.TI64 _v34))) $ span_spanId record - , (\_v34 -> P.Just (4, ("parentSpanId",T.TI64 _v34))) $ span_parentSpanId record - , (\_v34 -> P.Just (5, ("operationName",T.TString $ E.encodeUtf8 _v34))) $ span_operationName record - , (\_v34 -> (6, ("references",T.TList (T.T_STRUCT typemap_SpanRef) $ P.map (\_v36 -> from_SpanRef _v36) $ Vector.toList _v34))) <$> span_references record - , (\_v34 -> P.Just (7, ("flags",T.TI32 _v34))) $ span_flags record - , (\_v34 -> P.Just (8, ("startTime",T.TI64 _v34))) $ span_startTime record - , (\_v34 -> P.Just (9, ("duration",T.TI64 _v34))) $ span_duration record - , (\_v34 -> (10, ("tags",T.TList (T.T_STRUCT typemap_Tag) $ P.map (\_v38 -> from_Tag _v38) $ Vector.toList _v34))) <$> span_tags record - , (\_v34 -> (11, ("logs",T.TList (T.T_STRUCT typemap_Log) $ P.map (\_v40 -> from_Log _v40) $ Vector.toList _v34))) <$> span_logs record - , (\_v34 -> (12, ("incomplete",T.TBool _v34))) <$> span_incomplete record - ] -write_Span :: T.Protocol p => p -> Span -> P.IO () -write_Span oprot record = T.writeVal oprot $ from_Span record -encode_Span :: T.StatelessProtocol p => p -> Span -> LBS.ByteString -encode_Span oprot record = T.serializeVal oprot $ from_Span record -to_Span :: T.ThriftVal -> Span -to_Span (T.TStruct fields) = Span{ - span_traceIdLow = P.maybe (P.error "Missing required field: traceIdLow") (\(_,_val42) -> (case _val42 of {T.TI64 _val43 -> _val43; _ -> P.error "wrong type"})) (Map.lookup (1) fields), - span_traceIdHigh = P.maybe (P.error "Missing required field: traceIdHigh") (\(_,_val42) -> (case _val42 of {T.TI64 _val44 -> _val44; _ -> P.error "wrong type"})) (Map.lookup (2) fields), - span_spanId = P.maybe (P.error "Missing required field: spanId") (\(_,_val42) -> (case _val42 of {T.TI64 _val45 -> _val45; _ -> P.error "wrong type"})) (Map.lookup (3) fields), - span_parentSpanId = P.maybe (P.error "Missing required field: parentSpanId") (\(_,_val42) -> (case _val42 of {T.TI64 _val46 -> _val46; _ -> P.error "wrong type"})) (Map.lookup (4) fields), - span_operationName = P.maybe (P.error "Missing required field: operationName") (\(_,_val42) -> (case _val42 of {T.TString _val47 -> E.decodeUtf8 _val47; _ -> P.error "wrong type"})) (Map.lookup (5) fields), - span_references = P.maybe (P.Nothing) (\(_,_val42) -> P.Just (case _val42 of {T.TList _ _val48 -> (Vector.fromList $ P.map (\_v49 -> (case _v49 of {T.TStruct _val50 -> (to_SpanRef (T.TStruct _val50)); _ -> P.error "wrong type"})) _val48); _ -> P.error "wrong type"})) (Map.lookup (6) fields), - span_flags = P.maybe (P.error "Missing required field: flags") (\(_,_val42) -> (case _val42 of {T.TI32 _val51 -> _val51; _ -> P.error "wrong type"})) (Map.lookup (7) fields), - span_startTime = P.maybe (P.error "Missing required field: startTime") (\(_,_val42) -> (case _val42 of {T.TI64 _val52 -> _val52; _ -> P.error "wrong type"})) (Map.lookup (8) fields), - span_duration = P.maybe (P.error "Missing required field: duration") (\(_,_val42) -> (case _val42 of {T.TI64 _val53 -> _val53; _ -> P.error "wrong type"})) (Map.lookup (9) fields), - span_tags = P.maybe (P.Nothing) (\(_,_val42) -> P.Just (case _val42 of {T.TList _ _val54 -> (Vector.fromList $ P.map (\_v55 -> (case _v55 of {T.TStruct _val56 -> (to_Tag (T.TStruct _val56)); _ -> P.error "wrong type"})) _val54); _ -> P.error "wrong type"})) (Map.lookup (10) fields), - span_logs = P.maybe (P.Nothing) (\(_,_val42) -> P.Just (case _val42 of {T.TList _ _val57 -> (Vector.fromList $ P.map (\_v58 -> (case _v58 of {T.TStruct _val59 -> (to_Log (T.TStruct _val59)); _ -> P.error "wrong type"})) _val57); _ -> P.error "wrong type"})) (Map.lookup (11) fields), - span_incomplete = P.maybe (P.Nothing) (\(_,_val42) -> P.Just (case _val42 of {T.TBool _val60 -> _val60; _ -> P.error "wrong type"})) (Map.lookup (12) fields) - } -to_Span _ = P.error "not a struct" -read_Span :: T.Protocol p => p -> P.IO Span -read_Span iprot = to_Span <$> T.readVal iprot (T.T_STRUCT typemap_Span) -decode_Span :: T.StatelessProtocol p => p -> LBS.ByteString -> Span -decode_Span iprot bs = to_Span $ T.deserializeVal iprot (T.T_STRUCT typemap_Span) bs -typemap_Span :: T.TypeMap -typemap_Span = Map.fromList [(1,("traceIdLow",T.T_I64)),(2,("traceIdHigh",T.T_I64)),(3,("spanId",T.T_I64)),(4,("parentSpanId",T.T_I64)),(5,("operationName",T.T_STRING)),(6,("references",(T.T_LIST (T.T_STRUCT typemap_SpanRef)))),(7,("flags",T.T_I32)),(8,("startTime",T.T_I64)),(9,("duration",T.T_I64)),(10,("tags",(T.T_LIST (T.T_STRUCT typemap_Tag)))),(11,("logs",(T.T_LIST (T.T_STRUCT typemap_Log)))),(12,("incomplete",T.T_BOOL))] -default_Span :: Span -default_Span = Span{ - span_traceIdLow = 0, - span_traceIdHigh = 0, - span_spanId = 0, - span_parentSpanId = 0, - span_operationName = "", - span_references = P.Nothing, - span_flags = 0, - span_startTime = 0, - span_duration = 0, - span_tags = P.Nothing, - span_logs = P.Nothing, - span_incomplete = P.Nothing} -data Process = Process { process_serviceName :: LT.Text - , process_tags :: P.Maybe (Vector.Vector Tag) - } deriving (P.Show,P.Eq,G.Generic,TY.Typeable) -instance H.Hashable Process where - hashWithSalt salt record = salt `H.hashWithSalt` process_serviceName record `H.hashWithSalt` process_tags record -instance QC.Arbitrary Process where - arbitrary = M.liftM Process (QC.arbitrary) - `M.ap`(M.liftM P.Just QC.arbitrary) - shrink obj | obj == default_Process = [] - | P.otherwise = M.catMaybes - [ if obj == default_Process{process_serviceName = process_serviceName obj} then P.Nothing else P.Just $ default_Process{process_serviceName = process_serviceName obj} - , if obj == default_Process{process_tags = process_tags obj} then P.Nothing else P.Just $ default_Process{process_tags = process_tags obj} - ] -from_Process :: Process -> T.ThriftVal -from_Process record = T.TStruct $ Map.fromList $ M.catMaybes - [ (\_v63 -> P.Just (1, ("serviceName",T.TString $ E.encodeUtf8 _v63))) $ process_serviceName record - , (\_v63 -> (2, ("tags",T.TList (T.T_STRUCT typemap_Tag) $ P.map (\_v65 -> from_Tag _v65) $ Vector.toList _v63))) <$> process_tags record - ] -write_Process :: T.Protocol p => p -> Process -> P.IO () -write_Process oprot record = T.writeVal oprot $ from_Process record -encode_Process :: T.StatelessProtocol p => p -> Process -> LBS.ByteString -encode_Process oprot record = T.serializeVal oprot $ from_Process record -to_Process :: T.ThriftVal -> Process -to_Process (T.TStruct fields) = Process{ - process_serviceName = P.maybe (P.error "Missing required field: serviceName") (\(_,_val67) -> (case _val67 of {T.TString _val68 -> E.decodeUtf8 _val68; _ -> P.error "wrong type"})) (Map.lookup (1) fields), - process_tags = P.maybe (P.Nothing) (\(_,_val67) -> P.Just (case _val67 of {T.TList _ _val69 -> (Vector.fromList $ P.map (\_v70 -> (case _v70 of {T.TStruct _val71 -> (to_Tag (T.TStruct _val71)); _ -> P.error "wrong type"})) _val69); _ -> P.error "wrong type"})) (Map.lookup (2) fields) - } -to_Process _ = P.error "not a struct" -read_Process :: T.Protocol p => p -> P.IO Process -read_Process iprot = to_Process <$> T.readVal iprot (T.T_STRUCT typemap_Process) -decode_Process :: T.StatelessProtocol p => p -> LBS.ByteString -> Process -decode_Process iprot bs = to_Process $ T.deserializeVal iprot (T.T_STRUCT typemap_Process) bs -typemap_Process :: T.TypeMap -typemap_Process = Map.fromList [(1,("serviceName",T.T_STRING)),(2,("tags",(T.T_LIST (T.T_STRUCT typemap_Tag))))] -default_Process :: Process -default_Process = Process{ - process_serviceName = "", - process_tags = P.Nothing} -data Batch = Batch { batch_process :: Process - , batch_spans :: (Vector.Vector Span) - } deriving (P.Show,P.Eq,G.Generic,TY.Typeable) -instance H.Hashable Batch where - hashWithSalt salt record = salt `H.hashWithSalt` batch_process record `H.hashWithSalt` batch_spans record -instance QC.Arbitrary Batch where - arbitrary = M.liftM Batch (QC.arbitrary) - `M.ap`(QC.arbitrary) - shrink obj | obj == default_Batch = [] - | P.otherwise = M.catMaybes - [ if obj == default_Batch{batch_process = batch_process obj} then P.Nothing else P.Just $ default_Batch{batch_process = batch_process obj} - , if obj == default_Batch{batch_spans = batch_spans obj} then P.Nothing else P.Just $ default_Batch{batch_spans = batch_spans obj} - ] -from_Batch :: Batch -> T.ThriftVal -from_Batch record = T.TStruct $ Map.fromList $ M.catMaybes - [ (\_v74 -> P.Just (1, ("process",from_Process _v74))) $ batch_process record - , (\_v74 -> P.Just (2, ("spans",T.TList (T.T_STRUCT typemap_Span) $ P.map (\_v76 -> from_Span _v76) $ Vector.toList _v74))) $ batch_spans record - ] -write_Batch :: T.Protocol p => p -> Batch -> P.IO () -write_Batch oprot record = T.writeVal oprot $ from_Batch record -encode_Batch :: T.StatelessProtocol p => p -> Batch -> LBS.ByteString -encode_Batch oprot record = T.serializeVal oprot $ from_Batch record -to_Batch :: T.ThriftVal -> Batch -to_Batch (T.TStruct fields) = Batch{ - batch_process = P.maybe (P.error "Missing required field: process") (\(_,_val78) -> (case _val78 of {T.TStruct _val79 -> (to_Process (T.TStruct _val79)); _ -> P.error "wrong type"})) (Map.lookup (1) fields), - batch_spans = P.maybe (P.error "Missing required field: spans") (\(_,_val78) -> (case _val78 of {T.TList _ _val80 -> (Vector.fromList $ P.map (\_v81 -> (case _v81 of {T.TStruct _val82 -> (to_Span (T.TStruct _val82)); _ -> P.error "wrong type"})) _val80); _ -> P.error "wrong type"})) (Map.lookup (2) fields) - } -to_Batch _ = P.error "not a struct" -read_Batch :: T.Protocol p => p -> P.IO Batch -read_Batch iprot = to_Batch <$> T.readVal iprot (T.T_STRUCT typemap_Batch) -decode_Batch :: T.StatelessProtocol p => p -> LBS.ByteString -> Batch -decode_Batch iprot bs = to_Batch $ T.deserializeVal iprot (T.T_STRUCT typemap_Batch) bs -typemap_Batch :: T.TypeMap -typemap_Batch = Map.fromList [(1,("process",(T.T_STRUCT typemap_Process))),(2,("spans",(T.T_LIST (T.T_STRUCT typemap_Span))))] -default_Batch :: Batch -default_Batch = Batch{ - batch_process = default_Process, - batch_spans = Vector.empty} -data BatchSubmitResponse = BatchSubmitResponse { batchSubmitResponse_ok :: P.Bool - } deriving (P.Show,P.Eq,G.Generic,TY.Typeable) -instance H.Hashable BatchSubmitResponse where - hashWithSalt salt record = salt `H.hashWithSalt` batchSubmitResponse_ok record -instance QC.Arbitrary BatchSubmitResponse where - arbitrary = M.liftM BatchSubmitResponse (QC.arbitrary) - shrink obj | obj == default_BatchSubmitResponse = [] - | P.otherwise = M.catMaybes - [ if obj == default_BatchSubmitResponse{batchSubmitResponse_ok = batchSubmitResponse_ok obj} then P.Nothing else P.Just $ default_BatchSubmitResponse{batchSubmitResponse_ok = batchSubmitResponse_ok obj} - ] -from_BatchSubmitResponse :: BatchSubmitResponse -> T.ThriftVal -from_BatchSubmitResponse record = T.TStruct $ Map.fromList $ M.catMaybes - [ (\_v85 -> P.Just (1, ("ok",T.TBool _v85))) $ batchSubmitResponse_ok record - ] -write_BatchSubmitResponse :: T.Protocol p => p -> BatchSubmitResponse -> P.IO () -write_BatchSubmitResponse oprot record = T.writeVal oprot $ from_BatchSubmitResponse record -encode_BatchSubmitResponse :: T.StatelessProtocol p => p -> BatchSubmitResponse -> LBS.ByteString -encode_BatchSubmitResponse oprot record = T.serializeVal oprot $ from_BatchSubmitResponse record -to_BatchSubmitResponse :: T.ThriftVal -> BatchSubmitResponse -to_BatchSubmitResponse (T.TStruct fields) = BatchSubmitResponse{ - batchSubmitResponse_ok = P.maybe (P.error "Missing required field: ok") (\(_,_val87) -> (case _val87 of {T.TBool _val88 -> _val88; _ -> P.error "wrong type"})) (Map.lookup (1) fields) - } -to_BatchSubmitResponse _ = P.error "not a struct" -read_BatchSubmitResponse :: T.Protocol p => p -> P.IO BatchSubmitResponse -read_BatchSubmitResponse iprot = to_BatchSubmitResponse <$> T.readVal iprot (T.T_STRUCT typemap_BatchSubmitResponse) -decode_BatchSubmitResponse :: T.StatelessProtocol p => p -> LBS.ByteString -> BatchSubmitResponse -decode_BatchSubmitResponse iprot bs = to_BatchSubmitResponse $ T.deserializeVal iprot (T.T_STRUCT typemap_BatchSubmitResponse) bs -typemap_BatchSubmitResponse :: T.TypeMap -typemap_BatchSubmitResponse = Map.fromList [(1,("ok",T.T_BOOL))] -default_BatchSubmitResponse :: BatchSubmitResponse -default_BatchSubmitResponse = BatchSubmitResponse{ - batchSubmitResponse_ok = P.False} diff --git a/gen-src/Zipkincore/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, 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,176 @@ +{-# LANGUAGE TypeFamilies, DeriveGeneric, TypeApplications, 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 () + +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/gen-src/Zipkincore_Types.hs b/gen-src/Zipkincore_Types.hs deleted file mode 100644 --- a/gen-src/Zipkincore_Types.hs +++ /dev/null @@ -1,325 +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} -data Response = Response { response_ok :: P.Bool - } deriving (P.Show,P.Eq,G.Generic,TY.Typeable) -instance H.Hashable Response where - hashWithSalt salt record = salt `H.hashWithSalt` response_ok record -instance QC.Arbitrary Response where - arbitrary = M.liftM Response (QC.arbitrary) - shrink obj | obj == default_Response = [] - | P.otherwise = M.catMaybes - [ if obj == default_Response{response_ok = response_ok obj} then P.Nothing else P.Just $ default_Response{response_ok = response_ok obj} - ] -from_Response :: Response -> T.ThriftVal -from_Response record = T.TStruct $ Map.fromList $ M.catMaybes - [ (\_v51 -> P.Just (1, ("ok",T.TBool _v51))) $ response_ok record - ] -write_Response :: T.Protocol p => p -> Response -> P.IO () -write_Response oprot record = T.writeVal oprot $ from_Response record -encode_Response :: T.StatelessProtocol p => p -> Response -> LBS.ByteString -encode_Response oprot record = T.serializeVal oprot $ from_Response record -to_Response :: T.ThriftVal -> Response -to_Response (T.TStruct fields) = Response{ - response_ok = P.maybe (P.error "Missing required field: ok") (\(_,_val53) -> (case _val53 of {T.TBool _val54 -> _val54; _ -> P.error "wrong type"})) (Map.lookup (1) fields) - } -to_Response _ = P.error "not a struct" -read_Response :: T.Protocol p => p -> P.IO Response -read_Response iprot = to_Response <$> T.readVal iprot (T.T_STRUCT typemap_Response) -decode_Response :: T.StatelessProtocol p => p -> LBS.ByteString -> Response -decode_Response iprot bs = to_Response $ T.deserializeVal iprot (T.T_STRUCT typemap_Response) bs -typemap_Response :: T.TypeMap -typemap_Response = Map.fromList [(1,("ok",T.T_BOOL))] -default_Response :: Response -default_Response = Response{ - response_ok = P.False} diff --git a/opentracing-jaeger.cabal b/opentracing-jaeger.cabal --- a/opentracing-jaeger.cabal +++ b/opentracing-jaeger.cabal @@ -1,7 +1,7 @@ cabal-version: 2.2 name: opentracing-jaeger -version: 0.1.0.0 +version: 0.2.0 synopsis: Jaeger backend for OpenTracing homepage: https://github.com/kim/opentracing bug-reports: https://github.com/kim/opentracing/issues @@ -27,13 +27,14 @@ OpenTracing.Jaeger.Propagation OpenTracing.Jaeger.Thrift other-modules: - Jaeger_Consts - Jaeger_Types - Agent - Agent_Client - Agent_Types - Agent_Iface - Zipkincore_Types + Agent.Client + Agent.Server + Agent.Types + Jaeger.Client + Jaeger.Server + Jaeger.Types + Zipkincore.Types + Zipkincore.Server hs-source-dirs: src gen-src @@ -58,7 +59,8 @@ , opentracing >= 0.1 , safe-exceptions >= 0.1 , text >= 1.2 - , thrift == 0.13.0 + , pinch >= 0.4.0.0 + , vector-instances , unordered-containers >= 0.2 , vector >= 0.12 default-language: Haskell2010 diff --git a/src/OpenTracing/Jaeger/AgentReporter.hs b/src/OpenTracing/Jaeger/AgentReporter.hs --- a/src/OpenTracing/Jaeger/AgentReporter.hs +++ b/src/OpenTracing/Jaeger/AgentReporter.hs @@ -27,50 +27,39 @@ ) where -import qualified Agent_Client as Thrift +import qualified Agent.Client as Thrift import Control.Exception.Safe import Control.Lens (makeLenses, view) import Control.Monad.IO.Class import Data.ByteString.Builder -import Data.Semigroup import Data.Text (Text) import qualified Data.Vector as Vector -import qualified Jaeger_Types as Thrift +import qualified Jaeger.Types as Thrift import Network.Socket -import qualified Network.Socket.ByteString.Lazy as Net import OpenTracing.Jaeger.Propagation (jaegerPropagation) import OpenTracing.Jaeger.Thrift import OpenTracing.Reporting (defaultErrorLog) import OpenTracing.Span import OpenTracing.Tags import OpenTracing.Types -import qualified Thrift -import qualified Thrift.Protocol.Compact as Thrift -import qualified Thrift.Transport.IOBuffer as Thrift - +import qualified Pinch +import qualified Pinch.Client as Pinch +import qualified Pinch.Transport as Pinch data JaegerAgent = JaegerAgent { envLocalProcess :: Thrift.Process , envErrorLog :: Builder -> IO () - , envTransport :: AgentTransport - } - -data AgentTransport = AgentTransport - { transSock :: Socket - , transBuf :: Thrift.WriteBuffer + , envClient :: JaegerClient } -instance Thrift.Transport AgentTransport where - tIsOpen = const (pure True) - tWrite = Thrift.writeBuf . transBuf - - tFlush AgentTransport{..} = - Thrift.flushBuf transBuf >>= Net.sendAll transSock +data JaegerClient = JaegerClient + { + jclClient :: Pinch.Client + , jclSocket :: Socket + } - tClose = error "tClose undefined" - tRead = error "tRead undefined" - tPeek = error "tPeek undefined" - tReadAll = error "tReadAll undefined" +instance Pinch.ThriftClient JaegerClient where + call JaegerClient{jclClient} = Pinch.call jclClient data JaegerAgentOptions = JaegerAgentOptions { _jaoServiceName :: Text @@ -97,9 +86,9 @@ in JaegerAgent tproc _jaoErrorLog <$> openAgentTransport _jaoAddr closeJaegerAgent :: JaegerAgent -> IO () -closeJaegerAgent JaegerAgent{envTransport} = - handleAny (const (return ())) $ - Thrift.tFlush envTransport *> Thrift.tClose envTransport +closeJaegerAgent JaegerAgent{envClient=JaegerClient{jclSocket}} = + handleAny (const (return ())) $ + close jclSocket withJaegerAgent :: ( MonadIO m @@ -111,24 +100,24 @@ withJaegerAgent opts = bracket (liftIO $ newJaegerAgent opts) (liftIO . closeJaegerAgent) -openAgentTransport :: Addr 'UDP -> IO AgentTransport +openAgentTransport :: Addr 'UDP -> IO JaegerClient openAgentTransport addr = do AddrInfo{..} : _ <- getAddrInfo (Just defaultHints { addrSocketType = Datagram }) (Just . view addrHostName $ addr) (Just . show . view addrPort $ addr) sock <- socket addrFamily addrSocketType addrProtocol connect sock addrAddress - buf <- Thrift.newWriteBuffer - return AgentTransport - { transSock = sock - , transBuf = buf - } + channel <- Pinch.createChannel sock Pinch.unframedTransport Pinch.compactProtocol + return JaegerClient + { + jclClient = Pinch.client channel + , jclSocket = sock + } jaegerAgentReporter :: MonadIO m => JaegerAgent -> FinishedSpan -> m () jaegerAgentReporter JaegerAgent{..} s = liftIO $ emit `catchAny` err where - proto = Thrift.CompactProtocol envTransport - emit = Thrift.emitBatch (undefined, proto) batch + emit = Pinch.call envClient (Thrift.emitBatch batch) batch = toThriftBatch envLocalProcess (Vector.singleton s) err e = envErrorLog $ shortByteString "Jaeger Agent Thrift error: " <> string8 (show e) diff --git a/src/OpenTracing/Jaeger/CollectorReporter.hs b/src/OpenTracing/Jaeger/CollectorReporter.hs --- a/src/OpenTracing/Jaeger/CollectorReporter.hs +++ b/src/OpenTracing/Jaeger/CollectorReporter.hs @@ -33,11 +33,11 @@ import Control.Monad (unless) import Control.Monad.Catch import Control.Monad.IO.Class +import Data.ByteString.Lazy (fromStrict) import Data.ByteString.Builder -import Data.Monoid import Data.Text (Text) import Data.Vector (fromList) -import qualified Jaeger_Types as Thrift +import qualified Jaeger.Types as Thrift import Network.HTTP.Client import Network.HTTP.Types.Status import OpenTracing.Jaeger.Propagation (jaegerPropagation) @@ -46,9 +46,7 @@ import OpenTracing.Span import OpenTracing.Tags import OpenTracing.Types -import Thrift.Protocol.Binary -import Thrift.Transport.Empty - +import qualified Pinch newtype JaegerCollector = JaegerCollector { fromJaegerCollector :: BatchEnv } @@ -125,7 +123,7 @@ <> intDec (statusCode rs) <> char8 '\n' where - body = RequestBodyLBS . serializeBatch $ toThriftBatch tproc spans + body = RequestBodyLBS . fromStrict . serializeBatch $ toThriftBatch tproc spans -- nb. collector accepts 'BinaryProtocol', but agent 'CompactProtocol' - serializeBatch = Thrift.encode_Batch (BinaryProtocol EmptyTransport) + serializeBatch = Pinch.encode Pinch.binaryProtocol diff --git a/src/OpenTracing/Jaeger/Propagation.hs b/src/OpenTracing/Jaeger/Propagation.hs --- a/src/OpenTracing/Jaeger/Propagation.hs +++ b/src/OpenTracing/Jaeger/Propagation.hs @@ -15,7 +15,6 @@ import Control.Lens import Data.Bits import qualified Data.HashMap.Strict as HashMap -import Data.Monoid import Data.Text (Text, isPrefixOf) import qualified Data.Text as Text import qualified Data.Text.Read as Text diff --git a/src/OpenTracing/Jaeger/Thrift.hs b/src/OpenTracing/Jaeger/Thrift.hs --- a/src/OpenTracing/Jaeger/Thrift.hs +++ b/src/OpenTracing/Jaeger/Thrift.hs @@ -8,6 +8,7 @@ ) where +import Data.ByteString.Lazy (toStrict) import Control.Lens import Data.Bool (bool) import Data.Foldable @@ -20,7 +21,7 @@ import qualified Data.Vector as Vector import Data.Vector.Lens (vector) import GHC.Stack (prettyCallStack) -import Jaeger_Types +import Jaeger.Types ( Batch (..) , Log (..) , Process (..) @@ -28,7 +29,7 @@ , SpanRef (..) , Tag (..) ) -import qualified Jaeger_Types as Thrift +import qualified Jaeger.Types as Thrift import OpenTracing.Log import OpenTracing.Span import OpenTracing.Tags @@ -43,7 +44,7 @@ , span_spanId = view (spanContext . to ctxSpanID') s , span_parentSpanId = maybe 0 (ctxSpanID' . refCtx) . findParent $ view spanRefs s - , span_operationName = view (spanOperation . lazy) s + , span_operationName = view spanOperation s , span_references = view ( spanRefs . to (map toThriftSpanRef . toList) . vector @@ -63,7 +64,6 @@ . Vector.fromList . foldr' (\r acc -> toThriftLog r : acc) [] $ view spanLogs s - , span_incomplete = Just False } toThriftSpanRef :: Reference -> Thrift.SpanRef @@ -85,18 +85,41 @@ -- acc. to https://github.com/opentracing/specification/blob/8d634bc7e3e73050f6ac1006858cddac8d9e0abe/semantic_conventions.yaml -- "http.status_code" is supposed to be integer-valued. Jaeger, however, drops -- the value (nb. _not_ the tag key) unless it is a string. -toThriftTag HttpStatusCodeKey (IntT v) = Thrift.default_Tag - { tag_key = view lazy HttpStatusCodeKey - , tag_vStr = Just . toLazyText . decimal $ v +toThriftTag HttpStatusCodeKey (IntT v) = Thrift.Tag + { tag_key = HttpStatusCodeKey + , tag_vType = Thrift.STRING + , tag_vStr = Just . view strict . toLazyText . decimal $ v + , tag_vDouble = Nothing + , tag_vBool = Nothing + , tag_vLong = Nothing + , tag_vBinary = Nothing } toThriftTag k v = - let t = Thrift.default_Tag { tag_key = view lazy k } - in case v of - BoolT x -> t { tag_vBool = Just x } - StringT x -> t { tag_vStr = Just (view lazy x) } - IntT x -> t { tag_vLong = Just x } - DoubleT x -> t { tag_vDouble = Just x } - BinaryT x -> t { tag_vBinary = Just x } + Thrift.Tag + { + tag_key = k + , tag_vType = case v of + BoolT _ -> Thrift.BOOL + StringT _ -> Thrift.STRING + IntT _ -> Thrift.LONG + DoubleT _ -> Thrift.DOUBLE + BinaryT _ -> Thrift.BINARY + , tag_vStr = case v of + StringT x -> Just x + _ -> Nothing + , tag_vDouble = case v of + DoubleT x -> Just x + _ -> Nothing + , tag_vBool = case v of + BoolT x -> Just x + _ -> Nothing + , tag_vLong = case v of + IntT x -> Just x + _ -> Nothing + , tag_vBinary = case v of + BinaryT x -> Just (toStrict x) + _ -> Nothing + } toThriftLog :: LogRecord -> Thrift.Log toThriftLog r = Thrift.Log @@ -118,7 +141,7 @@ toThriftProcess :: Text -> Tags -> Thrift.Process toThriftProcess srv tags = Thrift.Process - { process_serviceName = view lazy srv + { process_serviceName = srv , process_tags = Just $ toThriftTags tags } @@ -126,6 +149,8 @@ toThriftBatch tproc spans = Thrift.Batch { batch_process = tproc , batch_spans = toThriftSpan <$> spans + , batch_seqNo = Nothing + , batch_stats = Nothing } traceIdLo' :: SpanContext -> Int64