UI & Vocab: Project components list & link from collabs JSON to project

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
 

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

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) $
+    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

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)

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

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")])
 -}

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

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)

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
 

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
 

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

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

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) ->

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

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) ->

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
@@ -868,11 +863,8 @@ instance ActivityPub Project where
             <> "totalItems" .= length children
             )
         <> "context"        .= parents
-        <> "components" `pair` pairs
-            (  "type"       .= ("Collection" :: Text)
-            <> "items"      .= components
-            <> "totalItems" .= length components
-            )
+        <> "components"     .= ObjURI h components
+        <> "collaborators"  .= ObjURI h collabs
 
 data Audience u = Audience
     { audienceTo        :: [ObjURI u]

templates/project/widget/nav.hamlet

@@ -30,6 +30,9 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
   <span>
     <a href=@{ProjectCollabsR projectHash}>
       [🤝 Collaborators]
+  <span>
+    <a href=@{ProjectComponentsR projectHash}>
+      [🧩 Components]
   <span>
     [No wiki]
   <span>

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