{-# LANGUAGE DataKinds         #-}
{-# LANGUAGE NamedFieldPuns    #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes        #-}
{-# LANGUAGE RecordWildCards   #-}
{-# LANGUAGE StrictData        #-}
{-# LANGUAGE TemplateHaskell   #-}

module OpenTracing.Zipkin.V1.HttpReporter
    ( ZipkinOptions
    , zipkinOptions
    , zoManager
    , zoLocalEndpoint
    , zoEndpoint
    , zoLogfmt
    , zoErrorLog

    , defaultZipkinEndpoint
    , defaultZipkinAddr

    , Zipkin
    , newZipkin
    , closeZipkin
    , withZipkin

    , zipkinHttpReporter

    , Endpoint(..)

    , newManager
    , defaultManagerSettings
    )
where

import Control.Lens                 hiding (Context)
import Control.Monad                (unless)
import Control.Monad.Catch
import Control.Monad.IO.Class
import Data.ByteString.Builder
import Data.Monoid
import Network.HTTP.Client          hiding (port)
import Network.HTTP.Types
import OpenTracing.Log
import OpenTracing.Reporting
import OpenTracing.Span
import OpenTracing.Types
import OpenTracing.Zipkin.Types
import OpenTracing.Zipkin.V1.Thrift


newtype Zipkin = Zipkin { Zipkin -> BatchEnv
fromZipkin :: BatchEnv }

data ZipkinOptions = ZipkinOptions
    { ZipkinOptions -> Manager
_zoManager       :: Manager
    , ZipkinOptions -> Endpoint
_zoLocalEndpoint :: Endpoint
    , ZipkinOptions -> String
_zoEndpoint      :: String
    , ZipkinOptions
-> forall (t :: * -> *). Foldable t => t LogField -> Builder
_zoLogfmt        :: forall t. Foldable t => t LogField -> Builder -- == LogFieldsFormatter
    , ZipkinOptions -> Builder -> IO ()
_zoErrorLog      :: Builder -> IO ()
    }

makeLenses ''ZipkinOptions

zipkinOptions :: Manager -> Endpoint -> ZipkinOptions
zipkinOptions :: Manager -> Endpoint -> ZipkinOptions
zipkinOptions Manager
mgr Endpoint
loc = ZipkinOptions :: Manager
-> Endpoint
-> String
-> (forall (t :: * -> *). Foldable t => t LogField -> Builder)
-> (Builder -> IO ())
-> ZipkinOptions
ZipkinOptions
    { _zoManager :: Manager
_zoManager       = Manager
mgr
    , _zoLocalEndpoint :: Endpoint
_zoLocalEndpoint = Endpoint
loc
    , _zoEndpoint :: String
_zoEndpoint      = String
defaultZipkinEndpoint
    , _zoLogfmt :: forall (t :: * -> *). Foldable t => t LogField -> Builder
_zoLogfmt        = forall (t :: * -> *). Foldable t => t LogField -> Builder
jsonMap
    , _zoErrorLog :: Builder -> IO ()
_zoErrorLog      = Builder -> IO ()
defaultErrorLog
    }

defaultZipkinEndpoint :: String
defaultZipkinEndpoint :: String
defaultZipkinEndpoint = String
"http://"
    String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Getting String (Addr 'HTTP) String -> Addr 'HTTP -> String
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting String (Addr 'HTTP) String
forall (a :: Protocol). Lens' (Addr a) String
addrHostName Addr 'HTTP
addr
    String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
":"
    String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Port -> String
forall a. Show a => a -> String
show (Getting Port (Addr 'HTTP) Port -> Addr 'HTTP -> Port
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Port (Addr 'HTTP) Port
forall (a :: Protocol). Lens' (Addr a) Port
addrPort Addr 'HTTP
addr)
    String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"/api/v1/spans"
  where
    addr :: Addr 'HTTP
addr = Addr 'HTTP
defaultZipkinAddr

newZipkin :: ZipkinOptions -> IO Zipkin
newZipkin :: ZipkinOptions -> IO Zipkin
newZipkin opts :: ZipkinOptions
opts@ZipkinOptions{_zoEndpoint :: ZipkinOptions -> String
_zoEndpoint=String
endpoint, _zoErrorLog :: ZipkinOptions -> Builder -> IO ()
_zoErrorLog=Builder -> IO ()
errlog} = do
    Request
rq <- IO Request
mkReq
    (BatchEnv -> Zipkin) -> IO BatchEnv -> IO Zipkin
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap BatchEnv -> Zipkin
Zipkin
        (IO BatchEnv -> IO Zipkin)
-> (([FinishedSpan] -> IO ()) -> IO BatchEnv)
-> ([FinishedSpan] -> IO ())
-> IO Zipkin
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BatchOptions -> IO BatchEnv
newBatchEnv
        (BatchOptions -> IO BatchEnv)
-> (([FinishedSpan] -> IO ()) -> BatchOptions)
-> ([FinishedSpan] -> IO ())
-> IO BatchEnv
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ASetter
  BatchOptions BatchOptions (Builder -> IO ()) (Builder -> IO ())
-> (Builder -> IO ()) -> BatchOptions -> BatchOptions
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter
  BatchOptions BatchOptions (Builder -> IO ()) (Builder -> IO ())
Lens' BatchOptions (Builder -> IO ())
boptErrorLog Builder -> IO ()
errlog (BatchOptions -> BatchOptions)
-> (([FinishedSpan] -> IO ()) -> BatchOptions)
-> ([FinishedSpan] -> IO ())
-> BatchOptions
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([FinishedSpan] -> IO ()) -> BatchOptions
batchOptions
        (([FinishedSpan] -> IO ()) -> IO Zipkin)
-> ([FinishedSpan] -> IO ()) -> IO Zipkin
forall a b. (a -> b) -> a -> b
$ ZipkinOptions -> Request -> [FinishedSpan] -> IO ()
reporter ZipkinOptions
opts Request
rq
  where
    mkReq :: IO Request
mkReq = do
        Request
rq <- String -> IO Request
forall (m :: * -> *). MonadThrow m => String -> m Request
parseRequest String
endpoint
        Request -> IO Request
forall (m :: * -> *) a. Monad m => a -> m a
return Request
rq { requestHeaders :: RequestHeaders
requestHeaders = [(HeaderName
hContentType, ByteString
"application/x-thrift")] }

closeZipkin :: Zipkin -> IO ()
closeZipkin :: Zipkin -> IO ()
closeZipkin = BatchEnv -> IO ()
closeBatchEnv (BatchEnv -> IO ()) -> (Zipkin -> BatchEnv) -> Zipkin -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Zipkin -> BatchEnv
fromZipkin

withZipkin
    :: ( MonadIO   m
       , MonadMask m
       )
    => ZipkinOptions
    -> (Zipkin -> m a)
    -> m a
withZipkin :: ZipkinOptions -> (Zipkin -> m a) -> m a
withZipkin ZipkinOptions
opts = m Zipkin -> (Zipkin -> m ()) -> (Zipkin -> m a) -> m a
forall (m :: * -> *) a c b.
MonadMask m =>
m a -> (a -> m c) -> (a -> m b) -> m b
bracket (IO Zipkin -> m Zipkin
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Zipkin -> m Zipkin) -> IO Zipkin -> m Zipkin
forall a b. (a -> b) -> a -> b
$ ZipkinOptions -> IO Zipkin
newZipkin ZipkinOptions
opts) (IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> (Zipkin -> IO ()) -> Zipkin -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Zipkin -> IO ()
closeZipkin)


zipkinHttpReporter :: MonadIO m => Zipkin -> FinishedSpan -> m ()
zipkinHttpReporter :: Zipkin -> FinishedSpan -> m ()
zipkinHttpReporter = BatchEnv -> FinishedSpan -> m ()
forall (m :: * -> *). MonadIO m => BatchEnv -> FinishedSpan -> m ()
batchReporter (BatchEnv -> FinishedSpan -> m ())
-> (Zipkin -> BatchEnv) -> Zipkin -> FinishedSpan -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Zipkin -> BatchEnv
fromZipkin

reporter :: ZipkinOptions -> Request -> [FinishedSpan] -> IO ()
reporter :: ZipkinOptions -> Request -> [FinishedSpan] -> IO ()
reporter ZipkinOptions{String
Manager
Endpoint
Builder -> IO ()
forall (t :: * -> *). Foldable t => t LogField -> Builder
_zoErrorLog :: Builder -> IO ()
_zoLogfmt :: forall (t :: * -> *). Foldable t => t LogField -> Builder
_zoEndpoint :: String
_zoLocalEndpoint :: Endpoint
_zoManager :: Manager
_zoErrorLog :: ZipkinOptions -> Builder -> IO ()
_zoLogfmt :: ZipkinOptions
-> forall (t :: * -> *). Foldable t => t LogField -> Builder
_zoEndpoint :: ZipkinOptions -> String
_zoLocalEndpoint :: ZipkinOptions -> Endpoint
_zoManager :: ZipkinOptions -> Manager
..} Request
rq [FinishedSpan]
spans = do
    Status
rs <- Response ByteString -> Status
forall body. Response body -> Status
responseStatus (Response ByteString -> Status)
-> IO (Response ByteString) -> IO Status
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Request -> Manager -> IO (Response ByteString)
httpLbs Request
rq { requestBody :: RequestBody
requestBody = RequestBody
body } Manager
_zoManager
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Status -> Bool
statusIsSuccessful Status
rs) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        Builder -> IO ()
_zoErrorLog (Builder -> IO ()) -> Builder -> IO ()
forall a b. (a -> b) -> a -> b
$ ShortByteString -> Builder
shortByteString ShortByteString
"Error from Zipkin server: "
                    Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Int -> Builder
intDec (Status -> Int
statusCode Status
rs)
                    Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
char8 Char
'\n'
  where
    body :: RequestBody
body = ByteString -> RequestBody
RequestBodyLBS
         (ByteString -> RequestBody)
-> ([FinishedSpan] -> ByteString) -> [FinishedSpan] -> RequestBody
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Span] -> ByteString
forall (t :: * -> *). Traversable t => t Span -> ByteString
thriftEncodeSpans
         ([Span] -> ByteString)
-> ([FinishedSpan] -> [Span]) -> [FinishedSpan] -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FinishedSpan -> Span) -> [FinishedSpan] -> [Span]
forall a b. (a -> b) -> [a] -> [b]
map (Endpoint
-> (forall (t :: * -> *). Foldable t => t LogField -> Builder)
-> FinishedSpan
-> Span
toThriftSpan Endpoint
_zoLocalEndpoint forall (t :: * -> *). Foldable t => t LogField -> Builder
_zoLogfmt)
         ([FinishedSpan] -> RequestBody) -> [FinishedSpan] -> RequestBody
forall a b. (a -> b) -> a -> b
$ [FinishedSpan]
spans