sup39/vervis
1
0
Fork 0
mirror of https://code.sup39.dev/repos/Wqawg synced 2025-03-20 04:46:22 +09:00
Code Issues Activity

Implement getTicketDepR, not used anywhere else yet

Browse source 
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

10
src/Data/Aeson/Local.hs
View file

@ -19,8 +19,10 @@ module Data.Aeson.Local
, fromEither
, (.:|)
, (.:|?)
, (.:+)
, (.=?)
, (.=%)
, (.=+)
, WithValue (..)
)
where
@ -59,6 +61,9 @@ o .:| t = o .: t <|> o .: (frg <> t)
(.:|?) :: FromJSON a => Object -> Text -> Parser (Maybe a)
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 .=?
(.=?) :: ToJSON v => Text -> Maybe v -> Series
_ .=? Nothing = mempty
@ -71,6 +76,11 @@ k .=% v =
then mempty
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
{ wvRaw :: Object
, wvParsed :: a

20
src/Vervis/API.hs
View file

@ -451,7 +451,8 @@ offerTicketC
-> Handler (Either Text OutboxItemId)
offerTicketC shrUser summary audience offer@(Offer ticket uTarget) = runExceptT $ do
(hProject, shrProject, prjProject) <- parseTarget uTarget
deps <- checkOffer hProject shrProject prjProject
{-deps <- -}
checkOffer hProject shrProject prjProject
(localRecips, remoteRecips) <- do
mrecips <- parseAudience audience
fromMaybeE mrecips "Offer with no recipients"
@ -469,7 +470,7 @@ offerTicketC shrUser summary audience offer@(Offer ticket uTarget) = runExceptT
mprojAndDeps <- do
targetIsLocal <- hostIsLocal hProject
if targetIsLocal
then Just <$> getProjectAndDeps shrProject prjProject deps
then Just <$> getProjectAndDeps shrProject prjProject {-deps-}
else return Nothing
(obiid, doc, luOffer) <- lift $ insertToOutbox now obidAuthor
moreRemotes <-
@ -488,10 +489,11 @@ offerTicketC shrUser summary audience offer@(Offer ticket uTarget) = runExceptT
verifyNothingE (AP.ticketName ticket) "Ticket with 'name'"
verifyNothingE (AP.ticketAssignedTo ticket) "Ticket with 'assignedTo'"
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"
traverse checkDep' $ AP.ticketDependsOn ticket
where
checkDep' = checkDep hProject shrProject prjProject
--traverse checkDep' $ AP.ticketDependsOn ticket
--where
--checkDep' = checkDep hProject shrProject prjProject
checkRecips hProject shrProject prjProject localRecips = do
local <- hostIsLocal hProject
if local
@ -570,7 +572,7 @@ offerTicketC shrUser summary audience offer@(Offer ticket uTarget) = runExceptT
forCollect = flip traverseCollect
deliverLocalProject shr prj (LocalProjectRelatedSet project _) =
case mprojAndDeps of
Just (sid, jid, ibid, fsid, tids)
Just (sid, jid, ibid, fsid{-, tids-})
| shr == shrProject &&
prj == prjProject &&
localRecipProject project -> do
@ -579,7 +581,7 @@ offerTicketC shrUser summary audience offer@(Offer ticket uTarget) = runExceptT
((subtract 1) . projectNextTicket) <$>
updateGet jid [ProjectNextTicket +=. 1]
(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
(pidsTeam, remotesTeam) <-
if localRecipProjectTeam project
@ -653,7 +655,7 @@ offerTicketC shrUser summary audience offer@(Offer ticket uTarget) = runExceptT
obiid
[OutboxItemActivity =. persistJSONObjectFromDoc doc]
return (obiid, doc)
insertTicket jid tidsDeps next obiidAccept = do
insertTicket jid {-tidsDeps-} next obiidAccept = do
did <- insert Discussion
fsid <- insert FollowerSet
tid <- insert Ticket
@ -677,7 +679,7 @@ offerTicketC shrUser summary audience offer@(Offer ticket uTarget) = runExceptT
, ticketAuthorLocalAuthor = pidAuthor
, ticketAuthorLocalOffer = obiid
}
insertMany_ $ map (TicketDependency tid) tidsDeps
--insertMany_ $ map (TicketDependency tid) tidsDeps
insert_ $ Follow pidAuthor fsid False
publishAccept pidAuthor sid jid fsid luOffer num obiid doc = do
now <- liftIO getCurrentTime

10
src/Vervis/ActivityPub.hs
View file

@ -35,7 +35,7 @@ module Vervis.ActivityPub
, deliverRemoteHTTP
, checkForward
, parseTarget
, checkDep
--, checkDep
, getProjectAndDeps
, deliverRemoteDB'
, deliverRemoteHttp
@ -398,6 +398,7 @@ parseTarget u = do
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) $
@ -416,16 +417,19 @@ checkDep hProject shrProject prjProject u = do
case route of
TicketR shr prj num -> return (shr, prj, num)
_ -> throwE "Expected ticket route, got non-ticket route"
-}
getProjectAndDeps shr prj deps = do
getProjectAndDeps shr prj {-deps-} = do
msid <- lift $ getKeyBy $ UniqueSharer shr
sid <- fromMaybeE msid "Offer target: no such local sharer"
mej <- lift $ getBy $ UniqueProject prj 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, tids)
-}
return (sid, jid, projectInbox j, projectFollowers j{-, tids-})
data Recip
= RecipRA (Entity RemoteActor)

32
src/Vervis/Federation/Ticket.hs
View file

@ -72,7 +72,7 @@ import Vervis.Model.Ident
import Vervis.Model.Ticket
checkOffer
:: AP.Ticket -> Text -> ShrIdent -> PrjIdent -> ExceptT Text Handler [Int]
:: AP.Ticket -> Text -> ShrIdent -> PrjIdent -> ExceptT Text Handler ()
checkOffer ticket hProject shrProject prjProject = do
verifyNothingE (AP.ticketLocal ticket) "Ticket with 'id'"
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.ticketAssignedTo ticket) "Ticket with 'assignedTo'"
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"
traverse checkDep' $ AP.ticketDependsOn ticket
where
checkDep' = checkDep hProject shrProject prjProject
--traverse checkDep' $ AP.ticketDependsOn ticket
--where
--checkDep' = checkDep hProject shrProject prjProject
sharerOfferTicketF
:: UTCTime
@ -95,25 +96,29 @@ sharerOfferTicketF
sharerOfferTicketF now shrRecip author body (Offer ticket uTarget) = do
(hProject, shrProject, prjProject) <- parseTarget uTarget
luOffer <- fromMaybeE (activityId $ actbActivity body) "Offer without 'id'"
deps <- checkOffer ticket hProject shrProject prjProject
{-deps <- -}
checkOffer ticket hProject shrProject prjProject
local <- hostIsLocal hProject
runDBExcept $ do
ibidRecip <- lift $ do
sid <- getKeyBy404 $ UniqueSharer shrRecip
p <- getValBy404 $ UniquePersonIdent sid
return $ personInbox p
when local $ checkTargetAndDeps shrProject prjProject deps
when local $ checkTargetAndDeps shrProject prjProject {-deps-}
lift $ insertToInbox luOffer ibidRecip
where
checkTargetAndDeps shrProject prjProject deps = do
checkTargetAndDeps shrProject prjProject {-deps-} = do
msid <- lift $ getKeyBy $ UniqueSharer shrProject
sid <- fromMaybeE msid "Offer target: no such local sharer"
mjid <- lift $ getKeyBy $ UniqueProject prjProject sid
jid <- fromMaybeE mjid "Offer target: no such local project"
return ()
{-
for_ deps $ \ dep -> do
mt <- lift $ getBy $ UniqueTicket jid dep
unless (isJust mt) $
throwE "Local dep: No such ticket number in DB"
-}
insertToInbox luOffer ibidRecip = do
let iidAuthor = remoteAuthorInstance author
jsonObj = persistJSONFromBL $ actbBL body
@ -219,16 +224,17 @@ projectOfferTicketF
(activityId $ actbActivity body)
"Offer without 'id'"
hLocal <- getsYesod siteInstanceHost
deps <- checkOffer ticket hLocal shrRecip prjRecip
{-deps <- -}
checkOffer ticket hLocal shrRecip prjRecip
msig <- checkForward shrRecip prjRecip
let colls =
findRelevantCollections hLocal $
activityAudience $ actbActivity body
mremotesHttp <- runDBExcept $ do
(sid, jid, ibid, fsid, tids) <-
getProjectAndDeps shrRecip prjRecip deps
(sid, jid, ibid, fsid{-, tids-}) <-
getProjectAndDeps shrRecip prjRecip {-deps-}
lift $ do
mticket <- insertTicket luOffer jid ibid tids
mticket <- insertTicket luOffer jid ibid {-tids-}
for mticket $ \ (ractid, num, obiidAccept, docAccept) -> do
msr <- for msig $ \ sig -> do
remoteRecips <- deliverLocal ractid colls sid fsid
@ -276,7 +282,7 @@ projectOfferTicketF
| shr == shrRecip && prj == prjRecip
-> Just OfferTicketRecipProjectFollowers
_ -> Nothing
insertTicket luOffer jid ibid deps = do
insertTicket luOffer jid ibid {-deps-} = do
let iidAuthor = remoteAuthorInstance author
raidAuthor = remoteAuthorId author
ractid <- either entityKey id <$> insertBy' RemoteActivity
@ -319,7 +325,7 @@ projectOfferTicketF
, ticketAuthorRemoteAuthor = raidAuthor
, ticketAuthorRemoteOffer = ractid
}
insertMany_ $ map (TicketDependency tid) deps
-- insertMany_ $ map (TicketDependency tid) deps
insert_ $ RemoteFollow raidAuthor fsid False
return $ Just (ractid, next, obiidAccept, docAccept)

1
src/Vervis/Foundation.hs
View file

@ -133,6 +133,7 @@ data App = App
type OutboxItemKeyHashid = KeyHashid OutboxItem
type MessageKeyHashid = KeyHashid Message
type LocalMessageKeyHashid = KeyHashid LocalMessage
type TicketDepKeyHashid = KeyHashid TicketDependency
-- This is where we define all of the routes in our application. For a full
-- explanation of the syntax, please see:

55
src/Vervis/Handler/Ticket.hs
View file

@ -48,6 +48,7 @@ module Vervis.Handler.Ticket
, postTicketDepOldR
, deleteTicketDepOldR
, getTicketReverseDepsR
, getTicketDepR
, getTicketParticipantsR
, getTicketTeamR
, getTicketEventsR
@ -889,10 +890,15 @@ postTicketDepsR shr prj num = do
((result, widget), enctype) <- runFormPost $ ticketDepForm jid tid
case result of
FormSuccess ctid -> do
pidAuthor <- requireVerifiedAuthId
now <- liftIO getCurrentTime
runDB $ do
let td = TicketDependency
{ ticketDependencyParent = tid
, ticketDependencyChild = ctid
{ ticketDependencyParent = tid
, ticketDependencyChild = ctid
, ticketDependencyAuthor = pidAuthor
, ticketDependencySummary = "(A ticket dependency)"
, ticketDependencyCreated = now
}
insert_ td
trrFix td ticketDepGraph
@ -937,6 +943,51 @@ deleteTicketDepOldR shr prj pnum cnum = do
getTicketReverseDepsR :: ShrIdent -> PrjIdent -> Int -> Handler Html
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 shr prj num = getFollowersCollection here getFsid
where

34
src/Vervis/Migration.hs
View file

@ -971,6 +971,40 @@ changes hLocal ctx =
updateWhere
[Ticket20190624Id <-. tids]
[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

11
src/Vervis/Migration/Model.hs
View file

@ -110,6 +110,14 @@ module Vervis.Migration.Model
, Ticket20190624Generic (..)
, Ticket20190624
, TicketAuthorLocal20190624Generic (..)
, Sharer127Generic (..)
, Person127Generic (..)
, Outbox127Generic (..)
, Inbox127Generic (..)
, Project127Generic (..)
, Ticket127Generic (..)
, TicketDependency127Generic (..)
, TicketDependency127
)
where
@ -227,3 +235,6 @@ makeEntitiesMigration "20190616"
makeEntitiesMigration "20190624"
$(modelFile "migrations/2019_06_24.model")
makeEntitiesMigration "127"
$(modelFile "migrations/2019_07_11.model")

61
src/Web/ActivityPub.hs
View file

@ -40,6 +40,8 @@ module Web.ActivityPub
-- * Content objects
, Note (..)
, RelationshipProperty (..)
, Relationship (..)
, TextHtml (..)
, TextPandocMarkdown (..)
, TicketLocal (..)
@ -554,6 +556,65 @@ instance ActivityPub Note where
<> "content" .= content
<> "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
{ unTextHtml :: Text
}

5
src/Yesod/ActivityPub.hs
View file

@ -19,6 +19,7 @@ module Yesod.ActivityPub
, deliverActivityBL
, deliverActivityBL'
, forwardActivity
, redirectToPrettyJSON
, provideHtmlAndAP
, provideHtmlAndAP'
, provideHtmlAndAP''
@ -172,6 +173,10 @@ forwardActivity inbox sig rSender body = do
]
return result
redirectToPrettyJSON
:: (MonadHandler m, HandlerSite m ~ site) => Route site -> m a
redirectToPrettyJSON route = redirect (route, [("prettyjson", "true")])
provideHtmlAndAP
:: (YesodActivityPub site, ActivityPub a)
=> a -> WidgetFor site () -> HandlerFor site TypedContent