sup39/vervis
1
0
Fork 0
mirror of https://code.sup39.dev/repos/Wqawg synced 2024-12-27 16:14:51 +09:00
Code Issues Activity

Implement C2S Create{Ticket}, available in PublishR and in postTicketsR

Browse source 
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 2020-02-22 19:45:27 +00:00
parent e0300ba0fa
commit a00c45a444
13 changed files with 521 additions and 83 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

7
config/models
View file

@ -372,6 +372,13 @@ TicketProjectLocal
UniqueTicketProjectLocal ticket UniqueTicketProjectLocal ticket
UniqueTicketProjectLocalAccept accept UniqueTicketProjectLocalAccept accept
TicketProjectRemote
ticket TicketAuthorLocalId
tracker RemoteActorId
project RemoteObjectId Maybe -- specify if not same as tracker
UniqueTicketProjectRemote ticket
TicketAuthorLocal TicketAuthorLocal
ticket LocalTicketId ticket LocalTicketId
author PersonId author PersonId

6
migrations/2020_02_22_tpr.model Normal file
View file

@ -0,0 +1,6 @@
TicketProjectRemote
ticket TicketAuthorLocalId
tracker RemoteActorId
project RemoteObjectId Maybe
UniqueTicketProjectRemote ticket

271
src/Vervis/API.hs
View file

@ -15,6 +15,7 @@
module Vervis.API module Vervis.API
( createNoteC ( createNoteC
, createTicketC
, followC , followC
, offerTicketC , offerTicketC
, undoC , undoC
@ -398,7 +399,7 @@ createNoteC host (Note mluNote luAttrib aud muParent muContext mpublished source
-> OutboxItemId -> OutboxItemId
-> [ShrIdent] -> [ShrIdent]
-> Maybe (SharerId, FollowerSetId, InboxId, FollowerSetId) -> 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 deliverLocal pidAuthor obid recips mticket = do
recipPids <- traverse getPersonId $ nub recips recipPids <- traverse getPersonId $ nub recips
when (pidAuthor `elem` recipPids) $ 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" 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 data Followee
= FolloweeSharer ShrIdent = FolloweeSharer ShrIdent
| FolloweeProject ShrIdent PrjIdent | FolloweeProject ShrIdent PrjIdent
@ -1041,7 +1308,7 @@ pushCommitsC (eperson, sharer) summary push shrRepo rpRepo = runExceptT $ do
:: OutboxItemId :: OutboxItemId
-> AppDB -> AppDB
[ ( (InstanceId, Host) [ ( (InstanceId, Host)
, NonEmpty (RemoteActorId, LocalURI, LocalURI, Maybe UTCTime) , NonEmpty RemoteRecipient
) )
] ]
deliverLocal obiid = do deliverLocal obiid = do

57
src/Vervis/ActivityPub.hs
View file

@ -41,6 +41,8 @@ module Vervis.ActivityPub
, deliverRemoteHttp , deliverRemoteHttp
, serveCommit , serveCommit
, deliverLocal , deliverLocal
, RemoteRecipient (..)
, deliverLocal'
) )
where where
@ -200,7 +202,7 @@ getPersonOrGroupId sid = do
"Found sharer that is neither person nor group" "Found sharer that is neither person nor group"
"Found sharer that is both person and 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 getTicketTeam sid = do
id_ <- getPersonOrGroupId sid id_ <- getPersonOrGroupId sid
(,[]) <$> case id_ of (,[]) <$> case id_ of
@ -213,7 +215,7 @@ getProjectTeam = getTicketTeam
getRepoTeam = 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 getFollowers fsid = do
local <- selectList [FollowTarget ==. fsid] [Asc FollowPerson] local <- selectList [FollowTarget ==. fsid] [Asc FollowPerson]
remote <- E.select $ E.from $ \ (rf `E.InnerJoin` ra `E.InnerJoin` ro `E.InnerJoin` i) -> do remote <- E.select $ E.from $ \ (rf `E.InnerJoin` ra `E.InnerJoin` ro `E.InnerJoin` i) -> do
@ -239,16 +241,16 @@ getFollowers fsid = do
remote remote
) )
where 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 groupRemotes = groupWithExtractBy ((==) `on` fst) fst snd . map toTuples
where 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 unionRemotes
:: [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, Maybe UTCTime))] :: [((InstanceId, Host), NonEmpty RemoteRecipient)]
-> [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, Maybe UTCTime))] -> [((InstanceId, Host), NonEmpty RemoteRecipient)]
-> [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, Maybe UTCTime))] -> [((InstanceId, Host), NonEmpty RemoteRecipient)]
unionRemotes = unionGroupsOrdWith fst fst4 unionRemotes = unionGroupsOrdWith fst remoteRecipientActor
insertMany' mk xs = zip' xs <$> insertMany (NE.toList $ mk <$> xs) insertMany' mk xs = zip' xs <$> insertMany (NE.toList $ mk <$> xs)
where where
@ -303,21 +305,21 @@ deliverRemoteDB
-> RemoteActivityId -> RemoteActivityId
-> ProjectId -> ProjectId
-> ByteString -> ByteString
-> [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, Maybe UTCTime))] -> [((InstanceId, Host), NonEmpty RemoteRecipient)]
-> AppDB -> AppDB
[((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, ForwardingId))] [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, ForwardingId))]
deliverRemoteDB body ractid jid sig recips = do deliverRemoteDB body ractid jid sig recips = do
let body' = BL.toStrict body let body' = BL.toStrict body
deliv raid msince = Forwarding raid ractid body' jid sig $ isNothing msince deliv raid msince = Forwarding raid ractid body' jid sig $ isNothing msince
fetchedDeliv <- for recips $ \ (i, rs) -> 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 return $ takeNoError4 fetchedDeliv
where where
takeNoError noError = mapMaybe $ \ (i, rs) -> (i,) <$> nonEmpty (mapMaybe noError $ NE.toList rs) takeNoError noError = mapMaybe $ \ (i, rs) -> (i,) <$> nonEmpty (mapMaybe noError $ NE.toList rs)
takeNoError4 = takeNoError noError takeNoError4 = takeNoError noError
where where
noError ((ak, luA, luI, Nothing), dlk) = Just (ak, luA, luI, dlk) noError (RemoteRecipient ak luA luI Nothing , dlk) = Just (ak, luA, luI, dlk)
noError ((_ , _ , _ , Just _ ), _ ) = Nothing noError (RemoteRecipient _ _ _ (Just _), _ ) = Nothing
deliverRemoteHTTP deliverRemoteHTTP
:: UTCTime :: UTCTime
@ -449,7 +451,7 @@ deliverRemoteDB'
:: Host :: Host
-> OutboxItemId -> OutboxItemId
-> [(Host, NonEmpty LocalURI)] -> [(Host, NonEmpty LocalURI)]
-> [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, Maybe UTCTime))] -> [((InstanceId, Host), NonEmpty RemoteRecipient)]
-> AppDB -> AppDB
( [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, DeliveryId))] ( [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, DeliveryId))]
, [((InstanceId, Host), NonEmpty (UnfetchedRemoteActorId, LocalURI, UnlinkedDeliveryId))] , [((InstanceId, Host), NonEmpty (UnfetchedRemoteActorId, LocalURI, UnlinkedDeliveryId))]
@ -474,7 +476,7 @@ deliverRemoteDB' hContext obid recips known = do
Nothing -> Just $ Left lu Nothing -> Just $ Left lu
Just (ro, r) -> Just (ro, r) ->
case r of 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) RecipURA (Entity uraid ura) -> Just $ Right $ Right (uraid, remoteObjectIdent ro, unfetchedRemoteActorSince ura)
RecipRC _ -> Nothing RecipRC _ -> Nothing
let (unknown, newKnown) = partitionEithers $ catMaybes $ NE.toList es let (unknown, newKnown) = partitionEithers $ catMaybes $ NE.toList es
@ -486,7 +488,7 @@ deliverRemoteDB' hContext obid recips known = do
allFetched = unionRemotes known moreKnown allFetched = unionRemotes known moreKnown
fetchedDeliv <- for allFetched $ \ (i, rs) -> fetchedDeliv <- for allFetched $ \ (i, rs) ->
let fwd = snd i == hContext let fwd = snd i == 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) -> unfetchedDeliv <- for unfetched $ \ (i, rs) ->
let fwd = snd i == hContext let fwd = snd i == hContext
in (i,) <$> insertMany' (\ (uraid, _, msince) -> UnlinkedDelivery uraid obid fwd $ isNothing msince) rs 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 noError ((_ , _ , Just _ ), _ ) = Nothing
takeNoError4 = takeNoError noError takeNoError4 = takeNoError noError
where where
noError ((ak, luA, luI, Nothing), dlk) = Just (ak, luA, luI, dlk) noError (RemoteRecipient ak luA luI Nothing , dlk) = Just (ak, luA, luI, dlk)
noError ((_ , _ , _ , Just _ ), _ ) = Nothing noError (RemoteRecipient _ _ _ (Just _), _ ) = Nothing
deliverRemoteHttp deliverRemoteHttp
:: Host :: Host
@ -712,13 +714,12 @@ deliverLocal
-> LocalRecipientSet -> LocalRecipientSet
-> AppDB -> AppDB
[ ( (InstanceId, Host) [ ( (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 where
sieve = [(shrAuthor, LocalSharerRelatedSet (LocalSharerDirectSet False True) [] [])] sieve = [(shrAuthor, LocalSharerRelatedSet (LocalSharerDirectSet False True) [] [])]
fromRR (RemoteRecipient raid luA luI msince) = (raid, luA, luI, msince)
data RemoteRecipient = RemoteRecipient data RemoteRecipient = RemoteRecipient
{ remoteRecipientActor :: RemoteActorId { remoteRecipientActor :: RemoteActorId
@ -735,12 +736,12 @@ data RemoteRecipient = RemoteRecipient
-- the remote members -- the remote members
deliverLocal' deliverLocal'
:: Bool -- ^ Whether to deliver to collection only if owner actor is addressed :: Bool -- ^ Whether to deliver to collection only if owner actor is addressed
-> ShrIdent -> LocalActor
-> InboxId -> InboxId
-> OutboxItemId -> OutboxItemId
-> LocalRecipientSet -> LocalRecipientSet
-> AppDB [((InstanceId, Host), NonEmpty RemoteRecipient)] -> 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 ibidsSharer <- L.delete ibidAuthor <$> getSharerInboxes recips
ibidsOther <- concat <$> traverse getOtherInboxes recips ibidsOther <- concat <$> traverse getOtherInboxes recips
@ -799,7 +800,7 @@ deliverLocal' requireOwner shrAuthor ibidAuthor obiid recips = do
[shr | (shr, s) <- sharers [shr | (shr, s) <- sharers
, let d = localRecipSharerDirect s , let d = localRecipSharerDirect s
in localRecipSharerFollowers d && in localRecipSharerFollowers d &&
(localRecipSharer d || not requireOwner || shr == shrAuthor) (localRecipSharer d || not requireOwner || LocalActorSharer shr == author)
] ]
sids <- selectKeysList [SharerIdent <-. shrs] [] sids <- selectKeysList [SharerIdent <-. shrs] []
map (personFollowers . entityVal) <$> selectList [PersonIdent <-. sids] [] map (personFollowers . entityVal) <$> selectList [PersonIdent <-. sids] []
@ -819,7 +820,7 @@ deliverLocal' requireOwner shrAuthor ibidAuthor obiid recips = do
[prj | (prj, j) <- projects [prj | (prj, j) <- projects
, let d = localRecipProjectDirect j , let d = localRecipProjectDirect j
in localRecipProjectFollowers d && in localRecipProjectFollowers d &&
(localRecipProject d || not requireOwner) (localRecipProject d || not requireOwner || LocalActorProject shr prj == author)
] ]
fsidsJ <- fsidsJ <-
map (projectFollowers . entityVal) <$> map (projectFollowers . entityVal) <$>
@ -829,7 +830,7 @@ deliverLocal' requireOwner shrAuthor ibidAuthor obiid recips = do
then then
[ (prj, localRecipTicketRelated j) [ (prj, localRecipTicketRelated j)
| (prj, j) <- projects | (prj, j) <- projects
, localRecipProject $ localRecipProjectDirect j , localRecipProject (localRecipProjectDirect j) || LocalActorProject shr prj == author
] ]
else else
map (second localRecipTicketRelated) projects map (second localRecipTicketRelated) projects
@ -863,7 +864,7 @@ deliverLocal' requireOwner shrAuthor ibidAuthor obiid recips = do
[rp | (rp, r) <- repos [rp | (rp, r) <- repos
, let d = localRecipRepoDirect r , let d = localRecipRepoDirect r
in localRecipRepoFollowers d && in localRecipRepoFollowers d &&
(localRecipRepo d || not requireOwner) (localRecipRepo d || not requireOwner || LocalActorRepo shr rp == author)
] ]
in map (repoFollowers . entityVal) <$> in map (repoFollowers . entityVal) <$>
selectList [RepoSharer ==. sid, RepoIdent <-. rps] [] selectList [RepoSharer ==. sid, RepoIdent <-. rps] []
@ -911,7 +912,7 @@ deliverLocal' requireOwner shrAuthor ibidAuthor obiid recips = do
getProjectTeams sid projects = do getProjectTeams sid projects = do
let prjs = let prjs =
[prj | (prj, LocalProjectRelatedSet d ts) <- projects [prj | (prj, LocalProjectRelatedSet d ts) <- projects
, (localRecipProject d || not requireOwner) && , (localRecipProject d || not requireOwner || LocalActorProject shr prj == author) &&
(localRecipProjectTeam d || any (localRecipTicketTeam . snd) ts) (localRecipProjectTeam d || any (localRecipTicketTeam . snd) ts)
] ]
jids <- selectKeysList [ProjectSharer ==. sid, ProjectIdent <-. prjs] [] jids <- selectKeysList [ProjectSharer ==. sid, ProjectIdent <-. prjs] []
@ -922,7 +923,7 @@ deliverLocal' requireOwner shrAuthor ibidAuthor obiid recips = do
[rp | (rp, r) <- repos [rp | (rp, r) <- repos
, let d = localRecipRepoDirect r , let d = localRecipRepoDirect r
in localRecipRepoTeam d && in localRecipRepoTeam d &&
(localRecipRepo d || not requireOwner) (localRecipRepo d || not requireOwner || LocalActorRepo shr rp == author)
] ]
rids <- selectKeysList [RepoSharer ==. sid, RepoIdent <-. rps] [] rids <- selectKeysList [RepoSharer ==. sid, RepoIdent <-. rps] []
pids <- map (repoCollabPerson . entityVal) <$> selectList [RepoCollabRepo <-. rids] [] pids <- map (repoCollabPerson . entityVal) <$> selectList [RepoCollabRepo <-. rids] []

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

@ -15,6 +15,7 @@
module Vervis.ActivityPub.Recipient module Vervis.ActivityPub.Recipient
( LocalActor (..) ( LocalActor (..)
, LocalPersonCollection (..)
, LocalTicketDirectSet (..) , LocalTicketDirectSet (..)
, LocalProjectDirectSet (..) , LocalProjectDirectSet (..)
, LocalProjectRelatedSet (..) , LocalProjectRelatedSet (..)
@ -25,6 +26,9 @@ module Vervis.ActivityPub.Recipient
, LocalRecipientSet , LocalRecipientSet
, concatRecipients , concatRecipients
, parseLocalActor , parseLocalActor
, renderLocalActor
, renderLocalPersonCollection
, makeRecipientSet
, parseAudience , parseAudience
, actorRecips , actorRecips
, localRecipSieve , localRecipSieve
@ -78,6 +82,7 @@ data LocalActor
= LocalActorSharer ShrIdent = LocalActorSharer ShrIdent
| LocalActorProject ShrIdent PrjIdent | LocalActorProject ShrIdent PrjIdent
| LocalActorRepo ShrIdent RpIdent | LocalActorRepo ShrIdent RpIdent
deriving Eq
parseLocalActor :: Route App -> Maybe LocalActor parseLocalActor :: Route App -> Maybe LocalActor
parseLocalActor (SharerR shr) = Just $ LocalActorSharer shr 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 (RepoR shr rp) = Just $ LocalActorRepo shr rp
parseLocalActor _ = Nothing 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 data LocalPersonCollection
= LocalPersonCollectionSharerFollowers ShrIdent = LocalPersonCollectionSharerFollowers ShrIdent
| LocalPersonCollectionProjectTeam ShrIdent PrjIdent | LocalPersonCollectionProjectTeam ShrIdent PrjIdent
@ -93,6 +103,7 @@ data LocalPersonCollection
| LocalPersonCollectionTicketFollowers ShrIdent PrjIdent (KeyHashid LocalTicket) | LocalPersonCollectionTicketFollowers ShrIdent PrjIdent (KeyHashid LocalTicket)
| LocalPersonCollectionRepoTeam ShrIdent RpIdent | LocalPersonCollectionRepoTeam ShrIdent RpIdent
| LocalPersonCollectionRepoFollowers ShrIdent RpIdent | LocalPersonCollectionRepoFollowers ShrIdent RpIdent
deriving Eq
parseLocalPersonCollection parseLocalPersonCollection
:: Route App -> Maybe LocalPersonCollection :: Route App -> Maybe LocalPersonCollection
@ -112,6 +123,15 @@ parseLocalPersonCollection (RepoFollowersR shr rp) =
Just $ LocalPersonCollectionRepoFollowers shr rp Just $ LocalPersonCollectionRepoFollowers shr rp
parseLocalPersonCollection _ = Nothing 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 parseLocalRecipient
:: Route App -> Maybe (Either LocalActor LocalPersonCollection) :: Route App -> Maybe (Either LocalActor LocalPersonCollection)
parseLocalRecipient r = parseLocalRecipient r =
@ -321,6 +341,12 @@ groupLocalRecipients
-- Parse URIs into a grouped recipient set -- Parse URIs into a grouped recipient set
------------------------------------------------------------------------------- -------------------------------------------------------------------------------
makeRecipientSet :: [LocalActor] -> [LocalPersonCollection] -> LocalRecipientSet
makeRecipientSet actors collections =
groupLocalRecipients $
map groupedRecipientFromActor actors ++
map groupedRecipientFromCollection collections
parseRecipients parseRecipients
:: (MonadSite m, SiteEnv m ~ App) :: (MonadSite m, SiteEnv m ~ App)
=> NonEmpty FedURI => NonEmpty FedURI

62
src/Vervis/Client.hs
View file

@ -22,6 +22,7 @@ module Vervis.Client
, followTicket , followTicket
, followRepo , followRepo
, offerTicket , offerTicket
, createTicket
, undoFollowSharer , undoFollowSharer
, undoFollowProject , undoFollowProject
, undoFollowTicket , undoFollowTicket
@ -233,6 +234,7 @@ offerTicket shrAuthor (TextHtml title) (TextPandocMarkdown desc) shr prj = runEx
, AP.ticketAttributedTo = encodeRouteLocal $ SharerR shrAuthor , AP.ticketAttributedTo = encodeRouteLocal $ SharerR shrAuthor
, AP.ticketPublished = Nothing , AP.ticketPublished = Nothing
, AP.ticketUpdated = Nothing , AP.ticketUpdated = Nothing
, AP.ticketContext = Nothing
-- , AP.ticketName = Nothing -- , AP.ticketName = Nothing
, AP.ticketSummary = TextHtml title , AP.ticketSummary = TextHtml title
, AP.ticketContent = TextHtml descHtml , AP.ticketContent = TextHtml descHtml
@ -254,6 +256,66 @@ offerTicket shrAuthor (TextHtml title) (TextPandocMarkdown desc) shr prj = runEx
} }
return (summary, audience, offer) 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 undoFollow
:: (MonadUnliftIO m, MonadHandler m, HandlerSite m ~ App, MonadSite m, SiteEnv m ~ App) :: (MonadUnliftIO m, MonadHandler m, HandlerSite m ~ App, MonadSite m, SiteEnv m ~ App)
=> ShrIdent => ShrIdent

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

@ -347,7 +347,7 @@ projectCreateNoteF now shrRecip prjRecip author body (Note mluNote _ _ muParent
-> SharerId -> SharerId
-> FollowerSetId -> FollowerSetId
-> FollowerSetId -> FollowerSetId
-> AppDB [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, Maybe UTCTime))] -> AppDB [((InstanceId, Host), NonEmpty RemoteRecipient)]
deliverLocal ractid recips sid fsidProject fsidTicket = do deliverLocal ractid recips sid fsidProject fsidTicket = do
(teamPids, teamRemotes) <- (teamPids, teamRemotes) <-
if CreateNoteRecipTicketTeam `elem` recips if CreateNoteRecipTicketTeam `elem` recips

2
src/Vervis/Federation/Offer.hs
View file

@ -256,7 +256,7 @@ followF
newFollow <- insertFollow ractid obiid $ recipFollowers recip newFollow <- insertFollow ractid obiid $ recipFollowers recip
if newFollow if newFollow
then Right <$> do 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 iidAuthor = remoteAuthorInstance author
hAuthor = objUriAuthority $ remoteAuthorURI author hAuthor = objUriAuthority $ remoteAuthorURI author
hostSection = ((iidAuthor, hAuthor), raInfo :| []) hostSection = ((iidAuthor, hAuthor), raInfo :| [])

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

@ -298,7 +298,7 @@ projectOfferTicketF
-> [OfferTicketRecipColl] -> [OfferTicketRecipColl]
-> SharerId -> SharerId
-> FollowerSetId -> FollowerSetId
-> AppDB [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, Maybe UTCTime))] -> AppDB [((InstanceId, Host), NonEmpty RemoteRecipient)]
deliverLocal ractid recips sid fsid = do deliverLocal ractid recips sid fsid = do
(teamPids, teamRemotes) <- (teamPids, teamRemotes) <-
if OfferTicketRecipProjectTeam `elem` recips if OfferTicketRecipProjectTeam `elem` recips
@ -381,7 +381,7 @@ projectOfferTicketF
let raidAuthor = remoteAuthorId author let raidAuthor = remoteAuthorId author
ra <- getJust raidAuthor ra <- getJust raidAuthor
ro <- getJust $ remoteActorIdent ra 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 iidAuthor = remoteAuthorInstance author
hAuthor = objUriAuthority $ remoteAuthorURI author hAuthor = objUriAuthority $ remoteAuthorURI author
hostSection = ((iidAuthor, hAuthor), raInfo :| []) hostSection = ((iidAuthor, hAuthor), raInfo :| [])

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

@ -55,6 +55,7 @@ data NewTicket = NewTicket
, ntTParams :: [(WorkflowFieldId, Text)] , ntTParams :: [(WorkflowFieldId, Text)]
, ntEParams :: [(WorkflowFieldId, WorkflowEnumCtorId)] , ntEParams :: [(WorkflowFieldId, WorkflowEnumCtorId)]
, ntCParams :: [WorkflowFieldId] , ntCParams :: [WorkflowFieldId]
, ntOffer :: Bool
} }
fieldSettings :: Text -> Bool -> FieldSettings App fieldSettings :: Text -> Bool -> FieldSettings App
@ -135,6 +136,7 @@ newTicketForm wid html = do
<*> (catMaybes <$> traverse tfield tfs) <*> (catMaybes <$> traverse tfield tfs)
<*> (fmap catMaybes $ sequenceA $ mapMaybe efield efs) <*> (fmap catMaybes $ sequenceA $ mapMaybe efield efs)
<*> (catMaybes <$> traverse cfield cfs) <*> (catMaybes <$> traverse cfield cfs)
<*> areq checkBoxField "Offer" Nothing
editTicketContentAForm :: Ticket -> AForm Handler Ticket editTicketContentAForm :: Ticket -> AForm Handler Ticket
editTicketContentAForm ticket = Ticket editTicketContentAForm ticket = Ticket

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

@ -167,9 +167,23 @@ publishCommentForm html = do
defp = ObjURI (Authority "forge.angeley.es" Nothing) $ LocalURI "/s/fr33/m/2f1a7" defp = ObjURI (Authority "forge.angeley.es" Nothing) $ LocalURI "/s/fr33/m/2f1a7"
defmsg = "Hi! I'm testing federation. Can you see my message? :)" 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) :: Form ((Host, ShrIdent, PrjIdent), TextHtml, TextPandocMarkdown)
openTicketForm html = do offerTicketForm html = do
enc <- getEncodeRouteLocal enc <- getEncodeRouteLocal
flip renderDivs html $ (,,) flip renderDivs html $ (,,)
<$> areq (projectField enc) "Project" (Just defj) <$> areq (projectField enc) "Project" (Just defj)
@ -195,23 +209,30 @@ activityWidget
:: Widget -> Enctype :: Widget -> Enctype
-> Widget -> Enctype -> Widget -> Enctype
-> Widget -> Enctype -> Widget -> Enctype
-> Widget -> Enctype
-> Widget -> Widget
activityWidget widget1 enctype1 widget2 enctype2 widget3 enctype3 = activityWidget
widget1 enctype1 widget2 enctype2 widget3 enctype3 widget4 enctype4 =
[whamlet| [whamlet|
<h1>Publish a ticket comment <h1>Publish a ticket comment
<form method=POST action=@{PublishR} enctype=#{enctype1}> <form method=POST action=@{PublishR} enctype=#{enctype1}>
^{widget1} ^{widget1}
<input type=submit> <input type=submit>
<h1>Open a new ticket <h1>Open a new ticket (via Create)
<form method=POST action=@{PublishR} enctype=#{enctype2}> <form method=POST action=@{PublishR} enctype=#{enctype2}>
^{widget2} ^{widget2}
<input type=submit> <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}> <form method=POST action=@{PublishR} enctype=#{enctype3}>
^{widget3} ^{widget3}
<input type=submit> <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) getUser :: Handler (ShrIdent, PersonId)
@ -228,11 +249,14 @@ getPublishR = do
((_result1, widget1), enctype1) <- ((_result1, widget1), enctype1) <-
runFormPost $ identifyForm "f1" publishCommentForm runFormPost $ identifyForm "f1" publishCommentForm
((_result2, widget2), enctype2) <- ((_result2, widget2), enctype2) <-
runFormPost $ identifyForm "f2" openTicketForm runFormPost $ identifyForm "f2" createTicketForm
((_result3, widget3), enctype3) <- ((_result3, widget3), enctype3) <-
runFormPost $ identifyForm "f3" followForm runFormPost $ identifyForm "f3" offerTicketForm
((_result4, widget4), enctype4) <-
runFormPost $ identifyForm "f4" followForm
defaultLayout $ defaultLayout $
activityWidget widget1 enctype1 widget2 enctype2 widget3 enctype3 activityWidget
widget1 enctype1 widget2 enctype2 widget3 enctype3 widget4 enctype4
postSharerOutboxR :: ShrIdent -> Handler Html postSharerOutboxR :: ShrIdent -> Handler Html
postSharerOutboxR _shrAuthor = do postSharerOutboxR _shrAuthor = do
@ -240,8 +264,8 @@ postSharerOutboxR _shrAuthor = do
unless federation badMethod unless federation badMethod
error error
"ActivityPub C2S outbox POST not implemented yet, but you can public \ "ActivityPub C2S outbox POST not implemented yet, but you can post \
\activities via the /publish page" \public activities via the /publish page"
postPublishR :: Handler Html postPublishR :: Handler Html
postPublishR = do postPublishR = do
@ -251,15 +275,20 @@ postPublishR = do
((result1, widget1), enctype1) <- ((result1, widget1), enctype1) <-
runFormPost $ identifyForm "f1" publishCommentForm runFormPost $ identifyForm "f1" publishCommentForm
((result2, widget2), enctype2) <- ((result2, widget2), enctype2) <-
runFormPost $ identifyForm "f2" openTicketForm runFormPost $ identifyForm "f2" createTicketForm
((result3, widget3), enctype3) <- ((result3, widget3), enctype3) <-
runFormPost $ identifyForm "f3" followForm runFormPost $ identifyForm "f3" offerTicketForm
((result4, widget4), enctype4) <-
runFormPost $ identifyForm "f4" followForm
let result let result
= Left <$> result1 = Left . Left <$> result1
<|> Right . Left <$> result2 <|> Left . Right <$> result2
<|> Right . Right <$> result3 <|> Right . Left <$> result3
<|> Right . Right <$> result4
shrAuthor <- getUserShrIdent ep@(Entity _ p) <- requireVerifiedAuth
s <- runDB $ getJust $ personIdent p
let shrAuthor = sharerIdent s
eid <- runExceptT $ do eid <- runExceptT $ do
input <- input <-
@ -267,16 +296,21 @@ postPublishR = do
FormMissing -> throwE "Field(s) missing" FormMissing -> throwE "Field(s) missing"
FormFailure _l -> throwE "Invalid input, see below" FormFailure _l -> throwE "Invalid input, see below"
FormSuccess r -> return r 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 case eid of
Left err -> setMessage $ toHtml err Left err -> setMessage $ toHtml err
Right id_ -> Right id_ ->
case id_ of case id_ of
Left lmid -> do Left (Left lmid) -> do
lmkhid <- encodeKeyHashid lmid lmkhid <- encodeKeyHashid lmid
renderUrl <- getUrlRender renderUrl <- getUrlRender
let u = renderUrl $ MessageR shrAuthor lmkhid let u = renderUrl $ MessageR shrAuthor lmkhid
setMessage $ toHtml $ "Message created! ID: " <> u 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) -> Right (Left _obiid) ->
setMessage "Ticket offer published!" setMessage "Ticket offer published!"
Right (Right _obiid) -> Right (Right _obiid) ->
@ -286,6 +320,7 @@ postPublishR = do
widget1 enctype1 widget1 enctype1
widget2 enctype2 widget2 enctype2
widget3 enctype3 widget3 enctype3
widget4 enctype4
where where
publishComment shrAuthor ((hTicket, shrTicket, prj, num), muParent, msg) = do publishComment shrAuthor ((hTicket, shrTicket, prj, num), muParent, msg) = do
encodeRouteFed <- getEncodeRouteHome encodeRouteFed <- getEncodeRouteHome
@ -319,6 +354,15 @@ postPublishR = do
, noteContent = contentHtml , noteContent = contentHtml
} }
ExceptT $ createNoteC hLocal note 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 openTicket shrAuthor ((h, shr, prj), TextHtml title, TextPandocMarkdown desc) = do
encodeRouteLocal <- getEncodeRouteLocal encodeRouteLocal <- getEncodeRouteLocal
encodeRouteFed <- getEncodeRouteFed encodeRouteFed <- getEncodeRouteFed
@ -664,12 +708,14 @@ postTicketsR shr prj = do
return $ projectWorkflow j return $ projectWorkflow j
((result, widget), enctype) <- runFormPost $ newTicketForm wid ((result, widget), enctype) <- runFormPost $ newTicketForm wid
shrAuthor <- do (eperson, sharer) <- do
Entity _ p <- requireVerifiedAuth ep@(Entity _ p) <- requireVerifiedAuth
runDB $ sharerIdent <$> getJust (personIdent p) s <- runDB $ getJust $ personIdent p
return (ep, s)
let shrAuthor = sharerIdent sharer
eltid <- runExceptT $ do eid <- runExceptT $ do
NewTicket title desc tparams eparams cparams <- NewTicket title desc tparams eparams cparams offer <-
case result of case result of
FormMissing -> throwE "Field(s) missing." FormMissing -> throwE "Field(s) missing."
FormFailure _l -> FormFailure _l ->
@ -691,6 +737,8 @@ postTicketsR shr prj = do
} }
insertMany_ $ map mkeparam $ ntEParams nt insertMany_ $ map mkeparam $ ntEParams nt
-} -}
if offer
then Right <$> do
(summary, audience, offer) <- (summary, audience, offer) <-
ExceptT $ offerTicket shrAuthor (TextHtml title) (TextPandocMarkdown desc) shr prj ExceptT $ offerTicket shrAuthor (TextHtml title) (TextPandocMarkdown desc) shr prj
obiid <- ExceptT $ offerTicketC shrAuthor summary audience offer obiid <- ExceptT $ offerTicketC shrAuthor summary audience offer
@ -703,11 +751,24 @@ postTicketsR shr prj = do
"Offer processed successfully but no ticket \ "Offer processed successfully but no ticket \
\created" \created"
Just tal -> Right $ ticketAuthorLocalTicket tal 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 Left e -> do
setMessage $ toHtml e setMessage $ toHtml e
defaultLayout $(widgetFile "ticket/new") 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 ltkhid <- encodeKeyHashid ltid
eobiidFollow <- runExceptT $ do eobiidFollow <- runExceptT $ do
(summary, audience, follow) <- followTicket shrAuthor shr prj ltkhid False (summary, audience, follow) <- followTicket shrAuthor shr prj ltkhid False

2
src/Vervis/Migration.hs
View file

@ -1507,6 +1507,8 @@ changes hLocal ctx =
, removeField "RemoteMessage" "ident" , removeField "RemoteMessage" "ident"
-- 233 -- 233
, renameField "RemoteMessage" "identNew" "ident" , renameField "RemoteMessage" "identNew" "ident"
-- 234
, addEntities model_2020_02_22
] ]
migrateDB migrateDB

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

@ -180,6 +180,7 @@ module Vervis.Migration.Model
, RemoteObject227Generic (..) , RemoteObject227Generic (..)
, RemoteMessage227 , RemoteMessage227
, RemoteMessage227Generic (..) , RemoteMessage227Generic (..)
, model_2020_02_22
) )
where where
@ -350,3 +351,6 @@ makeEntitiesMigration "223"
makeEntitiesMigration "227" makeEntitiesMigration "227"
$(modelFile "migrations/2020_02_10_rm_point_to_ro.model") $(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")