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
This commit is contained in:
Pere Lev
parent
a74b24f61a
commit
66870458b7
34 changed files with 1213 additions and 143 deletions
|
|
@ -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
|
||||
###############################################################################
|
||||
|
|
|
|||
6
migrations/649_2024-07-29_factory.model
Normal file
6
migrations/649_2024-07-29_factory.model
Normal file
|
|
@ -0,0 +1,6 @@
|
|||
Factory
|
||||
resource ResourceId
|
||||
create OutboxItemId
|
||||
|
||||
UniqueFactory resource
|
||||
UniqueFactoryCreate create
|
||||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -67,6 +67,7 @@ module Vervis.Actor
|
|||
, DeckRoutes (..)
|
||||
, LoomRoutes (..)
|
||||
, ProjectRoutes (..)
|
||||
, FactoryRoutes (..)
|
||||
, DeckFamilyRoutes (..)
|
||||
, LoomFamilyRoutes (..)
|
||||
, RecipientRoutes (..)
|
||||
|
|
@ -169,6 +170,7 @@ data LocalActorBy f
|
|||
| LocalActorDeck (f Deck)
|
||||
| LocalActorLoom (f Loom)
|
||||
| LocalActorProject (f Project)
|
||||
| LocalActorFactory (f Factory)
|
||||
deriving (Generic, FunctorB, ConstraintsB)
|
||||
|
||||
deriving instance AllBF Eq f LocalActorBy => Eq (LocalActorBy f)
|
||||
|
|
@ -182,6 +184,7 @@ data LocalResourceBy f
|
|||
| LocalResourceDeck (f Deck)
|
||||
| LocalResourceLoom (f Loom)
|
||||
| LocalResourceProject (f Project)
|
||||
| LocalResourceFactory (f Factory)
|
||||
deriving (Generic, FunctorB, ConstraintsB)
|
||||
|
||||
deriving instance AllBF Eq f LocalResourceBy => Eq (LocalResourceBy f)
|
||||
|
|
@ -191,6 +194,7 @@ data LocalResourceNonGroupBy f
|
|||
| LocalResourceDeck' (f Deck)
|
||||
| LocalResourceLoom' (f Loom)
|
||||
| LocalResourceProject' (f Project)
|
||||
| LocalResourceFactory' (f Factory)
|
||||
deriving (Generic, FunctorB, ConstraintsB)
|
||||
|
||||
deriving instance AllBF Eq f LocalResourceNonGroupBy => Eq (LocalResourceNonGroupBy f)
|
||||
|
|
@ -204,6 +208,7 @@ actorToResource = \case
|
|||
LocalActorDeck d -> Just $ LocalResourceDeck d
|
||||
LocalActorLoom l -> Just $ LocalResourceLoom l
|
||||
LocalActorProject j -> Just $ LocalResourceProject j
|
||||
LocalActorFactory f -> Just $ LocalResourceFactory f
|
||||
|
||||
resourceToActor = \case
|
||||
LocalResourceGroup g -> LocalActorGroup g
|
||||
|
|
@ -211,6 +216,7 @@ resourceToActor = \case
|
|||
LocalResourceDeck d -> LocalActorDeck d
|
||||
LocalResourceLoom l -> LocalActorLoom l
|
||||
LocalResourceProject j -> LocalActorProject j
|
||||
LocalResourceFactory f -> LocalActorFactory f
|
||||
|
||||
resourceToNG = \case
|
||||
LocalResourceGroup _ -> Nothing
|
||||
|
|
@ -218,12 +224,14 @@ resourceToNG = \case
|
|||
LocalResourceDeck d -> Just $ LocalResourceDeck' d
|
||||
LocalResourceLoom l -> Just $ LocalResourceLoom' l
|
||||
LocalResourceProject j -> Just $ LocalResourceProject' j
|
||||
LocalResourceFactory f -> Just $ LocalResourceFactory' f
|
||||
|
||||
resourceFromNG = \case
|
||||
LocalResourceRepo' r -> LocalResourceRepo r
|
||||
LocalResourceDeck' d -> LocalResourceDeck d
|
||||
LocalResourceLoom' l -> LocalResourceLoom l
|
||||
LocalResourceProject' j -> LocalResourceProject j
|
||||
LocalResourceFactory' f -> LocalResourceFactory f
|
||||
|
||||
hashLocalActorPure
|
||||
:: HashidsContext -> LocalActorBy Key -> LocalActorBy KeyHashid
|
||||
|
|
@ -235,6 +243,7 @@ hashLocalActorPure ctx = f
|
|||
f (LocalActorDeck d) = LocalActorDeck $ encodeKeyHashidPure ctx d
|
||||
f (LocalActorLoom l) = LocalActorLoom $ encodeKeyHashidPure ctx l
|
||||
f (LocalActorProject j) = LocalActorProject $ encodeKeyHashidPure ctx j
|
||||
f (LocalActorFactory f) = LocalActorFactory $ encodeKeyHashidPure ctx f
|
||||
|
||||
getHashLocalActor
|
||||
:: (MonadActor m, StageHashids (MonadActorStage m))
|
||||
|
|
@ -260,6 +269,7 @@ unhashLocalActorPure ctx = f
|
|||
f (LocalActorDeck d) = LocalActorDeck <$> decodeKeyHashidPure ctx d
|
||||
f (LocalActorLoom l) = LocalActorLoom <$> decodeKeyHashidPure ctx l
|
||||
f (LocalActorProject j) = LocalActorProject <$> decodeKeyHashidPure ctx j
|
||||
f (LocalActorFactory f) = LocalActorFactory <$> decodeKeyHashidPure ctx f
|
||||
|
||||
unhashLocalActor
|
||||
:: (MonadActor m, StageHashids (MonadActorStage m))
|
||||
|
|
@ -307,6 +317,7 @@ hashLocalResourcePure ctx = f
|
|||
f (LocalResourceDeck d) = LocalResourceDeck $ encodeKeyHashidPure ctx d
|
||||
f (LocalResourceLoom l) = LocalResourceLoom $ encodeKeyHashidPure ctx l
|
||||
f (LocalResourceProject j) = LocalResourceProject $ encodeKeyHashidPure ctx j
|
||||
f (LocalResourceFactory f) = LocalResourceFactory $ encodeKeyHashidPure ctx f
|
||||
|
||||
getHashLocalResource
|
||||
:: (MonadActor m, StageHashids (MonadActorStage m))
|
||||
|
|
@ -331,6 +342,7 @@ unhashLocalResourcePure ctx = f
|
|||
f (LocalResourceDeck d) = LocalResourceDeck <$> decodeKeyHashidPure ctx d
|
||||
f (LocalResourceLoom l) = LocalResourceLoom <$> decodeKeyHashidPure ctx l
|
||||
f (LocalResourceProject j) = LocalResourceProject <$> decodeKeyHashidPure ctx j
|
||||
f (LocalResourceFactory f) = LocalResourceFactory <$> decodeKeyHashidPure ctx f
|
||||
|
||||
unhashLocalResource
|
||||
:: (MonadActor m, StageHashids (MonadActorStage m))
|
||||
|
|
@ -415,6 +427,12 @@ data ProjectRoutes = ProjectRoutes
|
|||
}
|
||||
deriving Eq
|
||||
|
||||
data FactoryRoutes = FactoryRoutes
|
||||
{ routeFactory :: Bool
|
||||
, routeFactoryFollowers :: Bool
|
||||
}
|
||||
deriving Eq
|
||||
|
||||
data DeckFamilyRoutes = DeckFamilyRoutes
|
||||
{ familyDeck :: DeckRoutes
|
||||
, familyTickets :: [(KeyHashid TicketDeck, TicketRoutes)]
|
||||
|
|
@ -434,6 +452,7 @@ data RecipientRoutes = RecipientRoutes
|
|||
, recipDecks :: [(KeyHashid Deck , DeckFamilyRoutes)]
|
||||
, recipLooms :: [(KeyHashid Loom , LoomFamilyRoutes)]
|
||||
, recipProjects :: [(KeyHashid Project, ProjectRoutes)]
|
||||
, recipFactories :: [(KeyHashid Factory, FactoryRoutes)]
|
||||
}
|
||||
deriving Eq
|
||||
|
||||
|
|
@ -513,6 +532,11 @@ instance Actor Group where
|
|||
type ActorKey Group = GroupId
|
||||
type ActorReturn Group = Either Text Text
|
||||
data ActorMessage Group = MsgG Verse
|
||||
instance Actor Factory where
|
||||
type ActorStage Factory = Staje
|
||||
type ActorKey Factory = FactoryId
|
||||
type ActorReturn Factory = Either Text Text
|
||||
data ActorMessage Factory = MsgF Verse
|
||||
|
||||
instance VervisActor Person where
|
||||
actorVerse = MsgP . Left
|
||||
|
|
@ -538,6 +562,9 @@ instance VervisActor Repo where
|
|||
case e of
|
||||
Left v -> Just v
|
||||
Right _ -> Nothing
|
||||
instance VervisActor Factory where
|
||||
actorVerse = MsgF
|
||||
toVerse (MsgF v) = Just v
|
||||
|
||||
instance Stage Staje where
|
||||
data StageEnv Staje = forall y. (Typeable y, Yesod y) => Env
|
||||
|
|
@ -564,7 +591,7 @@ instance Stage Staje where
|
|||
, envFetch :: ActorFetchShare
|
||||
}
|
||||
deriving Typeable
|
||||
type StageActors Staje = [Person, Project, Group, Deck, Loom, Repo]
|
||||
type StageActors Staje = [Person, Project, Group, Deck, Loom, Repo, Factory]
|
||||
|
||||
instance Message (ActorMessage Person) where
|
||||
summarize (MsgP (Left verse)) = summarizeVerse verse
|
||||
|
|
@ -588,6 +615,9 @@ instance Message (ActorMessage Project) where
|
|||
instance Message (ActorMessage Group) where
|
||||
summarize (MsgG verse) = summarizeVerse verse
|
||||
refer (MsgG verse) = referVerse verse
|
||||
instance Message (ActorMessage Factory) where
|
||||
summarize (MsgF verse) = summarizeVerse verse
|
||||
refer (MsgF verse) = referVerse verse
|
||||
|
||||
type YesodRender y = Route y -> [(Text, Text)] -> Text
|
||||
|
||||
|
|
@ -670,7 +700,8 @@ launchActorIO
|
|||
TVar (HashMap GroupId (ActorRef Group)),
|
||||
TVar (HashMap DeckId (ActorRef Deck)),
|
||||
TVar (HashMap LoomId (ActorRef Loom)),
|
||||
TVar (HashMap RepoId (ActorRef Repo))]
|
||||
TVar (HashMap RepoId (ActorRef Repo)),
|
||||
TVar (HashMap FactoryId (ActorRef Factory))]
|
||||
l'1
|
||||
, H.HOccurs'
|
||||
(TVar (HashMap (ActorKey a) (ActorRef a)))
|
||||
|
|
@ -680,7 +711,8 @@ launchActorIO
|
|||
TVar (HashMap GroupId (ActorRef Group)),
|
||||
TVar (HashMap DeckId (ActorRef Deck)),
|
||||
TVar (HashMap LoomId (ActorRef Loom)),
|
||||
TVar (HashMap RepoId (ActorRef Repo))]
|
||||
TVar (HashMap RepoId (ActorRef Repo)),
|
||||
TVar (HashMap FactoryId (ActorRef Factory))]
|
||||
)
|
||||
=> Theater
|
||||
-> StageEnv Staje
|
||||
|
|
@ -705,7 +737,8 @@ launchActor
|
|||
TVar (HashMap GroupId (ActorRef Group)),
|
||||
TVar (HashMap DeckId (ActorRef Deck)),
|
||||
TVar (HashMap LoomId (ActorRef Loom)),
|
||||
TVar (HashMap RepoId (ActorRef Repo))]
|
||||
TVar (HashMap RepoId (ActorRef Repo)),
|
||||
TVar (HashMap FactoryId (ActorRef Factory))]
|
||||
l'0
|
||||
, H.HOccurs'
|
||||
(TVar (HashMap (ActorKey a) (ActorRef a)))
|
||||
|
|
@ -715,7 +748,8 @@ launchActor
|
|||
TVar (HashMap GroupId (ActorRef Group)),
|
||||
TVar (HashMap DeckId (ActorRef Deck)),
|
||||
TVar (HashMap LoomId (ActorRef Loom)),
|
||||
TVar (HashMap RepoId (ActorRef Repo))]
|
||||
TVar (HashMap RepoId (ActorRef Repo)),
|
||||
TVar (HashMap FactoryId (ActorRef Factory))]
|
||||
)
|
||||
=> ActorKey a
|
||||
-> Act Bool
|
||||
|
|
@ -771,6 +805,7 @@ sendToLocalActors authorAndId body requireOwner mauthor maidAuthor recips = do
|
|||
for looms $ \ (loomID, (LoomFamilyRoutes loom cloths)) ->
|
||||
(loomID,) . (loom,) <$> unhashKeys cloths
|
||||
projects <- unhashKeys $ recipProjects recips
|
||||
factories <- unhashKeys $ recipFactories recips
|
||||
|
||||
-- Grab local actor sets whose stages are allowed for delivery
|
||||
let allowStages'
|
||||
|
|
@ -793,6 +828,8 @@ sendToLocalActors authorAndId body requireOwner mauthor maidAuthor recips = do
|
|||
filter (allowStages' fst routeLoom LocalActorLoom) loomsAndCloths
|
||||
projectsForStages =
|
||||
filter (allowStages' id routeProject LocalActorProject) projects
|
||||
factoriesForStages =
|
||||
filter (allowStages' id routeFactory LocalActorFactory) factories
|
||||
|
||||
-- Grab local actors being addressed
|
||||
let localActorsForSelf = concat
|
||||
|
|
@ -802,6 +839,7 @@ sendToLocalActors authorAndId body requireOwner mauthor maidAuthor recips = do
|
|||
, [ LocalActorDeck key | (key, (routes, _)) <- decksAndTickets, routeDeck routes ]
|
||||
, [ LocalActorLoom key | (key, (routes, _)) <- loomsAndCloths, routeLoom routes ]
|
||||
, [ LocalActorProject key | (key, routes) <- projects, routeProject routes ]
|
||||
, [ LocalActorFactory key | (key, routes) <- factories, routeFactory routes ]
|
||||
]
|
||||
|
||||
-- Grab local actors whose followers are going to be delivered to
|
||||
|
|
@ -817,6 +855,8 @@ sendToLocalActors authorAndId body requireOwner mauthor maidAuthor recips = do
|
|||
[ key | (key, (routes, _)) <- loomsAndClothsForStages, routeLoomFollowers routes ]
|
||||
projectIDsForFollowers =
|
||||
[ key | (key, routes) <- projectsForStages, routeProjectFollowers routes ]
|
||||
factoryIDsForFollowers =
|
||||
[ key | (key, routes) <- factoriesForStages, routeFactoryFollowers routes ]
|
||||
|
||||
-- Grab tickets and cloths whose followers are going to be delivered to
|
||||
let ticketSetsForFollowers =
|
||||
|
|
@ -848,6 +888,7 @@ sendToLocalActors authorAndId body requireOwner mauthor maidAuthor recips = do
|
|||
, selectActorIDs deckActor deckIDsForFollowers
|
||||
, selectActorIDs loomActor loomIDsForFollowers
|
||||
, selectActorIDs projectActor projectIDsForFollowers
|
||||
, selectActorIDs' factoryResource factoryIDsForFollowers
|
||||
]
|
||||
ticketIDs <-
|
||||
concat <$>
|
||||
|
|
@ -875,6 +916,7 @@ sendToLocalActors authorAndId body requireOwner mauthor maidAuthor recips = do
|
|||
, selectFollowers LocalActorDeck DeckActor followerSetIDs
|
||||
, selectFollowers LocalActorLoom LoomActor followerSetIDs
|
||||
, selectFollowers LocalActorProject ProjectActor followerSetIDs
|
||||
, selectFollowers' LocalActorFactory FactoryResource followerSetIDs
|
||||
]
|
||||
remotes <- getRemoteFollowers followerSetIDs
|
||||
return (locals, remotes)
|
||||
|
|
@ -889,7 +931,7 @@ sendToLocalActors authorAndId body requireOwner mauthor maidAuthor recips = do
|
|||
Just a -> HS.delete a s
|
||||
authorAndId' =
|
||||
second (\ (author, luAct) -> (author, luAct, Nothing)) authorAndId
|
||||
(liveRecipsP, liveRecipsJ, liveRecipsG, liveRecipsD, liveRecipsL, liveRecipsR) =
|
||||
(liveRecipsP, liveRecipsJ, liveRecipsG, liveRecipsD, liveRecipsL, liveRecipsR, liveRecipsF) =
|
||||
partitionByActor liveRecips
|
||||
verse = Verse authorAndId' body
|
||||
sendMany $
|
||||
|
|
@ -898,7 +940,8 @@ sendToLocalActors authorAndId body requireOwner mauthor maidAuthor recips = do
|
|||
(liveRecipsG, actorVerse verse) `H.HCons`
|
||||
(liveRecipsD, actorVerse verse) `H.HCons`
|
||||
(liveRecipsL, actorVerse verse) `H.HCons`
|
||||
(liveRecipsR, actorVerse verse) `H.HCons` H.HNil
|
||||
(liveRecipsR, actorVerse verse) `H.HCons`
|
||||
(liveRecipsF, actorVerse verse) `H.HCons` H.HNil
|
||||
|
||||
-- Return remote followers, to whom we need to deliver via HTTP
|
||||
return remoteFollowers
|
||||
|
|
@ -940,6 +983,15 @@ sendToLocalActors authorAndId body requireOwner mauthor maidAuthor recips = do
|
|||
selectActorIDs grabActor ids =
|
||||
map (grabActor . entityVal) <$> selectList [persistIdField <-. ids] []
|
||||
|
||||
selectActorIDs'
|
||||
:: (MonadIO m, PersistRecordBackend record SqlBackend)
|
||||
=> (record -> ResourceId)
|
||||
-> [Key record]
|
||||
-> ReaderT SqlBackend m [ActorId]
|
||||
selectActorIDs' grabResource ids = do
|
||||
resourceIDs <- map (grabResource . entityVal) <$> selectList [persistIdField <-. ids] []
|
||||
map (resourceActor . entityVal) <$> selectList [ResourceId <-. resourceIDs] []
|
||||
|
||||
selectTicketIDs
|
||||
:: ( MonadIO m
|
||||
, PersistRecordBackend tracker SqlBackend
|
||||
|
|
@ -990,6 +1042,14 @@ sendToLocalActors authorAndId body requireOwner mauthor maidAuthor recips = do
|
|||
E.where_ $ f E.^. FollowTarget `E.in_` E.valList followerSetIDs
|
||||
return $ p E.^. persistIdField
|
||||
|
||||
selectFollowers' makeLocalActor resourceField followerSetIDs =
|
||||
fmap (map (makeLocalActor . E.unValue)) $
|
||||
E.select $ E.from $ \ (f `E.InnerJoin` r `E.InnerJoin` p) -> do
|
||||
E.on $ r E.^. ResourceId E.==. p E.^. resourceField
|
||||
E.on $ f E.^. FollowActor E.==. r E.^. ResourceActor
|
||||
E.where_ $ f E.^. FollowTarget `E.in_` E.valList followerSetIDs
|
||||
return $ p E.^. persistIdField
|
||||
|
||||
partitionByActor
|
||||
:: HashSet (LocalActorBy Key)
|
||||
-> ( HashSet PersonId
|
||||
|
|
@ -998,21 +1058,24 @@ sendToLocalActors authorAndId body requireOwner mauthor maidAuthor recips = do
|
|||
, HashSet DeckId
|
||||
, HashSet LoomId
|
||||
, HashSet RepoId
|
||||
, HashSet FactoryId
|
||||
)
|
||||
partitionByActor = foldl' f (HS.empty, HS.empty, HS.empty, HS.empty, HS.empty, HS.empty)
|
||||
partitionByActor = foldl' f (HS.empty, HS.empty, HS.empty, HS.empty, HS.empty, HS.empty, HS.empty)
|
||||
where
|
||||
f (p, j, g, d, l, r) (LocalActorPerson k) =
|
||||
(HS.insert k p, j, g, d, l, r)
|
||||
f (p, j, g, d, l, r) (LocalActorProject k) =
|
||||
(p, HS.insert k j, g, d, l, r)
|
||||
f (p, j, g, d, l, r) (LocalActorGroup k) =
|
||||
(p, j, HS.insert k g, d, l, r)
|
||||
f (p, j, g, d, l, r) (LocalActorDeck k) =
|
||||
(p, j, g, HS.insert k d, l, r)
|
||||
f (p, j, g, d, l, r) (LocalActorLoom k) =
|
||||
(p, j, g, d, HS.insert k l, r)
|
||||
f (p, j, g, d, l, r) (LocalActorRepo k) =
|
||||
(p, j, g, d, l, HS.insert k r)
|
||||
f (p, j, g, d, l, r, f') (LocalActorPerson k) =
|
||||
(HS.insert k p, j, g, d, l, r, f')
|
||||
f (p, j, g, d, l, r, f') (LocalActorProject k) =
|
||||
(p, HS.insert k j, g, d, l, r, f')
|
||||
f (p, j, g, d, l, r, f') (LocalActorGroup k) =
|
||||
(p, j, HS.insert k g, d, l, r, f')
|
||||
f (p, j, g, d, l, r, f') (LocalActorDeck k) =
|
||||
(p, j, g, HS.insert k d, l, r, f')
|
||||
f (p, j, g, d, l, r, f') (LocalActorLoom k) =
|
||||
(p, j, g, d, HS.insert k l, r, f')
|
||||
f (p, j, g, d, l, r, f') (LocalActorRepo k) =
|
||||
(p, j, g, d, l, HS.insert k r, f')
|
||||
f (p, j, g, d, l, r, f') (LocalActorFactory k) =
|
||||
(p, j, g, d, l, r, HS.insert k f')
|
||||
|
||||
actorIsAddressed :: RecipientRoutes -> LocalActor -> Bool
|
||||
actorIsAddressed recips = isJust . verify
|
||||
|
|
@ -1035,6 +1098,9 @@ actorIsAddressed recips = isJust . verify
|
|||
verify (LocalActorProject j) = do
|
||||
routes <- lookup j $ recipProjects recips
|
||||
guard $ routeProject routes
|
||||
verify (LocalActorFactory f) = do
|
||||
routes <- lookup f $ recipFactories recips
|
||||
guard $ routeFactory routes
|
||||
|
||||
localActorType :: LocalActorBy f -> AP.ActorType
|
||||
localActorType = \case
|
||||
|
|
@ -1044,3 +1110,4 @@ localActorType = \case
|
|||
LocalActorLoom _ -> AP.ActorTypePatchTracker
|
||||
LocalActorProject _ -> AP.ActorTypeProject
|
||||
LocalActorGroup _ -> AP.ActorTypeTeam
|
||||
LocalActorFactory _ -> AP.ActorTypeFactory
|
||||
|
|
|
|||
65
src/Vervis/Actor/Factory.hs
Normal file
65
src/Vervis/Actor/Factory.hs
Normal file
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -21,7 +21,7 @@ module Vervis.Data.Actor
|
|||
, activityRoute
|
||||
, stampRoute
|
||||
, parseStampRoute
|
||||
, localActorID
|
||||
, grabLocalActorID
|
||||
, localResourceID
|
||||
, WA.parseLocalURI
|
||||
, parseFedURIOld
|
||||
|
|
@ -46,6 +46,7 @@ import Control.Monad.Logger.CallStack
|
|||
import Control.Monad.Trans.Except
|
||||
import Data.Bitraversable
|
||||
import Data.Text (Text)
|
||||
import Database.Persist.Sql
|
||||
import Database.Persist.Types
|
||||
import UnliftIO.Exception (try, SomeException, displayException)
|
||||
|
||||
|
|
@ -154,6 +155,7 @@ activityRoute (LocalActorRepo r) = RepoOutboxItemR r
|
|||
activityRoute (LocalActorDeck d) = DeckOutboxItemR d
|
||||
activityRoute (LocalActorLoom l) = LoomOutboxItemR l
|
||||
activityRoute (LocalActorProject r) = ProjectOutboxItemR r
|
||||
activityRoute (LocalActorFactory f) = FactoryOutboxItemR f
|
||||
|
||||
stampRoute :: LocalActorBy KeyHashid -> KeyHashid SigKey -> Route App
|
||||
stampRoute (LocalActorPerson p) = PersonStampR p
|
||||
|
|
@ -162,6 +164,7 @@ stampRoute (LocalActorRepo r) = RepoStampR r
|
|||
stampRoute (LocalActorDeck d) = DeckStampR d
|
||||
stampRoute (LocalActorLoom l) = LoomStampR l
|
||||
stampRoute (LocalActorProject r) = ProjectStampR r
|
||||
stampRoute (LocalActorFactory f) = FactoryStampR f
|
||||
|
||||
parseStampRoute
|
||||
:: Route App -> Maybe (LocalActorBy KeyHashid, KeyHashid SigKey)
|
||||
|
|
@ -171,15 +174,17 @@ parseStampRoute (RepoStampR r i) = Just (LocalActorRepo r, i)
|
|||
parseStampRoute (DeckStampR d i) = Just (LocalActorDeck d, i)
|
||||
parseStampRoute (LoomStampR l i) = Just (LocalActorLoom l, i)
|
||||
parseStampRoute (ProjectStampR r i) = Just (LocalActorProject r, i)
|
||||
parseStampRoute (FactoryStampR f i) = Just (LocalActorFactory f, i)
|
||||
parseStampRoute _ = Nothing
|
||||
|
||||
localActorID :: LocalActorBy Entity -> ActorId
|
||||
localActorID (LocalActorPerson (Entity _ p)) = personActor p
|
||||
localActorID (LocalActorGroup (Entity _ g)) = groupActor g
|
||||
localActorID (LocalActorRepo (Entity _ r)) = repoActor r
|
||||
localActorID (LocalActorDeck (Entity _ d)) = deckActor d
|
||||
localActorID (LocalActorLoom (Entity _ l)) = loomActor l
|
||||
localActorID (LocalActorProject (Entity _ r)) = projectActor r
|
||||
grabLocalActorID :: MonadIO m => LocalActorBy Entity -> SqlPersistT m ActorId
|
||||
grabLocalActorID (LocalActorPerson (Entity _ p)) = pure $ personActor p
|
||||
grabLocalActorID (LocalActorGroup (Entity _ g)) = pure $ groupActor g
|
||||
grabLocalActorID (LocalActorRepo (Entity _ r)) = pure $ repoActor r
|
||||
grabLocalActorID (LocalActorDeck (Entity _ d)) = pure $ deckActor d
|
||||
grabLocalActorID (LocalActorLoom (Entity _ l)) = pure $ loomActor l
|
||||
grabLocalActorID (LocalActorProject (Entity _ r)) = pure $ projectActor r
|
||||
grabLocalActorID (LocalActorFactory (Entity _ f)) = resourceActor <$> getJust (factoryResource f)
|
||||
|
||||
localResourceID :: LocalResourceBy Entity -> ResourceId
|
||||
localResourceID (LocalResourceGroup (Entity _ g)) = groupResource g
|
||||
|
|
@ -187,6 +192,7 @@ localResourceID (LocalResourceRepo (Entity _ r)) = repoResource r
|
|||
localResourceID (LocalResourceDeck (Entity _ d)) = deckResource d
|
||||
localResourceID (LocalResourceLoom (Entity _ l)) = loomResource l
|
||||
localResourceID (LocalResourceProject (Entity _ r)) = projectResource r
|
||||
localResourceID (LocalResourceFactory (Entity _ f)) = factoryResource f
|
||||
|
||||
parseFedURIOld
|
||||
:: ( MonadSite m
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -256,7 +256,7 @@ getHomeR = do
|
|||
bitraverse
|
||||
(\ byK -> do
|
||||
byE <- getLocalActorEntityE byK "No such local actor in DB"
|
||||
actor <- lift $ getJust $ localActorID byE
|
||||
actor <- lift $ getJust =<< grabLocalActorID byE
|
||||
return (byK, actor)
|
||||
)
|
||||
(\ u ->
|
||||
|
|
@ -271,7 +271,7 @@ getHomeR = do
|
|||
)
|
||||
|
||||
personalOverview :: Entity Person -> Handler Html
|
||||
personalOverview (Entity pid _person) = do
|
||||
personalOverview (Entity pid person) = do
|
||||
(permits, invites) <- runDB $ do
|
||||
permits <- do
|
||||
locals <- do
|
||||
|
|
@ -418,11 +418,14 @@ getHomeR = do
|
|||
)
|
||||
return $ sortOn (view _1) $ locals ++ remotes
|
||||
return (permits, invites)
|
||||
let (people, repos, decks, looms, projects, groups, others) =
|
||||
let (people, repos, decks, looms, projects, groups, factories, others) =
|
||||
partitionByActorType (view _4) (view _1) permits
|
||||
if null people
|
||||
then pure ()
|
||||
else error "Bug: Person as a PermitTopic"
|
||||
canCreateFactories <- do
|
||||
cans <- asksSite $ appCanCreateFactories . appSettings
|
||||
return $ personUsername person `elem` map text2username cans
|
||||
defaultLayout $(widgetFile "personal-overview")
|
||||
|
||||
where
|
||||
|
|
@ -432,7 +435,7 @@ getHomeR = do
|
|||
=> (a -> AP.ActorType)
|
||||
-> (a -> b)
|
||||
-> [a]
|
||||
-> ([a], [a], [a], [a], [a], [a], [a])
|
||||
-> ([a], [a], [a], [a], [a], [a], [a], [a])
|
||||
partitionByActorType typ key xs =
|
||||
let p = filter ((== AP.ActorTypePerson) . typ) xs
|
||||
r = filter ((== AP.ActorTypeRepo) . typ) xs
|
||||
|
|
@ -440,8 +443,9 @@ getHomeR = do
|
|||
l = filter ((== AP.ActorTypePatchTracker) . typ) xs
|
||||
j = filter ((== AP.ActorTypeProject) . typ) xs
|
||||
g = filter ((== AP.ActorTypeTeam) . typ) xs
|
||||
x = deleteFirstsBy ((==) `on` key) xs (p ++ r ++ d ++ l ++ j ++ g)
|
||||
in (p, r, d, l, j, g, x)
|
||||
f = filter ((== AP.ActorTypeFactory) . typ) xs
|
||||
x = deleteFirstsBy ((==) `on` key) xs (p ++ r ++ d ++ l ++ j ++ g ++ f)
|
||||
in (p, r, d, l, j, g, f, x)
|
||||
|
||||
item (_gestureID, role, deleg, _typ, actor, exts) =
|
||||
[whamlet|
|
||||
|
|
@ -492,6 +496,9 @@ getHomeR = do
|
|||
|
||||
getBrowseR :: Handler Html
|
||||
getBrowseR = do
|
||||
canCreateFactories <- do
|
||||
cans <- asksSite $ appCanCreateFactories . appSettings
|
||||
return $ \ p -> personUsername p `elem` map text2username cans
|
||||
(people, groups, repos, decks, looms, projects) <- runDB $
|
||||
(,,,,,)
|
||||
<$> (E.select $ E.from $ \ (person `E.InnerJoin` actor) -> do
|
||||
|
|
|
|||
418
src/Vervis/Handler/Factory.hs
Normal file
418
src/Vervis/Handler/Factory.hs
Normal file
|
|
@ -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
|
||||
|
|
@ -3848,6 +3848,8 @@ changes hLocal ctx =
|
|||
, removeField "Effort" "topic"
|
||||
-- 648
|
||||
, addEntities model_648_report
|
||||
-- 649
|
||||
, addEntities model_649_factory
|
||||
]
|
||||
|
||||
migrateDB
|
||||
|
|
|
|||
|
|
@ -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")
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -114,21 +114,28 @@ getLocalComponent = fmap (bmap entityKey) . getLocalComponentEnt
|
|||
getLocalActorEnt
|
||||
:: MonadIO m => ActorId -> ReaderT SqlBackend m (LocalActorBy Entity)
|
||||
getLocalActorEnt actorID = do
|
||||
m <- getKeyBy $ UniqueResource actorID
|
||||
|
||||
mp <- getBy $ UniquePersonActor actorID
|
||||
mg <- getBy $ UniqueGroupActor actorID
|
||||
mr <- getBy $ UniqueRepoActor actorID
|
||||
md <- getBy $ UniqueDeckActor actorID
|
||||
ml <- getBy $ UniqueLoomActor actorID
|
||||
mj <- getBy $ UniqueProjectActor actorID
|
||||
mf <- runMaybeT $ do
|
||||
resourceID <- hoistMaybe m
|
||||
MaybeT $ getBy $ UniqueFactory resourceID
|
||||
|
||||
return $
|
||||
case (mp, mg, mr, md, ml, mj) of
|
||||
(Nothing, Nothing, Nothing, Nothing, Nothing, Nothing) -> error "Unused ActorId"
|
||||
(Just p, Nothing, Nothing, Nothing, Nothing, Nothing) -> LocalActorPerson p
|
||||
(Nothing, Just g, Nothing, Nothing, Nothing, Nothing) -> LocalActorGroup g
|
||||
(Nothing, Nothing, Just r, Nothing, Nothing, Nothing) -> LocalActorRepo r
|
||||
(Nothing, Nothing, Nothing, Just d, Nothing, Nothing) -> LocalActorDeck d
|
||||
(Nothing, Nothing, Nothing, Nothing, Just l, Nothing) -> LocalActorLoom l
|
||||
(Nothing, Nothing, Nothing, Nothing, Nothing, Just j) -> LocalActorProject j
|
||||
case (mp, mg, mr, md, ml, mj, mf) of
|
||||
(Nothing, Nothing, Nothing, Nothing, Nothing, Nothing, Nothing) -> error "Unused ActorId"
|
||||
(Just p, Nothing, Nothing, Nothing, Nothing, Nothing, Nothing) -> LocalActorPerson p
|
||||
(Nothing, Just g, Nothing, Nothing, Nothing, Nothing, Nothing) -> LocalActorGroup g
|
||||
(Nothing, Nothing, Just r, Nothing, Nothing, Nothing, Nothing) -> LocalActorRepo r
|
||||
(Nothing, Nothing, Nothing, Just d, Nothing, Nothing, Nothing) -> LocalActorDeck d
|
||||
(Nothing, Nothing, Nothing, Nothing, Just l, Nothing, Nothing) -> LocalActorLoom l
|
||||
(Nothing, Nothing, Nothing, Nothing, Nothing, Just j, Nothing) -> LocalActorProject j
|
||||
(Nothing, Nothing, Nothing, Nothing, Nothing, Nothing, Just f) -> LocalActorFactory f
|
||||
_ -> error "Multi-usage of an ActorId"
|
||||
|
||||
getLocalResourceEnt
|
||||
|
|
@ -142,6 +149,7 @@ getLocalResourceEnt resourceID = do
|
|||
, fmap LocalResourceLoom <$> getBy (UniqueLoomActor actorID)
|
||||
, fmap LocalResourceProject <$> getBy (UniqueProjectActor actorID)
|
||||
, fmap LocalResourceGroup <$> getBy (UniqueGroupActor actorID)
|
||||
, fmap LocalResourceFactory <$> getBy (UniqueFactory resourceID)
|
||||
]
|
||||
exactlyOneJust
|
||||
options
|
||||
|
|
@ -180,6 +188,8 @@ getLocalActorEntity (LocalActorLoom l) =
|
|||
fmap (LocalActorLoom . Entity l) <$> get l
|
||||
getLocalActorEntity (LocalActorProject r) =
|
||||
fmap (LocalActorProject . Entity r) <$> get r
|
||||
getLocalActorEntity (LocalActorFactory f) =
|
||||
fmap (LocalActorFactory . Entity f) <$> get f
|
||||
|
||||
getLocalActorEntityE a e = do
|
||||
m <- lift $ getLocalActorEntity a
|
||||
|
|
@ -203,6 +213,8 @@ getLocalResourceEntity (LocalResourceLoom l) =
|
|||
fmap (LocalResourceLoom . Entity l) <$> get l
|
||||
getLocalResourceEntity (LocalResourceProject r) =
|
||||
fmap (LocalResourceProject . Entity r) <$> get r
|
||||
getLocalResourceEntity (LocalResourceFactory f) =
|
||||
fmap (LocalResourceFactory . Entity f) <$> get f
|
||||
|
||||
getLocalResourceEntityE a e = do
|
||||
m <- lift $ getLocalResourceEntity a
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -215,6 +215,7 @@ parseLocalActor (RepoR rkhid) = Just $ LocalActorRepo rkhid
|
|||
parseLocalActor (DeckR dkhid) = Just $ LocalActorDeck dkhid
|
||||
parseLocalActor (LoomR lkhid) = Just $ LocalActorLoom lkhid
|
||||
parseLocalActor (ProjectR jkhid) = Just $ LocalActorProject jkhid
|
||||
parseLocalActor (FactoryR fkhid) = Just $ LocalActorFactory fkhid
|
||||
parseLocalActor _ = Nothing
|
||||
|
||||
renderLocalActor :: LocalActor -> Route App
|
||||
|
|
@ -224,6 +225,7 @@ renderLocalActor (LocalActorRepo rkhid) = RepoR rkhid
|
|||
renderLocalActor (LocalActorDeck dkhid) = DeckR dkhid
|
||||
renderLocalActor (LocalActorLoom lkhid) = LoomR lkhid
|
||||
renderLocalActor (LocalActorProject jkhid) = ProjectR jkhid
|
||||
renderLocalActor (LocalActorFactory fkhid) = FactoryR fkhid
|
||||
|
||||
parseLocalResource :: Route App -> Maybe (LocalResourceBy KeyHashid)
|
||||
parseLocalResource (GroupR gkhid) = Just $ LocalResourceGroup gkhid
|
||||
|
|
@ -231,6 +233,7 @@ parseLocalResource (RepoR rkhid) = Just $ LocalResourceRepo rkhid
|
|||
parseLocalResource (DeckR dkhid) = Just $ LocalResourceDeck dkhid
|
||||
parseLocalResource (LoomR lkhid) = Just $ LocalResourceLoom lkhid
|
||||
parseLocalResource (ProjectR jkhid) = Just $ LocalResourceProject jkhid
|
||||
parseLocalResource (FactoryR fkhid) = Just $ LocalResourceFactory fkhid
|
||||
parseLocalResource _ = Nothing
|
||||
|
||||
renderLocalResource :: LocalResourceBy KeyHashid -> Route App
|
||||
|
|
@ -239,6 +242,7 @@ renderLocalResource (LocalResourceRepo rkhid) = RepoR rkhid
|
|||
renderLocalResource (LocalResourceDeck dkhid) = DeckR dkhid
|
||||
renderLocalResource (LocalResourceLoom lkhid) = LoomR lkhid
|
||||
renderLocalResource (LocalResourceProject jkhid) = ProjectR jkhid
|
||||
renderLocalResource (LocalResourceFactory fkhid) = FactoryR fkhid
|
||||
|
||||
data LocalStageBy f
|
||||
= LocalStagePersonFollowers (f Person)
|
||||
|
|
@ -254,6 +258,8 @@ data LocalStageBy f
|
|||
| LocalStageClothFollowers (f Loom) (f TicketLoom)
|
||||
|
||||
| LocalStageProjectFollowers (f Project)
|
||||
|
||||
| LocalStageFactoryFollowers (f Factory)
|
||||
deriving (Generic, FunctorB, ConstraintsB)
|
||||
|
||||
deriving instance AllBF Eq f LocalStageBy => Eq (LocalStageBy f)
|
||||
|
|
@ -278,6 +284,8 @@ parseLocalStage (ClothFollowersR lkhid ltkhid) =
|
|||
Just $ LocalStageClothFollowers lkhid ltkhid
|
||||
parseLocalStage (ProjectFollowersR jkhid) =
|
||||
Just $ LocalStageProjectFollowers jkhid
|
||||
parseLocalStage (FactoryFollowersR fkhid) =
|
||||
Just $ LocalStageFactoryFollowers fkhid
|
||||
parseLocalStage _ = Nothing
|
||||
|
||||
renderLocalStage :: LocalStage -> Route App
|
||||
|
|
@ -297,6 +305,8 @@ renderLocalStage (LocalStageClothFollowers lkhid ltkhid) =
|
|||
ClothFollowersR lkhid ltkhid
|
||||
renderLocalStage (LocalStageProjectFollowers jkhid) =
|
||||
ProjectFollowersR jkhid
|
||||
renderLocalStage (LocalStageFactoryFollowers fkhid) =
|
||||
FactoryFollowersR fkhid
|
||||
|
||||
parseLocalRecipient :: Route App -> Maybe (Either LocalActor LocalStage)
|
||||
parseLocalRecipient r =
|
||||
|
|
@ -309,6 +319,7 @@ localActorFollowers (LocalActorRepo r) = LocalStageRepoFollowers r
|
|||
localActorFollowers (LocalActorDeck d) = LocalStageDeckFollowers d
|
||||
localActorFollowers (LocalActorLoom l) = LocalStageLoomFollowers l
|
||||
localActorFollowers (LocalActorProject j) = LocalStageProjectFollowers j
|
||||
localActorFollowers (LocalActorFactory f) = LocalStageFactoryFollowers f
|
||||
|
||||
-------------------------------------------------------------------------------
|
||||
-- Converting between KeyHashid, Key, Identity and Entity
|
||||
|
|
@ -412,6 +423,8 @@ hashLocalStagePure ctx = f
|
|||
(encodeKeyHashidPure ctx c)
|
||||
f (LocalStageProjectFollowers j) =
|
||||
LocalStageProjectFollowers $ encodeKeyHashidPure ctx j
|
||||
f (LocalStageFactoryFollowers j) =
|
||||
LocalStageFactoryFollowers $ encodeKeyHashidPure ctx j
|
||||
|
||||
getHashLocalStage
|
||||
:: (MonadSite m, YesodHashids (SiteEnv m))
|
||||
|
|
@ -451,6 +464,8 @@ unhashLocalStagePure ctx = f
|
|||
<*> decodeKeyHashidPure ctx c
|
||||
f (LocalStageProjectFollowers j) =
|
||||
LocalStageProjectFollowers <$> decodeKeyHashidPure ctx j
|
||||
f (LocalStageFactoryFollowers j) =
|
||||
LocalStageFactoryFollowers <$> decodeKeyHashidPure ctx j
|
||||
|
||||
unhashLocalStage
|
||||
:: (MonadSite m, YesodHashids (SiteEnv m))
|
||||
|
|
@ -493,6 +508,10 @@ getLocalActorID (LocalActorRepo r) = fmap repoActor <$> get r
|
|||
getLocalActorID (LocalActorDeck d) = fmap deckActor <$> get d
|
||||
getLocalActorID (LocalActorLoom l) = fmap loomActor <$> get l
|
||||
getLocalActorID (LocalActorProject j) = fmap projectActor <$> get j
|
||||
getLocalActorID (LocalActorFactory f) = do
|
||||
maybeResourceID <- fmap factoryResource <$> get f
|
||||
for maybeResourceID $ \ resourceID ->
|
||||
resourceActor <$> getJust resourceID
|
||||
|
||||
-------------------------------------------------------------------------------
|
||||
-- Intermediate recipient types
|
||||
|
|
@ -518,6 +537,8 @@ data LeafLoom = LeafLoom | LeafLoomFollowers deriving (Eq, Ord)
|
|||
|
||||
data LeafProject = LeafProject | LeafProjectFollowers deriving (Eq, Ord)
|
||||
|
||||
data LeafFactory = LeafFactory | LeafFactoryFollowers deriving (Eq, Ord)
|
||||
|
||||
data PieceDeck
|
||||
= PieceDeck LeafDeck
|
||||
| PieceTicket (KeyHashid TicketDeck) LeafTicket
|
||||
|
|
@ -535,6 +556,7 @@ data LocalRecipient
|
|||
| RecipDeck (KeyHashid Deck) PieceDeck
|
||||
| RecipLoom (KeyHashid Loom) PieceLoom
|
||||
| RecipProject (KeyHashid Project) LeafProject
|
||||
| RecipFactory (KeyHashid Factory) LeafFactory
|
||||
deriving (Eq, Ord)
|
||||
|
||||
recipientFromActor :: LocalActor -> LocalRecipient
|
||||
|
|
@ -550,6 +572,8 @@ recipientFromActor (LocalActorLoom lkhid) =
|
|||
RecipLoom lkhid $ PieceLoom LeafLoom
|
||||
recipientFromActor (LocalActorProject jkhid) =
|
||||
RecipProject jkhid LeafProject
|
||||
recipientFromActor (LocalActorFactory fkhid) =
|
||||
RecipFactory fkhid LeafFactory
|
||||
|
||||
recipientFromStage :: LocalStage -> LocalRecipient
|
||||
recipientFromStage (LocalStagePersonFollowers pkhid) =
|
||||
|
|
@ -568,6 +592,8 @@ recipientFromStage (LocalStageClothFollowers lkhid ltkhid) =
|
|||
RecipLoom lkhid $ PieceCloth ltkhid LeafClothFollowers
|
||||
recipientFromStage (LocalStageProjectFollowers jkhid) =
|
||||
RecipProject jkhid LeafProjectFollowers
|
||||
recipientFromStage (LocalStageFactoryFollowers fkhid) =
|
||||
RecipFactory fkhid LeafFactoryFollowers
|
||||
|
||||
-------------------------------------------------------------------------------
|
||||
-- Recipient set types
|
||||
|
|
@ -589,21 +615,24 @@ groupLocalRecipients = organize . partitionByActor
|
|||
, [(KeyHashid Deck, PieceDeck)]
|
||||
, [(KeyHashid Loom, PieceLoom)]
|
||||
, [(KeyHashid Project, LeafProject)]
|
||||
, [(KeyHashid Factory, LeafFactory)]
|
||||
)
|
||||
partitionByActor = foldl' f ([], [], [], [], [], [])
|
||||
partitionByActor = foldl' f ([], [], [], [], [], [], [])
|
||||
where
|
||||
f (p, g, r, d, l, j) (RecipPerson pkhid pleaf) =
|
||||
((pkhid, pleaf) : p, g, r, d, l, j)
|
||||
f (p, g, r, d, l, j) (RecipGroup gkhid gleaf) =
|
||||
(p, (gkhid, gleaf) : g, r, d, l, j)
|
||||
f (p, g, r, d, l, j) (RecipRepo rkhid rleaf) =
|
||||
(p, g, (rkhid, rleaf) : r, d, l, j)
|
||||
f (p, g, r, d, l, j) (RecipDeck dkhid dpiece) =
|
||||
(p, g, r, (dkhid, dpiece) : d, l, j)
|
||||
f (p, g, r, d, l, j) (RecipLoom lkhid lpiece) =
|
||||
(p, g, r, d, (lkhid, lpiece) : l, j)
|
||||
f (p, g, r, d, l, j) (RecipProject jkhid jleaf) =
|
||||
(p, g, r, d, l, (jkhid, jleaf) : j)
|
||||
f (p, g, r, d, l, j, f') (RecipPerson pkhid pleaf) =
|
||||
((pkhid, pleaf) : p, g, r, d, l, j, f')
|
||||
f (p, g, r, d, l, j, f') (RecipGroup gkhid gleaf) =
|
||||
(p, (gkhid, gleaf) : g, r, d, l, j, f')
|
||||
f (p, g, r, d, l, j, f') (RecipRepo rkhid rleaf) =
|
||||
(p, g, (rkhid, rleaf) : r, d, l, j, f')
|
||||
f (p, g, r, d, l, j, f') (RecipDeck dkhid dpiece) =
|
||||
(p, g, r, (dkhid, dpiece) : d, l, j, f')
|
||||
f (p, g, r, d, l, j, f') (RecipLoom lkhid lpiece) =
|
||||
(p, g, r, d, (lkhid, lpiece) : l, j, f')
|
||||
f (p, g, r, d, l, j, f') (RecipProject jkhid jleaf) =
|
||||
(p, g, r, d, l, (jkhid, jleaf) : j, f')
|
||||
f (p, g, r, d, l, j, f') (RecipFactory fkhid fleaf) =
|
||||
(p, g, r, d, l, j, (fkhid, fleaf) : f')
|
||||
|
||||
organize
|
||||
:: ( [(KeyHashid Person, LeafPerson)]
|
||||
|
|
@ -612,9 +641,10 @@ groupLocalRecipients = organize . partitionByActor
|
|||
, [(KeyHashid Deck, PieceDeck)]
|
||||
, [(KeyHashid Loom, PieceLoom)]
|
||||
, [(KeyHashid Project, LeafProject)]
|
||||
, [(KeyHashid Factory, LeafFactory)]
|
||||
)
|
||||
-> RecipientRoutes
|
||||
organize (p, g, r, d, l, j) = RecipientRoutes
|
||||
organize (p, g, r, d, l, j, f) = RecipientRoutes
|
||||
{ recipPeople =
|
||||
map (second $ foldr orLP $ PersonRoutes False False) $ groupByKeySort p
|
||||
, recipGroups =
|
||||
|
|
@ -645,6 +675,8 @@ groupLocalRecipients = organize . partitionByActor
|
|||
groupByKeySort l
|
||||
, recipProjects =
|
||||
map (second $ foldr orLJ $ ProjectRoutes False False) $ groupByKeySort j
|
||||
, recipFactories =
|
||||
map (second $ foldr orLF $ FactoryRoutes False False) $ groupByKeySort f
|
||||
}
|
||||
where
|
||||
groupByKey :: (Foldable f, Eq a) => f (a, b) -> [(a, NonEmpty b)]
|
||||
|
|
@ -691,6 +723,11 @@ groupLocalRecipients = organize . partitionByActor
|
|||
orLJ LeafProject rr@(ProjectRoutes _ _) = rr { routeProject = True }
|
||||
orLJ LeafProjectFollowers rr@(ProjectRoutes _ _) = rr { routeProjectFollowers = True }
|
||||
|
||||
orLF :: LeafFactory -> FactoryRoutes -> FactoryRoutes
|
||||
orLF _ rr@(FactoryRoutes True True) = rr
|
||||
orLF LeafFactory rr@(FactoryRoutes _ _) = rr { routeFactory = True }
|
||||
orLF LeafFactoryFollowers rr@(FactoryRoutes _ _) = rr { routeFactoryFollowers = True }
|
||||
|
||||
pd2either :: PieceDeck -> Either LeafDeck (KeyHashid TicketDeck, LeafTicket)
|
||||
pd2either (PieceDeck ld) = Left ld
|
||||
pd2either (PieceTicket ltkhid lt) = Right (ltkhid, lt)
|
||||
|
|
@ -729,6 +766,7 @@ localRecipSieve' sieve allowPeople allowOthers routes = RecipientRoutes
|
|||
, recipDecks = applySieve' applyDeck recipDecks
|
||||
, recipLooms = applySieve' applyLoom recipLooms
|
||||
, recipProjects = applySieve' applyProject recipProjects
|
||||
, recipFactories = applySieve' applyFactory recipFactories
|
||||
}
|
||||
where
|
||||
applySieve
|
||||
|
|
@ -843,6 +881,17 @@ localRecipSieve' sieve allowPeople allowOthers routes = RecipientRoutes
|
|||
then Nothing
|
||||
else Just (rkhid, merged)
|
||||
|
||||
applyFactory _ (This _) = Nothing
|
||||
applyFactory rkhid (That r) =
|
||||
if allowOthers && routeFactory r
|
||||
then Just (rkhid, FactoryRoutes True False)
|
||||
else Nothing
|
||||
applyFactory rkhid (These (FactoryRoutes r' rf') (FactoryRoutes r rf)) =
|
||||
let merged = FactoryRoutes (r && (r' || allowOthers)) (rf && rf')
|
||||
in if merged == FactoryRoutes False False
|
||||
then Nothing
|
||||
else Just (rkhid, merged)
|
||||
|
||||
data ParsedAudience u = ParsedAudience
|
||||
{ paudLocalRecips :: RecipientRoutes
|
||||
, paudRemoteActors :: [(Authority u, NonEmpty LocalURI)]
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
|
|
|
|||
|
|
@ -17,15 +17,20 @@
|
|||
module Vervis.Web.Actor
|
||||
( getInbox
|
||||
, getInbox'
|
||||
, getInbox''
|
||||
, postInbox
|
||||
, getOutbox
|
||||
, getOutbox'
|
||||
, getOutboxItem
|
||||
, getOutboxItem'
|
||||
, getFollowersCollection
|
||||
, getActorFollowersCollection
|
||||
, getActorFollowersCollection'
|
||||
, getFollowingCollection
|
||||
, handleRobotInbox
|
||||
, serveInstanceKey
|
||||
, servePerActorKey
|
||||
, servePerActorKey''
|
||||
)
|
||||
where
|
||||
|
||||
|
|
@ -80,7 +85,6 @@ import qualified Database.Esqueleto as E
|
|||
import Control.Concurrent.Actor hiding (Actor)
|
||||
import Database.Persist.JSON
|
||||
import Network.FedURI
|
||||
import Web.ActivityPub hiding (Project (..), ActorLocal (..))
|
||||
import Yesod.ActivityPub
|
||||
import Yesod.Auth.Unverified
|
||||
import Yesod.FedURI
|
||||
|
|
@ -90,6 +94,7 @@ import Yesod.RenderSource
|
|||
|
||||
import qualified Control.Concurrent.Actor as CCA
|
||||
import qualified Crypto.ActorKey as AK
|
||||
import qualified Web.ActivityPub as AP
|
||||
|
||||
import Control.Monad.Trans.Except.Local
|
||||
import Data.Aeson.Local
|
||||
|
|
@ -143,11 +148,15 @@ objectId o =
|
|||
|
||||
getInbox = getInbox' actorInbox
|
||||
|
||||
getInbox' grabInbox here actor hash = do
|
||||
getInbox' grabInbox here actor hash =
|
||||
getInbox'' grabInbox here (pure . actor) hash
|
||||
|
||||
getInbox'' grabInbox here getActorID hash = do
|
||||
key <- decodeKeyHashid404 hash
|
||||
(total, pages, mpage) <- runDB $ do
|
||||
inboxID <- do
|
||||
actorID <- actor <$> get404 key
|
||||
rec <- get404 key
|
||||
actorID <- getActorID rec
|
||||
grabInbox <$> getJust actorID
|
||||
getPageAndNavCount
|
||||
(countItems inboxID)
|
||||
|
|
@ -161,37 +170,37 @@ getInbox' grabInbox here actor hash = do
|
|||
selectRep $
|
||||
case mpage of
|
||||
Nothing -> do
|
||||
provideAP $ pure $ Doc host $ Collection
|
||||
{ collectionId = encodeRouteLocal here'
|
||||
, collectionType = CollectionTypeOrdered
|
||||
, collectionTotalItems = Just total
|
||||
, collectionCurrent = Nothing
|
||||
, collectionFirst = Just $ pageUrl 1
|
||||
, collectionLast = Just $ pageUrl pages
|
||||
, collectionItems = [] :: [Text]
|
||||
, collectionContext = Nothing
|
||||
AP.provideAP $ pure $ AP.Doc host $ AP.Collection
|
||||
{ AP.collectionId = encodeRouteLocal here'
|
||||
, AP.collectionType = AP.CollectionTypeOrdered
|
||||
, AP.collectionTotalItems = Just total
|
||||
, AP.collectionCurrent = Nothing
|
||||
, AP.collectionFirst = Just $ pageUrl 1
|
||||
, AP.collectionLast = Just $ pageUrl pages
|
||||
, AP.collectionItems = [] :: [Text]
|
||||
, AP.collectionContext = Nothing
|
||||
}
|
||||
provideRep (redirectFirstPage here' :: Handler Html)
|
||||
Just (items, navModel) -> do
|
||||
let current = nmCurrent navModel
|
||||
provideAP $ pure $ Doc host $ CollectionPage
|
||||
{ collectionPageId = pageUrl current
|
||||
, collectionPageType = CollectionPageTypeOrdered
|
||||
, collectionPageTotalItems = Nothing
|
||||
, collectionPageCurrent = Just $ pageUrl current
|
||||
, collectionPageFirst = Just $ pageUrl 1
|
||||
, collectionPageLast = Just $ pageUrl pages
|
||||
, collectionPagePartOf = encodeRouteLocal here'
|
||||
, collectionPagePrev =
|
||||
AP.provideAP $ pure $ AP.Doc host $ AP.CollectionPage
|
||||
{ AP.collectionPageId = pageUrl current
|
||||
, AP.collectionPageType = AP.CollectionPageTypeOrdered
|
||||
, AP.collectionPageTotalItems = Nothing
|
||||
, AP.collectionPageCurrent = Just $ pageUrl current
|
||||
, AP.collectionPageFirst = Just $ pageUrl 1
|
||||
, AP.collectionPageLast = Just $ pageUrl pages
|
||||
, AP.collectionPagePartOf = encodeRouteLocal here'
|
||||
, AP.collectionPagePrev =
|
||||
if current > 1
|
||||
then Just $ pageUrl $ current - 1
|
||||
else Nothing
|
||||
, collectionPageNext =
|
||||
, AP.collectionPageNext =
|
||||
if current < pages
|
||||
then Just $ pageUrl $ current + 1
|
||||
else Nothing
|
||||
, collectionPageStartIndex = Nothing
|
||||
, collectionPageItems = map (view _1) items
|
||||
, AP.collectionPageStartIndex = Nothing
|
||||
, AP.collectionPageItems = map (view _1) items
|
||||
}
|
||||
provideRep $ do
|
||||
let pageNav = navWidget navModel
|
||||
|
|
@ -262,7 +271,8 @@ postInbox
|
|||
TVar (M.HashMap GroupId (ActorRef Group)),
|
||||
TVar (M.HashMap DeckId (ActorRef Deck)),
|
||||
TVar (M.HashMap LoomId (ActorRef Loom)),
|
||||
TVar (M.HashMap RepoId (ActorRef Vervis.Model.Repo))]
|
||||
TVar (M.HashMap RepoId (ActorRef Vervis.Model.Repo)),
|
||||
TVar (M.HashMap FactoryId (ActorRef Factory))]
|
||||
l'0
|
||||
, H.HOccurs'
|
||||
(TVar (M.HashMap (Key a) (ActorRef a)))
|
||||
|
|
@ -272,7 +282,8 @@ postInbox
|
|||
TVar (M.HashMap GroupId (ActorRef Group)),
|
||||
TVar (M.HashMap DeckId (ActorRef Deck)),
|
||||
TVar (M.HashMap LoomId (ActorRef Loom)),
|
||||
TVar (M.HashMap RepoId (ActorRef Vervis.Model.Repo))]
|
||||
TVar (M.HashMap RepoId (ActorRef Vervis.Model.Repo)),
|
||||
TVar (M.HashMap FactoryId (ActorRef Factory))]
|
||||
)
|
||||
=> (Key a -> LocalActorBy Key) -> Key a -> Handler ()
|
||||
postInbox toLA recipID = do
|
||||
|
|
@ -290,11 +301,11 @@ postInbox toLA recipID = do
|
|||
parseAuthenticatedLocalActivityURI
|
||||
authorByKey
|
||||
(AP.activityId $ actbActivity body)
|
||||
actorID <- do
|
||||
ment <- lift $ runDB $ getLocalActorEntity authorByKey
|
||||
actorID <- runDBExcept $ do
|
||||
ment <- lift $ getLocalActorEntity authorByKey
|
||||
case ment of
|
||||
Nothing -> throwE "Author not found in DB"
|
||||
Just ent -> return $ localActorID ent
|
||||
Just ent -> lift $ grabLocalActorID ent
|
||||
return (authorByKey, actorID, outboxItemID)
|
||||
ActivityAuthRemote author -> Right <$> do
|
||||
luActivity <-
|
||||
|
|
@ -333,11 +344,14 @@ postInbox toLA recipID = do
|
|||
throwE "'actor' actor and 'id' actor mismatch"
|
||||
return outboxItemID
|
||||
|
||||
getOutbox here itemRoute grabActorID hash = do
|
||||
getOutbox here itemRoute grabActorID hash =
|
||||
getOutbox' here itemRoute (pure . grabActorID) hash
|
||||
|
||||
getOutbox' here itemRoute grabActorID hash = do
|
||||
key <- decodeKeyHashid404 hash
|
||||
(total, pages, mpage) <- runDB $ do
|
||||
outboxID <- do
|
||||
actorID <- grabActorID <$> get404 key
|
||||
actorID <- grabActorID =<< get404 key
|
||||
actorOutbox <$> getJust actorID
|
||||
let countAllItems = count [OutboxItemOutbox ==. outboxID]
|
||||
selectItems off lim = selectList [OutboxItemOutbox ==. outboxID] [Desc OutboxItemId, OffsetBy off, LimitTo lim]
|
||||
|
|
@ -351,37 +365,37 @@ getOutbox here itemRoute grabActorID hash = do
|
|||
selectRep $
|
||||
case mpage of
|
||||
Nothing -> do
|
||||
provideAP $ pure $ Doc host $ Collection
|
||||
{ collectionId = encodeRouteLocal here'
|
||||
, collectionType = CollectionTypeOrdered
|
||||
, collectionTotalItems = Just total
|
||||
, collectionCurrent = Nothing
|
||||
, collectionFirst = Just $ pageUrl 1
|
||||
, collectionLast = Just $ pageUrl pages
|
||||
, collectionItems = [] :: [Text]
|
||||
, collectionContext = Nothing
|
||||
AP.provideAP $ pure $ AP.Doc host $ AP.Collection
|
||||
{ AP.collectionId = encodeRouteLocal here'
|
||||
, AP.collectionType = AP.CollectionTypeOrdered
|
||||
, AP.collectionTotalItems = Just total
|
||||
, AP.collectionCurrent = Nothing
|
||||
, AP.collectionFirst = Just $ pageUrl 1
|
||||
, AP.collectionLast = Just $ pageUrl pages
|
||||
, AP.collectionItems = [] :: [Text]
|
||||
, AP.collectionContext = Nothing
|
||||
}
|
||||
provideRep (redirectFirstPage here' :: Handler Html)
|
||||
Just (items, navModel) -> do
|
||||
let current = nmCurrent navModel
|
||||
provideAP $ pure $ Doc host $ CollectionPage
|
||||
{ collectionPageId = pageUrl current
|
||||
, collectionPageType = CollectionPageTypeOrdered
|
||||
, collectionPageTotalItems = Nothing
|
||||
, collectionPageCurrent = Just $ pageUrl current
|
||||
, collectionPageFirst = Just $ pageUrl 1
|
||||
, collectionPageLast = Just $ pageUrl pages
|
||||
, collectionPagePartOf = encodeRouteLocal here'
|
||||
, collectionPagePrev =
|
||||
AP.provideAP $ pure $ AP.Doc host $ AP.CollectionPage
|
||||
{ AP.collectionPageId = pageUrl current
|
||||
, AP.collectionPageType = AP.CollectionPageTypeOrdered
|
||||
, AP.collectionPageTotalItems = Nothing
|
||||
, AP.collectionPageCurrent = Just $ pageUrl current
|
||||
, AP.collectionPageFirst = Just $ pageUrl 1
|
||||
, AP.collectionPageLast = Just $ pageUrl pages
|
||||
, AP.collectionPagePartOf = encodeRouteLocal here'
|
||||
, AP.collectionPagePrev =
|
||||
if current > 1
|
||||
then Just $ pageUrl $ current - 1
|
||||
else Nothing
|
||||
, collectionPageNext =
|
||||
, AP.collectionPageNext =
|
||||
if current < pages
|
||||
then Just $ pageUrl $ current + 1
|
||||
else Nothing
|
||||
, collectionPageStartIndex = Nothing
|
||||
, collectionPageItems = map (persistJSONObject . outboxItemActivity . entityVal) items
|
||||
, AP.collectionPageStartIndex = Nothing
|
||||
, AP.collectionPageItems = map (persistJSONObject . outboxItemActivity . entityVal) items
|
||||
}
|
||||
provideRep $ do
|
||||
let pageNav = navWidget navModel
|
||||
|
|
@ -389,12 +403,15 @@ getOutbox here itemRoute grabActorID hash = do
|
|||
hashItem <- getEncodeKeyHashid
|
||||
defaultLayout $(widgetFile "person/outbox")
|
||||
|
||||
getOutboxItem here actor topicHash itemHash = do
|
||||
getOutboxItem here actor topicHash itemHash =
|
||||
getOutboxItem' here (pure . actor) topicHash itemHash
|
||||
|
||||
getOutboxItem' here actor topicHash itemHash = do
|
||||
topicID <- decodeKeyHashid404 topicHash
|
||||
itemID <- decodeKeyHashid404 itemHash
|
||||
body <- runDB $ do
|
||||
outboxID <- do
|
||||
actorID <- actor <$> get404 topicID
|
||||
actorID <- actor =<< get404 topicID
|
||||
actorOutbox <$> getJust actorID
|
||||
item <- get404 itemID
|
||||
unless (outboxItemOutbox item == outboxID) notFound
|
||||
|
|
@ -405,6 +422,7 @@ getOutboxItem here actor topicHash itemHash = do
|
|||
getLocalActors
|
||||
:: [ActorId] -> ReaderT SqlBackend Handler [LocalActorBy Key]
|
||||
getLocalActors actorIDs = do
|
||||
resourceIDs <- selectKeysList [ResourceActor <-. actorIDs] []
|
||||
localActors <-
|
||||
concat <$> sequenceA
|
||||
[ map LocalActorPerson <$>
|
||||
|
|
@ -419,6 +437,8 @@ getLocalActors actorIDs = do
|
|||
selectKeysList [LoomActor <-. actorIDs] []
|
||||
, map LocalActorProject <$>
|
||||
selectKeysList [ProjectActor <-. actorIDs] []
|
||||
, map LocalActorFactory <$>
|
||||
selectKeysList [FactoryResource <-. resourceIDs] []
|
||||
]
|
||||
case compare (length localActors) (length actorIDs) of
|
||||
LT -> error "Found actor ID not used by any specific actor"
|
||||
|
|
@ -453,26 +473,29 @@ getFollowersCollection here getFsid = do
|
|||
encodeRouteLocal <- getEncodeRouteLocal
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
hashActor <- getHashLocalActor
|
||||
let followersAP = Collection
|
||||
{ collectionId = encodeRouteLocal here
|
||||
, collectionType = CollectionTypeUnordered
|
||||
, collectionTotalItems = Just $ l + r
|
||||
, collectionCurrent = Nothing
|
||||
, collectionFirst = Nothing
|
||||
, collectionLast = Nothing
|
||||
, collectionItems =
|
||||
let followersAP = AP.Collection
|
||||
{ AP.collectionId = encodeRouteLocal here
|
||||
, AP.collectionType = AP.CollectionTypeUnordered
|
||||
, AP.collectionTotalItems = Just $ l + r
|
||||
, AP.collectionCurrent = Nothing
|
||||
, AP.collectionFirst = Nothing
|
||||
, AP.collectionLast = Nothing
|
||||
, AP.collectionItems =
|
||||
map (encodeRouteHome . renderLocalActor . hashActor) locals ++
|
||||
map (uncurry ObjURI . bimap E.unValue E.unValue) remotes
|
||||
, collectionContext = Nothing
|
||||
, AP.collectionContext = Nothing
|
||||
}
|
||||
provideHtmlAndAP followersAP $ redirectToPrettyJSON here
|
||||
|
||||
getActorFollowersCollection here actor hash = do
|
||||
getActorFollowersCollection here actor hash =
|
||||
getActorFollowersCollection' here (pure . actor) hash
|
||||
|
||||
getActorFollowersCollection' here actor hash = do
|
||||
key <- decodeKeyHashid404 hash
|
||||
getFollowersCollection (here hash) (getFsid key)
|
||||
where
|
||||
getFsid key = do
|
||||
actorID <- actor <$> get404 key
|
||||
actorID <- actor =<< get404 key
|
||||
actorFollowers <$> getJust actorID
|
||||
|
||||
getFollowingCollection here actor hash = do
|
||||
|
|
@ -500,15 +523,15 @@ getFollowingCollection here actor hash = do
|
|||
encodeRouteLocal <- getEncodeRouteLocal
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
let here' = here hash
|
||||
followingAP = Collection
|
||||
{ collectionId = encodeRouteLocal here'
|
||||
, collectionType = CollectionTypeUnordered
|
||||
, collectionTotalItems = Just $ localTotal + length remotes
|
||||
, collectionCurrent = Nothing
|
||||
, collectionFirst = Nothing
|
||||
, collectionLast = Nothing
|
||||
, collectionItems = map encodeRouteHome locals ++ remotes
|
||||
, collectionContext = Nothing
|
||||
followingAP = AP.Collection
|
||||
{ AP.collectionId = encodeRouteLocal here'
|
||||
, AP.collectionType = AP.CollectionTypeUnordered
|
||||
, AP.collectionTotalItems = Just $ localTotal + length remotes
|
||||
, AP.collectionCurrent = Nothing
|
||||
, AP.collectionFirst = Nothing
|
||||
, AP.collectionLast = Nothing
|
||||
, AP.collectionItems = map encodeRouteHome locals ++ remotes
|
||||
, AP.collectionContext = Nothing
|
||||
}
|
||||
provideHtmlAndAP followingAP $ redirectToPrettyJSON here'
|
||||
where
|
||||
|
|
@ -531,7 +554,7 @@ handleRobotInbox
|
|||
-> ActivityBody
|
||||
-> Maybe (RecipientRoutes, ByteString)
|
||||
-> LocalURI
|
||||
-> SpecificActivity URIMode
|
||||
-> AP.SpecificActivity URIMode
|
||||
-> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text))
|
||||
)
|
||||
-> UTCTime
|
||||
|
|
@ -544,13 +567,13 @@ handleRobotInbox recipByHash handleSpecific now auth body = do
|
|||
ActivityAuthLocal _ -> throwE "Got a forwarded local activity, I don't need those"
|
||||
ActivityAuthRemote ra -> return ra
|
||||
luActivity <-
|
||||
fromMaybeE (activityId $ actbActivity body) "Activity without 'id'"
|
||||
fromMaybeE (AP.activityId $ actbActivity body) "Activity without 'id'"
|
||||
localRecips <- do
|
||||
mrecips <- parseAudience $ activityAudience $ actbActivity body
|
||||
mrecips <- parseAudience $ AP.activityAudience $ actbActivity body
|
||||
paudLocalRecips <$> fromMaybeE mrecips "Activity with no recipients"
|
||||
msig <- checkForwarding recipByHash
|
||||
let mfwd = (localRecips,) <$> msig
|
||||
handleSpecific now remoteAuthor body mfwd luActivity (activitySpecific $ actbActivity body)
|
||||
handleSpecific now remoteAuthor body mfwd luActivity (AP.activitySpecific $ actbActivity body)
|
||||
|
||||
actorKeyAP
|
||||
:: ( MonadSite m, SiteEnv m ~ site
|
||||
|
|
@ -602,11 +625,21 @@ servePerActorKey
|
|||
-> KeyHashid holder
|
||||
-> KeyHashid SigKey
|
||||
-> Handler TypedContent
|
||||
servePerActorKey holderActor localActorHolder holderHash keyHash = do
|
||||
servePerActorKey holderActor localActorHolder holderHash keyHash =
|
||||
servePerActorKey'' (pure . holderActor) localActorHolder holderHash keyHash
|
||||
|
||||
servePerActorKey''
|
||||
:: (PersistRecordBackend holder SqlBackend, ToBackendKey SqlBackend holder)
|
||||
=> (holder -> AppDB ActorId)
|
||||
-> (KeyHashid holder -> LocalActorBy KeyHashid)
|
||||
-> KeyHashid holder
|
||||
-> KeyHashid SigKey
|
||||
-> Handler TypedContent
|
||||
servePerActorKey'' holderActor localActorHolder holderHash keyHash = do
|
||||
holderID <- decodeKeyHashid404 holderHash
|
||||
keyID <- decodeKeyHashid404 keyHash
|
||||
akey <- runDB $ do
|
||||
actorID <- holderActor <$> get404 holderID
|
||||
actorID <- holderActor =<< get404 holderID
|
||||
SigKey actorID' akey <- get404 keyID
|
||||
unless (actorID' == actorID) notFound
|
||||
return akey
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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}
|
||||
|
||||
|
|
|
|||
|
|
@ -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>
|
||||
|
|
|
|||
35
templates/factory/nav.hamlet
Normal file
35
templates/factory/nav.hamlet
Normal file
|
|
@ -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]
|
||||
18
templates/factory/new.hamlet
Normal file
18
templates/factory/new.hamlet
Normal file
|
|
@ -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">
|
||||
|
|
@ -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>
|
||||
|
|
|
|||
|
|
@ -167,6 +167,13 @@ Komponent
|
|||
|
||||
UniqueKomponent resource
|
||||
|
||||
Factory
|
||||
resource ResourceId
|
||||
create OutboxItemId
|
||||
|
||||
UniqueFactory resource
|
||||
UniqueFactoryCreate create
|
||||
|
||||
-- ========================================================================= --
|
||||
-- Delivery
|
||||
-- ========================================================================= --
|
||||
|
|
|
|||
26
th/routes
26
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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in a new issue