1
0
Fork 0
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:
fr33domlover 2019-07-11 15:14:16 +00:00
parent 828e015c54
commit 81a05a950f
13 changed files with 289 additions and 29 deletions

View file

@ -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

View file

@ -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

View 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

View file

@ -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

View file

@ -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

View file

@ -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)

View file

@ -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)

View file

@ -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:

View file

@ -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

View file

@ -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

View file

@ -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")

View file

@ -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
} }

View file

@ -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