forge/Vervis
1
0
Fork 0
Code Pull requests Activity

Prepare for ticket dependency federation

Browse source 
To be honest, this is a huge patch that changes tons of stuff and probably
should have been broken up into small changes. But I already had the codebase
not building, so... just did all of this at once :P

Basically this patch does the following:

- DB migrations for ticket dependency related tables, e.g. allowing a remote
  author and a remote child
- Allowing S2S handlers to provide an async continued processing function,
  which is executed and the result then added to the debug page
- Most UI and functionality related to ticket deps is disabled, new
  implementation being added gradually via ActivityPub
- Improvements to AP tools, e.g. allow to specify multiple hosts for approved
  forwarding when sending out an activity, and allow to specify audience of
  software-authored activities using a convenient human-friendly structure
- Implementation of S2S sharerOfferDepF which creates a dependency under a
  sharer-hosted ticket/patch and sends back an Accept
This commit is contained in:
fr33domlover 2020-06-18 10:38:04 +00:00
parent 854d35fd9b
commit a2468c52fd
35 changed files with 1780 additions and 684 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

44
config/models
View file

@ -455,14 +455,44 @@ Patch
created UTCTime created UTCTime
content Text content Text
TicketDependency RemoteTicketDependency
parent TicketId ident RemoteObjectId
child TicketId child LocalTicketId
author PersonId
summary Text -- HTML
created UTCTime
UniqueTicketDependency parent child UniqueRemoteTicketDependency ident
LocalTicketDependency
parent LocalTicketId
created UTCTime
accept OutboxItemId
TicketDependencyChildLocal
dep LocalTicketDependencyId
child LocalTicketId
UniqueTicketDependencyChildLocal dep
TicketDependencyChildRemote
dep LocalTicketDependencyId
child RemoteObjectId
UniqueTicketDependencyChildRemote dep
TicketDependencyAuthorLocal
dep LocalTicketDependencyId
author PersonId
open OutboxItemId
UniqueTicketDependencyAuthorLocal dep
UniqueTicketDependencyAuthorLocalOpen open
TicketDependencyAuthorRemote
dep LocalTicketDependencyId
author RemoteActorId
open RemoteActivityId
UniqueTicketDependencyAuthorRemote dep
UniqueTicketDependencyAuthorRemoteOpen open
TicketClaimRequest TicketClaimRequest
person PersonId person PersonId

15
migrations/2020_05_28_tda.model Normal file
View file

@ -0,0 +1,15 @@
TicketDependencyAuthorLocal
dep TicketDependencyId
author PersonId
open OutboxItemId
UniqueTicketDependencyAuthorLocal dep
UniqueTicketDependencyAuthorLocalOpen open
TicketDependencyAuthorRemote
dep TicketDependencyId
author RemoteActorId
open RemoteActivityId
UniqueTicketDependencyAuthorRemote dep
UniqueTicketDependencyAuthorRemoteOpen open

39
migrations/2020_05_28_tda_mig.model Normal file
View file

@ -0,0 +1,39 @@
Person
ident Int64
login Text
passphraseHash ByteString
email Text
verified Bool
verifiedKey Text
verifiedKeyCreated UTCTime
resetPassKey Text
resetPassKeyCreated UTCTime
about Text
inbox Int64
outbox OutboxId
followers Int64
Outbox
OutboxItem
outbox OutboxId
activity PersistJSONObject
published UTCTime
Ticket
TicketDependency
parent TicketId
child TicketId
author PersonId
created UTCTime
UniqueTicketDependency parent child
TicketDependencyAuthorLocal
dep TicketDependencyId
author PersonId
open OutboxItemId
UniqueTicketDependencyAuthorLocal dep
UniqueTicketDependencyAuthorLocalOpen open

17
migrations/2020_06_01_tdc.model Normal file
View file

@ -0,0 +1,17 @@
TicketDependencyChildLocal
dep TicketDependencyId
child LocalTicketId
UniqueTicketDependencyChildLocal dep
TicketDependencyChildRemote
dep TicketDependencyId
child RemoteObjectId
UniqueTicketDependencyChildRemote dep
RemoteTicketDependency
ident RemoteObjectId
child LocalTicketId
UniqueRemoteTicketDependency ident

67
migrations/2020_06_01_tdc_mig.model Normal file
View file

@ -0,0 +1,67 @@
Discussion
FollowerSet
OutboxItem
RemoteActor
RemoteActivity
RemoteObject
RemoteDiscussion
Ticket
LocalTicket
ticket TicketId
discuss DiscussionId
followers FollowerSetId
UniqueLocalTicket ticket
UniqueLocalTicketDiscussion discuss
UniqueLocalTicketFollowers followers
TicketContextLocal
ticket TicketId
accept OutboxItemId
UniqueTicketContextLocal ticket
UniqueTicketContextLocalAccept accept
TicketAuthorRemote
ticket TicketContextLocalId
author RemoteActorId
open RemoteActivityId
UniqueTicketAuthorRemote ticket
UniqueTicketAuthorRemoteOpen open
RemoteTicket
ticket TicketAuthorRemoteId
ident RemoteObjectId
discuss RemoteDiscussionId
UniqueRemoteTicket ticket
UniqueRemoteTicketIdent ident
UniqueRemoteTicketDiscuss discuss
LocalTicketDependency
parent TicketId
child TicketId
created UTCTime
UniqueLocalTicketDependency parent child
TicketDependencyChildLocal
dep LocalTicketDependencyId
child LocalTicketId
UniqueTicketDependencyChildLocal dep
TicketDependencyChildRemote
dep LocalTicketDependencyId
child RemoteObjectId
UniqueTicketDependencyChildRemote dep

30
migrations/2020_06_02_tdp.model Normal file
View file

@ -0,0 +1,30 @@
Discussion
FollowerSet
Person
Ticket
number Int Maybe
created UTCTime
title Text -- HTML
source Text -- Pandoc Markdown
description Text -- HTML
assignee PersonId Maybe
status Text
closed UTCTime
closer PersonId Maybe
LocalTicket
ticket TicketId
discuss DiscussionId
followers FollowerSetId
UniqueLocalTicket ticket
UniqueLocalTicketDiscussion discuss
UniqueLocalTicketFollowers followers
LocalTicketDependency
parent TicketId
parentNew LocalTicketId
created UTCTime

85
migrations/2020_06_15_td_accept.model Normal file
View file

@ -0,0 +1,85 @@
Outbox
OutboxItem
outbox OutboxId
activity PersistJSONObject
published UTCTime
Ticket
Discussion
FollowerSet
Inbox
Role
Workflow
Sharer
Repo
Person
Project
ident PrjIdent
sharer SharerId
name Text Maybe
desc Text Maybe
workflow WorkflowId
nextTicket Int
wiki RepoId Maybe
collabUser RoleId Maybe
collabAnon RoleId Maybe
inbox InboxId
outbox OutboxId
followers FollowerSetId
UniqueProject ident sharer
UniqueProjectInbox inbox
UniqueProjectOutbox outbox
UniqueProjectFollowers followers
LocalTicket
ticket TicketId
discuss DiscussionId
followers FollowerSetId
UniqueLocalTicket ticket
UniqueLocalTicketDiscussion discuss
UniqueLocalTicketFollowers followers
TicketContextLocal
ticket TicketId
accept OutboxItemId
UniqueTicketContextLocal ticket
UniqueTicketContextLocalAccept accept
TicketProjectLocal
context TicketContextLocalId
project ProjectId
UniqueTicketProjectLocal context
TicketAuthorLocal
ticket LocalTicketId
author PersonId
open OutboxItemId
UniqueTicketAuthorLocal ticket
UniqueTicketAuthorLocalOpen open
TicketUnderProject
project TicketContextLocalId
author TicketAuthorLocalId
UniqueTicketUnderProjectProject project
UniqueTicketUnderProjectAuthor author
LocalTicketDependency
parent LocalTicketId
created UTCTime
accept OutboxItemId

2
src/Network/FedURI.hs
View file

@ -184,7 +184,7 @@ instance PersistFieldSql FullURI where
data LocalURI = LocalURI data LocalURI = LocalURI
{ localUriPath :: Text { localUriPath :: Text
} }
deriving (Eq, Generic) deriving (Eq, Ord, Generic)
instance Hashable LocalURI instance Hashable LocalURI

15
src/Vervis/API.hs
View file

@ -359,13 +359,6 @@ createNoteC (Entity pidUser personUser) sharerUser summary audience note = runEx
sharerSet <- lookup shr localRecips sharerSet <- lookup shr localRecips
repoSet <- lookup rp $ localRecipRepoRelated sharerSet repoSet <- lookup rp $ localRecipRepoRelated sharerSet
guard $ localRecipRepo $ localRecipRepoDirect repoSet guard $ localRecipRepo $ localRecipRepoDirect repoSet
insertEmptyOutboxItem obid now = do
h <- asksSite siteInstanceHost
insert OutboxItem
{ outboxItemOutbox = obid
, outboxItemActivity = persistJSONObjectFromDoc $ Doc h emptyActivity
, outboxItemPublished = now
}
getProject tpl = do getProject tpl = do
j <- getJust $ ticketProjectLocalProject tpl j <- getJust $ ticketProjectLocalProject tpl
s <- getJust $ projectSharer j s <- getJust $ projectSharer j
@ -1005,9 +998,10 @@ offerTicketC
:: ShrIdent :: ShrIdent
-> TextHtml -> TextHtml
-> Audience URIMode -> Audience URIMode
-> Offer URIMode -> AP.Ticket URIMode
-> FedURI
-> Handler (Either Text OutboxItemId) -> Handler (Either Text OutboxItemId)
offerTicketC shrUser summary audience offer@(Offer ticket uTarget) = runExceptT $ do offerTicketC shrUser summary audience ticket uTarget = runExceptT $ do
(hProject, shrProject, prjProject) <- parseTarget uTarget (hProject, shrProject, prjProject) <- parseTarget uTarget
{-deps <- -} {-deps <- -}
checkOffer hProject shrProject prjProject checkOffer hProject shrProject prjProject
@ -1085,7 +1079,8 @@ offerTicketC shrUser summary audience offer@(Offer ticket uTarget) = runExceptT
, activityActor = AP.ticketAttributedTo ticket , activityActor = AP.ticketAttributedTo ticket
, activitySummary = Just summary , activitySummary = Just summary
, activityAudience = audience , activityAudience = audience
, activitySpecific = OfferActivity offer , activitySpecific =
OfferActivity $ Offer (OfferTicket ticket) uTarget
} }
obiid <- insert OutboxItem obiid <- insert OutboxItem
{ outboxItemOutbox = obid { outboxItemOutbox = obid

127
src/Vervis/ActivityPub.hs
View file

@ -19,7 +19,6 @@ module Vervis.ActivityPub
, verifyHostLocal , verifyHostLocal
, parseContext , parseContext
, parseParent , parseParent
, runDBExcept
, getLocalParentMessageId , getLocalParentMessageId
, getPersonOrGroupId , getPersonOrGroupId
, getTicketTeam , getTicketTeam
@ -43,13 +42,16 @@ module Vervis.ActivityPub
--, checkDep --, checkDep
, getProjectAndDeps , getProjectAndDeps
, deliverRemoteDB' , deliverRemoteDB'
, deliverRemoteDB''
, deliverRemoteHttp , deliverRemoteHttp
, deliverRemoteHttp'
, serveCommit , serveCommit
, deliverLocal , deliverLocal
, RemoteRecipient (..) , RemoteRecipient (..)
, deliverLocal' , deliverLocal'
, insertRemoteActivityToLocalInboxes , insertRemoteActivityToLocalInboxes
, provideEmptyCollection , provideEmptyCollection
, insertEmptyOutboxItem
) )
where where
@ -194,20 +196,6 @@ parseParent uParent = do
_ -> throwE "Local parent isn't a message route" _ -> throwE "Local parent isn't a message route"
else return $ Right uParent else return $ Right uParent
newtype FedError = FedError Text deriving Show
instance Exception FedError
runDBExcept :: (MonadUnliftIO m, MonadSite m, SiteEnv m ~ App) => ExceptT Text (ReaderT SqlBackend m) a -> ExceptT Text m a
runDBExcept action = do
result <-
lift $ try $ runSiteDB $ either abort return =<< runExceptT action
case result of
Left (FedError t) -> throwE t
Right r -> return r
where
abort = liftIO . throwIO . FedError
getLocalParentMessageId :: DiscussionId -> ShrIdent -> LocalMessageId -> ExceptT Text AppDB MessageId getLocalParentMessageId :: DiscussionId -> ShrIdent -> LocalMessageId -> ExceptT Text AppDB MessageId
getLocalParentMessageId did shr lmid = do getLocalParentMessageId did shr lmid = do
mlm <- lift $ get lmid mlm <- lift $ get lmid
@ -328,14 +316,14 @@ deliverHttpBL body mfwd h luInbox =
deliverActivityBL' (ObjURI h luInbox) (ObjURI h <$> mfwd) body deliverActivityBL' (ObjURI h luInbox) (ObjURI h <$> mfwd) body
deliverRemoteDB_ deliverRemoteDB_
:: PersistRecordBackend fwder SqlBackend :: (MonadIO m, PersistRecordBackend fwder SqlBackend)
=> (ForwardingId -> Key sender -> fwder) => (ForwardingId -> Key sender -> fwder)
-> BL.ByteString -> BL.ByteString
-> RemoteActivityId -> RemoteActivityId
-> Key sender -> Key sender
-> ByteString -> ByteString
-> [((InstanceId, Host), NonEmpty RemoteRecipient)] -> [((InstanceId, Host), NonEmpty RemoteRecipient)]
-> AppDB -> ReaderT SqlBackend m
[((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, ForwardingId, Key fwder))] [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, ForwardingId, Key fwder))]
deliverRemoteDB_ makeFwder body ractid senderKey sig recips = do deliverRemoteDB_ makeFwder body ractid senderKey sig recips = do
let body' = BL.toStrict body let body' = BL.toStrict body
@ -353,32 +341,35 @@ deliverRemoteDB_ makeFwder body ractid senderKey sig recips = do
noError ((RemoteRecipient _ _ _ (Just _), _ ), _ ) = Nothing noError ((RemoteRecipient _ _ _ (Just _), _ ), _ ) = Nothing
deliverRemoteDB_J deliverRemoteDB_J
:: BL.ByteString :: MonadIO m
=> BL.ByteString
-> RemoteActivityId -> RemoteActivityId
-> ProjectId -> ProjectId
-> ByteString -> ByteString
-> [((InstanceId, Host), NonEmpty RemoteRecipient)] -> [((InstanceId, Host), NonEmpty RemoteRecipient)]
-> AppDB -> ReaderT SqlBackend m
[((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, ForwardingId, ForwarderProjectId))] [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, ForwardingId, ForwarderProjectId))]
deliverRemoteDB_J = deliverRemoteDB_ ForwarderProject deliverRemoteDB_J = deliverRemoteDB_ ForwarderProject
deliverRemoteDB_S deliverRemoteDB_S
:: BL.ByteString :: MonadIO m
=> BL.ByteString
-> RemoteActivityId -> RemoteActivityId
-> SharerId -> SharerId
-> ByteString -> ByteString
-> [((InstanceId, Host), NonEmpty RemoteRecipient)] -> [((InstanceId, Host), NonEmpty RemoteRecipient)]
-> AppDB -> ReaderT SqlBackend m
[((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, ForwardingId, ForwarderSharerId))] [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, ForwardingId, ForwarderSharerId))]
deliverRemoteDB_S = deliverRemoteDB_ ForwarderSharer deliverRemoteDB_S = deliverRemoteDB_ ForwarderSharer
deliverRemoteDB_R deliverRemoteDB_R
:: BL.ByteString :: MonadIO m
=> BL.ByteString
-> RemoteActivityId -> RemoteActivityId
-> RepoId -> RepoId
-> ByteString -> ByteString
-> [((InstanceId, Host), NonEmpty RemoteRecipient)] -> [((InstanceId, Host), NonEmpty RemoteRecipient)]
-> AppDB -> ReaderT SqlBackend m
[((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, ForwardingId, ForwarderRepoId))] [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, ForwardingId, ForwarderRepoId))]
deliverRemoteDB_R = deliverRemoteDB_ ForwarderRepo deliverRemoteDB_R = deliverRemoteDB_ ForwarderRepo
@ -554,7 +545,20 @@ deliverRemoteDB'
, [((InstanceId, Host), NonEmpty (UnfetchedRemoteActorId, LocalURI, UnlinkedDeliveryId))] , [((InstanceId, Host), NonEmpty (UnfetchedRemoteActorId, LocalURI, UnlinkedDeliveryId))]
, [((InstanceId, Host), NonEmpty (UnfetchedRemoteActorId, LocalURI, UnlinkedDeliveryId))] , [((InstanceId, Host), NonEmpty (UnfetchedRemoteActorId, LocalURI, UnlinkedDeliveryId))]
) )
deliverRemoteDB' hContext obid recips known = do deliverRemoteDB' hContext = deliverRemoteDB'' [hContext]
deliverRemoteDB''
:: MonadIO m
=> [Host]
-> OutboxItemId
-> [(Host, NonEmpty LocalURI)]
-> [((InstanceId, Host), NonEmpty RemoteRecipient)]
-> ReaderT SqlBackend m
( [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, DeliveryId))]
, [((InstanceId, Host), NonEmpty (UnfetchedRemoteActorId, LocalURI, UnlinkedDeliveryId))]
, [((InstanceId, Host), NonEmpty (UnfetchedRemoteActorId, LocalURI, UnlinkedDeliveryId))]
)
deliverRemoteDB'' hContexts obid recips known = do
recips' <- for recips $ \ (h, lus) -> do recips' <- for recips $ \ (h, lus) -> do
let lus' = NE.nub lus let lus' = NE.nub lus
(iid, inew) <- idAndNew <$> insertBy' (Instance h) (iid, inew) <- idAndNew <$> insertBy' (Instance h)
@ -584,16 +588,16 @@ deliverRemoteDB' hContext obid recips known = do
stillUnknown = mapMaybe (\ (i, (_, _, uk)) -> (i,) <$> uk) recips' stillUnknown = mapMaybe (\ (i, (_, _, uk)) -> (i,) <$> uk) recips'
allFetched = unionRemotes known moreKnown allFetched = unionRemotes known moreKnown
fetchedDeliv <- for allFetched $ \ (i, rs) -> fetchedDeliv <- for allFetched $ \ (i, rs) ->
let fwd = snd i == hContext let fwd = snd i `elem` hContexts
in (i,) <$> insertMany' (\ (RemoteRecipient raid _ _ msince) -> Delivery raid obid fwd $ isNothing msince) rs in (i,) <$> insertMany' (\ (RemoteRecipient raid _ _ msince) -> Delivery raid obid fwd $ isNothing msince) rs
unfetchedDeliv <- for unfetched $ \ (i, rs) -> unfetchedDeliv <- for unfetched $ \ (i, rs) ->
let fwd = snd i == hContext let fwd = snd i `elem` hContexts
in (i,) <$> insertMany' (\ (uraid, _, msince) -> UnlinkedDelivery uraid obid fwd $ isNothing msince) rs in (i,) <$> insertMany' (\ (uraid, _, msince) -> UnlinkedDelivery uraid obid fwd $ isNothing msince) rs
unknownDeliv <- for stillUnknown $ \ (i, lus) -> do unknownDeliv <- for stillUnknown $ \ (i, lus) -> do
-- TODO maybe for URA insertion we should do insertUnique? -- TODO maybe for URA insertion we should do insertUnique?
ros <- insertMany' (\ lu -> RemoteObject (fst i) lu) lus ros <- insertMany' (\ lu -> RemoteObject (fst i) lu) lus
rs <- insertMany' (\ (_lu, roid) -> UnfetchedRemoteActor roid Nothing) ros rs <- insertMany' (\ (_lu, roid) -> UnfetchedRemoteActor roid Nothing) ros
let fwd = snd i == hContext let fwd = snd i `elem` hContexts
(i,) <$> insertMany' (\ (_, uraid) -> UnlinkedDelivery uraid obid fwd True) rs (i,) <$> insertMany' (\ (_, uraid) -> UnlinkedDelivery uraid obid fwd True) rs
return return
( takeNoError4 fetchedDeliv ( takeNoError4 fetchedDeliv
@ -622,10 +626,21 @@ deliverRemoteHttp
, [((InstanceId, Host), NonEmpty (UnfetchedRemoteActorId, LocalURI, UnlinkedDeliveryId))] , [((InstanceId, Host), NonEmpty (UnfetchedRemoteActorId, LocalURI, UnlinkedDeliveryId))]
) )
-> Worker () -> Worker ()
deliverRemoteHttp hContext obid doc (fetched, unfetched, unknown) = do deliverRemoteHttp hContext = deliverRemoteHttp' [hContext]
deliverRemoteHttp'
:: [Host]
-> OutboxItemId
-> Doc Activity URIMode
-> ( [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, DeliveryId))]
, [((InstanceId, Host), NonEmpty (UnfetchedRemoteActorId, LocalURI, UnlinkedDeliveryId))]
, [((InstanceId, Host), NonEmpty (UnfetchedRemoteActorId, LocalURI, UnlinkedDeliveryId))]
)
-> Worker ()
deliverRemoteHttp' hContexts obid doc (fetched, unfetched, unknown) = do
logDebug' "Starting" logDebug' "Starting"
let deliver fwd h inbox = do let deliver fwd h inbox = do
let fwd' = if h == hContext then Just fwd else Nothing let fwd' = if h `elem` hContexts then Just fwd else Nothing
(isJust fwd',) <$> deliverHttp doc fwd' h inbox (isJust fwd',) <$> deliverHttp doc fwd' h inbox
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
logDebug' $ logDebug' $
@ -831,7 +846,10 @@ data RemoteRecipient = RemoteRecipient
-- * If collections are listed, insert activity to the local members and return -- * If collections are listed, insert activity to the local members and return
-- the remote members -- the remote members
insertActivityToLocalInboxes insertActivityToLocalInboxes
:: PersistRecordBackend record SqlBackend :: ( MonadSite m
, YesodHashids (SiteEnv m)
, PersistRecordBackend record SqlBackend
)
=> (InboxId -> InboxItemId -> record) => (InboxId -> InboxItemId -> record)
-- ^ Database record to insert as an new inbox item to each inbox -- ^ Database record to insert as an new inbox item to each inbox
-> Bool -> Bool
@ -846,7 +864,7 @@ insertActivityToLocalInboxes
-- listed in the recipient set. This is meant to be the activity's -- listed in the recipient set. This is meant to be the activity's
-- author. -- author.
-> LocalRecipientSet -> LocalRecipientSet
-> AppDB [((InstanceId, Host), NonEmpty RemoteRecipient)] -> ReaderT SqlBackend m [((InstanceId, Host), NonEmpty RemoteRecipient)]
insertActivityToLocalInboxes makeInboxItem requireOwner mauthor mibidAuthor recips = do insertActivityToLocalInboxes makeInboxItem requireOwner mauthor mibidAuthor recips = do
ibidsSharer <- deleteAuthor <$> getSharerInboxes recips ibidsSharer <- deleteAuthor <$> getSharerInboxes recips
ibidsOther <- concat <$> traverse getOtherInboxes recips ibidsOther <- concat <$> traverse getOtherInboxes recips
@ -876,7 +894,8 @@ insertActivityToLocalInboxes makeInboxItem requireOwner mauthor mibidAuthor reci
Nothing -> id Nothing -> id
Just ibidAuthor -> L.delete ibidAuthor Just ibidAuthor -> L.delete ibidAuthor
getSharerInboxes :: LocalRecipientSet -> AppDB [InboxId] getSharerInboxes
:: MonadIO m => LocalRecipientSet -> ReaderT SqlBackend m [InboxId]
getSharerInboxes sharers = do getSharerInboxes sharers = do
let shrs = let shrs =
[shr | (shr, s) <- sharers [shr | (shr, s) <- sharers
@ -885,7 +904,9 @@ insertActivityToLocalInboxes makeInboxItem requireOwner mauthor mibidAuthor reci
sids <- selectKeysList [SharerIdent <-. shrs] [] sids <- selectKeysList [SharerIdent <-. shrs] []
map (personInbox . entityVal) <$> selectList [PersonIdent <-. sids] [Asc PersonInbox] map (personInbox . entityVal) <$> selectList [PersonIdent <-. sids] [Asc PersonInbox]
getOtherInboxes :: (ShrIdent, LocalSharerRelatedSet) -> AppDB [InboxId] getOtherInboxes
:: MonadIO m
=> (ShrIdent, LocalSharerRelatedSet) -> ReaderT SqlBackend m [InboxId]
getOtherInboxes (shr, LocalSharerRelatedSet _ _ _ projects repos) = do getOtherInboxes (shr, LocalSharerRelatedSet _ _ _ projects repos) = do
msid <- getKeyBy $ UniqueSharer shr msid <- getKeyBy $ UniqueSharer shr
case msid of case msid of
@ -910,7 +931,9 @@ insertActivityToLocalInboxes makeInboxItem requireOwner mauthor mibidAuthor reci
in map (repoInbox . entityVal) <$> in map (repoInbox . entityVal) <$>
selectList [RepoSharer ==. sid, RepoIdent <-. rps] [] selectList [RepoSharer ==. sid, RepoIdent <-. rps] []
getSharerFollowerSets :: LocalRecipientSet -> AppDB [FollowerSetId] getSharerFollowerSets
:: MonadIO m
=> LocalRecipientSet -> ReaderT SqlBackend m [FollowerSetId]
getSharerFollowerSets sharers = do getSharerFollowerSets sharers = do
let shrs = let shrs =
[shr | (shr, s) <- sharers [shr | (shr, s) <- sharers
@ -921,7 +944,10 @@ insertActivityToLocalInboxes makeInboxItem requireOwner mauthor mibidAuthor reci
sids <- selectKeysList [SharerIdent <-. shrs] [] sids <- selectKeysList [SharerIdent <-. shrs] []
map (personFollowers . entityVal) <$> selectList [PersonIdent <-. sids] [] map (personFollowers . entityVal) <$> selectList [PersonIdent <-. sids] []
getOtherFollowerSets :: (ShrIdent, LocalSharerRelatedSet) -> AppDB [FollowerSetId] getOtherFollowerSets
:: (MonadSite m, YesodHashids (SiteEnv m))
=> (ShrIdent, LocalSharerRelatedSet)
-> ReaderT SqlBackend m [FollowerSetId]
getOtherFollowerSets (shr, LocalSharerRelatedSet _ tickets patches projects repos) = do getOtherFollowerSets (shr, LocalSharerRelatedSet _ tickets patches projects repos) = do
msid <- getKeyBy $ UniqueSharer shr msid <- getKeyBy $ UniqueSharer shr
case msid of case msid of
@ -1043,7 +1069,8 @@ insertActivityToLocalInboxes makeInboxItem requireOwner mauthor mibidAuthor reci
) )
return $ lt E.^. LocalTicketFollowers return $ lt E.^. LocalTicketFollowers
getLocalFollowers :: [FollowerSetId] -> AppDB [InboxId] getLocalFollowers
:: MonadIO m => [FollowerSetId] -> ReaderT SqlBackend m [InboxId]
getLocalFollowers fsids = do getLocalFollowers fsids = do
pids <- pids <-
map (followPerson . entityVal) <$> map (followPerson . entityVal) <$>
@ -1051,7 +1078,11 @@ insertActivityToLocalInboxes makeInboxItem requireOwner mauthor mibidAuthor reci
map (personInbox . entityVal) <$> map (personInbox . entityVal) <$>
selectList [PersonId <-. pids] [Asc PersonInbox] selectList [PersonId <-. pids] [Asc PersonInbox]
getRemoteFollowers :: [FollowerSetId] -> AppDB [((InstanceId, Host), NonEmpty RemoteRecipient)] getRemoteFollowers
:: MonadIO m
=> [FollowerSetId]
-> ReaderT SqlBackend m
[((InstanceId, Host), NonEmpty RemoteRecipient)]
getRemoteFollowers fsids = getRemoteFollowers fsids =
fmap groupRemotes $ fmap groupRemotes $
E.select $ E.from $ \ (rf `E.InnerJoin` ra `E.InnerJoin` ro `E.InnerJoin` i) -> do E.select $ E.from $ \ (rf `E.InnerJoin` ra `E.InnerJoin` ro `E.InnerJoin` i) -> do
@ -1073,7 +1104,9 @@ insertActivityToLocalInboxes makeInboxItem requireOwner mauthor mibidAuthor reci
where where
toTuples (E.Value iid, E.Value h, E.Value raid, E.Value luA, E.Value luI, E.Value ms) = ((iid, h), RemoteRecipient raid luA luI ms) toTuples (E.Value iid, E.Value h, E.Value raid, E.Value luA, E.Value luI, E.Value ms) = ((iid, h), RemoteRecipient raid luA luI ms)
getTeams :: (ShrIdent, LocalSharerRelatedSet) -> AppDB [InboxId] getTeams
:: MonadIO m
=> (ShrIdent, LocalSharerRelatedSet) -> ReaderT SqlBackend m [InboxId]
getTeams (shr, LocalSharerRelatedSet _ tickets _ projects repos) = do getTeams (shr, LocalSharerRelatedSet _ tickets _ projects repos) = do
msid <- getKeyBy $ UniqueSharer shr msid <- getKeyBy $ UniqueSharer shr
case msid of case msid of
@ -1115,22 +1148,24 @@ insertActivityToLocalInboxes makeInboxItem requireOwner mauthor mibidAuthor reci
-- * If collections are listed, insert activity to the local members and return -- * If collections are listed, insert activity to the local members and return
-- the remote members -- the remote members
deliverLocal' deliverLocal'
:: Bool -- ^ Whether to deliver to collection only if owner actor is addressed :: (MonadSite m, YesodHashids (SiteEnv m))
=> Bool -- ^ Whether to deliver to collection only if owner actor is addressed
-> LocalActor -> LocalActor
-> InboxId -> InboxId
-> OutboxItemId -> OutboxItemId
-> LocalRecipientSet -> LocalRecipientSet
-> AppDB [((InstanceId, Host), NonEmpty RemoteRecipient)] -> ReaderT SqlBackend m [((InstanceId, Host), NonEmpty RemoteRecipient)]
deliverLocal' requireOwner author ibidAuthor obiid = deliverLocal' requireOwner author ibidAuthor obiid =
insertActivityToLocalInboxes makeItem requireOwner (Just author) (Just ibidAuthor) insertActivityToLocalInboxes makeItem requireOwner (Just author) (Just ibidAuthor)
where where
makeItem ibid ibiid = InboxItemLocal ibid obiid ibiid makeItem ibid ibiid = InboxItemLocal ibid obiid ibiid
insertRemoteActivityToLocalInboxes insertRemoteActivityToLocalInboxes
:: Bool :: (MonadSite m, YesodHashids (SiteEnv m))
=> Bool
-> RemoteActivityId -> RemoteActivityId
-> LocalRecipientSet -> LocalRecipientSet
-> AppDB [((InstanceId, Host), NonEmpty RemoteRecipient)] -> ReaderT SqlBackend m [((InstanceId, Host), NonEmpty RemoteRecipient)]
insertRemoteActivityToLocalInboxes requireOwner ractid = insertRemoteActivityToLocalInboxes requireOwner ractid =
insertActivityToLocalInboxes makeItem requireOwner Nothing Nothing insertActivityToLocalInboxes makeItem requireOwner Nothing Nothing
where where
@ -1149,3 +1184,11 @@ provideEmptyCollection typ here = do
, collectionItems = [] :: [Text] , collectionItems = [] :: [Text]
} }
provideHtmlAndAP coll $ redirectToPrettyJSON here provideHtmlAndAP coll $ redirectToPrettyJSON here
insertEmptyOutboxItem obid now = do
h <- asksSite siteInstanceHost
insert OutboxItem
{ outboxItemOutbox = obid
, outboxItemActivity = persistJSONObjectFromDoc $ Doc h emptyActivity
, outboxItemPublished = now
}

44
src/Vervis/ActivityPub/Recipient.hs
View file

@ -34,6 +34,9 @@ module Vervis.ActivityPub.Recipient
, actorRecips , actorRecips
, localRecipSieve , localRecipSieve
, localRecipSieve' , localRecipSieve'
, Aud (..)
, collectAudience
) )
where where
@ -46,11 +49,13 @@ import Data.Foldable
import Data.List ((\\)) import Data.List ((\\))
import Data.List.NonEmpty (NonEmpty, nonEmpty) import Data.List.NonEmpty (NonEmpty, nonEmpty)
import Data.Maybe import Data.Maybe
import Data.Semigroup
import Data.Text (Text) import Data.Text (Text)
import Data.These import Data.These
import Data.Traversable import Data.Traversable
import qualified Data.List.NonEmpty as NE import qualified Data.List.NonEmpty as NE
import qualified Data.List.Ordered as LO
import qualified Data.Text as T import qualified Data.Text as T
import Network.FedURI import Network.FedURI
@ -84,7 +89,7 @@ data LocalActor
= LocalActorSharer ShrIdent = LocalActorSharer ShrIdent
| LocalActorProject ShrIdent PrjIdent | LocalActorProject ShrIdent PrjIdent
| LocalActorRepo ShrIdent RpIdent | LocalActorRepo ShrIdent RpIdent
deriving Eq deriving (Eq, Ord)
parseLocalActor :: Route App -> Maybe LocalActor parseLocalActor :: Route App -> Maybe LocalActor
parseLocalActor (SharerR shr) = Just $ LocalActorSharer shr parseLocalActor (SharerR shr) = Just $ LocalActorSharer shr
@ -111,7 +116,7 @@ data LocalPersonCollection
| LocalPersonCollectionRepoTeam ShrIdent RpIdent | LocalPersonCollectionRepoTeam ShrIdent RpIdent
| LocalPersonCollectionRepoFollowers ShrIdent RpIdent | LocalPersonCollectionRepoFollowers ShrIdent RpIdent
| LocalPersonCollectionRepoPatchFollowers ShrIdent RpIdent (KeyHashid LocalTicket) | LocalPersonCollectionRepoPatchFollowers ShrIdent RpIdent (KeyHashid LocalTicket)
deriving Eq deriving (Eq, Ord)
parseLocalPersonCollection parseLocalPersonCollection
:: Route App -> Maybe LocalPersonCollection :: Route App -> Maybe LocalPersonCollection
@ -592,3 +597,38 @@ localRecipSieve' sieve allowSharers allowOthers =
where where
applyRepo (LocalRepoDirectSet r' t' f') (LocalRepoDirectSet r t f) = applyRepo (LocalRepoDirectSet r' t' f') (LocalRepoDirectSet r t f) =
LocalRepoDirectSet (r && (r' || allowOthers)) (t && t') (f && f') LocalRepoDirectSet (r && (r' || allowOthers)) (t && t') (f && f')
data Aud u
= AudLocal [LocalActor] [LocalPersonCollection]
| AudRemote (Authority u) [LocalURI] [LocalURI]
collectAudience
:: Foldable f
=> f (Aud u)
-> ( LocalRecipientSet
, [(Authority u, NonEmpty LocalURI)]
, [Authority u]
, [Route App]
, [ObjURI u]
)
collectAudience auds =
let (locals, remotes) = partitionAudience auds
(actors, collections) =
let organize = LO.nubSort . concat
in bimap organize organize $ unzip locals
groupedRemotes =
let organize = LO.nubSort . sconcat
in map (second $ bimap organize organize . NE.unzip) $
groupAllExtract fst snd remotes
in ( makeRecipientSet actors collections
, mapMaybe (\ (h, (as, _)) -> (h,) <$> nonEmpty as) groupedRemotes
, [ h | (h, (_, cs)) <- groupedRemotes, not (null cs) ]
, map renderLocalActor actors ++
map renderLocalPersonCollection collections
, concatMap (\ (h, (as, cs)) -> ObjURI h <$> as ++ cs) groupedRemotes
)
where
partitionAudience = foldl' f ([], [])
where
f (ls, rs) (AudLocal as cs) = ((as, cs) : ls, rs)
f (ls, rs) (AudRemote h as cs) = (ls , (h, (as, cs)) : rs)

11
src/Vervis/Client.hs
View file

@ -210,7 +210,7 @@ followRepo shrAuthor shrObject rpObject hide = do
offerTicket offerTicket
:: (MonadHandler m, HandlerSite m ~ App, MonadSite m, SiteEnv m ~ App) :: (MonadHandler m, HandlerSite m ~ App, MonadSite m, SiteEnv m ~ App)
=> ShrIdent -> TextHtml -> TextPandocMarkdown -> ShrIdent -> PrjIdent -> m (Either Text (TextHtml, Audience URIMode, Offer URIMode)) => ShrIdent -> TextHtml -> TextPandocMarkdown -> ShrIdent -> PrjIdent -> m (Either Text (TextHtml, Audience URIMode, AP.Ticket URIMode, FedURI))
offerTicket shrAuthor (TextHtml title) (TextPandocMarkdown desc) shr prj = runExceptT $ do offerTicket shrAuthor (TextHtml title) (TextPandocMarkdown desc) shr prj = runExceptT $ do
encodeRouteLocal <- getEncodeRouteLocal encodeRouteLocal <- getEncodeRouteLocal
encodeRouteHome <- getEncodeRouteHome encodeRouteHome <- getEncodeRouteHome
@ -243,10 +243,7 @@ offerTicket shrAuthor (TextHtml title) (TextPandocMarkdown desc) shr prj = runEx
, AP.ticketIsResolved = False , AP.ticketIsResolved = False
, AP.ticketAttachment = Nothing , AP.ticketAttachment = Nothing
} }
offer = Offer target = encodeRouteHome $ ProjectR shr prj
{ offerObject = ticket
, offerTarget = encodeRouteHome $ ProjectR shr prj
}
audience = Audience audience = Audience
{ audienceTo = map encodeRouteHome $ recipsA ++ recipsC { audienceTo = map encodeRouteHome $ recipsA ++ recipsC
, audienceBto = [] , audienceBto = []
@ -255,7 +252,7 @@ offerTicket shrAuthor (TextHtml title) (TextPandocMarkdown desc) shr prj = runEx
, audienceGeneral = [] , audienceGeneral = []
, audienceNonActors = map encodeRouteHome recipsC , audienceNonActors = map encodeRouteHome recipsC
} }
return (summary, audience, offer) return (summary, audience, ticket, target)
createTicket createTicket
:: (MonadHandler m, HandlerSite m ~ App, MonadSite m, SiteEnv m ~ App) :: (MonadHandler m, HandlerSite m ~ App, MonadSite m, SiteEnv m ~ App)
@ -330,7 +327,7 @@ undoFollow
undoFollow shrAuthor pidAuthor getFsid typ objRoute recipRoute = runExceptT $ do undoFollow shrAuthor pidAuthor getFsid typ objRoute recipRoute = runExceptT $ do
encodeRouteLocal <- getEncodeRouteLocal encodeRouteLocal <- getEncodeRouteLocal
encodeRouteHome <- getEncodeRouteHome encodeRouteHome <- getEncodeRouteHome
obiidFollow <- runDBExcept $ do obiidFollow <- runSiteDBExcept $ do
fsid <- getFsid fsid <- getFsid
mf <- lift $ getValBy $ UniqueFollow pidAuthor fsid mf <- lift $ getValBy $ UniqueFollow pidAuthor fsid
followFollow <$> fromMaybeE mf ("Not following this " <> typ) followFollow <$> fromMaybeE mf ("Not following this " <> typ)

64
src/Vervis/Federation.hs
View file

@ -125,12 +125,12 @@ parseTicket project luContext = do
_ -> throwE "Local context isn't a ticket route" _ -> throwE "Local context isn't a ticket route"
handleSharerInbox handleSharerInbox
:: UTCTime :: ShrIdent
-> ShrIdent -> UTCTime
-> ActivityAuthentication -> ActivityAuthentication
-> ActivityBody -> ActivityBody
-> ExceptT Text Handler Text -> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text))
handleSharerInbox _now shrRecip (ActivityAuthLocal (ActivityAuthLocalPerson pidAuthor)) body = do handleSharerInbox shrRecip _now (ActivityAuthLocal (ActivityAuthLocalPerson pidAuthor)) body = (,Nothing) <$> do
(shrActivity, obiid) <- do (shrActivity, obiid) <- do
luAct <- luAct <-
fromMaybeE fromMaybeE
@ -174,7 +174,7 @@ handleSharerInbox _now shrRecip (ActivityAuthLocal (ActivityAuthLocalPerson pidA
"Activity already exists in inbox of /s/" <> recip "Activity already exists in inbox of /s/" <> recip
Just _ -> Just _ ->
return $ "Activity inserted to inbox of /s/" <> recip return $ "Activity inserted to inbox of /s/" <> recip
handleSharerInbox _now shrRecip (ActivityAuthLocal (ActivityAuthLocalProject jidAuthor)) body = do handleSharerInbox shrRecip _now (ActivityAuthLocal (ActivityAuthLocalProject jidAuthor)) body = (,Nothing) <$> do
(shrActivity, prjActivity, obiid) <- do (shrActivity, prjActivity, obiid) <- do
luAct <- luAct <-
fromMaybeE fromMaybeE
@ -218,7 +218,7 @@ handleSharerInbox _now shrRecip (ActivityAuthLocal (ActivityAuthLocalProject jid
"Activity already exists in inbox of /s/" <> recip "Activity already exists in inbox of /s/" <> recip
Just _ -> Just _ ->
return $ "Activity inserted to inbox of /s/" <> recip return $ "Activity inserted to inbox of /s/" <> recip
handleSharerInbox _now shrRecip (ActivityAuthLocal (ActivityAuthLocalRepo ridAuthor)) body = do handleSharerInbox shrRecip _now (ActivityAuthLocal (ActivityAuthLocalRepo ridAuthor)) body = (,Nothing) <$> do
(shrActivity, rpActivity, obiid) <- do (shrActivity, rpActivity, obiid) <- do
luAct <- luAct <-
fromMaybeE fromMaybeE
@ -262,37 +262,42 @@ handleSharerInbox _now shrRecip (ActivityAuthLocal (ActivityAuthLocalRepo ridAut
"Activity already exists in inbox of /s/" <> recip "Activity already exists in inbox of /s/" <> recip
Just _ -> Just _ ->
return $ "Activity inserted to inbox of /s/" <> recip return $ "Activity inserted to inbox of /s/" <> recip
handleSharerInbox now shrRecip (ActivityAuthRemote author) body = handleSharerInbox shrRecip now (ActivityAuthRemote author) body =
case activitySpecific $ actbActivity body of case activitySpecific $ actbActivity body of
AcceptActivity accept -> AcceptActivity accept ->
sharerAcceptF shrRecip now author body accept (,Nothing) <$> sharerAcceptF shrRecip now author body accept
CreateActivity (Create obj mtarget) -> CreateActivity (Create obj mtarget) ->
case obj of case obj of
CreateNote note -> CreateNote note ->
sharerCreateNoteF now shrRecip author body note (,Nothing) <$> sharerCreateNoteF now shrRecip author body note
CreateTicket ticket -> CreateTicket ticket ->
sharerCreateTicketF now shrRecip author body ticket mtarget (,Nothing) <$> sharerCreateTicketF now shrRecip author body ticket mtarget
_ -> return "Unsupported create object type for sharers" _ -> return ("Unsupported create object type for sharers", Nothing)
FollowActivity follow -> FollowActivity follow ->
sharerFollowF shrRecip now author body follow (,Nothing) <$> sharerFollowF shrRecip now author body follow
OfferActivity offer -> OfferActivity (Offer obj target) ->
sharerOfferTicketF now shrRecip author body offer case obj of
OfferTicket ticket ->
(,Nothing) <$> sharerOfferTicketF now shrRecip author body ticket target
OfferDep dep ->
sharerOfferDepF now shrRecip author body dep target
_ -> return ("Unsupported offer object type for sharers", Nothing)
PushActivity push -> PushActivity push ->
sharerPushF shrRecip now author body push (,Nothing) <$> sharerPushF shrRecip now author body push
RejectActivity reject -> RejectActivity reject ->
sharerRejectF shrRecip now author body reject (,Nothing) <$> sharerRejectF shrRecip now author body reject
UndoActivity undo -> UndoActivity undo ->
sharerUndoF shrRecip now author body undo (,Nothing) <$> sharerUndoF shrRecip now author body undo
_ -> return "Unsupported activity type for sharers" _ -> return ("Unsupported activity type for sharers", Nothing)
handleProjectInbox handleProjectInbox
:: UTCTime :: ShrIdent
-> ShrIdent
-> PrjIdent -> PrjIdent
-> UTCTime
-> ActivityAuthentication -> ActivityAuthentication
-> ActivityBody -> ActivityBody
-> ExceptT Text Handler Text -> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text))
handleProjectInbox now shrRecip prjRecip auth body = do handleProjectInbox shrRecip prjRecip now auth body = (,Nothing) <$> do
remoteAuthor <- remoteAuthor <-
case auth of case auth of
ActivityAuthLocal local -> throwE $ errorLocalForwarded local ActivityAuthLocal local -> throwE $ errorLocalForwarded local
@ -307,8 +312,11 @@ handleProjectInbox now shrRecip prjRecip auth body = do
_ -> error "Unsupported create object type for projects" _ -> error "Unsupported create object type for projects"
FollowActivity follow -> FollowActivity follow ->
projectFollowF shrRecip prjRecip now remoteAuthor body follow projectFollowF shrRecip prjRecip now remoteAuthor body follow
OfferActivity offer -> OfferActivity (Offer obj target) ->
projectOfferTicketF now shrRecip prjRecip remoteAuthor body offer case obj of
OfferTicket ticket ->
projectOfferTicketF now shrRecip prjRecip remoteAuthor body ticket target
_ -> return "Unsupported offer object type for projects"
UndoActivity undo -> UndoActivity undo ->
projectUndoF shrRecip prjRecip now remoteAuthor body undo projectUndoF shrRecip prjRecip now remoteAuthor body undo
_ -> return "Unsupported activity type for projects" _ -> return "Unsupported activity type for projects"
@ -324,13 +332,13 @@ handleProjectInbox now shrRecip prjRecip auth body = do
T.pack (show $ fromSqlKey rid) T.pack (show $ fromSqlKey rid)
handleRepoInbox handleRepoInbox
:: UTCTime :: ShrIdent
-> ShrIdent
-> RpIdent -> RpIdent
-> UTCTime
-> ActivityAuthentication -> ActivityAuthentication
-> ActivityBody -> ActivityBody
-> ExceptT Text Handler Text -> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text))
handleRepoInbox now shrRecip rpRecip auth body = do handleRepoInbox shrRecip rpRecip now auth body = (,Nothing) <$> do
remoteAuthor <- remoteAuthor <-
case auth of case auth of
ActivityAuthLocal local -> throwE $ errorLocalForwarded local ActivityAuthLocal local -> throwE $ errorLocalForwarded local

27
src/Vervis/Federation/Discussion.hs
View file

@ -68,6 +68,7 @@ import Vervis.ActivityPub
import Vervis.ActivityPub.Recipient import Vervis.ActivityPub.Recipient
import Vervis.FedURI import Vervis.FedURI
import Vervis.Federation.Auth import Vervis.Federation.Auth
import Vervis.Federation.Util
import Vervis.Foundation import Vervis.Foundation
import Vervis.Model import Vervis.Model
import Vervis.Model.Ident import Vervis.Model.Ident
@ -100,32 +101,6 @@ checkNote (Note mluNote _ _ muParent muCtx mpub source content) = do
else Just <$> parseParent uParent else Just <$> parseParent uParent
return (luNote, published, context, mparent, source, content) return (luNote, published, context, mparent, source, content)
-- | Insert a remote activity delivered to us into our inbox. Return its
-- database ID if the activity wasn't already in our inbox.
insertToInbox
:: UTCTime
-> RemoteAuthor
-> ActivityBody
-> InboxId
-> LocalURI
-> Bool
-> AppDB (Maybe RemoteActivityId)
insertToInbox now author body ibid luCreate unread = do
let iidAuthor = remoteAuthorInstance author
roid <-
either entityKey id <$> insertBy' (RemoteObject iidAuthor luCreate)
ractid <- either entityKey id <$> insertBy' RemoteActivity
{ remoteActivityIdent = roid
, remoteActivityContent = persistJSONFromBL $ actbBL body
, remoteActivityReceived = now
}
ibiid <- insert $ InboxItem unread
new <- isRight <$> insertBy' (InboxItemRemote ibid ractid ibiid)
return $
if new
then Just ractid
else Nothing
-- | Given the parent specified by the Note we received, check if we already -- | Given the parent specified by the Note we received, check if we already
-- know and have this parent note in the DB, and whether the child and parent -- know and have this parent note in the DB, and whether the child and parent
-- belong to the same discussion root. -- belong to the same discussion root.

460
src/Vervis/Federation/Ticket.hs
View file

@ -19,6 +19,8 @@ module Vervis.Federation.Ticket
, sharerCreateTicketF , sharerCreateTicketF
, projectCreateTicketF , projectCreateTicketF
, sharerOfferDepF
) )
where where
@ -30,6 +32,7 @@ import Control.Monad.Trans.Except
import Control.Monad.Trans.Maybe import Control.Monad.Trans.Maybe
import Data.Aeson import Data.Aeson
import Data.Bifunctor import Data.Bifunctor
import Data.Bitraversable
import Data.Foldable import Data.Foldable
import Data.Function import Data.Function
import Data.List (nub, union) import Data.List (nub, union)
@ -70,10 +73,13 @@ import Vervis.ActivityPub
import Vervis.ActivityPub.Recipient import Vervis.ActivityPub.Recipient
import Vervis.FedURI import Vervis.FedURI
import Vervis.Federation.Auth import Vervis.Federation.Auth
import Vervis.Federation.Util
import Vervis.Foundation import Vervis.Foundation
import Vervis.Model import Vervis.Model
import Vervis.Model.Ident import Vervis.Model.Ident
import Vervis.Model.Ticket import Vervis.Model.Ticket
import Vervis.Patch
import Vervis.Ticket
checkOffer checkOffer
:: AP.Ticket URIMode :: AP.Ticket URIMode
@ -95,9 +101,10 @@ sharerOfferTicketF
-> ShrIdent -> ShrIdent
-> RemoteAuthor -> RemoteAuthor
-> ActivityBody -> ActivityBody
-> Offer URIMode -> AP.Ticket URIMode
-> FedURI
-> ExceptT Text Handler Text -> ExceptT Text Handler Text
sharerOfferTicketF now shrRecip author body (Offer ticket uTarget) = do sharerOfferTicketF now shrRecip author body ticket uTarget = do
(hProject, shrProject, prjProject) <- parseTarget uTarget (hProject, shrProject, prjProject) <- parseTarget uTarget
luOffer <- fromMaybeE (activityId $ actbActivity body) "Offer without 'id'" luOffer <- fromMaybeE (activityId $ actbActivity body) "Offer without 'id'"
{-deps <- -} {-deps <- -}
@ -192,10 +199,11 @@ projectOfferTicketF
-> PrjIdent -> PrjIdent
-> RemoteAuthor -> RemoteAuthor
-> ActivityBody -> ActivityBody
-> Offer URIMode -> AP.Ticket URIMode
-> FedURI
-> ExceptT Text Handler Text -> ExceptT Text Handler Text
projectOfferTicketF projectOfferTicketF
now shrRecip prjRecip author body (Offer ticket uTarget) = do now shrRecip prjRecip author body ticket uTarget = do
targetIsUs <- lift $ runExceptT checkTarget targetIsUs <- lift $ runExceptT checkTarget
case targetIsUs of case targetIsUs of
Left t -> do Left t -> do
@ -737,3 +745,447 @@ projectCreateTicketF now shrRecip prjRecip author body ticket muTarget = do
delete tid delete tid
return $ Left True return $ Left True
Just _rtid -> return $ Right () Just _rtid -> return $ Right ()
sharerOfferDepF
:: UTCTime
-> ShrIdent
-> RemoteAuthor
-> ActivityBody
-> AP.TicketDependency URIMode
-> FedURI
-> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text))
sharerOfferDepF now shrRecip author body dep uTarget = do
luOffer <- fromMaybeE (activityId $ actbActivity body) "Offer without 'id'"
(parent, child) <- checkDepAndTarget dep uTarget
(localRecips, _remoteRecips) <- do
mrecips <- parseAudience $ activityAudience $ actbActivity body
fromMaybeE mrecips "Offer Dep with no recipients"
msig <- checkForward $ LocalActorSharer shrRecip
personRecip <- lift $ runDB $ do
sid <- getKeyBy404 $ UniqueSharer shrRecip
getValBy404 $ UniquePersonIdent sid
return $ (,) "Ran initial checks, doing the rest asynchronously" $ Just $ do
manager <- asksSite appHttpManager
relevantParent <-
for (parentRelevance shrRecip parent) $ \ (talid, patch) -> do
(parentLtid, parentCtx) <- runSiteDBExcept $ do
let getTcr tcr = do
let getRoid roid = do
ro <- getJust roid
i <- getJust $ remoteObjectInstance ro
return $ mkuri (i, ro)
roidT <- remoteActorIdent <$> getJust (ticketProjectRemoteTracker tcr)
let mroidJ = ticketProjectRemoteProject tcr
(,) <$> getRoid roidT <*> traverse getRoid mroidJ
if patch
then do
(_, Entity ltid _, _, context, _) <- do
mticket <- lift $ getSharerPatch shrRecip talid
fromMaybeE mticket $ "Parent" <> ": No such sharer-patch"
context' <-
lift $
bitraverse
(\ (_, Entity _ trl) -> do
r <- getJust $ ticketRepoLocalRepo trl
s <- getJust $ repoSharer r
return $ Right (sharerIdent s, repoIdent r)
)
(\ (Entity _ tcr, _) -> getTcr tcr)
context
return (ltid, context')
else do
(_, Entity ltid _, _, context) <- do
mticket <- lift $ getSharerTicket shrRecip talid
fromMaybeE mticket $ "Parent" <> ": No such sharer-ticket"
context' <-
lift $
bitraverse
(\ (_, Entity _ tpl) -> do
j <- getJust $ ticketProjectLocalProject tpl
s <- getJust $ projectSharer j
return $ Left (sharerIdent s, projectIdent j)
)
(\ (Entity _ tcr, _) -> getTcr tcr)
context
return (ltid, context')
parentCtx' <- bifor parentCtx pure $ \ (uTracker, muProject) -> do
let uProject = fromMaybe uTracker muProject
obj <- withExceptT T.pack $ AP.fetchAP manager $ Left uProject
unless (objId obj == uProject) $
throwE "Project 'id' differs from the URI we fetched"
return
(uTracker, objUriAuthority uProject, objFollowers obj, objTeam obj)
(childId, childCtx, childAuthor) <-
case child of
Left wi -> runSiteDBExcept $ do
(ltid, ctx, author) <- getWorkItem "Child" wi
return (Left (wi, ltid), second mkuri ctx, second mkuri author)
Right u -> do
Doc hAuthor t <- withExceptT T.pack $ AP.fetchAP manager $ Left u
(hTicket, tl) <- fromMaybeE (AP.ticketLocal t) "Child ticket no 'id'"
unless (ObjURI hAuthor (AP.ticketId tl) == u) $
throwE "Ticket 'id' differs from the URI we fetched"
uCtx <- fromMaybeE (AP.ticketContext t) "Ticket without 'context'"
ctx <- parseTicketContext uCtx
author <- parseTicketAuthor $ ObjURI hTicket (AP.ticketAttributedTo t)
return (Right (u, AP.ticketParticipants tl), ctx, author)
childCtx' <- bifor childCtx pure $ \ u -> do
obj <- withExceptT T.pack $ AP.fetchAP manager $ Left u
unless (objId obj == u) $
throwE "Project 'id' differs from the URI we fetched"
u' <-
case (objContext obj, objInbox obj) of
(Just c, Nothing) -> do
hl <- hostIsLocal $ objUriAuthority c
when hl $ throwE "Child remote context has a local context"
pure c
(Nothing, Just _) -> pure u
_ -> throwE "Umm context-inbox thing"
return
(u', objUriAuthority u, objFollowers obj, objTeam obj)
return (talid, patch, parentLtid, parentCtx', childId, childCtx', childAuthor)
mhttp <- lift $ runSiteDB $ do
mractid <- insertToInbox now author body (personInbox personRecip) luOffer True
for mractid $ \ ractid -> do
mremotesHttpFwd <- for msig $ \ sig -> do
relevantFollowers <- askRelevantFollowers
let sieve =
makeRecipientSet [] $ catMaybes
[ relevantFollowers shrRecip parent
, relevantFollowers shrRecip child
]
remoteRecips <-
insertRemoteActivityToLocalInboxes
False ractid $
localRecipSieve'
sieve False False localRecips
(sig,) <$> deliverRemoteDB_S (actbBL body) ractid (personIdent personRecip) sig remoteRecips
mremotesHttpAccept <- for relevantParent $ \ ticketData@(_, _, parentLtid, _, childId, _, _) -> do
obiidAccept <- insertEmptyOutboxItem (personOutbox personRecip) now
tdid <- insertDep ractid parentLtid childId obiidAccept
(docAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept) <-
insertAccept luOffer obiidAccept tdid ticketData
knownRemoteRecipsAccept <-
deliverLocal'
False
(LocalActorSharer shrRecip)
(personInbox personRecip)
obiidAccept
localRecipsAccept
(obiidAccept,docAccept,fwdHostsAccept,) <$> deliverRemoteDB'' fwdHostsAccept obiidAccept remoteRecipsAccept knownRemoteRecipsAccept
return (mremotesHttpFwd, mremotesHttpAccept)
case mhttp of
Nothing -> return "I already have this activity in my inbox, doing nothing"
Just (mremotesHttpFwd, mremotesHttpAccept) -> do
for_ mremotesHttpFwd $ \ (sig, remotes) ->
forkWorker "sharerOfferDepF inbox-forwarding" $
deliverRemoteHTTP_S now shrRecip (actbBL body) sig remotes
for_ mremotesHttpAccept $ \ (obiid, doc, fwdHosts, remotes) ->
forkWorker "sharerOfferDepF Accept HTTP delivery" $
deliverRemoteHttp' fwdHosts obiid doc remotes
return $
case (mremotesHttpAccept, mremotesHttpFwd) of
(Nothing, Nothing) -> "Parent not mine, just stored in inbox and no inbox-forwarding to do"
(Nothing, Just _) -> "Parent not mine, just stored in inbox and ran inbox-forwarding"
(Just _, Nothing) -> "Accepted new ticket dep, no inbox-forwarding to do"
(Just _, Just _) -> "Accepted new ticket dep and ran inbox-forwarding of the Offer"
where
checkDepAndTarget
(AP.TicketDependency id_ uParent uChild _attrib published updated) uTarget = do
verifyNothingE id_ "Dep with 'id'"
parent <- parseWorkItem "Dep parent" uParent
child <- parseWorkItem "Dep child" uChild
when (parent == child) $
throwE "Parent and child are the same work item"
verifyNothingE published "Dep with 'published'"
verifyNothingE updated "Dep with 'updated'"
target <- parseTarget uTarget
checkParentAndTarget parent target
return (parent, child)
where
parseWorkItem name u@(ObjURI h lu) = do
hl <- hostIsLocal h
if hl
then Left <$> do
route <-
fromMaybeE (decodeRouteLocal lu) $
name <> ": Not a valid route"
case route of
SharerTicketR shr talkhid -> do
talid <- decodeKeyHashidE talkhid $ name <> ": Invalid talkhid"
return $ WorkItemSharerTicket shr talid False
SharerPatchR shr talkhid -> do
talid <- decodeKeyHashidE talkhid $ name <> ": Invalid talkhid"
return $ WorkItemSharerTicket shr talid True
ProjectTicketR shr prj ltkhid -> do
ltid <- decodeKeyHashidE ltkhid $ name <> ": Invalid ltkhid"
return $ WorkItemProjectTicket shr prj ltid
RepoPatchR shr rp ltkhid -> do
ltid <- decodeKeyHashidE ltkhid $ name <> ": Invalid ltkhid"
return $ WorkItemRepoPatch shr rp ltid
_ -> throwE $ name <> ": not a work item route"
else return $ Right u
parseTarget u@(ObjURI h lu) = do
hl <- hostIsLocal h
if hl
then Left <$> do
route <-
fromMaybeE
(decodeRouteLocal lu)
"Offer local target isn't a valid route"
fromMaybeE
(parseLocalActor route)
"Offer local target isn't an actor route"
else return $ Right u
checkParentAndTarget (Left wi) (Left la) =
unless (workItemActor wi == la) $
throwE "Parent and target mismatch"
where
workItemActor (WorkItemSharerTicket shr _ _) = LocalActorSharer shr
workItemActor (WorkItemProjectTicket shr prj _) = LocalActorProject shr prj
workItemActor (WorkItemRepoPatch shr rp _) = LocalActorRepo shr rp
checkParentAndTarget (Left _) (Right _) = throwE "Local parent but remote target"
checkParentAndTarget (Right _) (Left _) = throwE "Local target but remote parent"
checkParentAndTarget (Right _) (Right _) = return ()
parentRelevance shr (Left (WorkItemSharerTicket shr' talid patch))
| shr == shr' = Just (talid, patch)
parentRelevance _ _ = Nothing
{-
getWorkItem
:: MonadIO m
=> Text
-> WorkItem
-> ExceptT Text (ReaderT SqlBaclend m)
( LocalTicketId
, Either
(Either (ShrIdent, PrjIdent) (ShrIdent, RpIdent))
(Instance, RemoteObject)
, Either ShrIdent (Instance, RemoteObject)
)
-}
getWorkItem name (WorkItemSharerTicket shr talid False) = do
(_, Entity ltid _, _, context) <- do
mticket <- lift $ getSharerTicket shr talid
fromMaybeE mticket $ name <> ": No such sharer-ticket"
context' <-
lift $
bitraverse
(\ (_, Entity _ tpl) -> do
j <- getJust $ ticketProjectLocalProject tpl
s <- getJust $ projectSharer j
return $ Left (sharerIdent s, projectIdent j)
)
(\ (Entity _ tcr, _) -> do
roid <-
case ticketProjectRemoteProject tcr of
Nothing ->
remoteActorIdent <$>
getJust (ticketProjectRemoteTracker tcr)
Just roid -> return roid
ro <- getJust roid
i <- getJust $ remoteObjectInstance ro
return (i, ro)
)
context
return (ltid, context', Left shr)
getWorkItem name (WorkItemSharerTicket shr talid True) = do
(_, Entity ltid _, _, context, _) <- do
mticket <- lift $ getSharerPatch shr talid
fromMaybeE mticket $ name <> ": No such sharer-patch"
context' <-
lift $
bitraverse
(\ (_, Entity _ trl) -> do
r <- getJust $ ticketRepoLocalRepo trl
s <- getJust $ repoSharer r
return $ Right (sharerIdent s, repoIdent r)
)
(\ (Entity _ tcr, _) -> do
roid <-
case ticketProjectRemoteProject tcr of
Nothing ->
remoteActorIdent <$>
getJust (ticketProjectRemoteTracker tcr)
Just roid -> return roid
ro <- getJust roid
i <- getJust $ remoteObjectInstance ro
return (i, ro)
)
context
return (ltid, context', Left shr)
getWorkItem name (WorkItemProjectTicket shr prj ltid) = do
mticket <- lift $ getProjectTicket shr prj ltid
(Entity _ s, Entity _ j, _, _, _, _, author) <-
fromMaybeE mticket $ name <> ": No such project-ticket"
author' <-
lift $
bitraverse
(\ (Entity _ tal, _) -> do
p <- getJust $ ticketAuthorLocalAuthor tal
sharerIdent <$> getJust (personIdent p)
)
(\ (Entity _ tar) -> do
ra <- getJust $ ticketAuthorRemoteAuthor tar
ro <- getJust $ remoteActorIdent ra
i <- getJust $ remoteObjectInstance ro
return (i, ro)
)
author
return (ltid, Left $ Left (sharerIdent s, projectIdent j), author')
getWorkItem name (WorkItemRepoPatch shr rp ltid) = do
mticket <- lift $ getRepoPatch shr rp ltid
(Entity _ s, Entity _ r, _, _, _, _, author, _) <-
fromMaybeE mticket $ name <> ": No such repo-patch"
author' <-
lift $
bitraverse
(\ (Entity _ tal, _) -> do
p <- getJust $ ticketAuthorLocalAuthor tal
sharerIdent <$> getJust (personIdent p)
)
(\ (Entity _ tar) -> do
ra <- getJust $ ticketAuthorRemoteAuthor tar
ro <- getJust $ remoteActorIdent ra
i <- getJust $ remoteObjectInstance ro
return (i, ro)
)
author
return (ltid, Left $ Right (sharerIdent s, repoIdent r), author')
mkuri (i, ro) = ObjURI (instanceHost i) (remoteObjectIdent ro)
parseTicketContext u@(ObjURI h lu) = do
hl <- hostIsLocal h
if hl
then Left <$> do
route <- fromMaybeE (decodeRouteLocal lu) "Not a route"
case route of
ProjectR shr prj -> return $ Left (shr, prj)
RepoR shr rp -> return $ Right (shr, rp)
_ -> throwE "Not a ticket context route"
else return $ Right u
parseTicketAuthor u@(ObjURI h lu) = do
hl <- hostIsLocal h
if hl
then Left <$> do
route <- fromMaybeE (decodeRouteLocal lu) "Not a route"
case route of
SharerR shr -> return shr
_ -> throwE "Not a ticket author route"
else return $ Right u
askRelevantFollowers = do
hashTALID <- getEncodeKeyHashid
return $ \ shr wi -> followers hashTALID <$> parentRelevance shr wi
where
followers hashTALID (talid, patch) =
let coll =
if patch
then LocalPersonCollectionSharerPatchFollowers
else LocalPersonCollectionSharerTicketFollowers
in coll shrRecip (hashTALID talid)
insertDep ractidOffer ltidParent child obiidAccept = do
tdid <- insert LocalTicketDependency
{ localTicketDependencyParent = ltidParent
, localTicketDependencyCreated = now
, localTicketDependencyAccept = obiidAccept
}
case child of
Left (_wi, ltid) -> insert_ TicketDependencyChildLocal
{ ticketDependencyChildLocalDep = tdid
, ticketDependencyChildLocalChild = ltid
}
Right (ObjURI h lu, _luFollowers) -> do
iid <- either entityKey id <$> insertBy' (Instance h)
roid <- either entityKey id <$> insertBy' (RemoteObject iid lu)
insert_ TicketDependencyChildRemote
{ ticketDependencyChildRemoteDep = tdid
, ticketDependencyChildRemoteChild = roid
}
insert_ TicketDependencyAuthorRemote
{ ticketDependencyAuthorRemoteDep = tdid
, ticketDependencyAuthorRemoteAuthor = remoteAuthorId author
, ticketDependencyAuthorRemoteOpen = ractidOffer
}
return tdid
insertAccept luOffer obiidAccept tdid (talid, patch, _, parentCtx, childId, childCtx, childAuthor) = do
encodeRouteLocal <- getEncodeRouteLocal
encodeRouteHome <- getEncodeRouteHome
followers <- askFollowers
workItemFollowers <- askWorkItemFollowers
hLocal <- asksSite siteInstanceHost
obikhidAccept <- encodeKeyHashid obiidAccept
tdkhid <- encodeKeyHashid tdid
ra <- getJust $ remoteAuthorId author
let ObjURI hAuthor luAuthor = remoteAuthorURI author
audAuthor =
AudRemote hAuthor [luAuthor] (maybeToList $ remoteActorFollowers ra)
audParentContext = contextAudience parentCtx
audChildContext = contextAudience childCtx
audParent = AudLocal [LocalActorSharer shrRecip] [followers talid patch]
audChildAuthor =
case childAuthor of
Left shr -> AudLocal [LocalActorSharer shr] []
Right (ObjURI h lu) -> AudRemote h [lu] []
audChildFollowers =
case childId of
Left (wi, _ltid) -> AudLocal [] [workItemFollowers wi]
Right (ObjURI h _, luFollowers) -> AudRemote h [] [luFollowers]
(recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
collectAudience $
audAuthor :
audParent :
audChildAuthor :
audChildFollowers :
audParentContext ++ audChildContext
recips = map encodeRouteHome audLocal ++ audRemote
doc = Doc hLocal Activity
{ activityId =
Just $ encodeRouteLocal $
SharerOutboxItemR shrRecip obikhidAccept
, activityActor = encodeRouteLocal $ SharerR shrRecip
, activitySummary = Nothing
, activityAudience = Audience recips [] [] [] [] []
, activitySpecific = AcceptActivity Accept
{ acceptObject = ObjURI hAuthor luOffer
, acceptResult =
Just $ encodeRouteLocal $ TicketDepR tdkhid
}
}
update obiidAccept [OutboxItemActivity =. persistJSONObjectFromDoc doc]
return (doc, recipientSet, remoteActors, fwdHosts)
where
contextAudience ctx =
case ctx of
Left (Left (shr, prj)) ->
pure $ AudLocal
[LocalActorProject shr prj]
[ LocalPersonCollectionProjectTeam shr prj
, LocalPersonCollectionProjectFollowers shr prj
]
Left (Right (shr, rp)) ->
pure $ AudLocal
[LocalActorRepo shr rp]
[ LocalPersonCollectionRepoTeam shr rp
, LocalPersonCollectionRepoFollowers shr rp
]
Right (ObjURI hTracker luTracker, hProject, luFollowers, luTeam) ->
[ AudRemote hTracker [luTracker] []
, AudRemote hProject [] (catMaybes [luFollowers, luTeam])
]
askFollowers = do
hashTALID <- getEncodeKeyHashid
return $ \ talid patch ->
let coll =
if patch
then LocalPersonCollectionSharerPatchFollowers
else LocalPersonCollectionSharerTicketFollowers
in coll shrRecip (hashTALID talid)
askWorkItemFollowers = do
hashTALID <- getEncodeKeyHashid
hashLTID <- getEncodeKeyHashid
let workItemFollowers (WorkItemSharerTicket shr talid False) = LocalPersonCollectionSharerTicketFollowers shr $ hashTALID talid
workItemFollowers (WorkItemSharerTicket shr talid True) = LocalPersonCollectionSharerPatchFollowers shr $ hashTALID talid
workItemFollowers (WorkItemProjectTicket shr prj ltid) = LocalPersonCollectionProjectTicketFollowers shr prj $ hashLTID ltid
workItemFollowers (WorkItemRepoPatch shr rp ltid) = LocalPersonCollectionRepoPatchFollowers shr rp $ hashLTID ltid
return workItemFollowers

62
src/Vervis/Federation/Util.hs Normal file
View file

@ -0,0 +1,62 @@
{- This file is part of Vervis.
-
- Written in 2019, 2020 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.Federation.Util
( insertToInbox
)
where
import Control.Monad.IO.Class
import Control.Monad.Trans.Reader
import Data.Either
import Data.Time.Clock
import Database.Persist
import Database.Persist.Sql
import Database.Persist.JSON
import Network.FedURI
import Database.Persist.Local
import Vervis.Federation.Auth
import Vervis.Foundation
import Vervis.Model
-- | Insert a remote activity delivered to us into our inbox. Return its
-- database ID if the activity wasn't already in our inbox.
insertToInbox
:: MonadIO m
=> UTCTime
-> RemoteAuthor
-> ActivityBody
-> InboxId
-> LocalURI
-> Bool
-> ReaderT SqlBackend m (Maybe RemoteActivityId)
insertToInbox now author body ibid luAct unread = do
let iidAuthor = remoteAuthorInstance author
roid <-
either entityKey id <$> insertBy' (RemoteObject iidAuthor luAct)
ractid <- either entityKey id <$> insertBy' RemoteActivity
{ remoteActivityIdent = roid
, remoteActivityContent = persistJSONFromBL $ actbBL body
, remoteActivityReceived = now
}
ibiid <- insert $ InboxItem unread
new <- isRight <$> insertBy' (InboxItemRemote ibid ractid ibiid)
return $
if new
then Just ractid
else Nothing

6
src/Vervis/Field/Ticket.hs
View file

@ -15,7 +15,7 @@
module Vervis.Field.Ticket module Vervis.Field.Ticket
( selectAssigneeFromProject ( selectAssigneeFromProject
, selectTicketDep --, selectTicketDep
) )
where where
@ -33,7 +33,7 @@ import qualified Database.Persist as P
import Database.Persist.Sql.Graph.Connects (uconnects) import Database.Persist.Sql.Graph.Connects (uconnects)
import Vervis.Foundation (Handler) import Vervis.Foundation (Handler)
import Vervis.GraphProxy (ticketDepGraph) --import Vervis.GraphProxy (ticketDepGraph)
import Vervis.Model import Vervis.Model
import Vervis.Model.Ident (shr2text) import Vervis.Model.Ident (shr2text)
@ -52,6 +52,7 @@ selectAssigneeFromProject pid jid = selectField $ do
return (sharer ^. SharerIdent, person ^. PersonId) return (sharer ^. SharerIdent, person ^. PersonId)
optionsPairs $ map (shr2text . unValue *** unValue) l optionsPairs $ map (shr2text . unValue *** unValue) l
{-
checkNotSelf :: TicketId -> Field Handler TicketId -> Field Handler TicketId checkNotSelf :: TicketId -> Field Handler TicketId -> Field Handler TicketId
checkNotSelf tidP = checkNotSelf tidP =
checkBool (/= tidP) ("A ticket can’t depend on itself" :: Text) checkBool (/= tidP) ("A ticket can’t depend on itself" :: Text)
@ -80,3 +81,4 @@ selectTicketDep jid tid =
orderBy [asc $ t ^. TicketId] orderBy [asc $ t ^. TicketId]
return (t ^. TicketTitle, t ^. TicketId) return (t ^. TicketTitle, t ^. TicketId)
optionsPairs $ map (bimap unValue unValue) ts optionsPairs $ map (bimap unValue unValue) ts
-}

4
src/Vervis/Form/Ticket.hs
View file

@ -20,7 +20,7 @@ module Vervis.Form.Ticket
, assignTicketForm , assignTicketForm
, claimRequestForm , claimRequestForm
, ticketFilterForm , ticketFilterForm
, ticketDepForm --, ticketDepForm
) )
where where
@ -273,8 +273,10 @@ ticketFilterAForm = mk
ticketFilterForm :: Form TicketFilter ticketFilterForm :: Form TicketFilter
ticketFilterForm = renderDivs ticketFilterAForm ticketFilterForm = renderDivs ticketFilterAForm
{-
ticketDepAForm :: ProjectId -> TicketId -> AForm Handler TicketId ticketDepAForm :: ProjectId -> TicketId -> AForm Handler TicketId
ticketDepAForm jid tid = areq (selectTicketDep jid tid) "Dependency" Nothing ticketDepAForm jid tid = areq (selectTicketDep jid tid) "Dependency" Nothing
ticketDepForm :: ProjectId -> TicketId -> Form TicketId ticketDepForm :: ProjectId -> TicketId -> Form TicketId
ticketDepForm jid tid = renderDivs $ ticketDepAForm jid tid ticketDepForm jid tid = renderDivs $ ticketDepAForm jid tid
-}

2
src/Vervis/Foundation.hs
View file

@ -130,7 +130,7 @@ type MessageKeyHashid = KeyHashid Message
type LocalMessageKeyHashid = KeyHashid LocalMessage type LocalMessageKeyHashid = KeyHashid LocalMessage
type LocalTicketKeyHashid = KeyHashid LocalTicket type LocalTicketKeyHashid = KeyHashid LocalTicket
type TicketAuthorLocalKeyHashid = KeyHashid TicketAuthorLocal type TicketAuthorLocalKeyHashid = KeyHashid TicketAuthorLocal
type TicketDepKeyHashid = KeyHashid TicketDependency type TicketDepKeyHashid = KeyHashid LocalTicketDependency
type PatchKeyHashid = KeyHashid Patch type PatchKeyHashid = KeyHashid Patch
-- This is where we define all of the routes in our application. For a full -- This is where we define all of the routes in our application. For a full

6
src/Vervis/GraphProxy.hs
View file

@ -29,7 +29,7 @@
-- proxy type directly each time, which may be long and cumbersome. -- proxy type directly each time, which may be long and cumbersome.
module Vervis.GraphProxy module Vervis.GraphProxy
( GraphProxy ( GraphProxy
, ticketDepGraph --, ticketDepGraph
) )
where where
@ -39,5 +39,5 @@ import Vervis.Model
type GraphProxy n e = Proxy (n, e) type GraphProxy n e = Proxy (n, e)
ticketDepGraph :: GraphProxy Ticket TicketDependency --ticketDepGraph :: GraphProxy Ticket TicketDependency
ticketDepGraph = Proxy --ticketDepGraph = Proxy

11
src/Vervis/Handler/Client.hs
View file

@ -401,10 +401,7 @@ postPublishR = do
, ticketIsResolved = False , ticketIsResolved = False
, ticketAttachment = Nothing , ticketAttachment = Nothing
} }
offer = Offer target = encodeRouteFed h $ ProjectR shr prj
{ offerObject = ticketAP
, offerTarget = encodeRouteFed h $ ProjectR shr prj
}
audience = Audience audience = Audience
{ audienceTo = { audienceTo =
map (encodeRouteFed h) $ recipsA ++ recipsC map (encodeRouteFed h) $ recipsA ++ recipsC
@ -414,7 +411,7 @@ postPublishR = do
, audienceGeneral = [] , audienceGeneral = []
, audienceNonActors = map (encodeRouteFed h) recipsC , audienceNonActors = map (encodeRouteFed h) recipsC
} }
ExceptT $ offerTicketC shrAuthor summary audience offer ExceptT $ offerTicketC shrAuthor summary audience ticketAP target
follow shrAuthor (uObject@(ObjURI hObject luObject), uRecip) = do follow shrAuthor (uObject@(ObjURI hObject luObject), uRecip) = do
(summary, audience, followAP) <- (summary, audience, followAP) <-
C.follow shrAuthor uObject uRecip False C.follow shrAuthor uObject uRecip False
@ -741,9 +738,9 @@ postProjectTicketsR shr prj = do
-} -}
if offer if offer
then Right <$> do then Right <$> do
(summary, audience, offer) <- (summary, audience, ticket, target) <-
ExceptT $ offerTicket shrAuthor (TextHtml title) (TextPandocMarkdown desc) shr prj ExceptT $ offerTicket shrAuthor (TextHtml title) (TextPandocMarkdown desc) shr prj
obiid <- ExceptT $ offerTicketC shrAuthor summary audience offer obiid <- ExceptT $ offerTicketC shrAuthor summary audience ticket target
ExceptT $ runDB $ do ExceptT $ runDB $ do
mtal <- getValBy $ UniqueTicketAuthorLocalOpen obiid mtal <- getValBy $ UniqueTicketAuthorLocalOpen obiid
return $ return $

77
src/Vervis/Handler/Inbox.hs
View file

@ -80,6 +80,7 @@ import Yesod.ActivityPub
import Yesod.Auth.Unverified import Yesod.Auth.Unverified
import Yesod.FedURI import Yesod.FedURI
import Yesod.Hashids import Yesod.Hashids
import Yesod.MonadSite
import Yesod.RenderSource import Yesod.RenderSource
import Data.Aeson.Local import Data.Aeson.Local
@ -267,65 +268,69 @@ getRepoInboxR shr rp = getInbox here getInboxId
r <- getValBy404 $ UniqueRepo rp sid r <- getValBy404 $ UniqueRepo rp sid
return $ repoInbox r return $ repoInbox r
postSharerInboxR :: ShrIdent -> Handler () recordActivity
postSharerInboxR shrRecip = do :: (MonadSite m, SiteEnv m ~ App)
federation <- getsYesod $ appFederation . appSettings => UTCTime -> Either Text (Object, (Text, w)) -> [ContentType] -> m ()
unless federation badMethod
contentTypes <- lookupHeaders "Content-Type"
now <- liftIO getCurrentTime
result <- runExceptT $ do
(auth, body) <- authenticateActivity now
(actbObject body,) <$> handleSharerInbox now shrRecip auth body
recordActivity now result contentTypes
case result of
Left err -> do
logDebug err
sendResponseStatus badRequest400 err
Right _ -> return ()
recordActivity now result contentTypes = do recordActivity now result contentTypes = do
macts <- getsYesod appActivities macts <- asksSite appActivities
for_ macts $ \ (size, acts) -> for_ macts $ \ (size, acts) ->
liftIO $ atomically $ modifyTVar' acts $ \ vec -> liftIO $ atomically $ modifyTVar' acts $ \ vec ->
let (msg, body) = let (msg, body) =
case result of case result of
Left t -> (t, "{?}") Left t -> (t, "{?}")
Right (o, t) -> (t, encodePretty o) Right (o, (t, _)) -> (t, encodePretty o)
item = ActivityReport now msg contentTypes body item = ActivityReport now msg contentTypes body
vec' = item `V.cons` vec vec' = item `V.cons` vec
in if V.length vec' > size in if V.length vec' > size
then V.init vec' then V.init vec'
else vec' else vec'
postProjectInboxR :: ShrIdent -> PrjIdent -> Handler () handleInbox
postProjectInboxR shrRecip prjRecip = do :: ( UTCTime
-> ActivityAuthentication
-> ActivityBody
-> ExceptT Text Handler
( Text
, Maybe (ExceptT Text Worker Text)
)
)
-> Handler ()
handleInbox handler = do
federation <- getsYesod $ appFederation . appSettings federation <- getsYesod $ appFederation . appSettings
unless federation badMethod unless federation badMethod
contentTypes <- lookupHeaders "Content-Type" contentTypes <- lookupHeaders "Content-Type"
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
result <- runExceptT $ do result <- runExceptT $ do
(auth, body) <- authenticateActivity now (auth, body) <- authenticateActivity now
(actbObject body,) <$> (actbObject body,) <$> handler now auth body
handleProjectInbox now shrRecip prjRecip auth body
recordActivity now result contentTypes recordActivity now result contentTypes
case result of case result of
Left _ -> sendResponseStatus badRequest400 () Left err -> do
logDebug err
sendResponseStatus badRequest400 err
Right (obj, (_, mworker)) ->
for_ mworker $ \ worker -> forkWorker "handleInbox worker" $ do
wait <- asyncWorker $ runExceptT worker
result' <- wait
let result'' =
case result' of
Left e -> Left $ T.pack $ displayException e
Right (Left e) -> Left e
Right (Right t) -> Right (obj, (t, Nothing))
now' <- liftIO getCurrentTime
recordActivity now' result'' contentTypes
case result'' of
Left err -> logDebug err
Right _ -> return () Right _ -> return ()
postSharerInboxR :: ShrIdent -> Handler ()
postSharerInboxR shrRecip = handleInbox $ handleSharerInbox shrRecip
postProjectInboxR :: ShrIdent -> PrjIdent -> Handler ()
postProjectInboxR shr prj = handleInbox $ handleProjectInbox shr prj
postRepoInboxR :: ShrIdent -> RpIdent -> Handler () postRepoInboxR :: ShrIdent -> RpIdent -> Handler ()
postRepoInboxR shrRecip rpRecip = do postRepoInboxR shr rp = handleInbox $ handleRepoInbox shr rp
federation <- getsYesod $ appFederation . appSettings
unless federation badMethod
contentTypes <- lookupHeaders "Content-Type"
now <- liftIO getCurrentTime
result <- runExceptT $ do
(auth, body) <- authenticateActivity now
(actbObject body,) <$>
handleRepoInbox now shrRecip rpRecip auth body
recordActivity now result contentTypes
case result of
Left _ -> sendResponseStatus badRequest400 ()
Right _ -> return ()
{- {-
jsonField :: (FromJSON a, ToJSON a) => Field Handler a jsonField :: (FromJSON a, ToJSON a) => Field Handler a

62
src/Vervis/Handler/Patch.hs
View file

@ -206,26 +206,25 @@ getSharerPatchDiscussionR shr talkhid =
(_, Entity _ lt, _, _, _) <- getSharerPatch404 shr talkhid (_, Entity _ lt, _, _, _) <- getSharerPatch404 shr talkhid
return $ localTicketDiscuss lt return $ localTicketDiscuss lt
getSharerPatchDeps
:: Bool -> ShrIdent -> KeyHashid TicketAuthorLocal -> Handler TypedContent
getSharerPatchDeps forward shr talkhid =
getDependencyCollection here getTicketId404 forward
where
here =
let route =
if forward then SharerPatchDepsR else SharerPatchReverseDepsR
in route shr talkhid
getTicketId404 = do
(_, _, Entity tid _, _, _) <- getSharerPatch404 shr talkhid
return tid
getSharerPatchDepsR getSharerPatchDepsR
:: ShrIdent -> KeyHashid TicketAuthorLocal -> Handler TypedContent :: ShrIdent -> KeyHashid TicketAuthorLocal -> Handler TypedContent
getSharerPatchDepsR = getSharerPatchDeps True getSharerPatchDepsR shr talkhid =
getDependencyCollection here getTicket404
where
here = SharerPatchDepsR shr talkhid
getTicket404 = do
(_, Entity ltid _, _, _, _) <- getSharerPatch404 shr talkhid
return ltid
getSharerPatchReverseDepsR getSharerPatchReverseDepsR
:: ShrIdent -> KeyHashid TicketAuthorLocal -> Handler TypedContent :: ShrIdent -> KeyHashid TicketAuthorLocal -> Handler TypedContent
getSharerPatchReverseDepsR = getSharerPatchDeps False getSharerPatchReverseDepsR shr talkhid =
getReverseDependencyCollection here getTicket404
where
here = SharerPatchDepsR shr talkhid
getTicket404 = do
(_, Entity ltid _, _, _, _) <- getSharerPatch404 shr talkhid
return ltid
getSharerPatchFollowersR getSharerPatchFollowersR
:: ShrIdent -> KeyHashid TicketAuthorLocal -> Handler TypedContent :: ShrIdent -> KeyHashid TicketAuthorLocal -> Handler TypedContent
@ -469,30 +468,25 @@ getRepoPatchDiscussionR shr rp ltkhid =
(_, _, _, Entity _ lt, _, _, _, _) <- getRepoPatch404 shr rp ltkhid (_, _, _, Entity _ lt, _, _, _, _) <- getRepoPatch404 shr rp ltkhid
return $ localTicketDiscuss lt return $ localTicketDiscuss lt
getRepoPatchDeps
:: Bool
-> ShrIdent
-> RpIdent
-> KeyHashid LocalTicket
-> Handler TypedContent
getRepoPatchDeps forward shr rp ltkhid =
getDependencyCollection here getTicketId404 forward
where
here =
let route =
if forward then RepoPatchDepsR else RepoPatchReverseDepsR
in route shr rp ltkhid
getTicketId404 = do
(_, _, Entity tid _, _, _, _, _, _) <- getRepoPatch404 shr rp ltkhid
return tid
getRepoPatchDepsR getRepoPatchDepsR
:: ShrIdent -> RpIdent -> KeyHashid LocalTicket -> Handler TypedContent :: ShrIdent -> RpIdent -> KeyHashid LocalTicket -> Handler TypedContent
getRepoPatchDepsR = getRepoPatchDeps True getRepoPatchDepsR shr rp ltkhid =
getDependencyCollection here getTicketId404
where
here = RepoPatchDepsR shr rp ltkhid
getTicketId404 = do
(_, _, _, Entity ltid _, _, _, _, _) <- getRepoPatch404 shr rp ltkhid
return ltid
getRepoPatchReverseDepsR getRepoPatchReverseDepsR
:: ShrIdent -> RpIdent -> KeyHashid LocalTicket -> Handler TypedContent :: ShrIdent -> RpIdent -> KeyHashid LocalTicket -> Handler TypedContent
getRepoPatchReverseDepsR = getRepoPatchDeps False getRepoPatchReverseDepsR shr rp ltkhid =
getReverseDependencyCollection here getTicketId404
where
here = RepoPatchReverseDepsR shr rp ltkhid
getTicketId404 = do
(_, _, _, Entity ltid _, _, _, _, _) <- getRepoPatch404 shr rp ltkhid
return ltid
getRepoPatchFollowersR getRepoPatchFollowersR
:: ShrIdent -> RpIdent -> KeyHashid LocalTicket -> Handler TypedContent :: ShrIdent -> RpIdent -> KeyHashid LocalTicket -> Handler TypedContent

273
src/Vervis/Handler/Ticket.hs
View file

@ -129,7 +129,7 @@ import Vervis.FedURI
import Vervis.Form.Ticket import Vervis.Form.Ticket
import Vervis.Foundation import Vervis.Foundation
import Vervis.Handler.Discussion import Vervis.Handler.Discussion
import Vervis.GraphProxy (ticketDepGraph) --import Vervis.GraphProxy (ticketDepGraph)
import Vervis.Model import Vervis.Model
import Vervis.Model.Ident import Vervis.Model.Ident
import Vervis.Model.Ticket import Vervis.Model.Ticket
@ -276,13 +276,15 @@ getProjectTicketsR shr prj = selectRep $ do
ticketRoute _ _ _ (Right (E.Value h, E.Value lu)) = ObjURI h lu ticketRoute _ _ _ (Right (E.Value h, E.Value lu)) = ObjURI h lu
getProjectTicketTreeR :: ShrIdent -> PrjIdent -> Handler Html getProjectTicketTreeR :: ShrIdent -> PrjIdent -> Handler Html
getProjectTicketTreeR shr prj = do getProjectTicketTreeR _shr _prj = error "Ticket tree view disabled for now"
{-
(summaries, deps) <- runDB $ do (summaries, deps) <- runDB $ do
Entity sid _ <- getBy404 $ UniqueSharer shr Entity sid _ <- getBy404 $ UniqueSharer shr
Entity jid _ <- getBy404 $ UniqueProject prj sid Entity jid _ <- getBy404 $ UniqueProject prj sid
(,) <$> getTicketSummaries Nothing Nothing Nothing jid (,) <$> getTicketSummaries Nothing Nothing Nothing jid
<*> getTicketDepEdges jid <*> getTicketDepEdges jid
defaultLayout $ ticketTreeDW shr prj summaries deps defaultLayout $ ticketTreeDW shr prj summaries deps
-}
getProjectTicketNewR :: ShrIdent -> PrjIdent -> Handler Html getProjectTicketNewR :: ShrIdent -> PrjIdent -> Handler Html
getProjectTicketNewR shr prj = do getProjectTicketNewR shr prj = do
@ -297,8 +299,7 @@ getProjectTicketR :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler Ty
getProjectTicketR shar proj ltkhid = do getProjectTicketR shar proj ltkhid = do
mpid <- maybeAuthId mpid <- maybeAuthId
( wshr, wfl, ( wshr, wfl,
author, massignee, mcloser, ticket, lticket, tparams, eparams, cparams, author, massignee, mcloser, ticket, lticket, tparams, eparams, cparams) <-
deps, rdeps) <-
runDB $ do runDB $ do
(Entity sid sharer, Entity jid project, Entity tid ticket, Entity _ lticket, _etcl, _etpl, author) <- getProjectTicket404 shar proj ltkhid (Entity sid sharer, Entity jid project, Entity tid ticket, Entity _ lticket, _etcl, _etpl, author) <- getProjectTicket404 shar proj ltkhid
(wshr, wid, wfl) <- do (wshr, wid, wfl) <- do
@ -341,21 +342,10 @@ getProjectTicketR shar proj ltkhid = do
tparams <- getTicketTextParams tid wid tparams <- getTicketTextParams tid wid
eparams <- getTicketEnumParams tid wid eparams <- getTicketEnumParams tid wid
cparams <- getTicketClasses tid wid cparams <- getTicketClasses tid wid
deps <- E.select $ E.from $ \ (dep `E.InnerJoin` t `E.InnerJoin` lt) -> do
E.on $ t E.^. TicketId E.==. lt E.^. LocalTicketTicket
E.on $ dep E.^. TicketDependencyChild E.==. t E.^. TicketId
E.where_ $ dep E.^. TicketDependencyParent E.==. E.val tid
return (lt E.^. LocalTicketId, t)
rdeps <- E.select $ E.from $ \ (dep `E.InnerJoin` t `E.InnerJoin` lt) -> do
E.on $ t E.^. TicketId E.==. lt E.^. LocalTicketTicket
E.on $ dep E.^. TicketDependencyParent E.==. t E.^. TicketId
E.where_ $ dep E.^. TicketDependencyChild E.==. E.val tid
return (lt E.^. LocalTicketId, t)
return return
( wshr, wfl ( wshr, wfl
, author', massignee, mcloser, ticket, lticket , author', massignee, mcloser, ticket, lticket
, tparams, eparams, cparams , tparams, eparams, cparams
, deps, rdeps
) )
encodeHid <- getEncodeKeyHashid encodeHid <- getEncodeKeyHashid
let desc :: Widget let desc :: Widget
@ -871,94 +861,20 @@ getProjectTicketReplyR shr prj ltkhid mkhid = do
(selectDiscussionId shr prj ltkhid) (selectDiscussionId shr prj ltkhid)
mid mid
getTicketDeps
:: Bool -> ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler TypedContent
getTicketDeps forward shr prj ltkhid = do
(deps, rows) <- unzip <$> runDB getDepsFromDB
depsAP <- makeDepsCollection deps
encodeHid <- getEncodeKeyHashid
provideHtmlAndAP depsAP $(widgetFile "ticket/dep/list")
where
getDepsFromDB = do
let from' =
if forward then TicketDependencyParent else TicketDependencyChild
to' =
if forward then TicketDependencyChild else TicketDependencyParent
(_es, _ej, Entity tid _, _elt, _etcl, _etpl, _author) <- getProjectTicket404 shr prj ltkhid
fmap (map toRow) $ E.select $ E.from $
\ ( td
`E.InnerJoin` t
`E.InnerJoin` lt
`E.InnerJoin` tcl
`E.InnerJoin` tpl
`E.LeftOuterJoin` (tal `E.InnerJoin` p `E.InnerJoin` s)
`E.LeftOuterJoin` (tar `E.InnerJoin` ra `E.InnerJoin` ro `E.InnerJoin` i)
) -> do
E.on $ ro E.?. RemoteObjectInstance E.==. i E.?. InstanceId
E.on $ ra E.?. RemoteActorIdent E.==. ro E.?. RemoteObjectId
E.on $ tar E.?. TicketAuthorRemoteAuthor E.==. ra E.?. RemoteActorId
E.on $ E.just (tcl E.^. TicketContextLocalId) 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 (lt E.^. LocalTicketId) E.==. tal E.?. TicketAuthorLocalTicket
E.on $ tcl E.^. TicketContextLocalId E.==. tpl E.^. TicketProjectLocalContext
E.on $ t E.^. TicketId E.==. tcl E.^. TicketContextLocalTicket
E.on $ t E.^. TicketId E.==. lt E.^. LocalTicketTicket
E.on $ td E.^. to' E.==. t E.^. TicketId
E.where_ $ td E.^. from' E.==. E.val tid
E.orderBy [E.asc $ t E.^. TicketId]
return
( td E.^. TicketDependencyId
, lt E.^. LocalTicketId
, s
, i
, ro
, ra
, t E.^. TicketTitle
, t E.^. TicketStatus
)
where
toRow (E.Value dep, E.Value ltid, ms, mi, mro, mra, E.Value title, E.Value status) =
( dep
, ( ltid
, case (ms, mi, mro, mra) of
(Just s, Nothing, Nothing, Nothing) ->
Left $ entityVal s
(Nothing, Just i, Just ro, Just ra) ->
Right (entityVal i, entityVal ro, entityVal ra)
_ -> error "Ticket author DB invalid state"
, title
, status
)
)
makeDepsCollection tdids = do
encodeRouteLocal <- getEncodeRouteLocal
encodeRouteHome <- getEncodeRouteHome
encodeKeyHashid <- getEncodeKeyHashid
let here =
let route =
if forward
then ProjectTicketDepsR
else ProjectTicketReverseDepsR
in route shr prj ltkhid
return Collection
{ collectionId = encodeRouteLocal here
, collectionType = CollectionTypeUnordered
, collectionTotalItems = Just $ length tdids
, collectionCurrent = Nothing
, collectionFirst = Nothing
, collectionLast = Nothing
, collectionItems =
map (encodeRouteHome . TicketDepR . encodeKeyHashid) tdids
}
getProjectTicketDepsR getProjectTicketDepsR
:: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler TypedContent :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler TypedContent
getProjectTicketDepsR = getTicketDeps True getProjectTicketDepsR shr prj ltkhid =
getDependencyCollection here getLocalTicketId404
where
here = ProjectTicketDepsR shr prj ltkhid
getLocalTicketId404 = do
(_, _, _, Entity ltid _, _, _, _) <- getProjectTicket404 shr prj ltkhid
return ltid
postProjectTicketDepsR postProjectTicketDepsR
:: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler Html :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler Html
postProjectTicketDepsR shr prj ltkhid = do postProjectTicketDepsR _shr _prj _ltkhid = error "Temporarily disabled"
{-
(_es, Entity jid _, Entity tid _, _elt, _etcl, _etpl, _author) <- runDB $ getProjectTicket404 shr prj ltkhid (_es, Entity jid _, Entity tid _, _elt, _etcl, _etpl, _author) <- runDB $ getProjectTicket404 shr prj ltkhid
((result, widget), enctype) <- runFormPost $ ticketDepForm jid tid ((result, widget), enctype) <- runFormPost $ ticketDepForm jid tid
case result of case result of
@ -969,11 +885,14 @@ postProjectTicketDepsR shr prj ltkhid = do
let td = TicketDependency let td = TicketDependency
{ ticketDependencyParent = tid { ticketDependencyParent = tid
, ticketDependencyChild = ctid , ticketDependencyChild = ctid
, ticketDependencyAuthor = pidAuthor
, ticketDependencySummary = "(A ticket dependency)"
, ticketDependencyCreated = now , ticketDependencyCreated = now
} }
insert_ td tdid <- insert td
insert_ TicketDependencyAuthorLocal
{ ticketDependencyAuthorLocalDep = tdid
, ticketDependencyAuthorLocalAuthor = pidAuthor
, ticketDependencyAuthorLocalOpen = obiidOffer?
}
trrFix td ticketDepGraph trrFix td ticketDepGraph
setMessage "Ticket dependency added." setMessage "Ticket dependency added."
redirect $ ProjectTicketR shr prj ltkhid redirect $ ProjectTicketR shr prj ltkhid
@ -983,13 +902,16 @@ postProjectTicketDepsR shr prj ltkhid = do
FormFailure _l -> do FormFailure _l -> do
setMessage "Submission failed, see errors below." setMessage "Submission failed, see errors below."
defaultLayout $(widgetFile "ticket/dep/new") defaultLayout $(widgetFile "ticket/dep/new")
-}
getProjectTicketDepNewR getProjectTicketDepNewR
:: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler Html :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler Html
getProjectTicketDepNewR shr prj ltkhid = do getProjectTicketDepNewR _shr _prj _ltkhid = error "Currently disabled"
{-
(_es, Entity jid _, Entity tid _, _elt, _etcl, _etpl, _author) <- runDB $ getProjectTicket404 shr prj ltkhid (_es, Entity jid _, Entity tid _, _elt, _etcl, _etpl, _author) <- runDB $ getProjectTicket404 shr prj ltkhid
((_result, widget), enctype) <- runFormPost $ ticketDepForm jid tid ((_result, widget), enctype) <- runFormPost $ ticketDepForm jid tid
defaultLayout $(widgetFile "ticket/dep/new") defaultLayout $(widgetFile "ticket/dep/new")
-}
postTicketDepOldR postTicketDepOldR
:: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> KeyHashid LocalTicket -> Handler Html :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> KeyHashid LocalTicket -> Handler Html
@ -1001,7 +923,8 @@ postTicketDepOldR shr prj pnum cnum = do
deleteTicketDepOldR deleteTicketDepOldR
:: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> KeyHashid LocalTicket -> Handler Html :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> KeyHashid LocalTicket -> Handler Html
deleteTicketDepOldR shr prj pnum cnum = do deleteTicketDepOldR _shr _prj _pnum _cnum = error "Dep deletion disabled for now"
{-
runDB $ do runDB $ do
(_es, Entity jid _, Entity ptid _, _elt, _etcl, _etpl, _author) <- getProjectTicket404 shr prj pnum (_es, Entity jid _, Entity ptid _, _elt, _etcl, _etpl, _author) <- getProjectTicket404 shr prj pnum
@ -1016,69 +939,86 @@ deleteTicketDepOldR shr prj pnum cnum = do
delete tdid delete tdid
setMessage "Ticket dependency removed." setMessage "Ticket dependency removed."
redirect $ ProjectTicketDepsR shr prj pnum redirect $ ProjectTicketDepsR shr prj pnum
-}
getProjectTicketReverseDepsR getProjectTicketReverseDepsR
:: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler TypedContent :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler TypedContent
getProjectTicketReverseDepsR = getTicketDeps False getProjectTicketReverseDepsR shr prj ltkhid =
getReverseDependencyCollection here getLocalTicketId404
where
here = ProjectTicketReverseDepsR shr prj ltkhid
getLocalTicketId404 = do
(_, _, _, Entity ltid _, _, _, _) <- getProjectTicket404 shr prj ltkhid
return ltid
getTicketDepR :: KeyHashid TicketDependency -> Handler TypedContent getTicketDepR :: KeyHashid LocalTicketDependency -> Handler TypedContent
getTicketDepR tdkhid = do getTicketDepR tdkhid = do
tdid <- decodeKeyHashid404 tdkhid
( td,
(sParent, jParent, ltParent),
(sChild, jChild, ltChild),
(sAuthor, pAuthor)
) <- runDB $ do
tdep <- get404 tdid
(,,,) tdep
<$> getTicket (ticketDependencyParent tdep)
<*> getTicket (ticketDependencyChild tdep)
<*> getAuthor (ticketDependencyAuthor tdep)
encodeRouteLocal <- getEncodeRouteLocal encodeRouteLocal <- getEncodeRouteLocal
encodeRouteHome <- getEncodeRouteHome encodeRouteHome <- getEncodeRouteHome
encodeHid <- getEncodeKeyHashid wiRoute <- askWorkItemRoute
let ticketRoute s j lt = hLocal <- asksSite siteInstanceHost
ProjectTicketR (sharerIdent s) (projectIdent j) (encodeHid lt)
here = TicketDepR tdkhid tdid <- decodeKeyHashid404 tdkhid
(td, author, parent, child) <- runDB $ do
td <- get404 tdid
(td,,,)
<$> getAuthor tdid
<*> getWorkItem ( localTicketDependencyParent td)
<*> getChild tdid
let host =
case author of
Left _ -> hLocal
Right (h, _) -> h
tdepAP = AP.TicketDependency tdepAP = AP.TicketDependency
{ ticketDepId = Just $ encodeRouteHome here { ticketDepId = Just $ encodeRouteHome here
, ticketDepParent = , ticketDepParent = encodeRouteHome $ wiRoute parent
encodeRouteHome $ ticketRoute sParent jParent ltParent
, ticketDepChild = , ticketDepChild =
encodeRouteHome $ ticketRoute sChild jChild ltChild case child of
Left wi -> encodeRouteHome $ wiRoute wi
Right (h, lu) -> ObjURI h lu
, ticketDepAttributedTo = , ticketDepAttributedTo =
encodeRouteLocal $ SharerR $ sharerIdent sAuthor case author of
, ticketDepPublished = Just $ ticketDependencyCreated td Left shr -> encodeRouteLocal $ SharerR shr
, ticketDepUpdated = Just $ ticketDependencyCreated td Right (_h, lu) -> lu
, ticketDepSummary = TextHtml $ ticketDependencySummary td , ticketDepPublished = Just $ localTicketDependencyCreated td
, ticketDepUpdated = Nothing
} }
provideHtmlAndAP' host tdepAP $ redirectToPrettyJSON here
provideHtmlAndAP tdepAP $ redirectToPrettyJSON here
where where
getTicket tid = do here = TicketDepR tdkhid
ltid <- do getAuthor tdid = do
mltid <- getKeyBy $ UniqueLocalTicket tid tda <- requireEitherAlt
case mltid of (getValBy $ UniqueTicketDependencyAuthorLocal tdid)
Nothing -> error "No LocalTicket" (getValBy $ UniqueTicketDependencyAuthorRemote tdid)
Just v -> return v "No TDA"
tclid <- do "Both TDAL and TDAR"
mtclid <- getKeyBy $ UniqueTicketContextLocal tid bitraverse
case mtclid of (\ tdal -> do
Nothing -> error "No TicketContextLocal" p <- getJust $ ticketDependencyAuthorLocalAuthor tdal
Just v -> return v
tpl <- do
mtpl <- getValBy $ UniqueTicketProjectLocal tclid
case mtpl of
Nothing -> error "No TicketProjectLocal"
Just v -> return v
j <- getJust $ ticketProjectLocalProject tpl
s <- getJust $ projectSharer j
return (s, j, ltid)
getAuthor pid = do
p <- getJust pid
s <- getJust $ personIdent p s <- getJust $ personIdent p
return (s, p) return $ sharerIdent s
)
(\ tdar -> do
ra <- getJust $ ticketDependencyAuthorRemoteAuthor tdar
ro <- getJust $ remoteActorIdent ra
i <- getJust $ remoteObjectInstance ro
return (instanceHost i, remoteObjectIdent ro)
)
tda
getChild tdid = do
tdc <- requireEitherAlt
(getValBy $ UniqueTicketDependencyChildLocal tdid)
(getValBy $ UniqueTicketDependencyChildRemote tdid)
"No TDC"
"Both TDCL and TDCR"
bitraverse
(getWorkItem . ticketDependencyChildLocalChild)
(\ tdcr -> do
ro <- getJust $ ticketDependencyChildRemoteChild tdcr
i <- getJust $ remoteObjectInstance ro
return (instanceHost i, remoteObjectIdent ro)
)
tdc
getProjectTicketParticipantsR getProjectTicketParticipantsR
:: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler TypedContent :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler TypedContent
@ -1244,26 +1184,25 @@ getSharerTicketDiscussionR shr talkhid =
(_, Entity _ lt, _, _) <- getSharerTicket404 shr talkhid (_, Entity _ lt, _, _) <- getSharerTicket404 shr talkhid
return $ localTicketDiscuss lt return $ localTicketDiscuss lt
getSharerTicketDeps
:: Bool -> ShrIdent -> KeyHashid TicketAuthorLocal -> Handler TypedContent
getSharerTicketDeps forward shr talkhid =
getDependencyCollection here getTicketId404 forward
where
here =
let route =
if forward then SharerTicketDepsR else SharerTicketReverseDepsR
in route shr talkhid
getTicketId404 = do
(_, _, Entity tid _, _) <- getSharerTicket404 shr talkhid
return tid
getSharerTicketDepsR getSharerTicketDepsR
:: ShrIdent -> KeyHashid TicketAuthorLocal -> Handler TypedContent :: ShrIdent -> KeyHashid TicketAuthorLocal -> Handler TypedContent
getSharerTicketDepsR = getSharerTicketDeps True getSharerTicketDepsR shr talkhid =
getDependencyCollection here getLocalTicketId404
where
here = SharerTicketDepsR shr talkhid
getLocalTicketId404 = do
(_, Entity ltid _, _, _) <- getSharerTicket404 shr talkhid
return ltid
getSharerTicketReverseDepsR getSharerTicketReverseDepsR
:: ShrIdent -> KeyHashid TicketAuthorLocal -> Handler TypedContent :: ShrIdent -> KeyHashid TicketAuthorLocal -> Handler TypedContent
getSharerTicketReverseDepsR = getSharerTicketDeps False getSharerTicketReverseDepsR shr talkhid =
getReverseDependencyCollection here getLocalTicketId404
where
here = SharerTicketReverseDepsR shr talkhid
getLocalTicketId404 = do
(_, Entity ltid _, _, _) <- getSharerTicket404 shr talkhid
return ltid
getSharerTicketFollowersR getSharerTicketFollowersR
:: ShrIdent -> KeyHashid TicketAuthorLocal -> Handler TypedContent :: ShrIdent -> KeyHashid TicketAuthorLocal -> Handler TypedContent

119
src/Vervis/Migration.hs
View file

@ -786,7 +786,7 @@ changes hLocal ctx =
summary renderUrl summary renderUrl
, activityAudience = Audience recips [] [] [] [] [] , activityAudience = Audience recips [] [] [] [] []
, activitySpecific = OfferActivity Offer , activitySpecific = OfferActivity Offer
{ offerObject = ticketAP { offerObject = OfferTicket ticketAP
, offerTarget = , offerTarget =
encodeRouteHome $ ProjectR shrProject prj encodeRouteHome $ ProjectR shrProject prj
} }
@ -1587,6 +1587,123 @@ changes hLocal ctx =
, addFieldPrimOptional "TicketRepoLocal" (Nothing :: Maybe Text) "branch" , addFieldPrimOptional "TicketRepoLocal" (Nothing :: Maybe Text) "branch"
-- 252 -- 252
, addEntities model_2020_05_25 , addEntities model_2020_05_25
-- 253
, removeField "TicketDependency" "summary"
-- 254
, addEntities model_2020_05_28
-- 255
, unchecked $ lift $ do
tds <- selectList ([] :: [Filter TicketDependency255]) []
for_ tds $ \ (Entity tdid td) -> do
let pid = ticketDependency255Author td
p <- getJust pid
obiid <-
insert $
OutboxItem255
(person255Outbox p)
(persistJSONObjectFromDoc $ Doc hLocal emptyActivity)
(ticketDependency255Created td)
insert_ $ TicketDependencyAuthorLocal255 tdid pid obiid
-- 256
, removeField "TicketDependency" "author"
-- 257
, addEntities model_2020_06_01
-- 258
, renameEntity "TicketDependency" "LocalTicketDependency"
-- 259
, renameUnique
"LocalTicketDependency"
"UniqueTicketDependency"
"UniqueLocalTicketDependency"
-- 260
, unchecked $ lift $ do
tds <- selectList ([] :: [Filter LocalTicketDependency260]) []
for_ tds $ \ (Entity tdid td) -> do
let tid = localTicketDependency260Child td
location <-
requireEitherAlt
(getKeyBy $ UniqueLocalTicket260 tid)
(runMaybeT $ do
tclid <- MaybeT $ getKeyBy $ UniqueTicketContextLocal260 tid
tarid <- MaybeT $ getKeyBy $ UniqueTicketAuthorRemote260 tclid
rt <- MaybeT $ getValBy $ UniqueRemoteTicket260 tarid
return $ remoteTicket260Ident rt
)
"Neither LT nor RT"
"Both LT and RT"
case location of
Left ltid -> insert_ $ TicketDependencyChildLocal260 tdid ltid
Right roid -> insert_ $ TicketDependencyChildRemote260 tdid roid
-- 261
, removeUnique "LocalTicketDependency" "UniqueLocalTicketDependency"
-- 262
, removeField "LocalTicketDependency" "child"
-- 263
, addFieldRefRequired''
"LocalTicketDependency"
(do did <- insert Discussion263
fsid <- insert FollowerSet263
tid <- insert $ Ticket263 Nothing defaultTime "" "" "" Nothing "TSNew" defaultTime Nothing
insertEntity $ LocalTicket263 tid did fsid
)
(Just $ \ (Entity ltidTemp ltTemp) -> do
tdids <- selectList ([] :: [Filter LocalTicketDependency263]) []
for_ tdids $ \ (Entity tdid td) -> do
ltid <- do
mltid <-
getKeyBy $ UniqueLocalTicket263 $
localTicketDependency263Parent td
case mltid of
Nothing -> error "TD with non-local parent"
Just v -> return v
update tdid [LocalTicketDependency263ParentNew =. ltid]
delete ltidTemp
delete $ localTicket263Ticket ltTemp
delete $ localTicket263Discuss ltTemp
delete $ localTicket263Followers ltTemp
)
"parentNew"
"LocalTicket"
-- 264
, removeField "LocalTicketDependency" "parent"
-- 265
, renameField "LocalTicketDependency" "parentNew" "parent"
-- 266
, addFieldRefRequired''
"LocalTicketDependency"
(do obid <- insert Outbox266
let doc = persistJSONObjectFromDoc $ Doc hLocal emptyActivity
insertEntity $ OutboxItem266 obid doc defaultTime
)
(Just $ \ (Entity obiidTemp obiTemp) -> do
tdids <- selectList ([] :: [Filter LocalTicketDependency266]) []
for_ tdids $ \ (Entity tdid td) -> do
lt <- getJust $ localTicketDependency266Parent td
mtpl <- runMaybeT $ do
tclid <- MaybeT $ getKeyBy $ UniqueTicketContextLocal266 $ localTicket266Ticket lt
_ <- MaybeT $ getBy $ UniqueTicketUnderProjectProject266 tclid
MaybeT $ getValBy $ UniqueTicketProjectLocal266 tclid
tpl <-
case mtpl of
Nothing -> error "No TPL"
Just v -> return v
j <- getJust $ ticketProjectLocal266Project tpl
let doc = persistJSONObjectFromDoc $ Doc hLocal emptyActivity
obiid <-
insert $
OutboxItem266
(project266Outbox j)
doc
(localTicketDependency266Created td)
update tdid [LocalTicketDependency266Accept =. obiid]
delete obiidTemp
delete $ outboxItem266Outbox obiTemp
)
"accept"
"OutboxItem"
] ]
migrateDB migrateDB

43
src/Vervis/Migration/Model.hs
View file

@ -199,6 +199,34 @@ module Vervis.Migration.Model
, TicketProjectLocal247Generic (..) , TicketProjectLocal247Generic (..)
, model_2020_05_17 , model_2020_05_17
, model_2020_05_25 , model_2020_05_25
, model_2020_05_28
, OutboxItem255Generic (..)
, Person255Generic (..)
, TicketDependency255
, TicketDependency255Generic (..)
, TicketDependencyAuthorLocal255Generic (..)
, model_2020_06_01
, RemoteTicket260Generic (..)
, LocalTicketDependency260
, LocalTicketDependency260Generic (..)
, TicketDependencyChildLocal260Generic (..)
, TicketDependencyChildRemote260Generic (..)
, Discussion263Generic (..)
, FollowerSet263Generic (..)
, Ticket263Generic (..)
, LocalTicket263Generic (..)
, LocalTicketDependency263
, LocalTicketDependency263Generic (..)
, Outbox266Generic (..)
, OutboxItem266Generic (..)
, LocalTicketDependency266
, LocalTicketDependency266Generic (..)
, LocalTicket266Generic (..)
, TicketContextLocal266Generic (..)
, TicketUnderProject266Generic (..)
, TicketProjectLocal266Generic (..)
, Project266Generic (..)
) )
where where
@ -399,3 +427,18 @@ model_2020_05_17 = $(schema "2020_05_17_patch")
model_2020_05_25 :: [Entity SqlBackend] model_2020_05_25 :: [Entity SqlBackend]
model_2020_05_25 = $(schema "2020_05_25_fwd_sender_repo") model_2020_05_25 = $(schema "2020_05_25_fwd_sender_repo")
model_2020_05_28 :: [Entity SqlBackend]
model_2020_05_28 = $(schema "2020_05_28_tda")
makeEntitiesMigration "255" $(modelFile "migrations/2020_05_28_tda_mig.model")
model_2020_06_01 :: [Entity SqlBackend]
model_2020_06_01 = $(schema "2020_06_01_tdc")
makeEntitiesMigration "260" $(modelFile "migrations/2020_06_01_tdc_mig.model")
makeEntitiesMigration "263" $(modelFile "migrations/2020_06_02_tdp.model")
makeEntitiesMigration "266"
$(modelFile "migrations/2020_06_15_td_accept.model")

2
src/Vervis/Model.hs
View file

@ -81,11 +81,13 @@ instance Hashable RoleId where
hashWithSalt salt = hashWithSalt salt . fromSqlKey hashWithSalt salt = hashWithSalt salt . fromSqlKey
hash = hash . fromSqlKey hash = hash . fromSqlKey
{-
instance PersistEntityGraph Ticket TicketDependency where instance PersistEntityGraph Ticket TicketDependency where
sourceParam = ticketDependencyParent sourceParam = ticketDependencyParent
sourceField = TicketDependencyParent sourceField = TicketDependencyParent
destParam = ticketDependencyChild destParam = ticketDependencyChild
destField = TicketDependencyChild destField = TicketDependencyChild
-}
{- {-
instance PersistEntityGraphSelect Ticket TicketDependency where instance PersistEntityGraphSelect Ticket TicketDependency where

15
src/Vervis/Patch.hs
View file

@ -22,12 +22,15 @@ module Vervis.Patch
where where
import Control.Monad import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Trans.Class import Control.Monad.Trans.Class
import Control.Monad.Trans.Maybe import Control.Monad.Trans.Maybe
import Control.Monad.Trans.Reader
import Data.List.NonEmpty (NonEmpty, nonEmpty) import Data.List.NonEmpty (NonEmpty, nonEmpty)
import Data.Maybe import Data.Maybe
import Data.Traversable import Data.Traversable
import Database.Persist import Database.Persist
import Database.Persist.Sql
import Yesod.Core import Yesod.Core
import Yesod.Hashids import Yesod.Hashids
@ -40,9 +43,10 @@ import Vervis.Model
import Vervis.Model.Ident import Vervis.Model.Ident
getSharerPatch getSharerPatch
:: ShrIdent :: MonadIO m
=> ShrIdent
-> TicketAuthorLocalId -> TicketAuthorLocalId
-> AppDB -> ReaderT SqlBackend m
( Maybe ( Maybe
( Entity TicketAuthorLocal ( Entity TicketAuthorLocal
, Entity LocalTicket , Entity LocalTicket
@ -73,7 +77,7 @@ getSharerPatch shr talid = runMaybeT $ do
repo <- repo <-
requireEitherAlt requireEitherAlt
(do mtcl <- lift $ getBy $ UniqueTicketContextLocal tid (do mtcl <- lift $ getBy $ UniqueTicketContextLocal tid
for mtcl $ \ etcl@(Entity tclid tcl) -> do for mtcl $ \ etcl@(Entity tclid _) -> do
etrl <- MaybeT $ getBy $ UniqueTicketRepoLocal tclid etrl <- MaybeT $ getBy $ UniqueTicketRepoLocal tclid
mtup1 <- lift $ getBy $ UniqueTicketUnderProjectProject tclid mtup1 <- lift $ getBy $ UniqueTicketUnderProjectProject tclid
mtup2 <- lift $ getBy $ UniqueTicketUnderProjectAuthor talid mtup2 <- lift $ getBy $ UniqueTicketUnderProjectAuthor talid
@ -114,10 +118,11 @@ getSharerPatch404 shr talkhid = do
Just patch -> return patch Just patch -> return patch
getRepoPatch getRepoPatch
:: ShrIdent :: MonadIO m
=> ShrIdent
-> RpIdent -> RpIdent
-> LocalTicketId -> LocalTicketId
-> AppDB -> ReaderT SqlBackend m
( Maybe ( Maybe
( Entity Sharer ( Entity Sharer
, Entity Repo , Entity Repo

540
src/Vervis/Ticket.hs
View file

@ -15,7 +15,7 @@
module Vervis.Ticket module Vervis.Ticket
( getTicketSummaries ( getTicketSummaries
, getTicketDepEdges --, getTicketDepEdges
, WorkflowFieldFilter (..) , WorkflowFieldFilter (..)
, WorkflowFieldSummary (..) , WorkflowFieldSummary (..)
, TicketTextParamValue (..) , TicketTextParamValue (..)
@ -34,31 +34,42 @@ module Vervis.Ticket
, getSharerWorkItems , getSharerWorkItems
, getDependencyCollection , getDependencyCollection
, getReverseDependencyCollection
, WorkItem (..)
, getWorkItemRoute
, askWorkItemRoute
, getWorkItem
) )
where where
import Control.Arrow ((***))
import Control.Monad import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Trans.Class import Control.Monad.Trans.Class
import Control.Monad.Trans.Except
import Control.Monad.Trans.Maybe import Control.Monad.Trans.Maybe
import Control.Monad.Trans.Reader
import Data.Either
import Data.Foldable (for_) import Data.Foldable (for_)
import Data.Int
import Data.Maybe (isJust) import Data.Maybe (isJust)
import Data.Text (Text) import Data.Text (Text)
import Data.Traversable import Data.Traversable
import Database.Esqueleto import Database.Persist
import Database.Persist.Sql
import Yesod.Core (notFound) import Yesod.Core (notFound)
import Yesod.Core.Content import Yesod.Core.Content
import Yesod.Persist.Core import Yesod.Persist.Core
import qualified Database.Esqueleto as E import qualified Database.Esqueleto as E
import qualified Database.Persist as P
import Network.FedURI
import Web.ActivityPub hiding (Ticket, Project) import Web.ActivityPub hiding (Ticket, Project)
import Yesod.ActivityPub import Yesod.ActivityPub
import Yesod.FedURI import Yesod.FedURI
import Yesod.Hashids import Yesod.Hashids
import Yesod.MonadSite
import Control.Monad.Trans.Except.Local
import Data.Either.Local import Data.Either.Local
import Data.Paginate.Local import Data.Paginate.Local
import Database.Persist.Local import Database.Persist.Local
@ -74,65 +85,65 @@ import Vervis.Widget.Ticket (TicketSummary (..))
-- | Get summaries of all the tickets in the given project. -- | Get summaries of all the tickets in the given project.
getTicketSummaries getTicketSummaries
:: Maybe (SqlExpr (Entity Ticket) -> SqlExpr (Value Bool)) :: Maybe (E.SqlExpr (Entity Ticket) -> E.SqlExpr (E.Value Bool))
-> Maybe (SqlExpr (Entity Ticket) -> [SqlExpr OrderBy]) -> Maybe (E.SqlExpr (Entity Ticket) -> [E.SqlExpr E.OrderBy])
-> Maybe (Int, Int) -> Maybe (Int, Int)
-> ProjectId -> ProjectId
-> AppDB [TicketSummary] -> AppDB [TicketSummary]
getTicketSummaries mfilt morder offlim jid = do getTicketSummaries mfilt morder offlim jid = do
tickets <- select $ from $ tickets <- E.select $ E.from $
\ ( t \ ( t
`InnerJoin` lt `E.InnerJoin` lt
`InnerJoin` tcl `E.InnerJoin` tcl
`InnerJoin` tpl `E.InnerJoin` tpl
`LeftOuterJoin` (tal `InnerJoin` p `InnerJoin` s `LeftOuterJoin` tup) `E.LeftOuterJoin` (tal `E.InnerJoin` p `E.InnerJoin` s `E.LeftOuterJoin` tup)
`LeftOuterJoin` (tar `InnerJoin` ra `InnerJoin` ro `InnerJoin` i) `E.LeftOuterJoin` (tar `E.InnerJoin` ra `E.InnerJoin` ro `E.InnerJoin` i)
`InnerJoin` d `E.InnerJoin` d
`LeftOuterJoin` m `E.LeftOuterJoin` m
) -> do ) -> do
on $ just (d ^. DiscussionId) ==. m ?. MessageRoot E.on $ E.just (d E.^. DiscussionId) E.==. m E.?. MessageRoot
on $ lt ^. LocalTicketDiscuss ==. d ^. DiscussionId E.on $ lt E.^. LocalTicketDiscuss E.==. d E.^. DiscussionId
on $ ro ?. RemoteObjectInstance ==. i ?. InstanceId E.on $ ro E.?. RemoteObjectInstance E.==. i E.?. InstanceId
on $ ra ?. RemoteActorIdent ==. ro ?. RemoteObjectId E.on $ ra E.?. RemoteActorIdent E.==. ro E.?. RemoteObjectId
on $ tar ?. TicketAuthorRemoteAuthor ==. ra ?. RemoteActorId E.on $ tar E.?. TicketAuthorRemoteAuthor E.==. ra E.?. RemoteActorId
on $ just (tcl ^. TicketContextLocalId) ==. tar ?. TicketAuthorRemoteTicket E.on $ E.just (tcl E.^. TicketContextLocalId) E.==. tar E.?. TicketAuthorRemoteTicket
on $ tal ?. TicketAuthorLocalId ==. tup ?. TicketUnderProjectAuthor E.on $ tal E.?. TicketAuthorLocalId E.==. tup E.?. TicketUnderProjectAuthor
on $ p ?. PersonIdent ==. s ?. SharerId E.on $ p E.?. PersonIdent E.==. s E.?. SharerId
on $ tal ?. TicketAuthorLocalAuthor ==. p ?. PersonId E.on $ tal E.?. TicketAuthorLocalAuthor E.==. p E.?. PersonId
on $ just (lt ^. LocalTicketId) ==. tal ?. TicketAuthorLocalTicket E.on $ E.just (lt E.^. LocalTicketId) E.==. tal E.?. TicketAuthorLocalTicket
on $ tcl ^. TicketContextLocalId ==. tpl ^. TicketProjectLocalContext E.on $ tcl E.^. TicketContextLocalId E.==. tpl E.^. TicketProjectLocalContext
on $ t ^. TicketId ==. tcl ^. TicketContextLocalTicket E.on $ t E.^. TicketId E.==. tcl E.^. TicketContextLocalTicket
on $ t ^. TicketId ==. lt ^. LocalTicketTicket E.on $ t E.^. TicketId E.==. lt E.^. LocalTicketTicket
where_ $ tpl ^. TicketProjectLocalProject ==. val jid E.where_ $ tpl E.^. TicketProjectLocalProject E.==. E.val jid
groupBy E.groupBy
( t ^. TicketId, lt ^. LocalTicketId ( t E.^. TicketId, lt E.^. LocalTicketId
, tal ?. TicketAuthorLocalId, s ?. SharerId, tup ?. TicketUnderProjectId , tal E.?. TicketAuthorLocalId, s E.?. SharerId, tup E.?. TicketUnderProjectId
, ra ?. RemoteActorId, ro ?. RemoteObjectId, i ?. InstanceId , ra E.?. RemoteActorId, ro E.?. RemoteObjectId, i E.?. InstanceId
) )
for_ mfilt $ \ filt -> where_ $ filt t for_ mfilt $ \ filt -> E.where_ $ filt t
for_ morder $ \ order -> orderBy $ order t for_ morder $ \ order -> E.orderBy $ order t
for_ offlim $ \ (off, lim) -> do for_ offlim $ \ (off, lim) -> do
offset $ fromIntegral off E.offset $ fromIntegral off
limit $ fromIntegral lim E.limit $ fromIntegral lim
return return
( t ^. TicketId ( t E.^. TicketId
, lt ^. LocalTicketId , lt E.^. LocalTicketId
, tal ?. TicketAuthorLocalId , tal E.?. TicketAuthorLocalId
, s , s
, tup ?. TicketUnderProjectId , tup E.?. TicketUnderProjectId
, i , i
, ro , ro
, ra , ra
, t ^. TicketCreated , t E.^. TicketCreated
, t ^. TicketTitle , t E.^. TicketTitle
, t ^. TicketStatus , t E.^. TicketStatus
, count $ m ?. MessageId , E.count $ m E.?. MessageId
) )
for tickets $ for tickets $
\ (Value tid, Value ltid, Value mtalid, ms, Value mtupid, mi, mro, mra, Value c, Value t, Value d, Value r) -> do \ (E.Value tid, E.Value ltid, E.Value mtalid, ms, E.Value mtupid, mi, mro, mra, E.Value c, E.Value t, E.Value d, E.Value r) -> do
labels <- select $ from $ \ (tpc `InnerJoin` wf) -> do labels <- E.select $ E.from $ \ (tpc `E.InnerJoin` wf) -> do
on $ tpc ^. TicketParamClassField ==. wf ^. WorkflowFieldId E.on $ tpc E.^. TicketParamClassField E.==. wf E.^. WorkflowFieldId
where_ $ tpc ^. TicketParamClassTicket ==. val tid E.where_ $ tpc E.^. TicketParamClassTicket E.==. E.val tid
return wf return wf
return TicketSummary return TicketSummary
{ tsId = ltid { tsId = ltid
@ -156,6 +167,7 @@ getTicketSummaries mfilt morder offlim jid = do
-- | Get the child-parent ticket number pairs of all the ticket dependencies -- | 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 -- in the given project, in ascending order by child, and then ascending order
-- by parent. -- by parent.
{-
getTicketDepEdges :: ProjectId -> AppDB [(Int64, Int64)] getTicketDepEdges :: ProjectId -> AppDB [(Int64, Int64)]
getTicketDepEdges jid = getTicketDepEdges jid =
fmap (map $ fromSqlKey . unValue *** fromSqlKey . unValue) $ fmap (map $ fromSqlKey . unValue *** fromSqlKey . unValue) $
@ -175,6 +187,7 @@ getTicketDepEdges jid =
tpl2 ^. TicketProjectLocalProject ==. val jid tpl2 ^. TicketProjectLocalProject ==. val jid
orderBy [asc $ t1 ^. TicketId, asc $ t2 ^. TicketId] orderBy [asc $ t1 ^. TicketId, asc $ t2 ^. TicketId]
return (t1 ^. TicketId, t2 ^. TicketId) return (t1 ^. TicketId, t2 ^. TicketId)
-}
data WorkflowFieldFilter = WorkflowFieldFilter data WorkflowFieldFilter = WorkflowFieldFilter
{ wffNew :: Bool { wffNew :: Bool
@ -202,29 +215,29 @@ data TicketTextParam = TicketTextParam
} }
toTParam toTParam
:: ( Value WorkflowFieldId :: ( E.Value WorkflowFieldId
, Value FldIdent , E.Value FldIdent
, Value Text , E.Value Text
, Value Bool , E.Value Bool
, Value Bool , E.Value Bool
, Value Bool , E.Value Bool
, Value Bool , E.Value Bool
, Value Bool , E.Value Bool
, Value (Maybe TicketParamTextId) , E.Value (Maybe TicketParamTextId)
, Value (Maybe Text) , E.Value (Maybe Text)
) )
-> TicketTextParam -> TicketTextParam
toTParam toTParam
( Value fid ( E.Value fid
, Value fld , E.Value fld
, Value name , E.Value name
, Value req , E.Value req
, Value con , E.Value con
, Value new , E.Value new
, Value todo , E.Value todo
, Value closed , E.Value closed
, Value mp , E.Value mp
, Value mt , E.Value mt
) = ) =
TicketTextParam TicketTextParam
{ ttpField = WorkflowFieldSummary { ttpField = WorkflowFieldSummary
@ -252,25 +265,25 @@ toTParam
getTicketTextParams :: TicketId -> WorkflowId -> AppDB [TicketTextParam] getTicketTextParams :: TicketId -> WorkflowId -> AppDB [TicketTextParam]
getTicketTextParams tid wid = fmap (map toTParam) $ getTicketTextParams tid wid = fmap (map toTParam) $
select $ from $ \ (p `RightOuterJoin` f) -> do E.select $ E.from $ \ (p `E.RightOuterJoin` f) -> do
on $ E.on $
p ?. TicketParamTextField ==. just (f ^. WorkflowFieldId) &&. p E.?. TicketParamTextField E.==. E.just (f E.^. WorkflowFieldId) E.&&.
p ?. TicketParamTextTicket ==. just (val tid) p E.?. TicketParamTextTicket E.==. E.just (E.val tid)
where_ $ E.where_ $
f ^. WorkflowFieldWorkflow ==. val wid &&. f E.^. WorkflowFieldWorkflow E.==. E.val wid E.&&.
f ^. WorkflowFieldType ==. val WFTText &&. f E.^. WorkflowFieldType E.==. E.val WFTText E.&&.
isNothing (f ^. WorkflowFieldEnm) E.isNothing (f E.^. WorkflowFieldEnm)
return return
( f ^. WorkflowFieldId ( f E.^. WorkflowFieldId
, f ^. WorkflowFieldIdent , f E.^. WorkflowFieldIdent
, f ^. WorkflowFieldName , f E.^. WorkflowFieldName
, f ^. WorkflowFieldRequired , f E.^. WorkflowFieldRequired
, f ^. WorkflowFieldConstant , f E.^. WorkflowFieldConstant
, f ^. WorkflowFieldFilterNew , f E.^. WorkflowFieldFilterNew
, f ^. WorkflowFieldFilterTodo , f E.^. WorkflowFieldFilterTodo
, f ^. WorkflowFieldFilterClosed , f E.^. WorkflowFieldFilterClosed
, p ?. TicketParamTextId , p E.?. TicketParamTextId
, p ?. TicketParamTextValue , p E.?. TicketParamTextValue
) )
data WorkflowEnumSummary = WorkflowEnumSummary data WorkflowEnumSummary = WorkflowEnumSummary
@ -291,35 +304,35 @@ data TicketEnumParam = TicketEnumParam
} }
toEParam toEParam
:: ( Value WorkflowFieldId :: ( E.Value WorkflowFieldId
, Value FldIdent , E.Value FldIdent
, Value Text , E.Value Text
, Value Bool , E.Value Bool
, Value Bool , E.Value Bool
, Value Bool , E.Value Bool
, Value Bool , E.Value Bool
, Value Bool , E.Value Bool
, Value WorkflowEnumId , E.Value WorkflowEnumId
, Value EnmIdent , E.Value EnmIdent
, Value (Maybe TicketParamEnumId) , E.Value (Maybe TicketParamEnumId)
, Value (Maybe WorkflowEnumCtorId) , E.Value (Maybe WorkflowEnumCtorId)
, Value (Maybe Text) , E.Value (Maybe Text)
) )
-> TicketEnumParam -> TicketEnumParam
toEParam toEParam
( Value fid ( E.Value fid
, Value fld , E.Value fld
, Value name , E.Value name
, Value req , E.Value req
, Value con , E.Value con
, Value new , E.Value new
, Value todo , E.Value todo
, Value closed , E.Value closed
, Value i , E.Value i
, Value e , E.Value e
, Value mp , E.Value mp
, Value mc , E.Value mc
, Value mt , E.Value mt
) = ) =
TicketEnumParam TicketEnumParam
{ tepField = WorkflowFieldSummary { tepField = WorkflowFieldSummary
@ -352,32 +365,32 @@ toEParam
getTicketEnumParams :: TicketId -> WorkflowId -> AppDB [TicketEnumParam] getTicketEnumParams :: TicketId -> WorkflowId -> AppDB [TicketEnumParam]
getTicketEnumParams tid wid = fmap (map toEParam) $ getTicketEnumParams tid wid = fmap (map toEParam) $
select $ from $ \ (p `InnerJoin` c `RightOuterJoin` f `InnerJoin` e) -> do E.select $ E.from $ \ (p `E.InnerJoin` c `E.RightOuterJoin` f `E.InnerJoin` e) -> do
on $ E.on $
e ^. WorkflowEnumWorkflow ==. val wid &&. e E.^. WorkflowEnumWorkflow E.==. E.val wid E.&&.
f ^. WorkflowFieldEnm ==. just (e ^. WorkflowEnumId) f E.^. WorkflowFieldEnm E.==. E.just (e E.^. WorkflowEnumId)
on $ E.on $
f ^. WorkflowFieldWorkflow ==. val wid &&. f E.^. WorkflowFieldWorkflow E.==. E.val wid E.&&.
f ^. WorkflowFieldType ==. val WFTEnum &&. f E.^. WorkflowFieldType E.==. E.val WFTEnum E.&&.
p ?. TicketParamEnumField ==. just (f ^. WorkflowFieldId) &&. p E.?. TicketParamEnumField E.==. E.just (f E.^. WorkflowFieldId) E.&&.
c ?. WorkflowEnumCtorEnum ==. f ^. WorkflowFieldEnm c E.?. WorkflowEnumCtorEnum E.==. f E.^. WorkflowFieldEnm
on $ E.on $
p ?. TicketParamEnumTicket ==. just (val tid) &&. p E.?. TicketParamEnumTicket E.==. E.just (E.val tid) E.&&.
p ?. TicketParamEnumValue ==. c ?. WorkflowEnumCtorId p E.?. TicketParamEnumValue E.==. c E.?. WorkflowEnumCtorId
return return
( f ^. WorkflowFieldId ( f E.^. WorkflowFieldId
, f ^. WorkflowFieldIdent , f E.^. WorkflowFieldIdent
, f ^. WorkflowFieldName , f E.^. WorkflowFieldName
, f ^. WorkflowFieldRequired , f E.^. WorkflowFieldRequired
, f ^. WorkflowFieldConstant , f E.^. WorkflowFieldConstant
, f ^. WorkflowFieldFilterNew , f E.^. WorkflowFieldFilterNew
, f ^. WorkflowFieldFilterTodo , f E.^. WorkflowFieldFilterTodo
, f ^. WorkflowFieldFilterClosed , f E.^. WorkflowFieldFilterClosed
, e ^. WorkflowEnumId , e E.^. WorkflowEnumId
, e ^. WorkflowEnumIdent , e E.^. WorkflowEnumIdent
, p ?. TicketParamEnumId , p E.?. TicketParamEnumId
, c ?. WorkflowEnumCtorId , c E.?. WorkflowEnumCtorId
, c ?. WorkflowEnumCtorName , c E.?. WorkflowEnumCtorName
) )
data TicketClassParam = TicketClassParam data TicketClassParam = TicketClassParam
@ -386,27 +399,27 @@ data TicketClassParam = TicketClassParam
} }
toCParam toCParam
:: ( Value WorkflowFieldId :: ( E.Value WorkflowFieldId
, Value FldIdent , E.Value FldIdent
, Value Text , E.Value Text
, Value Bool , E.Value Bool
, Value Bool , E.Value Bool
, Value Bool , E.Value Bool
, Value Bool , E.Value Bool
, Value Bool , E.Value Bool
, Value (Maybe TicketParamClassId) , E.Value (Maybe TicketParamClassId)
) )
-> TicketClassParam -> TicketClassParam
toCParam toCParam
( Value fid ( E.Value fid
, Value fld , E.Value fld
, Value name , E.Value name
, Value req , E.Value req
, Value con , E.Value con
, Value new , E.Value new
, Value todo , E.Value todo
, Value closed , E.Value closed
, Value mp , E.Value mp
) = TicketClassParam ) = TicketClassParam
{ tcpField = WorkflowFieldSummary { tcpField = WorkflowFieldSummary
{ wfsId = fid { wfsId = fid
@ -425,30 +438,31 @@ toCParam
getTicketClasses :: TicketId -> WorkflowId -> AppDB [TicketClassParam] getTicketClasses :: TicketId -> WorkflowId -> AppDB [TicketClassParam]
getTicketClasses tid wid = fmap (map toCParam) $ getTicketClasses tid wid = fmap (map toCParam) $
select $ from $ \ (p `RightOuterJoin` f) -> do E.select $ E.from $ \ (p `E.RightOuterJoin` f) -> do
on $ E.on $
p ?. TicketParamClassField ==. just (f ^. WorkflowFieldId) &&. p E.?. TicketParamClassField E.==. E.just (f E.^. WorkflowFieldId) E.&&.
p ?. TicketParamClassTicket ==. just (val tid) p E.?. TicketParamClassTicket E.==. E.just (E.val tid)
where_ $ E.where_ $
f ^. WorkflowFieldWorkflow ==. val wid &&. f E.^. WorkflowFieldWorkflow E.==. E.val wid E.&&.
f ^. WorkflowFieldType ==. val WFTClass &&. f E.^. WorkflowFieldType E.==. E.val WFTClass E.&&.
isNothing (f ^. WorkflowFieldEnm) E.isNothing (f E.^. WorkflowFieldEnm)
return return
( f ^. WorkflowFieldId ( f E.^. WorkflowFieldId
, f ^. WorkflowFieldIdent , f E.^. WorkflowFieldIdent
, f ^. WorkflowFieldName , f E.^. WorkflowFieldName
, f ^. WorkflowFieldRequired , f E.^. WorkflowFieldRequired
, f ^. WorkflowFieldConstant , f E.^. WorkflowFieldConstant
, f ^. WorkflowFieldFilterNew , f E.^. WorkflowFieldFilterNew
, f ^. WorkflowFieldFilterTodo , f E.^. WorkflowFieldFilterTodo
, f ^. WorkflowFieldFilterClosed , f E.^. WorkflowFieldFilterClosed
, p ?. TicketParamClassId , p E.?. TicketParamClassId
) )
getSharerTicket getSharerTicket
:: ShrIdent :: MonadIO m
=> ShrIdent
-> TicketAuthorLocalId -> TicketAuthorLocalId
-> AppDB -> ReaderT SqlBackend m
( Maybe ( Maybe
( Entity TicketAuthorLocal ( Entity TicketAuthorLocal
, Entity LocalTicket , Entity LocalTicket
@ -472,12 +486,12 @@ getSharerTicket shr talid = runMaybeT $ do
lt <- lift $ getJust ltid lt <- lift $ getJust ltid
let tid = localTicketTicket lt let tid = localTicketTicket lt
t <- lift $ getJust tid t <- lift $ getJust tid
npatches <- lift $ P.count [PatchTicket P.==. tid] npatches <- lift $ count [PatchTicket ==. tid]
guard $ npatches <= 0 guard $ npatches <= 0
project <- project <-
requireEitherAlt requireEitherAlt
(do mtcl <- lift $ getBy $ UniqueTicketContextLocal tid (do mtcl <- lift $ getBy $ UniqueTicketContextLocal tid
for mtcl $ \ etcl@(Entity tclid tcl) -> do for mtcl $ \ etcl@(Entity tclid _) -> do
etpl <- MaybeT $ getBy $ UniqueTicketProjectLocal tclid etpl <- MaybeT $ getBy $ UniqueTicketProjectLocal tclid
mtup1 <- lift $ getBy $ UniqueTicketUnderProjectProject tclid mtup1 <- lift $ getBy $ UniqueTicketUnderProjectProject tclid
mtup2 <- lift $ getBy $ UniqueTicketUnderProjectAuthor talid mtup2 <- lift $ getBy $ UniqueTicketUnderProjectAuthor talid
@ -517,10 +531,11 @@ getSharerTicket404 shr talkhid = do
Just ticket -> return ticket Just ticket -> return ticket
getProjectTicket getProjectTicket
:: ShrIdent :: MonadIO m
=> ShrIdent
-> PrjIdent -> PrjIdent
-> LocalTicketId -> LocalTicketId
-> AppDB -> ReaderT SqlBackend m
( Maybe ( Maybe
( Entity Sharer ( Entity Sharer
, Entity Project , Entity Project
@ -542,7 +557,7 @@ getProjectTicket shr prj ltid = runMaybeT $ do
etcl@(Entity tclid _) <- MaybeT $ getBy $ UniqueTicketContextLocal tid etcl@(Entity tclid _) <- MaybeT $ getBy $ UniqueTicketContextLocal tid
etpl@(Entity _ tpl) <- MaybeT $ getBy $ UniqueTicketProjectLocal tclid etpl@(Entity _ tpl) <- MaybeT $ getBy $ UniqueTicketProjectLocal tclid
guard $ ticketProjectLocalProject tpl == jid guard $ ticketProjectLocalProject tpl == jid
npatches <- lift $ P.count [PatchTicket P.==. tid] npatches <- lift $ count [PatchTicket ==. tid]
guard $ npatches <= 0 guard $ npatches <= 0
author <- author <-
requireEitherAlt requireEitherAlt
@ -586,7 +601,7 @@ getSharerWorkItems
=> (ShrIdent -> Route App) => (ShrIdent -> Route App)
-> (ShrIdent -> KeyHashid record -> Route App) -> (ShrIdent -> KeyHashid record -> Route App)
-> (PersonId -> AppDB Int) -> (PersonId -> AppDB Int)
-> (PersonId -> Int -> Int -> AppDB [Value (Key record)]) -> (PersonId -> Int -> Int -> AppDB [E.Value (Key record)])
-> ShrIdent -> ShrIdent
-> Handler TypedContent -> Handler TypedContent
getSharerWorkItems mkhere itemRoute countItems selectItems shr = do getSharerWorkItems mkhere itemRoute countItems selectItems shr = do
@ -632,37 +647,170 @@ getSharerWorkItems mkhere itemRoute countItems selectItems shr = do
else Nothing else Nothing
, collectionPageStartIndex = Nothing , collectionPageStartIndex = Nothing
, collectionPageItems = , collectionPageItems =
map (encodeRouteHome . ticketUrl . unValue) tickets map (encodeRouteHome . ticketUrl . E.unValue) tickets
} }
where where
provide :: ActivityPub a => Route App -> a URIMode -> Handler TypedContent provide :: ActivityPub a => Route App -> a URIMode -> Handler TypedContent
provide here a = provideHtmlAndAP a $ redirectToPrettyJSON here provide here a = provideHtmlAndAP a $ redirectToPrettyJSON here
getDependencyCollection getDependencyCollection
:: Route App -> AppDB TicketId -> Bool -> Handler TypedContent :: Route App -> AppDB LocalTicketId -> Handler TypedContent
getDependencyCollection here getTicketId404 forward = do getDependencyCollection here getLocalTicketId404 = do
tdids <- runDB $ do tdids <- runDB $ do
tid <- getTicketId404 ltid <- getLocalTicketId404
let (from, to) = selectKeysList
if forward [LocalTicketDependencyParent ==. ltid]
then (TicketDependencyParent, TicketDependencyChild) [Desc LocalTicketDependencyId]
else (TicketDependencyChild, TicketDependencyParent) encodeRouteLocal <- getEncodeRouteLocal
E.select $ E.from $ \ (td `E.InnerJoin` t) -> do encodeRouteHome <- getEncodeRouteHome
E.on $ td E.^. to E.==. t E.^. TicketId encodeHid <- getEncodeKeyHashid
E.where_ $ td E.^. from E.==. E.val tid let deps = Collection
return $ td E.^. TicketDependencyId { collectionId = encodeRouteLocal here
, collectionType = CollectionTypeOrdered
, collectionTotalItems = Just $ length tdids
, collectionCurrent = Nothing
, collectionFirst = Nothing
, collectionLast = Nothing
, collectionItems =
map (encodeRouteHome . TicketDepR . encodeHid) tdids
}
provideHtmlAndAP deps $ redirectToPrettyJSON here
getReverseDependencyCollection
:: Route App -> AppDB LocalTicketId -> Handler TypedContent
getReverseDependencyCollection here getLocalTicketId404 = do
(locals, remotes) <- runDB $ do
ltid <- getLocalTicketId404
(,) <$> getLocals ltid <*> getRemotes ltid
encodeRouteLocal <- getEncodeRouteLocal encodeRouteLocal <- getEncodeRouteLocal
encodeRouteHome <- getEncodeRouteHome encodeRouteHome <- getEncodeRouteHome
encodeHid <- getEncodeKeyHashid encodeHid <- getEncodeKeyHashid
let deps = Collection let deps = Collection
{ collectionId = encodeRouteLocal here { collectionId = encodeRouteLocal here
, collectionType = CollectionTypeUnordered , collectionType = CollectionTypeUnordered
, collectionTotalItems = Just $ length tdids , collectionTotalItems = Just $ length locals + length remotes
, collectionCurrent = Nothing , collectionCurrent = Nothing
, collectionFirst = Nothing , collectionFirst = Nothing
, collectionLast = Nothing , collectionLast = Nothing
, collectionItems = , collectionItems =
map (encodeRouteHome . TicketDepR . encodeHid . E.unValue) map (encodeRouteHome . TicketDepR . encodeHid) locals ++
tdids map (\ (E.Value h, E.Value lu) -> ObjURI h lu) remotes
} }
provideHtmlAndAP deps $ redirectToPrettyJSON here provideHtmlAndAP deps $ redirectToPrettyJSON here
where
getLocals ltid =
map (ticketDependencyChildLocalDep . entityVal) <$>
selectList [TicketDependencyChildLocalChild ==. ltid] []
getRemotes ltid =
E.select $ E.from $ \ (rtd `E.InnerJoin` ro `E.InnerJoin` i) -> do
E.on $ ro E.^. RemoteObjectInstance E.==. i E.^. InstanceId
E.on $ rtd E.^. RemoteTicketDependencyIdent E.==. ro E.^. RemoteObjectId
E.where_ $ rtd E.^. RemoteTicketDependencyChild E.==. E.val ltid
return (i E.^. InstanceHost, ro E.^. RemoteObjectIdent)
data WorkItem
= WorkItemSharerTicket ShrIdent TicketAuthorLocalId Bool
| WorkItemProjectTicket ShrIdent PrjIdent LocalTicketId
| WorkItemRepoPatch ShrIdent RpIdent LocalTicketId
deriving Eq
getWorkItemRoute
:: (MonadSite m, YesodHashids (SiteEnv m)) => WorkItem -> m (Route App)
getWorkItemRoute wi = ($ wi) <$> askWorkItemRoute
askWorkItemRoute
:: (MonadSite m, YesodHashids (SiteEnv m)) => m (WorkItem -> Route App)
askWorkItemRoute = do
hashTALID <- getEncodeKeyHashid
hashLTID <- getEncodeKeyHashid
let route (WorkItemSharerTicket shr talid False) = SharerTicketR shr (hashTALID talid)
route (WorkItemSharerTicket shr talid True) = SharerPatchR shr (hashTALID talid)
route (WorkItemProjectTicket shr prj ltid) = ProjectTicketR shr prj (hashLTID ltid)
route (WorkItemRepoPatch shr rp ltid) = RepoPatchR shr rp (hashLTID ltid)
return route
getWorkItem :: MonadIO m => LocalTicketId -> ReaderT SqlBackend m WorkItem
getWorkItem ltid = (either error return =<<) $ runExceptT $ do
lt <- lift $ getJust ltid
let tid = localTicketTicket lt
metal <- lift $ getBy $ UniqueTicketAuthorLocal ltid
mremoteContext <-
case metal of
Nothing -> return Nothing
Just (Entity talid _) -> lift $ do
metcr <- getBy (UniqueTicketProjectRemote talid)
for metcr $ \ etcr ->
(etcr,) . (> 0) <$> count [PatchTicket ==. tid]
mlocalContext <- do
metcl <- lift $ getBy $ UniqueTicketContextLocal tid
for metcl $ \ etcl@(Entity tclid _) -> do
npatches <- lift $ count [PatchTicket ==. tid]
metpl <- lift $ getBy $ UniqueTicketProjectLocal tclid
metrl <- lift $ getBy $ UniqueTicketRepoLocal tclid
case (metpl, metrl) of
(Nothing, Nothing) -> throwE "TCL but no TPL and no TRL"
(Just etpl, Nothing) -> do
when (npatches > 0) $ throwE "TPL but patches attached"
return (etcl, Left etpl)
(Nothing, Just etrl) -> do
when (npatches < 1) $ throwE "TRL but no patches attached"
return (etcl, Right etrl)
(Just _, Just _) -> throwE "Both TPL and TRL"
metar <-
case mlocalContext of
Nothing -> return Nothing
Just (Entity tclid _, _) ->
lift $ getBy $ UniqueTicketAuthorRemote tclid
mert <-
case metar of
Nothing -> return Nothing
Just (Entity tarid _) -> lift $ getBy $ UniqueRemoteTicket tarid
metuc <-
case (metal, mlocalContext) of
(Nothing, Nothing) -> return Nothing
(Just (Entity talid _), Nothing) -> do
mtuc <- lift $ getBy $ UniqueTicketUnderProjectAuthor talid
for mtuc $ \ _ -> throwE "No TCL, but TUC exists for TAL"
(Nothing, Just (Entity tclid _, _)) -> do
mtuc <- lift $ getBy $ UniqueTicketUnderProjectProject tclid
for mtuc $ \ _ -> throwE "No TAL, but TUC exists for TCL"
(Just (Entity talid _), Just (Entity tclid _, _)) -> do
metuc1 <- lift $ getBy $ UniqueTicketUnderProjectAuthor talid
mtucid2 <- lift $ getKeyBy $ UniqueTicketUnderProjectProject tclid
case (metuc1, mtucid2) of
(Nothing, Nothing) -> return Nothing
(Just _, Nothing) -> throwE "TAL has TUC, TCL doesn't"
(Nothing, Just _) -> throwE "TCL has TUC, TAL doesn't"
(Just etuc, Just tucid) ->
if entityKey etuc == tucid
then return $ Just etuc
else throwE "TAL and TCL have different TUCs"
verifyNothingE mert "Ticket has both LT and RT"
case (mremoteContext, metal, mlocalContext, metar) of
(Nothing, Just etal, Just (_, ctx), Nothing) ->
lift $
case metuc of
Nothing -> authorHosted etal (isRight ctx)
Just _ -> contextHosted ctx
(Nothing, Nothing, Just (_, ctx), Just _) -> lift $ contextHosted ctx
(Just (_, patch), Just etal, Nothing, Nothing) ->
lift $ authorHosted etal patch
_ -> throwE "Invalid/unexpected context/author situation"
where
contextHosted (Left (Entity _ tpl)) = do
j <- getJust $ ticketProjectLocalProject tpl
s <- getJust $ projectSharer j
return $ WorkItemProjectTicket (sharerIdent s) (projectIdent j) ltid
contextHosted (Right (Entity _ trl)) = do
r <- getJust $ ticketRepoLocalRepo trl
s <- getJust $ repoSharer r
return $ WorkItemRepoPatch (sharerIdent s) (repoIdent r) ltid
authorHosted (Entity talid tal) patch = do
p <- getJust $ ticketAuthorLocalAuthor tal
s <- getJust $ personIdent p
return $ WorkItemSharerTicket (sharerIdent s) talid patch

62
src/Web/ActivityPub.hs
View file

@ -61,6 +61,7 @@ module Web.ActivityPub
, CreateObject (..) , CreateObject (..)
, Create (..) , Create (..)
, Follow (..) , Follow (..)
, OfferObject (..)
, Offer (..) , Offer (..)
, Push (..) , Push (..)
, Reject (..) , Reject (..)
@ -84,6 +85,7 @@ module Web.ActivityPub
, httpPostAP , httpPostAP
, httpPostAPBytes , httpPostAPBytes
, Fetched (..) , Fetched (..)
, fetchAP
, fetchAPID , fetchAPID
, fetchAPID' , fetchAPID'
, fetchRecipient , fetchRecipient
@ -91,6 +93,8 @@ module Web.ActivityPub
, fetchUnknownKey , fetchUnknownKey
, fetchKnownPersonalKey , fetchKnownPersonalKey
, fetchKnownSharedKey , fetchKnownSharedKey
, Obj (..)
) )
where where
@ -733,7 +737,6 @@ data Relationship u = Relationship
, relationshipAttributedTo :: LocalURI , relationshipAttributedTo :: LocalURI
, relationshipPublished :: Maybe UTCTime , relationshipPublished :: Maybe UTCTime
, relationshipUpdated :: Maybe UTCTime , relationshipUpdated :: Maybe UTCTime
, relationshipSummary :: TextHtml
} }
instance ActivityPub Relationship where instance ActivityPub Relationship where
@ -755,11 +758,10 @@ instance ActivityPub Relationship where
<*> pure attributedTo <*> pure attributedTo
<*> o .:? "published" <*> o .:? "published"
<*> o .:? "updated" <*> o .:? "updated"
<*> (TextHtml . sanitizeBalance <$> o .: "summary")
toSeries authority toSeries authority
(Relationship id_ typs subject property object attributedTo published (Relationship id_ typs subject property object attributedTo published
updated summary) updated)
= "id" .=? id_ = "id" .=? id_
<> "type" .= ("Relationship" : typs) <> "type" .= ("Relationship" : typs)
<> "subject" .= subject <> "subject" .= subject
@ -768,7 +770,6 @@ instance ActivityPub Relationship where
<> "attributedTo" .= ObjURI authority attributedTo <> "attributedTo" .= ObjURI authority attributedTo
<> "published" .=? published <> "published" .=? published
<> "updated" .=? updated <> "updated" .=? updated
<> "summary" .= summary
data TicketDependency u = TicketDependency data TicketDependency u = TicketDependency
{ ticketDepId :: Maybe (ObjURI u) { ticketDepId :: Maybe (ObjURI u)
@ -777,7 +778,6 @@ data TicketDependency u = TicketDependency
, ticketDepAttributedTo :: LocalURI , ticketDepAttributedTo :: LocalURI
, ticketDepPublished :: Maybe UTCTime , ticketDepPublished :: Maybe UTCTime
, ticketDepUpdated :: Maybe UTCTime , ticketDepUpdated :: Maybe UTCTime
, ticketDepSummary :: TextHtml
} }
instance ActivityPub TicketDependency where instance ActivityPub TicketDependency where
@ -799,7 +799,6 @@ instance ActivityPub TicketDependency where
, ticketDepAttributedTo = relationshipAttributedTo rel , ticketDepAttributedTo = relationshipAttributedTo rel
, ticketDepPublished = relationshipPublished rel , ticketDepPublished = relationshipPublished rel
, ticketDepUpdated = relationshipUpdated rel , ticketDepUpdated = relationshipUpdated rel
, ticketDepSummary = relationshipSummary rel
} }
toSeries a = toSeries a . td2rel toSeries a = toSeries a . td2rel
@ -813,7 +812,6 @@ instance ActivityPub TicketDependency where
, relationshipAttributedTo = ticketDepAttributedTo td , relationshipAttributedTo = ticketDepAttributedTo td
, relationshipPublished = ticketDepPublished td , relationshipPublished = ticketDepPublished td
, relationshipUpdated = ticketDepUpdated td , relationshipUpdated = ticketDepUpdated td
, relationshipSummary = ticketDepSummary td
} }
newtype TextHtml = TextHtml newtype TextHtml = TextHtml
@ -893,6 +891,7 @@ parseTicketLocal o = do
Nothing -> do Nothing -> do
verifyNothing "replies" verifyNothing "replies"
verifyNothing "participants" verifyNothing "participants"
verifyNothing "followers"
verifyNothing "team" verifyNothing "team"
verifyNothing "history" verifyNothing "history"
verifyNothing "dependencies" verifyNothing "dependencies"
@ -903,7 +902,7 @@ parseTicketLocal o = do
TicketLocal TicketLocal
<$> pure id_ <$> pure id_
<*> withAuthorityO a (o .: "replies") <*> withAuthorityO a (o .: "replies")
<*> withAuthorityO a (o .: "participants") <*> withAuthorityO a (o .: "participants" <|> o .: "followers")
<*> withAuthorityMaybeO a (o .:? "team") <*> withAuthorityMaybeO a (o .:? "team")
<*> withAuthorityO a (o .: "history") <*> withAuthorityO a (o .: "history")
<*> withAuthorityO a (o .: "dependencies") <*> withAuthorityO a (o .: "dependencies")
@ -916,10 +915,10 @@ parseTicketLocal o = do
encodeTicketLocal :: UriMode u => Authority u -> TicketLocal -> Series encodeTicketLocal :: UriMode u => Authority u -> TicketLocal -> Series
encodeTicketLocal encodeTicketLocal
a (TicketLocal id_ replies participants team events deps rdeps) a (TicketLocal id_ replies followers team events deps rdeps)
= "id" .= ObjURI a id_ = "id" .= ObjURI a id_
<> "replies" .= ObjURI a replies <> "replies" .= ObjURI a replies
<> "participants" .= ObjURI a participants <> "followers" .= ObjURI a followers
<> "team" .=? (ObjURI a <$> team) <> "team" .=? (ObjURI a <$> team)
<> "history" .= ObjURI a events <> "history" .= ObjURI a events
<> "dependencies" .= ObjURI a deps <> "dependencies" .= ObjURI a deps
@ -1220,23 +1219,38 @@ encodeFollow (Follow obj mcontext hide)
<> "context" .=? mcontext <> "context" .=? mcontext
<> "hide" .= hide <> "hide" .= hide
data OfferObject u = OfferTicket (Ticket u) | OfferDep (TicketDependency u)
instance ActivityPub OfferObject where
jsonldContext = error "jsonldContext OfferObject"
parseObject o
= second OfferTicket <$> parseObject o
<|> second OfferDep <$> parseObject o
toSeries h (OfferTicket t) = toSeries h t
toSeries h (OfferDep d) = toSeries h d
data Offer u = Offer data Offer u = Offer
{ offerObject :: Ticket u { offerObject :: OfferObject u
, offerTarget :: ObjURI u , offerTarget :: ObjURI u
} }
parseOffer :: UriMode u => Object -> Authority u -> LocalURI -> Parser (Offer u) parseOffer :: UriMode u => Object -> Authority u -> LocalURI -> Parser (Offer u)
parseOffer o a luActor = do parseOffer o a luActor = do
ticket <- withAuthorityT a $ parseObject =<< o .: "object" obj <- withAuthorityT a $ parseObject =<< o .: "object"
target@(ObjURI hTarget luTarget) <- o .: "target"
case obj of
OfferTicket ticket -> do
unless (luActor == ticketAttributedTo ticket) $ unless (luActor == ticketAttributedTo ticket) $
fail "Offer actor != Ticket attrib" fail "Offer actor != Ticket attrib"
target@(ObjURI hTarget luTarget) <- o .: "target"
for_ (ticketContext ticket) $ \ (ObjURI hContext luContext) -> do for_ (ticketContext ticket) $ \ (ObjURI hContext luContext) -> do
unless (hTarget == hContext) $ unless (hTarget == hContext) $
fail "Offer target host != Ticket context host" fail "Offer target host != Ticket context host"
unless (luTarget == luContext) $ unless (luTarget == luContext) $
fail "Offer target != Ticket context" fail "Offer target != Ticket context"
return $ Offer ticket target OfferDep dep -> do
unless (luActor == ticketDepAttributedTo dep) $
fail "Offer actor != TicketDependency attrib"
return $ Offer obj target
encodeOffer :: UriMode u => Authority u -> LocalURI -> Offer u -> Series encodeOffer :: UriMode u => Authority u -> LocalURI -> Offer u -> Series
encodeOffer authority actor (Offer obj target) encodeOffer authority actor (Offer obj target)
@ -1821,3 +1835,23 @@ fetchKnownSharedKey manager malgo host luActor luKey = do
-> Either (PublicKey u) (Actor u) -> Either (PublicKey u) (Actor u)
-> Either (PublicKey u) (Actor u) -> Either (PublicKey u) (Actor u)
asKeyOrActor _ = id asKeyOrActor _ = id
data Obj u = Obj
{ objId :: ObjURI u
, objType :: Text
, objContext :: Maybe (ObjURI u)
, objFollowers :: Maybe LocalURI
, objInbox :: Maybe LocalURI
, objTeam :: Maybe LocalURI
}
instance UriMode u => FromJSON (Obj u) where
parseJSON = withObject "Obj" $ \ o -> do
id_@(ObjURI h _) <- o .: "id" <|> o .: "@id"
Obj id_
<$> (o .: "type" <|> o .: "@type")
<*> o .:? "context"
<*> withAuthorityMaybeO h (o .:? "followers")
<*> withAuthorityMaybeO h (o .:? "inbox")
<*> withAuthorityMaybeO h (o .:? "team")

36
src/Yesod/MonadSite.hs
View file

@ -1,6 +1,6 @@
{- This file is part of Vervis. {- This file is part of Vervis.
- -
- Written in 2019 by fr33domlover <fr33domlover@riseup.net>. - Written in 2019, 2020 by fr33domlover <fr33domlover@riseup.net>.
- -
- ♡ Copying is an act of love. Please copy, reuse and share. - ♡ Copying is an act of love. Please copy, reuse and share.
- -
@ -22,6 +22,8 @@ module Yesod.MonadSite
, askUrlRender , askUrlRender
, asksSite , asksSite
, runSiteDB , runSiteDB
, runSiteDBExcept
, runDBExcept
, WorkerT () , WorkerT ()
, runWorkerT , runWorkerT
, WorkerFor , WorkerFor
@ -31,7 +33,6 @@ module Yesod.MonadSite
) )
where where
import Control.Exception
import Control.Monad.Fail import Control.Monad.Fail
import Control.Monad.IO.Class import Control.Monad.IO.Class
import Control.Monad.IO.Unlift import Control.Monad.IO.Unlift
@ -44,6 +45,7 @@ import Data.Functor
import Data.Text (Text) import Data.Text (Text)
import Database.Persist.Sql import Database.Persist.Sql
import UnliftIO.Async import UnliftIO.Async
import UnliftIO.Exception
import UnliftIO.Concurrent import UnliftIO.Concurrent
import Yesod.Core hiding (logError) import Yesod.Core hiding (logError)
import Yesod.Core.Types import Yesod.Core.Types
@ -104,6 +106,36 @@ runSiteDB action = do
site <- askSite site <- askSite
runPool (sitePersistConfig site) action (sitePersistPool site) runPool (sitePersistConfig site) action (sitePersistPool site)
newtype FedError = FedError Text deriving Show
instance Exception FedError
runSiteDBExcept
:: ( MonadUnliftIO m
, MonadSite m
, SiteEnv m ~ site
, Site site
, MonadIO (PersistConfigBackend (SitePersistConfig site) m)
)
=> ExceptT Text (PersistConfigBackend (SitePersistConfig site) m) a
-> ExceptT Text m a
runSiteDBExcept action = do
result <-
lift $ try $ runSiteDB $ either abort return =<< runExceptT action
case result of
Left (FedError t) -> throwE t
Right r -> return r
where
abort = throwIO . FedError
runDBExcept
:: ( Site site
, MonadIO (PersistConfigBackend (SitePersistConfig site) (HandlerFor site))
)
=> ExceptT Text (PersistConfigBackend (SitePersistConfig site) (HandlerFor site)) a
-> ExceptT Text (HandlerFor site) a
runDBExcept = runSiteDBExcept
instance MonadSite (HandlerFor site) where instance MonadSite (HandlerFor site) where
type SiteEnv (HandlerFor site) = site type SiteEnv (HandlerFor site) = site
askSite = getYesod askSite = getYesod

40
templates/ticket/dep/list.hamlet
View file

@ -1,40 +0,0 @@
$# This file is part of Vervis.
$#
$# Written in 2016, 2018, 2019, 2020 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/>.
<table>
<tr>
<th>Number
<th>Author
<th>Title
<th>Status
$if forward
<th>Remove dependency
$forall (tid, author, title, status) <- rows
<tr>
<td>
<a href=@{ProjectTicketR shr prj $ encodeHid tid}>###
<td>
^{sharerLinkFedW author}
<td>
<a href=@{ProjectTicketR shr prj $ encodeHid tid}>#{title}
<td>
#{show status}
$if forward
<td>
^{buttonW DELETE "Remove" (TicketDepOldR shr prj ltkhid $ encodeHid tid)}
$if forward
<p>
<a href=@{ProjectTicketDepNewR shr prj ltkhid}>
Add new…

18
templates/ticket/dep/new.hamlet
View file

@ -1,18 +0,0 @@
$# This file is part of Vervis.
$#
$# Written in 2016, 2020 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/>.
<form method=POST action=@{ProjectTicketDepsR shr prj ltkhid} enctype=#{enctype}>
^{widget}
<div class="submit">
<input type="submit">

22
templates/ticket/one.hamlet
View file

@ -37,28 +37,6 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
^{followButton} ^{followButton}
<p>
Depended by:
<ul>
$if null rdeps
<li>(none)
$else
$forall (E.Value ltid, Entity _ t) <- rdeps
<li>
^{ticketDepW shar proj ltid t}
<p>
Depends on:
<ul>
$if null deps
<li>(none)
$else
$forall (E.Value ltid, Entity _ t) <- deps
<li>
^{ticketDepW shar proj ltid t}
<div>^{desc} <div>^{desc}
$if ticketStatus ticket /= TSClosed $if ticketStatus ticket /= TSClosed

1
vervis.cabal
View file

@ -134,6 +134,7 @@ library
Vervis.Federation.Offer Vervis.Federation.Offer
Vervis.Federation.Push Vervis.Federation.Push
Vervis.Federation.Ticket Vervis.Federation.Ticket
Vervis.Federation.Util
Vervis.FedURI Vervis.FedURI
Vervis.Field.Key Vervis.Field.Key
Vervis.Field.Person Vervis.Field.Person