From 1fd46b059059b17364c3cbb2d13165466b2da676 Mon Sep 17 00:00:00 2001 From: Pere Lev Date: Tue, 27 Jun 2023 21:07:21 +0300 Subject: [PATCH] UI & Vocab: Project components list & link from collabs JSON to project --- src/Vervis/ActivityPub.hs | 1 + src/Vervis/Actor/Project.hs | 5 +- src/Vervis/Data/Collab.hs | 24 ++++---- src/Vervis/Foundation.hs | 2 + src/Vervis/Handler/Cloth.hs | 1 + src/Vervis/Handler/Deck.hs | 2 + src/Vervis/Handler/Loom.hs | 1 + src/Vervis/Handler/Project.hs | 85 ++++++++++++++++++++++++++++- src/Vervis/Handler/Repo.hs | 1 + src/Vervis/Handler/Ticket.hs | 1 + src/Vervis/Ticket.hs | 2 + src/Vervis/Web/Actor.hs | 4 ++ src/Vervis/Web/Darcs.hs | 1 + src/Vervis/Web/Discussion.hs | 1 + src/Vervis/Web/Git.hs | 1 + src/Web/ActivityPub.hs | 32 ++++------- templates/project/widget/nav.hamlet | 3 + th/routes | 2 + 18 files changed, 136 insertions(+), 33 deletions(-) diff --git a/src/Vervis/ActivityPub.hs b/src/Vervis/ActivityPub.hs index 76ef19c..83ff5c6 100644 --- a/src/Vervis/ActivityPub.hs +++ b/src/Vervis/ActivityPub.hs @@ -227,6 +227,7 @@ provideEmptyCollection typ here = do , AP.collectionFirst = Nothing , AP.collectionLast = Nothing , AP.collectionItems = [] :: [Text] + , AP.collectionContext = Nothing } provideHtmlAndAP coll $ redirectToPrettyJSON here diff --git a/src/Vervis/Actor/Project.hs b/src/Vervis/Actor/Project.hs index b7dd182..9c681b5 100644 --- a/src/Vervis/Actor/Project.hs +++ b/src/Vervis/Actor/Project.hs @@ -120,8 +120,9 @@ projectAdd now projectID (Verse authorIdMsig body) add = do -- Check input component <- do let author = bimap (view _1) (remoteAuthorURI . view _1) authorIdMsig - (component, project) <- parseAdd author add - unless (project == Left projectID) $ throwE "Add target isn't me" + (component, projectComps) <- parseAdd author add + unless (projectComps == Left projectID) $ + throwE "Add target isn't my components collection" return component -- If component is local, find it in our DB diff --git a/src/Vervis/Data/Collab.hs b/src/Vervis/Data/Collab.hs index f7d60d6..1e3b788 100644 --- a/src/Vervis/Data/Collab.hs +++ b/src/Vervis/Data/Collab.hs @@ -47,6 +47,7 @@ module Vervis.Data.Collab , grantResourceLocalActor , ComponentBy (..) + , componentActor ) where @@ -281,21 +282,20 @@ parseAdd , Either ProjectId FedURI ) parseAdd sender (AP.Add object target) = do - result@(component, project) <- + result@(component, collection) <- (,) <$> nameExceptT "Add.object" (parseComponent' object) - <*> nameExceptT "Add.target" (parseProject target) + <*> nameExceptT "Add.target" (parseProjectComps target) case result of (Right u, Right v) | u == v -> throwE "Object and target are the same" _ -> pure () when (sender == first componentActor component) $ throwE "Sender and component are the same" - when (sender == first LocalActorProject project) $ - throwE "Sender and project are the same" + case collection of + Left projectID | sender == Left (LocalActorProject projectID) -> + throwE "Sender and project are the same" + _ -> pure () return result where - componentActor (ComponentRepo r) = LocalActorRepo r - componentActor (ComponentDeck d) = LocalActorDeck d - componentActor (ComponentLoom l) = LocalActorLoom l parseComponent' (Right _) = throwE "Not a component URI" parseComponent' (Left u) = do routeOrRemote <- parseFedURI u @@ -316,12 +316,12 @@ parseAdd sender (AP.Add object target) = do parseComponent (DeckR d) = Just $ ComponentDeck d parseComponent (LoomR l) = Just $ ComponentLoom l parseComponent _ = Nothing - parseProject u = do + parseProjectComps u = do routeOrRemote <- parseFedURI u bitraverse (\case - ProjectR j -> WAP.decodeKeyHashidE j "Inavlid hashid" - _ -> throwE "Not a project route" + ProjectComponentsR j -> WAP.decodeKeyHashidE j "Inavlid hashid" + _ -> throwE "Not a project components collection route" ) pure routeOrRemote @@ -434,3 +434,7 @@ unhashComponent c = do return $ unhashComponentPure ctx c unhashComponentE c e = ExceptT $ maybe (Left e) Right <$> unhashComponent c + +componentActor (ComponentRepo r) = LocalActorRepo r +componentActor (ComponentDeck d) = LocalActorDeck d +componentActor (ComponentLoom l) = LocalActorLoom l diff --git a/src/Vervis/Foundation.hs b/src/Vervis/Foundation.hs index b40d5a8..2c12b59 100644 --- a/src/Vervis/Foundation.hs +++ b/src/Vervis/Foundation.hs @@ -1000,3 +1000,5 @@ instance YesodBreadcrumbs App where ProjectInviteR d -> ("Invite", Just $ ProjectR d) ProjectRemoveR _ _ -> ("", Nothing) + + ProjectComponentsR j -> ("Components", Just $ ProjectR j) diff --git a/src/Vervis/Handler/Cloth.hs b/src/Vervis/Handler/Cloth.hs index 7b7a8ca..ff9bd55 100644 --- a/src/Vervis/Handler/Cloth.hs +++ b/src/Vervis/Handler/Cloth.hs @@ -1123,6 +1123,7 @@ getRepoProposalsR shr rp = do , collectionFirst = Just $ pageUrl 1 , collectionLast = Just $ pageUrl pages , collectionItems = [] :: [Text] + , collectionContext = Nothing } Just (patches, navModel) -> let current = nmCurrent navModel diff --git a/src/Vervis/Handler/Deck.hs b/src/Vervis/Handler/Deck.hs index 8f312b8..92d4131 100644 --- a/src/Vervis/Handler/Deck.hs +++ b/src/Vervis/Handler/Deck.hs @@ -285,6 +285,7 @@ getDeckTicketsR deckHash = selectRep $ do , collectionFirst = Just $ pageUrl 1 , collectionLast = Just $ pageUrl pages , collectionItems = [] :: [Text] + , collectionContext = Nothing } Just (tickets, navModel) -> let current = nmCurrent navModel @@ -707,6 +708,7 @@ getProjectTeamR shr prj = do , collectionFirst = Nothing , collectionLast = Nothing , collectionItems = map (encodeRouteHome . SharerR) memberShrs + , collectionContext = Nothing } provideHtmlAndAP team $ redirect (here, [("prettyjson", "true")]) -} diff --git a/src/Vervis/Handler/Loom.hs b/src/Vervis/Handler/Loom.hs index d229572..16fca92 100644 --- a/src/Vervis/Handler/Loom.hs +++ b/src/Vervis/Handler/Loom.hs @@ -236,6 +236,7 @@ getLoomClothsR loomHash = selectRep $ do , AP.collectionFirst = Just $ pageUrl 1 , AP.collectionLast = Just $ pageUrl pages , AP.collectionItems = [] :: [Text] + , AP.collectionContext = Nothing } Just (tickets, navModel) -> let current = nmCurrent navModel diff --git a/src/Vervis/Handler/Project.hs b/src/Vervis/Handler/Project.hs index cd965ac..657f1c9 100644 --- a/src/Vervis/Handler/Project.hs +++ b/src/Vervis/Handler/Project.hs @@ -32,6 +32,8 @@ module Vervis.Handler.Project , getProjectInviteR , postProjectInviteR , postProjectRemoveR + + , getProjectComponentsR ) where @@ -40,6 +42,7 @@ import Control.Monad import Control.Monad.Trans.Except import Control.Monad.Trans.Maybe import Data.Aeson +import Data.Bifunctor import Data.Bitraversable import Data.ByteString (ByteString) import Data.Default.Class @@ -81,6 +84,7 @@ import Yesod.Persist.Local import Vervis.Access import Vervis.API +import Vervis.Data.Collab import Vervis.Federation.Auth import Vervis.Federation.Collab import Vervis.Federation.Discussion @@ -147,7 +151,10 @@ getProjectR projectHash = do , AP.projectTracker = Nothing , AP.projectChildren = [] , AP.projectParents = [] - , AP.projectComponents = [] + , AP.projectComponents = + encodeRouteLocal $ ProjectComponentsR projectHash + , AP.projectCollaborators = + encodeRouteLocal $ ProjectCollabsR projectHash } provideHtmlAndAP projectAP $(widgetFile "project/one") where @@ -330,3 +337,79 @@ postProjectRemoveR projectHash ctID = do Right removeID -> setMessage "Remove sent" redirect $ ProjectCollabsR projectHash + +getProjectComponentsR :: KeyHashid Project -> Handler TypedContent +getProjectComponentsR projectHash = do + projectID <- decodeKeyHashid404 projectHash + components <- runDB $ concat <$> sequence + [ map (Left . ComponentRepo) <$> getRepos projectID + , map (Left . ComponentDeck) <$> getDecks projectID + , map (Left . ComponentLoom) <$> getLooms projectID + , map Right <$> getRemotes projectID + ] + encodeRouteLocal <- getEncodeRouteLocal + encodeRouteHome <- getEncodeRouteHome + hashActor <- getHashLocalActor + let componentsAP = Collection + { collectionId = encodeRouteLocal here + , collectionType = CollectionTypeUnordered + , collectionTotalItems = Just $ length components + , collectionCurrent = Nothing + , collectionFirst = Nothing + , collectionLast = Nothing + , collectionItems = + map (bimap + ( encodeRouteHome + . renderLocalActor + . hashActor + . componentActor + ) + id + ) + components + , collectionContext = + Just $ encodeRouteLocal $ ProjectR projectHash + } + provideHtmlAndAP componentsAP $ redirectToPrettyJSON here + + 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 + E.on $ local E.^. ComponentLocalId E.==. repo E.^. ComponentLocalRepoComponent + E.on $ comp E.^. ComponentId E.==. local E.^. ComponentLocalComponent + E.on $ comp E.^. ComponentId E.==. enable E.^. ComponentEnableComponent + E.where_ $ comp E.^. ComponentProject E.==. E.val projectID + return $ repo E.^. ComponentLocalRepoRepo + + getDecks projectID = + fmap (map E.unValue) $ + E.select $ E.from $ \ (comp `E.InnerJoin` enable `E.InnerJoin` local `E.InnerJoin` deck) -> do + E.on $ local E.^. ComponentLocalId E.==. deck E.^. ComponentLocalDeckComponent + E.on $ comp E.^. ComponentId E.==. local E.^. ComponentLocalComponent + E.on $ comp E.^. ComponentId E.==. enable E.^. ComponentEnableComponent + E.where_ $ comp E.^. ComponentProject E.==. E.val projectID + return $ deck E.^. ComponentLocalDeckDeck + + getLooms projectID = + fmap (map E.unValue) $ + E.select $ E.from $ \ (comp `E.InnerJoin` enable `E.InnerJoin` local `E.InnerJoin` loom) -> do + E.on $ local E.^. ComponentLocalId E.==. loom E.^. ComponentLocalLoomComponent + E.on $ comp E.^. ComponentId E.==. local E.^. ComponentLocalComponent + E.on $ comp E.^. ComponentId E.==. enable E.^. ComponentEnableComponent + E.where_ $ comp E.^. ComponentProject E.==. E.val projectID + return $ loom E.^. ComponentLocalLoomLoom + + getRemotes projectID = + fmap (map $ uncurry ObjURI . bimap E.unValue E.unValue) $ + E.select $ E.from $ \ (comp `E.InnerJoin` enable `E.InnerJoin` remote `E.InnerJoin` ra `E.InnerJoin` ro `E.InnerJoin` i) -> do + E.on $ ro E.^. RemoteObjectInstance E.==. i E.^. InstanceId + E.on $ ra E.^. RemoteActorIdent E.==. ro E.^. RemoteObjectId + E.on $ remote E.^. ComponentRemoteActor E.==. ra E.^. RemoteActorId + E.on $ comp E.^. ComponentId E.==. remote E.^. ComponentRemoteComponent + E.on $ comp E.^. ComponentId E.==. enable E.^. ComponentEnableComponent + E.where_ $ comp E.^. ComponentProject E.==. E.val projectID + return (i E.^. InstanceHost, ro E.^. RemoteObjectIdent) diff --git a/src/Vervis/Handler/Repo.hs b/src/Vervis/Handler/Repo.hs index ec0ac26..110e9bd 100644 --- a/src/Vervis/Handler/Repo.hs +++ b/src/Vervis/Handler/Repo.hs @@ -981,6 +981,7 @@ getRepoTeamR shr rp = do , collectionFirst = Nothing , collectionLast = Nothing , collectionItems = map (encodeRouteHome . SharerR) memberShrs + , collectionContext = Nothing } provideHtmlAndAP team $ redirectToPrettyJSON here diff --git a/src/Vervis/Handler/Ticket.hs b/src/Vervis/Handler/Ticket.hs index ff4405c..add1e07 100644 --- a/src/Vervis/Handler/Ticket.hs +++ b/src/Vervis/Handler/Ticket.hs @@ -936,6 +936,7 @@ getProjectTicketTeamR shr prj ltkhid = do , collectionFirst = Nothing , collectionLast = Nothing , collectionItems = map (encodeRouteHome . SharerR) memberShrs + , collectionContext = Nothing } provideHtmlAndAP team $ redirectToPrettyJSON here diff --git a/src/Vervis/Ticket.hs b/src/Vervis/Ticket.hs index b9228ea..1c4d039 100644 --- a/src/Vervis/Ticket.hs +++ b/src/Vervis/Ticket.hs @@ -648,6 +648,7 @@ getDependencyCollection here depRoute getLocalTicketId404 = do , collectionLast = Nothing , collectionItems = map (encodeRouteHome . depRoute . encodeHid) tdids + , collectionContext = Nothing } provideHtmlAndAP deps $ redirectToPrettyJSON here @@ -670,6 +671,7 @@ getReverseDependencyCollection here getLocalTicketId404 = do , collectionItems = map (encodeRouteHome . TicketDepR . encodeHid) locals ++ map (\ (E.Value h, E.Value lu) -> ObjURI h lu) remotes + , collectionContext = Nothing } provideHtmlAndAP deps $ redirectToPrettyJSON here where diff --git a/src/Vervis/Web/Actor.hs b/src/Vervis/Web/Actor.hs index 199891f..8c92be0 100644 --- a/src/Vervis/Web/Actor.hs +++ b/src/Vervis/Web/Actor.hs @@ -158,6 +158,7 @@ getInbox here actor hash = do , collectionFirst = Just $ pageUrl 1 , collectionLast = Just $ pageUrl pages , collectionItems = [] :: [Text] + , collectionContext = Nothing } provideRep (redirectFirstPage here' :: Handler Html) Just (items, navModel) -> do @@ -321,6 +322,7 @@ getOutbox here itemRoute grabActorID hash = do , collectionFirst = Just $ pageUrl 1 , collectionLast = Just $ pageUrl pages , collectionItems = [] :: [Text] + , collectionContext = Nothing } provideRep (redirectFirstPage here' :: Handler Html) Just (items, navModel) -> do @@ -424,6 +426,7 @@ getFollowersCollection here getFsid = do , collectionItems = map (encodeRouteHome . renderLocalActor . hashActor) locals ++ map (uncurry ObjURI . bimap E.unValue E.unValue) remotes + , collectionContext = Nothing } provideHtmlAndAP followersAP $ redirectToPrettyJSON here @@ -468,6 +471,7 @@ getFollowingCollection here actor hash = do , collectionFirst = Nothing , collectionLast = Nothing , collectionItems = map encodeRouteHome locals ++ remotes + , collectionContext = Nothing } provideHtmlAndAP followingAP $ redirectToPrettyJSON here' where diff --git a/src/Vervis/Web/Darcs.hs b/src/Vervis/Web/Darcs.hs index c5933cb..9451847 100644 --- a/src/Vervis/Web/Darcs.hs +++ b/src/Vervis/Web/Darcs.hs @@ -133,6 +133,7 @@ getDarcsRepoChanges repo = do , AP.collectionFirst = Just $ pageUrl 1 , AP.collectionLast = Just $ pageUrl pages , AP.collectionItems = [] :: [Text] + , AP.collectionContext = Nothing } provideHtmlAndAP collection $ redirectFirstPage here Just (_total, pages, items, navModel) -> diff --git a/src/Vervis/Web/Discussion.hs b/src/Vervis/Web/Discussion.hs index c87c045..105c936 100644 --- a/src/Vervis/Web/Discussion.hs +++ b/src/Vervis/Web/Discussion.hs @@ -100,6 +100,7 @@ getRepliesCollection here getDiscussionId404 = do , AP.collectionLast = Nothing , AP.collectionItems = map localUri locals ++ map remoteUri remotes + , AP.collectionContext = Nothing } where selectLocals did = do diff --git a/src/Vervis/Web/Git.hs b/src/Vervis/Web/Git.hs index cba5f8d..5687e6d 100644 --- a/src/Vervis/Web/Git.hs +++ b/src/Vervis/Web/Git.hs @@ -165,6 +165,7 @@ getGitRepoChanges repo ref = do , AP.collectionFirst = Just $ pageUrl 1 , AP.collectionLast = Just $ pageUrl pages , AP.collectionItems = [] :: [Text] + , AP.collectionContext = Nothing } provideHtmlAndAP collection $ redirectFirstPage here Just (_total, pages, items, navModel) -> diff --git a/src/Web/ActivityPub.hs b/src/Web/ActivityPub.hs index 1401046..5ba77fc 100644 --- a/src/Web/ActivityPub.hs +++ b/src/Web/ActivityPub.hs @@ -702,6 +702,7 @@ data Collection a u = Collection , collectionFirst :: Maybe LocalPageURI , collectionLast :: Maybe LocalPageURI , collectionItems :: [a] + , collectionContext :: Maybe LocalURI } instance (FromJSON a, ToJSON a) => ActivityPub (Collection a) where @@ -716,7 +717,8 @@ instance (FromJSON a, ToJSON a) => ActivityPub (Collection a) where <*> withAuthorityMaybeP authority (o .:? "first") <*> withAuthorityMaybeP authority (o .:? "last") <*> optional (o .: "items" <|> o .: "orderedItems") .!= [] - toSeries authority (Collection id_ typ total curr firzt last items) + <*> withAuthorityMaybeO authority (o .:? "context") + toSeries authority (Collection id_ typ total curr firzt last items ctx) = "id" .= ObjURI authority id_ <> "type" .= typ <> "totalItems" .=? total @@ -724,6 +726,7 @@ instance (FromJSON a, ToJSON a) => ActivityPub (Collection a) where <> "first" .=? (PageURI authority <$> firzt) <> "last" .=? (PageURI authority <$> last) <> itemsProp .=% items + <> "context" .=? (ObjURI authority <$> ctx) where itemsProp = case typ of @@ -824,7 +827,8 @@ data Project u = Project , projectTracker :: Maybe (ObjURI u) , projectChildren :: [ObjURI u] , projectParents :: [ObjURI u] - , projectComponents :: [ObjURI u] + , projectComponents :: LocalURI + , projectCollaborators :: LocalURI } instance ActivityPub Project where @@ -848,18 +852,9 @@ instance ActivityPub Project where return items ) <*> o .:? "context" .!= [] - <*> (do c <- o .: "components" - typ <- c .: "type" - unless (typ == ("Collection" :: Text)) $ - fail "components.type isn't Collection" - items <- c .: "items" - mtotal <- c .:? "totalItems" - for_ mtotal $ \ total -> - unless (length items == total) $ - fail "Incorrect totalItems" - return items - ) - toSeries h (Project actor tracker children parents components) + <*> withAuthorityO h (o .: "components") + <*> withAuthorityO h (o .: "collaborators") + toSeries h (Project actor tracker children parents components collabs) = toSeries h actor <> "ticketsTrackedBy" .=? tracker <> "subprojects" `pair` pairs @@ -867,12 +862,9 @@ instance ActivityPub Project where <> "items" .= children <> "totalItems" .= length children ) - <> "context" .= parents - <> "components" `pair` pairs - ( "type" .= ("Collection" :: Text) - <> "items" .= components - <> "totalItems" .= length components - ) + <> "context" .= parents + <> "components" .= ObjURI h components + <> "collaborators" .= ObjURI h collabs data Audience u = Audience { audienceTo :: [ObjURI u] diff --git a/templates/project/widget/nav.hamlet b/templates/project/widget/nav.hamlet index 1bee34f..bd8ec5f 100644 --- a/templates/project/widget/nav.hamlet +++ b/templates/project/widget/nav.hamlet @@ -30,6 +30,9 @@ $# . [🤝 Collaborators] + + + [🧩 Components] [No wiki] diff --git a/th/routes b/th/routes index 4d1da99..4c45713 100644 --- a/th/routes +++ b/th/routes @@ -322,3 +322,5 @@ /projects/#ProjectKeyHashid/collabs ProjectCollabsR GET /projects/#ProjectKeyHashid/invite ProjectInviteR GET POST /projects/#ProjectKeyHashid/remove/#CollabTopicProjectId ProjectRemoveR POST + +/projects/#ProjectKeyHashid/components ProjectComponentsR GET