{-# LANGUAGE OverloadedStrings #-}
module Main where
import Control.Concurrent (threadDelay)
import Control.Monad (join)
import Control.Monad.IO.Class (liftIO)
import qualified Data.Binary.Builder as Builder
import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as BS
import qualified Data.ByteString.Lazy.Char8 as LBSC8
import qualified Data.Maybe as Maybe
import qualified Data.Text as T
import Instana.SDK.SDK (InstanaContext)
import qualified Instana.SDK.SDK as InstanaSDK
import Instana.SDK.Span.SpanData (Annotation)
import qualified Instana.SDK.Span.SpanData as SpanData
import qualified Instana.SDK.Span.SpanType as SpanType
import qualified Network.HTTP.Client as HTTP
import qualified Network.HTTP.Types as HTTPTypes
import qualified Network.Wai as Wai
import qualified Network.Wai.Handler.Warp as Warp
import System.Environment (lookupEnv)
import qualified System.Exit as Exit
import System.IO (Handle, stdout)
import System.Log.Formatter
import System.Log.Handler (setFormatter)
import System.Log.Handler.Simple (GenericHandler, fileHandler,
streamHandler)
import System.Log.Logger (Priority (..), infoM,
rootLoggerName, setHandlers,
setLevel, updateGlobalLogger)
import qualified System.Posix.Process as Posix
import System.Posix.Types (CPid)
appLogger :: String
appLogger = "WaiWarpApp"
downstreamBaseUrl :: String
downstreamBaseUrl = "http://127.0.0.1:1208/echo"
application :: InstanaContext -> HTTP.Manager -> CPid -> Wai.Application
application instana httpManager pid request respond = do
let
route = Wai.pathInfo request
method = Wai.requestMethod request
case (method, route) of
(_, []) ->
root respond
(_, ["ping"]) ->
ping respond pid
("POST", ["bracket", "api", "root"]) ->
bracketApiRootEntry instana respond
("POST", ["bracket", "api", "non-root"]) ->
bracketApiNonRootEntry instana respond
("POST", ["bracket", "api", "with-tags"]) ->
bracketApiWithTags instana respond
("POST", ["bracket", "api", "with-service-name"]) ->
bracketApiWithServiceName instana respond
("POST", ["bracket", "api", "with-service-name-exit-only"]) ->
bracketApiWithServiceNameExitOnly instana respond
("POST", ["low", "level", "api", "root"]) ->
lowLevelApiRootEntry instana respond
("POST", ["low", "level", "api", "non-root"]) ->
lowLevelApiNonRootEntry instana respond
("POST", ["low", "level", "api", "with-tags"]) ->
lowLevelApiWithTags instana respond
("GET", ["http", "bracket", "api"]) ->
httpBracketApi instana httpManager request respond
("GET", ["http", "low", "level", "api"]) ->
httpLowLevelApi instana httpManager request respond
("POST", ["single"]) ->
createSingleSpan instana request respond
("POST", ["shutdown"]) ->
shutDown respond
_ ->
respond404 respond
root ::
(Wai.Response -> IO Wai.ResponseReceived)
-> IO Wai.ResponseReceived
root respond =
respondWithPlainText
respond
"Instana Haskell Trace SDK Integration Test Wai Dummy App"
ping ::
(Wai.Response -> IO Wai.ResponseReceived)
-> CPid
-> IO Wai.ResponseReceived
ping respond pid = do
respond $
Wai.responseLBS HTTPTypes.status200 [] $ LBSC8.pack $ show pid
bracketApiRootEntry ::
InstanaContext
-> (Wai.Response -> IO Wai.ResponseReceived)
-> IO Wai.ResponseReceived
bracketApiRootEntry instana respond = do
result <-
InstanaSDK.withRootEntry
instana
"haskell.dummy.root.entry"
(withExit instana)
respondWithPlainText respond $ result ++ "::entry done"
bracketApiNonRootEntry ::
InstanaContext
-> (Wai.Response -> IO Wai.ResponseReceived)
-> IO Wai.ResponseReceived
bracketApiNonRootEntry instana respond = do
result <-
InstanaSDK.withEntry
instana
"trace-id"
"parent-id"
"haskell.dummy.entry"
(withExit instana)
respondWithPlainText respond $ result ++ "::entry done"
withExit :: InstanaContext -> IO String
withExit instana =
InstanaSDK.withExit
instana
"haskell.dummy.exit"
simulateExitCall
bracketApiWithTags ::
InstanaContext
-> (Wai.Response -> IO Wai.ResponseReceived)
-> IO Wai.ResponseReceived
bracketApiWithTags instana respond = do
entryCallResult <-
InstanaSDK.withRootEntry
instana
"haskell.dummy.root.entry"
(withExitWithTags instana)
respondWithPlainText respond $ entryCallResult
withExitWithTags :: InstanaContext -> IO String
withExitWithTags instana = do
addAnnotations instana (someSpanData "entry")
exitCallResult <-
InstanaSDK.withExit
instana
"haskell.dummy.exit"
(simulateExitCallWithTags instana)
InstanaSDK.incrementErrorCount instana
addAnnotations instana (moreSpanData "entry")
return $ exitCallResult ++ "::entry done"
simulateExitCallWithTags :: InstanaContext -> IO String
simulateExitCallWithTags instana = do
addAnnotations instana (someSpanData "exit")
-- some time needs to pass, otherwise the exit span's duration will be 0
threadDelay $ 10 * 1000
InstanaSDK.addToErrorCount instana 2
addAnnotations instana (moreSpanData "exit")
InstanaSDK.addJsonValueAt instana "nested.key1" ("nested.text.value1" :: String)
InstanaSDK.addJsonValueAt instana "nested.key2" ("nested.text.value2" :: String)
InstanaSDK.addJsonValueAt instana "nested.key3" (1604 :: Int)
return "exit done"
bracketApiWithServiceName ::
InstanaContext
-> (Wai.Response -> IO Wai.ResponseReceived)
-> IO Wai.ResponseReceived
bracketApiWithServiceName instana respond = do
entryCallResult <-
InstanaSDK.withRootEntry
instana
"haskell.dummy.root.entry"
(withExitWithServiceName instana)
respondWithPlainText respond $ entryCallResult
withExitWithServiceName :: InstanaContext -> IO String
withExitWithServiceName instana = do
InstanaSDK.setServiceName instana "Service Entry"
exitCallResult <-
InstanaSDK.withExit
instana
"haskell.dummy.exit"
(simulateExitCallWithServiceName instana)
return $ exitCallResult ++ "::entry done"
bracketApiWithServiceNameExitOnly ::
InstanaContext
-> (Wai.Response -> IO Wai.ResponseReceived)
-> IO Wai.ResponseReceived
bracketApiWithServiceNameExitOnly instana respond = do
entryCallResult <-
InstanaSDK.withRootEntry
instana
"haskell.dummy.root.entry"
(withExitWithServiceNameExitOnly instana)
respondWithPlainText respond $ entryCallResult
withExitWithServiceNameExitOnly :: InstanaContext -> IO String
withExitWithServiceNameExitOnly instana = do
exitCallResult <-
InstanaSDK.withExit
instana
"haskell.dummy.exit"
(simulateExitCallWithServiceName instana)
return $ exitCallResult ++ "::entry done"
simulateExitCallWithServiceName :: InstanaContext -> IO String
simulateExitCallWithServiceName instana = do
InstanaSDK.setServiceName instana "Service Exit"
-- some time needs to pass, otherwise the exit span's duration will be 0
threadDelay $ 10 * 1000
return "exit done"
lowLevelApiRootEntry ::
InstanaContext
-> (Wai.Response -> IO Wai.ResponseReceived)
-> IO Wai.ResponseReceived
lowLevelApiRootEntry instana respond = do
InstanaSDK.startRootEntry
instana
"haskell.dummy.root.entry"
result <- doExitCall instana
InstanaSDK.completeEntry instana
respondWithPlainText respond result
lowLevelApiNonRootEntry ::
InstanaContext
-> (Wai.Response -> IO Wai.ResponseReceived)
-> IO Wai.ResponseReceived
lowLevelApiNonRootEntry instana respond = do
InstanaSDK.startEntry
instana
"trace-id"
"parent-id"
"haskell.dummy.entry"
result <- doExitCall instana
InstanaSDK.completeEntry instana
respondWithPlainText respond result
doExitCall :: InstanaContext -> IO String
doExitCall instana = do
InstanaSDK.startExit
instana
"haskell.dummy.exit"
result <- simulateExitCall
InstanaSDK.completeExit instana
return result
lowLevelApiWithTags ::
InstanaContext
-> (Wai.Response -> IO Wai.ResponseReceived)
-> IO Wai.ResponseReceived
lowLevelApiWithTags instana respond = do
InstanaSDK.startRootEntry
instana
"haskell.dummy.root.entry"
addAnnotations instana (someSpanData "entry")
result <- doExitCallWithTags instana
InstanaSDK.incrementErrorCount instana
addAnnotations instana (moreSpanData "entry")
InstanaSDK.addJsonValueAt
instana "nested.entry.key" ("nested.entry.value" :: String)
InstanaSDK.completeEntry instana
respondWithPlainText respond result
doExitCallWithTags :: InstanaContext -> IO String
doExitCallWithTags instana = do
InstanaSDK.startExit
instana
"haskell.dummy.exit"
addAnnotations instana (someSpanData "exit")
result <- simulateExitCall
InstanaSDK.incrementErrorCount instana
addAnnotations instana (moreSpanData "exit")
InstanaSDK.addJsonValueAt instana "nested.exit.key" ("nested.exit.value" :: String)
InstanaSDK.completeExit instana
return result
simulateExitCall :: IO String
simulateExitCall = do
-- some time needs to pass, otherwise the exit span's duration will be 0
threadDelay $ 10 * 1000
return "exit done"
addAnnotations :: InstanaContext -> [Annotation] -> IO ()
addAnnotations instana annotations =
mapM_
(\annotation -> InstanaSDK.addAnnotation instana annotation)
annotations
someSpanData :: String -> [Annotation]
someSpanData kind =
[ SpanData.simpleAnnotation "data1" ("value1" :: String)
, SpanData.simpleAnnotation "data2" (42 :: Int)
, SpanData.simpleAnnotation "startKind" kind
]
moreSpanData :: String -> [Annotation]
moreSpanData kind =
[ SpanData.simpleAnnotation "data2" (1302 :: Int)
, SpanData.simpleAnnotation "data3" ("value3" :: String)
, SpanData.simpleAnnotation "endKind" kind
]
httpBracketApi ::
InstanaContext
-> HTTP.Manager
-> Wai.Request
-> (Wai.Response -> IO Wai.ResponseReceived)
-> IO Wai.ResponseReceived
httpBracketApi instana httpManager requestIn respond = do
response <- do
InstanaSDK.withHttpEntry instana requestIn $ do
let
query = BS.unpack $ Wai.rawQueryString requestIn
downstreamUrl = downstreamBaseUrl ++ query
downstreamRequest <-
HTTP.parseUrlThrow downstreamUrl
downstreamResponse <- InstanaSDK.withHttpExit
instana
(addDowntreamRequestHeaders downstreamRequest)
(\req -> do
downstreamRespone' <- HTTP.httpLbs req httpManager
threadDelay $ 1000 -- make sure there is a duration > 0
return downstreamRespone'
)
return $
Wai.responseLBS
HTTPTypes.status200
[ ("Content-Type", "application/json; charset=UTF-8")
, ("X-Response-Header-On-Entry", "response header on entry value")
, ("X-Response-Header-App-To-Test", "Value 4")
]
(HTTP.responseBody downstreamResponse)
respond response
httpLowLevelApi ::
InstanaContext
-> HTTP.Manager
-> Wai.Request
-> (Wai.Response -> IO Wai.ResponseReceived)
-> IO Wai.ResponseReceived
httpLowLevelApi instana httpManager requestIn respond = do
InstanaSDK.startHttpEntry instana requestIn
let
query = BS.unpack $ Wai.rawQueryString requestIn
downstreamUrl = downstreamBaseUrl ++ query
downstreamRequest <-
HTTP.parseUrlThrow downstreamUrl
downstreamRequest' <-
InstanaSDK.startHttpExit instana $
addDowntreamRequestHeaders downstreamRequest
downstreamResponse <- HTTP.httpLbs downstreamRequest' httpManager
threadDelay $ 1000 -- make sure there is a duration > 0
InstanaSDK.completeExit instana
let
response =
Wai.responseLBS
HTTPTypes.status200
[ ("Content-Type", "application/json; charset=UTF-8")
, ("X-Response-Header-On-Entry", "response header on entry value")
, ("X-Response-Header-App-To-Test", "Value 4")
]
(HTTP.responseBody downstreamResponse)
response' <-
InstanaSDK.postProcessHttpResponse instana response
result <- respond response'
InstanaSDK.completeEntry instana
return result
createSingleSpan ::
InstanaContext
-> Wai.Request
-> (Wai.Response -> IO Wai.ResponseReceived)
-> IO Wai.ResponseReceived
createSingleSpan instana requestIn respond = do
let
query = Wai.queryString requestIn
maybeMaybeSpanName = lookup ("spanName" :: ByteString) query
spanNameByteString =
Maybe.fromMaybe "haskell.test.span" $ join maybeMaybeSpanName
spanType = SpanType.SdkSpan $ T.pack $ BS.unpack spanNameByteString
InstanaSDK.withRootEntry instana spanType $ do
threadDelay $ 1000 -- make sure there is a duration > 0
respond $
Wai.responseBuilder
HTTPTypes.status200
[("Content-Type", "application/json; charset=UTF-8")]
"{\"response\": \"ok\"}"
shutDown ::
(Wai.Response -> IO Wai.ResponseReceived)
-> IO Wai.ResponseReceived
shutDown respond = do
liftIO $ infoM appLogger $ "Wai/Warp app shutdown requested"
_ <-liftIO $ Posix.exitImmediately Exit.ExitSuccess
respond $
Wai.responseBuilder HTTPTypes.status204 [] Builder.empty
addDowntreamRequestHeaders :: HTTP.Request -> HTTP.Request
addDowntreamRequestHeaders request =
request {
HTTP.requestHeaders =
[ ("X-Request-Header-On-Exit", "request header on exit value")
, ("X-Request-Header-App-To-Downstream", "Value 2")
]
}
respondWithPlainText ::
(Wai.Response -> IO Wai.ResponseReceived)
-> String
-> IO Wai.ResponseReceived
respondWithPlainText respond content =
respond $
Wai.responseLBS
HTTPTypes.status200
[("Content-Type", "text/plain")]
(LBSC8.pack content)
respond404 ::
(Wai.Response -> IO Wai.ResponseReceived)
-> IO Wai.ResponseReceived
respond404 respond =
respond $
Wai.responseLBS HTTPTypes.status404 [] "not found"
main :: IO ()
main = do
initLogging
httpManager <- initHttpManager
let
config = InstanaSDK.defaultConfig { InstanaSDK.agentPort = Just 1302 }
InstanaSDK.withConfiguredInstana config $ runApp httpManager
runApp :: HTTP.Manager -> InstanaContext -> IO ()
runApp httpManager instana = do
pid <- Posix.getProcessID
let
host = "127.0.0.1"
port = (1207 :: Int)
warpSettings =
((Warp.setPort port) . (Warp.setHost "127.0.0.1")) Warp.defaultSettings
infoM appLogger $
"Starting Wai/Warp app at " ++ host ++ ":" ++ show port ++
" (PID: " ++ show pid ++ ")."
Warp.runSettings warpSettings $ application instana httpManager pid
initLogging :: IO ()
initLogging = do
logLevelEnvVar <- lookupEnv "APP_LOG_LEVEL"
let
logLevel =
case logLevelEnvVar of
Just "DEBUG" -> DEBUG
_ -> INFO
updateGlobalLogger appLogger $ setLevel logLevel
appFileHandler <- fileHandler "wai-warp-app.log" logLevel
appStreamHandler <- streamHandler stdout logLevel
let
formattedAppFileHandler = withFormatter appFileHandler
formattedAppStreamHandler = withFormatter appStreamHandler
updateGlobalLogger appLogger $
setHandlers [ formattedAppFileHandler ]
updateGlobalLogger rootLoggerName $
setHandlers [ formattedAppStreamHandler ]
withFormatter :: GenericHandler Handle -> GenericHandler Handle
withFormatter handler = setFormatter handler formatter
where
timeFormat = "%F %H:%M:%S.%4q %z"
formatter = tfLogFormatter timeFormat "{$time $loggername $pid $prio} $msg"
initHttpManager :: IO HTTP.Manager
initHttpManager =
HTTP.newManager $
HTTP.defaultManagerSettings
{ HTTP.managerConnCount = 5
, HTTP.managerResponseTimeout = HTTP.responseTimeoutMicro $ 5000 * 1000
}