From b1897a20c0b2550ce3f3b4fd8a8dd54472edd6a9 Mon Sep 17 00:00:00 2001
From: fr33domlover <fr33domlover@riseup.net>
Date: Fri, 7 Jun 2019 04:26:32 +0000
Subject: [PATCH] Allow ticket author to be a remote actor
---
config/models | 15 ++-
migrations/2019_06_06.model | 11 ++
migrations/2019_06_06_mig.model | 24 ++++
src/Data/Either/Local.hs | 13 +++
src/Vervis/Form/Ticket.hs | 1 -
src/Vervis/Handler/Group.hs | 2 +-
src/Vervis/Handler/Repo/Git.hs | 2 +-
src/Vervis/Handler/Ticket.hs | 115 +++++++++++++-------
src/Vervis/Migration.hs | 12 ++
src/Vervis/Migration/Model.hs | 10 ++
src/Vervis/Ticket.hs | 73 ++++++++-----
src/Vervis/Widget/Discussion.hs | 2 +-
src/Vervis/Widget/Sharer.hs | 36 ++++--
src/Vervis/Widget/Ticket.hs | 6 +-
src/Yesod/ActivityPub.hs | 44 ++++----
templates/group/list.hamlet | 4 +-
templates/group/member/list.hamlet | 4 +-
templates/project/claim-request/list.hamlet | 4 +-
templates/project/collab/list.hamlet | 2 +-
templates/repo/collab/list.hamlet | 2 +-
templates/repo/patch.hamlet | 4 +-
templates/sharer-link.hamlet | 19 ----
templates/ticket/claim-request/list.hamlet | 4 +-
templates/ticket/dep/list.hamlet | 6 +-
templates/ticket/one.hamlet | 11 +-
templates/ticket/widget/summary.hamlet | 4 +-
26 files changed, 281 insertions(+), 149 deletions(-)
create mode 100644 migrations/2019_06_06.model
create mode 100644 migrations/2019_06_06_mig.model
delete mode 100644 templates/sharer-link.hamlet
diff --git a/config/models b/config/models
index 59d0ed2..bb8e8c5 100644
--- a/config/models
+++ b/config/models
@@ -281,14 +281,13 @@ Ticket
project ProjectId
number Int
created UTCTime
- creator PersonId
title Text
source Text -- Pandoc Markdown
description Text -- HTML
assignee PersonId Maybe
status TicketStatus
closed UTCTime
- closer PersonId
+ closer PersonId Maybe
discuss DiscussionId
followers FollowerSetId
@@ -296,6 +295,18 @@ Ticket
UniqueTicketDiscussion discuss
UniqueTicketFollowers followers
+TicketAuthorLocal
+ ticket TicketId
+ author PersonId
+
+ UniqueTicketAuthorLocal ticket
+
+TicketAuthorRemote
+ ticket TicketId
+ author RemoteActorId
+
+ UniqueTicketAuthorRemote ticket
+
TicketDependency
parent TicketId
child TicketId
diff --git a/migrations/2019_06_06.model b/migrations/2019_06_06.model
new file mode 100644
index 0000000..4c968fe
--- /dev/null
+++ b/migrations/2019_06_06.model
@@ -0,0 +1,11 @@
+TicketAuthorLocal
+ ticket TicketId
+ author PersonId
+
+ UniqueTicketAuthorLocal ticket
+
+TicketAuthorRemote
+ ticket TicketId
+ author RemoteActorId
+
+ UniqueTicketAuthorRemote ticket
diff --git a/migrations/2019_06_06_mig.model b/migrations/2019_06_06_mig.model
new file mode 100644
index 0000000..5dbfbde
--- /dev/null
+++ b/migrations/2019_06_06_mig.model
@@ -0,0 +1,24 @@
+TicketAuthorLocal
+ ticket TicketId
+ author Int64
+
+ UniqueTicketAuthorLocal ticket
+
+Ticket
+ project Int64
+ number Int
+ created UTCTime
+ creator Int64
+ title Text
+ source Text -- Pandoc Markdown
+ description Text -- HTML
+ assignee Int64 Maybe
+ status Text
+ closed UTCTime
+ closer Int64
+ discuss Int64
+ followers Int64
+
+ UniqueTicket project number
+ UniqueTicketDiscussion discuss
+ UniqueTicketFollowers followers
diff --git a/src/Data/Either/Local.hs b/src/Data/Either/Local.hs
index 19dbf51..ec6c932 100644
--- a/src/Data/Either/Local.hs
+++ b/src/Data/Either/Local.hs
@@ -17,11 +17,14 @@ module Data.Either.Local
( maybeRight
, maybeLeft
, requireEither
+ , requireEitherAlt
)
where
import Prelude
+import Control.Applicative
+
maybeRight :: Either a b -> Maybe b
maybeRight (Left _) = Nothing
maybeRight (Right b) = Just b
@@ -35,3 +38,13 @@ requireEither Nothing Nothing = Left False
requireEither (Just _) (Just _) = Left True
requireEither (Just x) Nothing = Right $ Left x
requireEither Nothing (Just y) = Right $ Right y
+
+requireEitherAlt
+ :: Applicative f
+ => f (Maybe a) -> f (Maybe b) -> String -> String -> f (Either a b)
+requireEitherAlt get1 get2 errNone errBoth = liftA2 mk get1 get2
+ where
+ mk Nothing Nothing = error errNone
+ mk (Just _) (Just _) = error errBoth
+ mk (Just x) Nothing = Left x
+ mk Nothing (Just y) = Right y
diff --git a/src/Vervis/Form/Ticket.hs b/src/Vervis/Form/Ticket.hs
index 67f8199..4d0680f 100644
--- a/src/Vervis/Form/Ticket.hs
+++ b/src/Vervis/Form/Ticket.hs
@@ -123,7 +123,6 @@ editTicketContentAForm ticket = Ticket
<$> pure (ticketProject ticket)
<*> pure (ticketNumber ticket)
<*> pure (ticketCreated ticket)
- <*> pure (ticketCreator ticket)
<*> areq textField "Title*" (Just $ ticketTitle ticket)
<*> ( maybe "" (T.filter (/= '\r') . unTextarea) <$>
aopt
diff --git a/src/Vervis/Handler/Group.hs b/src/Vervis/Handler/Group.hs
index 6afc254..35f75c3 100644
--- a/src/Vervis/Handler/Group.hs
+++ b/src/Vervis/Handler/Group.hs
@@ -52,7 +52,7 @@ import Vervis.Model.Group
import Vervis.Model.Ident (ShrIdent, shr2text)
import Vervis.Settings (widgetFile)
import Vervis.Time (showDate)
-import Vervis.Widget.Sharer (groupLinkW, personLinkW)
+import Vervis.Widget.Sharer
getGroupsR :: Handler Html
getGroupsR = do
diff --git a/src/Vervis/Handler/Repo/Git.hs b/src/Vervis/Handler/Repo/Git.hs
index 8a764e0..519e21c 100644
--- a/src/Vervis/Handler/Repo/Git.hs
+++ b/src/Vervis/Handler/Repo/Git.hs
@@ -78,7 +78,7 @@ import Vervis.Style
import Vervis.Time (showDate)
import Vervis.Widget (buttonW)
import Vervis.Widget.Repo
-import Vervis.Widget.Sharer (personLinkW)
+import Vervis.Widget.Sharer
import qualified Data.ByteString.Lazy as BL (ByteString)
import qualified Data.Git.Local as G (createRepo)
diff --git a/src/Vervis/Handler/Ticket.hs b/src/Vervis/Handler/Ticket.hs
index 7a3e675..646546f 100644
--- a/src/Vervis/Handler/Ticket.hs
+++ b/src/Vervis/Handler/Ticket.hs
@@ -96,6 +96,7 @@ import Yesod.Hashids
import qualified Web.ActivityPub as AP
+import Data.Either.Local
import Data.Maybe.Local (partitionMaybePairs)
import Database.Persist.Local
import Yesod.Persist.Local
@@ -117,7 +118,7 @@ import Vervis.TicketFilter (filterTickets)
import Vervis.Time (showDate)
import Vervis.Widget (buttonW)
import Vervis.Widget.Discussion (discussionW)
-import Vervis.Widget.Sharer (personLinkW)
+import Vervis.Widget.Sharer
import Vervis.Widget.Ticket
getTicketsR :: ShrIdent -> PrjIdent -> Handler Html
@@ -164,18 +165,18 @@ postTicketsR shar proj = do
{ ticketProject = pid
, ticketNumber = projectNextTicket project
, ticketCreated = now
- , ticketCreator = author
, ticketTitle = ntTitle nt
, ticketSource = source
, ticketDescription = descHtml
, ticketAssignee = Nothing
, ticketStatus = TSNew
, ticketClosed = UTCTime (ModifiedJulianDay 0) 0
- , ticketCloser = author
+ , ticketCloser = Nothing
, ticketDiscuss = did
, ticketFollowers = fsid
}
tid <- insert ticket
+ insert_ $ TicketAuthorLocal tid author
let mktparam (fid, v) = TicketParamText
{ ticketParamTextTicket = tid
, ticketParamTextField = fid
@@ -221,7 +222,7 @@ getTicketR :: ShrIdent -> PrjIdent -> Int -> Handler TypedContent
getTicketR shar proj num = do
mpid <- maybeAuthId
( wshr, wfl,
- author, massignee, closer, ticket, tparams, eparams, deps, rdeps) <-
+ author, massignee, mcloser, ticket, tparams, eparams, deps, rdeps) <-
runDB $ do
(jid, wshr, wid, wfl) <- do
Entity s sharer <- getBy404 $ UniqueSharer shar
@@ -238,19 +239,37 @@ getTicketR shar proj num = do
, workflowIdent w
)
Entity tid ticket <- getBy404 $ UniqueTicket jid num
- author <- do
- person <- get404 $ ticketCreator ticket
- get404 $ personIdent person
+ author <-
+ requireEitherAlt
+ (do mtal <- getValBy $ UniqueTicketAuthorLocal tid
+ for mtal $ \ tal -> do
+ p <- getJust $ ticketAuthorLocalAuthor tal
+ getJust $ personIdent p
+ )
+ (do mtar <- getValBy $ UniqueTicketAuthorRemote tid
+ for mtar $ \ tar -> do
+ ra <- getJust $ ticketAuthorRemoteAuthor tar
+ i <- getJust $ remoteActorInstance ra
+ return (i, ra)
+ )
+ "Ticket doesn't have author"
+ "Ticket has both local and remote author"
massignee <- for (ticketAssignee ticket) $ \ apid -> do
person <- get404 apid
sharer <- get404 $ personIdent person
return (sharer, fromMaybe False $ (== apid) <$> mpid)
- closer <-
+ mcloser <-
case ticketStatus ticket of
- TSClosed -> do
- person <- get404 $ ticketCloser ticket
- get404 $ personIdent person
- _ -> return author
+ TSClosed ->
+ case ticketCloser ticket of
+ Just pidCloser -> Just <$> do
+ person <- getJust pidCloser
+ getJust $ personIdent person
+ Nothing -> error "Closer not set for closed ticket"
+ _ ->
+ case ticketCloser ticket of
+ Just _ -> error "Closer set for open ticket"
+ Nothing -> return Nothing
tparams <- getTicketTextParams tid wid
eparams <- getTicketEnumParams tid wid
deps <- E.select $ E.from $ \ (dep `E.InnerJoin` t) -> do
@@ -263,7 +282,7 @@ getTicketR shar proj num = do
return t
return
( wshr, wfl
- , author, massignee, closer, ticket, tparams, eparams
+ , author, massignee, mcloser, ticket, tparams, eparams
, deps, rdeps
)
encodeHid <- getEncodeKeyHashid
@@ -287,6 +306,10 @@ getTicketR shar proj num = do
encodeRouteHome <- getEncodeRouteHome
let siblingUri =
encodeRouteHome . TicketR shar proj . ticketNumber . entityVal
+ host =
+ case author of
+ Left _ -> hLocal
+ Right (i, _) -> instanceHost i
ticketAP = AP.Ticket
{ AP.ticketLocal = Just
( hLocal
@@ -307,7 +330,11 @@ getTicketR shar proj num = do
)
, AP.ticketAttributedTo =
- encodeRouteLocal $ SharerR $ sharerIdent author
+ case author of
+ Left sharer ->
+ encodeRouteLocal $ SharerR $ sharerIdent sharer
+ Right (_inztance, actor) ->
+ remoteActorIdent actor
, AP.ticketPublished = Just $ ticketCreated ticket
, AP.ticketUpdated = Nothing
, AP.ticketName = Just $ "#" <> T.pack (show num)
@@ -322,7 +349,7 @@ getTicketR shar proj num = do
, AP.ticketDependsOn = map siblingUri deps
, AP.ticketDependedBy = map siblingUri rdeps
}
- provideHtmlAndAP ticketAP $(widgetFile "ticket/one")
+ provideHtmlAndAP' host ticketAP $(widgetFile "ticket/one")
putTicketR :: ShrIdent -> PrjIdent -> Int -> Handler Html
putTicketR shar proj num = do
@@ -438,7 +465,7 @@ postTicketCloseR shr prj num = do
[ TicketAssignee =. Nothing
, TicketStatus =. TSClosed
, TicketClosed =. now
- , TicketCloser =. pid
+ , TicketCloser =. Just pid
]
return True
setMessage $
@@ -460,7 +487,7 @@ postTicketOpenR shr prj num = do
TSClosed -> do
update tid
[ TicketStatus =. TSTodo
- , TicketCloser =. ticketCreator ticket
+ , TicketCloser =. Nothing
]
return True
_ -> return False
@@ -768,24 +795,42 @@ getTicketDeps forward shr prj num = do
Entity sid _ <- getBy404 $ UniqueSharer shr
Entity jid _ <- getBy404 $ UniqueProject prj sid
Entity tid _ <- getBy404 $ UniqueTicket jid num
- E.select $ E.from $
- \ ( td `E.InnerJoin`
- ticket `E.InnerJoin`
- person `E.InnerJoin`
- sharer
+ fmap (map toRow) $ E.select $ E.from $
+ \ ( td
+ `E.InnerJoin` t
+ `E.LeftOuterJoin` (tal `E.InnerJoin` p `E.InnerJoin` s)
+ `E.LeftOuterJoin` (tar `E.InnerJoin` ra `E.InnerJoin` i)
) -> do
- E.on $ person E.^. PersonIdent E.==. sharer E.^. SharerId
- E.on $ ticket E.^. TicketCreator E.==. person E.^. PersonId
- E.on $ td E.^. to' E.==. ticket E.^. TicketId
+ E.on $ ra E.?. RemoteActorInstance E.==. i E.?. InstanceId
+ E.on $ tar E.?. TicketAuthorRemoteAuthor E.==. ra E.?. RemoteActorId
+ E.on $ E.just (t E.^. TicketId) E.==. tar E.?. TicketAuthorRemoteTicket
+ E.on $ p E.?. PersonIdent E.==. s E.?. SharerId
+ E.on $ tal E.?. TicketAuthorLocalAuthor E.==. p E.?. PersonId
+ E.on $ E.just (t E.^. TicketId) E.==. tal E.?. TicketAuthorLocalTicket
+ E.on $ td E.^. to' E.==. t E.^. TicketId
E.where_ $ td E.^. from' E.==. E.val tid
- E.orderBy [E.asc $ ticket E.^. TicketNumber]
+ E.orderBy [E.asc $ t E.^. TicketNumber]
return
- ( ticket E.^. TicketNumber
- , sharer
- , ticket E.^. TicketTitle
- , ticket E.^. TicketStatus
+ ( t E.^. TicketNumber
+ , s
+ , i
+ , ra
+ , t E.^. TicketTitle
+ , t E.^. TicketStatus
)
defaultLayout $(widgetFile "ticket/dep/list")
+ where
+ toRow (E.Value number, ms, mi, mra, E.Value title, E.Value status) =
+ ( number
+ , case (ms, mi, mra) of
+ (Just s, Nothing, Nothing) ->
+ Left $ entityVal s
+ (Nothing, Just i, Just ra) ->
+ Right (entityVal i, entityVal ra)
+ _ -> error "Ticket author DB invalid state"
+ , title
+ , status
+ )
getTicketDepsR :: ShrIdent -> PrjIdent -> Int -> Handler Html
getTicketDepsR = getTicketDeps True
@@ -934,16 +979,6 @@ getTicketTeamR shr prj num = do
[whamlet|
<div><pre>#{encodePrettyToLazyText doc}
|]
- where
- requireEitherAlt
- :: Applicative f
- => f (Maybe a) -> f (Maybe b) -> String -> String -> f (Either a b)
- requireEitherAlt get1 get2 errNone errBoth = liftA2 mk get1 get2
- where
- mk Nothing Nothing = error errNone
- mk (Just _) (Just _) = error errBoth
- mk (Just x) Nothing = Left x
- mk Nothing (Just y) = Right y
getTicketEventsR :: ShrIdent -> PrjIdent -> Int -> Handler TypedContent
getTicketEventsR shr prj num = error "TODO not implemented"
diff --git a/src/Vervis/Migration.hs b/src/Vervis/Migration.hs
index 74e8785..955b86a 100644
--- a/src/Vervis/Migration.hs
+++ b/src/Vervis/Migration.hs
@@ -527,6 +527,18 @@ changes hLocal ctx =
[ Ticket201906Source =. source
, Ticket201906Description =. content
]
+ -- 91
+ , addEntities model_2019_06_06
+ -- 92
+ , unchecked $ lift $ do
+ tickets <- selectList ([] :: [Filter Ticket20190606]) []
+ let mklocal (Entity tid t) =
+ TicketAuthorLocal20190606 tid $ ticket20190606Creator t
+ insertMany_ $ map mklocal tickets
+ -- 93
+ , setFieldMaybe "Ticket" "closer"
+ -- 94
+ , removeField "Ticket" "creator"
]
migrateDB :: MonadIO m => Text -> HashidsContext -> ReaderT SqlBackend m (Either Text (Int, Int))
diff --git a/src/Vervis/Migration/Model.hs b/src/Vervis/Migration/Model.hs
index 7b8cf23..6dc10a5 100644
--- a/src/Vervis/Migration/Model.hs
+++ b/src/Vervis/Migration/Model.hs
@@ -57,6 +57,10 @@ module Vervis.Migration.Model
, Message201906
, Ticket201906Generic (..)
, Ticket201906
+ , model_2019_06_06
+ , Ticket20190606Generic (..)
+ , Ticket20190606
+ , TicketAuthorLocal20190606Generic (..)
)
where
@@ -146,3 +150,9 @@ makeEntitiesMigration "201906"
makeEntitiesMigration "201906"
$(modelFile "migrations/2019_06_03.model")
+
+model_2019_06_06 :: [Entity SqlBackend]
+model_2019_06_06 = $(schema "2019_06_06")
+
+makeEntitiesMigration "20190606"
+ $(modelFile "migrations/2019_06_06_mig.model")
diff --git a/src/Vervis/Ticket.hs b/src/Vervis/Ticket.hs
index c9daaf5..f53712d 100644
--- a/src/Vervis/Ticket.hs
+++ b/src/Vervis/Ticket.hs
@@ -47,34 +47,51 @@ getTicketSummaries
-> Maybe (SqlExpr (Entity Ticket) -> [SqlExpr OrderBy])
-> ProjectId
-> AppDB [TicketSummary]
-getTicketSummaries mfilt morder jid = do
- let toSummary (Value n, Entity _ s, Value c, Value t, Value d, Value r) =
- TicketSummary
- { tsNumber = n
- , tsCreatedBy = s
- , tsCreatedAt = c
- , tsTitle = t
- , tsStatus = d
- , tsComments = r
- }
- fmap (map toSummary) $ select $ from $
- \ (t `InnerJoin` p `InnerJoin` s `InnerJoin` d `LeftOuterJoin` m) -> do
- on $ just (d ^. DiscussionId) ==. m ?. MessageRoot
- on $ t ^. TicketDiscuss ==. d ^. DiscussionId
- on $ p ^. PersonIdent ==. s ^. SharerId
- on $ t ^. TicketCreator ==. p ^. PersonId
- where_ $ t ^. TicketProject ==. val jid
- groupBy (t ^. TicketId, s ^. SharerId)
- for_ mfilt $ \ filt -> where_ $ filt t
- for_ morder $ \ order -> orderBy $ order t
- return
- ( t ^. TicketNumber
- , s
- , t ^. TicketCreated
- , t ^. TicketTitle
- , t ^. TicketStatus
- , count $ m ?. MessageId
- )
+getTicketSummaries mfilt morder jid = fmap (map toSummary) $ select $ from $
+ \ ( t
+ `LeftOuterJoin` (tal `InnerJoin` p `InnerJoin` s)
+ `LeftOuterJoin` (tar `InnerJoin` ra `InnerJoin` i)
+ `InnerJoin` d
+ `LeftOuterJoin` m
+ ) -> do
+ on $ just (d ^. DiscussionId) ==. m ?. MessageRoot
+ on $ t ^. TicketDiscuss ==. d ^. DiscussionId
+ on $ ra ?. RemoteActorInstance ==. i ?. InstanceId
+ on $ tar ?. TicketAuthorRemoteAuthor ==. ra ?. RemoteActorId
+ on $ just (t ^. TicketId) ==. tar ?. TicketAuthorRemoteTicket
+ on $ p ?. PersonIdent ==. s ?. SharerId
+ on $ tal ?. TicketAuthorLocalAuthor ==. p ?. PersonId
+ on $ just (t ^. TicketId) ==. tal ?. TicketAuthorLocalTicket
+ where_ $ t ^. TicketProject ==. val jid
+ groupBy $ t ^. TicketId
+ for_ mfilt $ \ filt -> where_ $ filt t
+ for_ morder $ \ order -> orderBy $ order t
+ return
+ ( t ^. TicketNumber
+ , s
+ , i
+ , ra
+ , t ^. TicketCreated
+ , t ^. TicketTitle
+ , t ^. TicketStatus
+ , count $ m ?. MessageId
+ )
+ where
+ toSummary (Value n, ms, mi, mra, Value c, Value t, Value d, Value r) =
+ TicketSummary
+ { tsNumber = n
+ , tsCreatedBy =
+ case (ms, mi, mra) of
+ (Just s, Nothing, Nothing) ->
+ Left $ entityVal s
+ (Nothing, Just i, Just ra) ->
+ Right (entityVal i, entityVal ra)
+ _ -> error "Ticket author DB invalid state"
+ , tsCreatedAt = c
+ , tsTitle = t
+ , tsStatus = d
+ , tsComments = r
+ }
-- | Get the child-parent ticket number pairs of all the ticket dependencies
-- in the given project, in ascending order by child, and then ascending order
diff --git a/src/Vervis/Widget/Discussion.hs b/src/Vervis/Widget/Discussion.hs
index f051b9c..637b229 100644
--- a/src/Vervis/Widget/Discussion.hs
+++ b/src/Vervis/Widget/Discussion.hs
@@ -45,7 +45,7 @@ import Vervis.Model
import Vervis.Model.Ident
import Vervis.Render (renderSourceT)
import Vervis.Settings (widgetFile)
-import Vervis.Widget.Sharer (personLinkW)
+import Vervis.Widget.Sharer
actorLinkW :: MessageTreeNodeAuthor -> Widget
actorLinkW actor = $(widgetFile "widget/actor-link")
diff --git a/src/Vervis/Widget/Sharer.hs b/src/Vervis/Widget/Sharer.hs
index 2f584f6..865e658 100644
--- a/src/Vervis/Widget/Sharer.hs
+++ b/src/Vervis/Widget/Sharer.hs
@@ -15,28 +15,40 @@
module Vervis.Widget.Sharer
( sharerLinkW
- , personLinkW
- , groupLinkW
+ , sharerLinkFedW
)
where
import Prelude
-import Yesod.Core (Route)
+import Yesod.Core
+
+import Network.FedURI
import Vervis.Foundation
import Vervis.Model
import Vervis.Model.Ident (ShrIdent, shr2text)
import Vervis.Settings (widgetFile)
-link :: (ShrIdent -> Route App) -> Sharer -> Widget
-link route sharer = $(widgetFile "sharer-link")
-
sharerLinkW :: Sharer -> Widget
-sharerLinkW = link SharerR
+sharerLinkW sharer =
+ [whamlet|
+ <a href=@{SharerR $ sharerIdent sharer}>
+ $maybe name <- sharerName sharer
+ #{name}
+ $nothing
+ #{shr2text $ sharerIdent sharer}
+ |]
-personLinkW :: Sharer -> Widget
-personLinkW = link SharerR
-
-groupLinkW :: Sharer -> Widget
-groupLinkW = link SharerR
+sharerLinkFedW :: Either Sharer (Instance, RemoteActor) -> Widget
+sharerLinkFedW (Left sharer) = sharerLinkW sharer
+sharerLinkFedW (Right (inztance, actor)) =
+ [whamlet|
+ <a href="#{renderFedURI uActor}">
+ $maybe name <- remoteActorName actor
+ #{name}
+ $nothing
+ (?)
+ |]
+ where
+ uActor = l2f (instanceHost inztance) (remoteActorIdent actor)
diff --git a/src/Vervis/Widget/Ticket.hs b/src/Vervis/Widget/Ticket.hs
index 929764d..d359b0a 100644
--- a/src/Vervis/Widget/Ticket.hs
+++ b/src/Vervis/Widget/Ticket.hs
@@ -1,6 +1,6 @@
{- This file is part of Vervis.
-
- - Written in 2016 by fr33domlover <fr33domlover@riseup.net>.
+ - Written in 2016, 2019 by fr33domlover <fr33domlover@riseup.net>.
-
- ♡ Copying is an act of love. Please copy, reuse and share.
-
@@ -45,11 +45,11 @@ import Vervis.Model.Ticket
import Vervis.Settings (widgetFile)
import Vervis.Style
import Vervis.Time (showDate)
-import Vervis.Widget.Sharer (personLinkW)
+import Vervis.Widget.Sharer
data TicketSummary = TicketSummary
{ tsNumber :: Int
- , tsCreatedBy :: Sharer
+ , tsCreatedBy :: Either Sharer (Instance, RemoteActor)
, tsCreatedAt :: UTCTime
, tsTitle :: Text
, tsStatus :: TicketStatus
diff --git a/src/Yesod/ActivityPub.hs b/src/Yesod/ActivityPub.hs
index 4e6023d..d689418 100644
--- a/src/Yesod/ActivityPub.hs
+++ b/src/Yesod/ActivityPub.hs
@@ -18,6 +18,7 @@ module Yesod.ActivityPub
, deliverActivity
, forwardActivity
, provideHtmlAndAP
+ , provideHtmlAndAP'
)
where
@@ -121,25 +122,30 @@ provideHtmlAndAP
=> a -> WidgetFor site () -> HandlerFor site TypedContent
provideHtmlAndAP object widget = do
host <- getsYesod siteInstanceHost
+ provideHtmlAndAP' host object widget
+
+provideHtmlAndAP'
+ :: (YesodActivityPub site, ActivityPub a)
+ => Text -> a -> WidgetFor site () -> HandlerFor site TypedContent
+provideHtmlAndAP' host object widget = selectRep $ do
let doc = Doc host object
- selectRep $ do
- provideAP $ pure doc
- provideRep $ do
- mval <- lookupGetParam "prettyjson"
- defaultLayout $
- case mval of
- Just "true" ->
+ provideAP $ pure doc
+ provideRep $ do
+ mval <- lookupGetParam "prettyjson"
+ defaultLayout $
+ case mval of
+ Just "true" ->
+ [whamlet|
+ <div><pre>#{encodePrettyToLazyText doc}
+ |]
+ _ -> do
+ widget
+ mroute <- getCurrentRoute
+ for_ mroute $ \ route -> do
+ params <- reqGetParams <$> getRequest
+ let pj = ("prettyjson", "true")
[whamlet|
- <div><pre>#{encodePrettyToLazyText doc}
+ <div>
+ <a href=@?{(route, pj : params)}>
+ [See JSON]
|]
- _ -> do
- widget
- mroute <- getCurrentRoute
- for_ mroute $ \ route -> do
- params <- reqGetParams <$> getRequest
- let pj = ("prettyjson", "true")
- [whamlet|
- <div>
- <a href=@?{(route, pj : params)}>
- [See JSON]
- |]
diff --git a/templates/group/list.hamlet b/templates/group/list.hamlet
index fc77322..95505ba 100644
--- a/templates/group/list.hamlet
+++ b/templates/group/list.hamlet
@@ -1,6 +1,6 @@
$# This file is part of Vervis.
$#
-$# Written in 2016 by fr33domlover <fr33domlover@riseup.net>.
+$# Written in 2016, 2019 by fr33domlover <fr33domlover@riseup.net>.
$#
$# ♡ Copying is an act of love. Please copy, reuse and share.
$#
@@ -18,4 +18,4 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
<ul>
$forall Entity _sid sharer <- groups
<li>
- ^{groupLinkW sharer}
+ ^{sharerLinkW sharer}
diff --git a/templates/group/member/list.hamlet b/templates/group/member/list.hamlet
index 3de334a..e869c65 100644
--- a/templates/group/member/list.hamlet
+++ b/templates/group/member/list.hamlet
@@ -1,6 +1,6 @@
$# This file is part of Vervis.
$#
-$# Written in 2016 by fr33domlover <fr33domlover@riseup.net>.
+$# Written in 2016, 2019 by fr33domlover <fr33domlover@riseup.net>.
$#
$# ♡ Copying is an act of love. Please copy, reuse and share.
$#
@@ -24,4 +24,4 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
<ul>
$forall Entity _sid s <- members
<li>
- ^{personLinkW s}
+ ^{sharerLinkW s}
diff --git a/templates/project/claim-request/list.hamlet b/templates/project/claim-request/list.hamlet
index ddd927e..a69b7a6 100644
--- a/templates/project/claim-request/list.hamlet
+++ b/templates/project/claim-request/list.hamlet
@@ -1,6 +1,6 @@
$# This file is part of Vervis.
$#
-$# Written in 2016 by fr33domlover <fr33domlover@riseup.net>.
+$# Written in 2016, 2019 by fr33domlover <fr33domlover@riseup.net>.
$#
$# ♡ Copying is an act of love. Please copy, reuse and share.
$#
@@ -23,7 +23,7 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
<td>
#{showDate time}
<td>
- ^{personLinkW sharer}
+ ^{sharerLinkW sharer}
<td>
<a href=@{TicketR shr prj num}>#{num}
<td>
diff --git a/templates/project/collab/list.hamlet b/templates/project/collab/list.hamlet
index 4d4c734..8d8a915 100644
--- a/templates/project/collab/list.hamlet
+++ b/templates/project/collab/list.hamlet
@@ -18,7 +18,7 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
<th>Role
$forall (Entity _sid sharer, Value mrl) <- devs
<tr>
- <td>^{personLinkW sharer}
+ <td>^{sharerLinkW sharer}
<td>
$maybe rl <- mrl
#{rl2text rl}
diff --git a/templates/repo/collab/list.hamlet b/templates/repo/collab/list.hamlet
index 96f73a8..4bda84b 100644
--- a/templates/repo/collab/list.hamlet
+++ b/templates/repo/collab/list.hamlet
@@ -18,7 +18,7 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
<th>Role
$forall (Entity _sid sharer, Value mrl) <- devs
<tr>
- <td>^{personLinkW sharer}
+ <td>^{sharerLinkW sharer}
<td>
$maybe rl <- mrl
#{rl2text rl}
diff --git a/templates/repo/patch.hamlet b/templates/repo/patch.hamlet
index 3a1c93e..a45a6b5 100644
--- a/templates/repo/patch.hamlet
+++ b/templates/repo/patch.hamlet
@@ -1,6 +1,6 @@
$# This file is part of Vervis.
$#
-$# Written in 2018 by fr33domlover <fr33domlover@riseup.net>.
+$# Written in 2018, 2019 by fr33domlover <fr33domlover@riseup.net>.
$#
$# ♡ Copying is an act of love. Please copy, reuse and share.
$#
@@ -17,7 +17,7 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
<td>By
<td>
$maybe sharer <- msharer
- ^{personLinkW sharer}
+ ^{sharerLinkW sharer}
$nothing
#{patchAuthorName patch}
<tr>
diff --git a/templates/sharer-link.hamlet b/templates/sharer-link.hamlet
deleted file mode 100644
index 5c56a1b..0000000
--- a/templates/sharer-link.hamlet
+++ /dev/null
@@ -1,19 +0,0 @@
-$# This file is part of Vervis.
-$#
-$# Written in 2016 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/>.
-
-<a href=@{route $ sharerIdent sharer}>
- $maybe name <- sharerName sharer
- #{name}
- $nothing
- #{shr2text $ sharerIdent sharer}
diff --git a/templates/ticket/claim-request/list.hamlet b/templates/ticket/claim-request/list.hamlet
index 4807371..4df5f92 100644
--- a/templates/ticket/claim-request/list.hamlet
+++ b/templates/ticket/claim-request/list.hamlet
@@ -1,6 +1,6 @@
$# This file is part of Vervis.
$#
-$# Written in 2016 by fr33domlover <fr33domlover@riseup.net>.
+$# Written in 2016, 2019 by fr33domlover <fr33domlover@riseup.net>.
$#
$# ♡ Copying is an act of love. Please copy, reuse and share.
$#
@@ -22,6 +22,6 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
<td>
#{showDate $ ticketClaimRequestCreated tcr}
<td>
- ^{personLinkW sharer}
+ ^{sharerLinkW sharer}
<td>
^{renderSourceT Markdown $ ticketClaimRequestMessage tcr}
diff --git a/templates/ticket/dep/list.hamlet b/templates/ticket/dep/list.hamlet
index ea98da7..f007199 100644
--- a/templates/ticket/dep/list.hamlet
+++ b/templates/ticket/dep/list.hamlet
@@ -1,6 +1,6 @@
$# This file is part of Vervis.
$#
-$# Written in 2016, 2018 by fr33domlover <fr33domlover@riseup.net>.
+$# Written in 2016, 2018, 2019 by fr33domlover <fr33domlover@riseup.net>.
$#
$# ♡ Copying is an act of love. Please copy, reuse and share.
$#
@@ -20,12 +20,12 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
<th>Status
$if forward
<th>Remove dependency
- $forall (E.Value number, Entity _ author, E.Value title, E.Value status) <- rows
+ $forall (number, author, title, status) <- rows
<tr>
<td>
<a href=@{TicketR shr prj number}>#{number}
<td>
- ^{personLinkW author}
+ ^{sharerLinkFedW author}
<td>
<a href=@{TicketR shr prj number}>#{title}
<td>
diff --git a/templates/ticket/one.hamlet b/templates/ticket/one.hamlet
index eff824b..a8d5290 100644
--- a/templates/ticket/one.hamlet
+++ b/templates/ticket/one.hamlet
@@ -1,6 +1,6 @@
$# This file is part of Vervis.
$#
-$# Written in 2016, 2018 by fr33domlover <fr33domlover@riseup.net>.
+$# Written in 2016, 2018, 2019 by fr33domlover <fr33domlover@riseup.net>.
$#
$# ♡ Copying is an act of love. Please copy, reuse and share.
$#
@@ -41,7 +41,7 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
<p>
Created on #{showDate $ ticketCreated ticket} by
- ^{personLinkW author}
+ ^{sharerLinkFedW author}
$if ticketStatus ticket /= TSClosed
<p>
@@ -51,7 +51,7 @@ $if ticketStatus ticket /= TSClosed
^{buttonW POST "Unclaim this ticket" (TicketUnclaimR shar proj num)}
$else
- Assigned to ^{personLinkW assignee}.
+ Assigned to ^{sharerLinkW assignee}.
^{buttonW POST "Unassign this ticket" (TicketUnassignR shar proj num)}
$nothing
@@ -90,8 +90,9 @@ $if ticketStatus ticket /= TSClosed
^{buttonW POST "Close this ticket" (TicketCloseR shar proj num)}
$of TSClosed
- Closed on #{showDate $ ticketClosed ticket} by
- ^{personLinkW closer}.
+ Closed on #{showDate $ ticketClosed ticket}
+ $maybe closer <- mcloser
+ by ^{sharerLinkW closer}.
^{buttonW POST "Reopen this ticket" (TicketOpenR shar proj num)}
diff --git a/templates/ticket/widget/summary.hamlet b/templates/ticket/widget/summary.hamlet
index 9ef549a..245a31b 100644
--- a/templates/ticket/widget/summary.hamlet
+++ b/templates/ticket/widget/summary.hamlet
@@ -1,6 +1,6 @@
$# This file is part of Vervis.
$#
-$# Written in 2016 by fr33domlover <fr33domlover@riseup.net>.
+$# Written in 2016, 2019 by fr33domlover <fr33domlover@riseup.net>.
$#
$# ♡ Copying is an act of love. Please copy, reuse and share.
$#
@@ -30,7 +30,7 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
<span>
#{showDate $ tsCreatedAt ts}
- ^{personLinkW $ tsCreatedBy ts}
+ ^{sharerLinkFedW $ tsCreatedBy ts}
<a href=@{TicketR shr prj $ tsNumber ts}>
#{tsTitle ts}