diff --git a/.github/workflows/docker-image.yml b/.github/workflows/docker-image.yml index 0f0eb1b5..f7dab565 100644 --- a/.github/workflows/docker-image.yml +++ b/.github/workflows/docker-image.yml @@ -19,7 +19,7 @@ jobs: registry: ghcr.io username: ${{ github.actor }} password: ${{ secrets.GITHUB_TOKEN }} - - name: Build the hello-docker Docker image + - name: Build the Docker image run: | docker build . --tag ghcr.io/flora-pm/flora-server:latest docker run ghcr.io/flora-pm/flora-server:latest diff --git a/.github/workflows/test-docker-image.yml b/.github/workflows/test-docker-image.yml index a92eb35c..c74464d9 100644 --- a/.github/workflows/test-docker-image.yml +++ b/.github/workflows/test-docker-image.yml @@ -13,5 +13,5 @@ jobs: runs-on: ubuntu-latest steps: - uses: actions/checkout@v4 - - name: Build the hello-docker Docker image + - name: Build the Docker image run: make docker-build diff --git a/CHANGELOG.md b/CHANGELOG.md index c54d8bca..429e0f1f 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,8 +1,16 @@ # CHANGELOG +## 1.0.19 -- 2024-07-23 + +- Log and re-import packages with zero dependencies [#553](https://github.com/flora-pm/flora-server/pull/553) +- Have explicit version ARGS in docker for tools [#557](https://github.com/flora-pm/flora-server/pull/557) +- Remove the enqueueImportJob function [#558](https://github.com/flora-pm/flora-server/pull/558) +- Store archive hashes [#560](https://github.com/flora-pm/flora-server/pull/560) +- Implement tracing with zipkin [#564](https://github.com/flora-pm/flora-server/pull/564) + ## 1.0.18 -- 2024-05-18 -* Add @horizon namespace ([#498](https://github.com/flora-pm/flora-server/issues/498)) +* Add `@horizon` namespace ([#498](https://github.com/flora-pm/flora-server/issues/498)) * Signal deprecations and revision dates in version listing page ([#548](https://github.com/flora-pm/flora-server/pull/548)) * Introduce [changelog-d](https://codeberg.org/fgaz/changelog-d) in the release process. * Remove the last @apply from tailwind ([#550](https://github.com/flora-pm/flora-server/pulls/550)) diff --git a/Dockerfile b/Dockerfile index 9191206a..14952598 100644 --- a/Dockerfile +++ b/Dockerfile @@ -5,8 +5,15 @@ FROM ubuntu@sha256:67211c14fa74f070d27cc59d69a7fa9aeff8e28ea118ef3babc295a0428a6 ARG GID=1000 ARG UID=1000 -ARG ghc_version=9.6.5 -ARG cabal_version=3.10.3.0 +ARG GHC_VERSION=9.6.6 +ARG CABAL_VERSION=3.10.3.0 +ARG FOURMOLU_VERSION=0.14.1.0 +ARG HLINT_VERSION=3.8 +ARG APPLY_REFACT_VERSION=0.14.0.0 +ARG CABAL_FMT_VERSION=0.1.12 +ARG GHCID_VERSION=0.8.9 +ARG GHC_TAGS_VERSION=1.8 +ARG POSTGRESQL_MIGRATION_VERSION=0.2.1.8 # generate a working directory USER "root" @@ -23,29 +30,29 @@ RUN chown -R $USER:$USER /home/$USER/.cabal WORKDIR /flora-server RUN apt update && \ - apt install -y build-essential curl libffi-dev libffi8 libgmp-dev libgmp10 libncurses-dev libncurses5 libtinfo5 git libsodium-dev + apt install -y build-essential curl libffi-dev libffi8 libgmp-dev libgmp10 libncurses-dev libncurses5 libtinfo5 git libsodium-dev pkg-config # install dependencies (pg_config, postgresql-client, yarn) ENV BOOTSTRAP_HASKELL_NONINTERACTIVE="YES" -ENV BOOTSTRAP_HASKELL_GHC_VERSION="$ghc_version" -ENV BOOTSTRAP_HASKELL_CABAL_VERSION="$cabal_version" ENV BOOTSTRAP_HASKELL_INSTALL_NO_STACK="YES" ENV BOOTSTRAP_HASKELL_INSTALL_NO_STACK_HOOK="YES" -ENV BOOTSTRAP_HASKELL_INSTALL_HLS="YES" +ENV PATH="$PATH:/home/$USER/.ghcup/bin" RUN curl -sS https://dl.yarnpkg.com/debian/pubkey.gpg | apt-key add - RUN curl -fsSL https://deb.nodesource.com/setup_18.x | bash - RUN echo "deb https://dl.yarnpkg.com/debian/ stable main" | tee /etc/apt/sources.list.d/yarn.list RUN apt install -y nodejs libpq-dev mcpp wget zsh tmux postgresql-client RUN corepack enable -RUN chmod ugo+x /home/$USER/.cabal - USER ${USER} +RUN chmod ugo+x /home/$USER/.cabal RUN git config --global --add safe.directory "*" RUN curl --proto '=https' --tlsv1.2 -sSf https://get-ghcup.haskell.org | sh +RUN ghcup install hls $HLS_VERSION \ + && ghcup install ghc $GHC_VERSION \ + && ghcup set ghc $GHC_VERSION \ + && ghcup install cabal $CABAL_VERSION USER ${USER} -ENV PATH="$PATH:/home/$USER/.ghcup/bin" # install soufflé USER "root" @@ -59,12 +66,13 @@ RUN echo $PATH # to run `cabal update` as separate step, as cabal doesn't delete # package versions) RUN cabal update -RUN cabal install -j postgresql-migration -RUN cabal install -j hlint apply-refact -RUN cabal install -j fourmolu-0.14.1.0 -RUN cabal install -j cabal-fmt -RUN cabal install -j ghcid -RUN cabal install -j ghc-tags +RUN cabal install -j postgresql-migration-$POSTGRESQL_MIGRATION_VERSION +RUN cabal install -j hlint-$HLINT_VERSION +RUN cabal install -j apply-refact-$APPLY_REFACT_VERSION +RUN cabal install -j fourmolu-$FOURMOLU_VERSION +RUN cabal install -j cabal-fmt-$CABAL_FMT_VERSION +RUN cabal install -j ghcid-$GHCID_VERSION +RUN cabal install -j ghc-tags-$GHC_TAGS_VERSION # configure the shell RUN sh -c "$(curl -fsSL https://raw.github.com/ohmyzsh/ohmyzsh/master/tools/install.sh)" diff --git a/app/cli/Main.hs b/app/cli/Main.hs index c2e689c4..f6c411af 100644 --- a/app/cli/Main.hs +++ b/app/cli/Main.hs @@ -238,7 +238,6 @@ importIndex path repository = do importPackageTarball :: ( Log :> es , BlobStoreAPI :> es - , Time :> es , IOE :> es , DB :> es ) diff --git a/cabal.project b/cabal.project index 735fa951..8ca9908d 100644 --- a/cabal.project +++ b/cabal.project @@ -1,7 +1,7 @@ packages: ./ -with-compiler: ghc-9.6.5 +with-compiler: ghc-9.6 active-repositories: hackage.haskell.org @@ -29,11 +29,21 @@ package warp package zlib flags: -pkg-config +source-repository-package + type: git + location: https://github.com/scrive/tracing + tag: e49720d + subdir: + . + ./tracing-effectful + source-repository-package type: git location: https://github.com/haskell-cryptography/libsodium-bindings - tag: c9265c0 - subdir: ./sel + tag: 6bc69bf + subdir: + ./sel + ./libsodium-bindings source-repository-package type: git diff --git a/cabal.project.freeze b/cabal.project.freeze index 9cdfe5b5..155f28d9 100644 --- a/cabal.project.freeze +++ b/cabal.project.freeze @@ -1,14 +1,13 @@ -active-repositories: hackage.haskell.org:merge constraints: any.Cabal ==3.10.3.0, any.Cabal-syntax ==3.10.3.0, any.HUnit ==1.6.2.0, - any.JuicyPixels ==3.3.8, + any.JuicyPixels ==3.3.9, JuicyPixels -mmap, any.OneTuple ==0.4.2, any.Only ==0.1, - any.PyF ==0.11.2.1, + any.PyF ==0.11.3.0, PyF -python_test, - any.QuickCheck ==2.14.3, + any.QuickCheck ==2.15.0.1, QuickCheck -old-random +templatehaskell, any.RSA ==2.4.1, any.SHA ==1.6.4.4, @@ -17,7 +16,7 @@ constraints: any.Cabal ==3.10.3.0, any.abstract-deque ==0.3, abstract-deque -usecas, any.adjunctions ==4.4.2, - any.aeson ==2.2.1.0, + any.aeson ==2.2.3.0, aeson +ordered-keymap, any.aeson-pretty ==0.8.10, aeson-pretty -lib-only, @@ -25,7 +24,6 @@ constraints: any.Cabal ==3.10.3.0, ansi-terminal -example, any.ansi-terminal-types ==1.1, any.appar ==0.1.8, - any.array ==0.5.6.0, any.asn1-encoding ==0.9.6, any.asn1-parse ==0.9.5, any.asn1-types ==0.3.4, @@ -33,15 +31,14 @@ constraints: any.Cabal ==3.10.3.0, assoc -tagged, any.async ==2.2.4, async -bench, - any.atomic-primops ==0.8.7, + any.atomic-primops ==0.8.8, atomic-primops -debug, any.attoparsec ==0.14.4, attoparsec -developer, - any.attoparsec-aeson ==2.2.0.1, + any.attoparsec-aeson ==2.2.2.0, any.authenticate-oauth ==1.7, any.auto-update ==0.1.6, any.barbies ==2.1.1.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, @@ -59,7 +56,7 @@ constraints: any.Cabal ==3.10.3.0, any.blaze-builder ==0.4.2.3, any.blaze-html ==0.9.2.0, any.blaze-markup ==0.8.3.0, - any.boring ==0.2.1, + any.boring ==0.2.2, boring +tagged, any.bsb-http-chunked ==0.0.0.4, any.bytebuild ==0.3.16.2, @@ -78,6 +75,7 @@ constraints: any.Cabal ==3.10.3.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.clock ==0.8.4, clock -llvm, @@ -88,7 +86,7 @@ constraints: any.Cabal ==3.10.3.0, any.colour ==2.3.6, any.colourista ==0.1.0.2, any.commonmark ==0.2.6, - any.commonmark-extensions ==0.2.5.4, + any.commonmark-extensions ==0.2.5.5, any.comonad ==5.0.8, comonad +containers +distributive +indexed-traversable, any.concurrent-output ==1.10.21, @@ -109,8 +107,8 @@ constraints: any.Cabal ==3.10.3.0, cryptohash-sha256 -exe +use-cbits, any.crypton ==1.0.0, 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.3.2, - any.crypton-x509 ==1.7.6, + any.crypton-connection ==0.4.1, + 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, @@ -123,20 +121,19 @@ constraints: any.Cabal ==3.10.3.0, any.data-default-instances-dlist ==0.0.1, any.data-default-instances-old-locale ==0.0.1, any.data-fix ==0.3.3, - any.dec ==0.0.5, - any.deepseq ==1.4.8.1, + any.dec ==0.0.6, any.deriving-aeson ==0.2.9, - any.directory ==1.3.8.4, + any.directory ==1.3.8.5, any.distributive ==0.6.2.1, distributive +semigroups +tagged, any.dlist ==1.0, dlist -werror, any.easy-file ==0.2.5, - any.effectful ==2.3.0.0, + any.effectful ==2.3.1.0, effectful -benchmark-foreign-libraries, - any.effectful-core ==2.3.0.1, + any.effectful-core ==2.3.1.0, any.either ==5.0.2, - any.emojis ==0.1.3, + any.emojis ==0.1.4.1, any.entropy ==0.4.1.10, entropy -donotgetentropy, any.envparse ==0.5.0, @@ -144,7 +141,7 @@ 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.2, + any.fast-logger ==3.2.3, any.file-embed ==0.0.16.0, any.filepath ==1.4.300.1, flora -prod, @@ -156,21 +153,18 @@ constraints: any.Cabal ==3.10.3.0, generic-deriving +base-4-9, any.generically ==0.1.1, any.generics-sop ==0.5.1.4, - any.ghc ==9.6.5, - any.ghc-bignum ==1.3, - any.ghc-boot ==9.6.5, - any.ghc-boot-th ==9.6.5, - any.ghc-heap ==9.6.5, - any.ghc-prim ==0.10.0, - any.ghci ==9.6.5, + any.ghc ==9.6.6, + any.ghc-boot ==9.6.6, + any.ghc-heap ==9.6.6, + any.ghci ==9.6.6, any.haddock-library ==1.11.0, any.half ==0.3.1, any.happy ==1.20.1.1, - any.hashable ==1.4.4.0, - hashable +integer-gmp -random-initial-seed, + any.hashable ==1.4.7.0, + hashable -arch-native +integer-gmp -random-initial-seed, any.haskell-lexer ==1.1.1, any.haskell-src-exts ==1.23.1, - any.haskell-src-meta ==0.8.13, + any.haskell-src-meta ==0.8.14, any.hdaemonize ==0.5.7, any.heaps ==0.4, any.hedgehog ==1.4, @@ -179,9 +173,9 @@ constraints: any.Cabal ==3.10.3.0, any.hpc ==0.6.2.0, any.hsc2hs ==0.68.10, hsc2hs -in-ghc-tree, - any.hspec ==2.11.8, - any.hspec-core ==2.11.8, - any.hspec-discover ==2.11.8, + any.hspec ==2.11.9, + any.hspec-core ==2.11.9, + any.hspec-discover ==2.11.9, any.hspec-expectations ==0.8.4, any.hsyslog ==5.0.2, hsyslog -install-examples, @@ -198,11 +192,10 @@ constraints: any.Cabal ==3.10.3.0, any.http2 ==5.0.1, http2 -devel -h2spec, any.indexed-profunctors ==0.1.1.1, - any.indexed-traversable ==0.1.3, - any.indexed-traversable-instances ==0.1.1.2, + any.indexed-traversable ==0.1.4, + any.indexed-traversable-instances ==0.1.2, any.insert-ordered-containers ==0.2.5.3, any.integer-conversion ==0.1.1, - any.integer-gmp ==1.1, any.integer-logarithms ==1.0.3.1, integer-logarithms -check-bounds +integer-gmp, any.invariant ==0.6.3, @@ -221,7 +214,7 @@ constraints: any.Cabal ==3.10.3.0, any.log-effectful ==1.0.0.0, any.lucid ==2.11.20230408, any.lucid-alpine ==0.1.0.7, - any.lucid-svg ==0.7.1.1, + any.lucid-svg ==0.7.2.0, any.megaparsec ==9.6.1, megaparsec -dev, any.memory ==0.18.0, @@ -260,7 +253,7 @@ 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.2.2, + any.os-string ==2.0.3, any.parallel ==3.2.2.0, any.parsec ==3.1.16.1, any.parser-combinators ==1.3.0, @@ -297,20 +290,19 @@ constraints: any.Cabal ==3.10.3.0, any.recv ==0.1.0, any.reflection ==2.1.8, reflection -slow +template-haskell, - any.req ==3.13.2, + any.req ==3.13.3, req -dev, any.resource-pool ==0.4.0.0, any.resourcet ==1.3.0, any.retry ==0.9.3.1, retry -lib-werror, - any.rts ==1.0.2, any.run-st ==0.1.3.3, any.safe ==0.3.21, any.safe-exceptions ==0.1.7.4, any.scientific ==0.3.8.0, scientific -integer-simple, any.sel ==0.0.1.0, - any.semialign ==1.3, + any.semialign ==1.3.1, semialign +semigroupoids, any.semigroupoids ==6.0.1, semigroupoids +comonad +containers +contravariant +distributive +tagged +unordered-containers, @@ -330,8 +322,8 @@ constraints: any.Cabal ==3.10.3.0, servant-static-th -buildexample, any.simple-sendfile ==0.2.32, simple-sendfile +allow-bsd -fallback, - any.singleton-bool ==0.1.7, - any.slugify ==0.1.0.1, + any.singleton-bool ==0.1.8, + any.slugify ==0.1.0.2, any.socks ==0.6.1, any.some ==1.0.6, some +newtype-unsafe, @@ -355,34 +347,33 @@ constraints: any.Cabal ==3.10.3.0, any.syb ==0.7.2.4, any.tagged ==0.8.8, tagged +deepseq +transformers, - any.tar ==0.6.2.0, + any.tar ==0.6.3.0, any.tasty ==1.5, tasty +unix, - any.tasty-hunit ==0.10.1, - any.template-haskell ==2.20.0.0, + any.tasty-hunit ==0.10.2, any.temporary ==1.3, any.terminal-size ==0.3.4, any.text ==2.0.2, any.text-conversions ==0.3.1.1, any.text-display ==0.0.5.2, text-display -book, - any.text-iso8601 ==0.1, + any.text-iso8601 ==0.1.1, any.text-manipulate ==0.3.1.0, any.text-short ==0.1.6, text-short -asserts, any.tf-random ==0.5, - any.th-abstraction ==0.6.0.0, + 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-reify-many ==0.1.10, - any.these ==1.2, + any.these ==1.2.1, any.time ==1.12.2, any.time-compat ==1.9.7, any.time-manager ==0.0.1, any.timing-convenience ==0.1, - any.tls ==2.0.5, + any.tls ==2.0.6, tls -devel, any.torsor ==0.1.0.1, any.transformers ==0.6.1.0, @@ -400,7 +391,7 @@ constraints: any.Cabal ==3.10.3.0, any.unix ==2.8.4.0, any.unix-compat ==0.7.1, unix-compat -old-time, - any.unix-time ==0.4.12, + any.unix-time ==0.4.15, any.unlifted ==0.2.2.0, any.unliftio ==0.2.25.0, any.unliftio-core ==0.2.1.0, @@ -413,7 +404,7 @@ constraints: any.Cabal ==3.10.3.0, vault +useghc, any.vector ==0.13.1.0, vector +boundschecks -internalchecks -unsafechecks -wall, - any.vector-algorithms ==0.9.0.1, + any.vector-algorithms ==0.9.0.2, vector-algorithms +bench +boundschecks -internalchecks -llvm +properties -unsafechecks, any.vector-stream ==0.1.0.1, any.void ==0.7.3, @@ -421,7 +412,7 @@ 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.14, + any.wai-extra ==3.1.15, wai-extra -build-example, any.wai-log ==0.4.0.1, any.wai-logger ==2.4.0, @@ -429,7 +420,7 @@ constraints: any.Cabal ==3.10.3.0, any.warp ==3.3.31, warp +allow-sendfilefd -network-bytestring -warp-debug -x509, any.wide-word ==0.1.6.0, - any.witherable ==0.4.2, + any.witherable ==0.5, any.wl-pprint-annotated ==0.1.0.1, any.word8 ==0.1.3, any.xml-conduit ==1.9.1.3, @@ -438,4 +429,3 @@ constraints: any.Cabal ==3.10.3.0, any.zigzag ==0.1.0.0, any.zlib ==0.7.1.0, zlib -bundled-c-zlib +non-blocking-ffi -pkg-config -index-state: hackage.haskell.org 2024-05-14T16:55:19Z diff --git a/changelog.d/config b/changelog.d/config index 986678ac..bc7de983 100644 --- a/changelog.d/config +++ b/changelog.d/config @@ -1,5 +1,5 @@ organization: flora-pm repository: flora-server -issue-url-template: https://github.com/{organization}/{repository}/issues/{index} -pr-url-template: https://github.com/{organization}/{repository}/pulls/{index} +issue-url-template: https://github.com/{organization}/{repository}/issue/{index} +pr-url-template: https://github.com/{organization}/{repository}/pull/{index} required-fields: synopsis prs diff --git a/docker-compose.yml b/docker-compose.yml index 8a8bcb22..91230b31 100644 --- a/docker-compose.yml +++ b/docker-compose.yml @@ -1,4 +1,3 @@ -version: "3" services: server: image: ghcr.io/flora-pm/flora-server:latest diff --git a/docs/yarn.lock b/docs/yarn.lock index a973fe34..6fb910ae 100644 --- a/docs/yarn.lock +++ b/docs/yarn.lock @@ -1588,7 +1588,7 @@ "@docusaurus/theme-search-algolia" "2.4.1" "@docusaurus/types" "2.4.1" -"@docusaurus/react-loadable@5.5.2", "react-loadable@npm:@docusaurus/react-loadable@5.5.2": +"@docusaurus/react-loadable@5.5.2": version "5.5.2" resolved "https://registry.yarnpkg.com/@docusaurus/react-loadable/-/react-loadable-5.5.2.tgz#81aae0db81ecafbdaee3651f12804580868fa6ce" integrity sha512-A3dYjdBGuy0IGT+wyLIGIKLRE+sAk1iNk0f1HjNDysO7u8lhL4N3VEm+FAubmJbAztn94F7MxBTPmnixbiyFdQ== @@ -7008,6 +7008,14 @@ react-loadable-ssr-addon-v5-slorber@^1.0.1: dependencies: "@babel/runtime" "^7.10.3" +"react-loadable@npm:@docusaurus/react-loadable@5.5.2": + version "5.5.2" + resolved "https://registry.yarnpkg.com/@docusaurus/react-loadable/-/react-loadable-5.5.2.tgz#81aae0db81ecafbdaee3651f12804580868fa6ce" + integrity sha512-A3dYjdBGuy0IGT+wyLIGIKLRE+sAk1iNk0f1HjNDysO7u8lhL4N3VEm+FAubmJbAztn94F7MxBTPmnixbiyFdQ== + dependencies: + "@types/react" "*" + prop-types "^15.6.2" + react-router-config@^5.1.1: version "5.1.1" resolved "https://registry.yarnpkg.com/react-router-config/-/react-router-config-5.1.1.tgz#0f4263d1a80c6b2dc7b9c1902c9526478194a988" @@ -8696,14 +8704,14 @@ write-file-atomic@^3.0.0: typedarray-to-buffer "^3.1.5" ws@^7.3.1: - version "7.5.9" - resolved "https://registry.yarnpkg.com/ws/-/ws-7.5.9.tgz#54fa7db29f4c7cec68b1ddd3a89de099942bb591" - integrity sha512-F+P9Jil7UiSKSkppIiD94dN07AwvFixvLIj1Og1Rl9GGMuNipJnV9JzjD6XuqmAeiswGvUmNLjr5cFuXwNS77Q== + version "7.5.10" + resolved "https://registry.yarnpkg.com/ws/-/ws-7.5.10.tgz#58b5c20dc281633f6c19113f39b349bd8bd558d9" + integrity sha512-+dbF1tHwZpXcbOJdVOkzLDxZP1ailvSxM6ZweXTegylPny803bFhA+vqBYw4s31NSAk4S2Qz+AKXK9a4wkdjcQ== ws@^8.13.0: - version "8.13.0" - resolved "https://registry.yarnpkg.com/ws/-/ws-8.13.0.tgz#9a9fb92f93cf41512a0735c8f4dd09b8a1211cd0" - integrity sha512-x9vcZYTrFPC7aSIbj7sRCYo7L/Xb8Iy+pW0ng0wt2vCJv7M9HOMy0UoN3rr+IFC7hb7vXoqS+P9ktyLLLhO+LA== + version "8.17.1" + resolved "https://registry.yarnpkg.com/ws/-/ws-8.17.1.tgz#9293da530bb548febc95371d90f9c878727d919b" + integrity sha512-6XQFvXTkbfUOZOKKILFG1PDK2NDQs4azKQl26T0YS5CxqWLgXajbPZ+h4gZekJyRqFU8pvnbAbbs/3TgRPy+GQ== xdg-basedir@^4.0.0: version "4.0.0" diff --git a/flora.cabal b/flora.cabal index 262bd1f5..6ac1cdb6 100644 --- a/flora.cabal +++ b/flora.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: flora -version: 1.0.18 +version: 1.0.19 homepage: https://github.com/flora-pm/flora-server/#readme bug-reports: https://github.com/flora-pm/flora-server/issues author: Théophile Choutri @@ -12,7 +12,7 @@ extra-doc-files: CHANGELOG.md README.md -tested-with: GHC ==9.6.5 +tested-with: GHC ==9.6.6 source-repository head type: git @@ -133,6 +133,7 @@ library Flora.Publish Flora.QRCode Flora.Search + Flora.Tracing JSON Log.Backend.File Lucid.Orphans @@ -194,6 +195,7 @@ library , text , text-display , time + , tracing , unliftio , utf8-string , uuid @@ -334,6 +336,8 @@ library flora-web , text-display , time , torsor + , tracing + , tracing-effectful , uuid , vector , vector-algorithms diff --git a/migrations/20240617215020_make_archive_checksum_nullable.sql b/migrations/20240617215020_make_archive_checksum_nullable.sql new file mode 100644 index 00000000..42f33694 --- /dev/null +++ b/migrations/20240617215020_make_archive_checksum_nullable.sql @@ -0,0 +1,2 @@ +alter table releases + alter column archive_checksum drop not null; diff --git a/src/core/Flora/Import/Package.hs b/src/core/Flora/Import/Package.hs index cdc1f08a..5be11bdb 100644 --- a/src/core/Flora/Import/Package.hs +++ b/src/core/Flora/Import/Package.hs @@ -20,34 +20,55 @@ module Flora.Import.Package ( coreLibraries , versionList - , enqueueImportJob , loadContent - , loadAndExtractCabalFile , persistImportOutput , extractPackageDataFromCabal , chooseNamespace + , loadJSONContent + , persistHashes ) where import Control.DeepSeq (force) import Control.Exception +import Control.Monad (forM_) +import Data.Aeson (object, (.=)) +import Data.Aeson qualified as Aeson +import Data.Aeson.Key qualified as Key +import Data.Aeson.KeyMap qualified as KeyMap import Data.ByteString qualified as BS +import Data.IORef (IORef) +import Data.IORef qualified as IORef +import Data.IORef qualified as IOref +import Data.List.NonEmpty qualified as NE +import Data.Map (Map) +import Data.Map.Strict qualified as Map import Data.Maybe -import Data.Pool (withResource) import Data.Set (Set) import Data.Set qualified as Set import Data.Text (Text, pack) -import Data.Text qualified as T +import Data.Text qualified as Text import Data.Text.Display -import Data.Text.IO qualified as T +import Data.Text.Encoding qualified as Text +import Data.Text.IO qualified as Text import Data.Time (UTCTime) import Data.Vector (Vector) import Data.Vector qualified as Vector import Distribution.Compat.NonEmptySet (toList) import Distribution.Compiler (CompilerFlavor (..)) import Distribution.Fields.ParseResult -import Distribution.PackageDescription (CondBranch (..), CondTree (condTreeData), Condition (CNot), ConfVar, UnqualComponentName, allLibraries, unPackageName, unUnqualComponentName) +import Distribution.PackageDescription + ( CondBranch (..) + , CondTree (condTreeData) + , Condition (CNot) + , ConfVar + , UnqualComponentName + , allLibraries + , unPackageName + , unUnqualComponentName + ) import Distribution.PackageDescription qualified as Cabal hiding (PackageName) import Distribution.PackageDescription.Parsec (parseGenericPackageDescription) +import Distribution.Parsec qualified as Parsec import Distribution.Pretty import Distribution.Types.Benchmark import Distribution.Types.Dependency @@ -63,29 +84,29 @@ import Distribution.Types.VersionRange (VersionRange, withinRange) import Distribution.Utils.ShortText qualified as Cabal import Distribution.Version qualified as Version import Effectful -import Effectful.Internal.Monad (unsafeEff_) import Effectful.Log (Log) import Effectful.Poolboy (Poolboy) import Effectful.Poolboy qualified as Poolboy -import Effectful.PostgreSQL.Transact.Effect (DB, getPool) +import Effectful.PostgreSQL.Transact.Effect (DB) import Effectful.Time (Time) import Effectful.Time qualified as Time +import GHC.List (List) import Log qualified -import OddJobs.Job (createJob) import Optics.Core -import System.Directory qualified as System +import System.Exit (exitFailure) +import System.FilePath qualified as FilePath -import Control.Monad (forM_, unless, void) import Flora.Import.Categories.Tuning qualified as Tuning import Flora.Import.Package.Types import Flora.Import.Types import Flora.Model.Category.Update qualified as Update import Flora.Model.Component.Types as Component -import Flora.Model.Job (FloraOddJobs (..)) import Flora.Model.Package.Orphans () +import Flora.Model.Package.Query qualified as Query import Flora.Model.Package.Types import Flora.Model.Package.Update qualified as Update import Flora.Model.Release (deterministicReleaseId) +import Flora.Model.Release.Query qualified as Query import Flora.Model.Release.Types import Flora.Model.Release.Update qualified as Update import Flora.Model.Requirement @@ -182,40 +203,53 @@ versionList = , Version.mkVersion [7, 10, 3] ] -enqueueImportJob :: (DB :> es, IOE :> es) => ImportOutput -> Eff es () -enqueueImportJob importOutput = do - pool <- getPool - void $ - liftIO $ - withResource - pool - ( \conn -> - createJob - conn - "oddjobs" - (ImportPackage importOutput) - ) - --- | Loads and parses a Cabal file -loadFile - :: (IOE :> es, Log :> es) - => FilePath - -- ^ The absolute path to the Cabal file - -> Eff es (UTCTime, GenericPackageDescription) -loadFile path = do - exists <- liftIO $ System.doesFileExist path - unless exists $ - unsafeEff_ $ - throwIO $ - CabalFileNotFound path - content <- liftIO $ BS.readFile path - timestamp <- liftIO $ System.getModificationTime path - descr <- loadContent path content - pure (timestamp, descr) - -loadContent :: Log :> es => String -> BS.ByteString -> Eff es GenericPackageDescription +loadContent :: Log :> es => FilePath -> BS.ByteString -> Eff es GenericPackageDescription loadContent = parseString parseGenericPackageDescription +loadJSONContent + :: (Log :> es, IOE :> es) + => FilePath + -> BS.ByteString + -> (Text, Set PackageName) + -> Eff es (PackageName, Namespace, Version, Target) +loadJSONContent path content (repositoryName, repositoryPackages) = do + case getNameAndVersionFromPath path of + Nothing -> do + Log.logAttention "parse error" $ + object ["path" .= path] + error "Parse error" + Just (name, versionText) -> do + let (mReleaseJSON :: Maybe ReleaseJSONFile) = Aeson.decodeStrict' content + let field = "/package/" <> name <> "-" <> versionText <> ".tar.gz" + case mReleaseJSON of + Nothing -> do + Log.logAttention "Could not parse JSON" $ + object ["json" .= Text.decodeUtf8 content] + liftIO exitFailure + Just releaseJSON -> do + let mTarget = KeyMap.lookup (Key.fromText field) releaseJSON.signed.targets + case mTarget of + Nothing -> do + Log.logAttention ("Could not find field: " <> field) $ + object ["json" .= releaseJSON] + liftIO exitFailure + Just target -> do + case Parsec.simpleParsec $ Text.unpack versionText of + Nothing -> do + Log.logAttention "Could not parse version" $ + object ["version" .= versionText, "package" .= name] + error ":(" + Just version -> do + let packageName = PackageName name + let chosenNamespace = chooseNamespace packageName repositoryName repositoryPackages + pure (packageName, chosenNamespace, version, target) + +getNameAndVersionFromPath :: FilePath -> Maybe (Text, Text) +getNameAndVersionFromPath path = + case Text.split (== '/') $ Text.pack $ FilePath.takeDirectory path of + [name, versionText] -> Just (name, versionText) + _ -> Nothing + parseString :: Log :> es => (BS.ByteString -> ParseResult a) @@ -232,37 +266,27 @@ parseString parser name bs = do Log.logAttention_ (display $ show err) throw $ CabalFileCouldNotBeParsed name -loadAndExtractCabalFile - :: (IOE :> es, Log :> es, Time :> es) - => UserId - -> FilePath - -> (Text, Set PackageName) - -> Eff es ImportOutput -loadAndExtractCabalFile userId filePath repo = - loadFile filePath - >>= uncurry (extractPackageDataFromCabal userId repo) - -- | Persists an 'ImportOutput' to the database. An 'ImportOutput' can be obtained -- by extracting relevant information from a Cabal file using 'extractPackageDataFromCabal' persistImportOutput :: forall es. (Poolboy :> es, DB :> es, IOE :> es) => ImportOutput -> Eff es () persistImportOutput (ImportOutput package categories release components) = do - liftIO . T.putStrLn $ "📦 Persisting package: " <> packageName <> ", 🗓 Release v" <> display release.version + liftIO . Text.putStrLn $ "📦 Persisting package: " <> packageName <> ", 🗓 Release v" <> display release.version persistPackage Update.upsertRelease release parallelRun persistComponent components liftIO $ putStr "\n" where - parallelRun :: (a -> Eff es ()) -> [a] -> Eff es () - parallelRun f xs = forM_ xs (\x -> void $ Poolboy.enqueue (f x)) + parallelRun :: Foldable t => (a -> Eff es ()) -> t a -> Eff es () + parallelRun f xs = forM_ xs (Poolboy.enqueue . f) packageName = display package.namespace <> "/" <> display package.name persistPackage = do let packageId = package.packageId Update.upsertPackage package forM_ categories (\case Tuning.NormalisedPackageCategory cat -> Update.addToCategoryByName packageId cat) - persistComponent :: (PackageComponent, [ImportDependency]) -> Eff es () + persistComponent :: (PackageComponent, List ImportDependency) -> Eff es () persistComponent (packageComponent, deps) = do - liftIO . T.putStrLn $ + liftIO . Text.putStrLn $ "🧩 Persisting component: " <> display packageComponent.canonicalForm <> " with " @@ -276,17 +300,49 @@ persistImportOutput (ImportOutput package categories release components) = do Update.upsertPackage dep.package Update.upsertRequirement dep.requirement +persistHashes + :: (DB :> es, IOE :> es, Log :> es) + => IORef (Map (Namespace, PackageName) Text) + -> (PackageName, Namespace, Version, Target) + -> Eff es () +persistHashes tarballHashIORef (packageName, namespace, version, target) = do + mPackage <- Query.getPackageByNamespaceAndName namespace packageName + case mPackage of + Just package -> do + mRelease <- Query.getReleaseByVersion package.packageId version + case mRelease of + Nothing -> do + Log.logInfo_ "Release does not exist, putting the hash in an ioref" + persisHashInMemory tarballHashIORef (namespace, packageName) target.hashes.sha256 + Just release -> Update.setArchiveChecksum release.releaseId target.hashes.sha256 + Nothing -> do + Log.logInfo_ "Package does not exist, putting the hash in an ioref" + persisHashInMemory tarballHashIORef (namespace, packageName) target.hashes.sha256 + +persisHashInMemory + :: IOE :> es + => IORef (Map (Namespace, PackageName) Text) + -> (Namespace, PackageName) + -> Text + -> Eff es () +persisHashInMemory tarballHashIORef key hash = + liftIO $ + IOref.atomicModifyIORef' + tarballHashIORef + (\m -> (Map.insert key hash m, ())) + -- | Transforms a 'GenericPackageDescription' from Cabal into an 'ImportOutput' -- that can later be inserted into the database. This function produces stable, deterministic ids, -- so it should be possible to extract and insert a single package many times in a row. extractPackageDataFromCabal - :: (IOE :> es, Time :> es) - => UserId + :: (IOE :> es, Time :> es, Log :> es) + => IORef (Map (Namespace, PackageName) Text) + -> UserId -> (Text, Set PackageName) -> UTCTime -> GenericPackageDescription -> Eff es ImportOutput -extractPackageDataFromCabal userId (repositoryName, repositoryPackages) uploadTime genericDesc = do +extractPackageDataFromCabal tarballHashIORef userId (repositoryName, repositoryPackages) uploadTime genericDesc = do let packageDesc = genericDesc.packageDescription let flags = Vector.fromList genericDesc.genPackageFlags let packageName = force $ packageDesc ^. #package % #pkgName % to unPackageName % to pack % to PackageName @@ -297,9 +353,16 @@ extractPackageDataFromCabal userId (repositoryName, repositoryPackages) uploadTi let releaseId = deterministicReleaseId packageId packageVersion timestamp <- Time.currentTime let sourceRepos = getRepoURL packageName packageDesc.sourceRepos - let rawCategoryField = packageDesc ^. #category % to Cabal.fromShortText % to T.pack - let categoryList = fmap (Tuning.UserPackageCategory . T.stripStart . T.stripEnd) (T.splitOn "," rawCategoryField) + let rawCategoryField = packageDesc ^. #category % to Cabal.fromShortText % to Text.pack + let categoryList = fmap (Tuning.UserPackageCategory . Text.stripStart . Text.stripEnd) (Text.splitOn "," rawCategoryField) categories <- liftIO $ Tuning.normalisedCategories <$> Tuning.normalise categoryList + (mTarballHash :: Maybe Text) <- liftIO $ IORef.atomicModifyIORef' tarballHashIORef $ \m -> + let result = Map.lookup (namespace, packageName) m + in case result of + Nothing -> (m, Nothing) + Just hash -> + let newMap = Map.delete (namespace, packageName) m + in (newMap, Just hash) let package = Package { packageId @@ -317,7 +380,7 @@ extractPackageDataFromCabal userId (repositoryName, repositoryPackages) uploadTi { releaseId , packageId , version = packageVersion - , archiveChecksum = mempty + , archiveChecksum = mTarballHash , uploadedAt = Just uploadTime , createdAt = timestamp , updatedAt = timestamp @@ -359,7 +422,7 @@ extractPackageDataFromCabal userId (repositoryName, repositoryPackages) uploadTi let benchmarks = extractBenchmark package (repositoryName, repositoryPackages) release Nothing [] <$> packageDesc.benchmarks let condBenchmarks = extractCondTrees extractBenchmark package (repositoryName, repositoryPackages) release genericDesc.condBenchmarks - let components = + let components' = lib <> condLib <> condSubLibs @@ -371,40 +434,43 @@ extractPackageDataFromCabal userId (repositoryName, repositoryPackages) uploadTi <> condTestSuites <> benchmarks <> condBenchmarks - pure ImportOutput{..} + case NE.nonEmpty components' of + Nothing -> do + Log.logAttention "Empty dependencies" $ object ["package" .= package] + extractPackageDataFromCabal tarballHashIORef userId (repositoryName, repositoryPackages) uploadTime genericDesc + Just components -> pure ImportOutput{..} extractLibrary :: Package -> (Text, Set PackageName) -> Release -> Maybe UnqualComponentName - -> [Condition ConfVar] + -> List (Condition ConfVar) -> Library - -> ImportComponent -extractLibrary package repository = + -> (PackageComponent, List ImportDependency) +extractLibrary package = genericComponentExtractor Component.Library (^. #libName % to (getLibName package.name)) (^. #libBuildInfo % #targetBuildDepends) package - repository getLibName :: PackageName -> LibraryName -> Text getLibName pname LMainLibName = display pname -getLibName _ (LSubLibName lname) = T.pack $ unUnqualComponentName lname +getLibName _ (LSubLibName lname) = Text.pack $ unUnqualComponentName lname extractForeignLib :: Package -> (Text, Set PackageName) -> Release -> Maybe UnqualComponentName - -> [Condition ConfVar] + -> List (Condition ConfVar) -> ForeignLib - -> ImportComponent + -> (PackageComponent, List ImportDependency) extractForeignLib = genericComponentExtractor Component.ForeignLib - (^. #foreignLibName % to unUnqualComponentName % to T.pack) + (^. #foreignLibName % to unUnqualComponentName % to Text.pack) (^. #foreignLibBuildInfo % #targetBuildDepends) extractExecutable @@ -412,13 +478,13 @@ extractExecutable -> (Text, Set PackageName) -> Release -> Maybe UnqualComponentName - -> [Condition ConfVar] + -> List (Condition ConfVar) -> Executable - -> ImportComponent + -> (PackageComponent, List ImportDependency) extractExecutable = genericComponentExtractor Component.Executable - (^. #exeName % to unUnqualComponentName % to T.pack) + (^. #exeName % to unUnqualComponentName % to Text.pack) (^. #buildInfo % #targetBuildDepends) extractTestSuite @@ -426,13 +492,13 @@ extractTestSuite -> (Text, Set PackageName) -> Release -> Maybe UnqualComponentName - -> [Condition ConfVar] + -> List (Condition ConfVar) -> TestSuite - -> ImportComponent + -> (PackageComponent, List ImportDependency) extractTestSuite = genericComponentExtractor Component.TestSuite - (^. #testName % to unUnqualComponentName % to T.pack) + (^. #testName % to unUnqualComponentName % to Text.pack) (^. #testBuildInfo % #targetBuildDepends) extractBenchmark @@ -440,25 +506,25 @@ extractBenchmark -> (Text, Set PackageName) -> Release -> Maybe UnqualComponentName - -> [Condition ConfVar] + -> List (Condition ConfVar) -> Benchmark - -> ImportComponent + -> (PackageComponent, List ImportDependency) extractBenchmark = genericComponentExtractor Component.Benchmark - (^. #benchmarkName % to unUnqualComponentName % to T.pack) + (^. #benchmarkName % to unUnqualComponentName % to Text.pack) (^. #benchmarkBuildInfo % #targetBuildDepends) -- | Traverses the provided 'CondTree' and applies the given 'ComponentExtractor' --- to every node, returning a list of 'ImportComponent' +-- to every node, returning a list of '(PackageComponent, List ImportDependency)' extractCondTree - :: (Package -> (Text, Set PackageName) -> Release -> Maybe UnqualComponentName -> [Condition ConfVar] -> component -> ImportComponent) + :: (Package -> (Text, Set PackageName) -> Release -> Maybe UnqualComponentName -> List (Condition ConfVar) -> component -> (PackageComponent, List ImportDependency)) -> Package -> (Text, Set PackageName) -> Release -> Maybe UnqualComponentName - -> CondTree ConfVar [Dependency] component - -> [ImportComponent] + -> CondTree ConfVar (List Dependency) component + -> List (PackageComponent, List ImportDependency) extractCondTree extractor package repository release defaultComponentName = go [] where go cond tree = @@ -474,12 +540,12 @@ extractCondTree extractor package repository release defaultComponentName = go [ -- This function builds upon 'extractCondTree' to make it easier to extract fields such as 'condExecutables', 'condTestSuites' etc. -- from a 'GenericPackageDescription' extractCondTrees - :: (Package -> (Text, Set PackageName) -> Release -> Maybe UnqualComponentName -> [Condition ConfVar] -> component -> ImportComponent) + :: (Package -> (Text, Set PackageName) -> Release -> Maybe UnqualComponentName -> List (Condition ConfVar) -> component -> (PackageComponent, List ImportDependency)) -> Package -> (Text, Set PackageName) -> Release - -> [(UnqualComponentName, CondTree ConfVar [Dependency] component)] - -> [ImportComponent] + -> List (UnqualComponentName, CondTree ConfVar (List Dependency) component) + -> List (PackageComponent, List ImportDependency) extractCondTrees extractor package repository release trees = trees >>= \case (name, tree) -> extractCondTree extractor package repository release (Just name) tree @@ -489,15 +555,15 @@ genericComponentExtractor => ComponentType -> (component -> Text) -- ^ Extract name from component - -> (component -> [Dependency]) + -> (component -> List Dependency) -- ^ Extract dependencies -> Package -> (Text, Set PackageName) -> Release -> Maybe UnqualComponentName - -> [Condition ConfVar] + -> List (Condition ConfVar) -> component - -> (PackageComponent, [ImportDependency]) + -> (PackageComponent, List ImportDependency) genericComponentExtractor componentType getName @@ -543,7 +609,7 @@ buildDependency package (repository, repositoryPackages) packageComponentId (Cab } in ImportDependency{package = dependencyPackage, requirement} -getRepoURL :: PackageName -> [Cabal.SourceRepo] -> Vector Text +getRepoURL :: PackageName -> List Cabal.SourceRepo -> Vector Text getRepoURL _ [] = Vector.empty getRepoURL _ (repo : _) = Vector.singleton $ display $ fromMaybe mempty repo.repoLocation diff --git a/src/core/Flora/Import/Package/Bulk.hs b/src/core/Flora/Import/Package/Bulk.hs index ce3ea363..2f41afb3 100644 --- a/src/core/Flora/Import/Package/Bulk.hs +++ b/src/core/Flora/Import/Package/Bulk.hs @@ -28,24 +28,33 @@ import Effectful import Effectful.FileSystem (FileSystem) import Effectful.FileSystem qualified as FileSystem import Effectful.FileSystem.IO.ByteString qualified as FileSystem +import Effectful.Log (Log) import Effectful.Log qualified as Log import Effectful.Poolboy import Effectful.PostgreSQL.Transact.Effect (DB) import Effectful.Time (Time) +import GHC.Conc (numCapabilities) import Streamly.Data.Fold qualified as SFold import Streamly.Data.Stream (Stream) +import Streamly.Data.Stream.Prelude (maxThreads, ordered) import Streamly.Data.Stream.Prelude qualified as Streamly import System.Directory import System.Directory qualified as System import System.FilePath import UnliftIO.Exception (finally) -import Effectful.Log (Log) +import Data.IORef (IORef) +import Data.IORef qualified as IORef +import Data.Map (Map) +import Data.Map.Strict qualified as Map import Flora.Import.Package ( extractPackageDataFromCabal , loadContent + , loadJSONContent + , persistHashes , persistImportOutput ) +import Flora.Import.Types (ImportFileType (..)) import Flora.Model.Package import Flora.Model.Package.Update qualified as Update import Flora.Model.PackageIndex.Query qualified as Query @@ -54,8 +63,6 @@ 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 GHC.Conc (numCapabilities) -import Streamly.Data.Stream.Prelude (maxThreads, ordered) -- | Same as 'importAllFilesInDirectory' but accepts a relative path to the current working directory importAllFilesInRelativeDirectory @@ -97,16 +104,18 @@ importFromIndex user (repositoryName, repositoryURL) index = do where buildContentStream :: UTCTime - -> Stream (Eff es) (FilePath, UTCTime, StrictByteString) + -> Stream (Eff es) (ImportFileType, UTCTime, StrictByteString) -> Tar.GenEntry Tar.TarPath linkTarget - -> Stream (Eff es) (FilePath, UTCTime, StrictByteString) + -> Stream (Eff es) (ImportFileType, UTCTime, StrictByteString) buildContentStream time acc entry = let entryPath = Tar.entryPath entry entryTime = posixSecondsToUTCTime . fromIntegral $ Tar.entryTime entry in Tar.entryContent entry & \case Tar.NormalFile bs _ | ".cabal" `isSuffixOf` entryPath && entryTime > time -> - (entryPath, entryTime, BL.toStrict bs) `Streamly.cons` acc + (CabalFile entryPath, entryTime, BL.toStrict bs) `Streamly.cons` acc + | ".json" `isSuffixOf` entryPath && entryTime > time -> + (JSONFile entryPath, entryTime, BL.toStrict bs) `Streamly.cons` acc _ -> acc -- | Finds all cabal files in the specified directory, and inserts them into the database after extracting the relevant data @@ -127,14 +136,15 @@ importFromStream . (Time :> es, Log :> es, Poolboy :> es, DB :> es, IOE :> es) => UserId -> (Text, Text, Set PackageName) - -> Stream (Eff es) (String, UTCTime, StrictByteString) + -> Stream (Eff es) (ImportFileType, UTCTime, StrictByteString) -> Eff es () importFromStream user (repositoryName, _repositoryURL, repositoryPackages) stream = do + tarballHashIORef <- liftIO $ IORef.newIORef Map.empty let cfg = maxThreads numCapabilities . ordered True processedPackageCount <- finally ( Streamly.fold displayCount $ - Streamly.parMapM cfg processFile stream + Streamly.parMapM cfg (processFile tarballHashIORef) stream ) -- We want to refresh db and update latest timestamp even if we fell -- over at some point @@ -155,12 +165,22 @@ importFromStream user (repositoryName, _repositoryURL, repositoryPackages) strea when (currentCount `mod` 400 == 0) $ displayStats currentCount pure currentCount - processFile :: (String, UTCTime, StrictByteString) -> Eff es () - processFile (path, timestamp, content) = - loadContent path content - >>= ( extractPackageDataFromCabal user (repositoryName, repositoryPackages) timestamp - >=> \importedPackage -> persistImportOutput importedPackage - ) + processFile + :: IORef (Map (Namespace, PackageName) Text) + -> (ImportFileType, UTCTime, StrictByteString) + -> Eff es () + processFile tarballHashIORef importSubject = + case importSubject of + (CabalFile path, timestamp, content) -> + loadContent path content + >>= ( extractPackageDataFromCabal tarballHashIORef user (repositoryName, repositoryPackages) timestamp + >=> \importedPackage -> persistImportOutput importedPackage + ) + (JSONFile path, _, content) -> + do + loadJSONContent path content (repositoryName, repositoryPackages) + >>= persistHashes tarballHashIORef + displayStats :: Int -> Eff es () displayStats currentCount = liftIO . putStrLn $ "✅ Processed " <> show currentCount <> " new cabal files" @@ -169,10 +189,10 @@ findAllCabalFilesInDirectory :: forall es . FileSystem :> es => FilePath - -> Stream (Eff es) (String, UTCTime, StrictByteString) + -> Stream (Eff es) (ImportFileType, UTCTime, StrictByteString) findAllCabalFilesInDirectory workdir = Streamly.concatMapM traversePath $ Streamly.fromList [workdir] where - traversePath :: FilePath -> Eff es (Stream (Eff es) (FilePath, UTCTime, StrictByteString)) + traversePath :: FilePath -> Eff es (Stream (Eff es) (ImportFileType, UTCTime, StrictByteString)) traversePath p = do isDir <- FileSystem.doesDirectoryExist p case isDir of @@ -182,7 +202,7 @@ findAllCabalFilesInDirectory workdir = Streamly.concatMapM traversePath $ Stream False | ".cabal" `isSuffixOf` p -> do content <- FileSystem.readFile p timestamp <- FileSystem.getModificationTime p - pure $ Streamly.fromPure (p, timestamp, content) + pure $ Streamly.fromPure (CabalFile p, timestamp, content) _ -> pure Streamly.nil buildPackageListFromArchive :: Entries e -> Either e (Set PackageName) diff --git a/src/core/Flora/Import/Package/Types.hs b/src/core/Flora/Import/Package/Types.hs index 707c6154..f3e4741f 100644 --- a/src/core/Flora/Import/Package/Types.hs +++ b/src/core/Flora/Import/Package/Types.hs @@ -2,15 +2,17 @@ module Flora.Import.Package.Types where import Control.DeepSeq import Data.Aeson +import Data.List.NonEmpty (NonEmpty) +import GHC.Generics +import GHC.List (List) + import Flora.Import.Categories.Tuning qualified as Tuning import Flora.Model.Component.Types import Flora.Model.Package.Types import Flora.Model.Release.Types import Flora.Model.Requirement -import GHC.Generics - -type ImportComponent = (PackageComponent, [ImportDependency]) +-- | Package being depended on and its requirement constraint. data ImportDependency = ImportDependency { package :: Package -- ^ the package that is being depended on. Must be inserted in the DB before the requirement @@ -28,7 +30,7 @@ data ImportOutput = ImportOutput { package :: Package , categories :: [Tuning.NormalisedPackageCategory] , release :: Release - , components :: [ImportComponent] + , components :: NonEmpty (PackageComponent, List ImportDependency) } deriving stock (Eq, Show, Generic) deriving anyclass (FromJSON, ToJSON) diff --git a/src/core/Flora/Import/Types.hs b/src/core/Flora/Import/Types.hs index 5316020a..9b7ae0a7 100644 --- a/src/core/Flora/Import/Types.hs +++ b/src/core/Flora/Import/Types.hs @@ -1,7 +1,18 @@ -module Flora.Import.Types where +module Flora.Import.Types + ( ImportError (..) + , Target (..) + , Hashes (..) + , ImportFileType (..) + , ReleaseJSONFile (..) + , Signed (..) + ) where import Control.Exception +import Data.Aeson +import Data.Aeson.KeyMap import Data.Text (Text) +import GHC.Generics + import Flora.Model.Package data ImportError @@ -12,3 +23,31 @@ data ImportError | CabalFileCouldNotBeParsed FilePath deriving stock (Eq, Show) deriving anyclass (Exception) + +data ReleaseJSONFile = ReleaseJSONFile + { signed :: Signed + } + deriving stock (Eq, Show, Generic) + deriving anyclass (FromJSON, ToJSON) + +data Signed = Signed + { targets :: KeyMap Target + } + deriving stock (Eq, Show, Generic) + deriving anyclass (FromJSON, ToJSON) + +data Target = Target + { hashes :: Hashes + } + deriving stock (Eq, Show, Generic) + deriving anyclass (FromJSON, ToJSON) + +data Hashes = Hashes + { sha256 :: Text + } + deriving stock (Eq, Show, Generic) + deriving anyclass (FromJSON, ToJSON) + +data ImportFileType + = CabalFile FilePath + | JSONFile FilePath diff --git a/src/core/Flora/Model/BlobIndex/Update.hs b/src/core/Flora/Model/BlobIndex/Update.hs index c73956a7..8f02cdd0 100644 --- a/src/core/Flora/Model/BlobIndex/Update.hs +++ b/src/core/Flora/Model/BlobIndex/Update.hs @@ -10,7 +10,6 @@ import Data.Text.Display (display) import Effectful (Eff, type (:>)) import Effectful.Log (Log) import Effectful.PostgreSQL.Transact.Effect (DB, dbtToEff) -import Effectful.Time (Time) import Log qualified import Database.PostgreSQL.Entity (Entity, _insert) @@ -31,7 +30,7 @@ import Flora.Model.Release.Types (Release (..), ReleaseId (..)) import Flora.Model.Release.Update qualified as Update insertTar - :: (Log :> es, DB :> es, BlobStoreAPI :> es, Time :> es) + :: (Log :> es, DB :> es, BlobStoreAPI :> es) => PackageName -> Version -> LazyByteString diff --git a/src/core/Flora/Model/Package/Query.hs b/src/core/Flora/Model/Package/Query.hs index f55f987e..a8f4b7a2 100644 --- a/src/core/Flora/Model/Package/Query.hs +++ b/src/core/Flora/Model/Package/Query.hs @@ -86,21 +86,13 @@ getAllPackages = do getPackagesByNamespace :: DB :> es => Namespace -> Eff es (Vector Package) getPackagesByNamespace namespace = dbtToEff $ selectManyByField @Package [field| namespace |] (Only namespace) -getPackageByNamespaceAndName :: (DB :> es, Log :> es, Time :> es) => Namespace -> PackageName -> Eff es (Maybe Package) +getPackageByNamespaceAndName :: DB :> es => Namespace -> PackageName -> Eff es (Maybe Package) getPackageByNamespaceAndName namespace name = do - (result, duration) <- - timeAction $ - dbtToEff $ - queryOne - Select - (_selectWhere @Package [[field| namespace |], [field| name |]]) - (namespace, name) - Log.logInfo "Get package by namespace and name" $ - object - [ "duration" .= duration - , "package" .= result - ] - pure result + dbtToEff $ + queryOne + Select + (_selectWhere @Package [[field| namespace |], [field| name |]]) + (namespace, name) getNonDeprecatedPackages :: DB :> es => Eff es (Vector Package) getNonDeprecatedPackages = dbtToEff $ selectWhereNull @Package [[field| deprecation_info |]] diff --git a/src/core/Flora/Model/Release/Types.hs b/src/core/Flora/Model/Release/Types.hs index 67aa55b5..a95afb20 100644 --- a/src/core/Flora/Model/Release/Types.hs +++ b/src/core/Flora/Model/Release/Types.hs @@ -83,7 +83,7 @@ data Release = Release { releaseId :: ReleaseId , packageId :: PackageId , version :: Version - , archiveChecksum :: Text + , archiveChecksum :: Maybe Text , uploadedAt :: Maybe UTCTime , createdAt :: UTCTime , updatedAt :: UTCTime diff --git a/src/core/Flora/Model/Release/Update.hs b/src/core/Flora/Model/Release/Update.hs index 7358f952..7bb7eddc 100644 --- a/src/core/Flora/Model/Release/Update.hs +++ b/src/core/Flora/Model/Release/Update.hs @@ -17,6 +17,7 @@ import Crypto.Hash.SHA256 qualified as SHA import Data.ByteString (toStrict) import Data.ByteString.Lazy (LazyByteString) import Data.Function ((&)) +import Data.Text (Text) import Data.Time (UTCTime) import Data.Vector (Vector) import Data.Vector qualified as Vector @@ -108,3 +109,12 @@ setReleasesDeprecationMarker releaseVersions = FROM (VALUES (?,?)) as upd(x,y) WHERE r0.release_id = (upd.y :: uuid) |] + +setArchiveChecksum :: DB :> es => ReleaseId -> Text -> Eff es () +setArchiveChecksum releaseId sha256Hash = + dbtToEff $ + void $ + updateFieldsBy @Release + [[field| archive_checksum |]] + ([field| release_id |], releaseId) + (Only sha256Hash) diff --git a/src/core/Flora/Publish.hs b/src/core/Flora/Publish.hs index b3c7e895..2dc55161 100644 --- a/src/core/Flora/Publish.hs +++ b/src/core/Flora/Publish.hs @@ -4,9 +4,7 @@ import Control.Monad import Data.Text.Display import Data.Text.IO qualified as T import Effectful -import Effectful.Log import Effectful.PostgreSQL.Transact.Effect -import Effectful.Time import Flora.Import.Categories.Tuning import Flora.Import.Categories.Tuning qualified as Tuning @@ -25,7 +23,7 @@ import Flora.Model.Requirement (Requirement) -} publishPackage - :: (DB :> es, Log :> es, Time :> es, IOE :> es) + :: (DB :> es, IOE :> es) => [Requirement] -> [PackageComponent] -> Release diff --git a/src/core/Flora/Tracing.hs b/src/core/Flora/Tracing.hs new file mode 100644 index 00000000..5d7cebfc --- /dev/null +++ b/src/core/Flora/Tracing.hs @@ -0,0 +1,25 @@ +module Flora.Tracing where + +import Data.Text (Text) +import Data.Text qualified as Text +import Monitor.Tracing.Zipkin (Zipkin) +import Monitor.Tracing.Zipkin qualified as ZPK + +newZipkin + :: Text + -- ^ Zipkin server URL + -> Text + -- ^ Flora instance identifier + -> IO Zipkin +newZipkin serverURL serviceName = do + let settings = + ZPK.defaultSettings + { ZPK.settingsEndpoint = + Just $ + ZPK.defaultEndpoint + { ZPK.endpointService = Just serviceName + } + , ZPK.settingsHostname = Just $ Text.unpack serverURL + , ZPK.settingsPublishPeriod = 1 + } + ZPK.new settings diff --git a/src/jobs-worker/FloraJobs/Runner.hs b/src/jobs-worker/FloraJobs/Runner.hs index b15c9346..23e31ee6 100644 --- a/src/jobs-worker/FloraJobs/Runner.hs +++ b/src/jobs-worker/FloraJobs/Runner.hs @@ -105,7 +105,6 @@ makeReadme pay@ReadmeJobPayload{..} = fetchTarball :: ( IOE :> es - , Time :> es , DB :> es , Reader JobsRunnerEnv :> es , Log :> es diff --git a/src/web/FloraWeb/API/Server/Packages.hs b/src/web/FloraWeb/API/Server/Packages.hs index 68b042a6..37654f7e 100644 --- a/src/web/FloraWeb/API/Server/Packages.hs +++ b/src/web/FloraWeb/API/Server/Packages.hs @@ -5,12 +5,11 @@ import Data.Maybe (fromMaybe) import Data.Vector qualified as Vector import Distribution.Version (Version) import Effectful (Eff, (:>)) -import Servant hiding ((:>)) - import Effectful.Error.Static (Error) -import Effectful.Log (Log) import Effectful.PostgreSQL.Transact.Effect (DB) -import Effectful.Time (Time) +import Effectful.Trace +import Servant hiding ((:>)) + import Flora.Model.Component.Query qualified as Query import Flora.Model.Package.Types import Flora.Model.Release.Query qualified as Query @@ -35,7 +34,10 @@ withPackageServer namespace packageName = } getPackageHandler - :: (Time :> es, Log :> es, DB :> es, Error ServerError :> es) + :: ( DB :> es + , Error ServerError :> es + , Trace :> es + ) => Namespace -> PackageName -> (Eff es) (PackageDTO 0) @@ -56,7 +58,10 @@ getPackageHandler namespace packageName = do pure $ toPackageDTO package release components getVersionedPackageHandler - :: (Time :> es, Log :> es, DB :> es, Error ServerError :> es) + :: ( DB :> es + , Error ServerError :> es + , Trace :> es + ) => Namespace -> PackageName -> Version diff --git a/src/web/FloraWeb/Common/Guards.hs b/src/web/FloraWeb/Common/Guards.hs index 5edeb115..459154d0 100644 --- a/src/web/FloraWeb/Common/Guards.hs +++ b/src/web/FloraWeb/Common/Guards.hs @@ -5,11 +5,11 @@ module FloraWeb.Common.Guards where import Data.Text (Text) import Distribution.Types.Version (Version) import Effectful -import Effectful.Log (Log) import Effectful.PostgreSQL.Transact.Effect -import Effectful.Time (Time) +import Effectful.Trace import FloraWeb.Pages.Templates import Log qualified +import Monitor.Tracing qualified as Tracing import Optics.Core import Servant (respond) import Servant.API.UVerb @@ -27,14 +27,16 @@ import FloraWeb.Session (Session) import FloraWeb.Types (FloraEff) guardThatPackageExists - :: (DB :> es, Log :> es, Time :> es) + :: (DB :> es, Trace :> es) => Namespace -> PackageName -> (Namespace -> PackageName -> Eff es Package) -- ^ Action to run if the package does not exist -> Eff es Package guardThatPackageExists namespace packageName action = do - result <- Query.getPackageByNamespaceAndName namespace packageName + result <- + Tracing.childSpan "Query.getPackageByNamespaceAndName " $ + Query.getPackageByNamespaceAndName namespace packageName case result of Nothing -> action namespace packageName Just package -> @@ -43,14 +45,16 @@ guardThatPackageExists namespace packageName action = do UnknownPackage -> action namespace packageName guardThatReleaseExists - :: DB :> es + :: (DB :> es, Trace :> es) => PackageId -> Version -> (Version -> Eff es Release) -- ^ Action to run if the package does not exist -> Eff es Release guardThatReleaseExists packageId version action = do - result <- Query.getReleaseByVersion packageId version + result <- + Tracing.childSpan "Query.getReleaseByVersion" $ + Query.getReleaseByVersion packageId version case result of Just release -> pure release Nothing -> action version diff --git a/src/web/FloraWeb/Pages/Server/Packages.hs b/src/web/FloraWeb/Pages/Server/Packages.hs index 492d820e..05c85a58 100644 --- a/src/web/FloraWeb/Pages/Server/Packages.hs +++ b/src/web/FloraWeb/Pages/Server/Packages.hs @@ -8,7 +8,6 @@ import Control.Monad (unless) import Data.ByteString.Lazy (ByteString) import Data.Foldable import Data.Function -import Data.Map.Strict as Map import Data.Maybe (fromMaybe, isJust, isNothing) import Data.Positive import Data.Text (Text) @@ -19,10 +18,12 @@ import Distribution.Types.Version (Version) import Effectful (Eff, IOE, (:>)) import Effectful.Error.Static (Error, throwError) import Effectful.Reader.Static (Reader, ask) +import Effectful.Trace import Log (object, (.=)) import Log qualified import Lucid import Lucid.Orphans () +import Monitor.Tracing qualified as Tracing import Servant (Headers (..), ServerError, ServerT) import Servant.Server (err404) @@ -30,7 +31,6 @@ import Effectful.Log (Log) import Effectful.PostgreSQL.Transact.Effect (DB) import Effectful.Time (Time) import Flora.Environment (FeatureEnv (..)) -import Flora.Logging import Flora.Model.BlobIndex.Query qualified as Query import Flora.Model.BlobStore.API (BlobStoreAPI) import Flora.Model.Package @@ -71,154 +71,218 @@ server = } listPackagesHandler - :: (DB :> es, Reader FeatureEnv :> es, IOE :> es) + :: ( DB :> es + , Reader FeatureEnv :> es + , IOE :> es + , Trace :> es + ) => SessionWithCookies (Maybe User) -> Maybe (Positive Word) -> Eff es (Html ()) listPackagesHandler (Headers session _) pageParam = do - let pageNumber = pageParam ?: PositiveUnsafe 1 - templateDefaults <- templateFromSession session defaultTemplateEnv - (count', results) <- Search.listAllPackages (fromPage pageNumber) - render templateDefaults $ Search.showAllPackages count' pageNumber results + Tracing.rootSpan alwaysSampled "list-all-packages" $ do + let pageNumber = pageParam ?: PositiveUnsafe 1 + templateDefaults <- templateFromSession session defaultTemplateEnv + (count', results) <- Search.listAllPackages (fromPage pageNumber) + render templateDefaults $ Search.showAllPackages count' pageNumber results showNamespaceHandler - :: (DB :> es, Reader FeatureEnv :> es, Time :> es, Error ServerError :> es, Log :> es, IOE :> es) + :: ( DB :> es + , Reader FeatureEnv :> es + , Time :> es + , Error ServerError :> es + , Log :> es + , IOE :> es + , Trace :> es + ) => SessionWithCookies (Maybe User) -> Namespace -> Maybe (Positive Word) -> Eff es (Html ()) -showNamespaceHandler (Headers session _) namespace pageParam = do - let pageNumber = pageParam ?: PositiveUnsafe 1 - templateDefaults <- templateFromSession session defaultTemplateEnv - (count', results) <- Search.listAllPackagesInNamespace (fromPage pageNumber) namespace - if extractNamespaceText namespace == "haskell" - then do - let description = "Core Haskell packages" - let templateEnv = - templateDefaults - { navbarSearchContent = Just $ "in:" <> display namespace <> " " - , description = description - } - render templateEnv $ - Search.showAllPackagesInNamespace - namespace - description - count' - pageNumber - results - else do - mPackageIndex <- Query.getPackageIndexByName (extractNamespaceText namespace) - case mPackageIndex of - Nothing -> renderError templateDefaults notFound404 - Just packageIndex -> do - let templateEnv = - templateDefaults - { navbarSearchContent = Just $ "in:" <> display namespace <> " " - , description = packageIndex.description - } - render templateEnv $ - Search.showAllPackagesInNamespace namespace packageIndex.description count' pageNumber results +showNamespaceHandler (Headers session _) packageNamespace pageParam = + Tracing.rootSpan alwaysSampled "show-namespace" $ do + let pageNumber = pageParam ?: PositiveUnsafe 1 + templateDefaults <- templateFromSession session defaultTemplateEnv + (count', results) <- Search.listAllPackagesInNamespace (fromPage pageNumber) packageNamespace + if extractNamespaceText packageNamespace == "haskell" + then do + let description = "Core Haskell packages" + let templateEnv = + templateDefaults + { navbarSearchContent = Just $ "in:" <> display packageNamespace <> " " + , description = description + } + render templateEnv $ + Search.showAllPackagesInNamespace + packageNamespace + description + count' + pageNumber + results + else do + mPackageIndex <- Query.getPackageIndexByName (extractNamespaceText packageNamespace) + case mPackageIndex of + Nothing -> renderError templateDefaults notFound404 + Just packageIndex -> do + let templateEnv = + templateDefaults + { navbarSearchContent = Just $ "in:" <> display packageNamespace <> " " + , description = packageIndex.description + } + render templateEnv $ + Search.showAllPackagesInNamespace packageNamespace packageIndex.description count' pageNumber results showPackageHandler - :: (DB :> es, Reader FeatureEnv :> es, Time :> es, Error ServerError :> es, Log :> es, IOE :> es) + :: ( DB :> es + , Reader FeatureEnv :> es + , Time :> es + , Error ServerError :> es + , Log :> es + , IOE :> es + , Trace :> es + ) => SessionWithCookies (Maybe User) -> Namespace -> PackageName -> Eff es (Html ()) -showPackageHandler sessionWithCookies namespace packageName = showPackageVersion sessionWithCookies namespace packageName Nothing +showPackageHandler sessionWithCookies packageNamespace packageName = + showPackageVersion sessionWithCookies packageNamespace packageName Nothing showVersionHandler - :: (DB :> es, Reader FeatureEnv :> es, Time :> es, Error ServerError :> es, Log :> es, IOE :> es) + :: ( DB :> es + , Reader FeatureEnv :> es + , Time :> es + , Error ServerError :> es + , Log :> es + , IOE :> es + , Trace :> es + ) => SessionWithCookies (Maybe User) -> Namespace -> PackageName -> Version -> Eff es (Html ()) -showVersionHandler sessionWithCookies namespace packageName version = - showPackageVersion sessionWithCookies namespace packageName (Just version) +showVersionHandler sessionWithCookies packageNamespace packageName version = + showPackageVersion sessionWithCookies packageNamespace packageName (Just version) showPackageVersion - :: (DB :> es, Reader FeatureEnv :> es, Time :> es, Error ServerError :> es, Log :> es, IOE :> es) + :: ( DB :> es + , Reader FeatureEnv :> es + , Time :> es + , Error ServerError :> es + , Log :> es + , IOE :> es + , Trace :> es + ) => SessionWithCookies (Maybe User) -> Namespace -> PackageName -> Maybe Version -> Eff es (Html ()) -showPackageVersion (Headers session _) namespace packageName mversion = do - templateEnv' <- templateFromSession session defaultTemplateEnv - package <- guardThatPackageExists namespace packageName (\_ _ -> web404 session) - packageIndex <- guardThatPackageIndexExists namespace $ const (web404 session) - releases <- Query.getReleases package.packageId - let latestRelease = - releases - & Vector.filter (\r -> r.deprecated /= Just True) - & maximumBy (compare `on` (.version)) - version = fromMaybe latestRelease.version mversion - release <- guardThatReleaseExists package.packageId version $ const (web404 session) - numberOfReleases <- Query.getNumberOfReleases package.packageId - dependents <- Query.getPackageDependents namespace packageName - releaseDependencies <- Query.getRequirements package.name release.releaseId - categories <- Query.getPackageCategories package.packageId - numberOfDependents <- Query.getNumberOfPackageDependents namespace packageName Nothing - numberOfDependencies <- Query.getNumberOfPackageRequirements release.releaseId +showPackageVersion (Headers session _) packageNamespace packageName mversion = + Tracing.rootSpan alwaysSampled "show-package-with-version" $ do + templateEnv' <- templateFromSession session defaultTemplateEnv + package <- + Tracing.childSpan "guardThatPackageExists " $ + guardThatPackageExists packageNamespace packageName (\_ _ -> web404 session) + packageIndex <- + Tracing.childSpan "guardThatPackageIndexExists " $ + guardThatPackageIndexExists packageNamespace $ + const (web404 session) + releases <- + Tracing.childSpan "Query.getReleases" $ + Query.getReleases package.packageId + let latestRelease = + releases + & Vector.filter (\r -> r.deprecated /= Just True) + & maximumBy (compare `on` (.version)) + version = fromMaybe latestRelease.version mversion + release <- guardThatReleaseExists package.packageId version $ const (web404 session) + numberOfReleases <- Query.getNumberOfReleases package.packageId + dependents <- + Tracing.childSpan "Query.getPackageDependents" $ + Query.getPackageDependents packageNamespace packageName + releaseDependencies <- + Tracing.childSpan "Query.getRequirements" $ + Query.getRequirements package.name release.releaseId + categories <- Query.getPackageCategories package.packageId + numberOfDependents <- + Tracing.childSpan "Query.getNumberOfPackageDependents" $ + Query.getNumberOfPackageDependents packageNamespace packageName Nothing + numberOfDependencies <- Query.getNumberOfPackageRequirements release.releaseId - let templateEnv = - templateEnv' - { title = display namespace <> "/" <> display packageName - , description = release.synopsis - , indexPage = isNothing mversion - } + let templateEnv = + templateEnv' + { title = display packageNamespace <> "/" <> display packageName + , description = release.synopsis + , indexPage = isNothing mversion + } - Log.logInfo "displaying a package" $ - object - [ "release" - .= object - [ "id" .= release.releaseId - , "version" .= display release.version - ] - , "dependencies" - .= object - [ "count" .= numberOfDependencies - ] - , "dependents" - .= object - [ "count" .= numberOfDependents - ] - , "package" .= (display namespace <> "/" <> display packageName) - , "releases" .= numberOfReleases - ] + Log.logInfo "displaying a package" $ + object + [ "release" + .= object + [ "id" .= release.releaseId + , "version" .= display release.version + ] + , "dependencies" + .= object + [ "count" .= numberOfDependencies + ] + , "dependents" + .= object + [ "count" .= numberOfDependents + ] + , "package" .= (display packageNamespace <> "/" <> display packageName) + , "releases" .= numberOfReleases + ] - let packageIndexURL = packageIndex.url + let packageIndexURL = packageIndex.url - render templateEnv $ - Packages.showPackage - release - releases - numberOfReleases - package - packageIndexURL - dependents - numberOfDependents - releaseDependencies - numberOfDependencies - categories + Tracing.childSpan "render showPackage" $ + render templateEnv $ + Packages.showPackage + release + releases + numberOfReleases + package + packageIndexURL + dependents + numberOfDependents + releaseDependencies + numberOfDependencies + categories showDependentsHandler - :: (DB :> es, Reader FeatureEnv :> es, Time :> es, Error ServerError :> es, Log :> es, IOE :> es) + :: ( DB :> es + , Reader FeatureEnv :> es + , Time :> es + , Error ServerError :> es + , Log :> es + , IOE :> es + , Trace :> es + ) => SessionWithCookies (Maybe User) -> Namespace -> PackageName -> Maybe (Positive Word) -> Maybe Text -> Eff es (Html ()) -showDependentsHandler s@(Headers session _) namespace packageName mPage mSearch = do - package <- guardThatPackageExists namespace packageName (\_ _ -> web404 session) +showDependentsHandler s@(Headers session _) packageNamespace packageName mPage mSearch = do + package <- guardThatPackageExists packageNamespace packageName (\_ _ -> web404 session) releases <- Query.getAllReleases package.packageId let latestRelease = maximumBy (compare `on` (.version)) releases - showVersionDependentsHandler s namespace packageName latestRelease.version mPage mSearch + showVersionDependentsHandler s packageNamespace packageName latestRelease.version mPage mSearch showVersionDependentsHandler - :: (DB :> es, Reader FeatureEnv :> es, Log :> es, Time :> es, Error ServerError :> es, IOE :> es) + :: ( DB :> es + , Reader FeatureEnv :> es + , Log :> es + , Time :> es + , Error ServerError :> es + , IOE :> es + , Trace :> es + ) => SessionWithCookies (Maybe User) -> Namespace -> PackageName @@ -226,134 +290,176 @@ showVersionDependentsHandler -> Maybe (Positive Word) -> Maybe Text -> Eff es (Html ()) -showVersionDependentsHandler s namespace packageName version Nothing mSearch = - showVersionDependentsHandler s namespace packageName version (Just $ PositiveUnsafe 1) mSearch -showVersionDependentsHandler s namespace packageName version pageNumber (Just "") = - showVersionDependentsHandler s namespace packageName version pageNumber Nothing -showVersionDependentsHandler (Headers session _) namespace packageName version (Just pageNumber) mSearch = do - templateEnv' <- templateFromSession session defaultTemplateEnv - package <- guardThatPackageExists namespace packageName (\_ _ -> web404 session) - release <- guardThatReleaseExists package.packageId version (const (web404 session)) - let templateEnv = - templateEnv' - { title = display namespace <> "/" <> display packageName - , description = "Dependents of " <> display namespace <> "/" <> display packageName - , navbarSearchContent = Just $ "depends:" <> display namespace <> "/" <> display packageName <> " " - } - results <- - Query.getAllPackageDependentsWithLatestVersion - namespace - packageName - (fromPage pageNumber) - mSearch +showVersionDependentsHandler s packageNamespace packageName version Nothing mSearch = + showVersionDependentsHandler s packageNamespace packageName version (Just $ PositiveUnsafe 1) mSearch +showVersionDependentsHandler s packageNamespace packageName version pageNumber (Just "") = + showVersionDependentsHandler s packageNamespace packageName version pageNumber Nothing +showVersionDependentsHandler (Headers session _) packageNamespace packageName version (Just pageNumber) mSearch = do + Tracing.rootSpan alwaysSampled "show-package-version-dependents" $ do + templateEnv' <- templateFromSession session defaultTemplateEnv + package <- guardThatPackageExists packageNamespace packageName (\_ _ -> web404 session) + release <- guardThatReleaseExists package.packageId version (const (web404 session)) + let templateEnv = + templateEnv' + { title = display packageNamespace <> "/" <> display packageName + , description = "Dependents of " <> display packageNamespace <> "/" <> display packageName + , navbarSearchContent = Just $ "depends:" <> display packageNamespace <> "/" <> display packageName <> " " + } + results <- + Tracing.childSpan "Query.getPackageDependents" $ + Query.getAllPackageDependentsWithLatestVersion + packageNamespace + packageName + (fromPage pageNumber) + mSearch - totalDependents <- Query.getNumberOfPackageDependents namespace packageName mSearch - render templateEnv $ - Package.showDependents - namespace - packageName - release - totalDependents - results - pageNumber + totalDependents <- Query.getNumberOfPackageDependents packageNamespace packageName mSearch + Tracing.childSpan "render showDependents" $ + render templateEnv $ + Package.showDependents + packageNamespace + packageName + release + totalDependents + results + pageNumber -showDependenciesHandler :: (DB :> es, Reader FeatureEnv :> es, Time :> es, Log :> es, Error ServerError :> es, IOE :> es) => SessionWithCookies (Maybe User) -> Namespace -> PackageName -> Eff es (Html ()) -showDependenciesHandler s@(Headers session _) namespace packageName = do - package <- guardThatPackageExists namespace packageName (\_ _ -> web404 session) +showDependenciesHandler + :: ( DB :> es + , Reader FeatureEnv :> es + , Error ServerError :> es + , IOE :> es + , Trace :> es + ) + => SessionWithCookies (Maybe User) + -> Namespace + -> PackageName + -> Eff es (Html ()) +showDependenciesHandler s@(Headers session _) packageNamespace packageName = do + package <- guardThatPackageExists packageNamespace packageName (\_ _ -> web404 session) releases <- Query.getAllReleases package.packageId let latestRelease = maximumBy (compare `on` (.version)) releases - showVersionDependenciesHandler s namespace packageName latestRelease.version + showVersionDependenciesHandler s packageNamespace packageName latestRelease.version -showVersionDependenciesHandler :: (DB :> es, Reader FeatureEnv :> es, IOE :> es, Log :> es, Time :> es, Error ServerError :> es) => SessionWithCookies (Maybe User) -> Namespace -> PackageName -> Version -> Eff es (Html ()) -showVersionDependenciesHandler (Headers session _) namespace packageName version = do - templateEnv' <- templateFromSession session defaultTemplateEnv - package <- guardThatPackageExists namespace packageName (\_ _ -> web404 session) - release <- guardThatReleaseExists package.packageId version $ const (web404 session) - let templateEnv = - templateEnv' - { title = display namespace <> "/" <> display packageName - , description = "Dependencies of " <> display namespace <> display packageName - } - (releaseDependencies, duration) <- - timeAction $ - Query.getAllRequirements release.releaseId - - Log.logInfo "Retrieving all dependencies of the latest release of a package" $ - object - [ "duration" .= duration - , "package" .= (display namespace <> "/" <> display packageName) - , "release_id" .= release.releaseId - , "component_count" .= Map.size releaseDependencies - , "dependencies_count" .= Map.foldl' (\acc ds -> acc + Vector.length ds) 0 releaseDependencies - ] +showVersionDependenciesHandler + :: ( DB :> es + , Reader FeatureEnv :> es + , IOE :> es + , Error ServerError :> es + , Trace :> es + ) + => SessionWithCookies (Maybe User) + -> Namespace + -> PackageName + -> Version + -> Eff es (Html ()) +showVersionDependenciesHandler (Headers session _) packageNamespace packageName version = do + Tracing.rootSpan alwaysSampled "show-version-dependencies" $ do + templateEnv' <- templateFromSession session defaultTemplateEnv + package <- guardThatPackageExists packageNamespace packageName (\_ _ -> web404 session) + release <- guardThatReleaseExists package.packageId version $ const (web404 session) + let templateEnv = + templateEnv' + { title = display packageNamespace <> "/" <> display packageName + , description = "Dependencies of " <> display packageNamespace <> display packageName + } + releaseDependencies <- + Tracing.childSpan "Query.getAllRequirements" $ + Query.getAllRequirements release.releaseId - render templateEnv $ - Package.showDependencies namespace packageName release releaseDependencies + Tracing.childSpan "render showDependencies" $ + render templateEnv $ + Package.showDependencies packageNamespace packageName release releaseDependencies showChangelogHandler - :: (DB :> es, Reader FeatureEnv :> es, Time :> es, Log :> es, Error ServerError :> es, IOE :> es) + :: ( DB :> es + , Reader FeatureEnv :> es + , Error ServerError :> es + , IOE :> es + , Trace :> es + ) => SessionWithCookies (Maybe User) -> Namespace -> PackageName -> Eff es (Html ()) -showChangelogHandler s@(Headers session _) namespace packageName = do - package <- guardThatPackageExists namespace packageName (\_ _ -> web404 session) - releases <- Query.getAllReleases package.packageId - let latestRelease = maximumBy (compare `on` (.version)) releases - showVersionChangelogHandler s namespace packageName latestRelease.version +showChangelogHandler s@(Headers session _) packageNamespace packageName = do + Tracing.rootSpan alwaysSampled "show-changelog" $ do + package <- guardThatPackageExists packageNamespace packageName (\_ _ -> web404 session) + releases <- + Tracing.childSpan "Query.getAllReleases" $ + Query.getAllReleases package.packageId + let latestRelease = maximumBy (compare `on` (.version)) releases + showVersionChangelogHandler s packageNamespace packageName latestRelease.version showVersionChangelogHandler - :: (DB :> es, Reader FeatureEnv :> es, Log :> es, Time :> es, IOE :> es, Error ServerError :> es) + :: ( DB :> es + , Reader FeatureEnv :> es + , IOE :> es + , Error ServerError :> es + , Trace :> es + ) => SessionWithCookies (Maybe User) -> Namespace -> PackageName -> Version -> Eff es (Html ()) -showVersionChangelogHandler (Headers session _) namespace packageName version = do - Log.logInfo_ $ display namespace - templateEnv' <- templateFromSession session defaultTemplateEnv - package <- guardThatPackageExists namespace packageName (\_ _ -> web404 session) - release <- guardThatReleaseExists package.packageId version $ const (web404 session) - let templateEnv = - templateEnv' - { title = display namespace <> "/" <> display packageName - , description = "Changelog of @" <> display namespace <> display packageName - } +showVersionChangelogHandler (Headers session _) packageNamespace packageName version = do + Tracing.rootSpan alwaysSampled "show-version-changelog" $ do + templateEnv' <- templateFromSession session defaultTemplateEnv + package <- guardThatPackageExists packageNamespace packageName (\_ _ -> web404 session) + release <- guardThatReleaseExists package.packageId version $ const (web404 session) + let templateEnv = + templateEnv' + { title = display packageNamespace <> "/" <> display packageName + , description = "Changelog of " <> display packageNamespace <> "/" <> display packageName + } - render templateEnv $ Package.showChangelog namespace packageName version release.changelog + render templateEnv $ Package.showChangelog packageNamespace packageName version release.changelog listVersionsHandler - :: (DB :> es, Reader FeatureEnv :> es, IOE :> es, Log :> es, Time :> es, Error ServerError :> es) + :: ( DB :> es + , Reader FeatureEnv :> es + , IOE :> es + , Error ServerError :> es + , Trace :> es + ) => SessionWithCookies (Maybe User) -> Namespace -> PackageName -> Eff es (Html ()) -listVersionsHandler (Headers session _) namespace packageName = do +listVersionsHandler (Headers session _) packageNamespace packageName = do templateEnv' <- templateFromSession session defaultTemplateEnv - package <- guardThatPackageExists namespace packageName (\_ _ -> web404 session) + package <- guardThatPackageExists packageNamespace packageName (\_ _ -> web404 session) let templateEnv = templateEnv' - { title = display namespace <> "/" <> display packageName - , description = "Releases of " <> display namespace <> display packageName + { title = display packageNamespace <> "/" <> display packageName + , description = "Releases of " <> display packageNamespace <> display packageName } releases <- Query.getAllReleases package.packageId - render templateEnv $ Package.listVersions namespace packageName releases + render templateEnv $ Package.listVersions packageNamespace packageName releases constructTarballPath :: PackageName -> Version -> Text constructTarballPath pname v = display pname <> "-" <> display v <> ".tar.gz" getTarballHandler - :: (DB :> es, Reader FeatureEnv :> es, Log :> es, Time :> es, IOE :> es, Error ServerError :> es, BlobStoreAPI :> es) + :: ( DB :> es + , Reader FeatureEnv :> es + , Log :> es + , IOE :> es + , Error ServerError :> es + , BlobStoreAPI :> es + , Trace :> es + ) => SessionWithCookies (Maybe User) -> Namespace -> PackageName -> Version -> Text -> Eff es ByteString -getTarballHandler (Headers session _) namespace packageName version tarballName = do +getTarballHandler (Headers session _) packageNamespace packageName version tarballName = do features <- ask @FeatureEnv unless (isJust features.blobStoreImpl) $ throwError err404 - package <- guardThatPackageExists namespace packageName $ \_ _ -> web404 session + package <- guardThatPackageExists packageNamespace packageName $ \_ _ -> web404 session release <- guardThatReleaseExists package.packageId version $ const (web404 session) case release.tarballRootHash of Just rootHash diff --git a/src/web/FloraWeb/Server.hs b/src/web/FloraWeb/Server.hs index c366c78f..44f675eb 100644 --- a/src/web/FloraWeb/Server.hs +++ b/src/web/FloraWeb/Server.hs @@ -17,8 +17,10 @@ import Effectful.Fail (runFailIO) import Effectful.PostgreSQL.Transact.Effect (runDB) import Effectful.Reader.Static (runReader) import Effectful.Time (runTime) +import Effectful.Trace qualified as Trace import Log (Logger) import Log qualified +import Monitor.Tracing.Zipkin (Zipkin (..)) import Network.HTTP.Client qualified as HTTP import Network.HTTP.Client.TLS (tlsManagerSettings) import Network.HTTP.Types (notFound404) @@ -60,9 +62,10 @@ import Flora.Environment , LoggingEnv (..) , getFloraEnv ) -import Flora.Environment.Config (Assets) +import Flora.Environment.Config (Assets, DeploymentEnv (..)) import Flora.Logging qualified as Logging import Flora.Model.BlobStore.API +import Flora.Tracing qualified as Tracing import FloraJobs.Runner (runner) import FloraJobs.Types (JobsRunnerEnv (..), makeConfig, makeUIConfig) import FloraWeb.API.Routes qualified as API @@ -101,6 +104,7 @@ runFlora = let baseURL = "http://localhost:" <> display env.httpPort liftIO $ blueMessage $ "🌺 Starting Flora server on " <> baseURL liftIO $ when (isJust env.logging.sentryDSN) (blueMessage "📋 Connected to Sentry endpoint") + liftIO $ when (env.environment == Production) (blueMessage "🖊️ Connected to Zipkin endpoint") let withLogger = Logging.makeLogger env.logging.logger withLogger ( \appLogger -> @@ -127,6 +131,7 @@ logException env logger exception = runServer :: (Concurrent :> es, IOE :> es) => Logger -> FloraEnv -> Eff es () runServer appLogger floraEnv = do httpManager <- liftIO $ HTTP.newManager tlsManagerSettings + zipkin <- liftIO $ Tracing.newZipkin "localhost" "flora-server-local" let runnerEnv = JobsRunnerEnv httpManager let oddjobsUiCfg = makeUIConfig floraEnv.config appLogger floraEnv.jobsPool oddJobsCfg = @@ -145,7 +150,7 @@ runServer appLogger floraEnv = do oddJobsEnv <- OddJobs.mkEnv oddjobsUiCfg ("/admin/odd-jobs/" <>) let webEnv = WebEnv floraEnv webEnvStore <- liftIO $ newWebEnvStore webEnv - let server = mkServer appLogger webEnvStore floraEnv oddjobsUiCfg oddJobsEnv + let server = mkServer appLogger webEnvStore floraEnv oddjobsUiCfg oddJobsEnv zipkin let warpSettings = setPort (fromIntegral floraEnv.httpPort) $ setOnException @@ -168,12 +173,13 @@ mkServer -> FloraEnv -> OddJobs.UIConfig -> OddJobs.Env + -> Zipkin -> Application -mkServer logger webEnvStore floraEnv cfg jobsRunnerEnv = +mkServer logger webEnvStore floraEnv cfg jobsRunnerEnv zipkin = serveWithContextT (Proxy @ServerRoutes) (genAuthServerContext logger floraEnv) - (naturalTransform floraEnv logger webEnvStore) + (naturalTransform floraEnv logger webEnvStore zipkin) (floraServer cfg jobsRunnerEnv) floraServer @@ -190,12 +196,17 @@ floraServer cfg jobsRunnerEnv = , docs = serveDirectoryWith docsBundler } -naturalTransform :: FloraEnv -> Logger -> WebEnvStore -> FloraEff a -> Handler a -naturalTransform floraEnv logger _webEnvStore app = do +naturalTransform :: FloraEnv -> Logger -> WebEnvStore -> Zipkin -> FloraEff a -> Handler a +naturalTransform floraEnv logger _webEnvStore zipkin app = do + let runTrace = + if floraEnv.environment == Development + then Trace.runTrace zipkin.zipkinTracer + else Trace.runNoTrace result <- liftIO $ Right <$> app + & runTrace & runDB floraEnv.pool & runTime & runReader floraEnv.features diff --git a/src/web/FloraWeb/Types.hs b/src/web/FloraWeb/Types.hs index 4407d066..3d769e3c 100644 --- a/src/web/FloraWeb/Types.hs +++ b/src/web/FloraWeb/Types.hs @@ -23,6 +23,7 @@ import Effectful.Log (Log) import Effectful.PostgreSQL.Transact.Effect (DB) import Effectful.Reader.Static (Reader) import Effectful.Time (Time) +import Effectful.Trace import GHC.Clock (getMonotonicTime) import GHC.Generics import Servant (FromHttpApiData (..), Handler, ServerError) @@ -36,7 +37,8 @@ newtype WebEnvStore = WebEnvStore (MVar WebEnv) type FloraEff = Eff RouteEffects type RouteEffects = - '[ DB + '[ Trace + , DB , Time , Reader FeatureEnv , BlobStoreAPI diff --git a/test/Flora/TestUtils.hs b/test/Flora/TestUtils.hs index 0968e66d..78cbeeef 100644 --- a/test/Flora/TestUtils.hs +++ b/test/Flora/TestUtils.hs @@ -473,7 +473,7 @@ data ReleaseTemplate m = ReleaseTemplate { releaseId :: m ReleaseId , packageId :: m PackageId , version :: m Version - , archiveChecksum :: m Text + , archiveChecksum :: m (Maybe Text) , uploadedAt :: m (Maybe UTCTime) , createdAt :: m UTCTime , updatedAt :: m UTCTime @@ -508,7 +508,7 @@ randomReleaseTemplate = , version = do result <- H.sample $ H.nonEmpty (Range.singleton 4) (H.int (Range.constant 0 10)) pure $ Version.mkVersion $ NE.toList result - , archiveChecksum = H.sample $ H.text (Range.singleton 30) H.ascii + , archiveChecksum = pure Nothing , uploadedAt = Just <$> H.sample genUTCTime , updatedAt = H.sample genUTCTime , createdAt = H.sample genUTCTime