C2S: Rewrite createNoteC based on createTicketC

This commit is contained in:
fr33domlover 2020-05-01 17:48:01 +00:00
parent 23056b3b3c
commit edaa3c49b2
8 changed files with 487 additions and 388 deletions

View file

@ -1,6 +1,6 @@
{- This file is part of Vervis. {- This file is part of Vervis.
- -
- Written in 2019 by fr33domlover <fr33domlover@riseup.net>. - Written in 2019, 2020 by fr33domlover <fr33domlover@riseup.net>.
- -
- Copying is an act of love. Please copy, reuse and share. - Copying is an act of love. Please copy, reuse and share.
- -
@ -15,10 +15,12 @@
module Database.Persist.Local module Database.Persist.Local
( idAndNew ( idAndNew
, valAndNew
, getKeyBy , getKeyBy
, getValBy , getValBy
, insertUnique_ , insertUnique_
, insertBy' , insertBy'
, insertByEntity'
) )
where where
@ -28,6 +30,7 @@ import Control.Monad
import Control.Monad.IO.Class import Control.Monad.IO.Class
import Control.Monad.Trans.Maybe import Control.Monad.Trans.Maybe
import Control.Monad.Trans.Reader import Control.Monad.Trans.Reader
import Data.Bifunctor
import Database.Persist import Database.Persist
import qualified Data.Text as T import qualified Data.Text as T
@ -36,6 +39,10 @@ idAndNew :: Either (Entity a) (Key a) -> (Key a, Bool)
idAndNew (Left (Entity iid _)) = (iid, False) idAndNew (Left (Entity iid _)) = (iid, False)
idAndNew (Right iid) = (iid, True) idAndNew (Right iid) = (iid, True)
valAndNew :: Either (Entity a) (Entity a) -> (a, Bool)
valAndNew (Left (Entity _ val)) = (val, False)
valAndNew (Right (Entity _ val)) = (val, True)
getKeyBy getKeyBy
:: ( MonadIO m :: ( MonadIO m
, PersistRecordBackend record backend , PersistRecordBackend record backend
@ -80,3 +87,11 @@ insertBy' val = do
"insertBy': Couldn't insert but also couldn't get the value, \ "insertBy': Couldn't insert but also couldn't get the value, \
\perhaps it was concurrently deleted or updated: " <> \perhaps it was concurrently deleted or updated: " <>
T.pack (show $ map toPersistValue $ toPersistFields val) T.pack (show $ map toPersistValue $ toPersistFields val)
insertByEntity'
:: ( MonadIO m
, PersistUniqueWrite backend
, PersistRecordBackend record backend
)
=> record -> ReaderT backend m (Either (Entity record) (Entity record))
insertByEntity' val = second (flip Entity val) <$> insertBy' val

View file

@ -14,7 +14,8 @@
-} -}
module Vervis.API module Vervis.API
( createNoteC ( noteC
, createNoteC
, createTicketC , createTicketC
, followC , followC
, offerTicketC , offerTicketC
@ -110,6 +111,7 @@ import Vervis.Model.Ident
import Vervis.Model.Ticket import Vervis.Model.Ticket
import Vervis.RemoteActorStore import Vervis.RemoteActorStore
import Vervis.Settings import Vervis.Settings
import Vervis.Ticket
verifyIsLoggedInUser verifyIsLoggedInUser
:: LocalURI :: LocalURI
@ -147,195 +149,268 @@ parseComment luParent = do
MessageR shr hid -> (shr,) <$> decodeKeyHashidE hid "Non-existent local message hashid" MessageR shr hid -> (shr,) <$> decodeKeyHashidE hid "Non-existent local message hashid"
_ -> throwE "Not a local message route" _ -> throwE "Not a local message route"
data NoteContext
= NoteContextSharerTicket ShrIdent TicketAuthorLocalId
| NoteContextProjectTicket ShrIdent PrjIdent LocalTicketId
deriving Eq
noteC
:: Entity Person
-> Sharer
-> Note URIMode
-> Handler (Either Text LocalMessageId)
noteC person sharer note = do
let shrUser = sharerIdent sharer
summary <-
TextHtml . TL.toStrict . renderHtml <$>
withUrlRenderer
[hamlet|
<p>
<a href=@{SharerR shrUser}>#{shr2text shrUser}
$maybe uContext <- noteContext note
\ commented under a #
<a href="#{renderObjURI uContext}">topic</a>.
$nothing
\ commented.
|]
createNoteC person sharer summary (noteAudience note) note
-- | Handle a Note submitted by a local user to their outbox. It can be either -- | Handle a Note submitted by a local user to their outbox. It can be either
-- a comment on a local ticket, or a comment on some remote context. Return an -- a comment on a local ticket, or a comment on some remote context. Return an
-- error message if the Note is rejected, otherwise the new 'LocalMessageId'. -- error message if the Note is rejected, otherwise the new 'LocalMessageId'.
createNoteC :: Host -> Note URIMode -> Handler (Either Text LocalMessageId) createNoteC
createNoteC host (Note mluNote luAttrib aud muParent muContext mpublished source content) = runExceptT $ do :: Entity Person
verifyHostLocal host "Attributed to non-local actor" -> Sharer
verifyNothingE mluNote "Note specifies an id" -> TextHtml
verifyNothingE mpublished "Note specifies published" -> Audience URIMode
uContext <- fromMaybeE muContext "Note without context" -> Note URIMode
(mparent, localRecips, mticket, remoteRecips) <- parseRecipsContextParent uContext muParent -> Handler (Either Text LocalMessageId)
federation <- getsYesod $ appFederation . appSettings createNoteC (Entity pidUser personUser) sharerUser summary audience note = runExceptT $ do
unless (federation || null remoteRecips) $ let shrUser = sharerIdent sharerUser
throwE "Federation disabled, but remote recipients specified" noteData@(muParent, mparent, uContext, context, source, content) <- checkNote shrUser note
(localRecips, remoteRecips) <- do
mrecips <- parseAudience audience
fromMaybeE mrecips "Create Note with no recipients"
checkFederation remoteRecips
verifyContextRecip context localRecips remoteRecips
now <- liftIO getCurrentTime
(lmid, obiid, doc, remotesHttp) <- runDBExcept $ do (lmid, obiid, doc, remotesHttp) <- runDBExcept $ do
(pid, obid, shrUser) <- verifyIsLoggedInUser luAttrib "Note attributed to different actor" obiidCreate <- lift $ insertEmptyOutboxItem (personOutbox personUser) now
(did, meparent, mcollections) <- case mticket of (mproject, did, meparent) <- getTopicAndParent context mparent
Just (shr, prj, ltkhid) -> do lmid <- lift $ insertMessage now content source obiidCreate did meparent
mt <- lift $ runMaybeT $ do docCreate <- lift $ insertCreateToOutbox now shrUser noteData obiidCreate lmid
sid <- MaybeT $ getKeyBy $ UniqueSharer shr remoteRecipsHttpCreate <- do
Entity jid j <- MaybeT $ getBy $ UniqueProject prj sid hashLT <- getEncodeKeyHashid
ltid <- decodeKeyHashidM ltkhid hashTAL <- getEncodeKeyHashid
lt <- MaybeT $ get ltid let sieve =
tpl <- let actors =
MaybeT $ getValBy $ case mproject of
UniqueTicketProjectLocal $ localTicketTicket lt Nothing -> []
guard $ ticketProjectLocalProject tpl == jid Just (shr, prj) -> [LocalActorProject shr prj]
return (sid, projectInbox j, projectFollowers j, lt) collections =
(sid, ibidProject, fsidProject, lt) <- fromMaybeE mt "Context: No such local ticket" let project =
let did = localTicketDiscuss lt case mproject of
mmidParent <- for mparent $ \ parent -> Nothing -> []
case parent of Just (shr, prj) ->
Left (shrParent, lmidParent) -> getLocalParentMessageId did shrParent lmidParent [ LocalPersonCollectionProjectTeam shr prj
Right (ObjURI hParent luParent) -> do , LocalPersonCollectionProjectFollowers shr prj
mrm <- lift $ runMaybeT $ do ]
iid <- MaybeT $ getKeyBy $ UniqueInstance hParent ticket =
roid <- MaybeT $ getKeyBy $ UniqueRemoteObject iid luParent case context of
MaybeT $ getValBy $ UniqueRemoteMessageIdent roid Left nc ->
rm <- fromMaybeE mrm "Remote parent unknown locally" case nc of
NoteContextSharerTicket shr talid ->
let talkhid = hashTAL talid
in [ LocalPersonCollectionSharerTicketTeam shr talkhid
, LocalPersonCollectionSharerTicketFollowers shr talkhid
]
NoteContextProjectTicket shr prj ltid ->
let ltkhid = hashLT ltid
in [ LocalPersonCollectionProjectTicketTeam shr prj ltkhid
, LocalPersonCollectionProjectTicketFollowers shr prj ltkhid
]
Right _ -> []
commenter = [LocalPersonCollectionSharerFollowers shrUser]
in project ++ ticket ++ commenter
in makeRecipientSet actors collections
moreRemoteRecips <-
lift $ deliverLocal' True (LocalActorSharer shrUser) (personInbox personUser) obiidCreate $
localRecipSieve' sieve True False localRecips
checkFederation moreRemoteRecips
lift $ deliverRemoteDB' (objUriAuthority uContext) obiidCreate remoteRecips moreRemoteRecips
return (lmid, obiidCreate, docCreate, remoteRecipsHttpCreate)
lift $ forkWorker "createNoteC: async HTTP delivery" $ deliverRemoteHttp (objUriAuthority uContext) obiid doc remotesHttp
return lmid
where
checkNote shrUser (Note mluNote luAttrib _aud muParent muContext mpublished source content) = do
verifyNothingE mluNote "Note specifies an id"
encodeRouteLocal <- getEncodeRouteLocal
unless (encodeRouteLocal (SharerR shrUser) == luAttrib) $
throwE "Note attributed to someone else"
verifyNothingE mpublished "Note specifies published"
uContext <- fromMaybeE muContext "Note without context"
context <- parseNoteContext uContext
mparent <- checkParent context =<< traverse parseParent muParent
return (muParent, mparent, uContext, context, source, content)
where
parseTopic name route =
case route of
SharerTicketR shr talkhid ->
NoteContextSharerTicket shr <$>
decodeKeyHashidE
talkhid
(name <> " sharer ticket invalid talkhid")
ProjectTicketR shr prj ltkhid ->
NoteContextProjectTicket shr prj <$>
decodeKeyHashidE
ltkhid
(name <> " project ticket invalid ltkhid")
_ -> throwE $ name <> " isn't a discussion topic route"
parseNoteContext u@(ObjURI h lu) = do
hl <- hostIsLocal h
if hl
then Left <$> do
route <-
fromMaybeE
(decodeRouteLocal lu)
"Note context local but not a valid route"
parseTopic "Note context" route
else return $ Right u
parseParent u@(ObjURI h lu) = do
hl <- hostIsLocal h
if hl
then Left <$> do
route <-
fromMaybeE
(decodeRouteLocal lu)
"Note parent local but not a valid route"
Left <$> parseTopic "Note parent" route <|>
Right <$> parseComment route
else return $ Right u
where
parseComment (MessageR shr lmkhid) =
(shr,) <$> decodeKeyHashidE lmkhid "Note parent invalid lmkhid"
parseComment _ = throwE "Note parent not a comment route"
checkParent _ Nothing = return Nothing
checkParent (Left topic) (Just (Left (Left topic'))) =
if topic == topic'
then return Nothing
else throwE "Note context and parent are different local topics"
checkParent _ (Just (Left (Right msg))) = return $ Just $ Left msg
checkParent (Left _) (Just (Right u)) = return $ Just $ Right u
checkParent (Right u) (Just (Right u')) =
return $
if u == u'
then Nothing
else Just $ Right u'
checkFederation remoteRecips = do
federation <- asksSite $ appFederation . appSettings
unless (federation || null remoteRecips) $
throwE "Federation disabled, but remote recipients found"
verifyContextRecip (Right (ObjURI h _)) _ remoteRecips =
unless (any ((== h) . fst) remoteRecips) $
throwE
"Context is remote but no recipients of that host are listed"
verifyContextRecip (Left (NoteContextSharerTicket shr _)) localRecips _ =
fromMaybeE
verify
"Local context ticket's hosting sharer isn't listed as a recipient"
where
verify = do
sharerSet <- lookup shr localRecips
guard $ localRecipSharer $ localRecipSharerDirect sharerSet
verifyContextRecip (Left (NoteContextProjectTicket shr prj _)) localRecips _ =
fromMaybeE
verify
"Local context ticket's hosting project isn't listed as a recipient"
where
verify = do
sharerSet <- lookup shr localRecips
projectSet <- lookup prj $ localRecipProjectRelated sharerSet
guard $ localRecipProject $ localRecipProjectDirect projectSet
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
return (sharerIdent s, projectIdent j)
getTopicAndParent (Left context) mparent = do
(mproject, did) <-
case context of
NoteContextSharerTicket shr talid -> do
(_, Entity _ lt, _, project) <- do
mticket <- lift $ getSharerTicket shr talid
fromMaybeE mticket "Note context no such local sharer-hosted ticket"
mproj <-
case project of
Left (Entity _ tpl) -> lift $ Just <$> getProject tpl
Right () -> return Nothing
return (mproj, localTicketDiscuss lt)
NoteContextProjectTicket shr prj ltid -> do
(_, _, _, Entity _ lt, _, _) <- do
mticket <- lift $ getProjectTicket shr prj ltid
fromMaybeE mticket "Note context no such local project-hosted ticket"
return (Just (shr, prj), localTicketDiscuss lt)
mmidParent <- for mparent $ \ parent ->
case parent of
Left (shrParent, lmidParent) -> getLocalParentMessageId did shrParent lmidParent
Right (ObjURI hParent luParent) -> do
mrm <- lift $ runMaybeT $ do
iid <- MaybeT $ getKeyBy $ UniqueInstance hParent
roid <- MaybeT $ getKeyBy $ UniqueRemoteObject iid luParent
MaybeT $ getValBy $ UniqueRemoteMessageIdent roid
rm <- fromMaybeE mrm "Remote parent unknown locally"
let mid = remoteMessageRest rm
m <- lift $ getJust mid
unless (messageRoot m == did) $
throwE "Remote parent belongs to a different discussion"
return mid
return (mproject, did, Left <$> mmidParent)
getTopicAndParent (Right u@(ObjURI h lu)) mparent = do
(mproject, rd, rdnew) <- lift $ do
iid <- either entityKey id <$> insertBy' (Instance h)
roid <- either entityKey id <$> insertBy' (RemoteObject iid lu)
merd <- getBy $ UniqueRemoteDiscussionIdent roid
case merd of
Just (Entity rdid rd) -> do
mproj <- do
mrt <- getValBy $ UniqueRemoteTicketDiscuss rdid
for mrt $ \ rt -> do
tar <- getJust $ remoteTicketTicket rt
tpl <- getJust $ ticketAuthorRemoteTicket tar
getProject tpl
return (mproj, rd, False)
Nothing -> do
did <- insert Discussion
(rd, rdnew) <- valAndNew <$> insertByEntity' (RemoteDiscussion roid did)
unless rdnew $ delete did
return (Nothing, rd, rdnew)
let did = remoteDiscussionDiscuss rd
meparent <- for mparent $ \ parent ->
case parent of
Left (shrParent, lmidParent) -> do
when rdnew $ throwE "Local parent inexistent, RemoteDiscussion is new"
Left <$> getLocalParentMessageId did shrParent lmidParent
Right uParent@(ObjURI hParent luParent) -> do
mrm <- lift $ runMaybeT $ do
iid <- MaybeT $ getKeyBy $ UniqueInstance hParent
roid <- MaybeT $ getKeyBy $ UniqueRemoteObject iid luParent
MaybeT $ getValBy $ UniqueRemoteMessageIdent roid
case mrm of
Nothing -> return $ Right uParent
Just rm -> Left <$> do
let mid = remoteMessageRest rm let mid = remoteMessageRest rm
m <- lift $ getJust mid m <- lift $ getJust mid
unless (messageRoot m == did) $ unless (messageRoot m == did) $
throwE "Remote parent belongs to a different discussion" throwE "Remote parent belongs to a different discussion"
return mid return mid
-- lift $ insertUnique_ $ Follow pid (ticketFollowers t) False True return (mproject, did, meparent)
return (did, Left <$> mmidParent, Just (sid, localTicketFollowers lt, ibidProject, fsidProject)) insertMessage now content source obiidCreate did meparent = do
Nothing -> do
(rd, rdnew) <- lift $ do
let ObjURI hContext luContext = uContext
iid <- either entityKey id <$> insertBy' (Instance hContext)
roid <- either entityKey id <$> insertBy' (RemoteObject iid luContext)
mrd <- getValBy $ UniqueRemoteDiscussionIdent roid
case mrd of
Just rd -> return (rd, False)
Nothing -> do
did <- insert Discussion
let rd = RemoteDiscussion roid did
erd <- insertBy' rd
case erd of
Left (Entity _ rd') -> do
delete did
return (rd', False)
Right _ -> return (rd, True)
let did = remoteDiscussionDiscuss rd
meparent <- for mparent $ \ parent ->
case parent of
Left (shrParent, lmidParent) -> do
when rdnew $ throwE "Local parent inexistent, RemoteDiscussion is new"
Left <$> getLocalParentMessageId did shrParent lmidParent
Right p@(ObjURI hParent luParent) -> do
mrm <- lift $ runMaybeT $ do
iid <- MaybeT $ getKeyBy $ UniqueInstance hParent
roid <- MaybeT $ getKeyBy $ UniqueRemoteObject iid luParent
MaybeT $ getValBy $ UniqueRemoteMessageIdent roid
case mrm of
Nothing -> return $ Right p
Just rm -> Left <$> do
let mid = remoteMessageRest rm
m <- lift $ getJust mid
unless (messageRoot m == did) $
throwE "Remote parent belongs to a different discussion"
return mid
return (did, meparent, Nothing)
summary <-
withUrlRenderer
[hamlet|
<p>
<a href=@{SharerR shrUser}>#{shr2text shrUser}
\ commented on a #
<a href=#{renderObjURI uContext}>ticket</a>.
|]
(lmid, obiid, doc) <- lift $ insertMessage luAttrib shrUser pid obid uContext did muParent meparent source content summary
moreRemotes <- deliverLocal pid obiid localRecips mcollections
unless (federation || null moreRemotes) $
throwE "Federation disabled but remote collection members found"
remotesHttp <- lift $ deliverRemoteDB' (objUriAuthority uContext) obiid remoteRecips moreRemotes
return (lmid, obiid, doc, remotesHttp)
lift $ forkWorker "Outbox POST handler: async HTTP delivery" $ deliverRemoteHttp (objUriAuthority uContext) obiid doc remotesHttp
return lmid
where
parseRecipsContextParent
:: FedURI
-> Maybe FedURI
-> ExceptT Text Handler
( Maybe (Either (ShrIdent, LocalMessageId) FedURI)
, [ShrIdent]
, Maybe (ShrIdent, PrjIdent, KeyHashid LocalTicket)
, [(Host, NonEmpty LocalURI)]
)
parseRecipsContextParent uContext muParent = do
(localsSet, remotes) <- do
mrecips <- parseAudience aud
fromMaybeE mrecips "Note without recipients"
let ObjURI hContext luContext = uContext
parent <- parseParent uContext muParent
local <- hostIsLocal hContext
if local
then do
ticket <- parseContextTicket luContext
shrs <- verifyTicketRecipients ticket localsSet
return (parent, shrs, Just ticket, remotes)
else do
shrs <- verifyOnlySharers localsSet
return (parent, shrs, Nothing, remotes)
where
parseParent :: FedURI -> Maybe FedURI -> ExceptT Text Handler (Maybe (Either (ShrIdent, LocalMessageId) FedURI))
parseParent _ Nothing = return Nothing
parseParent uContext (Just uParent) =
if uParent == uContext
then return Nothing
else Just <$> do
let ObjURI hParent luParent = uParent
parentLocal <- hostIsLocal hParent
if parentLocal
then Left <$> parseComment luParent
else return $ Right uParent
parseContextTicket :: Monad m => LocalURI -> ExceptT Text m (ShrIdent, PrjIdent, KeyHashid LocalTicket)
parseContextTicket luContext = do
route <- case decodeRouteLocal luContext of
Nothing -> throwE "Local context isn't a valid route"
Just r -> return r
case route of
ProjectTicketR shr prj num -> return (shr, prj, num)
_ -> throwE "Local context isn't a ticket route"
atMostSharer :: e -> (ShrIdent, LocalSharerRelatedSet) -> ExceptT e Handler (Maybe ShrIdent)
atMostSharer _ (shr, LocalSharerRelatedSet s [] [] []) = return $ if localRecipSharer s then Just shr else Nothing
atMostSharer e (_ , LocalSharerRelatedSet _ _ _ _ ) = throwE e
verifyTicketRecipients :: (ShrIdent, PrjIdent, KeyHashid LocalTicket) -> LocalRecipientSet -> ExceptT Text Handler [ShrIdent]
verifyTicketRecipients (shr, prj, num) recips = do
lsrSet <- fromMaybeE (lookupSorted shr recips) "Note with local context: No required recipients"
(prj', lprSet) <- verifySingleton (localRecipProjectRelated lsrSet) "Note project-related recipient sets"
unless (prj == prj') $ throwE "Note project recipients mismatch context's project"
unless (localRecipProject $ localRecipProjectDirect lprSet) $ throwE "Note context's project not addressed"
unless (localRecipProjectFollowers $ localRecipProjectDirect lprSet) $ throwE "Note context's project followers not addressed"
(num', ltrSet) <- verifySingleton (localRecipProjectTicketRelated lprSet) "Note ticket-related recipient sets"
unless (num == num') $ throwE "Note project recipients mismatch context's ticket number"
unless (localRecipTicketTeam ltrSet) $
throwE "Note ticket team not addressed"
unless (localRecipTicketFollowers ltrSet) $
throwE "Note ticket participants not addressed"
let rest = deleteBy ((==) `on` fst) (shr, lsrSet) recips
orig = if localRecipSharer $ localRecipSharerDirect lsrSet then Just shr else Nothing
catMaybes . (orig :) <$> traverse (atMostSharer "Note with unrelated non-sharer recipients") rest
where
verifySingleton :: Monad m => [a] -> Text -> ExceptT Text m a
verifySingleton [] t = throwE $ t <> ": expected 1, got 0"
verifySingleton [x] _ = return x
verifySingleton l t = throwE $ t <> ": expected 1, got " <> T.pack (show $ length l)
verifyOnlySharers :: LocalRecipientSet -> ExceptT Text Handler [ShrIdent]
verifyOnlySharers lrs = catMaybes <$> traverse (atMostSharer "Note with remote context but local project-related recipients") lrs
insertMessage
:: LocalURI
-> ShrIdent
-> PersonId
-> OutboxId
-> FedURI
-> DiscussionId
-> Maybe FedURI
-> Maybe (Either MessageId FedURI)
-> Text
-> Text
-> Html
-> AppDB (LocalMessageId, OutboxItemId, Doc Activity URIMode)
insertMessage luAttrib shrUser pid obid uContext did muParent meparent source content summary = do
now <- liftIO getCurrentTime
mid <- insert Message mid <- insert Message
{ messageCreated = now { messageCreated = now
, messageSource = source , messageSource = source
@ -346,17 +421,31 @@ createNoteC host (Note mluNote luAttrib aud muParent muContext mpublished source
_ -> Nothing _ -> Nothing
, messageRoot = did , messageRoot = did
} }
let activity luAct luNote = Doc host Activity insert LocalMessage
{ activityId = Just luAct { localMessageAuthor = pidUser
, localMessageRest = mid
, localMessageCreate = obiidCreate
, localMessageUnlinkedParent =
case meparent of
Just (Right uParent) -> Just uParent
_ -> Nothing
}
insertCreateToOutbox now shrUser (muParent, _mparent, uContext, _context, source, content) obiidCreate lmid = do
encodeRouteLocal <- getEncodeRouteLocal
hLocal <- asksSite siteInstanceHost
obikhid <- encodeKeyHashid obiidCreate
lmkhid <- encodeKeyHashid lmid
let luAttrib = encodeRouteLocal $ SharerR shrUser
create = Doc hLocal Activity
{ activityId = Just $ encodeRouteLocal $ SharerOutboxItemR shrUser obikhid
, activityActor = luAttrib , activityActor = luAttrib
, activitySummary = , activitySummary = Just summary
Just $ TextHtml $ TL.toStrict $ renderHtml summary , activityAudience = audience
, activityAudience = aud
, activitySpecific = CreateActivity Create , activitySpecific = CreateActivity Create
{ createObject = CreateNote Note { createObject = CreateNote Note
{ noteId = Just luNote { noteId = Just $ encodeRouteLocal $ MessageR shrUser lmkhid
, noteAttrib = luAttrib , noteAttrib = luAttrib
, noteAudience = aud , noteAudience = emptyAudience
, noteReplyTo = Just $ fromMaybe uContext muParent , noteReplyTo = Just $ fromMaybe uContext muParent
, noteContext = Just uContext , noteContext = Just uContext
, notePublished = Just now , notePublished = Just now
@ -366,90 +455,8 @@ createNoteC host (Note mluNote luAttrib aud muParent muContext mpublished source
, createTarget = Nothing , createTarget = Nothing
} }
} }
tempUri = topLocalURI update obiidCreate [OutboxItemActivity =. persistJSONObjectFromDoc create]
obiid <- insert OutboxItem return create
{ outboxItemOutbox = obid
, outboxItemActivity =
persistJSONObjectFromDoc $ activity tempUri tempUri
, outboxItemPublished = now
}
lmid <- insert LocalMessage
{ localMessageAuthor = pid
, localMessageRest = mid
, localMessageCreate = obiid
, localMessageUnlinkedParent =
case meparent of
Just (Right uParent) -> Just uParent
_ -> Nothing
}
route2local <- getEncodeRouteLocal
obihid <- encodeKeyHashid obiid
lmhid <- encodeKeyHashid lmid
let luAct = route2local $ SharerOutboxItemR shrUser obihid
luNote = route2local $ MessageR shrUser lmhid
doc = activity luAct luNote
update obiid [OutboxItemActivity =. persistJSONObjectFromDoc doc]
return (lmid, obiid, doc)
-- Deliver to local recipients. For local users, find in DB and deliver.
-- For local collections, expand them, deliver to local users, and return a
-- list of remote actors found in them.
deliverLocal
:: PersonId
-> OutboxItemId
-> [ShrIdent]
-> Maybe (SharerId, FollowerSetId, InboxId, FollowerSetId)
-> ExceptT Text AppDB [((InstanceId, Host), NonEmpty RemoteRecipient)]
deliverLocal pidAuthor obid recips mticket = do
recipPids <- traverse getPersonId $ nub recips
when (pidAuthor `elem` recipPids) $
throwE "Note addressed to note author"
(morePids, remotes) <-
lift $ case mticket of
Nothing -> return ([], [])
Just (sid, fsidT, _, fsidJ) -> do
(teamPids, teamRemotes) <- getTicketTeam sid
(tfsPids, tfsRemotes) <- getFollowers fsidT
(jfsPids, jfsRemotes) <- getFollowers fsidJ
return
( L.delete pidAuthor $ union teamPids $ union tfsPids jfsPids
, teamRemotes `unionRemotes` tfsRemotes `unionRemotes` jfsRemotes
)
lift $ do
for_ mticket $ \ (_, _, ibidProject, _) -> do
ibiid <- insert $ InboxItem False
insert_ $ InboxItemLocal ibidProject obid ibiid
for_ (union recipPids morePids) $ \ pid -> do
ibid <- personInbox <$> getJust pid
ibiid <- insert $ InboxItem True
insert_ $ InboxItemLocal ibid obid ibiid
return remotes
where
getPersonId :: ShrIdent -> ExceptT Text AppDB PersonId
getPersonId shr = do
msid <- lift $ getKeyBy $ UniqueSharer shr
sid <- fromMaybeE msid "Local Note addresses nonexistent local sharer"
id_ <- lift $ getPersonOrGroupId sid
case id_ of
Left pid -> return pid
Right _gid -> throwE "Local Note addresses a local group"
{-
-- Deliver to a local sharer, if they exist as a user account
deliverToLocalSharer :: OutboxItemId -> ShrIdent -> ExceptT Text AppDB ()
deliverToLocalSharer obid shr = do
msid <- lift $ getKeyBy $ UniqueSharer shr
sid <- fromMaybeE msid "Local Note addresses nonexistent local sharer"
mpid <- lift $ getKeyBy $ UniquePersonIdent sid
mgid <- lift $ getKeyBy $ UniqueGroup sid
id_ <-
requireEitherM mpid mgid
"Found sharer that is neither person nor group"
"Found sharer that is both person and group"
case id_ of
Left pid -> lift $ insert_ $ InboxItemLocal pid obid
Right _gid -> throwE "Local Note addresses a local group"
-}
-- | Handle a Ticket submitted by a local user to their outbox. The ticket's -- | 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 -- context project may be local or remote. Return an error message if the
@ -983,8 +990,9 @@ offerTicketC shrUser summary audience offer@(Offer ticket uTarget) = runExceptT
else verifyOnlySharer lsrSet else verifyOnlySharer lsrSet
where where
offerRecips prj = LocalSharerRelatedSet offerRecips prj = LocalSharerRelatedSet
{ localRecipSharerDirect = LocalSharerDirectSet False False { localRecipSharerDirect = LocalSharerDirectSet False False
, localRecipProjectRelated = , localRecipSharerTicketRelated = []
, localRecipProjectRelated =
[ ( prj [ ( prj
, LocalProjectRelatedSet , LocalProjectRelatedSet
{ localRecipProjectDirect = { localRecipProjectDirect =
@ -993,7 +1001,7 @@ offerTicketC shrUser summary audience offer@(Offer ticket uTarget) = runExceptT
} }
) )
] ]
, localRecipRepoRelated = [] , localRecipRepoRelated = []
} }
verifyOnlySharer lsrSet = do verifyOnlySharer lsrSet = do
unless (null $ localRecipProjectRelated lsrSet) $ unless (null $ localRecipProjectRelated lsrSet) $

View file

@ -32,6 +32,7 @@ module Vervis.ActivityPub.Recipient
, parseAudience , parseAudience
, actorRecips , actorRecips
, localRecipSieve , localRecipSieve
, localRecipSieve'
) )
where where
@ -454,22 +455,31 @@ actorRecips = groupLocalRecipients . (: []) . groupedRecipientFromActor
localRecipSieve localRecipSieve
:: LocalRecipientSet -> Bool -> LocalRecipientSet -> LocalRecipientSet :: LocalRecipientSet -> Bool -> LocalRecipientSet -> LocalRecipientSet
localRecipSieve sieve allowActors = localRecipSieve sieve allowActors =
localRecipSieve' sieve allowActors allowActors
localRecipSieve'
:: LocalRecipientSet
-> Bool
-> Bool
-> LocalRecipientSet
-> LocalRecipientSet
localRecipSieve' sieve allowSharers allowOthers =
mapMaybe (uncurry applySharerRelated) . sortAlign sieve mapMaybe (uncurry applySharerRelated) . sortAlign sieve
where where
onlyActorsJ (LocalProjectRelatedSet (LocalProjectDirectSet j _t _f) _ts) = onlyActorsJ (LocalProjectRelatedSet (LocalProjectDirectSet j _t _f) _ts) =
LocalProjectRelatedSet (LocalProjectDirectSet j False False) [] LocalProjectRelatedSet (LocalProjectDirectSet (j && allowOthers) False False) []
onlyActorsR (LocalRepoRelatedSet (LocalRepoDirectSet r _t _f)) = onlyActorsR (LocalRepoRelatedSet (LocalRepoDirectSet r _t _f)) =
LocalRepoRelatedSet $ LocalRepoDirectSet r False False LocalRepoRelatedSet $ LocalRepoDirectSet (r && allowOthers) False False
onlyActorsS (LocalSharerRelatedSet (LocalSharerDirectSet s _f) _ts js rs) = onlyActorsS (LocalSharerRelatedSet (LocalSharerDirectSet s _f) _ts js rs) =
LocalSharerRelatedSet LocalSharerRelatedSet
(LocalSharerDirectSet s False) (LocalSharerDirectSet (s && allowSharers) False)
[] []
(map (second onlyActorsJ) js) (map (second onlyActorsJ) js)
(map (second onlyActorsR) rs) (map (second onlyActorsR) rs)
applySharerRelated _ (This _) = Nothing applySharerRelated _ (This _) = Nothing
applySharerRelated shr (That s) = applySharerRelated shr (That s) =
if allowActors if allowSharers || allowOthers
then Just (shr, onlyActorsS s) then Just (shr, onlyActorsS s)
else Nothing else Nothing
applySharerRelated shr (These (LocalSharerRelatedSet s' t' j' r') (LocalSharerRelatedSet s t j r)) = applySharerRelated shr (These (LocalSharerRelatedSet s' t' j' r') (LocalSharerRelatedSet s t j r)) =
@ -483,7 +493,7 @@ localRecipSieve sieve allowActors =
) )
where where
applySharer (LocalSharerDirectSet s' f') (LocalSharerDirectSet s f) = applySharer (LocalSharerDirectSet s' f') (LocalSharerDirectSet s f) =
LocalSharerDirectSet (s && (s' || allowActors)) (f && f') LocalSharerDirectSet (s && (s' || allowSharers)) (f && f')
applyTicketRelated ltkhid (These t' t) = Just (ltkhid, applyTicket t' t) applyTicketRelated ltkhid (These t' t) = Just (ltkhid, applyTicket t' t)
where where
@ -493,7 +503,7 @@ localRecipSieve sieve allowActors =
applyProjectRelated _ (This _) = Nothing applyProjectRelated _ (This _) = Nothing
applyProjectRelated prj (That j) = applyProjectRelated prj (That j) =
if allowActors if allowOthers
then Just (prj, onlyActorsJ j) then Just (prj, onlyActorsJ j)
else Nothing else Nothing
applyProjectRelated prj (These (LocalProjectRelatedSet j' t') (LocalProjectRelatedSet j t)) = applyProjectRelated prj (These (LocalProjectRelatedSet j' t') (LocalProjectRelatedSet j t)) =
@ -505,15 +515,15 @@ localRecipSieve sieve allowActors =
) )
where where
applyProject (LocalProjectDirectSet j' t' f') (LocalProjectDirectSet j t f) = applyProject (LocalProjectDirectSet j' t' f') (LocalProjectDirectSet j t f) =
LocalProjectDirectSet (j && (j' || allowActors)) (t && t') (f && f') LocalProjectDirectSet (j && (j' || allowOthers)) (t && t') (f && f')
applyRepoRelated _ (This _) = Nothing applyRepoRelated _ (This _) = Nothing
applyRepoRelated rp (That r) = applyRepoRelated rp (That r) =
if allowActors if allowOthers
then Just (rp, onlyActorsR r) then Just (rp, onlyActorsR r)
else Nothing else Nothing
applyRepoRelated rp (These (LocalRepoRelatedSet r') (LocalRepoRelatedSet r)) = applyRepoRelated rp (These (LocalRepoRelatedSet r') (LocalRepoRelatedSet r)) =
Just (rp, LocalRepoRelatedSet $ applyRepo r' r) Just (rp, LocalRepoRelatedSet $ applyRepo r' r)
where where
applyRepo (LocalRepoDirectSet r' t' f') (LocalRepoDirectSet r t f) = applyRepo (LocalRepoDirectSet r' t' f') (LocalRepoDirectSet r t f) =
LocalRepoDirectSet (r && (r' || allowActors)) (t && t') (f && f') LocalRepoDirectSet (r && (r' || allowOthers)) (t && t') (f && f')

View file

@ -296,7 +296,7 @@ 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 (bitraverse (publishComment shrAuthor) (publishTicket ep s)) (bitraverse (openTicket shrAuthor) (follow shrAuthor)) input bitraverse (bitraverse (publishComment ep s) (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_ ->
@ -322,13 +322,14 @@ postPublishR = do
widget3 enctype3 widget3 enctype3
widget4 enctype4 widget4 enctype4
where where
publishComment shrAuthor ((hTicket, shrTicket, prj, num), muParent, msg) = do publishComment eperson sharer ((hTicket, shrTicket, prj, num), muParent, msg) = do
encodeRouteFed <- getEncodeRouteHome encodeRouteFed <- getEncodeRouteHome
encodeRouteLocal <- getEncodeRouteLocal encodeRouteLocal <- getEncodeRouteLocal
let msg' = T.filter (/= '\r') msg let msg' = T.filter (/= '\r') msg
contentHtml <- ExceptT . pure $ renderPandocMarkdown msg' contentHtml <- ExceptT . pure $ renderPandocMarkdown msg'
let encodeRecipRoute = ObjURI hTicket . encodeRouteLocal let encodeRecipRoute = ObjURI hTicket . encodeRouteLocal
uTicket = encodeRecipRoute $ ProjectTicketR shrTicket prj num uTicket = encodeRecipRoute $ ProjectTicketR shrTicket prj num
shrAuthor = sharerIdent sharer
ObjURI hLocal luAuthor = encodeRouteFed $ SharerR shrAuthor ObjURI hLocal luAuthor = encodeRouteFed $ SharerR shrAuthor
collections = collections =
[ ProjectFollowersR shrTicket prj [ ProjectFollowersR shrTicket prj
@ -353,7 +354,7 @@ postPublishR = do
, noteSource = msg' , noteSource = msg'
, noteContent = contentHtml , noteContent = contentHtml
} }
ExceptT $ createNoteC hLocal note ExceptT $ noteC eperson sharer note
publishTicket eperson sharer (target, context, title, desc) = do publishTicket eperson sharer (target, context, title, desc) = do
(summary, audience, create) <- (summary, audience, create) <-
ExceptT $ C.createTicket (sharerIdent sharer) title desc target context ExceptT $ C.createTicket (sharerIdent sharer) title desc target context

View file

@ -209,18 +209,19 @@ postTopReply
-> Handler Html -> Handler Html
postTopReply hDest recipsA recipsC context recipF replyP after = do postTopReply hDest recipsA recipsC context recipF replyP after = do
((result, widget), enctype) <- runFormPost newMessageForm ((result, widget), enctype) <- runFormPost newMessageForm
shrAuthor <- do (eperson, sharer) <- do
Entity _ p <- requireVerifiedAuth ep@(Entity _ p) <- requireVerifiedAuth
runDB $ sharerIdent <$> get404 (personIdent p) s <- runDB $ get404 (personIdent p)
return (ep, s)
let shrAuthor = sharerIdent sharer
elmid <- runExceptT $ do elmid <- runExceptT $ do
msg <- case result of msg <- case result of
FormMissing -> throwE "Field(s) missing." FormMissing -> throwE "Field(s) missing."
FormFailure _l -> throwE "Message submission failed, see errors below." FormFailure _l -> throwE "Message submission failed, see errors below."
FormSuccess nm -> FormSuccess nm ->
return $ TextPandocMarkdown $ T.filter (/= '\r') $ nmContent nm return $ TextPandocMarkdown $ T.filter (/= '\r') $ nmContent nm
hLocal <- asksSite siteInstanceHost
note <- ExceptT $ createThread shrAuthor msg hDest recipsA recipsC context note <- ExceptT $ createThread shrAuthor msg hDest recipsA recipsC context
ExceptT $ createNoteC hLocal note ExceptT $ noteC eperson sharer note
case elmid of case elmid of
Left e -> do Left e -> do
setMessage $ toHtml e setMessage $ toHtml e
@ -264,18 +265,19 @@ postReply
-> Handler Html -> Handler Html
postReply hDest recipsA recipsC context recipF replyG replyP after getdid midParent = do postReply hDest recipsA recipsC context recipF replyG replyP after getdid midParent = do
((result, widget), enctype) <- runFormPost newMessageForm ((result, widget), enctype) <- runFormPost newMessageForm
shrAuthor <- do (eperson, sharer) <- do
Entity _ p <- requireVerifiedAuth ep@(Entity _ p) <- requireVerifiedAuth
runDB $ sharerIdent <$> get404 (personIdent p) s <- runDB $ get404 (personIdent p)
return (ep, s)
let shrAuthor = sharerIdent sharer
elmid <- runExceptT $ do elmid <- runExceptT $ do
msg <- case result of msg <- case result of
FormMissing -> throwE "Field(s) missing." FormMissing -> throwE "Field(s) missing."
FormFailure _l -> throwE "Message submission failed, see errors below." FormFailure _l -> throwE "Message submission failed, see errors below."
FormSuccess nm -> FormSuccess nm ->
return $ TextPandocMarkdown $ T.filter (/= '\r') $ nmContent nm return $ TextPandocMarkdown $ T.filter (/= '\r') $ nmContent nm
hLocal <- asksSite siteInstanceHost
note <- ExceptT $ createReply shrAuthor msg hDest recipsA recipsC context midParent note <- ExceptT $ createReply shrAuthor msg hDest recipsA recipsC context midParent
ExceptT $ createNoteC hLocal note ExceptT $ noteC eperson sharer note
case elmid of case elmid of
Left e -> do Left e -> do
setMessage $ toHtml e setMessage $ toHtml e

View file

@ -266,31 +266,6 @@ getProjectTicketNewR shr prj = do
((_result, widget), enctype) <- runFormPost $ newTicketForm wid ((_result, widget), enctype) <- runFormPost $ newTicketForm wid
defaultLayout $(widgetFile "ticket/new") defaultLayout $(widgetFile "ticket/new")
getProjectTicket :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> AppDB (Entity Sharer, Entity Project, Entity Ticket, Entity LocalTicket, Entity TicketProjectLocal, Either (Entity TicketAuthorLocal) (Entity TicketAuthorRemote))
getProjectTicket shr prj ltkhid = do
es@(Entity sid _) <- getBy404 $ UniqueSharer shr
ej@(Entity jid _) <- getBy404 $ UniqueProject prj sid
ltid <- decodeKeyHashid404 ltkhid
lt <- get404 ltid
let tid = localTicketTicket lt
t <- get404 tid
etpl@(Entity tplid tpl) <- getBy404 $ UniqueTicketProjectLocal tid
unless (ticketProjectLocalProject tpl == jid) notFound
author <-
requireEitherAlt
(do mtal <- getBy $ UniqueTicketAuthorLocal ltid
for mtal $ \ tal@(Entity talid _) -> do
tupid1 <- getKeyBy404 $ UniqueTicketUnderProjectProject tplid
tupid2 <- getKeyBy404 $ UniqueTicketUnderProjectAuthor talid
unless (tupid1 == tupid2) $
error "TAL and TPL used by different TUPs!"
return tal
)
(getBy $ UniqueTicketAuthorRemote tplid)
"Ticket doesn't have author"
"Ticket has both local and remote author"
return (es, ej, Entity tid t, Entity ltid lt, etpl, author)
getProjectTicketR :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler TypedContent getProjectTicketR :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler TypedContent
getProjectTicketR shar proj ltkhid = do getProjectTicketR shar proj ltkhid = do
mpid <- maybeAuthId mpid <- maybeAuthId
@ -298,7 +273,7 @@ getProjectTicketR shar proj ltkhid = do
author, massignee, mcloser, ticket, lticket, tparams, eparams, cparams, author, massignee, mcloser, ticket, lticket, tparams, eparams, cparams,
deps, rdeps) <- deps, rdeps) <-
runDB $ do runDB $ do
(Entity sid sharer, Entity jid project, Entity tid ticket, Entity _ lticket, _etpl, author) <- getProjectTicket shar proj ltkhid (Entity sid sharer, Entity jid project, Entity tid ticket, Entity _ lticket, _etpl, author) <- getProjectTicket404 shar proj ltkhid
(wshr, wid, wfl) <- do (wshr, wid, wfl) <- do
w <- get404 $ projectWorkflow project w <- get404 $ projectWorkflow project
wsharer <- wsharer <-
@ -428,7 +403,7 @@ getProjectTicketR shar proj ltkhid = do
putProjectTicketR :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler Html putProjectTicketR :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler Html
putProjectTicketR shr prj ltkhid = do putProjectTicketR shr prj ltkhid = do
(tid, ticket, wid) <- runDB $ do (tid, ticket, wid) <- runDB $ do
(_es, Entity _ project, Entity tid ticket, _elt, _etpl, _author) <- getProjectTicket shr prj ltkhid (_es, Entity _ project, Entity tid ticket, _elt, _etpl, _author) <- getProjectTicket404 shr prj ltkhid
return (tid, ticket, projectWorkflow project) return (tid, ticket, projectWorkflow project)
((result, widget), enctype) <- ((result, widget), enctype) <-
runFormPost $ editTicketContentForm tid ticket wid runFormPost $ editTicketContentForm tid ticket wid
@ -502,7 +477,7 @@ postProjectTicketR shr prj ltkhid = do
getProjectTicketEditR :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler Html getProjectTicketEditR :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler Html
getProjectTicketEditR shr prj ltkhid = do getProjectTicketEditR shr prj ltkhid = do
(tid, ticket, wid) <- runDB $ do (tid, ticket, wid) <- runDB $ do
(_es, Entity _ project, Entity tid ticket, _elt, _etpl, _author) <- getProjectTicket shr prj ltkhid (_es, Entity _ project, Entity tid ticket, _elt, _etpl, _author) <- getProjectTicket404 shr prj ltkhid
return (tid, ticket, projectWorkflow project) return (tid, ticket, projectWorkflow project)
((_result, widget), enctype) <- ((_result, widget), enctype) <-
runFormPost $ editTicketContentForm tid ticket wid runFormPost $ editTicketContentForm tid ticket wid
@ -512,7 +487,7 @@ postProjectTicketAcceptR
:: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler Html :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler Html
postProjectTicketAcceptR shr prj ltkhid = do postProjectTicketAcceptR shr prj ltkhid = do
succ <- runDB $ do succ <- runDB $ do
(_es, _ej, Entity tid ticket, _elt, _etpl, _author) <- getProjectTicket shr prj ltkhid (_es, _ej, Entity tid ticket, _elt, _etpl, _author) <- getProjectTicket404 shr prj ltkhid
case ticketStatus ticket of case ticketStatus ticket of
TSNew -> do TSNew -> do
update tid [TicketStatus =. TSTodo] update tid [TicketStatus =. TSTodo]
@ -530,7 +505,7 @@ postProjectTicketCloseR shr prj ltkhid = do
pid <- requireAuthId pid <- requireAuthId
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
succ <- runDB $ do succ <- runDB $ do
(_es, _ej, Entity tid ticket, _elt, _etpl, _author) <- getProjectTicket shr prj ltkhid (_es, _ej, Entity tid ticket, _elt, _etpl, _author) <- getProjectTicket404 shr prj ltkhid
case ticketStatus ticket of case ticketStatus ticket of
TSClosed -> return False TSClosed -> return False
_ -> do _ -> do
@ -553,7 +528,7 @@ postProjectTicketOpenR shr prj ltkhid = do
pid <- requireAuthId pid <- requireAuthId
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
succ <- runDB $ do succ <- runDB $ do
(_es, _ej, Entity tid ticket, _elt, _etpl, _author) <- getProjectTicket shr prj ltkhid (_es, _ej, Entity tid ticket, _elt, _etpl, _author) <- getProjectTicket404 shr prj ltkhid
case ticketStatus ticket of case ticketStatus ticket of
TSClosed -> do TSClosed -> do
update tid update tid
@ -573,7 +548,7 @@ postProjectTicketClaimR
postProjectTicketClaimR shr prj ltkhid = do postProjectTicketClaimR shr prj ltkhid = do
pid <- requireAuthId pid <- requireAuthId
mmsg <- runDB $ do mmsg <- runDB $ do
(_es, _ej, Entity tid ticket, _elt, _etpl, _author) <- getProjectTicket shr prj ltkhid (_es, _ej, Entity tid ticket, _elt, _etpl, _author) <- getProjectTicket404 shr prj ltkhid
case (ticketStatus ticket, ticketAssignee ticket) of case (ticketStatus ticket, ticketAssignee ticket) of
(TSNew, _) -> (TSNew, _) ->
return $ return $
@ -595,7 +570,7 @@ postProjectTicketUnclaimR
postProjectTicketUnclaimR shr prj ltkhid = do postProjectTicketUnclaimR shr prj ltkhid = do
pid <- requireAuthId pid <- requireAuthId
mmsg <- runDB $ do mmsg <- runDB $ do
(_es, _ej, Entity tid ticket, _elt, _etpl, _author) <- getProjectTicket shr prj ltkhid (_es, _ej, Entity tid ticket, _elt, _etpl, _author) <- getProjectTicket404 shr prj ltkhid
case ((== pid) <$> ticketAssignee ticket, ticketStatus ticket) of case ((== pid) <$> ticketAssignee ticket, ticketStatus ticket) of
(Nothing, _) -> (Nothing, _) ->
return $ Just "The ticket is already unassigned." return $ Just "The ticket is already unassigned."
@ -619,7 +594,7 @@ getProjectTicketAssignR
:: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler Html :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler Html
getProjectTicketAssignR shr prj ltkhid = do getProjectTicketAssignR shr prj ltkhid = do
vpid <- requireAuthId vpid <- requireAuthId
(_es, Entity jid _, Entity tid ticket, _elt, _etpl, _author) <- runDB $ getProjectTicket shr prj ltkhid (_es, Entity jid _, Entity tid ticket, _elt, _etpl, _author) <- runDB $ getProjectTicket404 shr prj ltkhid
let msg t = do let msg t = do
setMessage t setMessage t
redirect $ ProjectTicketR shr prj ltkhid redirect $ ProjectTicketR shr prj ltkhid
@ -636,7 +611,7 @@ postProjectTicketAssignR
:: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler Html :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler Html
postProjectTicketAssignR shr prj ltkhid = do postProjectTicketAssignR shr prj ltkhid = do
vpid <- requireAuthId vpid <- requireAuthId
(_es, Entity jid _, Entity tid ticket, _elt, _etpl, _author) <- runDB $ getProjectTicket shr prj ltkhid (_es, Entity jid _, Entity tid ticket, _elt, _etpl, _author) <- runDB $ getProjectTicket404 shr prj ltkhid
let msg t = do let msg t = do
setMessage t setMessage t
redirect $ ProjectTicketR shr prj ltkhid redirect $ ProjectTicketR shr prj ltkhid
@ -668,7 +643,7 @@ postProjectTicketUnassignR
postProjectTicketUnassignR shr prj ltkhid = do postProjectTicketUnassignR shr prj ltkhid = do
pid <- requireAuthId pid <- requireAuthId
mmsg <- runDB $ do mmsg <- runDB $ do
(_es, _ej, Entity tid ticket, _elt, _etpl, _author) <- getProjectTicket shr prj ltkhid (_es, _ej, Entity tid ticket, _elt, _etpl, _author) <- getProjectTicket404 shr prj ltkhid
case ((== pid) <$> ticketAssignee ticket, ticketStatus ticket) of case ((== pid) <$> ticketAssignee ticket, ticketStatus ticket) of
(Nothing, _) -> (Nothing, _) ->
return $ Just "The ticket is already unassigned." return $ Just "The ticket is already unassigned."
@ -747,7 +722,7 @@ getClaimRequestsTicketR
:: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler Html :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler Html
getClaimRequestsTicketR shr prj ltkhid = do getClaimRequestsTicketR shr prj ltkhid = do
rqs <- runDB $ do rqs <- runDB $ do
(_es, _ej, Entity tid _, _elt, _etpl, _author) <- getProjectTicket shr prj ltkhid (_es, _ej, Entity tid _, _elt, _etpl, _author) <- getProjectTicket404 shr prj ltkhid
E.select $ E.from $ \ (tcr `E.InnerJoin` person `E.InnerJoin` sharer) -> do E.select $ E.from $ \ (tcr `E.InnerJoin` person `E.InnerJoin` sharer) -> do
E.on $ person E.^. PersonIdent E.==. sharer E.^. SharerId E.on $ person E.^. PersonIdent E.==. sharer E.^. SharerId
E.on $ tcr E.^. TicketClaimRequestPerson E.==. person E.^. PersonId E.on $ tcr E.^. TicketClaimRequestPerson E.==. person E.^. PersonId
@ -771,7 +746,7 @@ postClaimRequestsTicketR shr prj ltkhid = do
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
pid <- requireAuthId pid <- requireAuthId
runDB $ do runDB $ do
(_es, _ej, Entity tid _, _elt, _etpl, _author) <- getProjectTicket shr prj ltkhid (_es, _ej, Entity tid _, _elt, _etpl, _author) <- getProjectTicket404 shr prj ltkhid
let cr = TicketClaimRequest let cr = TicketClaimRequest
{ ticketClaimRequestPerson = pid { ticketClaimRequestPerson = pid
, ticketClaimRequestTicket = tid , ticketClaimRequestTicket = tid
@ -791,7 +766,7 @@ postClaimRequestsTicketR shr prj ltkhid = do
selectDiscussionId selectDiscussionId
:: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> AppDB DiscussionId :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> AppDB DiscussionId
selectDiscussionId shr prj ltkhid = do selectDiscussionId shr prj ltkhid = do
(_es, _ej, _et, Entity _ lticket, _etpl, _author) <- getProjectTicket shr prj ltkhid (_es, _ej, _et, Entity _ lticket, _etpl, _author) <- getProjectTicket404 shr prj ltkhid
return $ localTicketDiscuss lticket return $ localTicketDiscuss lticket
getProjectTicketDiscussionR getProjectTicketDiscussionR
@ -878,7 +853,7 @@ getTicketDeps forward shr prj ltkhid = do
if forward then TicketDependencyParent else TicketDependencyChild if forward then TicketDependencyParent else TicketDependencyChild
to' = to' =
if forward then TicketDependencyChild else TicketDependencyParent if forward then TicketDependencyChild else TicketDependencyParent
(_es, _ej, Entity tid _, _elt, _etpl, _author) <- getProjectTicket shr prj ltkhid (_es, _ej, Entity tid _, _elt, _etpl, _author) <- getProjectTicket404 shr prj ltkhid
fmap (map toRow) $ E.select $ E.from $ fmap (map toRow) $ E.select $ E.from $
\ ( td \ ( td
`E.InnerJoin` t `E.InnerJoin` t
@ -951,7 +926,7 @@ getProjectTicketDepsR = getTicketDeps True
postProjectTicketDepsR postProjectTicketDepsR
:: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler Html :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler Html
postProjectTicketDepsR shr prj ltkhid = do postProjectTicketDepsR shr prj ltkhid = do
(_es, Entity jid _, Entity tid _, _elt, _etpl, _author) <- runDB $ getProjectTicket shr prj ltkhid (_es, Entity jid _, Entity tid _, _elt, _etpl, _author) <- runDB $ getProjectTicket404 shr prj ltkhid
((result, widget), enctype) <- runFormPost $ ticketDepForm jid tid ((result, widget), enctype) <- runFormPost $ ticketDepForm jid tid
case result of case result of
FormSuccess ctid -> do FormSuccess ctid -> do
@ -979,7 +954,7 @@ postProjectTicketDepsR shr prj ltkhid = do
getProjectTicketDepNewR getProjectTicketDepNewR
:: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler Html :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler Html
getProjectTicketDepNewR shr prj ltkhid = do getProjectTicketDepNewR shr prj ltkhid = do
(_es, Entity jid _, Entity tid _, _elt, _etpl, _author) <- runDB $ getProjectTicket shr prj ltkhid (_es, Entity jid _, Entity tid _, _elt, _etpl, _author) <- runDB $ getProjectTicket404 shr prj ltkhid
((_result, widget), enctype) <- runFormPost $ ticketDepForm jid tid ((_result, widget), enctype) <- runFormPost $ ticketDepForm jid tid
defaultLayout $(widgetFile "ticket/dep/new") defaultLayout $(widgetFile "ticket/dep/new")
@ -995,7 +970,7 @@ deleteTicketDepOldR
:: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> KeyHashid LocalTicket -> Handler Html :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> KeyHashid LocalTicket -> Handler Html
deleteTicketDepOldR shr prj pnum cnum = do deleteTicketDepOldR shr prj pnum cnum = do
runDB $ do runDB $ do
(_es, Entity jid _, Entity ptid _, _elt, _etpl, _author) <- getProjectTicket shr prj pnum (_es, Entity jid _, Entity ptid _, _elt, _etpl, _author) <- getProjectTicket404 shr prj pnum
cltid <- decodeKeyHashid404 cnum cltid <- decodeKeyHashid404 cnum
clt <- get404 cltid clt <- get404 cltid
@ -1072,14 +1047,14 @@ getProjectTicketParticipantsR shr prj ltkhid = getFollowersCollection here getFs
where where
here = ProjectTicketParticipantsR shr prj ltkhid here = ProjectTicketParticipantsR shr prj ltkhid
getFsid = do getFsid = do
(_es, _ej, _et, Entity _ lt, _etpl, _author) <- getProjectTicket shr prj ltkhid (_es, _ej, _et, Entity _ lt, _etpl, _author) <- getProjectTicket404 shr prj ltkhid
return $ localTicketFollowers lt return $ localTicketFollowers lt
getProjectTicketTeamR getProjectTicketTeamR
:: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler TypedContent :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler TypedContent
getProjectTicketTeamR shr prj ltkhid = do getProjectTicketTeamR shr prj ltkhid = do
memberShrs <- runDB $ do memberShrs <- runDB $ do
(Entity sid _, _ej, _et, _elt, _etpl, _author) <- getProjectTicket shr prj ltkhid (Entity sid _, _ej, _et, _elt, _etpl, _author) <- getProjectTicket404 shr prj ltkhid
id_ <- id_ <-
requireEitherAlt requireEitherAlt
(getKeyBy $ UniquePersonIdent sid) (getKeyBy $ UniquePersonIdent sid)
@ -1117,43 +1092,6 @@ getProjectTicketEventsR
:: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler TypedContent :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler TypedContent
getProjectTicketEventsR _shr _prj _ltkhid = error "TODO not implemented" getProjectTicketEventsR _shr _prj _ltkhid = error "TODO not implemented"
getSharerTicket
:: ShrIdent
-> KeyHashid TicketAuthorLocal
-> AppDB
( Entity TicketAuthorLocal
, Entity LocalTicket
, Entity Ticket
, Either (Entity TicketProjectLocal) ()
)
getSharerTicket shr talkhid = do
pid <- do
sid <- getKeyBy404 $ UniqueSharer shr
getKeyBy404 $ UniquePersonIdent sid
talid <- decodeKeyHashid404 talkhid
tal <- get404 talid
unless (ticketAuthorLocalAuthor tal == pid) notFound
let ltid = ticketAuthorLocalTicket tal
lt <- getJust ltid
let tid = localTicketTicket lt
t <- getJust tid
project <-
requireEitherAlt
(do mtpl <- getBy $ UniqueTicketProjectLocal tid
for mtpl $ \ etpl@(Entity tplid tpl) -> do
mtup1 <- getBy $ UniqueTicketUnderProjectProject tplid
mtup2 <- getBy $ UniqueTicketUnderProjectAuthor talid
unless (isJust mtup1 == isJust mtup2) $
error "TUP points to unrelated TAL and TPL!"
unless (isNothing mtup1) notFound
return etpl
)
(return Nothing
)
"Ticket doesn't have project"
"Ticket has both local and remote project"
return (Entity talid tal, Entity ltid lt, Entity tid t, project)
getSharerTicketsR :: ShrIdent -> Handler TypedContent getSharerTicketsR :: ShrIdent -> Handler TypedContent
getSharerTicketsR shr = do getSharerTicketsR shr = do
(total, pages, mpage) <- runDB $ do (total, pages, mpage) <- runDB $ do
@ -1229,7 +1167,7 @@ getSharerTicketR
:: ShrIdent -> KeyHashid TicketAuthorLocal -> Handler TypedContent :: ShrIdent -> KeyHashid TicketAuthorLocal -> Handler TypedContent
getSharerTicketR shr talkhid = do getSharerTicketR shr talkhid = do
(ticket, project, massignee) <- runDB $ do (ticket, project, massignee) <- runDB $ do
(_, _, Entity _ t, tp) <- getSharerTicket shr talkhid (_, _, Entity _ t, tp) <- getSharerTicket404 shr talkhid
(,,) t (,,) t
<$> bitraverse <$> bitraverse
(\ (Entity _ tpl) -> do (\ (Entity _ tpl) -> do
@ -1290,7 +1228,7 @@ getSharerTicketDiscussionR
:: ShrIdent -> KeyHashid TicketAuthorLocal -> Handler TypedContent :: ShrIdent -> KeyHashid TicketAuthorLocal -> Handler TypedContent
getSharerTicketDiscussionR shr talkhid = do getSharerTicketDiscussionR shr talkhid = do
(locals, remotes) <- runDB $ do (locals, remotes) <- runDB $ do
(_, Entity _ lt, _, _) <- getSharerTicket shr talkhid (_, Entity _ lt, _, _) <- getSharerTicket404 shr talkhid
let did = localTicketDiscuss lt let did = localTicketDiscuss lt
(,) <$> selectLocals did <*> selectRemotes did (,) <$> selectLocals did <*> selectRemotes did
encodeRouteLocal <- getEncodeRouteLocal encodeRouteLocal <- getEncodeRouteLocal
@ -1340,7 +1278,7 @@ getSharerTicketDeps
:: Bool -> ShrIdent -> KeyHashid TicketAuthorLocal -> Handler TypedContent :: Bool -> ShrIdent -> KeyHashid TicketAuthorLocal -> Handler TypedContent
getSharerTicketDeps forward shr talkhid = do getSharerTicketDeps forward shr talkhid = do
tdids <- runDB $ do tdids <- runDB $ do
(_, _, Entity tid _, _) <- getSharerTicket shr talkhid (_, _, Entity tid _, _) <- getSharerTicket404 shr talkhid
let (from, to) = let (from, to) =
if forward if forward
then (TicketDependencyParent, TicketDependencyChild) then (TicketDependencyParent, TicketDependencyChild)
@ -1384,13 +1322,13 @@ getSharerTicketFollowersR shr talkhid = getFollowersCollection here getFsid
where where
here = SharerTicketFollowersR shr talkhid here = SharerTicketFollowersR shr talkhid
getFsid = do getFsid = do
(_, Entity _ lt, _, _) <- getSharerTicket shr talkhid (_, Entity _ lt, _, _) <- getSharerTicket404 shr talkhid
return $ localTicketFollowers lt return $ localTicketFollowers lt
getSharerTicketTeamR getSharerTicketTeamR
:: ShrIdent -> KeyHashid TicketAuthorLocal -> Handler TypedContent :: ShrIdent -> KeyHashid TicketAuthorLocal -> Handler TypedContent
getSharerTicketTeamR shr talkhid = do getSharerTicketTeamR shr talkhid = do
_ <- runDB $ getSharerTicket shr talkhid _ <- runDB $ getSharerTicket404 shr talkhid
encodeRouteLocal <- getEncodeRouteLocal encodeRouteLocal <- getEncodeRouteLocal
let team = Collection let team = Collection
{ collectionId = encodeRouteLocal here { collectionId = encodeRouteLocal here
@ -1408,7 +1346,7 @@ getSharerTicketTeamR shr talkhid = do
getSharerTicketEventsR getSharerTicketEventsR
:: ShrIdent -> KeyHashid TicketAuthorLocal -> Handler TypedContent :: ShrIdent -> KeyHashid TicketAuthorLocal -> Handler TypedContent
getSharerTicketEventsR shr talkhid = do getSharerTicketEventsR shr talkhid = do
_ <- runDB $ getSharerTicket shr talkhid _ <- runDB $ getSharerTicket404 shr talkhid
encodeRouteLocal <- getEncodeRouteLocal encodeRouteLocal <- getEncodeRouteLocal
let team = Collection let team = Collection
{ collectionId = encodeRouteLocal here { collectionId = encodeRouteLocal here

View file

@ -27,16 +27,29 @@ module Vervis.Ticket
, getTicketEnumParams , getTicketEnumParams
, TicketClassParam (..) , TicketClassParam (..)
, getTicketClasses , getTicketClasses
, getSharerTicket
, getSharerTicket404
, getProjectTicket
, getProjectTicket404
) )
where where
import Control.Arrow ((***)) import Control.Arrow ((***))
import Control.Monad
import Control.Monad.Trans.Class
import Control.Monad.Trans.Maybe
import Data.Foldable (for_) import Data.Foldable (for_)
import Data.Int import Data.Int
import Data.Maybe (isJust) import Data.Maybe (isJust)
import Data.Text (Text) import Data.Text (Text)
import Data.Traversable import Data.Traversable
import Database.Esqueleto import Database.Esqueleto
import Yesod.Core (notFound)
import Yesod.Hashids
import Data.Either.Local
import Database.Persist.Local
import Vervis.Foundation (AppDB) import Vervis.Foundation (AppDB)
import Vervis.Model import Vervis.Model
@ -408,3 +421,113 @@ getTicketClasses tid wid = fmap (map toCParam) $
, f ^. WorkflowFieldFilterClosed , f ^. WorkflowFieldFilterClosed
, p ?. TicketParamClassId , p ?. TicketParamClassId
) )
getSharerTicket
:: ShrIdent
-> TicketAuthorLocalId
-> AppDB
( Maybe
( Entity TicketAuthorLocal
, Entity LocalTicket
, Entity Ticket
, Either (Entity TicketProjectLocal) ()
)
)
getSharerTicket shr talid = runMaybeT $ do
pid <- do
sid <- MaybeT $ getKeyBy $ UniqueSharer shr
MaybeT $ getKeyBy $ UniquePersonIdent sid
tal <- MaybeT $ get talid
guard $ ticketAuthorLocalAuthor tal == pid
let ltid = ticketAuthorLocalTicket tal
lt <- lift $ getJust ltid
let tid = localTicketTicket lt
t <- lift $ getJust tid
project <-
requireEitherAlt
(do mtpl <- lift $ getBy $ UniqueTicketProjectLocal tid
for mtpl $ \ etpl@(Entity tplid tpl) -> do
mtup1 <- lift $ getBy $ UniqueTicketUnderProjectProject tplid
mtup2 <- lift $ getBy $ UniqueTicketUnderProjectAuthor talid
unless (isJust mtup1 == isJust mtup2) $
error "TUP points to unrelated TAL and TPL!"
guard $ not $ isJust mtup1
return etpl
)
(return Nothing
)
"Ticket doesn't have project"
"Ticket has both local and remote project"
return (Entity talid tal, Entity ltid lt, Entity tid t, project)
getSharerTicket404
:: ShrIdent
-> KeyHashid TicketAuthorLocal
-> AppDB
( Entity TicketAuthorLocal
, Entity LocalTicket
, Entity Ticket
, Either (Entity TicketProjectLocal) ()
)
getSharerTicket404 shr talkhid = do
talid <- decodeKeyHashid404 talkhid
mticket <- getSharerTicket shr talid
case mticket of
Nothing -> notFound
Just ticket -> return ticket
getProjectTicket
:: ShrIdent
-> PrjIdent
-> LocalTicketId
-> AppDB
( Maybe
( Entity Sharer
, Entity Project
, Entity Ticket
, Entity LocalTicket
, Entity TicketProjectLocal
, Either (Entity TicketAuthorLocal) (Entity TicketAuthorRemote)
)
)
getProjectTicket shr prj ltid = runMaybeT $ do
es@(Entity sid _) <- MaybeT $ getBy $ UniqueSharer shr
ej@(Entity jid _) <- MaybeT $ getBy $ UniqueProject prj sid
lt <- MaybeT $ get ltid
let tid = localTicketTicket lt
t <- MaybeT $ get tid
etpl@(Entity tplid tpl) <- MaybeT $ getBy $ UniqueTicketProjectLocal tid
guard $ ticketProjectLocalProject tpl == jid
author <-
requireEitherAlt
(do mtal <- lift $ getBy $ UniqueTicketAuthorLocal ltid
for mtal $ \ tal@(Entity talid _) -> do
tupid1 <- MaybeT $ getKeyBy $ UniqueTicketUnderProjectProject tplid
tupid2 <- MaybeT $ getKeyBy $ UniqueTicketUnderProjectAuthor talid
unless (tupid1 == tupid2) $
error "TAL and TPL used by different TUPs!"
return tal
)
(lift $ getBy $ UniqueTicketAuthorRemote tplid)
"Ticket doesn't have author"
"Ticket has both local and remote author"
return (es, ej, Entity tid t, Entity ltid lt, etpl, author)
getProjectTicket404
:: ShrIdent
-> PrjIdent
-> KeyHashid LocalTicket
-> AppDB
( Entity Sharer
, Entity Project
, Entity Ticket
, Entity LocalTicket
, Entity TicketProjectLocal
, Either (Entity TicketAuthorLocal) (Entity TicketAuthorRemote)
)
getProjectTicket404 shr prj ltkhid = do
ltid <- decodeKeyHashid404 ltkhid
mticket <- getProjectTicket shr prj ltid
case mticket of
Nothing -> notFound
Just ticket -> return ticket

View file

@ -67,6 +67,7 @@ module Web.ActivityPub
, Activity (..) , Activity (..)
-- * Utilities -- * Utilities
, emptyAudience
, emptyActivity , emptyActivity
, hActivityPubActor , hActivityPubActor
, provideAP , provideAP
@ -1266,6 +1267,9 @@ instance ActivityPub Activity where
encodeSpecific _ _ (RejectActivity a) = encodeReject a encodeSpecific _ _ (RejectActivity a) = encodeReject a
encodeSpecific h _ (UndoActivity a) = encodeUndo h a encodeSpecific h _ (UndoActivity a) = encodeUndo h a
emptyAudience :: Audience u
emptyAudience = Audience [] [] [] [] [] []
emptyActivity :: Activity u emptyActivity :: Activity u
emptyActivity = Activity emptyActivity = Activity
{ activityId = Nothing { activityId = Nothing
@ -1275,8 +1279,6 @@ emptyActivity = Activity
, activitySpecific = , activitySpecific =
RejectActivity $ Reject $ ObjURI (Authority "" Nothing) topLocalURI RejectActivity $ Reject $ ObjURI (Authority "" Nothing) topLocalURI
} }
where
emptyAudience = Audience [] [] [] [] [] []
typeActivityStreams2 :: ContentType typeActivityStreams2 :: ContentType
typeActivityStreams2 = "application/activity+json" typeActivityStreams2 = "application/activity+json"