From 40141cda413f9ba0cbbafde7aee26927a726d6b9 Mon Sep 17 00:00:00 2001 From: Matt Roberts Date: Mon, 4 Sep 2023 14:21:58 +0000 Subject: [PATCH 1/5] commit before deletion --- flora.cabal | 3 +++ src/core/Flora/Model/Package/Types.hs | 12 ++++++++++++ src/jobs-worker/FloraJobs/ThirdParties/GitHub/API.hs | 1 + .../FloraJobs/ThirdParties/GitHub/Client.hs | 1 + 4 files changed, 17 insertions(+) create mode 100644 src/jobs-worker/FloraJobs/ThirdParties/GitHub/API.hs create mode 100644 src/jobs-worker/FloraJobs/ThirdParties/GitHub/Client.hs diff --git a/flora.cabal b/flora.cabal index 316b30b00..1eb444b37 100644 --- a/flora.cabal +++ b/flora.cabal @@ -330,6 +330,8 @@ library flora-jobs FloraJobs.Scheduler FloraJobs.ThirdParties.Hackage.API FloraJobs.ThirdParties.Hackage.Client + FloraJobs.ThirdParties.GitHub.API + FloraJobs.ThirdParties.GitHub.Client FloraJobs.Types build-depends: @@ -342,6 +344,7 @@ library flora-jobs , containers , effectful-core , flora + , github , http-client , http-media , http-types diff --git a/src/core/Flora/Model/Package/Types.hs b/src/core/Flora/Model/Package/Types.hs index 8edacbbf3..0b46b7fe9 100644 --- a/src/core/Flora/Model/Package/Types.hs +++ b/src/core/Flora/Model/Package/Types.hs @@ -10,6 +10,7 @@ import Data.Aeson.TH import Data.ByteString (ByteString) import Data.ByteString.Lazy (fromStrict) import Data.Maybe (fromJust, fromMaybe) +import Data.Map qualified as M import Data.OpenApi (Schema (..), ToParamSchema (..), ToSchema (..), genericDeclareNamedSchema) import Data.Text (Text, isPrefixOf, unpack) import Data.Text qualified as Text @@ -188,6 +189,16 @@ instance FromField PackageStatus where instance ToField PackageStatus where toField = Escape . encodeUtf8 . display +newtype PackageFunding = PackageFunding { getPackageFunding :: M.Map Text Text } + deriving stock (Generic) + deriving + (Eq, Ord, Show, FromField, ToField, ToJSON, FromJSON, NFData) + +-- parsePackageFunding :: ByteString -> Maybe PackageFunding + +-- instance FromRow PackageStatus where +-- instance ToRow PackageStatus where + data Package = Package { packageId :: PackageId , namespace :: Namespace @@ -196,6 +207,7 @@ data Package = Package , createdAt :: UTCTime , updatedAt :: UTCTime , status :: PackageStatus + -- , funding :: PackageFunding , deprecationInfo :: Maybe PackageAlternatives } deriving stock (Eq, Ord, Show, Generic) diff --git a/src/jobs-worker/FloraJobs/ThirdParties/GitHub/API.hs b/src/jobs-worker/FloraJobs/ThirdParties/GitHub/API.hs new file mode 100644 index 000000000..73ead31e6 --- /dev/null +++ b/src/jobs-worker/FloraJobs/ThirdParties/GitHub/API.hs @@ -0,0 +1 @@ +module FloraJobs.ThirdParties.GitHub.API where diff --git a/src/jobs-worker/FloraJobs/ThirdParties/GitHub/Client.hs b/src/jobs-worker/FloraJobs/ThirdParties/GitHub/Client.hs new file mode 100644 index 000000000..d96015d9e --- /dev/null +++ b/src/jobs-worker/FloraJobs/ThirdParties/GitHub/Client.hs @@ -0,0 +1 @@ +module FloraJobs.ThirdParties.GitHub.Client where From 2154a4c4a72e38032f03f7a26e9c0658a7de2300 Mon Sep 17 00:00:00 2001 From: Matt Roberts Date: Fri, 8 Sep 2023 12:27:37 +0000 Subject: [PATCH 2/5] [FLORA-412] Basic requirements to make request to GitHub API for Funding information has been implemented. This includes changes to data types, models and more. GitHub/Client.hs, parsing local GitHub access token and providing a way to fetch the Funding filehave been added. Now need to test the runServer call with the updated JobsRunnerEnv constructor. --- flora.cabal | 4 ++-- scripts/.zshrc | 2 +- src/core/Flora/Environment.hs | 2 ++ src/core/Flora/Environment/Config.hs | 8 ++++++++ src/core/Flora/Model/Job.hs | 1 + src/core/Flora/Model/Package/Types.hs | 8 ++++---- src/jobs-worker/FloraJobs/Runner.hs | 19 +++++++++++++++++++ src/jobs-worker/FloraJobs/Scheduler.hs | 13 +++++++++++++ .../FloraJobs/ThirdParties/GitHub/Client.hs | 15 +++++++++++++++ src/jobs-worker/FloraJobs/Types.hs | 2 ++ src/web/FloraWeb/Server.hs | 2 +- 11 files changed, 68 insertions(+), 8 deletions(-) diff --git a/flora.cabal b/flora.cabal index 1eb444b37..7393b53ed 100644 --- a/flora.cabal +++ b/flora.cabal @@ -328,10 +328,10 @@ library flora-jobs FloraJobs.Render FloraJobs.Runner FloraJobs.Scheduler - FloraJobs.ThirdParties.Hackage.API - FloraJobs.ThirdParties.Hackage.Client FloraJobs.ThirdParties.GitHub.API FloraJobs.ThirdParties.GitHub.Client + FloraJobs.ThirdParties.Hackage.API + FloraJobs.ThirdParties.Hackage.Client FloraJobs.Types build-depends: diff --git a/scripts/.zshrc b/scripts/.zshrc index 02ecec4d5..cf7d9ac1c 100644 --- a/scripts/.zshrc +++ b/scripts/.zshrc @@ -1,6 +1,6 @@ #!/usr/bin/env zsh -set -euo pipefail +set -o pipefail export SHELL="zsh" export ZSH="$HOME/.oh-my-zsh" diff --git a/src/core/Flora/Environment.hs b/src/core/Flora/Environment.hs index 92498dcc5..f7d08f829 100644 --- a/src/core/Flora/Environment.hs +++ b/src/core/Flora/Environment.hs @@ -39,6 +39,7 @@ data FloraEnv = FloraEnv , environment :: DeploymentEnv , config :: FloraConfig , assets :: Assets + , githubToken :: Maybe ByteString } deriving stock (Generic) @@ -82,6 +83,7 @@ configToEnv floraConfig = do , environment = floraConfig.environment , assets = assets , config = floraConfig + , githubToken = floraConfig.githubToken } testConfigToTestEnv :: TestConfig -> Eff '[IOE] TestEnv diff --git a/src/core/Flora/Environment/Config.hs b/src/core/Flora/Environment/Config.hs index c0f0580f2..7b467fec0 100644 --- a/src/core/Flora/Environment/Config.hs +++ b/src/core/Flora/Environment/Config.hs @@ -43,6 +43,7 @@ import Env , def , help , nonempty + , optional , str , switch , var @@ -108,6 +109,7 @@ data FloraConfig = FloraConfig , httpPort :: Word16 , logging :: LoggingEnv , environment :: DeploymentEnv + , githubToken :: Maybe ByteString } deriving stock (Show, Generic) @@ -154,6 +156,11 @@ parseDeploymentEnv :: Parser Error DeploymentEnv parseDeploymentEnv = var deploymentEnv "FLORA_ENVIRONMENT" (help "Name of the current environment (production, development, test)") +parseGithubToken :: Parser Error (Maybe ByteString) +parseGithubToken = + optional $ + var str "FLORA_GITHUB_TOKEN" (help "The GitHub Token for Flora") + parseConfig :: Parser Error FloraConfig parseConfig = FloraConfig @@ -163,6 +170,7 @@ parseConfig = <*> parsePort <*> parseLoggingEnv <*> parseDeploymentEnv + <*> parseGithubToken parseTestConfig :: Parser Error TestConfig parseTestConfig = diff --git a/src/core/Flora/Model/Job.hs b/src/core/Flora/Model/Job.hs index 1d8ce000f..561bc402b 100644 --- a/src/core/Flora/Model/Job.hs +++ b/src/core/Flora/Model/Job.hs @@ -78,6 +78,7 @@ data FloraOddJobs | FetchPackageDeprecationList | FetchReleaseDeprecationList PackageName (Vector ReleaseId) | RefreshLatestVersions + | FetchFundingInformation Text Text deriving stock (Generic) -- TODO: Upstream these two ToJSON instances diff --git a/src/core/Flora/Model/Package/Types.hs b/src/core/Flora/Model/Package/Types.hs index 0b46b7fe9..79bb499c5 100644 --- a/src/core/Flora/Model/Package/Types.hs +++ b/src/core/Flora/Model/Package/Types.hs @@ -9,8 +9,8 @@ import Data.Aeson.Orphans () import Data.Aeson.TH import Data.ByteString (ByteString) import Data.ByteString.Lazy (fromStrict) -import Data.Maybe (fromJust, fromMaybe) import Data.Map qualified as M +import Data.Maybe (fromJust, fromMaybe) import Data.OpenApi (Schema (..), ToParamSchema (..), ToSchema (..), genericDeclareNamedSchema) import Data.Text (Text, isPrefixOf, unpack) import Data.Text qualified as Text @@ -189,7 +189,7 @@ instance FromField PackageStatus where instance ToField PackageStatus where toField = Escape . encodeUtf8 . display -newtype PackageFunding = PackageFunding { getPackageFunding :: M.Map Text Text } +newtype PackageFunding = PackageFunding {getPackageFunding :: M.Map Text Text} deriving stock (Generic) deriving (Eq, Ord, Show, FromField, ToField, ToJSON, FromJSON, NFData) @@ -207,8 +207,8 @@ data Package = Package , createdAt :: UTCTime , updatedAt :: UTCTime , status :: PackageStatus - -- , funding :: PackageFunding - , deprecationInfo :: Maybe PackageAlternatives + , -- , funding :: PackageFunding + deprecationInfo :: Maybe PackageAlternatives } deriving stock (Eq, Ord, Show, Generic) deriving anyclass (FromRow, ToRow, NFData) diff --git a/src/jobs-worker/FloraJobs/Runner.hs b/src/jobs-worker/FloraJobs/Runner.hs index d1d47e677..b191acb09 100644 --- a/src/jobs-worker/FloraJobs/Runner.hs +++ b/src/jobs-worker/FloraJobs/Runner.hs @@ -1,5 +1,8 @@ module FloraJobs.Runner where +import GitHub.Auth +import GitHub.Data.Content +import Effectful.Reader.Static qualified as Reader import Control.Concurrent (forkIO) import Control.Exception import Control.Monad @@ -7,6 +10,7 @@ import Control.Monad.IO.Class import Data.Aeson (Result (..), fromJSON, toJSON) import Data.Function import Data.Set qualified as Set +import Data.Text (Text) import Data.Text.Display import Data.Text.Lazy.Encoding qualified as TL import Data.Vector (Vector) @@ -21,6 +25,7 @@ import System.Process.Typed qualified as System import Flora.Import.Package (coreLibraries, persistImportOutput, withWorkerDbPool) import Flora.Model.Job +import FloraJobs.ThirdParties.GitHub.Client import Flora.Model.Package.Types import Flora.Model.Package.Update qualified as Update import Flora.Model.Release.Query qualified as Query @@ -68,6 +73,8 @@ runner job = localDomain "job-runner" $ fetchReleaseDeprecationList packageName releases RefreshLatestVersions -> Update.refreshLatestVersions + FetchFundingInformation owner repo -> + fetchFundingInformation owner repo fetchChangeLog :: ChangelogJobPayload -> JobsRunner () fetchChangeLog payload@ChangelogJobPayload{packageName, packageVersion, releaseId} = @@ -189,3 +196,15 @@ assignNamespace = then PackageAlternative (Namespace "haskell") p else PackageAlternative (Namespace "hackage") p ) + +fetchFundingInformation :: Text -> Text -> JobsRunner () +fetchFundingInformation owner repo = do + JobsRunnerEnv{ mGithubToken } <- Reader.ask @JobsRunnerEnv + case mGithubToken of + Nothing -> pure () + Just githubToken -> do + result <- liftIO $ runRequest (OAuth githubToken) $ + fetchFundingFile owner repo + case result of + Left e -> error (show e) + Right (ContentFile content) -> liftIO $ print content.contentFileContent diff --git a/src/jobs-worker/FloraJobs/Scheduler.hs b/src/jobs-worker/FloraJobs/Scheduler.hs index d5d8fa5ad..6e1f26500 100644 --- a/src/jobs-worker/FloraJobs/Scheduler.hs +++ b/src/jobs-worker/FloraJobs/Scheduler.hs @@ -9,6 +9,7 @@ module FloraJobs.Scheduler , schedulePackageDeprecationListJob , scheduleReleaseDeprecationListJob , scheduleRefreshLatestVersions + , scheduleFetchFundingInformation , checkIfIndexImportJobIsNotRunning , jobTableName -- prefer using smart constructors. @@ -21,6 +22,7 @@ where import Data.Pool import Data.Time qualified as Time import Data.Vector (Vector) +import Data.Text (Text) import Database.PostgreSQL.Entity.DBT import Database.PostgreSQL.Simple (Only (..)) import Database.PostgreSQL.Simple qualified as PG @@ -116,6 +118,17 @@ scheduleRefreshLatestVersions pool = RefreshLatestVersions ) +scheduleFetchFundingInformation :: Pool PG.Connection -> Text -> Text -> IO Job +scheduleFetchFundingInformation pool owner repo = + withResource + pool + ( \conn -> + createJob + conn + jobTableName + (FetchFundingInformation owner repo) + ) + checkIfIndexImportJobIsNotRunning :: JobsRunner Bool checkIfIndexImportJobIsNotRunning = do Log.logInfo_ "Checking if the index import job is not running…" diff --git a/src/jobs-worker/FloraJobs/ThirdParties/GitHub/Client.hs b/src/jobs-worker/FloraJobs/ThirdParties/GitHub/Client.hs index d96015d9e..7e4fe38b5 100644 --- a/src/jobs-worker/FloraJobs/ThirdParties/GitHub/Client.hs +++ b/src/jobs-worker/FloraJobs/ThirdParties/GitHub/Client.hs @@ -1 +1,16 @@ module FloraJobs.ThirdParties.GitHub.Client where + +import Data.Proxy +import Data.Text +import GitHub + +runRequest :: Auth -> Request k Content -> IO (Either Error Content) +runRequest auth request = + github auth request + +fetchFundingFile :: Text -> Text -> Request k Content +fetchFundingFile textOwner textRepo = + let owner = mkName (Proxy :: Proxy Owner) textOwner + repo = mkName (Proxy :: Proxy Repo) textRepo + filePath = ".github/FUNDING.yml" + in contentsForR owner repo filePath Nothing diff --git a/src/jobs-worker/FloraJobs/Types.hs b/src/jobs-worker/FloraJobs/Types.hs index b14661793..a57ec9a28 100644 --- a/src/jobs-worker/FloraJobs/Types.hs +++ b/src/jobs-worker/FloraJobs/Types.hs @@ -5,6 +5,7 @@ module FloraJobs.Types where import Commonmark qualified import Control.Exception (Exception) import Data.Aeson +import Data.ByteString (ByteString) import Data.Pool hiding (PoolConfig) import Data.Text qualified as Text import Data.Text.Encoding.Error (UnicodeException) @@ -73,6 +74,7 @@ jobTableName = "oddjobs" data JobsRunnerEnv = JobsRunnerEnv { httpManager :: Manager + , mGithubToken :: Maybe ByteString } deriving stock (Generic) diff --git a/src/web/FloraWeb/Server.hs b/src/web/FloraWeb/Server.hs index e774ba1e2..cc3a30dc2 100644 --- a/src/web/FloraWeb/Server.hs +++ b/src/web/FloraWeb/Server.hs @@ -120,7 +120,7 @@ logException env logger exception = runServer :: (Concurrent :> es, IOE :> es) => Logger -> FloraEnv -> Eff es () runServer appLogger floraEnv = do httpManager <- liftIO $ HTTP.newManager tlsManagerSettings - let runnerEnv = JobsRunnerEnv httpManager + let runnerEnv = JobsRunnerEnv httpManager floraEnv.githubToken let oddjobsUiCfg = makeUIConfig (floraEnv.config) appLogger (floraEnv.jobsPool) oddJobsCfg = makeConfig From 9681a53ea6efabd98c09fc5363193b362309f0be Mon Sep 17 00:00:00 2001 From: Matt Roberts Date: Thu, 14 Sep 2023 19:29:44 +0100 Subject: [PATCH 3/5] [FLORA-412] Added update to CHANGELOG.md to reflect the currently worked-on issue. --- CHANGELOG.md | 1 + 1 file changed, 1 insertion(+) diff --git a/CHANGELOG.md b/CHANGELOG.md index af80b93d1..3acd27b00 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,6 +1,7 @@ # CHANGELOG ## 1.0.13 -- XXXX-XX-XX +* Integrating Funding information from GitHub source repository ([#412](https://github.com/flora-pm/flora-server/issues/412)) * Fixed text color for header and button in login page ([#418](https://github.com/flora-pm/flora-server/pull/418)) * Exclude deprecated releases from latest versions and search ([#373](https://github.com/flora-pm/flora-server/pull/373)) * Add namespace browsing ([#375](https://github.com/flora-pm/flora-server/pull/375)) From 77d6dff1b547732ed790fdf33eb1a1208b4e67d4 Mon Sep 17 00:00:00 2001 From: Matt Roberts Date: Thu, 14 Sep 2023 20:27:56 +0100 Subject: [PATCH 4/5] Fixed more issues in Bulk.hs --- src/jobs-worker/FloraJobs/Runner.hs | 16 +++++++++------- src/jobs-worker/FloraJobs/Scheduler.hs | 2 +- 2 files changed, 10 insertions(+), 8 deletions(-) diff --git a/src/jobs-worker/FloraJobs/Runner.hs b/src/jobs-worker/FloraJobs/Runner.hs index b191acb09..5730a441a 100644 --- a/src/jobs-worker/FloraJobs/Runner.hs +++ b/src/jobs-worker/FloraJobs/Runner.hs @@ -1,8 +1,5 @@ module FloraJobs.Runner where -import GitHub.Auth -import GitHub.Data.Content -import Effectful.Reader.Static qualified as Reader import Control.Concurrent (forkIO) import Control.Exception import Control.Monad @@ -16,6 +13,9 @@ import Data.Text.Lazy.Encoding qualified as TL import Data.Vector (Vector) import Data.Vector qualified as Vector import Effectful.PostgreSQL.Transact.Effect +import Effectful.Reader.Static qualified as Reader +import GitHub.Auth +import GitHub.Data.Content import Log import Network.HTTP.Types (gone410, notFound404, statusCode) import OddJobs.Job (Job (..)) @@ -25,7 +25,6 @@ import System.Process.Typed qualified as System import Flora.Import.Package (coreLibraries, persistImportOutput, withWorkerDbPool) import Flora.Model.Job -import FloraJobs.ThirdParties.GitHub.Client import Flora.Model.Package.Types import Flora.Model.Package.Update qualified as Update import Flora.Model.Release.Query qualified as Query @@ -33,6 +32,7 @@ import Flora.Model.Release.Types import Flora.Model.Release.Update qualified as Update import FloraJobs.Render (renderMarkdown) import FloraJobs.Scheduler +import FloraJobs.ThirdParties.GitHub.Client import FloraJobs.ThirdParties.Hackage.API (HackagePreferredVersions (..), VersionedPackage (..)) import FloraJobs.ThirdParties.Hackage.Client qualified as Hackage import FloraJobs.Types @@ -199,12 +199,14 @@ assignNamespace = fetchFundingInformation :: Text -> Text -> JobsRunner () fetchFundingInformation owner repo = do - JobsRunnerEnv{ mGithubToken } <- Reader.ask @JobsRunnerEnv + JobsRunnerEnv{mGithubToken} <- Reader.ask @JobsRunnerEnv case mGithubToken of Nothing -> pure () Just githubToken -> do - result <- liftIO $ runRequest (OAuth githubToken) $ - fetchFundingFile owner repo + result <- + liftIO $ + runRequest (OAuth githubToken) $ + fetchFundingFile owner repo case result of Left e -> error (show e) Right (ContentFile content) -> liftIO $ print content.contentFileContent diff --git a/src/jobs-worker/FloraJobs/Scheduler.hs b/src/jobs-worker/FloraJobs/Scheduler.hs index 6e1f26500..585f86855 100644 --- a/src/jobs-worker/FloraJobs/Scheduler.hs +++ b/src/jobs-worker/FloraJobs/Scheduler.hs @@ -20,9 +20,9 @@ module FloraJobs.Scheduler where import Data.Pool +import Data.Text (Text) import Data.Time qualified as Time import Data.Vector (Vector) -import Data.Text (Text) import Database.PostgreSQL.Entity.DBT import Database.PostgreSQL.Simple (Only (..)) import Database.PostgreSQL.Simple qualified as PG From 520f26e1802efe5aa5f83820d1fb94a3f0e95c88 Mon Sep 17 00:00:00 2001 From: Matt Roberts Date: Thu, 14 Sep 2023 20:29:10 +0100 Subject: [PATCH 5/5] Commit before push --- src/core/Flora/Import/Package/Bulk.hs | 3 ++- src/jobs-worker/FloraJobs/Runner.hs | 2 +- 2 files changed, 3 insertions(+), 2 deletions(-) diff --git a/src/core/Flora/Import/Package/Bulk.hs b/src/core/Flora/Import/Package/Bulk.hs index 24abacc98..6b852ec2e 100644 --- a/src/core/Flora/Import/Package/Bulk.hs +++ b/src/core/Flora/Import/Package/Bulk.hs @@ -109,7 +109,8 @@ importFromStream appLogger user repository directImport stream = do liftIO $ S.fold displayCount $ S.fromAsync $ - S.mapM (processFile wq pool poolConfig) $ + S.mapM + (processFile wq pool poolConfig) stream ) -- We want to refresh db and update latest timestamp even if we fell diff --git a/src/jobs-worker/FloraJobs/Runner.hs b/src/jobs-worker/FloraJobs/Runner.hs index 5730a441a..f68ab6130 100644 --- a/src/jobs-worker/FloraJobs/Runner.hs +++ b/src/jobs-worker/FloraJobs/Runner.hs @@ -138,7 +138,7 @@ fetchUploadTime payload@UploadTimeJobPayload{packageName, packageVersion, releas -- | This job fetches the deprecation list and inserts the appropriate metadata in the packages fetchPackageDeprecationList :: JobsRunner () fetchPackageDeprecationList = do - result <- Hackage.request $ Hackage.getDeprecatedPackages + result <- Hackage.request Hackage.getDeprecatedPackages case result of Right deprecationList -> do logInfo_ "Deprecation List retrieved"