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