From 4f5954de7edf12f924324dbc641c0cdf066bd415 Mon Sep 17 00:00:00 2001
From: Pere Lev <pere@towards.vision>
Date: Mon, 20 May 2024 20:39:05 +0300
Subject: [PATCH] Serve live URIs for Team (Squad) records for project, repo,
 deck, loom

---
 src/Vervis/Foundation.hs      |  5 +++++
 src/Vervis/Handler/Deck.hs    | 12 ++++++++++++
 src/Vervis/Handler/Loom.hs    | 12 ++++++++++++
 src/Vervis/Handler/Project.hs | 12 ++++++++++++
 src/Vervis/Handler/Repo.hs    | 12 ++++++++++++
 th/routes                     |  4 ++++
 6 files changed, 57 insertions(+)

diff --git a/src/Vervis/Foundation.hs b/src/Vervis/Foundation.hs
index dcab196..e59cb1d 100644
--- a/src/Vervis/Foundation.hs
+++ b/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)
diff --git a/src/Vervis/Handler/Deck.hs b/src/Vervis/Handler/Deck.hs
index e6aa16e..37bd97c 100644
--- a/src/Vervis/Handler/Deck.hs
+++ b/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
diff --git a/src/Vervis/Handler/Loom.hs b/src/Vervis/Handler/Loom.hs
index 491fe5b..ad0f3d2 100644
--- a/src/Vervis/Handler/Loom.hs
+++ b/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
diff --git a/src/Vervis/Handler/Project.hs b/src/Vervis/Handler/Project.hs
index 028f759..4ad9231 100644
--- a/src/Vervis/Handler/Project.hs
+++ b/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
diff --git a/src/Vervis/Handler/Repo.hs b/src/Vervis/Handler/Repo.hs
index ce7ae61..48bcec7 100644
--- a/src/Vervis/Handler/Repo.hs
+++ b/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
+
 
 
 
diff --git a/th/routes b/th/routes
index ed9bf7a..1be4d61 100644
--- a/th/routes
+++ b/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