diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,4 +1,14 @@ -## [_Unreleased_](https://github.com/freckle/freckle-app/compare/v1.10.3.0...main) +## [_Unreleased_](https://github.com/freckle/freckle-app/compare/v1.10.4.0...main) + +## [v1.10.4.0](https://github.com/freckle/freckle-app/compare/v1.10.3.0...v1.10.4.0) + +- Use JUnit formatting for test output when `JUNIT_ENABLED` environment + variable is set. +- Use environment variables to [configure JUnit][junit-env]; always prefix + source paths with test suite `name` and output tests to `/tmp/junit`. +- Remove using `CIRCLECI` environment variable. + +[junit-env]: https://github.com/freckle/hspec-junit-formatter/blob/main/library/Test/Hspec/JUnit/Config/Env.hs ## [v1.10.3.0](https://github.com/freckle/freckle-app/compare/v1.10.2.0...v1.10.3.0) diff --git a/freckle-app.cabal b/freckle-app.cabal --- a/freckle-app.cabal +++ b/freckle-app.cabal @@ -1,6 +1,6 @@ cabal-version: 1.18 name: freckle-app -version: 1.10.3.0 +version: 1.10.4.0 license: MIT license-file: LICENSE maintainer: Freckle Education diff --git a/library/Freckle/App/Database.hs b/library/Freckle/App/Database.hs --- a/library/Freckle/App/Database.hs +++ b/library/Freckle/App/Database.hs @@ -138,7 +138,7 @@ runDB action = do pool <- asks getSqlPool Stats.withGauge Stats.dbConnections $ - inSpan "runDB" defaultSpanArguments $ + inSpan "runDB" clientSpanArguments $ runSqlPoolWithExtensibleHooks action pool Nothing $ setAlterBackend defaultSqlPoolHooks $ wrapSqlBackend mempty diff --git a/library/Freckle/App/Kafka/Consumer.hs b/library/Freckle/App/Kafka/Consumer.hs --- a/library/Freckle/App/Kafka/Consumer.hs +++ b/library/Freckle/App/Kafka/Consumer.hs @@ -13,6 +13,7 @@ import Blammo.Logging import Control.Lens (Lens', view) import Data.Aeson +import Data.ByteString (ByteString) import qualified Data.List.NonEmpty as NE import qualified Data.Map.Strict as Map import qualified Data.Text as T @@ -20,7 +21,7 @@ import Freckle.App.Async import Freckle.App.Env import Freckle.App.Kafka.Producer (envKafkaBrokerAddresses) -import Freckle.App.OpenTelemetry (withTraceIdContext) +import Freckle.App.OpenTelemetry import Kafka.Consumer hiding ( Timeout , closeConsumer @@ -29,7 +30,13 @@ , subscription ) import qualified Kafka.Consumer as Kafka -import UnliftIO.Exception (bracket, throwIO) +import UnliftIO.Exception + ( Exception (..) + , Handler (..) + , bracket + , catches + , throwIO + ) data KafkaConsumerConfig = KafkaConsumerConfig { kafkaConsumerConfigBrokerAddresses :: NonEmpty BrokerAddress @@ -143,11 +150,26 @@ TimeoutSeconds s -> s * 1000 TimeoutMilliseconds ms -> ms +data KafkaMessageDecodeError = KafkaMessageDecodeError + { input :: ByteString + , errors :: String + } + deriving stock (Show) + +instance Exception KafkaMessageDecodeError where + displayException KafkaMessageDecodeError {..} = + mconcat + [ "Unable to decode JSON" + , "\n input: " <> unpack (decodeUtf8 input) + , "\n errors: " <> errors + ] + runConsumer :: ( MonadMask m , MonadUnliftIO m , MonadReader env m , MonadLogger m + , MonadTracer m , HasKafkaConsumer env , FromJSON a ) @@ -157,12 +179,37 @@ runConsumer pollTimeout onMessage = withTraceIdContext $ immortalCreateLogged $ do consumer <- view kafkaConsumerL - eMessage <- - pollMessage consumer $ Kafka.Timeout $ timeoutMs pollTimeout - case eMessage of - Left (KafkaResponseError RdKafkaRespErrTimedOut) -> logDebug "Polling timeout" - Left err -> logError $ "Error polling for message from Kafka" :# ["error" .= show err] - Right ConsumerRecord {..} -> for_ crValue $ \bs -> - case eitherDecodeStrict bs of - Left err -> logError $ "Could not decode message value" :# ["error" .= err] - Right a -> onMessage a + + flip catches handlers $ inSpan "kafka.consumer" consumerSpanArguments $ do + mRecord <- fromKafkaError =<< pollMessage consumer kTimeout + + for_ (crValue =<< mRecord) $ \bs -> do + a <- + inSpan "kafka.consumer.message.decode" defaultSpanArguments $ + either (throwIO . KafkaMessageDecodeError bs) pure $ + eitherDecodeStrict bs + inSpan "kafka.consumer.message.handle" defaultSpanArguments $ onMessage a + where + kTimeout = Kafka.Timeout $ timeoutMs pollTimeout + + handlers = + [ Handler $ \err -> + logError $ + "Error polling for message from Kafka" + :# ["error" .= displayException @KafkaError err] + , Handler $ \err -> + logError $ + "Could not decode message value" + :# ["error" .= displayException @KafkaMessageDecodeError err] + ] + +fromKafkaError + :: (MonadIO m, MonadLogger m) => Either KafkaError a -> m (Maybe a) +fromKafkaError = + either + ( \case + KafkaResponseError RdKafkaRespErrTimedOut -> + Nothing <$ logDebug "Polling timeout" + err -> throwIO err + ) + $ pure . Just diff --git a/library/Freckle/App/Kafka/Producer.hs b/library/Freckle/App/Kafka/Producer.hs --- a/library/Freckle/App/Kafka/Producer.hs +++ b/library/Freckle/App/Kafka/Producer.hs @@ -18,13 +18,16 @@ import Control.Lens (Lens', view) import Data.Aeson (ToJSON, encode) import Data.ByteString.Lazy (toStrict) +import qualified Data.HashMap.Strict as HashMap import qualified Data.List.NonEmpty as NE import Data.Pool (Pool) import qualified Data.Pool as Pool import qualified Data.Text as T import Freckle.App.Async (async) import qualified Freckle.App.Env as Env +import Freckle.App.OpenTelemetry import Kafka.Producer +import qualified OpenTelemetry.Trace as Trace import UnliftIO.Exception (throwString) import Yesod.Core.Lens import Yesod.Core.Types (HandlerData) @@ -104,6 +107,7 @@ produceKeyedOn :: ( MonadUnliftIO m , MonadLogger m + , MonadTracer m , MonadReader env m , HasKafkaProducerPool env , ToJSON key @@ -113,7 +117,7 @@ -> NonEmpty value -> (value -> key) -> m () -produceKeyedOn prTopic values keyF = do +produceKeyedOn prTopic values keyF = traced $ do logDebugNS "kafka" $ "Producing Kafka events" :# ["events" .= values] view kafkaProducerPoolL >>= \case NullKafkaProducerPool -> pure () @@ -139,10 +143,20 @@ encode value } + traced = + inSpan + "kafka.produce" + producerSpanArguments + { Trace.attributes = + HashMap.fromList + [("topic", Trace.toAttribute $ unTopicName prTopic)] + } + produceKeyedOnAsync :: ( MonadMask m , MonadUnliftIO m , MonadLogger m + , MonadTracer m , MonadReader env m , HasKafkaProducerPool env , ToJSON key diff --git a/library/Freckle/App/Memcached.hs b/library/Freckle/App/Memcached.hs --- a/library/Freckle/App/Memcached.hs +++ b/library/Freckle/App/Memcached.hs @@ -34,8 +34,9 @@ import Freckle.App.Memcached.CacheKey import Freckle.App.Memcached.CacheTTL import Freckle.App.Memcached.Client (HasMemcachedClient (..)) -import Freckle.App.Memcached.MD5 import qualified Freckle.App.Memcached.Client as Memcached +import Freckle.App.Memcached.MD5 +import Freckle.App.OpenTelemetry import UnliftIO.Exception (Exception (..), handleAny) class Cachable a where @@ -63,6 +64,7 @@ caching :: ( MonadUnliftIO m , MonadLogger m + , MonadTracer m , MonadReader env m , HasMemcachedClient env , Cachable a @@ -75,7 +77,12 @@ -- | Like 'caching', but with explicit conversion functions cachingAs - :: (MonadUnliftIO m, MonadLogger m, MonadReader env m, HasMemcachedClient env) + :: ( MonadUnliftIO m + , MonadLogger m + , MonadTracer m + , MonadReader env m + , HasMemcachedClient env + ) => (ByteString -> Either String a) -> (a -> ByteString) -> CacheKey @@ -103,6 +110,7 @@ cachingAsJSON :: ( MonadUnliftIO m , MonadLogger m + , MonadTracer m , MonadReader env m , HasMemcachedClient env , FromJSON a @@ -118,6 +126,7 @@ cachingAsCBOR :: ( MonadUnliftIO m , MonadLogger m + , MonadTracer m , MonadReader env m , HasMemcachedClient env , Serialise a diff --git a/library/Freckle/App/Memcached/CacheKey.hs b/library/Freckle/App/Memcached/CacheKey.hs --- a/library/Freckle/App/Memcached/CacheKey.hs +++ b/library/Freckle/App/Memcached/CacheKey.hs @@ -10,6 +10,7 @@ import Data.Char (isControl, isSpace) import qualified Data.Text as T import Database.Memcache.Types (Key) +import OpenTelemetry.Trace (ToAttribute (..)) import UnliftIO.Exception (throwString) newtype CacheKey = CacheKey Text @@ -18,6 +19,9 @@ unCacheKey :: CacheKey -> Text unCacheKey (CacheKey x) = x + +instance ToAttribute CacheKey where + toAttribute = toAttribute . unCacheKey -- | Build a 'CacheKey', ensuring it's valid for Memcached -- diff --git a/library/Freckle/App/Memcached/CacheTTL.hs b/library/Freckle/App/Memcached/CacheTTL.hs --- a/library/Freckle/App/Memcached/CacheTTL.hs +++ b/library/Freckle/App/Memcached/CacheTTL.hs @@ -9,10 +9,14 @@ import Data.Word (Word32) import Database.Memcache.Types (Expiration) +import OpenTelemetry.Trace (ToAttribute (..)) newtype CacheTTL = CacheTTL Int deriving stock (Show) deriving newtype (Eq, Ord, Enum, Num, Real, Integral) + +instance ToAttribute CacheTTL where + toAttribute (CacheTTL x) = toAttribute x cacheTTL :: Int -> CacheTTL cacheTTL = CacheTTL diff --git a/library/Freckle/App/Memcached/Client.hs b/library/Freckle/App/Memcached/Client.hs --- a/library/Freckle/App/Memcached/Client.hs +++ b/library/Freckle/App/Memcached/Client.hs @@ -11,11 +11,14 @@ import Freckle.App.Prelude import Control.Lens (Lens', view, _1) +import qualified Data.HashMap.Strict as HashMap import qualified Database.Memcache.Client as Memcache import Database.Memcache.Types (Value) import Freckle.App.Memcached.CacheKey import Freckle.App.Memcached.CacheTTL import Freckle.App.Memcached.Servers +import Freckle.App.OpenTelemetry +import qualified OpenTelemetry.Trace as Trace import UnliftIO.Exception (finally) import Yesod.Core.Lens import Yesod.Core.Types (HandlerData) @@ -48,23 +51,30 @@ memcachedClientDisabled = MemcachedClientDisabled get - :: (MonadIO m, MonadReader env m, HasMemcachedClient env) + :: (MonadUnliftIO m, MonadTracer m, MonadReader env m, HasMemcachedClient env) => CacheKey -> m (Maybe Value) -get k = with $ \case +get k = traced $ with $ \case MemcachedClient mc -> liftIO $ view _1 <$$> Memcache.get mc (fromCacheKey k) MemcachedClientDisabled -> pure Nothing + where + traced = + inSpan + "cache.get" + clientSpanArguments + { Trace.attributes = HashMap.fromList [("key", Trace.toAttribute k)] + } -- | Set a value to expire in the given seconds -- -- Pass @0@ to set a value that never expires. set - :: (MonadIO m, MonadReader env m, HasMemcachedClient env) + :: (MonadUnliftIO m, MonadTracer m, MonadReader env m, HasMemcachedClient env) => CacheKey -> Value -> CacheTTL -> m () -set k v expiration = with $ \case +set k v expiration = traced $ with $ \case MemcachedClient mc -> void $ liftIO $ @@ -72,6 +82,18 @@ fromCacheTTL expiration MemcachedClientDisabled -> pure () + where + traced = + inSpan + "cache.set" + clientSpanArguments + { Trace.attributes = + HashMap.fromList + [ ("key", Trace.toAttribute k) + , ("value", Trace.toAttribute $ decodeUtf8 v) + , ("expiration", Trace.toAttribute expiration) + ] + } quitClient :: MonadIO m => MemcachedClient -> m () quitClient = \case diff --git a/library/Freckle/App/OpenTelemetry.hs b/library/Freckle/App/OpenTelemetry.hs --- a/library/Freckle/App/OpenTelemetry.hs +++ b/library/Freckle/App/OpenTelemetry.hs @@ -6,21 +6,21 @@ -- , appTracer :: Tracer -- } -- --- instance HasTracer App where +-- instance 'HasTracer' App where -- tracerL = lens appTracer $ \x y -> x { appTracer = y } -- -- loadApp f = do -- -- ... --- withTracerProvider $ \tracerProvider -> do --- let appTracer = makeTracer tracerProvider "my-app" tracerOptions +-- 'withTracerProvider' $ \tracerProvider -> do +-- let appTracer = 'makeTracer' tracerProvider "my-app" 'tracerOptions' -- f App {..} -- @ -- --- You may need to do this even if you don't plan to manually trace things, in order to --- satisfy the 'MonadTracer' constraint required by functions like 'runDB'. If --- you don't need this feature, and don't plan on running an otel-collector, set --- @OTEL_TRACES_EXPORTER=none@ in the environment, which makes all tracing a --- no-op. +-- You may need to do this even if you don't plan to manually trace things, in +-- order to satisfy the 'MonadTracer' constraint required by functions like +-- 'runDB'. If you don't need this feature, and don't plan on running an +-- otel-collector, set @OTEL_TRACES_EXPORTER=none@ in the environment, which +-- makes all tracing a no-op. -- -- In the future, it should be possible to use @OTEL_SDK_DISABLED@ for the same -- purpose. See . @@ -32,6 +32,10 @@ , MonadTracer (..) , inSpan , defaultSpanArguments + , serverSpanArguments + , clientSpanArguments + , producerSpanArguments + , consumerSpanArguments -- * Querying , withTraceIdContext @@ -62,6 +66,39 @@ import OpenTelemetry.Trace.Id (TraceId) import OpenTelemetry.Trace.Monad import UnliftIO.Exception (bracket) + +-- | 'defaultSpanArguments' with 'kind' set to 'Server' +-- +-- Indicates that the span covers server-side handling of a synchronous RPC or +-- other remote request. This span is the child of a remote @Client@ span that +-- was expected to wait for a response. +serverSpanArguments :: SpanArguments +serverSpanArguments = defaultSpanArguments {kind = Server} + +-- | 'defaultSpanArguments' with 'kind' set to 'Kind' +-- +-- Indicates that the span describes a synchronous request to some remote +-- service. This span is the parent of a remote @Server@ span and waits for its +-- response. +clientSpanArguments :: SpanArguments +clientSpanArguments = defaultSpanArguments {kind = Client} + +-- | 'defaultSpanArguments' with 'kind' set to 'Producer' +-- +-- Indicates that the span describes the parent of an asynchronous request. This +-- parent span is expected to end before the corresponding child @Producer@ +-- span, possibly even before the child span starts. In messaging scenarios with +-- batching, tracing individual messages requires a new @Producer@ span per +-- message to be created. +producerSpanArguments :: SpanArguments +producerSpanArguments = defaultSpanArguments {kind = Producer} + +-- | 'defaultSpanArguments' with 'kind' set to 'Consumer' +-- +-- Indicates that the span describes the child of an asynchronous @Producer@ +-- request. +consumerSpanArguments :: SpanArguments +consumerSpanArguments = defaultSpanArguments {kind = Consumer} withTracerProvider :: MonadUnliftIO m => (TracerProvider -> m a) -> m a withTracerProvider = diff --git a/library/Freckle/App/Test/Hspec/Runner.hs b/library/Freckle/App/Test/Hspec/Runner.hs --- a/library/Freckle/App/Test/Hspec/Runner.hs +++ b/library/Freckle/App/Test/Hspec/Runner.hs @@ -14,9 +14,10 @@ import Test.Hspec (Spec) import Test.Hspec.JUnit ( configWithJUnit - , defaultJUnitConfig , setJUnitConfigOutputFile + , setJUnitConfigSourcePathPrefix ) +import Test.Hspec.JUnit.Config.Env (envJUnitConfig, envJUnitEnabled) import Test.Hspec.Runner ( Config , Path @@ -25,8 +26,8 @@ , configSkipPredicate , defaultConfig , evaluateSummary + , hspecWithResult , readConfig - , runSpec ) import qualified Prelude as Unsafe (read) @@ -41,8 +42,6 @@ runWith :: Config -> String -> Spec -> IO () runWith config name spec = do args <- getArgs - isCircle <- isJust <$> lookupEnv "CIRCLECI" - let runner = if isCircle then junit else hspec -- Run unreliable tests first, so local dev errors are reported for reliable -- specs at the end @@ -66,18 +65,21 @@ evaluateSummary $ reliableSummary <> isolatedSummary where load = flip readConfig - junit filename changeConfig = - (spec `runJUnitSpec` ("/tmp/junit", filename)) . changeConfig - hspec _ changeConfig = runSpec spec . changeConfig + runner filename changeConfig = + (spec `runWithJUnit` ("/tmp/junit", filename)) . changeConfig noConcurrency x = x {configConcurrentJobs = Just 1} -runJUnitSpec :: Spec -> (FilePath, String) -> Config -> IO Summary -runJUnitSpec spec (path, name) config = - spec `runSpec` configWithJUnit junitConfig config +runWithJUnit :: Spec -> (FilePath, String) -> Config -> IO Summary +runWithJUnit spec (path, name) config = do + junitEnabled <- envJUnitEnabled + baseJUnitConfig <- envJUnitConfig + let modify = if junitEnabled then configWithJUnit $ withOverride baseJUnitConfig else id + spec `runSpec` modify config where + runSpec = flip hspecWithResult filePath = path <> "/" <> name <> "/test_results.xml" - junitConfig = - setJUnitConfigOutputFile filePath $ defaultJUnitConfig $ pack name + withOverride = + setJUnitConfigSourcePathPrefix name . setJUnitConfigOutputFile filePath makeParallelConfig :: Config -> IO Config makeParallelConfig config = do diff --git a/package.yaml b/package.yaml --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: freckle-app -version: 1.10.3.0 +version: 1.10.4.0 maintainer: Freckle Education category: Utils github: freckle/freckle-app diff --git a/tests/Freckle/App/MemcachedSpec.hs b/tests/Freckle/App/MemcachedSpec.hs --- a/tests/Freckle/App/MemcachedSpec.hs +++ b/tests/Freckle/App/MemcachedSpec.hs @@ -17,6 +17,7 @@ import Freckle.App.Memcached.Client (MemcachedClient, withMemcachedClient) import qualified Freckle.App.Memcached.Client as Memcached import Freckle.App.Memcached.Servers +import Freckle.App.OpenTelemetry data ExampleValue = A @@ -39,6 +40,7 @@ data App = App { appMemcachedClient :: MemcachedClient , appLogger :: Logger + , appTracer :: Tracer } instance HasMemcachedClient App where @@ -48,6 +50,9 @@ instance HasLogger App where loggerL = lens appLogger $ \x y -> x {appLogger = y} +instance HasTracer App where + tracerL = lens appTracer $ \x y -> x {appTracer = y} + loadApp :: (App -> IO a) -> IO a loadApp f = do servers <- @@ -57,8 +62,10 @@ "MEMCACHED_SERVERS" (Env.def defaultMemcachedServers) appLogger <- newTestLogger defaultLogSettings - withMemcachedClient servers $ \appMemcachedClient -> do - f App {..} + withTracerProvider $ \tp -> do + let appTracer = makeTracer tp "freckle-app" tracerOptions + withMemcachedClient servers $ \appMemcachedClient -> do + f App {..} spec :: Spec spec = withApp loadApp $ do