From d5dc53acc014bdcff7e05bdf5a20cbe254b2c3e4 Mon Sep 17 00:00:00 2001 From: Matt Roberts Date: Sat, 7 Oct 2023 13:23:32 +0100 Subject: [PATCH 1/2] [FLORA-443] support non hackage repo urls --- environment.docker.sh | 2 + src/core/Flora/Model/Package/Types.hs | 7 ++ src/core/Flora/Model/PackageIndex/Types.hs | 2 +- src/core/Flora/Model/PackageIndex/Update.hs | 3 + src/web/FloraWeb/Common/Guards.hs | 14 +++ src/web/FloraWeb/Pages/Server/Packages.hs | 5 + src/web/FloraWeb/Pages/Templates/Packages.hs | 108 +++++++++--------- .../Pages/Templates/Pages/Packages.hs | 7 +- 8 files changed, 95 insertions(+), 53 deletions(-) diff --git a/environment.docker.sh b/environment.docker.sh index d2dc616a..90c5e1bb 100755 --- a/environment.docker.sh +++ b/environment.docker.sh @@ -6,3 +6,5 @@ export FLORA_HTTP_PORT=8084 export FLORA_DB_CONNSTRING="host=${FLORA_DB_HOST} dbname=${FLORA_DB_DATABASE}\ user=${FLORA_DB_USER} password=${FLORA_DB_PASSWORD}" export PGPASSWORD=${FLORA_DB_PASSWORD} + +export FLORA_PG_URI="postgresql://${FLORA_DB_USER}:${FLORA_DB_PASSWORD}@${FLORA_DB_HOST}:${FLORA_DB_PORT}/${FLORA_DB_DATABASE}" diff --git a/src/core/Flora/Model/Package/Types.hs b/src/core/Flora/Model/Package/Types.hs index de3a039f..3d9ecb21 100644 --- a/src/core/Flora/Model/Package/Types.hs +++ b/src/core/Flora/Model/Package/Types.hs @@ -80,6 +80,9 @@ instance FromHttpApiData PackageName where Nothing -> Left "Could not parse package name" Just a -> Right a +extractPackageNameText :: PackageName -> Text +extractPackageNameText (PackageName text) = text + parsePackageName :: Text -> Maybe PackageName parsePackageName txt = if matches "[[:digit:]]*[[:alpha:]][[:alnum:]]*(-[[:digit:]]*[[:alpha:]][[:alnum:]]*)*" txt @@ -149,6 +152,10 @@ parseNamespace txt = then Just $ Namespace txt else Nothing +extractNamespaceText :: Namespace -> Text +extractNamespaceText (Namespace text) = + fromMaybe text (Text.stripPrefix "@" text) + instance ToSchema Namespace where declareNamedSchema proxy = genericDeclareNamedSchema openApiSchemaOptions proxy diff --git a/src/core/Flora/Model/PackageIndex/Types.hs b/src/core/Flora/Model/PackageIndex/Types.hs index 20f0f6c8..2053abc4 100644 --- a/src/core/Flora/Model/PackageIndex/Types.hs +++ b/src/core/Flora/Model/PackageIndex/Types.hs @@ -25,8 +25,8 @@ newtype PackageIndexId = PackageIndexId {getPackageIndexId :: UUID} data PackageIndex = PackageIndex { packageIndexId :: PackageIndexId , repository :: Text - , url :: Text , timestamp :: Maybe UTCTime + , url :: Text } deriving stock (Eq, Show, Generic) deriving anyclass (FromRow, ToRow, NFData) diff --git a/src/core/Flora/Model/PackageIndex/Update.hs b/src/core/Flora/Model/PackageIndex/Update.hs index 4d63389d..bd188c7e 100644 --- a/src/core/Flora/Model/PackageIndex/Update.hs +++ b/src/core/Flora/Model/PackageIndex/Update.hs @@ -16,6 +16,9 @@ import Effectful import Effectful.PostgreSQL.Transact.Effect (DB, dbtToEff) import Flora.Model.PackageIndex.Types + ( PackageIndex + , mkPackageIndex + ) updatePackageIndexByName :: DB :> es => Text -> Maybe UTCTime -> Eff es () updatePackageIndexByName repositoryName newTimestamp = do diff --git a/src/web/FloraWeb/Common/Guards.hs b/src/web/FloraWeb/Common/Guards.hs index 7198135a..5ca15720 100644 --- a/src/web/FloraWeb/Common/Guards.hs +++ b/src/web/FloraWeb/Common/Guards.hs @@ -9,6 +9,8 @@ import Effectful.PostgreSQL.Transact.Effect import Effectful.Time (Time) import Flora.Model.Package import Flora.Model.Package.Query qualified as Query +import Flora.Model.PackageIndex.Query as Query +import Flora.Model.PackageIndex.Types (PackageIndex) import Flora.Model.Release.Query qualified as Query import Flora.Model.Release.Types (Release) @@ -40,3 +42,15 @@ guardThatReleaseExists packageId version action = do case result of Just release -> pure release Nothing -> action version + +guardThatPackageIndexExists + :: DB :> es + => Namespace + -> (Namespace -> Eff es PackageIndex) + -- ^ Action to run if the package index does not exist + -> Eff es PackageIndex +guardThatPackageIndexExists namespace action = do + result <- Query.getPackageIndexByName (extractNamespaceText namespace) + case result of + Just packageIndex -> pure packageIndex + Nothing -> action namespace diff --git a/src/web/FloraWeb/Pages/Server/Packages.hs b/src/web/FloraWeb/Pages/Server/Packages.hs index 3316b6d6..259d436c 100644 --- a/src/web/FloraWeb/Pages/Server/Packages.hs +++ b/src/web/FloraWeb/Pages/Server/Packages.hs @@ -30,6 +30,7 @@ import Flora.Logging import Flora.Model.BlobIndex.Query qualified as Query import Flora.Model.Package import Flora.Model.Package.Query qualified as Query +import Flora.Model.PackageIndex.Types (PackageIndex (..)) import Flora.Model.Release.Query qualified as Query import Flora.Model.Release.Types import Flora.Search qualified as Search @@ -90,6 +91,7 @@ showPackageVersion namespace packageName mversion = do session <- getSession templateEnv' <- fromSession session defaultTemplateEnv package <- guardThatPackageExists namespace packageName (\_ _ -> web404) + packageIndex <- guardThatPackageIndexExists namespace $ const web404 releases <- Query.getReleases package.packageId let latestRelease = releases @@ -129,12 +131,15 @@ showPackageVersion namespace packageName mversion = do , "package" .= (display namespace <> "/" <> display packageName) ] + let packageIndexURL = packageIndex.url + render templateEnv $ Packages.showPackage release releases numberOfReleases package + packageIndexURL dependents numberOfDependents releaseDependencies diff --git a/src/web/FloraWeb/Pages/Templates/Packages.hs b/src/web/FloraWeb/Pages/Templates/Packages.hs index 842c05de..b170f273 100644 --- a/src/web/FloraWeb/Pages/Templates/Packages.hs +++ b/src/web/FloraWeb/Pages/Templates/Packages.hs @@ -62,18 +62,18 @@ presentationHeaderForSubpage -> Word -> FloraHTML presentationHeaderForSubpage namespace packageName release target numberOfPackages = div_ [class_ "divider"] $ do - div_ [class_ "page-title"] $ do - h1_ [class_ ""] $ do - span_ [class_ "headline"] $ do - displayNamespace namespace - chevronRightOutline - linkToPackageWithVersion namespace packageName (release.version) - chevronRightOutline - toHtml (display target) + div_ [class_ "page-title"] $ h1_ [class_ ""] $ do + span_ [class_ "headline"] $ do + displayNamespace namespace + chevronRightOutline + linkToPackageWithVersion namespace packageName (release.version) + chevronRightOutline + toHtml (display target) p_ [class_ "synopsis"] $ span_ [class_ "version"] $ toHtml $ - display numberOfPackages <> " results" + display numberOfPackages + <> " results" presentationHeaderForVersions :: Namespace @@ -81,18 +81,18 @@ presentationHeaderForVersions -> Word -> FloraHTML presentationHeaderForVersions namespace packageName numberOfReleases = div_ [class_ "divider"] $ do - div_ [class_ "page-title"] $ do - h1_ [class_ ""] $ do - span_ [class_ "headline"] $ do - displayNamespace namespace - chevronRightOutline - linkToPackage namespace packageName - chevronRightOutline - toHtml (display Versions) + div_ [class_ "page-title"] $ h1_ [class_ ""] $ do + span_ [class_ "headline"] $ do + displayNamespace namespace + chevronRightOutline + linkToPackage namespace packageName + chevronRightOutline + toHtml (display Versions) p_ [class_ "synopsis"] $ span_ [class_ "version"] $ toHtml $ - display numberOfReleases <> " results" + display numberOfReleases + <> " results" showDependents :: Namespace @@ -138,7 +138,7 @@ listVersions namespace packageName releases = ul_ [class_ "package-list"] $ Vector.forM_ releases - ( \release -> versionListItem namespace packageName release + ( versionListItem namespace packageName ) versionListItem :: Namespace -> PackageName -> Release -> FloraHTML @@ -149,15 +149,19 @@ versionListItem namespace packageName release = do Just ts -> span_ [class_ "package-list-item__synopsis"] (toHtml $ Time.formatTime defaultTimeLocale "%a, %_d %b %Y" ts) li_ [class_ "package-list-item"] $ - a_ [href, class_ ""] $ do - h4_ [class_ "package-list-item__name"] $ - strong_ [class_ ""] . toHtml $ - "v" <> toHtml release.version - uploadedAt - div_ [class_ "package-list-item__metadata"] $ - span_ [class_ "package-list-item__license"] $ do - licenseIcon - toHtml release.license + a_ [href, class_ ""] $ + do + h4_ [class_ "package-list-item__name"] + $ strong_ [class_ ""] + . toHtml + $ "v" + <> toHtml release.version + uploadedAt + div_ [class_ "package-list-item__metadata"] $ + span_ [class_ "package-list-item__license"] $ + do + licenseIcon + toHtml release.license -- | Render a list of package informations packageListing @@ -169,7 +173,7 @@ packageListing packageListing mExactMatchItems packages = ul_ [class_ "package-list"] $ do whenJust mExactMatchItems $ \exactMatchItems -> - forM_ exactMatchItems $ \em -> do + forM_ exactMatchItems $ \em -> div_ [class_ "exact-match"] $ packageListItem (em.namespace, em.name, em.synopsis, em.version, em.license) Vector.forM_ @@ -182,17 +186,17 @@ requirementListing requirements = ul_ [class_ "component-list"] $ requirementListItem requirements showChangelog :: Namespace -> PackageName -> Version -> Maybe TextHtml -> FloraHTML -showChangelog namespace packageName version mChangelog = div_ [class_ "container"] $ do - div_ [class_ "divider"] $ do - div_ [class_ "page-title"] $ - h1_ [class_ ""] $ do +showChangelog namespace packageName version mChangelog = div_ [class_ "container"] $ div_ [class_ "divider"] $ do + div_ [class_ "page-title"] $ + h1_ [class_ ""] $ + do span_ [class_ "headline"] $ toHtml ("Changelog of " <> display namespace <> "/" <> display packageName) toHtmlRaw @Text " " span_ [class_ "version"] $ toHtml $ display version - section_ [class_ "release-changelog"] $ do - case mChangelog of - Nothing -> toHtml @Text "This release does not have a Changelog" - Just (MkTextHtml changelogText) -> relaxHtmlT changelogText + section_ [class_ "release-changelog"] $ do + case mChangelog of + Nothing -> toHtml @Text "This release does not have a Changelog" + Just (MkTextHtml changelogText) -> relaxHtmlT changelogText displayReleaseVersion :: Version -> FloraHTML displayReleaseVersion = toHtml @@ -237,13 +241,14 @@ displayCategories categories = div_ [class_ "license "] $ h3_ [class_ "package-body-section"] "Categories" ul_ [class_ "categories"] $ foldMap renderCategory categories -displayLinks :: Namespace -> PackageName -> Release -> FloraHTML -displayLinks namespace packageName release = +displayLinks :: Namespace -> PackageName -> Text -> Release -> FloraHTML +displayLinks namespace packageName packageIndexURL release = li_ [class_ ""] $ do h3_ [class_ "package-body-section links"] "Links" ul_ [class_ "links"] $ do li_ [class_ "package-link"] $ a_ [href_ (getHomepage release)] "Homepage" - li_ [class_ "package-link"] $ a_ [href_ ("https://hackage.haskell.org/package/" <> display packageName <> "-" <> display release.version)] "Documentation" + li_ [class_ "package-link"] $ a_ [href_ (packageIndexURL <> "/package/" <> display packageName <> "-" <> display release.version)] "Documentation" + li_ [class_ "package-link"] $ displaySourceRepos release.sourceRepos li_ [class_ "package-link"] $ displayChangelog namespace packageName release.version release.changelog @@ -288,7 +293,7 @@ displayVersions namespace packageName versions numberOfReleases = toHtml $ Time.formatTime defaultTimeLocale "%a, %_d %b %Y" ts case release.revisedAt of Nothing -> span_ [] "" - Just revisionDate -> do + Just revisionDate -> span_ [ dataText_ ("Revised on " <> display (Time.formatTime defaultTimeLocale "%a, %_d %b %Y, %R %EZ" revisionDate)) @@ -334,7 +339,7 @@ displayInstructions namespace packageName latestRelease = , readonly_ "readonly" ] TemplateEnv{features} <- ask - when (isJust $ features.blobStoreImpl) $ do + when (isJust features.blobStoreImpl) $ do label_ [for_ "tarball", class_ "font-light"] "Download" let v = display latestRelease.version tarballName = display packageName <> "-" <> v <> ".tar.gz" @@ -352,11 +357,12 @@ displayPackageDeprecation (PackageAlternatives inFavourOf) = else do label_ [for_ "install-string", class_ "font-light"] "This package has been deprecated in favour of" ul_ [class_ "package-alternatives"] $ - Vector.forM_ inFavourOf $ \PackageAlternative{namespace, package} -> - li_ [] $ - a_ - [href_ ("/packages/" <> display namespace <> "/" <> display package)] - (text $ display namespace <> "/" <> display package) + Vector.forM_ inFavourOf $ + \PackageAlternative{namespace, package} -> + li_ [] $ + a_ + [href_ ("/packages/" <> display namespace <> "/" <> display package)] + (text $ display namespace <> "/" <> display package) displayReleaseDeprecation :: Maybe (Namespace, PackageName, Version) -> FloraHTML displayReleaseDeprecation mLatestViableRelease = @@ -463,8 +469,7 @@ displayPackageFlag MkPackageFlag{flagName, flagDescription, flagDefault} = case pre_ [class_ "package-flag-name"] (toHtml $ Text.pack (Flag.unFlagName flagName)) toHtmlRaw @Text " " defaultMarker flagDefault - div_ [class_ "package-flag-description"] $ do - renderHaddock $ Text.pack flagDescription + div_ [class_ "package-flag-description"] $ renderHaddock $ Text.pack flagDescription defaultMarker :: Bool -> FloraHTML defaultMarker True = em_ "(on by default)" @@ -482,8 +487,9 @@ intercalateVec sep vector = formatInstallString :: PackageName -> Release -> Text formatInstallString packageName Release{version} = - Text.pack . render $ - hcat [pretty packageName, PP.space, rangedVersion, ","] + Text.pack + . render + $ hcat [pretty packageName, PP.space, rangedVersion, ","] where rangedVersion :: Doc rangedVersion = "^>=" <> majMin diff --git a/src/web/FloraWeb/Pages/Templates/Pages/Packages.hs b/src/web/FloraWeb/Pages/Templates/Pages/Packages.hs index 7757a16a..8fd93a65 100644 --- a/src/web/FloraWeb/Pages/Templates/Pages/Packages.hs +++ b/src/web/FloraWeb/Pages/Templates/Pages/Packages.hs @@ -38,6 +38,7 @@ showPackage -> Vector Release -> Word -> Package + -> Text -> Vector Package -> Word -> Vector (Namespace, PackageName, Text) @@ -49,6 +50,7 @@ showPackage packageReleases numberOfReleases package@Package{namespace, name} + packageIndexURL dependents numberOfDependents dependencies @@ -58,6 +60,7 @@ showPackage presentationHeader latestRelease namespace name latestRelease.synopsis packageBody package + packageIndexURL latestRelease packageReleases numberOfReleases @@ -83,6 +86,7 @@ presentationHeader release namespace name synopsis = packageBody :: Package + -> Text -> Release -> Vector Release -> Word @@ -94,6 +98,7 @@ packageBody -> FloraHTML packageBody Package{namespace, name = packageName, deprecationInfo} + packageIndexURL latestRelease@Release{flags, deprecated, license, maintainer, version} packageReleases numberOfReleases @@ -107,7 +112,7 @@ packageBody displayCategories categories displayLicense license displayMaintainer maintainer - displayLinks namespace packageName latestRelease + displayLinks namespace packageName packageIndexURL latestRelease displayVersions namespace packageName packageReleases numberOfReleases div_ [class_ "release-readme-column"] $ div_ [class_ "release-readme"] $ displayReadme latestRelease div_ [class_ "package-right-column"] $ ul_ [class_ "package-right-rows"] $ do From 6a225d969d05e4e022a9d001e4ec1a30d3895b52 Mon Sep 17 00:00:00 2001 From: Matt Roberts Date: Sun, 26 Nov 2023 21:29:16 +0000 Subject: [PATCH 2/2] Added line in CHANGELOG.md --- CHANGELOG.md | 1 + 1 file changed, 1 insertion(+) diff --git a/CHANGELOG.md b/CHANGELOG.md index 454f9dda..36ee64a6 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -8,6 +8,7 @@ * Add initial support for hosting package tarballs ([#452](https://github.com/flora-pm/flora-server/pull/452)) * Show depended on components in dependencies page ([#464](https://github.com/flora-pm/flora-server/pull/464)) * Add search bar for reverse dependencies ([#476](https://github.com/flora-pm/flora-server/pull/476)) +* Support non Hackage repo URLs ([#479](https://github.com/flora-pm/flora-server/pull/479)) ## 1.0.13 -- 2023-09-17 * Exclude deprecated releases from latest versions and search ([#373](https://github.com/flora-pm/flora-server/pull/373))