diff --git a/src/Vervis/Handler/Client.hs b/src/Vervis/Handler/Client.hs index 71cfa34..0c3019a 100644 --- a/src/Vervis/Handler/Client.hs +++ b/src/Vervis/Handler/Client.hs @@ -137,77 +137,143 @@ getHomeR = do where personalOverview :: Entity Person -> Handler Html personalOverview (Entity pid _person) = do - permits <- runDB $ do - locals <- do - ls <- E.select $ E.from $ \ (permit `E.InnerJoin` topic `E.InnerJoin` enable) -> do - E.on $ topic E.^. PermitTopicLocalId E.==. enable E.^. PermitTopicEnableLocalTopic - E.on $ permit E.^. PermitId E.==. topic E.^. PermitTopicLocalPermit - E.where_ $ permit E.^. PermitPerson E.==. E.val pid - E.orderBy [E.asc $ enable E.^. PermitTopicEnableLocalId] - return - ( enable E.^. PermitTopicEnableLocalPermit - , permit E.^. PermitRole - , topic E.^. PermitTopicLocalId - ) - for ls $ \ (E.Value gestureID, E.Value role, E.Value topicID) -> do - topic <- getPermitTopicLocal topicID - actorID <- do - ma <- getLocalActorEntity topic - case ma of - Nothing -> error "Impossible, we should have found the local actor in DB" - Just a -> pure $ localActorID a - actor <- getJust actorID - delegator <- getKeyBy $ UniquePermitPersonSendDelegator gestureID - exts <- - case delegator of - Nothing -> pure [] - Just sendID -> do - topicHash <- VR.hashLocalActor topic - hashItem <- getEncodeKeyHashid - encodeRouteHome <- getEncodeRouteHome - map (encodeRouteHome . activityRoute topicHash . hashItem . permitTopicExtendLocalGrant . entityVal) <$> - selectList [PermitTopicExtendLocalPermit ==. sendID] [Asc PermitTopicExtendLocalId] - return - ( gestureID - , role - , delegator - , localActorType topic - , Left (topic, actor) - , exts - ) - remotes <- do - rs <- E.select $ E.from $ \ (permit `E.InnerJoin` topic `E.InnerJoin` enable) -> do - E.on $ topic E.^. PermitTopicRemoteId E.==. enable E.^. PermitTopicEnableRemoteTopic - E.on $ permit E.^. PermitId E.==. topic E.^. PermitTopicRemotePermit - E.where_ $ permit E.^. PermitPerson E.==. E.val pid - E.orderBy [E.asc $ enable E.^. PermitTopicEnableRemoteId] - return - ( enable E.^. PermitTopicEnableRemotePermit - , permit E.^. PermitRole - , topic E.^. PermitTopicRemoteActor - ) - for rs $ \ (E.Value gestureID, E.Value role, E.Value remoteActorID) -> do - remoteActor <- getJust remoteActorID - remoteObject <- getJust $ remoteActorIdent remoteActor - inztance <- getJust $ remoteObjectInstance remoteObject - delegator <- getKeyBy $ UniquePermitPersonSendDelegator gestureID - exts <- - case delegator of - Nothing -> pure [] - Just sendID -> do - es <- selectList [PermitTopicExtendRemotePermit ==. sendID] [Asc PermitTopicExtendRemoteId] - for es $ \ (Entity _ (PermitTopicExtendRemote _ _ grantID)) -> do - grant <- getJust grantID - getRemoteActivityURI grant - return - ( gestureID - , role - , delegator - , remoteActorType remoteActor - , Right (inztance, remoteObject, remoteActor) - , exts - ) - return $ locals ++ remotes + (permits, invites) <- runDB $ do + permits <- do + locals <- do + ls <- E.select $ E.from $ \ (permit `E.InnerJoin` topic `E.InnerJoin` enable) -> do + E.on $ topic E.^. PermitTopicLocalId E.==. enable E.^. PermitTopicEnableLocalTopic + E.on $ permit E.^. PermitId E.==. topic E.^. PermitTopicLocalPermit + E.where_ $ permit E.^. PermitPerson E.==. E.val pid + E.orderBy [E.asc $ enable E.^. PermitTopicEnableLocalId] + return + ( enable E.^. PermitTopicEnableLocalPermit + , permit E.^. PermitRole + , topic E.^. PermitTopicLocalId + ) + for ls $ \ (E.Value gestureID, E.Value role, E.Value topicID) -> do + topic <- getPermitTopicLocal topicID + actorID <- do + ma <- getLocalActorEntity topic + case ma of + Nothing -> error "Impossible, we should have found the local actor in DB" + Just a -> pure $ localActorID a + actor <- getJust actorID + delegator <- getKeyBy $ UniquePermitPersonSendDelegator gestureID + exts <- + case delegator of + Nothing -> pure [] + Just sendID -> do + topicHash <- VR.hashLocalActor topic + hashItem <- getEncodeKeyHashid + encodeRouteHome <- getEncodeRouteHome + map (encodeRouteHome . activityRoute topicHash . hashItem . permitTopicExtendLocalGrant . entityVal) <$> + selectList [PermitTopicExtendLocalPermit ==. sendID] [Asc PermitTopicExtendLocalId] + return + ( gestureID + , role + , delegator + , localActorType topic + , Left (topic, actor) + , exts + ) + remotes <- do + rs <- E.select $ E.from $ \ (permit `E.InnerJoin` topic `E.InnerJoin` enable) -> do + E.on $ topic E.^. PermitTopicRemoteId E.==. enable E.^. PermitTopicEnableRemoteTopic + E.on $ permit E.^. PermitId E.==. topic E.^. PermitTopicRemotePermit + E.where_ $ permit E.^. PermitPerson E.==. E.val pid + E.orderBy [E.asc $ enable E.^. PermitTopicEnableRemoteId] + return + ( enable E.^. PermitTopicEnableRemotePermit + , permit E.^. PermitRole + , topic E.^. PermitTopicRemoteActor + ) + for rs $ \ (E.Value gestureID, E.Value role, E.Value remoteActorID) -> do + remoteActor <- getJust remoteActorID + remoteObject <- getJust $ remoteActorIdent remoteActor + inztance <- getJust $ remoteObjectInstance remoteObject + delegator <- getKeyBy $ UniquePermitPersonSendDelegator gestureID + exts <- + case delegator of + Nothing -> pure [] + Just sendID -> do + es <- selectList [PermitTopicExtendRemotePermit ==. sendID] [Asc PermitTopicExtendRemoteId] + for es $ \ (Entity _ (PermitTopicExtendRemote _ _ grantID)) -> do + grant <- getJust grantID + getRemoteActivityURI grant + return + ( gestureID + , role + , delegator + , remoteActorType remoteActor + , Right (inztance, remoteObject, remoteActor) + , exts + ) + return $ locals ++ remotes + invites <- do + locals <- do + ls <- E.select $ E.from $ \ (permit `E.InnerJoin` fulfills `E.InnerJoin` topic `E.LeftOuterJoin` enable `E.LeftOuterJoin` valid `E.LeftOuterJoin` accept) -> do + E.on $ E.just (permit E.^. PermitId) E.==. accept E.?. PermitPersonGesturePermit + E.on $ E.just (topic E.^. PermitTopicLocalId) E.==. valid E.?. PermitTopicAcceptLocalTopic + E.on $ E.just (topic E.^. PermitTopicLocalId) E.==. enable E.?. PermitTopicEnableLocalTopic + E.on $ permit E.^. PermitId E.==. topic E.^. PermitTopicLocalPermit + E.on $ permit E.^. PermitId E.==. fulfills E.^. PermitFulfillsInvitePermit + E.where_ $ + permit E.^. PermitPerson E.==. E.val pid E.&&. + E.isNothing (enable E.?. PermitTopicEnableLocalId) + E.orderBy [E.asc $ permit E.^. PermitId] + return + ( fulfills E.^. PermitFulfillsInviteId + , permit E.^. PermitRole + , valid E.?. PermitTopicAcceptLocalId + , accept E.?. PermitPersonGestureId + , topic E.^. PermitTopicLocalId + ) + for ls $ \ (E.Value fulfillsID, E.Value role, E.Value valid, E.Value accept, E.Value topicID) -> do + topic <- getPermitTopicLocal topicID + actorID <- do + ma <- getLocalActorEntity topic + case ma of + Nothing -> error "Impossible, we should have found the local actor in DB" + Just a -> pure $ localActorID a + actor <- getJust actorID + return + ( fulfillsID + , role + , () <$ valid + , accept + , Left (topic, actor) + ) + remotes <- do + rs <- E.select $ E.from $ \ (permit `E.InnerJoin` fulfills `E.InnerJoin` topic `E.LeftOuterJoin` enable `E.LeftOuterJoin` valid `E.LeftOuterJoin` accept) -> do + E.on $ E.just (permit E.^. PermitId) E.==. accept E.?. PermitPersonGesturePermit + E.on $ E.just (topic E.^. PermitTopicRemoteId) E.==. valid E.?. PermitTopicAcceptRemoteTopic + E.on $ E.just (topic E.^. PermitTopicRemoteId) E.==. enable E.?. PermitTopicEnableRemoteTopic + E.on $ permit E.^. PermitId E.==. topic E.^. PermitTopicRemotePermit + E.on $ permit E.^. PermitId E.==. fulfills E.^. PermitFulfillsInvitePermit + E.where_ $ + permit E.^. PermitPerson E.==. E.val pid E.&&. + E.isNothing (enable E.?. PermitTopicEnableRemoteId) + E.orderBy [E.asc $ permit E.^. PermitId] + return + ( fulfills E.^. PermitFulfillsInviteId + , permit E.^. PermitRole + , valid E.?. PermitTopicAcceptRemoteId + , accept E.?. PermitPersonGestureId + , topic E.^. PermitTopicRemoteActor + ) + for rs $ \ (E.Value fulfillsID, E.Value role, E.Value valid, E.Value accept, E.Value remoteActorID) -> do + remoteActor <- getJust remoteActorID + remoteObject <- getJust $ remoteActorIdent remoteActor + inztance <- getJust $ remoteObjectInstance remoteObject + return + ( fulfillsID + , role + , () <$ valid + , accept + , Right (inztance, remoteObject, remoteActor) + ) + return $ sortOn (view _1) $ locals ++ remotes + return (permits, invites) let (people, repos, decks, looms, projects, groups, others) = partitionByActorType (view _4) (view _1) permits if null people @@ -251,6 +317,23 @@ getHomeR = do #{renderObjURI u} |] + invite (_fulfillsID, role, valid, accept, actor) = + [whamlet| + + [ + #{show role} + ] # + $maybe _ <- valid + \ [Valid] # + $nothing + \ [Not validated] # + $maybe _ <- accept + \ [You've accepted] # + $nothing + \ [Accept Button] [Reject Button] # + ^{actorLinkFedW actor} + |] + getBrowseR :: Handler Html getBrowseR = do (people, groups, repos, decks, looms, projects) <- runDB $ diff --git a/templates/personal-overview.hamlet b/templates/personal-overview.hamlet index 7cbc5fb..dd73cc0 100644 --- a/templates/personal-overview.hamlet +++ b/templates/personal-overview.hamlet @@ -105,3 +105,10 @@ $# Comment on a ticket or merge request $forall i <- others
  • ^{item i} + +

    Your invites + +
      + $forall i <- invites +
    • + ^{invite i}