sup39/vervis
1
0
Fork 0
mirror of https://code.sup39.dev/repos/Wqawg synced 2024-12-27 03:54:51 +09:00
Code Issues Activity

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

Browse source
This commit is contained in:
Pere Lev 2023-06-27 21:07:21 +03:00
parent 6ae079a310
commit 1fd46b0590
No known key found for this signature in database
GPG key ID: 5252C5C863E5E57D
18 changed files with 136 additions and 33 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

1
src/Vervis/ActivityPub.hs
View file

@ -227,6 +227,7 @@ provideEmptyCollection typ here = do
, AP.collectionFirst = Nothing
, AP.collectionLast = Nothing
, AP.collectionItems = [] :: [Text]
, AP.collectionContext = Nothing
}
provideHtmlAndAP coll $ redirectToPrettyJSON here

5
src/Vervis/Actor/Project.hs
View file

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

24
src/Vervis/Data/Collab.hs
View file

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

2
src/Vervis/Foundation.hs
View file

@ -1000,3 +1000,5 @@ instance YesodBreadcrumbs App where
ProjectInviteR d -> ("Invite", Just $ ProjectR d)
ProjectRemoveR _ _ -> ("", Nothing)
ProjectComponentsR j -> ("Components", Just $ ProjectR j)

1
src/Vervis/Handler/Cloth.hs
View file

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

2
src/Vervis/Handler/Deck.hs
View file

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

1
src/Vervis/Handler/Loom.hs
View file

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

85
src/Vervis/Handler/Project.hs
View file

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

1
src/Vervis/Handler/Repo.hs
View file

@ -981,6 +981,7 @@ getRepoTeamR shr rp = do
, collectionFirst = Nothing
, collectionLast = Nothing
, collectionItems = map (encodeRouteHome . SharerR) memberShrs
, collectionContext = Nothing
}
provideHtmlAndAP team $ redirectToPrettyJSON here

1
src/Vervis/Handler/Ticket.hs
View file

@ -936,6 +936,7 @@ getProjectTicketTeamR shr prj ltkhid = do
, collectionFirst = Nothing
, collectionLast = Nothing
, collectionItems = map (encodeRouteHome . SharerR) memberShrs
, collectionContext = Nothing
}
provideHtmlAndAP team $ redirectToPrettyJSON here

2
src/Vervis/Ticket.hs
View file

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

4
src/Vervis/Web/Actor.hs
View file

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

1
src/Vervis/Web/Darcs.hs
View file

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

1
src/Vervis/Web/Discussion.hs
View file

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

1
src/Vervis/Web/Git.hs
View file

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

32
src/Web/ActivityPub.hs
View file

@ -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]

3
templates/project/widget/nav.hamlet
View file

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

2
th/routes
View file

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