Handle Offer{Ticket} in project inbox, and turn DB ticketTitle into HTML
This commit is contained in:
parent
4d5fa0551f
commit
fb909adf2e
8 changed files with 346 additions and 130 deletions
|
@ -295,7 +295,7 @@ Ticket
|
|||
project ProjectId
|
||||
number Int
|
||||
created UTCTime
|
||||
title Text
|
||||
title Text -- HTML
|
||||
source Text -- Pandoc Markdown
|
||||
description Text -- HTML
|
||||
assignee PersonId Maybe
|
||||
|
|
|
@ -30,33 +30,50 @@ module Vervis.ActivityPub
|
|||
, isInstanceErrorP
|
||||
, isInstanceErrorG
|
||||
, deliverHttp
|
||||
, deliverRemoteDB
|
||||
, deliverRemoteHTTP
|
||||
, checkForward
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Exception hiding (try)
|
||||
import Control.Exception hiding (Handler, try)
|
||||
import Control.Monad
|
||||
import Control.Monad.IO.Class
|
||||
import Control.Monad.IO.Unlift
|
||||
import Control.Monad.Logger.CallStack
|
||||
import Control.Monad.Trans.Class
|
||||
import Control.Monad.Trans.Except
|
||||
import Control.Monad.Trans.Reader
|
||||
import Data.Bifunctor
|
||||
import Data.ByteString (ByteString)
|
||||
import Data.Foldable
|
||||
import Data.Function
|
||||
import Data.List.NonEmpty (NonEmpty, nonEmpty)
|
||||
import Data.List.NonEmpty (NonEmpty (..), nonEmpty)
|
||||
import Data.Maybe
|
||||
import Data.Semigroup
|
||||
import Data.Text (Text)
|
||||
import Data.Text.Encoding
|
||||
import Data.Time.Clock
|
||||
import Data.Traversable
|
||||
import Database.Persist
|
||||
import Database.Persist.Sql
|
||||
import Network.HTTP.Client
|
||||
import Network.TLS -- hiding (SHA256)
|
||||
import UnliftIO.Exception (try)
|
||||
import Yesod.Core.Handler
|
||||
import Yesod.Persist.Core
|
||||
|
||||
import qualified Data.ByteString.Lazy as BL
|
||||
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 Database.Esqueleto as E
|
||||
|
||||
import Yesod.HttpSignature
|
||||
|
||||
import Network.FedURI
|
||||
import Network.HTTP.Digest
|
||||
import Web.ActivityPub
|
||||
import Yesod.ActivityPub
|
||||
import Yesod.MonadSite
|
||||
|
@ -66,6 +83,7 @@ import Yesod.Hashids
|
|||
import Control.Monad.Trans.Except.Local
|
||||
import Data.Either.Local
|
||||
import Data.List.NonEmpty.Local
|
||||
import Data.Tuple.Local
|
||||
import Database.Persist.Local
|
||||
|
||||
import Vervis.Foundation
|
||||
|
@ -247,3 +265,99 @@ deliverHttp
|
|||
-> m (Either APPostError (Response ()))
|
||||
deliverHttp doc mfwd h luInbox =
|
||||
deliverActivity (l2f h luInbox) (l2f h <$> mfwd) doc
|
||||
|
||||
deliverRemoteDB
|
||||
:: BL.ByteString
|
||||
-> RemoteActivityId
|
||||
-> ProjectId
|
||||
-> ByteString
|
||||
-> [((InstanceId, Text), NonEmpty (RemoteActorId, LocalURI, LocalURI, Maybe UTCTime))]
|
||||
-> AppDB
|
||||
[((InstanceId, Text), NonEmpty (RemoteActorId, LocalURI, LocalURI, ForwardingId))]
|
||||
deliverRemoteDB body ractid jid sig recips = do
|
||||
let body' = BL.toStrict body
|
||||
deliv raid msince = Forwarding raid ractid body' jid sig $ isNothing msince
|
||||
fetchedDeliv <- for recips $ \ (i, rs) ->
|
||||
(i,) <$> insertMany' (\ (raid, _, _, msince) -> deliv raid msince) rs
|
||||
return $ takeNoError4 fetchedDeliv
|
||||
where
|
||||
takeNoError noError = mapMaybe $ \ (i, rs) -> (i,) <$> nonEmpty (mapMaybe noError $ NE.toList rs)
|
||||
takeNoError4 = takeNoError noError
|
||||
where
|
||||
noError ((ak, luA, luI, Nothing), dlk) = Just (ak, luA, luI, dlk)
|
||||
noError ((_ , _ , _ , Just _ ), _ ) = Nothing
|
||||
|
||||
deliverRemoteHTTP
|
||||
:: UTCTime
|
||||
-> ShrIdent
|
||||
-> PrjIdent
|
||||
-> BL.ByteString
|
||||
-> ByteString
|
||||
-> [((InstanceId, Text), NonEmpty (RemoteActorId, LocalURI, LocalURI, ForwardingId))]
|
||||
-> Handler ()
|
||||
deliverRemoteHTTP now shrRecip prjRecip body sig fetched = do
|
||||
let deliver h inbox =
|
||||
let sender = ProjectR shrRecip prjRecip
|
||||
in forwardActivity (l2f h inbox) sig sender body
|
||||
traverse_ (fork . deliverFetched deliver now) fetched
|
||||
where
|
||||
fork = forkHandler $ \ e -> logError $ "Project inbox handler: delivery failed! " <> T.pack (displayException e)
|
||||
deliverFetched deliver now ((_, h), recips@(r :| rs)) = do
|
||||
let (raid, _luActor, luInbox, fwid) = r
|
||||
e <- deliver h luInbox
|
||||
let e' = case e of
|
||||
Left err ->
|
||||
if isInstanceErrorP err
|
||||
then Nothing
|
||||
else Just False
|
||||
Right _resp -> Just True
|
||||
case e' of
|
||||
Nothing -> runDB $ do
|
||||
let recips' = NE.toList recips
|
||||
updateWhere [RemoteActorId <-. map fst4 recips', RemoteActorErrorSince ==. Nothing] [RemoteActorErrorSince =. Just now]
|
||||
updateWhere [ForwardingId <-. map fourth4 recips'] [ForwardingRunning =. False]
|
||||
Just success -> do
|
||||
runDB $
|
||||
if success
|
||||
then delete fwid
|
||||
else do
|
||||
updateWhere [RemoteActorId ==. raid, RemoteActorErrorSince ==. Nothing] [RemoteActorErrorSince =. Just now]
|
||||
update fwid [ForwardingRunning =. False]
|
||||
for_ rs $ \ (raid, _luActor, luInbox, fwid) ->
|
||||
fork $ do
|
||||
e <- deliver h luInbox
|
||||
runDB $
|
||||
case e of
|
||||
Left _err -> do
|
||||
updateWhere [RemoteActorId ==. raid, RemoteActorErrorSince ==. Nothing] [RemoteActorErrorSince =. Just now]
|
||||
update fwid [ForwardingRunning =. False]
|
||||
Right _resp -> delete fwid
|
||||
|
||||
checkForward shrRecip prjRecip = join <$> do
|
||||
let hSig = hForwardingSignature
|
||||
msig <- maybeHeader hSig
|
||||
for msig $ \ sig -> do
|
||||
_proof <- withExceptT (T.pack . displayException) $ ExceptT $
|
||||
let requires = [hDigest, hActivityPubForwarder]
|
||||
in prepareToVerifyHttpSigWith hSig False requires [] Nothing
|
||||
forwarder <- requireHeader hActivityPubForwarder
|
||||
renderUrl <- getUrlRender
|
||||
let project = renderUrl $ ProjectR shrRecip prjRecip
|
||||
return $
|
||||
if forwarder == encodeUtf8 project
|
||||
then Just sig
|
||||
else Nothing
|
||||
where
|
||||
maybeHeader n = do
|
||||
let n' = decodeUtf8 $ CI.original n
|
||||
hs <- lookupHeaders n
|
||||
case hs of
|
||||
[] -> return Nothing
|
||||
[h] -> return $ Just h
|
||||
_ -> throwE $ n' <> " multiple headers found"
|
||||
requireHeader n = do
|
||||
let n' = decodeUtf8 $ CI.original n
|
||||
mh <- maybeHeader n
|
||||
case mh of
|
||||
Nothing -> throwE $ n' <> " header not found"
|
||||
Just h -> return h
|
||||
|
|
|
@ -237,6 +237,8 @@ handleProjectInbox now shrRecip prjRecip auth body = do
|
|||
case activitySpecific $ actbActivity body of
|
||||
CreateActivity (Create note) ->
|
||||
projectCreateNoteF now shrRecip prjRecip remoteAuthor body note
|
||||
OfferActivity offer ->
|
||||
projectOfferTicketF now shrRecip prjRecip remoteAuthor body offer
|
||||
_ -> return "Unsupported activity type"
|
||||
|
||||
fixRunningDeliveries :: (MonadIO m, MonadLogger m, IsSqlBackend backend) => ReaderT backend m ()
|
||||
|
|
|
@ -216,7 +216,7 @@ projectCreateNoteF now shrRecip prjRecip author body (Note mluNote _ _ muParent
|
|||
if shr /= shrRecip || prj /= prjRecip
|
||||
then return $ recip <> " not using; context is a different project"
|
||||
else do
|
||||
msig <- checkForward
|
||||
msig <- checkForward shrRecip prjRecip
|
||||
hLocal <- getsYesod $ appInstanceHost . appSettings
|
||||
let colls =
|
||||
findRelevantCollections hLocal num $
|
||||
|
@ -229,40 +229,13 @@ projectCreateNoteF now shrRecip prjRecip author body (Note mluNote _ _ muParent
|
|||
updateOrphans luNote did mid
|
||||
for msig $ \ sig -> do
|
||||
remoteRecips <- deliverLocal ractid colls sid fsidProject fsidTicket
|
||||
(sig,) <$> deliverRemoteDB ractid jid sig remoteRecips
|
||||
(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 sig remotesHttp
|
||||
forkHandler handler $
|
||||
deliverRemoteHTTP now shrRecip prjRecip (actbBL body) sig remotesHttp
|
||||
return $ recip <> " inserted new ticket comment"
|
||||
where
|
||||
checkForward = join <$> do
|
||||
let hSig = hForwardingSignature
|
||||
msig <- maybeHeader hSig
|
||||
for msig $ \ sig -> do
|
||||
_proof <- withExceptT (T.pack . displayException) $ ExceptT $
|
||||
let requires = [hDigest, hActivityPubForwarder]
|
||||
in prepareToVerifyHttpSigWith hSig False requires [] Nothing
|
||||
forwarder <- requireHeader hActivityPubForwarder
|
||||
renderUrl <- getUrlRender
|
||||
let project = renderUrl $ ProjectR shrRecip prjRecip
|
||||
return $
|
||||
if forwarder == encodeUtf8 project
|
||||
then Just sig
|
||||
else Nothing
|
||||
where
|
||||
maybeHeader n = do
|
||||
let n' = decodeUtf8 $ CI.original n
|
||||
hs <- lookupHeaders n
|
||||
case hs of
|
||||
[] -> return Nothing
|
||||
[h] -> return $ Just h
|
||||
_ -> throwE $ n' <> " multiple headers found"
|
||||
requireHeader n = do
|
||||
let n' = decodeUtf8 $ CI.original n
|
||||
mh <- maybeHeader n
|
||||
case mh of
|
||||
Nothing -> throwE $ n' <> " header not found"
|
||||
Just h -> return h
|
||||
findRelevantCollections hLocal numCtx = nub . mapMaybe decide . concatRecipients
|
||||
where
|
||||
decide u = do
|
||||
|
@ -404,66 +377,3 @@ projectCreateNoteF now shrRecip prjRecip author body (Note mluNote _ _ muParent
|
|||
when (isNothing mibrid) $
|
||||
delete ibiid
|
||||
return remotes
|
||||
|
||||
deliverRemoteDB
|
||||
:: RemoteActivityId
|
||||
-> ProjectId
|
||||
-> ByteString
|
||||
-> [((InstanceId, Text), NonEmpty (RemoteActorId, LocalURI, LocalURI, Maybe UTCTime))]
|
||||
-> AppDB
|
||||
[((InstanceId, Text), NonEmpty (RemoteActorId, LocalURI, LocalURI, ForwardingId))]
|
||||
deliverRemoteDB ractid jid sig recips = do
|
||||
let body' = BL.toStrict $ actbBL body
|
||||
deliv raid msince = Forwarding raid ractid body' jid sig $ isNothing msince
|
||||
fetchedDeliv <- for recips $ \ (i, rs) ->
|
||||
(i,) <$> insertMany' (\ (raid, _, _, msince) -> deliv raid msince) rs
|
||||
return $ takeNoError4 fetchedDeliv
|
||||
where
|
||||
takeNoError noError = mapMaybe $ \ (i, rs) -> (i,) <$> nonEmpty (mapMaybe noError $ NE.toList rs)
|
||||
takeNoError4 = takeNoError noError
|
||||
where
|
||||
noError ((ak, luA, luI, Nothing), dlk) = Just (ak, luA, luI, dlk)
|
||||
noError ((_ , _ , _ , Just _ ), _ ) = Nothing
|
||||
|
||||
deliverRemoteHttp
|
||||
:: ByteString
|
||||
-> [((InstanceId, Text), NonEmpty (RemoteActorId, LocalURI, LocalURI, ForwardingId))]
|
||||
-> Handler ()
|
||||
deliverRemoteHttp sig fetched = do
|
||||
let deliver h inbox =
|
||||
let sender = ProjectR shrRecip prjRecip
|
||||
in forwardActivity (l2f h inbox) sig sender (actbBL body)
|
||||
now <- liftIO getCurrentTime
|
||||
traverse_ (fork . deliverFetched deliver now) fetched
|
||||
where
|
||||
fork = forkHandler $ \ e -> logError $ "Project inbox handler: delivery failed! " <> T.pack (displayException e)
|
||||
deliverFetched deliver now ((_, h), recips@(r :| rs)) = do
|
||||
let (raid, _luActor, luInbox, fwid) = r
|
||||
e <- deliver h luInbox
|
||||
let e' = case e of
|
||||
Left err ->
|
||||
if isInstanceErrorP err
|
||||
then Nothing
|
||||
else Just False
|
||||
Right _resp -> Just True
|
||||
case e' of
|
||||
Nothing -> runDB $ do
|
||||
let recips' = NE.toList recips
|
||||
updateWhere [RemoteActorId <-. map fst4 recips', RemoteActorErrorSince ==. Nothing] [RemoteActorErrorSince =. Just now]
|
||||
updateWhere [ForwardingId <-. map fourth4 recips'] [ForwardingRunning =. False]
|
||||
Just success -> do
|
||||
runDB $
|
||||
if success
|
||||
then delete fwid
|
||||
else do
|
||||
updateWhere [RemoteActorId ==. raid, RemoteActorErrorSince ==. Nothing] [RemoteActorErrorSince =. Just now]
|
||||
update fwid [ForwardingRunning =. False]
|
||||
for_ rs $ \ (raid, _luActor, luInbox, fwid) ->
|
||||
fork $ do
|
||||
e <- deliver h luInbox
|
||||
runDB $
|
||||
case e of
|
||||
Left _err -> do
|
||||
updateWhere [RemoteActorId ==. raid, RemoteActorErrorSince ==. Nothing] [RemoteActorErrorSince =. Just now]
|
||||
update fwid [ForwardingRunning =. False]
|
||||
Right _resp -> delete fwid
|
||||
|
|
|
@ -15,26 +15,42 @@
|
|||
|
||||
module Vervis.Federation.Ticket
|
||||
( sharerOfferTicketF
|
||||
, projectOfferTicketF
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Exception hiding (Handler)
|
||||
import Control.Monad
|
||||
import Control.Monad.Logger.CallStack
|
||||
import Control.Monad.Trans.Class
|
||||
import Control.Monad.Trans.Except
|
||||
import Data.Aeson
|
||||
import Data.Bifunctor
|
||||
import Data.Foldable
|
||||
import Data.Function
|
||||
import Data.List (nub, union)
|
||||
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 Yesod.Core.Handler
|
||||
import Yesod.Persist.Core
|
||||
|
||||
import Database.Persist.JSON
|
||||
import Network.FedURI
|
||||
import Web.ActivityPub
|
||||
import Web.ActivityPub hiding (Ticket (..))
|
||||
import Yesod.ActivityPub
|
||||
import Yesod.FedURI
|
||||
|
||||
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
|
||||
import Data.Tuple.Local
|
||||
import Database.Persist.Local
|
||||
import Yesod.Persist.Local
|
||||
|
||||
|
@ -43,6 +59,39 @@ import Vervis.Federation.Auth
|
|||
import Vervis.Foundation
|
||||
import Vervis.Model
|
||||
import Vervis.Model.Ident
|
||||
import Vervis.Model.Ticket
|
||||
|
||||
checkOffer
|
||||
:: AP.Ticket -> Text -> ShrIdent -> PrjIdent -> ExceptT Text Handler [Int]
|
||||
checkOffer ticket hProject shrProject prjProject = do
|
||||
verifyNothingE (AP.ticketLocal ticket) "Ticket with 'id'"
|
||||
_published <-
|
||||
fromMaybeE (AP.ticketPublished ticket) "Ticket without 'published'"
|
||||
verifyNothingE (AP.ticketUpdated ticket) "Ticket with 'updated'"
|
||||
verifyNothingE (AP.ticketName ticket) "Ticket with 'name'"
|
||||
verifyNothingE (AP.ticketAssignedTo ticket) "Ticket with 'assignedTo'"
|
||||
when (AP.ticketIsResolved ticket) $ throwE "Ticket resolved"
|
||||
unless (null $ AP.ticketDependedBy ticket) $ throwE "Ticket has rdeps"
|
||||
traverse checkDep $ AP.ticketDependsOn ticket
|
||||
where
|
||||
checkDep u = do
|
||||
let (h, lu) = f2l u
|
||||
unless (h == hProject) $
|
||||
throwE "Dep belongs to different host"
|
||||
(shrTicket, prjTicket, num) <- parseTicket lu
|
||||
unless (shrTicket == shrProject) $
|
||||
throwE "Dep belongs to different sharer under same host"
|
||||
unless (prjTicket == prjProject) $
|
||||
throwE "Dep belongs to different project under same sharer"
|
||||
return num
|
||||
where
|
||||
parseTicket lu = do
|
||||
route <- case decodeRouteLocal lu of
|
||||
Nothing -> throwE "Expected ticket route, got invalid route"
|
||||
Just r -> return r
|
||||
case route of
|
||||
TicketR shr prj num -> return (shr, prj, num)
|
||||
_ -> throwE "Expected ticket route, got non-ticket route"
|
||||
|
||||
sharerOfferTicketF
|
||||
:: UTCTime
|
||||
|
@ -52,16 +101,8 @@ sharerOfferTicketF
|
|||
-> Offer
|
||||
-> ExceptT Text Handler Text
|
||||
sharerOfferTicketF now shrRecip author body (Offer ticket uTarget) = do
|
||||
verifyNothingE (ticketLocal ticket) "Ticket with 'id'"
|
||||
_published <-
|
||||
fromMaybeE (ticketPublished ticket) "Ticket without 'published'"
|
||||
verifyNothingE (ticketName ticket) "Ticket with 'name'"
|
||||
verifyNothingE (ticketAssignedTo ticket) "Ticket with 'assignedTo'"
|
||||
when (ticketIsResolved ticket) $ throwE "Ticket resolved"
|
||||
(hProject, shrProject, prjProject) <- parseTarget uTarget
|
||||
unless (null $ ticketDependedBy ticket) $ throwE "Ticket has rdeps"
|
||||
let checkDep' = checkDep hProject shrProject prjProject
|
||||
deps <- traverse checkDep' $ ticketDependsOn ticket
|
||||
deps <- checkOffer ticket hProject shrProject prjProject
|
||||
local <- hostIsLocal hProject
|
||||
runDBExcept $ do
|
||||
ibidRecip <- lift $ do
|
||||
|
@ -83,24 +124,6 @@ sharerOfferTicketF now shrRecip author body (Offer ticket uTarget) = do
|
|||
case route of
|
||||
ProjectR shr prj -> return (shr, prj)
|
||||
_ -> throwE "Expected project route, got non-project route"
|
||||
checkDep hProject shrProject prjProject u = do
|
||||
let (h, lu) = f2l u
|
||||
unless (h == hProject) $
|
||||
throwE "Dep belongs to different host"
|
||||
(shrTicket, prjTicket, num) <- parseTicket lu
|
||||
unless (shrTicket == shrProject) $
|
||||
throwE "Dep belongs to different sharer under same host"
|
||||
unless (prjTicket == prjProject) $
|
||||
throwE "Dep belongs to different project under same sharer"
|
||||
return num
|
||||
where
|
||||
parseTicket lu = do
|
||||
route <- case decodeRouteLocal lu of
|
||||
Nothing -> throwE "Expected ticket route, got invalid route"
|
||||
Just r -> return r
|
||||
case route of
|
||||
TicketR shr prj num -> return (shr, prj, num)
|
||||
_ -> throwE "Expected ticket route, got non-ticket route"
|
||||
checkTargetAndDeps shrProject prjProject deps = do
|
||||
msid <- lift $ getKeyBy $ UniqueSharer shrProject
|
||||
sid <- fromMaybeE msid "Offer target: no such local sharer"
|
||||
|
@ -124,3 +147,161 @@ sharerOfferTicketF now shrRecip author body (Offer ticket uTarget) = 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
|
||||
deriving Eq
|
||||
|
||||
projectOfferTicketF
|
||||
:: UTCTime
|
||||
-> ShrIdent
|
||||
-> PrjIdent
|
||||
-> RemoteAuthor
|
||||
-> ActivityBody
|
||||
-> Offer
|
||||
-> ExceptT Text Handler Text
|
||||
projectOfferTicketF
|
||||
now shrRecip prjRecip author body (Offer ticket uTarget) = do
|
||||
targetIsUs <- lift $ runExceptT checkTarget
|
||||
case targetIsUs of
|
||||
Left t -> do
|
||||
logWarn $ T.concat
|
||||
[ recip, " got Offer Ticket with target "
|
||||
, renderFedURI uTarget
|
||||
]
|
||||
return t
|
||||
Right () -> do
|
||||
hLocal <- getsYesod siteInstanceHost
|
||||
deps <- checkOffer ticket hLocal shrRecip prjRecip
|
||||
msig <- checkForward shrRecip prjRecip
|
||||
let colls =
|
||||
findRelevantCollections hLocal $
|
||||
activityAudience $ actbActivity body
|
||||
mremotesHttp <- runDBExcept $ do
|
||||
(sid, jid, ibid, fsid, next, tids) <-
|
||||
getProjectAndDeps deps
|
||||
lift $ join <$> do
|
||||
mractid <- insertTicket jid ibid next 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
|
||||
return $ recip <> " inserted new ticket"
|
||||
where
|
||||
recip = T.concat ["/s/", shr2text shrRecip, "/p/", prj2text prjRecip]
|
||||
checkTarget = do
|
||||
let (h, lu) = f2l uTarget
|
||||
local <- hostIsLocal h
|
||||
unless local $
|
||||
throwE $ recip <> " not using; target has different host"
|
||||
route <-
|
||||
case decodeRouteLocal lu of
|
||||
Nothing ->
|
||||
throwE $
|
||||
recip <> " not using; local target isn't a valid route"
|
||||
Just r -> return r
|
||||
(shrTarget, prjTarget) <-
|
||||
case route of
|
||||
ProjectR shr prj -> return (shr, prj)
|
||||
_ -> throwE $
|
||||
recip <>
|
||||
" not using; local target isn't a project route"
|
||||
unless (shrTarget == shrRecip && prjTarget == prjRecip) $
|
||||
throwE $ recip <> " not using; local target is a different project"
|
||||
findRelevantCollections hLocal = nub . mapMaybe decide . concatRecipients
|
||||
where
|
||||
decide u = do
|
||||
let (h, lu) = f2l u
|
||||
guard $ h == hLocal
|
||||
route <- decodeRouteLocal lu
|
||||
case route of
|
||||
ProjectTeamR shr prj
|
||||
| shr == shrRecip && prj == prjRecip
|
||||
-> Just OfferTicketRecipProjectTeam
|
||||
ProjectFollowersR shr prj
|
||||
| shr == shrRecip && prj == prjRecip
|
||||
-> Just OfferTicketRecipProjectFollowers
|
||||
_ -> Nothing
|
||||
getProjectAndDeps deps = do
|
||||
msid <- lift $ getKeyBy $ UniqueSharer shrRecip
|
||||
sid <- fromMaybeE msid "Offer target: no such local sharer"
|
||||
mej <- lift $ getBy $ UniqueProject prjRecip sid
|
||||
Entity jid j <- fromMaybeE mej "Offer target: no such local project"
|
||||
tids <- for deps $ \ dep -> do
|
||||
mtid <- lift $ getKeyBy $ UniqueTicket jid dep
|
||||
fromMaybeE mtid "Local dep: No such ticket number in DB"
|
||||
return
|
||||
( sid, jid, projectInbox j, projectFollowers j, projectNextTicket j
|
||||
, tids
|
||||
)
|
||||
insertTicket jid ibid next deps = do
|
||||
let iidAuthor = remoteAuthorInstance author
|
||||
raidAuthor = remoteAuthorId author
|
||||
ractid <- either entityKey id <$> insertBy' RemoteActivity
|
||||
{ remoteActivityInstance = iidAuthor
|
||||
, remoteActivityIdent = activityId $ actbActivity body
|
||||
, remoteActivityContent = PersistJSON $ actbObject body
|
||||
, remoteActivityReceived = now
|
||||
}
|
||||
ibiid <- insert $ InboxItem False
|
||||
mibirid <- insertUnique $ InboxItemRemote ibid ractid ibiid
|
||||
case mibirid of
|
||||
Nothing -> do
|
||||
delete ibiid
|
||||
return Nothing
|
||||
Just _ibirid -> do
|
||||
update jid [ProjectNextTicket +=. 1]
|
||||
did <- insert Discussion
|
||||
fsid <- insert FollowerSet
|
||||
tid <- insert Ticket
|
||||
{ ticketProject = jid
|
||||
, ticketNumber = next
|
||||
, ticketCreated = now
|
||||
, ticketTitle = unTextHtml $ AP.ticketSummary ticket
|
||||
, ticketSource =
|
||||
unTextPandocMarkdown $ AP.ticketSource ticket
|
||||
, ticketDescription = unTextHtml $ AP.ticketContent ticket
|
||||
, ticketAssignee = Nothing
|
||||
, ticketStatus = TSNew
|
||||
, ticketClosed = UTCTime (ModifiedJulianDay 0) 0
|
||||
, ticketCloser = Nothing
|
||||
, ticketDiscuss = did
|
||||
, ticketFollowers = fsid
|
||||
}
|
||||
insert_ TicketAuthorRemote
|
||||
{ ticketAuthorRemoteTicket = tid
|
||||
, ticketAuthorRemoteAuthor = raidAuthor
|
||||
, ticketAuthorRemoteOffer = ractid
|
||||
}
|
||||
insertMany_ $ map (TicketDependency tid) deps
|
||||
return $ Just ractid
|
||||
|
||||
deliverLocal
|
||||
:: RemoteActivityId
|
||||
-> [OfferTicketRecipColl]
|
||||
-> SharerId
|
||||
-> FollowerSetId
|
||||
-> AppDB [((InstanceId, Text), NonEmpty (RemoteActorId, LocalURI, LocalURI, Maybe UTCTime))]
|
||||
deliverLocal ractid recips sid fsid = do
|
||||
(teamPids, teamRemotes) <-
|
||||
if OfferTicketRecipProjectTeam `elem` recips
|
||||
then getTicketTeam sid
|
||||
else return ([], [])
|
||||
(fsPids, fsRemotes) <-
|
||||
if OfferTicketRecipProjectFollowers `elem` recips
|
||||
then getFollowers fsid
|
||||
else return ([], [])
|
||||
let pids = union teamPids fsPids
|
||||
-- TODO inefficient, see the other TODOs about mergeConcat
|
||||
remotes = map (second $ NE.nubBy ((==) `on` fst4)) $ mergeConcat teamRemotes fsRemotes
|
||||
for_ pids $ \ pid -> do
|
||||
ibid <- personInbox <$> getJust pid
|
||||
ibiid <- insert $ InboxItem True
|
||||
mibrid <- insertUnique $ InboxItemRemote ibid ractid ibiid
|
||||
when (isNothing mibrid) $
|
||||
delete ibiid
|
||||
return remotes
|
||||
|
|
|
@ -32,6 +32,7 @@ import Data.Text (Text)
|
|||
import Data.Time.Calendar (Day (..))
|
||||
import Data.Time.Clock (getCurrentTime, UTCTime (..))
|
||||
import Database.Persist
|
||||
import Text.HTML.SanitizeXSS
|
||||
import Yesod.Form
|
||||
import Yesod.Persist.Core (runDB)
|
||||
|
||||
|
@ -121,7 +122,9 @@ editTicketContentAForm ticket = Ticket
|
|||
<$> pure (ticketProject ticket)
|
||||
<*> pure (ticketNumber ticket)
|
||||
<*> pure (ticketCreated ticket)
|
||||
<*> areq textField "Title*" (Just $ ticketTitle ticket)
|
||||
<*> ( sanitizeBalance <$>
|
||||
areq textField "Title*" (Just $ ticketTitle ticket)
|
||||
)
|
||||
<*> ( maybe "" (T.filter (/= '\r') . unTextarea) <$>
|
||||
aopt
|
||||
textareaField
|
||||
|
|
|
@ -72,6 +72,7 @@ import Database.Persist
|
|||
import Network.HTTP.Types (StdMethod (DELETE, POST))
|
||||
import Text.Blaze.Html (Html, toHtml)
|
||||
import Text.Blaze.Html.Renderer.Text
|
||||
import Text.HTML.SanitizeXSS
|
||||
import Yesod.Auth (requireAuthId, maybeAuthId)
|
||||
import Yesod.Core
|
||||
import Yesod.Core.Handler
|
||||
|
@ -165,7 +166,7 @@ postTicketsR shar proj = do
|
|||
{ ticketProject = pid
|
||||
, ticketNumber = projectNextTicket project
|
||||
, ticketCreated = now
|
||||
, ticketTitle = ntTitle nt
|
||||
, ticketTitle = sanitizeBalance $ ntTitle nt
|
||||
, ticketSource = source
|
||||
, ticketDescription = descHtml
|
||||
, ticketAssignee = Nothing
|
||||
|
@ -338,9 +339,7 @@ getTicketR shar proj num = do
|
|||
, AP.ticketPublished = Just $ ticketCreated ticket
|
||||
, AP.ticketUpdated = Nothing
|
||||
, AP.ticketName = Just $ "#" <> T.pack (show num)
|
||||
, AP.ticketSummary =
|
||||
TextHtml $ TL.toStrict $ renderHtml $ toHtml $
|
||||
ticketTitle ticket
|
||||
, AP.ticketSummary = TextHtml $ ticketTitle ticket
|
||||
, AP.ticketContent = TextHtml $ ticketDescription ticket
|
||||
, AP.ticketSource = TextPandocMarkdown $ ticketSource ticket
|
||||
, AP.ticketAssignedTo =
|
||||
|
|
|
@ -835,6 +835,13 @@ changes hLocal ctx =
|
|||
"Outbox"
|
||||
-- 122
|
||||
, addUnique "Project" $ Unique "UniqueProjectOutbox" ["outbox"]
|
||||
-- 123
|
||||
, unchecked $ lift $ do
|
||||
ts <- selectList ([] :: [Filter Ticket20190612]) []
|
||||
for_ ts $ \ (Entity tid t) ->
|
||||
let title =
|
||||
TL.toStrict $ renderHtml $ toHtml $ ticket20190612Title t
|
||||
in update tid [Ticket20190612Title =. title]
|
||||
]
|
||||
|
||||
migrateDB
|
||||
|
|
Loading…
Reference in a new issue