freckle-app 1.10.3.0 → 1.10.4.0

raw patch · 13 files changed

+200/−44 lines, 13 files

Files

• CHANGELOG.md +11/−1
• freckle-app.cabal +1/−1
• library/Freckle/App/Database.hs +1/−1
• library/Freckle/App/Kafka/Consumer.hs +58/−11
• library/Freckle/App/Kafka/Producer.hs +15/−1
• library/Freckle/App/Memcached.hs +11/−2
• library/Freckle/App/Memcached/CacheKey.hs +4/−0
• library/Freckle/App/Memcached/CacheTTL.hs +4/−0
• library/Freckle/App/Memcached/Client.hs +26/−4
• library/Freckle/App/OpenTelemetry.hs +45/−8
• library/Freckle/App/Test/Hspec/Runner.hs +14/−12
• package.yaml +1/−1
• tests/Freckle/App/MemcachedSpec.hs +9/−2

@@ -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) 

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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 --

@@ -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

@@ -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

@@ -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 <https://github.com/iand675/hs-opentelemetry/issues/60>.@@ -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 =

@@ -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

@@ -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

@@ -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