From 416164c47716ac59833a770d35f2a76224b783f6 Mon Sep 17 00:00:00 2001 From: Dmitry Zuikov Date: Mon, 22 Apr 2024 07:16:06 +0300 Subject: [PATCH] wip, commits infinite scroll --- .../assets/css/custom.css | 19 +++ hbs2-git/hbs2-git-dashboard/GitDashBoard.hs | 27 +++- .../src/HBS2/Git/DashBoard/State.hs | 3 + .../src/HBS2/Git/DashBoard/State/Commits.hs | 116 ++++++++++++++++++ .../src/HBS2/Git/Web/Html/Root.hs | 73 +++++++++-- hbs2-git/hbs2-git.cabal | 1 + 6 files changed, 228 insertions(+), 11 deletions(-) create mode 100644 hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/State/Commits.hs 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 9bc5b1d9..0c76be05 100644 --- a/hbs2-git/hbs2-git-dashboard-assets/assets/css/custom.css +++ b/hbs2-git/hbs2-git-dashboard-assets/assets/css/custom.css @@ -326,6 +326,23 @@ td.tree-locator span { margin-right: .5rem; } +tr.commit-brief-title td,th { + border-bottom: none; + align: top; +} + +tr.commit-brief-details td,th { + border-top: none; +} + +td.commit-brief-title { + background-color: +} + +td.commit-brief-last, th.commit-brief-last { + border: none; +} + pre > code.sourceCode { white-space: pre; position: relative; } pre > code.sourceCode > span { line-height: 1.25; } pre > code.sourceCode > span:empty { height: 1.2em; } @@ -390,3 +407,5 @@ code span.vs { color: #4e9a06; } /* VerbatimString */ code span.wa { color: #8f5902; font-weight: bold; font-style: italic; } /* Warning */ + + diff --git a/hbs2-git/hbs2-git-dashboard/GitDashBoard.hs b/hbs2-git/hbs2-git-dashboard/GitDashBoard.hs index 65f33dff..a4a8f089 100644 --- a/hbs2-git/hbs2-git-dashboard/GitDashBoard.hs +++ b/hbs2-git/hbs2-git-dashboard/GitDashBoard.hs @@ -21,6 +21,7 @@ import HBS2.Git.Local.CLI import HBS2.Git.Web.Assets import HBS2.Git.DashBoard.State import HBS2.Git.DashBoard.State.Index +import HBS2.Git.DashBoard.State.Commits import HBS2.Git.DashBoard.Types import HBS2.Git.Web.Html.Root @@ -250,14 +251,34 @@ runDashboardWeb wo = do co <- co' & orFall (status status404) blobHash <- blob' & orFall (status status404) - back <- lift $ selectParentTree (TreeCommit co) (TreeTree hash) - blobInfo <- lift (selectBlobInfo (BlobHash blobHash)) >>= orFall (status status404) lift $ html =<< renderTextT (repoBlob lww (TreeCommit co) (TreeTree hash) blobInfo) + get "/repo/:lww/commits" do + lwws' <- captureParam @String "lww" <&> fromStringMay @(LWWRefKey HBS2Basic) + + let pred = mempty & set commitPredOffset 0 + & set commitPredLimit 100 + + flip runContT pure do + lww <- lwws' & orFall (status status404) + lift $ html =<< renderTextT (repoCommits lww (Right pred)) + + get "/repo/:lww/commits/:off/:lim" do + lwws' <- captureParam @String "lww" <&> fromStringMay @(LWWRefKey HBS2Basic) + off <- captureParam @Int "off" + lim <- captureParam @Int "lim" + + let pred = mempty & set commitPredOffset off + & set commitPredLimit lim + + flip runContT pure do + lww <- lwws' & orFall (status status404) + lift $ html =<< renderTextT (repoCommits lww (Left pred)) + gitShowTree :: (DashBoardPerks m, MonadReader DashBoardEnv m) => LWWRefKey 'HBS2Basic @@ -355,7 +376,7 @@ updateIndexPeriodially = do lww <- lift (selectLwwByRefLog (RepoRefLog r)) >>= maybe (exit ()) pure - dir <- asks (view dataDir) <&> ( (show $ pretty lww)) + dir <- lift $ repoDataPath (coerce lww) here <- doesDirectoryExist dir diff --git a/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/State.hs b/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/State.hs index a72b9a0a..c1ddb9db 100644 --- a/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/State.hs +++ b/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/State.hs @@ -23,6 +23,7 @@ import DBPipe.SQLite hiding (insert) import DBPipe.SQLite qualified as S import DBPipe.SQLite.Generic as G + import Data.ByteString.Lazy.Char8 qualified as LBS8 import Data.ByteString.Lazy (ByteString) import Lucid.Base @@ -704,3 +705,5 @@ buildCommitTreeIndex dir = do + + 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 new file mode 100644 index 00000000..a9029257 --- /dev/null +++ b/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/State/Commits.hs @@ -0,0 +1,116 @@ +{-# LANGUAGE TemplateHaskell #-} +module HBS2.Git.DashBoard.State.Commits where + +import HBS2.Git.DashBoard.Prelude +import HBS2.Git.DashBoard.Types + +import HBS2.Git.Local +import HBS2.Git.Local.CLI + +import Data.ByteString.Lazy.Char8 qualified as LBS8 +import Data.Text.Encoding qualified as Text +import Data.Text qualified as Text +import Data.Time (UTCTime,LocalTime) +import Data.Time.Clock.POSIX (posixSecondsToUTCTime) +import Data.Either + +import Streaming.Prelude qualified as S + +{- HLINT ignore "Functor law" -} + +data CommitListStyle = CommitListBrief + +data SelectCommitsPred = + SelectCommitsPred + { _commitListStyle :: CommitListStyle + , _commitPredOffset :: Int + , _commitPredLimit :: Int + } + +makeLenses ''SelectCommitsPred + +instance Semigroup SelectCommitsPred where + (<>) _ _ = mempty + +instance Monoid SelectCommitsPred where + mempty = SelectCommitsPred CommitListBrief 0 100 + +briefCommits :: SelectCommitsPred +briefCommits = mempty + +newtype Author = Author Text + deriving stock (Generic,Data) + deriving newtype (Show) + + +newtype CommitListItemHash = CommitListItemHash GitHash + deriving stock (Generic,Data) + deriving newtype (Show,Pretty) + +newtype CommitListItemTime = CommitListItemTime Integer + deriving stock (Generic,Data) + deriving newtype (Show) + +newtype CommitListItemTitle = CommitListItemTitle Text + deriving stock (Generic,Data) + deriving newtype (Show) + +newtype CommitListItemAuthor = CommitListItemAuthor Author + deriving stock (Generic,Data) + deriving newtype (Show) + +data CommitListItem = + CommitListItemBrief + { commitListHash :: CommitListItemHash + , commitListTime :: CommitListItemTime + , commitListTitle :: CommitListItemTitle + , commitListAuthor :: CommitListItemAuthor + } + deriving stock (Generic,Data) + +selectCommits :: (DashBoardPerks m, MonadReader DashBoardEnv m) + => LWWRefKey 'HBS2Basic + -> SelectCommitsPred + -> m [CommitListItem] + +selectCommits lww SelectCommitsPred{..} = do + let lim = _commitPredLimit + let off = _commitPredOffset + let delim = "|||" :: Text + dir <- repoDataPath lww + + let cmd = case _commitListStyle of + CommitListBrief -> do + let fmt = [qc|--pretty=format:"%H{delim}%at{delim}%an{delim}%s"|] :: String + [qc|git --git-dir={dir} log --all --max-count {lim} --skip {off} {fmt}|] + + debug $ red "selectCommits" <+> pretty cmd + + ls <- gitRunCommand cmd + <&> fromRight mempty + <&> LBS8.lines + <&> fmap (Text.decodeUtf8 . LBS8.toStrict) + + S.toList_ do + for_ ls $ \l -> do + case Text.splitOn "|||" l of + z@[cohash,ts,au,msg] -> do + + let utc = readMay @Integer (Text.unpack ts) + <&> CommitListItemTime + + let hash = fromStringMay @GitHash (Text.unpack cohash) + <&> CommitListItemHash + + let co = CommitListItemBrief + <$> hash + <*> utc + <*> pure (CommitListItemTitle msg) + <*> pure (CommitListItemAuthor (Author au)) + + maybe1 co none S.yield + + _ -> none + + + 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 fb3785ec..7abe2aba 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 @@ -5,6 +5,7 @@ module HBS2.Git.Web.Html.Root where import HBS2.Git.DashBoard.Prelude import HBS2.Git.DashBoard.Types import HBS2.Git.DashBoard.State +import HBS2.Git.DashBoard.State.Commits import HBS2.Git.Data.Tx.Git import HBS2.Git.Data.RepoHead @@ -44,6 +45,9 @@ myCss = do hyper_ :: Text -> Attribute hyper_ = makeAttribute "_" +-- makeGetQuery :: String -> Attribute +-- makeGetQuery _ = termRaw "jop" + onClickCopy :: Text -> Attribute onClickCopy s = hyper_ [qc|on click writeText('{s}') into the navigator's clipboard add .clicked to me wait 2s remove .clicked from me|] @@ -70,6 +74,14 @@ instance ToHtml RepoBrief where data WithTime a = WithTime Integer a +agePure :: forall a b . (Integral a,Integral b) => a -> b -> Text +agePure t0 t = do + let sec = fromIntegral @_ @Word64 t - fromIntegral t0 + fromString $ show $ + if | sec > 86400 -> pretty (sec `div` 86400) <+> "days ago" + | sec > 3600 -> pretty (sec `div` 3600) <+> "hours ago" + | otherwise -> pretty (sec `div` 60) <+> "minutes ago" + instance ToHtml (WithTime RepoListItem) where toHtmlRaw = pure mempty @@ -82,12 +94,7 @@ instance ToHtml (WithTime RepoListItem) where let url = path ["repo", Text.unpack $ view rlRepoLwwAsText it] let t = fromIntegral $ coerce @_ @Word64 rlRepoSeq - let updated = "" <+> d - where - sec = now - t - d | sec > 86400 = pretty (sec `div` 86400) <+> "days ago" - | sec > 3600 = pretty (sec `div` 3600) <+> "hours ago" - | otherwise = pretty (sec `div` 60) <+> "minutes ago" + let updated = agePure t now div_ [class_ "repo-list-item"] do div_ [class_ "repo-info", style_ "flex: 1; flex-basis: 70%;"] do @@ -99,7 +106,7 @@ instance ToHtml (WithTime RepoListItem) where div_ [ ] do div_ [ class_ "attr" ] do - div_ [ class_ "attrname"] (toHtml $ show updated) + div_ [ class_ "attrname"] (toHtml updated) when locked do div_ [ class_ "attr" ] do @@ -365,6 +372,55 @@ repoTree lww co root tree back' = do {- HLINT ignore "Functor law" -} +repoCommits :: (DashBoardPerks m, MonadReader DashBoardEnv m) + => LWWRefKey 'HBS2Basic + -> Either SelectCommitsPred SelectCommitsPred + -> HtmlT m () + +repoCommits lww predicate' = do + now <- getEpoch + let repo = show $ pretty lww + + let predicate = either id id predicate' + + co <- lift $ selectCommits lww predicate + + let off = view commitPredOffset predicate + let lim = view commitPredLimit predicate + let noff = off + lim + + let query = path ["repo", repo, "commits", show noff, show lim] + + let rows = do + for_ co $ \case + CommitListItemBrief{..} -> do + tr_ [class_ "commit-brief-title"] do + td_ $ img_ [src_ "/icon/git-commit.svg"] + 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) + td_ do + small_ $ toHtml $ coerce @_ @Text commitListAuthor + tr_ [class_ "commit-brief-details"] do + td_ [colspan_ "1"] mempty + td_ [colspan_ "3", class_ "commit-brief-title"] do + small_ $ toHtml $ coerce @_ @Text commitListTitle + + unless (List.null co) do + tr_ [ class_ "commit-brief-last" + , hxGet_ query + , hxTrigger_ "revealed" + , hxSwap_ "afterend" + ] do + td_ [colspan_ "4"] do + mempty + + if isRight predicate' then do + table_ rows + else do + rows + repoBlob :: (DashBoardPerks m, MonadReader DashBoardEnv m) => LWWRefKey 'HBS2Basic -> TreeCommit @@ -499,7 +555,8 @@ repoPage it@RepoListItem{..} = rootPage do , hxTarget_ "#repo-tab-data" ] "manifest" - repoMenuItem [ + repoMenuItem [ hxGet_ (path ["repo", repo, "commits"]) + , hxTarget_ "#repo-tab-data" ] "commits" repoMenuItem (showRefsHtmxAttribs repo) "tree" diff --git a/hbs2-git/hbs2-git.cabal b/hbs2-git/hbs2-git.cabal index 8b04e8f9..54088659 100644 --- a/hbs2-git/hbs2-git.cabal +++ b/hbs2-git/hbs2-git.cabal @@ -147,6 +147,7 @@ executable hbs2-git-dashboard HBS2.Git.DashBoard.Prelude HBS2.Git.DashBoard.Types HBS2.Git.DashBoard.State + HBS2.Git.DashBoard.State.Commits HBS2.Git.DashBoard.State.Index HBS2.Git.DashBoard.State.Index.Channels HBS2.Git.DashBoard.State.Index.Peer