diff --git a/src/Vervis/Handler/Project.hs b/src/Vervis/Handler/Project.hs index a9d1db4..aa737dd 100644 --- a/src/Vervis/Handler/Project.hs +++ b/src/Vervis/Handler/Project.hs @@ -216,38 +216,75 @@ postProjectNewR = do getProjectStampR :: KeyHashid Project -> KeyHashid SigKey -> Handler TypedContent getProjectStampR = servePerActorKey projectActor LocalActorProject -getProjectCollabsR :: KeyHashid Project -> Handler Html +getProjectCollabsR :: KeyHashid Project -> Handler TypedContent getProjectCollabsR projectHash = do projectID <- decodeKeyHashid404 projectHash - (project, actor, collabs, invites, joins) <- runDB $ do - project <- get404 projectID - actor <- getJust $ projectActor project - collabs <- do - grants <- - getTopicGrants CollabTopicProjectCollab CollabTopicProjectProject projectID - for grants $ \ (role, actor, ct, time) -> - (,role,ct,time) <$> getPersonWidgetInfo actor - invites <- do - invites' <- - getTopicInvites CollabTopicProjectCollab CollabTopicProjectProject projectID - for invites' $ \ (inviter, recip, time, role) -> (,,,) - <$> (getPersonWidgetInfo =<< bitraverse grabPerson pure inviter) - <*> getPersonWidgetInfo recip - <*> pure time - <*> pure role - joins <- do - joins' <- - getTopicJoins CollabTopicProjectCollab CollabTopicProjectProject projectID - for joins' $ \ (recip, time, role) -> - (,time,role) <$> getPersonWidgetInfo recip - return (project, actor, collabs, invites, joins) - defaultLayout $(widgetFile "project/collab/list") + collabs <- runDB $ do + _project <- get404 projectID + grants <- getTopicGrants CollabTopicProjectCollab CollabTopicProjectProject projectID + for grants $ \ (role, actor, _ct, time) -> + (role,time,) <$> bitraverse pure (getRemoteActorURI <=< getJust) actor + h <- asksSite siteInstanceHost + encodeRouteLocal <- getEncodeRouteLocal + encodeRouteHome <- getEncodeRouteHome + hashPerson <- getEncodeKeyHashid + let makeItem (role, time, i) = AP.Relationship + { AP.relationshipId = Nothing + , AP.relationshipExtraTypes = [] + , AP.relationshipSubject = encodeRouteHome $ ProjectR projectHash + , AP.relationshipProperty = Left AP.RelHasCollab + , AP.relationshipObject = + case i of + Left personID -> encodeRouteHome $ PersonR $ hashPerson personID + Right u -> u + , AP.relationshipAttributedTo = encodeRouteLocal $ ProjectR projectHash + , AP.relationshipPublished = Just time + , AP.relationshipUpdated = Nothing + , AP.relationshipInstrument = Just role + } + collabsAP = AP.Collection + { AP.collectionId = encodeRouteLocal $ ProjectCollabsR projectHash + , AP.collectionType = CollectionTypeUnordered + , AP.collectionTotalItems = Just $ length collabs + , AP.collectionCurrent = Nothing + , AP.collectionFirst = Nothing + , AP.collectionLast = Nothing + , AP.collectionItems = map (Doc h . makeItem) collabs + , AP.collectionContext = + Just $ encodeRouteLocal $ ProjectR projectHash + } + provideHtmlAndAP collabsAP $ getHtml projectID where - grabPerson actorID = do - actorByKey <- getLocalActor actorID - case actorByKey of - LocalActorPerson personID -> return personID - _ -> error "Surprise, local inviter actor isn't a Person" + getHtml projectID = do + (project, actor, collabs, invites, joins) <- handlerToWidget $ runDB $ do + project <- get404 projectID + actor <- getJust $ projectActor project + collabs <- do + grants <- + getTopicGrants CollabTopicProjectCollab CollabTopicProjectProject projectID + for grants $ \ (role, actor, ct, time) -> + (,role,ct,time) <$> getPersonWidgetInfo actor + invites <- do + invites' <- + getTopicInvites CollabTopicProjectCollab CollabTopicProjectProject projectID + for invites' $ \ (inviter, recip, time, role) -> (,,,) + <$> (getPersonWidgetInfo =<< bitraverse grabPerson pure inviter) + <*> getPersonWidgetInfo recip + <*> pure time + <*> pure role + joins <- do + joins' <- + getTopicJoins CollabTopicProjectCollab CollabTopicProjectProject projectID + for joins' $ \ (recip, time, role) -> + (,time,role) <$> getPersonWidgetInfo recip + return (project, actor, collabs, invites, joins) + $(widgetFile "project/collab/list") + where + grabPerson actorID = do + actorByKey <- getLocalActor actorID + case actorByKey of + LocalActorPerson personID -> return personID + _ -> error "Surprise, local inviter actor isn't a Person" getProjectInviteR :: KeyHashid Project -> Handler Html getProjectInviteR projectHash = do @@ -352,7 +389,7 @@ getProjectComponentsR projectHash = do encodeRouteHome <- getEncodeRouteHome hashActor <- getHashLocalActor let componentsAP = Collection - { collectionId = encodeRouteLocal here + { collectionId = encodeRouteLocal $ ProjectComponentsR projectHash , collectionType = CollectionTypeUnordered , collectionTotalItems = Just $ length components , collectionCurrent = Nothing @@ -371,12 +408,10 @@ getProjectComponentsR projectHash = do , collectionContext = Just $ encodeRouteLocal $ ProjectR projectHash } - provideHtmlAndAP componentsAP $ redirectToPrettyJSON here + provideHtmlAndAP componentsAP $ getHtml projectID where - here = ProjectComponentsR projectHash - getRepos projectID = fmap (map E.unValue) $ E.select $ E.from $ \ (comp `E.InnerJoin` enable `E.InnerJoin` local `E.InnerJoin` repo) -> do @@ -415,6 +450,68 @@ getProjectComponentsR projectHash = do E.where_ $ comp E.^. ComponentProject E.==. E.val projectID return (i E.^. InstanceHost, ro E.^. RemoteObjectIdent) + getHtml projectID = do + (project, actor, comps, drafts) <- handlerToWidget $ runDB $ do + project <- get404 projectID + actor <- getJust $ projectActor project + cs <- + E.select $ E.from $ \ (comp `E.InnerJoin` enable `E.InnerJoin` grant) -> do + E.on $ enable E.^. ComponentEnableGrant E.==. grant E.^. OutboxItemId + E.on $ comp E.^. ComponentId E.==. enable E.^. ComponentEnableComponent + E.where_ $ comp E.^. ComponentProject E.==. E.val projectID + return (comp, grant) + cs' <- for cs $ \ (Entity cid c, Entity _ i) -> do + byKeyOrRaid <- bimap snd snd <$> getComponentIdent cid + identView <- + bitraverse + (\ byKey -> do + actorID <- + case byKey of + ComponentRepo k -> repoActor <$> getJust k + ComponentDeck k -> deckActor <$> getJust k + ComponentLoom k -> loomActor <$> getJust k + actor <- getJust actorID + return (byKey, actor) + ) + (\ remoteActorID -> do + remoteActor <- getJust remoteActorID + remoteObject <- getJust $ remoteActorIdent remoteActor + inztance <- getJust $ remoteObjectInstance remoteObject + return (inztance, remoteObject, remoteActor) + ) + byKeyOrRaid + return (identView, componentRole c, outboxItemPublished i) + ds <- + E.select $ E.from $ \ (comp `E.LeftOuterJoin` enable) -> do + E.on $ E.just (comp E.^. ComponentId) E.==. enable E.?. ComponentEnableComponent + E.where_ $ + comp E.^. ComponentProject E.==. E.val projectID E.&&. + E.isNothing (enable E.?. ComponentEnableId) + return comp + ds' <- for ds $ \ (Entity cid c) -> do + byKeyOrRaid <- bimap snd snd <$> getComponentIdent cid + identView <- + bitraverse + (\ byKey -> do + actorID <- + case byKey of + ComponentRepo k -> repoActor <$> getJust k + ComponentDeck k -> deckActor <$> getJust k + ComponentLoom k -> loomActor <$> getJust k + actor <- getJust actorID + return (byKey, actor) + ) + (\ remoteActorID -> do + remoteActor <- getJust remoteActorID + remoteObject <- getJust $ remoteActorIdent remoteActor + inztance <- getJust $ remoteObjectInstance remoteObject + return (inztance, remoteObject, remoteActor) + ) + byKeyOrRaid + return (identView, componentRole c) + return (project, actor, cs', ds') + $(widgetFile "project/components") + getProjectCollabLiveR :: KeyHashid Project -> KeyHashid CollabEnable -> Handler () getProjectCollabLiveR projectHash enableHash = do diff --git a/src/Vervis/Widget/Tracker.hs b/src/Vervis/Widget/Tracker.hs index cf6f056..02374a9 100644 --- a/src/Vervis/Widget/Tracker.hs +++ b/src/Vervis/Widget/Tracker.hs @@ -17,13 +17,17 @@ module Vervis.Widget.Tracker ( deckNavW , loomNavW , projectNavW + , componentLinkFedW ) where import Database.Persist.Types +import Yesod.Core.Widget +import Network.FedURI import Yesod.Hashids +import Vervis.Data.Collab import Vervis.Foundation import Vervis.Model import Vervis.Settings @@ -44,3 +48,38 @@ projectNavW :: Entity Project -> Actor -> Widget projectNavW (Entity projectID project) actor = do projectHash <- encodeKeyHashid projectID $(widgetFile "project/widget/nav") + +componentLinkW :: ComponentBy Key -> Actor -> Widget +componentLinkW (ComponentRepo k) actor = do + h <- encodeKeyHashid k + [whamlet| + + ^#{keyHashidText h} #{actorName actor} + |] +componentLinkW (ComponentDeck k) actor = do + h <- encodeKeyHashid k + [whamlet| + + =#{keyHashidText h} #{actorName actor} + |] +componentLinkW (ComponentLoom k) actor = do + h <- encodeKeyHashid k + [whamlet| + + +#{keyHashidText h} #{actorName actor} + |] + +componentLinkFedW + :: Either (ComponentBy Key, Actor) (Instance, RemoteObject, RemoteActor) + -> Widget +componentLinkFedW (Left (c, a)) = componentLinkW c a +componentLinkFedW (Right (inztance, object, actor)) = + [whamlet| + + $maybe name <- remoteActorName actor + #{name} + $nothing + #{renderAuthority $ instanceHost inztance}#{localUriPath $ remoteObjectIdent object} + |] + where + uActor = ObjURI (instanceHost inztance) (remoteObjectIdent object) diff --git a/src/Web/ActivityPub.hs b/src/Web/ActivityPub.hs index 5fadeda..d4dce07 100644 --- a/src/Web/ActivityPub.hs +++ b/src/Web/ActivityPub.hs @@ -54,6 +54,8 @@ module Web.ActivityPub -- * Content objects , Note (..) + , RelationshipProperty (..) + , Relationship (..) , TicketDependency (..) , PatchLocal (..) , Patch (..) @@ -1072,13 +1074,14 @@ instance ActivityPub Note where <> "content" .= content <> "mediaType" .= ("text/html" :: Text) -data RelationshipProperty = RelDependsOn deriving Eq +data RelationshipProperty = RelDependsOn | RelHasCollab deriving Eq instance FromJSON RelationshipProperty where parseJSON = withText "RelationshipProperty" parse where parse t | t == "dependsOn" = pure RelDependsOn + | t == "hasCollaborator" = pure RelHasCollab | otherwise = fail $ "Unrecognized relationship: " ++ T.unpack t instance ToJSON RelationshipProperty where @@ -1086,6 +1089,7 @@ instance ToJSON RelationshipProperty where toEncoding at = toEncoding $ case at of RelDependsOn -> "dependsOn" :: Text + RelHasCollab -> "hasCollaborator" data Relationship u = Relationship { relationshipId :: Maybe (ObjURI u) @@ -1096,6 +1100,7 @@ data Relationship u = Relationship , relationshipAttributedTo :: LocalURI , relationshipPublished :: Maybe UTCTime , relationshipUpdated :: Maybe UTCTime + , relationshipInstrument :: Maybe Role } instance ActivityPub Relationship where @@ -1117,10 +1122,11 @@ instance ActivityPub Relationship where <*> pure attributedTo <*> o .:? "published" <*> o .:? "updated" + <*> o .:? "instrument" toSeries authority (Relationship id_ typs subject property object attributedTo published - updated) + updated role) = "id" .=? id_ <> "type" .= ("Relationship" : typs) <> "subject" .= subject @@ -1129,6 +1135,7 @@ instance ActivityPub Relationship where <> "attributedTo" .= ObjURI authority attributedTo <> "published" .=? published <> "updated" .=? updated + <> "instrument" .=? role data TicketDependency u = TicketDependency { ticketDepId :: Maybe (ObjURI u) @@ -1171,6 +1178,7 @@ instance ActivityPub TicketDependency where , relationshipAttributedTo = ticketDepAttributedTo td , relationshipPublished = ticketDepPublished td , relationshipUpdated = ticketDepUpdated td + , relationshipInstrument = Nothing } data PatchLocal = PatchLocal diff --git a/templates/project/components.hamlet b/templates/project/components.hamlet new file mode 100644 index 0000000..b996301 --- /dev/null +++ b/templates/project/components.hamlet @@ -0,0 +1,42 @@ +$# This file is part of Vervis. +$# +$# Written in 2016, 2019, 2022, 2023 by fr33domlover . +$# +$# ♡ Copying is an act of love. Please copy, reuse and share. +$# +$# The author(s) have dedicated all copyright and related and neighboring +$# rights to this software to the public domain worldwide. This software is +$# distributed without any warranty. +$# +$# You should have received a copy of the CC0 Public Domain Dedication along +$# with this software. If not, see +$# . + +^{projectNavW (Entity projectID project) actor} + +Components + + + + Role + Component + Since + $forall (comp, role, since) <- comps + + #{show role} + ^{componentLinkFedW comp} + #{showDate since} +$# ^{buttonW POST "Remove" (ProjectRemoveR projectHash ctID)} + +Component requests in progress + + + + Role + Component + $forall (comp, role) <- drafts + + #{show role} + ^{componentLinkFedW comp} + +$#Invite…