From 6ffc2c987203ce6141eb283905fc88f426716e62 Mon Sep 17 00:00:00 2001
From: fr33domlover <fr33domlover@riseup.net>
Date: Sun, 1 Sep 2019 14:19:14 +0000
Subject: [PATCH] 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 | 67 +++++++++++++++++++-----
src/Yesod/ActivityPub.hs | 96 ++++++++++++++++++++--------------
2 files changed, 112 insertions(+), 51 deletions(-)
diff --git a/src/Vervis/Handler/Repo/Git.hs b/src/Vervis/Handler/Repo/Git.hs
index 1946788..46a74cf 100644
--- a/src/Vervis/Handler/Repo/Git.hs
+++ b/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
- then do
- (_, _, entries, navModel) <- getPageAndNavTop $
- \ o l -> liftIO $ G.readChangesView path ref o l
- let refSelect = refSelectW shar repo branches tags
- changes = changesW shar repo entries
- pageNav = navWidget navModel
- feed = changeFeed shar repo (Just ref) VCSGit entries
- selectRep $ do
- provideRep $ defaultLayout $(widgetFile "repo/changes-git")
- provideRep $ atomFeed feed
- provideRep $ rssFeed feed
- else notFound
+ unless (ref `S.member` branches || ref `S.member` tags)
+ notFound
+ let here = RepoChangesR shar repo ref
+ encodeRouteLocal <- getEncodeRouteLocal
+ encodeRouteHome <- getEncodeRouteHome
+ encodeRoutePageLocal <- getEncodeRoutePageLocal
+ let pageUrl = encodeRoutePageLocal here
+ getChanges o l = liftIO $ G.readChangesView path ref o l
+ mpage <- getPageAndNavMaybe getChanges
+ case mpage of
+ Nothing -> do
+ (total, pages, _, _) <- getPageAndNavTop getChanges
+ 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
diff --git a/src/Yesod/ActivityPub.hs b/src/Yesod/ActivityPub.hs
index 10ebc12..2650509 100644
--- a/src/Yesod/ActivityPub.hs
+++ b/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'
- :: (YesodActivityPub site, SiteFedURIMode site ~ u, ActivityPub a)
- => Authority u -> a u -> WidgetFor site () -> HandlerFor site TypedContent
-provideHtmlAndAP' host object widget = selectRep $ do
- let doc = Doc host object
- provideAP $ pure doc
+provideHtmlAndAP_
+ :: Yesod site
+ => (a -> Writer (Endo [ProvidedRep (HandlerFor site)]) ())
+ -> (a -> WidgetFor site ())
+ -> (a -> WidgetFor site ())
+ -> 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
- else renderPrettyJSON doc
+ then renderSky 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
- provideAP' $ pure $ persistJSONBytes body
- provideRep $ do
- mval <- lookupGetParam "prettyjson"
- defaultLayout $
- case mval of
- Just "true" -> do
- mhl <- lookupGetParam "highlight"
- let sky = case mhl of
- Nothing -> True
- Just "hl2" -> False
- Just "sky" -> True
- Just _ -> error "Invalid highlight style"
- pretty = encodePretty $ persistJSONObject body
- if sky
- then renderPrettyJSONSkylighting' pretty
- else renderPrettyJSON' pretty
- _ -> do
- widget
- mroute <- getCurrentRoute
- for_ mroute $ \ route -> do
- params <- reqGetParams <$> getRequest
- let pj = ("prettyjson", "true")
- hl = ("highlight", "sky")
- params' = pj : hl : params
- [whamlet|
- <div>
- <a href=@?{(route, params')}>
- [See JSON]
- |]
+provideHtmlAndAP'' body widget =
+ provideHtmlAndAP_
+ (provideAP' . pure . persistJSONBytes)
+ (renderPrettyJSONSkylighting' . encodePretty . persistJSONObject)
+ (renderPrettyJSON' . encodePretty . persistJSONObject)
+ body
+ widget
+ Nothing
+
+provideHtmlFeedAndAP
+ :: (YesodActivityPub site, SiteFedURIMode site ~ u, ActivityPub a)
+ => a u
+ -> Feed (Route site)
+ -> WidgetFor site ()
+ -> HandlerFor site TypedContent
+provideHtmlFeedAndAP object feed widget = do
+ host <- getsYesod siteInstanceHost
+ provideHtmlAndAP_
+ (provideAP . pure)
+ renderPrettyJSONSkylighting
+ renderPrettyJSON
+ (Doc host object)
+ widget
+ (Just feed)