forge/Vervis
1
0
Fork 0
Code Pull requests 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
Show stats Download patch file Download diff file Expand all files Collapse all files

3
config/models
View file

@ -330,6 +330,9 @@ TicketAuthorRemote
TicketDependency
parent TicketId
child TicketId
author PersonId
summary Text -- HTML
created UTCTime
UniqueTicketDependency parent child

1
config/routes
View file

@ -147,6 +147,7 @@
/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/rdeps TicketReverseDepsR GET
/tdeps/#TicketDepKeyHashid TicketDepR 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/events TicketEventsR GET

71
migrations/2019_07_11.model Normal file
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

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:

51
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
, 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