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
content Text
TicketDependency
parent TicketId
child TicketId
author PersonId
summary Text -- HTML
created UTCTime
RemoteTicketDependency
ident RemoteObjectId
child LocalTicketId
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
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
{ localUriPath :: Text
}
deriving (Eq, Generic)
deriving (Eq, Ord, Generic)
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
repoSet <- lookup rp $ localRecipRepoRelated sharerSet
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
j <- getJust $ ticketProjectLocalProject tpl
s <- getJust $ projectSharer j
@ -1005,9 +998,10 @@ offerTicketC
:: ShrIdent
-> TextHtml
-> Audience URIMode
-> Offer URIMode
-> AP.Ticket URIMode
-> FedURI
-> 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
{-deps <- -}
checkOffer hProject shrProject prjProject
@ -1085,7 +1079,8 @@ offerTicketC shrUser summary audience offer@(Offer ticket uTarget) = runExceptT
, activityActor = AP.ticketAttributedTo ticket
, activitySummary = Just summary
, activityAudience = audience
, activitySpecific = OfferActivity offer
, activitySpecific =
OfferActivity $ Offer (OfferTicket ticket) uTarget
}
obiid <- insert OutboxItem
{ outboxItemOutbox = obid

127
src/Vervis/ActivityPub.hs
View file

@ -19,7 +19,6 @@ module Vervis.ActivityPub
, verifyHostLocal
, parseContext
, parseParent
, runDBExcept
, getLocalParentMessageId
, getPersonOrGroupId
, getTicketTeam
@ -43,13 +42,16 @@ module Vervis.ActivityPub
--, checkDep
, getProjectAndDeps
, deliverRemoteDB'
, deliverRemoteDB''
, deliverRemoteHttp
, deliverRemoteHttp'
, serveCommit
, deliverLocal
, RemoteRecipient (..)
, deliverLocal'
, insertRemoteActivityToLocalInboxes
, provideEmptyCollection
, insertEmptyOutboxItem
)
where
@ -194,20 +196,6 @@ parseParent uParent = do
_ -> throwE "Local parent isn't a message route"
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 did shr lmid = do
mlm <- lift $ get lmid
@ -328,14 +316,14 @@ deliverHttpBL body mfwd h luInbox =
deliverActivityBL' (ObjURI h luInbox) (ObjURI h <$> mfwd) body
deliverRemoteDB_
:: PersistRecordBackend fwder SqlBackend
:: (MonadIO m, PersistRecordBackend fwder SqlBackend)
=> (ForwardingId -> Key sender -> fwder)
-> BL.ByteString
-> RemoteActivityId
-> Key sender
-> ByteString
-> [((InstanceId, Host), NonEmpty RemoteRecipient)]
-> AppDB
-> ReaderT SqlBackend m
[((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, ForwardingId, Key fwder))]
deliverRemoteDB_ makeFwder body ractid senderKey sig recips = do
let body' = BL.toStrict body
@ -353,32 +341,35 @@ deliverRemoteDB_ makeFwder body ractid senderKey sig recips = do
noError ((RemoteRecipient _ _ _ (Just _), _ ), _ ) = Nothing
deliverRemoteDB_J
:: BL.ByteString
:: MonadIO m
=> BL.ByteString
-> RemoteActivityId
-> ProjectId
-> ByteString
-> [((InstanceId, Host), NonEmpty RemoteRecipient)]
-> AppDB
-> ReaderT SqlBackend m
[((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, ForwardingId, ForwarderProjectId))]
deliverRemoteDB_J = deliverRemoteDB_ ForwarderProject
deliverRemoteDB_S
:: BL.ByteString
:: MonadIO m
=> BL.ByteString
-> RemoteActivityId
-> SharerId
-> ByteString
-> [((InstanceId, Host), NonEmpty RemoteRecipient)]
-> AppDB
-> ReaderT SqlBackend m
[((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, ForwardingId, ForwarderSharerId))]
deliverRemoteDB_S = deliverRemoteDB_ ForwarderSharer
deliverRemoteDB_R
:: BL.ByteString
:: MonadIO m
=> BL.ByteString
-> RemoteActivityId
-> RepoId
-> ByteString
-> [((InstanceId, Host), NonEmpty RemoteRecipient)]
-> AppDB
-> ReaderT SqlBackend m
[((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, ForwardingId, ForwarderRepoId))]
deliverRemoteDB_R = deliverRemoteDB_ ForwarderRepo
@ -554,7 +545,20 @@ deliverRemoteDB'
, [((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
let lus' = NE.nub lus
(iid, inew) <- idAndNew <$> insertBy' (Instance h)
@ -584,16 +588,16 @@ deliverRemoteDB' hContext obid recips known = do
stillUnknown = mapMaybe (\ (i, (_, _, uk)) -> (i,) <$> uk) recips'
allFetched = unionRemotes known moreKnown
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
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
unknownDeliv <- for stillUnknown $ \ (i, lus) -> do
-- TODO maybe for URA insertion we should do insertUnique?
ros <- insertMany' (\ lu -> RemoteObject (fst i) lu) lus
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
return
( takeNoError4 fetchedDeliv
@ -622,10 +626,21 @@ deliverRemoteHttp
, [((InstanceId, Host), NonEmpty (UnfetchedRemoteActorId, LocalURI, UnlinkedDeliveryId))]
)
-> 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"
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
now <- liftIO getCurrentTime
logDebug' $
@ -831,7 +846,10 @@ data RemoteRecipient = RemoteRecipient
-- * If collections are listed, insert activity to the local members and return
-- the remote members
insertActivityToLocalInboxes
:: PersistRecordBackend record SqlBackend
:: ( MonadSite m
, YesodHashids (SiteEnv m)
, PersistRecordBackend record SqlBackend
)
=> (InboxId -> InboxItemId -> record)
-- ^ Database record to insert as an new inbox item to each inbox
-> Bool
@ -846,7 +864,7 @@ insertActivityToLocalInboxes
-- listed in the recipient set. This is meant to be the activity's
-- author.
-> LocalRecipientSet
-> AppDB [((InstanceId, Host), NonEmpty RemoteRecipient)]
-> ReaderT SqlBackend m [((InstanceId, Host), NonEmpty RemoteRecipient)]
insertActivityToLocalInboxes makeInboxItem requireOwner mauthor mibidAuthor recips = do
ibidsSharer <- deleteAuthor <$> getSharerInboxes recips
ibidsOther <- concat <$> traverse getOtherInboxes recips
@ -876,7 +894,8 @@ insertActivityToLocalInboxes makeInboxItem requireOwner mauthor mibidAuthor reci
Nothing -> id
Just ibidAuthor -> L.delete ibidAuthor
getSharerInboxes :: LocalRecipientSet -> AppDB [InboxId]
getSharerInboxes
:: MonadIO m => LocalRecipientSet -> ReaderT SqlBackend m [InboxId]
getSharerInboxes sharers = do
let shrs =
[shr | (shr, s) <- sharers
@ -885,7 +904,9 @@ insertActivityToLocalInboxes makeInboxItem requireOwner mauthor mibidAuthor reci
sids <- selectKeysList [SharerIdent <-. shrs] []
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
msid <- getKeyBy $ UniqueSharer shr
case msid of
@ -910,7 +931,9 @@ insertActivityToLocalInboxes makeInboxItem requireOwner mauthor mibidAuthor reci
in map (repoInbox . entityVal) <$>
selectList [RepoSharer ==. sid, RepoIdent <-. rps] []
getSharerFollowerSets :: LocalRecipientSet -> AppDB [FollowerSetId]
getSharerFollowerSets
:: MonadIO m
=> LocalRecipientSet -> ReaderT SqlBackend m [FollowerSetId]
getSharerFollowerSets sharers = do
let shrs =
[shr | (shr, s) <- sharers
@ -921,7 +944,10 @@ insertActivityToLocalInboxes makeInboxItem requireOwner mauthor mibidAuthor reci
sids <- selectKeysList [SharerIdent <-. shrs] []
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
msid <- getKeyBy $ UniqueSharer shr
case msid of
@ -1043,7 +1069,8 @@ insertActivityToLocalInboxes makeInboxItem requireOwner mauthor mibidAuthor reci
)
return $ lt E.^. LocalTicketFollowers
getLocalFollowers :: [FollowerSetId] -> AppDB [InboxId]
getLocalFollowers
:: MonadIO m => [FollowerSetId] -> ReaderT SqlBackend m [InboxId]
getLocalFollowers fsids = do
pids <-
map (followPerson . entityVal) <$>
@ -1051,7 +1078,11 @@ insertActivityToLocalInboxes makeInboxItem requireOwner mauthor mibidAuthor reci
map (personInbox . entityVal) <$>
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 =
fmap groupRemotes $
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
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
msid <- getKeyBy $ UniqueSharer shr
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
-- the remote members
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
-> InboxId
-> OutboxItemId
-> LocalRecipientSet
-> AppDB [((InstanceId, Host), NonEmpty RemoteRecipient)]
-> ReaderT SqlBackend m [((InstanceId, Host), NonEmpty RemoteRecipient)]
deliverLocal' requireOwner author ibidAuthor obiid =
insertActivityToLocalInboxes makeItem requireOwner (Just author) (Just ibidAuthor)
where
makeItem ibid ibiid = InboxItemLocal ibid obiid ibiid
insertRemoteActivityToLocalInboxes
:: Bool
:: (MonadSite m, YesodHashids (SiteEnv m))
=> Bool
-> RemoteActivityId
-> LocalRecipientSet
-> AppDB [((InstanceId, Host), NonEmpty RemoteRecipient)]
-> ReaderT SqlBackend m [((InstanceId, Host), NonEmpty RemoteRecipient)]
insertRemoteActivityToLocalInboxes requireOwner ractid =
insertActivityToLocalInboxes makeItem requireOwner Nothing Nothing
where
@ -1149,3 +1184,11 @@ provideEmptyCollection typ here = do
, collectionItems = [] :: [Text]
}
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
, localRecipSieve
, localRecipSieve'
, Aud (..)
, collectAudience
)
where
@ -46,11 +49,13 @@ import Data.Foldable
import Data.List ((\\))
import Data.List.NonEmpty (NonEmpty, nonEmpty)
import Data.Maybe
import Data.Semigroup
import Data.Text (Text)
import Data.These
import Data.Traversable
import qualified Data.List.NonEmpty as NE
import qualified Data.List.Ordered as LO
import qualified Data.Text as T
import Network.FedURI
@ -84,7 +89,7 @@ data LocalActor
= LocalActorSharer ShrIdent
| LocalActorProject ShrIdent PrjIdent
| LocalActorRepo ShrIdent RpIdent
deriving Eq
deriving (Eq, Ord)
parseLocalActor :: Route App -> Maybe LocalActor
parseLocalActor (SharerR shr) = Just $ LocalActorSharer shr
@ -111,7 +116,7 @@ data LocalPersonCollection
| LocalPersonCollectionRepoTeam ShrIdent RpIdent
| LocalPersonCollectionRepoFollowers ShrIdent RpIdent
| LocalPersonCollectionRepoPatchFollowers ShrIdent RpIdent (KeyHashid LocalTicket)
deriving Eq
deriving (Eq, Ord)
parseLocalPersonCollection
:: Route App -> Maybe LocalPersonCollection
@ -592,3 +597,38 @@ localRecipSieve' sieve allowSharers allowOthers =
where
applyRepo (LocalRepoDirectSet r' t' f') (LocalRepoDirectSet r t 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
:: (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
encodeRouteLocal <- getEncodeRouteLocal
encodeRouteHome <- getEncodeRouteHome
@ -243,10 +243,7 @@ offerTicket shrAuthor (TextHtml title) (TextPandocMarkdown desc) shr prj = runEx
, AP.ticketIsResolved = False
, AP.ticketAttachment = Nothing
}
offer = Offer
{ offerObject = ticket
, offerTarget = encodeRouteHome $ ProjectR shr prj
}
target = encodeRouteHome $ ProjectR shr prj
audience = Audience
{ audienceTo = map encodeRouteHome $ recipsA ++ recipsC
, audienceBto = []
@ -255,7 +252,7 @@ offerTicket shrAuthor (TextHtml title) (TextPandocMarkdown desc) shr prj = runEx
, audienceGeneral = []
, audienceNonActors = map encodeRouteHome recipsC
}
return (summary, audience, offer)
return (summary, audience, ticket, target)
createTicket
:: (MonadHandler m, HandlerSite m ~ App, MonadSite m, SiteEnv m ~ App)
@ -330,7 +327,7 @@ undoFollow
undoFollow shrAuthor pidAuthor getFsid typ objRoute recipRoute = runExceptT $ do
encodeRouteLocal <- getEncodeRouteLocal
encodeRouteHome <- getEncodeRouteHome
obiidFollow <- runDBExcept $ do
obiidFollow <- runSiteDBExcept $ do
fsid <- getFsid
mf <- lift $ getValBy $ UniqueFollow pidAuthor fsid
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"
handleSharerInbox
:: UTCTime
-> ShrIdent
:: ShrIdent
-> UTCTime
-> ActivityAuthentication
-> ActivityBody
-> ExceptT Text Handler Text
handleSharerInbox _now shrRecip (ActivityAuthLocal (ActivityAuthLocalPerson pidAuthor)) body = do
-> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text))
handleSharerInbox shrRecip _now (ActivityAuthLocal (ActivityAuthLocalPerson pidAuthor)) body = (,Nothing) <$> do
(shrActivity, obiid) <- do
luAct <-
fromMaybeE
@ -174,7 +174,7 @@ handleSharerInbox _now shrRecip (ActivityAuthLocal (ActivityAuthLocalPerson pidA
"Activity already exists in inbox of /s/" <> recip
Just _ ->
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
luAct <-
fromMaybeE
@ -218,7 +218,7 @@ handleSharerInbox _now shrRecip (ActivityAuthLocal (ActivityAuthLocalProject jid
"Activity already exists in inbox of /s/" <> recip
Just _ ->
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
luAct <-
fromMaybeE
@ -262,37 +262,42 @@ handleSharerInbox _now shrRecip (ActivityAuthLocal (ActivityAuthLocalRepo ridAut
"Activity already exists in inbox of /s/" <> recip
Just _ ->
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
AcceptActivity accept ->
sharerAcceptF shrRecip now author body accept
(,Nothing) <$> sharerAcceptF shrRecip now author body accept
CreateActivity (Create obj mtarget) ->
case obj of
CreateNote note ->
sharerCreateNoteF now shrRecip author body note
(,Nothing) <$> sharerCreateNoteF now shrRecip author body note
CreateTicket ticket ->
sharerCreateTicketF now shrRecip author body ticket mtarget
_ -> return "Unsupported create object type for sharers"
(,Nothing) <$> sharerCreateTicketF now shrRecip author body ticket mtarget
_ -> return ("Unsupported create object type for sharers", Nothing)
FollowActivity follow ->
sharerFollowF shrRecip now author body follow
OfferActivity offer ->
sharerOfferTicketF now shrRecip author body offer
(,Nothing) <$> sharerFollowF shrRecip now author body follow
OfferActivity (Offer obj target) ->
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 ->
sharerPushF shrRecip now author body push
(,Nothing) <$> sharerPushF shrRecip now author body push
RejectActivity reject ->
sharerRejectF shrRecip now author body reject
(,Nothing) <$> sharerRejectF shrRecip now author body reject
UndoActivity undo ->
sharerUndoF shrRecip now author body undo
_ -> return "Unsupported activity type for sharers"
(,Nothing) <$> sharerUndoF shrRecip now author body undo
_ -> return ("Unsupported activity type for sharers", Nothing)
handleProjectInbox
:: UTCTime
-> ShrIdent
:: ShrIdent
-> PrjIdent
-> UTCTime
-> ActivityAuthentication
-> ActivityBody
-> ExceptT Text Handler Text
handleProjectInbox now shrRecip prjRecip auth body = do
-> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text))
handleProjectInbox shrRecip prjRecip now auth body = (,Nothing) <$> do
remoteAuthor <-
case auth of
ActivityAuthLocal local -> throwE $ errorLocalForwarded local
@ -307,8 +312,11 @@ handleProjectInbox now shrRecip prjRecip auth body = do
_ -> error "Unsupported create object type for projects"
FollowActivity follow ->
projectFollowF shrRecip prjRecip now remoteAuthor body follow
OfferActivity offer ->
projectOfferTicketF now shrRecip prjRecip remoteAuthor body offer
OfferActivity (Offer obj target) ->
case obj of
OfferTicket ticket ->
projectOfferTicketF now shrRecip prjRecip remoteAuthor body ticket target
_ -> return "Unsupported offer object type for projects"
UndoActivity undo ->
projectUndoF shrRecip prjRecip now remoteAuthor body undo
_ -> return "Unsupported activity type for projects"
@ -324,13 +332,13 @@ handleProjectInbox now shrRecip prjRecip auth body = do
T.pack (show $ fromSqlKey rid)
handleRepoInbox
:: UTCTime
-> ShrIdent
:: ShrIdent
-> RpIdent
-> UTCTime
-> ActivityAuthentication
-> ActivityBody
-> ExceptT Text Handler Text
handleRepoInbox now shrRecip rpRecip auth body = do
-> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text))
handleRepoInbox shrRecip rpRecip now auth body = (,Nothing) <$> do
remoteAuthor <-
case auth of
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.FedURI
import Vervis.Federation.Auth
import Vervis.Federation.Util
import Vervis.Foundation
import Vervis.Model
import Vervis.Model.Ident
@ -100,32 +101,6 @@ checkNote (Note mluNote _ _ muParent muCtx mpub source content) = do
else Just <$> parseParent uParent
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
-- know and have this parent note in the DB, and whether the child and parent
-- belong to the same discussion root.

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

@ -19,6 +19,8 @@ module Vervis.Federation.Ticket
, sharerCreateTicketF
, projectCreateTicketF
, sharerOfferDepF
)
where
@ -30,6 +32,7 @@ import Control.Monad.Trans.Except
import Control.Monad.Trans.Maybe
import Data.Aeson
import Data.Bifunctor
import Data.Bitraversable
import Data.Foldable
import Data.Function
import Data.List (nub, union)
@ -70,10 +73,13 @@ import Vervis.ActivityPub
import Vervis.ActivityPub.Recipient
import Vervis.FedURI
import Vervis.Federation.Auth
import Vervis.Federation.Util
import Vervis.Foundation
import Vervis.Model
import Vervis.Model.Ident
import Vervis.Model.Ticket
import Vervis.Patch
import Vervis.Ticket
checkOffer
:: AP.Ticket URIMode
@ -95,9 +101,10 @@ sharerOfferTicketF
-> ShrIdent
-> RemoteAuthor
-> ActivityBody
-> Offer URIMode
-> AP.Ticket URIMode
-> FedURI
-> 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
luOffer <- fromMaybeE (activityId $ actbActivity body) "Offer without 'id'"
{-deps <- -}
@ -192,10 +199,11 @@ projectOfferTicketF
-> PrjIdent
-> RemoteAuthor
-> ActivityBody
-> Offer URIMode
-> AP.Ticket URIMode
-> FedURI
-> ExceptT Text Handler Text
projectOfferTicketF
now shrRecip prjRecip author body (Offer ticket uTarget) = do
now shrRecip prjRecip author body ticket uTarget = do
targetIsUs <- lift $ runExceptT checkTarget
case targetIsUs of
Left t -> do
@ -737,3 +745,447 @@ projectCreateTicketF now shrRecip prjRecip author body ticket muTarget = do
delete tid
return $ Left True
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
( selectAssigneeFromProject
, selectTicketDep
--, selectTicketDep
)
where
@ -33,7 +33,7 @@ import qualified Database.Persist as P
import Database.Persist.Sql.Graph.Connects (uconnects)
import Vervis.Foundation (Handler)
import Vervis.GraphProxy (ticketDepGraph)
--import Vervis.GraphProxy (ticketDepGraph)
import Vervis.Model
import Vervis.Model.Ident (shr2text)
@ -52,6 +52,7 @@ selectAssigneeFromProject pid jid = selectField $ do
return (sharer ^. SharerIdent, person ^. PersonId)
optionsPairs $ map (shr2text . unValue *** unValue) l
{-
checkNotSelf :: TicketId -> Field Handler TicketId -> Field Handler TicketId
checkNotSelf tidP =
checkBool (/= tidP) ("A ticket can’t depend on itself" :: Text)
@ -80,3 +81,4 @@ selectTicketDep jid tid =
orderBy [asc $ t ^. TicketId]
return (t ^. TicketTitle, t ^. TicketId)
optionsPairs $ map (bimap unValue unValue) ts
-}

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

@ -20,7 +20,7 @@ module Vervis.Form.Ticket
, assignTicketForm
, claimRequestForm
, ticketFilterForm
, ticketDepForm
--, ticketDepForm
)
where
@ -273,8 +273,10 @@ ticketFilterAForm = mk
ticketFilterForm :: Form TicketFilter
ticketFilterForm = renderDivs ticketFilterAForm
{-
ticketDepAForm :: ProjectId -> TicketId -> AForm Handler TicketId
ticketDepAForm jid tid = areq (selectTicketDep jid tid) "Dependency" Nothing
ticketDepForm :: ProjectId -> TicketId -> Form TicketId
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 LocalTicketKeyHashid = KeyHashid LocalTicket
type TicketAuthorLocalKeyHashid = KeyHashid TicketAuthorLocal
type TicketDepKeyHashid = KeyHashid TicketDependency
type TicketDepKeyHashid = KeyHashid LocalTicketDependency
type PatchKeyHashid = KeyHashid Patch
-- 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.
module Vervis.GraphProxy
( GraphProxy
, ticketDepGraph
--, ticketDepGraph
)
where
@ -39,5 +39,5 @@ import Vervis.Model
type GraphProxy n e = Proxy (n, e)
ticketDepGraph :: GraphProxy Ticket TicketDependency
ticketDepGraph = Proxy
--ticketDepGraph :: GraphProxy Ticket TicketDependency
--ticketDepGraph = Proxy

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

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

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

@ -80,6 +80,7 @@ import Yesod.ActivityPub
import Yesod.Auth.Unverified
import Yesod.FedURI
import Yesod.Hashids
import Yesod.MonadSite
import Yesod.RenderSource
import Data.Aeson.Local
@ -267,65 +268,69 @@ getRepoInboxR shr rp = getInbox here getInboxId
r <- getValBy404 $ UniqueRepo rp sid
return $ repoInbox r
postSharerInboxR :: ShrIdent -> Handler ()
postSharerInboxR shrRecip = do
federation <- getsYesod $ appFederation . appSettings
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
:: (MonadSite m, SiteEnv m ~ App)
=> UTCTime -> Either Text (Object, (Text, w)) -> [ContentType] -> m ()
recordActivity now result contentTypes = do
macts <- getsYesod appActivities
macts <- asksSite appActivities
for_ macts $ \ (size, acts) ->
liftIO $ atomically $ modifyTVar' acts $ \ vec ->
let (msg, body) =
case result of
Left t -> (t, "{?}")
Right (o, t) -> (t, encodePretty o)
Right (o, (t, _)) -> (t, encodePretty o)
item = ActivityReport now msg contentTypes body
vec' = item `V.cons` vec
in if V.length vec' > size
then V.init vec'
else vec'
postProjectInboxR :: ShrIdent -> PrjIdent -> Handler ()
postProjectInboxR shrRecip prjRecip = do
handleInbox
:: ( UTCTime
-> ActivityAuthentication
-> ActivityBody
-> ExceptT Text Handler
( Text
, Maybe (ExceptT Text Worker Text)
)
)
-> Handler ()
handleInbox handler = do
federation <- getsYesod $ appFederation . appSettings
unless federation badMethod
contentTypes <- lookupHeaders "Content-Type"
now <- liftIO getCurrentTime
result <- runExceptT $ do
(auth, body) <- authenticateActivity now
(actbObject body,) <$>
handleProjectInbox now shrRecip prjRecip auth body
(actbObject body,) <$> handler now auth body
recordActivity now result contentTypes
case result of
Left _ -> sendResponseStatus badRequest400 ()
Right _ -> return ()
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 ()
postSharerInboxR :: ShrIdent -> Handler ()
postSharerInboxR shrRecip = handleInbox $ handleSharerInbox shrRecip
postProjectInboxR :: ShrIdent -> PrjIdent -> Handler ()
postProjectInboxR shr prj = handleInbox $ handleProjectInbox shr prj
postRepoInboxR :: ShrIdent -> RpIdent -> Handler ()
postRepoInboxR shrRecip rpRecip = do
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 ()
postRepoInboxR shr rp = handleInbox $ handleRepoInbox shr rp
{-
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
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
:: 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
:: 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
:: ShrIdent -> KeyHashid TicketAuthorLocal -> Handler TypedContent
@ -469,30 +468,25 @@ getRepoPatchDiscussionR shr rp ltkhid =
(_, _, _, Entity _ lt, _, _, _, _) <- getRepoPatch404 shr rp ltkhid
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
:: 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
:: 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
:: ShrIdent -> RpIdent -> KeyHashid LocalTicket -> Handler TypedContent

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

@ -129,7 +129,7 @@ import Vervis.FedURI
import Vervis.Form.Ticket
import Vervis.Foundation
import Vervis.Handler.Discussion
import Vervis.GraphProxy (ticketDepGraph)
--import Vervis.GraphProxy (ticketDepGraph)
import Vervis.Model
import Vervis.Model.Ident
import Vervis.Model.Ticket
@ -276,13 +276,15 @@ getProjectTicketsR shr prj = selectRep $ do
ticketRoute _ _ _ (Right (E.Value h, E.Value lu)) = ObjURI h lu
getProjectTicketTreeR :: ShrIdent -> PrjIdent -> Handler Html
getProjectTicketTreeR shr prj = do
getProjectTicketTreeR _shr _prj = error "Ticket tree view disabled for now"
{-
(summaries, deps) <- runDB $ do
Entity sid _ <- getBy404 $ UniqueSharer shr
Entity jid _ <- getBy404 $ UniqueProject prj sid
(,) <$> getTicketSummaries Nothing Nothing Nothing jid
<*> getTicketDepEdges jid
defaultLayout $ ticketTreeDW shr prj summaries deps
-}
getProjectTicketNewR :: ShrIdent -> PrjIdent -> Handler Html
getProjectTicketNewR shr prj = do
@ -297,8 +299,7 @@ getProjectTicketR :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler Ty
getProjectTicketR shar proj ltkhid = do
mpid <- maybeAuthId
( wshr, wfl,
author, massignee, mcloser, ticket, lticket, tparams, eparams, cparams,
deps, rdeps) <-
author, massignee, mcloser, ticket, lticket, tparams, eparams, cparams) <-
runDB $ do
(Entity sid sharer, Entity jid project, Entity tid ticket, Entity _ lticket, _etcl, _etpl, author) <- getProjectTicket404 shar proj ltkhid
(wshr, wid, wfl) <- do
@ -341,21 +342,10 @@ getProjectTicketR shar proj ltkhid = do
tparams <- getTicketTextParams tid wid
eparams <- getTicketEnumParams 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
( wshr, wfl
, author', massignee, mcloser, ticket, lticket
, tparams, eparams, cparams
, deps, rdeps
)
encodeHid <- getEncodeKeyHashid
let desc :: Widget
@ -871,94 +861,20 @@ getProjectTicketReplyR shr prj ltkhid mkhid = do
(selectDiscussionId shr prj ltkhid)
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
:: 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
:: 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
((result, widget), enctype) <- runFormPost $ ticketDepForm jid tid
case result of
@ -969,11 +885,14 @@ postProjectTicketDepsR shr prj ltkhid = do
let td = TicketDependency
{ ticketDependencyParent = tid
, ticketDependencyChild = ctid
, ticketDependencyAuthor = pidAuthor
, ticketDependencySummary = "(A ticket dependency)"
, ticketDependencyCreated = now
}
insert_ td
tdid <- insert td
insert_ TicketDependencyAuthorLocal
{ ticketDependencyAuthorLocalDep = tdid
, ticketDependencyAuthorLocalAuthor = pidAuthor
, ticketDependencyAuthorLocalOpen = obiidOffer?
}
trrFix td ticketDepGraph
setMessage "Ticket dependency added."
redirect $ ProjectTicketR shr prj ltkhid
@ -983,13 +902,16 @@ postProjectTicketDepsR shr prj ltkhid = do
FormFailure _l -> do
setMessage "Submission failed, see errors below."
defaultLayout $(widgetFile "ticket/dep/new")
-}
getProjectTicketDepNewR
:: 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
((_result, widget), enctype) <- runFormPost $ ticketDepForm jid tid
defaultLayout $(widgetFile "ticket/dep/new")
-}
postTicketDepOldR
:: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> KeyHashid LocalTicket -> Handler Html
@ -1001,7 +923,8 @@ postTicketDepOldR shr prj pnum cnum = do
deleteTicketDepOldR
:: 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
(_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
setMessage "Ticket dependency removed."
redirect $ ProjectTicketDepsR shr prj pnum
-}
getProjectTicketReverseDepsR
:: 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
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
encodeRouteHome <- getEncodeRouteHome
encodeHid <- getEncodeKeyHashid
let ticketRoute s j lt =
ProjectTicketR (sharerIdent s) (projectIdent j) (encodeHid lt)
here = TicketDepR tdkhid
wiRoute <- askWorkItemRoute
hLocal <- asksSite siteInstanceHost
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
{ ticketDepId = Just $ encodeRouteHome here
, ticketDepParent =
encodeRouteHome $ ticketRoute sParent jParent ltParent
, ticketDepParent = encodeRouteHome $ wiRoute parent
, ticketDepChild =
encodeRouteHome $ ticketRoute sChild jChild ltChild
case child of
Left wi -> encodeRouteHome $ wiRoute wi
Right (h, lu) -> ObjURI h lu
, ticketDepAttributedTo =
encodeRouteLocal $ SharerR $ sharerIdent sAuthor
, ticketDepPublished = Just $ ticketDependencyCreated td
, ticketDepUpdated = Just $ ticketDependencyCreated td
, ticketDepSummary = TextHtml $ ticketDependencySummary td
case author of
Left shr -> encodeRouteLocal $ SharerR shr
Right (_h, lu) -> lu
, ticketDepPublished = Just $ localTicketDependencyCreated td
, ticketDepUpdated = Nothing
}
provideHtmlAndAP tdepAP $ redirectToPrettyJSON here
provideHtmlAndAP' host tdepAP $ redirectToPrettyJSON here
where
getTicket tid = do
ltid <- do
mltid <- getKeyBy $ UniqueLocalTicket tid
case mltid of
Nothing -> error "No LocalTicket"
Just v -> return v
tclid <- do
mtclid <- getKeyBy $ UniqueTicketContextLocal tid
case mtclid of
Nothing -> error "No TicketContextLocal"
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
return (s, p)
here = TicketDepR tdkhid
getAuthor tdid = do
tda <- requireEitherAlt
(getValBy $ UniqueTicketDependencyAuthorLocal tdid)
(getValBy $ UniqueTicketDependencyAuthorRemote tdid)
"No TDA"
"Both TDAL and TDAR"
bitraverse
(\ tdal -> do
p <- getJust $ ticketDependencyAuthorLocalAuthor tdal
s <- getJust $ personIdent 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
:: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler TypedContent
@ -1244,26 +1184,25 @@ getSharerTicketDiscussionR shr talkhid =
(_, Entity _ lt, _, _) <- getSharerTicket404 shr talkhid
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
:: 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
:: 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
:: ShrIdent -> KeyHashid TicketAuthorLocal -> Handler TypedContent

119
src/Vervis/Migration.hs
View file

@ -786,7 +786,7 @@ changes hLocal ctx =
summary renderUrl
, activityAudience = Audience recips [] [] [] [] []
, activitySpecific = OfferActivity Offer
{ offerObject = ticketAP
{ offerObject = OfferTicket ticketAP
, offerTarget =
encodeRouteHome $ ProjectR shrProject prj
}
@ -1587,6 +1587,123 @@ changes hLocal ctx =
, addFieldPrimOptional "TicketRepoLocal" (Nothing :: Maybe Text) "branch"
-- 252
, 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

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

@ -199,6 +199,34 @@ module Vervis.Migration.Model
, TicketProjectLocal247Generic (..)
, model_2020_05_17
, 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
@ -399,3 +427,18 @@ model_2020_05_17 = $(schema "2020_05_17_patch")
model_2020_05_25 :: [Entity SqlBackend]
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
hash = hash . fromSqlKey
{-
instance PersistEntityGraph Ticket TicketDependency where
sourceParam = ticketDependencyParent
sourceField = TicketDependencyParent
destParam = ticketDependencyChild
destField = TicketDependencyChild
-}
{-
instance PersistEntityGraphSelect Ticket TicketDependency where

15
src/Vervis/Patch.hs
View file

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

540
src/Vervis/Ticket.hs
View file

@ -15,7 +15,7 @@
module Vervis.Ticket
( getTicketSummaries
, getTicketDepEdges
--, getTicketDepEdges
, WorkflowFieldFilter (..)
, WorkflowFieldSummary (..)
, TicketTextParamValue (..)
@ -34,31 +34,42 @@ module Vervis.Ticket
, getSharerWorkItems
, getDependencyCollection
, getReverseDependencyCollection
, WorkItem (..)
, getWorkItemRoute
, askWorkItemRoute
, getWorkItem
)
where
import Control.Arrow ((***))
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Trans.Class
import Control.Monad.Trans.Except
import Control.Monad.Trans.Maybe
import Control.Monad.Trans.Reader
import Data.Either
import Data.Foldable (for_)
import Data.Int
import Data.Maybe (isJust)
import Data.Text (Text)
import Data.Traversable
import Database.Esqueleto
import Database.Persist
import Database.Persist.Sql
import Yesod.Core (notFound)
import Yesod.Core.Content
import Yesod.Persist.Core
import qualified Database.Esqueleto as E
import qualified Database.Persist as P
import Network.FedURI
import Web.ActivityPub hiding (Ticket, Project)
import Yesod.ActivityPub
import Yesod.FedURI
import Yesod.Hashids
import Yesod.MonadSite
import Control.Monad.Trans.Except.Local
import Data.Either.Local
import Data.Paginate.Local
import Database.Persist.Local
@ -74,65 +85,65 @@ import Vervis.Widget.Ticket (TicketSummary (..))
-- | Get summaries of all the tickets in the given project.
getTicketSummaries
:: Maybe (SqlExpr (Entity Ticket) -> SqlExpr (Value Bool))
-> Maybe (SqlExpr (Entity Ticket) -> [SqlExpr OrderBy])
:: Maybe (E.SqlExpr (Entity Ticket) -> E.SqlExpr (E.Value Bool))
-> Maybe (E.SqlExpr (Entity Ticket) -> [E.SqlExpr E.OrderBy])
-> Maybe (Int, Int)
-> ProjectId
-> AppDB [TicketSummary]
getTicketSummaries mfilt morder offlim jid = do
tickets <- select $ from $
tickets <- E.select $ E.from $
\ ( t
`InnerJoin` lt
`InnerJoin` tcl
`InnerJoin` tpl
`LeftOuterJoin` (tal `InnerJoin` p `InnerJoin` s `LeftOuterJoin` tup)
`LeftOuterJoin` (tar `InnerJoin` ra `InnerJoin` ro `InnerJoin` i)
`InnerJoin` d
`LeftOuterJoin` m
`E.InnerJoin` lt
`E.InnerJoin` tcl
`E.InnerJoin` tpl
`E.LeftOuterJoin` (tal `E.InnerJoin` p `E.InnerJoin` s `E.LeftOuterJoin` tup)
`E.LeftOuterJoin` (tar `E.InnerJoin` ra `E.InnerJoin` ro `E.InnerJoin` i)
`E.InnerJoin` d
`E.LeftOuterJoin` m
) -> do
on $ just (d ^. DiscussionId) ==. m ?. MessageRoot
on $ lt ^. LocalTicketDiscuss ==. d ^. DiscussionId
on $ ro ?. RemoteObjectInstance ==. i ?. InstanceId
on $ ra ?. RemoteActorIdent ==. ro ?. RemoteObjectId
on $ tar ?. TicketAuthorRemoteAuthor ==. ra ?. RemoteActorId
on $ just (tcl ^. TicketContextLocalId) ==. tar ?. TicketAuthorRemoteTicket
on $ tal ?. TicketAuthorLocalId ==. tup ?. TicketUnderProjectAuthor
on $ p ?. PersonIdent ==. s ?. SharerId
on $ tal ?. TicketAuthorLocalAuthor ==. p ?. PersonId
on $ just (lt ^. LocalTicketId) ==. tal ?. TicketAuthorLocalTicket
on $ tcl ^. TicketContextLocalId ==. tpl ^. TicketProjectLocalContext
on $ t ^. TicketId ==. tcl ^. TicketContextLocalTicket
on $ t ^. TicketId ==. lt ^. LocalTicketTicket
where_ $ tpl ^. TicketProjectLocalProject ==. val jid
groupBy
( t ^. TicketId, lt ^. LocalTicketId
, tal ?. TicketAuthorLocalId, s ?. SharerId, tup ?. TicketUnderProjectId
, ra ?. RemoteActorId, ro ?. RemoteObjectId, i ?. InstanceId
E.on $ E.just (d E.^. DiscussionId) E.==. m E.?. MessageRoot
E.on $ lt E.^. LocalTicketDiscuss E.==. d E.^. DiscussionId
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 $ tal E.?. TicketAuthorLocalId E.==. tup E.?. TicketUnderProjectAuthor
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.where_ $ tpl E.^. TicketProjectLocalProject E.==. E.val jid
E.groupBy
( t E.^. TicketId, lt E.^. LocalTicketId
, tal E.?. TicketAuthorLocalId, s E.?. SharerId, tup E.?. TicketUnderProjectId
, ra E.?. RemoteActorId, ro E.?. RemoteObjectId, i E.?. InstanceId
)
for_ mfilt $ \ filt -> where_ $ filt t
for_ morder $ \ order -> orderBy $ order t
for_ mfilt $ \ filt -> E.where_ $ filt t
for_ morder $ \ order -> E.orderBy $ order t
for_ offlim $ \ (off, lim) -> do
offset $ fromIntegral off
limit $ fromIntegral lim
E.offset $ fromIntegral off
E.limit $ fromIntegral lim
return
( t ^. TicketId
, lt ^. LocalTicketId
, tal ?. TicketAuthorLocalId
( t E.^. TicketId
, lt E.^. LocalTicketId
, tal E.?. TicketAuthorLocalId
, s
, tup ?. TicketUnderProjectId
, tup E.?. TicketUnderProjectId
, i
, ro
, ra
, t ^. TicketCreated
, t ^. TicketTitle
, t ^. TicketStatus
, count $ m ?. MessageId
, t E.^. TicketCreated
, t E.^. TicketTitle
, t E.^. TicketStatus
, E.count $ m E.?. MessageId
)
for tickets $
\ (Value tid, Value ltid, Value mtalid, ms, Value mtupid, mi, mro, mra, Value c, Value t, Value d, Value r) -> do
labels <- select $ from $ \ (tpc `InnerJoin` wf) -> do
on $ tpc ^. TicketParamClassField ==. wf ^. WorkflowFieldId
where_ $ tpc ^. TicketParamClassTicket ==. val tid
\ (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 <- E.select $ E.from $ \ (tpc `E.InnerJoin` wf) -> do
E.on $ tpc E.^. TicketParamClassField E.==. wf E.^. WorkflowFieldId
E.where_ $ tpc E.^. TicketParamClassTicket E.==. E.val tid
return wf
return TicketSummary
{ tsId = ltid
@ -156,6 +167,7 @@ getTicketSummaries mfilt morder offlim jid = do
-- | 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
-- by parent.
{-
getTicketDepEdges :: ProjectId -> AppDB [(Int64, Int64)]
getTicketDepEdges jid =
fmap (map $ fromSqlKey . unValue *** fromSqlKey . unValue) $
@ -175,6 +187,7 @@ getTicketDepEdges jid =
tpl2 ^. TicketProjectLocalProject ==. val jid
orderBy [asc $ t1 ^. TicketId, asc $ t2 ^. TicketId]
return (t1 ^. TicketId, t2 ^. TicketId)
-}
data WorkflowFieldFilter = WorkflowFieldFilter
{ wffNew :: Bool
@ -202,29 +215,29 @@ data TicketTextParam = TicketTextParam
}
toTParam
:: ( Value WorkflowFieldId
, Value FldIdent
, Value Text
, Value Bool
, Value Bool
, Value Bool
, Value Bool
, Value Bool
, Value (Maybe TicketParamTextId)
, Value (Maybe Text)
:: ( E.Value WorkflowFieldId
, E.Value FldIdent
, E.Value Text
, E.Value Bool
, E.Value Bool
, E.Value Bool
, E.Value Bool
, E.Value Bool
, E.Value (Maybe TicketParamTextId)
, E.Value (Maybe Text)
)
-> TicketTextParam
toTParam
( Value fid
, Value fld
, Value name
, Value req
, Value con
, Value new
, Value todo
, Value closed
, Value mp
, Value mt
( E.Value fid
, E.Value fld
, E.Value name
, E.Value req
, E.Value con
, E.Value new
, E.Value todo
, E.Value closed
, E.Value mp
, E.Value mt
) =
TicketTextParam
{ ttpField = WorkflowFieldSummary
@ -252,25 +265,25 @@ toTParam
getTicketTextParams :: TicketId -> WorkflowId -> AppDB [TicketTextParam]
getTicketTextParams tid wid = fmap (map toTParam) $
select $ from $ \ (p `RightOuterJoin` f) -> do
on $
p ?. TicketParamTextField ==. just (f ^. WorkflowFieldId) &&.
p ?. TicketParamTextTicket ==. just (val tid)
where_ $
f ^. WorkflowFieldWorkflow ==. val wid &&.
f ^. WorkflowFieldType ==. val WFTText &&.
isNothing (f ^. WorkflowFieldEnm)
E.select $ E.from $ \ (p `E.RightOuterJoin` f) -> do
E.on $
p E.?. TicketParamTextField E.==. E.just (f E.^. WorkflowFieldId) E.&&.
p E.?. TicketParamTextTicket E.==. E.just (E.val tid)
E.where_ $
f E.^. WorkflowFieldWorkflow E.==. E.val wid E.&&.
f E.^. WorkflowFieldType E.==. E.val WFTText E.&&.
E.isNothing (f E.^. WorkflowFieldEnm)
return
( f ^. WorkflowFieldId
, f ^. WorkflowFieldIdent
, f ^. WorkflowFieldName
, f ^. WorkflowFieldRequired
, f ^. WorkflowFieldConstant
, f ^. WorkflowFieldFilterNew
, f ^. WorkflowFieldFilterTodo
, f ^. WorkflowFieldFilterClosed
, p ?. TicketParamTextId
, p ?. TicketParamTextValue
( f E.^. WorkflowFieldId
, f E.^. WorkflowFieldIdent
, f E.^. WorkflowFieldName
, f E.^. WorkflowFieldRequired
, f E.^. WorkflowFieldConstant
, f E.^. WorkflowFieldFilterNew
, f E.^. WorkflowFieldFilterTodo
, f E.^. WorkflowFieldFilterClosed
, p E.?. TicketParamTextId
, p E.?. TicketParamTextValue
)
data WorkflowEnumSummary = WorkflowEnumSummary
@ -291,35 +304,35 @@ data TicketEnumParam = TicketEnumParam
}
toEParam
:: ( Value WorkflowFieldId
, Value FldIdent
, Value Text
, Value Bool
, Value Bool
, Value Bool
, Value Bool
, Value Bool
, Value WorkflowEnumId
, Value EnmIdent
, Value (Maybe TicketParamEnumId)
, Value (Maybe WorkflowEnumCtorId)
, Value (Maybe Text)
:: ( E.Value WorkflowFieldId
, E.Value FldIdent
, E.Value Text
, E.Value Bool
, E.Value Bool
, E.Value Bool
, E.Value Bool
, E.Value Bool
, E.Value WorkflowEnumId
, E.Value EnmIdent
, E.Value (Maybe TicketParamEnumId)
, E.Value (Maybe WorkflowEnumCtorId)
, E.Value (Maybe Text)
)
-> TicketEnumParam
toEParam
( Value fid
, Value fld
, Value name
, Value req
, Value con
, Value new
, Value todo
, Value closed
, Value i
, Value e
, Value mp
, Value mc
, Value mt
( E.Value fid
, E.Value fld
, E.Value name
, E.Value req
, E.Value con
, E.Value new
, E.Value todo
, E.Value closed
, E.Value i
, E.Value e
, E.Value mp
, E.Value mc
, E.Value mt
) =
TicketEnumParam
{ tepField = WorkflowFieldSummary
@ -352,32 +365,32 @@ toEParam
getTicketEnumParams :: TicketId -> WorkflowId -> AppDB [TicketEnumParam]
getTicketEnumParams tid wid = fmap (map toEParam) $
select $ from $ \ (p `InnerJoin` c `RightOuterJoin` f `InnerJoin` e) -> do
on $
e ^. WorkflowEnumWorkflow ==. val wid &&.
f ^. WorkflowFieldEnm ==. just (e ^. WorkflowEnumId)
on $
f ^. WorkflowFieldWorkflow ==. val wid &&.
f ^. WorkflowFieldType ==. val WFTEnum &&.
p ?. TicketParamEnumField ==. just (f ^. WorkflowFieldId) &&.
c ?. WorkflowEnumCtorEnum ==. f ^. WorkflowFieldEnm
on $
p ?. TicketParamEnumTicket ==. just (val tid) &&.
p ?. TicketParamEnumValue ==. c ?. WorkflowEnumCtorId
E.select $ E.from $ \ (p `E.InnerJoin` c `E.RightOuterJoin` f `E.InnerJoin` e) -> do
E.on $
e E.^. WorkflowEnumWorkflow E.==. E.val wid E.&&.
f E.^. WorkflowFieldEnm E.==. E.just (e E.^. WorkflowEnumId)
E.on $
f E.^. WorkflowFieldWorkflow E.==. E.val wid E.&&.
f E.^. WorkflowFieldType E.==. E.val WFTEnum E.&&.
p E.?. TicketParamEnumField E.==. E.just (f E.^. WorkflowFieldId) E.&&.
c E.?. WorkflowEnumCtorEnum E.==. f E.^. WorkflowFieldEnm
E.on $
p E.?. TicketParamEnumTicket E.==. E.just (E.val tid) E.&&.
p E.?. TicketParamEnumValue E.==. c E.?. WorkflowEnumCtorId
return
( f ^. WorkflowFieldId
, f ^. WorkflowFieldIdent
, f ^. WorkflowFieldName
, f ^. WorkflowFieldRequired
, f ^. WorkflowFieldConstant
, f ^. WorkflowFieldFilterNew
, f ^. WorkflowFieldFilterTodo
, f ^. WorkflowFieldFilterClosed
, e ^. WorkflowEnumId
, e ^. WorkflowEnumIdent
, p ?. TicketParamEnumId
, c ?. WorkflowEnumCtorId
, c ?. WorkflowEnumCtorName
( f E.^. WorkflowFieldId
, f E.^. WorkflowFieldIdent
, f E.^. WorkflowFieldName
, f E.^. WorkflowFieldRequired
, f E.^. WorkflowFieldConstant
, f E.^. WorkflowFieldFilterNew
, f E.^. WorkflowFieldFilterTodo
, f E.^. WorkflowFieldFilterClosed
, e E.^. WorkflowEnumId
, e E.^. WorkflowEnumIdent
, p E.?. TicketParamEnumId
, c E.?. WorkflowEnumCtorId
, c E.?. WorkflowEnumCtorName
)
data TicketClassParam = TicketClassParam
@ -386,27 +399,27 @@ data TicketClassParam = TicketClassParam
}
toCParam
:: ( Value WorkflowFieldId
, Value FldIdent
, Value Text
, Value Bool
, Value Bool
, Value Bool
, Value Bool
, Value Bool
, Value (Maybe TicketParamClassId)
:: ( E.Value WorkflowFieldId
, E.Value FldIdent
, E.Value Text
, E.Value Bool
, E.Value Bool
, E.Value Bool
, E.Value Bool
, E.Value Bool
, E.Value (Maybe TicketParamClassId)
)
-> TicketClassParam
toCParam
( Value fid
, Value fld
, Value name
, Value req
, Value con
, Value new
, Value todo
, Value closed
, Value mp
( E.Value fid
, E.Value fld
, E.Value name
, E.Value req
, E.Value con
, E.Value new
, E.Value todo
, E.Value closed
, E.Value mp
) = TicketClassParam
{ tcpField = WorkflowFieldSummary
{ wfsId = fid
@ -425,30 +438,31 @@ toCParam
getTicketClasses :: TicketId -> WorkflowId -> AppDB [TicketClassParam]
getTicketClasses tid wid = fmap (map toCParam) $
select $ from $ \ (p `RightOuterJoin` f) -> do
on $
p ?. TicketParamClassField ==. just (f ^. WorkflowFieldId) &&.
p ?. TicketParamClassTicket ==. just (val tid)
where_ $
f ^. WorkflowFieldWorkflow ==. val wid &&.
f ^. WorkflowFieldType ==. val WFTClass &&.
isNothing (f ^. WorkflowFieldEnm)
E.select $ E.from $ \ (p `E.RightOuterJoin` f) -> do
E.on $
p E.?. TicketParamClassField E.==. E.just (f E.^. WorkflowFieldId) E.&&.
p E.?. TicketParamClassTicket E.==. E.just (E.val tid)
E.where_ $
f E.^. WorkflowFieldWorkflow E.==. E.val wid E.&&.
f E.^. WorkflowFieldType E.==. E.val WFTClass E.&&.
E.isNothing (f E.^. WorkflowFieldEnm)
return
( f ^. WorkflowFieldId
, f ^. WorkflowFieldIdent
, f ^. WorkflowFieldName
, f ^. WorkflowFieldRequired
, f ^. WorkflowFieldConstant
, f ^. WorkflowFieldFilterNew
, f ^. WorkflowFieldFilterTodo
, f ^. WorkflowFieldFilterClosed
, p ?. TicketParamClassId
( f E.^. WorkflowFieldId
, f E.^. WorkflowFieldIdent
, f E.^. WorkflowFieldName
, f E.^. WorkflowFieldRequired
, f E.^. WorkflowFieldConstant
, f E.^. WorkflowFieldFilterNew
, f E.^. WorkflowFieldFilterTodo
, f E.^. WorkflowFieldFilterClosed
, p E.?. TicketParamClassId
)
getSharerTicket
:: ShrIdent
:: MonadIO m
=> ShrIdent
-> TicketAuthorLocalId
-> AppDB
-> ReaderT SqlBackend m
( Maybe
( Entity TicketAuthorLocal
, Entity LocalTicket
@ -472,12 +486,12 @@ getSharerTicket shr talid = runMaybeT $ do
lt <- lift $ getJust ltid
let tid = localTicketTicket lt
t <- lift $ getJust tid
npatches <- lift $ P.count [PatchTicket P.==. tid]
npatches <- lift $ count [PatchTicket ==. tid]
guard $ npatches <= 0
project <-
requireEitherAlt
(do mtcl <- lift $ getBy $ UniqueTicketContextLocal tid
for mtcl $ \ etcl@(Entity tclid tcl) -> do
for mtcl $ \ etcl@(Entity tclid _) -> do
etpl <- MaybeT $ getBy $ UniqueTicketProjectLocal tclid
mtup1 <- lift $ getBy $ UniqueTicketUnderProjectProject tclid
mtup2 <- lift $ getBy $ UniqueTicketUnderProjectAuthor talid
@ -517,10 +531,11 @@ getSharerTicket404 shr talkhid = do
Just ticket -> return ticket
getProjectTicket
:: ShrIdent
:: MonadIO m
=> ShrIdent
-> PrjIdent
-> LocalTicketId
-> AppDB
-> ReaderT SqlBackend m
( Maybe
( Entity Sharer
, Entity Project
@ -542,7 +557,7 @@ getProjectTicket shr prj ltid = runMaybeT $ do
etcl@(Entity tclid _) <- MaybeT $ getBy $ UniqueTicketContextLocal tid
etpl@(Entity _ tpl) <- MaybeT $ getBy $ UniqueTicketProjectLocal tclid
guard $ ticketProjectLocalProject tpl == jid
npatches <- lift $ P.count [PatchTicket P.==. tid]
npatches <- lift $ count [PatchTicket ==. tid]
guard $ npatches <= 0
author <-
requireEitherAlt
@ -586,7 +601,7 @@ getSharerWorkItems
=> (ShrIdent -> Route App)
-> (ShrIdent -> KeyHashid record -> Route App)
-> (PersonId -> AppDB Int)
-> (PersonId -> Int -> Int -> AppDB [Value (Key record)])
-> (PersonId -> Int -> Int -> AppDB [E.Value (Key record)])
-> ShrIdent
-> Handler TypedContent
getSharerWorkItems mkhere itemRoute countItems selectItems shr = do
@ -632,37 +647,170 @@ getSharerWorkItems mkhere itemRoute countItems selectItems shr = do
else Nothing
, collectionPageStartIndex = Nothing
, collectionPageItems =
map (encodeRouteHome . ticketUrl . unValue) tickets
map (encodeRouteHome . ticketUrl . E.unValue) tickets
}
where
provide :: ActivityPub a => Route App -> a URIMode -> Handler TypedContent
provide here a = provideHtmlAndAP a $ redirectToPrettyJSON here
getDependencyCollection
:: Route App -> AppDB TicketId -> Bool -> Handler TypedContent
getDependencyCollection here getTicketId404 forward = do
:: Route App -> AppDB LocalTicketId -> Handler TypedContent
getDependencyCollection here getLocalTicketId404 = do
tdids <- runDB $ do
tid <- getTicketId404
let (from, to) =
if forward
then (TicketDependencyParent, TicketDependencyChild)
else (TicketDependencyChild, TicketDependencyParent)
E.select $ E.from $ \ (td `E.InnerJoin` t) -> do
E.on $ td E.^. to E.==. t E.^. TicketId
E.where_ $ td E.^. from E.==. E.val tid
return $ td E.^. TicketDependencyId
ltid <- getLocalTicketId404
selectKeysList
[LocalTicketDependencyParent ==. ltid]
[Desc LocalTicketDependencyId]
encodeRouteLocal <- getEncodeRouteLocal
encodeRouteHome <- getEncodeRouteHome
encodeHid <- getEncodeKeyHashid
let deps = Collection
{ 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
encodeRouteHome <- getEncodeRouteHome
encodeHid <- getEncodeKeyHashid
let deps = Collection
{ collectionId = encodeRouteLocal here
, collectionType = CollectionTypeUnordered
, collectionTotalItems = Just $ length tdids
, collectionTotalItems = Just $ length locals + length remotes
, collectionCurrent = Nothing
, collectionFirst = Nothing
, collectionLast = Nothing
, collectionItems =
map (encodeRouteHome . TicketDepR . encodeHid . E.unValue)
tdids
map (encodeRouteHome . TicketDepR . encodeHid) locals ++
map (\ (E.Value h, E.Value lu) -> ObjURI h lu) remotes
}
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

74
src/Web/ActivityPub.hs
View file

@ -61,6 +61,7 @@ module Web.ActivityPub
, CreateObject (..)
, Create (..)
, Follow (..)
, OfferObject (..)
, Offer (..)
, Push (..)
, Reject (..)
@ -84,6 +85,7 @@ module Web.ActivityPub
, httpPostAP
, httpPostAPBytes
, Fetched (..)
, fetchAP
, fetchAPID
, fetchAPID'
, fetchRecipient
@ -91,6 +93,8 @@ module Web.ActivityPub
, fetchUnknownKey
, fetchKnownPersonalKey
, fetchKnownSharedKey
, Obj (..)
)
where
@ -733,7 +737,6 @@ data Relationship u = Relationship
, relationshipAttributedTo :: LocalURI
, relationshipPublished :: Maybe UTCTime
, relationshipUpdated :: Maybe UTCTime
, relationshipSummary :: TextHtml
}
instance ActivityPub Relationship where
@ -755,11 +758,10 @@ instance ActivityPub Relationship where
<*> pure attributedTo
<*> o .:? "published"
<*> o .:? "updated"
<*> (TextHtml . sanitizeBalance <$> o .: "summary")
toSeries authority
(Relationship id_ typs subject property object attributedTo published
updated summary)
updated)
= "id" .=? id_
<> "type" .= ("Relationship" : typs)
<> "subject" .= subject
@ -768,7 +770,6 @@ instance ActivityPub Relationship where
<> "attributedTo" .= ObjURI authority attributedTo
<> "published" .=? published
<> "updated" .=? updated
<> "summary" .= summary
data TicketDependency u = TicketDependency
{ ticketDepId :: Maybe (ObjURI u)
@ -777,7 +778,6 @@ data TicketDependency u = TicketDependency
, ticketDepAttributedTo :: LocalURI
, ticketDepPublished :: Maybe UTCTime
, ticketDepUpdated :: Maybe UTCTime
, ticketDepSummary :: TextHtml
}
instance ActivityPub TicketDependency where
@ -799,7 +799,6 @@ instance ActivityPub TicketDependency where
, ticketDepAttributedTo = relationshipAttributedTo rel
, ticketDepPublished = relationshipPublished rel
, ticketDepUpdated = relationshipUpdated rel
, ticketDepSummary = relationshipSummary rel
}
toSeries a = toSeries a . td2rel
@ -813,7 +812,6 @@ instance ActivityPub TicketDependency where
, relationshipAttributedTo = ticketDepAttributedTo td
, relationshipPublished = ticketDepPublished td
, relationshipUpdated = ticketDepUpdated td
, relationshipSummary = ticketDepSummary td
}
newtype TextHtml = TextHtml
@ -893,6 +891,7 @@ parseTicketLocal o = do
Nothing -> do
verifyNothing "replies"
verifyNothing "participants"
verifyNothing "followers"
verifyNothing "team"
verifyNothing "history"
verifyNothing "dependencies"
@ -903,7 +902,7 @@ parseTicketLocal o = do
TicketLocal
<$> pure id_
<*> withAuthorityO a (o .: "replies")
<*> withAuthorityO a (o .: "participants")
<*> withAuthorityO a (o .: "participants" <|> o .: "followers")
<*> withAuthorityMaybeO a (o .:? "team")
<*> withAuthorityO a (o .: "history")
<*> withAuthorityO a (o .: "dependencies")
@ -916,10 +915,10 @@ parseTicketLocal o = do
encodeTicketLocal :: UriMode u => Authority u -> TicketLocal -> Series
encodeTicketLocal
a (TicketLocal id_ replies participants team events deps rdeps)
a (TicketLocal id_ replies followers team events deps rdeps)
= "id" .= ObjURI a id_
<> "replies" .= ObjURI a replies
<> "participants" .= ObjURI a participants
<> "followers" .= ObjURI a followers
<> "team" .=? (ObjURI a <$> team)
<> "history" .= ObjURI a events
<> "dependencies" .= ObjURI a deps
@ -1220,23 +1219,38 @@ encodeFollow (Follow obj mcontext hide)
<> "context" .=? mcontext
<> "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
{ offerObject :: Ticket u
{ offerObject :: OfferObject u
, offerTarget :: ObjURI u
}
parseOffer :: UriMode u => Object -> Authority u -> LocalURI -> Parser (Offer u)
parseOffer o a luActor = do
ticket <- withAuthorityT a $ parseObject =<< o .: "object"
unless (luActor == ticketAttributedTo ticket) $
fail "Offer actor != Ticket attrib"
obj <- withAuthorityT a $ parseObject =<< o .: "object"
target@(ObjURI hTarget luTarget) <- o .: "target"
for_ (ticketContext ticket) $ \ (ObjURI hContext luContext) -> do
unless (hTarget == hContext) $
fail "Offer target host != Ticket context host"
unless (luTarget == luContext) $
fail "Offer target != Ticket context"
return $ Offer ticket target
case obj of
OfferTicket ticket -> do
unless (luActor == ticketAttributedTo ticket) $
fail "Offer actor != Ticket attrib"
for_ (ticketContext ticket) $ \ (ObjURI hContext luContext) -> do
unless (hTarget == hContext) $
fail "Offer target host != Ticket context host"
unless (luTarget == luContext) $
fail "Offer target != Ticket context"
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 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)
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.
-
- 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.
-
@ -22,6 +22,8 @@ module Yesod.MonadSite
, askUrlRender
, asksSite
, runSiteDB
, runSiteDBExcept
, runDBExcept
, WorkerT ()
, runWorkerT
, WorkerFor
@ -31,7 +33,6 @@ module Yesod.MonadSite
)
where
import Control.Exception
import Control.Monad.Fail
import Control.Monad.IO.Class
import Control.Monad.IO.Unlift
@ -44,6 +45,7 @@ import Data.Functor
import Data.Text (Text)
import Database.Persist.Sql
import UnliftIO.Async
import UnliftIO.Exception
import UnliftIO.Concurrent
import Yesod.Core hiding (logError)
import Yesod.Core.Types
@ -104,6 +106,36 @@ runSiteDB action = do
site <- askSite
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
type SiteEnv (HandlerFor site) = site
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}
<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}
$if ticketStatus ticket /= TSClosed

1
vervis.cabal
View file

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