Serve live URIs for Team (Squad) records for project, repo, deck, loom

src/Vervis/Foundation.hs

@@ -162,6 +162,7 @@ type CollabEnableKeyHashid      = KeyHashid CollabEnable
 type StemKeyHashid              = KeyHashid Stem
 type PermitFulfillsInviteKeyHashid = KeyHashid PermitFulfillsInvite
 type DestUsStartKeyHashid       = KeyHashid DestUsStart
+type SquadUsStartKeyHashid      = KeyHashid SquadUsStart
 
 -- This is where we define all of the routes in our application. For a full
 -- explanation of the syntax, please see:
@@ -950,6 +951,7 @@ instance YesodBreadcrumbs App where
         RepoAddTeamR r -> ("", Nothing)
         RepoApproveTeamR r t -> ("", Nothing)
         RepoRemoveTeamR r t -> ("", Nothing)
+        RepoTeamLiveR _ _ -> ("", Nothing)
 
         DeckR d             -> ("Ticket Tracker =" <> keyHashidText d, Just HomeR)
         DeckInboxR d        -> ("Inbox", Just $ DeckR d)
@@ -983,6 +985,7 @@ instance YesodBreadcrumbs App where
         DeckAddTeamR d -> ("", Nothing)
         DeckApproveTeamR d t -> ("", Nothing)
         DeckRemoveTeamR d t -> ("", Nothing)
+        DeckTeamLiveR _ _ -> ("", Nothing)
 
         TicketR d t            -> ("#" <> keyHashidText t, Just $ DeckTicketsR d)
         TicketDiscussionR d t  -> ("Discussion", Just $ TicketR d t)
@@ -1024,6 +1027,7 @@ instance YesodBreadcrumbs App where
         LoomAddTeamR l -> ("", Nothing)
         LoomApproveTeamR l t -> ("", Nothing)
         LoomRemoveTeamR l t -> ("", Nothing)
+        LoomTeamLiveR _ _ -> ("", Nothing)
 
         ClothR l c            -> ("#" <> keyHashidText c, Just $ LoomClothsR l)
         ClothDiscussionR l c  -> ("Discussion", Just $ ClothR l c)
@@ -1085,6 +1089,7 @@ instance YesodBreadcrumbs App where
         ProjectAddTeamR _ -> ("", Nothing)
         ProjectApproveTeamR _ _ -> ("", Nothing)
         ProjectRemoveTeamR _ _ -> ("", Nothing)
+        ProjectTeamLiveR _ _ -> ("", Nothing)
 
         PersonErrboxR p -> ("Errbox", Just $ PersonR p)
         GroupErrboxR g -> ("Errbox", Just $ GroupR g)

src/Vervis/Handler/Deck.hs

@@ -49,6 +49,7 @@ module Vervis.Handler.Deck
     , postDeckAddTeamR
     , postDeckApproveTeamR
     , postDeckRemoveTeamR
+    , getDeckTeamLiveR
 
 
 
@@ -748,6 +749,17 @@ postDeckRemoveTeamR deckHash squadID = do
             setMessage "Remove sent"
     redirect $ DeckCollabsR deckHash
 
+getDeckTeamLiveR :: KeyHashid Deck -> KeyHashid SquadUsStart -> Handler ()
+getDeckTeamLiveR deckHash startHash = do
+    deckID <- decodeKeyHashid404 deckHash
+    startID <- decodeKeyHashid404 startHash
+    runDB $ do
+        deck <- get404 deckID
+        SquadUsStart usAcceptID _ <- get404 startID
+        SquadUsAccept squadID _ <- getJust usAcceptID
+        Squad _ resourceID <- getJust squadID
+        unless (resourceID == deckResource deck) notFound
+
 {-
 getProjectsR :: ShrIdent -> Handler Html
 getProjectsR ident = do

src/Vervis/Handler/Loom.hs

@@ -40,6 +40,7 @@ module Vervis.Handler.Loom
     , postLoomAddTeamR
     , postLoomApproveTeamR
     , postLoomRemoveTeamR
+    , getLoomTeamLiveR
     )
 where
 
@@ -563,3 +564,14 @@ postLoomRemoveTeamR loomHash squadID = do
         Right removeID ->
             setMessage "Remove sent"
     redirect $ LoomCollabsR loomHash
+
+getLoomTeamLiveR :: KeyHashid Loom -> KeyHashid SquadUsStart -> Handler ()
+getLoomTeamLiveR loomHash startHash = do
+    loomID <- decodeKeyHashid404 loomHash
+    startID <- decodeKeyHashid404 startHash
+    runDB $ do
+        loom <- get404 loomID
+        SquadUsStart usAcceptID _ <- get404 startID
+        SquadUsAccept squadID _ <- getJust usAcceptID
+        Squad _ resourceID <- getJust squadID
+        unless (resourceID == loomResource loom) notFound

src/Vervis/Handler/Project.hs

@@ -58,6 +58,7 @@ module Vervis.Handler.Project
     , postProjectAddTeamR
     , postProjectApproveTeamR
     , postProjectRemoveTeamR
+    , getProjectTeamLiveR
     )
 where
 
@@ -1371,3 +1372,14 @@ postProjectRemoveTeamR projectHash squadID = do
         Right removeID ->
             setMessage "Remove sent"
     redirect $ ProjectCollabsR projectHash
+
+getProjectTeamLiveR :: KeyHashid Project -> KeyHashid SquadUsStart -> Handler ()
+getProjectTeamLiveR projectHash startHash = do
+    projectID <- decodeKeyHashid404 projectHash
+    startID <- decodeKeyHashid404 startHash
+    runDB $ do
+        project <- get404 projectID
+        SquadUsStart usAcceptID _ <- get404 startID
+        SquadUsAccept squadID _ <- getJust usAcceptID
+        Squad _ resourceID <- getJust squadID
+        unless (resourceID == projectResource project) notFound

src/Vervis/Handler/Repo.hs

@@ -57,6 +57,7 @@ module Vervis.Handler.Repo
     , postRepoAddTeamR
     , postRepoApproveTeamR
     , postRepoRemoveTeamR
+    , getRepoTeamLiveR
 
 
 
@@ -988,6 +989,17 @@ postRepoRemoveTeamR repoHash squadID = do
             setMessage "Remove sent"
     redirect $ RepoCollabsR repoHash
 
+getRepoTeamLiveR :: KeyHashid Repo -> KeyHashid SquadUsStart -> Handler ()
+getRepoTeamLiveR repoHash startHash = do
+    repoID <- decodeKeyHashid404 repoHash
+    startID <- decodeKeyHashid404 startHash
+    runDB $ do
+        repo <- get404 repoID
+        SquadUsStart usAcceptID _ <- get404 startID
+        SquadUsAccept squadID _ <- getJust usAcceptID
+        Squad _ resourceID <- getJust squadID
+        unless (resourceID == repoResource repo) notFound
+
 
 
 

th/routes

@@ -245,6 +245,7 @@
 /repos/#RepoKeyHashid/add-team              RepoAddTeamR     POST
 /repos/#RepoKeyHashid/approve-team/#SquadId RepoApproveTeamR POST
 /repos/#RepoKeyHashid/remove-team/#SquadId  RepoRemoveTeamR  POST
+/repos/#RepoKeyHashid/teams/#SquadUsStartKeyHashid/live RepoTeamLiveR GET
 
 ---- Deck --------------------------------------------------------------------
 
@@ -281,6 +282,7 @@
 /decks/#DeckKeyHashid/add-team              DeckAddTeamR     POST
 /decks/#DeckKeyHashid/approve-team/#SquadId DeckApproveTeamR POST
 /decks/#DeckKeyHashid/remove-team/#SquadId  DeckRemoveTeamR  POST
+/decks/#DeckKeyHashid/teams/#SquadUsStartKeyHashid/live DeckTeamLiveR GET
 
 ---- Ticket ------------------------------------------------------------------
 
@@ -340,6 +342,7 @@
 /looms/#LoomKeyHashid/add-team              LoomAddTeamR     POST
 /looms/#LoomKeyHashid/approve-team/#SquadId LoomApproveTeamR POST
 /looms/#LoomKeyHashid/remove-team/#SquadId  LoomRemoveTeamR  POST
+/looms/#LoomKeyHashid/teams/#SquadUsStartKeyHashid/live LoomTeamLiveR GET
 
 ---- Cloth -------------------------------------------------------------------
 
@@ -418,3 +421,4 @@
 /projects/#ProjectKeyHashid/add-team              ProjectAddTeamR     POST
 /projects/#ProjectKeyHashid/approve-team/#SquadId ProjectApproveTeamR POST
 /projects/#ProjectKeyHashid/remove-team/#SquadId  ProjectRemoveTeamR  POST
+/projects/#ProjectKeyHashid/teams/#SquadUsStartKeyHashid/live ProjectTeamLiveR GET