Implement C2S Create{Ticket}, available in PublishR and in postTicketsR
IMPORTANT: Since a lot of ticket code still doesn't use TicketUnderProject, creating tickets now appears to be failing. Usage of this patch as is, is at your own risk ^_^ the next patches will update the ticket handlers to fix this problem.
This commit is contained in:
fr33domlover
parent
e0300ba0fa
commit
a00c45a444
13 changed files with 521 additions and 83 deletions
|
|
@ -372,6 +372,13 @@ TicketProjectLocal
|
|||
UniqueTicketProjectLocal ticket
|
||||
UniqueTicketProjectLocalAccept accept
|
||||
|
||||
TicketProjectRemote
|
||||
ticket TicketAuthorLocalId
|
||||
tracker RemoteActorId
|
||||
project RemoteObjectId Maybe -- specify if not same as tracker
|
||||
|
||||
UniqueTicketProjectRemote ticket
|
||||
|
||||
TicketAuthorLocal
|
||||
ticket LocalTicketId
|
||||
author PersonId
|
||||
|
|
|
|||
6
migrations/2020_02_22_tpr.model
Normal file
6
migrations/2020_02_22_tpr.model
Normal file
|
|
@ -0,0 +1,6 @@
|
|||
TicketProjectRemote
|
||||
ticket TicketAuthorLocalId
|
||||
tracker RemoteActorId
|
||||
project RemoteObjectId Maybe
|
||||
|
||||
UniqueTicketProjectRemote ticket
|
||||
|
|
@ -15,6 +15,7 @@
|
|||
|
||||
module Vervis.API
|
||||
( createNoteC
|
||||
, createTicketC
|
||||
, followC
|
||||
, offerTicketC
|
||||
, undoC
|
||||
|
|
@ -398,7 +399,7 @@ createNoteC host (Note mluNote luAttrib aud muParent muContext mpublished source
|
|||
-> OutboxItemId
|
||||
-> [ShrIdent]
|
||||
-> Maybe (SharerId, FollowerSetId, InboxId, FollowerSetId)
|
||||
-> ExceptT Text AppDB [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, Maybe UTCTime))]
|
||||
-> ExceptT Text AppDB [((InstanceId, Host), NonEmpty RemoteRecipient)]
|
||||
deliverLocal pidAuthor obid recips mticket = do
|
||||
recipPids <- traverse getPersonId $ nub recips
|
||||
when (pidAuthor `elem` recipPids) $
|
||||
|
|
@ -450,6 +451,272 @@ createNoteC host (Note mluNote luAttrib aud muParent muContext mpublished source
|
|||
Right _gid -> throwE "Local Note addresses a local group"
|
||||
-}
|
||||
|
||||
-- | Handle a Ticket submitted by a local user to their outbox. The ticket's
|
||||
-- context project may be local or remote. Return an error message if the
|
||||
-- Ticket is rejected, otherwise the new 'TicketAuthorLocalId'.
|
||||
createTicketC
|
||||
:: Entity Person
|
||||
-> Sharer
|
||||
-> TextHtml
|
||||
-> Audience URIMode
|
||||
-> AP.Ticket URIMode
|
||||
-> Maybe FedURI
|
||||
-> Handler (Either Text TicketAuthorLocalId)
|
||||
createTicketC (Entity pidUser personUser) sharerUser summary audience ticket muTarget = runExceptT $ do
|
||||
let shrUser = sharerIdent sharerUser
|
||||
ticketData@(uContext, title, desc, source, uTarget) <- checkTicket shrUser ticket muTarget
|
||||
context <- parseTicketContext uContext
|
||||
(localRecips, remoteRecips) <- do
|
||||
mrecips <- parseAudience audience
|
||||
fromMaybeE mrecips "Create Ticket with no recipients"
|
||||
checkFederation remoteRecips
|
||||
verifyProjectRecip context localRecips
|
||||
tracker <- fetchTracker context uTarget
|
||||
now <- liftIO getCurrentTime
|
||||
(talid, obiidCreate, docCreate, remotesHttpCreate, maybeAccept) <- runDBExcept $ do
|
||||
obiidCreate <- lift $ insertEmptyOutboxItem (personOutbox personUser) now
|
||||
project <- prepareProject now tracker
|
||||
talid <- lift $ insertTicket now pidUser title desc source obiidCreate project
|
||||
docCreate <- lift $ insertCreateToOutbox shrUser ticketData now obiidCreate talid
|
||||
remoteRecipsHttpCreate <- do
|
||||
let sieve =
|
||||
case tracker of
|
||||
Left (shr, prj) ->
|
||||
makeRecipientSet
|
||||
[ LocalActorProject shr prj
|
||||
]
|
||||
[ LocalPersonCollectionSharerFollowers shrUser
|
||||
, LocalPersonCollectionProjectTeam shr prj
|
||||
, LocalPersonCollectionProjectFollowers shr prj
|
||||
]
|
||||
Right _ ->
|
||||
makeRecipientSet
|
||||
[]
|
||||
[LocalPersonCollectionSharerFollowers shrUser]
|
||||
moreRemoteRecips <- lift $ deliverLocal' True (LocalActorSharer shrUser) (personInbox personUser) obiidCreate $ localRecipSieve sieve False localRecips
|
||||
checkFederation moreRemoteRecips
|
||||
lift $ deliverRemoteDB' (objUriAuthority uTarget) obiidCreate remoteRecips moreRemoteRecips
|
||||
maccept <-
|
||||
case project of
|
||||
Left proj@(shr, Entity _ j, obiidAccept) -> Just <$> do
|
||||
let prj = projectIdent j
|
||||
recipsA =
|
||||
[ LocalActorSharer shrUser
|
||||
]
|
||||
recipsC =
|
||||
[ LocalPersonCollectionProjectTeam shr prj
|
||||
, LocalPersonCollectionProjectFollowers shr prj
|
||||
, LocalPersonCollectionSharerFollowers shrUser
|
||||
]
|
||||
doc <- lift $ insertAcceptToOutbox proj shrUser obiidCreate talid recipsA recipsC
|
||||
recips <- lift $ deliverLocal' True (LocalActorProject shr prj) (projectInbox j) obiidAccept $ makeRecipientSet recipsA recipsC
|
||||
checkFederation recips
|
||||
lift $ (obiidAccept,doc,) <$> deliverRemoteDB' dont obiidAccept [] recips
|
||||
Right _ -> return Nothing
|
||||
return (talid, obiidCreate, docCreate, remoteRecipsHttpCreate, maccept)
|
||||
lift $ do
|
||||
forkWorker "createTicketC: async HTTP Create delivery" $ deliverRemoteHttp (objUriAuthority uTarget) obiidCreate docCreate remotesHttpCreate
|
||||
for_ maybeAccept $ \ (obiidAccept, docAccept, remotesHttpAccept) ->
|
||||
forkWorker "createTicketC: async HTTP Accept delivery" $ deliverRemoteHttp dont obiidAccept docAccept remotesHttpAccept
|
||||
return talid
|
||||
where
|
||||
checkTicket shr (AP.Ticket mlocal luAttrib mpublished mupdated mcontext summary content source massigned resolved) mtarget = do
|
||||
verifyNothingE mlocal "Ticket with 'id'"
|
||||
encodeRouteLocal <- getEncodeRouteLocal
|
||||
unless (encodeRouteLocal (SharerR shr) == luAttrib) $
|
||||
throwE "Ticket attributed to someone else"
|
||||
verifyNothingE mpublished "Ticket with 'published'"
|
||||
verifyNothingE mupdated "Ticket with 'updated'"
|
||||
context <- fromMaybeE mcontext "Ticket without 'context'"
|
||||
verifyNothingE massigned "Ticket with 'assignedTo'"
|
||||
when resolved $ throwE "Ticket resolved"
|
||||
target <- fromMaybeE mtarget "Create Ticket without 'target'"
|
||||
return (context, summary, content, source, target)
|
||||
|
||||
parseTicketContext :: (MonadSite m, SiteEnv m ~ App) => FedURI -> ExceptT Text m (Either (ShrIdent, PrjIdent) FedURI)
|
||||
parseTicketContext u@(ObjURI h lu) = do
|
||||
hl <- hostIsLocal h
|
||||
if hl
|
||||
then Left <$> do
|
||||
route <- fromMaybeE (decodeRouteLocal lu) "Ticket context isn't a valid route"
|
||||
case route of
|
||||
ProjectR shr prj -> return (shr, prj)
|
||||
_ -> throwE "Ticket context isn't a project route"
|
||||
else return $ Right u
|
||||
|
||||
checkFederation remoteRecips = do
|
||||
federation <- asksSite $ appFederation . appSettings
|
||||
unless (federation || null remoteRecips) $
|
||||
throwE "Federation disabled, but remote recipients found"
|
||||
|
||||
verifyProjectRecip (Right _) _ = return ()
|
||||
verifyProjectRecip (Left (shr, prj)) localRecips =
|
||||
fromMaybeE verify "Local context project isn't listed as a recipient"
|
||||
where
|
||||
verify = do
|
||||
sharerSet <- lookup shr localRecips
|
||||
projectSet <- lookup prj $ localRecipProjectRelated sharerSet
|
||||
guard $ localRecipProject $ localRecipProjectDirect projectSet
|
||||
|
||||
fetchTracker c u@(ObjURI h lu) = do
|
||||
hl <- hostIsLocal h
|
||||
case (hl, c) of
|
||||
(True, Left (shr, prj)) -> Left <$> do
|
||||
encodeRouteLocal <- getEncodeRouteLocal
|
||||
unless (encodeRouteLocal (ProjectR shr prj) == lu) $
|
||||
throwE "Local context and target mismatch"
|
||||
return (shr, prj)
|
||||
(True, Right _) -> throwE "context and target different host"
|
||||
(False, Left _) -> throwE "context and target different host"
|
||||
(False, Right (ObjURI h' lu')) -> Right <$> do
|
||||
unless (h == h') $ throwE "context and target different host"
|
||||
(iid, era) <- do
|
||||
iid <- lift $ runDB $ either entityKey id <$> insertBy' (Instance h)
|
||||
result <- lift $ fetchRemoteActor iid h lu
|
||||
case result of
|
||||
Left e -> throwE $ T.pack $ displayException e
|
||||
Right (Left e) -> throwE $ T.pack $ show e
|
||||
Right (Right mera) -> do
|
||||
era <- fromMaybeE mera "target found to be a collection, not an actor"
|
||||
return (iid, era)
|
||||
return (iid, era, if lu == lu' then Nothing else Just lu')
|
||||
|
||||
insertEmptyOutboxItem obid now = do
|
||||
h <- asksSite siteInstanceHost
|
||||
insert OutboxItem
|
||||
{ outboxItemOutbox = obid
|
||||
, outboxItemActivity = persistJSONObjectFromDoc $ Doc h emptyActivity
|
||||
, outboxItemPublished = now
|
||||
}
|
||||
|
||||
prepareProject now (Left (shr, prj)) = Left <$> do
|
||||
mej <- lift $ runMaybeT $ do
|
||||
sid <- MaybeT $ getKeyBy $ UniqueSharer shr
|
||||
MaybeT $ getBy $ UniqueProject prj sid
|
||||
ej@(Entity _ j) <- fromMaybeE mej "Local context: no such project"
|
||||
obiidAccept <- lift $ insertEmptyOutboxItem (projectOutbox j) now
|
||||
return (shr, ej, obiidAccept)
|
||||
prepareProject _ (Right (iid, era, mlu)) = lift $ Right <$> do
|
||||
mroid <- for mlu $ \ lu -> either entityKey id <$> insertBy' (RemoteObject iid lu)
|
||||
return (era, mroid)
|
||||
|
||||
insertTicket now pidUser title desc source obiidCreate project = do
|
||||
did <- insert Discussion
|
||||
fsid <- insert FollowerSet
|
||||
tid <- insert Ticket
|
||||
{ ticketNumber = Nothing
|
||||
, ticketCreated = now
|
||||
, ticketTitle = unTextHtml title
|
||||
, ticketSource = unTextPandocMarkdown source
|
||||
, ticketDescription = unTextHtml desc
|
||||
, ticketAssignee = Nothing
|
||||
, ticketStatus = TSNew
|
||||
, ticketClosed = UTCTime (ModifiedJulianDay 0) 0
|
||||
, ticketCloser = Nothing
|
||||
}
|
||||
ltid <- insert LocalTicket
|
||||
{ localTicketTicket = tid
|
||||
, localTicketDiscuss = did
|
||||
, localTicketFollowers = fsid
|
||||
}
|
||||
talid <- insert TicketAuthorLocal
|
||||
{ ticketAuthorLocalTicket = ltid
|
||||
, ticketAuthorLocalAuthor = pidUser
|
||||
, ticketAuthorLocalOpen = obiidCreate
|
||||
}
|
||||
case project of
|
||||
Left (_shr, Entity jid _j, obiidAccept) ->
|
||||
insert_ TicketProjectLocal
|
||||
{ ticketProjectLocalTicket = tid
|
||||
, ticketProjectLocalProject = jid
|
||||
, ticketProjectLocalAccept = obiidAccept
|
||||
}
|
||||
Right (Entity raid _ra, mroid) ->
|
||||
insert_ TicketProjectRemote
|
||||
{ ticketProjectRemoteTicket = talid
|
||||
, ticketProjectRemoteTracker = raid
|
||||
, ticketProjectRemoteProject = mroid
|
||||
}
|
||||
return talid
|
||||
|
||||
insertCreateToOutbox shrUser (uContext, title, desc, source, uTarget) now obiidCreate talid = do
|
||||
encodeRouteLocal <- getEncodeRouteLocal
|
||||
hLocal <- asksSite siteInstanceHost
|
||||
talkhid <- encodeKeyHashid talid
|
||||
obikhid <- encodeKeyHashid obiidCreate
|
||||
let luAttrib = encodeRouteLocal $ SharerR shrUser
|
||||
tlocal = TicketLocal
|
||||
{ ticketId = encodeRouteLocal $ SharerTicketR shrUser talkhid
|
||||
, ticketReplies = encodeRouteLocal $ SharerTicketDiscussionR shrUser talkhid
|
||||
, ticketParticipants = encodeRouteLocal $ SharerTicketFollowersR shrUser talkhid
|
||||
, ticketTeam = encodeRouteLocal $ SharerTicketTeamR shrUser talkhid
|
||||
, ticketEvents = encodeRouteLocal $ SharerTicketEventsR shrUser talkhid
|
||||
, ticketDeps = encodeRouteLocal $ SharerTicketDepsR shrUser talkhid
|
||||
, ticketReverseDeps = encodeRouteLocal $ SharerTicketReverseDepsR shrUser talkhid
|
||||
}
|
||||
create = Doc hLocal Activity
|
||||
{ activityId = Just $ encodeRouteLocal $ SharerOutboxItemR shrUser obikhid
|
||||
, activityActor = luAttrib
|
||||
, activitySummary = Just summary
|
||||
, activityAudience = audience
|
||||
, activitySpecific = CreateActivity Create
|
||||
{ createObject = CreateTicket AP.Ticket
|
||||
{ AP.ticketLocal = Just (hLocal, tlocal)
|
||||
, AP.ticketAttributedTo = luAttrib
|
||||
, AP.ticketPublished = Just now
|
||||
, AP.ticketUpdated = Nothing
|
||||
, AP.ticketContext = Just uContext
|
||||
, AP.ticketSummary = title
|
||||
, AP.ticketContent = desc
|
||||
, AP.ticketSource = source
|
||||
, AP.ticketAssignedTo = Nothing
|
||||
, AP.ticketIsResolved = False
|
||||
}
|
||||
, createTarget = Just uTarget
|
||||
}
|
||||
}
|
||||
update obiidCreate [OutboxItemActivity =. persistJSONObjectFromDoc create]
|
||||
return create
|
||||
|
||||
insertAcceptToOutbox (shrJ, Entity _ j, obiidAccept) shrU obiidCreate talid actors colls = do
|
||||
encodeRouteLocal <- getEncodeRouteLocal
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
hLocal <- asksSite siteInstanceHost
|
||||
obikhidAccept <- encodeKeyHashid obiidAccept
|
||||
obikhidCreate <- encodeKeyHashid obiidCreate
|
||||
talkhid <- encodeKeyHashid talid
|
||||
let prjJ = projectIdent j
|
||||
summary <-
|
||||
TextHtml . TL.toStrict . renderHtml <$>
|
||||
withUrlRenderer
|
||||
[hamlet|
|
||||
<p>
|
||||
Project #
|
||||
<a href=@{ProjectR shrJ prjJ}>
|
||||
#{prj2text prjJ}
|
||||
\ accepted #
|
||||
<a href=@{SharerTicketR shrU talkhid}>
|
||||
ticket
|
||||
\ by #
|
||||
<a href=@{SharerR shrU}>
|
||||
#{shr2text shrU}
|
||||
|]
|
||||
let recips = map encodeRouteHome $ map renderLocalActor actors ++ map renderLocalPersonCollection colls
|
||||
accept = Doc hLocal Activity
|
||||
{ activityId = Just $ encodeRouteLocal $ ProjectOutboxItemR shrJ prjJ obikhidAccept
|
||||
, activityActor = encodeRouteLocal $ ProjectR shrJ prjJ
|
||||
, activitySummary = Just summary
|
||||
, activityAudience = Audience recips [] [] [] [] []
|
||||
, activitySpecific = AcceptActivity Accept
|
||||
{ acceptObject = encodeRouteHome $ SharerOutboxItemR shrU obikhidCreate
|
||||
, acceptResult = Nothing
|
||||
}
|
||||
}
|
||||
update obiidAccept [OutboxItemActivity =. persistJSONObjectFromDoc accept]
|
||||
return accept
|
||||
|
||||
dont = Authority "dont-do.any-forwarding" Nothing
|
||||
|
||||
data Followee
|
||||
= FolloweeSharer ShrIdent
|
||||
| FolloweeProject ShrIdent PrjIdent
|
||||
|
|
@ -1041,7 +1308,7 @@ pushCommitsC (eperson, sharer) summary push shrRepo rpRepo = runExceptT $ do
|
|||
:: OutboxItemId
|
||||
-> AppDB
|
||||
[ ( (InstanceId, Host)
|
||||
, NonEmpty (RemoteActorId, LocalURI, LocalURI, Maybe UTCTime)
|
||||
, NonEmpty RemoteRecipient
|
||||
)
|
||||
]
|
||||
deliverLocal obiid = do
|
||||
|
|
|
|||
|
|
@ -41,6 +41,8 @@ module Vervis.ActivityPub
|
|||
, deliverRemoteHttp
|
||||
, serveCommit
|
||||
, deliverLocal
|
||||
, RemoteRecipient (..)
|
||||
, deliverLocal'
|
||||
)
|
||||
where
|
||||
|
||||
|
|
@ -200,7 +202,7 @@ getPersonOrGroupId sid = do
|
|||
"Found sharer that is neither person nor group"
|
||||
"Found sharer that is both person and group"
|
||||
|
||||
getTicketTeam :: SharerId -> AppDB ([PersonId], [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, Maybe UTCTime))])
|
||||
getTicketTeam :: SharerId -> AppDB ([PersonId], [((InstanceId, Host), NonEmpty RemoteRecipient)])
|
||||
getTicketTeam sid = do
|
||||
id_ <- getPersonOrGroupId sid
|
||||
(,[]) <$> case id_ of
|
||||
|
|
@ -213,7 +215,7 @@ getProjectTeam = getTicketTeam
|
|||
|
||||
getRepoTeam = getTicketTeam
|
||||
|
||||
getFollowers :: FollowerSetId -> AppDB ([PersonId], [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, Maybe UTCTime))])
|
||||
getFollowers :: FollowerSetId -> AppDB ([PersonId], [((InstanceId, Host), NonEmpty RemoteRecipient)])
|
||||
getFollowers fsid = do
|
||||
local <- selectList [FollowTarget ==. fsid] [Asc FollowPerson]
|
||||
remote <- E.select $ E.from $ \ (rf `E.InnerJoin` ra `E.InnerJoin` ro `E.InnerJoin` i) -> do
|
||||
|
|
@ -239,16 +241,16 @@ getFollowers fsid = do
|
|||
remote
|
||||
)
|
||||
where
|
||||
groupRemotes :: [(InstanceId, Host, RemoteActorId, LocalURI, LocalURI, Maybe UTCTime)] -> [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, Maybe UTCTime))]
|
||||
groupRemotes :: [(InstanceId, Host, RemoteActorId, LocalURI, LocalURI, Maybe UTCTime)] -> [((InstanceId, Host), NonEmpty RemoteRecipient)]
|
||||
groupRemotes = groupWithExtractBy ((==) `on` fst) fst snd . map toTuples
|
||||
where
|
||||
toTuples (iid, h, raid, luA, luI, ms) = ((iid, h), (raid, luA, luI, ms))
|
||||
toTuples (iid, h, raid, luA, luI, ms) = ((iid, h), RemoteRecipient raid luA luI ms)
|
||||
|
||||
unionRemotes
|
||||
:: [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, Maybe UTCTime))]
|
||||
-> [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, Maybe UTCTime))]
|
||||
-> [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, Maybe UTCTime))]
|
||||
unionRemotes = unionGroupsOrdWith fst fst4
|
||||
:: [((InstanceId, Host), NonEmpty RemoteRecipient)]
|
||||
-> [((InstanceId, Host), NonEmpty RemoteRecipient)]
|
||||
-> [((InstanceId, Host), NonEmpty RemoteRecipient)]
|
||||
unionRemotes = unionGroupsOrdWith fst remoteRecipientActor
|
||||
|
||||
insertMany' mk xs = zip' xs <$> insertMany (NE.toList $ mk <$> xs)
|
||||
where
|
||||
|
|
@ -303,21 +305,21 @@ deliverRemoteDB
|
|||
-> RemoteActivityId
|
||||
-> ProjectId
|
||||
-> ByteString
|
||||
-> [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, Maybe UTCTime))]
|
||||
-> [((InstanceId, Host), NonEmpty RemoteRecipient)]
|
||||
-> AppDB
|
||||
[((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, ForwardingId))]
|
||||
deliverRemoteDB body ractid jid sig recips = do
|
||||
let body' = BL.toStrict body
|
||||
deliv raid msince = Forwarding raid ractid body' jid sig $ isNothing msince
|
||||
fetchedDeliv <- for recips $ \ (i, rs) ->
|
||||
(i,) <$> insertMany' (\ (raid, _, _, msince) -> deliv raid msince) rs
|
||||
(i,) <$> insertMany' (\ (RemoteRecipient raid _ _ msince) -> deliv raid msince) rs
|
||||
return $ takeNoError4 fetchedDeliv
|
||||
where
|
||||
takeNoError noError = mapMaybe $ \ (i, rs) -> (i,) <$> nonEmpty (mapMaybe noError $ NE.toList rs)
|
||||
takeNoError4 = takeNoError noError
|
||||
where
|
||||
noError ((ak, luA, luI, Nothing), dlk) = Just (ak, luA, luI, dlk)
|
||||
noError ((_ , _ , _ , Just _ ), _ ) = Nothing
|
||||
noError (RemoteRecipient ak luA luI Nothing , dlk) = Just (ak, luA, luI, dlk)
|
||||
noError (RemoteRecipient _ _ _ (Just _), _ ) = Nothing
|
||||
|
||||
deliverRemoteHTTP
|
||||
:: UTCTime
|
||||
|
|
@ -449,7 +451,7 @@ deliverRemoteDB'
|
|||
:: Host
|
||||
-> OutboxItemId
|
||||
-> [(Host, NonEmpty LocalURI)]
|
||||
-> [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, Maybe UTCTime))]
|
||||
-> [((InstanceId, Host), NonEmpty RemoteRecipient)]
|
||||
-> AppDB
|
||||
( [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, DeliveryId))]
|
||||
, [((InstanceId, Host), NonEmpty (UnfetchedRemoteActorId, LocalURI, UnlinkedDeliveryId))]
|
||||
|
|
@ -474,7 +476,7 @@ deliverRemoteDB' hContext obid recips known = do
|
|||
Nothing -> Just $ Left lu
|
||||
Just (ro, r) ->
|
||||
case r of
|
||||
RecipRA (Entity raid ra) -> Just $ Right $ Left (raid, remoteObjectIdent ro, remoteActorInbox ra, remoteActorErrorSince ra)
|
||||
RecipRA (Entity raid ra) -> Just $ Right $ Left $ RemoteRecipient raid (remoteObjectIdent ro) (remoteActorInbox ra) (remoteActorErrorSince ra)
|
||||
RecipURA (Entity uraid ura) -> Just $ Right $ Right (uraid, remoteObjectIdent ro, unfetchedRemoteActorSince ura)
|
||||
RecipRC _ -> Nothing
|
||||
let (unknown, newKnown) = partitionEithers $ catMaybes $ NE.toList es
|
||||
|
|
@ -486,7 +488,7 @@ deliverRemoteDB' hContext obid recips known = do
|
|||
allFetched = unionRemotes known moreKnown
|
||||
fetchedDeliv <- for allFetched $ \ (i, rs) ->
|
||||
let fwd = snd i == hContext
|
||||
in (i,) <$> insertMany' (\ (raid, _, _, msince) -> Delivery raid obid fwd $ isNothing msince) rs
|
||||
in (i,) <$> insertMany' (\ (RemoteRecipient raid _ _ msince) -> Delivery raid obid fwd $ isNothing msince) rs
|
||||
unfetchedDeliv <- for unfetched $ \ (i, rs) ->
|
||||
let fwd = snd i == hContext
|
||||
in (i,) <$> insertMany' (\ (uraid, _, msince) -> UnlinkedDelivery uraid obid fwd $ isNothing msince) rs
|
||||
|
|
@ -511,8 +513,8 @@ deliverRemoteDB' hContext obid recips known = do
|
|||
noError ((_ , _ , Just _ ), _ ) = Nothing
|
||||
takeNoError4 = takeNoError noError
|
||||
where
|
||||
noError ((ak, luA, luI, Nothing), dlk) = Just (ak, luA, luI, dlk)
|
||||
noError ((_ , _ , _ , Just _ ), _ ) = Nothing
|
||||
noError (RemoteRecipient ak luA luI Nothing , dlk) = Just (ak, luA, luI, dlk)
|
||||
noError (RemoteRecipient _ _ _ (Just _), _ ) = Nothing
|
||||
|
||||
deliverRemoteHttp
|
||||
:: Host
|
||||
|
|
@ -712,13 +714,12 @@ deliverLocal
|
|||
-> LocalRecipientSet
|
||||
-> AppDB
|
||||
[ ( (InstanceId, Host)
|
||||
, NonEmpty (RemoteActorId, LocalURI, LocalURI, Maybe UTCTime)
|
||||
, NonEmpty RemoteRecipient
|
||||
)
|
||||
]
|
||||
deliverLocal shrAuthor ibidAuthor _fsidAuthor obiid = fmap (map $ second $ NE.map fromRR) . deliverLocal' True shrAuthor ibidAuthor obiid . localRecipSieve sieve True
|
||||
deliverLocal shrAuthor ibidAuthor _fsidAuthor obiid = deliverLocal' True (LocalActorSharer shrAuthor) ibidAuthor obiid . localRecipSieve sieve True
|
||||
where
|
||||
sieve = [(shrAuthor, LocalSharerRelatedSet (LocalSharerDirectSet False True) [] [])]
|
||||
fromRR (RemoteRecipient raid luA luI msince) = (raid, luA, luI, msince)
|
||||
|
||||
data RemoteRecipient = RemoteRecipient
|
||||
{ remoteRecipientActor :: RemoteActorId
|
||||
|
|
@ -735,12 +736,12 @@ data RemoteRecipient = RemoteRecipient
|
|||
-- the remote members
|
||||
deliverLocal'
|
||||
:: Bool -- ^ Whether to deliver to collection only if owner actor is addressed
|
||||
-> ShrIdent
|
||||
-> LocalActor
|
||||
-> InboxId
|
||||
-> OutboxItemId
|
||||
-> LocalRecipientSet
|
||||
-> AppDB [((InstanceId, Host), NonEmpty RemoteRecipient)]
|
||||
deliverLocal' requireOwner shrAuthor ibidAuthor obiid recips = do
|
||||
deliverLocal' requireOwner author ibidAuthor obiid recips = do
|
||||
ibidsSharer <- L.delete ibidAuthor <$> getSharerInboxes recips
|
||||
ibidsOther <- concat <$> traverse getOtherInboxes recips
|
||||
|
||||
|
|
@ -799,7 +800,7 @@ deliverLocal' requireOwner shrAuthor ibidAuthor obiid recips = do
|
|||
[shr | (shr, s) <- sharers
|
||||
, let d = localRecipSharerDirect s
|
||||
in localRecipSharerFollowers d &&
|
||||
(localRecipSharer d || not requireOwner || shr == shrAuthor)
|
||||
(localRecipSharer d || not requireOwner || LocalActorSharer shr == author)
|
||||
]
|
||||
sids <- selectKeysList [SharerIdent <-. shrs] []
|
||||
map (personFollowers . entityVal) <$> selectList [PersonIdent <-. sids] []
|
||||
|
|
@ -819,7 +820,7 @@ deliverLocal' requireOwner shrAuthor ibidAuthor obiid recips = do
|
|||
[prj | (prj, j) <- projects
|
||||
, let d = localRecipProjectDirect j
|
||||
in localRecipProjectFollowers d &&
|
||||
(localRecipProject d || not requireOwner)
|
||||
(localRecipProject d || not requireOwner || LocalActorProject shr prj == author)
|
||||
]
|
||||
fsidsJ <-
|
||||
map (projectFollowers . entityVal) <$>
|
||||
|
|
@ -829,7 +830,7 @@ deliverLocal' requireOwner shrAuthor ibidAuthor obiid recips = do
|
|||
then
|
||||
[ (prj, localRecipTicketRelated j)
|
||||
| (prj, j) <- projects
|
||||
, localRecipProject $ localRecipProjectDirect j
|
||||
, localRecipProject (localRecipProjectDirect j) || LocalActorProject shr prj == author
|
||||
]
|
||||
else
|
||||
map (second localRecipTicketRelated) projects
|
||||
|
|
@ -863,7 +864,7 @@ deliverLocal' requireOwner shrAuthor ibidAuthor obiid recips = do
|
|||
[rp | (rp, r) <- repos
|
||||
, let d = localRecipRepoDirect r
|
||||
in localRecipRepoFollowers d &&
|
||||
(localRecipRepo d || not requireOwner)
|
||||
(localRecipRepo d || not requireOwner || LocalActorRepo shr rp == author)
|
||||
]
|
||||
in map (repoFollowers . entityVal) <$>
|
||||
selectList [RepoSharer ==. sid, RepoIdent <-. rps] []
|
||||
|
|
@ -911,7 +912,7 @@ deliverLocal' requireOwner shrAuthor ibidAuthor obiid recips = do
|
|||
getProjectTeams sid projects = do
|
||||
let prjs =
|
||||
[prj | (prj, LocalProjectRelatedSet d ts) <- projects
|
||||
, (localRecipProject d || not requireOwner) &&
|
||||
, (localRecipProject d || not requireOwner || LocalActorProject shr prj == author) &&
|
||||
(localRecipProjectTeam d || any (localRecipTicketTeam . snd) ts)
|
||||
]
|
||||
jids <- selectKeysList [ProjectSharer ==. sid, ProjectIdent <-. prjs] []
|
||||
|
|
@ -922,7 +923,7 @@ deliverLocal' requireOwner shrAuthor ibidAuthor obiid recips = do
|
|||
[rp | (rp, r) <- repos
|
||||
, let d = localRecipRepoDirect r
|
||||
in localRecipRepoTeam d &&
|
||||
(localRecipRepo d || not requireOwner)
|
||||
(localRecipRepo d || not requireOwner || LocalActorRepo shr rp == author)
|
||||
]
|
||||
rids <- selectKeysList [RepoSharer ==. sid, RepoIdent <-. rps] []
|
||||
pids <- map (repoCollabPerson . entityVal) <$> selectList [RepoCollabRepo <-. rids] []
|
||||
|
|
|
|||
|
|
@ -15,6 +15,7 @@
|
|||
|
||||
module Vervis.ActivityPub.Recipient
|
||||
( LocalActor (..)
|
||||
, LocalPersonCollection (..)
|
||||
, LocalTicketDirectSet (..)
|
||||
, LocalProjectDirectSet (..)
|
||||
, LocalProjectRelatedSet (..)
|
||||
|
|
@ -25,6 +26,9 @@ module Vervis.ActivityPub.Recipient
|
|||
, LocalRecipientSet
|
||||
, concatRecipients
|
||||
, parseLocalActor
|
||||
, renderLocalActor
|
||||
, renderLocalPersonCollection
|
||||
, makeRecipientSet
|
||||
, parseAudience
|
||||
, actorRecips
|
||||
, localRecipSieve
|
||||
|
|
@ -78,6 +82,7 @@ data LocalActor
|
|||
= LocalActorSharer ShrIdent
|
||||
| LocalActorProject ShrIdent PrjIdent
|
||||
| LocalActorRepo ShrIdent RpIdent
|
||||
deriving Eq
|
||||
|
||||
parseLocalActor :: Route App -> Maybe LocalActor
|
||||
parseLocalActor (SharerR shr) = Just $ LocalActorSharer shr
|
||||
|
|
@ -85,6 +90,11 @@ parseLocalActor (ProjectR shr prj) = Just $ LocalActorProject shr prj
|
|||
parseLocalActor (RepoR shr rp) = Just $ LocalActorRepo shr rp
|
||||
parseLocalActor _ = Nothing
|
||||
|
||||
renderLocalActor :: LocalActor -> Route App
|
||||
renderLocalActor (LocalActorSharer shr) = SharerR shr
|
||||
renderLocalActor (LocalActorProject shr prj) = ProjectR shr prj
|
||||
renderLocalActor (LocalActorRepo shr rp) = RepoR shr rp
|
||||
|
||||
data LocalPersonCollection
|
||||
= LocalPersonCollectionSharerFollowers ShrIdent
|
||||
| LocalPersonCollectionProjectTeam ShrIdent PrjIdent
|
||||
|
|
@ -93,6 +103,7 @@ data LocalPersonCollection
|
|||
| LocalPersonCollectionTicketFollowers ShrIdent PrjIdent (KeyHashid LocalTicket)
|
||||
| LocalPersonCollectionRepoTeam ShrIdent RpIdent
|
||||
| LocalPersonCollectionRepoFollowers ShrIdent RpIdent
|
||||
deriving Eq
|
||||
|
||||
parseLocalPersonCollection
|
||||
:: Route App -> Maybe LocalPersonCollection
|
||||
|
|
@ -112,6 +123,15 @@ parseLocalPersonCollection (RepoFollowersR shr rp) =
|
|||
Just $ LocalPersonCollectionRepoFollowers shr rp
|
||||
parseLocalPersonCollection _ = Nothing
|
||||
|
||||
renderLocalPersonCollection :: LocalPersonCollection -> Route App
|
||||
renderLocalPersonCollection (LocalPersonCollectionSharerFollowers shr) = SharerFollowersR shr
|
||||
renderLocalPersonCollection (LocalPersonCollectionProjectTeam shr prj) = ProjectTeamR shr prj
|
||||
renderLocalPersonCollection (LocalPersonCollectionProjectFollowers shr prj) = ProjectFollowersR shr prj
|
||||
renderLocalPersonCollection (LocalPersonCollectionTicketTeam shr prj ltkhid) = TicketTeamR shr prj ltkhid
|
||||
renderLocalPersonCollection (LocalPersonCollectionTicketFollowers shr prj ltkhid) = TicketParticipantsR shr prj ltkhid
|
||||
renderLocalPersonCollection (LocalPersonCollectionRepoTeam shr rp) = RepoTeamR shr rp
|
||||
renderLocalPersonCollection (LocalPersonCollectionRepoFollowers shr rp) = RepoFollowersR shr rp
|
||||
|
||||
parseLocalRecipient
|
||||
:: Route App -> Maybe (Either LocalActor LocalPersonCollection)
|
||||
parseLocalRecipient r =
|
||||
|
|
@ -321,6 +341,12 @@ groupLocalRecipients
|
|||
-- Parse URIs into a grouped recipient set
|
||||
-------------------------------------------------------------------------------
|
||||
|
||||
makeRecipientSet :: [LocalActor] -> [LocalPersonCollection] -> LocalRecipientSet
|
||||
makeRecipientSet actors collections =
|
||||
groupLocalRecipients $
|
||||
map groupedRecipientFromActor actors ++
|
||||
map groupedRecipientFromCollection collections
|
||||
|
||||
parseRecipients
|
||||
:: (MonadSite m, SiteEnv m ~ App)
|
||||
=> NonEmpty FedURI
|
||||
|
|
|
|||
|
|
@ -22,6 +22,7 @@ module Vervis.Client
|
|||
, followTicket
|
||||
, followRepo
|
||||
, offerTicket
|
||||
, createTicket
|
||||
, undoFollowSharer
|
||||
, undoFollowProject
|
||||
, undoFollowTicket
|
||||
|
|
@ -233,6 +234,7 @@ offerTicket shrAuthor (TextHtml title) (TextPandocMarkdown desc) shr prj = runEx
|
|||
, AP.ticketAttributedTo = encodeRouteLocal $ SharerR shrAuthor
|
||||
, AP.ticketPublished = Nothing
|
||||
, AP.ticketUpdated = Nothing
|
||||
, AP.ticketContext = Nothing
|
||||
-- , AP.ticketName = Nothing
|
||||
, AP.ticketSummary = TextHtml title
|
||||
, AP.ticketContent = TextHtml descHtml
|
||||
|
|
@ -254,6 +256,66 @@ offerTicket shrAuthor (TextHtml title) (TextPandocMarkdown desc) shr prj = runEx
|
|||
}
|
||||
return (summary, audience, offer)
|
||||
|
||||
createTicket
|
||||
:: (MonadHandler m, HandlerSite m ~ App, MonadSite m, SiteEnv m ~ App)
|
||||
=> ShrIdent
|
||||
-> TextHtml
|
||||
-> TextPandocMarkdown
|
||||
-> FedURI
|
||||
-> FedURI
|
||||
-> m (Either Text (TextHtml, Audience URIMode, Create URIMode))
|
||||
createTicket shrAuthor (TextHtml title) (TextPandocMarkdown desc) target context = runExceptT $ do
|
||||
summary <-
|
||||
TextHtml . TL.toStrict . renderHtml <$>
|
||||
withUrlRenderer
|
||||
[hamlet|
|
||||
<p>
|
||||
<a href=@{SharerR shrAuthor}>
|
||||
#{shr2text shrAuthor}
|
||||
\ opened a ticket on project #
|
||||
<a href="#{renderObjURI context}"}>
|
||||
#{renderObjURI context}
|
||||
: #{preEscapedToHtml title}.
|
||||
|]
|
||||
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
let recipsA = [target]
|
||||
recipsC =
|
||||
let ObjURI h (LocalURI lu) = context
|
||||
in [ ObjURI h $ LocalURI $ lu <> "/followers"
|
||||
, ObjURI h $ LocalURI $ lu <> "/team"
|
||||
, encodeRouteHome $ SharerFollowersR shrAuthor
|
||||
]
|
||||
audience = Audience
|
||||
{ audienceTo = recipsA ++ recipsC
|
||||
, audienceBto = []
|
||||
, audienceCc = []
|
||||
, audienceBcc = []
|
||||
, audienceGeneral = []
|
||||
, audienceNonActors = recipsC
|
||||
}
|
||||
|
||||
encodeRouteLocal <- getEncodeRouteLocal
|
||||
descHtml <- ExceptT . pure $ renderPandocMarkdown desc
|
||||
let ticket = AP.Ticket
|
||||
{ AP.ticketLocal = Nothing
|
||||
, AP.ticketAttributedTo = encodeRouteLocal $ SharerR shrAuthor
|
||||
, AP.ticketPublished = Nothing
|
||||
, AP.ticketUpdated = Nothing
|
||||
, AP.ticketContext = Just context
|
||||
, AP.ticketSummary = TextHtml title
|
||||
, AP.ticketContent = TextHtml descHtml
|
||||
, AP.ticketSource = TextPandocMarkdown desc
|
||||
, AP.ticketAssignedTo = Nothing
|
||||
, AP.ticketIsResolved = False
|
||||
}
|
||||
create = Create
|
||||
{ createObject = CreateTicket ticket
|
||||
, createTarget = Just target
|
||||
}
|
||||
|
||||
return (summary, audience, create)
|
||||
|
||||
undoFollow
|
||||
:: (MonadUnliftIO m, MonadHandler m, HandlerSite m ~ App, MonadSite m, SiteEnv m ~ App)
|
||||
=> ShrIdent
|
||||
|
|
|
|||
|
|
@ -347,7 +347,7 @@ projectCreateNoteF now shrRecip prjRecip author body (Note mluNote _ _ muParent
|
|||
-> SharerId
|
||||
-> FollowerSetId
|
||||
-> FollowerSetId
|
||||
-> AppDB [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, Maybe UTCTime))]
|
||||
-> AppDB [((InstanceId, Host), NonEmpty RemoteRecipient)]
|
||||
deliverLocal ractid recips sid fsidProject fsidTicket = do
|
||||
(teamPids, teamRemotes) <-
|
||||
if CreateNoteRecipTicketTeam `elem` recips
|
||||
|
|
|
|||
|
|
@ -256,7 +256,7 @@ followF
|
|||
newFollow <- insertFollow ractid obiid $ recipFollowers recip
|
||||
if newFollow
|
||||
then Right <$> do
|
||||
let raInfo = (raidAuthor, remoteObjectIdent ro, remoteActorInbox ra, remoteActorErrorSince ra)
|
||||
let raInfo = RemoteRecipient raidAuthor (remoteObjectIdent ro) (remoteActorInbox ra) (remoteActorErrorSince ra)
|
||||
iidAuthor = remoteAuthorInstance author
|
||||
hAuthor = objUriAuthority $ remoteAuthorURI author
|
||||
hostSection = ((iidAuthor, hAuthor), raInfo :| [])
|
||||
|
|
|
|||
|
|
@ -298,7 +298,7 @@ projectOfferTicketF
|
|||
-> [OfferTicketRecipColl]
|
||||
-> SharerId
|
||||
-> FollowerSetId
|
||||
-> AppDB [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, Maybe UTCTime))]
|
||||
-> AppDB [((InstanceId, Host), NonEmpty RemoteRecipient)]
|
||||
deliverLocal ractid recips sid fsid = do
|
||||
(teamPids, teamRemotes) <-
|
||||
if OfferTicketRecipProjectTeam `elem` recips
|
||||
|
|
@ -381,7 +381,7 @@ projectOfferTicketF
|
|||
let raidAuthor = remoteAuthorId author
|
||||
ra <- getJust raidAuthor
|
||||
ro <- getJust $ remoteActorIdent ra
|
||||
let raInfo = (raidAuthor, remoteObjectIdent ro, remoteActorInbox ra, remoteActorErrorSince ra)
|
||||
let raInfo = RemoteRecipient raidAuthor (remoteObjectIdent ro) (remoteActorInbox ra) (remoteActorErrorSince ra)
|
||||
iidAuthor = remoteAuthorInstance author
|
||||
hAuthor = objUriAuthority $ remoteAuthorURI author
|
||||
hostSection = ((iidAuthor, hAuthor), raInfo :| [])
|
||||
|
|
|
|||
|
|
@ -55,6 +55,7 @@ data NewTicket = NewTicket
|
|||
, ntTParams :: [(WorkflowFieldId, Text)]
|
||||
, ntEParams :: [(WorkflowFieldId, WorkflowEnumCtorId)]
|
||||
, ntCParams :: [WorkflowFieldId]
|
||||
, ntOffer :: Bool
|
||||
}
|
||||
|
||||
fieldSettings :: Text -> Bool -> FieldSettings App
|
||||
|
|
@ -135,6 +136,7 @@ newTicketForm wid html = do
|
|||
<*> (catMaybes <$> traverse tfield tfs)
|
||||
<*> (fmap catMaybes $ sequenceA $ mapMaybe efield efs)
|
||||
<*> (catMaybes <$> traverse cfield cfs)
|
||||
<*> areq checkBoxField "Offer" Nothing
|
||||
|
||||
editTicketContentAForm :: Ticket -> AForm Handler Ticket
|
||||
editTicketContentAForm ticket = Ticket
|
||||
|
|
|
|||
|
|
@ -167,9 +167,23 @@ publishCommentForm html = do
|
|||
defp = ObjURI (Authority "forge.angeley.es" Nothing) $ LocalURI "/s/fr33/m/2f1a7"
|
||||
defmsg = "Hi! I'm testing federation. Can you see my message? :)"
|
||||
|
||||
openTicketForm
|
||||
createTicketForm :: Form (FedURI, FedURI, TextHtml, TextPandocMarkdown)
|
||||
createTicketForm = renderDivs $ (,,,)
|
||||
<$> areq fedUriField "Tracker" (Just defaultProject)
|
||||
<*> areq fedUriField "Context" (Just defaultProject)
|
||||
<*> (TextHtml . sanitizeBalance <$> areq textField "Title" Nothing)
|
||||
<*> (TextPandocMarkdown . T.filter (/= '\r') . unTextarea <$>
|
||||
areq textareaField "Description" Nothing
|
||||
)
|
||||
where
|
||||
defaultProject =
|
||||
ObjURI
|
||||
(Authority "forge.angeley.es" Nothing)
|
||||
(LocalURI "/s/fr33/p/sandbox")
|
||||
|
||||
offerTicketForm
|
||||
:: Form ((Host, ShrIdent, PrjIdent), TextHtml, TextPandocMarkdown)
|
||||
openTicketForm html = do
|
||||
offerTicketForm html = do
|
||||
enc <- getEncodeRouteLocal
|
||||
flip renderDivs html $ (,,)
|
||||
<$> areq (projectField enc) "Project" (Just defj)
|
||||
|
|
@ -195,23 +209,30 @@ activityWidget
|
|||
:: Widget -> Enctype
|
||||
-> Widget -> Enctype
|
||||
-> Widget -> Enctype
|
||||
-> Widget -> Enctype
|
||||
-> Widget
|
||||
activityWidget widget1 enctype1 widget2 enctype2 widget3 enctype3 =
|
||||
activityWidget
|
||||
widget1 enctype1 widget2 enctype2 widget3 enctype3 widget4 enctype4 =
|
||||
[whamlet|
|
||||
<h1>Publish a ticket comment
|
||||
<form method=POST action=@{PublishR} enctype=#{enctype1}>
|
||||
^{widget1}
|
||||
<input type=submit>
|
||||
|
||||
<h1>Open a new ticket
|
||||
<h1>Open a new ticket (via Create)
|
||||
<form method=POST action=@{PublishR} enctype=#{enctype2}>
|
||||
^{widget2}
|
||||
<input type=submit>
|
||||
|
||||
<h1>Follow a person, a projet or a repo
|
||||
<h1>Open a new ticket (via Offer)
|
||||
<form method=POST action=@{PublishR} enctype=#{enctype3}>
|
||||
^{widget3}
|
||||
<input type=submit>
|
||||
|
||||
<h1>Follow a person, a projet or a repo
|
||||
<form method=POST action=@{PublishR} enctype=#{enctype4}>
|
||||
^{widget4}
|
||||
<input type=submit>
|
||||
|]
|
||||
|
||||
getUser :: Handler (ShrIdent, PersonId)
|
||||
|
|
@ -228,11 +249,14 @@ getPublishR = do
|
|||
((_result1, widget1), enctype1) <-
|
||||
runFormPost $ identifyForm "f1" publishCommentForm
|
||||
((_result2, widget2), enctype2) <-
|
||||
runFormPost $ identifyForm "f2" openTicketForm
|
||||
runFormPost $ identifyForm "f2" createTicketForm
|
||||
((_result3, widget3), enctype3) <-
|
||||
runFormPost $ identifyForm "f3" followForm
|
||||
runFormPost $ identifyForm "f3" offerTicketForm
|
||||
((_result4, widget4), enctype4) <-
|
||||
runFormPost $ identifyForm "f4" followForm
|
||||
defaultLayout $
|
||||
activityWidget widget1 enctype1 widget2 enctype2 widget3 enctype3
|
||||
activityWidget
|
||||
widget1 enctype1 widget2 enctype2 widget3 enctype3 widget4 enctype4
|
||||
|
||||
postSharerOutboxR :: ShrIdent -> Handler Html
|
||||
postSharerOutboxR _shrAuthor = do
|
||||
|
|
@ -240,8 +264,8 @@ postSharerOutboxR _shrAuthor = do
|
|||
unless federation badMethod
|
||||
|
||||
error
|
||||
"ActivityPub C2S outbox POST not implemented yet, but you can public \
|
||||
\activities via the /publish page"
|
||||
"ActivityPub C2S outbox POST not implemented yet, but you can post \
|
||||
\public activities via the /publish page"
|
||||
|
||||
postPublishR :: Handler Html
|
||||
postPublishR = do
|
||||
|
|
@ -251,15 +275,20 @@ postPublishR = do
|
|||
((result1, widget1), enctype1) <-
|
||||
runFormPost $ identifyForm "f1" publishCommentForm
|
||||
((result2, widget2), enctype2) <-
|
||||
runFormPost $ identifyForm "f2" openTicketForm
|
||||
runFormPost $ identifyForm "f2" createTicketForm
|
||||
((result3, widget3), enctype3) <-
|
||||
runFormPost $ identifyForm "f3" followForm
|
||||
runFormPost $ identifyForm "f3" offerTicketForm
|
||||
((result4, widget4), enctype4) <-
|
||||
runFormPost $ identifyForm "f4" followForm
|
||||
let result
|
||||
= Left <$> result1
|
||||
<|> Right . Left <$> result2
|
||||
<|> Right . Right <$> result3
|
||||
= Left . Left <$> result1
|
||||
<|> Left . Right <$> result2
|
||||
<|> Right . Left <$> result3
|
||||
<|> Right . Right <$> result4
|
||||
|
||||
shrAuthor <- getUserShrIdent
|
||||
ep@(Entity _ p) <- requireVerifiedAuth
|
||||
s <- runDB $ getJust $ personIdent p
|
||||
let shrAuthor = sharerIdent s
|
||||
|
||||
eid <- runExceptT $ do
|
||||
input <-
|
||||
|
|
@ -267,16 +296,21 @@ postPublishR = do
|
|||
FormMissing -> throwE "Field(s) missing"
|
||||
FormFailure _l -> throwE "Invalid input, see below"
|
||||
FormSuccess r -> return r
|
||||
bitraverse (publishComment shrAuthor) (bitraverse (openTicket shrAuthor) (follow shrAuthor)) input
|
||||
bitraverse (bitraverse (publishComment shrAuthor) (publishTicket ep s)) (bitraverse (openTicket shrAuthor) (follow shrAuthor)) input
|
||||
case eid of
|
||||
Left err -> setMessage $ toHtml err
|
||||
Right id_ ->
|
||||
case id_ of
|
||||
Left lmid -> do
|
||||
Left (Left lmid) -> do
|
||||
lmkhid <- encodeKeyHashid lmid
|
||||
renderUrl <- getUrlRender
|
||||
let u = renderUrl $ MessageR shrAuthor lmkhid
|
||||
setMessage $ toHtml $ "Message created! ID: " <> u
|
||||
Left (Right talid) -> do
|
||||
talkhid <- encodeKeyHashid talid
|
||||
renderUrl <- getUrlRender
|
||||
let u = renderUrl $ SharerTicketR shrAuthor talkhid
|
||||
setMessage $ toHtml $ "Ticket created! ID: " <> u
|
||||
Right (Left _obiid) ->
|
||||
setMessage "Ticket offer published!"
|
||||
Right (Right _obiid) ->
|
||||
|
|
@ -286,6 +320,7 @@ postPublishR = do
|
|||
widget1 enctype1
|
||||
widget2 enctype2
|
||||
widget3 enctype3
|
||||
widget4 enctype4
|
||||
where
|
||||
publishComment shrAuthor ((hTicket, shrTicket, prj, num), muParent, msg) = do
|
||||
encodeRouteFed <- getEncodeRouteHome
|
||||
|
|
@ -319,6 +354,15 @@ postPublishR = do
|
|||
, noteContent = contentHtml
|
||||
}
|
||||
ExceptT $ createNoteC hLocal note
|
||||
publishTicket eperson sharer (target, context, title, desc) = do
|
||||
(summary, audience, create) <-
|
||||
ExceptT $ C.createTicket (sharerIdent sharer) title desc target context
|
||||
let ticket =
|
||||
case createObject create of
|
||||
CreateTicket t -> t
|
||||
_ -> error "Create object isn't a ticket"
|
||||
target = createTarget create
|
||||
ExceptT $ createTicketC eperson sharer summary audience ticket target
|
||||
openTicket shrAuthor ((h, shr, prj), TextHtml title, TextPandocMarkdown desc) = do
|
||||
encodeRouteLocal <- getEncodeRouteLocal
|
||||
encodeRouteFed <- getEncodeRouteFed
|
||||
|
|
@ -664,12 +708,14 @@ postTicketsR shr prj = do
|
|||
return $ projectWorkflow j
|
||||
((result, widget), enctype) <- runFormPost $ newTicketForm wid
|
||||
|
||||
shrAuthor <- do
|
||||
Entity _ p <- requireVerifiedAuth
|
||||
runDB $ sharerIdent <$> getJust (personIdent p)
|
||||
(eperson, sharer) <- do
|
||||
ep@(Entity _ p) <- requireVerifiedAuth
|
||||
s <- runDB $ getJust $ personIdent p
|
||||
return (ep, s)
|
||||
let shrAuthor = sharerIdent sharer
|
||||
|
||||
eltid <- runExceptT $ do
|
||||
NewTicket title desc tparams eparams cparams <-
|
||||
eid <- runExceptT $ do
|
||||
NewTicket title desc tparams eparams cparams offer <-
|
||||
case result of
|
||||
FormMissing -> throwE "Field(s) missing."
|
||||
FormFailure _l ->
|
||||
|
|
@ -691,6 +737,8 @@ postTicketsR shr prj = do
|
|||
}
|
||||
insertMany_ $ map mkeparam $ ntEParams nt
|
||||
-}
|
||||
if offer
|
||||
then Right <$> do
|
||||
(summary, audience, offer) <-
|
||||
ExceptT $ offerTicket shrAuthor (TextHtml title) (TextPandocMarkdown desc) shr prj
|
||||
obiid <- ExceptT $ offerTicketC shrAuthor summary audience offer
|
||||
|
|
@ -703,11 +751,24 @@ postTicketsR shr prj = do
|
|||
"Offer processed successfully but no ticket \
|
||||
\created"
|
||||
Just tal -> Right $ ticketAuthorLocalTicket tal
|
||||
case eltid of
|
||||
else Left <$> do
|
||||
(summary, audience, Create obj mtarget) <- do
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
let project = encodeRouteHome $ ProjectR shr prj
|
||||
ExceptT $ createTicket shrAuthor (TextHtml title) (TextPandocMarkdown desc) project project
|
||||
let ticket =
|
||||
case obj of
|
||||
CreateTicket t -> t
|
||||
_ -> error "Create object isn't a ticket"
|
||||
ExceptT $ createTicketC eperson sharer summary audience ticket mtarget
|
||||
case eid of
|
||||
Left e -> do
|
||||
setMessage $ toHtml e
|
||||
defaultLayout $(widgetFile "ticket/new")
|
||||
Right ltid -> do
|
||||
Right (Left talid) -> do
|
||||
talkhid <- encodeKeyHashid talid
|
||||
redirect $ SharerTicketR shr talkhid
|
||||
Right (Right ltid) -> do
|
||||
ltkhid <- encodeKeyHashid ltid
|
||||
eobiidFollow <- runExceptT $ do
|
||||
(summary, audience, follow) <- followTicket shrAuthor shr prj ltkhid False
|
||||
|
|
|
|||
|
|
@ -1507,6 +1507,8 @@ changes hLocal ctx =
|
|||
, removeField "RemoteMessage" "ident"
|
||||
-- 233
|
||||
, renameField "RemoteMessage" "identNew" "ident"
|
||||
-- 234
|
||||
, addEntities model_2020_02_22
|
||||
]
|
||||
|
||||
migrateDB
|
||||
|
|
|
|||
|
|
@ -180,6 +180,7 @@ module Vervis.Migration.Model
|
|||
, RemoteObject227Generic (..)
|
||||
, RemoteMessage227
|
||||
, RemoteMessage227Generic (..)
|
||||
, model_2020_02_22
|
||||
)
|
||||
where
|
||||
|
||||
|
|
@ -350,3 +351,6 @@ makeEntitiesMigration "223"
|
|||
|
||||
makeEntitiesMigration "227"
|
||||
$(modelFile "migrations/2020_02_10_rm_point_to_ro.model")
|
||||
|
||||
model_2020_02_22 :: [Entity SqlBackend]
|
||||
model_2020_02_22 = $(schema "2020_02_22_tpr")
|
||||
|
|
|
|||
Loading…
Reference in a new issue