S2S: Deck Add handler
This commit is contained in:
Pere Lev
parent
06e5ab9e90
commit
521eed8bb2
1 changed files with 282 additions and 0 deletions
|
|
@ -19,6 +19,7 @@ module Vervis.Actor.Deck
|
|||
where
|
||||
|
||||
import Control.Applicative
|
||||
import Control.Exception.Base
|
||||
import Control.Monad
|
||||
import Control.Monad.IO.Class
|
||||
import Control.Monad.Logger.CallStack
|
||||
|
|
@ -36,9 +37,11 @@ import Data.Time.Clock
|
|||
import Data.Traversable
|
||||
import Database.Persist
|
||||
import Database.Persist.Sql
|
||||
import Optics.Core
|
||||
import Yesod.Persist.Core
|
||||
|
||||
import qualified Data.Text as T
|
||||
import qualified Database.Esqueleto as E
|
||||
|
||||
import Control.Concurrent.Actor
|
||||
import Network.FedURI
|
||||
|
|
@ -68,8 +71,286 @@ import Vervis.Recipient (makeRecipientSet, LocalStageBy (..), Aud (..), collectA
|
|||
import Vervis.Persist.Actor
|
||||
import Vervis.Persist.Collab
|
||||
import Vervis.Persist.Discussion
|
||||
import Vervis.RemoteActorStore
|
||||
import Vervis.Ticket
|
||||
|
||||
checkExistingStems
|
||||
:: DeckId -> Either (Entity Project) RemoteActorId -> ActDBE ()
|
||||
checkExistingStems deckID projectDB = do
|
||||
|
||||
-- Find existing Stem records I have for this project
|
||||
stemIDs <- lift $ getExistingStems projectDB
|
||||
|
||||
-- Grab all the enabled ones, make sure none are enabled, and even if
|
||||
-- any are enabled, make sure there's at most one (otherwise it's a
|
||||
-- bug)
|
||||
byEnabled <-
|
||||
lift $ for stemIDs $ \ (_, stem) ->
|
||||
isJust <$> runMaybeT (tryStemEnabled stem)
|
||||
case length $ filter id byEnabled of
|
||||
0 -> return ()
|
||||
1 -> throwE "I already have a StemProjectGrant* for this project"
|
||||
_ -> error "Multiple StemProjectGrant* for a project"
|
||||
|
||||
-- Verify none of the Stem records are already in
|
||||
-- Add-waiting-for-project or Invite-waiting-for-my-collaborator state
|
||||
anyStarted <-
|
||||
lift $ runMaybeT $ asum $
|
||||
map (\ (stemID, project) ->
|
||||
tryStemAddAccept stemID <|>
|
||||
tryStemInviteAccept stemID project
|
||||
)
|
||||
stemIDs
|
||||
unless (isNothing anyStarted) $
|
||||
throwE
|
||||
"One of the Stem records is already in Add-Accept or \
|
||||
\Invite-Accept state"
|
||||
|
||||
where
|
||||
|
||||
getExistingStems (Left (Entity projectID _)) =
|
||||
fmap (map $ bimap E.unValue (Left . E.unValue)) $
|
||||
E.select $ E.from $ \ (project `E.InnerJoin` ident) -> do
|
||||
E.on $ project E.^. StemProjectLocalStem E.==. ident E.^. StemIdentDeckStem
|
||||
E.where_ $
|
||||
project E.^. StemProjectLocalProject E.==. E.val projectID E.&&.
|
||||
ident E.^. StemIdentDeckDeck E.==. E.val deckID
|
||||
return
|
||||
( project E.^. StemProjectLocalStem
|
||||
, project E.^. StemProjectLocalId
|
||||
)
|
||||
getExistingStems (Right remoteActorID) =
|
||||
fmap (map $ bimap E.unValue (Right . E.unValue)) $
|
||||
E.select $ E.from $ \ (project `E.InnerJoin` ident) -> do
|
||||
E.on $ project E.^. StemProjectRemoteStem E.==. ident E.^. StemIdentDeckStem
|
||||
E.where_ $
|
||||
project E.^. StemProjectRemoteProject E.==. E.val remoteActorID E.&&.
|
||||
ident E.^. StemIdentDeckDeck E.==. E.val deckID
|
||||
return
|
||||
( project E.^. StemProjectRemoteStem
|
||||
, project E.^. StemProjectRemoteId
|
||||
)
|
||||
|
||||
tryStemEnabled (Left localID) =
|
||||
const () <$> MaybeT (getBy $ UniqueStemProjectGrantLocalProject localID)
|
||||
tryStemEnabled (Right remoteID) =
|
||||
const () <$> MaybeT (getBy $ UniqueStemProjectGrantRemoteProject remoteID)
|
||||
|
||||
tryStemAddAccept stemID = do
|
||||
_ <- MaybeT $ getBy $ UniqueStemOriginAdd stemID
|
||||
_ <- MaybeT $ getBy $ UniqueStemComponentAccept stemID
|
||||
pure ()
|
||||
|
||||
tryStemInviteAccept stemID project = do
|
||||
originID <- MaybeT $ getKeyBy $ UniqueStemOriginInvite stemID
|
||||
case project of
|
||||
Left localID ->
|
||||
const () <$> MaybeT (getBy $ UniqueStemProjectAcceptLocalProject localID)
|
||||
Right remoteID ->
|
||||
const () <$> MaybeT (getBy $ UniqueStemProjectAcceptRemoteProject remoteID)
|
||||
|
||||
-- Meaning: An actor is adding some object to some target
|
||||
-- Behavior:
|
||||
-- * Verify that the object is me
|
||||
-- * Verify the target is some project's components collection URI
|
||||
-- * Verify the Add is authorized
|
||||
-- * For all the Stem records I have for this project:
|
||||
-- * Verify I'm not yet a member of the project
|
||||
-- * Verify I haven't already Accepted an Add to this project
|
||||
-- * Verify I haven't already seen an Invite-and-Project-accept for
|
||||
-- this project
|
||||
-- * Insert the Add to my inbox
|
||||
-- * Create a Stem record in DB
|
||||
-- * Forward the Add activity to my followers
|
||||
-- * Send an Accept on the Add:
|
||||
-- * To:
|
||||
-- * The author of the Add
|
||||
-- * The project
|
||||
-- * CC:
|
||||
-- * Author's followers
|
||||
-- * Project's followers
|
||||
-- * My followers
|
||||
deckAdd
|
||||
:: UTCTime
|
||||
-> DeckId
|
||||
-> Verse
|
||||
-> AP.Add URIMode
|
||||
-> ActE (Text, Act (), Next)
|
||||
deckAdd now deckID (Verse authorIdMsig body) add = do
|
||||
|
||||
-- Check capability
|
||||
capability <- do
|
||||
|
||||
-- Verify that a capability is provided
|
||||
uCap <- do
|
||||
let muCap = AP.activityCapability $ actbActivity body
|
||||
fromMaybeE muCap "No capability provided"
|
||||
|
||||
-- Verify the capability URI is one of:
|
||||
-- * Outbox item URI of a local actor, i.e. a local activity
|
||||
-- * A remote URI
|
||||
cap <- nameExceptT "Invite capability" $ parseActivityURI' uCap
|
||||
|
||||
-- Verify the capability is local
|
||||
case cap of
|
||||
Left (actorByKey, _, outboxItemID) ->
|
||||
return (actorByKey, outboxItemID)
|
||||
_ -> throwE "Capability is remote i.e. definitely not by me"
|
||||
|
||||
-- Check input
|
||||
projectComps <- do
|
||||
let author = bimap (view _1) (remoteAuthorURI . view _1) authorIdMsig
|
||||
(component, projectComps, role) <- parseAdd author add
|
||||
unless (component == Left (ComponentDeck deckID)) $
|
||||
throwE "Add object isn't me"
|
||||
unless (role == AP.RoleAdmin) $
|
||||
throwE "Add role isn't admin"
|
||||
return projectComps
|
||||
|
||||
-- If project is local, find it in our DB
|
||||
-- If project is remote, HTTP GET it and store in our DB (if it's already
|
||||
-- there, no need for HTTP)
|
||||
--
|
||||
-- NOTE: This is a blocking HTTP GET done right here in the handler,
|
||||
-- which is NOT a good idea. Ideally, it would be done async, and the
|
||||
-- handler result would be sent later in a separate (e.g. Accept) activity.
|
||||
-- But for the PoC level, the current situation will hopefully do.
|
||||
projectDB <-
|
||||
bitraverse
|
||||
(withDBExcept . flip getEntityE "Project not found in DB")
|
||||
(\ u@(ObjURI h luComps) -> do
|
||||
manager <- asksEnv envHttpManager
|
||||
collection <-
|
||||
ExceptT $ first T.pack <$>
|
||||
AP.fetchAPID
|
||||
manager
|
||||
(AP.collectionId :: AP.Collection FedURI URIMode -> LocalURI)
|
||||
h
|
||||
luComps
|
||||
luProject <- fromMaybeE (AP.collectionContext collection) "Collection has no context"
|
||||
project <-
|
||||
ExceptT $ first T.pack <$>
|
||||
AP.fetchAPID manager (AP.actorId . AP.actorLocal . AP.projectActor) h luProject
|
||||
unless (AP.projectComponents project == luComps) $
|
||||
throwE "The collection isn't the project's components collection"
|
||||
|
||||
instanceID <-
|
||||
lift $ withDB $ either entityKey id <$> insertBy' (Instance h)
|
||||
result <-
|
||||
ExceptT $ first (T.pack . displayException) <$>
|
||||
fetchRemoteActor' instanceID h luProject
|
||||
case result of
|
||||
Left Nothing -> throwE "Target @id mismatch"
|
||||
Left (Just err) -> throwE $ T.pack $ displayException err
|
||||
Right Nothing -> throwE "Target isn't an actor"
|
||||
Right (Just actor) -> do
|
||||
unless (remoteActorType (entityVal actor) == AP.ActorTypeProject) $
|
||||
throwE "Remote project type isn't Project"
|
||||
return $ entityKey actor
|
||||
)
|
||||
projectComps
|
||||
|
||||
maybeNew <- withDBExcept $ do
|
||||
|
||||
-- Grab me from DB
|
||||
(deck, actor) <- lift $ do
|
||||
d <- getJust deckID
|
||||
(d,) <$> getJust (deckActor d)
|
||||
|
||||
-- Find existing Stem records I have for this project
|
||||
-- Make sure none are enabled / in Add-Accept mode / in Invite-Accept
|
||||
-- mode
|
||||
checkExistingStems deckID projectDB
|
||||
|
||||
-- Verify the specified capability gives relevant access
|
||||
verifyCapability'
|
||||
capability authorIdMsig (GrantResourceDeck deckID) AP.RoleAdmin
|
||||
|
||||
-- Insert the Add to my inbox
|
||||
mractid <- lift $ insertToInbox now authorIdMsig body (actorInbox actor) False
|
||||
lift $ for mractid $ \ addDB -> do
|
||||
|
||||
-- Create a Stem record in DB
|
||||
acceptID <- insertEmptyOutboxItem' (actorOutbox actor) now
|
||||
insertStem projectDB addDB acceptID
|
||||
|
||||
-- Prepare forwarding Add to my followers
|
||||
sieve <- do
|
||||
deckHash <- encodeKeyHashid deckID
|
||||
return $ makeRecipientSet [] [LocalStageDeckFollowers deckHash]
|
||||
|
||||
-- Prepare an Accept activity and insert to my outbox
|
||||
accept@(actionAccept, _, _, _) <- prepareAccept projectDB
|
||||
_luAccept <- updateOutboxItem' (LocalActorDeck deckID) acceptID actionAccept
|
||||
|
||||
return (deckActor deck, sieve, acceptID, accept)
|
||||
|
||||
case maybeNew of
|
||||
Nothing -> done "I already have this activity in my inbox"
|
||||
Just (actorID, sieve, acceptID, (actionAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept)) -> do
|
||||
forwardActivity
|
||||
authorIdMsig body (LocalActorDeck deckID) actorID sieve
|
||||
lift $ sendActivity
|
||||
(LocalActorDeck deckID) actorID localRecipsAccept
|
||||
remoteRecipsAccept fwdHostsAccept acceptID actionAccept
|
||||
done "Recorded and forwarded the Add, sent an Accept"
|
||||
|
||||
where
|
||||
|
||||
insertStem projectDB addDB acceptID = do
|
||||
stemID <- insert $ Stem AP.RoleAdmin
|
||||
insert_ $ StemIdentDeck stemID deckID
|
||||
case projectDB of
|
||||
Left (Entity projectID _) ->
|
||||
insert_ $ StemProjectLocal stemID projectID
|
||||
Right remoteActorID ->
|
||||
insert_ $ StemProjectRemote stemID remoteActorID
|
||||
insert_ $ StemOriginAdd stemID
|
||||
case addDB of
|
||||
Left (_, _, addID) ->
|
||||
insert_ $ StemComponentGestureLocal stemID addID
|
||||
Right (author, _, addID) ->
|
||||
insert_ $ StemComponentGestureRemote stemID (remoteAuthorId author) addID
|
||||
insert_ $ StemComponentAccept stemID acceptID
|
||||
|
||||
prepareAccept projectDB = do
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
|
||||
audAdder <- makeAudSenderWithFollowers authorIdMsig
|
||||
audProject <-
|
||||
case projectDB of
|
||||
Left (Entity j _) -> do
|
||||
jh <- encodeKeyHashid j
|
||||
return $
|
||||
AudLocal
|
||||
[LocalActorProject jh]
|
||||
[LocalStageProjectFollowers jh]
|
||||
Right remoteActorID -> do
|
||||
ra <- getJust remoteActorID
|
||||
ObjURI h lu <- getRemoteActorURI ra
|
||||
return $ AudRemote h [lu] (maybeToList $ remoteActorFollowers ra)
|
||||
audComponent <-
|
||||
AudLocal [] . pure . LocalStageDeckFollowers <$>
|
||||
encodeKeyHashid deckID
|
||||
uAdd <- lift $ getActivityURI authorIdMsig
|
||||
|
||||
let (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
|
||||
collectAudience [audAdder, audProject, audComponent]
|
||||
|
||||
recips = map encodeRouteHome audLocal ++ audRemote
|
||||
action = AP.Action
|
||||
{ AP.actionCapability = Nothing
|
||||
, AP.actionSummary = Nothing
|
||||
, AP.actionAudience = AP.Audience recips [] [] [] [] []
|
||||
, AP.actionFulfills = [uAdd]
|
||||
, AP.actionSpecific = AP.AcceptActivity AP.Accept
|
||||
{ AP.acceptObject = uAdd
|
||||
, AP.acceptResult = Nothing
|
||||
}
|
||||
}
|
||||
|
||||
return (action, recipientSet, remoteActors, fwdHosts)
|
||||
|
||||
-- Meaning: Someone has created a ticket tracker with my ID URI
|
||||
-- Behavior:
|
||||
-- * Verify I'm in a just-been-created state
|
||||
|
|
@ -472,6 +753,7 @@ deckBehavior :: UTCTime -> DeckId -> VerseExt -> ActE (Text, Act (), Next)
|
|||
deckBehavior now deckID (Left verse@(Verse _authorIdMsig body)) =
|
||||
case AP.activitySpecific $ actbActivity body of
|
||||
AP.AcceptActivity accept -> deckAccept now deckID verse accept
|
||||
AP.AddActivity add -> deckAdd now deckID verse add
|
||||
AP.CreateActivity create -> deckCreate now deckID verse create
|
||||
AP.FollowActivity follow -> deckFollow now deckID verse follow
|
||||
AP.InviteActivity invite -> deckInvite now deckID verse invite
|
||||
|
|
|
|||
Loading…
Reference in a new issue