wip

hbs2-git/hbs2-git-dashboard-assets/assets/css/custom.css

@@ -314,13 +314,8 @@ nav[role="tab-control"] li.active {
     font-family: 'Courier New', Courier, monospace;
 }
 
-
+.tree {
-.blob {
+  font-weight: 600;
-    width: 16px;
-    height: 16px;
-    display: inline-block;
-
-    background-image: url('/icon/file.svg');
-    background-size: cover;
 }
 
+

hbs2-git/hbs2-git-dashboard/GitDashBoard.hs

@@ -222,16 +222,19 @@ runDashboardWeb wo = do
       refs <- lift $ gitShowRefs lww
       lift $ html =<< renderTextT (repoRefs lww refs)
 
-  get "/repo/:lww/tree/:hash" do
+  get "/repo/:lww/tree/:co/:hash" do
     lwws' <- captureParam @String "lww" <&> fromStringMay @(LWWRefKey HBS2Basic)
     hash' <- captureParam @String "hash" <&> fromStringMay @GitHash
-    back  <- queryParamMaybe @String "back" <&> ((fromStringMay @GitHash) =<<)
+    co'   <- captureParam @String "co" <&> fromStringMay @GitHash
 
     flip runContT pure do
       lww  <- lwws' & orFall (status status404)
       hash <- hash' & orFall (status status404)
+      co   <- co'   & orFall (status status404)
       tree <- lift $ gitShowTree lww hash
-      lift $ html =<< renderTextT (repoTree lww hash tree back)
+      back <- lift $ selectParentTree co hash
+      debug $ "selectParentTree" <+> pretty co <+> pretty hash <+> pretty back
+      lift $ html =<< renderTextT (repoTree lww co hash tree back)
 
 
 repoDataPath  :: (DashBoardPerks m, MonadReader DashBoardEnv m) => LWWRefKey 'HBS2Basic -> m FilePath

hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/State.hs

@@ -24,6 +24,7 @@ import DBPipe.SQLite qualified as S
 import DBPipe.SQLite.Generic as G
 
 
+import Control.Applicative
 import Data.ByteString.Lazy.Char8 qualified as LBS8
 import Lucid.Base
 import Data.Text qualified as Text
@@ -443,17 +444,11 @@ createRepoTreeIndexTable = do
     create table if not exists tree
     ( parent text not null
     , child  text not null
-    , primary key (parent,child)
+    , kommit text not null
+    , primary key (parent,child,kommit)
     )
   |]
 
-  ddl [qc|
-    create table if not exists committree
-    ( kommit text not null
-    , tree   text not null
-    , primary key (kommit,tree)
-    )
-  |]
 
 isProcessed :: (DashBoardPerks m) => HashRef -> DBPipeM m Bool
 isProcessed href = do
@@ -468,24 +463,27 @@ insertProcessed href = do
   on conflict(hash) do nothing
   |] (Only href)
 
-insertCommitTree :: (DashBoardPerks m) => GitHash -> GitHash -> DBPipeM m ()
+insertTree :: (DashBoardPerks m) => GitHash -> GitHash -> GitHash -> DBPipeM m ()
-insertCommitTree commit tree = do
+insertTree commit parent child = do
   S.insert [qc|
-  insert into committree (kommit,tree)
+  insert into tree (parent,child,kommit)
-  values (?,?)
+  values (?,?,?)
-  on conflict (kommit,tree) do nothing
+  on conflict (parent,child,kommit) do nothing
-  |] (commit,tree)
+  |] (parent,child,commit)
 
-insertTree :: (DashBoardPerks m) => GitHash -> GitHash -> DBPipeM m ()
+selectParentTree :: (DashBoardPerks m, MonadReader DashBoardEnv m) => GitHash -> GitHash -> m (Maybe GitHash)
-insertTree parent child = do
+selectParentTree  co me = withState do
-  S.insert [qc|
+  w <- select [qc|select coalesce(parent,kommit) from tree where child = ? and kommit = ?|] (me,co)
-  insert into tree (parent,child)
+        <&> listToMaybe . fmap fromOnly
-  values (?,?)
+
-  on conflict (parent,child) do nothing
+  if co == me then
-  |] (parent,child)
+    pure Nothing
+  else do
+    pure $ w <|> Just co
 
 {- HLINT ignore "Functor law" -}
 
+
 pattern TreeHash :: GitHash -> LBS8.ByteString
 pattern TreeHash hash <- (LBS8.words -> (_ : (fromStringMay . LBS8.unpack -> Just hash) : _))
 
@@ -519,7 +517,6 @@ buildCommitTreeIndex dir = do
                 >>= toMPlus
 
       lift $ transactional do
-        insertCommitTree co root
 
         trees <- gitRunCommand [qc|git --git-dir {dir} ls-tree -r -t {pretty co}|]
           <&> fromRight mempty
@@ -538,7 +535,7 @@ buildCommitTreeIndex dir = do
 
           for_ parent $ \p -> do
             debug $ red "FOUND SHIT:" <+> pretty (h0,p)
-            insertTree p h0
+            insertTree co p h0
 
         insertProcessed hkey
 

hbs2-git/hbs2-git-dashboard/src/HBS2/Git/Web/Html/Root.hs

@@ -20,10 +20,9 @@ import System.FilePath
 import Data.Word
 import Data.Either
 import Safe
+import Data.List (sortOn)
+import Data.Ord (comparing, Down(..))
 
-import Data.ByteString.Char8 qualified as BS8
-import Network.URI (uriToString, parseURI, URI(..), URIAuth(..))
-import Network.HTTP.Types.URI (renderQuery)
 
 import Streaming.Prelude qualified as S
 
@@ -204,30 +203,39 @@ repoRefs :: (DashBoardPerks m, MonadReader DashBoardEnv m)
 repoRefs lww refs = do
   table_ [] do
     for_ refs $ \(r,h) -> do
-      let link = path [ "repo", show $ pretty lww, "tree",  show (pretty h) ]
+      let co = show $ pretty h
+      let uri = path [ "repo", show $ pretty lww, "tree", co, co ]
       tr_ mempty do
         td_ mempty (toHtml $ show $ pretty r)
         td_ [class_ "mono"] $ a_ [ href_ "#"
-                                 , hxGet_ link
+                                 , hxGet_ uri
                                  , hxTarget_ "#repo-tab-data"
                                  ] (toHtml $ show $ pretty h)
 
 
-
 repoTree :: (DashBoardPerks m, MonadReader DashBoardEnv m)
          => LWWRefKey 'HBS2Basic
          -> GitHash -- ^ this
+         -> GitHash -- ^ this
          -> [(GitObjectType, GitHash, Text)]
          -> Maybe GitHash -- ^ back
          -> HtmlT m ()
 
-repoTree lww root tree back' = do
+repoTree lww co root tree back' = do
+
+  let co_ = show $ pretty co
+
+  let sorted = sortOn (\(tp, _, name) -> (tpOrder tp, name)) tree
+        where
+          tpOrder Tree = (0 :: Int)
+          tpOrder Blob = 1
+          tpOrder _    = 2
 
   table_ [] do
     tr_ mempty do
 
       for_ back' $ \root -> do
-        let rootLink = path [ "repo", show $ pretty lww, "tree", show (pretty root) ]
+        let rootLink = path [ "repo", show $ pretty lww, "tree", co_, show (pretty root) ]
         td_ $ img_ [src_ "/icon/tree-up.svg"]
         td_ ".."
         td_ do a_ [ href_ "#"
@@ -235,19 +243,17 @@ repoTree lww root tree back' = do
                   , hxTarget_ "#repo-tab-data"
                   ] (toHtml $ show $ pretty root)
 
-    for_ tree $ \(tp,h,name) -> do
+    for_ sorted $ \(tp,h,name) -> do
-
+      let itemClass = pretty tp & show & Text.pack
-      let back = show $ pretty root
+      let hash_ = show $ pretty h
-      let backPart = [qc|?back={back}|]
+      let uri = path [ "repo", show $ pretty lww, "tree", co_, hash_ ]
-
-      let link = path [ "repo", show $ pretty lww, "tree", show (pretty h) ]
       tr_ mempty do
         td_  $ case tp of
           Blob -> img_ [src_ "/icon/blob.svg"]
           Tree -> img_ [src_ "/icon/tree.svg"]
           _    -> mempty
 
-        td_ mempty (toHtml $ show $ pretty name)
+        td_ [class_ itemClass] (toHtml $ show $ pretty name)
         td_ [class_ "mono"] do
           case tp of
             Blob -> do
@@ -256,9 +262,9 @@ repoTree lww root tree back' = do
 
             Tree -> do
               a_ [ href_ "#"
-                 , hxGet_ (link <> backPart)
+                 , hxGet_ uri
                  , hxTarget_ "#repo-tab-data"
-                 , hxPushUrl_ "true"
+                 -- , hxPushUrl_ "true"
                  ] (toHtml $ show $ pretty h)
 
             _ -> mempty