browser history for commit like working

2024-04-22 10:33:17 +03:00 · 2024-04-22 10:33:17 +03:00 · 86764baf6c
parent 1f4aa22156
commit 86764baf6c
8 changed files with 228 additions and 11 deletions
--- a/flake.lock
+++ b/flake.lock
@ -149,6 +149,42 @@
        "type": "github"
      }
    },
+    "flake-utils_8": {
+      "locked": {
+        "lastModified": 1644229661,
+        "narHash": "sha256-1YdnJAsNy69bpcjuoKdOYQX0YxZBiCYZo4Twxerqv7k=",
+        "owner": "numtide",
+        "repo": "flake-utils",
+        "rev": "3cecb5b042f7f209c56ffd8371b2711a290ec797",
+        "type": "github"
+      },
+      "original": {
+        "owner": "numtide",
+        "repo": "flake-utils",
+        "type": "github"
+      }
+    },
+    "fuzzy": {
+      "inputs": {
+        "haskell-flake-utils": "haskell-flake-utils_4",
+        "nixpkgs": [
+          "nixpkgs"
+        ]
+      },
+      "locked": {
+        "lastModified": 1711855026,
+        "narHash": "sha256-uO2dNqFiio46cuZURBC00k17uKGAtUgP7bZAYZ9HlOU=",
+        "ref": "refs/heads/master",
+        "rev": "a579201f0672f90eec7c42e65d6828978dddb816",
+        "revCount": 39,
+        "type": "git",
+        "url": "http://git.hbs2/GmcLB9gEPT4tbx9eyQiECwsu8oPyEh6qKEpQDtyBWVPA"
+      },
+      "original": {
+        "type": "git",
+        "url": "http://git.hbs2/GmcLB9gEPT4tbx9eyQiECwsu8oPyEh6qKEpQDtyBWVPA"
+      }
+    },
    "haskell-flake-utils": {
      "inputs": {
        "flake-utils": "flake-utils"
@ -207,6 +243,24 @@
      "inputs": {
        "flake-utils": "flake-utils_4"
      },
+      "locked": {
+        "lastModified": 1707809372,
+        "narHash": "sha256-wfTL9PlCSOqSSyU4eenFFI7pHrV21gba4GEILnI4nAU=",
+        "owner": "ivanovs-4",
+        "repo": "haskell-flake-utils",
+        "rev": "3cbdc5d6093e8b4464ae64097e0c8c61e4414ff2",
+        "type": "github"
+      },
+      "original": {
+        "owner": "ivanovs-4",
+        "repo": "haskell-flake-utils",
+        "type": "github"
+      }
+    },
+    "haskell-flake-utils_5": {
+      "inputs": {
+        "flake-utils": "flake-utils_5"
+      },
      "locked": {
        "lastModified": 1698938553,
        "narHash": "sha256-oXpTKXioqFbl2mhhvpJIAvgNd+wYyv4ekI+YnJHEJ6s=",
@ -222,9 +276,9 @@
        "type": "github"
      }
    },
-    "haskell-flake-utils_5": {
+    "haskell-flake-utils_6": {
      "inputs": {
-        "flake-utils": "flake-utils_5"
+        "flake-utils": "flake-utils_6"
      },
      "locked": {
        "lastModified": 1672412555,
@ -241,9 +295,9 @@
        "type": "github"
      }
    },
-    "haskell-flake-utils_6": {
+    "haskell-flake-utils_7": {
      "inputs": {
-        "flake-utils": "flake-utils_6"
+        "flake-utils": "flake-utils_7"
      },
      "locked": {
        "lastModified": 1698938553,
@ -259,9 +313,9 @@
        "type": "github"
      }
    },
-    "haskell-flake-utils_7": {
+    "haskell-flake-utils_8": {
      "inputs": {
-        "flake-utils": "flake-utils_7"
+        "flake-utils": "flake-utils_8"
      },
      "locked": {
        "lastModified": 1672412555,
@ -279,7 +333,7 @@
    },
    "hspup": {
      "inputs": {
-        "haskell-flake-utils": "haskell-flake-utils_5",
+        "haskell-flake-utils": "haskell-flake-utils_6",
        "nixpkgs": [
          "nixpkgs"
        ]
@ -300,7 +354,7 @@
    },
    "lsm": {
      "inputs": {
-        "haskell-flake-utils": "haskell-flake-utils_6",
+        "haskell-flake-utils": "haskell-flake-utils_7",
        "nixpkgs": [
          "nixpkgs"
        ]
@ -339,7 +393,8 @@
      "inputs": {
        "db-pipe": "db-pipe",
        "fixme": "fixme",
-        "haskell-flake-utils": "haskell-flake-utils_4",
+        "fuzzy": "fuzzy",
+        "haskell-flake-utils": "haskell-flake-utils_5",
        "hspup": "hspup",
        "lsm": "lsm",
        "nixpkgs": "nixpkgs",
@ -388,7 +443,7 @@
    },
    "suckless-conf_2": {
      "inputs": {
-        "haskell-flake-utils": "haskell-flake-utils_7",
+        "haskell-flake-utils": "haskell-flake-utils_8",
        "nixpkgs": [
          "nixpkgs"
        ]
--- a/flake.nix
+++ b/flake.nix
@ -21,6 +21,9 @@ inputs = {
    lsm.url = "git+https://git.hbs2.net/5BCaH95cWsVKBmWaDNLWQr2umxzzT5kqRRKNTm2J15Ls";
    lsm.inputs.nixpkgs.follows = "nixpkgs";

+    fuzzy.url = "git+http://git.hbs2/GmcLB9gEPT4tbx9eyQiECwsu8oPyEh6qKEpQDtyBWVPA";
+    fuzzy.inputs.nixpkgs.follows = "nixpkgs";
+
    saltine = {
      url = "github:tel/saltine/3d3a54cf46f78b71b4b55653482fb6f4cee6b77d";
      flake = false;
--- a/hbs2-git/hbs2-git-dashboard-assets/assets/css/custom.css
+++ b/hbs2-git/hbs2-git-dashboard-assets/assets/css/custom.css
@ -310,6 +310,23 @@ nav[role="tab-control"] li.active {
  color: #0089D1;
 }

+
+nav.secondary[role="tab-control"] li {
+  border-right: none;
+  font-weight: normal;
+}
+
+ul.misc-menu  {
+  margin: 0 0 0 0;
+  padding: 0 0 0 0;
+}
+
+ul.misc-menu li {
+  padding: 0 0 0 0;
+  margin-right: 1em;
+  display: inline;
+}
+
 .mono {
    font-family: 'Courier New', Courier, monospace;
 }
--- a/hbs2-git/hbs2-git-dashboard/GitDashBoard.hs
+++ b/hbs2-git/hbs2-git-dashboard/GitDashBoard.hs
@ -256,6 +256,9 @@ runDashboardWeb wo = do

      lift $ html =<< renderTextT (repoBlob lww (TreeCommit co) (TreeTree hash) blobInfo)

+  get "/repo/:lww/commit/:hash" (commitRoute RepoCommitSummary)
+  get "/repo/:lww/commit/summary/:hash" (commitRoute RepoCommitSummary)
+  get "/repo/:lww/commit/patch/:hash" (commitRoute RepoCommitPatch)

  get "/repo/:lww/commits" do
    lwws' <- captureParam @String "lww" <&> fromStringMay @(LWWRefKey HBS2Basic)
@ -279,6 +282,16 @@ runDashboardWeb wo = do
      lww       <- lwws' & orFall (status status404)
      lift $ html =<< renderTextT (repoCommits lww (Left pred))

+  where
+    commitRoute style = do
+      lwws' <- captureParam @String "lww" <&> fromStringMay @(LWWRefKey HBS2Basic)
+      co    <- captureParam @String "hash" <&> fromStringMay @GitHash
+
+      flip runContT pure do
+        lww   <- lwws' & orFall (status status404)
+        hash  <- co & orFall (status status404)
+        lift $ html =<< renderTextT (repoCommit style lww hash)
+

 gitShowTree :: (DashBoardPerks m, MonadReader DashBoardEnv m)
            => LWWRefKey 'HBS2Basic
--- a/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/State/Commits.hs
+++ b/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/State/Commits.hs
@ -112,5 +112,36 @@ selectCommits lww SelectCommitsPred{..} = do

        _ -> none

+getCommitRawBrief :: (DashBoardPerks m, MonadReader DashBoardEnv m)
+                  => LWWRefKey 'HBS2Basic
+                  -> GitHash
+                  -> m Text

+getCommitRawBrief lww hash = do

+  dir <- repoDataPath lww
+
+  let cmd = [qc|git --git-dir={dir} show --stat {pretty hash}|]
+
+  debug $ red "getCommitRawBrief" <+> viaShow cmd
+
+  gitRunCommand cmd
+    <&> fromRight mempty
+    <&> Text.decodeUtf8 . LBS8.toStrict
+
+getCommitRawPatch :: (DashBoardPerks m, MonadReader DashBoardEnv m)
+                  => LWWRefKey 'HBS2Basic
+                  -> GitHash
+                  -> m Text
+
+getCommitRawPatch lww hash = do
+
+  dir <- repoDataPath lww
+
+  let cmd = [qc|git --git-dir={dir} show {pretty hash}|]
+
+  debug $ red "getCommitRawPatch" <+> viaShow cmd
+
+  gitRunCommand cmd
+    <&> fromRight mempty
+    <&> Text.decodeUtf8 . LBS8.toStrict
--- 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
@ -10,6 +10,8 @@ import HBS2.Git.DashBoard.State.Commits
 import HBS2.Git.Data.Tx.Git
 import HBS2.Git.Data.RepoHead

+-- import Data.Text.Fuzzy.Tokenize as Fuzz
+
 import Data.ByteString.Lazy qualified as LBS
 import Data.Text qualified as Text
 import Data.Text.Encoding qualified as Text
@ -359,12 +361,14 @@ 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
@ -372,6 +376,93 @@ repoTree lww co root tree back' = do

 {- HLINT ignore "Functor law" -}

+data RepoCommitStyle = RepoCommitSummary | RepoCommitPatch
+                       deriving (Eq,Ord,Show)
+
+repoCommit :: (DashBoardPerks m, MonadReader DashBoardEnv m)
+            => RepoCommitStyle
+            -> LWWRefKey 'HBS2Basic
+            -> GitHash
+            -> HtmlT m ()
+
+repoCommit style lww hash = do
+  let syntaxMap = Sky.defaultSyntaxMap
+
+  let repo = show $ pretty lww
+  let co_ = show $ pretty hash
+  let root = co_
+
+  txt <- lift $ getCommitRawBrief lww hash
+
+  let header = Text.lines txt & takeWhile (not . Text.null)
+                              & fmap Text.words
+
+  let au = [ Text.takeWhile (/= '<') (Text.unwords a)
+           | ("Author:" : a) <- header
+           ] & headMay
+
+  table_ [class_ "item-attr"] do
+
+    tr_ do
+      th_ [width_ "16rem"] $ strong_ "commit"
+      td_ $ a_ [ href_ "#"
+               , hxGet_ (path [ "repo", show $ pretty lww, "tree", co_, co_ ])
+               , hxTarget_ "#repo-tab-data"
+               ] $ toHtml $ show $ pretty hash
+
+    for_ au $ \author -> do
+      tr_ do
+        th_ $ strong_ "author"
+        td_ $ toHtml  author
+
+    tr_ $ do
+      th_ $ strong_ "view"
+      td_ do
+        ul_ [class_ "misc-menu"]do
+          unless (style == RepoCommitSummary ) do
+            li_ $ a_ [ href_ "#"
+                     , hxGet_ (path ["repo", repo, "commit", "summary", co_])
+                     , hxTarget_ "#repo-tab-data"
+                     ] "summary"
+          unless (style == RepoCommitPatch ) do
+            li_ $ a_ [ href_ "#"
+                     , hxGet_ (path ["repo", repo, "commit", "patch", co_])
+                     , hxTarget_ "#repo-tab-data"
+                     ] "patch"
+
+  case style of
+    RepoCommitSummary -> do
+
+      let msyn = Sky.syntaxByName syntaxMap "default"
+
+      for_ msyn $ \syn -> do
+
+        let config = TokenizerConfig { traceOutput = False, syntaxMap = syntaxMap }
+
+        case tokenize config syn txt of
+          Left _ -> mempty
+          Right tokens -> do
+            let fo = Sky.defaultFormatOpts { Sky.numberLines = False, Sky.ansiColorLevel = Sky.ANSI256Color  }
+            let code = renderText (Lucid.formatHtmlBlock fo tokens)
+            toHtmlRaw code
+
+    RepoCommitPatch -> do
+
+      let msyn = Sky.syntaxByName syntaxMap "diff"
+
+      for_ msyn $ \syn -> do
+
+        txt <- lift $ getCommitRawPatch lww hash
+
+        let config = TokenizerConfig { traceOutput = False, syntaxMap = syntaxMap }
+
+        case tokenize config syn txt of
+          Left _ -> mempty
+          Right tokens -> do
+            let fo = Sky.defaultFormatOpts { Sky.numberLines = False, Sky.ansiColorLevel = Sky.ANSI256Color  }
+            let code = renderText (Lucid.formatHtmlBlock fo tokens)
+            toHtmlRaw code
+
 repoCommits :: (DashBoardPerks m, MonadReader DashBoardEnv m)
            => LWWRefKey 'HBS2Basic
            -> Either SelectCommitsPred SelectCommitsPred
@ -399,7 +490,11 @@ repoCommits lww predicate' = do
              td_ $ small_ $ toHtml (agePure (coerce @_ @Integer commitListTime) now)
              td_ [class_ "mono", width_ "20rem"] do
                  let hash = show $ pretty $ coerce @_ @GitHash commitListHash
-                  a_ [href_ ""] (toHtml hash)
+                  a_ [ href_ "#"
+                     , hxGet_ (path ["repo",repo,"commit",hash])
+                     , hxTarget_ "#repo-tab-data"
+                     , hxPushUrl_ query
+                     ] (toHtml hash)
              td_ do
                small_ $ toHtml $ coerce @_ @Text commitListAuthor
            tr_ [class_ "commit-brief-details"] do
--- a/hbs2-git/hbs2-git.cabal
+++ b/hbs2-git/hbs2-git.cabal
@ -156,6 +156,7 @@ executable hbs2-git-dashboard
    -- other-extensions:
    build-depends:
        base, hbs2-git-dashboard-assets, hbs2-peer, hbs2-git, suckless-conf
+        , fuzzy-parse
        , binary
        , generic-deriving
        , generic-data
--- a/hbs2-tests/hbs2-tests.cabal
+++ b/hbs2-tests/hbs2-tests.cabal
@ -19,6 +19,7 @@ common warnings
 common common-deps
    build-depends:
          base, hbs2-core, hbs2-storage-simple, hbs2-peer
+        , fuzzy-parse
        , async
        , bytestring
        , cache
@ -914,6 +915,7 @@ executable test-playground
    main-is:          Main.hs
    build-depends:
          base, hbs2-core
+        , fuzzy-parse
        , async
        , bytestring
        , cache