freckle-app 1.8.1.0 → 1.9.0.0

raw patch · 16 files changed

+346/−126 lines, 16 filesdep +resourcetPVP ok

version bump matches the API change (PVP)

Dependencies added: resourcet

API changes (from Hackage documentation)

Files

• CHANGELOG.md +8/−1
• README.md +3/−0
• freckle-app.cabal +52/−2
• library/Freckle/App.hs +99/−14
• library/Freckle/App/Aeson.hs +5/−1
• library/Freckle/App/Database.hs +14/−30
• library/Freckle/App/Dotenv.hs +1/−2
• library/Freckle/App/Memcached/CacheKey.hs +0/−1
• library/Freckle/App/OpenTelemetry.hs +19/−0
• library/Freckle/App/Prelude.hs +4/−4
• library/Freckle/App/Test.hs +15/−2
• library/Freckle/App/Wai.hs +18/−64
• library/Network/Wai/Middleware/Cors.hs +65/−0
• library/Network/Wai/Middleware/Stats.hs +17/−2
• package.yaml +25/−2
• tests/Spec.hs +1/−1

@@ -1,4 +1,11 @@-## [_Unreleased_](https://github.com/freckle/freckle-app/compare/v1.8.1.0...main)+## [_Unreleased_](https://github.com/freckle/freckle-app/compare/v1.9.0.0...main)++## [v1.9.0.0](https://github.com/freckle/freckle-app/compare/v1.8.1.0...v1.9.0.0)++- Refactor `Freckle.App.Wai` interface+- Add `addThreadContextFromStatsTags`+- Replace `HasXRayVaultData` with `MonadTracer`+- Introduce `AppT`  ## [v1.8.1.0](https://github.com/freckle/freckle-app/compare/v1.8.0.0...v1.8.1.0) 

@@ -1,5 +1,8 @@ # freckle-app +[![Hackage](https://img.shields.io/hackage/v/freckle-app.svg?style=flat)](https://hackage.haskell.org/package/freckle-app)+[![CI](https://github.com/freckle/freckle-app/actions/workflows/ci.yml/badge.svg)](https://github.com/freckle/freckle-app/actions/workflows/ci.yml)+ Haskell application toolkit used at Freckle.  ---

@@ -1,6 +1,6 @@ cabal-version:      1.18 name:               freckle-app-version:            1.8.1.0+version:            1.9.0.0 license:            MIT license-file:       LICENSE maintainer:         Freckle Education@@ -41,6 +41,7 @@         Freckle.App.Memcached.CacheTTL         Freckle.App.Memcached.Client         Freckle.App.Memcached.Servers+        Freckle.App.OpenTelemetry         Freckle.App.Prelude         Freckle.App.Scientist         Freckle.App.Stats@@ -54,6 +55,7 @@         Freckle.App.Yesod         Freckle.App.Yesod.Routes         Network.HTTP.Link.Compat+        Network.Wai.Middleware.Cors         Network.Wai.Middleware.Stats         Yesod.Core.Lens @@ -69,6 +71,12 @@         RecordWildCards ScopedTypeVariables StandaloneDeriving         TypeApplications TypeFamilies +    ghc-options:+        -fignore-optim-changes -Weverything -Wno-all-missed-specialisations+        -Wno-missing-exported-signatures -Wno-missing-import-lists+        -Wno-missing-local-signatures -Wno-monomorphism-restriction+        -Wno-safe -Wno-unsafe+     build-depends:         Blammo,         Glob,@@ -116,6 +124,7 @@         postgresql-simple,         primitive,         resource-pool,+        resourcet,         retry >=0.8.1.0,         safe,         scientist,@@ -135,6 +144,16 @@         yaml,         yesod-core +    if impl(ghc >=9.2)+        ghc-options: -Wno-missing-kind-signatures++    if impl(ghc >=8.10)+        ghc-options:+            -Wno-missing-safe-haskell-mode -Wno-prepositive-qualified-module++    if impl(ghc >=8.8)+        ghc-options: -fwrite-ide-info+ test-suite doctest     type:               exitcode-stdio-1.0     main-is:            Main.hs@@ -150,10 +169,26 @@         RecordWildCards ScopedTypeVariables StandaloneDeriving         TypeApplications TypeFamilies +    ghc-options:+        -fignore-optim-changes -Weverything -Wno-all-missed-specialisations+        -Wno-missing-exported-signatures -Wno-missing-import-lists+        -Wno-missing-local-signatures -Wno-monomorphism-restriction+        -Wno-safe -Wno-unsafe+     build-depends:         base >=4.12.0.0 && <5,         freckle-app +    if impl(ghc >=9.2)+        ghc-options: -Wno-missing-kind-signatures++    if impl(ghc >=8.10)+        ghc-options:+            -Wno-missing-safe-haskell-mode -Wno-prepositive-qualified-module++    if impl(ghc >=8.8)+        ghc-options: -fwrite-ide-info+ test-suite spec     type:               exitcode-stdio-1.0     main-is:            Main.hs@@ -181,7 +216,12 @@         RecordWildCards ScopedTypeVariables StandaloneDeriving         TypeApplications TypeFamilies -    ghc-options:        -threaded -rtsopts -with-rtsopts=-N+    ghc-options:+        -fignore-optim-changes -Weverything -Wno-all-missed-specialisations+        -Wno-missing-exported-signatures -Wno-missing-import-lists+        -Wno-missing-local-signatures -Wno-monomorphism-restriction+        -Wno-safe -Wno-unsafe -threaded -rtsopts -with-rtsopts=-N+     build-depends:         Blammo,         QuickCheck,@@ -205,3 +245,13 @@         vector,         wai,         wai-extra++    if impl(ghc >=9.2)+        ghc-options: -Wno-missing-kind-signatures++    if impl(ghc >=8.10)+        ghc-options:+            -Wno-missing-safe-haskell-mode -Wno-prepositive-qualified-module++    if impl(ghc >=8.8)+        ghc-options: -fwrite-ide-info

@@ -59,15 +59,25 @@ -- >     myAppAction -- >     myOtherAppAction --+-- == 'AppT'+--+-- Functions like @myAppAction@ will be run in the concrete stack 'AppT', but+-- you should prefer using using constraints (e.g. @'MonadReader' app@). See its+-- docs for all the constraints it satisfies.+-- -- == Database ----- Adding Database access requires an instance of @'HasSqlPool'@ on your @App@--- type. Most often, this will be easiest if you indeed separate a @Config@--- attribute:+-- Adding Database access requires a few more instances on your @App@ type: --+-- - @'HasSqlPool'@: so we can, you know, talk to a DB+-- - @'HasStatsClient'@: so we can manage connection count metrics+--+-- Most often, this will be easiest if you indeed separate a @Config@ attribute:+-- -- > data Config = Config -- >   { configDbPoolSize :: Int -- >   , configLogSettings :: LogSettings+-- >   , configStatsSettings :: StatsSettings -- >   } -- -- So you can isolate Env-related concerns@@ -76,6 +86,7 @@ -- > loadConfig = Env.parse id $ Config -- >   <$> Env.var Env.auto "PGPOOLSIZE" (Env.def 1) -- >   <*> LoggerEnv.parser+-- >   <*> envParseStatsSettings -- -- from the runtime application state: --@@ -83,6 +94,7 @@ -- >   { appConfig :: Config -- >   , appLogger :: Logger -- >   , appSqlPool :: SqlPool+-- >   , appStatsClient :: StatsClient -- >   } -- > -- > instance HasLogger App where@@ -90,6 +102,9 @@ -- > -- > instance HasSqlPool App where -- >   getSqlPool = appSqlPool+-- >+-- > instance HasStatsClient App where+-- >   statsClientL = lens appStatsClient $ \x y -> x { appStatsClient = y } -- -- The @"Freckle.App.Database"@ module provides @'makePostgresPool'@ for -- building a Pool given this (limited) config data:@@ -99,12 +114,17 @@ -- >   appConfig{..} <- loadConfig -- >   appLogger <- newLogger configLoggerSettings -- >   appSqlPool <- runLoggerLoggingT appLogger $ makePostgresPool configDbPoolSize--- >   f App{..}+-- >   withStatsClient configStatsSettings $ \appStatsClient -> do+-- >     f App{..} -- -- This unlocks @'runDB'@ for your application: -- -- > myAppAction--- >   :: (MonadIO m, MonadReader env m, HasSqlPool env)+-- >   :: ( MonadUnliftIO m+-- >      , MonadReader env m+-- >      , HasSqlPool env+-- >      , HasStatsClient env+-- >      ) -- >   => SqlPersistT m [Entity Something] -- > myAppAction = runDB $ selectList [] [] --@@ -124,7 +144,8 @@ -- >       result <- myAppAction :: AppExample App Text -- >       result `shouldBe` "as expected" ----- If your app type 'HasSqlPool', you can use 'runDB' in your specs too:+-- If your @App@ type has the required instances, you can use 'runDB' in your+-- specs too: -- -- > spec :: Spec -- > spec = aroundAll loadApp $ do@@ -135,23 +156,87 @@ -- module Freckle.App   ( runApp-  , module X+  , setLineBuffering++  -- * Concrete transformer stack+  , AppT(..)+  , runAppT++  -- * Re-exports+  , module Freckle.App.Database+  , module Freckle.App.OpenTelemetry+  , module Blammo.Logging+  , module Control.Monad.Reader   ) where -import Prelude+import Freckle.App.Prelude -import Blammo.Logging as X-import Control.Monad.Reader as X-import Freckle.App.Database as X+import Blammo.Logging+import Control.Monad.Catch (MonadCatch, MonadThrow)+import Control.Monad.IO.Unlift (MonadUnliftIO(..))+import Control.Monad.Primitive (PrimMonad(..))+import Control.Monad.Reader+import Control.Monad.Trans.Resource (MonadResource, ResourceT, runResourceT)+import Freckle.App.Database+import Freckle.App.OpenTelemetry import System.IO (BufferMode(..), hSetBuffering, stderr, stdout)  runApp   :: HasLogger app   => (forall b . (app -> IO b) -> IO b)-  -> ReaderT app (LoggingT IO) a+  -> AppT app IO a   -> IO a runApp loadApp action = do-  -- Ensure output is streamed if in a Docker container+  setLineBuffering+  loadApp $ runAppT action++-- | Ensure output is streamed if in a Docker container+--+-- 'runApp' calls this for you, but it may be useful if you're running the app+-- some other way.+--+setLineBuffering :: MonadIO m => m ()+setLineBuffering = liftIO $ do   hSetBuffering stdout LineBuffering   hSetBuffering stderr LineBuffering-  loadApp $ \app -> runLoggerLoggingT app $ runReaderT action app++newtype AppT app m a = AppT+  { unAppT :: ReaderT app (LoggingT (ResourceT m)) a+  }+  deriving newtype+    ( Functor+    , Applicative+    , Monad+    , MonadIO+    , MonadThrow+    , MonadCatch+    , MonadMask+    , MonadLogger+    , MonadLoggerIO+    , MonadResource+    , MonadReader app+    )++-- Just copies ReaderT's definition. This can be newtype-derived in GHC 8.10+,+-- but we do it by hand while we want to support older.+instance MonadUnliftIO m => MonadUnliftIO (AppT app m) where+  withRunInIO inner = AppT $ withRunInIO $ \run -> inner $ run . unAppT+  {-# INLINE withRunInIO #-}++instance PrimMonad m => PrimMonad (AppT app m) where+  type PrimState (AppT app m) = PrimState m++  -- This should really just be `lift . primitive`, but:+  --+  -- - We'd need `MonadTrans (AppT app)`, which meh+  -- - We'd need an orphan `Primitive LoggingT`, which no thanks+  --+  primitive = AppT . lift . lift . lift . primitive+  {-# INLINE primitive #-}++instance Applicative m => MonadTracer (AppT app m) where+  getVaultData = pure Nothing++runAppT :: (MonadUnliftIO m, HasLogger app) => AppT app m a -> app -> m a+runAppT action app =+  runResourceT $ runLoggerLoggingT app $ runReaderT (unAppT action) app

@@ -2,7 +2,9 @@  -- | Compatibility module for "Data.Aeson" 1.x vs 2.0 ----- TODO: An @aeson-compat@ package. Sadly, the name is taken.+-- This should be its own package, but the obvious name (@aeson-compat@) is+-- taken by something old and unrelated. I think that's why no one is doing it+-- yet, including us. -- module Freckle.App.Aeson   ( module X@@ -20,4 +22,6 @@ import Data.HashMap.Strict as X #endif +-- Ignored twice because HLint changes the name in some version+{-# ANN module ("HLint: ignore Avoid restricted alias" :: String) #-} {-# ANN module ("HLint: ignore Avoid restricted qualification" :: String) #-}

@@ -1,14 +1,10 @@ {-# LANGUAGE ApplicativeDo #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE StrictData #-} {-# LANGUAGE TypeOperators #-}  -- | Database access for your @App@ module Freckle.App.Database   ( HasSqlPool(..)-  , HasVaultData(..)   , SqlPool   , makePostgresPool   , makePostgresPoolWith@@ -27,6 +23,7 @@  import Blammo.Logging import qualified Control.Immortal as Immortal+import Control.Monad.IO.Unlift (MonadUnliftIO(..)) import Control.Monad.Reader import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as BS8@@ -47,6 +44,7 @@   (Connection, Only(..), connectPostgreSQL, execute) import Database.PostgreSQL.Simple.SqlQQ (sql) import qualified Freckle.App.Env as Env+import Freckle.App.OpenTelemetry (MonadTracer(..)) import Freckle.App.Stats (HasStatsClient) import qualified Freckle.App.Stats as Stats import Network.AWS.XRayClient.Persistent@@ -56,8 +54,7 @@ import UnliftIO.Concurrent (threadDelay) import UnliftIO.Exception (displayException) import UnliftIO.IORef-import Yesod.Core (MonadUnliftIO(withRunInIO), YesodRequest(reqWaiRequest))-import Yesod.Core.Types (HandlerData(handlerRequest))+import Yesod.Core.Types (HandlerData(..), RunHandlerEnv(..))  type SqlPool = Pool SqlBackend @@ -67,11 +64,8 @@ instance HasSqlPool SqlPool where   getSqlPool = id -class HasVaultData env where-  getVaultData :: env -> Maybe XRayVaultData--instance HasVaultData (HandlerData child site) where-  getVaultData = vaultDataFromRequest . reqWaiRequest . handlerRequest+instance HasSqlPool site => HasSqlPool (HandlerData child site) where+  getSqlPool = getSqlPool . rheSite . handlerEnv  makePostgresPool :: (MonadUnliftIO m, MonadLoggerIO m) => m SqlPool makePostgresPool = do@@ -80,31 +74,24 @@     Env.parse id $ Env.kept $ envParseDatabaseConf postgresPasswordSource   makePostgresPoolWith conf +-- | Run a Database action with connection stats and tracing runDB-  :: ( HasSqlPool app-     , HasStatsClient app-     , HasVaultData app-     , MonadUnliftIO m+  :: ( MonadUnliftIO m+     , MonadTracer m      , MonadReader app m+     , HasSqlPool app+     , HasStatsClient app      )   => SqlPersistT m a   -> m a runDB action = do   pool <- asks getSqlPool-  mVaultData <- asks getVaultData-  Stats.withGauge Stats.dbConnections $-    maybe-      runSqlPool-      (runSqlPoolXRay "runDB")-      mVaultData-      action-      pool+  mVaultData <- getVaultData+  Stats.withGauge Stats.dbConnections+    $ maybe runSqlPool (runSqlPoolXRay "runDB") mVaultData action pool  runDBSimple-  :: ( HasSqlPool app-     , MonadUnliftIO m-     , MonadReader app m-     )+  :: (HasSqlPool app, MonadUnliftIO m, MonadReader app m)   => SqlPersistT m a   -> m a runDBSimple action = do@@ -234,9 +221,6 @@  createAuroraIamToken :: MonadIO m => PostgresConnectionConf -> m AuroraIamToken createAuroraIamToken aitPostgresConnectionConf@PostgresConnectionConf {..} = do-  -- TODO: Consider recording how long creating an auth token takes-  -- somewhere, even if it is just in the logs, so we get an idea of how long-  -- it takes in prod.   aitToken <- T.strip . decodeUtf8 . BSL.toStrict <$> readProcessStdout_     (proc       "aws"

@@ -43,10 +43,9 @@     let examplePath = takeDirectory path </> ".env.example"     exampleExists <- doesFileExist examplePath -    void $ Dotenv.loadFile $ Dotenv.Config+    void $ Dotenv.loadFile $ Dotenv.defaultConfig       { Dotenv.configPath = [path]       , Dotenv.configExamplePath = [ examplePath | exampleExists ]-      , Dotenv.configOverride = False       }  locateInParents :: FilePath -> IO (Maybe FilePath)

@@ -10,7 +10,6 @@ import Data.Char (isControl, isSpace) import qualified Data.Text as T import Database.Memcache.Types (Key)-import GHC.Stack (HasCallStack) import UnliftIO.Exception (throwString)  newtype CacheKey = CacheKey Text

@@ -0,0 +1,19 @@+module Freckle.App.OpenTelemetry+  ( MonadTracer(..)+  ) where++import Freckle.App.Prelude++import Network.AWS.XRayClient.WAI (XRayVaultData, vaultDataFromRequest)+import Yesod.Core (HandlerFor, waiRequest)++-- | Class for reading 'XRayVaultData'+--+-- This is named the same as the OpenTelemetry class we'll use once we move to+-- that tracing system+--+class MonadTracer m where+  getVaultData :: m (Maybe XRayVaultData)++instance MonadTracer (HandlerFor app) where+  getVaultData = vaultDataFromRequest <$> waiRequest

@@ -1,13 +1,12 @@ -- | Those functions and types we can't do without! module Freckle.App.Prelude-  (-  -- * 'Prelude' as the starting point, without common partial functions-    module Prelude+  ( module Prelude    -- * Commonly imported types   , Alternative   , Exception   , Generic+  , HasCallStack   , HashMap   , HashSet   , Hashable@@ -100,9 +99,9 @@ import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.Primitive (PrimMonad) import Control.Monad.Reader (MonadReader, ReaderT)+import Data.Hashable (Hashable) import Data.HashMap.Strict (HashMap) import Data.HashSet (HashSet)-import Data.Hashable (Hashable) import Data.Int (Int64) import Data.List.NonEmpty (NonEmpty) import Data.Map.Strict (Map)@@ -111,6 +110,7 @@ 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) 

@@ -46,9 +46,11 @@ import Control.Monad.Trans.Control import Database.Persist.Sql (SqlPersistT, runSqlPool) import qualified Freckle.App.Dotenv as Dotenv+import Freckle.App.OpenTelemetry import qualified Test.Hspec as Hspec hiding (expectationFailure) import Test.Hspec.Core.Spec (Arg, Example, SpecWith, evaluateExample) import qualified Test.Hspec.Expectations.Lifted as Hspec (expectationFailure)+import qualified UnliftIO.Exception as UnliftIO  -- | An Hspec example over some @App@ value --@@ -85,6 +87,17 @@   withRunInIO inner =     AppExample $ withRunInIO $ \run -> inner (run . unAppExample) +instance MonadMask (AppExample app) where+  mask = UnliftIO.mask+  uninterruptibleMask = UnliftIO.uninterruptibleMask+  generalBracket acquire release use = mask $ \unmasked -> do+    resource <- acquire+    b <- unmasked (use resource) `UnliftIO.catch` \e -> do+      _ <- release resource (ExitCaseException e)+      throwM e+    c <- release resource (ExitCaseSuccess b)+    pure (b, c)+ instance MonadRandom (AppExample app) where   getRandomR = liftIO . getRandomR   getRandom = liftIO getRandom@@ -103,8 +116,8 @@     params     ($ ()) -instance HasVaultData app => HasVaultData (AppExample app a) where-  getVaultData = asks getVaultData+instance MonadTracer (AppExample app) where+  getVaultData = pure Nothing  -- | A type restricted version of id --

@@ -1,77 +1,31 @@ -- | Integration of "Freckle.App" tooling with "Network.Wai" module Freckle.App.Wai   ( noCacheMiddleware-  , corsMiddleware   , denyFrameEmbeddingMiddleware-  ) where -import Freckle.App.Prelude+  -- * CORS+  , corsMiddleware -import Data.ByteString (ByteString)-import qualified Data.ByteString as BS-import qualified Data.CaseInsensitive as CI-import Network.HTTP.Types (ResponseHeaders)-import Network.HTTP.Types.Status (status200)+  -- * Logs+  , requestLogger+  , addThreadContextFromRequest++  -- * Metrics+  , addThreadContextFromStatsTags+  , requestStats+  ) where+ import Network.Wai-import Network.Wai.Middleware.AddHeaders (addHeaders)+import Network.Wai.Middleware.AddHeaders+import Network.Wai.Middleware.Cors+import Network.Wai.Middleware.Logging+import Network.Wai.Middleware.Stats +-- | Middleware that adds header to disable all caching noCacheMiddleware :: Middleware-noCacheMiddleware = addHeaders [cacheControlHeader]- where-  cacheControlHeader =-    ("Cache-Control", "no-cache, no-store, max-age=0, private")--corsMiddleware-  :: (ByteString -> Bool)-  -- ^ Predicate that returns 'True' for valid @Origin@ values-  -> [ByteString]-  -- ^ Extra headers to add to @Expose-Headers@-  -> Middleware-corsMiddleware validateOrigin extraExposedHeaders =-  handleOptions validateOrigin extraExposedHeaders-    . addCORSHeaders validateOrigin extraExposedHeaders+noCacheMiddleware =+  addHeaders [("Cache-Control", "no-cache, no-store, max-age=0, private")]  -- | Middleware that adds header to deny all frame embedding denyFrameEmbeddingMiddleware :: Middleware denyFrameEmbeddingMiddleware = addHeaders [("X-Frame-Options", "DENY")]--handleOptions :: (ByteString -> Bool) -> [ByteString] -> Middleware-handleOptions validateOrigin extraExposedHeaders app req sendResponse =-  case (requestMethod req, lookup "Origin" (requestHeaders req)) of-    ("OPTIONS", Just origin) -> sendResponse $ responseLBS-      status200-      (toHeaders $ corsResponseHeaders validateOrigin extraExposedHeaders origin-      )-      mempty-    _ -> app req sendResponse- where-  toHeaders :: [(ByteString, ByteString)] -> ResponseHeaders-  toHeaders = map (first CI.mk)--addCORSHeaders :: (ByteString -> Bool) -> [ByteString] -> Middleware-addCORSHeaders validateOrigin extraExposedHeaders app req sendResponse =-  case lookup "Origin" (requestHeaders req) of-    Nothing -> app req sendResponse-    Just origin -> addHeaders-      (corsResponseHeaders validateOrigin extraExposedHeaders origin)-      app-      req-      sendResponse--corsResponseHeaders-  :: (ByteString -> Bool)-  -> [ByteString]-  -> ByteString-  -> [(ByteString, ByteString)]-corsResponseHeaders validateOrigin extraExposedHeaders origin =-  [ ("Access-Control-Allow-Origin", validatedOrigin)-  , ("Access-Control-Allow-Methods", "POST, GET, OPTIONS, PUT, DELETE, PATCH")-  , ("Access-Control-Allow-Credentials", "true")-  , ("Access-Control-Allow-Headers", "Content-Type, *")-  , ("Access-Control-Expose-Headers", BS.intercalate ", " exposedHeaders)-  ]- where-  validatedOrigin = if validateOrigin origin then origin else "BADORIGIN"--  exposedHeaders =-    ["Set-Cookie", "Content-Disposition", "Link"] <> extraExposedHeaders

@@ -0,0 +1,65 @@+-- | TODO: Can we use <https://hackage.haskell.org/package/wai-cors> instead?+module Network.Wai.Middleware.Cors+  ( corsMiddleware+  ) where++import Freckle.App.Prelude++import Data.ByteString (ByteString)+import qualified Data.ByteString as BS+import qualified Data.CaseInsensitive as CI+import Network.HTTP.Types (ResponseHeaders)+import Network.HTTP.Types.Status (status200)+import Network.Wai+import Network.Wai.Middleware.AddHeaders++corsMiddleware+  :: (ByteString -> Bool)+  -- ^ Predicate that returns 'True' for valid @Origin@ values+  -> [ByteString]+  -- ^ Extra headers to add to @Expose-Headers@+  -> Middleware+corsMiddleware validateOrigin extraExposedHeaders =+  handleOptions validateOrigin extraExposedHeaders+    . addCORSHeaders validateOrigin extraExposedHeaders++handleOptions :: (ByteString -> Bool) -> [ByteString] -> Middleware+handleOptions validateOrigin extraExposedHeaders app req sendResponse =+  case (requestMethod req, lookup "Origin" (requestHeaders req)) of+    ("OPTIONS", Just origin) -> sendResponse $ responseLBS+      status200+      (toHeaders $ corsResponseHeaders validateOrigin extraExposedHeaders origin+      )+      mempty+    _ -> app req sendResponse+ where+  toHeaders :: [(ByteString, ByteString)] -> ResponseHeaders+  toHeaders = map (first CI.mk)++addCORSHeaders :: (ByteString -> Bool) -> [ByteString] -> Middleware+addCORSHeaders validateOrigin extraExposedHeaders app req sendResponse =+  case lookup "Origin" (requestHeaders req) of+    Nothing -> app req sendResponse+    Just origin -> addHeaders+      (corsResponseHeaders validateOrigin extraExposedHeaders origin)+      app+      req+      sendResponse++corsResponseHeaders+  :: (ByteString -> Bool)+  -> [ByteString]+  -> ByteString+  -> [(ByteString, ByteString)]+corsResponseHeaders validateOrigin extraExposedHeaders origin =+  [ ("Access-Control-Allow-Origin", validatedOrigin)+  , ("Access-Control-Allow-Methods", "POST, GET, OPTIONS, PUT, DELETE, PATCH")+  , ("Access-Control-Allow-Credentials", "true")+  , ("Access-Control-Allow-Headers", "Content-Type, *")+  , ("Access-Control-Expose-Headers", BS.intercalate ", " exposedHeaders)+  ]+ where+  validatedOrigin = if validateOrigin origin then origin else "BADORIGIN"++  exposedHeaders =+    ["Set-Cookie", "Content-Disposition", "Link"] <> extraExposedHeaders

@@ -1,15 +1,30 @@ module Network.Wai.Middleware.Stats-  ( requestStats+  ( addThreadContextFromStatsTags+  , requestStats   ) where  import Freckle.App.Prelude +import Blammo.Logging (Pair, withThreadContext)+import Control.Lens ((^.)) import Control.Monad.Reader (runReaderT)-import Freckle.App.Stats (HasStatsClient)+import Data.Aeson ((.=))+import qualified Freckle.App.Aeson as Key+import Freckle.App.Stats (HasStatsClient(..), tagsL) import qualified Freckle.App.Stats as Stats import Network.HTTP.Types.Status (Status(..)) import Network.Wai (Middleware, Request, requestMethod, responseStatus) +-- | Add any tags in the ambient 'StatsClient' to the logging context+addThreadContextFromStatsTags :: HasStatsClient env => env -> Middleware+addThreadContextFromStatsTags env app req respond = do+  let context = uncurry fromTag <$> env ^. statsClientL . tagsL+  withThreadContext context $ app req respond+ where+  fromTag :: Text -> Text -> Pair+  fromTag k v = Key.fromText k .= v++-- | Emit @requests@ and @response_time_ms@ metrics requestStats   :: HasStatsClient env => env -> (Request -> [(Text, Text)]) -> Middleware requestStats env getTags app req respond = do

@@ -1,6 +1,5 @@---- name: freckle-app-version: 1.8.1.0+version: 1.9.0.0 maintainer: Freckle Education category: Utils github: freckle/freckle-app@@ -14,6 +13,29 @@ extra-source-files:   - package.yaml +ghc-options:+  - -fignore-optim-changes+  - -Weverything+  - -Wno-all-missed-specialisations+  - -Wno-missing-exported-signatures # re-enables missing-signatures+  - -Wno-missing-import-lists+  - -Wno-missing-local-signatures+  - -Wno-monomorphism-restriction+  - -Wno-safe+  - -Wno-unsafe++when:+  - condition: "impl(ghc >= 9.2)"+    ghc-options:+      - -Wno-missing-kind-signatures+  - condition: "impl(ghc >= 8.10)"+    ghc-options:+      - -Wno-missing-safe-haskell-mode+      - -Wno-prepositive-qualified-module+  - condition: "impl(ghc >= 8.8)"+    ghc-options:+      - -fwrite-ide-info+ dependencies:   - base < 5 @@ -90,6 +112,7 @@     - persistent-postgresql     - postgresql-simple     - primitive+    - resourcet     - resource-pool     - retry >= 0.8.1.0 # retryingDynamic     - safe

@@ -1,1 +1,1 @@-{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --module-name=Spec #-}+{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --module-name=Spec -Wno-missing-export-lists #-}