freckle-app (empty) → 1.0.0.1

raw patch · 31 files changed

+3075/−0 lines, 31 filesdep +Globdep +MonadRandomdep +aeson

Dependencies added: Glob, MonadRandom, aeson, ansi-terminal, base, bytestring, case-insensitive, conduit, data-default, datadog, directory, doctest, errors, exceptions, fast-logger, filepath, freckle-app, hspec, hspec-core, hspec-expectations-lifted, hspec-junit-formatter, http-client, http-conduit, http-link-header, http-types, immortal, iproute, lens, lens-aeson, load-env, monad-control, monad-logger, mtl, network, network-uri, persistent, persistent-postgresql, postgresql-simple, primitive, process, resource-pool, retry, rio, temporary, text, time, transformers, transformers-base, unliftio, unliftio-core, wai, wai-extra, yaml, yesod, yesod-core

Files

• CHANGELOG.md +7/−0
• LICENSE +21/−0
• README.md +7/−0
• doctest/Main.hs +11/−0
• freckle-app.cabal +166/−0
• library/Freckle/App.hs +190/−0
• library/Freckle/App/Database.hs +217/−0
• library/Freckle/App/Datadog.hs +196/−0
• library/Freckle/App/Env.hs +280/−0
• library/Freckle/App/Env/Internal.hs +99/−0
• library/Freckle/App/Ghci.hs +28/−0
• library/Freckle/App/GlobalCache.hs +88/−0
• library/Freckle/App/Http.hs +243/−0
• library/Freckle/App/Http/Paginate.hs +102/−0
• library/Freckle/App/Http/Retry.hs +95/−0
• library/Freckle/App/Logging.hs +197/−0
• library/Freckle/App/RIO.hs +74/−0
• library/Freckle/App/Test.hs +104/−0
• library/Freckle/App/Test/DocTest.hs +77/−0
• library/Freckle/App/Test/Hspec/Runner.hs +101/−0
• library/Freckle/App/Time.hs +10/−0
• library/Freckle/App/Version.hs +102/−0
• library/Freckle/App/Wai.hs +217/−0
• library/Freckle/App/Yesod.hs +55/−0
• library/Network/HTTP/Link/Compat.hs +27/−0
• tests/Freckle/App/Env/InternalSpec.hs +125/−0
• tests/Freckle/App/HttpSpec.hs +43/−0
• tests/Freckle/App/VersionSpec.hs +59/−0
• tests/Freckle/App/WaiSpec.hs +120/−0
• tests/Main.hs +13/−0
• tests/Spec.hs +1/−0

@@ -0,0 +1,7 @@+## [v1.0.0.1](https://github.com/freckle/freckle-app/compare/v1.0.0.0...v1.0.0.1)++- Ensure `release` GitHub Action completes properly.++## [v1.0.0.0](https://github.com/freckle/freckle-app/tree/v1.0.0.0)++First tagged release.

@@ -0,0 +1,21 @@+The MIT License (MIT)++Copyright (c) 2021 Renaissance Learning Inc++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.

@@ -0,0 +1,7 @@+# freckle-app++Haskell application toolkit used at Freckle.++---++[CHANGELOG](./CHANGELOG.md) | [LICENSE](./LICENSE)

@@ -0,0 +1,11 @@+module Main+  ( main+  )+where++import Prelude++import Freckle.App.Test.DocTest++main :: IO ()+main = doctest "library/"

@@ -0,0 +1,166 @@+cabal-version:      1.12+name:               freckle-app+version:            1.0.0.1+license:            MIT+license-file:       LICENSE+maintainer:         Freckle Education+homepage:           https://github.com/freckle/freckle-app#readme+bug-reports:        https://github.com/freckle/freckle-app/issues+synopsis:           Haskell application toolkit used at Freckle+description:        Please see README.md+category:           Utils+build-type:         Simple+extra-source-files:+    README.md+    CHANGELOG.md++source-repository head+    type:     git+    location: https://github.com/freckle/freckle-app++library+    exposed-modules:+        Freckle.App+        Freckle.App.Database+        Freckle.App.Datadog+        Freckle.App.Env+        Freckle.App.Env.Internal+        Freckle.App.Ghci+        Freckle.App.GlobalCache+        Freckle.App.Http+        Freckle.App.Http.Paginate+        Freckle.App.Http.Retry+        Freckle.App.Logging+        Freckle.App.RIO+        Freckle.App.Test+        Freckle.App.Test.DocTest+        Freckle.App.Test.Hspec.Runner+        Freckle.App.Time+        Freckle.App.Version+        Freckle.App.Wai+        Freckle.App.Yesod+        Network.HTTP.Link.Compat++    hs-source-dirs:     library+    other-modules:      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:+        Glob >=0.10.1,+        MonadRandom >=0.5.3,+        aeson >=1.5.6.0,+        ansi-terminal >=0.11,+        base >=4.14.1.0 && <5,+        bytestring >=0.10.12.0,+        case-insensitive >=1.2.1.0,+        conduit >=1.3.4.1,+        data-default >=0.7.1.1,+        datadog >=0.2.5.0,+        doctest >=0.17,+        errors >=2.3.0,+        exceptions >=0.10.4,+        fast-logger >=3.0.5,+        filepath >=1.4.2.1,+        hspec >=2.7.10,+        hspec-core >=2.7.10,+        hspec-expectations-lifted >=0.10.0,+        hspec-junit-formatter >=1.0.0.5,+        http-client >=0.6.4.1,+        http-conduit >=2.3.8,+        http-link-header >=1.2.0,+        http-types >=0.12.3,+        immortal >=0.3,+        iproute >=1.7.11,+        lens >=4.19.2,+        load-env >=0.2.1.0,+        monad-control >=1.0.2.3,+        monad-logger >=0.3.36,+        mtl >=2.2.2,+        network >=3.1.1.1,+        network-uri >=2.6.4.1,+        persistent >=2.13.1.1,+        persistent-postgresql >=2.13.0.3,+        postgresql-simple >=0.6.4,+        primitive >=0.7.1.0,+        process >=1.6.9.0,+        resource-pool >=0.2.3.2,+        retry >=0.8.1.2,+        rio >=0.1.20.0,+        text >=1.2.4.1,+        time >=1.9.3,+        transformers >=0.5.6.2,+        transformers-base >=0.4.5.2,+        unliftio >=0.2.18,+        unliftio-core >=0.2.0.1,+        wai >=3.2.3,+        wai-extra >=3.1.6,+        yaml >=0.11.5.0,+        yesod >=1.6.1.2,+        yesod-core >=1.6.20.2++test-suite doctest+    type:               exitcode-stdio-1.0+    main-is:            Main.hs+    hs-source-dirs:     doctest+    other-modules:      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.14.1.0 && <5,+        freckle-app -any++test-suite spec+    type:               exitcode-stdio-1.0+    main-is:            Main.hs+    hs-source-dirs:     tests+    other-modules:+        Freckle.App.Env.InternalSpec+        Freckle.App.HttpSpec+        Freckle.App.VersionSpec+        Freckle.App.WaiSpec+        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++    ghc-options:        -threaded -rtsopts -with-rtsopts=-N+    build-depends:+        aeson >=1.5.6.0,+        base >=4.14.1.0 && <5,+        bytestring >=0.10.12.0,+        directory >=1.3.6.0,+        freckle-app -any,+        hspec >=2.7.10,+        http-types >=0.12.3,+        lens >=4.19.2,+        lens-aeson >=1.1.1,+        process >=1.6.9.0,+        temporary >=1.3,+        text >=1.2.4.1,+        time >=1.9.3,+        wai >=3.2.3,+        wai-extra >=3.1.6

@@ -0,0 +1,190 @@+-- | Micro-framework for building a non-web application+--+-- This is a version of the /ReaderT Design Pattern/.+--+-- <https://www.fpcomplete.com/blog/2017/06/readert-design-pattern>+--+-- == Basic Usage+--+-- Start by defining a type to hold your global application state:+--+-- > data App = App+-- >   { appDryRun :: Bool+-- >   , appLogLevel :: LogLevel+-- >   }+--+-- This type can be as complex or simple as you want. It might hold a separate+-- @Config@ attribute or may keep everything as one level of properties. It+-- could even hold an @'IORef'@ if you need mutable application state.+--+-- The only requirements are some notion of a @'LogLevel'@:+--+-- > instance HasLogging App where+-- >   getLogLevel = appLogLevel+-- >   getLogFormat _ = FormatTerminal+-- >   getLogLocation _ = LogStdout+--+-- and a way to build a value:+--+-- > loadApp :: IO App+--+-- It's likely you'll want to use @"Freckle.App.Env"@ to load your @App@:+--+-- > import qualified Freckle.App.Env as Env+-- >+-- > loadApp = Env.parse $ App+-- >   <$> Env.switch "DRY_RUN" mempty+-- >   <*> Env.flag LevelInfo LevelDebug "DEBUG" mempty+--+-- Though not required, a type synonym can make things throughout your+-- application a bit more readable:+--+-- > type AppM = ReaderT App (LoggingT IO)+--+-- Now you have application-specific actions that can do IO, log, and access+-- your state:+--+-- > myAppAction :: AppM ()+-- > myAppAction = do+-- >   isDryRun <- asks appDryRun+-- >+-- >   if isDryRun+-- >     then $logWarn "Skipping due to dry-run"+-- >     else liftIO $ fireTheMissles+--+-- These actions can be (composed of course, or) invoked by a @main@ that+-- handles the reader context and evaluating the logging action.+--+-- > main :: IO ()+-- > main = do+-- >   app <- loadApp+-- >   runApp app $ do+-- >     myAppAction+-- >     myOtherAppAction+--+-- == Database+--+-- Adding Database access requires an instance of @'HasSqlPool'@ on your @App@+-- type. Most often, this will be easiest if you indeed separate a @Config@+-- attribute:+--+-- > data Config = Config+-- >   { configDbPoolSize :: Int+-- >   , configLogLevel :: LogLevel+-- >   }+--+-- So you can isolate Env-related concerns+--+-- > loadConfig :: IO Config+-- > loadConfig = Env.parse $ Config+-- >   <$> Env.var Env.auto "PGPOOLSIZE" (Env.def 1)+-- >   <*> Env.flag LevelInfo LevelDebug "DEBUG" mempty+--+-- from the runtime application state:+--+-- > data App = App+-- >   { appConfig :: Config+-- >   , appSqlPool :: SqlPool+-- >   }+-- >+-- > instance HasLogging App where+-- >   getLogLevel = configLogLevel . appConfig+-- >   getLogFormat _ = FormatTerminal+-- >   getLogLocation _ = LogStdout+--+-- The @"Freckle.App.Database"@ module provides @'makePostgresPool'@ for+-- building a Pool given this (limited) config data:+--+-- > loadApp :: IO App+-- > loadApp = do+-- >   appConfig{..} <- loadConfig+-- >   appSqlPool <- makePostgresPool configDbPoolSize+-- >   pure App{..}+-- >+-- > instance HasSqlPool App where+-- >   getSqlPool = appSqlPool+--+-- /Note/: the actual database connection parameters (host, user, etc) are+-- (currently) parsed from conventional environment variables by the underlying+-- driver directly. Our application configuration is only involved in declaring+-- the pool size.+--+-- This unlocks @'runDB'@ for your application:+--+-- > myAppAction :: AppM [Entity Something]+-- > myAppAction = runDB $ selectList [] []+--+-- == Testing+--+-- @"Freckle.App.Test"@ exposes an @'AppExample'@ type for examples in a+-- @'SpecWith' App@ spec. The can be run by giving your @loadApp@ function to+-- Hspec's @'before'@.+--+-- Our @Test@ module also exposes @'runAppTest'@ for running @AppM@ actions and+-- lifted expectations for use within such an example.+--+-- > spec :: Spec+-- > spec = before loadApp $ do+-- >   describe "myAppAction" $ do+-- >     it "works" $ do+-- >       result <- runAppTest myAppAction+-- >       result `shouldBe` "as expected"+--+-- If your application makes use of the database, a few things will have to be+-- different:+--+-- First, we want to have a specialized @'runDB'@ in tests to avoid excessive+-- annotations because of the generalized type of @'runDB'@ itself:+--+-- > import Database.Persist.Sql+-- > import qualified Freckle.App.Database as DB+-- >+-- > runDB :: SqlPersistM IO a -> AppExample App a+-- > runDB = DB.runDB+--+-- Second, we'll probably want a conventional @withApp@ function so that we can+-- truncate tables as part of spec setup:+--+-- > import Freckle.App (runApp)+-- > import Freckle.App.Test hiding (withApp)+-- > import Test.Hspec+-- >+-- > withApp :: SpecWith App -> Spec+-- > withApp = before $ do+-- >   app <- loadApp+-- >   runSqlPool truncateTables $ appSqlPool app+-- >   pure app+--+-- And now you can write specs that also use the database:+--+-- > spec :: Spec+-- > spec = withApp $ do+-- >   describe "myAppAction" $ do+-- >     it "works" . withGraph runDB do+-- >       nodeWith -- ...+-- >       nodeWith -- ...+-- >       nodeWith -- ...+-- >+-- >       result <- lift $ runAppTest myAppAction+-- >       result `shouldBe` "as expected"+--+module Freckle.App+  ( runApp+  , module X+  )+where++import Prelude++import Control.Monad.Logger as X+import Control.Monad.Reader as X+import Freckle.App.Database as X+import Freckle.App.Logging as X+import System.IO (BufferMode(..), hSetBuffering, stderr, stdout)++runApp :: HasLogging app => app -> ReaderT app (LoggingT IO) a -> IO a+runApp app action = do+  -- Ensure output is streamed if in a Docker container+  hSetBuffering stdout LineBuffering+  hSetBuffering stderr LineBuffering+  runAppLoggerT app $ runReaderT action app

@@ -0,0 +1,217 @@+{-# LANGUAGE ApplicativeDo #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE StrictData #-}++-- | Database access for your @App@+module Freckle.App.Database+  (+  -- * Abstract over access to a sql database+    HasSqlPool(..)+  , SqlPool+  , Seconds(..)+  , makePostgresPool+  , makePostgresPoolWith+  , runDB+  , PostgresConnectionConf(..)+  , PostgresPasswordSource(..)+  , PostgresPassword(..)+  , envParseDatabaseConf+  , envPostgresPasswordSource+  ) where++import Prelude++import Control.Concurrent+import qualified Control.Immortal as Immortal+import Control.Monad.IO.Unlift (MonadUnliftIO)+import Control.Monad.Logger (runNoLoggingT)+import Control.Monad.Reader+import Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as BS8+import Data.IORef+import Data.Pool+import qualified Data.Text as T+import Data.Time (UTCTime, getCurrentTime)+import Database.Persist.Postgresql+import Database.PostgreSQL.Simple+  (Connection, Only(..), connectPostgreSQL, execute)+import Database.PostgreSQL.Simple.SqlQQ (sql)+import qualified Freckle.App.Env as Env+import Freckle.App.Time (Seconds(..))+import System.Process (readProcess)++type SqlPool = Pool SqlBackend++class HasSqlPool app where+  getSqlPool :: app -> SqlPool++instance HasSqlPool SqlPool where+  getSqlPool = id++makePostgresPool :: IO SqlPool+makePostgresPool = do+  postgresPasswordSource <- Env.parse envPostgresPasswordSource+  conf <- Env.parse (envParseDatabaseConf postgresPasswordSource)+  makePostgresPoolWith conf++runDB+  :: (HasSqlPool app, MonadUnliftIO m, MonadReader app m)+  => SqlPersistT m a+  -> m a+runDB action = do+  pool <- asks getSqlPool+  runSqlPool action pool++data PostgresConnectionConf = PostgresConnectionConf+  { pccHost :: String+  , pccPort :: Int+  , pccUser :: String+  , pccPassword :: PostgresPassword+  , pccDatabase :: String+  , pccPoolSize :: Int+  , pccStatementTimeout :: Seconds+  }+  deriving stock (Show, Eq)++data PostgresPasswordSource+  = PostgresPasswordSourceIamAuth+  | PostgresPasswordSourceEnv+  deriving stock (Show, Eq)++data PostgresPassword+  = PostgresPasswordIamAuth+  | PostgresPasswordStatic String+  deriving stock (Show, Eq)++envPostgresPasswordSource :: Env.Parser PostgresPasswordSource+envPostgresPasswordSource = do+  useIam <- Env.switch "USE_RDS_IAM_AUTH" $ Env.def False+  pure $ if useIam+    then PostgresPasswordSourceIamAuth+    else PostgresPasswordSourceEnv++envParseDatabaseConf+  :: PostgresPasswordSource -> Env.Parser PostgresConnectionConf+envParseDatabaseConf source = do+  user <- Env.var Env.str "PGUSER" Env.nonEmpty+  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+  poolSize <- Env.var Env.auto "PGPOOLSIZE" $ Env.def 1+  statementTimeout <- Env.var Env.auto "PGSTATEMENTTIMEOUT" $ Env.def 120+  pure PostgresConnectionConf+    { pccHost = host+    , pccPort = port+    , pccUser = user+    , pccPassword = password+    , pccDatabase = database+    , pccPoolSize = poolSize+    , pccStatementTimeout = statementTimeout+    }++data AuroraIamToken = AuroraIamToken+  { aitToken :: String+  , aitCreatedAt :: UTCTime+  , aitPostgresConnectionConf :: PostgresConnectionConf+  }+  deriving stock (Show, Eq)++createAuroraIamToken :: PostgresConnectionConf -> IO 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+    , "--region"+    , "us-east-1"+    , "--username"+    , pccUser+    ]+    ""+  aitCreatedAt <- getCurrentTime+  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+  :: PostgresConnectionConf -> IO (IORef AuroraIamToken)+spawnIamTokenRefreshThread conf = do+  tokenIORef <- newIORef =<< createAuroraIamToken conf+  void $ Immortal.create $ \_ -> Immortal.onFinish onFinishCallback $ do+    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 ()++refreshIamToken :: PostgresConnectionConf -> IORef AuroraIamToken -> IO ()+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 =+  let timeoutMillis = unSeconds pccStatementTimeout * 1000+  in void $ execute conn [sql| SET statement_timeout = ? |] (Only timeoutMillis)++makePostgresPoolWith :: PostgresConnectionConf -> IO SqlPool+makePostgresPoolWith conf@PostgresConnectionConf {..} = case pccPassword of+  PostgresPasswordIamAuth -> makePostgresPoolWithIamAuth conf+  PostgresPasswordStatic password ->+    runNoLoggingT $ createPostgresqlPoolModified+      (setTimeout conf)+      (postgresConnectionString conf password)+      pccPoolSize++-- | Creates a PostgreSQL pool using IAM auth for the password.+makePostgresPoolWithIamAuth :: PostgresConnectionConf -> IO SqlPool+makePostgresPoolWithIamAuth conf@PostgresConnectionConf {..} = do+  tokenIORef <- spawnIamTokenRefreshThread conf+  runNoLoggingT $ 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)+    conn <- connectPostgreSQL connStr+    setTimeout conf conn+    openSimpleConn logFunc conn++postgresConnectionString :: PostgresConnectionConf -> String -> ByteString+postgresConnectionString PostgresConnectionConf {..} password =+  BS8.pack $ unwords+    [ "host=" <> pccHost+    , "port=" <> show pccPort+    , "user=" <> pccUser+    , "password=" <> password+    , "dbname=" <> pccDatabase+    ]

@@ -0,0 +1,196 @@+{-# LANGUAGE ApplicativeDo #-}+{-# LANGUAGE NamedFieldPuns #-}++-- | Datadog access for your @App@+module Freckle.App.Datadog+  (+  -- * Reader environment interface+    HasDogStatsClient(..)+  , HasDogStatsTags(..)+  , StatsClient+  , Tag++  -- * Lower-level operations+  , sendAppMetricWithTags++  -- * Higher-level operations+  , increment+  , counter+  , guage+  , histogram+  , histogramSince+  , histogramSinceMs++  -- * Reading settings at startup+  , DogStatsSettings(..)+  , envParseDogStatsEnabled+  , envParseDogStatsSettings+  , envParseDogStatsTags+  , mkStatsClient+  )+where++import Prelude++import Control.Lens (set)+import Control.Monad.IO.Unlift (MonadUnliftIO)+import Control.Monad.Reader+import Data.Foldable (for_)+import Data.Text (Text)+import Data.Time (NominalDiffTime, UTCTime, diffUTCTime, getCurrentTime)+import qualified Freckle.App.Env as Env+import Network.StatsD.Datadog hiding (metric, name, tags)+import qualified Network.StatsD.Datadog as Datadog+import Yesod.Core.Types (HandlerData, handlerEnv, rheSite)++class HasDogStatsClient app where+  getDogStatsClient :: app -> Maybe StatsClient++instance HasDogStatsClient site =>  HasDogStatsClient (HandlerData child site) where+  getDogStatsClient = getDogStatsClient . rheSite . handlerEnv++class HasDogStatsTags app where+  getDogStatsTags :: app -> [Tag]++instance HasDogStatsTags site =>  HasDogStatsTags (HandlerData child site) where+  getDogStatsTags = getDogStatsTags . rheSite . handlerEnv++increment+  :: ( MonadUnliftIO m+     , MonadReader env m+     , HasDogStatsClient env+     , HasDogStatsTags env+     )+  => Text+  -> [(Text, Text)]+  -> m ()+increment name tags = counter name tags 1++counter+  :: ( MonadUnliftIO m+     , MonadReader env m+     , HasDogStatsClient env+     , HasDogStatsTags env+     )+  => Text+  -> [(Text, Text)]+  -> Int+  -> m ()+counter name tags = sendAppMetricWithTags name tags Counter++guage+  :: ( MonadUnliftIO m+     , MonadReader env m+     , HasDogStatsClient env+     , HasDogStatsTags env+     )+  => Text+  -> [(Text, Text)]+  -> Double+  -> m ()+guage name tags = sendAppMetricWithTags name tags Gauge++histogram+  :: ( MonadUnliftIO m+     , MonadReader env m+     , HasDogStatsClient env+     , HasDogStatsTags env+     , ToMetricValue n+     )+  => Text+  -> [(Text, Text)]+  -> n+  -> m ()+histogram name tags metricValue =+  sendAppMetricWithTags name tags Histogram metricValue++histogramSince+  :: ( MonadUnliftIO m+     , MonadReader env m+     , HasDogStatsClient env+     , HasDogStatsTags env+     )+  => Text+  -> [(Text, Text)]+  -> UTCTime+  -> m ()+histogramSince = histogramSinceBy toSeconds+  where+  -- N.B. NominalDiffTime is treated as seconds when using round. Replace round+  -- with nominalDiffTimeToSeconds once we upgrade our version of the time+  -- library.+        toSeconds = round @_ @Int++histogramSinceMs+  :: ( MonadUnliftIO m+     , MonadReader env m+     , HasDogStatsClient env+     , HasDogStatsTags env+     )+  => Text+  -> [(Text, Text)]+  -> UTCTime+  -> m ()+histogramSinceMs = histogramSinceBy toMilliseconds+  where toMilliseconds = (* 1000) . realToFrac @_ @Double++histogramSinceBy+  :: ( MonadUnliftIO m+     , MonadReader env m+     , HasDogStatsClient env+     , HasDogStatsTags env+     , ToMetricValue n+     )+  => (NominalDiffTime -> n)+  -> Text+  -> [(Text, Text)]+  -> UTCTime+  -> m ()+histogramSinceBy f name tags time = do+  now <- liftIO getCurrentTime+  let delta = f $ now `diffUTCTime` time+  sendAppMetricWithTags name tags Histogram delta++sendAppMetricWithTags+  :: ( MonadUnliftIO m+     , MonadReader env m+     , HasDogStatsClient env+     , HasDogStatsTags env+     , ToMetricValue v+     )+  => Text+  -> [(Text, Text)]+  -> MetricType+  -> v+  -> m ()+sendAppMetricWithTags name tags metricType metricValue = do+  mClient <- asks getDogStatsClient++  for_ mClient $ \client -> do+    appTags <- asks getDogStatsTags++    let+      ddTags = appTags <> map (uncurry tag) tags+      ddMetric = set Datadog.tags ddTags+        $ Datadog.metric (MetricName name) metricType metricValue++    send client ddMetric++envParseDogStatsEnabled :: Env.Parser Bool+envParseDogStatsEnabled = Env.switch "DOGSTATSD_ENABLED" $ Env.def False++envParseDogStatsSettings :: Env.Parser 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+  dogStatsSettingsMaxDelay <-+    Env.var Env.auto "DOGSTATSD_MAX_DELAY_MICROSECONDS" $ Env.def 1000000+  pure defaultSettings+    { dogStatsSettingsHost+    , dogStatsSettingsPort+    , dogStatsSettingsMaxDelay+    }++envParseDogStatsTags :: Env.Parser [Tag]+envParseDogStatsTags =+  Env.var (map (uncurry tag) <$> Env.keyValues) "DOGSTATSD_TAGS" $ Env.def []

@@ -0,0 +1,280 @@+-- | Parse the shell environment for configuration+--+-- Usage:+--+-- > import Freckle.App.Env+-- >+-- > data Config = Config -- Example+-- >   { cBatchSize :: Natural+-- >   , cDryRun :: Bool+-- >   , cLogLevel :: LogLevel+-- >   }+-- >+-- > loadConfig :: IO Config+-- > loadConfig = parse $ Config+-- >   <$> var auto "BATCH_SIZE" (def 1)+-- >   <*> 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+  , Off(..)+  , On(..)+  , parse+  , var+  , flag+  , switch+  , handleEither++  -- * Readers+  , str+  , auto+  , time+  , keyValues+  , eitherReader++  -- * Modifiers+  , def+  , nonEmpty+  )+where++import Prelude++import Control.Error.Util (note)+import Data.Bifunctor (first, second)+import Data.String+import Data.Text (Text, pack, unpack)+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)++-- | Designates the value of a parameter when a flag is not provided.+newtype Off a = Off a++-- | 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+-- is returned, otherwise the default is used.+--+-- >>> import Control.Monad.Logger+--+-- >>> exampleParse [("DEBUG", "1")] $ flag (Off LevelInfo) (On LevelDebug) "DEBUG" mempty+-- Right LevelDebug+--+-- >>> exampleParse [("DEBUG", "")] $ flag (Off LevelInfo) (On LevelDebug) "DEBUG" mempty+-- Right LevelInfo+--+-- >>> exampleParse [] $ flag (Off LevelInfo) (On LevelDebug) "DEBUG" mempty+-- Right LevelInfo+--+-- N.B. only the empty string is falsey:+--+-- >>> exampleParse [("DEBUG", "false")] $ flag (Off LevelInfo) (On LevelDebug) "DEBUG" mempty+-- Right LevelDebug+--+-- >>> exampleParse [("DEBUG", "no")] $ flag (Off LevelInfo) (On LevelDebug) "DEBUG" mempty+-- 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++-- | Use a value's @'Read'@ instance+--+-- >>> import Numeric.Natural+--+-- >>> exampleParse @Natural [("SIZE", "1")] $ var auto "SIZE" mempty+-- Right 1+--+-- >>> exampleParse @Natural [("SIZE", "-1")] $ var auto "SIZE" mempty+-- Left [("SIZE",InvalidError "Prelude.read: no parse: \"-1\"")]+--+auto :: Read a => Reader a+auto = eitherReader readEither++-- | Read a time value using the given format+--+-- >>> exampleParse [("TIME", "1985-02-12")] $ var (time "%Y-%m-%d") "TIME" mempty+-- 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\"")]+--+time :: String -> Reader UTCTime+time fmt =+  eitherReader+    $ note ("unable to parse time as " <> fmt)+    . parseTimeM True defaultTimeLocale fmt++-- | Read key-value pairs+--+-- >>> exampleParse [("TAGS", "foo:bar,baz:bat")] $ var keyValues "TAGS" mempty+-- 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\"")]+--+-- 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\"")]+--+keyValues :: Reader [(Text, Text)]+keyValues = eitherReader $ traverse keyValue . T.splitOn "," . pack+ where+  keyValue :: Text -> Either String (Text, Text)+  keyValue t = case second (T.drop 1) $ T.breakOn ":" t of+    (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

@@ -0,0 +1,99 @@+{-# LANGUAGE TupleSections #-}++-- | Internal Env machinery exposed for testing+module Freckle.App.Env.Internal+  ( Error(..)+  , Parser(..)+  , bindParser+  , Reader(..)+  , Mod(..)+  , Var(..)+  , varParser+  )+where++import Prelude++import Control.Applicative+import Data.Bifunctor (first)++-- | 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

@@ -0,0 +1,28 @@+module Freckle.App.Ghci+  ( runDB+  , runDB'+  , loadEnv+  , loadEnvTest+  )+where++import Prelude++import Control.Monad.Reader (ReaderT)+import Database.Persist.Postgresql (runSqlPool)+import Database.Persist.Sql (SqlBackend)+import Freckle.App.Database (makePostgresPool)+import LoadEnv (loadEnv, loadEnvFrom)++-- | Run a db action against .env+runDB :: ReaderT SqlBackend IO b -> IO b+runDB f = loadEnv *> runDB' f++-- | Run a db action+runDB' :: ReaderT SqlBackend IO b -> IO b+runDB' f = do+  pool <- makePostgresPool+  runSqlPool f pool++loadEnvTest :: IO ()+loadEnvTest = loadEnvFrom ".env.test"

@@ -0,0 +1,88 @@+-- | Facility for purely creating an 'IORef' in which to stash a value+--+-- Storing a truly global value can be useful for performance (e.g. to speed up+-- tests by caching a constructed App) or necessary to prevent contention (e.g.+-- by caching a single 'LoggerSet' which holds access to a log file).+--+-- In some cases, it's not possible to create an 'IORef' safely in an 'IO'+-- context to use for this purpose. Either because a library prevents it (e.g.+-- the test runner provides no such hook before triggering its parallel+-- execution) or because the current application architecture cannot allow it+-- without a high effort re-organization.+--+-- For these cases, we use this module.+--+-- == Usage+--+-- Given some function,+--+-- @+-- makeLogger :: HasLogging a => a -> IO Logger+-- makeLogger app = makeYesodLogger =<< newLoggerSet defaultBufSize+--  where+--   newLoggerSet = case getLogLocation app of+--     LogStdout -> newStdoutLoggerSet+--     LogStderr -> newStderrLoggerSet+--     LogFile f -> flip newFileLoggerSet f+-- @+--+-- Update it to cache the construction in a new top-level value,+--+-- @+-- loggerSetVar :: GlobalCache LoggerSet+-- loggerSetVar = unsafePerformIO newGlobalCache+-- {-# NOINLINE loggerSetVar #-}+--+-- makeLogger :: HasLogging a => a -> IO Logger+-- makeLogger app = makeYesodLogger+--   =<< globallyCache loggerSetVar (newLoggerSet defaultBufSize)+--  where+--   newLoggerSet = case getLogLocation app of+--     LogStdout -> newStdoutLoggerSet+--     LogStderr -> newStderrLoggerSet+--     LogFile f -> flip newFileLoggerSet f+-- @+--+module Freckle.App.GlobalCache+  ( GlobalCache+  , newGlobalCache+  , globallyCache+  , withGlobalCacheCleanup+  )+where++import Prelude++import Control.Concurrent.MVar (mkWeakMVar, modifyMVar_, newMVar)+import Control.Monad (void)+import Data.IORef++newtype GlobalCache a = GlobalCache+  { _unGlobalCache :: IORef (Maybe a)+  }++newGlobalCache :: IO (GlobalCache a)+newGlobalCache = GlobalCache <$> newIORef Nothing++globallyCache :: GlobalCache a -> IO a -> IO a+globallyCache (GlobalCache var) construct = do+  mv <- readIORef var+  maybe (cache =<< construct) pure mv+  where cache v = atomicModifyIORef' var $ const (Just v, v)++-- | Garbage collect one of our 'IORef's after an action has run+--+-- Global 'IORef's are problematic for @ghci@. @ghci@ cannot garbage collect+-- them, so any state they hold will persist for an entire @ghci@ session. This+-- causes a varietyof issues.+--+-- 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 ()+  void $ mkWeakMVar cleanup $ writeIORef var Nothing+  void action+  modifyMVar_ cleanup (const $ pure ())

@@ -0,0 +1,243 @@+-- | Centralized module for making HTTP requests from the backend+--+-- These functions:+--+-- - Do not throw exceptions on non-200+-- - May throw for other 'HttpException' cases (e.g. 'ConnectionTimeout')+-- - Handle 429-@Retry-In@ for you+-- - Capture decoding failures with 'Either' values as the 'Response' body+--+-- == Examples+--+-- Make request, retry on 429s, and parse the body as JSON.+--+-- @+-- -- Throws, but only on a complete failure to perform the request+-- resp <- 'httpJson' $ 'parseRequest_' "https://example.com"+--+-- -- Safe access+-- 'getResponseBody' resp :: Either 'HttpDecodeError' a+--+-- -- Unsafe access (throws on Left)+-- 'getResponseBodyUnsafe' resp :: m a+-- @+--+-- 'httpLbs' can be used to get a raw response (without risk of decoding+-- errors), and 'httpDecode' can be used to supply your own decoding function+-- (e.g. for CSV).+--+-- Interact with a paginated endpoint that uses @Link@, combining all the pages+-- monoidally (e.g. concat) and throwing on any decoding errors.+--+-- @+-- 'httpPaginated' 'httpJson' 'getResponseBodyUnsafe' $ 'parseRequest_' "https://..."+-- @+--+-- Decoding errors can be handled differently by adjusting what 'Monoid' you+-- convert each page's response into:+--+-- @+-- 'httpPaginated' 'httpJson' fromResponseLenient $ 'parseRequest_' "https://..."+--+-- fromResponseLenient+--   :: MonadLogger m+--   => Response (Either e [MyJsonThing])+--   -> m [MyJsonThing]+-- fromResponseLenient r = case getResponseBody r of+--      Left _ -> [] <$ logWarn "..."+--      Right a -> pure a+-- @+--+-- 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(..)+  , httpDecode+  , httpLbs+  , httpNoBody+  , httpPaginated+  , sourcePaginated++  -- * Request builders+  , Request+  , parseRequest+  , parseRequest_++  -- * Request modifiers+  , addRequestHeader+  , addAcceptHeader+  , addBearerAuthorizationHeader+  , addToRequestQueryString+  , setRequestBasicAuth+  , setRequestBodyJSON+  , setRequestBodyURLEncoded+  , setRequestCheckStatus+  , setRequestPath++  -- * Response accessors+  , Response+  , getResponseStatus+  , getResponseBody++  -- ** 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+  --+  --   -- ...+  -- @+  --+  , httpExceptionIsInformational+  , httpExceptionIsRedirection+  , httpExceptionIsClientError+  , httpExceptionIsServerError++  -- * "Network.HTTP.Types" re-exports+  , Status+  , statusCode+  , statusIsInformational+  , statusIsSuccessful+  , statusIsRedirection+  , statusIsClientError+  , statusIsServerError+  ) where++import Prelude++import Conduit (foldC, mapMC, runConduit, (.|))+import Control.Monad.IO.Class (MonadIO)+import Data.Aeson (FromJSON)+import qualified Data.Aeson as Aeson+import Data.Bifunctor (first)+import qualified Data.ByteString as BS+import Data.ByteString.Lazy (ByteString)+import qualified Data.ByteString.Lazy.Char8 as BSL8+import Data.List.NonEmpty (NonEmpty(..))+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.Simple hiding (httpLbs, httpNoBody)+import qualified Network.HTTP.Simple as HTTP+import Network.HTTP.Types.Header (hAccept, hAuthorization)+import Network.HTTP.Types.Status+  ( Status+  , statusCode+  , statusIsClientError+  , statusIsInformational+  , statusIsRedirection+  , statusIsServerError+  , statusIsSuccessful+  )+import UnliftIO.Exception (Exception(..), throwIO)++data HttpDecodeError = HttpDecodeError+  { hdeBody :: ByteString+  , hdeErrors :: NonEmpty String+  }+  deriving stock (Eq, Show)++instance Exception HttpDecodeError where+  displayException HttpDecodeError {..} =+    unlines+      $ ["Error decoding HTTP Response:", "Raw body:", BSL8.unpack hdeBody]+      <> fromErrors hdeErrors+   where+    fromErrors = \case+      err :| [] -> ["Error:", err]+      errs -> "Errors:" : map bullet (NE.toList errs)+    bullet = (" • " <>)++-- | Request and decode a response as JSON+httpJson+  :: (MonadIO m, FromJSON a)+  => Request+  -> m (Response (Either HttpDecodeError a))+httpJson = httpDecode (first pure . Aeson.eitherDecode)+  . addAcceptHeader "application/json"++-- | Request and decode a response+httpDecode+  :: MonadIO m+  => (ByteString -> Either (NonEmpty String) a)+  -> Request+  -> m (Response (Either HttpDecodeError a))+httpDecode decode req = do+  resp <- httpLbs req+  let body = getResponseBody resp+  pure $ first (HttpDecodeError body) . decode <$> resp++-- | Request a lazy 'ByteString', handling 429 retries+httpLbs :: MonadIO m => Request -> m (Response ByteString)+httpLbs = rateLimited httpLBS++-- | Make a Request ignoring the response, but handling 429 retries+httpNoBody :: MonadIO m => Request -> m (Response ())+httpNoBody = rateLimited HTTP.httpNoBody++-- | Request all pages of a paginated endpoint into a big list+--+-- This uses 'sourcePaginated', and so reads a @Link@ header. To do otherwise,+-- drop down to 'sourcePaginatedBy' directly.+--+-- 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))+  -> (Response a -> m b)+  -> Request+  -> m b+httpPaginated runRequest getBody req =+  runConduit $ sourcePaginated runRequest req .| mapMC getBody .| foldC++addAcceptHeader :: BS.ByteString -> Request -> Request+addAcceptHeader = addRequestHeader hAccept++addBearerAuthorizationHeader :: BS.ByteString -> Request -> Request+addBearerAuthorizationHeader = addRequestHeader hAuthorization . ("Bearer " <>)++-- | Read an 'Either' response body, throwing any 'Left' as an exception+--+-- 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++httpExceptionIsInformational :: HttpException -> Bool+httpExceptionIsInformational = filterStatusException statusIsInformational++httpExceptionIsRedirection :: HttpException -> Bool+httpExceptionIsRedirection = filterStatusException statusIsRedirection++httpExceptionIsClientError :: HttpException -> Bool+httpExceptionIsClientError = filterStatusException statusIsClientError++httpExceptionIsServerError :: HttpException -> Bool+httpExceptionIsServerError = filterStatusException statusIsServerError++filterStatusException :: (Status -> Bool) -> HttpException -> Bool+filterStatusException predicate = \case+  HttpExceptionRequest _ (StatusCodeException resp _) ->+    predicate $ getResponseStatus resp+  _ -> False

@@ -0,0 +1,102 @@+-- | Streaming interface for paginated HTTP APIs+--+-- == Examples+--+-- Take an action on each page as it is requested:+--+-- @+-- let req = parseRequest_ "https://..."+--+-- runConduit+--   $ sourcePaginated httpJson req+--   .| mapM_C onEachPage+--+-- onEachPage :: Response (Either HttpDecodeError [MyJsonThing]) -> m ()+-- onEachPage = undefined+-- @+--+-- Take and action /and/ collect:+--+-- @+-- allPages <- runConduit+--   $ 'sourcePaginated' httpJson req+--   .| iterM onEachPage+--   .| sinkList+-- @+--+-- For APIs that do pagination not via @Link@, you can use 'sourcePaginatedBy'+--+-- @+-- data Page a = Page+--   { pData :: [a]+--   , pNext :: Int+--   }+--+-- instance FromJSON a => FromJSON (Item a) where+--   parseJSON = withObject "Page" $ \o -> Page+--     <$> o .: "data"+--     <*> o .: "next"+--+-- runConduit+--   $ 'sourcePaginatedBy' nextPage httpJson req+--   .| mapMC (fmap pData . 'getResponseBodyUnsafe')+--   .| foldC+--+-- nextPage+--   :: Request+--   -> Response (Either ('HttpDecodeError' String) (Page a))+--   -> Maybe Request+-- nextPage req resp = do+--   body <- hush $ getResponseBody resp+--   let next = C8.pack $ show $ pNext body+--   pure $ addToRequestQueryString [("next", Just next)] req+-- @+--+module Freckle.App.Http.Paginate+  ( sourcePaginated+  , sourcePaginatedBy+  ) where++import Prelude++import Conduit+import Control.Error.Util (hush)+import Data.Foldable (traverse_)+import Data.List (find)+import Data.Maybe (listToMaybe)+import Data.Text.Encoding (decodeUtf8)+import Network.HTTP.Link.Compat hiding (linkHeader)+import Network.HTTP.Simple++-- | Stream pages of a paginated response, using @Link@ to find next pages+--+sourcePaginated+  :: MonadIO m+  => (Request -> m (Response body))+  -- ^ Run one request+  -> Request+  -- ^ Initial request+  -> ConduitT i (Response body) m ()+sourcePaginated = sourcePaginatedBy linkHeader++-- | Stream pages of a paginated response, using a custom /find next/+sourcePaginatedBy+  :: MonadIO m+  => (Request -> Response body -> Maybe Request)+  -- ^ How to get the next page from each request+  -> (Request -> m (Response body))+  -- ^ Run one request+  -> Request+  -- ^ Initial request+  -> ConduitT i (Response body) m ()+sourcePaginatedBy mNextRequest runRequest req = do+  resp <- lift $ runRequest req+  yield resp+  traverse_ (sourcePaginatedBy mNextRequest runRequest) $ mNextRequest req resp++linkHeader :: Request -> Response body -> Maybe Request+linkHeader _req resp = do+  header <- listToMaybe $ getResponseHeader "Link" resp+  links <- hush $ parseLinkURI $ decodeUtf8 header+  uri <- href <$> find (((Rel, "next") `elem`) . linkParams) links+  parseRequest $ show uri

@@ -0,0 +1,95 @@+module Freckle.App.Http.Retry+  ( RetriesExhausted(..)+  , rateLimited+  , rateLimited'+  ) where++import Prelude++import Control.Monad (guard, unless, void)+import Control.Monad.IO.Class (MonadIO)+import Control.Retry+import qualified Data.ByteString.Char8 as BS8+import Data.Maybe (listToMaybe)+import Network.HTTP.Client (Request(..))+import Network.HTTP.Simple+import Network.HTTP.Types.Status (status429)+import Text.Read (readMaybe)+import UnliftIO.Exception (Exception(..), throwIO)++-- | Thrown if we exhaust our retries limit and still see a @429@+--+-- This typically means the API is not sending back accurate @Retry-In@ values+-- with 429 responses.+--+-- __Rationale__:+--+-- In order for 'rateLimited' to function in the case when the 'Request' is+-- using 'throwErrorStatusCodes' for 'checkResponse', we have to modify it to+-- not throw on 429s specifically. Otherwise, the first response would just+-- throw due to 4XX and never retry. However, in that case of someone expecting+-- invalid statuses to throw an exception, if we exhaust our retries and still+-- see a 429 at the end, an exception should be thrown.+--+-- 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++instance Exception RetriesExhausted where+  displayException RetriesExhausted {..} =+    "Retries exhaused after "+      <> show reLimit+      <> " attempts. Final response:\n"+      <> show reResponse++rateLimited+  :: MonadIO m => (Request -> m (Response body)) -> Request -> m (Response body)+rateLimited = rateLimited' 10++-- | 'rateLimited' but with configurable retry limit+rateLimited'+  :: MonadIO m+  => Int+  -> (Request -> m (Response body))+  -> Request+  -> m (Response body)+rateLimited' retryLimit f req = do+  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++checkRetriesExhausted :: MonadIO m => Int -> Response body -> m (Response body)+checkRetriesExhausted retryLimit resp+  | getResponseStatus resp == status429 = throwIO+  $ RetriesExhausted { reLimit = retryLimit, reResponse = void resp }+  | otherwise = pure resp++getRetryAfter :: Response body -> Maybe Int+getRetryAfter resp = do+  guard $ getResponseStatus resp == status429+  header <- listToMaybe $ getResponseHeader "Retry-After" resp+  readMaybe $ BS8.unpack header++microseconds :: Int -> Int+microseconds = (* 1000000)

@@ -0,0 +1,197 @@+{-# LANGUAGE TupleSections #-}++module Freckle.App.Logging+  (+  -- * Logging settings+    HasLogging(..)+  , getLogDefaultANSI+  , getLogBehaviors+  , LogLevel+  , LogFormat(..)+  , LogLocation(..)++  -- ** Loading+  , parseEnvLogFormat+  , parseEnvLogLevel+  , parseEnvLogLocation++  -- * 'MonadLogger'-style running+  , runAppLoggerT++  -- * Formats, for use from other Logging libraries+  , formatJsonLogStr+  , formatJsonNoLoc+  , formatJson+  , formatTerminal+  )+where++import Prelude++import Control.Monad.Logger+import Data.Aeson (ToJSON, encode, object, (.=))+import Data.ByteString (ByteString)+import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as BS8+import qualified Data.ByteString.Lazy as BSL+import Data.Text (Text)+import Data.Text.Encoding (decodeUtf8)+import qualified Freckle.App.Env as Env+import System.Console.ANSI+  ( Color(Blue, Magenta, Red, Yellow)+  , ColorIntensity(Dull)+  , ConsoleLayer(Foreground)+  , SGR(Reset, SetColor)+  , hSupportsANSI+  , setSGRCode+  )+import System.IO (stderr, stdout)++data LogFormat+  = FormatJSON+  -- ^ Emit @{"level": "{level}", "message": "{message}"}@+  | FormatTerminal+  -- ^ Emit @[{level}] @{message}@, possibly colorized++data LogLocation+  = LogStdout+  | LogStderr+  | LogFile FilePath++-- | Class for getting Logging settings from your @app@ type+class HasLogging a where+    getLogLevel :: a -> LogLevel++    getLogFormat :: a -> LogFormat++    getLogLocation :: a -> LogLocation++-- | Provide a pure decision for colorizing output+--+-- This is useful in a context where actively checking for ANSI terminal support+-- is either not possible or too expensive. Given that we support 'LogFile', and+-- so are unlikely to be redirecting terminal output to a file, it is relatively+-- safe to use this determination.+--+getLogDefaultANSI :: HasLogging a => a -> Bool+getLogDefaultANSI app = case (getLogLocation app, getLogFormat app) of+  (LogStdout, FormatTerminal) -> True+  (LogStdout, FormatJSON) -> False+  (LogStderr, FormatTerminal) -> True+  (LogStderr, FormatJSON) -> False+  (LogFile _, FormatTerminal) -> False+  (LogFile _, FormatJSON) -> False++getLogBehaviors :: HasLogging a => a -> IO (ByteString -> IO (), Bool)+getLogBehaviors app = case getLogLocation app of+  LogStdout -> (BS8.hPutStr stdout, ) <$> hSupportsANSI stdout+  LogStderr -> (BS8.hPutStr stderr, ) <$> hSupportsANSI stderr+  LogFile path -> pure (BS8.appendFile path, False)++parseEnvLogLevel :: Env.Parser LogLevel+parseEnvLogLevel = Env.var parse "LOG_LEVEL" $ Env.def LevelWarn+ where+  parse = Env.eitherReader $ \case+    "warn" -> Right LevelWarn+    "error" -> Right LevelError+    "debug" -> Right LevelDebug+    "info" -> Right LevelInfo+    level -> Left $ "unexpected log level: " <> level++parseEnvLogFormat :: Env.Parser LogFormat+parseEnvLogFormat = Env.var parse "LOG_FORMAT" $ Env.def FormatTerminal+ where+  parse = Env.eitherReader $ \case+    "json" -> Right FormatJSON+    "terminal" -> Right FormatTerminal+    format -> Left $ "unexpected format: " <> format++parseEnvLogLocation :: Env.Parser LogLocation+parseEnvLogLocation = Env.var parse "LOG_LOCATION" $ Env.def LogStdout+ where+  parse = Env.eitherReader $ \case+    "stdout" -> Right LogStdout+    "stderr" -> Right LogStderr+    "file" -> Right $ LogFile "fancy.log"+    file -> Right $ LogFile file++runAppLoggerT :: HasLogging a => a -> LoggingT IO b -> IO b+runAppLoggerT app f = do+  (putLogLine, isANSI) <- getLogBehaviors app++  let+    logger = case getLogFormat app of+      FormatJSON -> jsonLogger putLogLine+      FormatTerminal -> ansiLogger putLogLine isANSI++  flip runLoggingT logger+    $ filterLogger (\_ level -> level >= getLogLevel app) f+ where+  jsonLogger putLogLine loc src level str =+    putLogLine $ formatJsonLogStr loc src level str++  ansiLogger putLogLine isANSI loc src level str =+    putLogLine $ formatTerminal isANSI loc src level str++formatJsonLogStr :: Loc -> LogSource -> LogLevel -> LogStr -> ByteString+formatJsonLogStr loc src level =+  formatJson (Just loc) (Just src) level . decodeUtf8 . fromLogStr++formatJsonNoLoc :: ToJSON a => LogLevel -> a -> ByteString+formatJsonNoLoc = formatJson Nothing Nothing++formatJson+  :: ToJSON a => Maybe Loc -> Maybe LogSource -> LogLevel -> a -> ByteString+formatJson loc src level msg = (<> "\n") $ BSL.toStrict $ encode $ object+  [ "loc" .= (locJson <$> loc)+  , "src" .= src+  , "level" .= levelText level+  , "message" .= msg+  ]+ where+  locJson Loc {..} = object+    [ "filename" .= loc_filename+    , "package" .= loc_package+    , "module" .= loc_module+    , "start" .= loc_start+    , "end" .= loc_end+    ]++formatTerminal+  :: ToLogStr a+  => Bool -- ^ Supports escapes?+  -> Loc+  -> LogSource+  -> LogLevel+  -> a+  -> ByteString+formatTerminal isANSI loc src level str = mconcat+  [ esc $ style level+  , BS.snoc levelStr labelEnd+  , esc Reset+  , BS.intercalate (BS.singleton labelEnd) logStr+  , esc Reset+  ]+ where+  labelEnd = fromIntegral $ fromEnum ']'++  (levelStr : logStr) =+    BS.split labelEnd . fromLogStr $ defaultLogStr loc src level $ toLogStr str++  esc x = if isANSI then BS8.pack $ setSGRCode [x] else ""++style :: LogLevel -> SGR+style = \case+  LevelDebug -> SetColor Foreground Dull Magenta+  LevelInfo -> SetColor Foreground Dull Blue+  LevelWarn -> SetColor Foreground Dull Yellow+  LevelError -> SetColor Foreground Dull Red+  LevelOther _ -> Reset++levelText :: LogLevel -> Text+levelText = \case+  LevelDebug -> "Debug"+  LevelInfo -> "Info"+  LevelWarn -> "Warn"+  LevelError -> "Error"+  LevelOther x -> x

@@ -0,0 +1,74 @@+-- | Compatibility between "Freckle.App" and "RIO"+--+-- "Freckle.App" was created before "RIO" existed. We need to decide if we're+-- going to move to using "RIO" without "Freckle.App" (and port the things+-- we've added to be "RIO"-based), or not.+--+-- As part of that decisions, some Apps are using "RIO". These should still be+-- able to make use of "Freckle.App", by using this module.+--+module Freckle.App.RIO+  ( toAppLogLevel+  , fromAppLogLevel+  , makeLogFunc+  )+where++import Prelude++import Control.Monad (when)+import Control.Monad.Logger (Loc(..), LogLevel(..))+import Data.Maybe (fromMaybe, listToMaybe)+import Freckle.App.Logging+import GHC.Exception (CallStack, SrcLoc(..), getCallStack)+import qualified RIO++toAppLogLevel :: RIO.LogLevel -> LogLevel+toAppLogLevel = \case+  RIO.LevelDebug -> LevelDebug+  RIO.LevelInfo -> LevelInfo+  RIO.LevelWarn -> LevelWarn+  RIO.LevelError -> LevelError+  RIO.LevelOther x -> LevelOther x++fromAppLogLevel :: LogLevel -> RIO.LogLevel+fromAppLogLevel = \case+  LevelDebug -> RIO.LevelDebug+  LevelInfo -> RIO.LevelInfo+  LevelWarn -> RIO.LevelWarn+  LevelError -> RIO.LevelError+  LevelOther x -> RIO.LevelOther x++makeLogFunc :: HasLogging a => a -> IO RIO.LogFunc+makeLogFunc app = do+  (putLogLine, isANSI) <- getLogBehaviors app++  pure $ RIO.mkLogFunc $ \cs src rioLevel builder -> do+    let+      level = toAppLogLevel rioLevel+      msg = RIO.utf8BuilderToText builder++    when (level >= getLogLevel app) $ putLogLine $ case getLogFormat app of+      FormatJSON -> formatJson (Just $ callStackToLoc cs) (Just src) level msg+      FormatTerminal -> formatTerminal isANSI (callStackToLoc cs) src level msg++callStackToLoc :: CallStack -> Loc+callStackToLoc cs = fromMaybe unknownLoc $ do+  (_, SrcLoc {..}) <- listToMaybe $ getCallStack cs++  pure $ Loc+    { loc_filename = srcLocFile+    , loc_package = srcLocPackage+    , loc_module = srcLocModule+    , loc_start = (srcLocStartLine, srcLocStartCol)+    , loc_end = (srcLocEndLine, srcLocEndCol)+    }++unknownLoc :: Loc+unknownLoc = Loc+  { loc_filename = "<unknown>"+  , loc_package = "<unknown>"+  , loc_module = "unknown"+  , loc_start = (0, 0)+  , loc_end = (0, 0)+  }

@@ -0,0 +1,104 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -fno-warn-deprecations #-}++module Freckle.App.Test+  ( AppExample+  , withApp+  , withAppSql+  , runAppTest+  , module X+  ) where++import Prelude++import Control.Monad.Base+import Control.Monad.Catch+import Control.Monad.IO.Unlift+import Control.Monad.Logger+import Control.Monad.Primitive+import Control.Monad.Random (MonadRandom(..))+import Control.Monad.Reader+import Control.Monad.Trans.Control+import Data.Pool as X+import Database.Persist.Sql (SqlPersistT, runSqlPool)+import Freckle.App.Database as X+import LoadEnv+import Test.Hspec as X+  (Spec, beforeAll, beforeWith, context, describe, example, fit, it, xit)+import Test.Hspec.Core.Spec (Arg, Example, SpecWith, evaluateExample)+import Test.Hspec.Expectations.Lifted as X++-- | An Hspec example over some @App@ value+newtype AppExample app a = AppExample (NoLoggingT (ReaderT app IO) a)+  deriving newtype+    ( Applicative+    , Functor+    , Monad+    , MonadBase IO+    , MonadBaseControl IO+    , MonadCatch+    , MonadIO+    , MonadReader app+    , MonadThrow+    , MonadUnliftIO+    , MonadFail+    , MonadLogger+    )++instance MonadRandom (AppExample app) where+  getRandomR = liftIO . getRandomR+  getRandom = liftIO getRandom+  getRandomRs = liftIO . getRandomRs+  getRandoms = liftIO getRandoms++instance PrimMonad (AppExample app) where+  type PrimState (AppExample app) = PrimState IO+  primitive = liftIO . primitive++instance Example (AppExample app a) where+  type Arg (AppExample app a) = app++  evaluateExample (AppExample ex) params action = evaluateExample+    (action $ \app -> void $ runReaderT (runNoLoggingT ex) app)+    params+    ($ ())++-- | Spec before helper+--+-- @+-- spec :: Spec+-- spec = 'withApp' loadApp $ do+-- @+--+-- Reads @.env.test@, then @.env@, then loads the application. Examples within+-- this spec can use 'runAppTest' (and 'runDB', if the app 'HasSqlPool').+--+withApp :: IO app -> SpecWith app -> Spec+withApp load = beforeAll (loadEnvTest *> load)++-- | 'withApp', with custom DB 'Pool' initialization+--+-- Runs the given function on the pool before every spec item. For example, to+-- truncate tables.+--+withAppSql+  :: HasSqlPool app => SqlPersistT IO a -> IO app -> SpecWith app -> Spec+withAppSql f load = beforeAll (loadEnvTest *> load) . beforeWith setup+  where setup app = app <$ runSqlPool f (getSqlPool app)++loadEnvTest :: IO ()+loadEnvTest = loadEnvFrom ".env.test" >> loadEnv++-- | Run an action with the test @App@+--+-- Like @'runApp'@, but without exception handling or logging+--+runAppTest :: ReaderT app (LoggingT IO) a -> AppExample app a+runAppTest action = do+  app <- ask++  liftIO $ runStderrLoggingT $ filterLogger (\_ _ -> False) $ runReaderT+    action+    app

@@ -0,0 +1,77 @@+{-# LANGUAGE PackageImports #-}++module Freckle.App.Test.DocTest+  ( doctest+  , doctestWith++  -- * Lower-level, for site-specific use+  , findPackageFlags+  , findDocTestedFiles+  )+where++import Prelude++import Control.Monad (filterM)+import Data.Aeson+import Data.Text (Text)+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++-- | Run doctest on files in the given directory+doctest :: FilePath -> IO ()+doctest = doctestWith []++-- | Run doctest on files in the given directory and with additional flags+doctestWith :: [String] -> FilePath -> IO ()+doctestWith flags dir = do+  packageFlags <- findPackageFlags+  sourceFiles <- findDocTestedFiles dir+  DocTest.doctest $ packageFlags <> flags <> sourceFiles++-- | Representation of only the information we need in a @package.yaml@+data PackageYaml+  = PackageYaml+  { defaultExtensions :: [String]+  , name :: String+  }++instance FromJSON PackageYaml where+  parseJSON = withObject "PackageYaml"+    $ \o -> PackageYaml <$> o .: "default-extensions" <*> o .: "name"++-- Parse @default-extensions@ and @name& out of @package.yaml@+--+-- NB. This won't find target-specific extensions. If your package does this+-- (consider not, then) add them via the direct argument to @'doctestWith'@.+--+findPackageFlags :: IO [String]+findPackageFlags = do+  PackageYaml {..} <- decodeFileThrow "package.yaml"+  pure $ ("-package " <> name) : map ("-X" <>) defaultExtensions++-- | Find any source files with doctest comments+--+-- Doctest with a lot of files is really slow. Like /really/ slow:+--+-- <https://github.com/sol/doctest/issues/141>+--+-- Also, some suites won't actually work on a lot of our files because of some+-- instance-import-related debt that we don't have the time to clean up at this+-- time:+--+-- <https://freckleinc.slack.com/archives/C459XJBGR/p1519220418000125>+--+-- 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+  filterM (fmap hasDocTests . T.readFile) paths++hasDocTests :: Text -> Bool+hasDocTests = any ("-- >>>" `T.isInfixOf`) . T.lines

@@ -0,0 +1,101 @@+module Freckle.App.Test.Hspec.Runner+  ( run+  , runParConfig+  , runWith+  , makeParallelConfig+  )+where++import Prelude++import Control.Applicative ((<|>))+import Control.Concurrent (getNumCapabilities, setNumCapabilities)+import Control.Monad (void)+import Control.Monad.Trans.Maybe (MaybeT(MaybeT), runMaybeT)+import Data.List (isInfixOf)+import Data.Maybe (fromMaybe, isJust)+import System.Environment (getArgs, lookupEnv)+import Test.HSpec.JUnit (runJUnitSpec)+import Test.Hspec (Spec)+import Test.Hspec.Runner+  ( Config+  , Path+  , configConcurrentJobs+  , configSkipPredicate+  , defaultConfig+  , evaluateSummary+  , readConfig+  , runSpec+  )++run :: String -> Spec -> IO ()+run = runWith defaultConfig++runParConfig :: String -> Spec -> IO ()+runParConfig name spec = do+  config <- makeParallelConfig defaultConfig+  runWith config name spec++runWith :: Config -> String -> Spec -> IO ()+runWith config name spec = do+  args <- getArgs+  isCircle <- isJust <$> lookupEnv "CIRCLECI"+  let runner = if isCircle then junit else hspec++  -- 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)++  putStrLn "Running RELIABLE"+  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)++  evaluateSummary $ reliableSummary <> isolatedSummary+ where+  load = flip readConfig+  junit filename changeConfig =+    (spec `runJUnitSpec` ("/tmp/junit", filename)) . changeConfig+  hspec _ changeConfig = runSpec spec . changeConfig+  noConcurrency x = x { configConcurrentJobs = Just 1 }++makeParallelConfig :: Config -> IO Config+makeParallelConfig config = do+  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 }++lookupTestCapabilities :: IO (Maybe Int)+lookupTestCapabilities = fmap read <$> lookupEnv "TEST_CAPABILITIES"++lookupHostCapabilities :: IO (Maybe Int)+lookupHostCapabilities = Just . reduceCapabilities <$> getNumCapabilities++-- Reduce capabilities to avoid contention with postgres+reduceCapabilities :: Int -> Int+reduceCapabilities = max 1 . (`div` 2)++skip :: (Path -> Bool) -> Config -> Config+skip predicate config = config { configSkipPredicate = Just predicate }++unreliableTests :: Path -> Bool+unreliableTests = ("UNRELIABLE" `isInfixOf`) . snd++reliableTests :: Path -> Bool+reliableTests = not . unreliableTests++isolatedTests :: Path -> Bool+isolatedTests = ("ISOLATED" `isInfixOf`) . snd++anys :: [a -> Bool] -> a -> Bool+anys xs a = or $ fmap (\f -> f a) xs

@@ -0,0 +1,10 @@+-- | Time types and functions for @App@+module Freckle.App.Time+  ( Seconds(..)+  ) where++import Prelude++newtype Seconds = Seconds { unSeconds :: Int }+  deriving stock (Show, Read)+  deriving newtype (Eq, Num)

@@ -0,0 +1,102 @@+-- | 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 Prelude++import Control.Applicative ((<|>))+import Control.Error.Util (hoistEither, note)+import Control.Monad.IO.Class (MonadIO(..))+import Control.Monad.IO.Unlift (MonadUnliftIO)+import Control.Monad.Trans.Except+import Data.Bifunctor (first)+import Data.Char (isSpace)+import Data.List (dropWhileEnd)+import Data.Text (Text, pack)+import qualified Data.Text as T+import Data.Time (UTCTime, getCurrentTime)+import Data.Time.Format (defaultTimeLocale, parseTimeM)+import System.Exit (ExitCode(..))+import System.FilePath ((</>))+import System.Process (readProcessWithExitCode)+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 $ readProcessWithExitCode "git" args []++  case ec of+    ExitSuccess -> pure stdout+    ExitFailure n ->+      throwE $ "[" <> show n <> "] git " <> unwords args <> ": " <> stderr++exceptIO :: MonadIO m => IO a -> ExceptT String m a+exceptIO = withExceptT show . ExceptT . liftIO . tryIO++strip :: String -> String+strip = dropWhile isSpace . dropWhileEnd isSpace

@@ -0,0 +1,217 @@+-- | Integration of "Freckle.App" tooling with "Network.Wai"+module Freckle.App.Wai+  ( RouteName(..)+  , TraceId(..)+  , makeLoggingMiddleware+  , noCacheMiddleware+  , corsMiddleware+  )+where++import Prelude++import Control.Applicative ((<|>))+import Control.Monad (guard)+import Control.Monad.Logger (LogLevel(..))+import Data.Aeson+import Data.Bifunctor (first)+import Data.ByteString (ByteString)+import qualified Data.ByteString as BS+import Data.ByteString.Builder (toLazyByteString)+import qualified Data.ByteString.Char8 as BS8+import qualified Data.ByteString.Lazy as BSL+import qualified Data.CaseInsensitive as CI+import Data.Default (def)+import Data.IP (fromHostAddress, fromHostAddress6)+import Data.Maybe (fromMaybe)+import Data.Text (Text)+import Data.Text.Encoding (decodeUtf8With)+import Data.Text.Encoding.Error (lenientDecode)+import Freckle.App.Logging+import Network.HTTP.Types (QueryItem, ResponseHeaders)+import Network.HTTP.Types.Status (Status, status200, statusCode)+import Network.Socket+import Network.Wai+import Network.Wai.Middleware.AddHeaders (addHeaders)+import Network.Wai.Middleware.RequestLogger+  ( Destination(Logger)+  , OutputFormat(..)+  , OutputFormatterWithDetails+  , destination+  , mkRequestLogger+  , outputFormat+  )+import System.Log.FastLogger (LoggerSet, toLogStr)++newtype RouteName = RouteName+  { unRouteName :: Text+  }+  deriving newtype ToJSON++newtype TraceId = TraceId+  { unTraceId :: Text+  }+  deriving newtype ToJSON++makeLoggingMiddleware+  :: HasLogging app+  => app+  -> (Request -> Maybe RouteName)+  -> (Request -> Maybe TraceId)+  -> LoggerSet+  -> IO Middleware+makeLoggingMiddleware app getRouteName getTraceId ls = case getLogFormat app of+  FormatJSON ->+    makeWith+      $ CustomOutputFormatWithDetails+      $ suppressByStatus (getLogLevel app)+      $ jsonOutputFormatter getRouteName getTraceId+  FormatTerminal -> makeWith $ Detailed $ getLogDefaultANSI app+ where+  makeWith format =+    mkRequestLogger def { outputFormat = format, destination = Logger ls }++suppressByStatus+  :: LogLevel -> OutputFormatterWithDetails -> OutputFormatterWithDetails+suppressByStatus minLevel f date req status responseSize duration reqBody response+  | statusLevel status >= minLevel+  = f date req status responseSize duration reqBody response+  | otherwise+  = ""++jsonOutputFormatter+  :: (Request -> Maybe RouteName)+  -> (Request -> Maybe TraceId)+  -> OutputFormatterWithDetails+jsonOutputFormatter getRouteName getTraceId date req status responseSize duration _reqBody response+  = toLogStr $ formatJsonNoLoc (statusLevel status) $ object+    [ "time" .= decodeUtf8 date+    , "method" .= decodeUtf8 (requestMethod req)+    , "route" .= getRouteName req+    , "path" .= decodeUtf8 (rawPathInfo req)+    , "query_string" .= map queryItemToJSON (queryString req)+    , "status" .= statusCode status+    , "duration_ms" .= (duration * 1000)+    , "request_size" .= requestBodyLengthToJSON (requestBodyLength req)+    , "response_size" .= responseSize+    , "response_body" .= do+      guard $ statusCode status >= 400+      Just $ maybeDecodeToValue $ toLazyByteString response+    , "trace_id" .= getTraceId req+    , "client_ip" .= (decodeUtf8 <$> clientIp)+    ]+  where clientIp = requestRealIp req <|> Just (sockAddrToIp $ remoteHost req)++statusLevel :: Status -> LogLevel+statusLevel status = case statusCode status of+  404 -> LevelInfo -- Special case+  code | code >= 500 -> LevelError+  code | code >= 400 -> LevelWarn+  code | code >= 300 -> LevelInfo+  _ -> LevelDebug++decodeUtf8 :: ByteString -> Text+decodeUtf8 = decodeUtf8With lenientDecode++requestBodyLengthToJSON :: RequestBodyLength -> Value+requestBodyLengthToJSON ChunkedBody = String "Unknown"+requestBodyLengthToJSON (KnownLength l) = toJSON l++queryItemToJSON :: QueryItem -> Value+queryItemToJSON (name, mValue) =+  toJSON (decodeUtf8 name, decodeUtf8 <$> mValue)++-- Try to decode as a 'Value'. Otherwise make a JSON string.+maybeDecodeToValue :: BSL.ByteString -> Value+maybeDecodeToValue str =+  fromMaybe (toJSON . decodeUtf8With lenientDecode . BSL.toStrict $ str)+    . decode @Value+    $ str++-- Copied from bugnag-haskell++requestRealIp :: Request -> Maybe ByteString+requestRealIp request =+  requestForwardedFor request <|> lookup "X-Real-IP" (requestHeaders request)++requestForwardedFor :: Request -> Maybe ByteString+requestForwardedFor request =+  readForwardedFor =<< lookup "X-Forwarded-For" (requestHeaders request)++-- |+--+-- >>> readForwardedFor ""+-- Nothing+--+-- >>> readForwardedFor "123.123.123"+-- Just "123.123.123"+--+-- >>> readForwardedFor "123.123.123, 45.45.45"+-- Just "123.123.123"+--+readForwardedFor :: ByteString -> Maybe ByteString+readForwardedFor bs+  | BS8.null bs = Nothing+  | otherwise = Just $ fst $ BS8.break (== ',') bs++sockAddrToIp :: SockAddr -> ByteString+sockAddrToIp (SockAddrInet _ h) = BS8.pack $ show $ fromHostAddress h+sockAddrToIp (SockAddrInet6 _ _ h _) = BS8.pack $ show $ fromHostAddress6 h+sockAddrToIp (SockAddrUnix _) = "<socket>"++noCacheMiddleware :: Middleware+noCacheMiddleware = addHeaders [cacheControlHeader]+ where+  cacheControlHeader =+    ("Cache-Control", "no-cache, no-store, max-age=0, private")++corsMiddleware+  :: (ByteString -> Bool)+  -- ^ Predicate that returns 'True' for valid @Origin@ values+  -> [ByteString]+  -- ^ Extra headers to add to @Expose-Headers@+  -> Middleware+corsMiddleware validateOrigin extraExposedHeaders =+  handleOptions validateOrigin extraExposedHeaders+    . addCORSHeaders validateOrigin extraExposedHeaders++handleOptions :: (ByteString -> Bool) -> [ByteString] -> Middleware+handleOptions validateOrigin extraExposedHeaders app req sendResponse =+  case (requestMethod req, lookup "Origin" (requestHeaders req)) of+    ("OPTIONS", Just origin) -> sendResponse $ responseLBS+      status200+      (toHeaders $ corsResponseHeaders validateOrigin extraExposedHeaders origin+      )+      mempty+    _ -> app req sendResponse+ where+  toHeaders :: [(ByteString, ByteString)] -> ResponseHeaders+  toHeaders = map (first CI.mk)++addCORSHeaders :: (ByteString -> Bool) -> [ByteString] -> Middleware+addCORSHeaders validateOrigin extraExposedHeaders app req sendResponse =+  case lookup "Origin" (requestHeaders req) of+    Nothing -> app req sendResponse+    Just origin -> addHeaders+      (corsResponseHeaders validateOrigin extraExposedHeaders origin)+      app+      req+      sendResponse++corsResponseHeaders+  :: (ByteString -> Bool)+  -> [ByteString]+  -> ByteString+  -> [(ByteString, ByteString)]+corsResponseHeaders validateOrigin extraExposedHeaders origin =+  [ ("Access-Control-Allow-Origin", validatedOrigin)+  , ("Access-Control-Allow-Methods", "POST, GET, OPTIONS, PUT, DELETE, PATCH")+  , ("Access-Control-Allow-Credentials", "true")+  , ("Access-Control-Allow-Headers", "Content-Type, *")+  , ("Access-Control-Expose-Headers", BS.intercalate ", " exposedHeaders)+  ]+ where+  validatedOrigin = if validateOrigin origin then origin else "BADORIGIN"++  exposedHeaders =+    ["Set-Cookie", "Content-Disposition", "Link"] <> extraExposedHeaders

@@ -0,0 +1,55 @@+-- | Integration of "Freckle.App" tooling with "Yesod"+module Freckle.App.Yesod+  ( makeLogger+  , messageLoggerSource+  )+where++import Prelude++import Control.Monad (when)+import Control.Monad.Logger+import Freckle.App.GlobalCache+import Freckle.App.Logging+import System.IO.Unsafe (unsafePerformIO)+import System.Log.FastLogger+  ( LoggerSet+  , defaultBufSize+  , newFileLoggerSet+  , newStderrLoggerSet+  , newStdoutLoggerSet+  )+import Yesod.Core.Types (Logger, loggerPutStr)+import Yesod.Default.Config2 (makeYesodLogger)++loggerSetVar :: GlobalCache LoggerSet+loggerSetVar = unsafePerformIO newGlobalCache+{-# NOINLINE loggerSetVar #-}+{-# ANN loggerSetVar ("HLint: ignore Avoid restricted function" :: String) #-}++makeLogger :: HasLogging a => a -> IO Logger+makeLogger app = makeYesodLogger+  =<< globallyCache loggerSetVar (newLoggerSet defaultBufSize)+ where+  newLoggerSet = case getLogLocation app of+    LogStdout -> newStdoutLoggerSet+    LogStderr -> newStderrLoggerSet+    LogFile f -> flip newFileLoggerSet f++messageLoggerSource+  :: HasLogging a+  => a+  -> Logger+  -> Loc+  -> LogSource+  -> LogLevel+  -> LogStr+  -> IO ()+messageLoggerSource app logger loc src level str =+  when (level >= getLogLevel app)+    $ loggerPutStr logger+    $ toLogStr+    $ case getLogFormat app of+        FormatJSON -> formatJsonLogStr loc src level str+        FormatTerminal ->+          formatTerminal (getLogDefaultANSI app) loc src level str

@@ -0,0 +1,27 @@+{-# LANGUAGE CPP #-}+module Network.HTTP.Link.Compat+    ( Link+    , linkURI+    , parseLinkURI+    , module Network.HTTP.Link+    )+where++import Prelude++import Data.Text (Text)+import Network.HTTP.Link hiding (Link)+import qualified Network.HTTP.Link as HTTP+import Network.URI (URI)++#if MIN_VERSION_http_link_header(1,2,0)+type Link = HTTP.Link URI+#else+type Link = HTTP.Link+#endif++linkURI :: URI -> [(LinkParam, Text)] -> Link+linkURI = HTTP.Link++parseLinkURI :: Text -> Either String [Link]+parseLinkURI = parseLinkHeader'

@@ -0,0 +1,125 @@+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

@@ -0,0 +1,43 @@+module Freckle.App.HttpSpec+  ( spec+  ) where++import Prelude++import Control.Lens (_Left, _Right, to, (^?))+import Data.Aeson+import Data.Aeson.Lens+import qualified Data.List.NonEmpty as NE+import Freckle.App.Http+import Network.HTTP.Types.Status (status200)+import Test.Hspec++spec :: Spec+spec = do+  describe "httpJson" $ do+    it "fetches JSON via HTTP" $ do+      resp <- httpJson @_ @Value+        $ parseRequest_ "https://www.stackage.org/lts-17.10"++      getResponseStatus resp `shouldBe` status200+      getResponseBody resp+        ^? _Right+        . 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"++      let+        expectedErrorMessage+          = "Error in $: parsing [] failed, expected Array, but encountered Object"++      getResponseStatus resp `shouldBe` status200+      getResponseBody resp+        ^? _Left+        . to hdeErrors+        . to NE.toList+        `shouldBe` Just [expectedErrorMessage]

@@ -0,0 +1,59 @@+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

@@ -0,0 +1,120 @@+module Freckle.App.WaiSpec+  ( spec+  )+where++import Prelude++import Data.ByteString (ByteString)+import Data.Function (on)+import Data.List (deleteBy)+import Freckle.App.Wai (corsMiddleware, noCacheMiddleware)+import Network.HTTP.Types.Method (Method)+import Network.HTTP.Types.Status (status200)+import Network.Wai+import Network.Wai.Test+import Test.Hspec++spec :: Spec+spec = do+  describe "noCacheMiddleware" $ do+    let+      runTestSession :: Session a -> IO a+      runTestSession f = runSession f $ noCacheMiddleware app++    it "adds an appropriate Cache-Control header" $ runTestSession $ do+      response <- request defaultRequest++      assertHeader+        "Cache-Control"+        "no-cache, no-store, max-age=0, private"+        response+      assertBody "Test" response++  describe "corsMiddleware" $ do+    let+      runTestSession :: Session a -> IO a+      runTestSession = runTestSessionWith (const False) []++      runTestSessionWith+        :: (ByteString -> Bool) -> [ByteString] -> Session a -> IO a+      runTestSessionWith validateOrigin extraExposedHeaders f =+        runSession f $ corsMiddleware validateOrigin extraExposedHeaders app++    it "adds CORS headers to responses for non-OPTIONS" $ runTestSession $ do+      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++      assertAccessControlHeaders "BADORIGIN" response+      assertBody mempty response++    it "doesn't operate on requests without Origin" $ runTestSession $ do+      response1 <- request defaultRequest+      response2 <- request $ setMethod "OPTIONS" defaultRequest++      assertBody "Test" response1+      assertNoAccessControlHeaders response1+      assertBody "Test" response2+      assertNoAccessControlHeaders response2++    it "accepts only valid Origins" $ runTestSessionWith (== "A") [] $ do+      responseA <- request $ setOriginHeader "A" defaultRequest+      responseB <- request $ setOriginHeader "B" defaultRequest++      assertAccessControlHeaders "A" responseA+      assertAccessControlHeaders "BADORIGIN" responseB+      assertBody "Test" responseA+      assertBody "Test" responseB++    it "adds extra Exposed-Headers"+      $ runTestSessionWith (const False) ["X-Foo"]+      $ do+          response <- request $ setOriginHeader "unimportant" defaultRequest+          assertHeader+            "Access-Control-Expose-Headers"+            "Set-Cookie, Content-Disposition, Link, X-Foo"+            response++app :: Application+app _req respond = respond $ responseLBS status200 [] "Test"++setMethod :: Method -> Request -> Request+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] }++assertAccessControlHeaders :: ByteString -> SResponse -> Session ()+assertAccessControlHeaders origin response = do+  assertHeader "Access-Control-Allow-Origin" origin response+  assertHeader+    "Access-Control-Allow-Methods"+    "POST, GET, OPTIONS, PUT, DELETE, PATCH"+    response+  assertHeader "Access-Control-Allow-Credentials" "true" response+  assertHeader "Access-Control-Allow-Headers" "Content-Type, *" response+  assertHeader+    "Access-Control-Expose-Headers"+    "Set-Cookie, Content-Disposition, Link"+    response++assertNoAccessControlHeaders :: SResponse -> Session ()+assertNoAccessControlHeaders response = do+  assertNoHeader "Access-Control-Allow-Origin" response+  assertNoHeader "Access-Control-Allow-Methods" response+  assertNoHeader "Access-Control-Allow-Credentials" response+  assertNoHeader "Access-Control-Allow-Headers" response+  assertNoHeader "Access-Control-Expose-Headers" response

@@ -0,0 +1,13 @@+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

@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --module-name=Spec -optF --no-main #-}