Add package RSS feed

Distribution/Server/Features.hs

@@ -46,6 +46,7 @@ import Distribution.Server.Features.AdminLog            (initAdminLogFeature)
 import Distribution.Server.Features.HoogleData          (initHoogleDataFeature)
 import Distribution.Server.Features.Votes               (initVotesFeature)
 import Distribution.Server.Features.Sitemap             (initSitemapFeature)
+import Distribution.Server.Features.PackageFeed         (initPackageFeedFeature)
 #endif
 import Distribution.Server.Features.ServerIntrospect (serverIntrospectFeature)
 
@@ -149,6 +150,8 @@ initHackageFeatures env@ServerEnv{serverVerbosity = verbosity} = do
                                initAdminLogFeature env
     mkSitemapFeature        <- logStartup "sitemap" $
                                initSitemapFeature env
+    mkPackageFeedFeature    <- logStartup "package feed" $
+                               initPackageFeedFeature env
 #endif
 
     loginfo verbosity "Initialising features, part 2"
@@ -315,6 +318,11 @@ initHackageFeatures env@ServerEnv{serverVerbosity = verbosity} = do
                         documentationCoreFeature
                         tagsFeature
 
+    packageFeedFeature <- mkPackageFeedFeature
+                            coreFeature
+                            usersFeature
+                            tarIndexCacheFeature
+
 #endif
 
     -- The order of initialization above should be the same as
@@ -354,6 +362,7 @@ initHackageFeatures env@ServerEnv{serverVerbosity = verbosity} = do
          , getFeatureInterface votesFeature
          , getFeatureInterface adminLogFeature
          , getFeatureInterface siteMapFeature
+         , getFeatureInterface packageFeedFeature
 #endif
          , staticFilesFeature
          , serverIntrospectFeature allFeatures

Distribution/Server/Features/PackageFeed.hs

@@ -0,0 +1,168 @@
+{-# LANGUAGE LambdaCase, RecordWildCards #-}
+
+module Distribution.Server.Features.PackageFeed where
+
+import Distribution.Server.Features.Core
+import Distribution.Server.Features.TarIndexCache
+import Distribution.Server.Features.Users
+import Distribution.Server.Framework
+import Distribution.Server.Packages.ChangeLog
+import Distribution.Server.Packages.Types
+import qualified Distribution.Server.Users.Users as Users
+import Distribution.Server.Users.Users (Users)
+import Distribution.Server.Util.ServeTarball (loadTarEntry)
+
+import Distribution.Package
+import Distribution.PackageDescription
+import Distribution.Text
+
+import qualified Cheapskate as Markdown (markdown, Options(..))
+import qualified Cheapskate.Html as Markdown (renderDoc)
+import qualified Data.ByteString.Lazy as BS (ByteString, toStrict)
+import qualified Data.ByteString.Char8 as C8
+import Data.List (sortOn)
+import Data.Maybe (listToMaybe)
+import Data.Ord (Down(..))
+import qualified Data.Text as T
+import qualified Data.Text.Encoding as T
+import qualified Data.Text.Encoding.Error as T
+import Data.Time.Clock (UTCTime, getCurrentTime)
+import Data.Time.Format
+import Network.URI( URI(..), uriToString )
+import System.FilePath.Posix (takeExtension)
+import qualified Text.Blaze.Html.Renderer.Pretty as Blaze (renderHtml)
+import qualified Text.RSS as RSS
+import Text.RSS ( RSS(RSS) )
+import qualified Text.XHtml.Strict as XHtml
+import Text.XHtml.Strict ((<<))
+
+newtype PackageFeedFeature = PackageFeedFeature {
+  packageFeedFeatureInterface :: HackageFeature
+}
+
+instance IsHackageFeature PackageFeedFeature where
+  getFeatureInterface = packageFeedFeatureInterface
+
+initPackageFeedFeature :: ServerEnv
+                       -> IO ( CoreFeature
+                          -> UserFeature
+                          -> TarIndexCacheFeature
+                          -> IO PackageFeedFeature)
+initPackageFeedFeature env =
+  return $ \core users tars ->
+    return $ packageFeedFeature env core users tars
+
+packageFeedFeature :: ServerEnv
+                   -> CoreFeature
+                   -> UserFeature
+                   -> TarIndexCacheFeature
+                   -> PackageFeedFeature
+packageFeedFeature ServerEnv{..}
+                   CoreFeature{..}
+                   UserFeature{..}
+                   TarIndexCacheFeature{..}
+  = PackageFeedFeature{..}
+  where
+
+    CoreResource{..} = coreResource
+
+    packageFeedFeatureInterface = (emptyHackageFeature "package feed") {
+      featureResources = [ packageFeedResource ]
+      , featureState = []
+      , featureDesc = "Provides RSS feed for individual packages"
+      , featureCaches = []
+      , featurePostInit = pure ()
+    }
+
+    packageFeedResource :: Resource
+    packageFeedResource = (resourceAt "/package/:package.rss") {
+      resourceDesc = [(GET, "Package feed")]
+    , resourceGet = [("rss", packageFeed)]
+    }
+
+    packageFeed :: DynamicPath -> ServerPartE Response
+    packageFeed dpath = do
+      users <- queryGetUserDb
+      now <- liftIO getCurrentTime
+      pkgname <- packageInPath dpath
+      pkgs <- sortOn (Down . pkgOriginalUploadTime) <$> lookupPackageName pkgname
+      pkgs' <- liftIO $ forM pkgs changelog
+      return $ toResponse $ renderPackageFeed users serverBaseURI now pkgname pkgs'
+
+    changelog :: PkgInfo -> IO (PkgInfo, XHtml.Html)
+    changelog pkg = findToplevelFile pkg isChangeLogFile >>= \case
+        Left _ -> return (pkg, XHtml.primHtml "(No changelog found.)")
+        Right (tarfile, _, offset, filename) ->
+          loadTarEntry tarfile offset >>= \case
+            Left _ -> return (pkg, XHtml.primHtml "(No changelog found.)")
+            Right (_, content) ->
+              if supposedToBeMarkdown filename
+                then return (pkg, renderMarkdown content)
+                else return (pkg, XHtml.pre << unpackUtf8 content)
+
+renderPackageFeed :: Users -> URI -> UTCTime -> PackageName -> [(PkgInfo, XHtml.Html)] -> RSS
+renderPackageFeed users hostURI now name pkgs = RSS title uri desc (channel updated) items
+  where title = unPackageName name ++ " – new releases on Hackage"
+        desc = "New releases of package '" ++ unPackageName name ++ "' on Hackage."
+        items = feedItems users uri <$> pkgs
+        uri = hostURI { uriPath = "/package/" ++ display name }
+        updated = maybe now (fst . pkgOriginalUploadInfo . fst) (listToMaybe pkgs)
+
+channel :: UTCTime -> [RSS.ChannelElem]
+channel updated =
+  [ RSS.Language "en"
+  , RSS.ManagingEditor "[email protected]"
+  , RSS.WebMaster "[email protected]"
+  , RSS.ChannelPubDate updated
+  , RSS.LastBuildDate updated
+  , RSS.Generator "rss-feed"
+  ]
+
+feedItems :: Users -> URI -> (PkgInfo, XHtml.Html) -> [RSS.ItemElem]
+feedItems users hostURI (pkgInfo, chlog) =
+  [ RSS.Title title
+  , RSS.Link uri
+  , RSS.Guid True (uriToString id uri "")
+  , RSS.PubDate time
+  , RSS.Description desc
+  , RSS.Author uploader
+  ]
+  where title = pkgName ++ " (" ++ synopsis pd ++ ")"
+        uri = hostURI { uriPath = "/package/" ++ pkgName }
+        desc =
+          "<dl>" ++
+          d "Homepage" ("<a href=\"" ++ homepage pd ++ "\">" ++ homepage pd ++ "</a>") ++
+          d "Author" (author pd) ++
+          d "Uploaded" ("by " ++ uploader ++ " at " ++ timestr) ++
+          d "Maintainer" (maintainer pd) ++
+          "</dl><hr />" ++ show chlog
+        pkgName = display (pkgInfoId pkgInfo)
+        (time, uploaderId) = pkgOriginalUploadInfo pkgInfo
+        timestr = formatTime defaultTimeLocale "%Y-%m-%dT%H:%M:%S%EZ" time
+        uploader = display $ Users.userIdToName users uploaderId
+        pd = packageDescription (pkgDesc pkgInfo)
+        d dt dd = "<dt>" ++ dt ++ "</dt><dd>" ++ dd ++ "</dd>"
+
+renderMarkdown :: BS.ByteString -> XHtml.Html
+renderMarkdown = XHtml.primHtml . Blaze.renderHtml
+               . Markdown.renderDoc . Markdown.markdown opts
+               . T.decodeUtf8With T.lenientDecode . convertNewLine . BS.toStrict
+  where
+    opts =
+      Markdown.Options
+        { Markdown.sanitize           = True
+        , Markdown.allowRawHtml       = False
+        , Markdown.preserveHardBreaks = False
+        , Markdown.debug              = False
+        }
+
+convertNewLine :: C8.ByteString -> C8.ByteString
+convertNewLine = C8.filter (/= '\r')
+
+supposedToBeMarkdown :: FilePath -> Bool
+supposedToBeMarkdown fname = takeExtension fname `elem` [".md", ".markdown"]
+
+unpackUtf8 :: BS.ByteString -> String
+unpackUtf8 = T.unpack
+           . T.decodeUtf8With T.lenientDecode
+           . BS.toStrict

datafiles/templates/Html/package-page.html.st

@@ -47,7 +47,7 @@
       <tbody>
 
         <tr>
-          <th>Versions</th>
+          <th>Versions <span style="font-weight:normal;font-size: small;">[<a href="/package/$package.name$.rss">RSS</a>]</span></th>
           <td>$versions$</td>
         </tr>
 

hackage-server.cabal

@@ -289,6 +289,7 @@ library lib-server
       Distribution.Server.Features.PackageCandidates.Types
       Distribution.Server.Features.PackageCandidates.State
       Distribution.Server.Features.PackageCandidates.Backup
+      Distribution.Server.Features.PackageFeed
       Distribution.Server.Features.PackageList
       Distribution.Server.Features.Distro
       Distribution.Server.Features.Distro.Distributions