diff --git a/src/Vervis/Actor/Project.hs b/src/Vervis/Actor/Project.hs index 9accd5f..4f932a4 100644 --- a/src/Vervis/Actor/Project.hs +++ b/src/Vervis/Actor/Project.hs @@ -725,107 +725,56 @@ projectAccept now projectID (Verse authorIdMsig body) accept = do remoteRecipsGrant fwdHostsGrant grantID actionGrant doneDB inboxItemID "[Component mode] Forwarded the Accept and maybe published a Grant" - addChildParent cp = do + -- Add-a-child mode + addChildParent (Left (sourceID, topic, mode)) = do - idsForAccept <- + mode' <- bitraverse - -- Adding-a-new-child mode - (\ (sourceID, topic, mode) -> (sourceID,topic,) <$> bitraverse + -- Child-active mode + -- Verify we haven't yet seen child's Accept + (\ () -> do + maybeChildAccept <- + lift $ withDB $ + case bimap fst fst topic of + Left localID -> (() <$) <$> getBy (UniqueSourceThemAcceptLocal localID) + Right remoteID -> (() <$) <$> getBy (UniqueSourceThemAcceptRemote remoteID) + verifyNothingE maybeChildAccept "I already saw child's Accept" + ) - -- Child-active mode - -- Verify we haven't yet seen child's Accept - (\ () -> do - maybeChildAccept <- - lift $ withDB $ - case bimap fst fst topic of + -- Child-passive mode + -- Option 1: We haven't seen child's Accept yet + -- * Verify sender is the child + -- Option 2: We saw it, but not my collaborator's Accept + -- * Verify the Accept is authorized + -- Otherwise respond with error, no Accept is needed + (\ () -> do + (maybeChildAccept, maybeGrant) <- + lift $ withDB $ liftA2 (,) + (case bimap fst fst topic of Left localID -> (() <$) <$> getBy (UniqueSourceThemAcceptLocal localID) Right remoteID -> (() <$) <$> getBy (UniqueSourceThemAcceptRemote remoteID) - verifyNothingE maybeChildAccept "I already saw child's Accept" - ) - - -- Child-passive mode - -- Option 1: We haven't seen child's Accept yet - -- * Verify sender is the child - -- Option 2: We saw it, but not my collaborator's Accept - -- * Verify the Accept is authorized - -- Otherwise respond with error, no Accept is needed - (\ () -> do - (maybeChildAccept, maybeGrant) <- - lift $ withDB $ liftA2 (,) - (case bimap fst fst topic of - Left localID -> (() <$) <$> getBy (UniqueSourceThemAcceptLocal localID) - Right remoteID -> (() <$) <$> getBy (UniqueSourceThemAcceptRemote remoteID) - ) - (getBy $ UniqueSourceUsSendDelegator sourceID) - case (isJust maybeChildAccept, isJust maybeGrant) of - (False, True) -> error "Impossible/bug, didn't see child's Accept but sent a Grant" - (False, False) -> do - unless (theyIsAuthor topic) $ - throwE "The Accept I'm waiting for is from my new child" - return $ Left () - (True, False) -> do - let muCap = AP.activityCapability $ actbActivity body - uCap <- fromMaybeE muCap "No capability provided" - verifyCapability'' - uCap - authorIdMsig - (LocalResourceProject projectID) - AP.RoleAdmin - return $ Right () - (True, True) -> throwE "Child already enabled, not needing any further Accept" - ) - - mode + ) + (getBy $ UniqueSourceUsSendDelegator sourceID) + case (isJust maybeChildAccept, isJust maybeGrant) of + (False, True) -> error "Impossible/bug, didn't see child's Accept but sent a Grant" + (False, False) -> do + unless (theyIsAuthor topic) $ + throwE "The Accept I'm waiting for is from my new child" + return $ Left () + (True, False) -> do + let muCap = AP.activityCapability $ actbActivity body + uCap <- fromMaybeE muCap "No capability provided" + verifyCapability'' + uCap + authorIdMsig + (LocalResourceProject projectID) + AP.RoleAdmin + return $ Right () + (True, True) -> throwE "Child already enabled, not needing any further Accept" ) - -- Adding-a-new-parent mode - (\ (destID, topic, mode) -> case mode of - - -- Parent-active mode - -- Respond with error, we aren't supposed to get any Accept - Left () -> throwE "Parent-active (DestOriginUs) mode, I'm not expecting any Accept" - - -- Parent-passive mode - -- Option 1: I haven't yet seen parent's Accept - -- * Verify sender is the parent - -- Option 2: I saw it, but not my collaborator's Accept - -- * Verify the accept is authorized - -- Otherwise respond with error, no Accept is needed - Right themID -> (destID,themID,topic,) <$> do - (maybeParentAccept, maybeUsGesture) <- - lift $ withDB $ liftA2 (,) - (case bimap fst fst topic of - Left localID -> (() <$) <$> getBy (UniqueDestThemAcceptLocalTopic localID) - Right remoteID -> (() <$) <$> getBy (UniqueDestThemAcceptRemoteTopic remoteID) - ) - (do l <- getBy $ UniqueDestUsGestureLocal destID - r <- getBy $ UniqueDestUsGestureRemote destID - case (isJust l, isJust r) of - (False, False) -> pure Nothing - (False, True) -> pure $ Just () - (True, False) -> pure $ Just () - (True, True) -> error "Both DestUsGestureLocal and DestUsGestureRemote" - ) - case (isJust maybeParentAccept, isJust maybeUsGesture) of - (False, True) -> error "Impossible/bug, didn't see parent's Accept but recorded my collaborator's Accept" - (False, False) -> do - unless (theyIsAuthor topic) $ - throwE "The Accept I'm waiting for is from my new parent" - return $ Left () - (True, False) -> do - let muCap = AP.activityCapability $ actbActivity body - uCap <- fromMaybeE muCap "No capability provided" - verifyCapability'' - uCap - authorIdMsig - (LocalResourceProject projectID) - AP.RoleAdmin - return $ Right () - (True, True) -> throwE "Just waiting for Grant from parent, or already have it, anyway not needing any further Accept" - ) - - cp + mode maybeNew <- withDBExcept $ do @@ -839,93 +788,60 @@ projectAccept now projectID (Verse authorIdMsig body) accept = do for maybeAcceptDB $ \ (inboxItemID, acceptDB) -> do idsForGrant <- + lift $ bitraverse - -- Child mode - (\ (sourceID, topic, mode) -> lift $ bitraverse - - -- Child-active mode - -- If sender is child, record the Accept into the - -- Source record & prepare to send degelator-Grant - -- Othrerwise do nothing - (\ () -> - if theyIsAuthor topic - then Just <$> do - case (topic, acceptDB) of - (Left (localID, _), Left (_, _, acceptID)) -> - insert_ $ SourceThemAcceptLocal localID acceptID - (Right (remoteID, _), Right (_, _, acceptID)) -> - insert_ $ SourceThemAcceptRemote remoteID acceptID - _ -> error "projectAccept impossible iv" - grantID <- insertEmptyOutboxItem' (actorOutbox recipActor) now - insert_ $ SourceUsSendDelegator sourceID grantID - return (topic, grantID) - else pure Nothing - ) - - -- Child-passive mode - (\case - - -- Getting an Accept from the child - -- Record child's Accept in Source record - Left () -> do + -- Child-active mode + -- If sender is child, record the Accept into the + -- Source record & prepare to send degelator-Grant + -- Othrerwise do nothing + (\ () -> + if theyIsAuthor topic + then Just <$> do case (topic, acceptDB) of (Left (localID, _), Left (_, _, acceptID)) -> insert_ $ SourceThemAcceptLocal localID acceptID (Right (remoteID, _), Right (_, _, acceptID)) -> insert_ $ SourceThemAcceptRemote remoteID acceptID - _ -> error "projectAccept impossible v" - return Nothing - - -- Getting an Accept from my collaborator - -- Record my collaborator's Accept - -- Prepare to send delegator-Grant - Right () -> Just <$> do - {- - case (topic, acceptDB) of - (Left (localID, _), Left (_, _, acceptID)) -> - insert_ $ ? localID acceptID - (Right (remoteID, _), Right (_, _, acceptID)) -> - insert_ $ ? remoteID acceptID _ -> error "projectAccept impossible iv" - -} grantID <- insertEmptyOutboxItem' (actorOutbox recipActor) now insert_ $ SourceUsSendDelegator sourceID grantID - return (topic, grantID) - ) - - mode + return grantID + else pure Nothing ) - -- Parent-passive mode - (\ (destID, themID, topic, mode) -> lift $ case mode of + -- Child-passive mode + (\case - -- Getting an Accept from the parent - -- Record parent's Accept in the Dest record + -- Getting an Accept from the child + -- Record child's Accept in Source record Left () -> do case (topic, acceptDB) of (Left (localID, _), Left (_, _, acceptID)) -> - insert_ $ DestThemAcceptLocal themID localID acceptID + insert_ $ SourceThemAcceptLocal localID acceptID (Right (remoteID, _), Right (_, _, acceptID)) -> - insert_ $ DestThemAcceptRemote themID remoteID acceptID + insert_ $ SourceThemAcceptRemote remoteID acceptID _ -> error "projectAccept impossible v" return Nothing -- Getting an Accept from my collaborator - -- Record my collaborator's Accept in the Dest record - -- Prepare to send my own Accept + -- Record my collaborator's Accept + -- Prepare to send delegator-Grant Right () -> Just <$> do - case acceptDB of - Left (_, _, acceptID) -> - insert_ $ DestUsGestureLocal destID acceptID - Right (author, _, acceptID) -> - insert_ $ DestUsGestureRemote destID (remoteAuthorId author) acceptID - acceptID <- insertEmptyOutboxItem' (actorOutbox recipActor) now - insert_ $ DestUsAccept destID acceptID - return (topic, acceptID) + {- + case (topic, acceptDB) of + (Left (localID, _), Left (_, _, acceptID)) -> + insert_ $ ? localID acceptID + (Right (remoteID, _), Right (_, _, acceptID)) -> + insert_ $ ? remoteID acceptID + _ -> error "projectAccept impossible iv" + -} + grantID <- insertEmptyOutboxItem' (actorOutbox recipActor) now + insert_ $ SourceUsSendDelegator sourceID grantID + return grantID ) - idsForAccept + mode' -- Prepare forwarding of Accept to my followers @@ -935,27 +851,20 @@ projectAccept now projectID (Verse authorIdMsig body) accept = do maybeAct <- case idsForGrant of - Left (Left mg) -> for mg $ \ (topic, grantID) -> lift $ do + Left mg -> for mg $ \ grantID -> lift $ do grant@(actionGrant, _, _, _) <- prepareSourceDelegGrant (bimap snd snd topic) False let recipByKey = LocalActorProject projectID _luGrant <- updateOutboxItem' recipByKey grantID actionGrant return (grantID, grant) - Left (Right mg) -> for mg $ \ (topic, grantID) -> lift $ do + Right mg -> for mg $ \ grantID -> lift $ do grant@(actionGrant, _, _, _) <- prepareSourceDelegGrant (bimap snd snd topic) True let recipByKey = LocalActorProject projectID _luGrant <- updateOutboxItem' recipByKey grantID actionGrant return (grantID, grant) - Right ma -> for ma $ \ (topic, acceptID) -> lift $ do - accept@(actionAccept, _, _, _) <- - prepareDestAccept (bimap snd snd topic) - let recipByKey = LocalActorProject projectID - _luAccept <- updateOutboxItem' recipByKey acceptID actionAccept - return (acceptID, accept) - return (recipActorID, sieve, maybeAct, inboxItemID) case maybeNew of @@ -967,7 +876,119 @@ projectAccept now projectID (Verse authorIdMsig body) accept = do sendActivity recipByID recipActorID localRecipsGrant remoteRecipsGrant fwdHostsGrant grantID actionGrant - doneDB inboxItemID "[Child/Parent mode] Forwarded the Accept and maybe published a Grant/Accept" + doneDB inboxItemID "[Child mode] Forwarded the Accept and maybe published a Grant/Accept" + + -- Add-a-parent mode + addChildParent (Right (destID, topic, mode)) = do + + (themID, mode') <- + case mode of + + -- Parent-active mode + -- Respond with error, we aren't supposed to get any Accept + Left () -> throwE "Parent-active (DestOriginUs) mode, I'm not expecting any Accept" + + -- Parent-passive mode + -- Option 1: I haven't yet seen parent's Accept + -- * Verify sender is the parent + -- Option 2: I saw it, but not my collaborator's Accept + -- * Verify the accept is authorized + -- Otherwise respond with error, no Accept is needed + Right themID -> (themID,) <$> do + (maybeParentAccept, maybeUsGesture) <- + lift $ withDB $ liftA2 (,) + (case bimap fst fst topic of + Left localID -> (() <$) <$> getBy (UniqueDestThemAcceptLocalTopic localID) + Right remoteID -> (() <$) <$> getBy (UniqueDestThemAcceptRemoteTopic remoteID) + ) + (do l <- getBy $ UniqueDestUsGestureLocal destID + r <- getBy $ UniqueDestUsGestureRemote destID + case (isJust l, isJust r) of + (False, False) -> pure Nothing + (False, True) -> pure $ Just () + (True, False) -> pure $ Just () + (True, True) -> error "Both DestUsGestureLocal and DestUsGestureRemote" + ) + case (isJust maybeParentAccept, isJust maybeUsGesture) of + (False, True) -> error "Impossible/bug, didn't see parent's Accept but recorded my collaborator's Accept" + (False, False) -> do + unless (theyIsAuthor topic) $ + throwE "The Accept I'm waiting for is from my new parent" + return $ Left () + (True, False) -> do + let muCap = AP.activityCapability $ actbActivity body + uCap <- fromMaybeE muCap "No capability provided" + verifyCapability'' + uCap + authorIdMsig + (LocalResourceProject projectID) + AP.RoleAdmin + return $ Right () + (True, True) -> throwE "Just waiting for Grant from parent, or already have it, anyway not needing any further Accept" + + maybeNew <- withDBExcept $ do + + -- Grab me from DB + (recipActorID, recipActor) <- lift $ do + recip <- getJust projectID + let actorID = projectActor recip + (actorID,) <$> getJust actorID + + maybeAcceptDB <- lift $ insertToInbox now authorIdMsig body (actorInbox recipActor) False + for maybeAcceptDB $ \ (inboxItemID, acceptDB) -> do + + idsForGrant <- + lift $ case mode' of + + -- Getting an Accept from the parent + -- Record parent's Accept in the Dest record + Left () -> do + case (topic, acceptDB) of + (Left (localID, _), Left (_, _, acceptID)) -> + insert_ $ DestThemAcceptLocal themID localID acceptID + (Right (remoteID, _), Right (_, _, acceptID)) -> + insert_ $ DestThemAcceptRemote themID remoteID acceptID + _ -> error "projectAccept impossible v" + return Nothing + + -- Getting an Accept from my collaborator + -- Record my collaborator's Accept in the Dest record + -- Prepare to send my own Accept + Right () -> Just <$> do + case acceptDB of + Left (_, _, acceptID) -> + insert_ $ DestUsGestureLocal destID acceptID + Right (author, _, acceptID) -> + insert_ $ DestUsGestureRemote destID (remoteAuthorId author) acceptID + acceptID <- insertEmptyOutboxItem' (actorOutbox recipActor) now + insert_ $ DestUsAccept destID acceptID + return acceptID + + -- Prepare forwarding of Accept to my followers + let recipByID = LocalActorProject projectID + recipByHash <- hashLocalActor recipByID + let sieve = makeRecipientSet [] [localActorFollowers recipByHash] + + maybeAct <- + for idsForGrant $ \ acceptID -> lift $ do + accept@(actionAccept, _, _, _) <- + prepareDestAccept (bimap snd snd topic) + let recipByKey = LocalActorProject projectID + _luAccept <- updateOutboxItem' recipByKey acceptID actionAccept + return (acceptID, accept) + + return (recipActorID, sieve, maybeAct, inboxItemID) + + case maybeNew of + Nothing -> done "I already have this activity in my inbox" + Just (recipActorID, sieve, maybeGrant, inboxItemID) -> do + let recipByID = LocalActorProject projectID + forwardActivity authorIdMsig body recipByID recipActorID sieve + lift $ for_ maybeGrant $ \ (grantID, (actionGrant, localRecipsGrant, remoteRecipsGrant, fwdHostsGrant)) -> + sendActivity + recipByID recipActorID localRecipsGrant + remoteRecipsGrant fwdHostsGrant grantID actionGrant + doneDB inboxItemID "[Parent mode] Forwarded the Accept and maybe published a Grant/Accept" prepareCollabGrant isInvite sender role = do encodeRouteHome <- getEncodeRouteHome