C2S: Rewrite createNoteC based on createTicketC
This commit is contained in:
fr33domlover
parent
23056b3b3c
commit
edaa3c49b2
8 changed files with 487 additions and 388 deletions
|
|
@ -1,6 +1,6 @@
|
|||
{- This file is part of Vervis.
|
||||
-
|
||||
- Written in 2019 by fr33domlover <fr33domlover@riseup.net>.
|
||||
- Written in 2019, 2020 by fr33domlover <fr33domlover@riseup.net>.
|
||||
-
|
||||
- ♡ Copying is an act of love. Please copy, reuse and share.
|
||||
-
|
||||
|
|
@ -15,10 +15,12 @@
|
|||
|
||||
module Database.Persist.Local
|
||||
( idAndNew
|
||||
, valAndNew
|
||||
, getKeyBy
|
||||
, getValBy
|
||||
, insertUnique_
|
||||
, insertBy'
|
||||
, insertByEntity'
|
||||
)
|
||||
where
|
||||
|
||||
|
|
@ -28,6 +30,7 @@ import Control.Monad
|
|||
import Control.Monad.IO.Class
|
||||
import Control.Monad.Trans.Maybe
|
||||
import Control.Monad.Trans.Reader
|
||||
import Data.Bifunctor
|
||||
import Database.Persist
|
||||
|
||||
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 (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
|
||||
:: ( MonadIO m
|
||||
, PersistRecordBackend record backend
|
||||
|
|
@ -80,3 +87,11 @@ insertBy' val = do
|
|||
"insertBy': Couldn't insert but also couldn't get the value, \
|
||||
\perhaps it was concurrently deleted or updated: " <>
|
||||
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
|
||||
|
|
|
|||
|
|
@ -14,7 +14,8 @@
|
|||
-}
|
||||
|
||||
module Vervis.API
|
||||
( createNoteC
|
||||
( noteC
|
||||
, createNoteC
|
||||
, createTicketC
|
||||
, followC
|
||||
, offerTicketC
|
||||
|
|
@ -110,6 +111,7 @@ import Vervis.Model.Ident
|
|||
import Vervis.Model.Ticket
|
||||
import Vervis.RemoteActorStore
|
||||
import Vervis.Settings
|
||||
import Vervis.Ticket
|
||||
|
||||
verifyIsLoggedInUser
|
||||
:: LocalURI
|
||||
|
|
@ -147,195 +149,268 @@ parseComment luParent = do
|
|||
MessageR shr hid -> (shr,) <$> decodeKeyHashidE hid "Non-existent local message hashid"
|
||||
_ -> 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
|
||||
-- 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'.
|
||||
createNoteC :: Host -> Note URIMode -> Handler (Either Text LocalMessageId)
|
||||
createNoteC host (Note mluNote luAttrib aud muParent muContext mpublished source content) = runExceptT $ do
|
||||
verifyHostLocal host "Attributed to non-local actor"
|
||||
verifyNothingE mluNote "Note specifies an id"
|
||||
verifyNothingE mpublished "Note specifies published"
|
||||
uContext <- fromMaybeE muContext "Note without context"
|
||||
(mparent, localRecips, mticket, remoteRecips) <- parseRecipsContextParent uContext muParent
|
||||
federation <- getsYesod $ appFederation . appSettings
|
||||
unless (federation || null remoteRecips) $
|
||||
throwE "Federation disabled, but remote recipients specified"
|
||||
createNoteC
|
||||
:: Entity Person
|
||||
-> Sharer
|
||||
-> TextHtml
|
||||
-> Audience URIMode
|
||||
-> Note URIMode
|
||||
-> Handler (Either Text LocalMessageId)
|
||||
createNoteC (Entity pidUser personUser) sharerUser summary audience note = runExceptT $ do
|
||||
let shrUser = sharerIdent sharerUser
|
||||
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
|
||||
(pid, obid, shrUser) <- verifyIsLoggedInUser luAttrib "Note attributed to different actor"
|
||||
(did, meparent, mcollections) <- case mticket of
|
||||
Just (shr, prj, ltkhid) -> do
|
||||
mt <- lift $ runMaybeT $ do
|
||||
sid <- MaybeT $ getKeyBy $ UniqueSharer shr
|
||||
Entity jid j <- MaybeT $ getBy $ UniqueProject prj sid
|
||||
ltid <- decodeKeyHashidM ltkhid
|
||||
lt <- MaybeT $ get ltid
|
||||
tpl <-
|
||||
MaybeT $ getValBy $
|
||||
UniqueTicketProjectLocal $ localTicketTicket lt
|
||||
guard $ ticketProjectLocalProject tpl == jid
|
||||
return (sid, projectInbox j, projectFollowers j, lt)
|
||||
(sid, ibidProject, fsidProject, lt) <- fromMaybeE mt "Context: No such local ticket"
|
||||
let did = 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"
|
||||
obiidCreate <- lift $ insertEmptyOutboxItem (personOutbox personUser) now
|
||||
(mproject, did, meparent) <- getTopicAndParent context mparent
|
||||
lmid <- lift $ insertMessage now content source obiidCreate did meparent
|
||||
docCreate <- lift $ insertCreateToOutbox now shrUser noteData obiidCreate lmid
|
||||
remoteRecipsHttpCreate <- do
|
||||
hashLT <- getEncodeKeyHashid
|
||||
hashTAL <- getEncodeKeyHashid
|
||||
let sieve =
|
||||
let actors =
|
||||
case mproject of
|
||||
Nothing -> []
|
||||
Just (shr, prj) -> [LocalActorProject shr prj]
|
||||
collections =
|
||||
let project =
|
||||
case mproject of
|
||||
Nothing -> []
|
||||
Just (shr, prj) ->
|
||||
[ LocalPersonCollectionProjectTeam shr prj
|
||||
, LocalPersonCollectionProjectFollowers shr prj
|
||||
]
|
||||
ticket =
|
||||
case context of
|
||||
Left nc ->
|
||||
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
|
||||
m <- lift $ getJust mid
|
||||
unless (messageRoot m == did) $
|
||||
throwE "Remote parent belongs to a different discussion"
|
||||
return mid
|
||||
-- lift $ insertUnique_ $ Follow pid (ticketFollowers t) False True
|
||||
return (did, Left <$> mmidParent, Just (sid, localTicketFollowers lt, ibidProject, fsidProject))
|
||||
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
|
||||
return (mproject, did, meparent)
|
||||
insertMessage now content source obiidCreate did meparent = do
|
||||
mid <- insert Message
|
||||
{ messageCreated = now
|
||||
, messageSource = source
|
||||
|
|
@ -346,17 +421,31 @@ createNoteC host (Note mluNote luAttrib aud muParent muContext mpublished source
|
|||
_ -> Nothing
|
||||
, messageRoot = did
|
||||
}
|
||||
let activity luAct luNote = Doc host Activity
|
||||
{ activityId = Just luAct
|
||||
insert LocalMessage
|
||||
{ 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
|
||||
, activitySummary =
|
||||
Just $ TextHtml $ TL.toStrict $ renderHtml summary
|
||||
, activityAudience = aud
|
||||
, activitySummary = Just summary
|
||||
, activityAudience = audience
|
||||
, activitySpecific = CreateActivity Create
|
||||
{ createObject = CreateNote Note
|
||||
{ noteId = Just luNote
|
||||
{ noteId = Just $ encodeRouteLocal $ MessageR shrUser lmkhid
|
||||
, noteAttrib = luAttrib
|
||||
, noteAudience = aud
|
||||
, noteAudience = emptyAudience
|
||||
, noteReplyTo = Just $ fromMaybe uContext muParent
|
||||
, noteContext = Just uContext
|
||||
, notePublished = Just now
|
||||
|
|
@ -366,90 +455,8 @@ createNoteC host (Note mluNote luAttrib aud muParent muContext mpublished source
|
|||
, createTarget = Nothing
|
||||
}
|
||||
}
|
||||
tempUri = topLocalURI
|
||||
obiid <- insert OutboxItem
|
||||
{ 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"
|
||||
-}
|
||||
update obiidCreate [OutboxItemActivity =. persistJSONObjectFromDoc create]
|
||||
return create
|
||||
|
||||
-- | 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
|
||||
|
|
@ -983,8 +990,9 @@ offerTicketC shrUser summary audience offer@(Offer ticket uTarget) = runExceptT
|
|||
else verifyOnlySharer lsrSet
|
||||
where
|
||||
offerRecips prj = LocalSharerRelatedSet
|
||||
{ localRecipSharerDirect = LocalSharerDirectSet False False
|
||||
, localRecipProjectRelated =
|
||||
{ localRecipSharerDirect = LocalSharerDirectSet False False
|
||||
, localRecipSharerTicketRelated = []
|
||||
, localRecipProjectRelated =
|
||||
[ ( prj
|
||||
, LocalProjectRelatedSet
|
||||
{ localRecipProjectDirect =
|
||||
|
|
@ -993,7 +1001,7 @@ offerTicketC shrUser summary audience offer@(Offer ticket uTarget) = runExceptT
|
|||
}
|
||||
)
|
||||
]
|
||||
, localRecipRepoRelated = []
|
||||
, localRecipRepoRelated = []
|
||||
}
|
||||
verifyOnlySharer lsrSet = do
|
||||
unless (null $ localRecipProjectRelated lsrSet) $
|
||||
|
|
|
|||
|
|
@ -32,6 +32,7 @@ module Vervis.ActivityPub.Recipient
|
|||
, parseAudience
|
||||
, actorRecips
|
||||
, localRecipSieve
|
||||
, localRecipSieve'
|
||||
)
|
||||
where
|
||||
|
||||
|
|
@ -454,22 +455,31 @@ actorRecips = groupLocalRecipients . (: []) . groupedRecipientFromActor
|
|||
localRecipSieve
|
||||
:: LocalRecipientSet -> Bool -> LocalRecipientSet -> LocalRecipientSet
|
||||
localRecipSieve sieve allowActors =
|
||||
localRecipSieve' sieve allowActors allowActors
|
||||
|
||||
localRecipSieve'
|
||||
:: LocalRecipientSet
|
||||
-> Bool
|
||||
-> Bool
|
||||
-> LocalRecipientSet
|
||||
-> LocalRecipientSet
|
||||
localRecipSieve' sieve allowSharers allowOthers =
|
||||
mapMaybe (uncurry applySharerRelated) . sortAlign sieve
|
||||
where
|
||||
onlyActorsJ (LocalProjectRelatedSet (LocalProjectDirectSet j _t _f) _ts) =
|
||||
LocalProjectRelatedSet (LocalProjectDirectSet j False False) []
|
||||
LocalProjectRelatedSet (LocalProjectDirectSet (j && allowOthers) False False) []
|
||||
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) =
|
||||
LocalSharerRelatedSet
|
||||
(LocalSharerDirectSet s False)
|
||||
(LocalSharerDirectSet (s && allowSharers) False)
|
||||
[]
|
||||
(map (second onlyActorsJ) js)
|
||||
(map (second onlyActorsR) rs)
|
||||
|
||||
applySharerRelated _ (This _) = Nothing
|
||||
applySharerRelated shr (That s) =
|
||||
if allowActors
|
||||
if allowSharers || allowOthers
|
||||
then Just (shr, onlyActorsS s)
|
||||
else Nothing
|
||||
applySharerRelated shr (These (LocalSharerRelatedSet s' t' j' r') (LocalSharerRelatedSet s t j r)) =
|
||||
|
|
@ -483,7 +493,7 @@ localRecipSieve sieve allowActors =
|
|||
)
|
||||
where
|
||||
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)
|
||||
where
|
||||
|
|
@ -493,7 +503,7 @@ localRecipSieve sieve allowActors =
|
|||
|
||||
applyProjectRelated _ (This _) = Nothing
|
||||
applyProjectRelated prj (That j) =
|
||||
if allowActors
|
||||
if allowOthers
|
||||
then Just (prj, onlyActorsJ j)
|
||||
else Nothing
|
||||
applyProjectRelated prj (These (LocalProjectRelatedSet j' t') (LocalProjectRelatedSet j t)) =
|
||||
|
|
@ -505,15 +515,15 @@ localRecipSieve sieve allowActors =
|
|||
)
|
||||
where
|
||||
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 rp (That r) =
|
||||
if allowActors
|
||||
if allowOthers
|
||||
then Just (rp, onlyActorsR r)
|
||||
else Nothing
|
||||
applyRepoRelated rp (These (LocalRepoRelatedSet r') (LocalRepoRelatedSet r)) =
|
||||
Just (rp, LocalRepoRelatedSet $ applyRepo r' r)
|
||||
where
|
||||
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')
|
||||
|
|
|
|||
|
|
@ -296,7 +296,7 @@ postPublishR = do
|
|||
FormMissing -> throwE "Field(s) missing"
|
||||
FormFailure _l -> throwE "Invalid input, see below"
|
||||
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
|
||||
Left err -> setMessage $ toHtml err
|
||||
Right id_ ->
|
||||
|
|
@ -322,13 +322,14 @@ postPublishR = do
|
|||
widget3 enctype3
|
||||
widget4 enctype4
|
||||
where
|
||||
publishComment shrAuthor ((hTicket, shrTicket, prj, num), muParent, msg) = do
|
||||
publishComment eperson sharer ((hTicket, shrTicket, prj, num), muParent, msg) = do
|
||||
encodeRouteFed <- getEncodeRouteHome
|
||||
encodeRouteLocal <- getEncodeRouteLocal
|
||||
let msg' = T.filter (/= '\r') msg
|
||||
contentHtml <- ExceptT . pure $ renderPandocMarkdown msg'
|
||||
let encodeRecipRoute = ObjURI hTicket . encodeRouteLocal
|
||||
uTicket = encodeRecipRoute $ ProjectTicketR shrTicket prj num
|
||||
shrAuthor = sharerIdent sharer
|
||||
ObjURI hLocal luAuthor = encodeRouteFed $ SharerR shrAuthor
|
||||
collections =
|
||||
[ ProjectFollowersR shrTicket prj
|
||||
|
|
@ -353,7 +354,7 @@ postPublishR = do
|
|||
, noteSource = msg'
|
||||
, noteContent = contentHtml
|
||||
}
|
||||
ExceptT $ createNoteC hLocal note
|
||||
ExceptT $ noteC eperson sharer note
|
||||
publishTicket eperson sharer (target, context, title, desc) = do
|
||||
(summary, audience, create) <-
|
||||
ExceptT $ C.createTicket (sharerIdent sharer) title desc target context
|
||||
|
|
|
|||
|
|
@ -209,18 +209,19 @@ postTopReply
|
|||
-> Handler Html
|
||||
postTopReply hDest recipsA recipsC context recipF replyP after = do
|
||||
((result, widget), enctype) <- runFormPost newMessageForm
|
||||
shrAuthor <- do
|
||||
Entity _ p <- requireVerifiedAuth
|
||||
runDB $ sharerIdent <$> get404 (personIdent p)
|
||||
(eperson, sharer) <- do
|
||||
ep@(Entity _ p) <- requireVerifiedAuth
|
||||
s <- runDB $ get404 (personIdent p)
|
||||
return (ep, s)
|
||||
let shrAuthor = sharerIdent sharer
|
||||
elmid <- runExceptT $ do
|
||||
msg <- case result of
|
||||
FormMissing -> throwE "Field(s) missing."
|
||||
FormFailure _l -> throwE "Message submission failed, see errors below."
|
||||
FormSuccess nm ->
|
||||
return $ TextPandocMarkdown $ T.filter (/= '\r') $ nmContent nm
|
||||
hLocal <- asksSite siteInstanceHost
|
||||
note <- ExceptT $ createThread shrAuthor msg hDest recipsA recipsC context
|
||||
ExceptT $ createNoteC hLocal note
|
||||
ExceptT $ noteC eperson sharer note
|
||||
case elmid of
|
||||
Left e -> do
|
||||
setMessage $ toHtml e
|
||||
|
|
@ -264,18 +265,19 @@ postReply
|
|||
-> Handler Html
|
||||
postReply hDest recipsA recipsC context recipF replyG replyP after getdid midParent = do
|
||||
((result, widget), enctype) <- runFormPost newMessageForm
|
||||
shrAuthor <- do
|
||||
Entity _ p <- requireVerifiedAuth
|
||||
runDB $ sharerIdent <$> get404 (personIdent p)
|
||||
(eperson, sharer) <- do
|
||||
ep@(Entity _ p) <- requireVerifiedAuth
|
||||
s <- runDB $ get404 (personIdent p)
|
||||
return (ep, s)
|
||||
let shrAuthor = sharerIdent sharer
|
||||
elmid <- runExceptT $ do
|
||||
msg <- case result of
|
||||
FormMissing -> throwE "Field(s) missing."
|
||||
FormFailure _l -> throwE "Message submission failed, see errors below."
|
||||
FormSuccess nm ->
|
||||
return $ TextPandocMarkdown $ T.filter (/= '\r') $ nmContent nm
|
||||
hLocal <- asksSite siteInstanceHost
|
||||
note <- ExceptT $ createReply shrAuthor msg hDest recipsA recipsC context midParent
|
||||
ExceptT $ createNoteC hLocal note
|
||||
ExceptT $ noteC eperson sharer note
|
||||
case elmid of
|
||||
Left e -> do
|
||||
setMessage $ toHtml e
|
||||
|
|
|
|||
|
|
@ -266,31 +266,6 @@ getProjectTicketNewR shr prj = do
|
|||
((_result, widget), enctype) <- runFormPost $ newTicketForm wid
|
||||
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 shar proj ltkhid = do
|
||||
mpid <- maybeAuthId
|
||||
|
|
@ -298,7 +273,7 @@ getProjectTicketR shar proj ltkhid = do
|
|||
author, massignee, mcloser, ticket, lticket, tparams, eparams, cparams,
|
||||
deps, rdeps) <-
|
||||
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
|
||||
w <- get404 $ projectWorkflow project
|
||||
wsharer <-
|
||||
|
|
@ -428,7 +403,7 @@ getProjectTicketR shar proj ltkhid = do
|
|||
putProjectTicketR :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler Html
|
||||
putProjectTicketR shr prj ltkhid = 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)
|
||||
((result, widget), enctype) <-
|
||||
runFormPost $ editTicketContentForm tid ticket wid
|
||||
|
|
@ -502,7 +477,7 @@ postProjectTicketR shr prj ltkhid = do
|
|||
getProjectTicketEditR :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler Html
|
||||
getProjectTicketEditR shr prj ltkhid = 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)
|
||||
((_result, widget), enctype) <-
|
||||
runFormPost $ editTicketContentForm tid ticket wid
|
||||
|
|
@ -512,7 +487,7 @@ postProjectTicketAcceptR
|
|||
:: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler Html
|
||||
postProjectTicketAcceptR shr prj ltkhid = 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
|
||||
TSNew -> do
|
||||
update tid [TicketStatus =. TSTodo]
|
||||
|
|
@ -530,7 +505,7 @@ postProjectTicketCloseR shr prj ltkhid = do
|
|||
pid <- requireAuthId
|
||||
now <- liftIO getCurrentTime
|
||||
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
|
||||
TSClosed -> return False
|
||||
_ -> do
|
||||
|
|
@ -553,7 +528,7 @@ postProjectTicketOpenR shr prj ltkhid = do
|
|||
pid <- requireAuthId
|
||||
now <- liftIO getCurrentTime
|
||||
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
|
||||
TSClosed -> do
|
||||
update tid
|
||||
|
|
@ -573,7 +548,7 @@ postProjectTicketClaimR
|
|||
postProjectTicketClaimR shr prj ltkhid = do
|
||||
pid <- requireAuthId
|
||||
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
|
||||
(TSNew, _) ->
|
||||
return $
|
||||
|
|
@ -595,7 +570,7 @@ postProjectTicketUnclaimR
|
|||
postProjectTicketUnclaimR shr prj ltkhid = do
|
||||
pid <- requireAuthId
|
||||
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
|
||||
(Nothing, _) ->
|
||||
return $ Just "The ticket is already unassigned."
|
||||
|
|
@ -619,7 +594,7 @@ getProjectTicketAssignR
|
|||
:: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler Html
|
||||
getProjectTicketAssignR shr prj ltkhid = do
|
||||
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
|
||||
setMessage t
|
||||
redirect $ ProjectTicketR shr prj ltkhid
|
||||
|
|
@ -636,7 +611,7 @@ postProjectTicketAssignR
|
|||
:: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler Html
|
||||
postProjectTicketAssignR shr prj ltkhid = do
|
||||
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
|
||||
setMessage t
|
||||
redirect $ ProjectTicketR shr prj ltkhid
|
||||
|
|
@ -668,7 +643,7 @@ postProjectTicketUnassignR
|
|||
postProjectTicketUnassignR shr prj ltkhid = do
|
||||
pid <- requireAuthId
|
||||
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
|
||||
(Nothing, _) ->
|
||||
return $ Just "The ticket is already unassigned."
|
||||
|
|
@ -747,7 +722,7 @@ getClaimRequestsTicketR
|
|||
:: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler Html
|
||||
getClaimRequestsTicketR shr prj ltkhid = 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.on $ person E.^. PersonIdent E.==. sharer E.^. SharerId
|
||||
E.on $ tcr E.^. TicketClaimRequestPerson E.==. person E.^. PersonId
|
||||
|
|
@ -771,7 +746,7 @@ postClaimRequestsTicketR shr prj ltkhid = do
|
|||
now <- liftIO getCurrentTime
|
||||
pid <- requireAuthId
|
||||
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
|
||||
{ ticketClaimRequestPerson = pid
|
||||
, ticketClaimRequestTicket = tid
|
||||
|
|
@ -791,7 +766,7 @@ postClaimRequestsTicketR shr prj ltkhid = do
|
|||
selectDiscussionId
|
||||
:: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> AppDB DiscussionId
|
||||
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
|
||||
|
||||
getProjectTicketDiscussionR
|
||||
|
|
@ -878,7 +853,7 @@ getTicketDeps forward shr prj ltkhid = do
|
|||
if forward then TicketDependencyParent else TicketDependencyChild
|
||||
to' =
|
||||
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 $
|
||||
\ ( td
|
||||
`E.InnerJoin` t
|
||||
|
|
@ -951,7 +926,7 @@ getProjectTicketDepsR = getTicketDeps True
|
|||
postProjectTicketDepsR
|
||||
:: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler Html
|
||||
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
|
||||
case result of
|
||||
FormSuccess ctid -> do
|
||||
|
|
@ -979,7 +954,7 @@ postProjectTicketDepsR shr prj ltkhid = do
|
|||
getProjectTicketDepNewR
|
||||
:: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler Html
|
||||
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
|
||||
defaultLayout $(widgetFile "ticket/dep/new")
|
||||
|
||||
|
|
@ -995,7 +970,7 @@ deleteTicketDepOldR
|
|||
:: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> KeyHashid LocalTicket -> Handler Html
|
||||
deleteTicketDepOldR shr prj pnum cnum = 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
|
||||
clt <- get404 cltid
|
||||
|
|
@ -1072,14 +1047,14 @@ getProjectTicketParticipantsR shr prj ltkhid = getFollowersCollection here getFs
|
|||
where
|
||||
here = ProjectTicketParticipantsR shr prj ltkhid
|
||||
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
|
||||
|
||||
getProjectTicketTeamR
|
||||
:: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler TypedContent
|
||||
getProjectTicketTeamR shr prj ltkhid = 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_ <-
|
||||
requireEitherAlt
|
||||
(getKeyBy $ UniquePersonIdent sid)
|
||||
|
|
@ -1117,43 +1092,6 @@ getProjectTicketEventsR
|
|||
:: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler TypedContent
|
||||
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 shr = do
|
||||
(total, pages, mpage) <- runDB $ do
|
||||
|
|
@ -1229,7 +1167,7 @@ getSharerTicketR
|
|||
:: ShrIdent -> KeyHashid TicketAuthorLocal -> Handler TypedContent
|
||||
getSharerTicketR shr talkhid = do
|
||||
(ticket, project, massignee) <- runDB $ do
|
||||
(_, _, Entity _ t, tp) <- getSharerTicket shr talkhid
|
||||
(_, _, Entity _ t, tp) <- getSharerTicket404 shr talkhid
|
||||
(,,) t
|
||||
<$> bitraverse
|
||||
(\ (Entity _ tpl) -> do
|
||||
|
|
@ -1290,7 +1228,7 @@ getSharerTicketDiscussionR
|
|||
:: ShrIdent -> KeyHashid TicketAuthorLocal -> Handler TypedContent
|
||||
getSharerTicketDiscussionR shr talkhid = do
|
||||
(locals, remotes) <- runDB $ do
|
||||
(_, Entity _ lt, _, _) <- getSharerTicket shr talkhid
|
||||
(_, Entity _ lt, _, _) <- getSharerTicket404 shr talkhid
|
||||
let did = localTicketDiscuss lt
|
||||
(,) <$> selectLocals did <*> selectRemotes did
|
||||
encodeRouteLocal <- getEncodeRouteLocal
|
||||
|
|
@ -1340,7 +1278,7 @@ getSharerTicketDeps
|
|||
:: Bool -> ShrIdent -> KeyHashid TicketAuthorLocal -> Handler TypedContent
|
||||
getSharerTicketDeps forward shr talkhid = do
|
||||
tdids <- runDB $ do
|
||||
(_, _, Entity tid _, _) <- getSharerTicket shr talkhid
|
||||
(_, _, Entity tid _, _) <- getSharerTicket404 shr talkhid
|
||||
let (from, to) =
|
||||
if forward
|
||||
then (TicketDependencyParent, TicketDependencyChild)
|
||||
|
|
@ -1384,13 +1322,13 @@ getSharerTicketFollowersR shr talkhid = getFollowersCollection here getFsid
|
|||
where
|
||||
here = SharerTicketFollowersR shr talkhid
|
||||
getFsid = do
|
||||
(_, Entity _ lt, _, _) <- getSharerTicket shr talkhid
|
||||
(_, Entity _ lt, _, _) <- getSharerTicket404 shr talkhid
|
||||
return $ localTicketFollowers lt
|
||||
|
||||
getSharerTicketTeamR
|
||||
:: ShrIdent -> KeyHashid TicketAuthorLocal -> Handler TypedContent
|
||||
getSharerTicketTeamR shr talkhid = do
|
||||
_ <- runDB $ getSharerTicket shr talkhid
|
||||
_ <- runDB $ getSharerTicket404 shr talkhid
|
||||
encodeRouteLocal <- getEncodeRouteLocal
|
||||
let team = Collection
|
||||
{ collectionId = encodeRouteLocal here
|
||||
|
|
@ -1408,7 +1346,7 @@ getSharerTicketTeamR shr talkhid = do
|
|||
getSharerTicketEventsR
|
||||
:: ShrIdent -> KeyHashid TicketAuthorLocal -> Handler TypedContent
|
||||
getSharerTicketEventsR shr talkhid = do
|
||||
_ <- runDB $ getSharerTicket shr talkhid
|
||||
_ <- runDB $ getSharerTicket404 shr talkhid
|
||||
encodeRouteLocal <- getEncodeRouteLocal
|
||||
let team = Collection
|
||||
{ collectionId = encodeRouteLocal here
|
||||
|
|
|
|||
|
|
@ -27,16 +27,29 @@ module Vervis.Ticket
|
|||
, getTicketEnumParams
|
||||
, TicketClassParam (..)
|
||||
, getTicketClasses
|
||||
, getSharerTicket
|
||||
, getSharerTicket404
|
||||
, getProjectTicket
|
||||
, getProjectTicket404
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Arrow ((***))
|
||||
import Control.Monad
|
||||
import Control.Monad.Trans.Class
|
||||
import Control.Monad.Trans.Maybe
|
||||
import Data.Foldable (for_)
|
||||
import Data.Int
|
||||
import Data.Maybe (isJust)
|
||||
import Data.Text (Text)
|
||||
import Data.Traversable
|
||||
import Database.Esqueleto
|
||||
import Yesod.Core (notFound)
|
||||
|
||||
import Yesod.Hashids
|
||||
|
||||
import Data.Either.Local
|
||||
import Database.Persist.Local
|
||||
|
||||
import Vervis.Foundation (AppDB)
|
||||
import Vervis.Model
|
||||
|
|
@ -408,3 +421,113 @@ getTicketClasses tid wid = fmap (map toCParam) $
|
|||
, f ^. WorkflowFieldFilterClosed
|
||||
, 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
|
||||
|
|
|
|||
|
|
@ -67,6 +67,7 @@ module Web.ActivityPub
|
|||
, Activity (..)
|
||||
|
||||
-- * Utilities
|
||||
, emptyAudience
|
||||
, emptyActivity
|
||||
, hActivityPubActor
|
||||
, provideAP
|
||||
|
|
@ -1266,6 +1267,9 @@ instance ActivityPub Activity where
|
|||
encodeSpecific _ _ (RejectActivity a) = encodeReject a
|
||||
encodeSpecific h _ (UndoActivity a) = encodeUndo h a
|
||||
|
||||
emptyAudience :: Audience u
|
||||
emptyAudience = Audience [] [] [] [] [] []
|
||||
|
||||
emptyActivity :: Activity u
|
||||
emptyActivity = Activity
|
||||
{ activityId = Nothing
|
||||
|
|
@ -1275,8 +1279,6 @@ emptyActivity = Activity
|
|||
, activitySpecific =
|
||||
RejectActivity $ Reject $ ObjURI (Authority "" Nothing) topLocalURI
|
||||
}
|
||||
where
|
||||
emptyAudience = Audience [] [] [] [] [] []
|
||||
|
||||
typeActivityStreams2 :: ContentType
|
||||
typeActivityStreams2 = "application/activity+json"
|
||||
|
|
|
|||
Loading…
Reference in a new issue