diff --git a/config/models b/config/models index 9d4db56..f5b711f 100644 --- a/config/models +++ b/config/models @@ -304,10 +304,12 @@ Ticket closer PersonId Maybe discuss DiscussionId followers FollowerSetId + accept OutboxItemId UniqueTicket project number UniqueTicketDiscussion discuss UniqueTicketFollowers followers + UniqueTicketAccept accept TicketAuthorLocal ticket TicketId diff --git a/migrations/2019_06_24.model b/migrations/2019_06_24.model new file mode 100644 index 0000000..5e3e3e0 --- /dev/null +++ b/migrations/2019_06_24.model @@ -0,0 +1,92 @@ +Sharer + ident ShrIdent + name Text Maybe + created UTCTime + + UniqueSharer ident + +Person + ident SharerId + login Text + passphraseHash ByteString + email Text + verified Bool + verifiedKey Text + verifiedKeyCreated UTCTime + resetPassKey Text + resetPassKeyCreated UTCTime + about Text + inbox InboxId + outbox OutboxId + + UniquePersonIdent ident + UniquePersonLogin login + UniquePersonEmail email + UniquePersonInbox inbox + UniquePersonOutbox outbox + +Outbox + +OutboxItem + outbox OutboxId + activity PersistActivity + published UTCTime + +Inbox + +InboxItem + unread Bool + +InboxItemLocal + inbox InboxId + activity OutboxItemId + item InboxItemId + + UniqueInboxItemLocal inbox activity + UniqueInboxItemLocalItem item + +Project + ident PrjIdent + sharer SharerId + name Text Maybe + desc Text Maybe + workflow Int64 + nextTicket Int + wiki Int64 Maybe + collabUser Int64 Maybe + collabAnon Int64 Maybe + inbox InboxId + outbox OutboxId + followers Int64 + + UniqueProject ident sharer + UniqueProjectInbox inbox + UniqueProjectOutbox outbox + UniqueProjectFollowers followers + +Ticket + project ProjectId + number Int + created UTCTime + title Text -- HTML + source Text -- Pandoc Markdown + description Text -- HTML + assignee PersonId Maybe + status Text + closed UTCTime + closer PersonId Maybe + discuss Int64 + followers Int64 + accept OutboxItemId + + UniqueTicket project number + UniqueTicketDiscussion discuss + UniqueTicketFollowers followers + +TicketAuthorLocal + ticket TicketId + author PersonId + offer OutboxItemId + + UniqueTicketAuthorLocal ticket + UniqueTicketAuthorLocalOffer offer diff --git a/src/Vervis/API.hs b/src/Vervis/API.hs index a83e19a..ada831c 100644 --- a/src/Vervis/API.hs +++ b/src/Vervis/API.hs @@ -53,6 +53,7 @@ import Network.HTTP.Client import Network.HTTP.Types.Header import Network.HTTP.Types.URI import Network.TLS hiding (SHA256) +import Text.Blaze.Html (preEscapedToHtml) import Text.Blaze.Html.Renderer.Text import UnliftIO.Exception (try) import Yesod.Core hiding (logError, logWarn, logInfo, logDebug) @@ -468,9 +469,9 @@ offerTicketC shrUser summary audience offer@(Offer ticket uTarget) = runExceptT if targetIsLocal then Just <$> getProjectAndDeps shrProject prjProject deps else return Nothing - (obiid, doc) <- lift $ insertToOutbox now obidAuthor + (obiid, doc, luOffer) <- lift $ insertToOutbox now obidAuthor moreRemotes <- - lift $ deliverLocal shrProject prjProject now pidAuthor mprojAndDeps obiid localRecips + lift $ deliverLocal pidAuthor shrProject prjProject now mprojAndDeps obiid luOffer localRecips unless (federation || null moreRemotes) $ throwE "Federation disabled but remote collection members found" remotesHttp <- lift $ deliverRemoteDB' hProject obiid remoteRecips moreRemotes @@ -535,8 +536,8 @@ offerTicketC shrUser summary audience offer@(Offer ticket uTarget) = runExceptT let luAct = encodeRouteLocal $ SharerOutboxItemR shrUser obikhid doc = activity $ Just luAct update obiid [OutboxItemActivity =. PersistJSON doc] - return (obiid, doc) - deliverLocal shrProject prjProject now pidAuthor mprojAndDeps obiid recips = do + return (obiid, doc, luAct) + deliverLocal pidAuthor shrProject prjProject now mprojAndDeps obiid luOffer recips = do (pids, remotes) <- forCollect recips $ \ (shr, LocalSharerRelatedSet sharer projects) -> do (pids, remotes) <- traverseCollect (uncurry $ deliverLocalProject shr) projects @@ -571,7 +572,12 @@ offerTicketC shrUser summary audience offer@(Offer ticket uTarget) = runExceptT prj == prjProject && localRecipProject project -> do insertToInbox ibid - insertTicket jid tids + num <- + ((subtract 1) . projectNextTicket) <$> + updateGet jid [ProjectNextTicket +=. 1] + (obiidAccept, docAccept) <- insertAccept pidAuthor sid jid fsid luOffer num + insertTicket jid tids num obiidAccept + publishAccept pidAuthor sid jid fsid luOffer num obiidAccept docAccept (pidsTeam, remotesTeam) <- if localRecipProjectTeam project then getProjectTeam sid @@ -589,10 +595,59 @@ offerTicketC shrUser summary audience offer@(Offer ticket uTarget) = runExceptT insertToInbox ibid = do ibiid <- insert $ InboxItem False insert_ $ InboxItemLocal ibid obiid ibiid - insertTicket jid tidsDeps = do - next <- - ((subtract 1) . projectNextTicket) <$> - updateGet jid [ProjectNextTicket +=. 1] + insertAccept pidAuthor sid jid fsid luOffer num = do + now <- liftIO getCurrentTime + obid <- projectOutbox <$> getJust jid + insertToOutbox now obid + where + insertToOutbox now obid = do + summary <- + TextHtml . TL.toStrict . renderHtml <$> + withUrlRenderer + [hamlet| +

+ + #{shr2text shrUser} + 's ticket accepted by project # + + ./s/#{shr2text shrProject}/p/#{prj2text prjProject} + : # + + #{preEscapedToHtml $ unTextHtml $ AP.ticketSummary ticket}. + |] + hLocal <- asksSite siteInstanceHost + encodeRouteLocal <- getEncodeRouteLocal + encodeRouteHome <- getEncodeRouteHome + let recips = + map encodeRouteHome + [ SharerR shrUser + , ProjectTeamR shrProject prjProject + , ProjectFollowersR shrProject prjProject + ] + accept luAct = Doc hLocal Activity + { activityId = luAct + , activityActor = + encodeRouteLocal $ ProjectR shrProject prjProject + , activitySummary = Just summary + , activityAudience = Audience recips [] [] [] [] [] + , activitySpecific = AcceptActivity Accept + { acceptObject = l2f hLocal luOffer + , acceptResult = + encodeRouteLocal $ TicketR shrProject prjProject num + } + } + obiid <- insert OutboxItem + { outboxItemOutbox = obid + , outboxItemActivity = PersistJSON $ accept Nothing + , outboxItemPublished = now + } + encodeRouteLocal <- getEncodeRouteLocal + obikhid <- encodeKeyHashid obiid + let luAct = encodeRouteLocal $ ProjectOutboxItemR shrProject prjProject obikhid + doc = accept $ Just luAct + update obiid [OutboxItemActivity =. PersistJSON doc] + return (obiid, doc) + insertTicket jid tidsDeps next obiidAccept = do did <- insert Discussion fsid <- insert FollowerSet tid <- insert Ticket @@ -609,6 +664,7 @@ offerTicketC shrUser summary audience offer@(Offer ticket uTarget) = runExceptT , ticketCloser = Nothing , ticketDiscuss = did , ticketFollowers = fsid + , ticketAccept = obiidAccept } insert TicketAuthorLocal { ticketAuthorLocalTicket = tid @@ -616,6 +672,24 @@ offerTicketC shrUser summary audience offer@(Offer ticket uTarget) = runExceptT , ticketAuthorLocalOffer = obiid } insertMany_ $ map (TicketDependency tid) tidsDeps + publishAccept pidAuthor sid jid fsid luOffer num obiid doc = do + now <- liftIO getCurrentTime + remotesHttp <- do + moreRemotes <- deliverLocal now sid fsid obiid + deliverRemoteDB' "dont-do.any-forwarding" obiid [] moreRemotes + site <- askSite + liftIO $ runWorker (deliverRemoteHttp "dont-do.any-forwarding" obiid doc remotesHttp) site + where + deliverLocal now sid fsid obiid = do + (pidsTeam, remotesTeam) <- getProjectTeam sid + (pidsFollowers, remotesFollowers) <- getFollowers fsid + let pids = LO.insertSet pidAuthor $ LO.union pidsTeam pidsFollowers + remotes = unionRemotes remotesTeam remotesFollowers + for_ pids $ \ pid -> do + ibid <- personInbox <$> getJust pid + ibiid <- insert $ InboxItem True + insert_ $ InboxItemLocal ibid obiid ibiid + return remotes getFollowersCollection :: Route App -> AppDB FollowerSetId -> Handler TypedContent diff --git a/src/Vervis/ActivityPub.hs b/src/Vervis/ActivityPub.hs index e996a25..74970b5 100644 --- a/src/Vervis/ActivityPub.hs +++ b/src/Vervis/ActivityPub.hs @@ -67,7 +67,10 @@ import Database.Persist import Database.Persist.Sql import Network.HTTP.Client import Network.TLS -- hiding (SHA256) +import Text.Blaze.Html (preEscapedToHtml) +import Text.Blaze.Html.Renderer.Text import UnliftIO.Exception (try) +import Yesod.Core hiding (logError, logWarn, logInfo, logDebug) import Yesod.Core.Handler import Yesod.Persist.Core @@ -76,10 +79,12 @@ import qualified Data.CaseInsensitive as CI import qualified Data.List.NonEmpty as NE import qualified Data.List.Ordered as LO import qualified Data.Text as T +import qualified Data.Text.Lazy as TL import qualified Database.Esqueleto as E import Yesod.HttpSignature +import Database.Persist.JSON import Network.FedURI import Network.HTTP.Digest import Web.ActivityPub @@ -88,6 +93,8 @@ import Yesod.MonadSite import Yesod.FedURI import Yesod.Hashids +import qualified Web.ActivityPub as AP + import Control.Monad.Trans.Except.Local import Data.Either.Local import Data.List.NonEmpty.Local diff --git a/src/Vervis/Federation.hs b/src/Vervis/Federation.hs index 8949156..245cdfd 100644 --- a/src/Vervis/Federation.hs +++ b/src/Vervis/Federation.hs @@ -217,10 +217,14 @@ handleSharerInbox _now shrRecip (ActivityAuthLocalProject jidAuthor) body = do return $ "Activity inserted to inbox of /s/" <> recip handleSharerInbox now shrRecip (ActivityAuthRemote author) body = case activitySpecific $ actbActivity body of + AcceptActivity accept -> + sharerAcceptOfferTicketF now shrRecip author body accept CreateActivity (Create note) -> sharerCreateNoteF now shrRecip author body note OfferActivity offer -> sharerOfferTicketF now shrRecip author body offer + RejectActivity reject -> + sharerRejectOfferTicketF now shrRecip author body reject _ -> return "Unsupported activity type" handleProjectInbox diff --git a/src/Vervis/Federation/Ticket.hs b/src/Vervis/Federation/Ticket.hs index e0b9d67..0bec22b 100644 --- a/src/Vervis/Federation/Ticket.hs +++ b/src/Vervis/Federation/Ticket.hs @@ -15,6 +15,8 @@ module Vervis.Federation.Ticket ( sharerOfferTicketF + , sharerAcceptOfferTicketF + , sharerRejectOfferTicketF , projectOfferTicketF ) where @@ -29,24 +31,32 @@ import Data.Bifunctor import Data.Foldable import Data.Function import Data.List (nub, union) -import Data.List.NonEmpty (NonEmpty) +import Data.List.NonEmpty (NonEmpty (..)) import Data.Maybe import Data.Text (Text) import Data.Time.Calendar import Data.Time.Clock import Data.Traversable import Database.Persist +import Text.Blaze.Html (preEscapedToHtml) +import Text.Blaze.Html.Renderer.Text +import Yesod.Core hiding (logError, logWarn, logInfo, logDebug) import Yesod.Core.Handler import Yesod.Persist.Core +import qualified Data.List.NonEmpty as NE +import qualified Data.List.Ordered as LO +import qualified Data.Text as T +import qualified Data.Text.Lazy as TL + import Database.Persist.JSON import Network.FedURI import Web.ActivityPub hiding (Ticket (..)) import Yesod.ActivityPub import Yesod.FedURI +import Yesod.Hashids +import Yesod.MonadSite -import qualified Data.List.NonEmpty as NE -import qualified Data.Text as T import qualified Web.ActivityPub as AP import Control.Monad.Trans.Except.Local @@ -119,6 +129,68 @@ sharerOfferTicketF now shrRecip author body (Offer ticket uTarget) = do return $ "Activity already exists in inbox of /s/" <> recip Just _ -> return $ "Activity inserted to inbox of /s/" <> recip +sharerAcceptOfferTicketF + :: UTCTime + -> ShrIdent + -> RemoteAuthor + -> ActivityBody + -> Accept + -> ExceptT Text Handler Text +sharerAcceptOfferTicketF now shrRecip author body (Accept _uOffer _luTicket) = do + luAccept <- + fromMaybeE (activityId $ actbActivity body) "Accept without 'id'" + lift $ runDB $ do + ibidRecip <- do + sid <- getKeyBy404 $ UniqueSharer shrRecip + p <- getValBy404 $ UniquePersonIdent sid + return $ personInbox p + insertToInbox luAccept ibidRecip + where + insertToInbox luAccept ibidRecip = do + let iidAuthor = remoteAuthorInstance author + jsonObj = PersistJSON $ actbObject body + ract = RemoteActivity iidAuthor luAccept jsonObj now + ractid <- either entityKey id <$> insertBy' ract + ibiid <- insert $ InboxItem True + mibrid <- insertUnique $ InboxItemRemote ibidRecip ractid ibiid + let recip = shr2text shrRecip + case mibrid of + Nothing -> do + delete ibiid + return $ "Activity already exists in inbox of /s/" <> recip + Just _ -> return $ "Activity inserted to inbox of /s/" <> recip + +sharerRejectOfferTicketF + :: UTCTime + -> ShrIdent + -> RemoteAuthor + -> ActivityBody + -> Reject + -> ExceptT Text Handler Text +sharerRejectOfferTicketF now shrRecip author body (Reject _uOffer) = do + luReject <- + fromMaybeE (activityId $ actbActivity body) "Reject without 'id'" + lift $ runDB $ do + ibidRecip <- do + sid <- getKeyBy404 $ UniqueSharer shrRecip + p <- getValBy404 $ UniquePersonIdent sid + return $ personInbox p + insertToInbox luReject ibidRecip + where + insertToInbox luReject ibidRecip = do + let iidAuthor = remoteAuthorInstance author + jsonObj = PersistJSON $ actbObject body + ract = RemoteActivity iidAuthor luReject jsonObj now + ractid <- either entityKey id <$> insertBy' ract + ibiid <- insert $ InboxItem True + mibrid <- insertUnique $ InboxItemRemote ibidRecip ractid ibiid + let recip = shr2text shrRecip + case mibrid of + Nothing -> do + delete ibiid + return $ "Activity already exists in inbox of /s/" <> recip + Just _ -> return $ "Activity inserted to inbox of /s/" <> recip + data OfferTicketRecipColl = OfferTicketRecipProjectFollowers | OfferTicketRecipProjectTeam @@ -156,15 +228,19 @@ projectOfferTicketF mremotesHttp <- runDBExcept $ do (sid, jid, ibid, fsid, tids) <- getProjectAndDeps shrRecip prjRecip deps - lift $ join <$> do - mractid <- insertTicket luOffer jid ibid tids - for mractid $ \ ractid -> for msig $ \ sig -> do - remoteRecips <- deliverLocal ractid colls sid fsid - (sig,) <$> deliverRemoteDB (actbBL body) ractid jid sig remoteRecips - lift $ for_ mremotesHttp $ \ (sig, remotesHttp) -> do - let handler e = logError $ "Project inbox handler: delivery failed! " <> T.pack (displayException e) - forkHandler handler $ - deliverRemoteHTTP now shrRecip prjRecip (actbBL body) sig remotesHttp + lift $ do + mticket <- insertTicket luOffer jid ibid tids + for mticket $ \ (ractid, num, obiidAccept, docAccept) -> do + msr <- for msig $ \ sig -> do + remoteRecips <- deliverLocal ractid colls sid fsid + (sig,) <$> deliverRemoteDB (actbBL body) ractid jid sig remoteRecips + return (num, msr, obiidAccept, docAccept) + lift $ for_ mremotesHttp $ \ (num, msr, obiidAccept, docAccept) -> do + let handler e = logError $ "Project Accept sender: delivery failed! " <> T.pack (displayException e) + for msr $ \ (sig, remotesHttp) -> do + forkHandler handler $ + deliverRemoteHTTP now shrRecip prjRecip (actbBL body) sig remotesHttp + forkHandler handler $ publishAccept luOffer num obiidAccept docAccept return $ recip <> " inserted new ticket" where recip = T.concat ["/s/", shr2text shrRecip, "/p/", prj2text prjRecip] @@ -222,6 +298,7 @@ projectOfferTicketF updateGet jid [ProjectNextTicket +=. 1] did <- insert Discussion fsid <- insert FollowerSet + (obiidAccept, docAccept) <- insertAccept luOffer next tid <- insert Ticket { ticketProject = jid , ticketNumber = next @@ -236,6 +313,7 @@ projectOfferTicketF , ticketCloser = Nothing , ticketDiscuss = did , ticketFollowers = fsid + , ticketAccept = obiidAccept } insert_ TicketAuthorRemote { ticketAuthorRemoteTicket = tid @@ -243,7 +321,7 @@ projectOfferTicketF , ticketAuthorRemoteOffer = ractid } insertMany_ $ map (TicketDependency tid) deps - return $ Just ractid + return $ Just (ractid, next, obiidAccept, docAccept) deliverLocal :: RemoteActivityId @@ -269,3 +347,90 @@ projectOfferTicketF when (isNothing mibrid) $ delete ibiid return remotes + + insertAccept luOffer num = do + now <- liftIO getCurrentTime + (sid, project) <- do + sid <- fromJust <$> getKeyBy (UniqueSharer shrRecip) + j <- fromJust <$> getValBy (UniqueProject prjRecip sid) + return (sid, j) + insertToOutbox now $ projectOutbox project + where + insertToOutbox now obid = do + summary <- + TextHtml . TL.toStrict . renderHtml <$> + withUrlRenderer + [hamlet| +

+ + (?) + 's ticket accepted by project # + + ./s/#{shr2text shrRecip}/p/#{prj2text prjRecip} + : # + + #{preEscapedToHtml $ unTextHtml $ AP.ticketSummary ticket}. + |] + hLocal <- asksSite siteInstanceHost + encodeRouteLocal <- getEncodeRouteLocal + encodeRouteHome <- getEncodeRouteHome + let recips = + remoteAuthorURI author : + map encodeRouteHome + [ ProjectTeamR shrRecip prjRecip + , ProjectFollowersR shrRecip prjRecip + ] + accept luAct = Doc hLocal Activity + { activityId = luAct + , activityActor = + encodeRouteLocal $ ProjectR shrRecip prjRecip + , activitySummary = Just summary + , activityAudience = Audience recips [] [] [] [] [] + , activitySpecific = AcceptActivity Accept + { acceptObject = + l2f (furiHost $ remoteAuthorURI author) luOffer + , acceptResult = + encodeRouteLocal $ TicketR shrRecip prjRecip num + } + } + obiid <- insert OutboxItem + { outboxItemOutbox = obid + , outboxItemActivity = PersistJSON $ accept Nothing + , outboxItemPublished = now + } + encodeRouteLocal <- getEncodeRouteLocal + obikhid <- encodeKeyHashid obiid + let luAct = encodeRouteLocal $ ProjectOutboxItemR shrRecip prjRecip obikhid + doc = accept $ Just luAct + update obiid [OutboxItemActivity =. PersistJSON doc] + return (obiid, doc) + + publishAccept luOffer num obiid doc = do + now <- liftIO getCurrentTime + remotesHttp <- runDB $ do + (sid, project) <- do + sid <- fromJust <$> getKeyBy (UniqueSharer shrRecip) + j <- fromJust <$> getValBy (UniqueProject prjRecip sid) + return (sid, j) + moreRemotes <- deliverLocal now sid (projectFollowers project) obiid + let raidAuthor = remoteAuthorId author + ra <- getJust raidAuthor + let raInfo = (raidAuthor, remoteActorIdent ra, remoteActorInbox ra, remoteActorErrorSince ra) + iidAuthor = remoteAuthorInstance author + hAuthor = furiHost $ remoteAuthorURI author + hostSection = ((iidAuthor, hAuthor), raInfo :| []) + remotes = unionRemotes [hostSection] moreRemotes + deliverRemoteDB' "dont-do.any-forwarding" obiid [] remotes + site <- askSite + liftIO $ runWorker (deliverRemoteHttp "dont-do.any-forwarding" obiid doc remotesHttp) site + where + deliverLocal now sid fsid obiid = do + (pidsTeam, remotesTeam) <- getProjectTeam sid + (pidsFollowers, remotesFollowers) <- getFollowers fsid + let pids = LO.union pidsTeam pidsFollowers + remotes = unionRemotes remotesTeam remotesFollowers + for_ pids $ \ pid -> do + ibid <- personInbox <$> getJust pid + ibiid <- insert $ InboxItem True + insert_ $ InboxItemLocal ibid obiid ibiid + return remotes diff --git a/src/Vervis/Form/Ticket.hs b/src/Vervis/Form/Ticket.hs index 45fca46..a46ff8b 100644 --- a/src/Vervis/Form/Ticket.hs +++ b/src/Vervis/Form/Ticket.hs @@ -140,6 +140,7 @@ editTicketContentAForm ticket = Ticket <*> pure (ticketCloser ticket) <*> pure (ticketDiscuss ticket) <*> pure (ticketFollowers ticket) + <*> pure (ticketAccept ticket) tEditField :: TicketTextParam diff --git a/src/Vervis/Migration.hs b/src/Vervis/Migration.hs index 33c7dcd..f87594a 100644 --- a/src/Vervis/Migration.hs +++ b/src/Vervis/Migration.hs @@ -44,7 +44,7 @@ import Database.Persist.Schema (SchemaT, Migration) import Database.Persist.Schema.Types hiding (Entity) import Database.Persist.Schema.PostgreSQL (schemaBackend) import Database.Persist.Sql (SqlBackend, toSqlKey) -import Text.Blaze.Html (toHtml) +import Text.Blaze.Html (toHtml, preEscapedToHtml) import Text.Blaze.Html.Renderer.Text --import Text.Email.QuasiQuotation (email import Text.Email.Validate (unsafeEmailAddress) @@ -321,7 +321,7 @@ changes hLocal ctx = , activityActor = localUri , activitySummary = Nothing , activityAudience = Audience [] [] [] [] [] [] - , activitySpecific = AcceptActivity $ Accept fedUri + , activitySpecific = RejectActivity $ Reject fedUri } insertEntity $ OutboxItem201905 pid (PersistJSON doc) defaultTime ) @@ -688,7 +688,7 @@ changes hLocal ctx = , activityActor = localUri , activitySummary = Nothing , activityAudience = Audience [] [] [] [] [] [] - , activitySpecific = AcceptActivity $ Accept fedUri + , activitySpecific = RejectActivity $ Reject fedUri } insertEntity $ OutboxItem20190612 pid (PersistJSON doc) defaultTime ) @@ -842,6 +842,104 @@ changes hLocal ctx = let title = TL.toStrict $ renderHtml $ toHtml $ ticket20190612Title t in update tid [Ticket20190612Title =. title] + -- 124 + , addFieldRefRequired'' + "Ticket" + (do obid <- insert Outbox20190624 + let localUri = LocalURI "/x/y" "" + fedUri = l2f "x.y" localUri + doc = Doc "x.y" Activity + { activityId = Nothing + , activityActor = localUri + , activitySummary = Nothing + , activityAudience = Audience [] [] [] [] [] [] + , activitySpecific = RejectActivity $ Reject fedUri + } + insertEntity $ OutboxItem20190624 obid (PersistJSON doc) defaultTime + ) + (Just $ \ (Entity obiidTemp obiTemp) -> do + ts <- selectList ([] :: [Filter Ticket20190624]) [] + for_ ts $ \ (Entity tid ticket) -> do + let num = ticket20190624Number ticket + j <- getJust $ ticket20190624Project ticket + let prj = project20190624Ident j + ibidProject = project20190624Inbox j + obidProject = project20190624Outbox j + sProject <- getJust $ project20190624Sharer j + let shrProject = sharer20190624Ident sProject + + Entity talid tal <- + fromJust <$> getBy (UniqueTicketAuthorLocal20190624 tid) + let pidAuthor = ticketAuthorLocal20190624Author tal + pAuthor <- getJust pidAuthor + let ibidAuthor = person20190624Inbox pAuthor + sAuthor <- getJust $ person20190624Ident pAuthor + let shrAuthor = sharer20190624Ident sAuthor + + encodeRouteLocal <- getEncodeRouteLocal + encodeRouteHome <- getEncodeRouteHome + renderUrl <- askUrlRenderParams + offerR <- do + let obiidOffer = ticketAuthorLocal20190624Offer tal + obikhid <- + encodeKeyHashid $ E.toSqlKey $ E.fromSqlKey obiidOffer + return $ SharerOutboxItemR shrAuthor obikhid + + let recips = map encodeRouteHome + [ SharerR shrAuthor + , ProjectTeamR shrProject prj + , ProjectFollowersR shrProject prj + ] + author = encodeRouteLocal $ SharerR shrAuthor + summary = + [hamlet| +

+ + #{shr2text shrAuthor} + 's ticket accepted by project # + + ./s/#{shr2text shrProject}/p/#{prj2text prj} + : # + + #{preEscapedToHtml $ ticket20190624Title ticket}. + |] + doc mluAct = Doc hLocal Activity + { activityId = mluAct + , activityActor = author + , activitySummary = + Just $ TextHtml $ TL.toStrict $ renderHtml $ + summary renderUrl + , activityAudience = Audience recips [] [] [] [] [] + , activitySpecific = AcceptActivity Accept + { acceptObject = encodeRouteHome offerR + , acceptResult = + encodeRouteLocal $ TicketR shrProject prj num + } + } + obiidNew <- insert OutboxItem20190624 + { outboxItem20190624Outbox = obidProject + , outboxItem20190624Activity = PersistJSON $ doc Nothing + , outboxItem20190624Published = + ticket20190624Created ticket + } + obikhidNew <- + encodeKeyHashid $ E.toSqlKey $ E.fromSqlKey obiidNew + let luAct = + encodeRouteLocal $ + ProjectOutboxItemR shrProject prj obikhidNew + act = doc $ Just luAct + update obiidNew [OutboxItem20190624Activity =. PersistJSON act] + update tid [Ticket20190624Accept =. obiidNew] + ibiid <- insert $ InboxItem20190624 True + insert_ $ InboxItemLocal20190624 ibidAuthor obiidNew ibiid + + delete obiidTemp + delete $ outboxItem20190624Outbox obiTemp + ) + "accept" + "OutboxItem" + -- 125 + , addUnique "Ticket" $ Unique "UniqueTicketAccept" ["accept"] ] migrateDB diff --git a/src/Vervis/Migration/Model.hs b/src/Vervis/Migration/Model.hs index 6c2cf3e..4160a89 100644 --- a/src/Vervis/Migration/Model.hs +++ b/src/Vervis/Migration/Model.hs @@ -99,6 +99,17 @@ module Vervis.Migration.Model , Project20190616Generic (..) , Project20190616 , Outbox20190616Generic (..) + , Sharer20190624Generic (..) + , Person20190624Generic (..) + , Outbox20190624Generic (..) + , OutboxItem20190624Generic (..) + , Inbox20190624Generic (..) + , InboxItem20190624Generic (..) + , InboxItemLocal20190624Generic (..) + , Project20190624Generic (..) + , Ticket20190624Generic (..) + , Ticket20190624 + , TicketAuthorLocal20190624Generic (..) ) where @@ -213,3 +224,6 @@ makeEntitiesMigration "20190615" makeEntitiesMigration "20190616" $(modelFile "migrations/2019_06_16.model") + +makeEntitiesMigration "20190624" + $(modelFile "migrations/2019_06_24.model") diff --git a/src/Web/ActivityPub.hs b/src/Web/ActivityPub.hs index a20bf7b..3d5afb7 100644 --- a/src/Web/ActivityPub.hs +++ b/src/Web/ActivityPub.hs @@ -679,13 +679,19 @@ instance ActivityPub Ticket where data Accept = Accept { acceptObject :: FedURI + , acceptResult :: LocalURI } -parseAccept :: Object -> Parser Accept -parseAccept o = Accept <$> o .: "object" +parseAccept :: Text -> Object -> Parser Accept +parseAccept h o = + Accept + <$> o .: "object" + <*> (withHost h $ f2l <$> o .: "result") -encodeAccept :: Accept -> Series -encodeAccept (Accept obj) = "object" .= obj +encodeAccept :: Text -> Accept -> Series +encodeAccept host (Accept obj result) + = "object" .= obj + <> "result" .= l2f host result data Create = Create { createObject :: Note @@ -779,7 +785,7 @@ instance ActivityPub Activity where <*> do typ <- o .: "type" case typ of - "Accept" -> AcceptActivity <$> parseAccept o + "Accept" -> AcceptActivity <$> parseAccept h o "Create" -> CreateActivity <$> parseCreate o h actor "Follow" -> FollowActivity <$> parseFollow o "Offer" -> OfferActivity <$> parseOffer o h actor @@ -801,7 +807,7 @@ instance ActivityPub Activity where activityType (FollowActivity _) = "Follow" activityType (OfferActivity _) = "Offer" activityType (RejectActivity _) = "Reject" - encodeSpecific _ _ (AcceptActivity a) = encodeAccept a + encodeSpecific h _ (AcceptActivity a) = encodeAccept h a encodeSpecific h u (CreateActivity a) = encodeCreate h u a encodeSpecific _ _ (FollowActivity a) = encodeFollow a encodeSpecific h u (OfferActivity a) = encodeOffer h u a