freckle-app 1.0.4.0 → 1.1.0.0

raw patch · 16 files changed

+203/−525 lines, 16 filesdep +dlistdep +envparsedep +typed-processPVP ok

version bump matches the API change (PVP)

Dependencies added: dlist, envparse, typed-process

API changes (from Hackage documentation)

Files

• CHANGELOG.md +33/−1
• freckle-app.cabal +4/−5
• library/Freckle/App.hs +5/−6
• library/Freckle/App/Bugsnag.hs +3/−3
• library/Freckle/App/Database.hs +66/−65
• library/Freckle/App/Datadog.hs +5/−5
• library/Freckle/App/Env.hs +32/−189
• library/Freckle/App/Env/Internal.hs +0/−97
• library/Freckle/App/Ghci.hs +2/−1
• library/Freckle/App/Logging.hs +3/−3
• library/Freckle/App/Memcached/Servers.hs +1/−1
• library/Freckle/App/Test/Logging.hs +30/−14
• library/Freckle/App/Version.hs +11/−4
• package.yaml +4/−3
• tests/Freckle/App/Env/InternalSpec.hs +0/−125
• tests/Freckle/App/MemcachedSpec.hs +4/−3

@@ -1,4 +1,36 @@-## [_Unreleased_](https://github.com/freckle/freckle-app/compare/v1.0.4.0...main)+## [_Unreleased_](https://github.com/freckle/freckle-app/compare/v1.1.0.0...main)++## [v1.1.0.0](https://github.com/freckle/freckle-app/compare/v1.0.4.0...v1.1.0.0)++- Require `MonadLoggerIO` in `makePostgresPool` (and so respect that logging+  context from DB activities).++  Previous behavior can be recovered by using `runNoLoggingT makePostgresPool`.++- Re-implement `FronRow.App.Env` via external library, `envparse`++  Some conversions will be required:++  - `Reader a` should now be `Reader Error a`+  - `Parser a` should now be `Parser Error a`+  - `parse` should now be `parse id`+  - `var x X nonEmpty` should now be `var (x <=< nonempty) X mempty`++    Note that `(str <=< nonempty)` is redundant.++  - `var (f <$> g) X m` should now be `f <$> var g X m`++    Note that `def` will now need a value the same type as `g`, not `f`.++  - `switch` and `flag` no longer accept `def` (the non-active value is an+    implicit default; the previous behavior was kind of surprising and+    ambiguous).++  - `handleEither` has been removed. Users will have to parse a complete value+    and then further validate/throw externally.++  - Previously, we always behaved as if `keep` was applied. Add that explicitly+    if you need that behavior.  ## [v1.0.4.0](https://github.com/freckle/freckle-app/compare/v1.0.3.0...v1.0.4.0) 

@@ -1,6 +1,6 @@ cabal-version:      1.18 name:               freckle-app-version:            1.0.4.0+version:            1.1.0.0 license:            MIT license-file:       LICENSE maintainer:         Freckle Education@@ -32,7 +32,6 @@         Freckle.App.Datadog.Gauge         Freckle.App.Datadog.Rts         Freckle.App.Env-        Freckle.App.Env.Internal         Freckle.App.Ghci         Freckle.App.GlobalCache         Freckle.App.Http@@ -83,8 +82,10 @@         containers >=0.5.11.0,         data-default >=0.7.1.1,         datadog >=0.2.3.0,+        dlist >=0.8.0.5,         doctest >=0.16.0.1,         ekg-core >=0.1.1.6,+        envparse >=0.4.1,         errors >=2.3.0,         exceptions >=0.10.0,         fast-logger >=2.4.11,@@ -112,7 +113,6 @@         persistent-postgresql >=2.8.2.0,         postgresql-simple >=0.5.4.0,         primitive >=0.6.3.0,-        process >=1.6.3.0,         resource-pool >=0.2.3.2,         retry >=0.8.1.0,         rio >=0.1.7.0,@@ -124,6 +124,7 @@         time >=1.8.0.2,         transformers >=0.5.5.0,         transformers-base >=0.4.5.2,+        typed-process >=0.2.3.0,         unliftio >=0.2.9.0,         unordered-containers >=0.2.9.0,         vector >=0.12.0.2,@@ -192,7 +193,6 @@     hs-source-dirs:     tests     other-modules:         Freckle.App.BugsnagSpec-        Freckle.App.Env.InternalSpec         Freckle.App.HttpSpec         Freckle.App.Memcached.ServersSpec         Freckle.App.MemcachedSpec@@ -222,7 +222,6 @@         lens >=4.16.1,         lens-aeson >=1.0.2,         memcache >=0.2.0.1,-        monad-logger >=0.3.31,         mtl >=2.2.2,         postgresql-simple >=0.5.4.0,         unliftio-core >=0.1.2.0,

@@ -32,9 +32,9 @@ -- -- > import qualified Freckle.App.Env as Env -- >--- > loadApp = Env.parse $ App+-- > loadApp = Env.parse id $ App -- >   <$> Env.switch "DRY_RUN" mempty--- >   <*> Env.flag LevelInfo LevelDebug "DEBUG" mempty+-- >   <*> Env.flag (Off LevelInfo) (On LevelDebug) "DEBUG" mempty -- -- Though not required, a type synonym can make things throughout your -- application a bit more readable:@@ -76,9 +76,9 @@ -- So you can isolate Env-related concerns -- -- > loadConfig :: IO Config--- > loadConfig = Env.parse $ Config+-- > loadConfig = Env.parse id $ Config -- >   <$> Env.var Env.auto "PGPOOLSIZE" (Env.def 1)--- >   <*> Env.flag LevelInfo LevelDebug "DEBUG" mempty+-- >   <*> Env.flag (Off LevelInfo) (On LevelDebug) "DEBUG" mempty -- -- from the runtime application state: --@@ -171,8 +171,7 @@ module Freckle.App   ( runApp   , module X-  )-where+  ) where  import Prelude 

@@ -146,11 +146,11 @@  -- brittany-disable-next-binding -envParseBugsnagSettings :: Env.Parser Settings+envParseBugsnagSettings :: Env.Parser Env.Error Settings envParseBugsnagSettings =   build-    <$> Env.var Env.str "BUGSNAG_API_KEY" Env.nonEmpty-    <*> Env.var Env.str "BUGSNAG_RELEASE_STAGE" (Env.def "development")+    <$> 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

@@ -6,9 +6,7 @@  -- | Database access for your @App@ module Freckle.App.Database-  (-  -- * Abstract over access to a sql database-    HasSqlPool(..)+  ( HasSqlPool(..)   , SqlPool   , makePostgresPool   , makePostgresPoolWith@@ -24,14 +22,13 @@  import Freckle.App.Prelude -import Control.Concurrent import qualified Control.Immortal as Immortal-import Control.Monad.Logger (runNoLoggingT)+import Control.Monad.Logger import Control.Monad.Reader import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as BS8+import qualified Data.ByteString.Lazy as BSL import Data.Char (isDigit)-import Data.IORef import Data.Pool import qualified Data.Text as T import Database.Persist.Postgresql@@ -47,7 +44,9 @@ import Database.PostgreSQL.Simple.SqlQQ (sql) import qualified Freckle.App.Env as Env import qualified Prelude as Unsafe (read)-import System.Process (readProcess)+import System.Process.Typed (proc, readProcessStdout_)+import UnliftIO.Concurrent (threadDelay)+import UnliftIO.IORef  type SqlPool = Pool SqlBackend @@ -57,10 +56,11 @@ instance HasSqlPool SqlPool where   getSqlPool = id -makePostgresPool :: IO SqlPool+makePostgresPool :: (MonadUnliftIO m, MonadLoggerIO m) => m SqlPool makePostgresPool = do-  postgresPasswordSource <- Env.parse envPostgresPasswordSource-  conf <- Env.parse (envParseDatabaseConf postgresPasswordSource)+  conf <- liftIO $ do+    postgresPasswordSource <- Env.parse id envPostgresPasswordSource+    Env.parse id (envParseDatabaseConf postgresPasswordSource)   makePostgresPoolWith conf  runDB@@ -129,24 +129,24 @@     Right $ PostgresStatementTimeoutMilliseconds $ Unsafe.read digits   _ -> Left "must be {digits}(s|ms)" -envPostgresPasswordSource :: Env.Parser PostgresPasswordSource-envPostgresPasswordSource = do-  useIam <- Env.switch "USE_RDS_IAM_AUTH" $ Env.def False-  pure $ if useIam-    then PostgresPasswordSourceIamAuth-    else PostgresPasswordSourceEnv+envPostgresPasswordSource :: Env.Parser Env.Error PostgresPasswordSource+envPostgresPasswordSource = Env.flag+  (Env.Off PostgresPasswordSourceEnv)+  (Env.On PostgresPasswordSourceIamAuth)+  "USE_RDS_IAM_AUTH"+  mempty  envParseDatabaseConf-  :: PostgresPasswordSource -> Env.Parser PostgresConnectionConf+  :: PostgresPasswordSource -> Env.Parser Env.Error PostgresConnectionConf envParseDatabaseConf source = do-  user <- Env.var Env.str "PGUSER" Env.nonEmpty+  user <- Env.var Env.nonempty "PGUSER" mempty   password <- case source of     PostgresPasswordSourceIamAuth -> pure PostgresPasswordIamAuth     PostgresPasswordSourceEnv ->-      PostgresPasswordStatic <$> Env.var Env.str "PGPASSWORD" Env.nonEmpty-  host <- Env.var Env.str "PGHOST" Env.nonEmpty-  database <- Env.var Env.str "PGDATABASE" Env.nonEmpty-  port <- Env.var Env.auto "PGPORT" Env.nonEmpty+      PostgresPasswordStatic <$> Env.var Env.nonempty "PGPASSWORD" mempty+  host <- Env.var Env.nonempty "PGHOST" mempty+  database <- Env.var Env.nonempty "PGDATABASE" mempty+  port <- Env.var Env.auto "PGPORT" mempty   poolSize <- Env.var Env.auto "PGPOOLSIZE" $ Env.def 10   statementTimeout <-     Env.var (Env.eitherReader readPostgresStatementTimeout) "PGSTATEMENTTIMEOUT"@@ -162,30 +162,31 @@     }  data AuroraIamToken = AuroraIamToken-  { aitToken :: String+  { aitToken :: Text   , aitCreatedAt :: UTCTime   , aitPostgresConnectionConf :: PostgresConnectionConf   }   deriving stock (Show, Eq) -createAuroraIamToken :: PostgresConnectionConf -> IO AuroraIamToken+createAuroraIamToken :: MonadIO m => PostgresConnectionConf -> m AuroraIamToken createAuroraIamToken aitPostgresConnectionConf@PostgresConnectionConf {..} = do   -- TODO: Consider recording how long creating an auth token takes   -- somewhere, even if it is just in the logs, so we get an idea of how long   -- it takes in prod.-  aitToken <- T.unpack . T.strip . T.pack <$> readProcess-    "aws"-    [ "rds"-    , "generate-db-auth-token"-    , "--hostname"-    , pccHost-    , "--port"-    , show pccPort-    , "--username"-    , pccUser-    ]-    ""-  aitCreatedAt <- getCurrentTime+  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 { .. }  -- | Spawns a thread that refreshes the IAM auth token every minute@@ -194,58 +195,58 @@ -- be super safe. -- spawnIamTokenRefreshThread-  :: PostgresConnectionConf -> IO (IORef AuroraIamToken)+  :: (MonadUnliftIO m, MonadLogger m)+  => PostgresConnectionConf+  -> m (IORef AuroraIamToken) spawnIamTokenRefreshThread conf = do+  logInfoN "Spawning thread to refresh IAM auth token"   tokenIORef <- newIORef =<< createAuroraIamToken conf   void $ Immortal.create $ \_ -> Immortal.onFinish onFinishCallback $ do+    logDebugN "Refreshing IAM auth token"     refreshIamToken conf tokenIORef     threadDelay oneMinuteInMicroseconds   pure tokenIORef  where   oneMinuteInMicroseconds = 60 * 1000000 -  onFinishCallback (Left ex) =-    -- TODO: Somehow get MonadLogger-style error log message in here-    putStrLn $ "Error refreshing IAM auth token: " ++ show ex-  onFinishCallback (Right ()) = pure ()+  onFinishCallback = \case+    Left ex ->+      logErrorN $ pack $ "Error refreshing IAM auth token: " <> show ex+    Right () -> pure () -refreshIamToken :: PostgresConnectionConf -> IORef AuroraIamToken -> IO ()+refreshIamToken+  :: MonadIO m => PostgresConnectionConf -> IORef AuroraIamToken -> m () refreshIamToken conf tokenIORef = do   token' <- createAuroraIamToken conf   writeIORef tokenIORef token' --- isAuroraIamTokenExpired :: AuroraIamToken -> IO Bool--- isAuroraIamTokenExpired AuroraIamToken {..} = do---   now <- getCurrentTime---   let tenMinutesInSeconds = 60 * 15---   pure $ now `diffUTCTime` aitCreatedAt > tenMinutesInSeconds--setTimeout :: PostgresConnectionConf -> Connection -> IO ()-setTimeout PostgresConnectionConf {..} conn =+setTimeout :: MonadIO m => PostgresConnectionConf -> Connection -> m ()+setTimeout PostgresConnectionConf {..} conn = do   let timeoutMillis = postgresStatementTimeoutMilliseconds pccStatementTimeout-  in void $ execute conn [sql| SET statement_timeout = ? |] (Only timeoutMillis)+  void $ liftIO $ execute+    conn+    [sql| SET statement_timeout = ? |]+    (Only timeoutMillis) -makePostgresPoolWith :: PostgresConnectionConf -> IO SqlPool+makePostgresPoolWith+  :: (MonadUnliftIO m, MonadLoggerIO m) => PostgresConnectionConf -> m SqlPool makePostgresPoolWith conf@PostgresConnectionConf {..} = case pccPassword of   PostgresPasswordIamAuth -> makePostgresPoolWithIamAuth conf-  PostgresPasswordStatic password ->-    runNoLoggingT $ createPostgresqlPoolModified-      (setTimeout conf)-      (postgresConnectionString conf password)-      pccPoolSize+  PostgresPasswordStatic password -> createPostgresqlPoolModified+    (setTimeout conf)+    (postgresConnectionString conf password)+    pccPoolSize --- | Creates a PostgreSQL pool using IAM auth for the password.-makePostgresPoolWithIamAuth :: PostgresConnectionConf -> IO SqlPool+-- | Creates a PostgreSQL pool using IAM auth for the password+makePostgresPoolWithIamAuth+  :: (MonadUnliftIO m, MonadLoggerIO m) => PostgresConnectionConf -> m SqlPool makePostgresPoolWithIamAuth conf@PostgresConnectionConf {..} = do   tokenIORef <- spawnIamTokenRefreshThread conf-  runNoLoggingT $ createSqlPool (mkConn tokenIORef) pccPoolSize+  createSqlPool (mkConn tokenIORef) pccPoolSize  where-  -- TODO: Instead of refreshing the token before creating a connection, we-  -- could spawn a separate thread to refresh it on a timer. That way we don't-  -- waste time refreshing it when we want to make a new connection.   mkConn tokenIORef logFunc = do     token <- readIORef tokenIORef-    let connStr = postgresConnectionString conf (aitToken token)+    let connStr = postgresConnectionString conf (unpack $ aitToken token)     conn <- connectPostgreSQL connStr     setTimeout conf conn     openSimpleConn logFunc conn

@@ -189,10 +189,10 @@      send client ddMetric -envParseDogStatsEnabled :: Env.Parser Bool-envParseDogStatsEnabled = Env.switch "DOGSTATSD_ENABLED" $ Env.def False+envParseDogStatsEnabled :: Env.Parser Env.Error Bool+envParseDogStatsEnabled = Env.switch "DOGSTATSD_ENABLED" mempty -envParseDogStatsSettings :: Env.Parser DogStatsSettings+envParseDogStatsSettings :: Env.Parser Env.Error DogStatsSettings envParseDogStatsSettings = do   dogStatsSettingsHost <- Env.var Env.str "DOGSTATSD_HOST" $ Env.def "127.0.0.1"   dogStatsSettingsPort <- Env.var Env.auto "DOGSTATSD_PORT" $ Env.def 8125@@ -204,6 +204,6 @@     , dogStatsSettingsMaxDelay     } -envParseDogStatsTags :: Env.Parser [Tag]+envParseDogStatsTags :: Env.Parser Env.Error [Tag] envParseDogStatsTags =-  Env.var (map (uncurry tag) <$> Env.keyValues) "DOGSTATSD_TAGS" $ Env.def []+  map (uncurry tag) <$> Env.var Env.keyValues "DOGSTATSD_TAGS" (Env.def [])

@@ -1,5 +1,7 @@ -- | Parse the shell environment for configuration --+-- A minor extension of [envparse](https://hackage.haskell.org/package/envparse).+-- -- Usage: -- -- > import Freckle.App.Env@@ -16,45 +18,27 @@ -- >   <*> switch "DRY_RUN" mempty -- >   <*> flag (Off LevelInfo) (On LevelDebug) "DEBUG" mempty ----- N.B. Usage is meant to mimic envparse, but the implementation is greatly--- simplified (at loss of some features) and some bugs have been fixed.------ <http://hackage.haskell.org/package/envparse>--- module Freckle.App.Env-  (-  -- * Parsing-    Parser+  ( module Env++  -- * Replacements   , Off(..)   , On(..)-  , parse-  , var   , flag-  , switch-  , handleEither -  -- * Readers-  , str-  , auto+  -- * Extensions+  , eitherReader   , time   , keyValues-  , eitherReader--  -- * Modifiers-  , def-  , nonEmpty   ) where  import Freckle.App.Prelude  import Control.Error.Util (note)-import Data.String import qualified Data.Text as T-import Data.Time-import Freckle.App.Env.Internal-import System.Environment (getEnvironment)-import System.Exit (die)-import Text.Read (readEither)+import Data.Time (defaultTimeLocale, parseTimeM)+import Env hiding (flag)+import qualified Env  -- | Designates the value of a parameter when a flag is not provided. newtype Off a = Off a@@ -62,70 +46,6 @@ -- | Designates the value of a parameter when a flag is provided. newtype On a = On a --- $setup--- >>> :{---  let---    exampleParse :: [(String, String)] -> Parser a -> Either [(String, Error)] a---    exampleParse env = ($ env) . unParser--- :}---- | Parse the current environment in @'IO'@------ The process will exit non-zero after printing any errors.----parse :: Parser a -> IO a-parse p = do-  env <- getEnvironment-  either (die . prettyErrors) pure $ unParser p env- where-  prettyErrors = unlines . map (uncurry prettyError)-  prettyError name UnsetError = name <> " must be set"-  prettyError name (InvalidError msg) = name <> " is invalid:\n  " <> msg---- | Parse a variable by name, using the given Reader and options------ >>> exampleParse @String [("EDITOR", "vim")] $ var str "EDITOR" (def "vi")--- Right "vim"------ >>> exampleParse @String [] $ var str "EDITOR" (def "vi")--- Right "vi"------ Parsers are instances of @'Alternative'@, which means you can use combinators--- like @'optional'@ or @'<|>'@.------ >>> import Control.Applicative------ >>> exampleParse @(Maybe String) [] $ optional $ var str "EDITOR" nonEmpty--- Right Nothing------ The above will no longer fail if the environment variable is missing, but it--- will still validate it if it is present:------ >>> exampleParse @(Maybe String) [("EDITOR", "")] $ optional $ var str "EDITOR" nonEmpty--- Left [("EDITOR",InvalidError "value cannot be empty")]------ >>> exampleParse @(Maybe String) [("EDITOR", "vim")] $ optional $ var str "EDITOR" nonEmpty--- Right (Just "vim")------ >>> let p = var str "VISUAL" nonEmpty <|> var str "EDITOR" nonEmpty <|> pure "vi"--- >>> exampleParse @String [("VISUAL", "vim"), ("EDITOR", "ed")] p--- Right "vim"------ >>> exampleParse @String [("EDITOR", "ed")] p--- Right "ed"------ >>> exampleParse @String [] p--- Right "vi"------ Again, values that /are/ present are still validated:------ >>> exampleParse @String [("VISUAL", ""), ("EDITOR", "ed")] p--- Left [("VISUAL",InvalidError "value cannot be empty")]----var :: Reader a -> String -> Mod a -> Parser a-var r n (Mod m) =-  varParser $ m Var { varName = n, varReader = r, varDefault = Nothing }- -- | Parse a simple flag -- -- If the variable is present and non-empty in the environment, the active value@@ -133,73 +53,43 @@ -- -- >>> import Control.Monad.Logger ----- >>> exampleParse [("DEBUG", "1")] $ flag (Off LevelInfo) (On LevelDebug) "DEBUG" mempty+-- >>> flag (Off LevelInfo) (On LevelDebug) "DEBUG" mempty `parsePure` [("DEBUG", "1")] -- Right LevelDebug ----- >>> exampleParse [("DEBUG", "")] $ flag (Off LevelInfo) (On LevelDebug) "DEBUG" mempty+-- >>> flag (Off LevelInfo) (On LevelDebug) "DEBUG" mempty `parsePure` [("DEBUG", "")] -- Right LevelInfo ----- >>> exampleParse [] $ flag (Off LevelInfo) (On LevelDebug) "DEBUG" mempty+-- >>> flag (Off LevelInfo) (On LevelDebug) "DEBUG" mempty `parsePure` [] -- Right LevelInfo -- -- N.B. only the empty string is falsey: ----- >>> exampleParse [("DEBUG", "false")] $ flag (Off LevelInfo) (On LevelDebug) "DEBUG" mempty+-- >>> flag (Off LevelInfo) (On LevelDebug) "DEBUG" mempty `parsePure` [("DEBUG", "false")] -- Right LevelDebug ----- >>> exampleParse [("DEBUG", "no")] $ flag (Off LevelInfo) (On LevelDebug) "DEBUG" mempty+-- >>> flag (Off LevelInfo) (On LevelDebug) "DEBUG" mempty `parsePure` [("DEBUG", "no")] -- Right LevelDebug ---flag :: Off a -> On a -> String -> Mod a -> Parser a-flag (Off f) (On t) n (Mod m) = varParser $ m Var-  { varName = n-  , varReader = Reader $ \case-    "" -> Right f-    _ -> Right t-  , varDefault = Just f-  }---- | A simplified version of @'flag'@ for @'Bool'@ values------ >>> exampleParse [("VERBOSE", "1")] $ switch "VERBOSE" mempty--- Right True------ >>> exampleParse [] $ switch "VERBOSE" mempty--- Right False----switch :: String -> Mod Bool -> Parser Bool-switch = flag (Off False) (On True)---- | Create a @'Reader'@ from a simple parser function------ This is a building-block for other @'Reader'@s----eitherReader :: (String -> Either String a) -> Reader a-eitherReader f =-  Reader $ \s -> first (InvalidError . (<> (": \"" <> s <> "\""))) $ f s+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 --- | Use a value's @'Read'@ instance------ >>> import Numeric.Natural------ >>> exampleParse @Natural [("SIZE", "1")] $ var auto "SIZE" mempty--- Right 1+-- | Create a 'Reader' from a simple parser function ----- >>> exampleParse @Natural [("SIZE", "-1")] $ var auto "SIZE" mempty--- Left [("SIZE",InvalidError "Prelude.read: no parse: \"-1\"")]+-- This is a building-block for other 'Reader's ---auto :: Read a => Reader a-auto = eitherReader readEither+eitherReader :: (String -> Either String a) -> Reader Error a+eitherReader f s = first (unread . suffix) $ f s+  where suffix x = x <> ": " <> show s  -- | Read a time value using the given format ----- >>> exampleParse [("TIME", "1985-02-12")] $ var (time "%Y-%m-%d") "TIME" mempty+-- >>> var (time "%Y-%m-%d") "TIME" mempty `parsePure` [("TIME", "1985-02-12")] -- Right 1985-02-12 00:00:00 UTC ----- >>> exampleParse [("TIME", "10:00PM")] $ var (time "%Y-%m-%d") "TIME" mempty--- Left [("TIME",InvalidError "unable to parse time as %Y-%m-%d: \"10:00PM\"")]+-- >>> 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 UTCTime+time :: String -> Reader Error UTCTime time fmt =   eitherReader     $ note ("unable to parse time as " <> fmt)@@ -207,20 +97,20 @@  -- | Read key-value pairs ----- >>> exampleParse [("TAGS", "foo:bar,baz:bat")] $ var keyValues "TAGS" mempty+-- >>> var keyValues "TAGS" mempty `parsePure` [("TAGS", "foo:bar,baz:bat")] -- Right [("foo","bar"),("baz","bat")] -- -- Value-less keys are not supported: ----- >>> exampleParse [("TAGS", "foo,baz:bat")] $ var keyValues "TAGS" mempty--- Left [("TAGS",InvalidError "Key foo has no value: \"foo,baz:bat\"")]+-- >>> var keyValues "TAGS" mempty `parsePure` [("TAGS", "foo,baz:bat")]+-- Left [("TAGS",UnreadError "Key foo has no value: \"foo,baz:bat\"")] -- -- Nor are key-less values: ----- >>> exampleParse [("TAGS", "foo:bar,:bat")] $ var keyValues "TAGS" mempty--- Left [("TAGS",InvalidError "Value bat has no key: \"foo:bar,:bat\"")]+-- >>> var keyValues "TAGS" mempty `parsePure` [("TAGS", "foo:bar,:bat")]+-- Left [("TAGS",UnreadError "Value bat has no key: \"foo:bar,:bat\"")] ---keyValues :: Reader [(Text, Text)]+keyValues :: Reader Error [(Text, Text)] keyValues = eitherReader $ traverse keyValue . T.splitOn "," . pack  where   keyValue :: Text -> Either String (Text, Text)@@ -228,50 +118,3 @@     (k, v) | T.null v -> Left $ "Key " <> unpack k <> " has no value"     (k, v) | T.null k -> Left $ "Value " <> unpack v <> " has no key"     (k, v) -> Right (k, v)---- | Use a value's @'IsString'@ instance------ >>> import Data.Text (Text)------ >>> exampleParse @Text [("FOO", "foo")] $ var str "FOO" mempty--- Right "foo"------ Take note: if this fails, it's basically @'error'@.----str :: IsString a => Reader a-str = Reader $ pure . fromString---- | Modify parsing to fail on empty strings------ >>> exampleParse @String [("FOO", "")] $ var str "FOO" nonEmpty--- Left [("FOO",InvalidError "value cannot be empty")]----nonEmpty :: Mod a-nonEmpty = Mod $ \v -> v-  { varReader = Reader $ \case-    [] -> Left $ InvalidError "value cannot be empty"-    xs -> unReader (varReader v) xs-  }---- | Declare a default value for the parser-def :: a -> Mod a-def d = Mod $ \v -> v { varDefault = Just d }---- | Handle parsers that may fail------ Handling @'Either'@ parser results causes short circuiting in the parser--- results.------ >>> exampleParse @String [("FOO", "")] $ handleEither "CONTEXT" $ pure $ Left "failed"--- Left [("CONTEXT",InvalidError "failed")]------ >>> exampleParse @String [("FOO", "")] $ handleEither "CONTEXT" $ pure $ Right "stuff"--- Right "stuff"----handleEither-  :: String -- ^ Parser context reported on error-  -> Parser (Either String a)-  -> Parser a-handleEither context p = bindParser p $ \case-  Left err -> Parser $ \_ -> Left [(context, InvalidError err)]-  Right x -> pure x

@@ -1,97 +0,0 @@-{-# LANGUAGE TupleSections #-}---- | Internal Env machinery exposed for testing-module Freckle.App.Env.Internal-  ( Error(..)-  , Parser(..)-  , bindParser-  , Reader(..)-  , Mod(..)-  , Var(..)-  , varParser-  ) where--import Freckle.App.Prelude--import Control.Applicative---- | Environment parsing errors-data Error-  = UnsetError-  -- ^ A variable was not found, and no default was specified-  | InvalidError String-  -- ^ A variable was found, but it failed to parse-  deriving stock (Eq, Show)--isUnsetError :: Error -> Bool-isUnsetError UnsetError = True-isUnsetError (InvalidError _) = False---- | Parse an Environment------ Errors are accumulated into tuples mapping name to error.----newtype Parser a = Parser-  { unParser :: [(String, String)] -> Either [(String, Error)] a-  }-  deriving stock Functor--instance Applicative Parser where-  pure a = Parser . const $ Right a-  Parser f <*> Parser a = Parser $ \env -> case (f env, a env) of-    (Right f', Right a') -> Right $ f' a'--    -- Accumulate errors-    (Left e1, Left e2) -> Left $ e1 ++ e2-    (Left e, _) -> Left e-    (_, Left e) -> Left e--instance Alternative Parser where-  empty = Parser $ const $ Left []-  Parser f <|> Parser g = Parser $ \env -> case f env of-    Left ferrs | all (isUnsetError . snd) ferrs -> case g env of-      Left gerrs -> Left (ferrs ++ gerrs)-      y -> y-    x -> x---- | Monadic bind for @'Parser'@------ This short-circuits all parsing and is not ideal for an applicative style--- parser, which ideally reports all errors instead of short-circuiting. As such--- a `Monad` instance is not exposed for @'Parser'@.----bindParser :: Parser a -> (a -> Parser b) -> Parser b-bindParser (Parser f) g = Parser $ \envs -> do-  x <- f envs-  let h = unParser $ g x-  h envs---- | Read a single environment variable's value------ This will only ever fail with @'InvalidError'@, since @'UnsetError'@ is--- handled before invoking any @'Reader'@.----newtype Reader a = Reader-  { unReader :: String -> Either Error a-  }-  deriving stock (Functor)--newtype Mod a = Mod (Var a -> Var a)--instance Semigroup (Mod a) where-  Mod f <> Mod g = Mod $ f . g--instance Monoid (Mod a) where-  mempty = Mod id--data Var a = Var-  { varName :: String-  , varReader :: Reader a-  , varDefault :: Maybe a-  }--varParser :: Var a -> Parser a-varParser Var {..} = Parser $ \env -> case (lookup varName env, varDefault) of-  (Nothing, Just d) -> Right d-  (Nothing, _) -> Left [(varName, UnsetError)]-  (Just v, _) -> first (pure . (varName, )) $ unReader varReader v

@@ -7,6 +7,7 @@  import Freckle.App.Prelude +import Control.Monad.Logger (runNoLoggingT) import Database.Persist.Postgresql (runSqlPool) import Database.Persist.Sql (SqlBackend) import Freckle.App.Database (makePostgresPool)@@ -19,7 +20,7 @@ -- | Run a db action runDB' :: ReaderT SqlBackend IO b -> IO b runDB' f = do-  pool <- makePostgresPool+  pool <- runNoLoggingT makePostgresPool   runSqlPool f pool  loadEnvTest :: IO ()

@@ -85,7 +85,7 @@   LogStderr -> (BS8.hPutStr stderr, ) <$> hSupportsANSI stderr   LogFile path -> pure (BS8.appendFile path, False) -parseEnvLogLevel :: Env.Parser LogLevel+parseEnvLogLevel :: Env.Parser Env.Error LogLevel parseEnvLogLevel = Env.var parse "LOG_LEVEL" $ Env.def LevelWarn  where   parse = Env.eitherReader $ \case@@ -95,7 +95,7 @@     "info" -> Right LevelInfo     level -> Left $ "unexpected log level: " <> level -parseEnvLogFormat :: Env.Parser LogFormat+parseEnvLogFormat :: Env.Parser Env.Error LogFormat parseEnvLogFormat = Env.var parse "LOG_FORMAT" $ Env.def FormatTerminal  where   parse = Env.eitherReader $ \case@@ -103,7 +103,7 @@     "terminal" -> Right FormatTerminal     format -> Left $ "unexpected format: " <> format -parseEnvLogLocation :: Env.Parser LogLocation+parseEnvLogLocation :: Env.Parser Env.Error LogLocation parseEnvLogLocation = Env.var parse "LOG_LOCATION" $ Env.def LogStdout  where   parse = Env.eitherReader $ \case

@@ -12,7 +12,7 @@ -- -- @ -- -- Required--- Env.var (Env.eitherReader readMemcachedServers) "MEMCACHED_SERVERS" Env.nonEmpty+-- Env.var (Env.eitherReader readMemcachedServers <=< Env.nonempty) "MEMCACHED_SERVERS" mempty -- -- -- Default to localhost:11211 -- Env.var (Env.eitherReader readMemcachedServers) "MEMCACHED_SERVERS" (Env.def defaultMemcachedServers)

@@ -1,30 +1,46 @@+{-# LANGUAGE CPP #-}+ module Freckle.App.Test.Logging-  ( runCapturedLoggingT+  ( MonadLogger+  , LoggingT+  , runCapturedLoggingT+  , logLineToText   ) where  import Freckle.App.Prelude  import Control.Concurrent.Chan-import Control.Monad (forever) import Control.Monad.Logger+import Data.DList (DList)+import qualified Data.DList as DList import UnliftIO.Async-import UnliftIO.IORef+import UnliftIO.Exception (finally) +#if !MIN_VERSION_monad_logger(0,3,32)+type LogLine = (Loc, LogSource, LogLevel, LogStr)+#endif+ -- | Run a 'LoggingT', capturing and returning any logged messages alongside ----- I do not know why 'runChanLoggingT' exists presumably for this purpose, but--- requires so much more effort to ultimately accomplish.+-- This is 'runWriterLoggingT', but we're not able to supply a 'MonadUnliftIO'+-- instance when using that. ---runCapturedLoggingT :: MonadUnliftIO m => LoggingT m a -> m (a, [Text])+runCapturedLoggingT :: MonadUnliftIO m => LoggingT m a -> m (a, [LogLine]) runCapturedLoggingT f = do   chan <- liftIO newChan-  ref <- newIORef []-  x <- async $ forever $ do-    (_, _, _, str) <- liftIO $ readChan chan-    modifyIORef' ref (<> [decodeUtf8 $ fromLogStr str])+  x <- async $ captureLog DList.empty chan+  a <- runChanLoggingT chan $ f `finally` logInfoN doneMessage+  msgs <- wait x+  pure (a, DList.toList msgs) -  a <- runChanLoggingT chan f+captureLog :: MonadIO m => DList LogLine -> Chan LogLine -> m (DList LogLine)+captureLog acc chan = do+  ll <- liftIO $ readChan chan+  let txt = logLineToText ll+  if txt == doneMessage then pure acc else captureLog (DList.snoc acc ll) chan -  cancel x-  msgs <- readIORef ref-  pure (a, msgs)+doneMessage :: Text+doneMessage = "%DONE%"++logLineToText :: LogLine -> Text+logLineToText (_, _, _, str) = decodeUtf8 $ fromLogStr str

@@ -14,13 +14,14 @@  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 (readProcessWithExitCode)+import System.Process.Typed (proc, readProcess) import UnliftIO.Exception (tryIO)  data AppVersion = AppVersion@@ -81,12 +82,18 @@  git :: MonadIO m => [String] -> ExceptT String m String git args = do-  (ec, stdout, stderr) <- exceptIO $ readProcessWithExitCode "git" args []+  (ec, stdout, stderr) <- exceptIO $ readProcess $ proc "git" args    case ec of-    ExitSuccess -> pure stdout+    ExitSuccess -> pure $ BSL8.unpack stdout     ExitFailure n ->-      throwE $ "[" <> show n <> "] git " <> unwords args <> ": " <> stderr+      throwE+        $ "["+        <> show n+        <> "] git "+        <> unwords args+        <> ": "+        <> BSL8.unpack stderr  exceptIO :: MonadIO m => IO a -> ExceptT String m a exceptIO = withExceptT show . ExceptT . liftIO . tryIO

@@ -1,6 +1,6 @@ --- name: freckle-app-version: 1.0.4.0+version: 1.1.0.0 maintainer: Freckle Education category: Utils github: freckle/freckle-app@@ -63,8 +63,10 @@     - containers     - data-default     - datadog+    - dlist     - doctest     - ekg-core+    - envparse     - errors     - exceptions     - fast-logger@@ -92,7 +94,6 @@     - persistent-postgresql     - postgresql-simple     - primitive-    - process     - resource-pool     - retry >= 0.8.1.0     - rio@@ -104,6 +105,7 @@     - time     - transformers     - transformers-base+    - typed-process     - unliftio     - unordered-containers     - vector@@ -128,7 +130,6 @@       - lens       - lens-aeson       - memcache-      - monad-logger       - mtl       - postgresql-simple       - unliftio-core

@@ -1,125 +0,0 @@-module Freckle.App.Env.InternalSpec-  ( spec-  )-where--import Prelude--import Control.Applicative-import Freckle.App.Env-import Freckle.App.Env.Internal-import Numeric.Natural-import Test.Hspec--spec :: Spec-spec = do-  describe "Parser" $ do-    context "Alternative" $ do-      let-        run :: Parser a -> Either [(String, Error)] a-        run p = unParser p [("PRESENT", "present"), ("INVALID_NAT", "-1")]--      -- Left identity: 'empty <|> x == x'-      it "satisfies left identity" $ do-        run @String (empty <|> var str "PRESENT" mempty)-          `shouldBe` Right "present"--        run @Natural (empty <|> var auto "INVALID_NAT" mempty) `shouldBe` Left-          [("INVALID_NAT", InvalidError "Prelude.read: no parse: \"-1\"")]--        run @String (empty <|> var str "MISSING" mempty)-          `shouldBe` Left [("MISSING", UnsetError)]--      -- Right identity: 'x <|> empty == x'-      it "satisfies right identity" $ do-        run @String (var str "PRESENT" mempty <|> empty)-          `shouldBe` Right "present"--        run @Natural (var auto "INVALID_NAT" mempty <|> empty) `shouldBe` Left-          [("INVALID_NAT", InvalidError "Prelude.read: no parse: \"-1\"")]--        run @String (var str "MISSING" mempty <|> empty)-          `shouldBe` Left [("MISSING", UnsetError)]--      -- Annihilation: 'f <$> empty == empty'-      it "satisfies annihilation" $ do-        run @Natural ((+ 1) <$> empty) `shouldBe` Left []-        run @String ((++ "!") <$> empty) `shouldBe` Left []--      -- Associativity: 'x <|> (y <|> z) == (x <|> y) <|> z'-      it "satisfies associativity" $ do-        run @String (empty <|> (empty <|> empty)) `shouldBe` Left []-        run @String ((empty <|> empty) <|> empty) `shouldBe` Left []--        run @Natural-            (empty-            <|> (var auto "INVALID_NAT" mempty <|> var auto "MISSING" mempty)-            )-          `shouldBe` Left-                       [ ( "INVALID_NAT"-                         , InvalidError "Prelude.read: no parse: \"-1\""-                         )-                       ]-        run @Natural-            ((empty <|> var auto "INVALID_NAT" mempty)-            <|> var auto "MISSING" mempty-            )-          `shouldBe` Left-                       [ ( "INVALID_NAT"-                         , InvalidError "Prelude.read: no parse: \"-1\""-                         )-                       ]--        run @String-            (empty <|> (var str "MISSING" mempty <|> var str "PRESENT" mempty))-          `shouldBe` Right "present"-        run @String-            ((empty <|> var str "MISSING" mempty) <|> var str "PRESENT" mempty)-          `shouldBe` Right "present"--      -- Distributivity: 'f <$> (x <|> y) == (f <$> x) <|> (f <$> y)'-      it "satisfies distributivity" $ do-        run @Natural-            ((+ 1)-            <$> (var auto "NOT_PRESENT" mempty-                <|> var auto "INVALID_NAT" mempty-                )-            )-          `shouldBe` Left-                       [ ("NOT_PRESENT", UnsetError)-                       , ( "INVALID_NAT"-                         , InvalidError "Prelude.read: no parse: \"-1\""-                         )-                       ]--        run @Natural-            ((+ 1)-            <$> var auto "NOT_PRESENT" mempty-            <|> (+ 1)-            <$> var auto "INVALID_NAT" mempty-            )-          `shouldBe` Left-                       [ ("NOT_PRESENT", UnsetError)-                       , ( "INVALID_NAT"-                         , InvalidError "Prelude.read: no parse: \"-1\""-                         )-                       ]--        run @String-            ((++ "!")-            <$> (var str "NOT_PRESENT" mempty <|> var str "PRESENT" mempty)-            )-          `shouldBe` Right "present!"--        run @String-            ((++ "!")-            <$> var str "NOT_PRESENT" mempty-            <|> (++ "!")-            <$> var str "PRESENT" mempty-            )-          `shouldBe` Right "present!"--      -- Left catch: 'pure x <|> empty = pure x'-      it "satisfies left catch"-        $ run (pure True <|> empty)-        `shouldBe` Right True

@@ -5,7 +5,6 @@ import Freckle.App.Prelude  import Control.Monad.IO.Unlift (MonadUnliftIO(..))-import Control.Monad.Logger import Control.Monad.Reader import qualified Data.List.NonEmpty as NE import qualified Freckle.App.Env as Env@@ -58,12 +57,14 @@  runTestAppT :: MonadUnliftIO m => TestAppT m a -> m (a, [Text]) runTestAppT f = do-  servers <- liftIO $ Env.parse $ Env.var+  servers <- liftIO $ Env.parse id $ Env.var     (Env.eitherReader readMemcachedServers)     "MEMCACHED_SERVERS"     (Env.def defaultMemcachedServers)   mc <- newMemcachedClient servers-  runCapturedLoggingT $ runReaderT (unTestAppT f) mc+  fmap (second $ map logLineToText) $ runCapturedLoggingT $ runReaderT+    (unTestAppT f)+    mc  spec :: Spec spec = do