Add a new actor type: Factory

- No factories inserted to DB yet
- Admin user list specified in settings
- Admins can create a Factory via C2S
- Creating other actors via C2S the old way still works as well
- Factory S2S handler implementation still blank

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

migrations/649_2024-07-29_factory.model

@@ -0,0 +1,6 @@
+Factory
+    resource ResourceId
+    create   OutboxItemId
+
+    UniqueFactory       resource
+    UniqueFactoryCreate create

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

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) =
+        f (p, j, g, d, l, r, f') (LocalActorPerson k) =
-            (HS.insert k p, j, g, d, l, r)
+            (HS.insert k p, j, g, d, l, r, f')
-        f (p, j, g, d, l, r) (LocalActorProject k) =
+        f (p, j, g, d, l, r, f') (LocalActorProject k) =
-            (p, HS.insert k j, g, d, l, r)
+            (p, HS.insert k j, g, d, l, r, f')
-        f (p, j, g, d, l, r) (LocalActorGroup k) =
+        f (p, j, g, d, l, r, f') (LocalActorGroup k) =
-            (p, j, HS.insert k g, d, l, r)
+            (p, j, HS.insert k g, d, l, r, f')
-        f (p, j, g, d, l, r) (LocalActorDeck k) =
+        f (p, j, g, d, l, r, f') (LocalActorDeck k) =
-            (p, j, g, HS.insert k d, l, r)
+            (p, j, g, HS.insert k d, l, r, f')
-        f (p, j, g, d, l, r) (LocalActorLoom k) =
+        f (p, j, g, d, l, r, f') (LocalActorLoom k) =
-            (p, j, g, d, HS.insert k l, r)
+            (p, j, g, d, HS.insert k l, r, f')
-        f (p, j, g, d, l, r) (LocalActorRepo k) =
+        f (p, j, g, d, l, r, f') (LocalActorRepo k) =
-            (p, j, g, d, l, HS.insert k r)
+            (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

src/Vervis/Actor/Factory.hs

@@ -0,0 +1,65 @@
+{- This file is part of Vervis.
+ -
+ - Written in 2024 by fr33domlover <fr33domlover@riseup.net>.
+ -
+ - ♡ Copying is an act of love. Please copy, reuse and share.
+ -
+ - The author(s) have dedicated all copyright and related and neighboring
+ - rights to this software to the public domain worldwide. This software is
+ - distributed without any warranty.
+ -
+ - You should have received a copy of the CC0 Public Domain Dedication along
+ - with this software. If not, see
+ - <http://creativecommons.org/publicdomain/zero/1.0/>.
+ -}
+
+module Vervis.Actor.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

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

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

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

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
+grabLocalActorID :: MonadIO m => LocalActorBy Entity -> SqlPersistT m ActorId
-localActorID (LocalActorPerson (Entity _ p)) = personActor p
+grabLocalActorID (LocalActorPerson (Entity _ p)) = pure $ personActor p
-localActorID (LocalActorGroup (Entity _ g))  = groupActor g
+grabLocalActorID (LocalActorGroup (Entity _ g))  = pure $ groupActor g
-localActorID (LocalActorRepo (Entity _ r))   = repoActor r
+grabLocalActorID (LocalActorRepo (Entity _ r))   = pure $ repoActor r
-localActorID (LocalActorDeck (Entity _ d))   = deckActor d
+grabLocalActorID (LocalActorDeck (Entity _ d))   = pure $ deckActor d
-localActorID (LocalActorLoom (Entity _ l))   = loomActor l
+grabLocalActorID (LocalActorLoom (Entity _ l))   = pure $ loomActor l
-localActorID (LocalActorProject (Entity _ r))   = projectActor r
+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

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

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

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)

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)
+                f = filter ((== AP.ActorTypeFactory) . typ) xs
-            in  (p, r, d, l, j, g, x)
+                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

src/Vervis/Handler/Factory.hs

@@ -0,0 +1,418 @@
+{- This file is part of Vervis.
+ -
+ - Written in 2016, 2019, 2022, 2023, 2024
+ - by fr33domlover <fr33domlover@riseup.net>.
+ -
+ - ♡ Copying is an act of love. Please copy, reuse and share.
+ -
+ - The author(s) have dedicated all copyright and related and neighboring
+ - rights to this software to the public domain worldwide. This software is
+ - distributed without any warranty.
+ -
+ - You should have received a copy of the CC0 Public Domain Dedication along
+ - with this software. If not, see
+ - <http://creativecommons.org/publicdomain/zero/1.0/>.
+ -}
+
+module Vervis.Handler.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

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

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

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

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
+        case (mp, mg, mr, md, ml, mj, mf) of
-            (Nothing, Nothing, Nothing, Nothing, Nothing, Nothing) -> error "Unused ActorId"
+            (Nothing, Nothing, Nothing, Nothing, Nothing, Nothing, Nothing) -> error "Unused ActorId"
-            (Just p, Nothing, Nothing, Nothing, Nothing, Nothing) -> LocalActorPerson p
+            (Just p, Nothing, Nothing, Nothing, Nothing, Nothing, Nothing) -> LocalActorPerson p
-            (Nothing, Just g, Nothing, Nothing, Nothing, Nothing) -> LocalActorGroup g
+            (Nothing, Just g, Nothing, Nothing, Nothing, Nothing, Nothing) -> LocalActorGroup g
-            (Nothing, Nothing, Just r, Nothing, Nothing, Nothing) -> LocalActorRepo r
+            (Nothing, Nothing, Just r, Nothing, Nothing, Nothing, Nothing) -> LocalActorRepo r
-            (Nothing, Nothing, Nothing, Just d, Nothing, Nothing) -> LocalActorDeck d
+            (Nothing, Nothing, Nothing, Just d, Nothing, Nothing, Nothing) -> LocalActorDeck d
-            (Nothing, Nothing, Nothing, Nothing, Just l, Nothing) -> LocalActorLoom l
+            (Nothing, Nothing, Nothing, Nothing, Just l, Nothing, Nothing) -> LocalActorLoom l
-            (Nothing, Nothing, Nothing, Nothing, Nothing, Just j) -> LocalActorProject j
+            (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

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

src/Vervis/Persist/Follow.hs

@@ -1,6 +1,6 @@
 {- This file is part of Vervis.
  -
- - Written in 2022 by fr33domlover <fr33domlover@riseup.net>.
+ - Written in 2022, 2024 by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ 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

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) =
+        f (p, g, r, d, l, j, f') (RecipPerson pkhid pleaf) =
-            ((pkhid, pleaf) : p, g, r, d, l, j)
+            ((pkhid, pleaf) : p, g, r, d, l, j, f')
-        f (p, g, r, d, l, j) (RecipGroup gkhid gleaf) =
+        f (p, g, r, d, l, j, f') (RecipGroup gkhid gleaf) =
-            (p, (gkhid, gleaf) : g, r, d, l, j)
+            (p, (gkhid, gleaf) : g, r, d, l, j, f')
-        f (p, g, r, d, l, j) (RecipRepo rkhid rleaf) =
+        f (p, g, r, d, l, j, f') (RecipRepo rkhid rleaf) =
-            (p, g, (rkhid, rleaf) : r, d, l, j)
+            (p, g, (rkhid, rleaf) : r, d, l, j, f')
-        f (p, g, r, d, l, j) (RecipDeck dkhid dpiece) =
+        f (p, g, r, d, l, j, f') (RecipDeck dkhid dpiece) =
-            (p, g, r, (dkhid, dpiece) : d, l, j)
+            (p, g, r, (dkhid, dpiece) : d, l, j, f')
-        f (p, g, r, d, l, j) (RecipLoom lkhid lpiece) =
+        f (p, g, r, d, l, j, f') (RecipLoom lkhid lpiece) =
-            (p, g, r, d, (lkhid, lpiece) : l, j)
+            (p, g, r, d, (lkhid, lpiece) : l, j, f')
-        f (p, g, r, d, l, j) (RecipProject jkhid jleaf) =
+        f (p, g, r, d, l, j, f') (RecipProject jkhid jleaf) =
-            (p, g, r, d, l, (jkhid, jleaf) : j)
+            (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)]

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"

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
+                AP.provideAP $ pure $ AP.Doc host $ AP.Collection
-                    { collectionId         = encodeRouteLocal here'
+                    { AP.collectionId         = encodeRouteLocal here'
-                    , collectionType       = CollectionTypeOrdered
+                    , AP.collectionType       = AP.CollectionTypeOrdered
-                    , collectionTotalItems = Just total
+                    , AP.collectionTotalItems = Just total
-                    , collectionCurrent    = Nothing
+                    , AP.collectionCurrent    = Nothing
-                    , collectionFirst      = Just $ pageUrl 1
+                    , AP.collectionFirst      = Just $ pageUrl 1
-                    , collectionLast       = Just $ pageUrl pages
+                    , AP.collectionLast       = Just $ pageUrl pages
-                    , collectionItems      = [] :: [Text]
+                    , AP.collectionItems      = [] :: [Text]
-                    , collectionContext    = Nothing
+                    , AP.collectionContext    = Nothing
                     }
                 provideRep (redirectFirstPage here' :: Handler Html)
             Just (items, navModel) -> do
                 let current = nmCurrent navModel
-                provideAP $ pure $ Doc host $ CollectionPage
+                AP.provideAP $ pure $ AP.Doc host $ AP.CollectionPage
-                    { collectionPageId         = pageUrl current
+                    { AP.collectionPageId         = pageUrl current
-                    , collectionPageType       = CollectionPageTypeOrdered
+                    , AP.collectionPageType       = AP.CollectionPageTypeOrdered
-                    , collectionPageTotalItems = Nothing
+                    , AP.collectionPageTotalItems = Nothing
-                    , collectionPageCurrent    = Just $ pageUrl current
+                    , AP.collectionPageCurrent    = Just $ pageUrl current
-                    , collectionPageFirst      = Just $ pageUrl 1
+                    , AP.collectionPageFirst      = Just $ pageUrl 1
-                    , collectionPageLast       = Just $ pageUrl pages
+                    , AP.collectionPageLast       = Just $ pageUrl pages
-                    , collectionPagePartOf     = encodeRouteLocal here'
+                    , AP.collectionPagePartOf     = encodeRouteLocal here'
-                    , collectionPagePrev       =
+                    , 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
+                    , AP.collectionPageStartIndex = Nothing
-                    , collectionPageItems      = map (view _1) items
+                    , 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
+                    actorID <- runDBExcept $ do
-                        ment <- lift $ runDB $ getLocalActorEntity authorByKey
+                        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
+                AP.provideAP $ pure $ AP.Doc host $ AP.Collection
-                    { collectionId         = encodeRouteLocal here'
+                    { AP.collectionId         = encodeRouteLocal here'
-                    , collectionType       = CollectionTypeOrdered
+                    , AP.collectionType       = AP.CollectionTypeOrdered
-                    , collectionTotalItems = Just total
+                    , AP.collectionTotalItems = Just total
-                    , collectionCurrent    = Nothing
+                    , AP.collectionCurrent    = Nothing
-                    , collectionFirst      = Just $ pageUrl 1
+                    , AP.collectionFirst      = Just $ pageUrl 1
-                    , collectionLast       = Just $ pageUrl pages
+                    , AP.collectionLast       = Just $ pageUrl pages
-                    , collectionItems      = [] :: [Text]
+                    , AP.collectionItems      = [] :: [Text]
-                    , collectionContext    = Nothing
+                    , AP.collectionContext    = Nothing
                     }
                 provideRep (redirectFirstPage here' :: Handler Html)
             Just (items, navModel) -> do
                 let current = nmCurrent navModel
-                provideAP $ pure $ Doc host $ CollectionPage
+                AP.provideAP $ pure $ AP.Doc host $ AP.CollectionPage
-                    { collectionPageId         = pageUrl current
+                    { AP.collectionPageId         = pageUrl current
-                    , collectionPageType       = CollectionPageTypeOrdered
+                    , AP.collectionPageType       = AP.CollectionPageTypeOrdered
-                    , collectionPageTotalItems = Nothing
+                    , AP.collectionPageTotalItems = Nothing
-                    , collectionPageCurrent    = Just $ pageUrl current
+                    , AP.collectionPageCurrent    = Just $ pageUrl current
-                    , collectionPageFirst      = Just $ pageUrl 1
+                    , AP.collectionPageFirst      = Just $ pageUrl 1
-                    , collectionPageLast       = Just $ pageUrl pages
+                    , AP.collectionPageLast       = Just $ pageUrl pages
-                    , collectionPagePartOf     = encodeRouteLocal here'
+                    , AP.collectionPagePartOf     = encodeRouteLocal here'
-                    , collectionPagePrev       =
+                    , 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
+                    , AP.collectionPageStartIndex = Nothing
-                    , collectionPageItems      = map (persistJSONObject . outboxItemActivity . entityVal) items
+                    , 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
+    let followersAP = AP.Collection
-            { collectionId         = encodeRouteLocal here
+            { AP.collectionId         = encodeRouteLocal here
-            , collectionType       = CollectionTypeUnordered
+            , AP.collectionType       = AP.CollectionTypeUnordered
-            , collectionTotalItems = Just $ l + r
+            , AP.collectionTotalItems = Just $ l + r
-            , collectionCurrent    = Nothing
+            , AP.collectionCurrent    = Nothing
-            , collectionFirst      = Nothing
+            , AP.collectionFirst      = Nothing
-            , collectionLast       = Nothing
+            , AP.collectionLast       = Nothing
-            , collectionItems      =
+            , 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
+        followingAP = AP.Collection
-            { collectionId         = encodeRouteLocal here'
+            { AP.collectionId         = encodeRouteLocal here'
-            , collectionType       = CollectionTypeUnordered
+            , AP.collectionType       = AP.CollectionTypeUnordered
-            , collectionTotalItems = Just $ localTotal + length remotes
+            , AP.collectionTotalItems = Just $ localTotal + length remotes
-            , collectionCurrent    = Nothing
+            , AP.collectionCurrent    = Nothing
-            , collectionFirst      = Nothing
+            , AP.collectionFirst      = Nothing
-            , collectionLast       = Nothing
+            , AP.collectionLast       = Nothing
-            , collectionItems      = map encodeRouteHome locals ++ remotes
+            , AP.collectionItems      = map encodeRouteHome locals ++ remotes
-            , collectionContext    = Nothing
+            , 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

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

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
         <a href=@{GroupR h}>
           &#{keyHashidText h} #{actorName actor}
     |]
+actorLinkW (LocalActorFactory k) actor = do
+    h <- encodeKeyHashid k
+    [whamlet|
+        <a href=@{FactoryR h}>
+          *#{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

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

templates/browse.hamlet

@@ -75,6 +75,8 @@ $#      #forgefed @ Libera Chat
 <ul>
   $forall (Entity personID person, Entity _ actor) <- people
     <li>
+      $if canCreateFactories person
+        <span>👑
       <a href=@{PersonR $ hashPerson personID}>
         ~#{username2text $ personUsername person} #{actorName actor}
 

templates/default-layout.hamlet

@@ -13,11 +13,13 @@ $# with this software. If not, see
 $# <http://creativecommons.org/publicdomain/zero/1.0/>.
 
 <header>
-  $maybe (Entity _ person, hash, verified, unread) <- mperson
+  $maybe (Entity _ person, hash, verified, unread, can) <- mperson
     <div>
       $if verified
         <span>
           [You are logged in as
+          $if can
+            <span>👑
           <span .username>#{personLogin person}</span>]
         $if unread > 0
           <span>

templates/factory/nav.hamlet

@@ -0,0 +1,35 @@
+$# This file is part of Vervis.
+$#
+$# Written in 2019, 2022, 2023, 2024 by fr33domlover <fr33domlover@riseup.net>.
+$#
+$# ♡ Copying is an act of love. Please copy, reuse and share.
+$#
+$# The author(s) have dedicated all copyright and related and neighboring
+$# rights to this software to the public domain worldwide. This software is
+$# distributed without any warranty.
+$#
+$# You should have received a copy of the CC0 Public Domain Dedication along
+$# with this software. If not, see
+$# <http://creativecommons.org/publicdomain/zero/1.0/>.
+
+<div>
+  <span>
+    [[ 🏗
+    <a href=@{FactoryR factoryHash}>
+      *#{keyHashidText factoryHash} #{actorName actor}
+    ]] ::
+  <span>
+    <a href=@{FactoryInboxR factoryHash}>
+      [📥 Inbox]
+  <span>
+    <a href=@{FactoryOutboxR factoryHash}>
+      [📤 Outbox]
+  <span>
+    <a href=@{FactoryErrboxR factoryHash}>
+      [💥 Errbox]
+  <span>
+    <a href=@{FactoryFollowersR factoryHash}>
+      [🐤 Followers]
+  <span>
+    <a href=@{FactoryCollabsR factoryHash}>
+      [🤝 Collaborators]

templates/factory/new.hamlet

@@ -0,0 +1,18 @@
+$# This file is part of Vervis.
+$#
+$# Written in 2016, 2022, 2024 by fr33domlover <fr33domlover@riseup.net>.
+$#
+$# ♡ Copying is an act of love. Please copy, reuse and share.
+$#
+$# The author(s) have dedicated all copyright and related and neighboring
+$# rights to this software to the public domain worldwide. This software is
+$# distributed without any warranty.
+$#
+$# You should have received a copy of the CC0 Public Domain Dedication along
+$# with this software. If not, see
+$# <http://creativecommons.org/publicdomain/zero/1.0/>.
+
+<form method=POST action=@{FactoryNewR} enctype=#{enctype}>
+  ^{widget}
+  <div class="submit">
+      <input type="submit">

templates/personal-overview.hamlet

@@ -45,6 +45,10 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
           <li>
             <a href=@{LoomNewR}>
               patch tracker
+      $if canCreateFactories
+        <li>
+          <a href=@{FactoryNewR}>
+            factory
   <li>
     <a href=@{PublishOfferMergeR}>
       Open a merge request
@@ -106,6 +110,13 @@ $#       Comment on a ticket or merge request
     <li>
       ^{item i}
 
+<h2>Your factories
+
+<ul>
+  $forall i <- factories
+    <li>
+      ^{item i}
+
 <h2>Your resources of unrecognized type
 
 <ul>

th/models

@@ -167,6 +167,13 @@ Komponent
 
     UniqueKomponent resource
 
+Factory
+    resource ResourceId
+    create   OutboxItemId
+
+    UniqueFactory       resource
+    UniqueFactoryCreate create
+
 -- ========================================================================= --
 -- Delivery
 -- ========================================================================= --

th/routes

@@ -436,3 +436,29 @@
 /projects/#ProjectKeyHashid/approve-team/#SquadId ProjectApproveTeamR POST
 /projects/#ProjectKeyHashid/remove-team/#SquadId  ProjectRemoveTeamR  POST
 /projects/#ProjectKeyHashid/teams/#SquadUsStartKeyHashid/live ProjectTeamLiveR GET
+
+---- Factory -----------------------------------------------------------------
+
+/factories/#FactoryKeyHashid                                   FactoryR            GET
+/factories/#FactoryKeyHashid/inbox                             FactoryInboxR       GET POST
+/factories/#FactoryKeyHashid/errbox                            FactoryErrboxR      GET
+/factories/#FactoryKeyHashid/outbox                            FactoryOutboxR      GET
+/factories/#FactoryKeyHashid/outbox/#OutboxItemKeyHashid       FactoryOutboxItemR  GET
+/factories/#FactoryKeyHashid/followers                         FactoryFollowersR   GET
+
+/factories/#FactoryKeyHashid/messages/#LocalMessageKeyHashid   FactoryMessageR     GET
+
+/new-factory                                                   FactoryNewR         GET POST
+
+/factories/#FactoryKeyHashid/stamps/#SigKeyKeyHashid           FactoryStampR       GET
+
+/factories/#FactoryKeyHashid/collabs                           FactoryCollabsR     GET
+/factories/#FactoryKeyHashid/invite                            FactoryInviteR      POST
+/factories/#FactoryKeyHashid/remove/#CollabId                  FactoryRemoveR      POST
+
+/factories/#FactoryKeyHashid/teams                             FactoryTeamsR       GET
+
+/factories/#FactoryKeyHashid/add-team                          FactoryAddTeamR     POST
+/factories/#FactoryKeyHashid/approve-team/#SquadId             FactoryApproveTeamR POST
+/factories/#FactoryKeyHashid/remove-team/#SquadId              FactoryRemoveTeamR  POST
+/factories/#FactoryKeyHashid/teams/#SquadUsStartKeyHashid/live FactoryTeamLiveR    GET

vervis.cabal

@@ -157,6 +157,7 @@ library
                        Vervis.Actor2
                        Vervis.Actor.Common
                        Vervis.Actor.Deck
+                       Vervis.Actor.Factory
                        Vervis.Actor.Group
                        Vervis.Actor.Loom
                        Vervis.Actor.Person
@@ -213,6 +214,7 @@ library
                        Vervis.Handler.Cloth
                        Vervis.Handler.Common
                        Vervis.Handler.Deck
+                       Vervis.Handler.Factory
                        -- Vervis.Handler.Git
                        Vervis.Handler.Group
                        --Vervis.Handler.Inbox