{-# LANGUAGE DataKinds #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_HADDOCK prune not-home #-}
module System.TmpProc.Docker.Zipkin
(
TmpZipkin(..)
, aProc
, aHandle
, 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)
aProc :: HList '[TmpZipkin]
aProc :: HList '[TmpZipkin]
aProc = TmpZipkin
TmpZipkin forall anyTy (manyTys :: [*]).
anyTy -> HList manyTys -> HList (anyTy : manyTys)
`HCons` HList '[]
HNil
aHandle :: IO (HandlesOf '[TmpZipkin])
aHandle :: IO (HandlesOf '[TmpZipkin])
aHandle = forall (procs :: [*]).
AreProcs procs =>
HList procs -> IO (HandlesOf procs)
startupAll HList '[TmpZipkin]
aProc
data TmpZipkin = TmpZipkin
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 = forall e a. Exception e => Proxy e -> IO a -> IO Pinged
toPinged @HttpException forall {k} (t :: k). Proxy t
Proxy forall a b. (a -> b) -> a -> b
$ do
Zipkin
z <- ProcHandle TmpZipkin -> IO Zipkin
openConn' ProcHandle TmpZipkin
h
forall (m :: * -> *) a. TraceT m a -> Zipkin -> m a
ZPK.run forall (m :: * -> *). (MonadIO m, MonadTrace m) => m ()
tracedPing Zipkin
z
forall (m :: * -> *). MonadIO m => Zipkin -> m ()
ZPK.publish Zipkin
z
reset :: ProcHandle TmpZipkin -> IO ()
reset ProcHandle TmpZipkin
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
instance Connectable TmpZipkin where
type Conn TmpZipkin = ZPK.Zipkin
openConn :: ProcHandle TmpZipkin -> IO (Conn TmpZipkin)
openConn = ProcHandle TmpZipkin -> IO Zipkin
openConn'
closeConn :: Conn TmpZipkin -> IO ()
closeConn Conn TmpZipkin
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
openConn' :: ProcHandle TmpZipkin -> IO ZPK.Zipkin
openConn' :: ProcHandle TmpZipkin -> IO Zipkin
openConn' = forall (m :: * -> *). MonadIO m => Settings -> m Zipkin
ZPK.new forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProcHandle TmpZipkin -> Settings
toSettings
mkUri' :: HostIpAddress -> SvcURI
mkUri' :: Text -> SvcURI
mkUri' Text
ip = SvcURI
"http://" forall a. Semigroup a => a -> a -> a
<> String -> SvcURI
C8.pack (Text -> String
Text.unpack Text
ip) forall a. Semigroup a => a -> a -> a
<> SvcURI
"/"
toSettings :: ProcHandle TmpZipkin -> ZPK.Settings
toSettings :: ProcHandle TmpZipkin -> Settings
toSettings = forall a. IsString a => String -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
Text.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ProcHandle a -> Text
hAddr
pingAction :: IO ()
pingAction :: IO ()
pingAction = IO Handle
devNull forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= 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 :: forall (m :: * -> *). (MonadIO m, MonadTrace m) => m ()
tracedPing = forall (m :: * -> *) a.
MonadTrace m =>
SamplingPolicy -> Text -> m a -> m a
rootSpan SamplingPolicy
alwaysSampled Text
"ping" forall a b. (a -> b) -> a -> b
$ 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