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