From f8249b40004f7a73e5b321a2ceec1a6859793153 Mon Sep 17 00:00:00 2001
From: Dmitry Zuikov <dzuikov@gmail.com>
Date: Mon, 22 Apr 2024 11:18:54 +0300
Subject: [PATCH] back button for commits, ugly

---
 hbs2-git/hbs2-git-dashboard/GitDashBoard.hs   | 17 +++++++++++--
 .../src/HBS2/Git/Web/Html/Root.hs             | 24 +++++++++++++++----
 2 files changed, 34 insertions(+), 7 deletions(-)

diff --git a/hbs2-git/hbs2-git-dashboard/GitDashBoard.hs b/hbs2-git/hbs2-git-dashboard/GitDashBoard.hs
index 893746b6..f563035c 100644
--- a/hbs2-git/hbs2-git-dashboard/GitDashBoard.hs
+++ b/hbs2-git/hbs2-git-dashboard/GitDashBoard.hs
@@ -30,12 +30,13 @@ import HBS2.Peer.CLI.Detect
 import Lucid (renderTextT)
 import Options.Applicative as O
 import Data.Either
+import Data.Text qualified as Text
 import Data.ByteString.Lazy qualified as LBS
 import Network.HTTP.Types.Status
 import Network.Wai.Middleware.Static hiding ((<|>))
 import Network.Wai.Middleware.StaticEmbedded as E
 import Network.Wai.Middleware.RequestLogger
-import Web.Scotty.Trans
+import Web.Scotty.Trans as Scotty
 import Control.Monad.Except
 import System.Random
 import Data.HashMap.Strict (HashMap)
@@ -230,14 +231,18 @@ runDashboardWeb wo = do
     hash' <- captureParam @String "hash" <&> fromStringMay @GitHash
     co'   <- captureParam @String "co" <&> fromStringMay @GitHash
 
+
     flip runContT pure do
       lww  <- lwws' & orFall (status status404)
       hash <- hash' & orFall (status status404)
       co   <- co'   & orFall (status status404)
       tree <- lift $ gitShowTree lww hash
       back <- lift $ selectParentTree (TreeCommit co) (TreeTree hash)
+
+      let ctx = ViewContext [qc|/repo/{show $ pretty $ lww}/tree/{show $ pretty co}/{show $ pretty hash}|] mempty
+
       debug $ "selectParentTree" <+> pretty co <+> pretty hash <+> pretty back
-      lift $ html =<< renderTextT (repoTree lww co hash tree (coerce <$> back))
+      lift $ html =<< renderTextT (repoTree ctx lww co hash tree (coerce <$> back))
 
   get "/repo/:lww/blob/:co/:hash/:blob" do
     lwws' <- captureParam @String "lww" <&> fromStringMay @(LWWRefKey HBS2Basic)
@@ -279,7 +284,12 @@ runDashboardWeb wo = do
                       & set commitPredLimit lim
 
     flip runContT pure do
+
       lww       <- lwws' & orFall (status status404)
+
+      referrer <- lift (Scotty.header "Referer")
+                    >>= orFall (redirect $ fromString $ Text.unpack $ path ["repo", show $ pretty  lww])
+
       lift $ html =<< renderTextT (repoCommits lww (Left pred))
 
   where
@@ -287,6 +297,9 @@ runDashboardWeb wo = do
       lwws' <- captureParam @String "lww" <&> fromStringMay @(LWWRefKey HBS2Basic)
       co    <- captureParam @String "hash" <&> fromStringMay @GitHash
 
+      referrer <- Scotty.header "Referer"
+      debug $ yellow "COMMIT-REFERRER" <+> pretty referrer
+
       flip runContT pure do
         lww   <- lwws' & orFall (status status404)
         hash  <- co & orFall (status status404)
diff --git a/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/Web/Html/Root.hs b/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/Web/Html/Root.hs
index 875abce4..39b466bc 100644
--- a/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/Web/Html/Root.hs
+++ b/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/Web/Html/Root.hs
@@ -34,6 +34,15 @@ import Data.List (sortOn)
 
 import Streaming.Prelude qualified as S
 
+data ViewContext =
+  ViewContext
+  { _baseUri :: String
+  , _tab     :: Text
+  }
+  deriving stock Generic
+
+instance Serialise ViewContext
+
 rootPath :: [String] -> [String]
 rootPath = ("/":)
 
@@ -284,14 +293,15 @@ treeLocator lww co locator next = do
   next
 
 repoTree :: (DashBoardPerks m, MonadReader DashBoardEnv m)
-         => LWWRefKey 'HBS2Basic
+         => ViewContext
+         -> LWWRefKey 'HBS2Basic
          -> GitHash -- ^ this
          -> GitHash -- ^ this
          -> [(GitObjectType, GitHash, Text)]
          -> Maybe GitHash -- ^ back
          -> HtmlT m ()
 
-repoTree lww co root tree back' = do
+repoTree ctx lww co root tree back' = do
 
   let repo = show $ pretty $ lww
 
@@ -306,8 +316,9 @@ repoTree lww co root tree back' = do
           tpOrder Blob = 1
           tpOrder _    = 2
 
-  locator <- lift $ selectTreeLocator (TreeCommit co) (TreeTree root)
+  let wtf = show $ pretty $ AsBase58 (serialise ctx)
 
+  locator <- lift $ selectTreeLocator (TreeCommit co) (TreeTree root)
 
   table_ [] do
 
@@ -353,6 +364,8 @@ repoTree lww co root tree back' = do
 
             img_ ([alt_ (fromMaybe "blob" syn)] <> icon)
 
+        -- debug $ red "PUSH URL" <+> pretty (path ["back", wtf])
+
         td_ [class_ itemClass] (toHtml $ show $ pretty name)
         td_ [class_ "mono"] do
           case tp of
@@ -361,14 +374,12 @@ repoTree lww co root tree back' = do
               a_ [ href_ "#"
                  , hxGet_ blobUri
                  , hxTarget_ "#repo-tab-data"
-                 , hxPushUrl_ (path ["repo", repo, "refs" ])
                  ] (toHtml hash_)
 
             Tree -> do
               a_ [ href_ "#"
                  , hxGet_ uri
                  , hxTarget_ "#repo-tab-data"
-                 , hxPushUrl_ (path ["repo", repo, "refs" ])
                  ] (toHtml hash_)
 
             _ -> mempty
@@ -525,8 +536,11 @@ repoBlob :: (DashBoardPerks m, MonadReader DashBoardEnv m)
 
 repoBlob lww co tree BlobInfo{..} = do
   locator <- lift $ selectTreeLocator co tree
+
+  let repo = show $ pretty lww
   let co_ = show $ pretty co
   let tree_ = show $ pretty tree
+
   table_ [] do
     tr_ do
       td_ [class_ "tree-locator", colspan_ "3"] do