diff --git a/CHANGELOG.md b/CHANGELOG.md index af80b93d..3acd27b0 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)) diff --git a/flora.cabal b/flora.cabal index 316b30b0..7393b53e 100644 --- a/flora.cabal +++ b/flora.cabal @@ -328,6 +328,8 @@ library flora-jobs FloraJobs.Render FloraJobs.Runner FloraJobs.Scheduler + FloraJobs.ThirdParties.GitHub.API + FloraJobs.ThirdParties.GitHub.Client FloraJobs.ThirdParties.Hackage.API FloraJobs.ThirdParties.Hackage.Client FloraJobs.Types @@ -342,6 +344,7 @@ library flora-jobs , containers , effectful-core , flora + , github , http-client , http-media , http-types diff --git a/scripts/.zshrc b/scripts/.zshrc index 02ecec4d..cf7d9ac1 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 92498dcc..f7d08f82 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 c0f0580f..7b467fec 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/Import/Package/Bulk.hs b/src/core/Flora/Import/Package/Bulk.hs index 24abacc9..6b852ec2 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/core/Flora/Model/Job.hs b/src/core/Flora/Model/Job.hs index 1d8ce000..561bc402 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 8edacbbf..79bb499c 100644 --- a/src/core/Flora/Model/Package/Types.hs +++ b/src/core/Flora/Model/Package/Types.hs @@ -9,6 +9,7 @@ import Data.Aeson.Orphans () import Data.Aeson.TH import Data.ByteString (ByteString) import Data.ByteString.Lazy (fromStrict) +import Data.Map qualified as M import Data.Maybe (fromJust, fromMaybe) import Data.OpenApi (Schema (..), ToParamSchema (..), ToSchema (..), genericDeclareNamedSchema) import Data.Text (Text, isPrefixOf, unpack) @@ -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,7 +207,8 @@ data Package = Package , createdAt :: UTCTime , updatedAt :: UTCTime , status :: PackageStatus - , 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 d1d47e67..f68ab613 100644 --- a/src/jobs-worker/FloraJobs/Runner.hs +++ b/src/jobs-worker/FloraJobs/Runner.hs @@ -7,11 +7,15 @@ 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) 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 (..)) @@ -28,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 @@ -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} = @@ -131,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" @@ -189,3 +196,17 @@ 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 d5d8fa5a..585f8685 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. @@ -19,6 +20,7 @@ module FloraJobs.Scheduler where import Data.Pool +import Data.Text (Text) import Data.Time qualified as Time import Data.Vector (Vector) import Database.PostgreSQL.Entity.DBT @@ -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/API.hs b/src/jobs-worker/FloraJobs/ThirdParties/GitHub/API.hs new file mode 100644 index 00000000..73ead31e --- /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 00000000..7e4fe38b --- /dev/null +++ b/src/jobs-worker/FloraJobs/ThirdParties/GitHub/Client.hs @@ -0,0 +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 b1466179..a57ec9a2 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 e774ba1e..cc3a30dc 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