From 86764baf6c9696e583a59d601e387da9e036cdad Mon Sep 17 00:00:00 2001 From: Dmitry Zuikov Date: Mon, 22 Apr 2024 10:33:17 +0300 Subject: [PATCH] browser history for commit like working --- flake.lock | 75 ++++++++++++-- flake.nix | 3 + .../assets/css/custom.css | 17 ++++ hbs2-git/hbs2-git-dashboard/GitDashBoard.hs | 13 +++ .../src/HBS2/Git/DashBoard/State/Commits.hs | 31 ++++++ .../src/HBS2/Git/Web/Html/Root.hs | 97 ++++++++++++++++++- hbs2-git/hbs2-git.cabal | 1 + hbs2-tests/hbs2-tests.cabal | 2 + 8 files changed, 228 insertions(+), 11 deletions(-) diff --git a/flake.lock b/flake.lock index 3295e835..d8324239 100644 --- 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" ] diff --git a/flake.nix b/flake.nix index a5683ccc..476aafc9 100644 --- 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; diff --git a/hbs2-git/hbs2-git-dashboard-assets/assets/css/custom.css b/hbs2-git/hbs2-git-dashboard-assets/assets/css/custom.css index 4637d2a6..05d2c6ea 100644 --- 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; } diff --git a/hbs2-git/hbs2-git-dashboard/GitDashBoard.hs b/hbs2-git/hbs2-git-dashboard/GitDashBoard.hs index a4a8f089..893746b6 100644 --- 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 diff --git 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 index a9029257..011a1fe7 100644 --- 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 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 d9f89d2d..875abce4 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 @@ -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 diff --git a/hbs2-git/hbs2-git.cabal b/hbs2-git/hbs2-git.cabal index 54088659..30ed8b32 100644 --- 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 diff --git a/hbs2-tests/hbs2-tests.cabal b/hbs2-tests/hbs2-tests.cabal index a54d843d..df2b18b2 100644 --- 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