browser history for commit like working

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"
         ]

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;

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;
 }

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

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

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

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

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