[FLORA-412] GitHub repo funding information

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))

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

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"

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

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 =

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

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

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)

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

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…"

src/jobs-worker/FloraJobs/ThirdParties/GitHub/API.hs

@@ -0,0 +1 @@
+module FloraJobs.ThirdParties.GitHub.API where

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

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)
 

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