diff --git a/.github/workflows/release.yml b/.github/workflows/release.yml index 39575b3..4ad5d8a 100644 --- a/.github/workflows/release.yml +++ b/.github/workflows/release.yml @@ -13,6 +13,9 @@ jobs: - freckle-app - freckle-env - freckle-kafka + - freckle-http + - freckle-memcached + - freckle-otel steps: - uses: actions/checkout@v4 diff --git a/cabal.project b/cabal.project index 471f1b8..88c0720 100644 --- a/cabal.project +++ b/cabal.project @@ -1,4 +1,4 @@ -packages: freckle-app +packages: */*.cabal allow-newer: hs-opentelemetry-propagator-datadog:text documentation: True diff --git a/fourmolu.yaml b/fourmolu.yaml index ef571e8..315cc82 100644 --- a/fourmolu.yaml +++ b/fourmolu.yaml @@ -12,4 +12,6 @@ in-style: left-align single-constraint-parens: never # ignored until v12 / ghc-9.6 unicode: never # default respectful: true # default -fixities: [] # default +fixities: + - infixl 1 & + - infixr 4 <>~, .~ diff --git a/freckle-app/CHANGELOG.md b/freckle-app/CHANGELOG.md index eff0fbf..22b9c80 100644 --- a/freckle-app/CHANGELOG.md +++ b/freckle-app/CHANGELOG.md @@ -1,5 +1,21 @@ ## [_Unreleased_](https://github.com/freckle/freckle-app/compare/freckle-app-v1.19.0.0...main) +## [v1.12.0.0](https://github.com/freckle/freckle-app/compare/freckle-app-v1.19.0.0...freckle-app-v1.20.0.0) + +Changes affecting users: + +- Removed `Freckle.App.Memcached(.*)`; these modules have moved into the + `freckle-memcached` package. + +Changes that do not have to affect users: + +- Modules `Freckle.App(.Test?).Http(.*)` are now re-exports from the + `freckle-http` package. +- Modules `Freckle.App.OpenTelementry(.*)` are now re-exports from the + `freckle-otel` package. +- Module `Freckle.App.Dotenv` is now a re-export from the `freckle-env` + package. + ## [v1.19.0.0](https://github.com/freckle/freckle-app/compare/freckle-app-v1.18.2.0...freckle-app-v1.19.0.0) - Removed `Freckle.App.Kafka(.*)`; this is now available from the `freckle-kafka` diff --git a/freckle-app/freckle-app.cabal b/freckle-app/freckle-app.cabal index a7c1416..c6b7c31 100644 --- a/freckle-app/freckle-app.cabal +++ b/freckle-app/freckle-app.cabal @@ -5,7 +5,7 @@ cabal-version: 1.22 -- see: https://github.com/sol/hpack name: freckle-app -version: 1.19.0.0 +version: 1.20.0.0 synopsis: Haskell application toolkit used at Freckle description: Please see README.md category: Utils @@ -35,7 +35,6 @@ library Freckle.App.Bugsnag.SqlError Freckle.App.Csv Freckle.App.Database - Freckle.App.Dotenv Freckle.App.Ecs Freckle.App.Exception Freckle.App.Exception.MonadThrow @@ -44,25 +43,7 @@ library Freckle.App.Faktory.ProducerPool Freckle.App.Ghci Freckle.App.GlobalCache - Freckle.App.Http - Freckle.App.Http.Cache - Freckle.App.Http.Cache.Gzip - Freckle.App.Http.Cache.Memcached - Freckle.App.Http.Cache.State - Freckle.App.Http.Header - Freckle.App.Http.Paginate - Freckle.App.Http.Retry Freckle.App.Json.Empty - Freckle.App.Memcached - Freckle.App.Memcached.CacheKey - Freckle.App.Memcached.CacheTTL - Freckle.App.Memcached.Client - Freckle.App.Memcached.MD5 - Freckle.App.Memcached.Servers - Freckle.App.OpenTelemetry - Freckle.App.OpenTelemetry.Context - Freckle.App.OpenTelemetry.Http - Freckle.App.OpenTelemetry.ThreadContext Freckle.App.Prelude Freckle.App.Random Freckle.App.Scientist @@ -71,8 +52,6 @@ library Freckle.App.Test Freckle.App.Test.DocTest Freckle.App.Test.Hspec.Runner - Freckle.App.Test.Http - Freckle.App.Test.Http.MatchRequest Freckle.App.Test.Properties.JSON Freckle.App.Test.Properties.PathPiece Freckle.App.Test.Properties.PersistValue @@ -86,7 +65,19 @@ library other-modules: Paths_freckle_app reexported-modules: - Freckle.App.Env + Freckle.App.Dotenv + , Freckle.App.Env + , Freckle.App.Http + , Freckle.App.Http.Cache + , Freckle.App.Http.Cache.Gzip + , Freckle.App.Http.Cache.Memcached + , Freckle.App.Http.Cache.State + , Freckle.App.Http.Header + , Freckle.App.Http.Paginate + , Freckle.App.Http.Retry + , Freckle.App.HttpSpec + , Freckle.App.Test.Http + , Freckle.App.Test.Http.MatchRequest hs-source-dirs: library default-extensions: @@ -123,16 +114,14 @@ library , containers , cookie , datadog - , directory , doctest - , dotenv , ekg-core - , errors , exceptions , extra , faktory - , filepath , freckle-env + , freckle-http + , freckle-otel , hashable , hs-opentelemetry-api , hs-opentelemetry-instrumentation-persistent @@ -143,18 +132,13 @@ library , hspec-expectations-lifted , hspec-junit-formatter >=1.1.1.0 , http-client - , http-conduit >=2.3.5 - , http-link-header , http-types , immortal , lens - , memcache , monad-control - , monad-logger , monad-logger-aeson , monad-validate , mtl - , network-uri , nonempty-containers , openapi3 , path-pieces @@ -162,14 +146,11 @@ library , persistent-postgresql , postgresql-simple , primitive - , pureMD5 , resource-pool >=0.4.0.0 , resourcet - , retry >=0.8.1.0 , safe , scientist , semigroupoids - , serialise , template-haskell , text , time @@ -223,11 +204,6 @@ test-suite spec Freckle.App.Bugsnag.MetaDataSpec Freckle.App.BugsnagSpec Freckle.App.CsvSpec - Freckle.App.Http.CacheSpec - Freckle.App.HttpSpec - Freckle.App.Memcached.ServersSpec - Freckle.App.MemcachedSpec - Freckle.App.OpenTelemetry.ContextSpec Freckle.App.Test.Http.MatchRequestSpec Freckle.App.Test.Properties.JSONSpec Freckle.App.Test.Properties.PathPieceSpec @@ -260,28 +236,16 @@ test-suite spec , bytestring , cassava , conduit - , errors , freckle-app - , freckle-env , hs-opentelemetry-api , hspec - , hspec-expectations-json - , hspec-expectations-lifted , http-types - , lens - , lens-aeson - , memcache , monad-validate - , mtl , nonempty-containers , postgresql-simple - , text - , time - , unordered-containers , vector , wai , wai-extra - , zlib default-language: GHC2021 if impl(ghc >= 9.8) ghc-options: -Wno-missing-role-annotations -Wno-missing-poly-kind-signatures diff --git a/freckle-app/library/Freckle/App/Test/Hspec/Runner.hs b/freckle-app/library/Freckle/App/Test/Hspec/Runner.hs index 9b7f216..a476a0d 100644 --- a/freckle-app/library/Freckle/App/Test/Hspec/Runner.hs +++ b/freckle-app/library/Freckle/App/Test/Hspec/Runner.hs @@ -17,8 +17,8 @@ import Test.Hspec.JUnit.Config , setJUnitConfigSourcePathPrefix ) import Test.Hspec.JUnit.Config.Env (envJUnitConfig) -import qualified Test.Hspec.JUnit.Formatter as JUnit (add) -import qualified Test.Hspec.JUnit.Formatter.Env as JUnit (whenEnabled) +import Test.Hspec.JUnit.Formatter qualified as JUnit (add) +import Test.Hspec.JUnit.Formatter.Env qualified as JUnit (whenEnabled) import Test.Hspec.Runner ( Config , Path diff --git a/freckle-app/package.yaml b/freckle-app/package.yaml index 95ada8c..027a431 100644 --- a/freckle-app/package.yaml +++ b/freckle-app/package.yaml @@ -1,5 +1,5 @@ name: freckle-app -version: 1.19.0.0 +version: 1.20.0.0 maintainer: Freckle Education category: Utils github: freckle/freckle-app @@ -55,7 +55,19 @@ default-extensions: library: source-dirs: library reexported-modules: + - Freckle.App.Dotenv - Freckle.App.Env + - Freckle.App.Http + - Freckle.App.Http.Cache + - Freckle.App.Http.Cache.Gzip + - Freckle.App.Http.Cache.Memcached + - Freckle.App.Http.Cache.State + - Freckle.App.Http.Header + - Freckle.App.Http.Paginate + - Freckle.App.Http.Retry + - Freckle.App.HttpSpec + - Freckle.App.Test.Http + - Freckle.App.Test.Http.MatchRequest dependencies: - Blammo >= 2.0.0.0 - Blammo-wai @@ -76,16 +88,14 @@ library: - containers - cookie - datadog - - directory - doctest - - dotenv - ekg-core - - errors - exceptions - extra - faktory - - filepath - freckle-env + - freckle-http + - freckle-otel - hashable - hs-opentelemetry-api - hs-opentelemetry-instrumentation-persistent @@ -96,18 +106,13 @@ library: - hspec-expectations-lifted - hspec-junit-formatter >= 1.1.1.0 # Test.Hspec.JUnit.Formatter - http-client - - http-conduit >= 2.3.5 # addToRequestQueryString - - http-link-header - http-types - immortal - lens - - memcache - monad-control - - monad-logger - monad-logger-aeson - monad-validate - mtl - - network-uri - nonempty-containers - openapi3 - path-pieces @@ -115,14 +120,11 @@ library: - persistent-postgresql - postgresql-simple - primitive - - pureMD5 - resource-pool >= 0.4.0.0 # defaultPoolConfig, etc - resourcet - - retry >= 0.8.1.0 # retryingDynamic - safe - scientist - semigroupoids - - serialise - template-haskell - text - time @@ -152,28 +154,16 @@ tests: - bytestring - cassava - conduit - - errors - freckle-app - - freckle-env - hs-opentelemetry-api - hspec - - hspec-expectations-json - - hspec-expectations-lifted - http-types - - lens - - lens-aeson - - memcache - monad-validate - - mtl - nonempty-containers - postgresql-simple - - text - - time - - unordered-containers - vector - wai - wai-extra - - zlib doctest: main: Main.hs diff --git a/freckle-env/CHANGELOG.md b/freckle-env/CHANGELOG.md index 5b0e813..9969ea1 100644 --- a/freckle-env/CHANGELOG.md +++ b/freckle-env/CHANGELOG.md @@ -1,4 +1,12 @@ -## [_Unreleased_](https://github.com/freckle/freckle-app/compare/freckle-env-v0.0.0.0...main) +## [_Unreleased_](https://github.com/freckle/freckle-app/compare/freckle-env-v0.0.1.1...main) + +## [v0.0.1.1](https://github.com/freckle/freckle-app/compare/freckle-env-v0.0.1.0...freckle-env-v0.0.1.1) + +Drop `relude` dependency + +## [v0.0.1.0](https://github.com/freckle/freckle-app/compare/freckle-env-v0.0.0.0...freckle-env-v0.0.1.0) + +Added module `Freckle.App.Dotenv` (moved from `freckle-app-1.19.0.0`). ## [v0.0.0.0](https://github.com/freckle/freckle-app/tree/freckle-env-v0.0.0.0/freckle-env) diff --git a/freckle-env/freckle-env.cabal b/freckle-env/freckle-env.cabal index 129fc2d..ba91a0f 100644 --- a/freckle-env/freckle-env.cabal +++ b/freckle-env/freckle-env.cabal @@ -5,7 +5,7 @@ cabal-version: 1.18 -- see: https://github.com/sol/hpack name: freckle-env -version: 0.0.0.0 +version: 0.0.1.1 synopsis: Some extension to the envparse library description: Please see README.md category: Environment, System @@ -27,6 +27,7 @@ source-repository head library exposed-modules: + Freckle.App.Dotenv Freckle.App.Env other-modules: Paths_freckle_env @@ -46,11 +47,13 @@ library ghc-options: -fignore-optim-changes -fwrite-ide-info -Weverything -Wno-all-missed-specialisations -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missing-kind-signatures -Wno-missing-local-signatures -Wno-missing-safe-haskell-mode -Wno-monomorphism-restriction -Wno-prepositive-qualified-module -Wno-safe -Wno-unsafe build-depends: base <5 + , dotenv , envparse , errors - , relude + , filepath , text , time + , unliftio default-language: GHC2021 if impl(ghc >= 9.8) ghc-options: -Wno-missing-role-annotations -Wno-missing-poly-kind-signatures diff --git a/freckle-app/library/Freckle/App/Dotenv.hs b/freckle-env/library/Freckle/App/Dotenv.hs similarity index 94% rename from freckle-app/library/Freckle/App/Dotenv.hs rename to freckle-env/library/Freckle/App/Dotenv.hs index cdb7740..63e5ed0 100644 --- a/freckle-app/library/Freckle/App/Dotenv.hs +++ b/freckle-env/library/Freckle/App/Dotenv.hs @@ -5,9 +5,12 @@ module Freckle.App.Dotenv , loadFile ) where -import Freckle.App.Prelude +import Prelude import Configuration.Dotenv qualified as Dotenv +import Control.Monad ((<=<)) +import Data.Foldable (traverse_) +import Data.Functor (void) import System.FilePath (takeDirectory, ()) import UnliftIO.Directory (doesFileExist, getCurrentDirectory) diff --git a/freckle-env/library/Freckle/App/Env.hs b/freckle-env/library/Freckle/App/Env.hs index 19dbb3b..efe50e4 100644 --- a/freckle-env/library/Freckle/App/Env.hs +++ b/freckle-env/library/Freckle/App/Env.hs @@ -35,10 +35,12 @@ module Freckle.App.Env , timeout ) where -import Relude +import Prelude import Control.Error.Util (note) +import Data.Bifunctor (first, second) import Data.Char (isDigit) +import Data.Text (Text) import Data.Text qualified as T import Data.Time (UTCTime, defaultTimeLocale, parseTimeM) import Env hiding (flag) @@ -94,9 +96,9 @@ eitherReader f s = first (unread . suffix) $ f s -- Left [("TIME",UnreadError "unable to parse time as %Y-%m-%d: \"10:00PM\"")] time :: String -> Env.Reader Error UTCTime time fmt = - eitherReader - $ note ("unable to parse time as " <> fmt) - . parseTimeM True defaultTimeLocale fmt + eitherReader $ + note ("unable to parse time as " <> fmt) + . parseTimeM True defaultTimeLocale fmt -- | Read key-value pairs -- @@ -117,11 +119,11 @@ keyValues = splitOnParse ',' $ keyValue ':' keyValue :: Char -> Env.Reader Error (Text, Text) keyValue c = - eitherReader $ go . second (T.drop 1) . T.breakOn (T.singleton c) . toText + eitherReader $ go . second (T.drop 1) . T.breakOn (T.singleton c) . T.pack where go = \case - (k, v) | T.null v -> Left $ "Key " <> toString k <> " has no value" - (k, v) | T.null k -> Left $ "Value " <> toString v <> " has no key" + (k, v) | T.null v -> Left $ "Key " <> T.unpack k <> " has no value" + (k, v) | T.null k -> Left $ "Value " <> T.unpack v <> " has no key" (k, v) -> Right (k, v) -- | Use 'splitOn' then call the given 'Reader' on each element diff --git a/freckle-env/package.yaml b/freckle-env/package.yaml index a2b028f..6adc199 100644 --- a/freckle-env/package.yaml +++ b/freckle-env/package.yaml @@ -1,5 +1,5 @@ name: freckle-env -version: 0.0.0.0 +version: 0.0.1.1 maintainer: Freckle Education category: Environment, System github: freckle/freckle-app @@ -54,11 +54,13 @@ default-extensions: library: source-dirs: library dependencies: + - dotenv - envparse - errors - - relude + - filepath - text - time + - unliftio tests: doctest: diff --git a/freckle-http/CHANGELOG.md b/freckle-http/CHANGELOG.md new file mode 100644 index 0000000..644360b --- /dev/null +++ b/freckle-http/CHANGELOG.md @@ -0,0 +1,5 @@ +## [_Unreleased_](https://github.com/freckle/freckle-app/compare/freckle-http-v0.0.0.0...main) + +## [v0.0.0.0](https://github.com/freckle/freckle-app/tree/freckle-http-v0.0.0.0/freckle-http) + +First release, sprouted from `freckle-app-1.19.0.0`. diff --git a/freckle-http/LICENSE b/freckle-http/LICENSE new file mode 100644 index 0000000..5788a64 --- /dev/null +++ b/freckle-http/LICENSE @@ -0,0 +1,21 @@ +The MIT License (MIT) + +Copyright (c) 2024 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/freckle-http/README.md b/freckle-http/README.md new file mode 100644 index 0000000..b120b5d --- /dev/null +++ b/freckle-http/README.md @@ -0,0 +1 @@ +# freckle-http diff --git a/freckle-http/freckle-http.cabal b/freckle-http/freckle-http.cabal new file mode 100644 index 0000000..847430a --- /dev/null +++ b/freckle-http/freckle-http.cabal @@ -0,0 +1,139 @@ +cabal-version: 1.18 + +-- This file has been generated from package.yaml by hpack version 0.36.0. +-- +-- see: https://github.com/sol/hpack + +name: freckle-http +version: 0.0.0.0 +synopsis: ... +description: Please see README.md +category: Utils +homepage: https://github.com/freckle/freckle-app#readme +bug-reports: https://github.com/freckle/freckle-app/issues +maintainer: Freckle Education +license: MIT +license-file: LICENSE +build-type: Simple +extra-source-files: + package.yaml +extra-doc-files: + README.md + CHANGELOG.md + +source-repository head + type: git + location: https://github.com/freckle/freckle-app + +library + exposed-modules: + Freckle.App.Http + Freckle.App.Http.Cache + Freckle.App.Http.Cache.Gzip + Freckle.App.Http.Cache.Memcached + Freckle.App.Http.Cache.State + Freckle.App.Http.Header + Freckle.App.Http.Paginate + Freckle.App.Http.Retry + Freckle.App.HttpSpec + Freckle.App.Test.Http + Freckle.App.Test.Http.MatchRequest + other-modules: + Paths_freckle_http + hs-source-dirs: + library + default-extensions: + DataKinds + DeriveAnyClass + DerivingVia + DerivingStrategies + DuplicateRecordFields + GADTs + LambdaCase + NoImplicitPrelude + NoMonomorphismRestriction + OverloadedRecordDot + OverloadedStrings + RecordWildCards + TypeFamilies + ghc-options: -fignore-optim-changes -fwrite-ide-info -Weverything -Wno-all-missed-specialisations -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missing-kind-signatures -Wno-missing-local-signatures -Wno-missing-safe-haskell-mode -Wno-monomorphism-restriction -Wno-prepositive-qualified-module -Wno-safe -Wno-unsafe + build-depends: + Blammo >=2.0.0.0 + , Glob + , aeson + , annotated-exception + , base <5 + , bytestring + , case-insensitive + , conduit + , directory + , errors + , extra + , filepath + , freckle-memcached + , hs-opentelemetry-api + , hspec >=2.8.1 + , http-client + , http-conduit >=2.3.5 + , http-link-header + , http-types + , lens + , lens-aeson + , memcache + , monad-logger + , monad-validate + , mtl + , network-uri + , retry >=0.8.1.0 + , safe + , semigroupoids + , serialise + , text + , time + , transformers + , unliftio + , unordered-containers + default-language: GHC2021 + if impl(ghc >= 9.8) + ghc-options: -Wno-missing-role-annotations -Wno-missing-poly-kind-signatures + +test-suite spec + type: exitcode-stdio-1.0 + main-is: Main.hs + other-modules: + Freckle.App.Http.CacheSpec + Paths_freckle_http + hs-source-dirs: + tests + default-extensions: + DataKinds + DeriveAnyClass + DerivingVia + DerivingStrategies + DuplicateRecordFields + GADTs + LambdaCase + NoImplicitPrelude + NoMonomorphismRestriction + OverloadedRecordDot + OverloadedStrings + RecordWildCards + TypeFamilies + ghc-options: -fignore-optim-changes -fwrite-ide-info -Weverything -Wno-all-missed-specialisations -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missing-kind-signatures -Wno-missing-local-signatures -Wno-missing-safe-haskell-mode -Wno-monomorphism-restriction -Wno-prepositive-qualified-module -Wno-safe -Wno-unsafe -threaded -rtsopts "-with-rtsopts=-N" + build-depends: + aeson + , base <5 + , bytestring + , freckle-http + , hspec + , hspec-expectations-json + , hspec-expectations-lifted + , http-types + , lens + , mtl + , time + , unordered-containers + , zlib + default-language: GHC2021 + if impl(ghc >= 9.8) + ghc-options: -Wno-missing-role-annotations -Wno-missing-poly-kind-signatures diff --git a/freckle-app/library/Freckle/App/Http.hs b/freckle-http/library/Freckle/App/Http.hs similarity index 89% rename from freckle-app/library/Freckle/App/Http.hs rename to freckle-http/library/Freckle/App/Http.hs index 62f8f23..b6fd4bc 100644 --- a/freckle-app/library/Freckle/App/Http.hs +++ b/freckle-http/library/Freckle/App/Http.hs @@ -75,22 +75,30 @@ module Freckle.App.Http , StdMethod (..) ) where -import Freckle.App.Prelude +import Prelude import Conduit (foldC, mapMC, runConduit, (.|)) +import Control.Exception.Annotated.UnliftIO (Exception (..), throwWithCallStack) import Control.Monad.Except (ExceptT) +import Control.Monad.IO.Class (MonadIO) +import Control.Monad.Reader (ReaderT) import Control.Monad.State (StateT) +import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Maybe (MaybeT) import Control.Monad.Validate (ValidateT) import Control.Monad.Writer (WriterT) import Data.Aeson (FromJSON) import Data.Aeson qualified as Aeson -import Data.ByteString qualified as BS -import Data.ByteString.Lazy (ByteString) +import Data.Bifunctor (first) +import Data.ByteString (ByteString) +import Data.ByteString.Lazy qualified as BSL import Data.ByteString.Lazy.Char8 qualified as BSL8 +import Data.List.NonEmpty (NonEmpty) import Data.List.NonEmpty qualified as NE +import Data.Text qualified as T import Freckle.App.Http.Paginate import Freckle.App.Http.Retry +import GHC.Stack (HasCallStack) import Network.HTTP.Client qualified as HTTP (Request (..)) import Network.HTTP.Conduit (HttpExceptionContent (..)) import Network.HTTP.Simple hiding (httpLbs, httpNoBody, setRequestMethod) @@ -130,7 +138,7 @@ import Network.HTTP.Types.Status -- resp <- liftIO $ httpLbs ... -- @ class Monad m => MonadHttp m where - httpLbs :: Request -> m (Response ByteString) + httpLbs :: Request -> m (Response BSL.ByteString) instance MonadHttp IO where httpLbs = rateLimited HTTP.httpLbs @@ -154,20 +162,21 @@ instance MonadHttp m => MonadHttp (ValidateT e m) where httpLbs = lift . httpLbs data HttpDecodeError = HttpDecodeError - { hdeBody :: ByteString + { hdeBody :: BSL.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 + T.unpack $ + T.unlines $ + ["Error decoding HTTP Response:", "Raw body:", T.pack $ BSL8.unpack hdeBody] + <> fromErrors hdeErrors where fromErrors = \case - err NE.:| [] -> ["Error:", err] - errs -> "Errors:" : map bullet (NE.toList errs) + err NE.:| [] -> ["Error:", T.pack err] + errs -> "Errors:" : map (bullet . T.pack) (NE.toList errs) bullet = (" • " <>) -- | Make a request and parse the body as JSON @@ -195,7 +204,7 @@ httpJson = -- This be used to request other formats, e.g. CSV. httpDecode :: MonadHttp m - => (ByteString -> Either (NonEmpty String) a) + => (BSL.ByteString -> Either (NonEmpty String) a) -> Request -> m (Response (Either HttpDecodeError a)) httpDecode decode req = do @@ -248,10 +257,10 @@ httpPaginated httpPaginated runRequest getBody req = runConduit $ sourcePaginated runRequest req .| mapMC getBody .| foldC -addAcceptHeader :: BS.ByteString -> Request -> Request +addAcceptHeader :: ByteString -> Request -> Request addAcceptHeader = addRequestHeader hAccept -addBearerAuthorizationHeader :: BS.ByteString -> Request -> Request +addBearerAuthorizationHeader :: ByteString -> Request -> Request addBearerAuthorizationHeader = addRequestHeader hAuthorization . ("Bearer " <>) setRequestMethod :: StdMethod -> Request -> Request @@ -272,7 +281,7 @@ getResponseBodyUnsafe :: (MonadIO m, Exception e, HasCallStack) => Response (Either e a) -> m a -getResponseBodyUnsafe = either throwM pure . getResponseBody +getResponseBodyUnsafe = either throwWithCallStack pure . getResponseBody httpExceptionIsInformational :: HttpException -> Bool httpExceptionIsInformational = filterStatusException statusIsInformational diff --git a/freckle-app/library/Freckle/App/Http/Cache.hs b/freckle-http/library/Freckle/App/Http/Cache.hs similarity index 92% rename from freckle-app/library/Freckle/App/Http/Cache.hs rename to freckle-http/library/Freckle/App/Http/Cache.hs index 4dafd70..1b8562e 100644 --- a/freckle-app/library/Freckle/App/Http/Cache.hs +++ b/freckle-http/library/Freckle/App/Http/Cache.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE NoFieldSelectors #-} -- | Cache HTTP responses like a CDN or browser would @@ -12,17 +10,23 @@ module Freckle.App.Http.Cache , PotentiallyGzipped ) where -import Freckle.App.Prelude +import Prelude import Blammo.Logging (Message (..), (.=)) +import Control.Applicative ((<|>)) +import Control.Exception.Annotated.UnliftIO (SomeException, displayException) +import Control.Monad (guard) +import Control.Monad.IO.Class (MonadIO) import Data.ByteString (ByteString) import Data.ByteString.Char8 qualified as BS8 import Data.ByteString.Lazy qualified as BSL import Data.CaseInsensitive qualified as CI +import Data.Foldable (for_) import Data.List.Extra (firstJust) -import Data.Text.Encoding (decodeUtf8With) -import Data.Text.Encoding.Error (lenientDecode) -import Data.Time (addUTCTime, defaultTimeLocale, parseTimeM) +import Data.Maybe (fromMaybe, mapMaybe) +import Data.Text.Encoding qualified as T +import Data.Text.Encoding.Error qualified as T +import Data.Time (UTCTime, addUTCTime, defaultTimeLocale, parseTimeM) import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds) import Freckle.App.Http.Cache.Gzip import Freckle.App.Http.Header @@ -44,6 +48,7 @@ import Network.HTTP.Types.Header , hVary ) import Network.HTTP.Types.Status (Status, statusCode) +import Text.Read (readMaybe) data HttpCacheSettings m t = HttpCacheSettings { shared :: Bool @@ -108,7 +113,7 @@ httpCached settings doHttp req = now <- settings.getCurrentTime result <- fromEx Nothing $ settings.cache.get key - let tkey = decodeUtf8With lenientDecode $ fromCacheKey key + let tkey = T.decodeUtf8With T.lenientDecode $ fromCacheKey key case result of Nothing -> do @@ -136,7 +141,7 @@ httpCached settings doHttp req = settings.logDebug $ "Retrying with If-None-Match" :# [ "key" .= tkey - , "etag" .= decodeUtf8With lenientDecode etag + , "etag" .= T.decodeUtf8With T.lenientDecode etag ] resp <- getResponse $ addRequestHeader hIfNoneMatch etag req case statusCode (getResponseStatus resp) of @@ -167,7 +172,7 @@ httpCached settings doHttp req = for_ (getCachableResponseTTL settings resp) $ \ttl -> do settings.logDebug $ "Write cache" - :# [ "key" .= decodeUtf8With lenientDecode (fromCacheKey key) + :# [ "key" .= T.decodeUtf8With T.lenientDecode (fromCacheKey key) , "ttl" .= fromCacheTTL ttl ] let cresp = CachedResponse {response = resp, inserted = now, ttl = ttl} @@ -230,7 +235,8 @@ getCachableResponseTTL :: HttpCacheSettings m t -> Response body -> Maybe CacheTTL getCachableResponseTTL settings resp = do guard $ NoStore `notElem` responseHeaders.cacheControl - guard $ not settings.shared || Private `notElem` responseHeaders.cacheControl + guard $ + not settings.shared || Private `notElem` responseHeaders.cacheControl guard $ statusIsCacheable $ HTTP.responseStatus resp pure $ fromMaybe settings.defaultTTL $ responseHeadersToTTL responseHeaders where @@ -278,7 +284,7 @@ readCacheControl = go . CI.foldCase go = \case "private" -> Just Private "no-store" -> Just NoStore - h | Just s <- BS8.stripPrefix "max-age=" h -> MaxAge <$> readMay (BS8.unpack s) + h | Just s <- BS8.stripPrefix "max-age=" h -> MaxAge <$> readMaybe (BS8.unpack s) _ -> Nothing getCacheControl :: HasHeaders a => a -> [CacheControl] @@ -318,7 +324,7 @@ getResponseHeaders resp = { cacheControl = getCacheControl resp , age = fromMaybe 0 $ do h <- lookupHeader hAge resp - readMay $ BS8.unpack h + readMaybe $ BS8.unpack h , expires = do h <- lookupHeader hExpires resp parseTimeM True defaultTimeLocale httpDateFormat $ BS8.unpack h diff --git a/freckle-app/library/Freckle/App/Http/Cache/Gzip.hs b/freckle-http/library/Freckle/App/Http/Cache/Gzip.hs similarity index 85% rename from freckle-app/library/Freckle/App/Http/Cache/Gzip.hs rename to freckle-http/library/Freckle/App/Http/Cache/Gzip.hs index 2c34caa..16f1a7b 100644 --- a/freckle-app/library/Freckle/App/Http/Cache/Gzip.hs +++ b/freckle-http/library/Freckle/App/Http/Cache/Gzip.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE NoFieldSelectors #-} -- | Type and functions for handling gzipped HTTP responses @@ -19,10 +18,10 @@ module Freckle.App.Http.Cache.Gzip , gunzipResponseBody ) where -import Freckle.App.Prelude +import Prelude import Codec.Serialise (Serialise) -import Data.ByteString.Lazy (ByteString) +import Control.Monad.IO.Class import Data.ByteString.Lazy qualified as BSL import Freckle.App.Http (disableRequestDecompress) import Freckle.App.Http.Header @@ -48,16 +47,16 @@ requestPotentiallyGzipped doHttp = gunzipResponseBody :: MonadIO m => Request - -> Response (PotentiallyGzipped ByteString) - -> m (Response ByteString) + -> Response (PotentiallyGzipped BSL.ByteString) + -> m (Response BSL.ByteString) gunzipResponseBody req resp | HTTP.needsGunzip req (getHeaders resp) = liftIO $ do body <- gunzipBody $ HTTP.responseBody resp pure $ body <$ resp | otherwise = pure $ (.unwrap) <$> resp -gunzipBody :: PotentiallyGzipped ByteString -> IO ByteString +gunzipBody :: PotentiallyGzipped BSL.ByteString -> IO BSL.ByteString gunzipBody body = do body1 <- HTTP.constBodyReader $ BSL.toChunks body.unwrap - reader <- HTTP.makeGzipReader body1 - BSL.fromChunks <$> HTTP.brConsume reader + reader' <- HTTP.makeGzipReader body1 + BSL.fromChunks <$> HTTP.brConsume reader' diff --git a/freckle-app/library/Freckle/App/Http/Cache/Memcached.hs b/freckle-http/library/Freckle/App/Http/Cache/Memcached.hs similarity index 92% rename from freckle-app/library/Freckle/App/Http/Cache/Memcached.hs rename to freckle-http/library/Freckle/App/Http/Cache/Memcached.hs index 988d932..139cb60 100644 --- a/freckle-app/library/Freckle/App/Http/Cache/Memcached.hs +++ b/freckle-http/library/Freckle/App/Http/Cache/Memcached.hs @@ -1,6 +1,4 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedRecordDot #-} {-# OPTIONS_GHC -Wno-orphans #-} module Freckle.App.Http.Cache.Memcached @@ -9,23 +7,30 @@ module Freckle.App.Http.Cache.Memcached , memcachedHttpCache ) where -import Freckle.App.Prelude +import Prelude import Blammo.Logging (MonadLogger, logDebugNS, logWarnNS) import Codec.Serialise (Serialise (..), deserialiseOrFail, serialise) +import Control.Exception.Annotated.UnliftIO (try) +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Reader (MonadReader) +import Data.Bifunctor (bimap) import Data.ByteString.Lazy qualified as BSL import Data.CaseInsensitive (CI) import Data.CaseInsensitive qualified as CI +import Data.Time (UTCTime, getCurrentTime) import Database.Memcache.Types (Value) import Freckle.App.Http.Cache import Freckle.App.Memcached import Freckle.App.Memcached.Client qualified as Memcached -import Freckle.App.OpenTelemetry (MonadTracer) +import GHC.Generics (Generic) import Network.HTTP.Client (Request) import Network.HTTP.Client.Internal qualified as HTTP import Network.HTTP.Types.Header (ResponseHeaders) import Network.HTTP.Types.Status (Status (..)) import Network.HTTP.Types.Version (HttpVersion (..)) +import OpenTelemetry.Trace.Monad (MonadTracer (..)) +import UnliftIO (MonadUnliftIO) memcachedHttpCacheSettings :: ( MonadUnliftIO m diff --git a/freckle-app/library/Freckle/App/Http/Cache/State.hs b/freckle-http/library/Freckle/App/Http/Cache/State.hs similarity index 80% rename from freckle-app/library/Freckle/App/Http/Cache/State.hs rename to freckle-http/library/Freckle/App/Http/Cache/State.hs index 13051fc..270413d 100644 --- a/freckle-app/library/Freckle/App/Http/Cache/State.hs +++ b/freckle-http/library/Freckle/App/Http/Cache/State.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE NoFieldSelectors #-} -- | HTTP caching via 'MonadState' @@ -14,19 +13,23 @@ module Freckle.App.Http.Cache.State , stateHttpCache ) where -import Freckle.App.Prelude +import Prelude import Blammo.Logging (Message) import Control.Lens (Lens', at, lens, use, (.=), (?=)) +import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.Logger (ToLogStr (..), fromLogStr) -import Control.Monad.State -import Data.Text.Encoding (decodeUtf8With) -import Data.Text.Encoding.Error (lenientDecode) +import Control.Monad.State (MonadState) +import Data.HashMap.Strict (HashMap) +import Data.Text (Text) +import Data.Text.Encoding qualified as T +import Data.Text.Encoding.Error qualified as T import Data.Text.IO qualified as T +import Data.Time (getCurrentTime) import Freckle.App.Http.Cache import Freckle.App.Memcached.CacheKey import Freckle.App.Memcached.CacheTTL -import System.IO (stderr) +import System.IO qualified as IO newtype Cache = Cache { map :: HashMap CacheKey CachedResponse @@ -55,7 +58,7 @@ stateHttpCacheSettings = , defaultTTL = fiveMinuteTTL , getCurrentTime = liftIO getCurrentTime , logDebug = \_ -> pure () - , logWarn = liftIO . T.hPutStrLn stderr . messageToText + , logWarn = liftIO . T.hPutStrLn IO.stderr . messageToText , codec = stateHttpCacheCodec , cache = stateHttpCache } @@ -77,4 +80,4 @@ stateHttpCache = } messageToText :: Message -> Text -messageToText = decodeUtf8With lenientDecode . fromLogStr . toLogStr +messageToText = T.decodeUtf8With T.lenientDecode . fromLogStr . toLogStr diff --git a/freckle-app/library/Freckle/App/Http/Header.hs b/freckle-http/library/Freckle/App/Http/Header.hs similarity index 96% rename from freckle-app/library/Freckle/App/Http/Header.hs rename to freckle-http/library/Freckle/App/Http/Header.hs index 380392e..055d041 100644 --- a/freckle-app/library/Freckle/App/Http/Header.hs +++ b/freckle-http/library/Freckle/App/Http/Header.hs @@ -7,11 +7,12 @@ module Freckle.App.Http.Header , splitHeader ) where -import Freckle.App.Prelude +import Prelude import Data.ByteString (ByteString) import Data.ByteString.Char8 qualified as BS8 import Data.Char (isSpace) +import Data.Maybe (listToMaybe) import Network.HTTP.Client (Request, Response, requestHeaders, responseHeaders) import Network.HTTP.Simple (getRequestHeader, getResponseHeader) import Network.HTTP.Types.Header (Header, HeaderName) diff --git a/freckle-app/library/Freckle/App/Http/Paginate.hs b/freckle-http/library/Freckle/App/Http/Paginate.hs similarity index 94% rename from freckle-app/library/Freckle/App/Http/Paginate.hs rename to freckle-http/library/Freckle/App/Http/Paginate.hs index c36b479..2573236 100644 --- a/freckle-app/library/Freckle/App/Http/Paginate.hs +++ b/freckle-http/library/Freckle/App/Http/Paginate.hs @@ -56,10 +56,14 @@ module Freckle.App.Http.Paginate , sourcePaginatedBy ) where -import Freckle.App.Prelude +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 hiding (linkHeader) import Network.HTTP.Simple import Network.URI (URI) diff --git a/freckle-app/library/Freckle/App/Http/Retry.hs b/freckle-http/library/Freckle/App/Http/Retry.hs similarity index 90% rename from freckle-app/library/Freckle/App/Http/Retry.hs rename to freckle-http/library/Freckle/App/Http/Retry.hs index a4b9739..a75a2f2 100644 --- a/freckle-app/library/Freckle/App/Http/Retry.hs +++ b/freckle-http/library/Freckle/App/Http/Retry.hs @@ -4,10 +4,16 @@ module Freckle.App.Http.Retry , rateLimited' ) where -import Freckle.App.Prelude +import Prelude +import Control.Exception.Annotated.UnliftIO (Exception (..), throwWithCallStack) +import Control.Monad (guard, unless) +import Control.Monad.IO.Class (MonadIO) import Control.Retry import Data.ByteString.Char8 qualified as BS8 +import Data.Functor (void) +import Data.Maybe (listToMaybe) +import GHC.Stack (HasCallStack) import Network.HTTP.Client (Request (..)) import Network.HTTP.Simple import Network.HTTP.Types.Status (status429) @@ -81,7 +87,7 @@ checkRetriesExhausted :: (MonadIO m, HasCallStack) => Int -> Response body -> m (Response body) checkRetriesExhausted retryLimit resp | getResponseStatus resp == status429 = - throwM $ + throwWithCallStack $ RetriesExhausted {reLimit = retryLimit, reResponse = void resp} | otherwise = pure resp diff --git a/freckle-app/tests/Freckle/App/HttpSpec.hs b/freckle-http/library/Freckle/App/HttpSpec.hs similarity index 98% rename from freckle-app/tests/Freckle/App/HttpSpec.hs rename to freckle-http/library/Freckle/App/HttpSpec.hs index f72e4de..6bba423 100644 --- a/freckle-app/tests/Freckle/App/HttpSpec.hs +++ b/freckle-http/library/Freckle/App/HttpSpec.hs @@ -2,7 +2,7 @@ module Freckle.App.HttpSpec ( spec ) where -import Freckle.App.Prelude +import Prelude import Control.Lens (to, (^?), _Left, _Right) import Data.Aeson diff --git a/freckle-app/library/Freckle/App/Test/Http.hs b/freckle-http/library/Freckle/App/Test/Http.hs similarity index 94% rename from freckle-app/library/Freckle/App/Test/Http.hs rename to freckle-http/library/Freckle/App/Test/Http.hs index fdd7a97..2105377 100644 --- a/freckle-app/library/Freckle/App/Test/Http.hs +++ b/freckle-http/library/Freckle/App/Test/Http.hs @@ -1,8 +1,4 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedRecordDot #-} -{-# LANGUAGE TupleSections #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE NoFieldSelectors #-} @@ -43,21 +39,30 @@ module Freckle.App.Test.Http , runHttpStubsT ) where -import Freckle.App.Prelude +import Prelude -import Control.Lens (Lens', lens, view, (&), (.~), (<>~)) -import Control.Monad (filterM) -import Control.Monad.Reader (runReaderT) +import Control.Applicative (asum) +import Control.Lens (Lens', lens, view, (.~), (<>~)) +import Control.Monad.Reader (MonadReader, ReaderT, runReaderT) import Data.Aeson (ToJSON, encode) +import Data.Bifunctor (bimap) +import Control.Monad(filterM) import Data.ByteString.Lazy qualified as BSL +import Data.Either (partitionEithers) +import Data.Function ((&)) import Data.List (stripPrefix) -import Data.String (IsString (..)) +import Data.Maybe (mapMaybe) +import Data.String (IsString) +import Data.String qualified +import Data.Traversable (for) import Freckle.App.Http (MonadHttp (..)) import Freckle.App.Test.Http.MatchRequest +import GHC.Stack (HasCallStack) import Network.HTTP.Client (Request, Response) import Network.HTTP.Client.Internal qualified as HTTP import Network.HTTP.Types.Header (ResponseHeaders, hAccept, hContentType) import Network.HTTP.Types.Status (Status, status200) +import Safe (headMay) import System.Directory (doesFileExist) import System.FilePath (addTrailingPathSeparator) import System.FilePath.Glob (globDir1) @@ -96,9 +101,9 @@ httpStubbed stubs req = errorMessage = "No stubs were found that matched:\n" - <> show req - <> "\n" - <> concatMap (uncurry unmatchedMessage) unmatched + <> show req + <> "\n" + <> concatMap (uncurry unmatchedMessage) unmatched unmatchedMessage stub err = "\n== " <> stub.label <> " ==\n" <> err diff --git a/freckle-app/library/Freckle/App/Test/Http/MatchRequest.hs b/freckle-http/library/Freckle/App/Test/Http/MatchRequest.hs similarity index 95% rename from freckle-app/library/Freckle/App/Test/Http/MatchRequest.hs rename to freckle-http/library/Freckle/App/Test/Http/MatchRequest.hs index 87422a0..33f8a88 100644 --- a/freckle-app/library/Freckle/App/Test/Http/MatchRequest.hs +++ b/freckle-http/library/Freckle/App/Test/Http/MatchRequest.hs @@ -21,14 +21,19 @@ module Freckle.App.Test.Http.MatchRequest , showMatchRequestWithMismatches ) where -import Freckle.App.Prelude +import Prelude +import Control.Applicative ((<|>)) +import Control.Monad (guard) import Data.ByteString (ByteString) import Data.ByteString.Char8 qualified as BS8 import Data.ByteString.Lazy qualified as BSL +import Data.Foldable (toList) import Data.List (isPrefixOf) -import Data.List.NonEmpty (NonEmpty (..)) +import Data.List.NonEmpty (NonEmpty ((:|))) import Data.List.NonEmpty qualified as NE +import Data.Maybe (catMaybes) +import Data.Semigroup.Foldable (fold1) import Network.HTTP.Client (Request, RequestBody (..), parseRequest_) import Network.HTTP.Client.Internal qualified as HTTP import Network.HTTP.Types.Header (Header, RequestHeaders) diff --git a/freckle-http/package.yaml b/freckle-http/package.yaml new file mode 100644 index 0000000..af7a08e --- /dev/null +++ b/freckle-http/package.yaml @@ -0,0 +1,112 @@ +name: freckle-http +version: 0.0.0.0 +maintainer: Freckle Education +category: Utils +github: freckle/freckle-app +synopsis: ... +description: Please see README.md + +extra-doc-files: + - README.md + - CHANGELOG.md + +extra-source-files: + - package.yaml + +language: GHC2021 + +ghc-options: + - -fignore-optim-changes + - -fwrite-ide-info + - -Weverything + - -Wno-all-missed-specialisations + - -Wno-missing-exported-signatures # re-enables missing-signatures + - -Wno-missing-import-lists + - -Wno-missing-kind-signatures + - -Wno-missing-local-signatures + - -Wno-missing-safe-haskell-mode + - -Wno-monomorphism-restriction + - -Wno-prepositive-qualified-module + - -Wno-safe + - -Wno-unsafe + +when: + - condition: "impl(ghc >= 9.8)" + ghc-options: + - -Wno-missing-role-annotations + - -Wno-missing-poly-kind-signatures + +dependencies: + - base < 5 + +default-extensions: + - DataKinds + - DeriveAnyClass + - DerivingVia + - DerivingStrategies + - DuplicateRecordFields + - GADTs + - LambdaCase + - NoImplicitPrelude + - NoMonomorphismRestriction + - OverloadedRecordDot + - OverloadedStrings + - RecordWildCards + - TypeFamilies + +library: + source-dirs: library + dependencies: + - Glob + - Blammo >= 2.0.0.0 + - aeson + - annotated-exception + - bytestring + - case-insensitive + - conduit + - directory + - errors + - extra + - filepath + - freckle-memcached + - hs-opentelemetry-api + - hspec >= 2.8.1 + - http-client + - http-conduit >= 2.3.5 # addToRequestQueryString + - http-link-header + - http-types + - lens + - lens-aeson + - memcache + - monad-logger + - monad-validate + - mtl + - network-uri + - retry >= 0.8.1.0 # retryingDynamic + - safe + - serialise + - semigroupoids + - text + - time + - transformers + - unliftio + - unordered-containers + +tests: + spec: + main: Main.hs + source-dirs: tests + ghc-options: -threaded -rtsopts "-with-rtsopts=-N" + dependencies: + - aeson + - bytestring + - freckle-http + - hspec + - hspec-expectations-json + - hspec-expectations-lifted + - http-types + - lens + - mtl + - time + - unordered-containers + - zlib diff --git a/freckle-app/tests/Freckle/App/Http/CacheSpec.hs b/freckle-http/tests/Freckle/App/Http/CacheSpec.hs similarity index 97% rename from freckle-app/tests/Freckle/App/Http/CacheSpec.hs rename to freckle-http/tests/Freckle/App/Http/CacheSpec.hs index c30a869..9815af8 100644 --- a/freckle-app/tests/Freckle/App/Http/CacheSpec.hs +++ b/freckle-http/tests/Freckle/App/Http/CacheSpec.hs @@ -5,16 +5,19 @@ module Freckle.App.Http.CacheSpec ( spec ) where -import Freckle.App.Prelude +import Prelude import Codec.Compression.GZip qualified as GZip -import Control.Lens ((&), (.~), (<>~)) +import Control.Lens ((.~), (<>~)) +import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.State (StateT, execStateT) import Data.Aeson (FromJSON, eitherDecode) -import Data.ByteString.Lazy (ByteString) import Data.ByteString.Lazy qualified as BSL +import Data.Foldable (for_) +import Data.Function ((&)) +import Data.Functor (void) import Data.HashMap.Strict qualified as HashMap -import Data.Time (addUTCTime) +import Data.Time (addUTCTime, getCurrentTime) import Freckle.App.Http import Freckle.App.Http.Cache import Freckle.App.Http.Cache.State @@ -180,7 +183,7 @@ spec = do -- We don't want to expose the constructor, but we do want to verify the -- cache contains the gzipped form. map (show . getResponseBody . (.response) . snd) (HashMap.toList cache.map) - `shouldMatchList` [ "PotentiallyGzipped {unwrap = \"Hi (not zipped)\\n\"}" + `shouldMatchList` [ "PotentiallyGzipped {unwrap = \"Hi (not zipped)\\n\"}" :: String , "PotentiallyGzipped {unwrap = " <> show gzipped <> "}" ] @@ -357,7 +360,7 @@ requestBodyCached :: CacheSettings -> [HttpStub] -> Request - -> StateT Cache IO ByteString + -> StateT Cache IO BSL.ByteString requestBodyCached ss stubs req = getResponseBody <$> httpCached ss (pure . httpStubbed stubs) req @@ -385,7 +388,7 @@ settingsFuture = stubAnything :: [HttpStub] stubAnything = [httpStub "Anything" MatchAnything] -expectDecode :: (HasCallStack, MonadIO m, FromJSON a) => ByteString -> m a +expectDecode :: (HasCallStack, MonadIO m, FromJSON a) => BSL.ByteString -> m a expectDecode bs = case eitherDecode bs of Left err -> do expectationFailure $ diff --git a/freckle-http/tests/Main.hs b/freckle-http/tests/Main.hs new file mode 100644 index 0000000..1fcc19c --- /dev/null +++ b/freckle-http/tests/Main.hs @@ -0,0 +1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --module-name=Main -Wno-missing-export-lists #-} diff --git a/freckle-app/tests/files/constructed-responses.gzip b/freckle-http/tests/files/constructed-responses.gzip similarity index 100% rename from freckle-app/tests/files/constructed-responses.gzip rename to freckle-http/tests/files/constructed-responses.gzip diff --git a/freckle-app/tests/files/https/www.stackage.org/lts-17.10 b/freckle-http/tests/files/https/www.stackage.org/lts-17.10 similarity index 100% rename from freckle-app/tests/files/https/www.stackage.org/lts-17.10 rename to freckle-http/tests/files/https/www.stackage.org/lts-17.10 diff --git a/freckle-kafka/CHANGELOG.md b/freckle-kafka/CHANGELOG.md index 0a4ea4c..8acba82 100644 --- a/freckle-kafka/CHANGELOG.md +++ b/freckle-kafka/CHANGELOG.md @@ -1,4 +1,8 @@ -## [_Unreleased_](https://github.com/freckle/freckle-app/compare/freckle-kafka-v0.0.0.0...main) +## [_Unreleased_](https://github.com/freckle/freckle-app/compare/freckle-kafka-v0.0.0.1...main) + +## [v0.0.0.1](https://github.com/freckle/freckle-app/compare/freckle-kafka-v0.0.0.0...freckle-kafka-v0.0.0.1) + +Drop `relude` dependency ## [v0.0.0.0](https://github.com/freckle/freckle-app/tree/freckle-kafka-v0.0.0.0/freckle-kafka) diff --git a/freckle-kafka/freckle-kafka.cabal b/freckle-kafka/freckle-kafka.cabal index 7b0358e..a399712 100644 --- a/freckle-kafka/freckle-kafka.cabal +++ b/freckle-kafka/freckle-kafka.cabal @@ -5,7 +5,7 @@ cabal-version: 1.18 -- see: https://github.com/sol/hpack name: freckle-kafka -version: 0.0.0.0 +version: 0.0.0.1 synopsis: Some extensions to the hw-kafka-client library description: Please see README.md category: Database @@ -51,12 +51,13 @@ library , aeson , annotated-exception , base <5 + , bytestring , containers , freckle-env , hs-opentelemetry-sdk , hw-kafka-client , lens - , relude + , mtl , resource-pool >=0.4.0.0 , text , time diff --git a/freckle-kafka/library/Freckle/App/Kafka/Consumer.hs b/freckle-kafka/library/Freckle/App/Kafka/Consumer.hs index 7ab8cca..184599b 100644 --- a/freckle-kafka/library/Freckle/App/Kafka/Consumer.hs +++ b/freckle-kafka/library/Freckle/App/Kafka/Consumer.hs @@ -8,19 +8,34 @@ module Freckle.App.Kafka.Consumer , runConsumer ) where -import Relude +import Prelude import Blammo.Logging -import Control.Exception.Annotated.UnliftIO (AnnotatedException) +import Control.Arrow ((&&&)) +import Control.Exception.Annotated.UnliftIO + ( AnnotatedException + , Exception + , displayException + ) import Control.Exception.Annotated.UnliftIO qualified as Annotated import Control.Lens (Lens', view) +import Control.Monad (forever, (<=<)) +import Control.Monad.IO.Class (MonadIO) +import Control.Monad.Reader (MonadReader) import Data.Aeson +import Data.ByteString (ByteString) +import Data.Foldable (for_) +import Data.List.NonEmpty (NonEmpty) import Data.List.NonEmpty qualified as NE +import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map +import Data.Text (Text) import Data.Text qualified as T +import Data.Text.Encoding qualified as T import Freckle.App.Env (Timeout (..)) import Freckle.App.Env qualified as Env import Freckle.App.Kafka.Producer (envKafkaBrokerAddresses) +import GHC.Stack (HasCallStack, prettyCallStack) import Kafka.Consumer hiding ( Timeout , closeConsumer @@ -105,8 +120,8 @@ envKafkaConsumerConfig = do (fmap Map.fromList . Env.keyValues) "KAFKA_EXTRA_SUBSCRIPTION_PROPS" (Env.def mempty) - pure - $ KafkaConsumerConfig + pure $ + KafkaConsumerConfig brokerAddresses consumerGroupId kafkaTopic @@ -158,8 +173,8 @@ instance Exception KafkaMessageDecodeError where displayException e = mconcat [ "Unable to decode JSON" - , "\n input: " <> decodeUtf8 (input e) - , "\n errors: " <> (errors e) + , "\n input: " <> T.unpack (T.decodeUtf8 (input e)) + , "\n errors: " <> errors e ] runConsumer @@ -187,22 +202,22 @@ runConsumer pollTimeout onMessage = for_ (crValue =<< mRecord) $ \bs -> do a <- - inSpan "kafka.consumer.message.decode" defaultSpanArguments - $ either (Annotated.throw . KafkaMessageDecodeError bs) pure - $ eitherDecodeStrict bs + inSpan "kafka.consumer.message.decode" defaultSpanArguments $ + either (Annotated.throw . KafkaMessageDecodeError bs) pure $ + eitherDecodeStrict bs inSpan "kafka.consumer.message.handle" defaultSpanArguments $ onMessage a where kTimeout = Kafka.Timeout $ timeoutMs pollTimeout handlers = - [ Annotated.Handler - $ logErrorNS "kafka" - . annotatedExceptionMessageFrom @KafkaError - (const "Error polling for message from Kafka") - , Annotated.Handler - $ logErrorNS "kafka" - . annotatedExceptionMessageFrom @KafkaMessageDecodeError - (const "Could not decode message value") + [ Annotated.Handler $ + logErrorNS "kafka" + . annotatedExceptionMessageFrom @KafkaError + (const "Error polling for message from Kafka") + , Annotated.Handler $ + logErrorNS "kafka" + . annotatedExceptionMessageFrom @KafkaMessageDecodeError + (const "Could not decode message value") ] -- | Like 'annotatedExceptionMessage', but use the supplied function to @@ -231,4 +246,4 @@ fromKafkaError = err -> Annotated.throw err ) $ pure - . Just + . Just diff --git a/freckle-kafka/library/Freckle/App/Kafka/Producer.hs b/freckle-kafka/library/Freckle/App/Kafka/Producer.hs index 8712456..6dd2b00 100644 --- a/freckle-kafka/library/Freckle/App/Kafka/Producer.hs +++ b/freckle-kafka/library/Freckle/App/Kafka/Producer.hs @@ -11,7 +11,7 @@ module Freckle.App.Kafka.Producer , produceKeyedOn ) where -import Relude +import Prelude import Blammo.Logging ( Message ((:#)) @@ -22,15 +22,19 @@ import Blammo.Logging ) import Control.Exception.Annotated.UnliftIO qualified as Annotated import Control.Lens (Lens', lens, view) +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Reader (MonadReader) import Data.Aeson (ToJSON, encode) +import Data.ByteString.Lazy qualified as BSL +import Data.Foldable (for_, toList) import Data.HashMap.Strict qualified as HashMap +import Data.List.NonEmpty (NonEmpty) import Data.List.NonEmpty qualified as NE import Data.Pool (Pool) import Data.Pool qualified as Pool import Data.Text qualified as T import Data.Time (NominalDiffTime) import Freckle.App.Env qualified as Env -import GHC.IO.Exception (userError) import Kafka.Producer import OpenTelemetry.Trace (SpanKind (..), defaultSpanArguments) import OpenTelemetry.Trace qualified as Trace @@ -104,13 +108,13 @@ createKafkaProducerPool -> KafkaProducerPoolConfig -> IO (Pool KafkaProducer) createKafkaProducerPool addresses config = - Pool.newPool - $ Pool.setNumStripes (Just $ kafkaProducerPoolConfigStripes config) - $ Pool.defaultPoolConfig - mkProducer - closeProducer - (realToFrac $ kafkaProducerPoolConfigIdleTimeout config) - (kafkaProducerPoolConfigSize config) + Pool.newPool $ + Pool.setNumStripes (Just $ kafkaProducerPoolConfigStripes config) $ + Pool.defaultPoolConfig + mkProducer + closeProducer + (realToFrac $ kafkaProducerPoolConfigIdleTimeout config) + (kafkaProducerPoolConfigSize config) where mkProducer = either @@ -142,15 +146,17 @@ produceKeyedOn prTopic values keyF = traced $ do for_ @NonEmpty values $ \value -> do mError <- liftIO $ produceMessage producer $ mkProducerRecord value for_ @Maybe mError $ \e -> - run $ logErrorNS "kafka" $ "Failed to send event" - :# ["error" .= (show e :: Text)] + run $ + logErrorNS "kafka" $ + "Failed to send event" + :# ["error" .= T.pack (show e)] where mkProducerRecord value = ProducerRecord { prTopic , prPartition = UnassignedPartition - , prKey = Just $ toStrict $ encode $ keyF value - , prValue = Just $ toStrict $ encode value + , prKey = Just $ BSL.toStrict $ encode $ keyF value + , prValue = Just $ BSL.toStrict $ encode value , prHeaders = mempty } diff --git a/freckle-kafka/package.yaml b/freckle-kafka/package.yaml index 126e45d..2708f64 100644 --- a/freckle-kafka/package.yaml +++ b/freckle-kafka/package.yaml @@ -1,5 +1,5 @@ name: freckle-kafka -version: 0.0.0.0 +version: 0.0.0.1 maintainer: Freckle Education category: Database github: freckle/freckle-app @@ -57,12 +57,13 @@ library: - Blammo >= 2.0.0.0 - aeson - annotated-exception + - bytestring - containers - freckle-env - hs-opentelemetry-sdk - hw-kafka-client - lens - - relude + - mtl - resource-pool >= 0.4.0.0 - text - time diff --git a/freckle-memcached/CHANGELOG.md b/freckle-memcached/CHANGELOG.md new file mode 100644 index 0000000..88fef90 --- /dev/null +++ b/freckle-memcached/CHANGELOG.md @@ -0,0 +1,25 @@ +## [_Unreleased_](https://github.com/freckle/freckle-app/compare/freckle-memcached-v0.0.0.1...main) + +## [v0.0.0.1](https://github.com/freckle/freckle-app/compare/freckle-memcached-v0.0.0.0...freckle-memcached-v0.0.0.1) + +Drop `relude` dependency + +## [v0.0.0.0](https://github.com/freckle/freckle-app/tree/freckle-memcached-v0.0.0.0/freckle-memcached) + +First release, sprouted from `freckle-app-1.19.0.0`. + +A typeclass instance related to Yesod has been removed. To recover the original behavior, +you can add this instance: + +```haskell +import Yesod.Core.Types (HandlerData, RunHandlerEnv, handlerEnv, rheSite) + +instance HasMemcachedClient site => HasMemcachedClient (HandlerData child site) where + memcachedClientL = envL . siteL . memcachedClientL + +envL :: Lens' (HandlerData child site) (RunHandlerEnv child site) +envL = lens handlerEnv $ \x y -> x {handlerEnv = y} + +siteL :: Lens' (RunHandlerEnv child site) site +siteL = lens rheSite $ \x y -> x {rheSite = y} +``` diff --git a/freckle-memcached/LICENSE b/freckle-memcached/LICENSE new file mode 100644 index 0000000..34c4f31 --- /dev/null +++ b/freckle-memcached/LICENSE @@ -0,0 +1,21 @@ +The MIT License (MIT) + +Copyright (c) 2022-2024 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/freckle-memcached/README.md b/freckle-memcached/README.md new file mode 100644 index 0000000..2af42b0 --- /dev/null +++ b/freckle-memcached/README.md @@ -0,0 +1 @@ +# freckle-memcached diff --git a/freckle-memcached/freckle-memcached.cabal b/freckle-memcached/freckle-memcached.cabal new file mode 100644 index 0000000..430c1ca --- /dev/null +++ b/freckle-memcached/freckle-memcached.cabal @@ -0,0 +1,120 @@ +cabal-version: 1.18 + +-- This file has been generated from package.yaml by hpack version 0.36.0. +-- +-- see: https://github.com/sol/hpack + +name: freckle-memcached +version: 0.0.0.1 +synopsis: .. +description: Please see README.md +category: Database +homepage: https://github.com/freckle/freckle-app#readme +bug-reports: https://github.com/freckle/freckle-app/issues +maintainer: Freckle Education +license: MIT +license-file: LICENSE +build-type: Simple +extra-source-files: + package.yaml +extra-doc-files: + README.md + CHANGELOG.md + +source-repository head + type: git + location: https://github.com/freckle/freckle-app + +library + exposed-modules: + Freckle.App.Memcached + Freckle.App.Memcached.CacheKey + Freckle.App.Memcached.CacheTTL + Freckle.App.Memcached.Client + Freckle.App.Memcached.MD5 + Freckle.App.Memcached.Servers + other-modules: + Paths_freckle_memcached + hs-source-dirs: + library + default-extensions: + DataKinds + DeriveAnyClass + DerivingVia + DerivingStrategies + GADTs + LambdaCase + NoImplicitPrelude + NoMonomorphismRestriction + OverloadedStrings + RecordWildCards + TypeFamilies + ghc-options: -fignore-optim-changes -fwrite-ide-info -Weverything -Wno-all-missed-specialisations -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missing-kind-signatures -Wno-missing-local-signatures -Wno-missing-safe-haskell-mode -Wno-monomorphism-restriction -Wno-prepositive-qualified-module -Wno-safe -Wno-unsafe + build-depends: + Blammo >=2.0.0.0 + , aeson + , annotated-exception + , base <5 + , bytestring + , errors + , freckle-otel + , hashable + , hs-opentelemetry-sdk + , lens + , memcache + , mtl + , network-uri + , pureMD5 + , serialise + , text + , unliftio + , unordered-containers + default-language: GHC2021 + if impl(ghc >= 9.8) + ghc-options: -Wno-missing-role-annotations -Wno-missing-poly-kind-signatures + +test-suite spec + type: exitcode-stdio-1.0 + main-is: Main.hs + other-modules: + AppExample + Freckle.App.Memcached.ServersSpec + Freckle.App.MemcachedSpec + Paths_freckle_memcached + hs-source-dirs: + tests + default-extensions: + DataKinds + DeriveAnyClass + DerivingVia + DerivingStrategies + GADTs + LambdaCase + NoImplicitPrelude + NoMonomorphismRestriction + OverloadedStrings + RecordWildCards + TypeFamilies + ghc-options: -fignore-optim-changes -fwrite-ide-info -Weverything -Wno-all-missed-specialisations -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missing-kind-signatures -Wno-missing-local-signatures -Wno-missing-safe-haskell-mode -Wno-monomorphism-restriction -Wno-prepositive-qualified-module -Wno-safe -Wno-unsafe -threaded -rtsopts "-with-rtsopts=-N" + build-depends: + Blammo + , aeson + , base <5 + , errors + , exceptions + , freckle-env + , freckle-memcached + , hs-opentelemetry-sdk + , hspec + , hspec-core + , hspec-expectations-lifted + , lens + , lens-aeson + , memcache + , mtl + , safe + , text + , unliftio + default-language: GHC2021 + if impl(ghc >= 9.8) + ghc-options: -Wno-missing-role-annotations -Wno-missing-poly-kind-signatures diff --git a/freckle-app/library/Freckle/App/Memcached.hs b/freckle-memcached/library/Freckle/App/Memcached.hs similarity index 72% rename from freckle-app/library/Freckle/App/Memcached.hs rename to freckle-memcached/library/Freckle/App/Memcached.hs index 98c9542..df5ee8f 100644 --- a/freckle-app/library/Freckle/App/Memcached.hs +++ b/freckle-memcached/library/Freckle/App/Memcached.hs @@ -22,22 +22,32 @@ module Freckle.App.Memcached , module Freckle.App.Memcached.MD5 ) where -import Freckle.App.Prelude +import Prelude import Blammo.Logging import Codec.Serialise (Serialise, deserialiseOrFail, serialise) +import Control.Exception.Annotated.UnliftIO + ( AnnotatedException + , throwWithCallStack + ) +import Control.Exception.Annotated.UnliftIO qualified as AnnotatedException +import Control.Monad.Reader (MonadReader) import Data.Aeson +import Data.Bifunctor (first) import Data.ByteString (ByteString) import Data.ByteString.Lazy qualified as BSL -import Data.Text.Encoding (decodeUtf8With) -import Data.Text.Encoding.Error (lenientDecode) -import Freckle.App.Exception (annotatedExceptionMessage) +import Data.Text (Text) +import Data.Text.Encoding qualified as T +import Data.Text.Encoding.Error qualified as T import Freckle.App.Memcached.CacheKey import Freckle.App.Memcached.CacheTTL import Freckle.App.Memcached.Client (HasMemcachedClient (..)) import Freckle.App.Memcached.Client qualified as Memcached import Freckle.App.Memcached.MD5 import Freckle.App.OpenTelemetry +import GHC.Stack (HasCallStack, prettyCallStack) +import UnliftIO (MonadUnliftIO) +import UnliftIO.Exception class Cachable a where toCachable :: a -> ByteString @@ -52,8 +62,8 @@ instance Cachable BSL.ByteString where fromCachable = Right . BSL.fromStrict instance Cachable Text where - toCachable = encodeUtf8 - fromCachable = Right . decodeUtf8With lenientDecode + toCachable = T.encodeUtf8 + fromCachable = Right . T.decodeUtf8With T.lenientDecode data CachingError = CacheGetError SomeException @@ -75,6 +85,22 @@ warnOnCachingError val = . logWarnNS "caching" . annotatedExceptionMessage @CachingError +annotatedExceptionMessage :: Exception ex => AnnotatedException ex -> Message +annotatedExceptionMessage = annotatedExceptionMessageFrom $ const "Exception" + +annotatedExceptionMessageFrom + :: Exception ex => (ex -> Message) -> AnnotatedException ex -> Message +annotatedExceptionMessageFrom f ann = case f ex of + msg :# series -> msg :# series <> ["error" .= errorObject] + where + ex = AnnotatedException.exception ann + errorObject = + object + [ "message" .= displayException ex + , "stack" + .= (prettyCallStack <$> AnnotatedException.annotatedExceptionCallStack ann) + ] + -- | Memoize an action using Memcached and 'Cachable' caching :: ( MonadUnliftIO m @@ -114,9 +140,10 @@ cachingAs from to key ttl f = do a <- f a <$ warnOnCachingError () (cacheSet a) - cacheGet = flip catch (throwM . CacheGetError) $ Memcached.get key - cacheSet a = flip catch (throwM . CacheSetError) $ Memcached.set key (to a) ttl - cacheDeserialize = either (throwM . CacheDeserializeError) pure . from + cacheGet = flip catch (throwWithCallStack . CacheGetError) $ Memcached.get key + cacheSet a = + flip catch (throwWithCallStack . CacheSetError) $ Memcached.set key (to a) ttl + cacheDeserialize = either (throwWithCallStack . CacheDeserializeError) pure . from -- | Like 'caching', but de/serializing the value as JSON cachingAsJSON diff --git a/freckle-app/library/Freckle/App/Memcached/CacheKey.hs b/freckle-memcached/library/Freckle/App/Memcached/CacheKey.hs similarity index 74% rename from freckle-app/library/Freckle/App/Memcached/CacheKey.hs rename to freckle-memcached/library/Freckle/App/Memcached/CacheKey.hs index 47de8a3..d2805cf 100644 --- a/freckle-app/library/Freckle/App/Memcached/CacheKey.hs +++ b/freckle-memcached/library/Freckle/App/Memcached/CacheKey.hs @@ -5,11 +5,17 @@ module Freckle.App.Memcached.CacheKey , fromCacheKey ) where -import Freckle.App.Prelude +import Prelude +import Control.Exception.Annotated.UnliftIO (throwWithCallStack) +import Control.Monad.IO.Class (MonadIO) import Data.Char (isControl, isSpace) +import Data.Hashable (Hashable) +import Data.Text (Text) import Data.Text qualified as T +import Data.Text.Encoding qualified as T import Database.Memcache.Types (Key) +import GHC.Stack (HasCallStack) import OpenTelemetry.Trace (ToAttribute (..)) newtype CacheKey = CacheKey Text @@ -39,11 +45,11 @@ cacheKey t | otherwise = Right $ CacheKey t where invalid msg = - Left $ "Not a valid memcached key:\n " <> unpack t <> "\n\n" <> msg + Left $ "Not a valid memcached key:\n " <> T.unpack t <> "\n\n" <> msg -- | Build a 'CacheKey' and throw if invalid cacheKeyThrow :: (MonadIO m, HasCallStack) => Text -> m CacheKey -cacheKeyThrow = either throwString pure . cacheKey +cacheKeyThrow = either (throwWithCallStack . userError) pure . cacheKey fromCacheKey :: CacheKey -> Key -fromCacheKey = encodeUtf8 . unCacheKey +fromCacheKey = T.encodeUtf8 . unCacheKey diff --git a/freckle-app/library/Freckle/App/Memcached/CacheTTL.hs b/freckle-memcached/library/Freckle/App/Memcached/CacheTTL.hs similarity index 97% rename from freckle-app/library/Freckle/App/Memcached/CacheTTL.hs rename to freckle-memcached/library/Freckle/App/Memcached/CacheTTL.hs index 3c8d783..d817e1e 100644 --- a/freckle-app/library/Freckle/App/Memcached/CacheTTL.hs +++ b/freckle-memcached/library/Freckle/App/Memcached/CacheTTL.hs @@ -5,7 +5,7 @@ module Freckle.App.Memcached.CacheTTL , fiveMinuteTTL ) where -import Freckle.App.Prelude +import Prelude import Codec.Serialise (Serialise (..)) import Data.Word (Word32) diff --git a/freckle-app/library/Freckle/App/Memcached/Client.hs b/freckle-memcached/library/Freckle/App/Memcached/Client.hs similarity index 82% rename from freckle-app/library/Freckle/App/Memcached/Client.hs rename to freckle-memcached/library/Freckle/App/Memcached/Client.hs index d2f1a23..f5a2e2b 100644 --- a/freckle-app/library/Freckle/App/Memcached/Client.hs +++ b/freckle-memcached/library/Freckle/App/Memcached/Client.hs @@ -9,20 +9,24 @@ module Freckle.App.Memcached.Client , delete ) where -import Freckle.App.Prelude +import Prelude import Control.Lens (Lens', view, _1) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Monad.Reader (MonadReader) +import Data.Functor (void) import Data.HashMap.Strict qualified as HashMap import Database.Memcache.Client qualified as Memcache import Database.Memcache.Types (Value, Version) import Freckle.App.Memcached.CacheKey import Freckle.App.Memcached.CacheTTL import Freckle.App.Memcached.Servers -import Freckle.App.OpenTelemetry +import Freckle.App.OpenTelemetry (byteStringToAttribute) +import OpenTelemetry.Trace (SpanKind (..), defaultSpanArguments) import OpenTelemetry.Trace qualified as Trace +import OpenTelemetry.Trace.Monad +import UnliftIO (MonadUnliftIO) import UnliftIO.Exception (finally) -import Yesod.Core.Lens -import Yesod.Core.Types (HandlerData) data MemcachedClient = MemcachedClient Memcache.Client @@ -34,9 +38,6 @@ class HasMemcachedClient env where instance HasMemcachedClient MemcachedClient where memcachedClientL = id -instance HasMemcachedClient site => HasMemcachedClient (HandlerData child site) where - memcachedClientL = envL . siteL . memcachedClientL - newMemcachedClient :: MonadIO m => MemcachedServers -> m MemcachedClient newMemcachedClient servers = case toServerSpecs servers of [] -> pure memcachedClientDisabled @@ -56,14 +57,15 @@ get => CacheKey -> m (Maybe Value) get k = traced $ with $ \case - MemcachedClient mc -> liftIO $ view _1 <$$> Memcache.get mc (fromCacheKey k) + MemcachedClient mc -> liftIO $ fmap (view _1) <$> Memcache.get mc (fromCacheKey k) MemcachedClientDisabled -> pure Nothing where traced = inSpan "cache.get" - clientSpanArguments - { Trace.attributes = + defaultSpanArguments + { Trace.kind = Client + , Trace.attributes = HashMap.fromList [ ("service.name", "memcached") , ("key", Trace.toAttribute k) @@ -91,8 +93,9 @@ set k v expiration = traced $ with $ \case traced = inSpan "cache.set" - clientSpanArguments - { Trace.attributes = + defaultSpanArguments + { Trace.kind = Client + , Trace.attributes = HashMap.fromList [ ("service.name", "memcached") , ("key", Trace.toAttribute k) @@ -113,8 +116,9 @@ delete k = traced $ with $ \case traced = inSpan "cache.delete" - clientSpanArguments - { Trace.attributes = HashMap.fromList [("key", Trace.toAttribute k)] + defaultSpanArguments + { Trace.kind = Client + , Trace.attributes = HashMap.fromList [("key", Trace.toAttribute k)] } quitClient :: MonadIO m => MemcachedClient -> m () diff --git a/freckle-app/library/Freckle/App/Memcached/MD5.hs b/freckle-memcached/library/Freckle/App/Memcached/MD5.hs similarity index 67% rename from freckle-app/library/Freckle/App/Memcached/MD5.hs rename to freckle-memcached/library/Freckle/App/Memcached/MD5.hs index a503aed..262ce40 100644 --- a/freckle-app/library/Freckle/App/Memcached/MD5.hs +++ b/freckle-memcached/library/Freckle/App/Memcached/MD5.hs @@ -4,10 +4,13 @@ module Freckle.App.Memcached.MD5 , md5Text ) where -import Freckle.App.Prelude +import Prelude import Data.ByteString.Lazy qualified as BSL import Data.Digest.Pure.MD5 qualified as Digest +import Data.Text (Text) +import Data.Text qualified as T +import Data.Text.Encoding qualified as T import Freckle.App.Memcached.CacheKey md5CacheKey :: Show a => a -> CacheKey @@ -15,7 +18,7 @@ md5CacheKey = either (error "md5 is always cacheable") id . cacheKey . md5Key -- | Pack any showable into an md5 encoded text md5Key :: Show a => a -> Text -md5Key = md5Text . pack . show +md5Key = md5Text . T.pack . show md5Text :: Text -> Text -md5Text = pack . show . Digest.md5 . BSL.fromStrict . encodeUtf8 +md5Text = T.pack . show . Digest.md5 . BSL.fromStrict . T.encodeUtf8 diff --git a/freckle-app/library/Freckle/App/Memcached/Servers.hs b/freckle-memcached/library/Freckle/App/Memcached/Servers.hs similarity index 89% rename from freckle-app/library/Freckle/App/Memcached/Servers.hs rename to freckle-memcached/library/Freckle/App/Memcached/Servers.hs index f5e0ce1..50372f9 100644 --- a/freckle-app/library/Freckle/App/Memcached/Servers.hs +++ b/freckle-memcached/library/Freckle/App/Memcached/Servers.hs @@ -26,10 +26,14 @@ module Freckle.App.Memcached.Servers , toServerSpecs ) where -import Freckle.App.Prelude +import Prelude import Control.Error.Util (note) +import Control.Monad (guard) +import Data.Bifunctor (second) +import Data.Maybe (fromMaybe) import Data.Text qualified as T +import Data.Text.Encoding qualified as T import Database.Memcache.Client qualified as Memcache import Network.URI (URI (..), URIAuth (..), parseAbsoluteURI) @@ -46,11 +50,11 @@ emptyMemcachedServers = MemcachedServers [] readMemcachedServers :: String -> Either String MemcachedServers readMemcachedServers = fmap MemcachedServers - . traverse (readMemcachedServer . unpack) + . traverse (readMemcachedServer . T.unpack) . filter (not . T.null) . map T.strip . T.splitOn "," - . pack + . T.pack toServerSpecs :: MemcachedServers -> [Memcache.ServerSpec] toServerSpecs = map unMemcachedServer . unMemcachedServers @@ -77,7 +81,7 @@ readMemcachedServer s = do $ Memcache.def readAuthentication :: String -> Maybe Memcache.Authentication -readAuthentication = go . pack +readAuthentication = go . T.pack where go a = do (u, p) <- second (T.drop 1) . T.breakOn ":" <$> T.stripSuffix "@" a @@ -87,8 +91,8 @@ readAuthentication = go . pack pure Memcache.Auth - { Memcache.username = encodeUtf8 u - , Memcache.password = encodeUtf8 p + { Memcache.username = T.encodeUtf8 u + , Memcache.password = T.encodeUtf8 p } setHost :: URIAuth -> Memcache.ServerSpec -> Memcache.ServerSpec diff --git a/freckle-memcached/package.yaml b/freckle-memcached/package.yaml new file mode 100644 index 0000000..9b165c4 --- /dev/null +++ b/freckle-memcached/package.yaml @@ -0,0 +1,98 @@ +name: freckle-memcached +version: 0.0.0.1 +maintainer: Freckle Education +category: Database +github: freckle/freckle-app +synopsis: .. +description: Please see README.md + +extra-doc-files: + - README.md + - CHANGELOG.md + +extra-source-files: + - package.yaml + +language: GHC2021 + +ghc-options: + - -fignore-optim-changes + - -fwrite-ide-info + - -Weverything + - -Wno-all-missed-specialisations + - -Wno-missing-exported-signatures # re-enables missing-signatures + - -Wno-missing-import-lists + - -Wno-missing-kind-signatures + - -Wno-missing-local-signatures + - -Wno-missing-safe-haskell-mode + - -Wno-monomorphism-restriction + - -Wno-prepositive-qualified-module + - -Wno-safe + - -Wno-unsafe + +when: + - condition: "impl(ghc >= 9.8)" + ghc-options: + - -Wno-missing-role-annotations + - -Wno-missing-poly-kind-signatures + +dependencies: + - base < 5 + +default-extensions: + - DataKinds + - DeriveAnyClass + - DerivingVia + - DerivingStrategies + - GADTs + - LambdaCase + - NoImplicitPrelude + - NoMonomorphismRestriction + - OverloadedStrings + - RecordWildCards + - TypeFamilies + +library: + source-dirs: library + dependencies: + - Blammo >= 2.0.0.0 + - aeson + - annotated-exception + - bytestring + - errors + - freckle-otel + - hashable + - hs-opentelemetry-sdk + - lens + - memcache + - mtl + - network-uri + - pureMD5 + - serialise + - text + - unliftio + - unordered-containers + +tests: + spec: + main: Main.hs + source-dirs: tests + ghc-options: -threaded -rtsopts "-with-rtsopts=-N" + dependencies: + - Blammo + - aeson + - errors + - exceptions + - freckle-env + - freckle-memcached + - hs-opentelemetry-sdk + - hspec + - hspec-core + - hspec-expectations-lifted + - lens + - lens-aeson + - memcache + - mtl + - safe + - text + - unliftio diff --git a/freckle-memcached/tests/AppExample.hs b/freckle-memcached/tests/AppExample.hs new file mode 100644 index 0000000..2a2bbf5 --- /dev/null +++ b/freckle-memcached/tests/AppExample.hs @@ -0,0 +1,69 @@ +module AppExample + ( AppExample (..) + , appExample + , withApp + ) where + +import Prelude + +import Blammo.Logging +import Control.Lens (view) +import Control.Monad.Catch +import Control.Monad.Reader (MonadReader, ReaderT (..)) +import Data.Functor (void) +import Freckle.App.Dotenv qualified as Dotenv +import OpenTelemetry.Trace (HasTracer (..)) +import OpenTelemetry.Trace.Monad (MonadTracer (..)) +import Test.Hspec (Spec, SpecWith, aroundAll, beforeAll) +import Test.Hspec.Core.Spec (Example (..)) +import UnliftIO + +withApp :: ((app -> IO ()) -> IO ()) -> SpecWith app -> Spec +withApp run = beforeAll Dotenv.loadTest . aroundAll run + +-- | An Hspec example over some @app@ value +newtype AppExample app a = AppExample + { unAppExample :: ReaderT app IO a + } + deriving newtype + ( Applicative + , Functor + , Monad + , MonadCatch + , MonadIO + , MonadUnliftIO + , MonadReader app + , MonadThrow + , MonadFail + ) + deriving + (MonadLogger, MonadLoggerIO) + via WithLogger app IO + +instance MonadMask (AppExample app) where + mask = UnliftIO.mask + uninterruptibleMask = UnliftIO.uninterruptibleMask + generalBracket acquire release use = UnliftIO.mask $ \unmasked -> do + resource <- acquire + b <- + unmasked (use resource) `UnliftIO.catch` \e -> do + _ <- release resource (ExitCaseException e) + throwM e + + c <- release resource (ExitCaseSuccess b) + pure (b, c) + +instance Example (AppExample app a) where + type Arg (AppExample app a) = app + + evaluateExample (AppExample ex) params action = + evaluateExample + (action $ \app -> void $ runReaderT ex app) + params + ($ ()) + +instance HasTracer app => MonadTracer (AppExample app) where + getTracer = view tracerL + +appExample :: AppExample app a -> AppExample app a +appExample = id diff --git a/freckle-app/tests/Freckle/App/Memcached/ServersSpec.hs b/freckle-memcached/tests/Freckle/App/Memcached/ServersSpec.hs similarity index 96% rename from freckle-app/tests/Freckle/App/Memcached/ServersSpec.hs rename to freckle-memcached/tests/Freckle/App/Memcached/ServersSpec.hs index a3ac387..d58d87c 100644 --- a/freckle-app/tests/Freckle/App/Memcached/ServersSpec.hs +++ b/freckle-memcached/tests/Freckle/App/Memcached/ServersSpec.hs @@ -2,13 +2,16 @@ module Freckle.App.Memcached.ServersSpec ( spec ) where -import Freckle.App.Prelude +import Prelude import Control.Error.Util (hush) +import Control.Monad ((<=<)) import Data.Either (isLeft, isRight) +import Data.Functor (void) import Database.Memcache.Client qualified as Memcache import Freckle.App.Memcached.Servers -import Freckle.App.Test +import Safe (headMay) +import Test.Hspec spec :: Spec spec = do diff --git a/freckle-app/tests/Freckle/App/MemcachedSpec.hs b/freckle-memcached/tests/Freckle/App/MemcachedSpec.hs similarity index 78% rename from freckle-app/tests/Freckle/App/MemcachedSpec.hs rename to freckle-memcached/tests/Freckle/App/MemcachedSpec.hs index d2b740e..494e2eb 100644 --- a/freckle-app/tests/Freckle/App/MemcachedSpec.hs +++ b/freckle-memcached/tests/Freckle/App/MemcachedSpec.hs @@ -4,21 +4,38 @@ module Freckle.App.MemcachedSpec ( spec ) where -import Freckle.App.Test +import Prelude +import AppExample import Blammo.Logging.LogSettings import Blammo.Logging.Logger import Control.Lens (lens, to, (^?)) +import Control.Monad.IO.Class (liftIO) import Data.Aeson (Value (..)) import Data.Aeson.Lens import Data.List.NonEmpty qualified as NE import Data.Text qualified as T import Freckle.App.Env qualified as Env import Freckle.App.Memcached -import Freckle.App.Memcached.Client (MemcachedClient, withMemcachedClient) +import Freckle.App.Memcached.Client + ( MemcachedClient + , withMemcachedClient + ) import Freckle.App.Memcached.Client qualified as Memcached import Freckle.App.Memcached.Servers -import Freckle.App.OpenTelemetry +import OpenTelemetry.Trace + ( HasTracer (..) + , Tracer + , TracerProvider + , initializeGlobalTracerProvider + , makeTracer + , shutdownTracerProvider + , tracerOptions + ) +import Test.Hspec (Spec, describe, it) +import Test.Hspec.Expectations.Lifted (shouldBe, shouldSatisfy) +import UnliftIO (MonadUnliftIO) +import UnliftIO.Exception (bracket) data ExampleValue = A @@ -68,6 +85,12 @@ loadApp f = do withMemcachedClient servers $ \appMemcachedClient -> do f App {..} +withTracerProvider :: MonadUnliftIO m => (TracerProvider -> m a) -> m a +withTracerProvider = + bracket + (liftIO initializeGlobalTracerProvider) + (liftIO . shutdownTracerProvider) + spec :: Spec spec = withApp loadApp $ do describe "caching" $ do @@ -93,7 +116,10 @@ spec = withApp loadApp $ do msgs <- getLoggedMessagesLenient let Just LoggedMessage {..} = NE.last <$> NE.nonEmpty msgs - Object loggedMessageMeta ^? key "error" . key "message" . _String + Object loggedMessageMeta + ^? key "error" + . key "message" + . _String `shouldBe` Just "Unable to deserialize: invalid: \"Broken\"" -- This assertion is far too brittle, but can be useful to un-comment if @@ -106,5 +132,8 @@ spec = withApp loadApp $ do -- , " caching, called at tests/Freckle/App/MemcachedSpec.hs:87:15 in main:Freckle.App.MemcachedSpec" -- ] Object loggedMessageMeta - ^? key "error" . key "stack" . _String . to T.lines + ^? key "error" + . key "stack" + . _String + . to T.lines `shouldSatisfy` maybe False (not . null) diff --git a/freckle-memcached/tests/Main.hs b/freckle-memcached/tests/Main.hs new file mode 100644 index 0000000..1fcc19c --- /dev/null +++ b/freckle-memcached/tests/Main.hs @@ -0,0 +1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --module-name=Main -Wno-missing-export-lists #-} diff --git a/freckle-otel/CHANGELOG.md b/freckle-otel/CHANGELOG.md new file mode 100644 index 0000000..1165e96 --- /dev/null +++ b/freckle-otel/CHANGELOG.md @@ -0,0 +1,9 @@ +## [_Unreleased_](https://github.com/freckle/freckle-app/compare/freckle-otel-v0.0.0.0...main) + +## [v0.0.0.1](https://github.com/freckle/freckle-app/compare/freckle-otel-v0.0.0.0...freckle-otel-v0.0.0.1) + +Drop `relude` dependency + +## [v0.0.0.0](https://github.com/freckle/freckle-app/tree/freckle-otel-v0.0.0.0/freckle-otel) + +First release, sprouted from `freckle-app-1.19.0.0`. diff --git a/freckle-otel/LICENSE b/freckle-otel/LICENSE new file mode 100644 index 0000000..8666b16 --- /dev/null +++ b/freckle-otel/LICENSE @@ -0,0 +1,21 @@ +The MIT License (MIT) + +Copyright (c) 2023-2024 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/freckle-otel/README.md b/freckle-otel/README.md new file mode 100644 index 0000000..fd6f191 --- /dev/null +++ b/freckle-otel/README.md @@ -0,0 +1 @@ +# freckle-otel diff --git a/freckle-otel/freckle-otel.cabal b/freckle-otel/freckle-otel.cabal new file mode 100644 index 0000000..16d3d82 --- /dev/null +++ b/freckle-otel/freckle-otel.cabal @@ -0,0 +1,113 @@ +cabal-version: 1.18 + +-- This file has been generated from package.yaml by hpack version 0.36.0. +-- +-- see: https://github.com/sol/hpack + +name: freckle-otel +version: 0.0.0.1 +synopsis: ... +description: Please see README.md +category: OpenTelemetry, Telemetry, Monitoring, Observability, Metrics +homepage: https://github.com/freckle/freckle-app#readme +bug-reports: https://github.com/freckle/freckle-app/issues +maintainer: Freckle Education +license: MIT +license-file: LICENSE +build-type: Simple +extra-source-files: + package.yaml +extra-doc-files: + README.md + CHANGELOG.md + +source-repository head + type: git + location: https://github.com/freckle/freckle-app + +library + exposed-modules: + Freckle.App.OpenTelemetry + Freckle.App.OpenTelemetry.Context + Freckle.App.OpenTelemetry.Http + Freckle.App.OpenTelemetry.ThreadContext + other-modules: + Paths_freckle_otel + hs-source-dirs: + library + default-extensions: + DataKinds + DeriveAnyClass + DerivingVia + DerivingStrategies + GADTs + LambdaCase + NoImplicitPrelude + NoMonomorphismRestriction + OverloadedStrings + RecordWildCards + TypeFamilies + ghc-options: -fignore-optim-changes -fwrite-ide-info -Weverything -Wno-all-missed-specialisations -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missing-kind-signatures -Wno-missing-local-signatures -Wno-missing-safe-haskell-mode -Wno-monomorphism-restriction -Wno-prepositive-qualified-module -Wno-safe -Wno-unsafe + build-depends: + Blammo >=2.0.0.0 + , aeson + , base <5 + , bytestring + , case-insensitive + , errors + , exceptions + , faktory + , hs-opentelemetry-api + , hs-opentelemetry-sdk + , http-client + , http-conduit >=2.3.5 + , http-types + , lens + , text + , unliftio + , unordered-containers + default-language: GHC2021 + if impl(ghc >= 9.8) + ghc-options: -Wno-missing-role-annotations -Wno-missing-poly-kind-signatures + +test-suite spec + type: exitcode-stdio-1.0 + main-is: Main.hs + other-modules: + AppExample + Freckle.App.OpenTelemetry.ContextSpec + Paths_freckle_otel + hs-source-dirs: + tests + default-extensions: + DataKinds + DeriveAnyClass + DerivingVia + DerivingStrategies + GADTs + LambdaCase + NoImplicitPrelude + NoMonomorphismRestriction + OverloadedStrings + RecordWildCards + TypeFamilies + ghc-options: -fignore-optim-changes -fwrite-ide-info -Weverything -Wno-all-missed-specialisations -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missing-kind-signatures -Wno-missing-local-signatures -Wno-missing-safe-haskell-mode -Wno-monomorphism-restriction -Wno-prepositive-qualified-module -Wno-safe -Wno-unsafe -threaded -rtsopts "-with-rtsopts=-N" + build-depends: + Blammo + , base <5 + , exceptions + , freckle-env + , freckle-otel + , hs-opentelemetry-api + , hs-opentelemetry-sdk + , hspec + , hspec-core + , hspec-expectations-lifted + , http-types + , lens + , mtl + , text + , unliftio + default-language: GHC2021 + if impl(ghc >= 9.8) + ghc-options: -Wno-missing-role-annotations -Wno-missing-poly-kind-signatures diff --git a/freckle-app/library/Freckle/App/OpenTelemetry.hs b/freckle-otel/library/Freckle/App/OpenTelemetry.hs similarity index 94% rename from freckle-app/library/Freckle/App/OpenTelemetry.hs rename to freckle-otel/library/Freckle/App/OpenTelemetry.hs index 694f8af..990ea1b 100644 --- a/freckle-app/library/Freckle/App/OpenTelemetry.hs +++ b/freckle-otel/library/Freckle/App/OpenTelemetry.hs @@ -64,12 +64,16 @@ module Freckle.App.OpenTelemetry , attributeValueLimit ) where -import Freckle.App.Prelude +import Prelude +import Control.Monad.IO.Class (MonadIO, liftIO) import Data.ByteString (ByteString) +import Data.Functor (void) +import Data.HashMap.Strict (HashMap) +import Data.Text (Text) import Data.Text qualified as T -import Data.Text.Encoding (decodeUtf8With) -import Data.Text.Encoding.Error (lenientDecode) +import Data.Text.Encoding qualified as T +import Data.Text.Encoding.Error qualified as T import OpenTelemetry.Context (lookupSpan) import OpenTelemetry.Context.ThreadLocal (getContext) import OpenTelemetry.Trace hiding (inSpan) @@ -83,6 +87,7 @@ import OpenTelemetry.Trace.Id , traceIdBaseEncodedText ) import OpenTelemetry.Trace.Monad +import UnliftIO (MonadUnliftIO) import UnliftIO.Exception (bracket) -- | 'defaultSpanArguments' with 'kind' set to 'Server' @@ -152,7 +157,7 @@ byteStringToAttribute :: ByteString -> Attribute byteStringToAttribute = toAttribute . truncateText attributeValueLimit - . decodeUtf8With lenientDecode + . T.decodeUtf8With T.lenientDecode -- | Character limit for 'Attribute' values -- diff --git a/freckle-app/library/Freckle/App/OpenTelemetry/Context.hs b/freckle-otel/library/Freckle/App/OpenTelemetry/Context.hs similarity index 87% rename from freckle-app/library/Freckle/App/OpenTelemetry/Context.hs rename to freckle-otel/library/Freckle/App/OpenTelemetry/Context.hs index b1ef07a..9a4537f 100644 --- a/freckle-app/library/Freckle/App/OpenTelemetry/Context.hs +++ b/freckle-otel/library/Freckle/App/OpenTelemetry/Context.hs @@ -6,15 +6,22 @@ module Freckle.App.OpenTelemetry.Context , processWithContext ) where -import Freckle.App.Prelude +import Prelude import Control.Error.Util (hush) -import Control.Lens (Lens', lens, (&), (.~), (^.)) +import Control.Lens (Lens', lens, (.~), (^.)) import Control.Monad.Catch (MonadMask) +import Control.Monad.IO.Class (MonadIO) import Data.Aeson (FromJSON, ToJSON) +import Data.Bifunctor (bimap) import Data.ByteString (ByteString) import Data.CaseInsensitive (CI) import Data.CaseInsensitive qualified as CI +import Data.Function ((&)) +import Data.Functor (void) +import Data.Maybe (fromMaybe) +import Data.Text (Text) +import Data.Text.Encoding qualified as T import Faktory.Job (Job, custom, jobOptions) import Faktory.Job.Custom (fromCustom, toCustom) import Faktory.JobOptions (JobOptions (..)) @@ -24,6 +31,8 @@ import Freckle.App.OpenTelemetry , inSpan ) import Freckle.App.OpenTelemetry.ThreadContext (withTraceContext) +import GHC.Generics (Generic) +import GHC.Stack (HasCallStack) import Network.HTTP.Client (Request, requestHeaders) import Network.HTTP.Simple (setRequestHeaders) import Network.HTTP.Types.Header (Header) @@ -34,6 +43,7 @@ import OpenTelemetry.Trace.Core ( getTracerProviderPropagators , getTracerTracerProvider ) +import UnliftIO (MonadUnliftIO) class HasHeaders a where headersL :: Lens' a [Header] @@ -68,10 +78,10 @@ instance HasHeaders CustomTraceContext where headersL = lens (map encode . traceHeaders) $ \x y -> x {traceHeaders = map decode y} encode :: (Text, Text) -> (CI ByteString, ByteString) -encode = bimap (CI.mk . encodeUtf8) encodeUtf8 +encode = bimap (CI.mk . T.encodeUtf8) T.encodeUtf8 decode :: (CI ByteString, ByteString) -> (Text, Text) -decode = bimap (decodeUtf8 . CI.original) decodeUtf8 +decode = bimap (T.decodeUtf8 . CI.original) T.decodeUtf8 -- | Update our trace context from that extracted from the given item's headers extractContext diff --git a/freckle-app/library/Freckle/App/OpenTelemetry/Http.hs b/freckle-otel/library/Freckle/App/OpenTelemetry/Http.hs similarity index 85% rename from freckle-app/library/Freckle/App/OpenTelemetry/Http.hs rename to freckle-otel/library/Freckle/App/OpenTelemetry/Http.hs index 2ac9a25..caab73c 100644 --- a/freckle-app/library/Freckle/App/OpenTelemetry/Http.hs +++ b/freckle-otel/library/Freckle/App/OpenTelemetry/Http.hs @@ -5,13 +5,15 @@ module Freckle.App.OpenTelemetry.Http , httpResponseAttributes ) where -import Freckle.App.Prelude +import Prelude import Data.CaseInsensitive qualified as CI +import Data.HashMap.Strict (HashMap) import Data.HashMap.Strict qualified as HashMap +import Data.Text (Text) import Data.Text qualified as T -import Data.Text.Encoding (decodeUtf8With) -import Data.Text.Encoding.Error (lenientDecode) +import Data.Text.Encoding qualified as T +import Data.Text.Encoding.Error qualified as T import Freckle.App.OpenTelemetry ( SpanArguments (..) , byteStringToAttribute @@ -24,7 +26,7 @@ import OpenTelemetry.Attributes (Attribute, ToAttribute (..)) httpSpanName :: Request -> Text httpSpanName req = - decodeUtf8With lenientDecode $ HTTP.method req <> " " <> HTTP.path req + T.decodeUtf8With T.lenientDecode $ HTTP.method req <> " " <> HTTP.path req httpSpanArguments :: Request -> SpanArguments httpSpanArguments req = clientSpanArguments {attributes = httpAttributes req} @@ -54,5 +56,5 @@ httpResponseAttributes resp = statusAttr <> foldMap (uncurry headerAttr) (HTTP.r headerAttrKey = ("http.response.headers." <>) . T.toLower - . decodeUtf8With lenientDecode + . T.decodeUtf8With T.lenientDecode . CI.original diff --git a/freckle-app/library/Freckle/App/OpenTelemetry/ThreadContext.hs b/freckle-otel/library/Freckle/App/OpenTelemetry/ThreadContext.hs similarity index 93% rename from freckle-app/library/Freckle/App/OpenTelemetry/ThreadContext.hs rename to freckle-otel/library/Freckle/App/OpenTelemetry/ThreadContext.hs index 5257452..830193a 100644 --- a/freckle-app/library/Freckle/App/OpenTelemetry/ThreadContext.hs +++ b/freckle-otel/library/Freckle/App/OpenTelemetry/ThreadContext.hs @@ -4,12 +4,15 @@ module Freckle.App.OpenTelemetry.ThreadContext ( withTraceContext ) where -import Freckle.App.Prelude +import Prelude import Blammo.Logging (MonadMask, withThreadContext) +import Control.Monad.IO.Class (MonadIO) import Data.Aeson ((.=)) import Data.Aeson.Key qualified as Key import Data.Aeson.Types (Pair) +import Data.Bifunctor (bimap) +import Data.Text (Text) import Freckle.App.OpenTelemetry (getCurrentSpanContext) import OpenTelemetry.Trace.Core (SpanContext (..)) import OpenTelemetry.Trace.Id diff --git a/freckle-otel/package.yaml b/freckle-otel/package.yaml new file mode 100644 index 0000000..6e80d45 --- /dev/null +++ b/freckle-otel/package.yaml @@ -0,0 +1,94 @@ +name: freckle-otel +version: 0.0.0.1 +maintainer: Freckle Education +category: OpenTelemetry, Telemetry, Monitoring, Observability, Metrics +github: freckle/freckle-app +synopsis: ... +description: Please see README.md + +extra-doc-files: + - README.md + - CHANGELOG.md + +extra-source-files: + - package.yaml + +language: GHC2021 + +ghc-options: + - -fignore-optim-changes + - -fwrite-ide-info + - -Weverything + - -Wno-all-missed-specialisations + - -Wno-missing-exported-signatures # re-enables missing-signatures + - -Wno-missing-import-lists + - -Wno-missing-kind-signatures + - -Wno-missing-local-signatures + - -Wno-missing-safe-haskell-mode + - -Wno-monomorphism-restriction + - -Wno-prepositive-qualified-module + - -Wno-safe + - -Wno-unsafe + +when: + - condition: "impl(ghc >= 9.8)" + ghc-options: + - -Wno-missing-role-annotations + - -Wno-missing-poly-kind-signatures + +dependencies: + - base < 5 + +default-extensions: + - DataKinds + - DeriveAnyClass + - DerivingVia + - DerivingStrategies + - GADTs + - LambdaCase + - NoImplicitPrelude + - NoMonomorphismRestriction + - OverloadedStrings + - RecordWildCards + - TypeFamilies + +library: + source-dirs: library + dependencies: + - Blammo >= 2.0.0.0 + - aeson + - bytestring + - case-insensitive + - errors + - exceptions + - faktory + - hs-opentelemetry-api + - hs-opentelemetry-sdk + - http-client + - http-conduit >= 2.3.5 # addToRequestQueryString + - http-types + - lens + - text + - unliftio + - unordered-containers + +tests: + spec: + main: Main.hs + source-dirs: tests + ghc-options: -threaded -rtsopts "-with-rtsopts=-N" + dependencies: + - Blammo + - exceptions + - freckle-env + - freckle-otel + - hs-opentelemetry-api + - hs-opentelemetry-sdk + - hspec + - hspec-core + - hspec-expectations-lifted + - http-types + - lens + - mtl + - text + - unliftio diff --git a/freckle-otel/tests/AppExample.hs b/freckle-otel/tests/AppExample.hs new file mode 100644 index 0000000..9c0119d --- /dev/null +++ b/freckle-otel/tests/AppExample.hs @@ -0,0 +1,65 @@ +module AppExample + ( AppExample (..) + , appExample + , withApp + ) where + +import Prelude + +import Control.Lens (view) +import Control.Monad.Catch +import Control.Monad.Reader (MonadReader, ReaderT (..)) +import Data.Functor (void) +import Freckle.App.Dotenv qualified as Dotenv +import OpenTelemetry.Trace (HasTracer (..)) +import OpenTelemetry.Trace.Monad (MonadTracer (..)) +import Test.Hspec (Spec, SpecWith, aroundAll, beforeAll) +import Test.Hspec.Core.Spec (Example (..)) +import UnliftIO + +withApp :: ((app -> IO ()) -> IO ()) -> SpecWith app -> Spec +withApp run = beforeAll Dotenv.loadTest . aroundAll run + +-- | An Hspec example over some @app@ value +newtype AppExample app a = AppExample + { unAppExample :: ReaderT app IO a + } + deriving newtype + ( Applicative + , Functor + , Monad + , MonadCatch + , MonadIO + , MonadUnliftIO + , MonadReader app + , MonadThrow + , MonadFail + ) + +instance MonadMask (AppExample app) where + mask = UnliftIO.mask + uninterruptibleMask = UnliftIO.uninterruptibleMask + generalBracket acquire release use = UnliftIO.mask $ \unmasked -> do + resource <- acquire + b <- + unmasked (use resource) `UnliftIO.catch` \e -> do + _ <- release resource (ExitCaseException e) + throwM e + + c <- release resource (ExitCaseSuccess b) + pure (b, c) + +instance HasTracer app => MonadTracer (AppExample app) where + getTracer = view tracerL + +instance Example (AppExample app a) where + type Arg (AppExample app a) = app + + evaluateExample (AppExample ex) params action = + evaluateExample + (action $ \app -> void $ runReaderT ex app) + params + ($ ()) + +appExample :: AppExample app a -> AppExample app a +appExample = id diff --git a/freckle-app/tests/Freckle/App/OpenTelemetry/ContextSpec.hs b/freckle-otel/tests/Freckle/App/OpenTelemetry/ContextSpec.hs similarity index 78% rename from freckle-app/tests/Freckle/App/OpenTelemetry/ContextSpec.hs rename to freckle-otel/tests/Freckle/App/OpenTelemetry/ContextSpec.hs index 366a263..8fec81a 100644 --- a/freckle-app/tests/Freckle/App/OpenTelemetry/ContextSpec.hs +++ b/freckle-otel/tests/Freckle/App/OpenTelemetry/ContextSpec.hs @@ -2,16 +2,29 @@ module Freckle.App.OpenTelemetry.ContextSpec ( spec ) where -import Freckle.App.Test +import Prelude +import AppExample import Blammo.Logging import Blammo.Logging.Logger (newTestLogger) import Control.Lens (lens) +import Control.Monad.IO.Class (MonadIO) +import Data.List qualified as List +import Data.Text (Text) import Data.Text qualified as T +import Data.Text.Encoding qualified as T import Freckle.App.OpenTelemetry import Freckle.App.OpenTelemetry.Context +import GHC.Stack (HasCallStack) import Network.HTTP.Types.Header (Header) import OpenTelemetry.Trace.Core qualified as Trace +import Test.Hspec (Spec, describe, it) +import Test.Hspec.Expectations.Lifted + ( shouldBe + , shouldNotBe + , shouldReturn + ) +import Test.Hspec.Expectations.Lifted qualified as Hspec (expectationFailure) data App = App { appLogger :: Logger @@ -35,7 +48,7 @@ loadApp f = do spec :: Spec spec = withApp loadApp $ do describe "injectContext" $ do - it "sets request headers from existing context" $ appExample $ do + it "sets request headers from existing context" $ appExample @App $ do inSpan "example" defaultSpanArguments $ do spanContext <- assertCurrentSpanContext @@ -45,19 +58,19 @@ spec = withApp loadApp $ do (spanIdToHex $ Trace.spanId spanContext) injectContext ([] :: [Header]) - `shouldReturn` [ ("traceparent", encodeUtf8 expectedTraceParent) + `shouldReturn` [ ("traceparent", T.encodeUtf8 expectedTraceParent) , ("tracestate", "") ] describe "extractContext" $ do - it "sets the context from the headers" $ appExample $ do + it "sets the context from the headers" $ appExample @App $ do let traceId = "fba7cd19bff3ef866a599d6f6a85baef" spanId = "5747fd6b144f4009" headers :: [Header] headers = - [ ("traceparent", encodeUtf8 $ toTraceParent traceId spanId) + [ ("traceparent", T.encodeUtf8 $ toTraceParent traceId spanId) , ("tracestate", "") ] @@ -67,7 +80,7 @@ spec = withApp loadApp $ do traceIdToHex (Trace.traceId spanContext) `shouldBe` traceId spanIdToHex (Trace.spanId spanContext) `shouldBe` spanId - it "does nothing with no headers" $ appExample $ do + it "does nothing with no headers" $ appExample @App $ do getCurrentSpanContext `shouldReturn` Nothing extractContext ([] :: [Header]) @@ -75,7 +88,7 @@ spec = withApp loadApp $ do getCurrentSpanContext `shouldReturn` Nothing describe "processWithContext" $ do - it "creates a child-span context" $ appExample $ do + it "creates a child-span context" $ appExample @App $ do inSpan "example" defaultSpanArguments $ do outerSpanContext <- assertCurrentSpanContext @@ -85,7 +98,7 @@ spec = withApp loadApp $ do headers :: [Header] headers = - [ ("traceparent", encodeUtf8 $ toTraceParent traceId spanId) + [ ("traceparent", T.encodeUtf8 $ toTraceParent traceId spanId) , ("tracestate", "") ] @@ -98,7 +111,7 @@ spec = withApp loadApp $ do Trace.traceId innerSpanContext `shouldBe` Trace.traceId outerSpanContext Trace.spanId innerSpanContext `shouldNotBe` Trace.spanId outerSpanContext - it "sets the current context back into the headers" $ appExample $ do + it "sets the current context back into the headers" $ appExample @App $ do inSpan "example" defaultSpanArguments $ do let traceId = "fba7cd19bff3ef866a599d6f6a85baef" @@ -106,7 +119,7 @@ spec = withApp loadApp $ do headers :: [Header] headers = - [ ("traceparent", encodeUtf8 $ toTraceParent traceId spanId) + [ ("traceparent", T.encodeUtf8 $ toTraceParent traceId spanId) , ("tracestate", "") ] @@ -114,14 +127,14 @@ spec = withApp loadApp $ do spanContext <- assertCurrentSpanContext let headerTraceParent = do - bs <- lookup "traceparent" headers' - fromTraceParent $ decodeUtf8 bs + bs <- List.lookup "traceparent" headers' + fromTraceParent $ T.decodeUtf8 bs fmap fst headerTraceParent `shouldBe` Just traceId fmap snd headerTraceParent `shouldBe` Just (spanIdToHex $ Trace.spanId spanContext) - it "sets a fresh context back into the headers" $ appExample $ do + it "sets a fresh context back into the headers" $ appExample @App $ do inSpan "example" defaultSpanArguments $ do let headers :: [Header] @@ -131,8 +144,8 @@ spec = withApp loadApp $ do spanContext <- assertCurrentSpanContext let headerTraceParent = do - bs <- lookup "traceparent" headers' - fromTraceParent $ decodeUtf8 bs + bs <- List.lookup "traceparent" headers' + fromTraceParent $ T.decodeUtf8 bs fmap fst headerTraceParent `shouldBe` Just (traceIdToHex $ Trace.traceId spanContext) @@ -154,3 +167,6 @@ fromTraceParent a = do c <- T.stripSuffix "-00" b [traceId, spanId] <- Just $ T.splitOn "-" c pure (traceId, spanId) + +expectationFailure :: (MonadIO m, HasCallStack) => String -> m a +expectationFailure msg = Hspec.expectationFailure msg >> error "unreachable" diff --git a/freckle-otel/tests/Main.hs b/freckle-otel/tests/Main.hs new file mode 100644 index 0000000..1fcc19c --- /dev/null +++ b/freckle-otel/tests/Main.hs @@ -0,0 +1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --module-name=Main -Wno-missing-export-lists #-} diff --git a/hie.yaml b/hie.yaml index 9d0728a..ec6f55b 100644 --- a/hie.yaml +++ b/hie.yaml @@ -1,10 +1,37 @@ cradle: - stack: + cabal: - path: "freckle-app/library" - component: "freckle-app:lib" + component: "lib:freckle-app" - path: "freckle-app/doctest" component: "freckle-app:test:doctest" - path: "freckle-app/tests" component: "freckle-app:test:spec" + + - path: "freckle-env/library" + component: "lib:freckle-env" + + - path: "freckle-env/doctest" + component: "freckle-env:test:doctest" + + - path: "freckle-http/library" + component: "lib:freckle-http" + + - path: "freckle-http/tests" + component: "freckle-http:test:spec" + + - path: "freckle-kafka/library" + component: "lib:freckle-kafka" + + - path: "freckle-memcached/library" + component: "lib:freckle-memcached" + + - path: "freckle-memcached/tests" + component: "freckle-memcached:test:spec" + + - path: "freckle-otel/library" + component: "lib:freckle-otel" + + - path: "freckle-otel/tests" + component: "freckle-otel:test:spec" diff --git a/stack-lts-20.26.yaml b/stack-lts-20.26.yaml index 762f645..1f02a2c 100644 --- a/stack-lts-20.26.yaml +++ b/stack-lts-20.26.yaml @@ -36,4 +36,7 @@ extra-deps: packages: - freckle-app - freckle-env + - freckle-http - freckle-kafka + - freckle-memcached + - freckle-otel diff --git a/stack-lts-21.25.yaml b/stack-lts-21.25.yaml index 85343d9..d137766 100644 --- a/stack-lts-21.25.yaml +++ b/stack-lts-21.25.yaml @@ -32,4 +32,7 @@ extra-deps: packages: - freckle-app - freckle-env + - freckle-http - freckle-kafka + - freckle-memcached + - freckle-otel diff --git a/stack-nightly.yaml b/stack-nightly.yaml index a884480..dce051f 100644 --- a/stack-nightly.yaml +++ b/stack-nightly.yaml @@ -83,4 +83,7 @@ allow-newer-deps: packages: - freckle-app - freckle-env + - freckle-http - freckle-kafka + - freckle-memcached + - freckle-otel diff --git a/stack.yaml b/stack.yaml index e74b200..0fc354d 100644 --- a/stack.yaml +++ b/stack.yaml @@ -27,4 +27,7 @@ extra-deps: packages: - freckle-app - freckle-env + - freckle-http - freckle-kafka + - freckle-memcached + - freckle-otel