UI: Project: Component list HTML version

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
+    collabs <- runDB $ do
-        project <- get404 projectID
+        _project <- get404 projectID
-        actor <- getJust $ projectActor project
+        grants <- getTopicGrants CollabTopicProjectCollab CollabTopicProjectProject projectID
-        collabs <- do
+        for grants $ \ (role, actor, _ct, time) ->
-            grants <-
+            (role,time,) <$> bitraverse pure (getRemoteActorURI <=< getJust) actor
-                getTopicGrants CollabTopicProjectCollab CollabTopicProjectProject projectID
+    h <- asksSite siteInstanceHost
-            for grants $ \ (role, actor, ct, time) ->
+    encodeRouteLocal <- getEncodeRouteLocal
-                (,role,ct,time) <$> getPersonWidgetInfo actor
+    encodeRouteHome <- getEncodeRouteHome
-        invites <- do
+    hashPerson <- getEncodeKeyHashid
-            invites' <-
+    let makeItem (role, time, i) = AP.Relationship
-                getTopicInvites CollabTopicProjectCollab CollabTopicProjectProject projectID
+            { AP.relationshipId           = Nothing
-            for invites' $ \ (inviter, recip, time, role) -> (,,,)
+            , AP.relationshipExtraTypes   = []
-                <$> (getPersonWidgetInfo =<< bitraverse grabPerson pure inviter)
+            , AP.relationshipSubject      = encodeRouteHome $ ProjectR projectHash
-                <*> getPersonWidgetInfo recip
+            , AP.relationshipProperty     = Left AP.RelHasCollab
-                <*> pure time
+            , AP.relationshipObject       =
-                <*> pure role
+                case i of
-        joins <- do
+                    Left personID -> encodeRouteHome $ PersonR $ hashPerson personID
-            joins' <-
+                    Right u -> u
-                getTopicJoins CollabTopicProjectCollab CollabTopicProjectProject projectID
+            , AP.relationshipAttributedTo = encodeRouteLocal $ ProjectR projectHash
-            for joins' $ \ (recip, time, role) ->
+            , AP.relationshipPublished    = Just time
-                (,time,role) <$> getPersonWidgetInfo recip
+            , AP.relationshipUpdated      = Nothing
-        return (project, actor, collabs, invites, joins)
+            , AP.relationshipInstrument   = Just role
-    defaultLayout $(widgetFile "project/collab/list")
+            }
+        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
+    getHtml projectID = do
-        actorByKey <- getLocalActor actorID
+        (project, actor, collabs, invites, joins) <- handlerToWidget $ runDB $ do
-        case actorByKey of
+            project <- get404 projectID
-            LocalActorPerson personID -> return personID
+            actor <- getJust $ projectActor project
-            _ -> error "Surprise, local inviter actor isn't a Person"
+            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

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|
+        <a href=@{RepoR h}>
+          ^#{keyHashidText h} #{actorName actor}
+    |]
+componentLinkW (ComponentDeck k) actor = do
+    h <- encodeKeyHashid k
+    [whamlet|
+        <a href=@{DeckR h}>
+          =#{keyHashidText h} #{actorName actor}
+    |]
+componentLinkW (ComponentLoom k) actor = do
+    h <- encodeKeyHashid k
+    [whamlet|
+        <a href=@{LoomR h}>
+          +#{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|
+        <a href="#{renderObjURI uActor}">
+          $maybe name <- remoteActorName actor
+            #{name}
+          $nothing
+            #{renderAuthority $ instanceHost inztance}#{localUriPath $ remoteObjectIdent object}
+    |]
+    where
+    uActor = ObjURI (instanceHost inztance) (remoteObjectIdent object)

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

templates/project/components.hamlet

@@ -0,0 +1,42 @@
+$# This file is part of Vervis.
+$#
+$# Written in 2016, 2019, 2022, 2023 by fr33domlover <fr33domlover@riseup.net>.
+$#
+$# ♡ 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
+$# <http://creativecommons.org/publicdomain/zero/1.0/>.
+
+^{projectNavW (Entity projectID project) actor}
+
+<h2>Components
+
+<table>
+  <tr>
+    <th>Role
+    <th>Component
+    <th>Since
+  $forall (comp, role, since) <- comps
+    <tr>
+      <td>#{show role}
+      <td>^{componentLinkFedW comp}
+      <td>#{showDate since}
+$#    <td>^{buttonW POST "Remove" (ProjectRemoveR projectHash ctID)}
+
+<h2>Component requests in progress
+
+<table>
+  <tr>
+    <th>Role
+    <th>Component
+  $forall (comp, role) <- drafts
+    <tr>
+      <td>#{show role}
+      <td>^{componentLinkFedW comp}
+
+$#<a href=@{ProjectInviteR projectHash}>Invite…