diff --git a/config/models b/config/models index 654a14a..8dbac42 100644 --- a/config/models +++ b/config/models @@ -328,8 +328,11 @@ TicketAuthorRemote UniqueTicketAuthorRemoteOffer offer TicketDependency - parent TicketId - child TicketId + parent TicketId + child TicketId + author PersonId + summary Text -- HTML + created UTCTime UniqueTicketDependency parent child diff --git a/config/routes b/config/routes index 6cddd51..9aef6e7 100644 --- a/config/routes +++ b/config/routes @@ -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 diff --git a/migrations/2019_07_11.model b/migrations/2019_07_11.model new file mode 100644 index 0000000..8dad690 --- /dev/null +++ b/migrations/2019_07_11.model @@ -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 diff --git a/src/Data/Aeson/Local.hs b/src/Data/Aeson/Local.hs index 6d3c85e..123d646 100644 --- a/src/Data/Aeson/Local.hs +++ b/src/Data/Aeson/Local.hs @@ -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 diff --git a/src/Vervis/API.hs b/src/Vervis/API.hs index f34021a..80ec23a 100644 --- a/src/Vervis/API.hs +++ b/src/Vervis/API.hs @@ -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 diff --git a/src/Vervis/ActivityPub.hs b/src/Vervis/ActivityPub.hs index a923bec..f80ab58 100644 --- a/src/Vervis/ActivityPub.hs +++ b/src/Vervis/ActivityPub.hs @@ -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) diff --git a/src/Vervis/Federation/Ticket.hs b/src/Vervis/Federation/Ticket.hs index 2b147b8..31e7ada 100644 --- a/src/Vervis/Federation/Ticket.hs +++ b/src/Vervis/Federation/Ticket.hs @@ -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) diff --git a/src/Vervis/Foundation.hs b/src/Vervis/Foundation.hs index 4b73c31..f65d26e 100644 --- a/src/Vervis/Foundation.hs +++ b/src/Vervis/Foundation.hs @@ -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: diff --git a/src/Vervis/Handler/Ticket.hs b/src/Vervis/Handler/Ticket.hs index f1d0b50..bf65476 100644 --- a/src/Vervis/Handler/Ticket.hs +++ b/src/Vervis/Handler/Ticket.hs @@ -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 diff --git a/src/Vervis/Migration.hs b/src/Vervis/Migration.hs index 2b6a958..fbd59f4 100644 --- a/src/Vervis/Migration.hs +++ b/src/Vervis/Migration.hs @@ -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 diff --git a/src/Vervis/Migration/Model.hs b/src/Vervis/Migration/Model.hs index 0e6c3e7..3762e71 100644 --- a/src/Vervis/Migration/Model.hs +++ b/src/Vervis/Migration/Model.hs @@ -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") diff --git a/src/Web/ActivityPub.hs b/src/Web/ActivityPub.hs index c8d5910..2d65662 100644 --- a/src/Web/ActivityPub.hs +++ b/src/Web/ActivityPub.hs @@ -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 } diff --git a/src/Yesod/ActivityPub.hs b/src/Yesod/ActivityPub.hs index 224b6eb..13d2262 100644 --- a/src/Yesod/ActivityPub.hs +++ b/src/Yesod/ActivityPub.hs @@ -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