forge/Vervis
1
0
Fork 0
Code Pull requests Activity

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

Browse source
This commit is contained in:
fr33domlover 2022-09-19 11:00:47 +00:00
parent 5673340bd1
commit dae8554a12
6 changed files with 70 additions and 10 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

13
src/Data/MediaType.hs
View file

@ -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

5
src/Vervis/Foundation.hs
View file

@ -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)

25
src/Vervis/Handler/Cloth.hs
View file

@ -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'
@ -476,8 +481,8 @@ getPatchR loomHash clothHash bundleHash patchHash = do
let host =
case author of
Left _ -> hLocal
Right (i, _) -> instanceHost i
Left _ -> hLocal
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

7
src/Yesod/RenderSource.hs
View file

@ -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

25
templates/patch.hamlet Normal file
View file

@ -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}

5
vervis.cabal
View file

@ -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