[FLORA-443] support non hackage repo urls

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

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

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

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)

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

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

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

src/web/FloraWeb/Pages/Templates/Packages.hs

@@ -62,37 +62,37 @@ 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
   -> PackageName
   -> 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 "&nbsp;"
         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 "&nbsp;"
       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

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