packages feed

freckle-app 1.5.1.0 → 1.6.0.0

raw patch · 17 files changed

+394/−271 lines, 17 filesdep +dotenvdep −directorydep −load-envdep −process

Dependencies added: dotenv

Dependencies removed: directory, load-env, process, temporary

Files

CHANGELOG.md view
@@ -1,4 +1,33 @@-## [_Unreleased_](https://github.com/freckle/freckle-app/compare/v1.5.1.0...main)+## [_Unreleased_](https://github.com/freckle/freckle-app/compare/v1.6.0.0...main)++## [v1.6.0.0](https://github.com/freckle/freckle-app/compare/v1.5.0.1...v1.6.0.0)++- Remove `AppVersion`++  This also removes the `test-git` flag.++  This was over-engineered, in our opinion. If you're making use of the+  conventional `DD_` variables that the `Stats` module expects, you should be+  able to:++  - Replace any `appVersion :: AppVersion` with `appVersion :: Text`+  - Replace `appVersion <- getAppVersion` with `appVersion <- maybe "unknown" pack <$> lookupEnv "DD_VERSION"`+  - Replace `avName appVersion` with `appVersion`+  - Remove uses of `avCreatedAt`++- Add `Freckle.App.Dotenv`, wrapping [`dotenv`](https://hackage.haskell.org/package/dotenv)++  And move `Freckle.App.Test.withApp` to use it instead of `LoadEnv`. This is+  behavior-neutral except:++  - We no longer load `.env` after `.env.test`, we only load `.env.test`++    Missing variables should generate errors prompting you to copy values from+    the former to the latter as required.++  - We will verify the `.env` file against an `.env.example` if present.++- Add `Freckle.App.Bugsnag.Metadata`  ## [v1.5.0.1](https://github.com/freckle/freckle-app/compare/v1.5.0.1...v1.5.1.0)
freckle-app.cabal view
@@ -1,6 +1,6 @@ cabal-version:      1.18 name:               freckle-app-version:            1.5.1.0+version:            1.6.0.0 license:            MIT license-file:       LICENSE maintainer:         Freckle Education@@ -19,15 +19,15 @@     type:     git     location: https://github.com/freckle/freckle-app -flag test-git-    description: Run tests that run git commands-    manual:      True- library     exposed-modules:+        Configuration.Dotenv.Compat         Freckle.App+        Freckle.App.Aeson         Freckle.App.Bugsnag+        Freckle.App.Bugsnag.MetaData         Freckle.App.Database+        Freckle.App.Dotenv         Freckle.App.Ecs         Freckle.App.Env         Freckle.App.Ghci@@ -50,7 +50,6 @@         Freckle.App.Test.Hspec.Runner         Freckle.App.Test.Properties.JSON         Freckle.App.Test.Properties.PathPiece-        Freckle.App.Version         Freckle.App.Wai         Freckle.App.Yesod         Freckle.App.Yesod.Routes@@ -83,6 +82,7 @@         containers >=0.5.11.0,         datadog >=0.2.3.0,         doctest >=0.16.0.1,+        dotenv >=0.5.2.5,         ekg-core >=0.1.1.7,         envparse >=0.5.0,         errors >=2.3.0,@@ -100,7 +100,6 @@         http-types >=0.12.2,         immortal >=0.3,         lens >=4.16.1,-        load-env >=0.2.0.2,         memcache >=0.3.0.1,         monad-control >=1.0.2.3,         mtl >=2.2.2,@@ -149,45 +148,12 @@         base >=4.11.1.0 && <5,         freckle-app -any -test-suite gittest-    type:               exitcode-stdio-1.0-    main-is:            Main.hs-    hs-source-dirs:     gittest-    other-modules:-        Freckle.App.VersionSpec-        Spec-        Paths_freckle_app--    default-language:   Haskell2010-    default-extensions:-        BangPatterns DataKinds DeriveAnyClass DeriveFoldable DeriveFunctor-        DeriveGeneric DeriveLift DeriveTraversable DerivingStrategies-        FlexibleContexts FlexibleInstances GADTs GeneralizedNewtypeDeriving-        LambdaCase MultiParamTypeClasses NoImplicitPrelude-        NoMonomorphismRestriction OverloadedStrings RankNTypes-        RecordWildCards ScopedTypeVariables StandaloneDeriving-        TypeApplications TypeFamilies--    build-depends:-        base >=4.11.1.0 && <5,-        directory >=1.3.1.5,-        freckle-app -any,-        hspec >=2.8.1,-        process >=1.6.3.0,-        temporary >=1.3,-        text >=1.2.3.1,-        time >=1.8.0.2--    if flag(test-git)--    else-        buildable: False- test-suite spec     type:               exitcode-stdio-1.0     main-is:            Main.hs     hs-source-dirs:     tests     other-modules:+        Freckle.App.Bugsnag.MetaDataSpec         Freckle.App.BugsnagSpec         Freckle.App.HttpSpec         Freckle.App.Memcached.ServersSpec@@ -214,6 +180,7 @@         QuickCheck >=2.13.1,         aeson >=1.5.2.0,         base >=4.11.1.0 && <5,+        bugsnag >=1.0.0.1,         bytestring >=0.10.8.2,         errors >=2.3.0,         freckle-app -any,@@ -223,5 +190,6 @@         lens-aeson >=1.1,         memcache >=0.3.0.1,         postgresql-simple >=0.6.2,+        unliftio >=0.2.9.0,         wai >=3.2.1.2,         wai-extra >=3.0.29
− gittest/Freckle/App/VersionSpec.hs 
@@ -1,59 +0,0 @@-module Freckle.App.VersionSpec-  ( spec-  )-where--import Prelude--import Data.Bifunctor (first)-import Data.Maybe (fromMaybe)-import Data.Text (unpack)-import Data.Time (UTCTime)-import Data.Time.Format (defaultTimeLocale, parseTimeM)-import Freckle.App.Version-import System.Directory (withCurrentDirectory)-import System.IO.Temp (withSystemTempDirectory)-import System.Process (callProcess, readProcess)-import Test.Hspec--spec :: Spec-spec = do-  describe "getAppVersion" $ do-    -- NB. This is a single test case because the temporary directory and git-    -- stuff steps all over itself when run in parallel.-    ---    -- This could be a bug in withSystemTempDirectory or withCurrentDirectory?-    ---    it "tries files, then git, and records failed attempts" $ do-      inTemporaryDirectory $ \tmp -> do-        eVersion1 <- tryGetAppVersion tmp-        first (map $ unwords . take 6 . words) eVersion1 `shouldBe` Left-          [ "readFile: " <> tmp <> "/name: openFile: does not exist"-          , "[128] git rev-parse HEAD: fatal: not"-          ]--        callProcess "git" ["init", "--quiet"]-        callProcess "git" ["commit", "--quiet", "--allow-empty", "-m", "x"]-        sha <- readProcess "git" ["rev-parse", "HEAD"] ""--        eVersion2 <- tryGetAppVersion tmp-        fmap (unpack . (<> "\n") . avName) eVersion2 `shouldBe` Right sha--        let seconds = "1582301740"-        writeFile "name" "a version"-        writeFile "created-at" seconds--        eVersion3 <- tryGetAppVersion tmp-        eVersion3 `shouldBe` Right AppVersion-          { avName = "a version"-          , avCreatedAt = parseTimeUnsafe "%s" seconds-          }--inTemporaryDirectory :: (FilePath -> IO a) -> IO a-inTemporaryDirectory f = withSystemTempDirectory "freckle-app-tests"-  $ \tmp -> withCurrentDirectory tmp $ f tmp--parseTimeUnsafe :: String -> String -> UTCTime-parseTimeUnsafe fmt str = fromMaybe err-  $ parseTimeM True defaultTimeLocale fmt str-  where err = error $ str <> " did not parse as UTCTime format " <> fmt
− gittest/Main.hs 
@@ -1,13 +0,0 @@-module Main-  ( main-  )-where--import Prelude--import Freckle.App.Test.Hspec.Runner (runParConfig)-import qualified Spec-import Test.Hspec--main :: IO ()-main = "freckle-app" `runParConfig` parallel Spec.spec
− gittest/Spec.hs 
@@ -1,1 +0,0 @@-{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --module-name=Spec #-}
+ library/Configuration/Dotenv/Compat.hs view
@@ -0,0 +1,12 @@+{-# LANGUAGE CPP #-}++module Configuration.Dotenv.Compat+  ( module X+  ) where++import Configuration.Dotenv as X++#if !MIN_VERSION_dotenv(0,6,0)+-- The Config type was here in older versions+import Configuration.Dotenv.Types as X+#endif
+ library/Freckle/App/Aeson.hs view
@@ -0,0 +1,23 @@+{-# LANGUAGE CPP #-}++-- | Compatibility module for "Data.Aeson" 1.x vs 2.0+--+-- TODO: An @aeson-compat@ package. Sadly, the name is taken.+--+module Freckle.App.Aeson+  ( module X+  ) where++import Prelude++-- Blammo provides a lot in its module+import Data.Aeson.Compat as X++-- But it doesn't expose the whole interface we need, so we'll add this too+#if MIN_VERSION_aeson(2,0,0)+import Data.Aeson.KeyMap as X+#else+import Data.HashMap.Strict as X+#endif++{-# ANN module ("HLint: ignore Avoid restricted qualification" :: String) #-}
library/Freckle/App/Bugsnag.hs view
@@ -32,7 +32,6 @@ import Database.PostgreSQL.Simple (SqlError(..)) import Database.PostgreSQL.Simple.Errors import qualified Freckle.App.Env as Env-import Freckle.App.Version import Network.Bugsnag hiding (notifyBugsnag, notifyBugsnagWith) import qualified Network.Bugsnag as Bugsnag import Network.HTTP.Client (HttpException(..), host, method)@@ -41,17 +40,16 @@ import Yesod.Core.Types (HandlerData)  class HasAppVersion env where-  appVersionL :: Lens' env AppVersion--instance HasAppVersion AppVersion where-  appVersionL = id+  appVersionL :: Lens' env Text  instance HasAppVersion site =>  HasAppVersion (HandlerData child site) where   appVersionL = envL . siteL . appVersionL -setAppVersion :: AppVersion -> BeforeNotify-setAppVersion AppVersion {..} = updateEvent $ \event ->-  event { event_app = Just $ defaultApp { app_version = Just avName } }+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 }  class HasBugsnagSettings env where   bugsnagSettingsL :: Lens' env Settings
+ library/Freckle/App/Bugsnag/MetaData.hs view
@@ -0,0 +1,147 @@+-- | Working with Bugsnag's 'event_metaData' field+--+-- $details+--+module Freckle.App.Bugsnag.MetaData+  ( MetaData(..)+  , metaData+  , metaDataL++  -- * Collecting ambient data+  , collectMetaData+  , collectMetaDataFromStatsClient+  , collectMetaDataFromThreadContext++  -- * 'BeforeNotify'+  , mergeMetaData+  ) where++import Freckle.App.Prelude++import Blammo.Logging (Pair, myThreadContext)+import Control.Lens (Lens', lens, to, view, (<>~))+import Data.Aeson+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)++newtype MetaData = MetaData+  { unMetaData :: Object+  }+  deriving stock (Eq, Show)++instance Semigroup MetaData where+  -- | /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+    unionObjects = Aeson.unionWith unionValues++    unionValues (Object a) (Object b) = Object $ unionObjects a b+    unionValues a _ = a++instance Monoid MetaData where+  mempty = MetaData mempty++-- | Construct 'MetaData' from 'Pair's+metaData+  :: Aeson.Key+  -- ^ The Tab within which the values will display+  -> [Pair]+  -- ^ The Key-Values themselves+  -> MetaData+metaData key = MetaData . Aeson.fromList . pure . (key .=) . object++metaDataL :: Lens' Event MetaData+metaDataL = lens get set+ where+  get event = maybe mempty MetaData $ event_metaData event+  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 =+  (<>) <$> collectMetaDataFromStatsClient <*> collectMetaDataFromThreadContext++collectMetaDataFromStatsClient+  :: (MonadReader env m, HasStatsClient env) => m MetaData+collectMetaDataFromStatsClient = view $ statsClientL . tagsL . to toMetaData+  where toMetaData = metaData "tags" . map (bimap (fromString . unpack) String)++collectMetaDataFromThreadContext :: MonadIO m => m MetaData+collectMetaDataFromThreadContext =+  liftIO $ metaData "context" . Aeson.toList <$> myThreadContext++-- | Merge 'MetaData' into the 'Event'+--+-- 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++-- $details+--+-- From <https://bugsnagerrorreportingapi.docs.apiary.io/#reference/0/notify/send-error-reports>+--+-- @events[].metaData@+--+-- > An object containing any further data you wish to attach to this error+-- > event. This should contain one or more objects, with each object being+-- > displayed in its own tab on the event details on Bugsnag.+-- >+-- > {+-- >     // Custom user data to be displayed in the User tab along with standard+-- >     // user fields on the Bugsnag website.+-- >     "user": {+-- >        ...+-- >     },+-- >+-- >     // Custom app data to be displayed in the App tab along with standard+-- >     // app fields on the Bugsnag website.+-- >     "app": {+-- >        ...+-- >     },+-- >+-- >     // Custom device data to be displayed in the Device tab along with+-- >     //standard device fields on the Bugsnag website.+-- >     "device": {+-- >        ...+-- >     },+-- >+-- >     Custom request data to be displayed in the Request tab along with+-- >     standard request fields on the Bugsnag website.+-- >     "request": {+-- >        ...+-- >     },+-- >+-- >     // This will be displayed as an extra tab on the Bugsnag website.+-- >     "Some data": {+-- >+-- >         // A key value pair that will be displayed in the first tab.+-- >         "key": "value",+-- >+-- >         // Key value pairs can be contained in nested objects which helps+-- >         // to organise the information presented in the tab.+-- >         "setOfKeys": {+-- >             "key": "value",+-- >             "key2": "value"+-- >         }+-- >     },+-- >+-- >     // This would be the second extra tab on the Bugsnag website.+-- >     "Some more data": {+-- >         ...+-- >     }+-- > }
+ library/Freckle/App/Dotenv.hs view
@@ -0,0 +1,62 @@+-- | Conventional @.env@ handling+module Freckle.App.Dotenv+  ( load+  , loadTest+  , loadFile+  ) where++import Freckle.App.Prelude++import qualified Configuration.Dotenv.Compat as Dotenv+import System.FilePath (takeDirectory, (</>))+import UnliftIO.Directory (doesFileExist, getCurrentDirectory)++-- | Call 'loadFile' with @.env@+load :: IO ()+load = loadFile ".env"++-- | Call 'loadFile' with @.env.test@+loadTest :: IO ()+loadTest = loadFile ".env.test"++-- | An opinionated 'Configuration.Dotenv.loadFile'+--+-- Additional behaviors:+--+-- 1. Attempt to locate the file in parent directories too+--+--    We, sadly, have a monorepository. So we need to locate a @.env@ file in+--    parent directories when running tests in sub-directories.+--+-- 2. Silently ignore no file found+--+--    Since this is used by 'Freckle.App.Test.withApp', which we aim to use in+--    every non-trivial project, we can't fail in projects that don't need or+--    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+  go path = do+    let examplePath = takeDirectory path </> ".env.example"+    exampleExists <- doesFileExist examplePath++    void $ Dotenv.loadFile $ Dotenv.Config+      { Dotenv.configPath = [path]+      , Dotenv.configExamplePath = [ examplePath | exampleExists ]+      , Dotenv.configOverride = False+      }++locateInParents :: FilePath -> IO (Maybe FilePath)+locateInParents path = go =<< getCurrentDirectory+ where+  go cwd = do+    let absPath = cwd </> path++    exists <- doesFileExist absPath++    if exists+      then pure $ Just absPath+      else if cwd == "/" then pure Nothing else go $ takeDirectory cwd
library/Freckle/App/Ghci.hs view
@@ -1,8 +1,6 @@ module Freckle.App.Ghci   ( runDB   , runDB'-  , loadEnv-  , loadEnvTest   ) where  import Freckle.App.Prelude@@ -11,17 +9,14 @@ import Database.Persist.Postgresql (runSqlPool) import Database.Persist.Sql (SqlBackend) import Freckle.App.Database (makePostgresPool)-import LoadEnv (loadEnv, loadEnvFrom)+import qualified Freckle.App.Dotenv as Dotenv  -- | Run a db action against .env runDB :: ReaderT SqlBackend IO b -> IO b-runDB f = loadEnv *> runDB' f+runDB f = Dotenv.load *> runDB' f  -- | Run a db action runDB' :: ReaderT SqlBackend IO b -> IO b runDB' f = do   pool <- runSimpleLoggingT makePostgresPool   runSqlPool f pool--loadEnvTest :: IO ()-loadEnvTest = loadEnvFrom ".env.test"
library/Freckle/App/Stats.hs view
@@ -6,6 +6,8 @@ -- module Freckle.App.Stats   ( StatsSettings+  , defaultStatsSettings+  , setStatsSettingsTags   , envParseStatsSettings    -- * Client@@ -44,6 +46,16 @@   , amsTags :: [(Text, Text)]   } +defaultStatsSettings :: StatsSettings+defaultStatsSettings = StatsSettings+  { amsEnabled = False+  , amsSettings = Datadog.defaultSettings+  , amsTags = []+  }++setStatsSettingsTags :: [(Text, Text)] -> StatsSettings -> StatsSettings+setStatsSettingsTags x settings = settings { amsTags = x }+ envParseStatsSettings :: Env.Parser Env.Error StatsSettings envParseStatsSettings =   StatsSettings@@ -104,7 +116,7 @@         -- Add the tags to the thread context so they're present in all logs         withThreadContext (map toPair tags)           $ f StatsClient { scClient = client, scTags = tags }-    else f $ StatsClient { scClient = Datadog.Dummy, scTags = [] }+    else f $ StatsClient { scClient = Datadog.Dummy, scTags = amsTags }   where toPair = bimap (fromString . unpack) String  -- | Include the given tags on all metrics emitted from a block
library/Freckle/App/Test.hs view
@@ -8,6 +8,7 @@   , appExample   , withApp   , withAppSql+  , beforeSql   , expectationFailure   , pending   , pendingWith@@ -44,7 +45,7 @@ import Control.Monad.Reader import Control.Monad.Trans.Control import Database.Persist.Sql (SqlPersistT, runSqlPool)-import LoadEnv+import qualified Freckle.App.Dotenv as Dotenv 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)@@ -120,12 +121,11 @@ -- spec = 'withApp' loadApp $ do -- @ ----- Reads @.env.test@, then @.env@, then loads the application. Examples within--- this spec can use 'runAppTest' if the app 'HasLogger' (and 'runDB', if the--- app 'HasSqlPool').+-- 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 loadEnvTest . Hspec.aroundAll run+withApp run = beforeAll Dotenv.loadTest . Hspec.aroundAll run  -- | 'withApp', with custom DB 'Pool' initialization --@@ -138,12 +138,12 @@   -> ((app -> IO ()) -> IO ())   -> SpecWith app   -> Spec-withAppSql f run =-  beforeAll loadEnvTest . Hspec.aroundAll run . beforeWith setup-  where setup app = app <$ runSqlPool f (getSqlPool app)+withAppSql f run = withApp run . beforeSql f+{-# DEPRECATED withAppSql "Replace `withAppSql f g` with `withApp g . beforeSql f`" #-} -loadEnvTest :: IO ()-loadEnvTest = loadEnvFrom ".env.test" >> loadEnv+-- | Run the given SQL action before every spec item+beforeSql :: HasSqlPool app => SqlPersistT IO a -> SpecWith app -> SpecWith app+beforeSql f = beforeWith $ \app -> app <$ runSqlPool f (getSqlPool app)  expectationFailure :: (HasCallStack, MonadIO m) => String -> m a expectationFailure msg = Hspec.expectationFailure msg >> error "unreachable"
− library/Freckle/App/Version.hs 
@@ -1,102 +0,0 @@--- | Facilities for inferring an application version------ Various inputs are checked: files written during a docker build, git--- information, or falling back to an unknown version. This is useful for--- Bugsnag reports, client age comparison, etc.----module Freckle.App.Version-  ( AppVersion(..)-  , getAppVersion-  , tryGetAppVersion-  ) where--import Freckle.App.Prelude--import Control.Error.Util (hoistEither, note)-import Control.Monad.Trans.Except-import qualified Data.ByteString.Lazy.Char8 as BSL8-import Data.Char (isSpace)-import Data.List (dropWhileEnd)-import qualified Data.Text as T-import Data.Time.Format (defaultTimeLocale, parseTimeM)-import System.Exit (ExitCode(..))-import System.FilePath ((</>))-import System.Process.Typed (proc, readProcess)-import UnliftIO.Exception (tryIO)--data AppVersion = AppVersion-  { avName :: Text-  , avCreatedAt :: UTCTime-  }-  deriving stock (Eq, Show)---- | Attempt to infer an @'AppVersion'@------ - If files exist under @\/app-version@ they ar read, otherwise--- - If we're in a Git repository commit information is used, otherwise--- - An /Unknown/ version as of the current time is returned----getAppVersion :: MonadUnliftIO m => m AppVersion-getAppVersion =-  either (const getAppVersionUnknown) pure =<< tryGetAppVersion "/app-version"---- | A more testable version of @'getAppVersion'@------ - Reports what didn't work in @'Left'@--- - Accepts a parent path, for file-system version information----tryGetAppVersion-  :: MonadUnliftIO m => FilePath -> m (Either [String] AppVersion)-tryGetAppVersion parent =-  runExceptT-    $ withExceptT pure (getAppVersionFiles parent)-    <|> withExceptT pure getAppVersionGit--getAppVersionFiles :: MonadIO m => FilePath -> ExceptT String m AppVersion-getAppVersionFiles parent = do-  name <- readFileExceptT $ parent </> "name"-  seconds <- readFileExceptT $ parent </> "created-at"-  hoistEither $ toAppVersion name seconds--getAppVersionGit :: MonadIO m => ExceptT String m AppVersion-getAppVersionGit = do-  name <- git ["rev-parse", "HEAD"]-  seconds <- git ["show", "--no-patch", "--no-notes", "--pretty=%at"]-  hoistEither $ toAppVersion name seconds--toAppVersion :: String -> String -> Either String AppVersion-toAppVersion name seconds = do-  createdAt <- parseUnixSeconds $ strip seconds-  pure AppVersion { avName = T.strip $ pack name, avCreatedAt = createdAt }--parseUnixSeconds :: String -> Either String UTCTime-parseUnixSeconds x = note err $ parseTimeM True defaultTimeLocale "%s" x-  where err = x <> " does not parse as UTCTime with format %s"--getAppVersionUnknown :: MonadIO m => m AppVersion-getAppVersionUnknown = AppVersion "Unknown" <$> liftIO getCurrentTime--readFileExceptT :: MonadIO m => FilePath -> ExceptT String m String-readFileExceptT path = ExceptT $ liftIO $ first err <$> tryIO (readFile path)-  where err ex = "readFile: " <> show ex--git :: MonadIO m => [String] -> ExceptT String m String-git args = do-  (ec, stdout, stderr) <- exceptIO $ readProcess $ proc "git" args--  case ec of-    ExitSuccess -> pure $ BSL8.unpack stdout-    ExitFailure n ->-      throwE-        $ "["-        <> show n-        <> "] git "-        <> unwords args-        <> ": "-        <> BSL8.unpack stderr--exceptIO :: MonadIO m => IO a -> ExceptT String m a-exceptIO = withExceptT show . ExceptT . liftIO . tryIO--strip :: String -> String-strip = dropWhile isSpace . dropWhileEnd isSpace
package.yaml view
@@ -1,6 +1,6 @@ --- name: freckle-app-version: 1.5.1.0+version: 1.6.0.0 maintainer: Freckle Education category: Utils github: freckle/freckle-app@@ -14,12 +14,6 @@ extra-source-files:   - package.yaml -flags:-  test-git:-    description: Run tests that run git commands-    manual: true-    default: true- dependencies:   - base < 5 @@ -63,6 +57,7 @@     - containers     - datadog     - doctest+    - dotenv     - ekg-core     - envparse     - errors@@ -80,7 +75,6 @@     - http-types     - immortal     - lens-    - load-env     - memcache     - monad-control     - mtl@@ -119,6 +113,7 @@       - Blammo       - QuickCheck       - aeson+      - bugsnag       - bytestring       - errors       - freckle-app@@ -128,6 +123,7 @@       - lens-aeson       - memcache       - postgresql-simple+      - unliftio       - wai       - wai-extra @@ -136,21 +132,3 @@     source-dirs: doctest     dependencies:       - freckle-app--  gittest:-    main: Main.hs-    source-dirs: gittest-    dependencies:-      - freckle-app-      - directory-      - hspec-      - temporary-      - time-      - process-      - text-    when:-      - condition: flag(test-git)-        then:-          buildable: true-        else:-          buildable: false
+ tests/Freckle/App/Bugsnag/MetaDataSpec.hs view
@@ -0,0 +1,75 @@+module Freckle.App.Bugsnag.MetaDataSpec+  ( spec+  ) where++import Freckle.App.Test++import Blammo.Logging+import Data.Aeson+import Data.Bugsnag+import Freckle.App.Bugsnag+import Freckle.App.Bugsnag.MetaData+import Freckle.App.Stats+import qualified Freckle.App.Stats as Stats+import UnliftIO.Exception (SomeException)++spec :: Spec+spec = do+  describe "collectMetaData" $ do+    it "collects from StatsClient and myThreadContext" $ example $ do+      let settings = setStatsSettingsTags [("foo", "bar")] defaultStatsSettings++      withStatsClient settings $ \client -> flip runReaderT client $ do+        Stats.tagged [("baz", "bat")] $ do+          withThreadContext ["quix" .= ("quip" :: Text)] $ do+            collected <- collectMetaData++            let+              expected = mconcat+                [ metaData+                  "tags"+                  ["foo" .= ("bar" :: Text), "baz" .= ("bat" :: Text)]+                , metaData "context" ["quix" .= ("quip" :: Text)]+                ]++            runMergeMetaData Nothing collected `shouldBe` Just expected++  describe "mergeMetaData" $ do+    it "adds metadata to an empty Event" $ example $ do+      let incoming = metaData "test" ["foo" .= ("bar" :: Text)]++      runMergeMetaData Nothing incoming `shouldBe` Just incoming++    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)+          ]+++      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 }++someException :: SomeException+someException = undefined
tests/Main.hs view
@@ -1,7 +1,6 @@ module Main   ( main-  )-where+  ) where  import Prelude