diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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) diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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. --- 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.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 diff --git a/library/Freckle/App.hs b/library/Freckle/App.hs --- a/library/Freckle/App.hs +++ b/library/Freckle/App.hs @@ -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 diff --git a/library/Freckle/App/Aeson.hs b/library/Freckle/App/Aeson.hs --- a/library/Freckle/App/Aeson.hs +++ b/library/Freckle/App/Aeson.hs @@ -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) #-} 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 @@ -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" diff --git a/library/Freckle/App/Dotenv.hs b/library/Freckle/App/Dotenv.hs --- a/library/Freckle/App/Dotenv.hs +++ b/library/Freckle/App/Dotenv.hs @@ -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) 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,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 diff --git a/library/Freckle/App/OpenTelemetry.hs b/library/Freckle/App/OpenTelemetry.hs new file mode 100644 --- /dev/null +++ b/library/Freckle/App/OpenTelemetry.hs @@ -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 diff --git a/library/Freckle/App/Prelude.hs b/library/Freckle/App/Prelude.hs --- a/library/Freckle/App/Prelude.hs +++ b/library/Freckle/App/Prelude.hs @@ -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) diff --git a/library/Freckle/App/Test.hs b/library/Freckle/App/Test.hs --- a/library/Freckle/App/Test.hs +++ b/library/Freckle/App/Test.hs @@ -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 -- diff --git a/library/Freckle/App/Wai.hs b/library/Freckle/App/Wai.hs --- a/library/Freckle/App/Wai.hs +++ b/library/Freckle/App/Wai.hs @@ -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 diff --git a/library/Network/Wai/Middleware/Cors.hs b/library/Network/Wai/Middleware/Cors.hs new file mode 100644 --- /dev/null +++ b/library/Network/Wai/Middleware/Cors.hs @@ -0,0 +1,65 @@ +-- | TODO: Can we use 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 diff --git a/library/Network/Wai/Middleware/Stats.hs b/library/Network/Wai/Middleware/Stats.hs --- a/library/Network/Wai/Middleware/Stats.hs +++ b/library/Network/Wai/Middleware/Stats.hs @@ -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 diff --git a/package.yaml b/package.yaml --- a/package.yaml +++ b/package.yaml @@ -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 diff --git a/tests/Spec.hs b/tests/Spec.hs --- a/tests/Spec.hs +++ b/tests/Spec.hs @@ -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 #-}