diff --git a/CHANGELOG.md b/CHANGELOG.md index 0fd8e775..45a40c23 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,19 @@ # CHANGELOG +## 1.0.23 -- 2025-01-02 + +- Record more route duration metrics with prometheus [#810](https://github.com/flora-pm/flora-server/pull/810) +- Add prometheus counter for package imports [#811](https://github.com/flora-pm/flora-server/pull/811) +- Add new GHC versions [#813](https://github.com/flora-pm/flora-server/pull/813) + + The following versions have been added: + * 9.12.1 + * 9.10.1 + * 9.8.4 + * 9.8.3 + * 9.6.7 + * 9.6.6 + ## 1.0.22 -- 2024-12-27 ### Significant changes diff --git a/app/cli/Main.hs b/app/cli/Main.hs index 96e0ca6e..711510b1 100644 --- a/app/cli/Main.hs +++ b/app/cli/Main.hs @@ -19,6 +19,8 @@ import Effectful.FileSystem import Effectful.Log (Log, runLog) import Effectful.Poolboy import Effectful.PostgreSQL.Transact.Effect +import Effectful.Reader.Static (Reader) +import Effectful.Reader.Static qualified as Reader import Effectful.State.Static.Shared (State) import Effectful.State.Static.Shared qualified as State import Effectful.Time (Time, runTime) @@ -26,6 +28,7 @@ import Effectful.Trace (Trace) import Effectful.Trace qualified as Trace import GHC.Conc import GHC.Generics (Generic) +import GHC.Records import Log qualified import Log.Backend.StandardOutput qualified as Log import Monitor.Tracing.Zipkin (Zipkin (..)) @@ -36,7 +39,8 @@ import System.FilePath (()) import Advisories.Import (importAdvisories) import Advisories.Import.Error (AdvisoryImportError) -import Flora.Environment +import Flora.Environment (getFloraEnv) +import Flora.Environment.Env import Flora.Import.Categories (importCategories) import Flora.Import.Package.Bulk (importAllFilesInRelativeDirectory, importFromIndex) import Flora.Model.BlobIndex.Update qualified as Update @@ -108,6 +112,7 @@ main = Log.withStdOutLogger $ \logger -> do ) . runFileSystem . runLog "flora-cli" logger Log.LogTrace + . Reader.runReader env $ runOptions cliArgs case result of Right _ -> pure () @@ -196,6 +201,9 @@ runOptions , Poolboy :> es , Error (NonEmpty AdvisoryImportError) :> es , Trace :> es + , HasField "metrics" r Metrics + , HasField "mltp" r MLTP + , Reader r :> es ) => Options -> Eff es () @@ -245,6 +253,9 @@ importFolderOfCabalFiles , DB :> es , IOE :> es , State (Set (Namespace, PackageName, Version)) :> es + , HasField "metrics" r Metrics + , HasField "mltp" r MLTP + , Reader r :> es ) => FilePath -> Text @@ -264,6 +275,9 @@ importIndex , DB :> es , IOE :> es , State (Set (Namespace, PackageName, Version)) :> es + , HasField "metrics" r Metrics + , HasField "mltp" r MLTP + , Reader r :> es ) => FilePath -> Text diff --git a/app/server/Main.hs b/app/server/Main.hs index c9c3b63b..04297315 100644 --- a/app/server/Main.hs +++ b/app/server/Main.hs @@ -4,12 +4,12 @@ module Main where -import Control.Monad (forM_, unless, void) +import Control.Monad (forM_, unless) import Data.Function ((&)) import Data.List qualified as List -import Data.Pool (Pool) import Data.Set qualified as Set import Data.Text (Text) +import Data.Text qualified as Text import Data.Vector (Vector) import Data.Vector qualified as Vector import Database.PostgreSQL.Entity @@ -24,12 +24,11 @@ import Log qualified import System.Exit import System.IO -import Data.Text qualified as Text -import Database.PostgreSQL.Simple qualified as PG -import Flora.Environment (FloraEnv (..), MLTP (..), getFloraEnv) +import Flora.Environment (getFloraEnv) +import Flora.Environment.Env (FloraEnv (..), MLTP (..)) import Flora.Logging qualified as Logging import Flora.Model.PackageIndex.Types -import FloraJobs.Scheduler (checkIfIndexRefreshJobIsPlanned, scheduleRefreshIndexes) +import FloraJobs.Scheduler (checkIfIndexRefreshJobIsPlanned) import FloraWeb.Server main :: IO () @@ -47,17 +46,9 @@ main = do Log.LogTrace $ do checkRepositoriesAreConfigured - checkIndexRefreshScheduling env.pool + checkIfIndexRefreshJobIsPlanned env.pool runFlora -checkIndexRefreshScheduling :: (DB :> es, Log :> es, IOE :> es) => Pool PG.Connection -> Eff es () -checkIndexRefreshScheduling pool = do - indexRefreshIsPlanned <- - checkIfIndexRefreshJobIsPlanned - unless indexRefreshIsPlanned $ do - Log.logInfo_ "Scheduling index refresh" - void $ liftIO $ scheduleRefreshIndexes pool - checkRepositoriesAreConfigured :: (DB :> es, Log :> es, IOE :> es) => Eff es () checkRepositoriesAreConfigured = do let expectedRepositories = Set.fromList ["hackage", "cardano", "horizon"] diff --git a/cabal.project.freeze b/cabal.project.freeze index fdefbf4e..f3bcdce2 100644 --- a/cabal.project.freeze +++ b/cabal.project.freeze @@ -1,6 +1,7 @@ active-repositories: hackage.haskell.org:merge constraints: any.Cabal ==3.10.3.0, any.Cabal-syntax ==3.10.3.0, + any.Glob ==0.10.2, any.HUnit ==1.6.2.0, any.JuicyPixels ==3.3.9, JuicyPixels -mmap, @@ -21,7 +22,8 @@ constraints: any.Cabal ==3.10.3.0, aeson +ordered-keymap, any.aeson-pretty ==0.8.10, aeson-pretty -lib-only, - any.ansi-terminal ==1.1.1, + any.alex ==3.5.1.0, + any.ansi-terminal ==1.1.2, ansi-terminal -example, any.ansi-terminal-types ==1.1, any.appar ==0.1.8, @@ -44,7 +46,7 @@ constraints: any.Cabal ==3.10.3.0, any.base ==4.18.2.1, any.base-compat ==0.13.1, any.base-compat-batteries ==0.13.1, - any.base-orphans ==0.9.2, + any.base-orphans ==0.9.3, any.base16 ==1.0, any.base16-bytestring ==1.0.2.0, any.base32 ==0.4, @@ -62,24 +64,25 @@ constraints: any.Cabal ==3.10.3.0, any.boring ==0.2.2, boring +tagged, any.bsb-http-chunked ==0.0.0.4, - any.bytebuild ==0.3.16.2, + any.bytebuild ==0.3.16.3, bytebuild -checked, any.byteorder ==1.0.4, - any.byteslice ==0.2.13.2, + any.byteslice ==0.2.14.0, byteslice +avoid-rawmemchr, any.bytesmith ==0.3.11.1, any.bytestring ==0.11.5.3, - any.bytestring-builder ==0.10.8.2.0, - bytestring-builder +bytestring_has_builder, - any.cabal-doctest ==1.0.10, + any.cabal-doctest ==1.0.11, any.call-stack ==0.4.0, any.case-insensitive ==1.2.1.0, + any.cassava ==0.5.3.2, any.cborg ==0.2.10.0, cborg +optimize-gmp, any.cereal ==0.5.8.3, cereal -bytestring-builder, any.character-ps ==0.1, - any.chronos ==1.1.6.1, + any.chronos ==1.1.6.2, + any.citeproc ==0.8.1.2, + citeproc -executable -icu, any.clock ==0.8.4, clock -llvm, any.cmark-gfm ==0.2.6, @@ -89,11 +92,13 @@ constraints: any.Cabal ==3.10.3.0, any.colour ==2.3.6, any.colourista ==0.1.0.2, any.commonmark ==0.2.6.1, - any.commonmark-extensions ==0.2.5.5, - any.comonad ==5.0.8, + any.commonmark-extensions ==0.2.5.6, + any.commonmark-pandoc ==0.2.2.3, + any.comonad ==5.0.9, comonad +containers +distributive +indexed-traversable, any.concurrent-output ==1.10.21, any.conduit ==1.3.6, + any.conduit-combinators ==1.3.0, any.conduit-extra ==1.3.6, any.constraints ==0.14.2, any.containers ==0.6.7, @@ -108,35 +113,44 @@ constraints: any.Cabal ==3.10.3.0, any.cryptohash-sha1 ==0.11.101.0, any.cryptohash-sha256 ==0.11.102.1, cryptohash-sha256 -exe +use-cbits, - any.crypton ==1.0.0, + any.crypton ==1.0.1, crypton -check_alignment +integer-gmp -old_toolchain_inliner +support_aesni +support_deepseq +support_pclmuldq +support_rdrand -support_sse +use_target_attributes, - any.crypton-connection ==0.4.1, + any.crypton-connection ==0.4.3, any.crypton-x509 ==1.7.7, any.crypton-x509-store ==1.6.9, any.crypton-x509-system ==1.6.7, - any.crypton-x509-validation ==1.6.12, + any.crypton-x509-validation ==1.6.13, any.cryptonite ==0.30, cryptonite -check_alignment +integer-gmp -old_toolchain_inliner +support_aesni +support_deepseq -support_pclmuldq +support_rdrand -support_sse +use_target_attributes, any.cryptonite-conduit ==0.2.2, + any.cvss ==0.2, any.dani-servant-lucid2 ==0.1.0.0, - any.data-default ==0.7.1.1, - any.data-default-class ==0.1.2.0, - any.data-default-instances-containers ==0.0.1, - any.data-default-instances-dlist ==0.0.1, - any.data-default-instances-old-locale ==0.0.1, + any.data-default ==0.7.1.3, + any.data-default-class ==0.1.2.2, + any.data-default-instances-containers ==0.1.0.3, + any.data-default-instances-dlist ==0.0.1.2, + any.data-default-instances-old-locale ==0.0.1.2, any.data-fix ==0.3.4, + any.data-sketches ==0.3.1.0, + any.data-sketches-core ==0.1.0.0, any.dec ==0.0.6, any.deepseq ==1.4.8.1, - any.deriving-aeson ==0.2.9, + any.deriving-aeson ==0.2.10, + any.digest ==0.0.2.1, + digest -have_arm64_crc32c -have_builtin_prefetch -have_mm_prefetch -have_sse42 -have_strong_getauxval -have_weak_getauxval +pkg-config, any.directory ==1.3.8.5, any.distributive ==0.6.2.1, distributive +semigroups +tagged, + any.djot ==0.1.2.2, any.dlist ==1.0, dlist -werror, + any.doclayout ==0.5, + any.doctemplates ==0.11.0.1, any.easy-file ==0.2.5, any.effectful ==2.3.1.0, effectful -benchmark-foreign-libraries, any.effectful-core ==2.3.1.0, + any.effectful-plugin ==1.1.0.4, any.either ==5.0.2, any.emojis ==0.1.4.1, any.entropy ==0.4.1.10, @@ -146,16 +160,18 @@ constraints: any.Cabal ==3.10.3.0, any.exceptions ==0.10.7, any.extensible-exceptions ==0.1.1.4, any.extra ==1.7.16, - any.fast-logger ==3.2.3, + any.fast-logger ==3.2.4, + any.feed ==1.3.2.1, any.file-embed ==0.0.16.0, any.filepath ==1.4.300.1, + any.filtrable ==0.1.6.0, + filtrable +containers, flora -prod, any.foreign-store ==0.2.1, any.free ==5.2, any.friendly-time ==0.4.1, any.fusion-plugin-types ==0.1.0, - any.generic-deriving ==1.14.5, - generic-deriving +base-4-9, + any.generic-deriving ==1.14.6, any.generically ==0.1.1, any.generics-sop ==0.5.1.4, any.ghc ==9.6.6, @@ -165,26 +181,30 @@ constraints: any.Cabal ==3.10.3.0, any.ghc-heap ==9.6.6, any.ghc-prim ==0.10.0, any.ghci ==9.6.6, + any.gridtables ==0.1.0.0, any.haddock-library ==1.11.0, - any.half ==0.3.1, - any.happy ==2.0.2, - any.happy-lib ==2.0.2, + any.half ==0.3.2, + any.happy ==2.1.3, + any.happy-lib ==2.1.3, any.hashable ==1.4.7.0, hashable -arch-native +integer-gmp -random-initial-seed, - any.haskell-lexer ==1.1.1, + any.haskell-lexer ==1.1.2, any.haskell-src-exts ==1.23.1, any.haskell-src-meta ==0.8.14, any.hdaemonize ==0.5.7, - any.heaps ==0.4, + any.heaps ==0.4.1, any.hedgehog ==1.5, any.hostname ==1.0, any.hourglass ==0.2.12, any.hpc ==0.6.2.0, any.hsc2hs ==0.68.10, hsc2hs -in-ghc-tree, - any.hspec ==2.11.9, - any.hspec-core ==2.11.9, - any.hspec-discover ==2.11.9, + any.hsec-core ==0.2.0.1, + any.hsec-sync ==0.2.0.1, + any.hsec-tools ==0.2.0.1, + any.hspec ==2.11.10, + any.hspec-core ==2.11.10, + any.hspec-discover ==2.11.10, any.hspec-expectations ==0.8.4, any.hsyslog ==5.0.2, hsyslog -install-examples, @@ -192,10 +212,10 @@ constraints: any.Cabal ==3.10.3.0, any.htmx-lucid ==0.2.0.1, any.http-api-data ==0.6.1, http-api-data -use-text-show, - any.http-client ==0.7.17, + any.http-client ==0.7.18, http-client +network-uri, - any.http-client-tls ==0.3.6.3, - any.http-conduit ==2.3.9, + any.http-client-tls ==0.3.6.4, + any.http-conduit ==2.3.9.1, http-conduit +aeson, any.http-date ==0.0.11, any.http-media ==0.8.1.1, @@ -210,23 +230,32 @@ constraints: any.Cabal ==3.10.3.0, any.integer-gmp ==1.1, any.integer-logarithms ==1.0.3.1, integer-logarithms -check-bounds +integer-gmp, - any.invariant ==0.6.3, - any.iproute ==1.7.14, + any.invariant ==0.6.4, + any.iproute ==1.7.15, + any.ipynb ==0.2, any.iso8601-time ==0.1.5, iso8601-time +new-time, + any.jira-wiki-markup ==1.5.1, + any.junit-xml ==0.1.0.3, any.kan-extensions ==5.2.6, any.lens ==5.3.2, lens -benchmark-uniplate -dump-splices +inlining -j +test-hunit +test-properties +test-templates +trustworthy, + any.lens-aeson ==1.2.3, any.libsodium-bindings ==0.0.2.0, libsodium-bindings -homebrew -pkg-config, - any.lifted-async ==0.10.2.6, + any.libyaml ==0.1.4, + libyaml -no-unicode -system-libyaml, + any.libyaml-clib ==0.2.5, + any.lifted-async ==0.10.2.7, any.lifted-base ==0.2.3.12, any.lockfree-queue ==0.2.4, any.log-base ==0.12.0.1, - any.log-effectful ==1.0.0.0, + any.log-effectful ==1.0.1.0, any.lucid ==2.11.20230408, any.lucid2 ==0.0.20240424, - any.megaparsec ==9.6.1, + any.math-functions ==0.3.4.4, + math-functions +system-erf +system-expm1, + any.megaparsec ==9.7.0, megaparsec -dev, any.memory ==0.18.0, memory +support_bytestring +support_deepseq, @@ -242,10 +271,12 @@ constraints: any.Cabal ==3.10.3.0, monad-loops +base4, any.monad-time ==0.4.0.0, any.monad-time-effectful ==1.0.0.0, - any.mono-traversable ==1.0.20.0, + any.mono-traversable ==1.0.21.0, any.mtl ==2.3.1, any.mtl-compat ==0.2.2, mtl-compat -two-point-one -two-point-two, + any.mwc-random ==0.15.1.0, + mwc-random -benchpapi, any.natural-arithmetic ==0.2.1.0, any.network ==3.1.4.0, network -devel, @@ -264,11 +295,17 @@ constraints: any.Cabal ==3.10.3.0, any.optics-th ==0.4.1, any.optparse-applicative ==0.18.1.0, optparse-applicative +process, - any.os-string ==2.0.6, + any.ordered-containers ==0.2.4, + any.os-string ==2.0.7, + any.osv ==0.1.0.2, + any.pandoc ==3.6, + pandoc -embed_data_files, + any.pandoc-types ==1.23.1, any.parallel ==3.2.2.0, any.parsec ==3.1.16.1, any.parser-combinators ==1.3.0, parser-combinators -dev, + any.pathwalk ==0.3.1.2, any.pcre2 ==2.2.1, any.pem ==0.2.4, any.pg-entity ==0.0.4.4, @@ -278,6 +315,7 @@ constraints: any.Cabal ==3.10.3.0, any.poolboy ==0.2.2.0, any.postgresql-libpq ==0.11.0.0, postgresql-libpq -use-pkg-config, + any.postgresql-libpq-configure ==0.11, any.postgresql-migration ==0.2.1.8, any.postgresql-simple ==0.7.0.0, any.pretty ==1.1.3.6, @@ -288,19 +326,26 @@ constraints: any.Cabal ==3.10.3.0, any.primitive ==0.9.0.0, any.primitive-addr ==0.1.0.3, any.primitive-offset ==0.2.0.1, - any.primitive-unlifted ==2.1.0.0, + any.primitive-unlifted ==2.2.0.0, any.process ==1.6.19.0, any.profunctors ==5.6.2, + any.prometheus-client ==1.1.1, + any.prometheus-metrics-ghc ==1.0.1.2, + any.prometheus-proc ==0.1.6.0, any.psqueues ==0.2.8.0, any.qrcode-core ==0.9.10, any.qrcode-juicypixels ==0.8.6, any.quickcheck-io ==0.2.0, - any.random ==1.2.1.2, + any.random ==1.2.1.3, any.raven-haskell ==0.1.4.1, raven-haskell -tests, any.recv ==0.1.0, - any.reflection ==2.1.8, + any.reflection ==2.1.9, reflection -slow +template-haskell, + any.regex-applicative ==0.3.4, + any.regex-base ==0.94.0.2, + any.regex-tdfa ==1.3.2.2, + regex-tdfa +doctest -force-o2, any.req ==3.13.4, req -dev, any.resource-pool ==0.4.0.0, @@ -314,6 +359,7 @@ constraints: any.Cabal ==3.10.3.0, any.scientific ==0.3.8.0, scientific -integer-simple, any.sel ==0.0.2.0, + any.selective ==0.7.0.1, any.semialign ==1.3.1, semialign +semigroupoids, any.semigroupoids ==6.0.1, @@ -329,12 +375,21 @@ constraints: any.Cabal ==3.10.3.0, any.servant-effectful ==0.0.1.0, any.servant-lucid ==0.9.0.6, any.servant-openapi3 ==2.0.1.6, + any.servant-prometheus ==1.3.0, any.servant-server ==0.20.2, any.servant-static-th ==1.0.0.1, servant-static-th -buildexample, any.simple-sendfile ==0.2.32, simple-sendfile +allow-bsd -fallback, any.singleton-bool ==0.1.8, + any.skylighting ==0.14.4, + skylighting -executable, + any.skylighting-core ==0.14.4, + skylighting-core -executable, + any.skylighting-format-ansi ==0.1, + any.skylighting-format-blaze-html ==0.1.1.3, + any.skylighting-format-context ==0.1.0.2, + any.skylighting-format-latex ==0.1, any.slugify ==0.1.0.2, any.socks ==0.6.1, any.some ==1.0.6, @@ -342,7 +397,7 @@ constraints: any.Cabal ==3.10.3.0, any.sop-core ==0.5.0.2, any.souffle-haskell ==4.0.0, any.split ==0.2.5, - any.splitmix ==0.1.0.5, + any.splitmix ==0.1.1, splitmix -optimised-mixer, any.stm ==2.5.1.0, any.stm-chans ==3.0.0.9, @@ -357,15 +412,20 @@ constraints: any.Cabal ==3.10.3.0, string-conv -lib-werror, any.string-conversions ==0.4.0.1, any.syb ==0.7.2.4, - any.tagged ==0.8.8, + any.tagged ==0.8.9, tagged +deepseq +transformers, + any.tagsoup ==0.14.8, any.tar ==0.6.3.0, - any.tasty ==1.5, + any.tar-conduit ==0.4.1, + any.tasty ==1.5.2, tasty +unix, any.tasty-hunit ==0.10.2, + any.tasty-test-reporter ==0.1.1.4, any.template-haskell ==2.20.0.0, any.temporary ==1.3, any.terminal-size ==0.3.4, + any.texmath ==0.12.8.12, + texmath -executable -server, any.text ==2.0.2, any.text-conversions ==0.3.1.1, any.text-display ==0.0.5.2, @@ -375,19 +435,23 @@ constraints: any.Cabal ==3.10.3.0, any.text-short ==0.1.6, text-short -asserts, any.tf-random ==0.5, - any.th-abstraction ==0.7.0.0, - any.th-compat ==0.1.5, - any.th-expand-syns ==0.4.11.0, - any.th-lift ==0.8.4, - any.th-orphans ==0.13.14, + any.th-abstraction ==0.7.1.0, + any.th-compat ==0.1.6, + any.th-expand-syns ==0.4.12.0, + any.th-lift ==0.8.6, + any.th-lift-instances ==0.1.20, + any.th-orphans ==0.13.16, any.th-reify-many ==0.1.10, any.these ==1.2.1, any.time ==1.12.2, any.time-compat ==1.9.7, + any.time-locale-compat ==0.1.1.5, + time-locale-compat -old-locale, any.time-manager ==0.0.1, any.timing-convenience ==0.1, - any.tls ==2.1.0, + any.tls ==2.1.5, tls -devel, + any.toml-parser ==2.0.1.0, any.torsor ==0.1.0.1, any.tracing ==1.0.0.0, any.tracing-effectful ==1.0.0.0, @@ -398,14 +462,21 @@ constraints: any.Cabal ==3.10.3.0, transformers-compat -five +five-three -four +generic-deriving +mtl -three -two, any.tuples ==0.1.0.0, any.typed-process ==0.2.12.0, - any.typed-process-effectful ==1.0.0.2, + any.typed-process-effectful ==1.0.0.3, + any.typst ==0.6.1, + typst -executable, + any.typst-symbols ==0.1.7, + any.unicode-collation ==0.1.3.6, + unicode-collation -doctests -executable, any.unicode-data ==0.6.0, unicode-data -dev-has-icu, any.unicode-transforms ==0.4.0.1, unicode-transforms -bench-show -dev -has-icu -has-llvm -use-gauge, + any.uniplate ==1.6.13, any.unix ==2.8.4.0, - any.unix-compat ==0.7.2, - any.unix-time ==0.4.15, + any.unix-compat ==0.7.3, + any.unix-memory ==0.1.2, + any.unix-time ==0.4.16, any.unlifted ==0.2.2.0, any.unliftio ==0.2.25.0, any.unliftio-core ==0.2.1.0, @@ -414,11 +485,12 @@ constraints: any.Cabal ==3.10.3.0, any.utf8-string ==1.0.2, any.uuid ==1.3.16, any.uuid-types ==1.0.6, + any.validation-selective ==0.2.0.0, any.vault ==0.3.1.5, vault +useghc, - any.vector ==0.13.1.0, + any.vector ==0.13.2.0, vector +boundschecks -internalchecks -unsafechecks -wall, - any.vector-algorithms ==0.9.0.2, + any.vector-algorithms ==0.9.0.3, vector-algorithms +bench +boundschecks -internalchecks -llvm +properties -unsafechecks, any.vector-stream ==0.1.0.1, any.void ==0.7.3, @@ -426,21 +498,29 @@ constraints: any.Cabal ==3.10.3.0, any.wai ==3.2.4, any.wai-app-static ==3.1.9, wai-app-static +crypton -print, - any.wai-extra ==3.1.15, + any.wai-extra ==3.1.17, wai-extra -build-example, any.wai-log ==0.4.0.1, any.wai-logger ==2.5.0, any.wai-middleware-heartbeat ==0.0.1.0, + any.wai-middleware-prometheus ==1.0.1.0, any.warp ==3.3.31, warp +allow-sendfilefd -network-bytestring -warp-debug -x509, any.wide-word ==0.1.6.0, any.witherable ==0.5, any.wl-pprint-annotated ==0.1.0.1, any.word8 ==0.1.3, - any.xml-conduit ==1.9.1.3, + any.wreq ==0.5.4.3, + wreq -aws -developer +doctest -httpbin, + any.xml ==1.3.14, + any.xml-conduit ==1.9.1.4, any.xml-conduit-writer ==0.1.1.5, any.xml-types ==0.3.8, + any.yaml ==0.11.11.2, + yaml +no-examples +no-exe, any.zigzag ==0.1.0.0, + any.zip-archive ==0.4.3.2, + zip-archive -executable, any.zlib ==0.7.1.0, zlib -bundled-c-zlib +non-blocking-ffi -pkg-config -index-state: hackage.haskell.org 2024-10-11T12:55:31Z +index-state: hackage.haskell.org 2024-12-19T19:57:30Z diff --git a/cabal.project.repositories b/cabal.project.repositories index d93d1265..8ed16b78 100644 --- a/cabal.project.repositories +++ b/cabal.project.repositories @@ -9,10 +9,10 @@ repository cardano c00aae8461a256275598500ea0e187588c35a5d5d7454fb57eac18d9edb86a56 d4a35cd3121aa00d18544bb0ac01c3e1691d618f462c46129271bccf39f7e8ee -repository horizon - url: https://packages.horizon-haskell.net/ - secure: True - root-keys: - 272e995c7a74de109518100e1422193fe5e5971e52c92b98147c9355b47d7bb6 - ea5c1bc0944dabe64d9d68c6813a8141d747cda042b870576d7af63a2326c31b - eb47482ddf51da1d3610094f5c57a626d42cfd7d9c248f53e23420b02b21c695 +-- repository horizon +-- url: https://packages.horizon-haskell.net/ +-- secure: True +-- root-keys: +-- 272e995c7a74de109518100e1422193fe5e5971e52c92b98147c9355b47d7bb6 +-- ea5c1bc0944dabe64d9d68c6813a8141d747cda042b870576d7af63a2326c31b +-- eb47482ddf51da1d3610094f5c57a626d42cfd7d9c248f53e23420b02b21c695 diff --git a/changelog.d/810 b/changelog.d/810 deleted file mode 100644 index a1b300f5..00000000 --- a/changelog.d/810 +++ /dev/null @@ -1,2 +0,0 @@ -synopsis: Record more route duration metrics with prometheus -prs: #810 diff --git a/environment.sh b/environment.sh index a0935786..082c6794 100755 --- a/environment.sh +++ b/environment.sh @@ -20,7 +20,7 @@ export FLORA_HTTP_PORT=8083 export FLORA_ENVIRONMENT="development" export FLORA_DOMAIN="localhost" -# Either "stdout" or "json" +# Either "stdout", "json" or "json-file" export FLORA_LOGGING_DESTINATION="stdout" # Compatibility mode for Hackage. diff --git a/flora.cabal b/flora.cabal index 498e224c..1044ade8 100644 --- a/flora.cabal +++ b/flora.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: flora -version: 1.0.22 +version: 1.0.23 homepage: https://github.com/flora-pm/flora-server/#readme bug-reports: https://github.com/flora-pm/flora-server/issues author: Théophile Choutri @@ -97,6 +97,7 @@ library Effectful.Poolboy Flora.Environment Flora.Environment.Config + Flora.Environment.Env Flora.Import.Categories Flora.Import.Categories.Tuning Flora.Import.Package @@ -146,6 +147,7 @@ library Flora.Model.User Flora.Model.User.Query Flora.Model.User.Update + Flora.Monitoring Flora.QRCode Flora.Tracing JSON @@ -203,6 +205,7 @@ library , poolboy , postgresql-simple , pretty + , prometheus-client , qrcode-core , qrcode-juicypixels , resource-pool diff --git a/src/core/Flora/Environment.hs b/src/core/Flora/Environment.hs index 3bdda8ed..438e34ec 100644 --- a/src/core/Flora/Environment.hs +++ b/src/core/Flora/Environment.hs @@ -1,58 +1,23 @@ -{-# LANGUAGE PartialTypeSignatures #-} - module Flora.Environment - ( FloraEnv (..) - , DeploymentEnv (..) - , MLTP (..) - , FeatureEnv (..) - , BlobStoreImpl (..) - , TestEnv (..) - , getFloraEnv + ( getFloraEnv , getFloraTestEnv - ) -where + ) where import Colourista.IO (blueMessage) -import Data.Aeson (ToJSON) import Data.ByteString (ByteString) import Data.Pool (Pool) import Data.Pool qualified as Pool import Data.Pool.Introspection (defaultPoolConfig) -import Data.Text import Data.Text.Encoding qualified as Text import Data.Time (NominalDiffTime) -import Data.Word (Word16) import Database.PostgreSQL.Simple qualified as PG import Effectful import Effectful.Fail (Fail) -import Env - ( parse - ) -import Flora.Environment.Config -import GHC.Generics +import Env (parse) --- | The datatype that is used in the application -data FloraEnv = FloraEnv - { pool :: Pool PG.Connection - , dbConfig :: PoolConfig - , jobsPool :: Pool PG.Connection - , httpPort :: Word16 - , domain :: Text - , mltp :: MLTP - , environment :: DeploymentEnv - , features :: FeatureEnv - , config :: FloraConfig - , assets :: Assets - } - deriving stock (Generic) - -data TestEnv = TestEnv - { pool :: Pool PG.Connection - , dbConfig :: PoolConfig - , httpPort :: Word16 - , mltp :: MLTP - } - deriving stock (Generic) +import Flora.Environment.Config +import Flora.Environment.Env +import Flora.Monitoring mkPool :: IOE :> es @@ -69,16 +34,6 @@ mkPool connectionInfo timeout' connections = (realToFrac timeout') connections -data BlobStoreImpl = BlobStoreFS FilePath | BlobStorePure - deriving stock (Generic, Show) - -instance ToJSON BlobStoreImpl - -newtype FeatureEnv = FeatureEnv {blobStoreImpl :: Maybe BlobStoreImpl} - deriving stock (Generic, Show) - -instance ToJSON FeatureEnv - -- In future we'll want to error for conflicting o ptions featureConfigToEnv :: FeatureConfig -> Eff es FeatureEnv featureConfigToEnv FeatureConfig{..} = @@ -94,8 +49,8 @@ configToEnv floraConfig = do pool <- mkPool floraConfig.connectionInfo connectionTimeout connections jobsPool <- mkPool floraConfig.connectionInfo connectionTimeout connections assets <- getAssets floraConfig.environment - liftIO $ print assets featureEnv <- featureConfigToEnv floraConfig.features + metrics <- registerMetrics pure FloraEnv { pool = pool @@ -108,12 +63,14 @@ configToEnv floraConfig = do , features = featureEnv , assets = assets , config = floraConfig + , metrics = metrics } testConfigToTestEnv :: TestConfig -> Eff '[IOE] TestEnv testConfigToTestEnv config@TestConfig{..} = do let PoolConfig{..} = config.dbConfig pool <- mkPool connectionInfo connectionTimeout connections + metrics <- registerMetrics pure TestEnv{..} getFloraEnv :: Eff '[Fail, IOE] FloraEnv diff --git a/src/core/Flora/Environment/Env.hs b/src/core/Flora/Environment/Env.hs new file mode 100644 index 00000000..104bea25 --- /dev/null +++ b/src/core/Flora/Environment/Env.hs @@ -0,0 +1,57 @@ +module Flora.Environment.Env + ( FloraEnv (..) + , Metrics (..) + , DeploymentEnv (..) + , MLTP (..) + , FeatureEnv (..) + , BlobStoreImpl (..) + , TestEnv (..) + ) where + +import Data.Aeson +import Data.Pool (Pool) +import Data.Text (Text) +import Data.Word +import Database.PostgreSQL.Simple qualified as PG +import Flora.Environment.Config +import GHC.Generics +import Prometheus qualified as P + +-- | The datatype that is used in the application +data FloraEnv = FloraEnv + { pool :: Pool PG.Connection + , dbConfig :: PoolConfig + , jobsPool :: Pool PG.Connection + , httpPort :: Word16 + , domain :: Text + , mltp :: MLTP + , environment :: DeploymentEnv + , features :: FeatureEnv + , config :: FloraConfig + , assets :: Assets + , metrics :: Metrics + } + deriving stock (Generic) + +data Metrics = Metrics + { packageImportCounter :: P.Vector P.Label1 P.Counter + } + +data TestEnv = TestEnv + { pool :: Pool PG.Connection + , dbConfig :: PoolConfig + , httpPort :: Word16 + , mltp :: MLTP + , metrics :: Metrics + } + deriving stock (Generic) + +data BlobStoreImpl = BlobStoreFS FilePath | BlobStorePure + deriving stock (Generic, Show) + +instance ToJSON BlobStoreImpl + +newtype FeatureEnv = FeatureEnv {blobStoreImpl :: Maybe BlobStoreImpl} + deriving stock (Generic, Show) + +instance ToJSON FeatureEnv diff --git a/src/core/Flora/Import/Package.hs b/src/core/Flora/Import/Package.hs index a3e03a25..1f38504b 100644 --- a/src/core/Flora/Import/Package.hs +++ b/src/core/Flora/Import/Package.hs @@ -150,9 +150,15 @@ coreLibraries = versionList :: Set Version versionList = Set.fromList - [ Version.mkVersion [9, 10, 1] + [ Version.mkVersion [9, 12, 1] + , Version.mkVersion [9, 10, 2] + , Version.mkVersion [9, 10, 1] + , Version.mkVersion [9, 8, 4] + , Version.mkVersion [9, 8, 3] , Version.mkVersion [9, 8, 2] , Version.mkVersion [9, 8, 1] + , Version.mkVersion [9, 6, 7] + , Version.mkVersion [9, 6, 6] , Version.mkVersion [9, 6, 5] , Version.mkVersion [9, 6, 4] , Version.mkVersion [9, 6, 3] diff --git a/src/core/Flora/Import/Package/Bulk.hs b/src/core/Flora/Import/Package/Bulk.hs index a61f1f91..ebcd9a67 100644 --- a/src/core/Flora/Import/Package/Bulk.hs +++ b/src/core/Flora/Import/Package/Bulk.hs @@ -25,6 +25,7 @@ import Data.Text (Text) import Data.Text qualified as Text import Data.Time (UTCTime) import Data.Time.Clock.POSIX (posixSecondsToUTCTime) +import Distribution.Types.Version (Version) import Effectful import Effectful.FileSystem (FileSystem) import Effectful.FileSystem qualified as FileSystem @@ -33,9 +34,11 @@ import Effectful.Log (Log) import Effectful.Log qualified as Log import Effectful.Poolboy import Effectful.PostgreSQL.Transact.Effect (DB) +import Effectful.Reader.Static (Reader) import Effectful.State.Static.Shared (State) import Effectful.Time (Time) import GHC.Conc (numCapabilities) +import GHC.Records import Streamly.Data.Fold qualified as SFold import Streamly.Data.Stream (Stream) import Streamly.Data.Stream.Prelude (maxThreads, ordered) @@ -45,7 +48,7 @@ import System.Directory qualified as System import System.FilePath import UnliftIO.Exception (finally) -import Distribution.Types.Version (Version) +import Flora.Environment.Env import Flora.Import.Package ( extractPackageDataFromCabal , loadContent @@ -60,6 +63,7 @@ import Flora.Model.PackageIndex.Update qualified as Update import Flora.Model.Release.Query qualified as Query import Flora.Model.Release.Update qualified as Update import Flora.Model.User +import Flora.Monitoring -- | Same as 'importAllFilesInDirectory' but accepts a relative path to the current working directory importAllFilesInRelativeDirectory @@ -70,6 +74,9 @@ importAllFilesInRelativeDirectory , IOE :> es , Poolboy :> es , State (Set (Namespace, PackageName, Version)) :> es + , Reader r :> es + , HasField "metrics" r Metrics + , HasField "mltp" r MLTP ) => UserId -> (Text, Text) @@ -86,6 +93,9 @@ importFromIndex , DB :> es , IOE :> es , State (Set (Namespace, PackageName, Version)) :> es + , Reader r :> es + , HasField "metrics" r Metrics + , HasField "mltp" r MLTP ) => UserId -> Text @@ -142,6 +152,9 @@ importAllFilesInDirectory , IOE :> es , Poolboy :> es , State (Set (Namespace, PackageName, Version)) :> es + , Reader r :> es + , HasField "metrics" r Metrics + , HasField "mltp" r MLTP ) => UserId -> (Text, Text) @@ -154,13 +167,16 @@ importAllFilesInDirectory user (repositoryName, _repositoryURL) dir = do importFromStream user (repositoryName, packages) (findAllCabalFilesInDirectory dir) importFromStream - :: forall es + :: forall es r . ( Time :> es , Log :> es , DB :> es , IOE :> es , Poolboy :> es , State (Set (Namespace, PackageName, Version)) :> es + , Reader r :> es + , HasField "metrics" r Metrics + , HasField "mltp" r MLTP ) => UserId -> (Text, Set PackageName) @@ -182,16 +198,18 @@ importFromStream userId repository@(repositoryName, _) stream = do Update.updatePackageIndexByName repositoryName timestamp ) displayStats processedPackageCount + increasePackageImportCounterBy + (fromIntegral @Int @Double processedPackageCount) + repositoryName where displayCount :: SFold.Fold (Eff es) a Int displayCount = flip SFold.foldlM' (pure 0) $ - \previousCount _ -> + \previousCount _ -> do let currentCount = previousCount + 1 - in do - when (currentCount `mod` 400 == 0) $ - displayStats currentCount - pure currentCount + batchAmount = 400 + when (currentCount `mod` batchAmount == 0) $ displayStats currentCount + pure currentCount displayStats :: IOE :> es diff --git a/src/core/Flora/Model/Job.hs b/src/core/Flora/Model/Job.hs index 969d6693..7c5a279b 100644 --- a/src/core/Flora/Model/Job.hs +++ b/src/core/Flora/Model/Job.hs @@ -86,7 +86,7 @@ data FloraOddJobs | FetchPackageDeprecationList | FetchReleaseDeprecationList PackageName (Vector ReleaseId) | RefreshLatestVersions - | RefreshIndexes + | RefreshIndex Text deriving stock (Generic) -- TODO: Upstream these two ToJSON instances @@ -106,4 +106,5 @@ instance ToJSON LogEvent where LogWebUIRequest -> toJSON ("web-ui-request" :: Text) LogKillJobSuccess job -> toJSON ("kill-success" :: Text, job) LogKillJobFailed job -> toJSON ("kill-failed" :: Text, job) + LogDeletionPoll data_ -> toJSON ("log-deletion-poll" :: Text, data_) LogText other -> toJSON ("other" :: Text, other) diff --git a/src/core/Flora/Model/PackageIndex/Query.hs b/src/core/Flora/Model/PackageIndex/Query.hs index e8d34fd4..b9c1f30e 100644 --- a/src/core/Flora/Model/PackageIndex/Query.hs +++ b/src/core/Flora/Model/PackageIndex/Query.hs @@ -4,7 +4,9 @@ module Flora.Model.PackageIndex.Query where import Data.Text (Text) -import Database.PostgreSQL.Entity (selectOneByField) +import Data.Vector (Vector) +import Data.Vector qualified as Vector +import Database.PostgreSQL.Entity import Database.PostgreSQL.Entity.Types import Database.PostgreSQL.Simple (Only (..)) import Effectful @@ -19,3 +21,9 @@ getPackageIndexByName repository = r -> r in dbtToEff $ selectOneByField [field| repository |] (Only index) + +listPackageIndexes :: DB :> es => Eff es (Vector PackageIndex) +listPackageIndexes = + dbtToEff $ + selectOrderBy @PackageIndex $ + Vector.fromList [([field| repository |], ASC)] diff --git a/src/core/Flora/Monitoring.hs b/src/core/Flora/Monitoring.hs new file mode 100644 index 00000000..d2285d14 --- /dev/null +++ b/src/core/Flora/Monitoring.hs @@ -0,0 +1,88 @@ +module Flora.Monitoring + ( increaseCounter + , increasePackageImportCounter + , registerMetrics + , increaseCounterBy + , increasePackageImportCounterBy + ) where + +import Control.Monad (void, when) +import Data.Text +import Effectful +import Effectful.Reader.Static (Reader, ask) +import GHC.Records +import Prometheus +import Prometheus qualified as P + +import Flora.Environment.Env + +registerMetrics :: IOE :> es => Eff es Metrics +registerMetrics = do + let packageImportCount = + P.vector "package_index" $ + P.counter + P.Info + { metricName = "flora_packages_imported_total" + , metricHelp = "Packages imported and their index" + } + packageImportCounter <- P.register packageImportCount + pure Metrics{..} + +increaseCounter + :: forall r es label + . ( HasField "mltp" r MLTP + , Reader r :> es + , Label label + , IOE :> es + ) + => Vector label Counter + -> label + -> Eff es () +increaseCounter promVector label = do + env <- ask + let mltpConf = env.mltp + when mltpConf.prometheusEnabled $ + liftIO $ + withLabel promVector label incCounter + +increaseCounterBy + :: ( HasField "mltp" r MLTP + , Reader r :> es + , Label label + , IOE :> es + ) + => Double + -> Vector label Counter + -> label + -> Eff es () +increaseCounterBy value promVector label = do + env <- ask + let mltpConf = env.mltp + when mltpConf.prometheusEnabled $ + liftIO $ + withLabel promVector label (\c -> void $ addCounter c value) + +increasePackageImportCounter + :: ( HasField "metrics" r Metrics + , HasField "mltp" r MLTP + , Reader r :> es + , IOE :> es + ) + => Text + -> Eff es () +increasePackageImportCounter repository = do + env <- ask + increaseCounter env.metrics.packageImportCounter repository + +increasePackageImportCounterBy + :: ( HasField "metrics" r Metrics + , HasField "mltp" r MLTP + , Reader r :> es + , IOE :> es + ) + => Double + -> Text + -> Eff es () +increasePackageImportCounterBy value repository = do + env <- ask + increaseCounterBy value env.metrics.packageImportCounter repository diff --git a/src/jobs-worker/FloraJobs/Runner.hs b/src/jobs-worker/FloraJobs/Runner.hs index 9c039e0e..81decad6 100644 --- a/src/jobs-worker/FloraJobs/Runner.hs +++ b/src/jobs-worker/FloraJobs/Runner.hs @@ -6,11 +6,14 @@ import Control.Monad.IO.Class import Data.Aeson (Result (..), fromJSON, toJSON) import Data.Function import Data.Maybe (fromJust) +import Data.Set (Set) import Data.Set qualified as Set import Data.Text qualified as Text import Data.Text.Display +import Data.Text.HTML qualified as HTML import Data.Vector (Vector) import Data.Vector qualified as Vector +import Distribution.Types.Version (Version) import Effectful (Eff, IOE, type (:>)) import Effectful.FileSystem (FileSystem) import Effectful.FileSystem qualified as FileSystem @@ -19,6 +22,7 @@ import Effectful.Poolboy (Poolboy) import Effectful.PostgreSQL.Transact.Effect (DB) import Effectful.Process.Typed import Effectful.Reader.Static (Reader) +import Effectful.State.Static.Shared (State) import Effectful.Time (Time) import Log import Network.HTTP.Types (gone410, notFound404, statusCode) @@ -26,10 +30,8 @@ import OddJobs.Job (Job (..)) import Servant.Client (ClientError (..)) import Servant.Client.Core (ResponseF (..)) -import Data.Set (Set) -import Data.Text.HTML qualified as HTML -import Distribution.Types.Version (Version) -import Effectful.State.Static.Shared (State) +import Data.Text +import Flora.Environment.Env import Flora.Import.Package (coreLibraries, persistImportOutput) import Flora.Import.Package.Bulk qualified as Import import Flora.Model.BlobIndex.Update qualified as Update @@ -61,14 +63,11 @@ runner job = localDomain "job-runner" $ FetchTarball x -> fetchTarball x FetchUploadTime x -> fetchUploadTime x FetchChangelog x -> fetchChangeLog x - ImportPackage x -> - persistImportOutput x + ImportPackage x -> persistImportOutput x FetchPackageDeprecationList -> fetchPackageDeprecationList - FetchReleaseDeprecationList packageName releases -> - fetchReleaseDeprecationList packageName releases - RefreshLatestVersions -> - Update.refreshLatestVersions - RefreshIndexes -> refreshIndexes + FetchReleaseDeprecationList packageName releases -> fetchReleaseDeprecationList packageName releases + RefreshLatestVersions -> Update.refreshLatestVersions + RefreshIndex indexName -> refreshIndex indexName fetchChangeLog :: ChangelogJobPayload -> JobsRunner () fetchChangeLog payload@ChangelogJobPayload{packageName, packageVersion, releaseId} = @@ -222,33 +221,33 @@ assignNamespace = else PackageAlternative (Namespace "hackage") p ) -refreshIndexes +refreshIndex :: ( Time :> es , DB :> es - , TypedProcess :> es , Log :> es , Poolboy :> es + , TypedProcess :> es , IOE :> es , FileSystem :> es , State (Set (Namespace, PackageName, Version)) :> es + , Reader FloraEnv :> es ) - => Eff es () -refreshIndexes = do + => Text + -> Eff es () +refreshIndex indexName = do + let repoPath = + if indexName == "hackage" + then "hackage.haskell.org" + else Text.unpack indexName runProcess_ $ shell "cabal update --project-file cabal.project.repositories" - let packageIndexes = - [ ("hackage", "hackage.haskell.org") - , ("cardano", "cardano") - , ("horizon", "horizon") - ] user <- fromJust <$> Query.getUserByUsername "hackage-user" - forM_ packageIndexes $ \(indexName, repoPath) -> do - homeDir <- FileSystem.getHomeDirectory - let path = homeDir <> "/.cabal/packages/" <> repoPath <> "/01-index.tar.gz" - mPackageIndex <- Query.getPackageIndexByName indexName - case mPackageIndex of - Nothing -> do - Log.logAttention "Package index not found" $ - object ["package_index" .= indexName] - error $ Text.unpack $ "Package index " <> indexName <> " not found in the database!" - Just _ -> - Import.importFromIndex user.userId indexName path + homeDir <- FileSystem.getHomeDirectory + let path = homeDir <> "/.cabal/packages/" <> repoPath <> "/01-index.tar.gz" + mPackageIndex <- Query.getPackageIndexByName indexName + case mPackageIndex of + Nothing -> do + Log.logAttention "Package index not found" $ + object ["package_index" .= indexName] + error $ Text.unpack $ "Package index " <> indexName <> " not found in the database!" + Just _ -> + Import.importFromIndex user.userId indexName path diff --git a/src/jobs-worker/FloraJobs/Scheduler.hs b/src/jobs-worker/FloraJobs/Scheduler.hs index e88d218a..435635f7 100644 --- a/src/jobs-worker/FloraJobs/Scheduler.hs +++ b/src/jobs-worker/FloraJobs/Scheduler.hs @@ -9,7 +9,7 @@ module FloraJobs.Scheduler , schedulePackageDeprecationListJob , scheduleReleaseDeprecationListJob , scheduleRefreshLatestVersions - , scheduleRefreshIndexes + , scheduleRefreshIndex , checkIfIndexRefreshJobIsPlanned , jobTableName -- prefer using smart constructors. @@ -19,12 +19,14 @@ module FloraJobs.Scheduler ) where +import Control.Monad import Data.Aeson (ToJSON) import Data.Pool +import Data.Text (Text) import Data.Time qualified as Time import Data.Vector (Vector) +import Data.Vector qualified as Vector import Database.PostgreSQL.Entity.DBT -import Database.PostgreSQL.Simple (Only (..)) import Database.PostgreSQL.Simple qualified as PG import Database.PostgreSQL.Simple.SqlQQ (sql) import Distribution.Types.Version @@ -34,8 +36,11 @@ import Effectful.PostgreSQL.Transact.Effect import Log import OddJobs.Job (Job (..), createJob, scheduleJob) +import Database.PostgreSQL.Simple.Types import Flora.Model.Job import Flora.Model.Package +import Flora.Model.PackageIndex.Query qualified as Query +import Flora.Model.PackageIndex.Types import Flora.Model.Release.Types import FloraJobs.Types @@ -76,10 +81,10 @@ scheduleReleaseDeprecationListJob pool (package, releaseIds) = scheduleRefreshLatestVersions :: Pool PG.Connection -> IO Job scheduleRefreshLatestVersions pool = createJobWithResource pool RefreshLatestVersions -scheduleRefreshIndexes :: Pool PG.Connection -> IO Job -scheduleRefreshIndexes pool = withResource pool $ \conn -> do +scheduleRefreshIndex :: Pool PG.Connection -> Text -> IO Job +scheduleRefreshIndex pool indexName = withResource pool $ \conn -> do now <- Time.getCurrentTime - scheduleJob conn jobTableName RefreshIndexes (Time.addUTCTime Time.nominalDay now) + scheduleJob conn jobTableName (RefreshIndex indexName) (Time.addUTCTime Time.nominalDay now) createJobWithResource :: ToJSON p => Pool PG.Connection -> p -> IO Job createJobWithResource pool job = @@ -88,24 +93,25 @@ createJobWithResource pool job = checkIfIndexRefreshJobIsPlanned :: ( DB :> es , Log :> es + , IOE :> es ) - => Eff es Bool -checkIfIndexRefreshJobIsPlanned = do + => Pool PG.Connection + -> Eff es () +checkIfIndexRefreshJobIsPlanned pool = do Log.logInfo_ "Checking if the index refresh job is planned…" - (result :: Maybe (Only Int)) <- + indexes <- Query.listPackageIndexes + (result' :: Vector (Only Text)) <- dbtToEff $ - queryOne_ + query_ Select [sql| - select count(*) - from "oddjobs" - where payload ->> 'tag' = 'RefreshIndexes' - and status = 'queued' - |] - case result of - Just (Only 1) -> do - Log.logInfo_ "Index refresh job is planned" - pure True - _ -> do - Log.logInfo_ "Index refresh job not not planned" - pure False + select payload ->> 'contents' + from "oddjobs" + where payload ->> 'tag' = 'RefreshIndex' + and status = 'queued' + |] + let result = fmap fromOnly result' + forM_ indexes $ \index -> + when (Vector.notElem index.repository result) $ do + Log.logInfo "Scheduling index refresh" $ object ["index" .= index.repository] + void $ liftIO $ scheduleRefreshIndex pool index.repository diff --git a/src/jobs-worker/FloraJobs/Types.hs b/src/jobs-worker/FloraJobs/Types.hs index d4b97efe..6af52599 100644 --- a/src/jobs-worker/FloraJobs/Types.hs +++ b/src/jobs-worker/FloraJobs/Types.hs @@ -15,13 +15,15 @@ import Database.PostgreSQL.Simple qualified as PG import Database.PostgreSQL.Simple.Types (QualifiedIdentifier) import Distribution.Types.Version (Version) import Effectful +import Effectful.Concurrent.Async import Effectful.FileSystem import Effectful.Log hiding (LogLevel) import Effectful.Log qualified as LogEff hiding (LogLevel) import Effectful.Poolboy import Effectful.PostgreSQL.Transact.Effect (DB, runDB) import Effectful.Process.Typed -import Effectful.Reader.Static (Reader, runReader) +import Effectful.Reader.Static (Reader) +import Effectful.Reader.Static qualified as Reader import Effectful.State.Static.Shared (State) import Effectful.State.Static.Shared qualified as State import Effectful.Time (Time, runTime) @@ -34,8 +36,8 @@ import OddJobs.Job (Config (..), Job, LogEvent (..), LogLevel (..)) import OddJobs.Types (ConcurrencyControl (..), UIConfig (..)) import Data.Set (Set) -import Flora.Environment import Flora.Environment.Config +import Flora.Environment.Env import Flora.Logging qualified as Logging import Flora.Model.BlobStore.API import Flora.Model.Job () @@ -52,16 +54,24 @@ type JobsRunner = , TypedProcess , FileSystem , State (Set (Namespace, PackageName, Version)) + , Reader FloraEnv + , Concurrent , IOE ] -runJobRunner :: Pool Connection -> JobsRunnerEnv -> FloraEnv -> Logger -> JobsRunner a -> IO a +runJobRunner + :: Pool Connection + -> JobsRunnerEnv + -> FloraEnv + -> Logger + -> JobsRunner a + -> IO a runJobRunner pool runnerEnv floraEnv logger jobRunner = jobRunner & withUnliftStrategy (ConcUnlift Ephemeral Unlimited) & runDB pool & runPoolboy (poolboySettingsWith floraEnv.dbConfig.connections) - & runReader runnerEnv + & Reader.runReader runnerEnv & ( case floraEnv.features.blobStoreImpl of Just (BlobStoreFS fp) -> runBlobStoreFS fp _ -> runBlobStorePure @@ -71,6 +81,8 @@ runJobRunner pool runnerEnv floraEnv logger jobRunner = & runTypedProcess & runFileSystem & State.evalState mempty + & Reader.runReader floraEnv + & runConcurrent & runEff data OddJobException where diff --git a/src/web/FloraWeb/Common/Auth.hs b/src/web/FloraWeb/Common/Auth.hs index 329ff7a1..40804e7e 100644 --- a/src/web/FloraWeb/Common/Auth.hs +++ b/src/web/FloraWeb/Common/Auth.hs @@ -8,11 +8,16 @@ module FloraWeb.Common.Auth ) where +import Control.Monad.Except qualified as T import Data.Function ((&)) +import Data.Kind (Type) import Data.List qualified as List import Data.Text (Text) +import Data.Text.Encoding qualified as Text import Data.UUID qualified as UUID +import Data.UUID.V4 qualified as UUID import Effectful +import Effectful.Dispatch.Static import Effectful.Error.Static (Error, runErrorNoCallStack, throwError) import Effectful.PostgreSQL.Transact.Effect (DB) import Effectful.PostgreSQL.Transact.Effect qualified as DB @@ -24,12 +29,7 @@ import Servant.Server import Servant.Server.Experimental.Auth (AuthHandler, mkAuthHandler) import Web.Cookie -import Control.Monad.Except qualified as T -import Data.Kind (Type) -import Data.Text.Encoding qualified as Text -import Data.UUID.V4 qualified as UUID -import Effectful.Dispatch.Static -import Flora.Environment +import Flora.Environment.Env import Flora.Logging qualified as Logging import Flora.Model.PersistentSession import Flora.Model.User diff --git a/src/web/FloraWeb/Common/Tracing.hs b/src/web/FloraWeb/Common/Tracing.hs index ba11fd8d..22aeecb5 100644 --- a/src/web/FloraWeb/Common/Tracing.hs +++ b/src/web/FloraWeb/Common/Tracing.hs @@ -16,7 +16,7 @@ import System.Log.Raven (initRaven, register, silentFallback) import System.Log.Raven.Transport.HttpConduit (sendRecord) import System.Log.Raven.Types (SentryLevel (Error), SentryRecord (..)) -import Flora.Environment +import Flora.Environment.Env onException :: Logger -> DeploymentEnv -> MLTP -> Maybe Request -> SomeException -> IO () onException logger environment mltp mRequest exception = diff --git a/src/web/FloraWeb/LiveReload.hs b/src/web/FloraWeb/LiveReload.hs index b9dcd10a..6dd7ae0a 100644 --- a/src/web/FloraWeb/LiveReload.hs +++ b/src/web/FloraWeb/LiveReload.hs @@ -1,12 +1,12 @@ module FloraWeb.LiveReload where import Data.IORef +import Data.Text (Text) import Effectful +import Servant.API (Header, Headers, NoContent (..)) -import Data.Text (Text) -import Flora.Environment (DeploymentEnv (..)) +import Flora.Environment.Env (DeploymentEnv (..)) import FloraWeb.Common.Utils -import Servant.API (Header, Headers, NoContent (..)) livereloadHandler :: IOE :> es diff --git a/src/web/FloraWeb/Pages/Server/Admin.hs b/src/web/FloraWeb/Pages/Server/Admin.hs index f5baacdf..0d8e6ecb 100644 --- a/src/web/FloraWeb/Pages/Server/Admin.hs +++ b/src/web/FloraWeb/Pages/Server/Admin.hs @@ -16,7 +16,7 @@ import OddJobs.Types qualified as OddJobs import Optics.Core import Servant (HasServer (..), Headers (..)) -import Flora.Environment (FeatureEnv (..), FloraEnv (..)) +import Flora.Environment.Env (FeatureEnv (..), FloraEnv (..)) import Flora.Model.Admin.Report import Flora.Model.Release.Query qualified as Query import Flora.Model.User @@ -24,7 +24,13 @@ import FloraJobs.Scheduler import FloraWeb.Common.Auth import FloraWeb.Common.Utils (handlerToEff, redirect) import FloraWeb.Pages.Routes.Admin -import FloraWeb.Pages.Templates (ActiveElements (..), TemplateEnv (..), defaultTemplateEnv, render, templateFromSession) +import FloraWeb.Pages.Templates + ( ActiveElements (..) + , TemplateEnv (..) + , defaultTemplateEnv + , render + , templateFromSession + ) import FloraWeb.Pages.Templates.Admin qualified as Templates import FloraWeb.Types (FloraEff, fetchFloraEnv) diff --git a/src/web/FloraWeb/Pages/Server/Categories.hs b/src/web/FloraWeb/Pages/Server/Categories.hs index adb92f92..f291fffe 100644 --- a/src/web/FloraWeb/Pages/Server/Categories.hs +++ b/src/web/FloraWeb/Pages/Server/Categories.hs @@ -2,14 +2,14 @@ module FloraWeb.Pages.Server.Categories where import Data.Text (Text) import Effectful (Eff, IOE, (:>)) +import Effectful.Error.Static (Error) +import Effectful.PostgreSQL.Transact.Effect (DB) +import Effectful.Reader.Static (Reader) import Lucid (Html) import Network.HTTP.Types (notFound404) import Servant (Headers (..), ServerError, ServerT) -import Effectful.Error.Static (Error) -import Effectful.PostgreSQL.Transact.Effect (DB) -import Effectful.Reader.Static (Reader) -import Flora.Environment (FeatureEnv) +import Flora.Environment.Env (FeatureEnv) import Flora.Model.Category.Query qualified as Query import Flora.Model.Category.Types (Category (..)) import Flora.Model.Package.Query qualified as Query diff --git a/src/web/FloraWeb/Pages/Server/Packages.hs b/src/web/FloraWeb/Pages/Server/Packages.hs index 43e93db9..203f2aa4 100644 --- a/src/web/FloraWeb/Pages/Server/Packages.hs +++ b/src/web/FloraWeb/Pages/Server/Packages.hs @@ -33,7 +33,7 @@ import Servant.Server (err404) import Advisories.Model.Affected.Query qualified as Query import Advisories.Model.Affected.Types -import Flora.Environment (FeatureEnv (..)) +import Flora.Environment.Env (FeatureEnv (..)) import Flora.Model.BlobIndex.Query qualified as Query import Flora.Model.BlobStore.API (BlobStoreAPI) import Flora.Model.Package diff --git a/src/web/FloraWeb/Pages/Server/Settings.hs b/src/web/FloraWeb/Pages/Server/Settings.hs index 7f1ebcc3..f880de62 100644 --- a/src/web/FloraWeb/Pages/Server/Settings.hs +++ b/src/web/FloraWeb/Pages/Server/Settings.hs @@ -7,17 +7,17 @@ import Control.Monad.IO.Class import Data.ByteString.Base32 qualified as Base32 import Data.Text.Encoding qualified as Text import Effectful (Eff, IOE, (:>)) +import Effectful.Log (Log) +import Effectful.PostgreSQL.Transact.Effect (DB) import Effectful.Reader.Static (Reader) +import Effectful.Time (Time) import Log qualified import Lucid import Optics.Core import Sel.HMAC.SHA256 qualified as HMAC import Servant (HasServer (..), Headers (..), Union, WithStatus (..), respond) -import Effectful.Log (Log) -import Effectful.PostgreSQL.Transact.Effect (DB) -import Effectful.Time (Time) -import Flora.Environment +import Flora.Environment.Env import Flora.Model.User import Flora.Model.User.Update qualified as Update import Flora.QRCode qualified as QRCode diff --git a/src/web/FloraWeb/Pages/Templates.hs b/src/web/FloraWeb/Pages/Templates.hs index 0e75cf1b..d1b1867e 100644 --- a/src/web/FloraWeb/Pages/Templates.hs +++ b/src/web/FloraWeb/Pages/Templates.hs @@ -13,7 +13,7 @@ import Data.ByteString.Lazy import Data.Text.Display import Lucid -import Flora.Environment (DeploymentEnv (..)) +import Flora.Environment.Env (DeploymentEnv (..)) import FloraWeb.Components.Alert qualified as Alert import FloraWeb.Components.Header (header) import FloraWeb.Pages.Templates.Types as Types diff --git a/src/web/FloraWeb/Pages/Templates/Error.hs b/src/web/FloraWeb/Pages/Templates/Error.hs index 47ddd07f..d24ea97f 100644 --- a/src/web/FloraWeb/Pages/Templates/Error.hs +++ b/src/web/FloraWeb/Pages/Templates/Error.hs @@ -13,7 +13,7 @@ import Data.Kind (Type) import Effectful import Effectful.Error.Static (Error, throwError) import Effectful.Reader.Static (Reader) -import Flora.Environment (FeatureEnv) +import Flora.Environment.Env (FeatureEnv) import Flora.Model.User (User) import FloraWeb.Pages.Templates import FloraWeb.Session diff --git a/src/web/FloraWeb/Pages/Templates/Packages.hs b/src/web/FloraWeb/Pages/Templates/Packages.hs index b80036e8..5d4b5f18 100644 --- a/src/web/FloraWeb/Pages/Templates/Packages.hs +++ b/src/web/FloraWeb/Pages/Templates/Packages.hs @@ -56,7 +56,7 @@ import Text.PrettyPrint (Doc, hcat, render) import Text.PrettyPrint qualified as PP import Advisories.Model.Affected.Types -import Flora.Environment (FeatureEnv (..)) +import Flora.Environment.Env (FeatureEnv (..)) import Flora.Model.Category.Types import Flora.Model.Package import Flora.Model.Release.Types diff --git a/src/web/FloraWeb/Pages/Templates/Screens/Home.hs b/src/web/FloraWeb/Pages/Templates/Screens/Home.hs index aac9ad09..44f0e449 100644 --- a/src/web/FloraWeb/Pages/Templates/Screens/Home.hs +++ b/src/web/FloraWeb/Pages/Templates/Screens/Home.hs @@ -8,7 +8,7 @@ import Data.Text (Text) import Lucid import PyF -import Flora.Environment +import Flora.Environment.Env import FloraWeb.Components.MainSearchBar (mainSearchBar) import FloraWeb.Pages.Templates.Types diff --git a/src/web/FloraWeb/Pages/Templates/Types.hs b/src/web/FloraWeb/Pages/Templates/Types.hs index e71d91d2..8158f87b 100644 --- a/src/web/FloraWeb/Pages/Templates/Types.hs +++ b/src/web/FloraWeb/Pages/Templates/Types.hs @@ -15,16 +15,16 @@ where import Control.Monad.Identity import Control.Monad.Reader (ReaderT) import Data.Text (Text) +import Data.Text.Display import Data.UUID qualified as UUID +import Effectful +import Effectful.Reader.Static (Reader, ask) import GHC.Generics import Lucid import Optics.Core -import Data.Text.Display -import Effectful -import Effectful.Reader.Static (Reader, ask) -import Flora.Environment import Flora.Environment.Config (Assets) +import Flora.Environment.Env import Flora.Model.PersistentSession (PersistentSessionId (..)) import Flora.Model.User import FloraWeb.Common.Auth diff --git a/src/web/FloraWeb/Server.hs b/src/web/FloraWeb/Server.hs index 18b2084d..6b9374ea 100644 --- a/src/web/FloraWeb/Server.hs +++ b/src/web/FloraWeb/Server.hs @@ -60,15 +60,14 @@ import Servant import Servant.OpenApi import Servant.Server.Generic (AsServerT) -import Flora.Environment +import Flora.Environment (getFloraEnv) +import Flora.Environment.Config (Assets, DeploymentEnv (..)) +import Flora.Environment.Env ( BlobStoreImpl (..) - , DeploymentEnv , FeatureEnv (..) , FloraEnv (..) , MLTP (..) - , getFloraEnv ) -import Flora.Environment.Config (Assets, DeploymentEnv (..)) import Flora.Logging qualified as Logging import Flora.Model.BlobStore.API import Flora.Tracing qualified as Tracing @@ -115,6 +114,7 @@ runFlora = blueMessage $ "🔥 Exposing Prometheus metrics at " <> baseURL <> "/metrics" void $ P.register P.ghcMetrics void $ P.register P.procMetrics + void $ P.register (P.counter (P.Info "flora_imported_packages_total" "The number of imported packages")) liftIO $ when env.mltp.zipkinEnabled (blueMessage "🖊️ Connecting to Zipkin endpoint") liftIO $ when (env.environment == Development) (blueMessage "🔁 Live reloading enabled") let withLogger = Logging.makeLogger env.mltp.logger @@ -159,6 +159,10 @@ runServer appLogger floraEnv = do unsafeEff_ $ Safe.withException (startJobRunner oddJobsCfg) (logException floraEnv.environment appLogger) loggingMiddleware <- Logging.runLog floraEnv.environment appLogger WaiLog.mkLogMiddleware + let prometheusMiddleware = + if floraEnv.mltp.prometheusEnabled + then WaiMetrics.prometheus WaiMetrics.def + else id oddJobsEnv <- OddJobs.mkEnv oddjobsUiCfg ("/admin/odd-jobs/" <>) let webEnv = WebEnv floraEnv webEnvStore <- liftIO $ newWebEnvStore webEnv @@ -178,8 +182,8 @@ runServer appLogger floraEnv = do $ heartbeatMiddleware . loggingMiddleware . const - $ WaiMetrics.prometheus WaiMetrics.def - $ P.prometheusMiddleware P.defaultMetrics (Proxy @ServerRoutes) server + $ P.prometheusMiddleware P.defaultMetrics (Proxy @ServerRoutes) + $ prometheusMiddleware server mkServer :: Logger diff --git a/src/web/FloraWeb/Session.hs b/src/web/FloraWeb/Session.hs index 14b23c70..a0f53972 100644 --- a/src/web/FloraWeb/Session.hs +++ b/src/web/FloraWeb/Session.hs @@ -16,7 +16,7 @@ import Effectful.Internal.Monad (unsafeEff_) import Servant (Header, Headers, addHeader) import Web.Cookie -import Flora.Environment (FloraEnv) +import Flora.Environment.Env (FloraEnv) import Flora.Model.PersistentSession import FloraWeb.Common.Auth.Types import FloraWeb.Types (fetchFloraEnv) diff --git a/src/web/FloraWeb/Types.hs b/src/web/FloraWeb/Types.hs index 46a60476..d2087bbd 100644 --- a/src/web/FloraWeb/Types.hs +++ b/src/web/FloraWeb/Types.hs @@ -18,6 +18,7 @@ import Control.Monad.IO.Class import Control.Monad.Time (MonadTime (..)) import Data.Text.Encoding qualified as TE import Effectful +import Effectful.Concurrent (Concurrent) import Effectful.Error.Static (Error) import Effectful.Log (Log) import Effectful.PostgreSQL.Transact.Effect (DB) @@ -29,8 +30,7 @@ import GHC.Generics import Servant (FromHttpApiData (..), Handler, ServerError) import Web.Cookie -import Effectful.Concurrent (Concurrent) -import Flora.Environment +import Flora.Environment.Env import Flora.Model.BlobStore.API newtype WebEnvStore = WebEnvStore (MVar WebEnv) diff --git a/test/Flora/ImportSpec.hs b/test/Flora/ImportSpec.hs index 8db6e5e3..82fb5cd3 100644 --- a/test/Flora/ImportSpec.hs +++ b/test/Flora/ImportSpec.hs @@ -7,6 +7,7 @@ import Data.Text (Text) import Log.Backend.StandardOutput (withStdOutLogger) import Optics.Core +import Flora.Environment.Env import Flora.Import.Package (chooseNamespace) import Flora.Import.Package.Bulk import Flora.Model.Package.Query qualified as Query diff --git a/test/Flora/TestUtils.hs b/test/Flora/TestUtils.hs index 529d0883..fe79da50 100644 --- a/test/Flora/TestUtils.hs +++ b/test/Flora/TestUtils.hs @@ -135,8 +135,8 @@ import Test.Tasty.HUnit qualified as Test import Effectful.State.Static.Shared (State) import Effectful.State.Static.Shared qualified as State -import Flora.Environment import Flora.Environment.Config +import Flora.Environment.Env import Flora.Import.Package.Bulk (importAllFilesInRelativeDirectory) import Flora.Logging qualified as Logging import Flora.Model.BlobStore.API @@ -174,7 +174,20 @@ import Flora.Model.User import Flora.Model.User.Query qualified as Query import Flora.Model.User.Update qualified as Update -type TestEff = Eff '[Trace, FileSystem, Poolboy, Fail, BlobStoreAPI, Reader TestEnv, DB, Log, Time, State (Set (Namespace, PackageName, Version)), IOE] +type TestEff = + Eff + '[ Trace + , FileSystem + , Poolboy + , Fail + , BlobStoreAPI + , Reader TestEnv + , DB + , Log + , Time + , State (Set (Namespace, PackageName, Version)) + , IOE + ] data Fixtures = Fixtures { hackageUser :: User