wip

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

@@ -310,3 +310,17 @@ nav[role="tab-control"] li.active {
   color: #0089D1;
 }
 
+.mono {
+    font-family: 'Courier New', Courier, monospace;
+}
+
+
+.blob {
+    width: 16px;
+    height: 16px;
+    display: inline-block;
+
+    background-image: url('/icon/file.svg');
+    background-size: cover;
+}
+

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

@@ -0,0 +1,16 @@
+<svg xmlns="http://www.w3.org/2000/svg"
+  class="icon icon-tabler icon-tabler-file-alert"
+  width="24"
+  height="24"
+  viewBox="0 0 24 24"
+  stroke-width="1"
+  stroke="#2c3e50"
+  fill="none"
+  stroke-linecap="round"
+  stroke-linejoin="round">
+
+  <path stroke="none" d="M0 0h24v24H0z" fill="none"/>
+  <path d="M14 3v4a1 1 0 0 0 1 1h4" />
+  <path d="M17 21h-10a2 2 0 0 1 -2 -2v-14a2 2 0 0 1 2 -2h7l5 5v11a2 2 0 0 1 -2 2z" />
+  <!-- <path d="M12 11l0 3" /> -->
+</svg>

hbs2-git/hbs2-git-dashboard-assets/assets/icon/tree-up.svg

@@ -0,0 +1,4 @@
+<svg xmlns="http://www.w3.org/2000/svg" class="icon icon-tabler icon-tabler-arrow-big-up" width="24" height="24" viewBox="0 0 24 24" stroke-width="1" stroke="#2c3e50" fill="none" stroke-linecap="round" stroke-linejoin="round">
+  <path stroke="none" d="M0 0h24v24H0z" fill="none"/>
+  <path d="M9 20v-8h-3.586a1 1 0 0 1 -.707 -1.707l6.586 -6.586a1 1 0 0 1 1.414 0l6.586 6.586a1 1 0 0 1 -.707 1.707h-3.586v8a1 1 0 0 1 -1 1h-4a1 1 0 0 1 -1 -1z" />
+</svg>

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

@@ -0,0 +1,4 @@
+<svg xmlns="http://www.w3.org/2000/svg" class="icon icon-tabler icon-tabler-folder" width="24" height="24" viewBox="0 0 24 24" stroke-width="1" stroke="#2c3e50" fill="none" stroke-linecap="round" stroke-linejoin="round">
+  <path stroke="none" d="M0 0h24v24H0z" fill="none"/>
+  <path d="M5 4h4l3 3h7a2 2 0 0 1 2 2v8a2 2 0 0 1 -2 2h-14a2 2 0 0 1 -2 -2v-11a2 2 0 0 1 2 -2" />
+</svg>

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

@@ -13,6 +13,8 @@ import HBS2.Polling
 import HBS2.Peer.RPC.API.Storage
 import HBS2.Peer.RPC.Client.StorageClient
 
+import HBS2.Git.Local
+import HBS2.Git.Local.CLI
 
 import HBS2.Git.Web.Assets
 import HBS2.Git.DashBoard.State
@@ -39,6 +41,7 @@ import Control.Concurrent.STM (flushTQueue)
 import System.FilePath
 import System.Process.Typed
 import System.Directory (XdgDirectory(..),getXdgDirectory)
+import Data.ByteString.Lazy.Char8 qualified as LBS8
 
 
 configParser :: DashBoardPerks m => Parser (m ())
@@ -185,9 +188,6 @@ runDashboardWeb wo = do
 
   get "/repo/:lww" do
     lwws' <- captureParam @String "lww" <&> fromStringMay @(LWWRefKey HBS2Basic)
-
-    env <- lift ask
-
     flip runContT pure do
       lww <- lwws' & orFall (status status404)
 
@@ -200,6 +200,80 @@ runDashboardWeb wo = do
 
       lift $ html =<< renderTextT (repoPage item)
 
+  get "/repo/:lww/manifest" do
+    lwws' <- captureParam @String "lww" <&> fromStringMay @(LWWRefKey HBS2Basic)
+    flip runContT pure do
+      lww <- lwws' & orFall (status status404)
+
+      item <- lift (selectRepoList ( mempty
+                                      & set repoListByLww (Just lww)
+                                      & set repoListLimit (Just 1))
+                                   )
+                 <&> listToMaybe
+                 >>= orFall (status status404)
+
+      lift $ html =<< renderTextT (repoManifest item)
+
+
+  get "/repo/:lww/refs" do
+    lwws' <- captureParam @String "lww" <&> fromStringMay @(LWWRefKey HBS2Basic)
+    flip runContT pure do
+      lww <- lwws' & orFall (status status404)
+      refs <- lift $ gitShowRefs lww
+      lift $ html =<< renderTextT (repoRefs lww refs)
+
+  get "/repo/:lww/tree/:hash" do
+    lwws' <- captureParam @String "lww" <&> fromStringMay @(LWWRefKey HBS2Basic)
+    hash'  <- captureParam @String "hash" <&> fromStringMay @GitHash
+    back   <- queryParamMaybe @String "back" <&> ((fromStringMay @GitHash) =<<)
+
+    flip runContT pure do
+      lww  <- lwws' & orFall (status status404)
+      hash <- hash' & orFall (status status404)
+      tree <- lift $ gitShowTree lww hash
+      lift $ html =<< renderTextT (repoTree lww hash tree back)
+
+
+repoDataPath  :: (DashBoardPerks m, MonadReader DashBoardEnv m) => LWWRefKey 'HBS2Basic -> m FilePath
+repoDataPath lw = asks _dataDir <&> (</> (show $ pretty lw)) >>= canonicalizePath
+
+
+gitShowTree :: (DashBoardPerks m, MonadReader DashBoardEnv m)
+            => LWWRefKey 'HBS2Basic
+            -> GitHash
+            -> m [(GitObjectType, GitHash, Text)]
+gitShowTree what hash  = do
+  path <- repoDataPath what
+  let cmd = [qc|git --git-dir {path} ls-tree {show $ pretty hash}|]
+
+  -- FIXME: extract-method
+  gitRunCommand cmd
+    >>= orThrowUser ("can't read git repo" <+> pretty path)
+    <&> LBS8.lines
+    <&> fmap LBS8.words
+    <&> mapMaybe \case
+         [_,tp,h,name] -> do
+            (,,) <$> fromStringMay (LBS8.unpack tp)
+                 <*> fromStringMay (LBS8.unpack h)
+                 <*> pure (fromString (LBS8.unpack name))
+
+         _          -> Nothing
+
+
+gitShowRefs :: (DashBoardPerks m, MonadReader DashBoardEnv m) => LWWRefKey 'HBS2Basic -> m [(GitRef, GitHash)]
+gitShowRefs what = do
+  path <- repoDataPath what
+  let cmd = [qc|git --git-dir {path} show-ref|]
+
+  -- FIXME: extract-method
+  gitRunCommand cmd
+    >>= orThrowUser ("can't read git repo" <+> pretty path)
+    <&> LBS8.lines
+    <&> fmap LBS8.words
+    <&> mapMaybe \case
+         [val,name] -> (GitRef (LBS8.toStrict name),) <$> fromStringMay @GitHash (LBS8.unpack val)
+         _          -> Nothing
+
 
 runScotty :: DashBoardPerks m => DashBoardM m ()
 runScotty  = do

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

@@ -17,6 +17,7 @@ module HBS2.Git.DashBoard.Prelude
   , module Lens.Micro.Platform
   , module UnliftIO
   , module Codec.Serialise
+  , GitRef(..), GitHash(..), GitObjectType(..)
   , qc, q
   ) where
 
@@ -41,6 +42,7 @@ import HBS2.Peer.Proto.LWWRef    as API
 import HBS2.Peer.Proto.RefChan.Types as API
 import HBS2.Peer.Proto.RefChan.RefChanUpdate as API
 
+import HBS2.Git.Local
 
 import Data.Config.Suckless as Config
 

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

@@ -21,6 +21,10 @@ import Data.Word
 import Data.Either
 import Safe
 
+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
 
 rootPath :: [String] -> [String]
@@ -161,11 +165,11 @@ repoMenuItem :: Term [Attribute] (t1 -> t2) => [Attribute] -> t1 -> t2
 repoMenuItem misc name = li_ ([class_  "tab"] <> misc <> [tabClick]) name
 
 
-repoPage :: (DashBoardPerks m, MonadReader DashBoardEnv m) => RepoListItem -> HtmlT m ()
-repoPage RepoListItem{..} = rootPage do
+parsedManifest :: (DashBoardPerks m, MonadReader DashBoardEnv m) => RepoListItem  -> m ([Syntax C], Text)
+parsedManifest RepoListItem{..} = do
 
   sto <- asks _sto
-  mhead <- lift $ readRepoHeadFromTx sto (coerce rlRepoTx)
+  mhead <- readRepoHeadFromTx sto (coerce rlRepoTx)
 
   let rawManifest  = (_repoManifest . snd =<< mhead)
                       & fromMaybe (coerce rlRepoBrief)
@@ -185,6 +189,90 @@ repoPage RepoListItem{..} = rootPage do
 
   let manifest = mconcat $ rights  w
 
+  pure (meta, manifest)
+
+
+repoManifest :: (DashBoardPerks m, MonadReader DashBoardEnv m) => RepoListItem -> HtmlT m ()
+repoManifest it@RepoListItem{..} = do
+  (_, manifest) <- lift $ parsedManifest it
+  toHtmlRaw (renderMarkdown' manifest)
+
+repoRefs :: (DashBoardPerks m, MonadReader DashBoardEnv m)
+         => LWWRefKey 'HBS2Basic
+         -> [(GitRef, GitHash)]
+         -> HtmlT m ()
+repoRefs lww refs = do
+  table_ [] do
+    for_ refs $ \(r,h) -> do
+      let link = path [ "repo", show $ pretty lww, "tree",  show (pretty h) ]
+      tr_ mempty do
+        td_ mempty (toHtml $ show $ pretty r)
+        td_ [class_ "mono"] $ a_ [ href_ "#"
+                                 , hxGet_ link
+                                 , hxTarget_ "#repo-tab-data"
+                                 ] (toHtml $ show $ pretty h)
+
+
+
+repoTree :: (DashBoardPerks m, MonadReader DashBoardEnv m)
+         => LWWRefKey 'HBS2Basic
+         -> GitHash -- ^ this
+         -> [(GitObjectType, GitHash, Text)]
+         -> Maybe GitHash -- ^ back
+         -> HtmlT m ()
+
+repoTree lww root tree back' = do
+
+  table_ [] do
+    tr_ mempty do
+
+      for_ back' $ \root -> do
+        let rootLink = path [ "repo", show $ pretty lww, "tree", show (pretty root) ]
+        td_ $ img_ [src_ "/icon/tree-up.svg"]
+        td_ ".."
+        td_ do a_ [ href_ "#"
+                  , hxGet_ rootLink
+                  , hxTarget_ "#repo-tab-data"
+                  ] (toHtml $ show $ pretty root)
+
+    for_ tree $ \(tp,h,name) -> do
+
+      let back = show $ pretty root
+      let backPart = [qc|?back={back}|]
+
+      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_ "mono"] do
+          case tp of
+            Blob -> do
+              span_ do
+                toHtml $ show $ pretty h
+
+            Tree -> do
+              a_ [ href_ "#"
+                 , hxGet_ (link <> backPart)
+                 , hxTarget_ "#repo-tab-data"
+                 ] (toHtml $ show $ pretty h)
+
+            _ -> mempty
+
+
+repoPage :: (DashBoardPerks m, MonadReader DashBoardEnv m) => RepoListItem -> HtmlT m ()
+repoPage it@RepoListItem{..} = rootPage do
+
+  let repo = show $ pretty rlRepoLww
+
+  sto <- asks _sto
+  mhead <- lift $ readRepoHeadFromTx sto (coerce rlRepoTx)
+
+  (meta, manifest) <- lift $ parsedManifest it
+
   debug $ yellow "HEAD" <+> pretty rlRepoTx
   debug $ yellow "META" <+> pretty meta
 
@@ -223,10 +311,18 @@ repoPage RepoListItem{..} = rootPage do
       nav_ [ role_ "tab-control" ] do
        repoMenu do
         repoMenuItem  mempty $ a_ [href_ "/"] "root"
-        repoMenuItem0 mempty "manifest"
+
+        repoMenuItem0 [ hxGet_ (path ["repo", repo, "manifest"])
+                      , hxTarget_ "#repo-tab-data"
+                      ] "manifest"
+
+        repoMenuItem  [ hxGet_ (path ["repo", repo, "refs"])
+                      , hxTarget_ "#repo-tab-data"
+                      ] "browse"
 
       section_ [id_ "repo-data"] do
         h1_ (toHtml $ rlRepoName)
 
+      div_ [id_ "repo-tab-data"] do
         toHtmlRaw (renderMarkdown' manifest)
 

hbs2-git/hbs2-git.cabal

@@ -163,6 +163,7 @@ executable hbs2-git-dashboard
         , optparse-applicative
         , http-types
         , file-embed
+        , network-uri
         , wai
         , wai-extra
         , wai-middleware-static