wip, commits infinite scroll

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 */
 
 
+
+

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
 

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
 
 
 
+
+

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
+
+
+

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"

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