UI: getPatchR: Display diff-syntax-highlighted patch content file

src/Data/MediaType.hs

@@ -1,6 +1,6 @@
 {- This file is part of Vervis.
  -
- - Written in 2016 by fr33domlover <fr33domlover@riseup.net>.
+ - Written in 2016, 2022 by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ Copying is an act of love. Please copy, reuse and share.
  -
@@ -46,6 +46,8 @@ data MediaType
     | YesodRouteTemplate
     | Hamlet
     | Cassius
+    | Diff
+    | DarcsPatch
     deriving Show
 
 type FileName = Text
@@ -72,17 +74,20 @@ chooseMediaType dir base ext wt opts =
         (_, _, "json"    , _) -> PlainText
         (_, _, "yml"     , _) -> PlainText
         (_, _, "yaml"    , _) -> PlainText
+
         -- * Documents
         (_, _, "txt"     , _) -> PlainText
         (_, _, "md"      , _) -> Markdown
         (_, _, "mdwn"    , _) -> Markdown
         (_, _, "mkdn"    , _) -> Markdown
         (_, _, "markdown", _) -> Markdown
+
         -- * Web page basics
         (_, _, "html"    , _) -> PlainText
         (_, _, "xhtml"   , _) -> PlainText
         (_, _, "css"     , _) -> PlainText
         (_, _, "js"      , _) -> PlainText
+
         -- * Programming languages
         -- ** C
         (_, _, "c"       , _) -> PlainText
@@ -116,4 +121,10 @@ chooseMediaType dir base ext wt opts =
         (_, _, "rb"      , _) -> PlainText
         -- ** Scheme
         (_, _, "scm"     , _) -> PlainText
+
+        -- * Development
+        (_, _, "diff"    , _) -> Diff
+        (_, _, "patch"   , _) -> Diff
+        (_, _, "dpatch"  , _) -> DarcsPatch
+
         (_, _, _         , _) -> PlainText

src/Vervis/Foundation.hs

@@ -789,6 +789,11 @@ instance YesodPaginate App where
 
 instance YesodBreadcrumbs App where
     breadcrumb route = return $ case route of
+        LoomR l        -> ("MR Tracker +" <> keyHashidText l, Just HomeR)
+        LoomClothsR l  -> ("MRs", Just $ LoomR l)
+        ClothR l c     -> ("!" <> keyHashidText c, Just $ LoomClothsR l)
+        BundleR l c b  -> ("Bundle " <> keyHashidText b, Just $ ClothR l c)
+        PatchR l c b p -> ("Patch " <> keyHashidText p, Just $ BundleR l c b)
         {-
         StaticR _                        -> ("", Nothing)
         FaviconSvgR                      -> ("", Nothing)

src/Vervis/Handler/Cloth.hs

@@ -81,12 +81,14 @@ import qualified Data.List.NonEmpty as NE
 import qualified Data.List.Ordered as LO
 import qualified Database.Esqueleto as E
 
+import Data.MediaType
 import Development.PatchMediaType
 import Network.FedURI
 import Web.ActivityPub hiding (Ticket (..), Patch (..), Bundle (..), Repo (..), ActorDetail (..))
 import Yesod.ActivityPub
 import Yesod.FedURI
 import Yesod.Hashids
+import Yesod.RenderSource
 
 import qualified Web.ActivityPub as AP
 
@@ -461,12 +463,15 @@ getPatchR loomHash clothHash bundleHash patchHash = do
                     unless (patchBundle patch' == bundleID) notFound
                     return patch'
             <*> bitraverse
-                    (\ (Entity _ tal) -> return $ ticketAuthorLocalAuthor tal)
+                    (\ (Entity _ (TicketAuthorLocal _ personID _)) -> do
+                        p <- getJust personID
+                        (Entity personID p,) <$> getJust (personActor p)
+                    )
                     (\ (Entity _ tar) -> do
                         ra <- getJust $ ticketAuthorRemoteAuthor tar
                         ro <- getJust $ remoteActorIdent ra
                         i <- getJust $ remoteObjectInstance ro
-                        return (i, ro)
+                        return (i, ro, ra)
                     )
                     author'
 
@@ -477,7 +482,7 @@ getPatchR loomHash clothHash bundleHash patchHash = do
     let host =
             case author of
                 Left _          -> hLocal
-                Right (i, _) -> instanceHost i
+                Right (i, _, _) -> instanceHost i
         patchLocalAP = AP.PatchLocal
             { AP.patchId      = encodeRouteLocal here
             , AP.patchContext =
@@ -487,14 +492,20 @@ getPatchR loomHash clothHash bundleHash patchHash = do
             { AP.patchLocal = Just (hLocal, patchLocalAP)
             , AP.patchAttributedTo =
                 case author of
-                    Left authorID ->
+                    Left (Entity authorID _, _) ->
                         encodeRouteLocal $ PersonR $ hashPerson authorID
-                    Right (_, object) -> remoteObjectIdent object
+                    Right (_, object, _) -> remoteObjectIdent object
             , AP.patchPublished    = Just $ patchCreated patch
             , AP.patchType         = patchType patch
             , AP.patchContent      = patchContent patch
             }
-    provideHtmlAndAP' host patchAP $ redirectToPrettyJSON here
+    provideHtmlAndAP' host patchAP $ do
+        let syntax =
+                case patchType patch of
+                    PatchMediaTypeDarcs -> DarcsPatch
+                    PatchMediaTypeGit -> Diff
+            sourceW = renderSourceT syntax $ patchContent patch
+        $(widgetFile "patch")
     where
     here = PatchR loomHash clothHash bundleHash patchHash
 

src/Yesod/RenderSource.hs

@@ -1,6 +1,6 @@
 {- This file is part of Vervis.
  -
- - Written in 2016, 2018, 2019 by fr33domlover <fr33domlover@riseup.net>.
+ - Written in 2016, 2018, 2019, 2022 by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ Copying is an act of love. Please copy, reuse and share.
  -
@@ -79,6 +79,8 @@ import qualified Data.Text.Encoding.Error as TE
 import qualified Data.Text.Lazy as TL
 import qualified Data.Text.Lazy.Builder as TLB
 import qualified Data.Text.Lazy.Encoding as TLE
+import qualified Text.Highlighter.Lexers.DarcsPatch as L.DarcsPatch
+import qualified Text.Highlighter.Lexers.Diff as L.Diff
 import qualified Text.Highlighter.Lexers.Haskell as L.Haskell
 import qualified Text.Highlighter.Lexers.Javascript as L.JS
 
@@ -238,6 +240,9 @@ renderSource mt contentB contentTL contentT =
             -- * Programming languages
             -- ** Haskell
             Haskell   -> code L.Haskell.lexer
+            -- * Development files
+            Diff      -> code L.Diff.lexer
+            DarcsPatch -> code L.DarcsPatch.lexer
             -- * Misc
             _         -> plain
 

templates/patch.hamlet

@@ -0,0 +1,25 @@
+$# This file is part of Vervis.
+$#
+$# Written in 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/>.
+
+<div>
+  $case patchType patch
+    $of PatchMediaTypeDarcs
+      Darcs patch bundle,
+    $of PatchMediaTypeGit
+      Git patch,
+  belongs to MR received on #{showDate $ patchCreated patch} from
+  ^{personLinkFedW author}
+
+<div>
+  ^{sourceW}

vervis.cabal

@@ -424,7 +424,10 @@ library
 
   if flag(dev) || flag(library-only)
     cpp-options:       -DDEVELOPMENT
-    ghc-options:       -Wall -fwarn-tabs -O0 -Werror=incomplete-patterns -Werror=missing-fields
+    ghc-options:       -Wall -fwarn-tabs -O0
+                       -Werror=incomplete-patterns
+                       -Werror=missing-fields
+                       -Werror=overlapping-patterns
   else
     ghc-options:       -Wall -fwarn-tabs -O2