Project routes, handlers and creation UI

This commit is contained in:
Pere Lev 2023-06-26 22:02:54 +03:00
parent 3db602e3bd
commit 372fd35f2c
No known key found for this signature in database
GPG key ID: 5252C5C863E5E57D
31 changed files with 885 additions and 86 deletions

View file

@ -4,3 +4,9 @@ Project
UniqueProjectActor actor UniqueProjectActor actor
UniqueProjectCreate create UniqueProjectCreate create
CollabTopicProject
collab CollabId
project ProjectId
UniqueCollabTopicProject collab

View file

@ -173,6 +173,9 @@ verifyResourceAddressed localRecips resource = do
verify (GrantResourceLoom l) = do verify (GrantResourceLoom l) = do
routes <- lookup l $ recipLooms localRecips routes <- lookup l $ recipLooms localRecips
guard $ routeLoom $ familyLoom routes guard $ routeLoom $ familyLoom routes
verify (GrantResourceProject r) = do
routes <- lookup r $ recipProjects localRecips
guard $ routeProject routes
verifyRemoteAddressed verifyRemoteAddressed
:: Monad m => [(Host, NonEmpty LocalURI)] -> FedURI -> ExceptT Text m () :: Monad m => [(Host, NonEmpty LocalURI)] -> FedURI -> ExceptT Text m ()
@ -2054,6 +2057,7 @@ actorOutboxItem (LocalActorGroup _) = error "No outbox for Group yet"
actorOutboxItem (LocalActorRepo r) = RepoOutboxItemR r actorOutboxItem (LocalActorRepo r) = RepoOutboxItemR r
actorOutboxItem (LocalActorDeck d) = DeckOutboxItemR d actorOutboxItem (LocalActorDeck d) = DeckOutboxItemR d
actorOutboxItem (LocalActorLoom l) = LoomOutboxItemR l actorOutboxItem (LocalActorLoom l) = LoomOutboxItemR l
actorOutboxItem (LocalActorProject l) = ProjectOutboxItemR l
offerDepC offerDepC
:: Entity Person :: Entity Person

View file

@ -48,6 +48,7 @@ module Vervis.Actor
, RepoRoutes (..) , RepoRoutes (..)
, DeckRoutes (..) , DeckRoutes (..)
, LoomRoutes (..) , LoomRoutes (..)
, ProjectRoutes (..)
, DeckFamilyRoutes (..) , DeckFamilyRoutes (..)
, LoomFamilyRoutes (..) , LoomFamilyRoutes (..)
, RecipientRoutes (..) , RecipientRoutes (..)
@ -138,6 +139,7 @@ data LocalActorBy f
| LocalActorRepo (f Repo) | LocalActorRepo (f Repo)
| LocalActorDeck (f Deck) | LocalActorDeck (f Deck)
| LocalActorLoom (f Loom) | LocalActorLoom (f Loom)
| LocalActorProject (f Project)
deriving (Generic, FunctorB, ConstraintsB) deriving (Generic, FunctorB, ConstraintsB)
deriving instance AllBF Eq f LocalActorBy => Eq (LocalActorBy f) deriving instance AllBF Eq f LocalActorBy => Eq (LocalActorBy f)
@ -156,6 +158,7 @@ hashLocalActorPure ctx = f
f (LocalActorRepo r) = LocalActorRepo $ encodeKeyHashidPure ctx r f (LocalActorRepo r) = LocalActorRepo $ encodeKeyHashidPure ctx r
f (LocalActorDeck d) = LocalActorDeck $ encodeKeyHashidPure ctx d f (LocalActorDeck d) = LocalActorDeck $ encodeKeyHashidPure ctx d
f (LocalActorLoom l) = LocalActorLoom $ encodeKeyHashidPure ctx l f (LocalActorLoom l) = LocalActorLoom $ encodeKeyHashidPure ctx l
f (LocalActorProject j) = LocalActorProject $ encodeKeyHashidPure ctx j
getHashLocalActor getHashLocalActor
:: (MonadActor m, StageHashids (ActorEnv m)) :: (MonadActor m, StageHashids (ActorEnv m))
@ -180,6 +183,7 @@ unhashLocalActorPure ctx = f
f (LocalActorRepo r) = LocalActorRepo <$> decodeKeyHashidPure ctx r f (LocalActorRepo r) = LocalActorRepo <$> decodeKeyHashidPure ctx r
f (LocalActorDeck d) = LocalActorDeck <$> decodeKeyHashidPure ctx d f (LocalActorDeck d) = LocalActorDeck <$> decodeKeyHashidPure ctx d
f (LocalActorLoom l) = LocalActorLoom <$> decodeKeyHashidPure ctx l f (LocalActorLoom l) = LocalActorLoom <$> decodeKeyHashidPure ctx l
f (LocalActorProject j) = LocalActorProject <$> decodeKeyHashidPure ctx j
unhashLocalActor unhashLocalActor
:: (MonadActor m, StageHashids (ActorEnv m)) :: (MonadActor m, StageHashids (ActorEnv m))
@ -258,6 +262,12 @@ data LoomRoutes = LoomRoutes
} }
deriving Eq deriving Eq
data ProjectRoutes = ProjectRoutes
{ routeProject :: Bool
, routeProjectFollowers :: Bool
}
deriving Eq
data DeckFamilyRoutes = DeckFamilyRoutes data DeckFamilyRoutes = DeckFamilyRoutes
{ familyDeck :: DeckRoutes { familyDeck :: DeckRoutes
, familyTickets :: [(KeyHashid TicketDeck, TicketRoutes)] , familyTickets :: [(KeyHashid TicketDeck, TicketRoutes)]
@ -271,11 +281,12 @@ data LoomFamilyRoutes = LoomFamilyRoutes
deriving Eq deriving Eq
data RecipientRoutes = RecipientRoutes data RecipientRoutes = RecipientRoutes
{ recipPeople :: [(KeyHashid Person, PersonRoutes)] { recipPeople :: [(KeyHashid Person , PersonRoutes)]
, recipGroups :: [(KeyHashid Group , GroupRoutes)] , recipGroups :: [(KeyHashid Group , GroupRoutes)]
, recipRepos :: [(KeyHashid Repo , RepoRoutes)] , recipRepos :: [(KeyHashid Repo , RepoRoutes)]
, recipDecks :: [(KeyHashid Deck , DeckFamilyRoutes)] , recipDecks :: [(KeyHashid Deck , DeckFamilyRoutes)]
, recipLooms :: [(KeyHashid Loom , LoomFamilyRoutes)] , recipLooms :: [(KeyHashid Loom , LoomFamilyRoutes)]
, recipProjects :: [(KeyHashid Project, ProjectRoutes)]
} }
deriving Eq deriving Eq
@ -346,7 +357,6 @@ data Env = forall y. (Typeable y, Yesod y) => Env
, envHashidsContext :: HashidsContext , envHashidsContext :: HashidsContext
, envActorKeys :: Maybe (TVar (ActorKey, ActorKey, Bool)) , envActorKeys :: Maybe (TVar (ActorKey, ActorKey, Bool))
, envDeliveryTheater :: DeliveryTheater URIMode , envDeliveryTheater :: DeliveryTheater URIMode
--, envYesodSite :: y
, envYesodRender :: YesodRender y , envYesodRender :: YesodRender y
, envHttpManager :: Manager , envHttpManager :: Manager
, envFetch :: ActorFetchShare , envFetch :: ActorFetchShare
@ -469,6 +479,7 @@ sendToLocalActors authorAndId body requireOwner mauthor maidAuthor recips = do
looms <- unhashKeys $ recipLooms recips looms <- unhashKeys $ recipLooms recips
for looms $ \ (loomID, (LoomFamilyRoutes loom cloths)) -> for looms $ \ (loomID, (LoomFamilyRoutes loom cloths)) ->
(loomID,) . (loom,) <$> unhashKeys cloths (loomID,) . (loom,) <$> unhashKeys cloths
projects <- unhashKeys $ recipProjects recips
-- Grab local actor sets whose stages are allowed for delivery -- Grab local actor sets whose stages are allowed for delivery
let allowStages' let allowStages'
@ -489,6 +500,8 @@ sendToLocalActors authorAndId body requireOwner mauthor maidAuthor recips = do
filter (allowStages' fst routeDeck LocalActorDeck) decksAndTickets filter (allowStages' fst routeDeck LocalActorDeck) decksAndTickets
loomsAndClothsForStages = loomsAndClothsForStages =
filter (allowStages' fst routeLoom LocalActorLoom) loomsAndCloths filter (allowStages' fst routeLoom LocalActorLoom) loomsAndCloths
projectsForStages =
filter (allowStages' id routeProject LocalActorProject) projects
-- Grab local actors being addressed -- Grab local actors being addressed
let localActorsForSelf = concat let localActorsForSelf = concat
@ -497,6 +510,7 @@ sendToLocalActors authorAndId body requireOwner mauthor maidAuthor recips = do
, [ LocalActorRepo key | (key, routes) <- repos, routeRepo routes ] , [ LocalActorRepo key | (key, routes) <- repos, routeRepo routes ]
, [ LocalActorDeck key | (key, (routes, _)) <- decksAndTickets, routeDeck routes ] , [ LocalActorDeck key | (key, (routes, _)) <- decksAndTickets, routeDeck routes ]
, [ LocalActorLoom key | (key, (routes, _)) <- loomsAndCloths, routeLoom routes ] , [ LocalActorLoom key | (key, (routes, _)) <- loomsAndCloths, routeLoom routes ]
, [ LocalActorProject key | (key, routes) <- projects, routeProject routes ]
] ]
-- Grab local actors whose followers are going to be delivered to -- Grab local actors whose followers are going to be delivered to
@ -510,6 +524,8 @@ sendToLocalActors authorAndId body requireOwner mauthor maidAuthor recips = do
[ key | (key, (routes, _)) <- decksAndTicketsForStages, routeDeckFollowers routes ] [ key | (key, (routes, _)) <- decksAndTicketsForStages, routeDeckFollowers routes ]
loomIDsForFollowers = loomIDsForFollowers =
[ key | (key, (routes, _)) <- loomsAndClothsForStages, routeLoomFollowers routes ] [ key | (key, (routes, _)) <- loomsAndClothsForStages, routeLoomFollowers routes ]
projectIDsForFollowers =
[ key | (key, routes) <- projectsForStages, routeProjectFollowers routes ]
-- Grab tickets and cloths whose followers are going to be delivered to -- Grab tickets and cloths whose followers are going to be delivered to
let ticketSetsForFollowers = let ticketSetsForFollowers =
@ -540,6 +556,7 @@ sendToLocalActors authorAndId body requireOwner mauthor maidAuthor recips = do
, selectActorIDs repoActor repoIDsForFollowers , selectActorIDs repoActor repoIDsForFollowers
, selectActorIDs deckActor deckIDsForFollowers , selectActorIDs deckActor deckIDsForFollowers
, selectActorIDs loomActor loomIDsForFollowers , selectActorIDs loomActor loomIDsForFollowers
, selectActorIDs projectActor projectIDsForFollowers
] ]
ticketIDs <- ticketIDs <-
concat <$> concat <$>
@ -566,6 +583,7 @@ sendToLocalActors authorAndId body requireOwner mauthor maidAuthor recips = do
, selectFollowers LocalActorRepo RepoActor followerSetIDs , selectFollowers LocalActorRepo RepoActor followerSetIDs
, selectFollowers LocalActorDeck DeckActor followerSetIDs , selectFollowers LocalActorDeck DeckActor followerSetIDs
, selectFollowers LocalActorLoom LoomActor followerSetIDs , selectFollowers LocalActorLoom LoomActor followerSetIDs
, selectFollowers LocalActorProject ProjectActor followerSetIDs
] ]
remotes <- getRemoteFollowers followerSetIDs remotes <- getRemoteFollowers followerSetIDs
return (locals, remotes) return (locals, remotes)

View file

@ -92,6 +92,9 @@ verifyResourceAddressed localRecips resource = do
verify (GrantResourceLoom l) = do verify (GrantResourceLoom l) = do
routes <- lookup l $ recipLooms localRecips routes <- lookup l $ recipLooms localRecips
guard $ routeLoom $ familyLoom routes guard $ routeLoom $ familyLoom routes
verify (GrantResourceProject r) = do
routes <- lookup r $ recipProjects localRecips
guard $ routeProject routes
verifyRecipientAddressed localRecips recipient = do verifyRecipientAddressed localRecips recipient = do
recipientHash <- hashGrantRecip recipient recipientHash <- hashGrantRecip recipient
@ -384,6 +387,7 @@ clientInvite now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHost
Left (GrantResourceRepo r) -> Just $ LocalActorRepo r Left (GrantResourceRepo r) -> Just $ LocalActorRepo r
Left (GrantResourceDeck d) -> Just $ LocalActorDeck d Left (GrantResourceDeck d) -> Just $ LocalActorDeck d
Left (GrantResourceLoom l) -> Just $ LocalActorLoom l Left (GrantResourceLoom l) -> Just $ LocalActorLoom l
Left (GrantResourceProject l) -> Just $ LocalActorProject l
Right _ -> Nothing Right _ -> Nothing
, case recipientHash of , case recipientHash of
Left (GrantRecipPerson p) -> Just $ LocalActorPerson p Left (GrantRecipPerson p) -> Just $ LocalActorPerson p
@ -395,6 +399,7 @@ clientInvite now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHost
Left (GrantResourceRepo r) -> Just $ LocalStageRepoFollowers r Left (GrantResourceRepo r) -> Just $ LocalStageRepoFollowers r
Left (GrantResourceDeck d) -> Just $ LocalStageDeckFollowers d Left (GrantResourceDeck d) -> Just $ LocalStageDeckFollowers d
Left (GrantResourceLoom l) -> Just $ LocalStageLoomFollowers l Left (GrantResourceLoom l) -> Just $ LocalStageLoomFollowers l
Left (GrantResourceProject l) -> Just $ LocalStageProjectFollowers l
Right _ -> Nothing Right _ -> Nothing
, case recipientHash of , case recipientHash of
Left (GrantRecipPerson p) -> Just $ LocalStagePersonFollowers p Left (GrantRecipPerson p) -> Just $ LocalStagePersonFollowers p
@ -484,6 +489,7 @@ clientRemove now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHost
Left (GrantResourceRepo r) -> Just $ LocalActorRepo r Left (GrantResourceRepo r) -> Just $ LocalActorRepo r
Left (GrantResourceDeck d) -> Just $ LocalActorDeck d Left (GrantResourceDeck d) -> Just $ LocalActorDeck d
Left (GrantResourceLoom l) -> Just $ LocalActorLoom l Left (GrantResourceLoom l) -> Just $ LocalActorLoom l
Left (GrantResourceProject l) -> Just $ LocalActorProject l
Right _ -> Nothing Right _ -> Nothing
, case recipientHash of , case recipientHash of
Left (GrantRecipPerson p) -> Just $ LocalActorPerson p Left (GrantRecipPerson p) -> Just $ LocalActorPerson p
@ -495,6 +501,7 @@ clientRemove now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHost
Left (GrantResourceRepo r) -> Just $ LocalStageRepoFollowers r Left (GrantResourceRepo r) -> Just $ LocalStageRepoFollowers r
Left (GrantResourceDeck d) -> Just $ LocalStageDeckFollowers d Left (GrantResourceDeck d) -> Just $ LocalStageDeckFollowers d
Left (GrantResourceLoom l) -> Just $ LocalStageLoomFollowers l Left (GrantResourceLoom l) -> Just $ LocalStageLoomFollowers l
Left (GrantResourceProject l) -> Just $ LocalStageProjectFollowers l
Right _ -> Nothing Right _ -> Nothing
, case recipientHash of , case recipientHash of
Left (GrantRecipPerson p) -> Just $ LocalStagePersonFollowers p Left (GrantRecipPerson p) -> Just $ LocalStagePersonFollowers p

View file

@ -0,0 +1,62 @@
{- This file is part of Vervis.
-
- Written in 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/>.
-}
module Vervis.Actor.Project
(
)
where
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Logger.CallStack
import Control.Monad.Trans.Class
import Control.Monad.Trans.Except
import Control.Monad.Trans.Maybe
import Data.ByteString (ByteString)
import Data.Foldable
import Data.Text (Text)
import Data.Time.Clock
import Database.Persist
import Yesod.Persist.Core
import qualified Data.Text as T
import Control.Concurrent.Actor
import Network.FedURI
import Yesod.MonadSite
import qualified Web.ActivityPub as AP
import Control.Monad.Trans.Except.Local
import Database.Persist.Local
import Vervis.Actor
import Vervis.Cloth
import Vervis.Data.Discussion
import Vervis.FedURI
import Vervis.Federation.Util
import Vervis.Foundation
import Vervis.Model
import Vervis.Persist.Discussion
import Vervis.Ticket
projectBehavior :: UTCTime -> ProjectId -> VerseExt -> ActE (Text, Act (), Next)
projectBehavior now projectID (Left _verse@(Verse _authorIdMsig body)) =
case AP.activitySpecific $ actbActivity body of
_ -> throwE "Unsupported activity type for Project"
projectBehavior _ _ (Right _) = throwE "ClientMsgs aren't supported for Project"
instance VervisActor Project where
actorBehavior = projectBehavior

View file

@ -110,6 +110,7 @@ import Vervis.Actor.Deck
import Vervis.Actor.Group import Vervis.Actor.Group
import Vervis.Actor.Loom import Vervis.Actor.Loom
import Vervis.Actor.Person import Vervis.Actor.Person
import Vervis.Actor.Project
import Vervis.Actor.Repo import Vervis.Actor.Repo
import Vervis.Darcs import Vervis.Darcs
import Vervis.Data.Actor import Vervis.Data.Actor
@ -130,6 +131,7 @@ import Vervis.Handler.Group
import Vervis.Handler.Key import Vervis.Handler.Key
import Vervis.Handler.Loom import Vervis.Handler.Loom
import Vervis.Handler.Person import Vervis.Handler.Person
import Vervis.Handler.Project
import Vervis.Handler.Repo import Vervis.Handler.Repo
--import Vervis.Handler.Role --import Vervis.Handler.Role
--import Vervis.Handler.Sharer --import Vervis.Handler.Sharer
@ -349,6 +351,7 @@ makeFoundation appSettings = do
, selectAll LocalActorRepo , selectAll LocalActorRepo
, selectAll LocalActorDeck , selectAll LocalActorDeck
, selectAll LocalActorLoom , selectAll LocalActorLoom
, selectAll LocalActorProject
] ]
where where
selectAll selectAll

View file

@ -37,6 +37,7 @@ module Vervis.Client
, createDeck , createDeck
, createLoom , createLoom
, createRepo , createRepo
, createProject
, invite , invite
, remove , remove
) )
@ -949,6 +950,27 @@ createRepo senderHash name desc = do
return (Nothing, audience, detail) return (Nothing, audience, detail)
createProject
:: (MonadHandler m, HandlerSite m ~ App, MonadSite m, SiteEnv m ~ App)
=> KeyHashid Person
-> Text
-> Text
-> m (Maybe HTML, [Aud URIMode], AP.ActorDetail)
createProject senderHash name desc = do
let audAuthor =
AudLocal [] [LocalStagePersonFollowers senderHash]
audience = [audAuthor]
detail = AP.ActorDetail
{ AP.actorType = AP.ActorTypeProject
, AP.actorUsername = Nothing
, AP.actorName = Just name
, AP.actorSummary = Just desc
}
return (Nothing, audience, detail)
invite invite
:: PersonId :: PersonId
-> FedURI -> FedURI
@ -1012,6 +1034,8 @@ invite personID uRecipient uResource role = do
AudLocal [LocalActorDeck d] [LocalStageDeckFollowers d] AudLocal [LocalActorDeck d] [LocalStageDeckFollowers d]
Left (GrantResourceLoom l) -> Left (GrantResourceLoom l) ->
AudLocal [LocalActorLoom l] [LocalStageLoomFollowers l] AudLocal [LocalActorLoom l] [LocalStageLoomFollowers l]
Left (GrantResourceProject l) ->
AudLocal [LocalActorProject l] [LocalStageProjectFollowers l]
Right (remoteActor, ObjURI h lu) -> Right (remoteActor, ObjURI h lu) ->
AudRemote h AudRemote h
[lu] [lu]
@ -1093,6 +1117,8 @@ remove personID uRecipient uResource = do
AudLocal [LocalActorDeck d] [LocalStageDeckFollowers d] AudLocal [LocalActorDeck d] [LocalStageDeckFollowers d]
Left (GrantResourceLoom l) -> Left (GrantResourceLoom l) ->
AudLocal [LocalActorLoom l] [LocalStageLoomFollowers l] AudLocal [LocalActorLoom l] [LocalStageLoomFollowers l]
Left (GrantResourceProject l) ->
AudLocal [LocalActorProject l] [LocalStageProjectFollowers l]
Right (remoteActor, ObjURI h lu) -> Right (remoteActor, ObjURI h lu) ->
AudRemote h AudRemote h
[lu] [lu]

View file

@ -80,6 +80,7 @@ parseLocalActivityURI luAct = do
parseOutboxItemRoute (RepoOutboxItemR r i) = Just (LocalActorRepo r, i) parseOutboxItemRoute (RepoOutboxItemR r i) = Just (LocalActorRepo r, i)
parseOutboxItemRoute (DeckOutboxItemR d i) = Just (LocalActorDeck d, i) parseOutboxItemRoute (DeckOutboxItemR d i) = Just (LocalActorDeck d, i)
parseOutboxItemRoute (LoomOutboxItemR l i) = Just (LocalActorLoom l, i) parseOutboxItemRoute (LoomOutboxItemR l i) = Just (LocalActorLoom l, i)
parseOutboxItemRoute (ProjectOutboxItemR r i) = Just (LocalActorProject r, i)
parseOutboxItemRoute _ = Nothing parseOutboxItemRoute _ = Nothing
parseLocalActivityURI' parseLocalActivityURI'
@ -141,6 +142,7 @@ activityRoute (LocalActorGroup g) = GroupOutboxItemR g
activityRoute (LocalActorRepo r) = RepoOutboxItemR r activityRoute (LocalActorRepo r) = RepoOutboxItemR r
activityRoute (LocalActorDeck d) = DeckOutboxItemR d activityRoute (LocalActorDeck d) = DeckOutboxItemR d
activityRoute (LocalActorLoom l) = LoomOutboxItemR l activityRoute (LocalActorLoom l) = LoomOutboxItemR l
activityRoute (LocalActorProject r) = ProjectOutboxItemR r
stampRoute :: LocalActorBy KeyHashid -> KeyHashid SigKey -> Route App stampRoute :: LocalActorBy KeyHashid -> KeyHashid SigKey -> Route App
stampRoute (LocalActorPerson p) = PersonStampR p stampRoute (LocalActorPerson p) = PersonStampR p
@ -148,6 +150,7 @@ stampRoute (LocalActorGroup g) = GroupStampR g
stampRoute (LocalActorRepo r) = RepoStampR r stampRoute (LocalActorRepo r) = RepoStampR r
stampRoute (LocalActorDeck d) = DeckStampR d stampRoute (LocalActorDeck d) = DeckStampR d
stampRoute (LocalActorLoom l) = LoomStampR l stampRoute (LocalActorLoom l) = LoomStampR l
stampRoute (LocalActorProject r) = ProjectStampR r
parseStampRoute parseStampRoute
:: Route App -> Maybe (LocalActorBy KeyHashid, KeyHashid SigKey) :: Route App -> Maybe (LocalActorBy KeyHashid, KeyHashid SigKey)
@ -156,6 +159,7 @@ parseStampRoute (GroupStampR g i) = Just (LocalActorGroup g, i)
parseStampRoute (RepoStampR r i) = Just (LocalActorRepo r, i) parseStampRoute (RepoStampR r i) = Just (LocalActorRepo r, i)
parseStampRoute (DeckStampR d i) = Just (LocalActorDeck d, i) parseStampRoute (DeckStampR d i) = Just (LocalActorDeck d, i)
parseStampRoute (LoomStampR l i) = Just (LocalActorLoom l, i) parseStampRoute (LoomStampR l i) = Just (LocalActorLoom l, i)
parseStampRoute (ProjectStampR r i) = Just (LocalActorProject r, i)
parseStampRoute _ = Nothing parseStampRoute _ = Nothing
localActorID :: LocalActorBy Entity -> ActorId localActorID :: LocalActorBy Entity -> ActorId
@ -164,6 +168,7 @@ localActorID (LocalActorGroup (Entity _ g)) = groupActor g
localActorID (LocalActorRepo (Entity _ r)) = repoActor r localActorID (LocalActorRepo (Entity _ r)) = repoActor r
localActorID (LocalActorDeck (Entity _ d)) = deckActor d localActorID (LocalActorDeck (Entity _ d)) = deckActor d
localActorID (LocalActorLoom (Entity _ l)) = loomActor l localActorID (LocalActorLoom (Entity _ l)) = loomActor l
localActorID (LocalActorProject (Entity _ r)) = projectActor r
parseFedURIOld parseFedURIOld
:: ( MonadSite m :: ( MonadSite m

View file

@ -85,6 +85,7 @@ import Vervis.Model
parseGrantResource (RepoR r) = Just $ GrantResourceRepo r parseGrantResource (RepoR r) = Just $ GrantResourceRepo r
parseGrantResource (DeckR d) = Just $ GrantResourceDeck d parseGrantResource (DeckR d) = Just $ GrantResourceDeck d
parseGrantResource (LoomR l) = Just $ GrantResourceLoom l parseGrantResource (LoomR l) = Just $ GrantResourceLoom l
parseGrantResource (ProjectR l) = Just $ GrantResourceProject l
parseGrantResource _ = Nothing parseGrantResource _ = Nothing
data GrantRecipBy f = GrantRecipPerson (f Person) data GrantRecipBy f = GrantRecipPerson (f Person)
@ -230,11 +231,6 @@ parseGrant h (AP.Grant object context target mresult mstart mend allows deleg) =
resourceHash resourceHash
"Grant resource contains invalid hashid" "Grant resource contains invalid hashid"
else pure $ Right lu else pure $ Right lu
where
parseGrantResource (RepoR r) = Just $ GrantResourceRepo r
parseGrantResource (DeckR d) = Just $ GrantResourceDeck d
parseGrantResource (LoomR l) = Just $ GrantResourceLoom l
parseGrantResource _ = Nothing
parseTarget u@(ObjURI h lu) = do parseTarget u@(ObjURI h lu) = do
hl <- hostIsLocal h hl <- hostIsLocal h
if hl if hl
@ -277,11 +273,13 @@ grantResourceActorID :: GrantResourceBy Identity -> ActorId
grantResourceActorID (GrantResourceRepo (Identity r)) = repoActor r grantResourceActorID (GrantResourceRepo (Identity r)) = repoActor r
grantResourceActorID (GrantResourceDeck (Identity d)) = deckActor d grantResourceActorID (GrantResourceDeck (Identity d)) = deckActor d
grantResourceActorID (GrantResourceLoom (Identity l)) = loomActor l grantResourceActorID (GrantResourceLoom (Identity l)) = loomActor l
grantResourceActorID (GrantResourceProject (Identity l)) = projectActor l
data GrantResourceBy f data GrantResourceBy f
= GrantResourceRepo (f Repo) = GrantResourceRepo (f Repo)
| GrantResourceDeck (f Deck) | GrantResourceDeck (f Deck)
| GrantResourceLoom (f Loom) | GrantResourceLoom (f Loom)
| GrantResourceProject (f Project)
deriving (Generic, FunctorB, TraversableB, ConstraintsB) deriving (Generic, FunctorB, TraversableB, ConstraintsB)
deriving instance AllBF Eq f GrantResourceBy => Eq (GrantResourceBy f) deriving instance AllBF Eq f GrantResourceBy => Eq (GrantResourceBy f)
@ -294,6 +292,8 @@ unhashGrantResourcePure ctx = f
GrantResourceDeck <$> decodeKeyHashidPure ctx d GrantResourceDeck <$> decodeKeyHashidPure ctx d
f (GrantResourceLoom l) = f (GrantResourceLoom l) =
GrantResourceLoom <$> decodeKeyHashidPure ctx l GrantResourceLoom <$> decodeKeyHashidPure ctx l
f (GrantResourceProject l) =
GrantResourceProject <$> decodeKeyHashidPure ctx l
unhashGrantResource resource = do unhashGrantResource resource = do
ctx <- asksSite siteHashidsContext ctx <- asksSite siteHashidsContext
@ -317,6 +317,8 @@ hashGrantResource (GrantResourceDeck k) =
GrantResourceDeck <$> encodeKeyHashid k GrantResourceDeck <$> encodeKeyHashid k
hashGrantResource (GrantResourceLoom k) = hashGrantResource (GrantResourceLoom k) =
GrantResourceLoom <$> encodeKeyHashid k GrantResourceLoom <$> encodeKeyHashid k
hashGrantResource (GrantResourceProject k) =
GrantResourceProject <$> encodeKeyHashid k
hashGrantResource' (GrantResourceRepo k) = hashGrantResource' (GrantResourceRepo k) =
GrantResourceRepo <$> WAP.encodeKeyHashid k GrantResourceRepo <$> WAP.encodeKeyHashid k
@ -324,6 +326,8 @@ hashGrantResource' (GrantResourceDeck k) =
GrantResourceDeck <$> WAP.encodeKeyHashid k GrantResourceDeck <$> WAP.encodeKeyHashid k
hashGrantResource' (GrantResourceLoom k) = hashGrantResource' (GrantResourceLoom k) =
GrantResourceLoom <$> WAP.encodeKeyHashid k GrantResourceLoom <$> WAP.encodeKeyHashid k
hashGrantResource' (GrantResourceProject k) =
GrantResourceProject <$> WAP.encodeKeyHashid k
getGrantResource (GrantResourceRepo k) e = getGrantResource (GrantResourceRepo k) e =
GrantResourceRepo <$> getEntityE k e GrantResourceRepo <$> getEntityE k e
@ -331,6 +335,8 @@ getGrantResource (GrantResourceDeck k) e =
GrantResourceDeck <$> getEntityE k e GrantResourceDeck <$> getEntityE k e
getGrantResource (GrantResourceLoom k) e = getGrantResource (GrantResourceLoom k) e =
GrantResourceLoom <$> getEntityE k e GrantResourceLoom <$> getEntityE k e
getGrantResource (GrantResourceProject k) e =
GrantResourceProject <$> getEntityE k e
getGrantResource404 = maybe notFound return <=< getGrantResourceEntity getGrantResource404 = maybe notFound return <=< getGrantResourceEntity
where where
@ -340,8 +346,11 @@ getGrantResource404 = maybe notFound return <=< getGrantResourceEntity
fmap GrantResourceDeck <$> getEntity k fmap GrantResourceDeck <$> getEntity k
getGrantResourceEntity (GrantResourceLoom k) = getGrantResourceEntity (GrantResourceLoom k) =
fmap GrantResourceLoom <$> getEntity k fmap GrantResourceLoom <$> getEntity k
getGrantResourceEntity (GrantResourceProject k) =
fmap GrantResourceProject <$> getEntity k
grantResourceLocalActor :: GrantResourceBy f -> LocalActorBy f grantResourceLocalActor :: GrantResourceBy f -> LocalActorBy f
grantResourceLocalActor (GrantResourceRepo r) = LocalActorRepo r grantResourceLocalActor (GrantResourceRepo r) = LocalActorRepo r
grantResourceLocalActor (GrantResourceDeck d) = LocalActorDeck d grantResourceLocalActor (GrantResourceDeck d) = LocalActorDeck d
grantResourceLocalActor (GrantResourceLoom l) = LocalActorLoom l grantResourceLocalActor (GrantResourceLoom l) = LocalActorLoom l
grantResourceLocalActor (GrantResourceProject l) = LocalActorProject l

View file

@ -222,3 +222,4 @@ messageRoute (LocalActorGroup g) = GroupMessageR g
messageRoute (LocalActorRepo r) = RepoMessageR r messageRoute (LocalActorRepo r) = RepoMessageR r
messageRoute (LocalActorDeck d) = DeckMessageR d messageRoute (LocalActorDeck d) = DeckMessageR d
messageRoute (LocalActorLoom l) = LoomMessageR l messageRoute (LocalActorLoom l) = LoomMessageR l
messageRoute (LocalActorProject l) = ProjectMessageR l

View file

@ -16,10 +16,14 @@
module Vervis.Form.Tracker module Vervis.Form.Tracker
( NewDeck (..) ( NewDeck (..)
, newDeckForm , newDeckForm
, NewProject (..)
, newProjectForm
, NewLoom (..) , NewLoom (..)
, newLoomForm , newLoomForm
, DeckInvite (..) , DeckInvite (..)
, deckInviteForm , deckInviteForm
, ProjectInvite (..)
, projectInviteForm
--, NewProjectCollab (..) --, NewProjectCollab (..)
--, newProjectCollabForm --, newProjectCollabForm
--, editProjectForm --, editProjectForm
@ -56,6 +60,16 @@ newDeckForm = renderDivs $ NewDeck
<$> areq textField "Name*" Nothing <$> areq textField "Name*" Nothing
<*> areq textField "Description" Nothing <*> areq textField "Description" Nothing
data NewProject = NewProject
{ npName :: Text
, npDesc :: Text
}
newProjectForm :: Form NewProject
newProjectForm = renderDivs $ NewProject
<$> areq textField "Name*" Nothing
<*> areq textField "Description" Nothing
data NewLoom = NewLoom data NewLoom = NewLoom
{ nlName :: Text { nlName :: Text
, nlDesc :: Text , nlDesc :: Text
@ -115,6 +129,38 @@ deckInviteForm deckID = renderDivs $ DeckInvite
l l
selectRole = selectField optionsEnum selectRole = selectField optionsEnum
data ProjectInvite = ProjectInvite
{ jiPerson :: PersonId
, jiRole :: AP.Role
}
projectInviteForm :: ProjectId -> Form ProjectInvite
projectInviteForm projectID = renderDivs $ ProjectInvite
<$> areq selectPerson "Person*" Nothing
<*> areq selectRole "Role*" Nothing
where
selectPerson = selectField $ do
l <- runDB $ E.select $
E.from $ \ (person `E.InnerJoin` actor `E.LeftOuterJoin` (recip `E.InnerJoin` topic)) -> do
E.on $ recip E.^. CollabRecipLocalCollab E.==. topic E.^. CollabTopicProjectCollab E.&&.
topic E.^. CollabTopicProjectProject E.==. E.val projectID
E.on $ person E.^. PersonId E.==. recip E.^. CollabRecipLocalPerson
E.on $ person E.^. PersonActor E.==. actor E.^. ActorId
E.where_ $ E.isNothing $ E.just $ recip E.^. CollabRecipLocalId
return (person, actor)
optionsPairs $
map (\ (Entity pid p, Entity _ a) ->
( T.concat
[ actorName a
, " ~"
, username2text $ personUsername p
]
, pid
)
)
l
selectRole = selectField optionsEnum
{- {-
editProjectAForm :: SharerId -> Entity Project -> AForm Handler Project editProjectAForm :: SharerId -> Entity Project -> AForm Handler Project
editProjectAForm sid (Entity jid project) = Project editProjectAForm sid (Entity jid project) = Project

View file

@ -157,6 +157,7 @@ type LoomKeyHashid = KeyHashid Loom
type TicketDeckKeyHashid = KeyHashid TicketDeck type TicketDeckKeyHashid = KeyHashid TicketDeck
type TicketLoomKeyHashid = KeyHashid TicketLoom type TicketLoomKeyHashid = KeyHashid TicketLoom
type SigKeyKeyHashid = KeyHashid SigKey type SigKeyKeyHashid = KeyHashid SigKey
type ProjectKeyHashid = KeyHashid Project
-- This is where we define all of the routes in our application. For a full -- This is where we define all of the routes in our application. For a full
-- explanation of the syntax, please see: -- explanation of the syntax, please see:
@ -982,3 +983,20 @@ instance YesodBreadcrumbs App where
ClothReplyOnR l c _ -> ("Reply", Just $ ClothR l c) ClothReplyOnR l c _ -> ("Reply", Just $ ClothR l c)
ClothDepR l c p -> (keyHashidText p, Just $ ClothDepsR l c) ClothDepR l c p -> (keyHashidText p, Just $ ClothDepsR l c)
ProjectR d -> ("Project $" <> keyHashidText d, Just HomeR)
ProjectInboxR d -> ("Inbox", Just $ ProjectR d)
ProjectOutboxR d -> ("Outbox", Just $ ProjectR d)
ProjectOutboxItemR d i -> (keyHashidText i, Just $ ProjectOutboxR d)
ProjectFollowersR d -> ("Followers", Just $ ProjectR d)
ProjectMessageR d m -> ("Message #" <> keyHashidText m, Just $ ProjectR d)
ProjectNewR -> ("New Project", Just HomeR)
ProjectStampR d k -> ("Stamp #" <> keyHashidText k, Just $ ProjectR d)
ProjectCollabsR d -> ("Collaborators", Just $ ProjectR d)
ProjectInviteR d -> ("Invite", Just $ ProjectR d)
ProjectRemoveR _ _ -> ("", Nothing)

View file

@ -122,7 +122,7 @@ getHomeR = do
where where
personalOverview :: Entity Person -> Handler Html personalOverview :: Entity Person -> Handler Html
personalOverview (Entity pid _person) = do personalOverview (Entity pid _person) = do
(repos, decks, looms) <- runDB $ (,,) (repos, decks, looms, projects) <- runDB $ (,,,)
<$> (E.select $ E.from $ \ (recip `E.InnerJoin` collab `E.InnerJoin` topic `E.InnerJoin` enable `E.InnerJoin` repo `E.InnerJoin` actor) -> do <$> (E.select $ E.from $ \ (recip `E.InnerJoin` collab `E.InnerJoin` topic `E.InnerJoin` enable `E.InnerJoin` repo `E.InnerJoin` actor) -> do
E.on $ repo E.^. RepoActor E.==. actor E.^. ActorId E.on $ repo E.^. RepoActor E.==. actor E.^. ActorId
E.on $ topic E.^. CollabTopicRepoRepo E.==. repo E.^. RepoId E.on $ topic E.^. CollabTopicRepoRepo E.==. repo E.^. RepoId
@ -153,15 +153,26 @@ getHomeR = do
E.orderBy [E.asc $ loom E.^. LoomId] E.orderBy [E.asc $ loom E.^. LoomId]
return (loom, actor, collab) return (loom, actor, collab)
) )
<*> (E.select $ E.from $ \ (recip `E.InnerJoin` collab `E.InnerJoin` topic `E.InnerJoin` enable `E.InnerJoin` project `E.InnerJoin` actor) -> do
E.on $ project E.^. ProjectActor E.==. actor E.^. ActorId
E.on $ topic E.^. CollabTopicProjectProject E.==. project E.^. ProjectId
E.on $ topic E.^. CollabTopicProjectCollab E.==. enable E.^. CollabEnableCollab
E.on $ recip E.^. CollabRecipLocalCollab E.==. topic E.^. CollabTopicProjectCollab
E.on $ recip E.^. CollabRecipLocalCollab E.==. collab E.^. CollabId
E.where_ $ recip E.^. CollabRecipLocalPerson E.==. E.val pid
E.orderBy [E.asc $ project E.^. ProjectId]
return (project, actor, collab)
)
hashRepo <- getEncodeKeyHashid hashRepo <- getEncodeKeyHashid
hashDeck <- getEncodeKeyHashid hashDeck <- getEncodeKeyHashid
hashLoom <- getEncodeKeyHashid hashLoom <- getEncodeKeyHashid
hashProject <- getEncodeKeyHashid
defaultLayout $(widgetFile "personal-overview") defaultLayout $(widgetFile "personal-overview")
getBrowseR :: Handler Html getBrowseR :: Handler Html
getBrowseR = do getBrowseR = do
(people, groups, repos, decks, looms) <- runDB $ (people, groups, repos, decks, looms, projects) <- runDB $
(,,,,) (,,,,,)
<$> (E.select $ E.from $ \ (person `E.InnerJoin` actor) -> do <$> (E.select $ E.from $ \ (person `E.InnerJoin` actor) -> do
E.on $ person E.^. PersonActor E.==. actor E.^. ActorId E.on $ person E.^. PersonActor E.==. actor E.^. ActorId
E.orderBy [E.asc $ person E.^. PersonId] E.orderBy [E.asc $ person E.^. PersonId]
@ -187,6 +198,11 @@ getBrowseR = do
E.orderBy [E.asc $ loom E.^. LoomId] E.orderBy [E.asc $ loom E.^. LoomId]
return (loom, actor) return (loom, actor)
) )
<*> (E.select $ E.from $ \ (project `E.InnerJoin` actor) -> do
E.on $ project E.^. ProjectActor E.==. actor E.^. ActorId
E.orderBy [E.asc $ project E.^. ProjectId]
return (project, actor)
)
{- {-
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
repoRows <- forM repos $ repoRows <- forM repos $
@ -209,6 +225,7 @@ getBrowseR = do
hashRepo <- getEncodeKeyHashid hashRepo <- getEncodeKeyHashid
hashDeck <- getEncodeKeyHashid hashDeck <- getEncodeKeyHashid
hashLoom <- getEncodeKeyHashid hashLoom <- getEncodeKeyHashid
hashProject <- getEncodeKeyHashid
defaultLayout $ do defaultLayout $ do
setTitle "Welcome to Vervis!" setTitle "Welcome to Vervis!"
$(widgetFile "browse") $(widgetFile "browse")

View file

@ -0,0 +1,332 @@
{- 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/>.
-}
module Vervis.Handler.Project
( getProjectR
, getProjectInboxR
, postProjectInboxR
, getProjectOutboxR
, getProjectOutboxItemR
, getProjectFollowersR
, getProjectMessageR
, getProjectNewR
, postProjectNewR
, getProjectStampR
, getProjectCollabsR
, getProjectInviteR
, postProjectInviteR
, postProjectRemoveR
)
where
import Control.Applicative
import Control.Monad
import Control.Monad.Trans.Except
import Control.Monad.Trans.Maybe
import Data.Aeson
import Data.Bitraversable
import Data.ByteString (ByteString)
import Data.Default.Class
import Data.Foldable
import Data.Maybe (fromMaybe)
import Data.Text (Text)
import Data.Time.Clock
import Data.Traversable
import Database.Persist
import Network.HTTP.Types.Method
import Text.Blaze.Html (Html)
import Yesod.Auth (requireAuth)
import Yesod.Core
import Yesod.Core.Handler (redirect, setMessage, lookupPostParam, notFound)
import Yesod.Form.Functions (runFormPost, runFormGet)
import Yesod.Form.Types (FormResult (..))
import Yesod.Persist.Core (runDB, get404, getBy404)
import qualified Data.ByteString.Lazy as BL
import qualified Database.Esqueleto as E
import Database.Persist.JSON
import Development.PatchMediaType
import Network.FedURI
import Web.ActivityPub hiding (Project (..), Repo (..), Actor (..), ActorDetail (..), ActorLocal (..))
import Yesod.ActivityPub
import Yesod.FedURI
import Yesod.Hashids
import Yesod.MonadSite
import qualified Web.ActivityPub as AP
import Control.Monad.Trans.Except.Local
import Data.Either.Local
import Data.Paginate.Local
import Database.Persist.Local
import Yesod.Form.Local
import Yesod.Persist.Local
import Vervis.Access
import Vervis.API
import Vervis.Federation.Auth
import Vervis.Federation.Collab
import Vervis.Federation.Discussion
import Vervis.Federation.Offer
import Vervis.Federation.Ticket
import Vervis.FedURI
import Vervis.Form.Ticket
import Vervis.Form.Tracker
import Vervis.Foundation
import Vervis.Model
import Vervis.Paginate
import Vervis.Persist.Actor
import Vervis.Persist.Collab
import Vervis.Recipient
import Vervis.Settings
import Vervis.Ticket
import Vervis.TicketFilter
import Vervis.Time
import Vervis.Web.Actor
import Vervis.Widget
import Vervis.Widget.Person
import Vervis.Widget.Ticket
import Vervis.Widget.Tracker
import qualified Vervis.Client as C
getProjectR :: KeyHashid Project -> Handler TypedContent
getProjectR projectHash = do
projectID <- decodeKeyHashid404 projectHash
(project, actor, sigKeyIDs) <- runDB $ do
d <- get404 projectID
let aid = projectActor d
a <- getJust aid
sigKeys <- selectKeysList [SigKeyActor ==. aid] [Asc SigKeyId]
return (d, a, sigKeys)
encodeRouteLocal <- getEncodeRouteLocal
hashSigKey <- getEncodeKeyHashid
perActor <- asksSite $ appPerActorKeys . appSettings
let projectAP = AP.Project
{ AP.projectActor = AP.Actor
{ AP.actorLocal = AP.ActorLocal
{ AP.actorId = encodeRouteLocal $ ProjectR projectHash
, AP.actorInbox = encodeRouteLocal $ ProjectInboxR projectHash
, AP.actorOutbox =
Just $ encodeRouteLocal $ ProjectOutboxR projectHash
, AP.actorFollowers =
Just $ encodeRouteLocal $ ProjectFollowersR projectHash
, AP.actorFollowing = Nothing
, AP.actorPublicKeys =
map (Left . encodeRouteLocal) $
if perActor
then map (ProjectStampR projectHash . hashSigKey) sigKeyIDs
else [ActorKey1R, ActorKey2R]
, AP.actorSshKeys = []
}
, AP.actorDetail = AP.ActorDetail
{ AP.actorType = AP.ActorTypeProject
, AP.actorUsername = Nothing
, AP.actorName = Just $ actorName actor
, AP.actorSummary = Just $ actorDesc actor
}
}
, AP.projectTracker = Nothing
, AP.projectChildren = []
, AP.projectParents = []
, AP.projectComponents = []
}
provideHtmlAndAP projectAP $ redirectToPrettyJSON here
where
here = ProjectR projectHash
getProjectInboxR :: KeyHashid Project -> Handler TypedContent
getProjectInboxR = getInbox ProjectInboxR projectActor
postProjectInboxR :: KeyHashid Project -> Handler ()
postProjectInboxR projectHash = do
projectID <- decodeKeyHashid404 projectHash
postInbox $ LocalActorProject projectID
getProjectOutboxR :: KeyHashid Project -> Handler TypedContent
getProjectOutboxR = getOutbox ProjectOutboxR ProjectOutboxItemR projectActor
getProjectOutboxItemR
:: KeyHashid Project -> KeyHashid OutboxItem -> Handler TypedContent
getProjectOutboxItemR = getOutboxItem ProjectOutboxItemR projectActor
getProjectFollowersR :: KeyHashid Project -> Handler TypedContent
getProjectFollowersR = getActorFollowersCollection ProjectFollowersR projectActor
getProjectMessageR :: KeyHashid Project -> KeyHashid LocalMessage -> Handler Html
getProjectMessageR _ _ = notFound
getProjectNewR :: Handler Html
getProjectNewR = do
((_result, widget), enctype) <- runFormPost newProjectForm
defaultLayout $(widgetFile "project/new")
postProjectNewR :: Handler Html
postProjectNewR = do
NewProject name desc <- runFormPostRedirect ProjectNewR newProjectForm
personEntity@(Entity personID person) <- requireAuth
personHash <- encodeKeyHashid personID
(maybeSummary, audience, detail) <- C.createProject personHash name desc
(localRecips, remoteRecips, fwdHosts, action) <-
C.makeServerInput Nothing maybeSummary audience $ AP.CreateActivity $ AP.Create (AP.CreateProject detail Nothing) Nothing
result <-
runExceptT $
handleViaActor personID Nothing localRecips remoteRecips fwdHosts action
case result of
Left e -> do
setMessage $ toHtml e
redirect ProjectNewR
Right createID -> do
maybeProjectID <- runDB $ getKeyBy $ UniqueProjectCreate createID
case maybeProjectID of
Nothing -> error "Can't find the newly created project"
Just projectID -> do
projectHash <- encodeKeyHashid projectID
setMessage "New project created"
redirect $ ProjectR projectHash
getProjectStampR :: KeyHashid Project -> KeyHashid SigKey -> Handler TypedContent
getProjectStampR = servePerActorKey projectActor LocalActorProject
getProjectCollabsR :: KeyHashid Project -> Handler Html
getProjectCollabsR projectHash = do
projectID <- decodeKeyHashid404 projectHash
(project, actor, collabs, invites, joins) <- runDB $ do
project <- get404 projectID
actor <- getJust $ projectActor project
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)
defaultLayout $(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
projectID <- decodeKeyHashid404 projectHash
((_result, widget), enctype) <- runFormPost $ projectInviteForm projectID
defaultLayout $(widgetFile "project/collab/new")
postProjectInviteR :: KeyHashid Project -> Handler Html
postProjectInviteR projectHash = do
projectID <- decodeKeyHashid404 projectHash
ProjectInvite recipPersonID role <-
runFormPostRedirect (ProjectInviteR projectHash) $ projectInviteForm projectID
personEntity@(Entity personID person) <- requireAuth
personHash <- encodeKeyHashid personID
recipPersonHash <- encodeKeyHashid recipPersonID
encodeRouteHome <- getEncodeRouteHome
result <- runExceptT $ do
(maybeSummary, audience, invite) <- do
let uRecipient = encodeRouteHome $ PersonR recipPersonHash
uResource = encodeRouteHome $ ProjectR projectHash
C.invite personID uRecipient uResource role
grantID <- do
maybeItem <- lift $ runDB $ getGrant CollabTopicProjectCollab CollabTopicProjectProject projectID personID
fromMaybeE maybeItem "You need to be a collaborator in the Project to invite people"
grantHash <- encodeKeyHashid grantID
let uCap = encodeRouteHome $ ProjectOutboxItemR projectHash grantHash
(localRecips, remoteRecips, fwdHosts, action) <-
C.makeServerInput (Just uCap) maybeSummary audience $ AP.InviteActivity invite
let cap =
Left (LocalActorProject projectID, LocalActorProject projectHash, grantID)
handleViaActor
personID (Just cap) localRecips remoteRecips fwdHosts action
case result of
Left e -> do
setMessage $ toHtml e
redirect $ ProjectInviteR projectHash
Right inviteID -> do
setMessage "Invite sent"
redirect $ ProjectCollabsR projectHash
postProjectRemoveR :: KeyHashid Project -> CollabTopicProjectId -> Handler Html
postProjectRemoveR projectHash ctID = do
projectID <- decodeKeyHashid404 projectHash
personEntity@(Entity personID person) <- requireAuth
personHash <- encodeKeyHashid personID
encodeRouteHome <- getEncodeRouteHome
result <- runExceptT $ do
mpidOrU <- lift $ runDB $ runMaybeT $ do
CollabTopicProject collabID projectID' <- MaybeT $ get ctID
guard $ projectID' == projectID
_ <- MaybeT $ getBy $ UniqueCollabEnable collabID
member <-
Left <$> MaybeT (getValBy $ UniqueCollabRecipLocal collabID) <|>
Right <$> MaybeT (getValBy $ UniqueCollabRecipRemote collabID)
lift $
bitraverse
(pure . collabRecipLocalPerson)
(getRemoteActorURI <=< getJust . collabRecipRemoteActor)
member
pidOrU <- maybe notFound pure mpidOrU
(maybeSummary, audience, remove) <- do
uRecipient <-
case pidOrU of
Left pid -> encodeRouteHome . PersonR <$> encodeKeyHashid pid
Right u -> pure u
let uResource = encodeRouteHome $ ProjectR projectHash
C.remove personID uRecipient uResource
grantID <- do
maybeItem <- lift $ runDB $ getGrant CollabTopicProjectCollab CollabTopicProjectProject projectID personID
fromMaybeE maybeItem "You need to be a collaborator in the Project to remove people"
grantHash <- encodeKeyHashid grantID
let uCap = encodeRouteHome $ ProjectOutboxItemR projectHash grantHash
(localRecips, remoteRecips, fwdHosts, action) <-
C.makeServerInput (Just uCap) maybeSummary audience $ AP.RemoveActivity remove
let cap =
Left (LocalActorProject projectID, LocalActorProject projectHash, grantID)
handleViaActor
personID (Just cap) localRecips remoteRecips fwdHosts action
case result of
Left e -> do
setMessage $ toHtml e
Right removeID ->
setMessage "Remove sent"
redirect $ ProjectCollabsR projectHash

View file

@ -100,6 +100,10 @@ instance Hashable LoomId where
hashWithSalt salt = hashWithSalt salt . fromSqlKey hashWithSalt salt = hashWithSalt salt . fromSqlKey
hash = hash . fromSqlKey hash = hash . fromSqlKey
instance Hashable ProjectId where
hashWithSalt salt = hashWithSalt salt . fromSqlKey
hash = hash . fromSqlKey
{- {-
instance PersistEntityGraph Ticket TicketDependency where instance PersistEntityGraph Ticket TicketDependency where
sourceParam = ticketDependencyParent sourceParam = ticketDependencyParent

View file

@ -81,14 +81,16 @@ getLocalActorEnt actorID = do
mr <- getBy $ UniqueRepoActor actorID mr <- getBy $ UniqueRepoActor actorID
md <- getBy $ UniqueDeckActor actorID md <- getBy $ UniqueDeckActor actorID
ml <- getBy $ UniqueLoomActor actorID ml <- getBy $ UniqueLoomActor actorID
mj <- getBy $ UniqueProjectActor actorID
return $ return $
case (mp, mg, mr, md, ml) of case (mp, mg, mr, md, ml, mj) of
(Nothing, Nothing, Nothing, Nothing, Nothing) -> error "Unused ActorId" (Nothing, Nothing, Nothing, Nothing, Nothing, Nothing) -> error "Unused ActorId"
(Just p, Nothing, Nothing, Nothing, Nothing) -> LocalActorPerson p (Just p, Nothing, Nothing, Nothing, Nothing, Nothing) -> LocalActorPerson p
(Nothing, Just g, Nothing, Nothing, Nothing) -> LocalActorGroup g (Nothing, Just g, Nothing, Nothing, Nothing, Nothing) -> LocalActorGroup g
(Nothing, Nothing, Just r, Nothing, Nothing) -> LocalActorRepo r (Nothing, Nothing, Just r, Nothing, Nothing, Nothing) -> LocalActorRepo r
(Nothing, Nothing, Nothing, Just d, Nothing) -> LocalActorDeck d (Nothing, Nothing, Nothing, Just d, Nothing, Nothing) -> LocalActorDeck d
(Nothing, Nothing, Nothing, Nothing, Just l) -> LocalActorLoom l (Nothing, Nothing, Nothing, Nothing, Just l, Nothing) -> LocalActorLoom l
(Nothing, Nothing, Nothing, Nothing, Nothing, Just j) -> LocalActorProject j
_ -> error "Multi-usage of an ActorId" _ -> error "Multi-usage of an ActorId"
getLocalActorEntity getLocalActorEntity
@ -105,6 +107,8 @@ getLocalActorEntity (LocalActorDeck d) =
fmap (LocalActorDeck . Entity d) <$> get d fmap (LocalActorDeck . Entity d) <$> get d
getLocalActorEntity (LocalActorLoom l) = getLocalActorEntity (LocalActorLoom l) =
fmap (LocalActorLoom . Entity l) <$> get l fmap (LocalActorLoom . Entity l) <$> get l
getLocalActorEntity (LocalActorProject r) =
fmap (LocalActorProject . Entity r) <$> get r
verifyLocalActivityExistsInDB verifyLocalActivityExistsInDB
:: MonadIO m :: MonadIO m

View file

@ -63,15 +63,18 @@ getCollabTopic collabID = do
maybeRepo <- getValBy $ UniqueCollabTopicRepo collabID maybeRepo <- getValBy $ UniqueCollabTopicRepo collabID
maybeDeck <- getValBy $ UniqueCollabTopicDeck collabID maybeDeck <- getValBy $ UniqueCollabTopicDeck collabID
maybeLoom <- getValBy $ UniqueCollabTopicLoom collabID maybeLoom <- getValBy $ UniqueCollabTopicLoom collabID
maybeProject <- getValBy $ UniqueCollabTopicProject collabID
return $ return $
case (maybeRepo, maybeDeck, maybeLoom) of case (maybeRepo, maybeDeck, maybeLoom, maybeProject) of
(Nothing, Nothing, Nothing) -> error "Found Collab without topic" (Nothing, Nothing, Nothing, Nothing) -> error "Found Collab without topic"
(Just r, Nothing, Nothing) -> (Just r, Nothing, Nothing, Nothing) ->
GrantResourceRepo $ collabTopicRepoRepo r GrantResourceRepo $ collabTopicRepoRepo r
(Nothing, Just d, Nothing) -> (Nothing, Just d, Nothing, Nothing) ->
GrantResourceDeck $ collabTopicDeckDeck d GrantResourceDeck $ collabTopicDeckDeck d
(Nothing, Nothing, Just l) -> (Nothing, Nothing, Just l, Nothing) ->
GrantResourceLoom $ collabTopicLoomLoom l GrantResourceLoom $ collabTopicLoomLoom l
(Nothing, Nothing, Nothing, Just l) ->
GrantResourceProject $ collabTopicProjectProject l
_ -> error "Found Collab with multiple topics" _ -> error "Found Collab with multiple topics"
getCollabTopic' getCollabTopic'
@ -80,15 +83,18 @@ getCollabTopic' collabID = do
maybeRepo <- getBy $ UniqueCollabTopicRepo collabID maybeRepo <- getBy $ UniqueCollabTopicRepo collabID
maybeDeck <- getBy $ UniqueCollabTopicDeck collabID maybeDeck <- getBy $ UniqueCollabTopicDeck collabID
maybeLoom <- getBy $ UniqueCollabTopicLoom collabID maybeLoom <- getBy $ UniqueCollabTopicLoom collabID
maybeProject <- getBy $ UniqueCollabTopicProject collabID
return $ return $
case (maybeRepo, maybeDeck, maybeLoom) of case (maybeRepo, maybeDeck, maybeLoom, maybeProject) of
(Nothing, Nothing, Nothing) -> error "Found Collab without topic" (Nothing, Nothing, Nothing, Nothing) -> error "Found Collab without topic"
(Just (Entity k r), Nothing, Nothing) -> (Just (Entity k r), Nothing, Nothing, Nothing) ->
(delete k, GrantResourceRepo $ collabTopicRepoRepo r) (delete k, GrantResourceRepo $ collabTopicRepoRepo r)
(Nothing, Just (Entity k d), Nothing) -> (Nothing, Just (Entity k d), Nothing, Nothing) ->
(delete k, GrantResourceDeck $ collabTopicDeckDeck d) (delete k, GrantResourceDeck $ collabTopicDeckDeck d)
(Nothing, Nothing, Just (Entity k l)) -> (Nothing, Nothing, Just (Entity k l), Nothing) ->
(delete k, GrantResourceLoom $ collabTopicLoomLoom l) (delete k, GrantResourceLoom $ collabTopicLoomLoom l)
(Nothing, Nothing, Nothing, Just (Entity k l)) ->
(delete k, GrantResourceProject $ collabTopicProjectProject l)
_ -> error "Found Collab with multiple topics" _ -> error "Found Collab with multiple topics"
getGrantRecip (GrantRecipPerson k) e = GrantRecipPerson <$> getEntityE k e getGrantRecip (GrantRecipPerson k) e = GrantRecipPerson <$> getEntityE k e
@ -284,19 +290,7 @@ verifyCapability (capActor, capItem) actor resource requiredRole = do
throwE "Collab recipient is someone else" throwE "Collab recipient is someone else"
-- Find the local topic, on which this Collab gives access -- Find the local topic, on which this Collab gives access
topic <- lift $ do topic <- lift $ getCollabTopic collabID
maybeRepo <- getValBy $ UniqueCollabTopicRepo collabID
maybeDeck <- getValBy $ UniqueCollabTopicDeck collabID
maybeLoom <- getValBy $ UniqueCollabTopicLoom collabID
case (maybeRepo, maybeDeck, maybeLoom) of
(Nothing, Nothing, Nothing) -> error "Collab without topic"
(Just r, Nothing, Nothing) ->
return $ GrantResourceRepo $ collabTopicRepoRepo r
(Nothing, Just d, Nothing) ->
return $ GrantResourceDeck $ collabTopicDeckDeck d
(Nothing, Nothing, Just l) ->
return $ GrantResourceLoom $ collabTopicLoomLoom l
_ -> error "Collab with multiple topics"
-- Verify that topic is indeed the sender of the Grant -- Verify that topic is indeed the sender of the Grant
unless (grantResourceLocalActor topic == capActor) $ unless (grantResourceLocalActor topic == capActor) $

View file

@ -1,6 +1,7 @@
{- This file is part of Vervis. {- This file is part of Vervis.
- -
- Written in 2016, 2019, 2020, 2022 by fr33domlover <fr33domlover@riseup.net>. - Written in 2016, 2019, 2020, 2022, 2023
- by fr33domlover <fr33domlover@riseup.net>.
- -
- Copying is an act of love. Please copy, reuse and share. - Copying is an act of love. Please copy, reuse and share.
- -
@ -92,6 +93,9 @@ getLocalAuthor lmid aid name = do
LocalActorLoom loomID -> do LocalActorLoom loomID -> do
loomHash <- encodeKeyHashid loomID loomHash <- encodeKeyHashid loomID
return $ "+" <> keyHashidText loomHash return $ "+" <> keyHashidText loomHash
LocalActorProject projectID -> do
projectHash <- encodeKeyHashid projectID
return $ "$" <> keyHashidText projectHash
return $ MessageTreeNodeLocal lmid authorByKey code name return $ MessageTreeNodeLocal lmid authorByKey code name
getAllMessages :: AppDB DiscussionId -> Handler [MessageTreeNode] getAllMessages :: AppDB DiscussionId -> Handler [MessageTreeNode]

View file

@ -69,6 +69,7 @@ module Vervis.Recipient
, RepoRoutes (..) , RepoRoutes (..)
, DeckRoutes (..) , DeckRoutes (..)
, LoomRoutes (..) , LoomRoutes (..)
, ProjectRoutes (..)
, DeckFamilyRoutes (..) , DeckFamilyRoutes (..)
, LoomFamilyRoutes (..) , LoomFamilyRoutes (..)
, RecipientRoutes (..) , RecipientRoutes (..)
@ -192,6 +193,7 @@ parseLocalActor (GroupR gkhid) = Just $ LocalActorGroup gkhid
parseLocalActor (RepoR rkhid) = Just $ LocalActorRepo rkhid parseLocalActor (RepoR rkhid) = Just $ LocalActorRepo rkhid
parseLocalActor (DeckR dkhid) = Just $ LocalActorDeck dkhid parseLocalActor (DeckR dkhid) = Just $ LocalActorDeck dkhid
parseLocalActor (LoomR lkhid) = Just $ LocalActorLoom lkhid parseLocalActor (LoomR lkhid) = Just $ LocalActorLoom lkhid
parseLocalActor (ProjectR jkhid) = Just $ LocalActorProject jkhid
parseLocalActor _ = Nothing parseLocalActor _ = Nothing
renderLocalActor :: LocalActor -> Route App renderLocalActor :: LocalActor -> Route App
@ -200,6 +202,7 @@ renderLocalActor (LocalActorGroup gkhid) = GroupR gkhid
renderLocalActor (LocalActorRepo rkhid) = RepoR rkhid renderLocalActor (LocalActorRepo rkhid) = RepoR rkhid
renderLocalActor (LocalActorDeck dkhid) = DeckR dkhid renderLocalActor (LocalActorDeck dkhid) = DeckR dkhid
renderLocalActor (LocalActorLoom lkhid) = LoomR lkhid renderLocalActor (LocalActorLoom lkhid) = LoomR lkhid
renderLocalActor (LocalActorProject jkhid) = ProjectR jkhid
data LocalStageBy f data LocalStageBy f
= LocalStagePersonFollowers (f Person) = LocalStagePersonFollowers (f Person)
@ -213,6 +216,8 @@ data LocalStageBy f
| LocalStageLoomFollowers (f Loom) | LocalStageLoomFollowers (f Loom)
| LocalStageClothFollowers (f Loom) (f TicketLoom) | LocalStageClothFollowers (f Loom) (f TicketLoom)
| LocalStageProjectFollowers (f Project)
deriving (Generic, FunctorB, ConstraintsB) deriving (Generic, FunctorB, ConstraintsB)
deriving instance AllBF Eq f LocalStageBy => Eq (LocalStageBy f) deriving instance AllBF Eq f LocalStageBy => Eq (LocalStageBy f)
@ -235,6 +240,8 @@ parseLocalStage (LoomFollowersR lkhid) =
Just $ LocalStageLoomFollowers lkhid Just $ LocalStageLoomFollowers lkhid
parseLocalStage (ClothFollowersR lkhid ltkhid) = parseLocalStage (ClothFollowersR lkhid ltkhid) =
Just $ LocalStageClothFollowers lkhid ltkhid Just $ LocalStageClothFollowers lkhid ltkhid
parseLocalStage (ProjectFollowersR jkhid) =
Just $ LocalStageProjectFollowers jkhid
parseLocalStage _ = Nothing parseLocalStage _ = Nothing
renderLocalStage :: LocalStage -> Route App renderLocalStage :: LocalStage -> Route App
@ -252,6 +259,8 @@ renderLocalStage (LocalStageLoomFollowers lkhid) =
LoomFollowersR lkhid LoomFollowersR lkhid
renderLocalStage (LocalStageClothFollowers lkhid ltkhid) = renderLocalStage (LocalStageClothFollowers lkhid ltkhid) =
ClothFollowersR lkhid ltkhid ClothFollowersR lkhid ltkhid
renderLocalStage (LocalStageProjectFollowers jkhid) =
ProjectFollowersR jkhid
parseLocalRecipient :: Route App -> Maybe (Either LocalActor LocalStage) parseLocalRecipient :: Route App -> Maybe (Either LocalActor LocalStage)
parseLocalRecipient r = parseLocalRecipient r =
@ -263,6 +272,7 @@ localActorFollowers (LocalActorGroup g) = LocalStageGroupFollowers g
localActorFollowers (LocalActorRepo r) = LocalStageRepoFollowers r localActorFollowers (LocalActorRepo r) = LocalStageRepoFollowers r
localActorFollowers (LocalActorDeck d) = LocalStageDeckFollowers d localActorFollowers (LocalActorDeck d) = LocalStageDeckFollowers d
localActorFollowers (LocalActorLoom l) = LocalStageLoomFollowers l localActorFollowers (LocalActorLoom l) = LocalStageLoomFollowers l
localActorFollowers (LocalActorProject j) = LocalStageProjectFollowers j
------------------------------------------------------------------------------- -------------------------------------------------------------------------------
-- Converting between KeyHashid, Key, Identity and Entity -- Converting between KeyHashid, Key, Identity and Entity
@ -327,6 +337,8 @@ hashLocalStagePure ctx = f
LocalStageClothFollowers LocalStageClothFollowers
(encodeKeyHashidPure ctx l) (encodeKeyHashidPure ctx l)
(encodeKeyHashidPure ctx c) (encodeKeyHashidPure ctx c)
f (LocalStageProjectFollowers j) =
LocalStageProjectFollowers $ encodeKeyHashidPure ctx j
getHashLocalStage getHashLocalStage
:: (MonadSite m, YesodHashids (SiteEnv m)) :: (MonadSite m, YesodHashids (SiteEnv m))
@ -364,6 +376,8 @@ unhashLocalStagePure ctx = f
LocalStageClothFollowers LocalStageClothFollowers
<$> decodeKeyHashidPure ctx l <$> decodeKeyHashidPure ctx l
<*> decodeKeyHashidPure ctx c <*> decodeKeyHashidPure ctx c
f (LocalStageProjectFollowers j) =
LocalStageProjectFollowers <$> decodeKeyHashidPure ctx j
unhashLocalStage unhashLocalStage
:: (MonadSite m, YesodHashids (SiteEnv m)) :: (MonadSite m, YesodHashids (SiteEnv m))
@ -405,6 +419,7 @@ getLocalActorID (LocalActorGroup g) = fmap groupActor <$> get g
getLocalActorID (LocalActorRepo r) = fmap repoActor <$> get r getLocalActorID (LocalActorRepo r) = fmap repoActor <$> get r
getLocalActorID (LocalActorDeck d) = fmap deckActor <$> get d getLocalActorID (LocalActorDeck d) = fmap deckActor <$> get d
getLocalActorID (LocalActorLoom l) = fmap loomActor <$> get l getLocalActorID (LocalActorLoom l) = fmap loomActor <$> get l
getLocalActorID (LocalActorProject j) = fmap projectActor <$> get j
------------------------------------------------------------------------------- -------------------------------------------------------------------------------
-- Intermediate recipient types -- Intermediate recipient types
@ -428,6 +443,8 @@ data LeafDeck = LeafDeck | LeafDeckFollowers deriving (Eq, Ord)
data LeafLoom = LeafLoom | LeafLoomFollowers deriving (Eq, Ord) data LeafLoom = LeafLoom | LeafLoomFollowers deriving (Eq, Ord)
data LeafProject = LeafProject | LeafProjectFollowers deriving (Eq, Ord)
data PieceDeck data PieceDeck
= PieceDeck LeafDeck = PieceDeck LeafDeck
| PieceTicket (KeyHashid TicketDeck) LeafTicket | PieceTicket (KeyHashid TicketDeck) LeafTicket
@ -444,6 +461,7 @@ data LocalRecipient
| RecipRepo (KeyHashid Repo) LeafRepo | RecipRepo (KeyHashid Repo) LeafRepo
| RecipDeck (KeyHashid Deck) PieceDeck | RecipDeck (KeyHashid Deck) PieceDeck
| RecipLoom (KeyHashid Loom) PieceLoom | RecipLoom (KeyHashid Loom) PieceLoom
| RecipProject (KeyHashid Project) LeafProject
deriving (Eq, Ord) deriving (Eq, Ord)
recipientFromActor :: LocalActor -> LocalRecipient recipientFromActor :: LocalActor -> LocalRecipient
@ -457,6 +475,8 @@ recipientFromActor (LocalActorDeck dkhid) =
RecipDeck dkhid $ PieceDeck LeafDeck RecipDeck dkhid $ PieceDeck LeafDeck
recipientFromActor (LocalActorLoom lkhid) = recipientFromActor (LocalActorLoom lkhid) =
RecipLoom lkhid $ PieceLoom LeafLoom RecipLoom lkhid $ PieceLoom LeafLoom
recipientFromActor (LocalActorProject jkhid) =
RecipProject jkhid LeafProject
recipientFromStage :: LocalStage -> LocalRecipient recipientFromStage :: LocalStage -> LocalRecipient
recipientFromStage (LocalStagePersonFollowers pkhid) = recipientFromStage (LocalStagePersonFollowers pkhid) =
@ -473,6 +493,8 @@ recipientFromStage (LocalStageLoomFollowers lkhid) =
RecipLoom lkhid $ PieceLoom LeafLoomFollowers RecipLoom lkhid $ PieceLoom LeafLoomFollowers
recipientFromStage (LocalStageClothFollowers lkhid ltkhid) = recipientFromStage (LocalStageClothFollowers lkhid ltkhid) =
RecipLoom lkhid $ PieceCloth ltkhid LeafClothFollowers RecipLoom lkhid $ PieceCloth ltkhid LeafClothFollowers
recipientFromStage (LocalStageProjectFollowers jkhid) =
RecipProject jkhid LeafProjectFollowers
------------------------------------------------------------------------------- -------------------------------------------------------------------------------
-- Recipient set types -- Recipient set types
@ -493,19 +515,22 @@ groupLocalRecipients = organize . partitionByActor
, [(KeyHashid Repo, LeafRepo)] , [(KeyHashid Repo, LeafRepo)]
, [(KeyHashid Deck, PieceDeck)] , [(KeyHashid Deck, PieceDeck)]
, [(KeyHashid Loom, PieceLoom)] , [(KeyHashid Loom, PieceLoom)]
, [(KeyHashid Project, LeafProject)]
) )
partitionByActor = foldl' f ([], [], [], [], []) partitionByActor = foldl' f ([], [], [], [], [], [])
where where
f (p, g, r, d, l) (RecipPerson pkhid pleaf) = f (p, g, r, d, l, j) (RecipPerson pkhid pleaf) =
((pkhid, pleaf) : p, g, r, d, l) ((pkhid, pleaf) : p, g, r, d, l, j)
f (p, g, r, d, l) (RecipGroup gkhid gleaf) = f (p, g, r, d, l, j) (RecipGroup gkhid gleaf) =
(p, (gkhid, gleaf) : g, r, d, l) (p, (gkhid, gleaf) : g, r, d, l, j)
f (p, g, r, d, l) (RecipRepo rkhid rleaf) = f (p, g, r, d, l, j) (RecipRepo rkhid rleaf) =
(p, g, (rkhid, rleaf) : r, d, l) (p, g, (rkhid, rleaf) : r, d, l, j)
f (p, g, r, d, l) (RecipDeck dkhid dpiece) = f (p, g, r, d, l, j) (RecipDeck dkhid dpiece) =
(p, g, r, (dkhid, dpiece) : d, l) (p, g, r, (dkhid, dpiece) : d, l, j)
f (p, g, r, d, l) (RecipLoom lkhid lpiece) = f (p, g, r, d, l, j) (RecipLoom lkhid lpiece) =
(p, g, r, d, (lkhid, lpiece) : l) (p, g, r, d, (lkhid, lpiece) : l, j)
f (p, g, r, d, l, j) (RecipProject jkhid jleaf) =
(p, g, r, d, l, (jkhid, jleaf) : j)
organize organize
:: ( [(KeyHashid Person, LeafPerson)] :: ( [(KeyHashid Person, LeafPerson)]
@ -513,9 +538,10 @@ groupLocalRecipients = organize . partitionByActor
, [(KeyHashid Repo, LeafRepo)] , [(KeyHashid Repo, LeafRepo)]
, [(KeyHashid Deck, PieceDeck)] , [(KeyHashid Deck, PieceDeck)]
, [(KeyHashid Loom, PieceLoom)] , [(KeyHashid Loom, PieceLoom)]
, [(KeyHashid Project, LeafProject)]
) )
-> RecipientRoutes -> RecipientRoutes
organize (p, g, r, d, l) = RecipientRoutes organize (p, g, r, d, l, j) = RecipientRoutes
{ recipPeople = { recipPeople =
map (second $ foldr orLP $ PersonRoutes False False) $ groupByKeySort p map (second $ foldr orLP $ PersonRoutes False False) $ groupByKeySort p
, recipGroups = , recipGroups =
@ -544,6 +570,8 @@ groupLocalRecipients = organize . partitionByActor
. partitionEithers . NE.toList . NE.map pl2either . partitionEithers . NE.toList . NE.map pl2either
) $ ) $
groupByKeySort l groupByKeySort l
, recipProjects =
map (second $ foldr orLJ $ ProjectRoutes False False) $ groupByKeySort j
} }
where where
groupByKey :: (Foldable f, Eq a) => f (a, b) -> [(a, NonEmpty b)] groupByKey :: (Foldable f, Eq a) => f (a, b) -> [(a, NonEmpty b)]
@ -585,6 +613,11 @@ groupLocalRecipients = organize . partitionByActor
orLC _ cr@(ClothRoutes True) = cr orLC _ cr@(ClothRoutes True) = cr
orLC LeafClothFollowers cr@(ClothRoutes _) = cr { routeClothFollowers = True } orLC LeafClothFollowers cr@(ClothRoutes _) = cr { routeClothFollowers = True }
orLJ :: LeafProject -> ProjectRoutes -> ProjectRoutes
orLJ _ rr@(ProjectRoutes True True) = rr
orLJ LeafProject rr@(ProjectRoutes _ _) = rr { routeProject = True }
orLJ LeafProjectFollowers rr@(ProjectRoutes _ _) = rr { routeProjectFollowers = True }
pd2either :: PieceDeck -> Either LeafDeck (KeyHashid TicketDeck, LeafTicket) pd2either :: PieceDeck -> Either LeafDeck (KeyHashid TicketDeck, LeafTicket)
pd2either (PieceDeck ld) = Left ld pd2either (PieceDeck ld) = Left ld
pd2either (PieceTicket ltkhid lt) = Right (ltkhid, lt) pd2either (PieceTicket ltkhid lt) = Right (ltkhid, lt)
@ -622,6 +655,7 @@ localRecipSieve' sieve allowPeople allowOthers routes = RecipientRoutes
, recipRepos = applySieve' applyRepo recipRepos , recipRepos = applySieve' applyRepo recipRepos
, recipDecks = applySieve' applyDeck recipDecks , recipDecks = applySieve' applyDeck recipDecks
, recipLooms = applySieve' applyLoom recipLooms , recipLooms = applySieve' applyLoom recipLooms
, recipProjects = applySieve' applyProject recipProjects
} }
where where
applySieve applySieve
@ -725,6 +759,17 @@ localRecipSieve' sieve allowPeople allowOthers routes = RecipientRoutes
then Nothing then Nothing
else Just (lkhid, LoomFamilyRoutes loom cloths) else Just (lkhid, LoomFamilyRoutes loom cloths)
applyProject _ (This _) = Nothing
applyProject rkhid (That r) =
if allowOthers && routeProject r
then Just (rkhid, ProjectRoutes True False)
else Nothing
applyProject rkhid (These (ProjectRoutes r' rf') (ProjectRoutes r rf)) =
let merged = ProjectRoutes (r && (r' || allowOthers)) (rf && rf')
in if merged == ProjectRoutes False False
then Nothing
else Just (rkhid, merged)
actorIsAddressed :: RecipientRoutes -> LocalActor -> Bool actorIsAddressed :: RecipientRoutes -> LocalActor -> Bool
actorIsAddressed recips = isJust . verify actorIsAddressed recips = isJust . verify
where where
@ -743,6 +788,9 @@ actorIsAddressed recips = isJust . verify
verify (LocalActorLoom l) = do verify (LocalActorLoom l) = do
routes <- lookup l $ recipLooms recips routes <- lookup l $ recipLooms recips
guard $ routeLoom $ familyLoom routes guard $ routeLoom $ familyLoom routes
verify (LocalActorProject j) = do
routes <- lookup j $ recipProjects recips
guard $ routeProject routes
data ParsedAudience u = ParsedAudience data ParsedAudience u = ParsedAudience
{ paudLocalRecips :: RecipientRoutes { paudLocalRecips :: RecipientRoutes

View file

@ -378,6 +378,8 @@ getLocalActors actorIDs = do
selectKeysList [DeckActor <-. actorIDs] [] selectKeysList [DeckActor <-. actorIDs] []
, map LocalActorLoom <$> , map LocalActorLoom <$>
selectKeysList [LoomActor <-. actorIDs] [] selectKeysList [LoomActor <-. actorIDs] []
, map LocalActorProject <$>
selectKeysList [ProjectActor <-. actorIDs] []
] ]
case compare (length localActors) (length actorIDs) of case compare (length localActors) (length actorIDs) of
LT -> error "Found actor ID not used by any specific actor" LT -> error "Found actor ID not used by any specific actor"

View file

@ -1,6 +1,6 @@
{- This file is part of Vervis. {- This file is part of Vervis.
- -
- Written in 2019, 2022 by fr33domlover <fr33domlover@riseup.net>. - Written in 2019, 2022, 2023 by fr33domlover <fr33domlover@riseup.net>.
- -
- Copying is an act of love. Please copy, reuse and share. - Copying is an act of love. Please copy, reuse and share.
- -
@ -16,6 +16,7 @@
module Vervis.Widget.Tracker module Vervis.Widget.Tracker
( deckNavW ( deckNavW
, loomNavW , loomNavW
, projectNavW
) )
where where
@ -38,3 +39,8 @@ loomNavW (Entity loomID loom) actor = do
loomHash <- encodeKeyHashid loomID loomHash <- encodeKeyHashid loomID
hashRepo <- getEncodeKeyHashid hashRepo <- getEncodeKeyHashid
$(widgetFile "loom/widget/nav") $(widgetFile "loom/widget/nav")
projectNavW :: Entity Project -> Actor -> Widget
projectNavW (Entity projectID project) actor = do
projectHash <- encodeKeyHashid projectID
$(widgetFile "project/widget/nav")

View file

@ -1715,6 +1715,7 @@ data CreateObject u
| CreateTicketTracker ActorDetail (Maybe (Authority u, ActorLocal u)) | CreateTicketTracker ActorDetail (Maybe (Authority u, ActorLocal u))
| CreateRepository ActorDetail VersionControlSystem (Maybe (Authority u, ActorLocal u)) | CreateRepository ActorDetail VersionControlSystem (Maybe (Authority u, ActorLocal u))
| CreatePatchTracker ActorDetail (NonEmpty (ObjURI u)) (Maybe (Authority u, ActorLocal u)) | CreatePatchTracker ActorDetail (NonEmpty (ObjURI u)) (Maybe (Authority u, ActorLocal u))
| CreateProject ActorDetail (Maybe (Authority u, ActorLocal u))
parseCreateObject :: UriMode u => Object -> Parser (CreateObject u) parseCreateObject :: UriMode u => Object -> Parser (CreateObject u)
parseCreateObject o parseCreateObject o
@ -1737,6 +1738,11 @@ parseCreateObject o
repos <- o .:*+ "tracksPatchesFor" repos <- o .:*+ "tracksPatchesFor"
ml <- parseActorLocal o ml <- parseActorLocal o
return $ CreatePatchTracker d repos ml return $ CreatePatchTracker d repos ml
<|> do d <- parseActorDetail o
unless (actorType d == ActorTypeProject) $
fail "type isn't Project"
ml <- parseActorLocal o
return $ CreateProject d ml
encodeCreateObject :: UriMode u => CreateObject u -> Series encodeCreateObject :: UriMode u => CreateObject u -> Series
encodeCreateObject (CreateNote h note) = toSeries h note encodeCreateObject (CreateNote h note) = toSeries h note
@ -1751,6 +1757,8 @@ encodeCreateObject (CreatePatchTracker d repos ml)
= encodeActorDetail d = encodeActorDetail d
<> "tracksPatchesFor" .=*+ repos <> "tracksPatchesFor" .=*+ repos
<> maybe mempty (uncurry encodeActorLocal) ml <> maybe mempty (uncurry encodeActorLocal) ml
encodeCreateObject (CreateProject d ml) =
encodeActorDetail d <> maybe mempty (uncurry encodeActorLocal) ml
data Create u = Create data Create u = Create
{ createObject :: CreateObject u { createObject :: CreateObject u
@ -1770,6 +1778,7 @@ parseCreate o a luActor = do
CreateTicketTracker _ _ -> return () CreateTicketTracker _ _ -> return ()
CreateRepository _ _ _ -> return () CreateRepository _ _ _ -> return ()
CreatePatchTracker _ _ _ -> return () CreatePatchTracker _ _ _ -> return ()
CreateProject _ _ -> return ()
Create obj <$> o .:? "target" Create obj <$> o .:? "target"
encodeCreate :: UriMode u => Create u -> Series encodeCreate :: UriMode u => Create u -> Series

View file

@ -1,6 +1,7 @@
$# This file is part of Vervis. $# This file is part of Vervis.
$# $#
$# Written in 2016, 2018, 2019, 2022 by fr33domlover <fr33domlover@riseup.net>. $# Written in 2016, 2018, 2019, 2022, 2023
$# by fr33domlover <fr33domlover@riseup.net>.
$# $#
$# ♡ Copying is an act of love. Please copy, reuse and share. $# ♡ Copying is an act of love. Please copy, reuse and share.
$# $#
@ -96,3 +97,12 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
<li> <li>
<a href=@{LoomR $ hashLoom loomID}> <a href=@{LoomR $ hashLoom loomID}>
+#{keyHashidText $ hashLoom loomID} #{actorName actor} +#{keyHashidText $ hashLoom loomID} #{actorName actor}
<h2>Projects
<ul>
$forall (Entity projectID _, Entity _ actor) <- projects
<li>
<a href=@{ProjectR $ hashProject projectID}>
$#{keyHashidText $ hashProject projectID} #{actorName actor}
$# #{abcde}

View file

@ -33,6 +33,9 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
<li> <li>
<a href=@{LoomNewR}> <a href=@{LoomNewR}>
Create a new patch tracker Create a new patch tracker
<li>
<a href=@{ProjectNewR}>
Create a new project
<li> <li>
<a href=@{PublishOfferMergeR}> <a href=@{PublishOfferMergeR}>
Open a merge request Open a merge request
@ -85,3 +88,14 @@ $# Comment on a ticket or merge request
] ]
<a href=@{LoomR $ hashLoom loomID}> <a href=@{LoomR $ hashLoom loomID}>
+#{keyHashidText $ hashLoom loomID} #{actorName actor} +#{keyHashidText $ hashLoom loomID} #{actorName actor}
<h2>Your projects
<ul>
$forall (Entity projectID _, Entity _ actor, Entity _ (Collab role)) <- projects
<li>
[
#{show role}
]
<a href=@{ProjectR $ hashProject projectID}>
$#{keyHashidText $ hashProject projectID} #{actorName actor}

View file

@ -0,0 +1,59 @@
$# 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>Collaborators
<table>
<tr>
<th>Role
<th>Collaborator
<th>Since
$forall (person, role, ctID, since) <- collabs
<tr>
<td>#{show role}
<td>^{personLinkFedW person}
<td>#{showDate since}
<td>^{buttonW POST "Remove" (ProjectRemoveR projectHash ctID)}
<h2>Invites
<table>
<tr>
<th>Inviter
<th>Invitee
<th>Role
<th>Time
$forall (inviter, invitee, time, role) <- invites
<tr>
<td>^{personLinkFedW inviter}
<td>^{personLinkFedW invitee}
<td>#{show role}
<td>#{showDate time}
<a href=@{ProjectInviteR projectHash}>Invite…
<h2>Joins
<table>
<tr>
<th>Joiner
<th>Role
<th>Time
$forall (joiner, time, role) <- joins
<tr>
<td>^{personLinkFedW joiner}
<td>#{show role}
<td>#{showDate time}

View file

@ -0,0 +1,18 @@
$# This file is part of Vervis.
$#
$# Written in 2016, 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/>.
<form method=POST action=@{ProjectInviteR projectHash} enctype=#{enctype}>
^{widget}
<div class="submit">
<input type="submit">

View file

@ -0,0 +1,18 @@
$# This file is part of Vervis.
$#
$# Written in 2016, 2022 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/>.
<form method=POST action=@{ProjectNewR} enctype=#{enctype}>
^{widget}
<div class="submit">
<input type="submit">

View file

@ -0,0 +1,36 @@
$# This file is part of Vervis.
$#
$# Written in 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/>.
<div>
<span>
[[ 🏗
<a href=@{ProjectR projectHash}>
$#{keyHashidText projectHash} #{actorName actor}
]] ::
<span>
<a href=@{ProjectInboxR projectHash}>
[📥 Inbox]
<span>
<a href=@{ProjectOutboxR projectHash}>
[📤 Outbox]
<span>
<a href=@{ProjectFollowersR projectHash}>
[🐤 Followers]
<span>
<a href=@{ProjectCollabsR projectHash}>
[🤝 Collaborators]
<span>
[No wiki]
<span>
[✏ Edit]

View file

@ -647,13 +647,6 @@ CollabRecipRemoteJoin
-------------------------------- Collab topic -------------------------------- -------------------------------- Collab topic --------------------------------
-- Removed for now, until I figure out whether/how to federate custom roles
--CollabRoleLocal
-- collab CollabId
-- role RoleId
--
-- UniqueCollabRoleLocal collab
CollabTopicRepo CollabTopicRepo
collab CollabId collab CollabId
repo RepoId repo RepoId
@ -672,6 +665,12 @@ CollabTopicLoom
UniqueCollabTopicLoom collab UniqueCollabTopicLoom collab
CollabTopicProject
collab CollabId
project ProjectId
UniqueCollabTopicProject collab
CollabEnable CollabEnable
collab CollabId collab CollabId
grant OutboxItemId grant OutboxItemId

View file

@ -304,3 +304,21 @@
-- /looms/#LoomKeyHashid/cloths/#TicketLoomKeyHashid/new-dep ClothDepNewR GET POST -- /looms/#LoomKeyHashid/cloths/#TicketLoomKeyHashid/new-dep ClothDepNewR GET POST
-- /looms/#LoomKeyHashid/cloths/#TicketLoomKeyHashid/deps/#TicketDepKeyHashid/delete ClothDepDeleteR POST -- /looms/#LoomKeyHashid/cloths/#TicketLoomKeyHashid/deps/#TicketDepKeyHashid/delete ClothDepDeleteR POST
---- Project -----------------------------------------------------------------
/projects/#ProjectKeyHashid ProjectR GET
/projects/#ProjectKeyHashid/inbox ProjectInboxR GET POST
/projects/#ProjectKeyHashid/outbox ProjectOutboxR GET
/projects/#ProjectKeyHashid/outbox/#OutboxItemKeyHashid ProjectOutboxItemR GET
/projects/#ProjectKeyHashid/followers ProjectFollowersR GET
/projects/#ProjectKeyHashid/messages/#LocalMessageKeyHashid ProjectMessageR GET
/new-project ProjectNewR GET POST
/projects/#ProjectKeyHashid/stamps/#SigKeyKeyHashid ProjectStampR GET
/projects/#ProjectKeyHashid/collabs ProjectCollabsR GET
/projects/#ProjectKeyHashid/invite ProjectInviteR GET POST
/projects/#ProjectKeyHashid/remove/#CollabTopicProjectId ProjectRemoveR POST

View file

@ -149,6 +149,7 @@ library
Vervis.Actor.Loom Vervis.Actor.Loom
Vervis.Actor.Person Vervis.Actor.Person
Vervis.Actor.Person.Client Vervis.Actor.Person.Client
Vervis.Actor.Project
Vervis.Actor.Repo Vervis.Actor.Repo
Vervis.API Vervis.API
Vervis.Avatar Vervis.Avatar
@ -210,6 +211,7 @@ library
Vervis.Handler.Person Vervis.Handler.Person
Vervis.Handler.Repo Vervis.Handler.Repo
--Vervis.Handler.Role --Vervis.Handler.Role
Vervis.Handler.Project
--Vervis.Handler.Sharer --Vervis.Handler.Sharer
Vervis.Handler.Ticket Vervis.Handler.Ticket
-- Vervis.Handler.Wiki -- Vervis.Handler.Wiki