{-# 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.ByteString.Lazy         (fromStrict)
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
    { _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://"
    forall a. Semigroup a => a -> a -> a
<> forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall (a :: Protocol). Lens' (Addr a) String
addrHostName Addr 'HTTP
addr
    forall a. Semigroup a => a -> a -> a
<> String
":"
    forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall (a :: Protocol). Lens' (Addr a) Port
addrPort Addr 'HTTP
addr)
    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
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap BatchEnv -> Zipkin
Zipkin
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. BatchOptions -> IO BatchEnv
newBatchEnv
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s t a b. ASetter s t a b -> b -> s -> t
set Lens' BatchOptions (Builder -> IO ())
boptErrorLog Builder -> IO ()
errlog forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([FinishedSpan] -> IO ()) -> BatchOptions
batchOptions
        forall a b. (a -> b) -> a -> b
$ ZipkinOptions -> Request -> [FinishedSpan] -> IO ()
reporter ZipkinOptions
opts Request
rq
  where
    mkReq :: IO Request
mkReq = do
        Request
rq <- forall (m :: * -> *). MonadThrow m => String -> m Request
parseRequest String
endpoint
        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 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 :: forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
ZipkinOptions -> (Zipkin -> m a) -> m a
withZipkin ZipkinOptions
opts = forall (m :: * -> *) a c b.
MonadMask m =>
m a -> (a -> m c) -> (a -> m b) -> m b
bracket (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ ZipkinOptions -> IO Zipkin
newZipkin ZipkinOptions
opts) (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. Zipkin -> IO ()
closeZipkin)


zipkinHttpReporter :: MonadIO m => Zipkin -> FinishedSpan -> m ()
zipkinHttpReporter :: forall (m :: * -> *). MonadIO m => Zipkin -> FinishedSpan -> m ()
zipkinHttpReporter = forall (m :: * -> *). MonadIO m => BatchEnv -> FinishedSpan -> m ()
batchReporter 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 <- forall body. Response body -> Status
responseStatus 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
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Status -> Bool
statusIsSuccessful Status
rs) forall a b. (a -> b) -> a -> b
$
        Builder -> IO ()
_zoErrorLog forall a b. (a -> b) -> a -> b
$ ShortByteString -> Builder
shortByteString ShortByteString
"Error from Zipkin server: "
                    forall a. Semigroup a => a -> a -> a
<> Int -> Builder
intDec (Status -> Int
statusCode Status
rs)
                    forall a. Semigroup a => a -> a -> a
<> Char -> Builder
char8 Char
'\n'
  where
    body :: RequestBody
body = ByteString -> RequestBody
RequestBodyLBS
         forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
fromStrict
         forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *). Traversable t => t Span -> ByteString
thriftEncodeSpans
         forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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)
         forall a b. (a -> b) -> a -> b
$ [FinishedSpan]
spans