diff --git a/config/settings-default.yaml b/config/settings-default.yaml index e23eadc..147895a 100644 --- a/config/settings-default.yaml +++ b/config/settings-default.yaml @@ -107,6 +107,9 @@ max-accounts: 3 # development, and to verify otherwise. #email-verification: true +# Person usernames who are allowed to create Factory actors +can-create-factories: [] + ############################################################################### # Mail ############################################################################### diff --git a/migrations/649_2024-07-29_factory.model b/migrations/649_2024-07-29_factory.model new file mode 100644 index 0000000..0b7c0e8 --- /dev/null +++ b/migrations/649_2024-07-29_factory.model @@ -0,0 +1,6 @@ +Factory + resource ResourceId + create OutboxItemId + + UniqueFactory resource + UniqueFactoryCreate create diff --git a/src/Vervis/API.hs b/src/Vervis/API.hs index ee069ba..baa2251 100644 --- a/src/Vervis/API.hs +++ b/src/Vervis/API.hs @@ -1742,6 +1742,7 @@ actorOutboxItem (LocalActorRepo r) = RepoOutboxItemR r actorOutboxItem (LocalActorDeck d) = DeckOutboxItemR d actorOutboxItem (LocalActorLoom l) = LoomOutboxItemR l actorOutboxItem (LocalActorProject l) = ProjectOutboxItemR l +actorOutboxItem (LocalActorFactory l) = FactoryOutboxItemR l offerDepC :: Entity Person diff --git a/src/Vervis/Actor.hs b/src/Vervis/Actor.hs index 598bbfd..e4924cf 100644 --- a/src/Vervis/Actor.hs +++ b/src/Vervis/Actor.hs @@ -67,6 +67,7 @@ module Vervis.Actor , DeckRoutes (..) , LoomRoutes (..) , ProjectRoutes (..) + , FactoryRoutes (..) , DeckFamilyRoutes (..) , LoomFamilyRoutes (..) , RecipientRoutes (..) @@ -169,6 +170,7 @@ data LocalActorBy f | LocalActorDeck (f Deck) | LocalActorLoom (f Loom) | LocalActorProject (f Project) + | LocalActorFactory (f Factory) deriving (Generic, FunctorB, ConstraintsB) deriving instance AllBF Eq f LocalActorBy => Eq (LocalActorBy f) @@ -182,6 +184,7 @@ data LocalResourceBy f | LocalResourceDeck (f Deck) | LocalResourceLoom (f Loom) | LocalResourceProject (f Project) + | LocalResourceFactory (f Factory) deriving (Generic, FunctorB, ConstraintsB) deriving instance AllBF Eq f LocalResourceBy => Eq (LocalResourceBy f) @@ -191,6 +194,7 @@ data LocalResourceNonGroupBy f | LocalResourceDeck' (f Deck) | LocalResourceLoom' (f Loom) | LocalResourceProject' (f Project) + | LocalResourceFactory' (f Factory) deriving (Generic, FunctorB, ConstraintsB) deriving instance AllBF Eq f LocalResourceNonGroupBy => Eq (LocalResourceNonGroupBy f) @@ -204,6 +208,7 @@ actorToResource = \case LocalActorDeck d -> Just $ LocalResourceDeck d LocalActorLoom l -> Just $ LocalResourceLoom l LocalActorProject j -> Just $ LocalResourceProject j + LocalActorFactory f -> Just $ LocalResourceFactory f resourceToActor = \case LocalResourceGroup g -> LocalActorGroup g @@ -211,6 +216,7 @@ resourceToActor = \case LocalResourceDeck d -> LocalActorDeck d LocalResourceLoom l -> LocalActorLoom l LocalResourceProject j -> LocalActorProject j + LocalResourceFactory f -> LocalActorFactory f resourceToNG = \case LocalResourceGroup _ -> Nothing @@ -218,12 +224,14 @@ resourceToNG = \case LocalResourceDeck d -> Just $ LocalResourceDeck' d LocalResourceLoom l -> Just $ LocalResourceLoom' l LocalResourceProject j -> Just $ LocalResourceProject' j + LocalResourceFactory f -> Just $ LocalResourceFactory' f resourceFromNG = \case LocalResourceRepo' r -> LocalResourceRepo r LocalResourceDeck' d -> LocalResourceDeck d LocalResourceLoom' l -> LocalResourceLoom l LocalResourceProject' j -> LocalResourceProject j + LocalResourceFactory' f -> LocalResourceFactory f hashLocalActorPure :: HashidsContext -> LocalActorBy Key -> LocalActorBy KeyHashid @@ -235,6 +243,7 @@ hashLocalActorPure ctx = f f (LocalActorDeck d) = LocalActorDeck $ encodeKeyHashidPure ctx d f (LocalActorLoom l) = LocalActorLoom $ encodeKeyHashidPure ctx l f (LocalActorProject j) = LocalActorProject $ encodeKeyHashidPure ctx j + f (LocalActorFactory f) = LocalActorFactory $ encodeKeyHashidPure ctx f getHashLocalActor :: (MonadActor m, StageHashids (MonadActorStage m)) @@ -260,6 +269,7 @@ unhashLocalActorPure ctx = f f (LocalActorDeck d) = LocalActorDeck <$> decodeKeyHashidPure ctx d f (LocalActorLoom l) = LocalActorLoom <$> decodeKeyHashidPure ctx l f (LocalActorProject j) = LocalActorProject <$> decodeKeyHashidPure ctx j + f (LocalActorFactory f) = LocalActorFactory <$> decodeKeyHashidPure ctx f unhashLocalActor :: (MonadActor m, StageHashids (MonadActorStage m)) @@ -307,6 +317,7 @@ hashLocalResourcePure ctx = f f (LocalResourceDeck d) = LocalResourceDeck $ encodeKeyHashidPure ctx d f (LocalResourceLoom l) = LocalResourceLoom $ encodeKeyHashidPure ctx l f (LocalResourceProject j) = LocalResourceProject $ encodeKeyHashidPure ctx j + f (LocalResourceFactory f) = LocalResourceFactory $ encodeKeyHashidPure ctx f getHashLocalResource :: (MonadActor m, StageHashids (MonadActorStage m)) @@ -331,6 +342,7 @@ unhashLocalResourcePure ctx = f f (LocalResourceDeck d) = LocalResourceDeck <$> decodeKeyHashidPure ctx d f (LocalResourceLoom l) = LocalResourceLoom <$> decodeKeyHashidPure ctx l f (LocalResourceProject j) = LocalResourceProject <$> decodeKeyHashidPure ctx j + f (LocalResourceFactory f) = LocalResourceFactory <$> decodeKeyHashidPure ctx f unhashLocalResource :: (MonadActor m, StageHashids (MonadActorStage m)) @@ -415,6 +427,12 @@ data ProjectRoutes = ProjectRoutes } deriving Eq +data FactoryRoutes = FactoryRoutes + { routeFactory :: Bool + , routeFactoryFollowers :: Bool + } + deriving Eq + data DeckFamilyRoutes = DeckFamilyRoutes { familyDeck :: DeckRoutes , familyTickets :: [(KeyHashid TicketDeck, TicketRoutes)] @@ -434,6 +452,7 @@ data RecipientRoutes = RecipientRoutes , recipDecks :: [(KeyHashid Deck , DeckFamilyRoutes)] , recipLooms :: [(KeyHashid Loom , LoomFamilyRoutes)] , recipProjects :: [(KeyHashid Project, ProjectRoutes)] + , recipFactories :: [(KeyHashid Factory, FactoryRoutes)] } deriving Eq @@ -513,6 +532,11 @@ instance Actor Group where type ActorKey Group = GroupId type ActorReturn Group = Either Text Text data ActorMessage Group = MsgG Verse +instance Actor Factory where + type ActorStage Factory = Staje + type ActorKey Factory = FactoryId + type ActorReturn Factory = Either Text Text + data ActorMessage Factory = MsgF Verse instance VervisActor Person where actorVerse = MsgP . Left @@ -538,6 +562,9 @@ instance VervisActor Repo where case e of Left v -> Just v Right _ -> Nothing +instance VervisActor Factory where + actorVerse = MsgF + toVerse (MsgF v) = Just v instance Stage Staje where data StageEnv Staje = forall y. (Typeable y, Yesod y) => Env @@ -564,7 +591,7 @@ instance Stage Staje where , envFetch :: ActorFetchShare } deriving Typeable - type StageActors Staje = [Person, Project, Group, Deck, Loom, Repo] + type StageActors Staje = [Person, Project, Group, Deck, Loom, Repo, Factory] instance Message (ActorMessage Person) where summarize (MsgP (Left verse)) = summarizeVerse verse @@ -588,6 +615,9 @@ instance Message (ActorMessage Project) where instance Message (ActorMessage Group) where summarize (MsgG verse) = summarizeVerse verse refer (MsgG verse) = referVerse verse +instance Message (ActorMessage Factory) where + summarize (MsgF verse) = summarizeVerse verse + refer (MsgF verse) = referVerse verse type YesodRender y = Route y -> [(Text, Text)] -> Text @@ -670,7 +700,8 @@ launchActorIO TVar (HashMap GroupId (ActorRef Group)), TVar (HashMap DeckId (ActorRef Deck)), TVar (HashMap LoomId (ActorRef Loom)), - TVar (HashMap RepoId (ActorRef Repo))] + TVar (HashMap RepoId (ActorRef Repo)), + TVar (HashMap FactoryId (ActorRef Factory))] l'1 , H.HOccurs' (TVar (HashMap (ActorKey a) (ActorRef a))) @@ -680,7 +711,8 @@ launchActorIO TVar (HashMap GroupId (ActorRef Group)), TVar (HashMap DeckId (ActorRef Deck)), TVar (HashMap LoomId (ActorRef Loom)), - TVar (HashMap RepoId (ActorRef Repo))] + TVar (HashMap RepoId (ActorRef Repo)), + TVar (HashMap FactoryId (ActorRef Factory))] ) => Theater -> StageEnv Staje @@ -705,7 +737,8 @@ launchActor TVar (HashMap GroupId (ActorRef Group)), TVar (HashMap DeckId (ActorRef Deck)), TVar (HashMap LoomId (ActorRef Loom)), - TVar (HashMap RepoId (ActorRef Repo))] + TVar (HashMap RepoId (ActorRef Repo)), + TVar (HashMap FactoryId (ActorRef Factory))] l'0 , H.HOccurs' (TVar (HashMap (ActorKey a) (ActorRef a))) @@ -715,7 +748,8 @@ launchActor TVar (HashMap GroupId (ActorRef Group)), TVar (HashMap DeckId (ActorRef Deck)), TVar (HashMap LoomId (ActorRef Loom)), - TVar (HashMap RepoId (ActorRef Repo))] + TVar (HashMap RepoId (ActorRef Repo)), + TVar (HashMap FactoryId (ActorRef Factory))] ) => ActorKey a -> Act Bool @@ -771,6 +805,7 @@ sendToLocalActors authorAndId body requireOwner mauthor maidAuthor recips = do for looms $ \ (loomID, (LoomFamilyRoutes loom cloths)) -> (loomID,) . (loom,) <$> unhashKeys cloths projects <- unhashKeys $ recipProjects recips + factories <- unhashKeys $ recipFactories recips -- Grab local actor sets whose stages are allowed for delivery let allowStages' @@ -793,6 +828,8 @@ sendToLocalActors authorAndId body requireOwner mauthor maidAuthor recips = do filter (allowStages' fst routeLoom LocalActorLoom) loomsAndCloths projectsForStages = filter (allowStages' id routeProject LocalActorProject) projects + factoriesForStages = + filter (allowStages' id routeFactory LocalActorFactory) factories -- Grab local actors being addressed let localActorsForSelf = concat @@ -802,6 +839,7 @@ sendToLocalActors authorAndId body requireOwner mauthor maidAuthor recips = do , [ LocalActorDeck key | (key, (routes, _)) <- decksAndTickets, routeDeck routes ] , [ LocalActorLoom key | (key, (routes, _)) <- loomsAndCloths, routeLoom routes ] , [ LocalActorProject key | (key, routes) <- projects, routeProject routes ] + , [ LocalActorFactory key | (key, routes) <- factories, routeFactory routes ] ] -- Grab local actors whose followers are going to be delivered to @@ -817,6 +855,8 @@ sendToLocalActors authorAndId body requireOwner mauthor maidAuthor recips = do [ key | (key, (routes, _)) <- loomsAndClothsForStages, routeLoomFollowers routes ] projectIDsForFollowers = [ key | (key, routes) <- projectsForStages, routeProjectFollowers routes ] + factoryIDsForFollowers = + [ key | (key, routes) <- factoriesForStages, routeFactoryFollowers routes ] -- Grab tickets and cloths whose followers are going to be delivered to let ticketSetsForFollowers = @@ -848,6 +888,7 @@ sendToLocalActors authorAndId body requireOwner mauthor maidAuthor recips = do , selectActorIDs deckActor deckIDsForFollowers , selectActorIDs loomActor loomIDsForFollowers , selectActorIDs projectActor projectIDsForFollowers + , selectActorIDs' factoryResource factoryIDsForFollowers ] ticketIDs <- concat <$> @@ -875,6 +916,7 @@ sendToLocalActors authorAndId body requireOwner mauthor maidAuthor recips = do , selectFollowers LocalActorDeck DeckActor followerSetIDs , selectFollowers LocalActorLoom LoomActor followerSetIDs , selectFollowers LocalActorProject ProjectActor followerSetIDs + , selectFollowers' LocalActorFactory FactoryResource followerSetIDs ] remotes <- getRemoteFollowers followerSetIDs return (locals, remotes) @@ -889,7 +931,7 @@ sendToLocalActors authorAndId body requireOwner mauthor maidAuthor recips = do Just a -> HS.delete a s authorAndId' = second (\ (author, luAct) -> (author, luAct, Nothing)) authorAndId - (liveRecipsP, liveRecipsJ, liveRecipsG, liveRecipsD, liveRecipsL, liveRecipsR) = + (liveRecipsP, liveRecipsJ, liveRecipsG, liveRecipsD, liveRecipsL, liveRecipsR, liveRecipsF) = partitionByActor liveRecips verse = Verse authorAndId' body sendMany $ @@ -898,7 +940,8 @@ sendToLocalActors authorAndId body requireOwner mauthor maidAuthor recips = do (liveRecipsG, actorVerse verse) `H.HCons` (liveRecipsD, actorVerse verse) `H.HCons` (liveRecipsL, actorVerse verse) `H.HCons` - (liveRecipsR, actorVerse verse) `H.HCons` H.HNil + (liveRecipsR, actorVerse verse) `H.HCons` + (liveRecipsF, actorVerse verse) `H.HCons` H.HNil -- Return remote followers, to whom we need to deliver via HTTP return remoteFollowers @@ -940,6 +983,15 @@ sendToLocalActors authorAndId body requireOwner mauthor maidAuthor recips = do selectActorIDs grabActor ids = map (grabActor . entityVal) <$> selectList [persistIdField <-. ids] [] + selectActorIDs' + :: (MonadIO m, PersistRecordBackend record SqlBackend) + => (record -> ResourceId) + -> [Key record] + -> ReaderT SqlBackend m [ActorId] + selectActorIDs' grabResource ids = do + resourceIDs <- map (grabResource . entityVal) <$> selectList [persistIdField <-. ids] [] + map (resourceActor . entityVal) <$> selectList [ResourceId <-. resourceIDs] [] + selectTicketIDs :: ( MonadIO m , PersistRecordBackend tracker SqlBackend @@ -990,6 +1042,14 @@ sendToLocalActors authorAndId body requireOwner mauthor maidAuthor recips = do E.where_ $ f E.^. FollowTarget `E.in_` E.valList followerSetIDs return $ p E.^. persistIdField + selectFollowers' makeLocalActor resourceField followerSetIDs = + fmap (map (makeLocalActor . E.unValue)) $ + E.select $ E.from $ \ (f `E.InnerJoin` r `E.InnerJoin` p) -> do + E.on $ r E.^. ResourceId E.==. p E.^. resourceField + E.on $ f E.^. FollowActor E.==. r E.^. ResourceActor + E.where_ $ f E.^. FollowTarget `E.in_` E.valList followerSetIDs + return $ p E.^. persistIdField + partitionByActor :: HashSet (LocalActorBy Key) -> ( HashSet PersonId @@ -998,21 +1058,24 @@ sendToLocalActors authorAndId body requireOwner mauthor maidAuthor recips = do , HashSet DeckId , HashSet LoomId , HashSet RepoId + , HashSet FactoryId ) - partitionByActor = foldl' f (HS.empty, HS.empty, HS.empty, HS.empty, HS.empty, HS.empty) + partitionByActor = foldl' f (HS.empty, HS.empty, HS.empty, HS.empty, HS.empty, HS.empty, HS.empty) where - f (p, j, g, d, l, r) (LocalActorPerson k) = - (HS.insert k p, j, g, d, l, r) - f (p, j, g, d, l, r) (LocalActorProject k) = - (p, HS.insert k j, g, d, l, r) - f (p, j, g, d, l, r) (LocalActorGroup k) = - (p, j, HS.insert k g, d, l, r) - f (p, j, g, d, l, r) (LocalActorDeck k) = - (p, j, g, HS.insert k d, l, r) - f (p, j, g, d, l, r) (LocalActorLoom k) = - (p, j, g, d, HS.insert k l, r) - f (p, j, g, d, l, r) (LocalActorRepo k) = - (p, j, g, d, l, HS.insert k r) + f (p, j, g, d, l, r, f') (LocalActorPerson k) = + (HS.insert k p, j, g, d, l, r, f') + f (p, j, g, d, l, r, f') (LocalActorProject k) = + (p, HS.insert k j, g, d, l, r, f') + f (p, j, g, d, l, r, f') (LocalActorGroup k) = + (p, j, HS.insert k g, d, l, r, f') + f (p, j, g, d, l, r, f') (LocalActorDeck k) = + (p, j, g, HS.insert k d, l, r, f') + f (p, j, g, d, l, r, f') (LocalActorLoom k) = + (p, j, g, d, HS.insert k l, r, f') + f (p, j, g, d, l, r, f') (LocalActorRepo k) = + (p, j, g, d, l, HS.insert k r, f') + f (p, j, g, d, l, r, f') (LocalActorFactory k) = + (p, j, g, d, l, r, HS.insert k f') actorIsAddressed :: RecipientRoutes -> LocalActor -> Bool actorIsAddressed recips = isJust . verify @@ -1035,6 +1098,9 @@ actorIsAddressed recips = isJust . verify verify (LocalActorProject j) = do routes <- lookup j $ recipProjects recips guard $ routeProject routes + verify (LocalActorFactory f) = do + routes <- lookup f $ recipFactories recips + guard $ routeFactory routes localActorType :: LocalActorBy f -> AP.ActorType localActorType = \case @@ -1044,3 +1110,4 @@ localActorType = \case LocalActorLoom _ -> AP.ActorTypePatchTracker LocalActorProject _ -> AP.ActorTypeProject LocalActorGroup _ -> AP.ActorTypeTeam + LocalActorFactory _ -> AP.ActorTypeFactory diff --git a/src/Vervis/Actor/Factory.hs b/src/Vervis/Actor/Factory.hs new file mode 100644 index 0000000..1fa11c3 --- /dev/null +++ b/src/Vervis/Actor/Factory.hs @@ -0,0 +1,65 @@ +{- This file is part of Vervis. + - + - Written in 2024 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.Factory + ( + ) +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.Data.Discussion +import Vervis.FedURI + +import Vervis.Foundation +import Vervis.Model +import Vervis.Persist.Actor +import Vervis.Persist.Discussion + +factoryBehavior :: UTCTime -> FactoryId -> ActorMessage Factory -> ActE (Text, Act (), Next) +factoryBehavior now factoryID (MsgF _verse@(Verse _authorIdMsig body)) = + case AP.activitySpecific $ actbActivity body of + _ -> throwE "Unsupported activity type for Factory" + +instance VervisActorLaunch Factory where + actorBehavior' now factoryID ve = do + errboxID <- lift $ withDB $ do + resourceID <- factoryResource <$> getJust factoryID + Resource actorID <- getJust resourceID + actorErrbox <$> getJust actorID + adaptErrbox errboxID False factoryBehavior now factoryID ve diff --git a/src/Vervis/Actor/Person/Client.hs b/src/Vervis/Actor/Person/Client.hs index a5ce2ba..bc677e3 100644 --- a/src/Vervis/Actor/Person/Client.hs +++ b/src/Vervis/Actor/Person/Client.hs @@ -62,6 +62,7 @@ import Vervis.ActivityPub import Vervis.Actor import Vervis.Actor2 import Vervis.Actor.Deck +import Vervis.Actor.Factory import Vervis.Actor.Group import Vervis.Actor.Project import Vervis.Cloth @@ -74,12 +75,14 @@ import Vervis.FedURI import Vervis.Fetch import Vervis.Foundation import Vervis.Model +import Vervis.Model.Ident import Vervis.Persist.Actor import Vervis.Persist.Collab import Vervis.Persist.Discussion import Vervis.Persist.Follow import Vervis.Recipient (makeRecipientSet, LocalStageBy (..), Aud (..), collectAudience, localRecipSieve, localActorFollowers) import Vervis.RemoteActorStore +import Vervis.Settings import Vervis.Ticket verifyActorAddressed :: RecipientRoutes -> LocalActorBy Key -> ActE () @@ -831,6 +834,166 @@ clientCreateTeam now personMeID (ClientMsg maybeCap localRecips remoteRecips fwd } return (action, recipientSet, remoteActors, fwdHosts) +-- Meaning: The human wants to create a factory +-- Behavior: +-- * Verify human is allowed to +-- * Create a factory on DB +-- * Create a Permit record in DB +-- * Launch a factory actor +-- * Record a FollowRequest in DB +-- * Create and send Create and Follow to it +clientCreateFactory + :: UTCTime + -> PersonId + -> ClientMsg + -> AP.ActorDetail + -> ActE OutboxItemId +clientCreateFactory now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHosts action) detail = do + + -- Check input + verifyNothingE maybeCap "Capability not needed" + (name, msummary) <- parseDetail detail + + (actorMeID, localRecipsFinal, createID, actionCreate, followID, follow, factoryID) <- withDBExcept $ do + + -- Grab me from DB + (personMe, actorMe) <- lift $ do + p <- getJust personMeID + (p,) <$> getJust (personActor p) + let actorMeID = personActor personMe + + -- Verify I'm allowed to create a Factory + cans <- asksEnv $ appCanCreateFactories . envSettings + unless (personUsername personMe `elem` map text2username cans) $ + throwE "Not allowed to create factories" + + -- Insert new factory to DB + createID <- lift $ insertEmptyOutboxItem' (actorOutbox actorMe) now + (factoryID, resourceID, factoryFollowerSetID) <- + lift $ insertFactory now name msummary createID actorMeID + + -- Insert a Permit record + permitID <- lift $ insert $ Permit personMeID AP.RoleAdmin + topicID <- lift $ insert $ PermitTopicLocal permitID resourceID + lift $ insert_ $ PermitFulfillsTopicCreation permitID + lift $ insert_ $ PermitPersonGesture permitID createID + + -- Insert the Create activity to my outbox + factoryHash <- lift $ lift $ encodeKeyHashid factoryID + actionCreate <- lift $ lift $ prepareCreate name msummary factoryHash + luCreate <- lift $ updateOutboxItem' (LocalActorPerson personMeID) createID actionCreate + + -- Prepare recipient sieve for sending the Create + personMeHash <- lift $ lift $ encodeKeyHashid personMeID + let sieve = + makeRecipientSet + [LocalActorFactory factoryHash] + [LocalStagePersonFollowers personMeHash] + onlyFactory = FactoryRoutes True False + addMe' factories= (factoryHash, onlyFactory) : factories + addMe rs = rs { recipFactories = addMe' $ recipFactories rs } + + -- Insert a follow request, since I'm about to send a Follow + followID <- lift $ insertEmptyOutboxItem' (actorOutbox actorMe) now + lift $ insert_ $ FollowRequest actorMeID factoryFollowerSetID True followID + + -- Insert a Follow to my outbox + follow@(actionFollow, _, _, _) <- lift $ lift $ prepareFollow factoryID luCreate + _luFollow <- lift $ updateOutboxItem' (LocalActorPerson personMeID) followID actionFollow + + return + ( personActor personMe + , localRecipSieve sieve False $ addMe localRecips + , createID + , actionCreate + , followID + , follow + , factoryID + ) + + -- Spawn new Factory actor + success <- lift $ launchActor factoryID + unless success $ + error "Failed to spawn new Factory, somehow ID already in Theater" + + -- Send the Create + lift $ sendActivity + (LocalActorPerson personMeID) actorMeID localRecipsFinal remoteRecips + fwdHosts createID actionCreate + + -- Send the Follow + let (actionFollow, localRecipsFollow, remoteRecipsFollow, fwdHostsFollow) = follow + lift $ sendActivity + (LocalActorPerson personMeID) actorMeID localRecipsFollow + remoteRecipsFollow fwdHostsFollow followID actionFollow + + return createID + + where + + parseDetail (AP.ActorDetail typ muser mname msummary) = do + unless (typ == AP.ActorTypeFactory) $ + error "clientCreateFactory: Create object isn't a Factory" + verifyNothingE muser "Factory can't have a username" + name <- fromMaybeE mname "Factory doesn't specify name" + return (name, msummary) + + insertFactory now name msummary obiidCreate actorMeID = do + Entity aid a <- insertActor now name (fromMaybe "" msummary) (Just actorMeID) + rid <- insert $ Resource aid + fid <- insert Factory + { factoryResource = rid + , factoryCreate = obiidCreate + } + return (fid, rid, actorFollowers a) + + prepareCreate name msummary factoryHash = do + encodeRouteLocal <- getEncodeRouteLocal + hLocal <- asksEnv stageInstanceHost + let ttdetail = AP.ActorDetail + { AP.actorType = AP.ActorTypeFactory + , AP.actorUsername = Nothing + , AP.actorName = Just name + , AP.actorSummary = msummary + } + ttlocal = AP.ActorLocal + { AP.actorId = encodeRouteLocal $ FactoryR factoryHash + , AP.actorInbox = encodeRouteLocal $ FactoryInboxR factoryHash + , AP.actorOutbox = Nothing + , AP.actorFollowers = Nothing + , AP.actorFollowing = Nothing + , AP.actorPublicKeys = [] + , AP.actorSshKeys = [] + } + specific = AP.CreateActivity AP.Create + { AP.createObject = AP.CreateFactory ttdetail (Just (hLocal, ttlocal)) + , AP.createTarget = Nothing + } + return action { AP.actionSpecific = specific } + + prepareFollow factoryID luCreate = do + encodeRouteHome <- getEncodeRouteHome + h <- asksEnv stageInstanceHost + factoryHash <- encodeKeyHashid factoryID + + let audTopic = AudLocal [LocalActorFactory factoryHash] [] + (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) = + collectAudience [audTopic] + + recips = map encodeRouteHome audLocal ++ audRemote + action = AP.Action + { AP.actionCapability = Nothing + , AP.actionSummary = Nothing + , AP.actionAudience = AP.Audience recips [] [] [] [] [] + , AP.actionFulfills = [ObjURI h luCreate] + , AP.actionSpecific = AP.FollowActivity AP.Follow + { AP.followObject = encodeRouteHome $ FactoryR factoryHash + , AP.followContext = Nothing + , AP.followHide = False + } + } + return (action, recipientSet, remoteActors, fwdHosts) + clientCreate :: UTCTime -> PersonId @@ -855,6 +1018,11 @@ clientCreate now personMeID msg (AP.Create object muTarget) = verifyNothingE muTarget "'target' not supported in Create Team" clientCreateTeam now personMeID msg detail + AP.CreateFactory detail mlocal -> do + verifyNothingE mlocal "Factory id must not be provided" + verifyNothingE muTarget "'target' not supported in Create Factory" + clientCreateFactory now personMeID msg detail + _ -> throwE "Unsupported Create object for C2S" -- Meaning: The human wants to invite someone A to a resource R diff --git a/src/Vervis/Application.hs b/src/Vervis/Application.hs index c377d36..be761a2 100644 --- a/src/Vervis/Application.hs +++ b/src/Vervis/Application.hs @@ -106,6 +106,7 @@ import Web.Hashids.Local import Vervis.Actor import Vervis.Actor.Deck +import Vervis.Actor.Factory import Vervis.Actor.Group import Vervis.Actor.Loom import Vervis.Actor.Person @@ -125,6 +126,7 @@ import Vervis.Handler.Client import Vervis.Handler.Common import Vervis.Handler.Cloth import Vervis.Handler.Deck +import Vervis.Handler.Factory --import Vervis.Handler.Git import Vervis.Handler.Group import Vervis.Handler.Key @@ -348,16 +350,18 @@ makeFoundation appSettings = do , [(DeckId , StageEnv Staje)] , [(LoomId , StageEnv Staje)] , [(RepoId , StageEnv Staje)] + , [(FactoryId, StageEnv Staje)] ] ) loadTheater env = - (\ p j g d l r -> p `H.HCons`j `H.HCons` g `H.HCons` d `H.HCons` l `H.HCons` r `H.HCons` H.HNil) + (\ p j g d l r f -> p `H.HCons`j `H.HCons` g `H.HCons` d `H.HCons` l `H.HCons` r `H.HCons` f `H.HCons` H.HNil) <$> (map (,env) <$> selectKeysList [PersonVerified ==. True] []) <*> (map (,env) <$> selectKeysList [] []) <*> (map (,env) <$> selectKeysList [] []) <*> (map (,env) <$> selectKeysList [] []) <*> (map (,env) <$> selectKeysList [] []) <*> (map (,env) <$> selectKeysList [] []) + <*> (map (,env) <$> selectKeysList [] []) startPersonLauncher :: Theater -> StageEnv Staje -> IO (MVar (PersonId, MVar Bool)) startPersonLauncher theater env = do diff --git a/src/Vervis/Client.hs b/src/Vervis/Client.hs index ad773fa..0aaeff5 100644 --- a/src/Vervis/Client.hs +++ b/src/Vervis/Client.hs @@ -41,6 +41,7 @@ module Vervis.Client , createRepo , createProject , createGroup + , createFactory , invite , add , remove @@ -557,7 +558,7 @@ unfollow personID uActor = do meActorID <- lift $ personActor <$> getJust personID case target of Left byk -> do - themActorID <- localActorID <$> getLocalActorEntityE byk "No such local acto in DB" + themActorID <- lift . grabLocalActorID =<< getLocalActorEntityE byk "No such local acto in DB" theirFollowerSetID <- lift $ actorFollowers <$> getJust themActorID mf <- lift $ getValBy $ UniqueFollow meActorID theirFollowerSetID followFollow <$> @@ -1110,6 +1111,27 @@ createGroup senderHash name desc = do return (Nothing, audience, detail) +createFactory + :: (MonadHandler m, HandlerSite m ~ App, MonadSite m, SiteEnv m ~ App) + => KeyHashid Person + -> Text + -> Text + -> m (Maybe HTML, [Aud URIMode], AP.ActorDetail) +createFactory senderHash name desc = do + let audAuthor = + AudLocal [] [LocalStagePersonFollowers senderHash] + + audience = [audAuthor] + + detail = AP.ActorDetail + { AP.actorType = AP.ActorTypeFactory + , AP.actorUsername = Nothing + , AP.actorName = Just name + , AP.actorSummary = Just desc + } + + return (Nothing, audience, detail) + invite :: PersonId -> FedURI diff --git a/src/Vervis/Data/Actor.hs b/src/Vervis/Data/Actor.hs index 5a84d4a..abb5025 100644 --- a/src/Vervis/Data/Actor.hs +++ b/src/Vervis/Data/Actor.hs @@ -21,7 +21,7 @@ module Vervis.Data.Actor , activityRoute , stampRoute , parseStampRoute - , localActorID + , grabLocalActorID , localResourceID , WA.parseLocalURI , parseFedURIOld @@ -46,6 +46,7 @@ import Control.Monad.Logger.CallStack import Control.Monad.Trans.Except import Data.Bitraversable import Data.Text (Text) +import Database.Persist.Sql import Database.Persist.Types import UnliftIO.Exception (try, SomeException, displayException) @@ -154,6 +155,7 @@ activityRoute (LocalActorRepo r) = RepoOutboxItemR r activityRoute (LocalActorDeck d) = DeckOutboxItemR d activityRoute (LocalActorLoom l) = LoomOutboxItemR l activityRoute (LocalActorProject r) = ProjectOutboxItemR r +activityRoute (LocalActorFactory f) = FactoryOutboxItemR f stampRoute :: LocalActorBy KeyHashid -> KeyHashid SigKey -> Route App stampRoute (LocalActorPerson p) = PersonStampR p @@ -162,6 +164,7 @@ stampRoute (LocalActorRepo r) = RepoStampR r stampRoute (LocalActorDeck d) = DeckStampR d stampRoute (LocalActorLoom l) = LoomStampR l stampRoute (LocalActorProject r) = ProjectStampR r +stampRoute (LocalActorFactory f) = FactoryStampR f parseStampRoute :: Route App -> Maybe (LocalActorBy KeyHashid, KeyHashid SigKey) @@ -171,15 +174,17 @@ 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 (FactoryStampR f i) = Just (LocalActorFactory f, i) parseStampRoute _ = Nothing -localActorID :: LocalActorBy Entity -> ActorId -localActorID (LocalActorPerson (Entity _ p)) = personActor p -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 +grabLocalActorID :: MonadIO m => LocalActorBy Entity -> SqlPersistT m ActorId +grabLocalActorID (LocalActorPerson (Entity _ p)) = pure $ personActor p +grabLocalActorID (LocalActorGroup (Entity _ g)) = pure $ groupActor g +grabLocalActorID (LocalActorRepo (Entity _ r)) = pure $ repoActor r +grabLocalActorID (LocalActorDeck (Entity _ d)) = pure $ deckActor d +grabLocalActorID (LocalActorLoom (Entity _ l)) = pure $ loomActor l +grabLocalActorID (LocalActorProject (Entity _ r)) = pure $ projectActor r +grabLocalActorID (LocalActorFactory (Entity _ f)) = resourceActor <$> getJust (factoryResource f) localResourceID :: LocalResourceBy Entity -> ResourceId localResourceID (LocalResourceGroup (Entity _ g)) = groupResource g @@ -187,6 +192,7 @@ localResourceID (LocalResourceRepo (Entity _ r)) = repoResource r localResourceID (LocalResourceDeck (Entity _ d)) = deckResource d localResourceID (LocalResourceLoom (Entity _ l)) = loomResource l localResourceID (LocalResourceProject (Entity _ r)) = projectResource r +localResourceID (LocalResourceFactory (Entity _ f)) = factoryResource f parseFedURIOld :: ( MonadSite m diff --git a/src/Vervis/Data/Collab.hs b/src/Vervis/Data/Collab.hs index 58bd692..0c7085d 100644 --- a/src/Vervis/Data/Collab.hs +++ b/src/Vervis/Data/Collab.hs @@ -87,6 +87,7 @@ parseGrantResourceCollabs (DeckCollabsR d) = Just $ LocalResourceDeck d parseGrantResourceCollabs (LoomCollabsR l) = Just $ LocalResourceLoom l parseGrantResourceCollabs (ProjectCollabsR l) = Just $ LocalResourceProject l parseGrantResourceCollabs (GroupMembersR l) = Just $ LocalResourceGroup l +parseGrantResourceCollabs (FactoryCollabsR f) = Just $ LocalResourceFactory f parseGrantResourceCollabs _ = Nothing data GrantRecipBy f = GrantRecipPerson (f Person) @@ -390,6 +391,9 @@ parseAddTarget = \case LoomTeamsR k -> ATLoomTeams <$> WAP.decodeKeyHashidE k "Inavlid hashid" + FactoryTeamsR k -> + ATFactoryTeams <$> + WAP.decodeKeyHashidE k "Inavlid hashid" GroupEffortsR k -> ATGroupEfforts <$> WAP.decodeKeyHashidE k "Inavlid hashid" @@ -454,6 +458,7 @@ data AddTarget | ATRepoTeams RepoId | ATDeckTeams DeckId | ATLoomTeams LoomId + | ATFactoryTeams FactoryId | ATGroupEfforts GroupId deriving Eq @@ -471,6 +476,7 @@ addTargetResource = \case ATRepoTeams r -> LocalResourceRepo r ATDeckTeams d -> LocalResourceDeck d ATLoomTeams l -> LocalResourceLoom l + ATFactoryTeams f -> LocalResourceFactory f ATGroupEfforts g -> LocalResourceGroup g addTargetComponentProjects = \case @@ -563,6 +569,7 @@ resourceToComponent = \case LocalResourceLoom k -> Just $ ComponentLoom k LocalResourceProject _ -> Nothing LocalResourceGroup _ -> Nothing + LocalResourceFactory _ -> Nothing localComponentID :: ComponentBy Entity -> KomponentId localComponentID (ComponentRepo (Entity _ r)) = repoKomponent r diff --git a/src/Vervis/Data/Discussion.hs b/src/Vervis/Data/Discussion.hs index 96f8234..57971b2 100644 --- a/src/Vervis/Data/Discussion.hs +++ b/src/Vervis/Data/Discussion.hs @@ -223,3 +223,4 @@ messageRoute (LocalActorRepo r) = RepoMessageR r messageRoute (LocalActorDeck d) = DeckMessageR d messageRoute (LocalActorLoom l) = LoomMessageR l messageRoute (LocalActorProject l) = ProjectMessageR l +messageRoute (LocalActorFactory f) = FactoryMessageR f diff --git a/src/Vervis/Foundation.hs b/src/Vervis/Foundation.hs index 4a428f1..14c1138 100644 --- a/src/Vervis/Foundation.hs +++ b/src/Vervis/Foundation.hs @@ -161,6 +161,7 @@ type StemKeyHashid = KeyHashid Stem type PermitFulfillsInviteKeyHashid = KeyHashid PermitFulfillsInvite type DestUsStartKeyHashid = KeyHashid DestUsStart type SquadUsStartKeyHashid = KeyHashid SquadUsStart +type FactoryKeyHashid = KeyHashid Factory -- This is where we define all of the routes in our application. For a full -- explanation of the syntax, please see: @@ -238,6 +239,7 @@ instance Yesod App where Just (DeckInboxR _) -> return False Just (LoomInboxR _) -> return False Just (ProjectInboxR _) -> return False + Just (FactoryInboxR _) -> return False Just (GitUploadRequestR _) -> return False Just (DvaraR _) -> return False Just RegisterR -> return False @@ -282,7 +284,10 @@ instance Yesod App where [E.Value i] -> return i _ -> error $ "countUnread returned " ++ show vs hash <- YH.encodeKeyHashid pid - return (p, hash, verified, unread) + canCreateFactories <- do + cans <- asksSite $ appCanCreateFactories . appSettings + return $ personUsername person `elem` map text2username cans + return (p, hash, verified, unread, canCreateFactories) (title, bcs) <- breadcrumbs -- We break up the default layout into two components: @@ -384,6 +389,8 @@ instance Yesod App where (LoomInboxR _ , False) -> personAny + (FactoryInboxR _ , False) -> personAny + (FactoryNewR , _ ) -> personAny @@ -1106,6 +1113,7 @@ instance YesodBreadcrumbs App where RepoErrboxR r -> ("Errbox", Just $ RepoR r) DeckErrboxR d -> ("Errbox", Just $ DeckR d) LoomErrboxR l -> ("Errbox", Just $ LoomR l) + FactoryErrboxR f -> ("Errbox", Just $ FactoryR f) RemoteActorsR -> ("Remote Actors", Just HomeR) RemoteActorR k -> (T.pack $ show $ fromSqlKey k, Just RemoteActorsR) @@ -1114,3 +1122,27 @@ instance YesodBreadcrumbs App where FollowRemoteR _ -> ("", Nothing) UnfollowLocalR _ -> ("", Nothing) UnfollowRemoteR _ -> ("", Nothing) + + FactoryR f -> ("Factory *" <> keyHashidText f, Just HomeR) + FactoryInboxR f -> ("Inbox", Just $ FactoryR f) + FactoryOutboxR f -> ("Outbox", Just $ FactoryR f) + FactoryOutboxItemR f i -> (keyHashidText i, Just $ FactoryOutboxR f) + FactoryFollowersR f -> ("Followers", Just $ FactoryR f) + + FactoryMessageR f m -> ("Message #" <> keyHashidText m, Just $ FactoryR f) + + FactoryNewR -> ("New Factory", Just HomeR) + + FactoryStampR f k -> ("Stamp #" <> keyHashidText k, Just $ FactoryR f) + + FactoryCollabsR f -> ("Collaborators", Just $ FactoryR f) + + FactoryInviteR _ -> ("", Nothing) + FactoryRemoveR _ _ -> ("", Nothing) + + FactoryTeamsR f -> ("Teams", Just $ FactoryR f) + + FactoryAddTeamR f -> ("", Nothing) + FactoryApproveTeamR f t -> ("", Nothing) + FactoryRemoveTeamR f t -> ("", Nothing) + FactoryTeamLiveR _ _ -> ("", Nothing) diff --git a/src/Vervis/Handler/Client.hs b/src/Vervis/Handler/Client.hs index 6a06880..1e6c79a 100644 --- a/src/Vervis/Handler/Client.hs +++ b/src/Vervis/Handler/Client.hs @@ -256,7 +256,7 @@ getHomeR = do bitraverse (\ byK -> do byE <- getLocalActorEntityE byK "No such local actor in DB" - actor <- lift $ getJust $ localActorID byE + actor <- lift $ getJust =<< grabLocalActorID byE return (byK, actor) ) (\ u -> @@ -271,7 +271,7 @@ getHomeR = do ) personalOverview :: Entity Person -> Handler Html - personalOverview (Entity pid _person) = do + personalOverview (Entity pid person) = do (permits, invites) <- runDB $ do permits <- do locals <- do @@ -418,11 +418,14 @@ getHomeR = do ) return $ sortOn (view _1) $ locals ++ remotes return (permits, invites) - let (people, repos, decks, looms, projects, groups, others) = + let (people, repos, decks, looms, projects, groups, factories, others) = partitionByActorType (view _4) (view _1) permits if null people then pure () else error "Bug: Person as a PermitTopic" + canCreateFactories <- do + cans <- asksSite $ appCanCreateFactories . appSettings + return $ personUsername person `elem` map text2username cans defaultLayout $(widgetFile "personal-overview") where @@ -432,7 +435,7 @@ getHomeR = do => (a -> AP.ActorType) -> (a -> b) -> [a] - -> ([a], [a], [a], [a], [a], [a], [a]) + -> ([a], [a], [a], [a], [a], [a], [a], [a]) partitionByActorType typ key xs = let p = filter ((== AP.ActorTypePerson) . typ) xs r = filter ((== AP.ActorTypeRepo) . typ) xs @@ -440,8 +443,9 @@ getHomeR = do l = filter ((== AP.ActorTypePatchTracker) . typ) xs j = filter ((== AP.ActorTypeProject) . typ) xs g = filter ((== AP.ActorTypeTeam) . typ) xs - x = deleteFirstsBy ((==) `on` key) xs (p ++ r ++ d ++ l ++ j ++ g) - in (p, r, d, l, j, g, x) + f = filter ((== AP.ActorTypeFactory) . typ) xs + x = deleteFirstsBy ((==) `on` key) xs (p ++ r ++ d ++ l ++ j ++ g ++ f) + in (p, r, d, l, j, g, f, x) item (_gestureID, role, deleg, _typ, actor, exts) = [whamlet| @@ -492,6 +496,9 @@ getHomeR = do getBrowseR :: Handler Html getBrowseR = do + canCreateFactories <- do + cans <- asksSite $ appCanCreateFactories . appSettings + return $ \ p -> personUsername p `elem` map text2username cans (people, groups, repos, decks, looms, projects) <- runDB $ (,,,,,) <$> (E.select $ E.from $ \ (person `E.InnerJoin` actor) -> do diff --git a/src/Vervis/Handler/Factory.hs b/src/Vervis/Handler/Factory.hs new file mode 100644 index 0000000..abf2e62 --- /dev/null +++ b/src/Vervis/Handler/Factory.hs @@ -0,0 +1,418 @@ +{- This file is part of Vervis. + - + - Written in 2016, 2019, 2022, 2023, 2024 + - 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.Factory + ( getFactoryR + , getFactoryInboxR + , getFactoryErrboxR + , postFactoryInboxR + , getFactoryOutboxR + , getFactoryOutboxItemR + , getFactoryFollowersR + + , getFactoryMessageR + + , getFactoryNewR + , postFactoryNewR + + , getFactoryStampR + + , getFactoryCollabsR + , postFactoryInviteR + , postFactoryRemoveR + + , getFactoryTeamsR + + , postFactoryAddTeamR + , postFactoryApproveTeamR + , postFactoryRemoveTeamR + , getFactoryTeamLiveR + ) +where + +import Control.Applicative +import Control.Arrow ((&&&)) +import Control.Monad +import Control.Monad.Trans.Except +import Control.Monad.Trans.Maybe +import Data.Aeson +import Data.Bifunctor +import Data.Bitraversable +import Data.ByteString (ByteString) +import Data.Default.Class +import Data.Foldable +import Data.Maybe (fromMaybe, isJust) +import Data.Text (Text) +import Data.Time.Clock +import Data.Traversable +import Database.Persist +import Network.HTTP.Types.Method +import Optics.Core +import Text.Blaze.Html (Html) +import Yesod.Auth +import Yesod.Core +import Yesod.Core.Handler (redirect, setMessage, lookupPostParam, notFound) +import Yesod.Form +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 Data.Text as T +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 (..), Factory) +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.Actor.Factory +import Vervis.Data.Actor +import Vervis.Federation.Auth +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.Serve.Collab +import Vervis.Settings +import Vervis.Ticket +import Vervis.TicketFilter +import Vervis.Time +import Vervis.Web.Actor +import Vervis.Web.Collab +import Vervis.Widget +import Vervis.Widget.Person +import Vervis.Widget.Ticket +import Vervis.Widget.Tracker + +import qualified Vervis.Client as C + +getFactoryR :: KeyHashid Factory -> Handler TypedContent +getFactoryR factoryHash = do + factoryID <- decodeKeyHashid404 factoryHash + (factory, actor, sigKeyIDs) <- runDB $ do + f <- get404 factoryID + Resource aid <- getJust $ factoryResource f + a <- getJust aid + sigKeys <- selectKeysList [SigKeyActor ==. aid] [Asc SigKeyId] + return (f, a, sigKeys) + + encodeRouteLocal <- getEncodeRouteLocal + hashSigKey <- getEncodeKeyHashid + perActor <- asksSite $ appPerActorKeys . appSettings + let factoryAP = AP.Factory + { AP.factoryActor = AP.Actor + { AP.actorLocal = AP.ActorLocal + { AP.actorId = encodeRouteLocal $ FactoryR factoryHash + , AP.actorInbox = encodeRouteLocal $ FactoryInboxR factoryHash + , AP.actorOutbox = + Just $ encodeRouteLocal $ FactoryOutboxR factoryHash + , AP.actorFollowers = + Just $ encodeRouteLocal $ FactoryFollowersR factoryHash + , AP.actorFollowing = Nothing + , AP.actorPublicKeys = + map (Left . encodeRouteLocal) $ + if perActor + then map (FactoryStampR factoryHash . hashSigKey) sigKeyIDs + else [ActorKey1R, ActorKey2R] + , AP.actorSshKeys = [] + } + , AP.actorDetail = AP.ActorDetail + { AP.actorType = AP.ActorTypeFactory + , AP.actorUsername = Nothing + , AP.actorName = Just $ actorName actor + , AP.actorSummary = Just $ actorDesc actor + } + } + , AP.factoryCollabs = + encodeRouteLocal $ FactoryCollabsR factoryHash + , AP.factoryTeams = + encodeRouteLocal $ FactoryTeamsR factoryHash + } + + provideHtmlAndAP factoryAP $ redirectToPrettyJSON $ FactoryR factoryHash + +grabActorID = fmap resourceActor . getJust . factoryResource + +getFactoryInboxR :: KeyHashid Factory -> Handler TypedContent +getFactoryInboxR = getInbox'' actorInbox FactoryInboxR grabActorID + +getFactoryErrboxR :: KeyHashid Factory -> Handler TypedContent +getFactoryErrboxR = getInbox'' actorErrbox FactoryErrboxR grabActorID + +postFactoryInboxR :: KeyHashid Factory -> Handler () +postFactoryInboxR factoryHash = do + factoryID <- decodeKeyHashid404 factoryHash + postInbox LocalActorFactory factoryID + +getFactoryOutboxR :: KeyHashid Factory -> Handler TypedContent +getFactoryOutboxR = getOutbox' FactoryOutboxR FactoryOutboxItemR grabActorID + +getFactoryOutboxItemR + :: KeyHashid Factory -> KeyHashid OutboxItem -> Handler TypedContent +getFactoryOutboxItemR = getOutboxItem' FactoryOutboxItemR grabActorID + +getFactoryFollowersR :: KeyHashid Factory -> Handler TypedContent +getFactoryFollowersR = getActorFollowersCollection' FactoryFollowersR grabActorID + +getFactoryMessageR :: KeyHashid Factory -> KeyHashid LocalMessage -> Handler Html +getFactoryMessageR _ _ = notFound + +newFactoryForm = renderDivs $ (,) + <$> areq textField "Name*" Nothing + <*> areq textField "Description" Nothing + +getFactoryNewR :: Handler Html +getFactoryNewR = do + ((_result, widget), enctype) <- runFormPost newFactoryForm + defaultLayout $(widgetFile "factory/new") + +postFactoryNewR :: Handler Html +postFactoryNewR = do + (name, desc) <- runFormPostRedirect FactoryNewR newFactoryForm + + personEntity@(Entity personID person) <- requireAuth + personHash <- encodeKeyHashid personID + (maybeSummary, audience, detail) <- C.createFactory personHash name desc + (localRecips, remoteRecips, fwdHosts, action) <- + C.makeServerInput Nothing maybeSummary audience $ AP.CreateActivity $ AP.Create (AP.CreateFactory detail Nothing) Nothing + result <- + runExceptT $ + handleViaActor personID Nothing localRecips remoteRecips fwdHosts action + + case result of + Left e -> do + setMessage $ toHtml e + redirect FactoryNewR + Right createID -> do + maybeFactoryID <- runDB $ getKeyBy $ UniqueFactoryCreate createID + case maybeFactoryID of + Nothing -> error "Can't find the newly created factory" + Just factoryID -> do + factoryHash <- encodeKeyHashid factoryID + setMessage "New factory created" + redirect $ FactoryR factoryHash + +getFactoryStampR :: KeyHashid Factory -> KeyHashid SigKey -> Handler TypedContent +getFactoryStampR = servePerActorKey'' grabActorID LocalActorFactory + +getFactoryCollabsR :: KeyHashid Factory -> Handler TypedContent +getFactoryCollabsR factoryHash = do + factoryID <- decodeKeyHashid404 factoryHash + (factory, actor) <- runDB $ do + factory <- get404 factoryID + Resource actorID <- getJust $ factoryResource factory + actor <- getJust actorID + return (factory, actor) + serveCollabs + AP.RelHasCollab + (factoryResource factory) + (FactoryR factoryHash) + (FactoryCollabsR factoryHash) + (FactoryRemoveR factoryHash) + (FactoryInviteR factoryHash) + (Just + ( FactoryRemoveTeamR factoryHash + , FactoryAddTeamR factoryHash + , FactoryApproveTeamR factoryHash + ) + ) + (factoryNavW (Entity factoryID factory) actor) + +postFactoryInviteR :: KeyHashid Factory -> Handler Html +postFactoryInviteR factoryHash = do + factoryID <- decodeKeyHashid404 factoryHash + resourceID <- runDB $ factoryResource <$> get404 factoryID + serveInviteCollab resourceID (FactoryCollabsR factoryHash) + +postFactoryRemoveR :: KeyHashid Factory -> CollabId -> Handler Html +postFactoryRemoveR factoryHash collabID = do + factoryID <- decodeKeyHashid404 factoryHash + resourceID <- runDB $ factoryResource <$> get404 factoryID + serveRemoveCollab resourceID (FactoryCollabsR factoryHash) collabID + +getFactoryTeamsR :: KeyHashid Factory -> Handler TypedContent +getFactoryTeamsR factoryHash = do + factoryID <- decodeKeyHashid404 factoryHash + resourceID <- runDB $ factoryResource <$> get404 factoryID + serveTeamsCollection (FactoryR factoryHash) (FactoryTeamsR factoryHash) resourceID + +postFactoryAddTeamR :: KeyHashid Factory -> Handler () +postFactoryAddTeamR factoryHash = do + factoryID <- decodeKeyHashid404 factoryHash + (uTeam, role) <- + runFormPostRedirect (FactoryCollabsR factoryHash) addTeamForm + + personEntity@(Entity personID person) <- requireAuth + personHash <- encodeKeyHashid personID + encodeRouteHome <- getEncodeRouteHome + + let uCollection = encodeRouteHome $ FactoryTeamsR factoryHash + + result <- runExceptT $ do + (maybeSummary, audience, add) <- C.add personID uTeam uCollection role + cap <- do + maybeItem <- lift $ runDB $ do + resourceID <- factoryResource <$> get404 factoryID + getCapability personID (Left resourceID) AP.RoleAdmin + fromMaybeE maybeItem "You need to be have Admin access to the Factory to add teams" + uCap <- lift $ renderActivityURI cap + (localRecips, remoteRecips, fwdHosts, action) <- + C.makeServerInput (Just uCap) maybeSummary audience $ AP.AddActivity add + let cap' = first (\ (la, i) -> (la, error "lah", i)) cap + handleViaActor + personID (Just cap') localRecips remoteRecips fwdHosts action + + case result of + Left e -> setMessage $ toHtml e + Right inviteID -> setMessage "Add sent" + redirect $ FactoryCollabsR factoryHash + +postFactoryApproveTeamR :: KeyHashid Factory -> SquadId -> Handler Html +postFactoryApproveTeamR factoryHash squadID = do + factoryID <- decodeKeyHashid404 factoryHash + + personEntity@(Entity personID person) <- requireAuth + personHash <- encodeKeyHashid personID + encodeRouteHome <- getEncodeRouteHome + + result <- runExceptT $ do + mpidOrU <- lift $ runDB $ runMaybeT $ do + factory <- MaybeT $ get factoryID + Squad _ resourceID <- MaybeT $ get squadID + guard $ resourceID == factoryResource factory + + uAdd <- lift $ do + add <- getSquadAdd squadID + renderActivityURI add + + topic <- lift $ bimap snd snd <$> getSquadTeam squadID + lift $ + (factoryResource factory,uAdd,) <$> + bitraverse + pure + (getRemoteActorURI <=< getJust) + topic + (resourceID, uAdd, pidOrU) <- maybe notFound pure mpidOrU + (maybeSummary, audience, accept) <- do + uTeam <- + case pidOrU of + Left g -> encodeRouteHome . GroupR <$> encodeKeyHashid g + Right u -> pure u + let uFactory = encodeRouteHome $ FactoryR factoryHash + C.acceptParentChild personID uAdd uTeam uFactory + cap <- do + maybeItem <- lift $ runDB $ getCapability personID (Left resourceID) AP.RoleAdmin + fromMaybeE maybeItem "You need to be have Admin access to the Factory to approve teams" + uCap <- lift $ renderActivityURI cap + (localRecips, remoteRecips, fwdHosts, action) <- + C.makeServerInput (Just uCap) maybeSummary audience $ AP.AcceptActivity accept + let cap' = first (\ (la, i) -> (la, error "lah", i)) cap + handleViaActor + personID (Just cap') localRecips remoteRecips fwdHosts action + + case result of + Left e -> do + setMessage $ toHtml e + Right removeID -> + setMessage "Accept sent" + redirect $ FactoryCollabsR factoryHash + +postFactoryRemoveTeamR :: KeyHashid Factory -> SquadId -> Handler Html +postFactoryRemoveTeamR factoryHash squadID = do + factoryID <- decodeKeyHashid404 factoryHash + + personEntity@(Entity personID person) <- requireAuth + personHash <- encodeKeyHashid personID + encodeRouteHome <- getEncodeRouteHome + + result <- runExceptT $ do + mpidOrU <- lift $ runDB $ runMaybeT $ do + factory <- MaybeT $ get factoryID + Squad _ resourceID <- MaybeT $ get squadID + guard $ resourceID == factoryResource factory + acceptID <- MaybeT $ getKeyBy $ UniqueSquadUsAccept squadID + _ <- MaybeT $ getBy $ UniqueSquadUsStart acceptID + + uAdd <- lift $ do + add <- getSquadAdd squadID + renderActivityURI add + + topic <- lift $ bimap snd snd <$> getSquadTeam squadID + lift $ + (factoryResource factory,uAdd,) <$> + bitraverse + pure + (getRemoteActorURI <=< getJust) + topic + (resourceID, uAdd, pidOrU) <- maybe notFound pure mpidOrU + (maybeSummary, audience, remove) <- do + uTeam <- + case pidOrU of + Left g -> encodeRouteHome . GroupR <$> encodeKeyHashid g + Right u -> pure u + let uCollection = encodeRouteHome $ FactoryTeamsR factoryHash + C.remove personID uTeam uCollection + cap <- do + maybeItem <- lift $ runDB $ getCapability personID (Left resourceID) AP.RoleAdmin + fromMaybeE maybeItem "You need to be have Admin access to the Factory to remove teams" + uCap <- lift $ renderActivityURI cap + (localRecips, remoteRecips, fwdHosts, action) <- + C.makeServerInput (Just uCap) maybeSummary audience $ AP.RemoveActivity remove + let cap' = first (\ (la, i) -> (la, error "lah", i)) cap + handleViaActor + personID (Just cap') localRecips remoteRecips fwdHosts action + + case result of + Left e -> do + setMessage $ toHtml e + Right removeID -> + setMessage "Remove sent" + redirect $ FactoryCollabsR factoryHash + +getFactoryTeamLiveR :: KeyHashid Factory -> KeyHashid SquadUsStart -> Handler () +getFactoryTeamLiveR factoryHash startHash = do + factoryID <- decodeKeyHashid404 factoryHash + startID <- decodeKeyHashid404 startHash + runDB $ do + factory <- get404 factoryID + SquadUsStart usAcceptID _ <- get404 startID + SquadUsAccept squadID _ <- getJust usAcceptID + Squad _ resourceID <- getJust squadID + unless (resourceID == factoryResource factory) notFound diff --git a/src/Vervis/Migration.hs b/src/Vervis/Migration.hs index befebfb..863a79f 100644 --- a/src/Vervis/Migration.hs +++ b/src/Vervis/Migration.hs @@ -3848,6 +3848,8 @@ changes hLocal ctx = , removeField "Effort" "topic" -- 648 , addEntities model_648_report + -- 649 + , addEntities model_649_factory ] migrateDB diff --git a/src/Vervis/Migration/Entities.hs b/src/Vervis/Migration/Entities.hs index 422b84d..e757233 100644 --- a/src/Vervis/Migration/Entities.hs +++ b/src/Vervis/Migration/Entities.hs @@ -79,6 +79,7 @@ module Vervis.Migration.Entities , model_638_effort_squad , model_639_component_convey , model_648_report + , model_649_factory ) where @@ -311,3 +312,6 @@ type ListOfByteStrings = [ByteString] model_648_report :: [Entity SqlBackend] model_648_report = $(schema "648_2024-07-06_report") + +model_649_factory :: [Entity SqlBackend] +model_649_factory = $(schema "649_2024-07-29_factory") diff --git a/src/Vervis/Model.hs b/src/Vervis/Model.hs index 7987377..1a1a10f 100644 --- a/src/Vervis/Model.hs +++ b/src/Vervis/Model.hs @@ -109,6 +109,10 @@ instance Hashable ProjectId where hashWithSalt salt = hashWithSalt salt . fromSqlKey hash = hash . fromSqlKey +instance Hashable FactoryId 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 d9f843e..aa3d025 100644 --- a/src/Vervis/Persist/Actor.hs +++ b/src/Vervis/Persist/Actor.hs @@ -114,21 +114,28 @@ getLocalComponent = fmap (bmap entityKey) . getLocalComponentEnt getLocalActorEnt :: MonadIO m => ActorId -> ReaderT SqlBackend m (LocalActorBy Entity) getLocalActorEnt actorID = do + m <- getKeyBy $ UniqueResource actorID + mp <- getBy $ UniquePersonActor actorID mg <- getBy $ UniqueGroupActor actorID mr <- getBy $ UniqueRepoActor actorID md <- getBy $ UniqueDeckActor actorID ml <- getBy $ UniqueLoomActor actorID mj <- getBy $ UniqueProjectActor actorID + mf <- runMaybeT $ do + resourceID <- hoistMaybe m + MaybeT $ getBy $ UniqueFactory resourceID + return $ - 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 + case (mp, mg, mr, md, ml, mj, mf) of + (Nothing, Nothing, Nothing, Nothing, Nothing, Nothing, Nothing) -> error "Unused ActorId" + (Just p, Nothing, Nothing, Nothing, Nothing, Nothing, Nothing) -> LocalActorPerson p + (Nothing, Just g, Nothing, Nothing, Nothing, Nothing, Nothing) -> LocalActorGroup g + (Nothing, Nothing, Just r, Nothing, Nothing, Nothing, Nothing) -> LocalActorRepo r + (Nothing, Nothing, Nothing, Just d, Nothing, Nothing, Nothing) -> LocalActorDeck d + (Nothing, Nothing, Nothing, Nothing, Just l, Nothing, Nothing) -> LocalActorLoom l + (Nothing, Nothing, Nothing, Nothing, Nothing, Just j, Nothing) -> LocalActorProject j + (Nothing, Nothing, Nothing, Nothing, Nothing, Nothing, Just f) -> LocalActorFactory f _ -> error "Multi-usage of an ActorId" getLocalResourceEnt @@ -142,6 +149,7 @@ getLocalResourceEnt resourceID = do , fmap LocalResourceLoom <$> getBy (UniqueLoomActor actorID) , fmap LocalResourceProject <$> getBy (UniqueProjectActor actorID) , fmap LocalResourceGroup <$> getBy (UniqueGroupActor actorID) + , fmap LocalResourceFactory <$> getBy (UniqueFactory resourceID) ] exactlyOneJust options @@ -180,6 +188,8 @@ getLocalActorEntity (LocalActorLoom l) = fmap (LocalActorLoom . Entity l) <$> get l getLocalActorEntity (LocalActorProject r) = fmap (LocalActorProject . Entity r) <$> get r +getLocalActorEntity (LocalActorFactory f) = + fmap (LocalActorFactory . Entity f) <$> get f getLocalActorEntityE a e = do m <- lift $ getLocalActorEntity a @@ -203,6 +213,8 @@ getLocalResourceEntity (LocalResourceLoom l) = fmap (LocalResourceLoom . Entity l) <$> get l getLocalResourceEntity (LocalResourceProject r) = fmap (LocalResourceProject . Entity r) <$> get r +getLocalResourceEntity (LocalResourceFactory f) = + fmap (LocalResourceFactory . Entity f) <$> get f getLocalResourceEntityE a e = do m <- lift $ getLocalResourceEntity a diff --git a/src/Vervis/Persist/Discussion.hs b/src/Vervis/Persist/Discussion.hs index 3af46e7..a75aeca 100644 --- a/src/Vervis/Persist/Discussion.hs +++ b/src/Vervis/Persist/Discussion.hs @@ -96,6 +96,9 @@ getLocalAuthor lmid aid name = do LocalActorProject projectID -> do projectHash <- encodeKeyHashid projectID return $ "$" <> keyHashidText projectHash + LocalActorFactory factoryID -> do + factoryHash <- encodeKeyHashid factoryID + return $ "*" <> keyHashidText factoryHash return $ MessageTreeNodeLocal lmid authorByKey code name getAllMessages :: AppDB DiscussionId -> Handler [MessageTreeNode] @@ -176,7 +179,7 @@ getMessageFromRoute authorByKey localMsgID = do authorByEntity <- do maybeActor <- lift $ getLocalActorEntity authorByKey fromMaybeE maybeActor "No such author in DB" - let actorID = localActorID authorByEntity + actorID <- lift $ grabLocalActorID authorByEntity actor <- lift $ getJust actorID localMsg <- do mlm <- lift $ get localMsgID diff --git a/src/Vervis/Persist/Follow.hs b/src/Vervis/Persist/Follow.hs index 4614a50..71e130f 100644 --- a/src/Vervis/Persist/Follow.hs +++ b/src/Vervis/Persist/Follow.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2022 by fr33domlover . + - Written in 2022, 2024 by fr33domlover . - - ♡ Copying is an act of love. Please copy, reuse and share. - @@ -76,7 +76,8 @@ getFollowee (FolloweeActor actorByKey) = do actorByEntity <- do maybeActor <- lift $ getLocalActorEntity actorByKey fromMaybeE maybeActor "Actor not found in DB" - return (actorByKey, localActorID actorByEntity, Nothing) + actorID <- lift $ grabLocalActorID actorByEntity + return (actorByKey, actorID, Nothing) getFollowee (FolloweeWorkItem wi) = case wi of WorkItemTicket deckID taskID -> do diff --git a/src/Vervis/Recipient.hs b/src/Vervis/Recipient.hs index f3285e3..c58445c 100644 --- a/src/Vervis/Recipient.hs +++ b/src/Vervis/Recipient.hs @@ -215,6 +215,7 @@ 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 (FactoryR fkhid) = Just $ LocalActorFactory fkhid parseLocalActor _ = Nothing renderLocalActor :: LocalActor -> Route App @@ -224,6 +225,7 @@ renderLocalActor (LocalActorRepo rkhid) = RepoR rkhid renderLocalActor (LocalActorDeck dkhid) = DeckR dkhid renderLocalActor (LocalActorLoom lkhid) = LoomR lkhid renderLocalActor (LocalActorProject jkhid) = ProjectR jkhid +renderLocalActor (LocalActorFactory fkhid) = FactoryR fkhid parseLocalResource :: Route App -> Maybe (LocalResourceBy KeyHashid) parseLocalResource (GroupR gkhid) = Just $ LocalResourceGroup gkhid @@ -231,6 +233,7 @@ parseLocalResource (RepoR rkhid) = Just $ LocalResourceRepo rkhid parseLocalResource (DeckR dkhid) = Just $ LocalResourceDeck dkhid parseLocalResource (LoomR lkhid) = Just $ LocalResourceLoom lkhid parseLocalResource (ProjectR jkhid) = Just $ LocalResourceProject jkhid +parseLocalResource (FactoryR fkhid) = Just $ LocalResourceFactory fkhid parseLocalResource _ = Nothing renderLocalResource :: LocalResourceBy KeyHashid -> Route App @@ -239,6 +242,7 @@ renderLocalResource (LocalResourceRepo rkhid) = RepoR rkhid renderLocalResource (LocalResourceDeck dkhid) = DeckR dkhid renderLocalResource (LocalResourceLoom lkhid) = LoomR lkhid renderLocalResource (LocalResourceProject jkhid) = ProjectR jkhid +renderLocalResource (LocalResourceFactory fkhid) = FactoryR fkhid data LocalStageBy f = LocalStagePersonFollowers (f Person) @@ -254,6 +258,8 @@ data LocalStageBy f | LocalStageClothFollowers (f Loom) (f TicketLoom) | LocalStageProjectFollowers (f Project) + + | LocalStageFactoryFollowers (f Factory) deriving (Generic, FunctorB, ConstraintsB) deriving instance AllBF Eq f LocalStageBy => Eq (LocalStageBy f) @@ -278,6 +284,8 @@ parseLocalStage (ClothFollowersR lkhid ltkhid) = Just $ LocalStageClothFollowers lkhid ltkhid parseLocalStage (ProjectFollowersR jkhid) = Just $ LocalStageProjectFollowers jkhid +parseLocalStage (FactoryFollowersR fkhid) = + Just $ LocalStageFactoryFollowers fkhid parseLocalStage _ = Nothing renderLocalStage :: LocalStage -> Route App @@ -297,6 +305,8 @@ renderLocalStage (LocalStageClothFollowers lkhid ltkhid) = ClothFollowersR lkhid ltkhid renderLocalStage (LocalStageProjectFollowers jkhid) = ProjectFollowersR jkhid +renderLocalStage (LocalStageFactoryFollowers fkhid) = + FactoryFollowersR fkhid parseLocalRecipient :: Route App -> Maybe (Either LocalActor LocalStage) parseLocalRecipient r = @@ -309,6 +319,7 @@ localActorFollowers (LocalActorRepo r) = LocalStageRepoFollowers r localActorFollowers (LocalActorDeck d) = LocalStageDeckFollowers d localActorFollowers (LocalActorLoom l) = LocalStageLoomFollowers l localActorFollowers (LocalActorProject j) = LocalStageProjectFollowers j +localActorFollowers (LocalActorFactory f) = LocalStageFactoryFollowers f ------------------------------------------------------------------------------- -- Converting between KeyHashid, Key, Identity and Entity @@ -412,6 +423,8 @@ hashLocalStagePure ctx = f (encodeKeyHashidPure ctx c) f (LocalStageProjectFollowers j) = LocalStageProjectFollowers $ encodeKeyHashidPure ctx j + f (LocalStageFactoryFollowers j) = + LocalStageFactoryFollowers $ encodeKeyHashidPure ctx j getHashLocalStage :: (MonadSite m, YesodHashids (SiteEnv m)) @@ -451,6 +464,8 @@ unhashLocalStagePure ctx = f <*> decodeKeyHashidPure ctx c f (LocalStageProjectFollowers j) = LocalStageProjectFollowers <$> decodeKeyHashidPure ctx j + f (LocalStageFactoryFollowers j) = + LocalStageFactoryFollowers <$> decodeKeyHashidPure ctx j unhashLocalStage :: (MonadSite m, YesodHashids (SiteEnv m)) @@ -493,6 +508,10 @@ 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 +getLocalActorID (LocalActorFactory f) = do + maybeResourceID <- fmap factoryResource <$> get f + for maybeResourceID $ \ resourceID -> + resourceActor <$> getJust resourceID ------------------------------------------------------------------------------- -- Intermediate recipient types @@ -518,6 +537,8 @@ data LeafLoom = LeafLoom | LeafLoomFollowers deriving (Eq, Ord) data LeafProject = LeafProject | LeafProjectFollowers deriving (Eq, Ord) +data LeafFactory = LeafFactory | LeafFactoryFollowers deriving (Eq, Ord) + data PieceDeck = PieceDeck LeafDeck | PieceTicket (KeyHashid TicketDeck) LeafTicket @@ -535,6 +556,7 @@ data LocalRecipient | RecipDeck (KeyHashid Deck) PieceDeck | RecipLoom (KeyHashid Loom) PieceLoom | RecipProject (KeyHashid Project) LeafProject + | RecipFactory (KeyHashid Factory) LeafFactory deriving (Eq, Ord) recipientFromActor :: LocalActor -> LocalRecipient @@ -550,6 +572,8 @@ recipientFromActor (LocalActorLoom lkhid) = RecipLoom lkhid $ PieceLoom LeafLoom recipientFromActor (LocalActorProject jkhid) = RecipProject jkhid LeafProject +recipientFromActor (LocalActorFactory fkhid) = + RecipFactory fkhid LeafFactory recipientFromStage :: LocalStage -> LocalRecipient recipientFromStage (LocalStagePersonFollowers pkhid) = @@ -568,6 +592,8 @@ recipientFromStage (LocalStageClothFollowers lkhid ltkhid) = RecipLoom lkhid $ PieceCloth ltkhid LeafClothFollowers recipientFromStage (LocalStageProjectFollowers jkhid) = RecipProject jkhid LeafProjectFollowers +recipientFromStage (LocalStageFactoryFollowers fkhid) = + RecipFactory fkhid LeafFactoryFollowers ------------------------------------------------------------------------------- -- Recipient set types @@ -589,21 +615,24 @@ groupLocalRecipients = organize . partitionByActor , [(KeyHashid Deck, PieceDeck)] , [(KeyHashid Loom, PieceLoom)] , [(KeyHashid Project, LeafProject)] + , [(KeyHashid Factory, LeafFactory)] ) - partitionByActor = foldl' f ([], [], [], [], [], []) + partitionByActor = foldl' f ([], [], [], [], [], [], []) where - 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) + f (p, g, r, d, l, j, f') (RecipPerson pkhid pleaf) = + ((pkhid, pleaf) : p, g, r, d, l, j, f') + f (p, g, r, d, l, j, f') (RecipGroup gkhid gleaf) = + (p, (gkhid, gleaf) : g, r, d, l, j, f') + f (p, g, r, d, l, j, f') (RecipRepo rkhid rleaf) = + (p, g, (rkhid, rleaf) : r, d, l, j, f') + f (p, g, r, d, l, j, f') (RecipDeck dkhid dpiece) = + (p, g, r, (dkhid, dpiece) : d, l, j, f') + f (p, g, r, d, l, j, f') (RecipLoom lkhid lpiece) = + (p, g, r, d, (lkhid, lpiece) : l, j, f') + f (p, g, r, d, l, j, f') (RecipProject jkhid jleaf) = + (p, g, r, d, l, (jkhid, jleaf) : j, f') + f (p, g, r, d, l, j, f') (RecipFactory fkhid fleaf) = + (p, g, r, d, l, j, (fkhid, fleaf) : f') organize :: ( [(KeyHashid Person, LeafPerson)] @@ -612,9 +641,10 @@ groupLocalRecipients = organize . partitionByActor , [(KeyHashid Deck, PieceDeck)] , [(KeyHashid Loom, PieceLoom)] , [(KeyHashid Project, LeafProject)] + , [(KeyHashid Factory, LeafFactory)] ) -> RecipientRoutes - organize (p, g, r, d, l, j) = RecipientRoutes + organize (p, g, r, d, l, j, f) = RecipientRoutes { recipPeople = map (second $ foldr orLP $ PersonRoutes False False) $ groupByKeySort p , recipGroups = @@ -645,6 +675,8 @@ groupLocalRecipients = organize . partitionByActor groupByKeySort l , recipProjects = map (second $ foldr orLJ $ ProjectRoutes False False) $ groupByKeySort j + , recipFactories = + map (second $ foldr orLF $ FactoryRoutes False False) $ groupByKeySort f } where groupByKey :: (Foldable f, Eq a) => f (a, b) -> [(a, NonEmpty b)] @@ -691,6 +723,11 @@ groupLocalRecipients = organize . partitionByActor orLJ LeafProject rr@(ProjectRoutes _ _) = rr { routeProject = True } orLJ LeafProjectFollowers rr@(ProjectRoutes _ _) = rr { routeProjectFollowers = True } + orLF :: LeafFactory -> FactoryRoutes -> FactoryRoutes + orLF _ rr@(FactoryRoutes True True) = rr + orLF LeafFactory rr@(FactoryRoutes _ _) = rr { routeFactory = True } + orLF LeafFactoryFollowers rr@(FactoryRoutes _ _) = rr { routeFactoryFollowers = True } + pd2either :: PieceDeck -> Either LeafDeck (KeyHashid TicketDeck, LeafTicket) pd2either (PieceDeck ld) = Left ld pd2either (PieceTicket ltkhid lt) = Right (ltkhid, lt) @@ -729,6 +766,7 @@ localRecipSieve' sieve allowPeople allowOthers routes = RecipientRoutes , recipDecks = applySieve' applyDeck recipDecks , recipLooms = applySieve' applyLoom recipLooms , recipProjects = applySieve' applyProject recipProjects + , recipFactories = applySieve' applyFactory recipFactories } where applySieve @@ -843,6 +881,17 @@ localRecipSieve' sieve allowPeople allowOthers routes = RecipientRoutes then Nothing else Just (rkhid, merged) + applyFactory _ (This _) = Nothing + applyFactory rkhid (That r) = + if allowOthers && routeFactory r + then Just (rkhid, FactoryRoutes True False) + else Nothing + applyFactory rkhid (These (FactoryRoutes r' rf') (FactoryRoutes r rf)) = + let merged = FactoryRoutes (r && (r' || allowOthers)) (rf && rf') + in if merged == FactoryRoutes False False + then Nothing + else Just (rkhid, merged) + data ParsedAudience u = ParsedAudience { paudLocalRecips :: RecipientRoutes , paudRemoteActors :: [(Authority u, NonEmpty LocalURI)] diff --git a/src/Vervis/Settings.hs b/src/Vervis/Settings.hs index 3e95ae5..921db29 100644 --- a/src/Vervis/Settings.hs +++ b/src/Vervis/Settings.hs @@ -156,6 +156,8 @@ data AppSettings = AppSettings -- | SMTP server details for sending email, and other email related -- details. If set to 'Nothing', no email will be sent. , appMail :: Maybe MailSettings + -- | People's usernames who are allowed to create Factory actors + , appCanCreateFactories :: [Text] -- | Whether to support federation. This includes: -- @@ -254,6 +256,7 @@ instance FromJSON AppSettings where appAccounts <- o .: "max-accounts" appEmailVerification <- o .:? "email-verification" .!= not defaultDev appMail <- o .:? "mail" + appCanCreateFactories <- o .:? "can-create-factories" .!= [] appFederation <- o .:? "federation" .!= False appCapabilitySigningKeyFile <- o .: "capability-signing-key" diff --git a/src/Vervis/Web/Actor.hs b/src/Vervis/Web/Actor.hs index 41e1887..bb4c9bc 100644 --- a/src/Vervis/Web/Actor.hs +++ b/src/Vervis/Web/Actor.hs @@ -17,15 +17,20 @@ module Vervis.Web.Actor ( getInbox , getInbox' + , getInbox'' , postInbox , getOutbox + , getOutbox' , getOutboxItem + , getOutboxItem' , getFollowersCollection , getActorFollowersCollection + , getActorFollowersCollection' , getFollowingCollection , handleRobotInbox , serveInstanceKey , servePerActorKey + , servePerActorKey'' ) where @@ -80,7 +85,6 @@ import qualified Database.Esqueleto as E import Control.Concurrent.Actor hiding (Actor) import Database.Persist.JSON import Network.FedURI -import Web.ActivityPub hiding (Project (..), ActorLocal (..)) import Yesod.ActivityPub import Yesod.Auth.Unverified import Yesod.FedURI @@ -90,6 +94,7 @@ import Yesod.RenderSource import qualified Control.Concurrent.Actor as CCA import qualified Crypto.ActorKey as AK +import qualified Web.ActivityPub as AP import Control.Monad.Trans.Except.Local import Data.Aeson.Local @@ -143,11 +148,15 @@ objectId o = getInbox = getInbox' actorInbox -getInbox' grabInbox here actor hash = do +getInbox' grabInbox here actor hash = + getInbox'' grabInbox here (pure . actor) hash + +getInbox'' grabInbox here getActorID hash = do key <- decodeKeyHashid404 hash (total, pages, mpage) <- runDB $ do inboxID <- do - actorID <- actor <$> get404 key + rec <- get404 key + actorID <- getActorID rec grabInbox <$> getJust actorID getPageAndNavCount (countItems inboxID) @@ -161,37 +170,37 @@ getInbox' grabInbox here actor hash = do selectRep $ case mpage of Nothing -> do - provideAP $ pure $ Doc host $ Collection - { collectionId = encodeRouteLocal here' - , collectionType = CollectionTypeOrdered - , collectionTotalItems = Just total - , collectionCurrent = Nothing - , collectionFirst = Just $ pageUrl 1 - , collectionLast = Just $ pageUrl pages - , collectionItems = [] :: [Text] - , collectionContext = Nothing + AP.provideAP $ pure $ AP.Doc host $ AP.Collection + { AP.collectionId = encodeRouteLocal here' + , AP.collectionType = AP.CollectionTypeOrdered + , AP.collectionTotalItems = Just total + , AP.collectionCurrent = Nothing + , AP.collectionFirst = Just $ pageUrl 1 + , AP.collectionLast = Just $ pageUrl pages + , AP.collectionItems = [] :: [Text] + , AP.collectionContext = Nothing } provideRep (redirectFirstPage here' :: Handler Html) Just (items, navModel) -> do let current = nmCurrent navModel - provideAP $ pure $ Doc host $ CollectionPage - { collectionPageId = pageUrl current - , collectionPageType = CollectionPageTypeOrdered - , collectionPageTotalItems = Nothing - , collectionPageCurrent = Just $ pageUrl current - , collectionPageFirst = Just $ pageUrl 1 - , collectionPageLast = Just $ pageUrl pages - , collectionPagePartOf = encodeRouteLocal here' - , collectionPagePrev = + AP.provideAP $ pure $ AP.Doc host $ AP.CollectionPage + { AP.collectionPageId = pageUrl current + , AP.collectionPageType = AP.CollectionPageTypeOrdered + , AP.collectionPageTotalItems = Nothing + , AP.collectionPageCurrent = Just $ pageUrl current + , AP.collectionPageFirst = Just $ pageUrl 1 + , AP.collectionPageLast = Just $ pageUrl pages + , AP.collectionPagePartOf = encodeRouteLocal here' + , AP.collectionPagePrev = if current > 1 then Just $ pageUrl $ current - 1 else Nothing - , collectionPageNext = + , AP.collectionPageNext = if current < pages then Just $ pageUrl $ current + 1 else Nothing - , collectionPageStartIndex = Nothing - , collectionPageItems = map (view _1) items + , AP.collectionPageStartIndex = Nothing + , AP.collectionPageItems = map (view _1) items } provideRep $ do let pageNav = navWidget navModel @@ -262,7 +271,8 @@ postInbox TVar (M.HashMap GroupId (ActorRef Group)), TVar (M.HashMap DeckId (ActorRef Deck)), TVar (M.HashMap LoomId (ActorRef Loom)), - TVar (M.HashMap RepoId (ActorRef Vervis.Model.Repo))] + TVar (M.HashMap RepoId (ActorRef Vervis.Model.Repo)), + TVar (M.HashMap FactoryId (ActorRef Factory))] l'0 , H.HOccurs' (TVar (M.HashMap (Key a) (ActorRef a))) @@ -272,7 +282,8 @@ postInbox TVar (M.HashMap GroupId (ActorRef Group)), TVar (M.HashMap DeckId (ActorRef Deck)), TVar (M.HashMap LoomId (ActorRef Loom)), - TVar (M.HashMap RepoId (ActorRef Vervis.Model.Repo))] + TVar (M.HashMap RepoId (ActorRef Vervis.Model.Repo)), + TVar (M.HashMap FactoryId (ActorRef Factory))] ) => (Key a -> LocalActorBy Key) -> Key a -> Handler () postInbox toLA recipID = do @@ -290,11 +301,11 @@ postInbox toLA recipID = do parseAuthenticatedLocalActivityURI authorByKey (AP.activityId $ actbActivity body) - actorID <- do - ment <- lift $ runDB $ getLocalActorEntity authorByKey + actorID <- runDBExcept $ do + ment <- lift $ getLocalActorEntity authorByKey case ment of Nothing -> throwE "Author not found in DB" - Just ent -> return $ localActorID ent + Just ent -> lift $ grabLocalActorID ent return (authorByKey, actorID, outboxItemID) ActivityAuthRemote author -> Right <$> do luActivity <- @@ -333,11 +344,14 @@ postInbox toLA recipID = do throwE "'actor' actor and 'id' actor mismatch" return outboxItemID -getOutbox here itemRoute grabActorID hash = do +getOutbox here itemRoute grabActorID hash = + getOutbox' here itemRoute (pure . grabActorID) hash + +getOutbox' here itemRoute grabActorID hash = do key <- decodeKeyHashid404 hash (total, pages, mpage) <- runDB $ do outboxID <- do - actorID <- grabActorID <$> get404 key + actorID <- grabActorID =<< get404 key actorOutbox <$> getJust actorID let countAllItems = count [OutboxItemOutbox ==. outboxID] selectItems off lim = selectList [OutboxItemOutbox ==. outboxID] [Desc OutboxItemId, OffsetBy off, LimitTo lim] @@ -351,37 +365,37 @@ getOutbox here itemRoute grabActorID hash = do selectRep $ case mpage of Nothing -> do - provideAP $ pure $ Doc host $ Collection - { collectionId = encodeRouteLocal here' - , collectionType = CollectionTypeOrdered - , collectionTotalItems = Just total - , collectionCurrent = Nothing - , collectionFirst = Just $ pageUrl 1 - , collectionLast = Just $ pageUrl pages - , collectionItems = [] :: [Text] - , collectionContext = Nothing + AP.provideAP $ pure $ AP.Doc host $ AP.Collection + { AP.collectionId = encodeRouteLocal here' + , AP.collectionType = AP.CollectionTypeOrdered + , AP.collectionTotalItems = Just total + , AP.collectionCurrent = Nothing + , AP.collectionFirst = Just $ pageUrl 1 + , AP.collectionLast = Just $ pageUrl pages + , AP.collectionItems = [] :: [Text] + , AP.collectionContext = Nothing } provideRep (redirectFirstPage here' :: Handler Html) Just (items, navModel) -> do let current = nmCurrent navModel - provideAP $ pure $ Doc host $ CollectionPage - { collectionPageId = pageUrl current - , collectionPageType = CollectionPageTypeOrdered - , collectionPageTotalItems = Nothing - , collectionPageCurrent = Just $ pageUrl current - , collectionPageFirst = Just $ pageUrl 1 - , collectionPageLast = Just $ pageUrl pages - , collectionPagePartOf = encodeRouteLocal here' - , collectionPagePrev = + AP.provideAP $ pure $ AP.Doc host $ AP.CollectionPage + { AP.collectionPageId = pageUrl current + , AP.collectionPageType = AP.CollectionPageTypeOrdered + , AP.collectionPageTotalItems = Nothing + , AP.collectionPageCurrent = Just $ pageUrl current + , AP.collectionPageFirst = Just $ pageUrl 1 + , AP.collectionPageLast = Just $ pageUrl pages + , AP.collectionPagePartOf = encodeRouteLocal here' + , AP.collectionPagePrev = if current > 1 then Just $ pageUrl $ current - 1 else Nothing - , collectionPageNext = + , AP.collectionPageNext = if current < pages then Just $ pageUrl $ current + 1 else Nothing - , collectionPageStartIndex = Nothing - , collectionPageItems = map (persistJSONObject . outboxItemActivity . entityVal) items + , AP.collectionPageStartIndex = Nothing + , AP.collectionPageItems = map (persistJSONObject . outboxItemActivity . entityVal) items } provideRep $ do let pageNav = navWidget navModel @@ -389,12 +403,15 @@ getOutbox here itemRoute grabActorID hash = do hashItem <- getEncodeKeyHashid defaultLayout $(widgetFile "person/outbox") -getOutboxItem here actor topicHash itemHash = do +getOutboxItem here actor topicHash itemHash = + getOutboxItem' here (pure . actor) topicHash itemHash + +getOutboxItem' here actor topicHash itemHash = do topicID <- decodeKeyHashid404 topicHash itemID <- decodeKeyHashid404 itemHash body <- runDB $ do outboxID <- do - actorID <- actor <$> get404 topicID + actorID <- actor =<< get404 topicID actorOutbox <$> getJust actorID item <- get404 itemID unless (outboxItemOutbox item == outboxID) notFound @@ -405,6 +422,7 @@ getOutboxItem here actor topicHash itemHash = do getLocalActors :: [ActorId] -> ReaderT SqlBackend Handler [LocalActorBy Key] getLocalActors actorIDs = do + resourceIDs <- selectKeysList [ResourceActor <-. actorIDs] [] localActors <- concat <$> sequenceA [ map LocalActorPerson <$> @@ -419,6 +437,8 @@ getLocalActors actorIDs = do selectKeysList [LoomActor <-. actorIDs] [] , map LocalActorProject <$> selectKeysList [ProjectActor <-. actorIDs] [] + , map LocalActorFactory <$> + selectKeysList [FactoryResource <-. resourceIDs] [] ] case compare (length localActors) (length actorIDs) of LT -> error "Found actor ID not used by any specific actor" @@ -453,26 +473,29 @@ getFollowersCollection here getFsid = do encodeRouteLocal <- getEncodeRouteLocal encodeRouteHome <- getEncodeRouteHome hashActor <- getHashLocalActor - let followersAP = Collection - { collectionId = encodeRouteLocal here - , collectionType = CollectionTypeUnordered - , collectionTotalItems = Just $ l + r - , collectionCurrent = Nothing - , collectionFirst = Nothing - , collectionLast = Nothing - , collectionItems = + let followersAP = AP.Collection + { AP.collectionId = encodeRouteLocal here + , AP.collectionType = AP.CollectionTypeUnordered + , AP.collectionTotalItems = Just $ l + r + , AP.collectionCurrent = Nothing + , AP.collectionFirst = Nothing + , AP.collectionLast = Nothing + , AP.collectionItems = map (encodeRouteHome . renderLocalActor . hashActor) locals ++ map (uncurry ObjURI . bimap E.unValue E.unValue) remotes - , collectionContext = Nothing + , AP.collectionContext = Nothing } provideHtmlAndAP followersAP $ redirectToPrettyJSON here -getActorFollowersCollection here actor hash = do +getActorFollowersCollection here actor hash = + getActorFollowersCollection' here (pure . actor) hash + +getActorFollowersCollection' here actor hash = do key <- decodeKeyHashid404 hash getFollowersCollection (here hash) (getFsid key) where getFsid key = do - actorID <- actor <$> get404 key + actorID <- actor =<< get404 key actorFollowers <$> getJust actorID getFollowingCollection here actor hash = do @@ -500,15 +523,15 @@ getFollowingCollection here actor hash = do encodeRouteLocal <- getEncodeRouteLocal encodeRouteHome <- getEncodeRouteHome let here' = here hash - followingAP = Collection - { collectionId = encodeRouteLocal here' - , collectionType = CollectionTypeUnordered - , collectionTotalItems = Just $ localTotal + length remotes - , collectionCurrent = Nothing - , collectionFirst = Nothing - , collectionLast = Nothing - , collectionItems = map encodeRouteHome locals ++ remotes - , collectionContext = Nothing + followingAP = AP.Collection + { AP.collectionId = encodeRouteLocal here' + , AP.collectionType = AP.CollectionTypeUnordered + , AP.collectionTotalItems = Just $ localTotal + length remotes + , AP.collectionCurrent = Nothing + , AP.collectionFirst = Nothing + , AP.collectionLast = Nothing + , AP.collectionItems = map encodeRouteHome locals ++ remotes + , AP.collectionContext = Nothing } provideHtmlAndAP followingAP $ redirectToPrettyJSON here' where @@ -531,7 +554,7 @@ handleRobotInbox -> ActivityBody -> Maybe (RecipientRoutes, ByteString) -> LocalURI - -> SpecificActivity URIMode + -> AP.SpecificActivity URIMode -> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text)) ) -> UTCTime @@ -544,13 +567,13 @@ handleRobotInbox recipByHash handleSpecific now auth body = do ActivityAuthLocal _ -> throwE "Got a forwarded local activity, I don't need those" ActivityAuthRemote ra -> return ra luActivity <- - fromMaybeE (activityId $ actbActivity body) "Activity without 'id'" + fromMaybeE (AP.activityId $ actbActivity body) "Activity without 'id'" localRecips <- do - mrecips <- parseAudience $ activityAudience $ actbActivity body + mrecips <- parseAudience $ AP.activityAudience $ actbActivity body paudLocalRecips <$> fromMaybeE mrecips "Activity with no recipients" msig <- checkForwarding recipByHash let mfwd = (localRecips,) <$> msig - handleSpecific now remoteAuthor body mfwd luActivity (activitySpecific $ actbActivity body) + handleSpecific now remoteAuthor body mfwd luActivity (AP.activitySpecific $ actbActivity body) actorKeyAP :: ( MonadSite m, SiteEnv m ~ site @@ -602,11 +625,21 @@ servePerActorKey -> KeyHashid holder -> KeyHashid SigKey -> Handler TypedContent -servePerActorKey holderActor localActorHolder holderHash keyHash = do +servePerActorKey holderActor localActorHolder holderHash keyHash = + servePerActorKey'' (pure . holderActor) localActorHolder holderHash keyHash + +servePerActorKey'' + :: (PersistRecordBackend holder SqlBackend, ToBackendKey SqlBackend holder) + => (holder -> AppDB ActorId) + -> (KeyHashid holder -> LocalActorBy KeyHashid) + -> KeyHashid holder + -> KeyHashid SigKey + -> Handler TypedContent +servePerActorKey'' holderActor localActorHolder holderHash keyHash = do holderID <- decodeKeyHashid404 holderHash keyID <- decodeKeyHashid404 keyHash akey <- runDB $ do - actorID <- holderActor <$> get404 holderID + actorID <- holderActor =<< get404 holderID SigKey actorID' akey <- get404 keyID unless (actorID' == actorID) notFound return akey diff --git a/src/Vervis/Widget/Person.hs b/src/Vervis/Widget/Person.hs index e56a0d5..c4d8d6b 100644 --- a/src/Vervis/Widget/Person.hs +++ b/src/Vervis/Widget/Person.hs @@ -75,6 +75,7 @@ personLinkFedW (Right (inztance, object, actor)) = AP.ActorTypePatchTracker -> '+' AP.ActorTypeProject -> '$' AP.ActorTypeTeam -> '&' + AP.ActorTypeFactory -> '*' AP.ActorTypeOther _ -> '?' followW :: Route App -> Route App -> FollowerSetId -> Widget diff --git a/src/Vervis/Widget/Tracker.hs b/src/Vervis/Widget/Tracker.hs index 70831c8..cbcb5a5 100644 --- a/src/Vervis/Widget/Tracker.hs +++ b/src/Vervis/Widget/Tracker.hs @@ -17,6 +17,7 @@ module Vervis.Widget.Tracker ( deckNavW , loomNavW , projectNavW + , factoryNavW , componentLinkFedW , projectLinkFedW , groupLinkFedW @@ -81,6 +82,11 @@ groupNavW (Entity groupID group) actor = do groupHash <- encodeKeyHashid groupID $(widgetFile "group/nav") +factoryNavW :: Entity Factory -> Actor -> Widget +factoryNavW (Entity factoryID factory) actor = do + factoryHash <- encodeKeyHashid factoryID + $(widgetFile "factory/nav") + componentLinkW :: ComponentBy Key -> Actor -> Widget componentLinkW (ComponentRepo k) actor = do h <- encodeKeyHashid k @@ -155,6 +161,12 @@ actorLinkW (LocalActorGroup k) actor = do &#{keyHashidText h} #{actorName actor} |] +actorLinkW (LocalActorFactory k) actor = do + h <- encodeKeyHashid k + [whamlet| + + *#{keyHashidText h} #{actorName actor} + |] actorLinkFedW :: Either (LocalActorBy Key, Actor) (Instance, RemoteObject, RemoteActor) @@ -188,6 +200,7 @@ remoteActorLinkW (inztance, object, actor) = do AP.ActorTypePatchTracker -> '+' AP.ActorTypeProject -> '$' AP.ActorTypeTeam -> '&' + AP.ActorTypeFactory -> '*' AP.ActorTypeOther _ -> '?' personPermitsForResourceW diff --git a/src/Web/ActivityPub.hs b/src/Web/ActivityPub.hs index 21f9c43..b71a21b 100644 --- a/src/Web/ActivityPub.hs +++ b/src/Web/ActivityPub.hs @@ -57,6 +57,7 @@ module Web.ActivityPub , ResourceWithCollections (..) , Project (..) , Team (..) + , Factory (..) -- * Content objects , Note (..) @@ -493,6 +494,7 @@ data ActorType | ActorTypePatchTracker | ActorTypeProject | ActorTypeTeam + | ActorTypeFactory | ActorTypeOther Text deriving Eq @@ -508,6 +510,7 @@ actorTypeIsResource = \case ActorTypePatchTracker -> True ActorTypeProject -> True ActorTypeTeam -> True + ActorTypeFactory -> True _ -> False actorTypeIsResourceNT t = actorTypeIsResource t && t /= ActorTypeTeam @@ -520,6 +523,7 @@ parseActorType t | t == "PatchTracker" = ActorTypePatchTracker | t == "Project" = ActorTypeProject | t == "Team" = ActorTypeTeam + | t == "Factory" = ActorTypeFactory | otherwise = ActorTypeOther t renderActorType :: ActorType -> Text @@ -530,6 +534,7 @@ renderActorType = \case ActorTypePatchTracker -> "PatchTracker" ActorTypeProject -> "Project" ActorTypeTeam -> "Team" + ActorTypeFactory -> "Factory" ActorTypeOther t -> t instance FromJSON ActorType where @@ -1093,6 +1098,27 @@ instance ActivityPub Team where <> "members" .= ObjURI h members <> "teamResources" .= ObjURI h resources +data Factory u = Factory + { factoryActor :: Actor u + , factoryCollabs :: LocalURI + , factoryTeams :: LocalURI + } + +instance ActivityPub Factory where + jsonldContext _ = [as2Context, secContext, forgeContext] + parseObject o = do + (h, a) <- parseObject o + unless (actorType (actorDetail a) == ActorTypeFactory) $ + fail "Actor type isn't Factory" + fmap (h,) $ + Factory a + <$> withAuthorityO h (o .: "collaborators") + <*> withAuthorityO h (o .: "teams") + toSeries h (Factory actor collabs teams) + = toSeries h actor + <> "collaborators" .= ObjURI h collabs + <> "teams" .= ObjURI h teams + data Audience u = Audience { audienceTo :: [ObjURI u] , audienceBto :: [ObjURI u] @@ -1978,6 +2004,7 @@ data CreateObject u | CreatePatchTracker ActorDetail (NonEmpty (ObjURI u)) (Maybe (Authority u, ActorLocal u)) | CreateProject ActorDetail (Maybe (Authority u, ActorLocal u)) | CreateTeam ActorDetail (Maybe (Authority u, ActorLocal u)) + | CreateFactory ActorDetail (Maybe (Authority u, ActorLocal u)) parseCreateObject :: UriMode u => Object -> Parser (CreateObject u) parseCreateObject o @@ -2010,6 +2037,11 @@ parseCreateObject o fail "type isn't Team" ml <- parseActorLocal o return $ CreateTeam d ml + <|> do f <- parseActorDetail o + unless (actorType f == ActorTypeFactory) $ + fail "type isn't Factory" + ml <- parseActorLocal o + return $ CreateFactory f ml encodeCreateObject :: UriMode u => CreateObject u -> Series encodeCreateObject (CreateNote h note) = toSeries h note @@ -2028,6 +2060,8 @@ encodeCreateObject (CreateProject d ml) = encodeActorDetail d <> maybe mempty (uncurry encodeActorLocal) ml encodeCreateObject (CreateTeam d ml) = encodeActorDetail d <> maybe mempty (uncurry encodeActorLocal) ml +encodeCreateObject (CreateFactory d ml) = + encodeActorDetail d <> maybe mempty (uncurry encodeActorLocal) ml data Create u = Create { createObject :: CreateObject u @@ -2049,6 +2083,7 @@ parseCreate o a luActor = do CreatePatchTracker _ _ _ -> return () CreateProject _ _ -> return () CreateTeam _ _ -> return () + CreateFactory _ _ -> return () Create obj <$> o .:? "target" encodeCreate :: UriMode u => Create u -> Series diff --git a/templates/browse.hamlet b/templates/browse.hamlet index b76332d..ab46402 100644 --- a/templates/browse.hamlet +++ b/templates/browse.hamlet @@ -75,6 +75,8 @@ $# #forgefed @ Libera Chat