freckle-app 1.10.4.0 → 1.10.5.0

raw patch · 24 files changed

+456/−63 lines, 24 filesdep +annotated-exception

Dependencies added: annotated-exception

Files

• CHANGELOG.md +14/−1
• freckle-app.cabal +6/−2
• library/Freckle/App/Async.hs +0/−1
• library/Freckle/App/Bugsnag.hs +1/−1
• library/Freckle/App/Csv.hs +3/−4
• library/Freckle/App/Database.hs +0/−1
• library/Freckle/App/Ecs.hs +0/−1
• library/Freckle/App/Exception/MonadThrow.hs +115/−0
• library/Freckle/App/Exception/MonadUnliftIO.hs +116/−0
• library/Freckle/App/Exception/Types.hs +15/−0
• library/Freckle/App/Http.hs +5/−4
• library/Freckle/App/Http/Retry.hs +3/−3
• library/Freckle/App/Kafka/Consumer.hs +12/−15
• library/Freckle/App/Kafka/Producer.hs +4/−3
• library/Freckle/App/Memcached.hs +5/−4
• library/Freckle/App/Memcached/CacheKey.hs +1/−2
• library/Freckle/App/OpenTelemetry.hs +2/−1
• library/Freckle/App/Prelude.hs +17/−6
• library/Freckle/App/Random.hs +122/−0
• library/Freckle/App/Test.hs +7/−4
• library/Freckle/App/Test/Yesod.hs +1/−2
• library/Freckle/App/Yesod.hs +5/−5
• package.yaml +2/−2
• tests/Freckle/App/Bugsnag/MetaDataSpec.hs +0/−1

@@ -1,4 +1,17 @@-## [_Unreleased_](https://github.com/freckle/freckle-app/compare/v1.10.4.0...main)+## [_Unreleased_](https://github.com/freckle/freckle-app/compare/v1.10.5.0...main)++## [v1.10.5.0](https://github.com/freckle/freckle-app/compare/v1.10.4.0...v1.10.5.0)++- Add `Freckle.App.Exception...` modules with exception utilities based on the+  `annotated-exception` package.++- The Prelude module is expanded to reexport from `Freckle.App.Exception.MonadUnliftIO`+  the following: `throwM`, `throwString`, `fromJustNoteM`, `catch`, `catchJust`,+  `catches`, `try`, `tryJust`, `impossible`, `ExceptionHandler`, `Exception`,+  `SomeException`. These should be used in place of their relevant counterparts from+  packages `base`, `exceptions`, `safe-exceptions`, or `unliftio`.++- Add `Freckle.App.Random`  ## [v1.10.4.0](https://github.com/freckle/freckle-app/compare/v1.10.3.0...v1.10.4.0) 

@@ -1,6 +1,6 @@ cabal-version:      1.18 name:               freckle-app-version:            1.10.4.0+version:            1.10.5.0 license:            MIT license-file:       LICENSE maintainer:         Freckle Education@@ -33,6 +33,9 @@         Freckle.App.Dotenv         Freckle.App.Ecs         Freckle.App.Env+        Freckle.App.Exception.MonadThrow+        Freckle.App.Exception.MonadUnliftIO+        Freckle.App.Exception.Types         Freckle.App.Ghci         Freckle.App.GlobalCache         Freckle.App.Http@@ -49,6 +52,7 @@         Freckle.App.Memcached.Servers         Freckle.App.OpenTelemetry         Freckle.App.Prelude+        Freckle.App.Random         Freckle.App.Scientist         Freckle.App.Stats         Freckle.App.Stats.Rts@@ -90,6 +94,7 @@         Glob >=0.10.2,         MonadRandom >=0.5.3,         aeson >=1.5.6.0,+        annotated-exception >=0.2.0.5,         aws-xray-client-persistent >=0.1.0.5,         aws-xray-client-wai >=0.1.0.2,         base >=4.14.3.0,@@ -260,7 +265,6 @@         monad-validate >=1.2.0.1,         nonempty-containers >=0.3.4.4,         postgresql-simple >=0.6.4,-        unliftio >=0.2.21.0,         vector >=0.12.3.1,         wai >=3.2.3,         wai-extra >=3.1.8

@@ -14,7 +14,6 @@ import UnliftIO.Async (Async) import qualified UnliftIO.Async as UnliftIO import UnliftIO.Concurrent (threadDelay)-import UnliftIO.Exception (SomeException, displayException)  -- | 'UnliftIO.Async.async' but passing the thread context along async :: (MonadMask m, MonadUnliftIO m) => m a -> m (Async a)

@@ -33,10 +33,10 @@ import Database.PostgreSQL.Simple.Errors import Freckle.App.Async (async) import qualified Freckle.App.Env as Env+import qualified Freckle.App.Exception.MonadUnliftIO as Exception import Network.Bugsnag hiding (notifyBugsnag, notifyBugsnagWith) import qualified Network.Bugsnag as Bugsnag import Network.HTTP.Client (HttpException (..), host, method)-import qualified UnliftIO.Exception as Exception import Yesod.Core.Lens import Yesod.Core.Types (HandlerData) 

@@ -64,7 +64,6 @@ import qualified Data.Text as T import qualified Data.Text.Encoding as T import qualified Data.Vector as V-import UnliftIO.Exception (handle)  -- | Treat CSV header line as 1 --@@ -142,10 +141,10 @@    . MonadUnliftIO m   => ConduitT () Void (ValidateT (Seq (CsvException err)) (ResourceT m)) r   -> m (Either (Seq (CsvException err)) r)-runCsvConduit = handle nonUtf8 . runResourceT . runValidateT . runConduit+runCsvConduit = flip catch nonUtf8 . runResourceT . runValidateT . runConduit  where-  nonUtf8 :: Conduit.TextException -> m (Either (Seq (CsvException err)) r)-  nonUtf8 = const $ pure $ Left $ pure CsvUnknownFileEncoding+  nonUtf8 (_ :: Conduit.TextException) =+    pure $ Left $ pure CsvUnknownFileEncoding  -- | Stream in 'ByteString's and parse records in constant space decodeCsv

@@ -71,7 +71,6 @@ import OpenTelemetry.Instrumentation.Persistent import System.Process.Typed (proc, readProcessStdout_) import UnliftIO.Concurrent (threadDelay)-import UnliftIO.Exception (displayException) import UnliftIO.IORef import Yesod.Core.Types (HandlerData (..), RunHandlerEnv (..)) 

@@ -13,7 +13,6 @@ import Data.List.Extra (dropPrefix) import Freckle.App.Http import System.Environment (lookupEnv)-import UnliftIO.Exception (Exception (..))  data EcsMetadata = EcsMetadata   { emContainerMetadata :: EcsContainerMetadata

@@ -0,0 +1,115 @@+module Freckle.App.Exception.MonadThrow+  ( throwM+  , throwString+  , fromJustNoteM+  , impossible+  , catch+  , catchJust+  , catches+  , try+  , tryJust+  , checkpointCallStack++    -- * Miscellany+  , MonadThrow+  , MonadCatch+  , MonadMask+  , module Freckle.App.Exception.Types+  ) where++import Freckle.App.Exception.Types++import Control.Applicative (pure)+import Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow)+import Data.Either (Either (..))+import Data.Function (($), (.))+import Data.Functor (fmap, (<$>))+import Data.Maybe (Maybe, maybe)+import Data.String (String)+import GHC.IO.Exception (userError)+import GHC.Stack (withFrozenCallStack)++import qualified Control.Exception.Annotated as Annotated+import qualified Control.Monad.Catch++-- Throws an exception, wrapped in 'AnnotatedException' which includes a call stack+throwM :: forall e m a. (Exception e, MonadThrow m, HasCallStack) => e -> m a+throwM = Annotated.throw++throwString :: forall m a. (MonadThrow m, HasCallStack) => String -> m a+throwString = throwM . userError++fromJustNoteM+  :: forall m a. (MonadThrow m, HasCallStack) => String -> Maybe a -> m a+fromJustNoteM err = maybe (throwString err) pure++impossible :: forall m a. (MonadThrow m, HasCallStack) => m a+impossible = throwString "Impossible"++catch+  :: forall e m a+   . (Exception e, MonadCatch m, HasCallStack)+  => m a+  -> (e -> m a)+  -> m a+catch = withFrozenCallStack Annotated.catch++catchJust+  :: forall e b m a+   . (Exception e, MonadCatch m, HasCallStack)+  => (e -> Maybe b)+  -> m a+  -> (b -> m a)+  -> m a+catchJust test action handler =+  withFrozenCallStack $ Annotated.catch action $ \e ->+    maybe (Control.Monad.Catch.throwM e) handler (test e)++catches+  :: forall m a+   . (MonadCatch m, HasCallStack)+  => m a+  -- ^ Action to run+  -> [ExceptionHandler m a]+  -- ^ Recovery actions to run if the first action throws an exception+  --   with a type of either @e@ or @'AnnotatedException' e@+  -> m a+catches action handlers =+  withFrozenCallStack $+    Annotated.catches+      action+      (fmap (\case (ExceptionHandler f) -> Annotated.Handler f) handlers)++try+  :: forall e m a+   . (Exception e, MonadCatch m, HasCallStack)+  => m a+  -- ^ Action to run+  -> m (Either e a)+  -- ^ Returns 'Left' if the action throws an exception with a type+  --   of either @e@ or @'AnnotatedException' e@+try = withFrozenCallStack Annotated.try++tryJust+  :: forall e b m a+   . (Exception e, MonadCatch m, HasCallStack)+  => (e -> Maybe b)+  -> m a+  -- ^ Action to run+  -> m (Either b a)+tryJust test action =+  withFrozenCallStack $ Annotated.catch (Right <$> action) $ \e ->+    maybe (Control.Monad.Catch.throwM e) (pure . Left) (test e)++-- | When dealing with a library that does not use 'AnnotatedException',+--   apply this function to augment its exceptions with call stacks.+checkpointCallStack+  :: forall m a+   . (MonadCatch m, HasCallStack)+  => m a+  -- ^ Action that might throw whatever types of exceptions+  -> m a+  -- ^ Action that only throws 'AnnotatedException',+  --   where the annotations include a call stack+checkpointCallStack =+  withFrozenCallStack Annotated.checkpointCallStack

@@ -0,0 +1,116 @@+module Freckle.App.Exception.MonadUnliftIO+  ( throwM+  , throwString+  , fromJustNoteM+  , impossible+  , catch+  , catchJust+  , catches+  , try+  , tryJust+  , checkpointCallStack++    -- * Miscellany+  , IO+  , MonadIO+  , MonadUnliftIO+  , module Freckle.App.Exception.Types+  ) where++import Freckle.App.Exception.Types++import Control.Applicative (pure)+import Data.Either (Either (..))+import Data.Function (($), (.))+import Data.Functor (fmap, (<$>))+import Data.Maybe (Maybe, maybe)+import Data.String (String)+import GHC.IO.Exception (userError)+import GHC.Stack (withFrozenCallStack)+import System.IO (IO)+import UnliftIO (MonadIO, MonadUnliftIO)+import qualified UnliftIO.Exception++import qualified Control.Exception.Annotated.UnliftIO as Annotated++-- Throws an exception, wrapped in 'AnnotatedException' which includes a call stack+throwM :: forall e m a. (Exception e, MonadIO m, HasCallStack) => e -> m a+throwM = Annotated.throw++throwString :: forall m a. (MonadIO m, HasCallStack) => String -> m a+throwString = throwM . userError++fromJustNoteM+  :: forall m a. (MonadIO m, HasCallStack) => String -> Maybe a -> m a+fromJustNoteM err = maybe (throwString err) pure++impossible :: forall m a. (MonadIO m, HasCallStack) => m a+impossible = throwString "Impossible"++catch+  :: forall e m a+   . (Exception e, MonadUnliftIO m, HasCallStack)+  => m a+  -> (e -> m a)+  -> m a+catch = withFrozenCallStack Annotated.catch++catchJust+  :: forall e b m a+   . (Exception e, MonadUnliftIO m, HasCallStack)+  => (e -> Maybe b)+  -> m a+  -> (b -> m a)+  -> m a+catchJust test action handler =+  withFrozenCallStack $ Annotated.catch action $ \e ->+    maybe (UnliftIO.Exception.throwIO e) handler (test e)++catches+  :: forall m a+   . (MonadUnliftIO m, HasCallStack)+  => m a+  -- ^ Action to run+  -> [ExceptionHandler m a]+  -- ^ Recovery actions to run if the first action throws an exception+  --   with a type of either @e@ or @'AnnotatedException' e@+  -> m a+catches action handlers =+  withFrozenCallStack $+    Annotated.catches+      action+      (fmap (\case (ExceptionHandler f) -> Annotated.Handler f) handlers)++try+  :: forall e m a+   . (Exception e, MonadUnliftIO m, HasCallStack)+  => m a+  -- ^ Action to run+  -> m (Either e a)+  -- ^ Returns 'Left' if the action throws an exception with a type+  --   of either @e@ or @'AnnotatedException' e@+try = withFrozenCallStack Annotated.try++tryJust+  :: forall e b m a+   . (Exception e, MonadUnliftIO m, HasCallStack)+  => (e -> Maybe b)+  -> m a+  -- ^ Action to run+  -> m (Either b a)+tryJust test action =+  withFrozenCallStack $ Annotated.catch (Right <$> action) $ \e ->+    maybe (UnliftIO.Exception.throwIO e) (pure . Left) (test e)++-- | When dealing with a library that does not use 'AnnotatedException',+--   apply this function to augment its exceptions with call stacks.+checkpointCallStack+  :: forall m a+   . (MonadUnliftIO m, HasCallStack)+  => m a+  -- ^ Action that might throw whatever types of exceptions+  -> m a+  -- ^ Action that only throws 'AnnotatedException',+  --   where the annotations include a call stack+checkpointCallStack =+  withFrozenCallStack Annotated.checkpointCallStack

@@ -0,0 +1,15 @@+module Freckle.App.Exception.Types+  ( ExceptionHandler (..)+  , AnnotatedException (..)+  , Exception (..)+  , SomeException (..)+  , HasCallStack+  ) where++import Control.Exception (Exception (..), SomeException (..))+import Control.Exception.Annotated (AnnotatedException (..))+import GHC.Stack (HasCallStack)++-- Renamed just so that it can go into Freckle.App.Prelude and have a less generic name than 'Handler'+data ExceptionHandler m a+  = forall e. Exception e => ExceptionHandler (e -> m a)

@@ -92,7 +92,7 @@     -- error-handling specific to exceptions caused by 4XX responses:     --     -- @-    -- 'handleJust' (guarded 'httpExceptionIsClientError') handle4XXError $ do+    -- flip 'catchJust' (guard 'httpExceptionIsClientError' *> handle4XXError) $ do     --   resp <- 'httpJson' $ 'setRequestCheckStatus' $ parseRequest_ "http://..."     --   body <- 'getResponseBodyUnsafe' resp     --@@ -137,7 +137,6 @@   , statusIsServerError   , statusIsSuccessful   )-import UnliftIO.Exception (Exception (..), throwIO)  data HttpDecodeError = HttpDecodeError   { hdeBody :: ByteString@@ -213,8 +212,10 @@ -- error response bodies too, you'll want to use 'setRequestCheckStatus' so that -- you see status-code exceptions before 'HttpDecodeError's. getResponseBodyUnsafe-  :: (MonadIO m, Exception e) => Response (Either e a) -> m a-getResponseBodyUnsafe = either throwIO pure . getResponseBody+  :: (MonadIO m, Exception e, HasCallStack)+  => Response (Either e a)+  -> m a+getResponseBodyUnsafe = either throwM pure . getResponseBody  httpExceptionIsInformational :: HttpException -> Bool httpExceptionIsInformational = filterStatusException statusIsInformational

@@ -12,7 +12,6 @@ import Network.HTTP.Simple import Network.HTTP.Types.Status (status429) import Text.Read (readMaybe)-import UnliftIO.Exception (Exception (..), throwIO)  -- | Thrown if we exhaust our retries limit and still see a @429@ --@@ -78,10 +77,11 @@  where   originalCheckResponse = checkResponse req -checkRetriesExhausted :: MonadIO m => Int -> Response body -> m (Response body)+checkRetriesExhausted+  :: (MonadIO m, HasCallStack) => Int -> Response body -> m (Response body) checkRetriesExhausted retryLimit resp   | getResponseStatus resp == status429 =-      throwIO $+      throwM $         RetriesExhausted {reLimit = retryLimit, reResponse = void resp}   | otherwise = pure resp 

@@ -30,13 +30,7 @@   , subscription   ) import qualified Kafka.Consumer as Kafka-import UnliftIO.Exception-  ( Exception (..)-  , Handler (..)-  , bracket-  , catches-  , throwIO-  )+import UnliftIO.Exception (bracket)  data KafkaConsumerConfig = KafkaConsumerConfig   { kafkaConsumerConfigBrokerAddresses :: NonEmpty BrokerAddress@@ -135,15 +129,15 @@     <> extraSubscriptionProps kafkaConsumerConfigExtraSubscriptionProps  withKafkaConsumer-  :: MonadUnliftIO m+  :: (MonadUnliftIO m, HasCallStack)   => KafkaConsumerConfig   -> (KafkaConsumer -> m a)   -> m a withKafkaConsumer config = bracket newConsumer closeConsumer  where   (props, sub) = (consumerProps &&& subscription) config-  newConsumer = either throwIO pure =<< Kafka.newConsumer props sub-  closeConsumer = maybe (pure ()) throwIO <=< Kafka.closeConsumer+  newConsumer = either throwM pure =<< Kafka.newConsumer props sub+  closeConsumer = maybe (pure ()) throwM <=< Kafka.closeConsumer  timeoutMs :: Timeout -> Int timeoutMs = \case@@ -172,6 +166,7 @@      , MonadTracer m      , HasKafkaConsumer env      , FromJSON a+     , HasCallStack      )   => Timeout   -> (a -> m ())@@ -186,30 +181,32 @@       for_ (crValue =<< mRecord) $ \bs -> do         a <-           inSpan "kafka.consumer.message.decode" defaultSpanArguments $-            either (throwIO . KafkaMessageDecodeError bs) pure $+            either (throwM . KafkaMessageDecodeError bs) pure $               eitherDecodeStrict bs         inSpan "kafka.consumer.message.handle" defaultSpanArguments $ onMessage a  where   kTimeout = Kafka.Timeout $ timeoutMs pollTimeout    handlers =-    [ Handler $ \err ->+    [ ExceptionHandler $ \err ->         logError $           "Error polling for message from Kafka"             :# ["error" .= displayException @KafkaError err]-    , Handler $ \err ->+    , ExceptionHandler $ \err ->         logError $           "Could not decode message value"             :# ["error" .= displayException @KafkaMessageDecodeError err]     ]  fromKafkaError-  :: (MonadIO m, MonadLogger m) => Either KafkaError a -> m (Maybe a)+  :: (MonadIO m, MonadLogger m, HasCallStack)+  => Either KafkaError a+  -> m (Maybe a) fromKafkaError =   either     ( \case         KafkaResponseError RdKafkaRespErrTimedOut ->           Nothing <$ logDebug "Polling timeout"-        err -> throwIO err+        err -> throwM err     )     $ pure . Just

@@ -28,7 +28,6 @@ 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) @@ -101,8 +100,10 @@         kafkaProducerPoolConfigSize  where   mkProducer =-    either throw pure =<< newProducer (brokersList $ toList addresses)-  throw err = throwString $ "Failed to open kafka producer: " <> show err+    either+      (\err -> throwString ("Failed to open kafka producer: " <> show err))+      pure+      =<< newProducer (brokersList $ toList addresses)  produceKeyedOn   :: ( MonadUnliftIO m

@@ -37,7 +37,6 @@ 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   toCachable :: a -> ByteString@@ -142,9 +141,11 @@  handleCachingError   :: (MonadUnliftIO m, MonadLogger m) => a -> Text -> m a -> m a-handleCachingError value action = handleAny $ \ex -> do-  logCachingError action $ pack $ displayException ex-  pure value+handleCachingError value action = flip catch handler+ where+  handler (ex :: SomeException) = do+    logCachingError action $ pack $ displayException ex+    pure value  logCachingError :: MonadLogger m => Text -> Text -> m () logCachingError action message =

@@ -11,7 +11,6 @@ import qualified Data.Text as T import Database.Memcache.Types (Key) import OpenTelemetry.Trace (ToAttribute (..))-import UnliftIO.Exception (throwString)  newtype CacheKey = CacheKey Text   deriving stock (Show)@@ -43,7 +42,7 @@     Left $ "Not a valid memcached key:\n  " <> unpack t <> "\n\n" <> msg  -- | Build a 'CacheKey' and throw if invalid-cacheKeyThrow :: (HasCallStack, MonadIO m) => Text -> m CacheKey+cacheKeyThrow :: (MonadIO m, HasCallStack) => Text -> m CacheKey cacheKeyThrow = either throwString pure . cacheKey  fromCacheKey :: CacheKey -> Key

@@ -53,7 +53,8 @@  import Freckle.App.Prelude -import Blammo.Logging (MonadMask, withThreadContext, (.=))+import Blammo.Logging (withThreadContext, (.=))+import Control.Monad.Catch (MonadMask) import Data.Word (Word64) import OpenTelemetry.Context (lookupSpan) import OpenTelemetry.Context.ThreadLocal (getContext)

@@ -6,12 +6,11 @@      -- * Commonly imported types   , Alternative-  , Exception   , Generic   , HasCallStack+  , Hashable   , HashMap   , HashSet-  , Hashable   , Int64   , Map   , MonadIO@@ -88,6 +87,20 @@      -- ** 'UTCTime'   , getCurrentTime++   -- * Exceptions+  , throwM+  , throwString+  , fromJustNoteM+  , catch+  , catchJust+  , catches+  , try+  , tryJust+  , impossible+  , ExceptionHandler (..)+  , Exception (displayException)+  , SomeException (..)   ) where  -- Use 'Prelude' as the starting point, removing common partial functions@@ -112,7 +125,7 @@ -- Commonly used types (and their commonly used functions)  import Control.Applicative (Alternative, liftA2, optional, (<|>))-import Control.Monad.IO.Class (MonadIO, liftIO)+import Control.Monad.IO.Class (liftIO) import Control.Monad.Primitive (PrimMonad) import Control.Monad.Reader (MonadReader, ReaderT) import Data.HashMap.Strict (HashMap)@@ -122,13 +135,11 @@ import Data.List.NonEmpty (NonEmpty) import Data.Map.Strict (Map) import Data.Set (Set)+import Freckle.App.Exception.MonadUnliftIO import Data.Text (Text, pack, unpack) import Data.Time (NominalDiffTime, UTCTime, getCurrentTime) import Data.Vector (Vector) import GHC.Generics (Generic)-import GHC.Stack (HasCallStack)-import UnliftIO (MonadUnliftIO)-import UnliftIO.Exception (Exception)  -- Safe alternatives to prelude functions 

@@ -0,0 +1,122 @@+{-# LANGUAGE NamedFieldPuns #-}++module Freckle.App.Random+  ( smallRandomSubsetOfLargeIntegerRange+  , Range (..)+  , NonEmptyRange (..)+  , inclusiveRange+  ) where++import Freckle.App.Prelude++import Control.Monad.Random (MonadRandom (..), Random)+import Control.Monad.ST (runST)+import Control.Monad.State.Strict (execStateT, get, put)+import Data.Functor ((<&>))+import Data.STRef (newSTRef, readSTRef, writeSTRef)+import Numeric.Natural (Natural)++import qualified Data.Set as Set++-- | A possibly-empty contiguous range of integers+data Range i+  = RangeEmpty+  | RangeNonEmpty (NonEmptyRange i)++-- | A nonempty contiguous range of integers+data NonEmptyRange i = NonEmptyRange+  { inclusiveMinBound :: i+  , offset :: Natural+  -- ^ The size of the range minus one+  }++inclusiveRange+  :: Integral i+  => i+  -- ^ Lower bound, inclusive+  -> i+  -- ^ Upper bound, inclusive+  -> Range i+inclusiveRange a b =+  if a <= b+    then RangeNonEmpty (NonEmptyRange a (fromIntegral (b - a)))+    else RangeEmpty++-- | Select a fixed number of items uniformly at random+--   from a contiguous range of integers+--+-- This process accommodates selecting from a large range, but only has+-- reasonable performance when the number of items being selected is small+-- (it is quadratic in the number of items).+--+-- If the requested size is greater than or equal to the range, the entire+-- range is returned.+--+-- e.g. @smallRandomSubsetOfLargeIntegerRange 10 (inclusiveRange 30 70)@+-- may produce something like @fromList [32,34,45,54,56,58,62,63,64,65]@.+smallRandomSubsetOfLargeIntegerRange+  :: (MonadRandom m, Random i, Integral i)+  => Natural+  -- ^ How many items are wanted+  -> Range i+  -> m (Set i)+smallRandomSubsetOfLargeIntegerRange n = \case+  RangeEmpty -> pure Set.empty+  RangeNonEmpty r ->+    fmap gaps $+      flip execStateT (RangeWithGaps r Set.empty) $+        for_ [1 .. n] $ \_ -> do+          get >>= (lift . randomlyRemove) >>= put++data RangeWithGaps i = RangeWithGaps+  { rangeWithoutGaps :: NonEmptyRange i+  , gaps :: Set i+  -- ^ The set of items that has been removed from the larger range+  }++-- | Randomly remove an item from a 'RangeWithGaps'.+--+-- This selects uniformly at random an item from a 'RangeWithGaps' and+-- removes it (adds it to the 'gaps' set).+--+-- If every item in the range has already been removed, this does nothing.+randomlyRemove+  :: (MonadRandom m, Random i, Integral i) => RangeWithGaps i -> m (RangeWithGaps i)+randomlyRemove rg =+  randomFromRangeWithGaps rg <&> \case+    Nothing -> rg+    Just i -> rg {gaps = Set.insert i (gaps rg)}++-- | Randomly select an item from a 'RangeWithGaps'+--+-- This selects uniformly at random an item from the range that is not+-- present in the 'gaps' set.+randomFromRangeWithGaps+  :: (MonadRandom m, Random i, Integral i)+  => RangeWithGaps i+  -> m (Maybe i)+randomFromRangeWithGaps rg =+  let+    RangeWithGaps {rangeWithoutGaps, gaps} = rg+    NonEmptyRange {inclusiveMinBound, offset} = rangeWithoutGaps+  in+    if fromIntegral (Set.size gaps) == offset + 1+      then pure Nothing+      else+        Just+          <$> do+            r <-+              (inclusiveMinBound +)+                <$> getRandomR (0, fromIntegral offset - fromIntegral (Set.size gaps))+            pure $ runST $ do+              xRef <- newSTRef r+              gapQueue <- newSTRef $ Set.toAscList gaps+              let go = do+                    x <- readSTRef xRef+                    readSTRef gapQueue >>= \case+                      g : gs | g <= x -> do+                        writeSTRef xRef (x + 1)+                        writeSTRef gapQueue gs+                        go+                      _ -> pure x+              go

@@ -37,7 +37,8 @@ import Blammo.Logging import Control.Lens (view) import Control.Monad.Base-import Control.Monad.Catch+import Control.Monad.Catch (ExitCase (..), MonadCatch, MonadThrow, mask)+import qualified Control.Monad.Catch import qualified Control.Monad.Fail as Fail import Control.Monad.IO.Unlift (MonadUnliftIO (..)) import Control.Monad.Primitive@@ -53,6 +54,7 @@   ) import qualified Freckle.App.Database.XRay as XRay import qualified Freckle.App.Dotenv as Dotenv+import qualified Freckle.App.Exception.MonadThrow as MonadThrow import Freckle.App.OpenTelemetry import qualified Test.Hspec as Hspec hiding (expectationFailure) import Test.Hspec.Core.Spec (Arg, Example, SpecWith, evaluateExample)@@ -99,9 +101,10 @@   generalBracket acquire release use = mask $ \unmasked -> do     resource <- acquire     b <--      unmasked (use resource) `UnliftIO.catch` \e -> do+      unmasked (use resource) `catch` \e -> do         _ <- release resource (ExitCaseException e)-        throwM e+        MonadThrow.throwM e+     c <- release resource (ExitCaseSuccess b)     pure (b, c) @@ -175,7 +178,7 @@ beforeSql :: HasSqlPool app => SqlPersistT IO a -> SpecWith app -> SpecWith app beforeSql f = beforeWith $ \app -> app <$ runSqlPool f (getSqlPool app) -expectationFailure :: (HasCallStack, MonadIO m) => String -> m a+expectationFailure :: (MonadIO m, HasCallStack) => String -> m a expectationFailure msg = Hspec.expectationFailure msg >> error "unreachable"  pending :: MonadIO m => m ()

@@ -92,7 +92,6 @@ import Network.HTTP.Types.Header (hAccept, hAcceptLanguage, hContentType) import Network.Wai.Test (SResponse (..)) import Test.Hspec.Expectations.Lifted (expectationFailure)-import UnliftIO.Exception (throwString) import Web.Cookie (SetCookie) import Yesod.Core (RedirectUrl, Yesod) import Yesod.Test@@ -217,7 +216,7 @@ -- If the status code doesn't match, a portion of the body is also -- printed to aid in debugging. statusIs-  :: forall m site. (HasCallStack, MonadYesodExample site m) => Int -> m ()+  :: forall m site. (MonadYesodExample site m, HasCallStack) => Int -> m () statusIs = liftYesodExample . Yesod.Test.statusIs  -- | Assert that the given header field's value satisfied some predicate

@@ -12,7 +12,6 @@ import qualified Freckle.App.Stats as Stats import Network.HTTP.Types (ResponseHeaders, status503) import qualified Network.Wai as W-import UnliftIO.Exception (displayException, handleJust) import Yesod.Core.Handler (HandlerFor, sendWaiResponse)  -- | Catch 'SqlError' when queries are canceled due to timeout and respond 503@@ -28,10 +27,11 @@   => ResponseHeaders   -> HandlerFor site res   -> HandlerFor site res-respondQueryCanceledHeaders headers = handleJust queryCanceled $ \ex -> do-  logError $ "Query canceled" :# ["exception" .= displayException ex]-  Stats.increment "query_canceled"-  sendWaiResponse $ W.responseLBS status503 headers "Query canceled"+respondQueryCanceledHeaders headers handler =+  catchJust queryCanceled handler $ \ex -> do+    logError $ "Query canceled" :# ["exception" .= displayException ex]+    Stats.increment "query_canceled"+    sendWaiResponse $ W.responseLBS status503 headers "Query canceled"  queryCanceled :: SqlError -> Maybe SqlError queryCanceled ex = ex <$ guard (sqlState ex == "57014")

@@ -1,5 +1,5 @@ name: freckle-app-version: 1.10.4.0+version: 1.10.5.0 maintainer: Freckle Education category: Utils github: freckle/freckle-app@@ -72,6 +72,7 @@     - Glob     - MonadRandom     - aeson+    - annotated-exception     - aws-xray-client-persistent     - aws-xray-client-wai     - base@@ -168,7 +169,6 @@       - postgresql-simple       - monad-validate       - nonempty-containers-      - unliftio       - vector       - wai       - wai-extra

@@ -11,7 +11,6 @@ import Freckle.App.Bugsnag.MetaData import Freckle.App.Stats import qualified Freckle.App.Stats as Stats-import UnliftIO.Exception (SomeException)  spec :: Spec spec = do