diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -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. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,7 @@ +# freckle-app + +Haskell application toolkit used at Freckle. + +--- + +[CHANGELOG](./CHANGELOG.md) | [LICENSE](./LICENSE) diff --git a/doctest/Main.hs b/doctest/Main.hs new file mode 100644 --- /dev/null +++ b/doctest/Main.hs @@ -0,0 +1,11 @@ +module Main + ( main + ) +where + +import Prelude + +import Freckle.App.Test.DocTest + +main :: IO () +main = doctest "library/" diff --git a/freckle-app.cabal b/freckle-app.cabal new file mode 100644 --- /dev/null +++ b/freckle-app.cabal @@ -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 diff --git a/library/Freckle/App.hs b/library/Freckle/App.hs new file mode 100644 --- /dev/null +++ b/library/Freckle/App.hs @@ -0,0 +1,190 @@ +-- | Micro-framework for building a non-web application +-- +-- This is a version of the /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 diff --git a/library/Freckle/App/Database.hs b/library/Freckle/App/Database.hs new file mode 100644 --- /dev/null +++ b/library/Freckle/App/Database.hs @@ -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 + ] diff --git a/library/Freckle/App/Datadog.hs b/library/Freckle/App/Datadog.hs new file mode 100644 --- /dev/null +++ b/library/Freckle/App/Datadog.hs @@ -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 [] diff --git a/library/Freckle/App/Env.hs b/library/Freckle/App/Env.hs new file mode 100644 --- /dev/null +++ b/library/Freckle/App/Env.hs @@ -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. +-- +-- +-- +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 diff --git a/library/Freckle/App/Env/Internal.hs b/library/Freckle/App/Env/Internal.hs new file mode 100644 --- /dev/null +++ b/library/Freckle/App/Env/Internal.hs @@ -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 diff --git a/library/Freckle/App/Ghci.hs b/library/Freckle/App/Ghci.hs new file mode 100644 --- /dev/null +++ b/library/Freckle/App/Ghci.hs @@ -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" diff --git a/library/Freckle/App/GlobalCache.hs b/library/Freckle/App/GlobalCache.hs new file mode 100644 --- /dev/null +++ b/library/Freckle/App/GlobalCache.hs @@ -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 ()) diff --git a/library/Freckle/App/Http.hs b/library/Freckle/App/Http.hs new file mode 100644 --- /dev/null +++ b/library/Freckle/App/Http.hs @@ -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 diff --git a/library/Freckle/App/Http/Paginate.hs b/library/Freckle/App/Http/Paginate.hs new file mode 100644 --- /dev/null +++ b/library/Freckle/App/Http/Paginate.hs @@ -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 diff --git a/library/Freckle/App/Http/Retry.hs b/library/Freckle/App/Http/Retry.hs new file mode 100644 --- /dev/null +++ b/library/Freckle/App/Http/Retry.hs @@ -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) diff --git a/library/Freckle/App/Logging.hs b/library/Freckle/App/Logging.hs new file mode 100644 --- /dev/null +++ b/library/Freckle/App/Logging.hs @@ -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 diff --git a/library/Freckle/App/RIO.hs b/library/Freckle/App/RIO.hs new file mode 100644 --- /dev/null +++ b/library/Freckle/App/RIO.hs @@ -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 = "" + , loc_package = "" + , loc_module = "unknown" + , loc_start = (0, 0) + , loc_end = (0, 0) + } diff --git a/library/Freckle/App/Test.hs b/library/Freckle/App/Test.hs new file mode 100644 --- /dev/null +++ b/library/Freckle/App/Test.hs @@ -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 diff --git a/library/Freckle/App/Test/DocTest.hs b/library/Freckle/App/Test/DocTest.hs new file mode 100644 --- /dev/null +++ b/library/Freckle/App/Test/DocTest.hs @@ -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: +-- +-- +-- +-- 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: +-- +-- +-- +-- 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 diff --git a/library/Freckle/App/Test/Hspec/Runner.hs b/library/Freckle/App/Test/Hspec/Runner.hs new file mode 100644 --- /dev/null +++ b/library/Freckle/App/Test/Hspec/Runner.hs @@ -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 diff --git a/library/Freckle/App/Time.hs b/library/Freckle/App/Time.hs new file mode 100644 --- /dev/null +++ b/library/Freckle/App/Time.hs @@ -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) diff --git a/library/Freckle/App/Version.hs b/library/Freckle/App/Version.hs new file mode 100644 --- /dev/null +++ b/library/Freckle/App/Version.hs @@ -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 diff --git a/library/Freckle/App/Wai.hs b/library/Freckle/App/Wai.hs new file mode 100644 --- /dev/null +++ b/library/Freckle/App/Wai.hs @@ -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 _) = "" + +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 diff --git a/library/Freckle/App/Yesod.hs b/library/Freckle/App/Yesod.hs new file mode 100644 --- /dev/null +++ b/library/Freckle/App/Yesod.hs @@ -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 diff --git a/library/Network/HTTP/Link/Compat.hs b/library/Network/HTTP/Link/Compat.hs new file mode 100644 --- /dev/null +++ b/library/Network/HTTP/Link/Compat.hs @@ -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' diff --git a/tests/Freckle/App/Env/InternalSpec.hs b/tests/Freckle/App/Env/InternalSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Freckle/App/Env/InternalSpec.hs @@ -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 diff --git a/tests/Freckle/App/HttpSpec.hs b/tests/Freckle/App/HttpSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Freckle/App/HttpSpec.hs @@ -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] diff --git a/tests/Freckle/App/VersionSpec.hs b/tests/Freckle/App/VersionSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Freckle/App/VersionSpec.hs @@ -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 diff --git a/tests/Freckle/App/WaiSpec.hs b/tests/Freckle/App/WaiSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Freckle/App/WaiSpec.hs @@ -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 diff --git a/tests/Main.hs b/tests/Main.hs new file mode 100644 --- /dev/null +++ b/tests/Main.hs @@ -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 diff --git a/tests/Spec.hs b/tests/Spec.hs new file mode 100644 --- /dev/null +++ b/tests/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --module-name=Spec -optF --no-main #-}