{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns        #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE TypeApplications      #-}
{-# LANGUAGE TypeFamilies          #-}
{-# OPTIONS_HADDOCK prune not-home #-}
{-|
Copyright   : (c) 2020-2021 Tim Emiola
SPDX-License-Identifier: BSD3
Maintainer  : Tim Emiola <adetokunbo@users.noreply.github.com >

Provides an instance of 'Proc' that launches @ZipKin@ as a @tmp proc@.

The instance this module provides can be used in integration tests as is.

It's also possible to write other instances that launch @ZipKin@ in different
ways; for those, this instance can be used as a reference example.

-}
module System.TmpProc.Docker.Zipkin
  ( -- * 'Proc' instance
    TmpZipkin(..)

    -- * Useful definitions
  , aProc
  , aHandle

    -- * Re-exports
  , module System.TmpProc
  )
where

import           Control.Monad.IO.Class    (MonadIO, liftIO)
import           Control.Monad.Trace.Class (MonadTrace, alwaysSampled, rootSpan)
import qualified Data.ByteString.Char8     as C8
import           Data.Proxy                (Proxy (..))
import           Data.String               (fromString)
import qualified Data.Text                 as Text
import           Network.HTTP.Client       (HttpException)
import           System.IO                 (Handle, IOMode (..), hPutStrLn,
                                            openBinaryFile)

import qualified Monitor.Tracing.Zipkin    as ZPK

import           System.TmpProc            (Connectable (..), HList (..),
                                            HandlesOf, HostIpAddress,
                                            Pinged (..), Proc (..),
                                            ProcHandle (..), SvcURI, startupAll,
                                            toPinged, withTmpConn)


{-| A singleton 'HList' containing a 'TmpZipkin'. -}
aProc :: HList '[TmpZipkin]
aProc :: HList '[TmpZipkin]
aProc = TmpZipkin
TmpZipkin TmpZipkin -> HList '[] -> HList '[TmpZipkin]
forall anyTy (manyTys :: [*]).
anyTy -> HList manyTys -> HList (anyTy : manyTys)
`HCons` HList '[]
HNil


{-| An 'HList' that just contains the handle created by 'aProc'. -}
aHandle :: IO (HandlesOf '[TmpZipkin])
aHandle :: IO (HandlesOf '[TmpZipkin])
aHandle = HList '[TmpZipkin] -> IO (HandlesOf '[TmpZipkin])
forall (procs :: [*]).
AreProcs procs =>
HList procs -> IO (HandlesOf procs)
startupAll HList '[TmpZipkin]
aProc


{-| Provides the capability to launch a Zipkin instance as a @tmp proc@. -}
data TmpZipkin = TmpZipkin


{-| Specifies how to run @ZipKin@ as a @tmp proc@. -}
instance Proc TmpZipkin where
  type Image TmpZipkin = "openzipkin/zipkin-slim"
  type Name TmpZipkin = "a-zipkin-server"

  uriOf :: Text -> SvcURI
uriOf = Text -> SvcURI
mkUri'
  runArgs :: [Text]
runArgs = []

  ping :: ProcHandle TmpZipkin -> IO Pinged
ping ProcHandle TmpZipkin
h = Proxy HttpException -> IO () -> IO Pinged
forall e a. Exception e => Proxy e -> IO a -> IO Pinged
toPinged @HttpException Proxy HttpException
forall k (t :: k). Proxy t
Proxy (IO () -> IO Pinged) -> IO () -> IO Pinged
forall a b. (a -> b) -> a -> b
$ do
    Zipkin
z <- ProcHandle TmpZipkin -> IO Zipkin
openConn' ProcHandle TmpZipkin
h
    TraceT IO () -> Zipkin -> IO ()
forall (m :: * -> *) a. TraceT m a -> Zipkin -> m a
ZPK.run TraceT IO ()
forall (m :: * -> *). (MonadIO m, MonadTrace m) => m ()
tracedPing Zipkin
z
    Zipkin -> IO ()
forall (m :: * -> *). MonadIO m => Zipkin -> m ()
ZPK.publish Zipkin
z

  reset :: ProcHandle TmpZipkin -> IO ()
reset ProcHandle TmpZipkin
_ = () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()


{-| Specifies how to connect to a tmp @ZipKin@ service.

In this case, there is not really a connection type, but 'ZPK.Zipkin' provides
a close analogue.

-}
instance Connectable TmpZipkin where
  type Conn TmpZipkin = ZPK.Zipkin

  openConn :: ProcHandle TmpZipkin -> IO (Conn TmpZipkin)
openConn = ProcHandle TmpZipkin -> IO (Conn TmpZipkin)
ProcHandle TmpZipkin -> IO Zipkin
openConn'
  closeConn :: Conn TmpZipkin -> IO ()
closeConn Conn TmpZipkin
_ = () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()


openConn' :: ProcHandle TmpZipkin -> IO ZPK.Zipkin
openConn' :: ProcHandle TmpZipkin -> IO Zipkin
openConn' = Settings -> IO Zipkin
forall (m :: * -> *). MonadIO m => Settings -> m Zipkin
ZPK.new (Settings -> IO Zipkin)
-> (ProcHandle TmpZipkin -> Settings)
-> ProcHandle TmpZipkin
-> IO Zipkin
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProcHandle TmpZipkin -> Settings
toSettings


{-| Make a simple HTTP uri to the zipkin server. -}
mkUri' :: HostIpAddress -> SvcURI
mkUri' :: Text -> SvcURI
mkUri' Text
ip = SvcURI
"http://" SvcURI -> SvcURI -> SvcURI
forall a. Semigroup a => a -> a -> a
<> String -> SvcURI
C8.pack (Text -> String
Text.unpack Text
ip) SvcURI -> SvcURI -> SvcURI
forall a. Semigroup a => a -> a -> a
<> SvcURI
"/"


toSettings :: ProcHandle TmpZipkin -> ZPK.Settings
toSettings :: ProcHandle TmpZipkin -> Settings
toSettings = String -> Settings
forall a. IsString a => String -> a
fromString (String -> Settings)
-> (ProcHandle TmpZipkin -> String)
-> ProcHandle TmpZipkin
-> Settings
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
Text.unpack (Text -> String)
-> (ProcHandle TmpZipkin -> Text) -> ProcHandle TmpZipkin -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProcHandle TmpZipkin -> Text
forall a. ProcHandle a -> Text
hAddr


pingAction :: IO ()
pingAction :: IO ()
pingAction = IO Handle
devNull IO Handle -> (Handle -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Handle -> String -> IO ()) -> String -> Handle -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip Handle -> String -> IO ()
hPutStrLn String
"the trace of this will be sent as a ping"


tracedPing :: (MonadIO m, MonadTrace m) => m ()
tracedPing :: m ()
tracedPing = SamplingPolicy -> Text -> m () -> m ()
forall (m :: * -> *) a.
MonadTrace m =>
SamplingPolicy -> Text -> m a -> m a
rootSpan SamplingPolicy
alwaysSampled Text
"ping" (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ()
pingAction


devNull :: IO Handle
devNull :: IO Handle
devNull = String -> IOMode -> IO Handle
openBinaryFile String
"/dev/null"  IOMode
WriteMode