From 372fd35f2c339aa830f7e48b8379a5d47724a3b0 Mon Sep 17 00:00:00 2001 From: Pere Lev Date: Mon, 26 Jun 2023 22:02:54 +0300 Subject: [PATCH] Project routes, handlers and creation UI --- migrations/541_2023-06-26_project.model | 6 + src/Vervis/API.hs | 4 + src/Vervis/Actor.hs | 70 +++-- src/Vervis/Actor/Person/Client.hs | 7 + src/Vervis/Actor/Project.hs | 62 +++++ src/Vervis/Application.hs | 3 + src/Vervis/Client.hs | 26 ++ src/Vervis/Data/Actor.hs | 5 + src/Vervis/Data/Collab.hs | 19 +- src/Vervis/Data/Discussion.hs | 1 + src/Vervis/Form/Tracker.hs | 46 ++++ src/Vervis/Foundation.hs | 18 ++ src/Vervis/Handler/Client.hs | 23 +- src/Vervis/Handler/Project.hs | 332 ++++++++++++++++++++++++ src/Vervis/Model.hs | 4 + src/Vervis/Persist/Actor.hs | 18 +- src/Vervis/Persist/Collab.hs | 40 ++- src/Vervis/Persist/Discussion.hs | 6 +- src/Vervis/Recipient.hs | 72 ++++- src/Vervis/Web/Actor.hs | 2 + src/Vervis/Widget/Tracker.hs | 8 +- src/Web/ActivityPub.hs | 9 + templates/browse.hamlet | 12 +- templates/personal-overview.hamlet | 14 + templates/project/collab/list.hamlet | 59 +++++ templates/project/collab/new.hamlet | 18 ++ templates/project/new.hamlet | 18 ++ templates/project/widget/nav.hamlet | 36 +++ th/models | 13 +- th/routes | 18 ++ vervis.cabal | 2 + 31 files changed, 885 insertions(+), 86 deletions(-) create mode 100644 src/Vervis/Actor/Project.hs create mode 100644 src/Vervis/Handler/Project.hs create mode 100644 templates/project/collab/list.hamlet create mode 100644 templates/project/collab/new.hamlet create mode 100644 templates/project/new.hamlet create mode 100644 templates/project/widget/nav.hamlet diff --git a/migrations/541_2023-06-26_project.model b/migrations/541_2023-06-26_project.model index 833f061..2eb8824 100644 --- a/migrations/541_2023-06-26_project.model +++ b/migrations/541_2023-06-26_project.model @@ -4,3 +4,9 @@ Project UniqueProjectActor actor UniqueProjectCreate create + +CollabTopicProject + collab CollabId + project ProjectId + + UniqueCollabTopicProject collab diff --git a/src/Vervis/API.hs b/src/Vervis/API.hs index ba2885c..22f10f0 100644 --- a/src/Vervis/API.hs +++ b/src/Vervis/API.hs @@ -173,6 +173,9 @@ verifyResourceAddressed localRecips resource = do verify (GrantResourceLoom l) = do routes <- lookup l $ recipLooms localRecips guard $ routeLoom $ familyLoom routes + verify (GrantResourceProject r) = do + routes <- lookup r $ recipProjects localRecips + guard $ routeProject routes verifyRemoteAddressed :: 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 (LocalActorDeck d) = DeckOutboxItemR d actorOutboxItem (LocalActorLoom l) = LoomOutboxItemR l +actorOutboxItem (LocalActorProject l) = ProjectOutboxItemR l offerDepC :: Entity Person diff --git a/src/Vervis/Actor.hs b/src/Vervis/Actor.hs index a78cd47..a803485 100644 --- a/src/Vervis/Actor.hs +++ b/src/Vervis/Actor.hs @@ -48,6 +48,7 @@ module Vervis.Actor , RepoRoutes (..) , DeckRoutes (..) , LoomRoutes (..) + , ProjectRoutes (..) , DeckFamilyRoutes (..) , LoomFamilyRoutes (..) , RecipientRoutes (..) @@ -133,11 +134,12 @@ import Vervis.RemoteActorStore.Types import Vervis.Settings data LocalActorBy f - = LocalActorPerson (f Person) - | LocalActorGroup (f Group) - | LocalActorRepo (f Repo) - | LocalActorDeck (f Deck) - | LocalActorLoom (f Loom) + = LocalActorPerson (f Person) + | LocalActorGroup (f Group) + | LocalActorRepo (f Repo) + | LocalActorDeck (f Deck) + | LocalActorLoom (f Loom) + | LocalActorProject (f Project) deriving (Generic, FunctorB, ConstraintsB) deriving instance AllBF Eq f LocalActorBy => Eq (LocalActorBy f) @@ -151,11 +153,12 @@ hashLocalActorPure :: HashidsContext -> LocalActorBy Key -> LocalActorBy KeyHashid hashLocalActorPure ctx = f where - f (LocalActorPerson p) = LocalActorPerson $ encodeKeyHashidPure ctx p - f (LocalActorGroup g) = LocalActorGroup $ encodeKeyHashidPure ctx g - f (LocalActorRepo r) = LocalActorRepo $ encodeKeyHashidPure ctx r - f (LocalActorDeck d) = LocalActorDeck $ encodeKeyHashidPure ctx d - f (LocalActorLoom l) = LocalActorLoom $ encodeKeyHashidPure ctx l + f (LocalActorPerson p) = LocalActorPerson $ encodeKeyHashidPure ctx p + f (LocalActorGroup g) = LocalActorGroup $ encodeKeyHashidPure ctx g + f (LocalActorRepo r) = LocalActorRepo $ encodeKeyHashidPure ctx r + f (LocalActorDeck d) = LocalActorDeck $ encodeKeyHashidPure ctx d + f (LocalActorLoom l) = LocalActorLoom $ encodeKeyHashidPure ctx l + f (LocalActorProject j) = LocalActorProject $ encodeKeyHashidPure ctx j getHashLocalActor :: (MonadActor m, StageHashids (ActorEnv m)) @@ -175,11 +178,12 @@ unhashLocalActorPure :: HashidsContext -> LocalActorBy KeyHashid -> Maybe (LocalActorBy Key) unhashLocalActorPure ctx = f where - f (LocalActorPerson p) = LocalActorPerson <$> decodeKeyHashidPure ctx p - f (LocalActorGroup g) = LocalActorGroup <$> decodeKeyHashidPure ctx g - f (LocalActorRepo r) = LocalActorRepo <$> decodeKeyHashidPure ctx r - f (LocalActorDeck d) = LocalActorDeck <$> decodeKeyHashidPure ctx d - f (LocalActorLoom l) = LocalActorLoom <$> decodeKeyHashidPure ctx l + f (LocalActorPerson p) = LocalActorPerson <$> decodeKeyHashidPure ctx p + f (LocalActorGroup g) = LocalActorGroup <$> decodeKeyHashidPure ctx g + f (LocalActorRepo r) = LocalActorRepo <$> decodeKeyHashidPure ctx r + f (LocalActorDeck d) = LocalActorDeck <$> decodeKeyHashidPure ctx d + f (LocalActorLoom l) = LocalActorLoom <$> decodeKeyHashidPure ctx l + f (LocalActorProject j) = LocalActorProject <$> decodeKeyHashidPure ctx j unhashLocalActor :: (MonadActor m, StageHashids (ActorEnv m)) @@ -258,6 +262,12 @@ data LoomRoutes = LoomRoutes } deriving Eq +data ProjectRoutes = ProjectRoutes + { routeProject :: Bool + , routeProjectFollowers :: Bool + } + deriving Eq + data DeckFamilyRoutes = DeckFamilyRoutes { familyDeck :: DeckRoutes , familyTickets :: [(KeyHashid TicketDeck, TicketRoutes)] @@ -271,11 +281,12 @@ data LoomFamilyRoutes = LoomFamilyRoutes deriving Eq data RecipientRoutes = RecipientRoutes - { recipPeople :: [(KeyHashid Person, PersonRoutes)] - , recipGroups :: [(KeyHashid Group , GroupRoutes)] - , recipRepos :: [(KeyHashid Repo , RepoRoutes)] - , recipDecks :: [(KeyHashid Deck , DeckFamilyRoutes)] - , recipLooms :: [(KeyHashid Loom , LoomFamilyRoutes)] + { recipPeople :: [(KeyHashid Person , PersonRoutes)] + , recipGroups :: [(KeyHashid Group , GroupRoutes)] + , recipRepos :: [(KeyHashid Repo , RepoRoutes)] + , recipDecks :: [(KeyHashid Deck , DeckFamilyRoutes)] + , recipLooms :: [(KeyHashid Loom , LoomFamilyRoutes)] + , recipProjects :: [(KeyHashid Project, ProjectRoutes)] } deriving Eq @@ -346,7 +357,6 @@ data Env = forall y. (Typeable y, Yesod y) => Env , envHashidsContext :: HashidsContext , envActorKeys :: Maybe (TVar (ActorKey, ActorKey, Bool)) , envDeliveryTheater :: DeliveryTheater URIMode - --, envYesodSite :: y , envYesodRender :: YesodRender y , envHttpManager :: Manager , envFetch :: ActorFetchShare @@ -469,6 +479,7 @@ sendToLocalActors authorAndId body requireOwner mauthor maidAuthor recips = do looms <- unhashKeys $ recipLooms recips for looms $ \ (loomID, (LoomFamilyRoutes loom cloths)) -> (loomID,) . (loom,) <$> unhashKeys cloths + projects <- unhashKeys $ recipProjects recips -- Grab local actor sets whose stages are allowed for delivery let allowStages' @@ -489,6 +500,8 @@ sendToLocalActors authorAndId body requireOwner mauthor maidAuthor recips = do filter (allowStages' fst routeDeck LocalActorDeck) decksAndTickets loomsAndClothsForStages = filter (allowStages' fst routeLoom LocalActorLoom) loomsAndCloths + projectsForStages = + filter (allowStages' id routeProject LocalActorProject) projects -- Grab local actors being addressed let localActorsForSelf = concat @@ -497,6 +510,7 @@ sendToLocalActors authorAndId body requireOwner mauthor maidAuthor recips = do , [ LocalActorRepo key | (key, routes) <- repos, routeRepo routes ] , [ LocalActorDeck key | (key, (routes, _)) <- decksAndTickets, routeDeck 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 @@ -510,6 +524,8 @@ sendToLocalActors authorAndId body requireOwner mauthor maidAuthor recips = do [ key | (key, (routes, _)) <- decksAndTicketsForStages, routeDeckFollowers routes ] loomIDsForFollowers = [ 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 let ticketSetsForFollowers = @@ -540,6 +556,7 @@ sendToLocalActors authorAndId body requireOwner mauthor maidAuthor recips = do , selectActorIDs repoActor repoIDsForFollowers , selectActorIDs deckActor deckIDsForFollowers , selectActorIDs loomActor loomIDsForFollowers + , selectActorIDs projectActor projectIDsForFollowers ] ticketIDs <- concat <$> @@ -561,11 +578,12 @@ sendToLocalActors authorAndId body requireOwner mauthor maidAuthor recips = do -- Get the local and remote followers of the follower sets from DB locals <- concat <$> sequenceA - [ selectFollowers LocalActorPerson PersonActor followerSetIDs - , selectFollowers LocalActorGroup GroupActor followerSetIDs - , selectFollowers LocalActorRepo RepoActor followerSetIDs - , selectFollowers LocalActorDeck DeckActor followerSetIDs - , selectFollowers LocalActorLoom LoomActor followerSetIDs + [ selectFollowers LocalActorPerson PersonActor followerSetIDs + , selectFollowers LocalActorGroup GroupActor followerSetIDs + , selectFollowers LocalActorRepo RepoActor followerSetIDs + , selectFollowers LocalActorDeck DeckActor followerSetIDs + , selectFollowers LocalActorLoom LoomActor followerSetIDs + , selectFollowers LocalActorProject ProjectActor followerSetIDs ] remotes <- getRemoteFollowers followerSetIDs return (locals, remotes) diff --git a/src/Vervis/Actor/Person/Client.hs b/src/Vervis/Actor/Person/Client.hs index 3cdd7a9..bc7d828 100644 --- a/src/Vervis/Actor/Person/Client.hs +++ b/src/Vervis/Actor/Person/Client.hs @@ -92,6 +92,9 @@ verifyResourceAddressed localRecips resource = do verify (GrantResourceLoom l) = do routes <- lookup l $ recipLooms localRecips guard $ routeLoom $ familyLoom routes + verify (GrantResourceProject r) = do + routes <- lookup r $ recipProjects localRecips + guard $ routeProject routes verifyRecipientAddressed localRecips recipient = do recipientHash <- hashGrantRecip recipient @@ -384,6 +387,7 @@ clientInvite now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHost Left (GrantResourceRepo r) -> Just $ LocalActorRepo r Left (GrantResourceDeck d) -> Just $ LocalActorDeck d Left (GrantResourceLoom l) -> Just $ LocalActorLoom l + Left (GrantResourceProject l) -> Just $ LocalActorProject l Right _ -> Nothing , case recipientHash of 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 (GrantResourceDeck d) -> Just $ LocalStageDeckFollowers d Left (GrantResourceLoom l) -> Just $ LocalStageLoomFollowers l + Left (GrantResourceProject l) -> Just $ LocalStageProjectFollowers l Right _ -> Nothing , case recipientHash of 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 (GrantResourceDeck d) -> Just $ LocalActorDeck d Left (GrantResourceLoom l) -> Just $ LocalActorLoom l + Left (GrantResourceProject l) -> Just $ LocalActorProject l Right _ -> Nothing , case recipientHash of 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 (GrantResourceDeck d) -> Just $ LocalStageDeckFollowers d Left (GrantResourceLoom l) -> Just $ LocalStageLoomFollowers l + Left (GrantResourceProject l) -> Just $ LocalStageProjectFollowers l Right _ -> Nothing , case recipientHash of Left (GrantRecipPerson p) -> Just $ LocalStagePersonFollowers p diff --git a/src/Vervis/Actor/Project.hs b/src/Vervis/Actor/Project.hs new file mode 100644 index 0000000..ee5d7f2 --- /dev/null +++ b/src/Vervis/Actor/Project.hs @@ -0,0 +1,62 @@ +{- This file is part of Vervis. + - + - Written in 2023 by fr33domlover . + - + - ♡ 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 + - . + -} + +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 diff --git a/src/Vervis/Application.hs b/src/Vervis/Application.hs index 4389150..976ac0c 100644 --- a/src/Vervis/Application.hs +++ b/src/Vervis/Application.hs @@ -110,6 +110,7 @@ import Vervis.Actor.Deck import Vervis.Actor.Group import Vervis.Actor.Loom import Vervis.Actor.Person +import Vervis.Actor.Project import Vervis.Actor.Repo import Vervis.Darcs import Vervis.Data.Actor @@ -130,6 +131,7 @@ import Vervis.Handler.Group import Vervis.Handler.Key import Vervis.Handler.Loom import Vervis.Handler.Person +import Vervis.Handler.Project import Vervis.Handler.Repo --import Vervis.Handler.Role --import Vervis.Handler.Sharer @@ -349,6 +351,7 @@ makeFoundation appSettings = do , selectAll LocalActorRepo , selectAll LocalActorDeck , selectAll LocalActorLoom + , selectAll LocalActorProject ] where selectAll diff --git a/src/Vervis/Client.hs b/src/Vervis/Client.hs index 921b520..df638fa 100644 --- a/src/Vervis/Client.hs +++ b/src/Vervis/Client.hs @@ -37,6 +37,7 @@ module Vervis.Client , createDeck , createLoom , createRepo + , createProject , invite , remove ) @@ -949,6 +950,27 @@ createRepo senderHash name desc = do 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 :: PersonId -> FedURI @@ -1012,6 +1034,8 @@ invite personID uRecipient uResource role = do AudLocal [LocalActorDeck d] [LocalStageDeckFollowers d] Left (GrantResourceLoom l) -> AudLocal [LocalActorLoom l] [LocalStageLoomFollowers l] + Left (GrantResourceProject l) -> + AudLocal [LocalActorProject l] [LocalStageProjectFollowers l] Right (remoteActor, ObjURI h lu) -> AudRemote h [lu] @@ -1093,6 +1117,8 @@ remove personID uRecipient uResource = do AudLocal [LocalActorDeck d] [LocalStageDeckFollowers d] Left (GrantResourceLoom l) -> AudLocal [LocalActorLoom l] [LocalStageLoomFollowers l] + Left (GrantResourceProject l) -> + AudLocal [LocalActorProject l] [LocalStageProjectFollowers l] Right (remoteActor, ObjURI h lu) -> AudRemote h [lu] diff --git a/src/Vervis/Data/Actor.hs b/src/Vervis/Data/Actor.hs index 9bd298e..b3fb7e5 100644 --- a/src/Vervis/Data/Actor.hs +++ b/src/Vervis/Data/Actor.hs @@ -80,6 +80,7 @@ parseLocalActivityURI luAct = do parseOutboxItemRoute (RepoOutboxItemR r i) = Just (LocalActorRepo r, i) parseOutboxItemRoute (DeckOutboxItemR d i) = Just (LocalActorDeck d, i) parseOutboxItemRoute (LoomOutboxItemR l i) = Just (LocalActorLoom l, i) + parseOutboxItemRoute (ProjectOutboxItemR r i) = Just (LocalActorProject r, i) parseOutboxItemRoute _ = Nothing parseLocalActivityURI' @@ -141,6 +142,7 @@ activityRoute (LocalActorGroup g) = GroupOutboxItemR g activityRoute (LocalActorRepo r) = RepoOutboxItemR r activityRoute (LocalActorDeck d) = DeckOutboxItemR d activityRoute (LocalActorLoom l) = LoomOutboxItemR l +activityRoute (LocalActorProject r) = ProjectOutboxItemR r stampRoute :: LocalActorBy KeyHashid -> KeyHashid SigKey -> Route App stampRoute (LocalActorPerson p) = PersonStampR p @@ -148,6 +150,7 @@ stampRoute (LocalActorGroup g) = GroupStampR g stampRoute (LocalActorRepo r) = RepoStampR r stampRoute (LocalActorDeck d) = DeckStampR d stampRoute (LocalActorLoom l) = LoomStampR l +stampRoute (LocalActorProject r) = ProjectStampR r parseStampRoute :: 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 (DeckStampR d i) = Just (LocalActorDeck d, i) parseStampRoute (LoomStampR l i) = Just (LocalActorLoom l, i) +parseStampRoute (ProjectStampR r i) = Just (LocalActorProject r, i) parseStampRoute _ = Nothing localActorID :: LocalActorBy Entity -> ActorId @@ -164,6 +168,7 @@ localActorID (LocalActorGroup (Entity _ g)) = groupActor g localActorID (LocalActorRepo (Entity _ r)) = repoActor r localActorID (LocalActorDeck (Entity _ d)) = deckActor d localActorID (LocalActorLoom (Entity _ l)) = loomActor l +localActorID (LocalActorProject (Entity _ r)) = projectActor r parseFedURIOld :: ( MonadSite m diff --git a/src/Vervis/Data/Collab.hs b/src/Vervis/Data/Collab.hs index 24cdddf..5b5384e 100644 --- a/src/Vervis/Data/Collab.hs +++ b/src/Vervis/Data/Collab.hs @@ -85,6 +85,7 @@ import Vervis.Model parseGrantResource (RepoR r) = Just $ GrantResourceRepo r parseGrantResource (DeckR d) = Just $ GrantResourceDeck d parseGrantResource (LoomR l) = Just $ GrantResourceLoom l +parseGrantResource (ProjectR l) = Just $ GrantResourceProject l parseGrantResource _ = Nothing data GrantRecipBy f = GrantRecipPerson (f Person) @@ -230,11 +231,6 @@ parseGrant h (AP.Grant object context target mresult mstart mend allows deleg) = resourceHash "Grant resource contains invalid hashid" 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 hl <- hostIsLocal h if hl @@ -277,11 +273,13 @@ grantResourceActorID :: GrantResourceBy Identity -> ActorId grantResourceActorID (GrantResourceRepo (Identity r)) = repoActor r grantResourceActorID (GrantResourceDeck (Identity d)) = deckActor d grantResourceActorID (GrantResourceLoom (Identity l)) = loomActor l +grantResourceActorID (GrantResourceProject (Identity l)) = projectActor l data GrantResourceBy f = GrantResourceRepo (f Repo) | GrantResourceDeck (f Deck) | GrantResourceLoom (f Loom) + | GrantResourceProject (f Project) deriving (Generic, FunctorB, TraversableB, ConstraintsB) deriving instance AllBF Eq f GrantResourceBy => Eq (GrantResourceBy f) @@ -294,6 +292,8 @@ unhashGrantResourcePure ctx = f GrantResourceDeck <$> decodeKeyHashidPure ctx d f (GrantResourceLoom l) = GrantResourceLoom <$> decodeKeyHashidPure ctx l + f (GrantResourceProject l) = + GrantResourceProject <$> decodeKeyHashidPure ctx l unhashGrantResource resource = do ctx <- asksSite siteHashidsContext @@ -317,6 +317,8 @@ hashGrantResource (GrantResourceDeck k) = GrantResourceDeck <$> encodeKeyHashid k hashGrantResource (GrantResourceLoom k) = GrantResourceLoom <$> encodeKeyHashid k +hashGrantResource (GrantResourceProject k) = + GrantResourceProject <$> encodeKeyHashid k hashGrantResource' (GrantResourceRepo k) = GrantResourceRepo <$> WAP.encodeKeyHashid k @@ -324,6 +326,8 @@ hashGrantResource' (GrantResourceDeck k) = GrantResourceDeck <$> WAP.encodeKeyHashid k hashGrantResource' (GrantResourceLoom k) = GrantResourceLoom <$> WAP.encodeKeyHashid k +hashGrantResource' (GrantResourceProject k) = + GrantResourceProject <$> WAP.encodeKeyHashid k getGrantResource (GrantResourceRepo k) e = GrantResourceRepo <$> getEntityE k e @@ -331,6 +335,8 @@ getGrantResource (GrantResourceDeck k) e = GrantResourceDeck <$> getEntityE k e getGrantResource (GrantResourceLoom k) e = GrantResourceLoom <$> getEntityE k e +getGrantResource (GrantResourceProject k) e = + GrantResourceProject <$> getEntityE k e getGrantResource404 = maybe notFound return <=< getGrantResourceEntity where @@ -340,8 +346,11 @@ getGrantResource404 = maybe notFound return <=< getGrantResourceEntity fmap GrantResourceDeck <$> getEntity k getGrantResourceEntity (GrantResourceLoom k) = fmap GrantResourceLoom <$> getEntity k + getGrantResourceEntity (GrantResourceProject k) = + fmap GrantResourceProject <$> getEntity k grantResourceLocalActor :: GrantResourceBy f -> LocalActorBy f grantResourceLocalActor (GrantResourceRepo r) = LocalActorRepo r grantResourceLocalActor (GrantResourceDeck d) = LocalActorDeck d grantResourceLocalActor (GrantResourceLoom l) = LocalActorLoom l +grantResourceLocalActor (GrantResourceProject l) = LocalActorProject l diff --git a/src/Vervis/Data/Discussion.hs b/src/Vervis/Data/Discussion.hs index 55282a8..91ccfff 100644 --- a/src/Vervis/Data/Discussion.hs +++ b/src/Vervis/Data/Discussion.hs @@ -222,3 +222,4 @@ messageRoute (LocalActorGroup g) = GroupMessageR g messageRoute (LocalActorRepo r) = RepoMessageR r messageRoute (LocalActorDeck d) = DeckMessageR d messageRoute (LocalActorLoom l) = LoomMessageR l +messageRoute (LocalActorProject l) = ProjectMessageR l diff --git a/src/Vervis/Form/Tracker.hs b/src/Vervis/Form/Tracker.hs index c7f6911..0b6fb2e 100644 --- a/src/Vervis/Form/Tracker.hs +++ b/src/Vervis/Form/Tracker.hs @@ -16,10 +16,14 @@ module Vervis.Form.Tracker ( NewDeck (..) , newDeckForm + , NewProject (..) + , newProjectForm , NewLoom (..) , newLoomForm , DeckInvite (..) , deckInviteForm + , ProjectInvite (..) + , projectInviteForm --, NewProjectCollab (..) --, newProjectCollabForm --, editProjectForm @@ -56,6 +60,16 @@ newDeckForm = renderDivs $ NewDeck <$> areq textField "Name*" 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 { nlName :: Text , nlDesc :: Text @@ -115,6 +129,38 @@ deckInviteForm deckID = renderDivs $ DeckInvite l 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 sid (Entity jid project) = Project diff --git a/src/Vervis/Foundation.hs b/src/Vervis/Foundation.hs index 7b38726..b40d5a8 100644 --- a/src/Vervis/Foundation.hs +++ b/src/Vervis/Foundation.hs @@ -157,6 +157,7 @@ type LoomKeyHashid = KeyHashid Loom type TicketDeckKeyHashid = KeyHashid TicketDeck type TicketLoomKeyHashid = KeyHashid TicketLoom type SigKeyKeyHashid = KeyHashid SigKey +type ProjectKeyHashid = KeyHashid Project -- This is where we define all of the routes in our application. For a full -- explanation of the syntax, please see: @@ -982,3 +983,20 @@ instance YesodBreadcrumbs App where ClothReplyOnR l c _ -> ("Reply", Just $ ClothR 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) diff --git a/src/Vervis/Handler/Client.hs b/src/Vervis/Handler/Client.hs index b6b5ead..4ecf218 100644 --- a/src/Vervis/Handler/Client.hs +++ b/src/Vervis/Handler/Client.hs @@ -122,7 +122,7 @@ getHomeR = do where personalOverview :: Entity Person -> Handler Html 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.on $ repo E.^. RepoActor E.==. actor E.^. ActorId E.on $ topic E.^. CollabTopicRepoRepo E.==. repo E.^. RepoId @@ -153,15 +153,26 @@ getHomeR = do E.orderBy [E.asc $ loom E.^. LoomId] 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 hashDeck <- getEncodeKeyHashid hashLoom <- getEncodeKeyHashid + hashProject <- getEncodeKeyHashid defaultLayout $(widgetFile "personal-overview") getBrowseR :: Handler Html 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.on $ person E.^. PersonActor E.==. actor E.^. ActorId E.orderBy [E.asc $ person E.^. PersonId] @@ -187,6 +198,11 @@ getBrowseR = do E.orderBy [E.asc $ loom E.^. LoomId] 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 repoRows <- forM repos $ @@ -209,6 +225,7 @@ getBrowseR = do hashRepo <- getEncodeKeyHashid hashDeck <- getEncodeKeyHashid hashLoom <- getEncodeKeyHashid + hashProject <- getEncodeKeyHashid defaultLayout $ do setTitle "Welcome to Vervis!" $(widgetFile "browse") diff --git a/src/Vervis/Handler/Project.hs b/src/Vervis/Handler/Project.hs new file mode 100644 index 0000000..146121b --- /dev/null +++ b/src/Vervis/Handler/Project.hs @@ -0,0 +1,332 @@ +{- This file is part of Vervis. + - + - Written in 2016, 2019, 2022, 2023 by fr33domlover . + - + - ♡ 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 + - . + -} + +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 diff --git a/src/Vervis/Model.hs b/src/Vervis/Model.hs index f3156d7..6a584f4 100644 --- a/src/Vervis/Model.hs +++ b/src/Vervis/Model.hs @@ -100,6 +100,10 @@ instance Hashable LoomId where hashWithSalt salt = hashWithSalt salt . fromSqlKey hash = hash . fromSqlKey +instance Hashable ProjectId where + hashWithSalt salt = hashWithSalt salt . fromSqlKey + hash = hash . fromSqlKey + {- instance PersistEntityGraph Ticket TicketDependency where sourceParam = ticketDependencyParent diff --git a/src/Vervis/Persist/Actor.hs b/src/Vervis/Persist/Actor.hs index eccf518..4f51d96 100644 --- a/src/Vervis/Persist/Actor.hs +++ b/src/Vervis/Persist/Actor.hs @@ -81,14 +81,16 @@ getLocalActorEnt actorID = do mr <- getBy $ UniqueRepoActor actorID md <- getBy $ UniqueDeckActor actorID ml <- getBy $ UniqueLoomActor actorID + mj <- getBy $ UniqueProjectActor actorID return $ - case (mp, mg, mr, md, ml) of - (Nothing, Nothing, Nothing, Nothing, Nothing) -> error "Unused ActorId" - (Just p, Nothing, Nothing, Nothing, Nothing) -> LocalActorPerson p - (Nothing, Just g, Nothing, Nothing, Nothing) -> LocalActorGroup g - (Nothing, Nothing, Just r, Nothing, Nothing) -> LocalActorRepo r - (Nothing, Nothing, Nothing, Just d, Nothing) -> LocalActorDeck d - (Nothing, Nothing, Nothing, Nothing, Just l) -> LocalActorLoom l + case (mp, mg, mr, md, ml, mj) of + (Nothing, Nothing, Nothing, Nothing, Nothing, Nothing) -> error "Unused ActorId" + (Just p, Nothing, Nothing, Nothing, Nothing, Nothing) -> LocalActorPerson p + (Nothing, Just g, Nothing, Nothing, Nothing, Nothing) -> LocalActorGroup g + (Nothing, Nothing, Just r, Nothing, Nothing, Nothing) -> LocalActorRepo r + (Nothing, Nothing, Nothing, Just d, Nothing, Nothing) -> LocalActorDeck d + (Nothing, Nothing, Nothing, Nothing, Just l, Nothing) -> LocalActorLoom l + (Nothing, Nothing, Nothing, Nothing, Nothing, Just j) -> LocalActorProject j _ -> error "Multi-usage of an ActorId" getLocalActorEntity @@ -105,6 +107,8 @@ getLocalActorEntity (LocalActorDeck d) = fmap (LocalActorDeck . Entity d) <$> get d getLocalActorEntity (LocalActorLoom l) = fmap (LocalActorLoom . Entity l) <$> get l +getLocalActorEntity (LocalActorProject r) = + fmap (LocalActorProject . Entity r) <$> get r verifyLocalActivityExistsInDB :: MonadIO m diff --git a/src/Vervis/Persist/Collab.hs b/src/Vervis/Persist/Collab.hs index 457837d..c255c64 100644 --- a/src/Vervis/Persist/Collab.hs +++ b/src/Vervis/Persist/Collab.hs @@ -63,15 +63,18 @@ getCollabTopic collabID = do maybeRepo <- getValBy $ UniqueCollabTopicRepo collabID maybeDeck <- getValBy $ UniqueCollabTopicDeck collabID maybeLoom <- getValBy $ UniqueCollabTopicLoom collabID + maybeProject <- getValBy $ UniqueCollabTopicProject collabID return $ - case (maybeRepo, maybeDeck, maybeLoom) of - (Nothing, Nothing, Nothing) -> error "Found Collab without topic" - (Just r, Nothing, Nothing) -> + case (maybeRepo, maybeDeck, maybeLoom, maybeProject) of + (Nothing, Nothing, Nothing, Nothing) -> error "Found Collab without topic" + (Just r, Nothing, Nothing, Nothing) -> GrantResourceRepo $ collabTopicRepoRepo r - (Nothing, Just d, Nothing) -> + (Nothing, Just d, Nothing, Nothing) -> GrantResourceDeck $ collabTopicDeckDeck d - (Nothing, Nothing, Just l) -> + (Nothing, Nothing, Just l, Nothing) -> GrantResourceLoom $ collabTopicLoomLoom l + (Nothing, Nothing, Nothing, Just l) -> + GrantResourceProject $ collabTopicProjectProject l _ -> error "Found Collab with multiple topics" getCollabTopic' @@ -80,15 +83,18 @@ getCollabTopic' collabID = do maybeRepo <- getBy $ UniqueCollabTopicRepo collabID maybeDeck <- getBy $ UniqueCollabTopicDeck collabID maybeLoom <- getBy $ UniqueCollabTopicLoom collabID + maybeProject <- getBy $ UniqueCollabTopicProject collabID return $ - case (maybeRepo, maybeDeck, maybeLoom) of - (Nothing, Nothing, Nothing) -> error "Found Collab without topic" - (Just (Entity k r), Nothing, Nothing) -> + case (maybeRepo, maybeDeck, maybeLoom, maybeProject) of + (Nothing, Nothing, Nothing, Nothing) -> error "Found Collab without topic" + (Just (Entity k r), Nothing, Nothing, Nothing) -> (delete k, GrantResourceRepo $ collabTopicRepoRepo r) - (Nothing, Just (Entity k d), Nothing) -> + (Nothing, Just (Entity k d), Nothing, Nothing) -> (delete k, GrantResourceDeck $ collabTopicDeckDeck d) - (Nothing, Nothing, Just (Entity k l)) -> + (Nothing, Nothing, Just (Entity k l), Nothing) -> (delete k, GrantResourceLoom $ collabTopicLoomLoom l) + (Nothing, Nothing, Nothing, Just (Entity k l)) -> + (delete k, GrantResourceProject $ collabTopicProjectProject l) _ -> error "Found Collab with multiple topics" 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" -- Find the local topic, on which this Collab gives access - topic <- lift $ do - 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" + topic <- lift $ getCollabTopic collabID -- Verify that topic is indeed the sender of the Grant unless (grantResourceLocalActor topic == capActor) $ diff --git a/src/Vervis/Persist/Discussion.hs b/src/Vervis/Persist/Discussion.hs index b2249e6..e6a1a76 100644 --- a/src/Vervis/Persist/Discussion.hs +++ b/src/Vervis/Persist/Discussion.hs @@ -1,6 +1,7 @@ {- This file is part of Vervis. - - - Written in 2016, 2019, 2020, 2022 by fr33domlover . + - Written in 2016, 2019, 2020, 2022, 2023 + - by fr33domlover . - - ♡ Copying is an act of love. Please copy, reuse and share. - @@ -92,6 +93,9 @@ getLocalAuthor lmid aid name = do LocalActorLoom loomID -> do loomHash <- encodeKeyHashid loomID return $ "+" <> keyHashidText loomHash + LocalActorProject projectID -> do + projectHash <- encodeKeyHashid projectID + return $ "$" <> keyHashidText projectHash return $ MessageTreeNodeLocal lmid authorByKey code name getAllMessages :: AppDB DiscussionId -> Handler [MessageTreeNode] diff --git a/src/Vervis/Recipient.hs b/src/Vervis/Recipient.hs index 0610403..e779417 100644 --- a/src/Vervis/Recipient.hs +++ b/src/Vervis/Recipient.hs @@ -69,6 +69,7 @@ module Vervis.Recipient , RepoRoutes (..) , DeckRoutes (..) , LoomRoutes (..) + , ProjectRoutes (..) , DeckFamilyRoutes (..) , LoomFamilyRoutes (..) , RecipientRoutes (..) @@ -192,6 +193,7 @@ parseLocalActor (GroupR gkhid) = Just $ LocalActorGroup gkhid parseLocalActor (RepoR rkhid) = Just $ LocalActorRepo rkhid parseLocalActor (DeckR dkhid) = Just $ LocalActorDeck dkhid parseLocalActor (LoomR lkhid) = Just $ LocalActorLoom lkhid +parseLocalActor (ProjectR jkhid) = Just $ LocalActorProject jkhid parseLocalActor _ = Nothing renderLocalActor :: LocalActor -> Route App @@ -200,6 +202,7 @@ renderLocalActor (LocalActorGroup gkhid) = GroupR gkhid renderLocalActor (LocalActorRepo rkhid) = RepoR rkhid renderLocalActor (LocalActorDeck dkhid) = DeckR dkhid renderLocalActor (LocalActorLoom lkhid) = LoomR lkhid +renderLocalActor (LocalActorProject jkhid) = ProjectR jkhid data LocalStageBy f = LocalStagePersonFollowers (f Person) @@ -213,6 +216,8 @@ data LocalStageBy f | LocalStageLoomFollowers (f Loom) | LocalStageClothFollowers (f Loom) (f TicketLoom) + + | LocalStageProjectFollowers (f Project) deriving (Generic, FunctorB, ConstraintsB) deriving instance AllBF Eq f LocalStageBy => Eq (LocalStageBy f) @@ -235,6 +240,8 @@ parseLocalStage (LoomFollowersR lkhid) = Just $ LocalStageLoomFollowers lkhid parseLocalStage (ClothFollowersR lkhid ltkhid) = Just $ LocalStageClothFollowers lkhid ltkhid +parseLocalStage (ProjectFollowersR jkhid) = + Just $ LocalStageProjectFollowers jkhid parseLocalStage _ = Nothing renderLocalStage :: LocalStage -> Route App @@ -252,6 +259,8 @@ renderLocalStage (LocalStageLoomFollowers lkhid) = LoomFollowersR lkhid renderLocalStage (LocalStageClothFollowers lkhid ltkhid) = ClothFollowersR lkhid ltkhid +renderLocalStage (LocalStageProjectFollowers jkhid) = + ProjectFollowersR jkhid parseLocalRecipient :: Route App -> Maybe (Either LocalActor LocalStage) parseLocalRecipient r = @@ -263,6 +272,7 @@ localActorFollowers (LocalActorGroup g) = LocalStageGroupFollowers g localActorFollowers (LocalActorRepo r) = LocalStageRepoFollowers r localActorFollowers (LocalActorDeck d) = LocalStageDeckFollowers d localActorFollowers (LocalActorLoom l) = LocalStageLoomFollowers l +localActorFollowers (LocalActorProject j) = LocalStageProjectFollowers j ------------------------------------------------------------------------------- -- Converting between KeyHashid, Key, Identity and Entity @@ -327,6 +337,8 @@ hashLocalStagePure ctx = f LocalStageClothFollowers (encodeKeyHashidPure ctx l) (encodeKeyHashidPure ctx c) + f (LocalStageProjectFollowers j) = + LocalStageProjectFollowers $ encodeKeyHashidPure ctx j getHashLocalStage :: (MonadSite m, YesodHashids (SiteEnv m)) @@ -364,6 +376,8 @@ unhashLocalStagePure ctx = f LocalStageClothFollowers <$> decodeKeyHashidPure ctx l <*> decodeKeyHashidPure ctx c + f (LocalStageProjectFollowers j) = + LocalStageProjectFollowers <$> decodeKeyHashidPure ctx j unhashLocalStage :: (MonadSite m, YesodHashids (SiteEnv m)) @@ -405,6 +419,7 @@ getLocalActorID (LocalActorGroup g) = fmap groupActor <$> get g getLocalActorID (LocalActorRepo r) = fmap repoActor <$> get r getLocalActorID (LocalActorDeck d) = fmap deckActor <$> get d getLocalActorID (LocalActorLoom l) = fmap loomActor <$> get l +getLocalActorID (LocalActorProject j) = fmap projectActor <$> get j ------------------------------------------------------------------------------- -- Intermediate recipient types @@ -428,6 +443,8 @@ data LeafDeck = LeafDeck | LeafDeckFollowers deriving (Eq, Ord) data LeafLoom = LeafLoom | LeafLoomFollowers deriving (Eq, Ord) +data LeafProject = LeafProject | LeafProjectFollowers deriving (Eq, Ord) + data PieceDeck = PieceDeck LeafDeck | PieceTicket (KeyHashid TicketDeck) LeafTicket @@ -444,6 +461,7 @@ data LocalRecipient | RecipRepo (KeyHashid Repo) LeafRepo | RecipDeck (KeyHashid Deck) PieceDeck | RecipLoom (KeyHashid Loom) PieceLoom + | RecipProject (KeyHashid Project) LeafProject deriving (Eq, Ord) recipientFromActor :: LocalActor -> LocalRecipient @@ -457,6 +475,8 @@ recipientFromActor (LocalActorDeck dkhid) = RecipDeck dkhid $ PieceDeck LeafDeck recipientFromActor (LocalActorLoom lkhid) = RecipLoom lkhid $ PieceLoom LeafLoom +recipientFromActor (LocalActorProject jkhid) = + RecipProject jkhid LeafProject recipientFromStage :: LocalStage -> LocalRecipient recipientFromStage (LocalStagePersonFollowers pkhid) = @@ -473,6 +493,8 @@ recipientFromStage (LocalStageLoomFollowers lkhid) = RecipLoom lkhid $ PieceLoom LeafLoomFollowers recipientFromStage (LocalStageClothFollowers lkhid ltkhid) = RecipLoom lkhid $ PieceCloth ltkhid LeafClothFollowers +recipientFromStage (LocalStageProjectFollowers jkhid) = + RecipProject jkhid LeafProjectFollowers ------------------------------------------------------------------------------- -- Recipient set types @@ -493,19 +515,22 @@ groupLocalRecipients = organize . partitionByActor , [(KeyHashid Repo, LeafRepo)] , [(KeyHashid Deck, PieceDeck)] , [(KeyHashid Loom, PieceLoom)] + , [(KeyHashid Project, LeafProject)] ) - partitionByActor = foldl' f ([], [], [], [], []) + partitionByActor = foldl' f ([], [], [], [], [], []) where - f (p, g, r, d, l) (RecipPerson pkhid pleaf) = - ((pkhid, pleaf) : p, g, r, d, l) - f (p, g, r, d, l) (RecipGroup gkhid gleaf) = - (p, (gkhid, gleaf) : g, r, d, l) - f (p, g, r, d, l) (RecipRepo rkhid rleaf) = - (p, g, (rkhid, rleaf) : r, d, l) - f (p, g, r, d, l) (RecipDeck dkhid dpiece) = - (p, g, r, (dkhid, dpiece) : d, l) - f (p, g, r, d, l) (RecipLoom lkhid lpiece) = - (p, g, r, d, (lkhid, lpiece) : l) + f (p, g, r, d, l, j) (RecipPerson pkhid pleaf) = + ((pkhid, pleaf) : p, g, r, d, l, j) + f (p, g, r, d, l, j) (RecipGroup gkhid gleaf) = + (p, (gkhid, gleaf) : g, r, d, l, j) + f (p, g, r, d, l, j) (RecipRepo rkhid rleaf) = + (p, g, (rkhid, rleaf) : r, d, l, j) + f (p, g, r, d, l, j) (RecipDeck dkhid dpiece) = + (p, g, r, (dkhid, dpiece) : d, l, j) + f (p, g, r, d, l, j) (RecipLoom lkhid lpiece) = + (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 :: ( [(KeyHashid Person, LeafPerson)] @@ -513,9 +538,10 @@ groupLocalRecipients = organize . partitionByActor , [(KeyHashid Repo, LeafRepo)] , [(KeyHashid Deck, PieceDeck)] , [(KeyHashid Loom, PieceLoom)] + , [(KeyHashid Project, LeafProject)] ) -> RecipientRoutes - organize (p, g, r, d, l) = RecipientRoutes + organize (p, g, r, d, l, j) = RecipientRoutes { recipPeople = map (second $ foldr orLP $ PersonRoutes False False) $ groupByKeySort p , recipGroups = @@ -544,6 +570,8 @@ groupLocalRecipients = organize . partitionByActor . partitionEithers . NE.toList . NE.map pl2either ) $ groupByKeySort l + , recipProjects = + map (second $ foldr orLJ $ ProjectRoutes False False) $ groupByKeySort j } where groupByKey :: (Foldable f, Eq a) => f (a, b) -> [(a, NonEmpty b)] @@ -585,6 +613,11 @@ groupLocalRecipients = organize . partitionByActor orLC _ cr@(ClothRoutes True) = cr 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 ld) = Left ld pd2either (PieceTicket ltkhid lt) = Right (ltkhid, lt) @@ -622,6 +655,7 @@ localRecipSieve' sieve allowPeople allowOthers routes = RecipientRoutes , recipRepos = applySieve' applyRepo recipRepos , recipDecks = applySieve' applyDeck recipDecks , recipLooms = applySieve' applyLoom recipLooms + , recipProjects = applySieve' applyProject recipProjects } where applySieve @@ -725,6 +759,17 @@ localRecipSieve' sieve allowPeople allowOthers routes = RecipientRoutes then Nothing 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 recips = isJust . verify where @@ -743,6 +788,9 @@ actorIsAddressed recips = isJust . verify verify (LocalActorLoom l) = do routes <- lookup l $ recipLooms recips guard $ routeLoom $ familyLoom routes + verify (LocalActorProject j) = do + routes <- lookup j $ recipProjects recips + guard $ routeProject routes data ParsedAudience u = ParsedAudience { paudLocalRecips :: RecipientRoutes diff --git a/src/Vervis/Web/Actor.hs b/src/Vervis/Web/Actor.hs index 54f92c6..199891f 100644 --- a/src/Vervis/Web/Actor.hs +++ b/src/Vervis/Web/Actor.hs @@ -378,6 +378,8 @@ getLocalActors actorIDs = do selectKeysList [DeckActor <-. actorIDs] [] , map LocalActorLoom <$> selectKeysList [LoomActor <-. actorIDs] [] + , map LocalActorProject <$> + selectKeysList [ProjectActor <-. actorIDs] [] ] case compare (length localActors) (length actorIDs) of LT -> error "Found actor ID not used by any specific actor" diff --git a/src/Vervis/Widget/Tracker.hs b/src/Vervis/Widget/Tracker.hs index a7b615f..cf6f056 100644 --- a/src/Vervis/Widget/Tracker.hs +++ b/src/Vervis/Widget/Tracker.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2019, 2022 by fr33domlover . + - Written in 2019, 2022, 2023 by fr33domlover . - - ♡ Copying is an act of love. Please copy, reuse and share. - @@ -16,6 +16,7 @@ module Vervis.Widget.Tracker ( deckNavW , loomNavW + , projectNavW ) where @@ -38,3 +39,8 @@ loomNavW (Entity loomID loom) actor = do loomHash <- encodeKeyHashid loomID hashRepo <- getEncodeKeyHashid $(widgetFile "loom/widget/nav") + +projectNavW :: Entity Project -> Actor -> Widget +projectNavW (Entity projectID project) actor = do + projectHash <- encodeKeyHashid projectID + $(widgetFile "project/widget/nav") diff --git a/src/Web/ActivityPub.hs b/src/Web/ActivityPub.hs index 9e06a4c..0b01b4d 100644 --- a/src/Web/ActivityPub.hs +++ b/src/Web/ActivityPub.hs @@ -1715,6 +1715,7 @@ data CreateObject u | CreateTicketTracker ActorDetail (Maybe (Authority u, ActorLocal u)) | CreateRepository ActorDetail VersionControlSystem (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 o @@ -1737,6 +1738,11 @@ parseCreateObject o repos <- o .:*+ "tracksPatchesFor" ml <- parseActorLocal o 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 (CreateNote h note) = toSeries h note @@ -1751,6 +1757,8 @@ encodeCreateObject (CreatePatchTracker d repos ml) = encodeActorDetail d <> "tracksPatchesFor" .=*+ repos <> maybe mempty (uncurry encodeActorLocal) ml +encodeCreateObject (CreateProject d ml) = + encodeActorDetail d <> maybe mempty (uncurry encodeActorLocal) ml data Create u = Create { createObject :: CreateObject u @@ -1770,6 +1778,7 @@ parseCreate o a luActor = do CreateTicketTracker _ _ -> return () CreateRepository _ _ _ -> return () CreatePatchTracker _ _ _ -> return () + CreateProject _ _ -> return () Create obj <$> o .:? "target" encodeCreate :: UriMode u => Create u -> Series diff --git a/templates/browse.hamlet b/templates/browse.hamlet index 3009b25..e3b8c0c 100644 --- a/templates/browse.hamlet +++ b/templates/browse.hamlet @@ -1,6 +1,7 @@ $# This file is part of Vervis. $# -$# Written in 2016, 2018, 2019, 2022 by fr33domlover . +$# Written in 2016, 2018, 2019, 2022, 2023 +$# by fr33domlover . $# $# ♡ Copying is an act of love. Please copy, reuse and share. $# @@ -96,3 +97,12 @@ $# .
  • +#{keyHashidText $ hashLoom loomID} #{actorName actor} + +

    Projects + +