UI: Fix and re-enable getRepoCommitR

src/Vervis/Darcs.hs

@@ -19,8 +19,8 @@ module Vervis.Darcs
     --, readWikiView
     --, readChangesView
     --, lastChange
-    --, readPatch
-      writePostApplyHooks
+      readPatch
+    , writePostApplyHooks
     --, applyDarcsPatch
     )
 where
@@ -261,6 +261,7 @@ lastChange path now = fmap maybeRight $ runExceptT $ do
             intervalToEventTime $
             FriendlyConvert $
             now `diffUTCTime` piTime pi
+-}
 
 data Change
     = AddFile FilePath
@@ -389,7 +390,6 @@ readPatch path hash = handle $ runExceptT $ do
         mkedit' (Replace fp regex old new) = AddTextFile "Replace" 0 [T.concat ["replace ", T.pack fp, " ", regex, " ", old, " ", new]]
         mkedit' (Binary fp old new)        = EditBinaryFile fp (fromIntegral $ B.length old) 0 (fromIntegral $ B.length new) 0
         mkedit' (Pref pref old new)        = AddTextFile "Pref" 0 [T.concat ["changepref ", pref, " ", old, " ", new]]
--}
 
 writePostApplyHooks :: WorkerDB ()
 writePostApplyHooks = do

src/Vervis/Git.hs

@@ -15,15 +15,12 @@
  -}
 
 module Vervis.Git
-    (
-    {-
-      readSourceView
-    , readChangesView
-    , listRefs
-    , readPatch
-    , lastCommitTime
-    -}
-      writePostReceiveHooks
+    ( --readSourceView
+    --, readChangesView
+    --, listRefs
+      readPatch
+    --, lastCommitTime
+    , writePostReceiveHooks
     --, applyGitPatches
     )
 where
@@ -216,6 +213,7 @@ readChangesView path ref off lim = G.withRepo (fromString path) $ \ git -> do
 listRefs :: FilePath -> IO (Set Text, Set Text)
 listRefs path = G.withRepo (fromString path) $ \ git ->
     (,) <$> listBranches git <*> listTags git
+-}
 
 patch :: [Edit] -> Commit SHA1 -> P.Patch
 patch edits c = P.Patch
@@ -325,6 +323,7 @@ readPatch path hash = G.withRepo (fromString path) $ \ git -> do
         Left parents -> (patch []    c, parents)
         Right edits  -> (patch edits c, [])
 
+{-
 lastCommitTime :: FilePath -> IO (Maybe UTCTime)
 lastCommitTime repo =
     (either fail return =<<) $ fmap join $ withRepo (fromString repo) $ runExceptT $ do

src/Vervis/Handler/Repo.hs

@@ -166,6 +166,8 @@ import Vervis.Settings
 import Vervis.SourceTree
 import Vervis.Style
 import Vervis.Web.Actor
+import Vervis.Web.Darcs
+import Vervis.Web.Git
 
 import qualified Vervis.Client as C
 import qualified Vervis.Formatting as F
@@ -398,14 +400,11 @@ getRepoBranchCommitsR repoHash branch = do
 
 getRepoCommitR :: KeyHashid Repo -> Text -> Handler TypedContent
 getRepoCommitR repoHash ref = do
-    error "Temporarily disabled"
-    {-
     repoID <- decodeKeyHashid404 repoHash
     repo <- runDB $ get404 repoID
     case repoVcs repo of
         VCSDarcs -> getDarcsPatch repoHash ref
         VCSGit -> getGitPatch repoHash ref
-    -}
 
 getRepoNewR :: Handler Html
 getRepoNewR = do

src/Vervis/Web/Darcs.hs

@@ -13,11 +13,11 @@
  - <http://creativecommons.org/publicdomain/zero/1.0/>.
  -}
 
-module Vervis.Handler.Repo.Darcs
-    ( getDarcsRepoSource
-    , getDarcsRepoHeadChanges
-    , getDarcsRepoChanges
-    , getDarcsPatch
+module Vervis.Web.Darcs
+    ( --getDarcsRepoSource
+    --, getDarcsRepoHeadChanges
+    --, getDarcsRepoChanges
+      getDarcsPatch
     )
 where
 
@@ -47,9 +47,11 @@ import qualified Data.Text as T
 import qualified Data.Text.Lazy.Encoding as L (decodeUtf8With)
 
 import Data.MediaType
+import Development.PatchMediaType
 import Web.ActivityPub hiding (Repo, Project)
 import Yesod.ActivityPub
 import Yesod.FedURI
+import Yesod.Hashids
 import Yesod.RenderSource
 
 import Data.ByteString.Char8.Local (takeLine)
@@ -63,17 +65,17 @@ import Vervis.Changes
 import Vervis.Foundation
 import Vervis.Path
 import Vervis.Model
-import Vervis.Model.Ident
-import Development.PatchMediaType
 import Vervis.Paginate
 import Vervis.Readme
 import Vervis.Settings
 import Vervis.SourceTree
 import Vervis.Style
 import Vervis.Time
+import Vervis.Web.Repo
 
-import qualified Vervis.Darcs as D (readSourceView, readChangesView, readPatch)
+import qualified Vervis.Darcs as D
 
+{-
 getDarcsRepoSource :: (Maybe (Sharer, Project, Workflow, Sharer), Repo) -> ShrIdent -> RpIdent -> [Text] -> Handler Html
 getDarcsRepoSource (mproject, repository) user repo dir = do
     path <- askRepoDir user repo
@@ -97,7 +99,9 @@ getDarcsRepoSource (mproject, repository) user repo dir = do
             (RepoFollowR user repo)
             (RepoUnfollowR user repo)
             (return $ repoFollowers repository)
+-}
 
+{-
 getDarcsRepoHeadChanges :: ShrIdent -> RpIdent -> Handler TypedContent
 getDarcsRepoHeadChanges shar repo = do
     path <- askRepoDir shar repo
@@ -153,14 +157,17 @@ getDarcsRepoHeadChanges shar repo = do
                     let changes = changesW shar repo items
                         pageNav = navWidget navModel
                     in  $(widgetFile "repo/changes-darcs")
+-}
 
+{-
 getDarcsRepoChanges :: ShrIdent -> RpIdent -> Text -> Handler TypedContent
 getDarcsRepoChanges shar repo tag = notFound
+-}
 
-getDarcsPatch :: ShrIdent -> RpIdent -> Text -> Handler TypedContent
-getDarcsPatch shr rp ref = do
-    path <- askRepoDir shr rp
+getDarcsPatch :: KeyHashid Repo -> Text -> Handler TypedContent
+getDarcsPatch hash ref = do
+    path <- askRepoDir hash
     mpatch <- liftIO $ D.readPatch path ref
     case mpatch of
         Nothing -> notFound
-        Just patch -> serveCommit shr rp ref patch []
+        Just patch -> serveCommit hash ref patch []

src/Vervis/Web/Git.hs

@@ -1,6 +1,7 @@
 {- This file is part of Vervis.
  -
- - Written in 2016, 2018, 2019, 2020 by fr33domlover <fr33domlover@riseup.net>.
+ - Written in 2016, 2018, 2019, 2020, 2022
+ - by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ Copying is an act of love. Please copy, reuse and share.
  -
@@ -13,12 +14,12 @@
  - <http://creativecommons.org/publicdomain/zero/1.0/>.
  -}
 
-module Vervis.Handler.Repo.Git
-    ( getGitRepoSource
-    , getGitRepoHeadChanges
-    , getGitRepoBranch
-    , getGitRepoChanges
-    , getGitPatch
+module Vervis.Web.Git
+    ( --getGitRepoSource
+    --, getGitRepoHeadChanges
+    --, getGitRepoBranch
+    --, getGitRepoChanges
+      getGitPatch
     )
 where
 
@@ -62,6 +63,7 @@ import Data.MediaType
 import Web.ActivityPub hiding (Commit, Author, Repo, Project)
 import Yesod.ActivityPub
 import Yesod.FedURI
+import Yesod.Hashids
 import Yesod.RenderSource
 
 import qualified Web.ActivityPub as AP
@@ -86,10 +88,12 @@ import Vervis.Settings
 import Vervis.SourceTree
 import Vervis.Style
 import Vervis.Time (showDate)
+import Vervis.Web.Repo
 
 import qualified Data.ByteString.Lazy as BL (ByteString)
-import qualified Vervis.Git as G (readSourceView, readChangesView, listRefs, readPatch)
+import qualified Vervis.Git as G
 
+{-
 getGitRepoSource :: (Maybe (Sharer, Project, Workflow, Sharer), Repo) -> ShrIdent -> RpIdent -> Text -> [Text] -> Handler Html
 getGitRepoSource (mproject, repository) user repo ref dir = do
     path <- askRepoDir user repo
@@ -113,11 +117,15 @@ getGitRepoSource (mproject, repository) user repo ref dir = do
             (RepoFollowR user repo)
             (RepoUnfollowR user repo)
             (return $ repoFollowers repository)
+-}
 
+{-
 getGitRepoHeadChanges :: Repo -> ShrIdent -> RpIdent -> Handler TypedContent
 getGitRepoHeadChanges repository shar repo =
     getGitRepoChanges shar repo $ repoMainBranch repository
+-}
 
+{-
 getGitRepoBranch :: ShrIdent -> RpIdent -> Text -> Handler TypedContent
 getGitRepoBranch shar repo ref = do
     path <- askRepoDir shar repo
@@ -133,7 +141,9 @@ getGitRepoBranch shar repo ref = do
                     }
             provideHtmlAndAP branchAP $ redirectToPrettyJSON here
         else notFound
+-}
 
+{-
 getGitRepoChanges :: ShrIdent -> RpIdent -> Text -> Handler TypedContent
 getGitRepoChanges shar repo ref = do
     path <- askRepoDir shar repo
@@ -189,9 +199,10 @@ getGitRepoChanges shar repo ref = do
                         changes = changesW shar repo items
                         pageNav = navWidget navModel
                     in  $(widgetFile "repo/changes-git")
+-}
 
-getGitPatch :: ShrIdent -> RpIdent -> Text -> Handler TypedContent
-getGitPatch shr rp ref = do
-    path <- askRepoDir shr rp
+getGitPatch :: KeyHashid Repo -> Text -> Handler TypedContent
+getGitPatch hash ref = do
+    path <- askRepoDir hash
     (patch, parents) <- liftIO $ G.readPatch path ref
-    serveCommit shr rp ref patch parents
+    serveCommit hash ref patch parents

src/Vervis/Web/Repo.hs

@@ -0,0 +1,94 @@
+{- This file is part of Vervis.
+ -
+ - Written in 2019, 2020, 2021, 2022 by fr33domlover <fr33domlover@riseup.net>.
+ -
+ - ♡ Copying is an act of love. Please copy, reuse and share.
+ -
+ - The author(s) have dedicated all copyright and related and neighboring
+ - rights to this software to the public domain worldwide. This software is
+ - distributed without any warranty.
+ -
+ - You should have received a copy of the CC0 Public Domain Dedication along
+ - with this software. If not, see
+ - <http://creativecommons.org/publicdomain/zero/1.0/>.
+ -}
+
+module Vervis.Web.Repo
+    ( serveCommit
+    )
+where
+
+import Data.Text (Text)
+import Data.Text.Encoding
+import Data.Traversable
+import Database.Persist
+import Yesod.Core hiding (logError, logWarn, logInfo, logDebug)
+import Yesod.Persist.Core
+
+import qualified Data.Text as T
+
+import Web.ActivityPub hiding (Author (..), Ticket, Repo, ActorLocal (..))
+import Yesod.ActivityPub
+import Yesod.FedURI
+import Yesod.Hashids
+
+import qualified Web.ActivityPub as AP
+
+import Data.Patch.Local hiding (Patch)
+
+import qualified Data.Patch.Local as P
+
+import Vervis.Foundation
+import Vervis.Model
+import Vervis.Settings
+import Vervis.Time
+import Vervis.Widget.Person
+import Vervis.Widget.Repo
+
+serveCommit
+    :: KeyHashid Repo
+    -> Text
+    -> P.Patch
+    -> [Text]
+    -> Handler TypedContent
+serveCommit repoHash ref patch parents = do
+    (mpersonWritten, mpersonCommitted) <- runDB $ (,)
+        <$> getPerson (patchWritten patch)
+        <*> maybe (pure Nothing) getPerson (patchCommitted patch)
+    encodeRouteLocal <- getEncodeRouteLocal
+    encodeRouteHome <- getEncodeRouteHome
+    hashPerson <- getEncodeKeyHashid
+    let (author, written) = patchWritten patch
+        mcommitter = patchCommitted patch
+        makeAuthor' = makeAuthor hashPerson encodeRouteHome
+        patchAP = AP.Commit
+            { commitId          = encodeRouteLocal $ RepoCommitR repoHash ref
+            , commitRepository  = encodeRouteLocal $ RepoR repoHash
+            , commitAuthor      = makeAuthor' mpersonWritten author
+            , commitCommitter   =
+                makeAuthor' mpersonCommitted . fst <$> mcommitter
+            , commitTitle       = patchTitle patch
+            , commitHash        = Hash $ encodeUtf8 ref
+            , commitDescription =
+                let desc = patchDescription patch
+                in  if T.null desc
+                        then Nothing
+                        else Just desc
+            , commitWritten     = written
+            , commitCommitted   = snd <$> patchCommitted patch
+            }
+    provideHtmlAndAP patchAP $
+        let number = zip ([1..] :: [Int])
+        in  $(widgetFile "repo/patch")
+    where
+    getPerson (author, _time) = do
+        mp <- getBy $ UniquePersonEmail $ authorEmail author
+        for mp $ \ ep@(Entity _ person) ->
+            (ep,) <$> getJust (personActor person)
+
+    makeAuthor _ _ Nothing author = Left AP.Author
+        { AP.authorName  = authorName author
+        , AP.authorEmail = authorEmail author
+        }
+    makeAuthor hashPerson encodeRouteHome (Just (Entity personID _, _)) _ =
+        Right $ encodeRouteHome $ PersonR $ hashPerson personID

templates/repo/patch.hamlet

@@ -16,14 +16,14 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
   <tr>
     <td>By
     <td>
-      $maybe sharer <- msharerWritten
-        ^{sharerLinkW sharer}
+      $maybe (person, actor) <- mpersonWritten
+        ^{personLinkW person actor}
       $nothing
         #{authorName author}
       $maybe (committer, _) <- patchCommitted patch
         ;
-        $maybe sharer <- msharerCommitted
-          ^{sharerLinkW sharer}
+        $maybe (person, actor) <- mpersonCommitted
+          ^{personLinkW person actor}
         $nothing
           #{authorName committer}
   <tr>

vervis.cabal

@@ -184,8 +184,6 @@ library
                        Vervis.Handler.Loom
                        Vervis.Handler.Person
                        Vervis.Handler.Repo
-                       --Vervis.Handler.Repo.Darcs
-                       --Vervis.Handler.Repo.Git
                        --Vervis.Handler.Role
                        --Vervis.Handler.Sharer
                        Vervis.Handler.Ticket
@@ -228,6 +226,9 @@ library
                        Vervis.Time
 
                        Vervis.Web.Actor
+                       Vervis.Web.Darcs
+                       Vervis.Web.Git
+                       Vervis.Web.Repo
 
                        Vervis.Widget
                        Vervis.Widget.Discussion