diff --git a/src/Vervis/Foundation.hs b/src/Vervis/Foundation.hs
index 55149fd..3d5dcf5 100644
--- a/src/Vervis/Foundation.hs
+++ b/src/Vervis/Foundation.hs
@@ -956,7 +956,7 @@ instance YesodBreadcrumbs App where
DeckRemoveR _ _ -> ("", Nothing)
DeckProjectsR d -> ("Projects", Just $ DeckR d)
- DeckApproveCompR d c -> ("", Nothing)
+ DeckApproveProjectR d c -> ("", Nothing)
DeckAddProjectR d -> ("", Nothing)
TicketR d t -> ("#" <> keyHashidText t, Just $ DeckTicketsR d)
diff --git a/src/Vervis/Handler/Deck.hs b/src/Vervis/Handler/Deck.hs
index be3d8ea..00f4bdc 100644
--- a/src/Vervis/Handler/Deck.hs
+++ b/src/Vervis/Handler/Deck.hs
@@ -44,7 +44,7 @@ module Vervis.Handler.Deck
, postDeckRemoveR
, getDeckProjectsR
, postDeckAddProjectR
- , postDeckApproveCompR
+ , postDeckApproveProjectR
@@ -66,6 +66,7 @@ module Vervis.Handler.Deck
where
import Control.Applicative
+import Control.Arrow ((&&&))
import Control.Monad
import Control.Monad.Trans.Except
import Control.Monad.Trans.Maybe
@@ -589,19 +590,21 @@ getDeckProjectsR deckHash = do
deck <- lift $ get404 deckID
MaybeT $ getCapability personID (Left $ deckResource deck) AP.RoleAdmin
((_, widgetAP), enctypeAP) <- runFormPost addProjectForm
- (deck, actor, stems) <- runDB $ do
+ (deck, actor, stems, drafts) <- runDB $ do
deck <- get404 deckID
actor <- getJust $ deckActor deck
stems <-
- E.select $ E.from $ \ (ident `E.InnerJoin` stem `E.LeftOuterJoin` accept `E.LeftOuterJoin` deleg `E.LeftOuterJoin` gestl `E.LeftOuterJoin` gestr) -> do
- E.on $ E.just (stem E.^. StemId) E.==. gestr E.?. StemComponentGestureRemoteStem
- E.on $ E.just (stem E.^. StemId) E.==. gestl E.?. StemComponentGestureLocalStem
- E.on $ accept E.?. StemComponentAcceptId E.==. deleg E.?. StemDelegateLocalStem
- E.on $ E.just (stem E.^. StemId) E.==. accept E.?. StemComponentAcceptStem
+ E.select $ E.from $ \ (ident `E.InnerJoin` stem `E.InnerJoin` accept `E.InnerJoin` deleg `E.InnerJoin` grant) -> do
+ E.on $ deleg E.^. StemDelegateLocalGrant E.==. grant E.^. OutboxItemId
+ E.on $ accept E.^. StemComponentAcceptId E.==. deleg E.^. StemDelegateLocalStem
+ E.on $ stem E.^. StemId E.==. accept E.^. StemComponentAcceptStem
E.on $ ident E.^. StemIdentDeckStem E.==. stem E.^. StemId
E.where_ $ ident E.^. StemIdentDeckDeck E.==. E.val deckID
- return (stem, deleg, gestl, gestr)
- stems' <- for stems $ \ (Entity stemID stem, deleg, gestl, gestr) -> do
+ return
+ ( stem
+ , grant E.^. OutboxItemPublished
+ )
+ stems' <- for stems $ \ (Entity stemID stem, E.Value time) -> do
j <- getStemProject stemID
projectView <-
bitraverse
@@ -610,17 +613,69 @@ getDeckProjectsR deckHash = do
actor <- getJust actorID
return (projectID, actor)
)
- (\ remoteActorID -> do
- remoteActor <- getJust remoteActorID
- remoteObject <- getJust $ remoteActorIdent remoteActor
- inztance <- getJust $ remoteObjectInstance remoteObject
- return (inztance, remoteObject, remoteActor)
- )
+ getRemoteActorData
j
- stemHash <- encodeKeyHashid stemID
- return (projectView, stemRole stem, isJust deleg, isJust gestl || isJust gestr, stemHash)
- return (deck, actor, stems')
+ return (projectView, stemRole stem, time)
+ drafts <-
+ E.select $ E.from $ \ (ident `E.InnerJoin` stem `E.LeftOuterJoin` accept `E.LeftOuterJoin` deleg) -> do
+ E.on $ accept E.?. StemComponentAcceptId E.==. deleg E.?. StemDelegateLocalStem
+ E.on $ E.just (stem E.^. StemId) E.==. accept E.?. StemComponentAcceptStem
+ E.on $ ident E.^. StemIdentDeckStem E.==. stem E.^. StemId
+ E.where_ $
+ ident E.^. StemIdentDeckDeck E.==. E.val deckID E.&&.
+ E.isNothing (deleg E.?. StemDelegateLocalId)
+ return stem
+ drafts' <- for drafts $ \ (Entity stemID (Stem role)) -> do
+ (project, accept) <- do
+ project <- getStemProject stemID
+ accept <- isJust <$> getBy (UniqueStemComponentAccept stemID)
+ (,accept) <$> bitraverse
+ (\ j -> do
+ resourceID <- projectResource <$> getJust j
+ Resource actorID <- getJust resourceID
+ actor <- getJust actorID
+ return (j, actor)
+ )
+ getRemoteActorData
+ project
+ ((inviter, time), us) <- do
+ usOrThem <-
+ requireEitherAlt
+ (getKeyBy $ UniqueStemOriginAdd stemID)
+ (getKeyBy $ UniqueStemOriginInvite stemID)
+ "Neither us nor them"
+ "Both us and them"
+ (addOrActor, us) <-
+ case usOrThem of
+ Left _usID -> (,True) <$>
+ requireEitherAlt
+ (fmap stemComponentGestureLocalActivity <$> getValBy (UniqueStemComponentGestureLocal stemID))
+ (fmap (stemComponentGestureRemoteActor &&& stemComponentGestureRemoteActivity) <$> getValBy (UniqueStemComponentGestureRemote stemID))
+ "Neither local not remote"
+ "Both local and remote"
+ Right themID -> (,False) <$>
+ requireEitherAlt
+ (fmap stemProjectGestureLocalInvite <$> getValBy (UniqueStemProjectGestureLocal themID))
+ (fmap (stemProjectGestureRemoteActor &&& stemProjectGestureRemoteInvite) <$> getValBy (UniqueStemProjectGestureRemote themID))
+ "Neither local not remote"
+ "Both local and remote"
+ (,us) <$> case addOrActor of
+ Left addID -> do
+ OutboxItem outboxID _ time <- getJust addID
+ Entity actorID actor <- getByJust $ UniqueActorOutbox outboxID
+ (,time) . Left . (,actor) <$> getLocalActor actorID
+ Right (actorID, addID) -> do
+ RemoteActivity _ _ time <- getJust addID
+ (,time) . Right <$> getRemoteActorData actorID
+ return (inviter, us, project, accept, time, role, stemID)
+ return (deck, actor, stems', drafts')
defaultLayout $(widgetFile "deck/projects")
+ where
+ getRemoteActorData actorID = do
+ actor <- getJust actorID
+ object <- getJust $ remoteActorIdent actor
+ inztance <- getJust $ remoteObjectInstance object
+ return (inztance, object, actor)
addProjectForm = renderDivs $
areq fedUriField "(URI) Project" Nothing
@@ -669,91 +724,57 @@ postDeckAddProjectR deckHash = do
Right inviteID -> setMessage "Add sent"
redirect $ DeckProjectsR deckHash
-postDeckApproveCompR :: KeyHashid Deck -> KeyHashid Stem -> Handler Html
-postDeckApproveCompR deckHash stemHash = do
+postDeckApproveProjectR :: KeyHashid Deck -> StemId -> Handler Html
+postDeckApproveProjectR deckHash stemID = do
deckID <- decodeKeyHashid404 deckHash
- stemID <- decodeKeyHashid404 stemHash
personEntity@(Entity personID person) <- requireAuth
personHash <- encodeKeyHashid personID
encodeRouteHome <- getEncodeRouteHome
result <- runExceptT $ do
- (uInvite, jidOrURI) <- lift $ runDB $ do
- _ <- get404 deckID
- _ <- get404 stemID
- Entity _ (StemIdentDeck _ deckID') <- getBy404 $ UniqueStemIdentDeck stemID
- unless (deckID' == deckID) notFound
- uInvite <- do
- Entity originID _ <- getBy404 $ UniqueStemOriginInvite stemID
- i <-
- requireEitherAlt
- (getValBy $ UniqueStemProjectGestureLocal originID)
- (getValBy $ UniqueStemProjectGestureRemote originID)
- "Invite gesture not found"
- "Multiple invites"
- case i of
- Left g -> do
- let k = stemProjectGestureLocalInvite g
- oi <- getJust k
- a <- getKeyByJust $ UniqueActorOutbox $ outboxItemOutbox oi
- p <- getKeyByJust $ UniquePersonActor a
- ph <- encodeKeyHashid p
- kh <- encodeKeyHashid k
- return $ encodeRouteHome $ PersonOutboxItemR ph kh
- Right g -> do
- a <- getJust $ stemProjectGestureRemoteInvite g
- o <- getJust $ remoteActivityIdent a
- h <- getJust $ remoteObjectInstance o
- return $ ObjURI (instanceHost h) (remoteObjectIdent o)
- project <- getStemProject stemID
- (uInvite,) <$> bitraverse pure (getRemoteActorURI <=< getJust) project
- (maybeSummary, audience, accept) <-
- C.acceptProjectInvite personID (LocalActorDeck deckID) jidOrURI uInvite
- grantID <- do
- maybeItem <- lift $ runDB $ do
- resourceID <- deckResource <$> get404 deckID
- getGrant resourceID personID
- fromMaybeE maybeItem "You need to be a collaborator in the Deck to remove people"
- grantHash <- encodeKeyHashid grantID
- let uCap = encodeRouteHome $ DeckOutboxItemR deckHash grantHash
+ mpidOrU <- lift $ runDB $ runMaybeT $ do
+ deck <- MaybeT $ get deckID
+ _ <- MaybeT $ get stemID
+ StemIdentDeck _ d <- MaybeT $ getValBy $ UniqueStemIdentDeck stemID
+ guard $ deckID == d
+
+ uAdd <- lift $ do
+ add <- getStemAdd stemID
+ renderActivityURI add
+
+ topic <- lift $ getStemProject stemID
+ lift $
+ (deckResource deck,uAdd,) <$>
+ bitraverse
+ pure
+ (getRemoteActorURI <=< getJust)
+ topic
+ (resourceID, uAdd, pidOrU) <- maybe notFound pure mpidOrU
+ (maybeSummary, audience, accept) <- do
+ uProject <-
+ case pidOrU of
+ Left j -> encodeRouteHome . ProjectR <$> encodeKeyHashid j
+ Right u -> pure u
+ let uDeck = encodeRouteHome $ DeckR deckHash
+ C.acceptParentChild personID uAdd uProject uDeck
+ cap <- do
+ maybeItem <- lift $ runDB $ getCapability personID (Left resourceID) AP.RoleAdmin
+ fromMaybeE maybeItem "You need to be have Admin access to the Deck to approve projects"
+ uCap <- lift $ renderActivityURI cap
(localRecips, remoteRecips, fwdHosts, action) <-
C.makeServerInput (Just uCap) maybeSummary audience $ AP.AcceptActivity accept
- let cap =
- Left (LocalActorDeck deckID, LocalActorDeck deckHash, grantID)
+ let cap' = first (\ (la, i) -> (la, error "lah", i)) cap
handleViaActor
- personID (Just cap) localRecips remoteRecips fwdHosts action
+ personID (Just cap') localRecips remoteRecips fwdHosts action
case result of
Left e -> do
setMessage $ toHtml e
- Right removeID -> do
+ Right removeID ->
setMessage "Accept sent"
redirect $ DeckProjectsR deckHash
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
{-
getProjectsR :: ShrIdent -> Handler Html
getProjectsR ident = do
diff --git a/src/Vervis/Persist/Actor.hs b/src/Vervis/Persist/Actor.hs
index 6debea3..8d50a7a 100644
--- a/src/Vervis/Persist/Actor.hs
+++ b/src/Vervis/Persist/Actor.hs
@@ -41,6 +41,7 @@ module Vervis.Persist.Actor
, doneDB
, insertToInbox
, adaptErrbox
+ , getActivityIdent
)
where
@@ -388,3 +389,19 @@ adaptErrbox inboxID unread behavior now key ve@(Left (VA.Verse authorIdMsig body
(itemID, _) <- MaybeT $ insertToInbox now authorIdMsig body inboxID unread
lift $ update itemID [InboxItemResult =. err]
throwE err
+
+getActivityIdent
+ :: MonadIO m
+ => Either OutboxItemId RemoteActivityId
+ -> ReaderT SqlBackend m (Either (LocalActorBy Key, OutboxItemId) FedURI)
+getActivityIdent =
+ bitraverse
+ (\ itemID -> do
+ OutboxItem outboxID _ time <- getJust itemID
+ Entity actorID actor <- getByJust $ UniqueActorOutbox outboxID
+ (,itemID) <$> getLocalActor actorID
+ )
+ (\ actID -> do
+ act <- getJust actID
+ getRemoteActivityURI act
+ )
diff --git a/src/Vervis/Persist/Collab.hs b/src/Vervis/Persist/Collab.hs
index fd31657..92fb609 100644
--- a/src/Vervis/Persist/Collab.hs
+++ b/src/Vervis/Persist/Collab.hs
@@ -20,6 +20,7 @@ module Vervis.Persist.Collab
, getPermitTopic
, getStemIdent
, getStemProject
+ , getStemAdd
, getGrantRecip
, getComponentE
, getTopicGrants
@@ -168,6 +169,37 @@ getStemProject stemID =
"Found Stem without project"
"Found Stem with multiple projects"
+getStemAdd
+ :: MonadIO m
+ => StemId
+ -> ReaderT SqlBackend m
+ (Either
+ (LocalActorBy Key, OutboxItemId)
+ FedURI
+ )
+getStemAdd stemID = do
+ usOrThem <-
+ requireEitherAlt
+ (getKeyBy $ UniqueStemOriginAdd stemID)
+ (getKeyBy $ UniqueStemOriginInvite stemID)
+ "Neither us nor them"
+ "Both us and them"
+ add <-
+ case usOrThem of
+ Left _usID ->
+ requireEitherAlt
+ (fmap stemComponentGestureLocalActivity <$> getValBy (UniqueStemComponentGestureLocal stemID))
+ (fmap stemComponentGestureRemoteActivity <$> getValBy (UniqueStemComponentGestureRemote stemID))
+ "Neither local not remote"
+ "Both local and remote"
+ Right themID ->
+ requireEitherAlt
+ (fmap stemProjectGestureLocalInvite <$> getValBy (UniqueStemProjectGestureLocal themID))
+ (fmap stemProjectGestureRemoteInvite <$> getValBy (UniqueStemProjectGestureRemote themID))
+ "Neither local not remote"
+ "Both local and remote"
+ getActivityIdent add
+
getGrantRecip (GrantRecipPerson k) e = GrantRecipPerson <$> getEntityE k e
getComponentE (ComponentRepo k) e = ComponentRepo <$> getEntityE k e
@@ -467,17 +499,7 @@ getComponentAdd componentID = do
(fmap componentGestureRemoteAdd <$> getValBy (UniqueComponentGestureRemote themID))
"Neither local not remote"
"Both local and remote"
- bitraverse
- (\ addID -> do
- OutboxItem outboxID _ time <- getJust addID
- Entity actorID actor <- getByJust $ UniqueActorOutbox outboxID
- (,addID) <$> getLocalActor actorID
- )
- (\ addID -> do
- add <- getJust addID
- getRemoteActivityURI add
- )
- add
+ getActivityIdent add
getSourceTopic
:: MonadIO m
@@ -534,17 +556,7 @@ getSourceAdd sourceID = do
(fmap sourceThemGestureRemoteAdd <$> getValBy (UniqueSourceThemGestureRemote themID))
"Neither local not remote"
"Both local and remote"
- bitraverse
- (\ addID -> do
- OutboxItem outboxID _ time <- getJust addID
- Entity actorID actor <- getByJust $ UniqueActorOutbox outboxID
- (,addID) <$> getLocalActor actorID
- )
- (\ addID -> do
- add <- getJust addID
- getRemoteActivityURI add
- )
- add
+ getActivityIdent add
getDestTopic
:: MonadIO m
@@ -620,17 +632,7 @@ getDestAdd destID = do
(fmap destThemGestureRemoteAdd <$> getValBy (UniqueDestThemGestureRemote themID))
"Neither local not remote"
"Both local and remote"
- bitraverse
- (\ addID -> do
- OutboxItem outboxID _ time <- getJust addID
- Entity actorID actor <- getByJust $ UniqueActorOutbox outboxID
- (,addID) <$> getLocalActor actorID
- )
- (\ addID -> do
- add <- getJust addID
- getRemoteActivityURI add
- )
- add
+ getActivityIdent add
checkExistingStems
:: ComponentBy Key -> Either (Entity Project) RemoteActorId -> ActDBE ()
diff --git a/templates/deck/projects.hamlet b/templates/deck/projects.hamlet
index c6da0a7..5c6c813 100644
--- a/templates/deck/projects.hamlet
+++ b/templates/deck/projects.hamlet
@@ -21,19 +21,12 @@ $#