Provide git log in ActivityPub format

Currently it's a paged Collection where the items are merely URIs. This could
be changed to have actual Commit objects as items; for that we need to examine
the whole thing with the LogEntry type and the Patch type and have an
AP-friendly log item representation, but without commit diffs.

src/Vervis/Handler/Repo/Git.hs

@@ -22,6 +22,7 @@ module Vervis.Handler.Repo.Git
     )
 where
 
+import Control.Monad
 import Control.Monad.IO.Class (liftIO)
 import Data.Git.Graph
 import Data.Git.Harder
@@ -67,10 +68,12 @@ import qualified Web.ActivityPub as AP
 
 import Data.ByteString.Char8.Local (takeLine)
 import Data.Git.Local
+import Data.Paginate.Local
 import Text.FilePath.Local (breakExt)
 
 import Vervis.ActivityPub
 import Vervis.ChangeFeed (changeFeed)
+import Vervis.Changes
 import Vervis.Form.Repo
 import Vervis.Foundation
 import Vervis.Path
@@ -134,19 +137,57 @@ getGitRepoChanges :: ShrIdent -> RpIdent -> Text -> Handler TypedContent
 getGitRepoChanges shar repo ref = do
     path <- askRepoDir shar repo
     (branches, tags) <- liftIO $ G.listRefs path
-    if ref `S.member` branches || ref `S.member` tags
+    unless (ref `S.member` branches || ref `S.member` tags)
-        then do
+        notFound
-            (_, _, entries, navModel) <- getPageAndNavTop $
+    let here = RepoChangesR shar repo ref
-                \ o l -> liftIO $ G.readChangesView path ref o l
+    encodeRouteLocal <- getEncodeRouteLocal
-            let refSelect = refSelectW shar repo branches tags
+    encodeRouteHome <- getEncodeRouteHome
-                changes = changesW shar repo entries
+    encodeRoutePageLocal <- getEncodeRoutePageLocal
-                pageNav = navWidget navModel
+    let pageUrl = encodeRoutePageLocal here
-                feed = changeFeed shar repo (Just ref) VCSGit entries
+        getChanges o l = liftIO $ G.readChangesView path ref o l
-            selectRep $ do
+    mpage <- getPageAndNavMaybe getChanges
-                provideRep $ defaultLayout $(widgetFile "repo/changes-git")
+    case mpage of
-                provideRep $ atomFeed feed
+        Nothing -> do
-                provideRep $ rssFeed feed
+            (total, pages, _, _) <- getPageAndNavTop getChanges
-        else notFound
+            let collection = Collection
+                    { collectionId         = encodeRouteLocal here
+                    , collectionType       = CollectionTypeOrdered
+                    , collectionTotalItems = Just total
+                    , collectionCurrent    = Nothing
+                    , collectionFirst      = Just $ pageUrl 1
+                    , collectionLast       = Just $ pageUrl pages
+                    , collectionItems      = [] :: [Text]
+                    }
+            provideHtmlAndAP collection $ redirectFirstPage here
+        Just (_total, pages, items, navModel) ->
+            let current = nmCurrent navModel
+                page = CollectionPage
+                    { collectionPageId         = pageUrl current
+                    , collectionPageType       = CollectionPageTypeOrdered
+                    , collectionPageTotalItems = Nothing
+                    , collectionPageCurrent    = Just $ pageUrl current
+                    , collectionPageFirst      = Just $ pageUrl 1
+                    , collectionPageLast       = Just $ pageUrl pages
+                    , collectionPagePartOf     = encodeRouteLocal here
+                    , collectionPagePrev       =
+                        if current > 1
+                            then Just $ pageUrl $ current - 1
+                            else Nothing
+                    , collectionPageNext       =
+                        if current < pages
+                            then Just $ pageUrl $ current + 1
+                            else Nothing
+                    , collectionPageStartIndex = Nothing
+                    , collectionPageItems      =
+                        map (encodeRouteHome . RepoPatchR shar repo . leHash)
+                            items
+                    }
+                feed = changeFeed shar repo (Just ref) VCSGit items
+            in  provideHtmlFeedAndAP page feed $
+                    let refSelect = refSelectW shar repo branches tags
+                        changes = changesW shar repo items
+                        pageNav = navWidget navModel
+                    in  $(widgetFile "repo/changes-git")
 
 getGitPatch :: ShrIdent -> RpIdent -> Text -> Handler TypedContent
 getGitPatch shr rp ref = do

src/Yesod/ActivityPub.hs

@@ -23,11 +23,13 @@ module Yesod.ActivityPub
     , provideHtmlAndAP
     , provideHtmlAndAP'
     , provideHtmlAndAP''
+    , provideHtmlFeedAndAP
     )
 where
 
 import Control.Exception
 import Control.Monad.Logger.CallStack
+import Control.Monad.Trans.Writer
 import Data.Aeson
 import Data.Aeson.Encode.Pretty
 import Data.ByteString (ByteString)
@@ -35,10 +37,14 @@ import Data.Foldable
 import Data.Function
 import Data.List
 import Data.List.NonEmpty (NonEmpty)
+import Data.Semigroup
 import Data.Text (Text)
 import Network.HTTP.Client
 import Network.HTTP.Types.Header
+import Yesod.AtomFeed
 import Yesod.Core hiding (logError, logDebug)
+import Yesod.Feed
+import Yesod.RssFeed
 
 import qualified Data.ByteString.Lazy as BL
 import qualified Data.HashMap.Strict as M
@@ -192,12 +198,17 @@ provideHtmlAndAP object widget = do
     host <- getsYesod siteInstanceHost
     provideHtmlAndAP' host object widget
 
-provideHtmlAndAP'
+provideHtmlAndAP_
-    :: (YesodActivityPub site, SiteFedURIMode site ~ u, ActivityPub a)
+    :: Yesod site
-    => Authority u -> a u -> WidgetFor site () -> HandlerFor site TypedContent
+    => (a -> Writer (Endo [ProvidedRep (HandlerFor site)]) ())
-provideHtmlAndAP' host object widget = selectRep $ do
+    -> (a -> WidgetFor site ())
-    let doc = Doc host object
+    -> (a -> WidgetFor site ())
-    provideAP $ pure doc
+    -> a
+    -> WidgetFor site ()
+    -> Maybe (Feed (Route site))
+    -> HandlerFor site TypedContent
+provideHtmlAndAP_ provide renderSky renderHl doc widget mfeed = selectRep $ do
+    provide doc
     provideRep $ do
         mval <- lookupGetParam "prettyjson"
         defaultLayout $
@@ -210,8 +221,8 @@ provideHtmlAndAP' host object widget = selectRep $ do
                                 Just "sky" -> True
                                 Just _ -> error "Invalid highlight style"
                     if sky
-                        then renderPrettyJSONSkylighting doc
+                        then renderSky doc
-                        else renderPrettyJSON doc
+                        else renderHl doc
                     mroute <- getCurrentRoute
                     for_ mroute $ \ route -> do
                         params <- reqGetParams <$> getRequest
@@ -236,39 +247,48 @@ provideHtmlAndAP' host object widget = selectRep $ do
                               <a href=@?{(route, params')}>
                                 [See JSON]
                         |]
+    for_ mfeed $ \ feed -> do
+        provideRep $ atomFeed feed
+        provideRep $ rssFeed feed
     where
     delete' t = deleteBy ((==) `on` fst) (t, "")
 
+provideHtmlAndAP'
+    :: (YesodActivityPub site, SiteFedURIMode site ~ u, ActivityPub a)
+    => Authority u -> a u -> WidgetFor site () -> HandlerFor site TypedContent
+provideHtmlAndAP' host object widget =
+    provideHtmlAndAP_
+        (provideAP . pure)
+        renderPrettyJSONSkylighting
+        renderPrettyJSON
+        (Doc host object)
+        widget
+        Nothing
+
 provideHtmlAndAP''
     :: Yesod site
     => PersistJSON a -> WidgetFor site () -> HandlerFor site TypedContent
-provideHtmlAndAP'' body widget = selectRep $ do
+provideHtmlAndAP'' body widget =
-    provideAP' $ pure $ persistJSONBytes body
+    provideHtmlAndAP_
-    provideRep $ do
+        (provideAP' . pure . persistJSONBytes)
-        mval <- lookupGetParam "prettyjson"
+        (renderPrettyJSONSkylighting' . encodePretty . persistJSONObject)
-        defaultLayout $
+        (renderPrettyJSON' . encodePretty . persistJSONObject)
-            case mval of
+        body
-                Just "true" -> do
+        widget
-                    mhl <- lookupGetParam "highlight"
+        Nothing
-                    let sky = case mhl of
+
-                                Nothing -> True
+provideHtmlFeedAndAP
-                                Just "hl2" -> False
+    :: (YesodActivityPub site, SiteFedURIMode site ~ u, ActivityPub a)
-                                Just "sky" -> True
+    => a u
-                                Just _ -> error "Invalid highlight style"
+    -> Feed (Route site)
-                        pretty = encodePretty $ persistJSONObject body
+    -> WidgetFor site ()
-                    if sky
+    -> HandlerFor site TypedContent
-                        then renderPrettyJSONSkylighting' pretty
+provideHtmlFeedAndAP object feed widget = do
-                        else renderPrettyJSON' pretty
+    host <- getsYesod siteInstanceHost
-                _ -> do
+    provideHtmlAndAP_
-                    widget
+        (provideAP . pure)
-                    mroute <- getCurrentRoute
+        renderPrettyJSONSkylighting
-                    for_ mroute $ \ route -> do
+        renderPrettyJSON
-                        params <- reqGetParams <$> getRequest
+        (Doc host object)
-                        let pj = ("prettyjson", "true")
+        widget
-                            hl = ("highlight", "sky")
+        (Just feed)
-                            params' = pj : hl : params
-                        [whamlet|
-                            <div>
-                              <a href=@?{(route, params')}>
-                                [See JSON]
-                        |]