mirror of
https://code.sup39.dev/repos/Wqawg
synced 2024-12-27 17:14:52 +09:00
Implement getTicketDepR, not used anywhere else yet
This patch also disables the ability to specify deps when creating a ticket, because those deps won't be in the ticket object anymore. Instead of coding a workaround and getting complications later, I just disabled that thing. It wasn't really being used by anyone anyway.
This commit is contained in:
parent
828e015c54
commit
81a05a950f
13 changed files with 289 additions and 29 deletions
|
@ -330,6 +330,9 @@ TicketAuthorRemote
|
||||||
TicketDependency
|
TicketDependency
|
||||||
parent TicketId
|
parent TicketId
|
||||||
child TicketId
|
child TicketId
|
||||||
|
author PersonId
|
||||||
|
summary Text -- HTML
|
||||||
|
created UTCTime
|
||||||
|
|
||||||
UniqueTicketDependency parent child
|
UniqueTicketDependency parent child
|
||||||
|
|
||||||
|
|
|
@ -147,6 +147,7 @@
|
||||||
/s/#ShrIdent/p/#PrjIdent/t/#Int/deps/!new TicketDepNewR GET
|
/s/#ShrIdent/p/#PrjIdent/t/#Int/deps/!new TicketDepNewR GET
|
||||||
/s/#ShrIdent/p/#PrjIdent/t/#Int/deps/#Int TicketDepOldR POST DELETE
|
/s/#ShrIdent/p/#PrjIdent/t/#Int/deps/#Int TicketDepOldR POST DELETE
|
||||||
/s/#ShrIdent/p/#PrjIdent/t/#Int/rdeps TicketReverseDepsR GET
|
/s/#ShrIdent/p/#PrjIdent/t/#Int/rdeps TicketReverseDepsR GET
|
||||||
|
/tdeps/#TicketDepKeyHashid TicketDepR GET
|
||||||
/s/#ShrIdent/p/#PrjIdent/t/#Int/participants TicketParticipantsR GET
|
/s/#ShrIdent/p/#PrjIdent/t/#Int/participants TicketParticipantsR GET
|
||||||
/s/#ShrIdent/p/#PrjIdent/t/#Int/team TicketTeamR GET
|
/s/#ShrIdent/p/#PrjIdent/t/#Int/team TicketTeamR GET
|
||||||
/s/#ShrIdent/p/#PrjIdent/t/#Int/events TicketEventsR GET
|
/s/#ShrIdent/p/#PrjIdent/t/#Int/events TicketEventsR GET
|
||||||
|
|
71
migrations/2019_07_11.model
Normal file
71
migrations/2019_07_11.model
Normal file
|
@ -0,0 +1,71 @@
|
||||||
|
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
|
||||||
|
|
||||||
|
Inbox
|
||||||
|
|
||||||
|
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
|
||||||
|
|
||||||
|
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 Int64
|
||||||
|
|
||||||
|
UniqueTicket project number
|
||||||
|
UniqueTicketDiscussion discuss
|
||||||
|
UniqueTicketFollowers followers
|
||||||
|
UniqueTicketAccept accept
|
||||||
|
|
||||||
|
TicketDependency
|
||||||
|
parent TicketId
|
||||||
|
child TicketId
|
||||||
|
author PersonId
|
||||||
|
|
||||||
|
UniqueTicketDependency parent child
|
|
@ -19,8 +19,10 @@ module Data.Aeson.Local
|
||||||
, fromEither
|
, fromEither
|
||||||
, (.:|)
|
, (.:|)
|
||||||
, (.:|?)
|
, (.:|?)
|
||||||
|
, (.:+)
|
||||||
, (.=?)
|
, (.=?)
|
||||||
, (.=%)
|
, (.=%)
|
||||||
|
, (.=+)
|
||||||
, WithValue (..)
|
, WithValue (..)
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
|
@ -59,6 +61,9 @@ o .:| t = o .: t <|> o .: (frg <> t)
|
||||||
(.:|?) :: FromJSON a => Object -> Text -> Parser (Maybe a)
|
(.:|?) :: FromJSON a => Object -> Text -> Parser (Maybe a)
|
||||||
o .:|? t = optional $ o .:| t
|
o .:|? t = optional $ o .:| t
|
||||||
|
|
||||||
|
(.:+) :: (FromJSON a, FromJSON b) => Object -> Text -> Parser (Either a b)
|
||||||
|
o .:+ t = Left <$> o .: t <|> Right <$> o .: t
|
||||||
|
|
||||||
infixr 8 .=?
|
infixr 8 .=?
|
||||||
(.=?) :: ToJSON v => Text -> Maybe v -> Series
|
(.=?) :: ToJSON v => Text -> Maybe v -> Series
|
||||||
_ .=? Nothing = mempty
|
_ .=? Nothing = mempty
|
||||||
|
@ -71,6 +76,11 @@ k .=% v =
|
||||||
then mempty
|
then mempty
|
||||||
else k .= v
|
else k .= v
|
||||||
|
|
||||||
|
infixr 8 .=+
|
||||||
|
(.=+) :: (ToJSON a, ToJSON b) => Text -> Either a b -> Series
|
||||||
|
k .=+ Left x = k .= x
|
||||||
|
k .=+ Right y = k .= y
|
||||||
|
|
||||||
data WithValue a = WithValue
|
data WithValue a = WithValue
|
||||||
{ wvRaw :: Object
|
{ wvRaw :: Object
|
||||||
, wvParsed :: a
|
, wvParsed :: a
|
||||||
|
|
|
@ -451,7 +451,8 @@ offerTicketC
|
||||||
-> Handler (Either Text OutboxItemId)
|
-> Handler (Either Text OutboxItemId)
|
||||||
offerTicketC shrUser summary audience offer@(Offer ticket uTarget) = runExceptT $ do
|
offerTicketC shrUser summary audience offer@(Offer ticket uTarget) = runExceptT $ do
|
||||||
(hProject, shrProject, prjProject) <- parseTarget uTarget
|
(hProject, shrProject, prjProject) <- parseTarget uTarget
|
||||||
deps <- checkOffer hProject shrProject prjProject
|
{-deps <- -}
|
||||||
|
checkOffer hProject shrProject prjProject
|
||||||
(localRecips, remoteRecips) <- do
|
(localRecips, remoteRecips) <- do
|
||||||
mrecips <- parseAudience audience
|
mrecips <- parseAudience audience
|
||||||
fromMaybeE mrecips "Offer with no recipients"
|
fromMaybeE mrecips "Offer with no recipients"
|
||||||
|
@ -469,7 +470,7 @@ offerTicketC shrUser summary audience offer@(Offer ticket uTarget) = runExceptT
|
||||||
mprojAndDeps <- do
|
mprojAndDeps <- do
|
||||||
targetIsLocal <- hostIsLocal hProject
|
targetIsLocal <- hostIsLocal hProject
|
||||||
if targetIsLocal
|
if targetIsLocal
|
||||||
then Just <$> getProjectAndDeps shrProject prjProject deps
|
then Just <$> getProjectAndDeps shrProject prjProject {-deps-}
|
||||||
else return Nothing
|
else return Nothing
|
||||||
(obiid, doc, luOffer) <- lift $ insertToOutbox now obidAuthor
|
(obiid, doc, luOffer) <- lift $ insertToOutbox now obidAuthor
|
||||||
moreRemotes <-
|
moreRemotes <-
|
||||||
|
@ -488,10 +489,11 @@ offerTicketC shrUser summary audience offer@(Offer ticket uTarget) = runExceptT
|
||||||
verifyNothingE (AP.ticketName ticket) "Ticket with 'name'"
|
verifyNothingE (AP.ticketName ticket) "Ticket with 'name'"
|
||||||
verifyNothingE (AP.ticketAssignedTo ticket) "Ticket with 'assignedTo'"
|
verifyNothingE (AP.ticketAssignedTo ticket) "Ticket with 'assignedTo'"
|
||||||
when (AP.ticketIsResolved ticket) $ throwE "Ticket resolved"
|
when (AP.ticketIsResolved ticket) $ throwE "Ticket resolved"
|
||||||
|
unless (null $ AP.ticketDependsOn ticket) $ throwE "Ticket has deps"
|
||||||
unless (null $ AP.ticketDependedBy ticket) $ throwE "Ticket has rdeps"
|
unless (null $ AP.ticketDependedBy ticket) $ throwE "Ticket has rdeps"
|
||||||
traverse checkDep' $ AP.ticketDependsOn ticket
|
--traverse checkDep' $ AP.ticketDependsOn ticket
|
||||||
where
|
--where
|
||||||
checkDep' = checkDep hProject shrProject prjProject
|
--checkDep' = checkDep hProject shrProject prjProject
|
||||||
checkRecips hProject shrProject prjProject localRecips = do
|
checkRecips hProject shrProject prjProject localRecips = do
|
||||||
local <- hostIsLocal hProject
|
local <- hostIsLocal hProject
|
||||||
if local
|
if local
|
||||||
|
@ -570,7 +572,7 @@ offerTicketC shrUser summary audience offer@(Offer ticket uTarget) = runExceptT
|
||||||
forCollect = flip traverseCollect
|
forCollect = flip traverseCollect
|
||||||
deliverLocalProject shr prj (LocalProjectRelatedSet project _) =
|
deliverLocalProject shr prj (LocalProjectRelatedSet project _) =
|
||||||
case mprojAndDeps of
|
case mprojAndDeps of
|
||||||
Just (sid, jid, ibid, fsid, tids)
|
Just (sid, jid, ibid, fsid{-, tids-})
|
||||||
| shr == shrProject &&
|
| shr == shrProject &&
|
||||||
prj == prjProject &&
|
prj == prjProject &&
|
||||||
localRecipProject project -> do
|
localRecipProject project -> do
|
||||||
|
@ -579,7 +581,7 @@ offerTicketC shrUser summary audience offer@(Offer ticket uTarget) = runExceptT
|
||||||
((subtract 1) . projectNextTicket) <$>
|
((subtract 1) . projectNextTicket) <$>
|
||||||
updateGet jid [ProjectNextTicket +=. 1]
|
updateGet jid [ProjectNextTicket +=. 1]
|
||||||
(obiidAccept, docAccept) <- insertAccept pidAuthor sid jid fsid luOffer num
|
(obiidAccept, docAccept) <- insertAccept pidAuthor sid jid fsid luOffer num
|
||||||
insertTicket jid tids num obiidAccept
|
insertTicket jid {-tids-} num obiidAccept
|
||||||
publishAccept pidAuthor sid jid fsid luOffer num obiidAccept docAccept
|
publishAccept pidAuthor sid jid fsid luOffer num obiidAccept docAccept
|
||||||
(pidsTeam, remotesTeam) <-
|
(pidsTeam, remotesTeam) <-
|
||||||
if localRecipProjectTeam project
|
if localRecipProjectTeam project
|
||||||
|
@ -653,7 +655,7 @@ offerTicketC shrUser summary audience offer@(Offer ticket uTarget) = runExceptT
|
||||||
obiid
|
obiid
|
||||||
[OutboxItemActivity =. persistJSONObjectFromDoc doc]
|
[OutboxItemActivity =. persistJSONObjectFromDoc doc]
|
||||||
return (obiid, doc)
|
return (obiid, doc)
|
||||||
insertTicket jid tidsDeps next obiidAccept = do
|
insertTicket jid {-tidsDeps-} next obiidAccept = do
|
||||||
did <- insert Discussion
|
did <- insert Discussion
|
||||||
fsid <- insert FollowerSet
|
fsid <- insert FollowerSet
|
||||||
tid <- insert Ticket
|
tid <- insert Ticket
|
||||||
|
@ -677,7 +679,7 @@ offerTicketC shrUser summary audience offer@(Offer ticket uTarget) = runExceptT
|
||||||
, ticketAuthorLocalAuthor = pidAuthor
|
, ticketAuthorLocalAuthor = pidAuthor
|
||||||
, ticketAuthorLocalOffer = obiid
|
, ticketAuthorLocalOffer = obiid
|
||||||
}
|
}
|
||||||
insertMany_ $ map (TicketDependency tid) tidsDeps
|
--insertMany_ $ map (TicketDependency tid) tidsDeps
|
||||||
insert_ $ Follow pidAuthor fsid False
|
insert_ $ Follow pidAuthor fsid False
|
||||||
publishAccept pidAuthor sid jid fsid luOffer num obiid doc = do
|
publishAccept pidAuthor sid jid fsid luOffer num obiid doc = do
|
||||||
now <- liftIO getCurrentTime
|
now <- liftIO getCurrentTime
|
||||||
|
|
|
@ -35,7 +35,7 @@ module Vervis.ActivityPub
|
||||||
, deliverRemoteHTTP
|
, deliverRemoteHTTP
|
||||||
, checkForward
|
, checkForward
|
||||||
, parseTarget
|
, parseTarget
|
||||||
, checkDep
|
--, checkDep
|
||||||
, getProjectAndDeps
|
, getProjectAndDeps
|
||||||
, deliverRemoteDB'
|
, deliverRemoteDB'
|
||||||
, deliverRemoteHttp
|
, deliverRemoteHttp
|
||||||
|
@ -398,6 +398,7 @@ parseTarget u = do
|
||||||
ProjectR shr prj -> return (shr, prj)
|
ProjectR shr prj -> return (shr, prj)
|
||||||
_ -> throwE "Expected project route, got non-project route"
|
_ -> throwE "Expected project route, got non-project route"
|
||||||
|
|
||||||
|
{-
|
||||||
checkDep hProject shrProject prjProject u = do
|
checkDep hProject shrProject prjProject u = do
|
||||||
let (h, lu) = f2l u
|
let (h, lu) = f2l u
|
||||||
unless (h == hProject) $
|
unless (h == hProject) $
|
||||||
|
@ -416,16 +417,19 @@ checkDep hProject shrProject prjProject u = do
|
||||||
case route of
|
case route of
|
||||||
TicketR shr prj num -> return (shr, prj, num)
|
TicketR shr prj num -> return (shr, prj, num)
|
||||||
_ -> throwE "Expected ticket route, got non-ticket route"
|
_ -> throwE "Expected ticket route, got non-ticket route"
|
||||||
|
-}
|
||||||
|
|
||||||
getProjectAndDeps shr prj deps = do
|
getProjectAndDeps shr prj {-deps-} = do
|
||||||
msid <- lift $ getKeyBy $ UniqueSharer shr
|
msid <- lift $ getKeyBy $ UniqueSharer shr
|
||||||
sid <- fromMaybeE msid "Offer target: no such local sharer"
|
sid <- fromMaybeE msid "Offer target: no such local sharer"
|
||||||
mej <- lift $ getBy $ UniqueProject prj sid
|
mej <- lift $ getBy $ UniqueProject prj sid
|
||||||
Entity jid j <- fromMaybeE mej "Offer target: no such local project"
|
Entity jid j <- fromMaybeE mej "Offer target: no such local project"
|
||||||
|
{-
|
||||||
tids <- for deps $ \ dep -> do
|
tids <- for deps $ \ dep -> do
|
||||||
mtid <- lift $ getKeyBy $ UniqueTicket jid dep
|
mtid <- lift $ getKeyBy $ UniqueTicket jid dep
|
||||||
fromMaybeE mtid "Local dep: No such ticket number in DB"
|
fromMaybeE mtid "Local dep: No such ticket number in DB"
|
||||||
return (sid, jid, projectInbox j, projectFollowers j, tids)
|
-}
|
||||||
|
return (sid, jid, projectInbox j, projectFollowers j{-, tids-})
|
||||||
|
|
||||||
data Recip
|
data Recip
|
||||||
= RecipRA (Entity RemoteActor)
|
= RecipRA (Entity RemoteActor)
|
||||||
|
|
|
@ -72,7 +72,7 @@ import Vervis.Model.Ident
|
||||||
import Vervis.Model.Ticket
|
import Vervis.Model.Ticket
|
||||||
|
|
||||||
checkOffer
|
checkOffer
|
||||||
:: AP.Ticket -> Text -> ShrIdent -> PrjIdent -> ExceptT Text Handler [Int]
|
:: AP.Ticket -> Text -> ShrIdent -> PrjIdent -> ExceptT Text Handler ()
|
||||||
checkOffer ticket hProject shrProject prjProject = do
|
checkOffer ticket hProject shrProject prjProject = do
|
||||||
verifyNothingE (AP.ticketLocal ticket) "Ticket with 'id'"
|
verifyNothingE (AP.ticketLocal ticket) "Ticket with 'id'"
|
||||||
verifyNothingE (AP.ticketPublished ticket) "Ticket with 'published'"
|
verifyNothingE (AP.ticketPublished ticket) "Ticket with 'published'"
|
||||||
|
@ -80,10 +80,11 @@ checkOffer ticket hProject shrProject prjProject = do
|
||||||
verifyNothingE (AP.ticketName ticket) "Ticket with 'name'"
|
verifyNothingE (AP.ticketName ticket) "Ticket with 'name'"
|
||||||
verifyNothingE (AP.ticketAssignedTo ticket) "Ticket with 'assignedTo'"
|
verifyNothingE (AP.ticketAssignedTo ticket) "Ticket with 'assignedTo'"
|
||||||
when (AP.ticketIsResolved ticket) $ throwE "Ticket resolved"
|
when (AP.ticketIsResolved ticket) $ throwE "Ticket resolved"
|
||||||
|
unless (null $ AP.ticketDependsOn ticket) $ throwE "Ticket has deps"
|
||||||
unless (null $ AP.ticketDependedBy ticket) $ throwE "Ticket has rdeps"
|
unless (null $ AP.ticketDependedBy ticket) $ throwE "Ticket has rdeps"
|
||||||
traverse checkDep' $ AP.ticketDependsOn ticket
|
--traverse checkDep' $ AP.ticketDependsOn ticket
|
||||||
where
|
--where
|
||||||
checkDep' = checkDep hProject shrProject prjProject
|
--checkDep' = checkDep hProject shrProject prjProject
|
||||||
|
|
||||||
sharerOfferTicketF
|
sharerOfferTicketF
|
||||||
:: UTCTime
|
:: UTCTime
|
||||||
|
@ -95,25 +96,29 @@ sharerOfferTicketF
|
||||||
sharerOfferTicketF now shrRecip author body (Offer ticket uTarget) = do
|
sharerOfferTicketF now shrRecip author body (Offer ticket uTarget) = do
|
||||||
(hProject, shrProject, prjProject) <- parseTarget uTarget
|
(hProject, shrProject, prjProject) <- parseTarget uTarget
|
||||||
luOffer <- fromMaybeE (activityId $ actbActivity body) "Offer without 'id'"
|
luOffer <- fromMaybeE (activityId $ actbActivity body) "Offer without 'id'"
|
||||||
deps <- checkOffer ticket hProject shrProject prjProject
|
{-deps <- -}
|
||||||
|
checkOffer ticket hProject shrProject prjProject
|
||||||
local <- hostIsLocal hProject
|
local <- hostIsLocal hProject
|
||||||
runDBExcept $ do
|
runDBExcept $ do
|
||||||
ibidRecip <- lift $ do
|
ibidRecip <- lift $ do
|
||||||
sid <- getKeyBy404 $ UniqueSharer shrRecip
|
sid <- getKeyBy404 $ UniqueSharer shrRecip
|
||||||
p <- getValBy404 $ UniquePersonIdent sid
|
p <- getValBy404 $ UniquePersonIdent sid
|
||||||
return $ personInbox p
|
return $ personInbox p
|
||||||
when local $ checkTargetAndDeps shrProject prjProject deps
|
when local $ checkTargetAndDeps shrProject prjProject {-deps-}
|
||||||
lift $ insertToInbox luOffer ibidRecip
|
lift $ insertToInbox luOffer ibidRecip
|
||||||
where
|
where
|
||||||
checkTargetAndDeps shrProject prjProject deps = do
|
checkTargetAndDeps shrProject prjProject {-deps-} = do
|
||||||
msid <- lift $ getKeyBy $ UniqueSharer shrProject
|
msid <- lift $ getKeyBy $ UniqueSharer shrProject
|
||||||
sid <- fromMaybeE msid "Offer target: no such local sharer"
|
sid <- fromMaybeE msid "Offer target: no such local sharer"
|
||||||
mjid <- lift $ getKeyBy $ UniqueProject prjProject sid
|
mjid <- lift $ getKeyBy $ UniqueProject prjProject sid
|
||||||
jid <- fromMaybeE mjid "Offer target: no such local project"
|
jid <- fromMaybeE mjid "Offer target: no such local project"
|
||||||
|
return ()
|
||||||
|
{-
|
||||||
for_ deps $ \ dep -> do
|
for_ deps $ \ dep -> do
|
||||||
mt <- lift $ getBy $ UniqueTicket jid dep
|
mt <- lift $ getBy $ UniqueTicket jid dep
|
||||||
unless (isJust mt) $
|
unless (isJust mt) $
|
||||||
throwE "Local dep: No such ticket number in DB"
|
throwE "Local dep: No such ticket number in DB"
|
||||||
|
-}
|
||||||
insertToInbox luOffer ibidRecip = do
|
insertToInbox luOffer ibidRecip = do
|
||||||
let iidAuthor = remoteAuthorInstance author
|
let iidAuthor = remoteAuthorInstance author
|
||||||
jsonObj = persistJSONFromBL $ actbBL body
|
jsonObj = persistJSONFromBL $ actbBL body
|
||||||
|
@ -219,16 +224,17 @@ projectOfferTicketF
|
||||||
(activityId $ actbActivity body)
|
(activityId $ actbActivity body)
|
||||||
"Offer without 'id'"
|
"Offer without 'id'"
|
||||||
hLocal <- getsYesod siteInstanceHost
|
hLocal <- getsYesod siteInstanceHost
|
||||||
deps <- checkOffer ticket hLocal shrRecip prjRecip
|
{-deps <- -}
|
||||||
|
checkOffer ticket hLocal shrRecip prjRecip
|
||||||
msig <- checkForward shrRecip prjRecip
|
msig <- checkForward shrRecip prjRecip
|
||||||
let colls =
|
let colls =
|
||||||
findRelevantCollections hLocal $
|
findRelevantCollections hLocal $
|
||||||
activityAudience $ actbActivity body
|
activityAudience $ actbActivity body
|
||||||
mremotesHttp <- runDBExcept $ do
|
mremotesHttp <- runDBExcept $ do
|
||||||
(sid, jid, ibid, fsid, tids) <-
|
(sid, jid, ibid, fsid{-, tids-}) <-
|
||||||
getProjectAndDeps shrRecip prjRecip deps
|
getProjectAndDeps shrRecip prjRecip {-deps-}
|
||||||
lift $ do
|
lift $ do
|
||||||
mticket <- insertTicket luOffer jid ibid tids
|
mticket <- insertTicket luOffer jid ibid {-tids-}
|
||||||
for mticket $ \ (ractid, num, obiidAccept, docAccept) -> do
|
for mticket $ \ (ractid, num, obiidAccept, docAccept) -> do
|
||||||
msr <- for msig $ \ sig -> do
|
msr <- for msig $ \ sig -> do
|
||||||
remoteRecips <- deliverLocal ractid colls sid fsid
|
remoteRecips <- deliverLocal ractid colls sid fsid
|
||||||
|
@ -276,7 +282,7 @@ projectOfferTicketF
|
||||||
| shr == shrRecip && prj == prjRecip
|
| shr == shrRecip && prj == prjRecip
|
||||||
-> Just OfferTicketRecipProjectFollowers
|
-> Just OfferTicketRecipProjectFollowers
|
||||||
_ -> Nothing
|
_ -> Nothing
|
||||||
insertTicket luOffer jid ibid deps = do
|
insertTicket luOffer jid ibid {-deps-} = do
|
||||||
let iidAuthor = remoteAuthorInstance author
|
let iidAuthor = remoteAuthorInstance author
|
||||||
raidAuthor = remoteAuthorId author
|
raidAuthor = remoteAuthorId author
|
||||||
ractid <- either entityKey id <$> insertBy' RemoteActivity
|
ractid <- either entityKey id <$> insertBy' RemoteActivity
|
||||||
|
@ -319,7 +325,7 @@ projectOfferTicketF
|
||||||
, ticketAuthorRemoteAuthor = raidAuthor
|
, ticketAuthorRemoteAuthor = raidAuthor
|
||||||
, ticketAuthorRemoteOffer = ractid
|
, ticketAuthorRemoteOffer = ractid
|
||||||
}
|
}
|
||||||
insertMany_ $ map (TicketDependency tid) deps
|
-- insertMany_ $ map (TicketDependency tid) deps
|
||||||
insert_ $ RemoteFollow raidAuthor fsid False
|
insert_ $ RemoteFollow raidAuthor fsid False
|
||||||
return $ Just (ractid, next, obiidAccept, docAccept)
|
return $ Just (ractid, next, obiidAccept, docAccept)
|
||||||
|
|
||||||
|
|
|
@ -133,6 +133,7 @@ data App = App
|
||||||
type OutboxItemKeyHashid = KeyHashid OutboxItem
|
type OutboxItemKeyHashid = KeyHashid OutboxItem
|
||||||
type MessageKeyHashid = KeyHashid Message
|
type MessageKeyHashid = KeyHashid Message
|
||||||
type LocalMessageKeyHashid = KeyHashid LocalMessage
|
type LocalMessageKeyHashid = KeyHashid LocalMessage
|
||||||
|
type TicketDepKeyHashid = KeyHashid TicketDependency
|
||||||
|
|
||||||
-- This is where we define all of the routes in our application. For a full
|
-- This is where we define all of the routes in our application. For a full
|
||||||
-- explanation of the syntax, please see:
|
-- explanation of the syntax, please see:
|
||||||
|
|
|
@ -48,6 +48,7 @@ module Vervis.Handler.Ticket
|
||||||
, postTicketDepOldR
|
, postTicketDepOldR
|
||||||
, deleteTicketDepOldR
|
, deleteTicketDepOldR
|
||||||
, getTicketReverseDepsR
|
, getTicketReverseDepsR
|
||||||
|
, getTicketDepR
|
||||||
, getTicketParticipantsR
|
, getTicketParticipantsR
|
||||||
, getTicketTeamR
|
, getTicketTeamR
|
||||||
, getTicketEventsR
|
, getTicketEventsR
|
||||||
|
@ -889,10 +890,15 @@ postTicketDepsR shr prj num = do
|
||||||
((result, widget), enctype) <- runFormPost $ ticketDepForm jid tid
|
((result, widget), enctype) <- runFormPost $ ticketDepForm jid tid
|
||||||
case result of
|
case result of
|
||||||
FormSuccess ctid -> do
|
FormSuccess ctid -> do
|
||||||
|
pidAuthor <- requireVerifiedAuthId
|
||||||
|
now <- liftIO getCurrentTime
|
||||||
runDB $ do
|
runDB $ do
|
||||||
let td = TicketDependency
|
let td = TicketDependency
|
||||||
{ ticketDependencyParent = tid
|
{ ticketDependencyParent = tid
|
||||||
, ticketDependencyChild = ctid
|
, ticketDependencyChild = ctid
|
||||||
|
, ticketDependencyAuthor = pidAuthor
|
||||||
|
, ticketDependencySummary = "(A ticket dependency)"
|
||||||
|
, ticketDependencyCreated = now
|
||||||
}
|
}
|
||||||
insert_ td
|
insert_ td
|
||||||
trrFix td ticketDepGraph
|
trrFix td ticketDepGraph
|
||||||
|
@ -937,6 +943,51 @@ deleteTicketDepOldR shr prj pnum cnum = do
|
||||||
getTicketReverseDepsR :: ShrIdent -> PrjIdent -> Int -> Handler Html
|
getTicketReverseDepsR :: ShrIdent -> PrjIdent -> Int -> Handler Html
|
||||||
getTicketReverseDepsR = getTicketDeps False
|
getTicketReverseDepsR = getTicketDeps False
|
||||||
|
|
||||||
|
getTicketDepR :: KeyHashid TicketDependency -> Handler TypedContent
|
||||||
|
getTicketDepR tdkhid = do
|
||||||
|
tdid <- decodeKeyHashid404 tdkhid
|
||||||
|
( td,
|
||||||
|
(sParent, jParent, tParent),
|
||||||
|
(sChild, jChild, tChild),
|
||||||
|
(sAuthor, pAuthor)
|
||||||
|
) <- runDB $ do
|
||||||
|
tdep <- get404 tdid
|
||||||
|
(,,,) tdep
|
||||||
|
<$> getTicket (ticketDependencyParent tdep)
|
||||||
|
<*> getTicket (ticketDependencyChild tdep)
|
||||||
|
<*> getAuthor (ticketDependencyAuthor tdep)
|
||||||
|
|
||||||
|
encodeRouteLocal <- getEncodeRouteLocal
|
||||||
|
encodeRouteHome <- getEncodeRouteHome
|
||||||
|
let ticketRoute s j t =
|
||||||
|
TicketR (sharerIdent s) (projectIdent j) (ticketNumber t)
|
||||||
|
here = TicketDepR tdkhid
|
||||||
|
tdepAP = Relationship
|
||||||
|
{ relationshipId = Just $ encodeRouteHome here
|
||||||
|
, relationshipSubject =
|
||||||
|
encodeRouteHome $ ticketRoute sParent jParent tParent
|
||||||
|
, relationshipProperty = Left RelDependsOn
|
||||||
|
, relationshipObject =
|
||||||
|
encodeRouteHome $ ticketRoute sChild jChild tChild
|
||||||
|
, relationshipAttributedTo =
|
||||||
|
encodeRouteLocal $ SharerR $ sharerIdent sAuthor
|
||||||
|
, relationshipPublished = Just $ ticketDependencyCreated td
|
||||||
|
, relationshipUpdated = Just $ ticketDependencyCreated td
|
||||||
|
, relationshipSummary = TextHtml $ ticketDependencySummary td
|
||||||
|
}
|
||||||
|
|
||||||
|
provideHtmlAndAP tdepAP $ redirectToPrettyJSON here
|
||||||
|
where
|
||||||
|
getTicket tid = do
|
||||||
|
t <- getJust tid
|
||||||
|
j <- getJust $ ticketProject t
|
||||||
|
s <- getJust $ projectSharer j
|
||||||
|
return (s, j, t)
|
||||||
|
getAuthor pid = do
|
||||||
|
p <- getJust pid
|
||||||
|
s <- getJust $ personIdent p
|
||||||
|
return (s, p)
|
||||||
|
|
||||||
getTicketParticipantsR :: ShrIdent -> PrjIdent -> Int -> Handler TypedContent
|
getTicketParticipantsR :: ShrIdent -> PrjIdent -> Int -> Handler TypedContent
|
||||||
getTicketParticipantsR shr prj num = getFollowersCollection here getFsid
|
getTicketParticipantsR shr prj num = getFollowersCollection here getFsid
|
||||||
where
|
where
|
||||||
|
|
|
@ -971,6 +971,40 @@ changes hLocal ctx =
|
||||||
updateWhere
|
updateWhere
|
||||||
[Ticket20190624Id <-. tids]
|
[Ticket20190624Id <-. tids]
|
||||||
[Ticket20190624Closer =. Nothing]
|
[Ticket20190624Closer =. Nothing]
|
||||||
|
-- 127
|
||||||
|
, addFieldRefRequired''
|
||||||
|
"TicketDependency"
|
||||||
|
(do let user = "$$temp$$"
|
||||||
|
sid <-
|
||||||
|
insert $ Sharer127 (text2shr user) Nothing defaultTime
|
||||||
|
ibid <- insert Inbox127
|
||||||
|
obid <- insert Outbox127
|
||||||
|
insertEntity $
|
||||||
|
Person127
|
||||||
|
sid user "" "e@ma.il" False "" defaultTime ""
|
||||||
|
defaultTime "" ibid obid
|
||||||
|
)
|
||||||
|
(Just $ \ (Entity pidTemp pTemp) -> do
|
||||||
|
tds <- selectList ([] :: [Filter TicketDependency127]) []
|
||||||
|
for_ tds $ \ (Entity tdid td) -> do
|
||||||
|
t <- getJust $ ticketDependency127Parent td
|
||||||
|
j <- getJust $ ticket127Project t
|
||||||
|
mpid <- getKeyBy $ UniquePersonIdent127 $ project127Sharer j
|
||||||
|
let pid = fromMaybe (error "No Person found for Sharer") mpid
|
||||||
|
update tdid [TicketDependency127Author =. pid]
|
||||||
|
|
||||||
|
delete pidTemp
|
||||||
|
delete $ person127Ident pTemp
|
||||||
|
)
|
||||||
|
"author"
|
||||||
|
"Person"
|
||||||
|
-- 128
|
||||||
|
, addFieldPrimRequired
|
||||||
|
"TicketDependency"
|
||||||
|
("(A ticket dependency)" :: Text)
|
||||||
|
"summary"
|
||||||
|
-- 129
|
||||||
|
, addFieldPrimRequired "TicketDependency" defaultTime "created"
|
||||||
]
|
]
|
||||||
|
|
||||||
migrateDB
|
migrateDB
|
||||||
|
|
|
@ -110,6 +110,14 @@ module Vervis.Migration.Model
|
||||||
, Ticket20190624Generic (..)
|
, Ticket20190624Generic (..)
|
||||||
, Ticket20190624
|
, Ticket20190624
|
||||||
, TicketAuthorLocal20190624Generic (..)
|
, TicketAuthorLocal20190624Generic (..)
|
||||||
|
, Sharer127Generic (..)
|
||||||
|
, Person127Generic (..)
|
||||||
|
, Outbox127Generic (..)
|
||||||
|
, Inbox127Generic (..)
|
||||||
|
, Project127Generic (..)
|
||||||
|
, Ticket127Generic (..)
|
||||||
|
, TicketDependency127Generic (..)
|
||||||
|
, TicketDependency127
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
|
|
||||||
|
@ -227,3 +235,6 @@ makeEntitiesMigration "20190616"
|
||||||
|
|
||||||
makeEntitiesMigration "20190624"
|
makeEntitiesMigration "20190624"
|
||||||
$(modelFile "migrations/2019_06_24.model")
|
$(modelFile "migrations/2019_06_24.model")
|
||||||
|
|
||||||
|
makeEntitiesMigration "127"
|
||||||
|
$(modelFile "migrations/2019_07_11.model")
|
||||||
|
|
|
@ -40,6 +40,8 @@ module Web.ActivityPub
|
||||||
|
|
||||||
-- * Content objects
|
-- * Content objects
|
||||||
, Note (..)
|
, Note (..)
|
||||||
|
, RelationshipProperty (..)
|
||||||
|
, Relationship (..)
|
||||||
, TextHtml (..)
|
, TextHtml (..)
|
||||||
, TextPandocMarkdown (..)
|
, TextPandocMarkdown (..)
|
||||||
, TicketLocal (..)
|
, TicketLocal (..)
|
||||||
|
@ -554,6 +556,65 @@ instance ActivityPub Note where
|
||||||
<> "content" .= content
|
<> "content" .= content
|
||||||
<> "mediaType" .= ("text/html" :: Text)
|
<> "mediaType" .= ("text/html" :: Text)
|
||||||
|
|
||||||
|
data RelationshipProperty = RelDependsOn
|
||||||
|
|
||||||
|
instance FromJSON RelationshipProperty where
|
||||||
|
parseJSON = withText "RelationshipProperty" parse
|
||||||
|
where
|
||||||
|
parse t
|
||||||
|
| t == "dependsOn" = pure RelDependsOn
|
||||||
|
| otherwise = fail $ "Unrecognized relationship: " ++ T.unpack t
|
||||||
|
|
||||||
|
instance ToJSON RelationshipProperty where
|
||||||
|
toJSON = error "toJSON RelationshipProperty"
|
||||||
|
toEncoding at =
|
||||||
|
toEncoding $ case at of
|
||||||
|
RelDependsOn -> "dependsOn" :: Text
|
||||||
|
|
||||||
|
data Relationship = Relationship
|
||||||
|
{ relationshipId :: Maybe FedURI
|
||||||
|
, relationshipSubject :: FedURI
|
||||||
|
, relationshipProperty :: Either RelationshipProperty Text
|
||||||
|
, relationshipObject :: FedURI
|
||||||
|
, relationshipAttributedTo :: LocalURI
|
||||||
|
, relationshipPublished :: Maybe UTCTime
|
||||||
|
, relationshipUpdated :: Maybe UTCTime
|
||||||
|
, relationshipSummary :: TextHtml
|
||||||
|
}
|
||||||
|
|
||||||
|
instance ActivityPub Relationship where
|
||||||
|
jsonldContext _ = [as2Context, forgeContext]
|
||||||
|
parseObject o = do
|
||||||
|
typ <- o .: "type"
|
||||||
|
unless (typ == ("Relationship" :: Text)) $
|
||||||
|
fail "type isn't Relationship"
|
||||||
|
|
||||||
|
(h, attributedTo) <- f2l <$> o .: "attributedTo"
|
||||||
|
|
||||||
|
fmap (h,) $
|
||||||
|
Relationship
|
||||||
|
<$> o .:? "id"
|
||||||
|
<*> o .: "subject"
|
||||||
|
<*> o .:+ "relationship"
|
||||||
|
<*> o .: "object"
|
||||||
|
<*> pure attributedTo
|
||||||
|
<*> o .:? "published"
|
||||||
|
<*> o .:? "updated"
|
||||||
|
<*> (TextHtml . sanitizeBalance <$> o .: "summary")
|
||||||
|
|
||||||
|
toSeries host
|
||||||
|
(Relationship id_ subject property object attributedTo published
|
||||||
|
updated summary)
|
||||||
|
= "id" .=? id_
|
||||||
|
<> "type" .= ("Relationship" :: Text)
|
||||||
|
<> "subject" .= subject
|
||||||
|
<> "relationship" .=+ property
|
||||||
|
<> "object" .= object
|
||||||
|
<> "attributedTo" .= l2f host attributedTo
|
||||||
|
<> "published" .=? published
|
||||||
|
<> "updated" .=? updated
|
||||||
|
<> "summary" .= summary
|
||||||
|
|
||||||
newtype TextHtml = TextHtml
|
newtype TextHtml = TextHtml
|
||||||
{ unTextHtml :: Text
|
{ unTextHtml :: Text
|
||||||
}
|
}
|
||||||
|
|
|
@ -19,6 +19,7 @@ module Yesod.ActivityPub
|
||||||
, deliverActivityBL
|
, deliverActivityBL
|
||||||
, deliverActivityBL'
|
, deliverActivityBL'
|
||||||
, forwardActivity
|
, forwardActivity
|
||||||
|
, redirectToPrettyJSON
|
||||||
, provideHtmlAndAP
|
, provideHtmlAndAP
|
||||||
, provideHtmlAndAP'
|
, provideHtmlAndAP'
|
||||||
, provideHtmlAndAP''
|
, provideHtmlAndAP''
|
||||||
|
@ -172,6 +173,10 @@ forwardActivity inbox sig rSender body = do
|
||||||
]
|
]
|
||||||
return result
|
return result
|
||||||
|
|
||||||
|
redirectToPrettyJSON
|
||||||
|
:: (MonadHandler m, HandlerSite m ~ site) => Route site -> m a
|
||||||
|
redirectToPrettyJSON route = redirect (route, [("prettyjson", "true")])
|
||||||
|
|
||||||
provideHtmlAndAP
|
provideHtmlAndAP
|
||||||
:: (YesodActivityPub site, ActivityPub a)
|
:: (YesodActivityPub site, ActivityPub a)
|
||||||
=> a -> WidgetFor site () -> HandlerFor site TypedContent
|
=> a -> WidgetFor site () -> HandlerFor site TypedContent
|
||||||
|
|
Loading…
Reference in a new issue