wip

hbs2-git/hbs2-git-dashboard-assets/assets/icon/git-fork.svg

@@ -0,0 +1,8 @@
+<svg xmlns="http://www.w3.org/2000/svg" class="icon icon-tabler icon-tabler-git-fork" width="20" height="20" viewBox="0 0 24 24" stroke-width="1.5" stroke="#000000" fill="none" stroke-linecap="round" stroke-linejoin="round">
+  <path stroke="none" d="M0 0h24v24H0z" fill="none"/>
+  <path d="M12 18m-2 0a2 2 0 1 0 4 0a2 2 0 1 0 -4 0" />
+  <path d="M7 6m-2 0a2 2 0 1 0 4 0a2 2 0 1 0 -4 0" />
+  <path d="M17 6m-2 0a2 2 0 1 0 4 0a2 2 0 1 0 -4 0" />
+  <path d="M7 8v2a2 2 0 0 0 2 2h6a2 2 0 0 0 2 -2v-2" />
+  <path d="M12 12l0 4" />
+</svg>

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

@@ -209,7 +209,7 @@ runDashboardWeb wo = do
     renderHtml (repoPage tab lww qp)
 
   get (routePattern (RepoManifest "lww")) do
-    lwws' <- captureParam @String "lww" <&> fromStringMay @(LWWRefKey HBS2Basic)
+    lwws' <- captureParam @String "lww" <&> fromStringMay @(LWWRefKey 'HBS2Basic)
     flip runContT pure do
       lww <- lwws' & orFall (status status404)
 
@@ -224,7 +224,7 @@ runDashboardWeb wo = do
 
 
   get (routePattern (RepoRefs "lww")) do
-    lwws' <- captureParam @String "lww" <&> fromStringMay @(LWWRefKey HBS2Basic)
+    lwws' <- captureParam @String "lww" <&> fromStringMay @(LWWRefKey 'HBS2Basic)
 
     -- setHeader "HX-Push-Url" [qc|/{show $ pretty lwws'}|]
 
@@ -233,7 +233,7 @@ runDashboardWeb wo = do
       lift $ renderHtml (repoRefs lww)
 
   get (routePattern (RepoTree "lww" "co" "hash")) do
-    lwws' <- captureParam @String "lww" <&> fromStringMay @(LWWRefKey HBS2Basic)
+    lwws' <- captureParam @String "lww" <&> fromStringMay @(LWWRefKey 'HBS2Basic)
     hash' <- captureParam @String "hash" <&> fromStringMay @GitHash
     co'   <- captureParam @String "co" <&> fromStringMay @GitHash
 
@@ -241,10 +241,10 @@ runDashboardWeb wo = do
       lww  <- lwws' & orFall (status status404)
       hash <- hash' & orFall (status status404)
       co   <- co'   & orFall (status status404)
-      lift $ html =<< renderTextT (repoTree lww co hash)
+      lift $ renderHtml (repoTree lww co hash)
 
   get (routePattern (RepoBlob "lww" "co" "hash" "blob")) do
-    lwws' <- captureParam @String "lww" <&> fromStringMay @(LWWRefKey HBS2Basic)
+    lwws' <- captureParam @String "lww" <&> fromStringMay @(LWWRefKey 'HBS2Basic)
     hash' <- captureParam @String "hash" <&> fromStringMay @GitHash
     co'   <- captureParam @String "co" <&> fromStringMay @GitHash
     blob' <- captureParam @String "blob" <&> fromStringMay @GitHash
@@ -264,18 +264,25 @@ runDashboardWeb wo = do
   get (routePattern (RepoCommitSummaryQ "lww" "hash")) (commitRoute RepoCommitSummary)
   get (routePattern (RepoCommitPatchQ   "lww" "hash")) (commitRoute RepoCommitPatch)
 
+  get (routePattern (RepoForksHtmx "lww")) do
+    lwws' <- captureParam @String "lww" <&> fromStringMay @(LWWRefKey 'HBS2Basic)
+    flip runContT pure do
+      lww       <- lwws' & orFall (status status404)
+      lift $ renderHtml (repoForks lww)
+      -- lift $ renderHtml (toHtml $ show $ pretty lww)
+
   get (routePattern (RepoCommits "lww")) do
-    lwws' <- captureParam @String "lww" <&> fromStringMay @(LWWRefKey HBS2Basic)
+    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))
+      lift $ renderHtml (repoCommits lww (Right pred))
 
   get (routePattern (RepoCommitsQ "lww" "off" "lim")) do
-    lwws' <- captureParam @String "lww" <&> fromStringMay @(LWWRefKey HBS2Basic)
+    lwws' <- captureParam @String "lww" <&> fromStringMay @(LWWRefKey 'HBS2Basic)
     off   <- captureParam  @Int "off"
     lim   <- captureParam  @Int "lim"
 

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

@@ -154,7 +154,7 @@ newtype RepoBrief = RepoBrief Text
 
 newtype RepoForks = RepoForks Int
                     deriving stock (Generic,Data)
-                    deriving newtype (ToField,FromField,Show,Pretty)
+                    deriving newtype (ToField,FromField,Show,Pretty,Num,Eq,Ord)
 
 newtype RepoCommitsNum = RepoCommitsNum Int
                          deriving stock (Generic,Data)
@@ -178,7 +178,7 @@ newtype RepoHeadRef = RepoHeadRef HashRef
 
 newtype RepoHeadSeq = RepoHeadSeq Word64
                       deriving stock (Generic)
-                      deriving newtype (ToField,FromField)
+                      deriving newtype (ToField,FromField,Integral,Real,Ord,Eq,Num,Enum)
 
 newtype RepoRefLog = RepoRefLog (RefLogKey 'HBS2Basic)
                      deriving stock (Generic)
@@ -815,6 +815,18 @@ buildCommitTreeIndex lww = do
 
   -- FIXME: check-names-with-spaces
 
+selectRepoForks :: (DashBoardPerks m, MonadReader DashBoardEnv m)
+                => LWWRefKey 'HBS2Basic
+                -> m [RepoListItem]
+selectRepoForks lww = withState do
+  let cols = columnListPart (AllColumns @RepoListItem) & fromSQL
+  let sql = [qc| select {cols}
+                     from repolistview v join fork f on v.lww = f.b
+                     where f.a = ?
+            |]
+
+  debug $ yellow "selectRepoForks" <+> pretty sql <+> pretty lww
+  select sql (Only (RepoLww lww))
 
 gitShowTree :: (DashBoardPerks m, MonadReader DashBoardEnv m)
             => LWWRefKey 'HBS2Basic

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

@@ -63,6 +63,7 @@ data RepoListPage = RepoListPage
 data RepoPageTabs =  CommitsTab (Maybe GitHash)
                    | ManifestTab
                    | TreeTab (Maybe GitHash)
+                   | ForksTab
                     deriving stock (Eq,Ord,Show)
 
 data RepoPage s a = RepoPage s a
@@ -75,6 +76,8 @@ data RepoTreeEmbedded repo commit tree = RepoTreeEmbedded repo commit tree
 
 data RepoBlob repo commit tree blob = RepoBlob repo commit tree blob
 
+data RepoForksHtmx repo = RepoForksHtmx repo
+
 newtype RepoManifest repo = RepoManifest repo
 
 newtype RepoCommits repo = RepoCommits repo
@@ -105,12 +108,14 @@ instance Pretty RepoPageTabs where
     CommitsTab{}   -> "commits"
     ManifestTab{}  -> "manifest"
     TreeTab{}      -> "tree"
+    ForksTab{}     -> "forks"
 
 instance FromStringMaybe RepoPageTabs where
   fromStringMay = \case
     "commits"  -> pure (CommitsTab Nothing)
     "manifest" -> pure ManifestTab
     "tree"     -> pure (TreeTab Nothing)
+    "forks"    -> pure ForksTab
     _          -> pure (CommitsTab Nothing)
 
 instance ToRoutePattern RepoListPage where
@@ -228,6 +233,15 @@ instance ToRoutePattern (RepoTreeEmbedded String String String) where
     path ["/", "htmx", "tree", "embedded", toArg r, toArg co, toArg tree] & toPattern
 
 
+instance ToURL (RepoForksHtmx (LWWRefKey 'HBS2Basic))  where
+  toURL (RepoForksHtmx k) = path ["/", "htmx", "forks", repo]
+    where
+      repo = show $ pretty k
+
+instance ToRoutePattern (RepoForksHtmx String) where
+  routePattern (RepoForksHtmx r) =
+    path ["/", "htmx", "forks", toArg r] & toPattern
+
 myCss :: Monad m => HtmlT m ()
 myCss = do
   link_ [rel_ "stylesheet", href_ (path ["css/custom.css"])]
@@ -676,11 +690,26 @@ repoCommit style lww hash = do
 
 
 repoForks :: (DashBoardPerks m, MonadReader DashBoardEnv m)
-            => LWWRefKey 'HBS2Basic
+          => LWWRefKey 'HBS2Basic
-            -> HtmlT m ()
+          -> HtmlT m ()
 
 repoForks lww  = do
-  pure mempty
+  forks <- lift $ selectRepoForks lww
+  now <- getEpoch
+
+  unless (List.null forks) do
+    table_ $  do
+      tr_ $ th_ [colspan_ "3"] mempty
+      for_ forks $ \it@RepoListItem{..} -> do
+        let lwwTo = coerce @_ @(LWWRefKey 'HBS2Basic) rlRepoLww
+        tr_ [class_ "commit-brief-title"] do
+          td_ $ img_ [src_ "/icon/git-fork.svg"]
+          td_ [class_ "mono"] $
+            a_ [ href_ (toURL (RepoPage (CommitsTab Nothing) lwwTo))
+               ] do
+              toHtmlRaw $ view rlRepoLwwAsText it
+          td_ $ small_ $ toHtml (agePure rlRepoSeq now)
+
 
 repoCommits :: (DashBoardPerks m, MonadReader DashBoardEnv m)
             => LWWRefKey 'HBS2Basic
@@ -705,6 +734,7 @@ repoCommits lww predicate' = do
                   | otherwise = x <> "..."
 
   let rows = do
+        tr_ $ th_ [colspan_ "5"] mempty
         for_ co $ \case
           CommitListItemBrief{..} -> do
             tr_ [class_ "commit-brief-title"] do
@@ -827,6 +857,18 @@ raiseStatus s t = throwIO (StatusError s t)
 
 itemNotFound s = StatusError status404 (Text.pack $ show $ pretty s)
 
+newtype ShortRef a = ShortRef a
+
+shortRef :: String -> String
+shortRef a = [qc|{b}..{r}|]
+  where
+    b = take 18 a
+    r = reverse $ take 2 (reverse a)
+
+instance Pretty a => ToHtml (ShortRef a) where
+  toHtml (ShortRef a) = toHtml (shortRef (show $ pretty a))
+  toHtmlRaw (ShortRef a) = toHtml (shortRef (show $ pretty a))
+
 repoPage :: (MonadIO m, DashBoardPerks m, MonadReader DashBoardEnv m)
          => RepoPageTabs
          -> LWWRefKey 'HBS2Basic
@@ -854,6 +896,10 @@ repoPage tab lww params = rootPage do
   div_ [class_ "container main"] $ do
     nav_ [class_ "left"] $ do
 
+      div_ [class_ "info-block" ] do
+        div_ [ class_ "attr" ] do
+          a_ [href_ (toURL (RepoPage (CommitsTab Nothing) lww))] $ toHtml (ShortRef lww)
+
       div_ [class_ "info-block" ] do
         div_ [ class_ "attr" ] do
          img_ [src_ "/icon/tree-up.svg"]
@@ -877,10 +923,13 @@ repoPage tab lww params = rootPage do
               div_ [ class_ "attrname"] do
                 a_ [ href_ (toURL (RepoPage ManifestTab lww))] "Manifest"
 
-        div_ [ class_ "attr" ] do
+        when (rlRepoForks > 0) do
-          div_ [ class_ "attrname"] do
+          div_ [ class_ "attr" ] do
-            a_ [ href_ (toURL (RepoPage ManifestTab lww))] "Forks"
+            div_ [ class_ "attrname"] do
-          div_ [ class_ "attrval"] $ toHtml (show $ rlRepoForks)
+              a_ [ hxGet_ (toURL (RepoForksHtmx lww))
+                 , hxTarget_ "#repo-tab-data"
+                 ] "Forks"
+            div_ [ class_ "attrval"] $ toHtml (show $ rlRepoForks)
 
         div_ [ class_ "attr" ] do
           div_ [ class_ "attrname"] do
@@ -929,7 +978,7 @@ repoPage tab lww params = rootPage do
                     ] "tree"
 
       section_ [id_ "repo-data"] do
-        h1_ (toHtml $ rlRepoName)
+        strong_ (toHtml $ rlRepoName)
 
       div_ [id_ "repo-tab-data"] do
 
@@ -950,6 +999,9 @@ repoPage tab lww params = rootPage do
             let predicate = Right (fromQueryParams params)
             repoCommits lww predicate
 
+          ForksTab -> do
+            repoForks lww
+
       div_ [id_ "repo-tab-data-embedded"] mempty