freckle-app 1.9.0.3 → 1.9.1.0
raw patch · 46 files changed
+837/−642 lines, 46 filesdep +hw-kafka-client
Dependencies added: hw-kafka-client
Files
- CHANGELOG.md +5/−1
- freckle-app.cabal +3/−1
- library/Freckle/App.hs +7/−9
- library/Freckle/App/Aeson.hs +0/−1
- library/Freckle/App/Bugsnag.hs +50/−46
- library/Freckle/App/Bugsnag/MetaData.hs +9/−14
- library/Freckle/App/Csv.hs +41/−32
- library/Freckle/App/Database.hs +80/−70
- library/Freckle/App/Dotenv.hs +6/−5
- library/Freckle/App/Ecs.hs +21/−19
- library/Freckle/App/Env.hs +10/−15
- library/Freckle/App/GlobalCache.hs +2/−3
- library/Freckle/App/Http.hs +29/−34
- library/Freckle/App/Http/Paginate.hs +0/−2
- library/Freckle/App/Http/Retry.hs +24/−21
- library/Freckle/App/Kafka.hs +129/−0
- library/Freckle/App/Memcached.hs +11/−12
- library/Freckle/App/Memcached/CacheKey.hs +1/−2
- library/Freckle/App/Memcached/CacheTTL.hs +1/−1
- library/Freckle/App/Memcached/Client.hs +7/−5
- library/Freckle/App/Memcached/Servers.hs +10/−10
- library/Freckle/App/OpenTelemetry.hs +1/−2
- library/Freckle/App/Prelude.hs +36/−18
- library/Freckle/App/Scientist.hs +6/−7
- library/Freckle/App/Stats.hs +59/−58
- library/Freckle/App/Stats/Rts.hs +0/−1
- library/Freckle/App/Test.hs +13/−15
- library/Freckle/App/Test/DocTest.hs +4/−5
- library/Freckle/App/Test/Hspec/Runner.hs +24/−15
- library/Freckle/App/Wai.hs +3/−3
- library/Freckle/App/Yesod.hs +1/−2
- library/Freckle/App/Yesod/Routes.hs +12/−14
- library/Network/HTTP/Link/Compat.hs +6/−5
- library/Network/Wai/Middleware/Cors.hs +13/−10
- library/Network/Wai/Middleware/Stats.hs +7/−8
- library/Yesod/Core/Lens.hs +2/−2
- package.yaml +2/−1
- tests/Freckle/App/Bugsnag/MetaDataSpec.hs +32/−29
- tests/Freckle/App/BugsnagSpec.hs +69/−61
- tests/Freckle/App/CsvSpec.hs +38/−34
- tests/Freckle/App/HttpSpec.hs +16/−15
- tests/Freckle/App/Memcached/ServersSpec.hs +4/−4
- tests/Freckle/App/MemcachedSpec.hs +15/−12
- tests/Freckle/App/Test/Properties/JSONSpec.hs +3/−3
- tests/Freckle/App/Test/Properties/PathPieceSpec.hs +3/−3
- tests/Freckle/App/WaiSpec.hs +22/−12
CHANGELOG.md view
@@ -1,4 +1,8 @@-## [_Unreleased_](https://github.com/freckle/freckle-app/compare/v1.9.0.3...main)+## [_Unreleased_](https://github.com/freckle/freckle-app/compare/v1.9.1.0...main)++## [v1.9.1.0](https://github.com/freckle/freckle-app/compare/v1.9.0.3...v1.9.1.0)++- Add `Freckle.App.Kafka` for producing kafka events ## [v1.9.0.3](https://github.com/freckle/freckle-app/compare/v1.9.0.2...v1.9.0.3)
freckle-app.cabal view
@@ -1,6 +1,6 @@ cabal-version: 1.18 name: freckle-app-version: 1.9.0.3+version: 1.9.1.0 license: MIT license-file: LICENSE maintainer: Freckle Education@@ -36,6 +36,7 @@ Freckle.App.Http Freckle.App.Http.Paginate Freckle.App.Http.Retry+ Freckle.App.Kafka Freckle.App.Memcached Freckle.App.Memcached.CacheKey Freckle.App.Memcached.CacheTTL@@ -110,6 +111,7 @@ http-conduit >=2.3.5, http-link-header, http-types,+ hw-kafka-client, immortal, lens, memcache,
library/Freckle/App.hs view
@@ -153,16 +153,15 @@ -- > it "works" $ do -- > result <- runDB myQuery :: AppExample App Text -- > result `shouldBe` "as expected"--- module Freckle.App ( runApp , setLineBuffering - -- * Concrete transformer stack- , AppT(..)+ -- * Concrete transformer stack+ , AppT (..) , runAppT - -- * Re-exports+ -- * Re-exports , module Freckle.App.Database , module Freckle.App.OpenTelemetry , module Blammo.Logging@@ -173,17 +172,17 @@ import Blammo.Logging import Control.Monad.Catch (MonadCatch, MonadThrow)-import Control.Monad.IO.Unlift (MonadUnliftIO(..))-import Control.Monad.Primitive (PrimMonad(..))+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)+import System.IO (BufferMode (..), hSetBuffering, stderr, stdout) runApp :: HasLogger app- => (forall b . (app -> IO b) -> IO b)+ => (forall b. (app -> IO b) -> IO b) -> AppT app IO a -> IO a runApp loadApp action = do@@ -194,7 +193,6 @@ -- -- '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
library/Freckle/App/Aeson.hs view
@@ -5,7 +5,6 @@ -- 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 ) where
library/Freckle/App/Bugsnag.hs view
@@ -1,20 +1,20 @@ module Freckle.App.Bugsnag ( Settings- , HasBugsnagSettings(..)+ , HasBugsnagSettings (..) , notifyBugsnag , notifyBugsnagWith - -- * 'AppVersion'- , HasAppVersion(..)+ -- * 'AppVersion'+ , HasAppVersion (..) , setAppVersion - -- * Loading settings+ -- * Loading settings , envParseBugsnagSettings - -- * Exported for testing+ -- * Exported for testing , sqlErrorGroupingHash - -- * Re-exports+ -- * Re-exports , MonadReader , runReaderT , module Network.Bugsnag@@ -29,12 +29,12 @@ import Data.Bugsnag.Settings import qualified Data.ByteString.Char8 as BS8 import Data.List (isInfixOf)-import Database.PostgreSQL.Simple (SqlError(..))+import Database.PostgreSQL.Simple (SqlError (..)) import Database.PostgreSQL.Simple.Errors import qualified Freckle.App.Env as Env import Network.Bugsnag hiding (notifyBugsnag, notifyBugsnagWith) import qualified Network.Bugsnag as Bugsnag-import Network.HTTP.Client (HttpException(..), host, method)+import Network.HTTP.Client (HttpException (..), host, method) import qualified UnliftIO.Exception as Exception import Yesod.Core.Lens import Yesod.Core.Types (HandlerData)@@ -42,14 +42,16 @@ class HasAppVersion env where appVersionL :: Lens' env Text -instance HasAppVersion site => HasAppVersion (HandlerData child site) where+instance HasAppVersion site => HasAppVersion (HandlerData child site) where appVersionL = envL . siteL . appVersionL setAppVersion :: Text -> BeforeNotify-setAppVersion version = updateEvent $ \event -> event- { event_app = Just $ updateApp $ fromMaybe defaultApp $ event_app event- }- where updateApp app = app { app_version = Just version }+setAppVersion version = updateEvent $ \event ->+ event+ { event_app = Just $ updateApp $ fromMaybe defaultApp $ event_app event+ }+ where+ updateApp app = app {app_version = Just version} class HasBugsnagSettings env where bugsnagSettingsL :: Lens' env Settings@@ -57,14 +59,13 @@ instance HasBugsnagSettings Settings where bugsnagSettingsL = id -instance HasBugsnagSettings site => HasBugsnagSettings (HandlerData child site) where+instance HasBugsnagSettings site => HasBugsnagSettings (HandlerData child site) where bugsnagSettingsL = envL . siteL . bugsnagSettingsL -- | Notify Bugsnag of an exception -- -- The notification is made asynchronously via a simple @'forkIO'@. This is -- best-effort and we don't care to keep track of the spawned threads.--- notifyBugsnag :: ( MonadIO m , MonadReader env m@@ -93,18 +94,19 @@ asSqlError err@SqlError {..} = toSqlGrouping <> toSqlException where toSqlGrouping = maybe mempty setGroupingHash (sqlErrorGroupingHash err)- toSqlException = updateExceptions $ \ex -> ex- { exception_errorClass = decodeUtf8 $ "SqlError-" <> sqlState- , exception_message =- Just- $ decodeUtf8- $ sqlErrorMsg- <> ": "- <> sqlErrorDetail- <> " ("- <> sqlErrorHint- <> ")"- }+ toSqlException = updateExceptions $ \ex ->+ ex+ { exception_errorClass = decodeUtf8 $ "SqlError-" <> sqlState+ , exception_message =+ Just $+ decodeUtf8 $+ sqlErrorMsg+ <> ": "+ <> sqlErrorDetail+ <> " ("+ <> sqlErrorHint+ <> ")"+ } sqlErrorGroupingHash :: SqlError -> Maybe Text sqlErrorGroupingHash err = do@@ -118,27 +120,28 @@ asHttpException (HttpExceptionRequest req content) = setGroupingHash (decodeUtf8 $ host req) <> update where- update = updateExceptions $ \ex -> ex- { exception_errorClass = "HttpExceptionRequest"- , exception_message =- Just- . decodeUtf8- $ method req- <> " request to "- <> host req- <> " failed: "- <> BS8.pack (show content)+ update = updateExceptions $ \ex ->+ ex+ { exception_errorClass = "HttpExceptionRequest"+ , exception_message =+ Just+ . decodeUtf8+ $ method req+ <> " request to "+ <> host req+ <> " failed: "+ <> BS8.pack (show content)+ }+asHttpException (InvalidUrlException url msg) = updateExceptions $ \ex ->+ ex+ { exception_errorClass = "InvalidUrlException"+ , exception_message = Just $ pack $ url <> " is invalid: " <> msg }-asHttpException (InvalidUrlException url msg) = updateExceptions $ \ex -> ex- { exception_errorClass = "InvalidUrlException"- , exception_message = Just $ pack $ url <> " is invalid: " <> msg- } -- | Set StackFrame's InProject to @'False'@ for Error Helper modules -- -- We want exceptions grouped by the the first stack-frame that is /not/ them. -- Marking them as not in-project does this, with little downside.--- maskErrorHelpers :: BeforeNotify maskErrorHelpers = setStackFramesInProjectByFile (`isInfixOf` "Exceptions") @@ -150,10 +153,11 @@ <$> Env.var Env.nonempty "BUGSNAG_API_KEY" mempty <*> Env.var Env.nonempty "BUGSNAG_RELEASE_STAGE" (Env.def "development") where- build key stage = (defaultSettings key)- { settings_releaseStage = stage- , settings_beforeNotify = globalBeforeNotify- }+ build key stage =+ (defaultSettings key)+ { settings_releaseStage = stage+ , settings_beforeNotify = globalBeforeNotify+ } globalBeforeNotify :: BeforeNotify globalBeforeNotify =
library/Freckle/App/Bugsnag/MetaData.hs view
@@ -1,18 +1,15 @@ -- | Working with Bugsnag's 'event_metaData' field------ $details--- module Freckle.App.Bugsnag.MetaData- ( MetaData(..)+ ( MetaData (..) , metaData , metaDataL - -- * Collecting ambient data+ -- * Collecting ambient data , collectMetaData , collectMetaDataFromStatsClient , collectMetaDataFromThreadContext - -- * 'BeforeNotify'+ -- * 'BeforeNotify' , mergeMetaData ) where @@ -21,11 +18,11 @@ import Blammo.Logging (Pair, myThreadContext) import Control.Lens (Lens', lens, to, view, (<>~)) import Data.Aeson-import Data.Bugsnag (Event(..))+import Data.Bugsnag (Event (..)) import Data.String (fromString) import qualified Freckle.App.Aeson as Aeson import Freckle.App.Bugsnag-import Freckle.App.Stats (HasStatsClient(..), tagsL)+import Freckle.App.Stats (HasStatsClient (..), tagsL) newtype MetaData = MetaData { unMetaData :: Object@@ -33,11 +30,10 @@ deriving stock (Eq, Show) instance Semigroup MetaData where- -- | /Right/-biased, recursive union+ -- \| /Right/-biased, recursive union -- -- The chosen bias ensures that adding metadata in smaller scopes (later) -- overrides values from larger scopes.- -- MetaData x <> MetaData y = MetaData $ unionObjects y x where unionObjects :: Object -> Object -> Object@@ -62,13 +58,12 @@ metaDataL = lens get set where get event = maybe mempty MetaData $ event_metaData event- set event md = event { event_metaData = Just $ unMetaData md }+ set event md = event {event_metaData = Just $ unMetaData md} -- | Collect 'MetaData' from a 'StatsClient' and 'myThreadContext' -- -- Using this (and then 'mergeMetaData') will unify exception metadata with -- metrics tags and the logging context.--- collectMetaData :: (MonadIO m, MonadReader env m, HasStatsClient env) => m MetaData collectMetaData =@@ -77,7 +72,8 @@ collectMetaDataFromStatsClient :: (MonadReader env m, HasStatsClient env) => m MetaData collectMetaDataFromStatsClient = view $ statsClientL . tagsL . to toMetaData- where toMetaData = metaData "tags" . map (bimap (fromString . unpack) String)+ where+ toMetaData = metaData "tags" . map (bimap (fromString . unpack) String) collectMetaDataFromThreadContext :: MonadIO m => m MetaData collectMetaDataFromThreadContext =@@ -87,7 +83,6 @@ -- -- The given metadata will be combined with what already exists using '(<>)', -- preserving the incoming values on collisions.--- mergeMetaData :: MetaData -> BeforeNotify mergeMetaData md = updateEvent $ metaDataL <>~ md
library/Freckle/App/Csv.hs view
@@ -4,21 +4,24 @@ -- -- A minor extension of [cassava](https://hackage.haskell.org/package/cassava). -- Using `MonadValidate` and `Conduit`.--- module Freckle.App.Csv ( csvWithValidationSink , csvWithParserAndValidationSink- -- * Conduit Primitives++ -- * Conduit Primitives , runCsvConduit , decodeCsv- -- * Header Validation++ -- * Header Validation , ValidateHeader , validateHeader , hasHeader , defaultValidateOrderedHeader- -- * Exceptions- , CsvException(..)- -- * Options++ -- * Exceptions+ , CsvException (..)++ -- * Options , defaultOptions ) where @@ -27,15 +30,21 @@ import Conduit import Control.Monad (foldM) import Control.Monad.Validate- (MonadValidate(..), Validate, ValidateT, refute, runValidate, runValidateT)-import Data.Aeson (KeyValue(..), ToJSON(..), object, pairs, (.=))+ ( MonadValidate (..)+ , Validate+ , ValidateT+ , refute+ , runValidate+ , runValidateT+ )+import Data.Aeson (KeyValue (..), ToJSON (..), object, pairs, (.=)) import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as BS8 import qualified Data.Conduit.Combinators as Conduit import qualified Data.Conduit.Text as Conduit import Data.Csv ( DefaultOrdered- , FromNamedRecord(..)+ , FromNamedRecord (..) , Header , Name , NamedRecord@@ -48,7 +57,7 @@ import Data.Functor.Bind (Bind) import qualified Data.HashMap.Strict as HashMap import qualified Data.List.NonEmpty as NE-import Data.Proxy (Proxy(Proxy))+import Data.Proxy (Proxy (Proxy)) import Data.Sequence (Seq) import qualified Data.Sequence as Seq import Data.Sequence.NonEmpty (NESeq)@@ -60,12 +69,12 @@ -- | Treat CSV header line as 1 -- -- CSVs can break rows over lines, but we don't currently handle that.--- headerLineNumber :: Int headerLineNumber = 1 class ValidateHeader a where- validateHeader :: (Bind m, Monad m) => proxy a -> Header -> ValidateT (NESeq String) m ()+ validateHeader+ :: (Bind m, Monad m) => proxy a -> Header -> ValidateT (NESeq String) m () hasHeader :: Monad m => Header -> Name -> ValidateT (NESeq String) m () hasHeader h name@@ -85,7 +94,6 @@ -- -- - Expects UTF-8 -- - Provides incremental validation--- csvWithValidationSink :: forall a b err m . ( MonadThrow m@@ -106,7 +114,6 @@ -- -- - Expects UTF-8 -- - Provides incremental validation--- csvWithParserAndValidationSink :: forall a b err m . (MonadThrow m, MonadUnliftIO m, PrimMonad m)@@ -120,10 +127,10 @@ -> m (Validate (NonEmpty (CsvException err)) (Vector b)) csvWithParserAndValidationSink headerValidator p source validation = do validatedCsv <-- runCsvConduit- $ transPipe lift source- .| decodeCsvWithP headerValidator p- .| transPipe lift sinkVector+ runCsvConduit $+ transPipe lift source+ .| decodeCsvWithP headerValidator p+ .| transPipe lift sinkVector pure $ case validatedCsv of Left errs -> refute $ NE.fromList $ toList errs@@ -153,7 +160,6 @@ -- | Stream in 'ByteString's and parse records in constant space with a custom -- record parser--- decodeCsvWithP :: forall a m err . (MonadThrow m, MonadValidate (Seq (CsvException err)) m)@@ -168,21 +174,22 @@ parseCsv :: forall a m err- . (MonadValidate (Seq (CsvException err)) m)+ . MonadValidate (Seq (CsvException err)) m => (Header -> Validate (NESeq String) ()) -> (NamedRecord -> Parser a) -> ConduitT ByteString a m ()-parseCsv headerValidator p = parseHeader- headerValidator- (CsvI.decodeByNameWithP (stripParser p) defaultDecodeOptions)+parseCsv headerValidator p =+ parseHeader+ headerValidator+ (CsvI.decodeByNameWithP (stripParser p) defaultDecodeOptions) data CsvException a = CsvMissingColumn !Text | CsvParseException !Int !Text | CsvFileNotFound | CsvUnknownFileEncoding- | CsvExceptionExtension a- -- ^ A constructor for providing extensible csv exceptions+ | -- | A constructor for providing extensible csv exceptions+ CsvExceptionExtension a deriving stock (Eq, Show) instance ToJSON a => ToJSON (CsvException a) where@@ -192,10 +199,11 @@ csvExceptionPairs :: KeyValue kv => ([kv] -> r) -> (a -> r) -> CsvException a -> r csvExceptionPairs done extend = \case- CsvMissingColumn column -> done- [ "message" .= ("Missing column " <> tshow column)- , "missingColumn" .= column- ]+ CsvMissingColumn column ->+ done+ [ "message" .= ("Missing column " <> tshow column)+ , "missingColumn" .= column+ ] CsvParseException rowNumber message -> done ["rowNumber" .= rowNumber, "message" .= message] CsvFileNotFound -> done ["message" .= ("file not found" :: Text)]@@ -205,7 +213,7 @@ parseHeader :: forall a m err- . (MonadValidate (Seq (CsvException err)) m)+ . MonadValidate (Seq (CsvException err)) m => (Header -> Validate (NESeq String) ()) -> CsvI.HeaderParser (CsvI.Parser a) -> ConduitT ByteString a m ()@@ -216,7 +224,7 @@ await >>= (parseHeader headerValidator . k) . fromMaybe mempty CsvI.DoneH header parser -> case runValidate $ headerValidator $ fmap stripUtf8 header of- Right{} -> parseRow (succ headerLineNumber) parser+ Right {} -> parseRow (succ headerLineNumber) parser Left errs -> lift $ refute $ Seq.fromList $ CsvMissingColumn . pack <$> toList errs @@ -232,7 +240,8 @@ !newRowNumber <- handleRows rows await >>= parseRow newRowNumber . k . fromMaybe mempty CsvI.Done rows -> void $ handleRows rows- where handleRows = foldM handleRow rowNumber+ where+ handleRows = foldM handleRow rowNumber handleRow :: MonadValidate (Seq (CsvException err)) m
library/Freckle/App/Database.hs view
@@ -4,16 +4,16 @@ -- | Database access for your @App@ module Freckle.App.Database- ( HasSqlPool(..)+ ( HasSqlPool (..) , SqlPool , makePostgresPool , makePostgresPoolWith , runDB , runDBSimple- , PostgresConnectionConf(..)- , PostgresPasswordSource(..)- , PostgresPassword(..)- , PostgresStatementTimeout(..)+ , PostgresConnectionConf (..)+ , PostgresPasswordSource (..)+ , PostgresPassword (..)+ , PostgresStatementTimeout (..) , postgresStatementTimeoutMilliseconds , envParseDatabaseConf , envPostgresPasswordSource@@ -23,7 +23,7 @@ import Blammo.Logging import qualified Control.Immortal as Immortal-import Control.Monad.IO.Unlift (MonadUnliftIO(..))+import Control.Monad.IO.Unlift (MonadUnliftIO (..)) import Control.Monad.Reader import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as BS8@@ -41,20 +41,24 @@ , runSqlPool ) import Database.PostgreSQL.Simple- (Connection, Only(..), connectPostgreSQL, execute)+ ( 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.OpenTelemetry (MonadTracer (..)) import Freckle.App.Stats (HasStatsClient) import qualified Freckle.App.Stats as Stats import Network.AWS.XRayClient.Persistent import Network.AWS.XRayClient.WAI-import qualified Prelude as Unsafe (read) import System.Process.Typed (proc, readProcessStdout_) import UnliftIO.Concurrent (threadDelay) import UnliftIO.Exception (displayException) import UnliftIO.IORef-import Yesod.Core.Types (HandlerData(..), RunHandlerEnv(..))+import Yesod.Core.Types (HandlerData (..), RunHandlerEnv (..))+import qualified Prelude as Unsafe (read) type SqlPool = Pool SqlBackend @@ -87,8 +91,8 @@ runDB action = do pool <- asks getSqlPool mVaultData <- getVaultData- Stats.withGauge Stats.dbConnections- $ maybe runSqlPool (runSqlPoolXRay "runDB") mVaultData action pool+ Stats.withGauge Stats.dbConnections $+ maybe runSqlPool (runSqlPoolXRay "runDB") mVaultData action pool runDBSimple :: (HasSqlPool app, MonadUnliftIO m, MonadReader app m)@@ -106,21 +110,22 @@ -- -- The top-level subsegment will be named @\"<this> runSqlPool\"@ and the, -- with a lower-level subsegment named @\"<this> query\"@.- --- -> XRayVaultData -- ^ Vault data to trace with+ -> XRayVaultData+ -- ^ Vault data to trace with -> ReaderT backend m a -> Pool backend -> m a runSqlPoolXRay name vaultData action pool =- traceXRaySubsegment' vaultData (name <> " runSqlPool") id- $ withRunInIO- $ \run -> withResource pool $ \backend -> do+ traceXRaySubsegment' vaultData (name <> " runSqlPool") id $+ withRunInIO $+ \run -> withResource pool $ \backend -> do let sendTrace = atomicallyAddVaultDataSubsegment vaultData stdGenIORef = xrayVaultDataStdGen vaultData subsegmentName = name <> " query"- run . runSqlConn action =<< liftIO- (xraySqlBackend sendTrace stdGenIORef subsegmentName backend)+ run . runSqlConn action+ =<< liftIO+ (xraySqlBackend sendTrace stdGenIORef subsegmentName backend) data PostgresConnectionConf = PostgresConnectionConf { pccHost :: String@@ -170,7 +175,6 @@ -- -- >>> readPostgresStatementTimeout "2m0" -- Left "..."--- readPostgresStatementTimeout :: String -> Either String PostgresStatementTimeout readPostgresStatementTimeout x = case span isDigit x of@@ -182,11 +186,12 @@ _ -> Left "must be {digits}(s|ms)" envPostgresPasswordSource :: Env.Parser Env.Error PostgresPasswordSource-envPostgresPasswordSource = Env.flag- (Env.Off PostgresPasswordSourceEnv)- (Env.On PostgresPasswordSourceIamAuth)- "USE_RDS_IAM_AUTH"- mempty+envPostgresPasswordSource =+ Env.flag+ (Env.Off PostgresPasswordSourceEnv)+ (Env.On PostgresPasswordSourceIamAuth)+ "USE_RDS_IAM_AUTH"+ mempty envParseDatabaseConf :: PostgresPasswordSource -> Env.Parser Env.Error PostgresConnectionConf@@ -202,18 +207,19 @@ poolSize <- Env.var Env.auto "PGPOOLSIZE" $ Env.def 10 schema <- optional $ Env.var Env.nonempty "PGSCHEMA" mempty statementTimeout <-- Env.var (Env.eitherReader readPostgresStatementTimeout) "PGSTATEMENTTIMEOUT"- $ Env.def (PostgresStatementTimeoutSeconds 120)- pure PostgresConnectionConf- { pccHost = host- , pccPort = port- , pccUser = user- , pccPassword = password- , pccDatabase = database- , pccPoolSize = poolSize- , pccStatementTimeout = statementTimeout- , pccSchema = schema- }+ Env.var (Env.eitherReader readPostgresStatementTimeout) "PGSTATEMENTTIMEOUT" $+ Env.def (PostgresStatementTimeoutSeconds 120)+ pure+ PostgresConnectionConf+ { pccHost = host+ , pccPort = port+ , pccUser = user+ , pccPassword = password+ , pccDatabase = database+ , pccPoolSize = poolSize+ , pccStatementTimeout = statementTimeout+ , pccSchema = schema+ } data AuroraIamToken = AuroraIamToken { aitToken :: Text@@ -224,27 +230,28 @@ createAuroraIamToken :: MonadIO m => PostgresConnectionConf -> m AuroraIamToken createAuroraIamToken aitPostgresConnectionConf@PostgresConnectionConf {..} = do- aitToken <- T.strip . decodeUtf8 . BSL.toStrict <$> readProcessStdout_- (proc- "aws"- [ "rds"- , "generate-db-auth-token"- , "--hostname"- , pccHost- , "--port"- , show pccPort- , "--username"- , pccUser- ]- )+ aitToken <-+ T.strip . decodeUtf8 . BSL.toStrict+ <$> readProcessStdout_+ ( proc+ "aws"+ [ "rds"+ , "generate-db-auth-token"+ , "--hostname"+ , pccHost+ , "--port"+ , show pccPort+ , "--username"+ , pccUser+ ]+ ) aitCreatedAt <- liftIO getCurrentTime- pure AuroraIamToken { .. }+ pure AuroraIamToken {..} -- | Spawns a thread that refreshes the IAM auth token every minute -- -- The IAM auth token lasts 15 minutes, but we refresh it every minute just to -- be super safe.--- spawnIamTokenRefreshThread :: (MonadUnliftIO m, MonadLogger m) => PostgresConnectionConf@@ -262,9 +269,9 @@ onFinishCallback = \case Left ex ->- logError- $ "Error refreshing IAM auth token"- :# ["exception" .= displayException ex]+ logError $+ "Error refreshing IAM auth token"+ :# ["exception" .= displayException ex] Right () -> pure () refreshIamToken@@ -277,20 +284,22 @@ setStartupOptions PostgresConnectionConf {..} conn = do let timeoutMillis = postgresStatementTimeoutMilliseconds pccStatementTimeout liftIO $ do- void $ execute- conn- [sql| SET statement_timeout = ? |]- (Only timeoutMillis)+ void $+ execute+ conn+ [sql| SET statement_timeout = ? |]+ (Only timeoutMillis) for_ pccSchema $ \schema -> execute conn [sql| SET search_path TO ? |] (Only schema) makePostgresPoolWith :: (MonadUnliftIO m, MonadLoggerIO m) => PostgresConnectionConf -> m SqlPool makePostgresPoolWith conf@PostgresConnectionConf {..} = case pccPassword of PostgresPasswordIamAuth -> makePostgresPoolWithIamAuth conf- PostgresPasswordStatic password -> createPostgresqlPoolModified- (setStartupOptions conf)- (postgresConnectionString conf password)- pccPoolSize+ PostgresPasswordStatic password ->+ createPostgresqlPoolModified+ (setStartupOptions conf)+ (postgresConnectionString conf password)+ pccPoolSize -- | Creates a PostgreSQL pool using IAM auth for the password makePostgresPoolWithIamAuth@@ -308,10 +317,11 @@ postgresConnectionString :: PostgresConnectionConf -> String -> ByteString postgresConnectionString PostgresConnectionConf {..} password =- BS8.pack $ unwords- [ "host=" <> pccHost- , "port=" <> show pccPort- , "user=" <> pccUser- , "password=" <> password- , "dbname=" <> pccDatabase- ]+ BS8.pack $+ unwords+ [ "host=" <> pccHost+ , "port=" <> show pccPort+ , "user=" <> pccUser+ , "password=" <> password+ , "dbname=" <> pccDatabase+ ]
library/Freckle/App/Dotenv.hs view
@@ -35,7 +35,6 @@ -- have a @.env(.test)@ file (such as this one!). -- -- 3. Use the @.env.example@ feature, but only if one exists alongside--- loadFile :: FilePath -> IO () loadFile = traverse_ go <=< locateInParents where@@ -43,10 +42,12 @@ let examplePath = takeDirectory path </> ".env.example" exampleExists <- doesFileExist examplePath - void $ Dotenv.loadFile $ Dotenv.defaultConfig- { Dotenv.configPath = [path]- , Dotenv.configExamplePath = [ examplePath | exampleExists ]- }+ void $+ Dotenv.loadFile $+ Dotenv.defaultConfig+ { Dotenv.configPath = [path]+ , Dotenv.configExamplePath = [examplePath | exampleExists]+ } locateInParents :: FilePath -> IO (Maybe FilePath) locateInParents path = go =<< getCurrentDirectory
library/Freckle/App/Ecs.hs view
@@ -1,19 +1,19 @@ module Freckle.App.Ecs- ( EcsMetadata(..)- , EcsMetadataError(..)- , EcsContainerMetadata(..)- , EcsContainerTaskMetadata(..)+ ( EcsMetadata (..)+ , EcsMetadataError (..)+ , EcsContainerMetadata (..)+ , EcsContainerTaskMetadata (..) , getEcsMetadata ) where import Freckle.App.Prelude -import Control.Monad.Except (MonadError(..))+import Control.Monad.Except (MonadError (..)) import Data.Aeson import Data.List.Extra (dropPrefix) import Freckle.App.Http import System.Environment (lookupEnv)-import UnliftIO.Exception (Exception(..))+import UnliftIO.Exception (Exception (..)) data EcsMetadata = EcsMetadata { emContainerMetadata :: EcsContainerMetadata@@ -25,19 +25,18 @@ | EcsMetadataErrorInvalidURI String | EcsMetadataErrorUnexpectedStatus Request Status | EcsMetadataErrorInvalidJSON Request HttpDecodeError- deriving stock Show+ deriving stock (Show) -- | Parsing for the @/@ response -- -- <https://docs.aws.amazon.com/AmazonECS/latest/developerguide/task-metadata-endpoint-v4.html#task-metadata-endpoint-v4-examples>--- data EcsContainerMetadata = EcsContainerMetadata { ecmDockerId :: Text , ecmDockerName :: Text , ecmImage :: Text , ecmImageID :: Text }- deriving stock Generic+ deriving stock (Generic) instance FromJSON EcsContainerMetadata where parseJSON = genericParseJSON $ aesonDropPrefix "ecm"@@ -45,26 +44,28 @@ -- | Parsing of the @/task@ response -- -- <https://docs.aws.amazon.com/AmazonECS/latest/developerguide/task-metadata-endpoint-v4.html#task-metadata-endpoint-v4-response>--- data EcsContainerTaskMetadata = EcsContainerTaskMetadata { ectmCluster :: Text , ectmTaskARN :: Text , ectmFamily :: Text , ectmRevision :: Text }- deriving stock Generic+ deriving stock (Generic) instance FromJSON EcsContainerTaskMetadata where parseJSON = genericParseJSON $ aesonDropPrefix "ectm" aesonDropPrefix :: String -> Options-aesonDropPrefix x = defaultOptions { fieldLabelModifier = dropPrefix x }+aesonDropPrefix x = defaultOptions {fieldLabelModifier = dropPrefix x} getEcsMetadata :: (MonadIO m, MonadError EcsMetadataError m) => m EcsMetadata getEcsMetadata = do mURI <-- liftIO $ (<|>) <$> lookupEnv "ECS_CONTAINER_METADATA_URI_V4" <*> lookupEnv- "ECS_CONTAINER_METADATA_URI"+ liftIO $+ (<|>)+ <$> lookupEnv "ECS_CONTAINER_METADATA_URI_V4"+ <*> lookupEnv+ "ECS_CONTAINER_METADATA_URI" uri <- maybe (throwError EcsMetadataErrorNotEnabled) pure mURI @@ -75,15 +76,16 @@ makeContainerMetadataRequest :: (MonadIO m, MonadError EcsMetadataError m, FromJSON a) => String -> m a makeContainerMetadataRequest uri = do- req <- mapEither (EcsMetadataErrorInvalidURI . displayException)- $ parseRequest uri+ req <-+ mapEither (EcsMetadataErrorInvalidURI . displayException) $+ parseRequest uri resp <- httpJson req let status = getResponseStatus resp - unless (statusIsSuccessful status)- $ throwError- $ EcsMetadataErrorUnexpectedStatus req status+ unless (statusIsSuccessful status) $+ throwError $+ EcsMetadataErrorUnexpectedStatus req status mapEither (EcsMetadataErrorInvalidJSON req) $ getResponseBody resp
library/Freckle/App/Env.hs view
@@ -19,16 +19,15 @@ -- > <$> var auto "BATCH_SIZE" (def 1) -- > <*> switch "DRY_RUN" mempty -- > <*> flag (Off LevelInfo) (On LevelDebug) "DEBUG" mempty--- module Freckle.App.Env ( module Env - -- * Replacements- , Off(..)- , On(..)+ -- * Replacements+ , Off (..)+ , On (..) , flag - -- * Extensions+ -- * Extensions , kept , eitherReader , time@@ -43,7 +42,7 @@ import Env hiding (flag) import qualified Env import Env.Internal.Free (hoistAlt)-import Env.Internal.Parser (Parser(..), VarF(..))+import Env.Internal.Parser (Parser (..), VarF (..)) -- | Designates the value of a parameter when a flag is not provided. newtype Off a = Off a@@ -74,7 +73,6 @@ -- -- >>> flag (Off LevelInfo) (On LevelDebug) "DEBUG" mempty `parsePure` [("DEBUG", "no")] -- Right LevelDebug--- flag :: Off a -> On a -> String -> Mod Flag a -> Parser Error a flag (Off f) (On t) n m = Env.flag f t n m @@ -88,7 +86,6 @@ -- In @envparse-0.5@, the default is reversed and @sensitive@ can be used to -- explicitly unset read variables, and so this function will instead make them -- all behave as if @sensitive@ was /not/ used.--- kept :: Parser e a -> Parser e a kept = Parser . hoistAlt go . unParser where@@ -102,10 +99,10 @@ -- | Create a 'Reader' from a simple parser function -- -- This is a building-block for other 'Reader's--- eitherReader :: (String -> Either String a) -> Reader Error a eitherReader f s = first (unread . suffix) $ f s- where suffix x = x <> ": " <> show s+ where+ suffix x = x <> ": " <> show s -- | Read a time value using the given format --@@ -114,12 +111,11 @@ -- -- >>> var (time "%Y-%m-%d") "TIME" mempty `parsePure` [("TIME", "10:00PM")] -- Left [("TIME",UnreadError "unable to parse time as %Y-%m-%d: \"10:00PM\"")]--- time :: String -> Reader Error UTCTime time fmt =- eitherReader- $ note ("unable to parse time as " <> fmt)- . parseTimeM True defaultTimeLocale fmt+ eitherReader $+ note ("unable to parse time as " <> fmt)+ . parseTimeM True defaultTimeLocale fmt -- | Read key-value pairs --@@ -135,7 +131,6 @@ -- -- >>> var keyValues "TAGS" mempty `parsePure` [("TAGS", "foo:bar,:bat")] -- Left [("TAGS",UnreadError "Value bat has no key: \"foo:bar,:bat\"")]--- keyValues :: Reader Error [(Text, Text)] keyValues = eitherReader $ traverse keyValue . T.splitOn "," . pack where
library/Freckle/App/GlobalCache.hs view
@@ -42,7 +42,6 @@ -- LogStderr -> newStderrLoggerSet -- LogFile f -> flip newFileLoggerSet f -- @--- module Freckle.App.GlobalCache ( GlobalCache , newGlobalCache@@ -66,7 +65,8 @@ globallyCache (GlobalCache var) construct = do mv <- readIORef var maybe (cache =<< construct) pure mv- where cache v = atomicModifyIORef' var $ const (Just v, v)+ where+ cache v = atomicModifyIORef' var $ const (Just v, v) -- | Garbage collect one of our 'IORef's after an action has run --@@ -77,7 +77,6 @@ -- To avoid garbage collection issues, we can leverage a "System.Mem.Weak" to -- add a finalizer. When that 'MVar' gets garbage collected we can clear the -- global 'IORef'. This maintains the status quo, with minimal plumbing.--- withGlobalCacheCleanup :: GlobalCache a -> IO b -> IO () withGlobalCacheCleanup (GlobalCache var) action = do cleanup <- newMVar ()
library/Freckle/App/Http.hs view
@@ -50,22 +50,21 @@ -- -- See "Freckle.Http.App.Paginate" to process requested pages in a streaming -- fashion, or perform pagination based on somethign other than @Link@.--- module Freckle.App.Http ( httpJson- , HttpDecodeError(..)+ , HttpDecodeError (..) , httpDecode , httpLbs , httpNoBody , httpPaginated , sourcePaginated - -- * Request builders+ -- * Request builders , Request , parseRequest , parseRequest_ - -- * Request modifiers+ -- * Request modifiers , addRequestHeader , addAcceptHeader , addBearerAuthorizationHeader@@ -76,38 +75,35 @@ , setRequestCheckStatus , setRequestPath - -- * Response accessors+ -- * Response accessors , Response , getResponseStatus , getResponseBody - -- ** Unsafe access+ -- ** Unsafe access , getResponseBodyUnsafe - -- * Exceptions- , HttpException(..)-- -- **- -- | Predicates useful for handling 'HttpException's- --- -- For example, given a function 'guarded', which returns 'Just' a given value- -- when a predicate holds for it (otherwise 'Nothing'), you can add- -- error-handling specific to exceptions caused by 4XX responses:- --- -- @- -- 'handleJust' (guarded 'httpExceptionIsClientError') handle4XXError $ do- -- resp <- 'httpJson' $ 'setRequestCheckStatus' $ parseRequest_ "http://..."- -- body <- 'getResponseBodyUnsafe' resp- --- -- -- ...- -- @- --+ -- * Exceptions+ , HttpException (..)+ -- | Predicates useful for handling 'HttpException's+ --+ -- For example, given a function 'guarded', which returns 'Just' a given value+ -- when a predicate holds for it (otherwise 'Nothing'), you can add+ -- error-handling specific to exceptions caused by 4XX responses:+ --+ -- @+ -- 'handleJust' (guarded 'httpExceptionIsClientError') handle4XXError $ do+ -- resp <- 'httpJson' $ 'setRequestCheckStatus' $ parseRequest_ "http://..."+ -- body <- 'getResponseBodyUnsafe' resp+ --+ -- -- ...+ -- @ , httpExceptionIsInformational , httpExceptionIsRedirection , httpExceptionIsClientError , httpExceptionIsServerError - -- * "Network.HTTP.Types" re-exports+ -- * "Network.HTTP.Types" re-exports , Status , statusCode , statusIsInformational@@ -128,7 +124,7 @@ import qualified Data.List.NonEmpty as NE import Freckle.App.Http.Paginate import Freckle.App.Http.Retry-import Network.HTTP.Conduit (HttpExceptionContent(..))+import Network.HTTP.Conduit (HttpExceptionContent (..)) import Network.HTTP.Simple hiding (httpLbs, httpNoBody) import qualified Network.HTTP.Simple as HTTP import Network.HTTP.Types.Header (hAccept, hAuthorization)@@ -141,7 +137,7 @@ , statusIsServerError , statusIsSuccessful )-import UnliftIO.Exception (Exception(..), throwIO)+import UnliftIO.Exception (Exception (..), throwIO) data HttpDecodeError = HttpDecodeError { hdeBody :: ByteString@@ -151,9 +147,9 @@ instance Exception HttpDecodeError where displayException HttpDecodeError {..} =- unlines- $ ["Error decoding HTTP Response:", "Raw body:", BSL8.unpack hdeBody]- <> fromErrors hdeErrors+ unlines $+ ["Error decoding HTTP Response:", "Raw body:", BSL8.unpack hdeBody]+ <> fromErrors hdeErrors where fromErrors = \case err NE.:| [] -> ["Error:", err]@@ -165,8 +161,9 @@ :: (MonadIO m, FromJSON a) => Request -> m (Response (Either HttpDecodeError a))-httpJson = httpDecode (first pure . Aeson.eitherDecode)- . addAcceptHeader "application/json"+httpJson =+ httpDecode (first pure . Aeson.eitherDecode)+ . addAcceptHeader "application/json" -- | Request and decode a response httpDecode@@ -195,7 +192,6 @@ -- The second argument is used to extract the data to combine out of the -- response. This is particularly useful for 'Either' values, like you may get -- from 'httpJson'. It lives in @m@ to support functions such as 'getResponseBodyUnsafe'.--- httpPaginated :: (MonadIO m, Monoid b) => (Request -> m (Response a))@@ -216,7 +212,6 @@ -- If you plan to use this function, and haven't built your decoding to handle -- 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
library/Freckle/App/Http/Paginate.hs view
@@ -51,7 +51,6 @@ -- let next = C8.pack $ show $ pNext body -- pure $ addToRequestQueryString [("next", Just next)] req -- @--- module Freckle.App.Http.Paginate ( sourcePaginated , sourcePaginatedBy@@ -65,7 +64,6 @@ import Network.HTTP.Simple -- | Stream pages of a paginated response, using @Link@ to find next pages--- sourcePaginated :: MonadIO m => (Request -> m (Response body))
library/Freckle/App/Http/Retry.hs view
@@ -1,5 +1,5 @@ module Freckle.App.Http.Retry- ( RetriesExhausted(..)+ ( RetriesExhausted (..) , rateLimited , rateLimited' ) where@@ -8,11 +8,11 @@ import Control.Retry import qualified Data.ByteString.Char8 as BS8-import Network.HTTP.Client (Request(..))+import Network.HTTP.Client (Request (..)) import Network.HTTP.Simple import Network.HTTP.Types.Status (status429) import Text.Read (readMaybe)-import UnliftIO.Exception (Exception(..), throwIO)+import UnliftIO.Exception (Exception (..), throwIO) -- | Thrown if we exhaust our retries limit and still see a @429@ --@@ -31,12 +31,11 @@ -- Unfortunately, it's not possible to reuse the user-defined 'checkResponse' in -- order to throw a uniform 'HttpException' in this case; so we throw this -- ourselves instead.--- data RetriesExhausted = RetriesExhausted { reLimit :: Int , reResponse :: Response () }- deriving stock Show+ deriving stock (Show) instance Exception RetriesExhausted where displayException RetriesExhausted {..} =@@ -57,29 +56,33 @@ -> Request -> m (Response body) rateLimited' retryLimit f req = do- resp <- retryingDynamic- (limitRetries retryLimit)- (\_ ->- pure- . maybe DontRetry (ConsultPolicyOverrideDelay . microseconds)- . getRetryAfter- )- (\_ -> f $ suppressRetryStatusError req)+ resp <-+ retryingDynamic+ (limitRetries retryLimit)+ ( \_ ->+ pure+ . maybe DontRetry (ConsultPolicyOverrideDelay . microseconds)+ . getRetryAfter+ )+ (\_ -> f $ suppressRetryStatusError req) checkRetriesExhausted retryLimit resp suppressRetryStatusError :: Request -> Request-suppressRetryStatusError req = req- { checkResponse = \req' resp ->- unless (getResponseStatus resp == status429)- $ originalCheckResponse req' resp- }- where originalCheckResponse = checkResponse req+suppressRetryStatusError req =+ req+ { checkResponse = \req' resp ->+ unless (getResponseStatus resp == status429) $+ originalCheckResponse req' resp+ }+ where+ originalCheckResponse = checkResponse req checkRetriesExhausted :: MonadIO m => Int -> Response body -> m (Response body) checkRetriesExhausted retryLimit resp- | getResponseStatus resp == status429 = throwIO- $ RetriesExhausted { reLimit = retryLimit, reResponse = void resp }+ | getResponseStatus resp == status429 =+ throwIO $+ RetriesExhausted {reLimit = retryLimit, reResponse = void resp} | otherwise = pure resp getRetryAfter :: Response body -> Maybe Int
+ library/Freckle/App/Kafka.hs view
@@ -0,0 +1,129 @@+{-# LANGUAGE NamedFieldPuns #-}++module Freckle.App.Kafka+ ( envKafkaBrokerAddresses+ , KafkaProducerPool (..)+ , HasKafkaProducerPool (..)+ , createKafkaProducerPool+ , produceKeyedOn+ , produceKeyedOnAsync+ ) where++import Freckle.App.Prelude++import Blammo.Logging+import Control.Lens (Lens', view)+import Data.Aeson (ToJSON, encode)+import Data.ByteString.Lazy (toStrict)+import qualified Data.List.NonEmpty as NE+import Data.Pool (Pool)+import qualified Data.Pool as Pool+import qualified Data.Text as T+import qualified Freckle.App.Env as Env+import Kafka.Producer+import UnliftIO.Async (async)+import UnliftIO.Exception (throwString)+import Yesod.Core.Lens+import Yesod.Core.Types (HandlerData)++envKafkaBrokerAddresses+ :: Env.Parser Env.Error (NonEmpty BrokerAddress)+envKafkaBrokerAddresses =+ Env.var+ (Env.eitherReader readKafkaBrokerAddresses)+ "KAFKA_BROKER_ADDRESSES"+ mempty++readKafkaBrokerAddresses :: String -> Either String (NonEmpty BrokerAddress)+readKafkaBrokerAddresses t = case NE.nonEmpty $ T.splitOn "," $ T.pack t of+ Just xs@(x NE.:| _)+ | x /= "" -> Right $ BrokerAddress <$> xs+ _ -> Left "Broker Address cannot be empty"++data KafkaProducerPool+ = NullKafkaProducerPool+ | KafkaProducerPool (Pool KafkaProducer)++class HasKafkaProducerPool env where+ kafkaProducerPoolL :: Lens' env KafkaProducerPool++instance HasKafkaProducerPool site => HasKafkaProducerPool (HandlerData child site) where+ kafkaProducerPoolL = envL . siteL . kafkaProducerPoolL++createKafkaProducerPool+ :: NonEmpty BrokerAddress+ -> Int+ -- ^ The number of stripes (distinct sub-pools) to maintain.+ -- The smallest acceptable value is 1.+ -> NominalDiffTime+ -- ^ Amount of time for which an unused resource is kept open.+ -- The smallest acceptable value is 0.5 seconds.+ --+ -- The elapsed time before destroying a resource may be a little+ -- longer than requested, as the reaper thread wakes at 1-second+ -- intervals.+ -> Int+ -- ^ Maximum number of resources to keep open per stripe. The+ -- smallest acceptable value is 1.+ --+ -- Requests for resources will block if this limit is reached on a+ -- single stripe, even if other stripes have idle resources+ -- available.+ -> IO (Pool KafkaProducer)+createKafkaProducerPool addresses = Pool.createPool mkProducer closeProducer+ where+ mkProducer =+ either throw pure =<< newProducer (brokersList $ toList addresses)+ throw err = throwString $ "Failed to open kafka producer: " <> show err++produceKeyedOn+ :: ( ToJSON value+ , ToJSON key+ , MonadLogger m+ , MonadReader env m+ , HasKafkaProducerPool env+ , MonadUnliftIO m+ )+ => TopicName+ -> NonEmpty value+ -> (value -> key)+ -> m ()+produceKeyedOn prTopic values keyF = do+ logDebugNS "kafka" $ "Producing Kafka events" :# ["events" .= values]+ view kafkaProducerPoolL >>= \case+ NullKafkaProducerPool -> pure ()+ KafkaProducerPool producerPool -> do+ errors <-+ liftIO $+ Pool.withResource producerPool $ \producer ->+ produceMessageBatch producer $+ toList $+ mkProducerRecord <$> values+ unless (null errors) $+ logErrorNS "kafka" $+ "Failed to send events" :# ["errors" .= fmap (tshow . snd) errors]+ where+ mkProducerRecord value =+ ProducerRecord+ { prTopic+ , prPartition = UnassignedPartition+ , prKey = Just $ toStrict $ encode $ keyF value+ , prValue =+ Just $+ toStrict $+ encode value+ }++produceKeyedOnAsync+ :: ( ToJSON value+ , ToJSON key+ , MonadLogger m+ , MonadReader env m+ , HasKafkaProducerPool env+ , MonadUnliftIO m+ )+ => TopicName+ -> NonEmpty value+ -> (value -> key)+ -> m ()+produceKeyedOnAsync prTopic values = void . async . produceKeyedOn prTopic values
library/Freckle/App/Memcached.hs view
@@ -8,14 +8,13 @@ -- 4. Use 'caching' -- -- To avoid 'Cachable', see 'cachingAs' and 'cachingAsJSON'.--- module Freckle.App.Memcached- ( Cachable(..)+ ( Cachable (..) , caching , cachingAs , cachingAsJSON - -- * Re-exports+ -- * Re-exports , module Freckle.App.Memcached.Client , module Freckle.App.Memcached.CacheKey , module Freckle.App.Memcached.CacheTTL@@ -31,9 +30,9 @@ import Data.Text.Encoding.Error (lenientDecode) import Freckle.App.Memcached.CacheKey import Freckle.App.Memcached.CacheTTL-import Freckle.App.Memcached.Client (HasMemcachedClient(..))+import Freckle.App.Memcached.Client (HasMemcachedClient (..)) import qualified Freckle.App.Memcached.Client as Memcached-import UnliftIO.Exception (Exception(..), handleAny)+import UnliftIO.Exception (Exception (..), handleAny) class Cachable a where toCachable :: a -> ByteString@@ -81,9 +80,9 @@ -> m a cachingAs from to key ttl f = do result <-- fmap (maybe CacheNotFound (either (CacheError . pack) CacheFound . from))- $ handleCachingError Nothing "getting"- $ Memcached.get key+ fmap (maybe CacheNotFound (either (CacheError . pack) CacheFound . from)) $+ handleCachingError Nothing "getting" $+ Memcached.get key case result of CacheFound a -> pure a@@ -119,10 +118,10 @@ logCachingError :: MonadLogger m => Text -> Text -> m () logCachingError action message =- logErrorNS "caching"- $ "Error "- <> action- :# ["action" .= action, "message" .= message]+ logErrorNS "caching" $+ "Error "+ <> action+ :# ["action" .= action, "message" .= message] encodeStrict :: ToJSON a => a -> ByteString encodeStrict = BSL.toStrict . encode
library/Freckle/App/Memcached/CacheKey.hs view
@@ -13,7 +13,7 @@ import UnliftIO.Exception (throwString) newtype CacheKey = CacheKey Text- deriving stock Show+ deriving stock (Show) deriving newtype (Eq, Hashable) unCacheKey :: CacheKey -> Text@@ -28,7 +28,6 @@ -- normally clients wouldn't need to use such long keys); the key must not -- include control characters or whitespace. -- @--- cacheKey :: Text -> Either String CacheKey cacheKey t | T.length t > 250 = invalid "Must be fewer than 250 characters"
library/Freckle/App/Memcached/CacheTTL.hs view
@@ -10,7 +10,7 @@ import Database.Memcache.Types (Expiration) newtype CacheTTL = CacheTTL Int- deriving stock Show+ deriving stock (Show) deriving newtype (Eq, Ord, Enum, Num, Real, Integral) cacheTTL :: Int -> CacheTTL
library/Freckle/App/Memcached/Client.hs view
@@ -3,14 +3,14 @@ , newMemcachedClient , withMemcachedClient , memcachedClientDisabled- , HasMemcachedClient(..)+ , HasMemcachedClient (..) , get , set ) where import Freckle.App.Prelude -import Control.Lens (Lens', _1, view)+import Control.Lens (Lens', view, _1) import qualified Database.Memcache.Client as Memcache import Database.Memcache.Types (Value) import Freckle.App.Memcached.CacheKey@@ -58,7 +58,6 @@ -- | 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) => CacheKey@@ -67,8 +66,11 @@ -> m () set k v expiration = with $ \case MemcachedClient mc ->- void $ liftIO $ Memcache.set mc (fromCacheKey k) v 0 $ fromCacheTTL- expiration+ void $+ liftIO $+ Memcache.set mc (fromCacheKey k) v 0 $+ fromCacheTTL+ expiration MemcachedClientDisabled -> pure () quitClient :: MonadIO m => MemcachedClient -> m ()
library/Freckle/App/Memcached/Servers.hs view
@@ -20,9 +20,8 @@ -- -- Default to disabled -- Env.var (Env.eitherReader readMemcachedServers) "MEMCACHED_SERVERS" (Env.def emptyMemcachedServers) -- @--- module Freckle.App.Memcached.Servers- ( MemcachedServers(..)+ ( MemcachedServers (..) , defaultMemcachedServers , emptyMemcachedServers , readMemcachedServers@@ -34,7 +33,7 @@ import Control.Error.Util (note) import qualified Data.Text as T import qualified Database.Memcache.Client as Memcache-import Network.URI (URI(..), URIAuth(..), parseAbsoluteURI)+import Network.URI (URI (..), URIAuth (..), parseAbsoluteURI) newtype MemcachedServers = MemcachedServers { unMemcachedServers :: [MemcachedServer]@@ -88,15 +87,16 @@ guard $ not $ T.null u guard $ not $ T.null p - pure Memcache.Auth- { Memcache.username = encodeUtf8 u- , Memcache.password = encodeUtf8 p- }+ pure+ Memcache.Auth+ { Memcache.username = encodeUtf8 u+ , Memcache.password = encodeUtf8 p+ } setHost :: URIAuth -> Memcache.ServerSpec -> Memcache.ServerSpec setHost auth ss = case uriRegName auth of "" -> ss- rn -> ss { Memcache.ssHost = rn }+ rn -> ss {Memcache.ssHost = rn} setPort :: URIAuth -> Memcache.ServerSpec -> Memcache.ServerSpec setPort auth ss = fromMaybe ss $ do@@ -104,7 +104,7 @@ "" -> Nothing (':' : p) -> fromPort p p -> fromPort p- pure $ ss { Memcache.ssPort = p }+ pure $ ss {Memcache.ssPort = p} where #if MIN_VERSION_memcache(0,3,0) -- ssPort is a ServiceName, which is a String@@ -116,4 +116,4 @@ setAuth :: Memcache.Authentication -> Memcache.ServerSpec -> Memcache.ServerSpec-setAuth auth ss = ss { Memcache.ssAuth = auth }+setAuth auth ss = ss {Memcache.ssAuth = auth}
library/Freckle/App/OpenTelemetry.hs view
@@ -1,5 +1,5 @@ module Freckle.App.OpenTelemetry- ( MonadTracer(..)+ ( MonadTracer (..) ) where import Freckle.App.Prelude@@ -11,7 +11,6 @@ -- -- 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)
library/Freckle/App/Prelude.hs view
@@ -2,7 +2,7 @@ module Freckle.App.Prelude ( module Prelude - -- * Commonly imported types+ -- * Commonly imported types , Alternative , Exception , Generic@@ -24,20 +24,20 @@ , UTCTime , Vector - -- * Commonly used functions+ -- * Commonly used functions - -- ** Lifts+ -- ** Lifts , lift , liftIO - -- ** 'Text'+ -- ** 'Text' , tshow , pack , unpack , encodeUtf8 , decodeUtf8 - -- ** 'Maybe'+ -- ** 'Maybe' , catMaybes , fromMaybe , isJust@@ -46,32 +46,32 @@ , mapMaybe , maybeToList - -- ** Safe alternatives to partial prelude functions (e.g. 'headMay')+ -- ** Safe alternatives to partial prelude functions (e.g. 'headMay') , module SafeAlternatives - -- ** 'Either'+ -- ** 'Either' , partitionEithers - -- ** 'Foldable'+ -- ** 'Foldable' , module Foldable - -- ** 'Traversable'+ -- ** 'Traversable' , module Traversable - -- ** 'Functor'+ -- ** 'Functor' , (<$$>) - -- ** 'Bifunctor'+ -- ** 'Bifunctor' , bimap , first , second - -- ** 'Applicative'+ -- ** 'Applicative' , (<|>) , liftA2 , optional - -- ** 'Monad'+ -- ** 'Monad' , (<=<) , (>=>) , guard@@ -80,18 +80,29 @@ , void , when - -- ** 'Arrow'+ -- ** 'Arrow' , (&&&) , (***) - -- ** 'UTCTime'+ -- ** 'UTCTime' , getCurrentTime ) where -- Use 'Prelude' as the starting point, removing common partial functions import Prelude hiding- (cycle, foldl1, foldr1, head, init, last, maximum, minimum, read, tail, (!!))+ ( cycle+ , foldl1+ , foldr1+ , head+ , init+ , last+ , maximum+ , minimum+ , read+ , tail+ , (!!)+ ) -- Commonly used types (and their commonly used functions) @@ -99,9 +110,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)@@ -138,7 +149,14 @@ import Data.Either (partitionEithers) import Data.Foldable as Foldable hiding (foldl1, foldr1) import Data.Maybe- (catMaybes, fromMaybe, isJust, isNothing, listToMaybe, mapMaybe, maybeToList)+ ( catMaybes+ , fromMaybe+ , isJust+ , isNothing+ , listToMaybe+ , mapMaybe+ , maybeToList+ ) import Data.Text.Encoding (decodeUtf8, encodeUtf8) import Data.Traversable as Traversable
library/Freckle/App/Scientist.hs view
@@ -13,7 +13,6 @@ -- -- * Experiments are labeled "science.${name}" -- * Results are tagged with "variant:${name}"--- experimentPublishDatadog :: (MonadReader env m, MonadUnliftIO m, HasStatsClient env) => Result c a b@@ -23,11 +22,11 @@ statName = "science." <> resultDetailsExperimentName details ResultControl {..} = resultDetailsControl details - Stats.tagged [("variant", resultControlName)]- $ Stats.gauge statName- $ durationToSeconds resultControlDuration+ Stats.tagged [("variant", resultControlName)] $+ Stats.gauge statName $+ durationToSeconds resultControlDuration for_ (resultDetailsCandidates details) $ \ResultCandidate {..} ->- Stats.tagged [("variant", "candidate-" <> resultCandidateName)]- $ Stats.gauge statName- $ durationToSeconds resultCandidateDuration+ Stats.tagged [("variant", "candidate-" <> resultCandidateName)] $+ Stats.gauge statName $+ durationToSeconds resultCandidateDuration
library/Freckle/App/Stats.hs view
@@ -1,28 +1,25 @@ {-# LANGUAGE TupleSections #-} -- | An intentionally-leaky StatsD interface to Datadog------ $usage--- module Freckle.App.Stats ( StatsSettings , defaultStatsSettings , setStatsSettingsTags , envParseStatsSettings - -- * Client+ -- * Client , StatsClient , tagsL , withStatsClient- , HasStatsClient(..)+ , HasStatsClient (..) - -- * Gauges+ -- * Gauges , Gauges , Gauge , dbConnections , withGauge - -- * Reporting+ -- * Reporting , tagged , increment , counter@@ -38,7 +35,7 @@ import Control.Lens (Lens', lens, to, view, (&), (.~), (<>~)) import Control.Monad.Except (runExceptT) import Control.Monad.Reader (local)-import Data.Aeson (Value(..))+import Data.Aeson (Value (..)) import Data.String import Data.Time (diffUTCTime) import Freckle.App.Ecs@@ -57,42 +54,43 @@ } defaultStatsSettings :: StatsSettings-defaultStatsSettings = StatsSettings- { amsEnabled = False- , amsSettings = Datadog.defaultSettings- , amsTags = []- }+defaultStatsSettings =+ StatsSettings+ { amsEnabled = False+ , amsSettings = Datadog.defaultSettings+ , amsTags = []+ } setStatsSettingsTags :: [(Text, Text)] -> StatsSettings -> StatsSettings-setStatsSettingsTags x settings = settings { amsTags = x }+setStatsSettingsTags x settings = settings {amsTags = x} envParseStatsSettings :: Env.Parser Env.Error StatsSettings envParseStatsSettings = StatsSettings <$> Env.switch "DOGSTATSD_ENABLED" mempty- <*> (buildSettings- <$> optional (Env.var Env.str "DOGSTATSD_HOST" mempty)- <*> optional (Env.var Env.auto "DOGSTATSD_PORT" mempty)+ <*> ( buildSettings+ <$> optional (Env.var Env.str "DOGSTATSD_HOST" mempty)+ <*> optional (Env.var Env.auto "DOGSTATSD_PORT" mempty) )- <*> (buildTags- <$> optional (Env.var Env.nonempty "DD_ENV" mempty)- <*> optional (Env.var Env.nonempty "DD_SERVICE" mempty)- <*> optional (Env.var Env.nonempty "DD_VERSION" mempty)- <*> Env.var Env.keyValues "DOGSTATSD_TAGS" (Env.def [])+ <*> ( buildTags+ <$> optional (Env.var Env.nonempty "DD_ENV" mempty)+ <*> optional (Env.var Env.nonempty "DD_SERVICE" mempty)+ <*> optional (Env.var Env.nonempty "DD_VERSION" mempty)+ <*> Env.var Env.keyValues "DOGSTATSD_TAGS" (Env.def []) ) where buildSettings mHost mPort = Datadog.defaultSettings & maybe id (Datadog.host .~) mHost- . maybe id (Datadog.port .~) mPort+ . maybe id (Datadog.port .~) mPort buildTags mEnv mService mVersion tags = catMaybes- [ ("env", ) <$> mEnv- , ("environment", ) <$> mEnv -- Legacy- , ("service", ) <$> mService- , ("version", ) <$> mVersion- ]+ [ ("env",) <$> mEnv+ , ("environment",) <$> mEnv -- Legacy+ , ("service",) <$> mService+ , ("version",) <$> mVersion+ ] <> tags newtype Gauges = Gauges@@ -115,10 +113,10 @@ } tagsL :: Lens' StatsClient [(Text, Text)]-tagsL = lens scTags $ \x y -> x { scTags = y }+tagsL = lens scTags $ \x y -> x {scTags = y} gaugesL :: Lens' StatsClient Gauges-gaugesL = lens scGauges $ \x y -> x { scGauges = y }+gaugesL = lens scGauges $ \x y -> x {scGauges = y} class HasStatsClient env where statsClientL :: Lens' env StatsClient@@ -126,7 +124,7 @@ instance HasStatsClient StatsClient where statsClientL = id -instance HasStatsClient site => HasStatsClient (HandlerData child site) where+instance HasStatsClient site => HasStatsClient (HandlerData child site) where statsClientL = envL . siteL . statsClientL withStatsClient@@ -137,25 +135,29 @@ withStatsClient StatsSettings {..} f = do gauges <- liftIO $ do gdbConnections <- Gauge "active_pool_connections" <$> EKG.new- pure Gauges { .. }+ pure Gauges {..} if amsEnabled then do tags <- (amsTags <>) <$> getEcsMetadataTags Datadog.withDogStatsD amsSettings $ \client -> -- Add the tags to the thread context so they're present in all logs- withThreadContext (map toPair tags) $ f StatsClient- { scClient = client- , scTags = tags+ withThreadContext (map toPair tags) $+ f+ StatsClient+ { scClient = client+ , scTags = tags+ , scGauges = gauges+ }+ else do+ f $+ StatsClient+ { scClient = Datadog.Dummy+ , scTags = amsTags , scGauges = gauges }- else do- f $ StatsClient- { scClient = Datadog.Dummy- , scTags = amsTags- , scGauges = gauges- }- where toPair = bimap (fromString . unpack) String+ where+ toPair = bimap (fromString . unpack) String withGauge :: (MonadReader app m, HasStatsClient app, MonadUnliftIO m)@@ -206,7 +208,6 @@ -- -- The 'ToMetricValue' constraint can be satisfied by most numeric types and is -- assumed to be seconds.--- histogram :: ( MonadUnliftIO m , MonadReader env m@@ -231,7 +232,8 @@ -> UTCTime -> m () histogramSinceMs = histogramSinceBy toMilliseconds- where toMilliseconds = (* 1000) . realToFrac @_ @Double+ where+ toMilliseconds = (* 1000) . realToFrac @_ @Double histogramSinceBy :: ( MonadUnliftIO m@@ -261,9 +263,9 @@ sendMetric metricType name metricValue = do StatsClient {..} <- view statsClientL - Datadog.send scClient- $ Datadog.metric (Datadog.MetricName name) metricType metricValue- & (Datadog.tags .~ map (uncurry Datadog.tag) scTags)+ Datadog.send scClient $+ Datadog.metric (Datadog.MetricName name) metricType metricValue+ & (Datadog.tags .~ map (uncurry Datadog.tag) scTags) getEcsMetadataTags :: MonadIO m => m [(Text, Text)] getEcsMetadataTags = do@@ -272,16 +274,16 @@ where err e = liftIO $ hPutStrLn stderr $ "Error reading ECS Metadata: " <> show e - toTags (EcsMetadata EcsContainerMetadata {..} EcsContainerTaskMetadata {..})- = [ ("container_id", ecmDockerId)- , ("container_name", ecmDockerName)- , ("docker_image", ecmImage)- , ("image_tag", ecmImageID)- , ("cluster_name", ectmCluster)- , ("task_arn", ectmTaskARN)- , ("task_family", ectmFamily)- , ("task_version", ectmRevision)- ]+ toTags (EcsMetadata EcsContainerMetadata {..} EcsContainerTaskMetadata {..}) =+ [ ("container_id", ecmDockerId)+ , ("container_name", ecmDockerName)+ , ("docker_image", ecmImage)+ , ("image_tag", ecmImageID)+ , ("cluster_name", ectmCluster)+ , ("task_arn", ectmTaskARN)+ , ("task_family", ectmFamily)+ , ("task_version", ectmRevision)+ ] -- $usage -- Usage:@@ -353,4 +355,3 @@ -- Stats.'increment' \"action.success\" -- -- ... -- @---
library/Freckle/App/Stats/Rts.hs view
@@ -16,7 +16,6 @@ -- | Initialize a thread to poll RTS stats -- -- Stats are collected via `ekg-core` and 'System.Metrics.registerGcMetrics'--- forkRtsStatPolling :: (MonadUnliftIO m, MonadReader env m, HasStatsClient env) => m () forkRtsStatPolling = do
library/Freckle/App/Test.hs view
@@ -4,7 +4,7 @@ {-# OPTIONS_GHC -fno-warn-deprecations #-} module Freckle.App.Test- ( AppExample(..)+ ( AppExample (..) , appExample , withApp , withAppSql@@ -13,7 +13,7 @@ , pending , pendingWith - -- * Re-exports+ -- * Re-exports , module X ) where @@ -39,9 +39,9 @@ import Control.Monad.Base import Control.Monad.Catch import qualified Control.Monad.Fail as Fail-import Control.Monad.IO.Unlift (MonadUnliftIO(..))+import Control.Monad.IO.Unlift (MonadUnliftIO (..)) import Control.Monad.Primitive-import Control.Monad.Random (MonadRandom(..))+import Control.Monad.Random (MonadRandom (..)) import Control.Monad.Reader import Control.Monad.Trans.Control import Database.Persist.Sql (SqlPersistT, runSqlPool)@@ -58,7 +58,6 @@ -- -- - Export @LOG_LEVEL=error@, if this would be quiet enough, or -- - Export @LOG_DESTINATION=@/dev/null@ to fully silence--- newtype AppExample app a = AppExample { unAppExample :: ReaderT app (LoggingT IO) a }@@ -92,9 +91,10 @@ 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+ b <-+ unmasked (use resource) `UnliftIO.catch` \e -> do+ _ <- release resource (ExitCaseException e)+ throwM e c <- release resource (ExitCaseSuccess b) pure (b, c) @@ -111,10 +111,11 @@ instance HasLogger app => Example (AppExample app a) where type Arg (AppExample app a) = app - evaluateExample (AppExample ex) params action = evaluateExample- (action $ \app -> void $ runLoggerLoggingT app $ runReaderT ex app)- params- ($ ())+ evaluateExample (AppExample ex) params action =+ evaluateExample+ (action $ \app -> void $ runLoggerLoggingT app $ runReaderT ex app)+ params+ ($ ()) instance MonadTracer (AppExample app) where getVaultData = pure Nothing@@ -126,7 +127,6 @@ -- -- This can be used to avoid ambiguity errors when your expectation uses only -- polymorphic functions like 'runDB' or lifted 'shouldBe' et-al.--- appExample :: AppExample app a -> AppExample app a appExample = id @@ -139,7 +139,6 @@ -- -- Reads @.env.test@, then loads the application. Examples within this spec can -- use any @'MonadReader' app@ (including 'runDB', if the app 'HasSqlPool').--- withApp :: ((app -> IO ()) -> IO ()) -> SpecWith app -> Spec withApp run = beforeAll Dotenv.loadTest . Hspec.aroundAll run @@ -147,7 +146,6 @@ -- -- Runs the given function on the pool before every spec item. For example, to -- truncate tables.--- withAppSql :: HasSqlPool app => SqlPersistT IO a
library/Freckle/App/Test/DocTest.hs view
@@ -4,7 +4,7 @@ ( doctest , doctestWith - -- * Lower-level, for site-specific use+ -- * Lower-level, for site-specific use , findPackageFlags , findDocTestedFiles ) where@@ -16,8 +16,8 @@ import qualified Data.Text as T import qualified Data.Text.IO as T import Data.Yaml (decodeFileThrow)-import "Glob" System.FilePath.Glob (globDir1) import qualified Test.DocTest as DocTest+import "Glob" System.FilePath.Glob (globDir1) -- | Run doctest on files in the given directory doctest :: FilePath -> IO ()@@ -37,8 +37,8 @@ } instance FromJSON PackageYaml where- parseJSON = withObject "PackageYaml"- $ \o -> PackageYaml <$> o .: "default-extensions" <*> o .: "name"+ parseJSON = withObject "PackageYaml" $+ \o -> PackageYaml <$> o .: "default-extensions" <*> o .: "name" -- Parse @default-extensions@ and @name& out of @package.yaml@ --@@ -64,7 +64,6 @@ -- -- So we want to only run doctest for files that need it. This function finds -- such files by /naively/ looking for the @^-- >>>@ pattern.--- findDocTestedFiles :: FilePath -> IO [FilePath] findDocTestedFiles dir = do paths <- globDir1 "**/*.hs" dir
library/Freckle/App/Test/Hspec/Runner.hs view
@@ -8,13 +8,15 @@ import Freckle.App.Prelude import Control.Concurrent (getNumCapabilities, setNumCapabilities)-import Control.Monad.Trans.Maybe (MaybeT(MaybeT), runMaybeT)+import Control.Monad.Trans.Maybe (MaybeT (MaybeT), runMaybeT) import Data.List (isInfixOf)-import qualified Prelude as Unsafe (read) import System.Environment (getArgs, lookupEnv) import Test.Hspec (Spec) import Test.Hspec.JUnit- (configWithJUnit, defaultJUnitConfig, setJUnitConfigOutputFile)+ ( configWithJUnit+ , defaultJUnitConfig+ , setJUnitConfigOutputFile+ ) import Test.Hspec.Runner ( Config , Path@@ -26,6 +28,7 @@ , readConfig , runSpec )+import qualified Prelude as Unsafe (read) run :: String -> Spec -> IO () run = runWith defaultConfig@@ -44,17 +47,21 @@ -- Run unreliable tests first, so local dev errors are reported for reliable -- specs at the end putStrLn "Running UNRELIABLE tests; failures here should not fail the build"- void $ runner ("unreliable-" <> name) id =<< load- args- (skip reliableTests config)+ void $+ runner ("unreliable-" <> name) id+ =<< load+ args+ (skip reliableTests config) putStrLn "Running RELIABLE"- reliableSummary <- runner name id- =<< load args (skip (anys [unreliableTests, isolatedTests]) config)+ reliableSummary <-+ runner name id+ =<< load args (skip (anys [unreliableTests, isolatedTests]) config) putStrLn "Running ISOLATED"- isolatedSummary <- runner ("isolated-" <> name) noConcurrency- =<< load args (skip (not . isolatedTests) config)+ isolatedSummary <-+ runner ("isolated-" <> name) noConcurrency+ =<< load args (skip (not . isolatedTests) config) evaluateSummary $ reliableSummary <> isolatedSummary where@@ -62,7 +69,7 @@ junit filename changeConfig = (spec `runJUnitSpec` ("/tmp/junit", filename)) . changeConfig hspec _ changeConfig = runSpec spec . changeConfig- noConcurrency x = x { configConcurrentJobs = Just 1 }+ noConcurrency x = x {configConcurrentJobs = Just 1} runJUnitSpec :: Spec -> (FilePath, String) -> Config -> IO Summary runJUnitSpec spec (path, name) config =@@ -74,13 +81,15 @@ makeParallelConfig :: Config -> IO Config makeParallelConfig config = do- jobCores <- fromMaybe 1 <$> runMaybeT- (MaybeT lookupTestCapabilities <|> MaybeT lookupHostCapabilities)+ jobCores <-+ fromMaybe 1+ <$> runMaybeT+ (MaybeT lookupTestCapabilities <|> MaybeT lookupHostCapabilities) putStrLn $ "Running spec with " <> show jobCores <> " cores" setNumCapabilities jobCores -- Api specs are IO bound, having more jobs than cores allows for more -- cooperative IO from green thread interleaving.- pure config { configConcurrentJobs = Just $ jobCores * 4 }+ pure config {configConcurrentJobs = Just $ jobCores * 4} lookupTestCapabilities :: IO (Maybe Int) lookupTestCapabilities = fmap Unsafe.read <$> lookupEnv "TEST_CAPABILITIES"@@ -93,7 +102,7 @@ reduceCapabilities = max 1 . (`div` 2) skip :: (Path -> Bool) -> Config -> Config-skip predicate config = config { configSkipPredicate = Just predicate }+skip predicate config = config {configSkipPredicate = Just predicate} unreliableTests :: Path -> Bool unreliableTests = ("UNRELIABLE" `isInfixOf`) . snd
library/Freckle/App/Wai.hs view
@@ -3,14 +3,14 @@ ( noCacheMiddleware , denyFrameEmbeddingMiddleware - -- * CORS+ -- * CORS , corsMiddleware - -- * Logs+ -- * Logs , requestLogger , addThreadContextFromRequest - -- * Metrics+ -- * Metrics , addThreadContextFromStatsTags , requestStats ) where
library/Freckle/App/Yesod.hs view
@@ -7,7 +7,7 @@ import Freckle.App.Prelude import Blammo.Logging-import Database.PostgreSQL.Simple (SqlError(..))+import Database.PostgreSQL.Simple (SqlError (..)) import Freckle.App.Stats (HasStatsClient) import qualified Freckle.App.Stats as Stats import Network.HTTP.Types (ResponseHeaders, status503)@@ -18,7 +18,6 @@ -- | Catch 'SqlError' when queries are canceled due to timeout and respond 503 -- -- Also logs and increments a metric.--- respondQueryCanceled :: HasStatsClient site => HandlerFor site res -> HandlerFor site res respondQueryCanceled = respondQueryCanceledHeaders []
library/Freckle/App/Yesod/Routes.hs view
@@ -20,7 +20,6 @@ -- > \case -- > RoutePiece a -> case a of -- > RouteResource{} -> "ResourceName"--- mkRouteNameCaseExp :: [ResourceTree String] -> TH.Q TH.Exp mkRouteNameCaseExp tree = TH.LamCaseE . fold <$> traverse mkMatches tree @@ -28,15 +27,13 @@ -- -- > RoutePiece a -> case a of -- > ...--- mkMatches :: ResourceTree String -> TH.Q [TH.Match] mkMatches (ResourceLeaf resource) = pure [mkLeafMatch resource] mkMatches (ResourceParent name _checkOverlap params children) = do caseVar <- TH.newName "a"- let- -- by convention the final param in a route is the next route constructor- paramVars =- fmap (const TH.WildP) (filter isDynamic params) <> [TH.VarP caseVar]+ let -- by convention the final param in a route is the next route constructor+ paramVars =+ fmap (const TH.WildP) (filter isDynamic params) <> [TH.VarP caseVar] matches <- fold <$> traverse mkMatches children pure [ TH.Match@@ -44,7 +41,8 @@ (TH.NormalB $ TH.CaseE (TH.VarE caseVar) matches) [] ]- where constName = TH.mkName name+ where+ constName = TH.mkName name conP :: TH.Name -> [TH.Pat] -> TH.Pat #if MIN_VERSION_template_haskell(2,18,0)@@ -55,18 +53,18 @@ isDynamic :: Piece a -> Bool isDynamic = \case- Static{} -> False- Dynamic{} -> True+ Static {} -> False+ Dynamic {} -> True -- | Leaf match expressions for a resource -- -- > Name{} -> "ResourceName"--- mkLeafMatch :: Resource String -> TH.Match-mkLeafMatch resource = TH.Match- (TH.RecP constName [])- (TH.NormalB $ TH.LitE $ TH.StringL name)- []+mkLeafMatch resource =+ TH.Match+ (TH.RecP constName [])+ (TH.NormalB $ TH.LitE $ TH.StringL name)+ [] where constName = TH.mkName name name = resourceName resource
library/Network/HTTP/Link/Compat.hs view
@@ -1,10 +1,11 @@ {-# LANGUAGE CPP #-}+ module Network.HTTP.Link.Compat- ( Link- , linkURI- , parseLinkURI- , module Network.HTTP.Link- )+ ( Link+ , linkURI+ , parseLinkURI+ , module Network.HTTP.Link+ ) where import Prelude
library/Network/Wai/Middleware/Cors.hs view
@@ -26,11 +26,13 @@ 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+ ("OPTIONS", Just origin) ->+ sendResponse $+ responseLBS+ status200+ ( toHeaders $ corsResponseHeaders validateOrigin extraExposedHeaders origin+ )+ mempty _ -> app req sendResponse where toHeaders :: [(ByteString, ByteString)] -> ResponseHeaders@@ -40,11 +42,12 @@ 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+ Just origin ->+ addHeaders+ (corsResponseHeaders validateOrigin extraExposedHeaders origin)+ app+ req+ sendResponse corsResponseHeaders :: (ByteString -> Bool)
library/Network/Wai/Middleware/Stats.hs view
@@ -10,9 +10,9 @@ import Control.Monad.Reader (runReaderT) import Data.Aeson ((.=)) import qualified Freckle.App.Aeson as Key-import Freckle.App.Stats (HasStatsClient(..), tagsL)+import Freckle.App.Stats (HasStatsClient (..), tagsL) import qualified Freckle.App.Stats as Stats-import Network.HTTP.Types.Status (Status(..))+import Network.HTTP.Types.Status (Status (..)) import Network.Wai (Middleware, Request, requestMethod, responseStatus) -- | Add any tags in the ambient 'StatsClient' to the logging context@@ -30,12 +30,11 @@ requestStats env getTags app req respond = do start <- getCurrentTime app req $ \res -> do- let- tags =- getTags req- <> [ ("method", decodeUtf8 $ requestMethod req)- , ("status", pack $ show $ statusCode $ responseStatus res)- ]+ let tags =+ getTags req+ <> [ ("method", decodeUtf8 $ requestMethod req)+ , ("status", pack $ show $ statusCode $ responseStatus res)+ ] flip runReaderT env $ Stats.tagged tags $ do Stats.increment "requests"
library/Yesod/Core/Lens.hs view
@@ -9,7 +9,7 @@ import Yesod.Core.Types (HandlerData, RunHandlerEnv, handlerEnv, rheSite) envL :: Lens' (HandlerData child site) (RunHandlerEnv child site)-envL = lens handlerEnv $ \x y -> x { handlerEnv = y }+envL = lens handlerEnv $ \x y -> x {handlerEnv = y} siteL :: Lens' (RunHandlerEnv child site) site-siteL = lens rheSite $ \x y -> x { rheSite = y }+siteL = lens rheSite $ \x y -> x {rheSite = y}
package.yaml view
@@ -1,5 +1,5 @@ name: freckle-app-version: 1.9.0.3+version: 1.9.1.0 maintainer: Freckle Education category: Utils github: freckle/freckle-app@@ -99,6 +99,7 @@ - http-conduit >= 2.3.5 # addToRequestQueryString - http-link-header - http-types+ - hw-kafka-client - immortal - lens - memcache
tests/Freckle/App/Bugsnag/MetaDataSpec.hs view
@@ -24,13 +24,13 @@ withThreadContext ["quix" .= ("quip" :: Text)] $ do collected <- collectMetaData - let- expected = mconcat- [ metaData- "tags"- ["foo" .= ("bar" :: Text), "baz" .= ("bat" :: Text)]- , metaData "context" ["quix" .= ("quip" :: Text)]- ]+ let expected =+ mconcat+ [ metaData+ "tags"+ ["foo" .= ("bar" :: Text), "baz" .= ("bat" :: Text)]+ , metaData "context" ["quix" .= ("quip" :: Text)]+ ] runMergeMetaData Nothing collected `shouldBe` Just expected @@ -42,34 +42,37 @@ it "preserves new metadata on collisions" $ example $ do let- existing = metaData- "test"- [ "foo" .= ("bar1" :: Text)- , "baz" .= object ["bat" .= ("quix1" :: Text)]- , "keep" .= ("me" :: Text)- ]- incoming = metaData- "test"- [ "foo" .= ("bar2" :: Text)- , "baz" .= object ["bat" .= ("quix2" :: Text)]- , "add" .= ("me" :: Text)- ]- expected = metaData- "test"- [ "foo" .= ("bar2" :: Text)- , "baz" .= object ["bat" .= ("quix2" :: Text)]- , "keep" .= ("me" :: Text)- , "add" .= ("me" :: Text)- ]-+ existing =+ metaData+ "test"+ [ "foo" .= ("bar1" :: Text)+ , "baz" .= object ["bat" .= ("quix1" :: Text)]+ , "keep" .= ("me" :: Text)+ ]+ incoming =+ metaData+ "test"+ [ "foo" .= ("bar2" :: Text)+ , "baz" .= object ["bat" .= ("quix2" :: Text)]+ , "add" .= ("me" :: Text)+ ]+ expected =+ metaData+ "test"+ [ "foo" .= ("bar2" :: Text)+ , "baz" .= object ["bat" .= ("quix2" :: Text)]+ , "keep" .= ("me" :: Text)+ , "add" .= ("me" :: Text)+ ] runMergeMetaData (Just existing) incoming `shouldBe` Just expected runMergeMetaData :: Maybe MetaData -> MetaData -> Maybe MetaData runMergeMetaData mExisting incoming = MetaData <$> event_metaData event where- event = runBeforeNotify (mergeMetaData incoming) someException- $ defaultEvent { event_metaData = unMetaData <$> mExisting }+ event =+ runBeforeNotify (mergeMetaData incoming) someException $+ defaultEvent {event_metaData = unMetaData <$> mExisting} someException :: SomeException someException = undefined
tests/Freckle/App/BugsnagSpec.hs view
@@ -5,7 +5,7 @@ import Freckle.App.Prelude import Data.ByteString (ByteString)-import Database.PostgreSQL.Simple (ExecStatus(..), SqlError(..))+import Database.PostgreSQL.Simple (ExecStatus (..), SqlError (..)) import Freckle.App.Bugsnag import Test.Hspec @@ -14,21 +14,24 @@ describe "sqlErrorGroupingHash" $ do it "groups duplicate key errors by constraint name" $ do let- err1 = sqlError- { sqlState = duplicateKeyState- , sqlErrorMsg = duplicateKeyErrorMsg "table_a_id_key"- , sqlErrorDetail = "Key (a, b)=(1, 2) already exists"- }- err2 = sqlError- { sqlState = duplicateKeyState- , sqlErrorMsg = duplicateKeyErrorMsg "table_a_id_key"- , sqlErrorDetail = "Key (a, b)=(3, 2) already exists"- }- err3 = sqlError- { sqlState = duplicateKeyState- , sqlErrorMsg = duplicateKeyErrorMsg "table_b_id_key"- , sqlErrorDetail = "Key (a, b)=(1, 2) already exists"- }+ err1 =+ sqlError+ { sqlState = duplicateKeyState+ , sqlErrorMsg = duplicateKeyErrorMsg "table_a_id_key"+ , sqlErrorDetail = "Key (a, b)=(1, 2) already exists"+ }+ err2 =+ sqlError+ { sqlState = duplicateKeyState+ , sqlErrorMsg = duplicateKeyErrorMsg "table_a_id_key"+ , sqlErrorDetail = "Key (a, b)=(3, 2) already exists"+ }+ err3 =+ sqlError+ { sqlState = duplicateKeyState+ , sqlErrorMsg = duplicateKeyErrorMsg "table_b_id_key"+ , sqlErrorDetail = "Key (a, b)=(1, 2) already exists"+ } -- All duplicate keys hashed sqlErrorGroupingHash err1 `shouldSatisfy` isJust@@ -42,26 +45,30 @@ it "groups foreign key errors by constraint name" $ do let- err1 = sqlError- { sqlState = foreignKeyState- , sqlErrorMsg = foreignKeyErrorMsg "table_a" "table_b_id_fkey"- , sqlErrorDetail = "Key (a, b)=(1, 2) is still referenced"- }- err2 = sqlError- { sqlState = foreignKeyState- , sqlErrorMsg = foreignKeyErrorMsg "table_a" "table_b_id_fkey"- , sqlErrorDetail = "Key (a, b)=(3, 2) is still referenced"- }- err3 = sqlError- { sqlState = foreignKeyState- , sqlErrorMsg = foreignKeyErrorMsg "table_b" "table_b_id_key"- , sqlErrorDetail = "Key (a, b)=(1, 2) is still referenced"- }- err4 = sqlError- { sqlState = foreignKeyState- , sqlErrorMsg = foreignKeyErrorMsg "table_a" "table_a_id_key"- , sqlErrorDetail = "Key (a, b)=(1, 2) is still referenced"- }+ err1 =+ sqlError+ { sqlState = foreignKeyState+ , sqlErrorMsg = foreignKeyErrorMsg "table_a" "table_b_id_fkey"+ , sqlErrorDetail = "Key (a, b)=(1, 2) is still referenced"+ }+ err2 =+ sqlError+ { sqlState = foreignKeyState+ , sqlErrorMsg = foreignKeyErrorMsg "table_a" "table_b_id_fkey"+ , sqlErrorDetail = "Key (a, b)=(3, 2) is still referenced"+ }+ err3 =+ sqlError+ { sqlState = foreignKeyState+ , sqlErrorMsg = foreignKeyErrorMsg "table_b" "table_b_id_key"+ , sqlErrorDetail = "Key (a, b)=(1, 2) is still referenced"+ }+ err4 =+ sqlError+ { sqlState = foreignKeyState+ , sqlErrorMsg = foreignKeyErrorMsg "table_a" "table_a_id_key"+ , sqlErrorDetail = "Key (a, b)=(1, 2) is still referenced"+ } -- All errors hashed sqlErrorGroupingHash err1 `shouldSatisfy` isJust@@ -78,43 +85,44 @@ sqlErrorGroupingHash err3 `shouldNotBe` sqlErrorGroupingHash err4 it "does not group other SqlErrors" $ do- let- err = sqlError- { sqlState = "9999"- , sqlErrorMsg = duplicateKeyErrorMsg "table_a_id_key"- , sqlErrorDetail = "Key (a, b)=(1, 2) already exists"- }+ let err =+ sqlError+ { sqlState = "9999"+ , sqlErrorMsg = duplicateKeyErrorMsg "table_a_id_key"+ , sqlErrorDetail = "Key (a, b)=(1, 2) already exists"+ } sqlErrorGroupingHash err `shouldBe` Nothing it "does not group other states" $ do- let- err = sqlError- { sqlState = "12345"- , sqlErrorMsg = "State is wrong, \"table_a_id_key\""- , sqlErrorDetail = "Key (a, b)=(1, 2) already exists"- }+ let err =+ sqlError+ { sqlState = "12345"+ , sqlErrorMsg = "State is wrong, \"table_a_id_key\""+ , sqlErrorDetail = "Key (a, b)=(1, 2) already exists"+ } sqlErrorGroupingHash err `shouldBe` Nothing it "does not group when unable to parse" $ do- let- err = sqlError- { sqlState = foreignKeyState- , sqlErrorMsg = "FK needs two quoted values, \"table_a_id_fkey\""- , sqlErrorDetail = "Key (a, b)=(1, 2) already exists"- }+ let err =+ sqlError+ { sqlState = foreignKeyState+ , sqlErrorMsg = "FK needs two quoted values, \"table_a_id_fkey\""+ , sqlErrorDetail = "Key (a, b)=(1, 2) already exists"+ } sqlErrorGroupingHash err `shouldBe` Nothing sqlError :: SqlError-sqlError = SqlError- { sqlState = ""- , sqlExecStatus = FatalError- , sqlErrorMsg = ""- , sqlErrorDetail = ""- , sqlErrorHint = ""- }+sqlError =+ SqlError+ { sqlState = ""+ , sqlExecStatus = FatalError+ , sqlErrorMsg = ""+ , sqlErrorDetail = ""+ , sqlErrorHint = ""+ } duplicateKeyState :: ByteString duplicateKeyState = "23505"
tests/Freckle/App/CsvSpec.hs view
@@ -52,21 +52,21 @@ header = ["someInt", "someText"] rows :: [Foo] rows = [Foo 123 "this is some text", Foo 456 "this is more text"]- it "should parse records as expected"- $ decode HasHeader content- `shouldBe` Right (V.fromList rows)+ it "should parse records as expected" $+ decode HasHeader content+ `shouldBe` Right (V.fromList rows) - it "should parse named records as expected"- $ decodeByName content- `shouldBe` Right (V.fromList header, V.fromList rows)+ it "should parse named records as expected" $+ decodeByName content+ `shouldBe` Right (V.fromList header, V.fromList rows) - it "should serialize records as expected"- $ encode rows- `shouldBe` contentRows+ it "should serialize records as expected" $+ encode rows+ `shouldBe` contentRows - it "should serialize named records as expected"- $ encodeDefaultOrderedByName rows- `shouldBe` content+ it "should serialize named records as expected" $+ encodeDefaultOrderedByName rows+ `shouldBe` content for_ [CustomParser, FromNamedRecordParser] $ \testType -> do describe (csvSinkTestName testType) $ do@@ -78,8 +78,9 @@ it "should generate errors for parse errors" $ do result <- csvSinkTest testType (yieldMany []) pure- runValidate result `shouldBe` Left- (pure $ CsvParseException @Void 1 "parse error (not enough input)")+ runValidate result+ `shouldBe` Left+ (pure $ CsvParseException @Void 1 "parse error (not enough input)") it "should generate errors per row" $ do let@@ -98,7 +99,6 @@ first (fmap errorLine) (runValidate result) `shouldBe` Left (NE.fromList [2, 4, 5]) - it "should generate errors for non-utf8-encoded files" $ do let source = yieldMany [BS.pack [0XFF, 0XFF, 0XFF, 0XFF]] result <- csvSinkTest testType source pure@@ -109,34 +109,37 @@ validate foo@Foo {..} | someInt < 4 = pure foo | otherwise = refute $ pure $ CsvExceptionExtension BadFoo- source = yieldMany- [ "someInt,someText\n"- , "3,meep\n"- , "4,morp\n"- , "1,whomp\n"- , "5,merp\n"- ]+ source =+ yieldMany+ [ "someInt,someText\n"+ , "3,meep\n"+ , "4,morp\n"+ , "1,whomp\n"+ , "5,merp\n"+ ] result <- csvSinkTest testType source $ traverse validate runValidate result `shouldBe` Left- (NE.fromList- [ CsvExceptionExtension BadFoo- , CsvExceptionExtension BadFoo- ]- )+ ( NE.fromList+ [ CsvExceptionExtension BadFoo+ , CsvExceptionExtension BadFoo+ ]+ ) it "should successfully parse a CSV" $ do let validate foo@Foo {..} | someInt < 4 = pure foo | otherwise = refute $ pure $ CsvExceptionExtension BadFoo- source = yieldMany- ["someInt,someText\n", "1,meep\n", "2,morp\n", "3,merp\n"]+ source =+ yieldMany+ ["someInt,someText\n", "1,meep\n", "2,morp\n", "3,merp\n"] result <- csvSinkTest testType source $ traverse validate- runValidate result `shouldBe` Right- (V.fromList [Foo 1 "meep", Foo 2 "morp", Foo 3 "merp"])+ runValidate result+ `shouldBe` Right+ (V.fromList [Foo 1 "meep", Foo 2 "morp", Foo 3 "merp"]) it "should successfully parse a CSV with weird whitespace" $ do let@@ -152,8 +155,9 @@ ] result <- csvSinkTest testType source $ traverse validate- runValidate result `shouldBe` Right- (V.fromList [Foo 1 "meep", Foo 2 "morp", Foo 3 "merp"])+ runValidate result+ `shouldBe` Right+ (V.fromList [Foo 1 "meep", Foo 2 "morp", Foo 3 "merp"]) data CSVSinkTest = CustomParser | FromNamedRecordParser @@ -174,7 +178,7 @@ => CSVSinkTest -> ConduitT () ByteString (ResourceT m) () -> ( Vector Foo- -> Validate (NonEmpty (CsvException err)) (Vector Foo)+ -> Validate (NonEmpty (CsvException err)) (Vector Foo) ) -> m (Validate (NonEmpty (CsvException err)) (Vector Foo)) csvSinkTest = \case
tests/Freckle/App/HttpSpec.hs view
@@ -4,7 +4,7 @@ import Prelude -import Control.Lens (_Left, _Right, to, (^?))+import Control.Lens (to, (^?), _Left, _Right) import Data.Aeson import Data.Aeson.Lens import qualified Data.List.NonEmpty as NE@@ -16,30 +16,31 @@ spec = do describe "httpJson" $ do it "fetches JSON via HTTP" $ do- resp <- httpJson @_ @Value- $ parseRequest_ "https://www.stackage.org/lts-17.10"+ resp <-+ httpJson @_ @Value $+ parseRequest_ "https://www.stackage.org/lts-17.10" getResponseStatus resp `shouldBe` status200 getResponseBody resp ^? _Right- . key "snapshot"- . key "ghc"- . _String+ . key "snapshot"+ . key "ghc"+ . _String `shouldBe` Just "8.10.4" it "places JSON parse errors in a Left body" $ do- resp <- httpJson @_ @[()]- $ parseRequest_ "https://www.stackage.org/lts-17.10"+ resp <-+ httpJson @_ @[()] $+ parseRequest_ "https://www.stackage.org/lts-17.10" - let- expectedErrorMessages =- [ "Error in $: expected [a], encountered Object"- , "Error in $: parsing [] failed, expected Array, but encountered Object"- ]+ let expectedErrorMessages =+ [ "Error in $: expected [a], encountered Object"+ , "Error in $: parsing [] failed, expected Array, but encountered Object"+ ] getResponseStatus resp `shouldBe` status200 getResponseBody resp ^? _Left- . to hdeErrors- . to NE.head+ . to hdeErrors+ . to NE.head `shouldSatisfy` maybe False (`elem` expectedErrorMessages)
tests/Freckle/App/Memcached/ServersSpec.hs view
@@ -64,9 +64,9 @@ `shouldBe` Just (Memcache.Auth "user" "password") it "can do all of this for a list of servers" $ example $ do- let- mServerSpecs = readServerSpecs- "memcached://a-host,memcached://b-host:11212,memcached://u:p@:11213"+ let mServerSpecs =+ readServerSpecs+ "memcached://a-host,memcached://b-host:11212,memcached://u:p@:11213" fmap (map Memcache.ssHost) mServerSpecs `shouldBe` Just ["a-host", "b-host", defaultHost]@@ -74,7 +74,7 @@ `shouldBe` Just ["11211", "11212", "11213"] fmap (map Memcache.ssAuth) mServerSpecs `shouldBe` Just- [Memcache.NoAuth, Memcache.NoAuth, Memcache.Auth "u" "p"]+ [Memcache.NoAuth, Memcache.NoAuth, Memcache.Auth "u" "p"] readServerSpec :: String -> Maybe Memcache.ServerSpec readServerSpec = headMay <=< readServerSpecs
tests/Freckle/App/MemcachedSpec.hs view
@@ -9,7 +9,7 @@ import Blammo.Logging.LogSettings import Blammo.Logging.Logger import Control.Lens (lens)-import Data.Aeson (Value(..))+import Data.Aeson (Value (..)) import Data.Aeson.Compat as KeyMap import qualified Data.List.NonEmpty as NE import qualified Freckle.App.Env as Env@@ -43,20 +43,22 @@ instance HasMemcachedClient App where memcachedClientL =- lens appMemcachedClient $ \x y -> x { appMemcachedClient = y }+ lens appMemcachedClient $ \x y -> x {appMemcachedClient = y} instance HasLogger App where- loggerL = lens appLogger $ \x y -> x { appLogger = y }+ loggerL = lens appLogger $ \x y -> x {appLogger = y} loadApp :: (App -> IO a) -> IO a loadApp f = do- servers <- Env.parse id $ Env.var- (Env.eitherReader readMemcachedServers)- "MEMCACHED_SERVERS"- (Env.def defaultMemcachedServers)+ servers <-+ Env.parse id $+ Env.var+ (Env.eitherReader readMemcachedServers)+ "MEMCACHED_SERVERS"+ (Env.def defaultMemcachedServers) appLogger <- newTestLogger defaultLogSettings withMemcachedClient servers $ \appMemcachedClient -> do- f App { .. }+ f App {..} spec :: Spec spec = withApp loadApp $ do@@ -84,7 +86,8 @@ msgs <- getLoggedMessagesLenient let Just LoggedMessage {..} = NE.last <$> NE.nonEmpty msgs loggedMessageText `shouldBe` "Error deserializing"- loggedMessageMeta `shouldBe` KeyMap.fromList- [ ("action", String "deserializing")- , ("message", String "invalid: \"Broken\"")- ]+ loggedMessageMeta+ `shouldBe` KeyMap.fromList+ [ ("action", String "deserializing")+ , ("message", String "invalid: \"Broken\"")+ ]
tests/Freckle/App/Test/Properties/JSONSpec.hs view
@@ -23,6 +23,6 @@ describe "prop_roundTripJSON" $ do it "round trips for Integer" $ property $ prop_roundTripJSON @Integer it "round trips for Bool" $ property $ prop_roundTripJSON @Bool- it "round trips for some custom type"- $ property- $ prop_roundTripJSON @MyCustomType+ it "round trips for some custom type" $+ property $+ prop_roundTripJSON @MyCustomType
tests/Freckle/App/Test/Properties/PathPieceSpec.hs view
@@ -13,6 +13,6 @@ describe "pathPieceInstancesRoundTrip" $ do it "round trips for Integer" $ property $ prop_roundTripPathPiece @Integer it "round trips for Bool" $ property $ prop_roundTripPathPiece @Bool- it "round trips for Maybe String"- $ property- $ prop_roundTripPathPiece @(Maybe String)+ it "round trips for Maybe String" $+ property $+ prop_roundTripPathPiece @(Maybe String)
tests/Freckle/App/WaiSpec.hs view
@@ -8,7 +8,10 @@ import Data.Function (on) import Data.List (deleteBy) import Freckle.App.Wai- (corsMiddleware, denyFrameEmbeddingMiddleware, noCacheMiddleware)+ ( corsMiddleware+ , denyFrameEmbeddingMiddleware+ , noCacheMiddleware+ ) import Network.HTTP.Types.Method (Method) import Network.HTTP.Types.Status (status200) import Network.Wai@@ -42,17 +45,23 @@ runSession f $ corsMiddleware validateOrigin extraExposedHeaders app it "adds CORS headers to responses for non-OPTIONS" $ runTestSession $ do- response <- request $ setMethod "GET" $ setOriginHeader- "unimportant"- defaultRequest+ response <-+ request $+ setMethod "GET" $+ setOriginHeader+ "unimportant"+ defaultRequest assertAccessControlHeaders "BADORIGIN" response assertBody "Test" response it "responds itself, with CORS headers, for OPTIONS" $ runTestSession $ do- response <- request $ setMethod "OPTIONS" $ setOriginHeader- "unimportant"- defaultRequest+ response <-+ request $+ setMethod "OPTIONS" $+ setOriginHeader+ "unimportant"+ defaultRequest assertAccessControlHeaders "BADORIGIN" response assertBody mempty response@@ -75,9 +84,9 @@ assertBody "Test" responseA assertBody "Test" responseB - it "adds extra Exposed-Headers"- $ runTestSessionWith (const False) ["X-Foo"]- $ do+ it "adds extra Exposed-Headers" $+ runTestSessionWith (const False) ["X-Foo"] $+ do response <- request $ setOriginHeader "unimportant" defaultRequest assertHeader "Access-Control-Expose-Headers"@@ -99,14 +108,15 @@ app _req respond = respond $ responseLBS status200 [] "Test" setMethod :: Method -> Request -> Request-setMethod method req = req { requestMethod = method }+setMethod method req = req {requestMethod = method} setOriginHeader :: ByteString -> Request -> Request setOriginHeader origin req = let header = ("Origin", origin) others = deleteBy ((==) `on` fst) header $ requestHeaders req- in req { requestHeaders = others <> [header] }+ in+ req {requestHeaders = others <> [header]} assertAccessControlHeaders :: ByteString -> SResponse -> Session () assertAccessControlHeaders origin response = do