wip

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

@@ -6,10 +6,13 @@ import HBS2.Prelude.Plated
 import HBS2.OrDie
 import HBS2.System.Dir
 
+import HBS2.Git.Html.Root
+
 import HBS2.Peer.CLI.Detect
 
 import Data.Config.Suckless
 
+import Lucid
 import Options.Applicative as O
 import Data.Maybe
 import Data.Either
@@ -17,6 +20,7 @@ import Options.Applicative.BashCompletion
 import Control.Applicative
 import Data.ByteString.Lazy qualified as LBS
 import Network.HTTP.Types.Status
+import Network.Wai.Middleware.Static hiding ((<|>))
 import Network.Wai.Middleware.RequestLogger
 import Text.InterpolatedString.Perl6 (qc)
 import Web.Scotty.Trans
@@ -24,6 +28,7 @@ import Control.Monad.Reader
 import Control.Monad.Trans.Maybe
 import System.Directory
 import Control.Monad.Except
+
 import UnliftIO
 
 data HttpPortOpt
@@ -105,6 +110,17 @@ runDashBoardM cli m = do
 
   withDashBoardEnv env m
 
+-- type App =
+
+runDashboardWeb :: ScottyT (DashBoardM IO) ()
+runDashboardWeb = do
+  middleware logStdout
+
+  middleware $ staticPolicy (noDots >-> addBase "hbs2-git/hbs2-git-dashboard/assets/")
+
+  get "/" $ do
+    html =<< renderTextT (dashboardRootPage mempty)
+
 main :: IO ()
 main = do
 
@@ -120,8 +136,7 @@ main = do
 
     env <- ask
 
-    scottyT pno (withDashBoardEnv env) do
+    scottyT pno (withDashBoardEnv env) runDashboardWeb
-      middleware logStdout
 
   where
     opts = info (configParser <**> helper)

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

@@ -0,0 +1,297 @@
+input, button  {
+  font-size: var(--form-element-font-size);
+  height: 2.5rem;
+  padding: 0.25rem 0.5rem;
+  border-radius: 0.25rem;
+  border: 1px solid #ccc;
+}
+
+input[type="search"] {
+  font-size: var(--form-element-font-size);
+  height: 2.5rem;
+  padding: 0.25rem 0.5rem;
+  border-radius: 0.25rem;
+  border: 1px solid #ccc;
+}
+
+button.search {
+  background: url('/icon/refresh.svg') no-repeat center center;
+  background-size: 24px 24px;
+  min-width:  32px;
+  height: 2.5rem;
+}
+
+button.search svg {
+}
+
+body, html {
+  margin: 0;
+  height: 100%;
+  font-size: 18px;
+}
+
+
+header {
+  width: 100%;
+
+  font-size: 20px;
+
+  display: flex;
+  align-items: center;
+
+  padding: 8px;
+
+  top: 0;
+  left: 0;
+  z-index: 100;
+  box-shadow: 0 2px 5px rgba(0,0,0,0.2);
+}
+
+/* height: 64px; */
+
+header h1 {
+  font-size: 20px;
+  margin: 0 0 0 2.21rem;
+  font-weight: 500;
+}
+
+.header-title {
+}
+
+.container {
+  width: 100%;
+}
+
+.header-links {
+  display: flex;
+  margin-left: 10em;
+  gap: 2rem;
+  background: white;
+}
+
+header a {
+  /* display: inline; */
+  height: 1rem;
+  text-decoration: none;
+}
+
+.header-actions {
+  margin-left: auto;
+}
+
+nav.left {
+  flex: 0 0 20rem;
+  padding: 4rem 0rem 0 1rem;
+  font-size: 20px;
+  flex-direction: column;
+  justify-content: normal;
+  background: #FAFAFA;
+}
+
+nav.left .info-block {
+  margin-bottom: 4rem;
+}
+
+section#repo-data {
+  margin-top: 1.5rem;
+}
+
+section#repo-data> h1::after,
+section#repo-data> h2::after,
+section#repo-data> h3::after,
+section#repo-data> h4::after
+{
+  content: "";
+  display: block;
+  margin: 8px 0;
+  height: 1px;
+  background-color: #ccc;
+}
+
+/*  height: calc(100vh - 64px); */
+
+section {
+  margin-top: 1rem;
+}
+
+
+main {
+  flex-grow: 1;
+  padding: 2rem 0 0 4rem;
+}
+
+
+.main {
+  display: flex;
+  padding: 4px 0 0 0;
+  margin: 0;
+  min-height: 100vh;
+}
+
+main h1 {
+  font-size: 1.5rem;
+}
+
+main h2 {
+  font-size: 1.45rem;
+  font-weight: 400;
+}
+
+div .repo-list-item {
+  display: flex;
+  justify-content: space-between;
+  align-items: flex-start;
+
+
+  background: #FAFAFA;
+  padding: 0.75rem;
+  margin-top: 1.75rem;
+  border-radius: 0.25rem;
+  border: 1px solid #BFC7D9;
+}
+
+.channel-list-item {
+  display: block;
+
+  background: #FAFAFA;
+  padding: 1.45rem;
+  margin-top: 2rem;
+  border-radius: 0.25rem;
+  border: 1px solid #BFC7D9;
+
+}
+
+.repo-info, .repo-info-misc {
+  flex: 1;
+  padding: 1.25rem;
+}
+
+.repo-info h2 a {
+  text-decoration: none;
+  color: inherit;
+}
+
+.repo-info h2 {
+  font-size: 1.35rem;
+}
+
+.repo-info h2 a:hover {
+  text-decoration: underline dotted;
+}
+
+
+.repo-info-misc {
+  text-align: right;
+  font-size: 0.85rem;
+}
+
+
+.attr {
+  display: flex;
+  flex-direction: row;
+  gap: 2rem;
+  margin-bottom: 0.5em;
+  padding-right: 1rem;
+}
+
+.attrname,  {
+  flex: 1;
+  margin-right: 0.5em;
+}
+
+.attrval {
+  flex-basis: 70%;
+  text-align: right;
+}
+
+.icon {
+  flex-basis: 90%;
+  text-align: right;
+}
+
+
+form.search {
+  display: flex;
+  align-items: center;
+  align-items: flex-start;
+  gap: 0.5em;
+}
+
+form.search input[type="search"] {
+  align: center;
+  flex-grow: 1;
+  margin-right: 0.5em;
+}
+
+form.search button {
+  align: center;
+  min-width: 4rem;
+}
+
+.xclip::after {
+  display: inline-block;
+  content: url('/icon/xclip.svg');
+  vertical-align: middle;
+  width: 24px;
+  height: 24px;
+  opacity: 0;
+  transition: opacity 0.2s;
+  left: 16px;
+  position: relative;
+}
+
+.xclip:hover::after {
+  left: 16px;
+  position: relative;
+  content: url('/icon/xclip.svg');
+  vertical-align: middle;
+  height: 24x;
+  width: 24x;
+  opacity: 1;
+}
+
+.xclip {
+  /*position: relative;*/
+  text-decoration: underline dotted;
+}
+
+.xclip:hover {
+  text-decoration: underline dotted;
+}
+
+.clicked:hover::after {
+  content: url('/icon/xclipdone.svg');
+  vertical-align: middle;
+  right: 16px;
+  height: 24x;
+  width: 24x;
+  opacity: 1;
+}
+
+nav[role="tab-control"] {
+  min-height: 24px;
+  font-size: 18px;
+ /*  border: 1px solid black; */
+  display: block;
+  margin-bottom: 4rem;
+}
+
+nav[role="tab-control"] li {
+  display: block;
+  padding: 0 0 0 0;
+  padding-right: 2rem;
+  margin-right: 2rem;
+  border-right: 2px solid gray;
+  font-weight: bolder;
+}
+
+nav[role="tab-control"] li a {
+  color: inherit;
+  text-decoration: none;
+}
+
+nav[role="tab-control"] li.active {
+  display: block;
+  color: #0089D1;
+}
+

hbs2-git/hbs2-git-dashboard/assets/icon/lock-closed.svg

@@ -0,0 +1,7 @@
+<svg xmlns="http://www.w3.org/2000/svg" class="icon icon-tabler icon-tabler-lock" width="24" height="24" viewBox="0 0 24 24" stroke-width="1.5" stroke="#2c3e50" fill="none" stroke-linecap="round" stroke-linejoin="round">
+  <path stroke="none" d="M0 0h24v24H0z" fill="none"/>
+  <path d="M5 13a2 2 0 0 1 2 -2h10a2 2 0 0 1 2 2v6a2 2 0 0 1 -2 2h-10a2 2 0 0 1 -2 -2v-6z" />
+  <path d="M11 16a1 1 0 1 0 2 0a1 1 0 0 0 -2 0" />
+  <path d="M8 11v-4a4 4 0 1 1 8 0v4" />
+</svg>
+

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

@@ -0,0 +1,13 @@
+<svg xmlns="http://www.w3.org/2000/svg"
+    width="24"
+    height="24"
+    viewBox="0 0 24 24"
+    stroke-width="2"
+    stroke="currentColor"
+    fill="none"
+    stroke-linecap="round"
+    stroke-linejoin="round">
+  <path stroke="none" d="M0 0h24v24H0z" fill="none"/>
+  <path d="M20 11a8.1 8.1 0 0 0 -15.5 -2m-.5 -4v4h4" />
+  <path d="M4 13a8.1 8.1 0 0 0 15.5 2m.5 4v-4h-4" />
+</svg>

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

@@ -0,0 +1,6 @@
+<svg xmlns="http://www.w3.org/2000/svg" class="icon icon-tabler icon-tabler-copy" width="24" height="24" viewBox="0 0 24 24" stroke-width="1.5" stroke="#2c3e50" fill="none" stroke-linecap="round" stroke-linejoin="round">
+  <path stroke="none" d="M0 0h24v24H0z" fill="none"/>
+  <path d="M7 7m0 2.667a2.667 2.667 0 0 1 2.667 -2.667h8.666a2.667 2.667 0 0 1 2.667 2.667v8.666a2.667 2.667 0 0 1 -2.667 2.667h-8.666a2.667 2.667 0 0 1 -2.667 -2.667z" />
+  <path d="M4.012 16.737a2.005 2.005 0 0 1 -1.012 -1.737v-10c0 -1.1 .9 -2 2 -2h10c.75 0 1.158 .385 1.5 1" />
+</svg>
+

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

@@ -0,0 +1,6 @@
+<svg xmlns="http://www.w3.org/2000/svg" class="icon icon-tabler icon-tabler-copy-check" width="24" height="24" viewBox="0 0 24 24" stroke-width="1.5" stroke="#2c3e50" fill="none" stroke-linecap="round" stroke-linejoin="round">
+  <path stroke="none" d="M0 0h24v24H0z" fill="none"/>
+  <path d="M7 7m0 2.667a2.667 2.667 0 0 1 2.667 -2.667h8.666a2.667 2.667 0 0 1 2.667 2.667v8.666a2.667 2.667 0 0 1 -2.667 2.667h-8.666a2.667 2.667 0 0 1 -2.667 -2.667z" />
+  <path d="M4.012 16.737a2.005 2.005 0 0 1 -1.012 -1.737v-10c0 -1.1 .9 -2 2 -2h10c.75 0 1.158 .385 1.5 1" />
+  <path d="M11 14l2 2l4 -4" />
+</svg>

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

@@ -0,0 +1,89 @@
+module HBS2.Git.Html.Root where
+
+import HBS2.Prelude
+import HBS2.Base58
+import HBS2.Peer.Proto.RefChan.Types
+
+import Data.Config.Suckless
+
+import Control.Monad.Trans.Maybe
+import Data.Maybe
+import Data.Text qualified as Text
+import Lucid.Base
+import Lucid.Html5 hiding (for_)
+import System.FilePath
+import Text.InterpolatedString.Perl6 (q)
+
+rootPath :: [String] -> [String]
+rootPath = ("/":)
+
+path :: [String] -> Text
+path = Text.pack . joinPath . rootPath
+
+myCss :: Monad m => HtmlT m ()
+myCss = do
+  link_ [rel_ "stylesheet", href_ (path ["css/custom.css"])]
+
+rootPage :: Monad m => HtmlT m () -> HtmlT m ()
+rootPage content  = do
+  doctypehtml_ do
+    head_ do
+      meta_ [charset_ "UTF-8"]
+      meta_ [name_ "viewport", content_ "width=device-width, initial-scale=1.0"]
+      -- FIXME: static-local-loading
+      link_ [rel_ "stylesheet", href_ "https://cdn.jsdelivr.net/npm/@picocss/pico@2.0.6/css/pico.min.css"]
+      script_ [src_ "https://unpkg.com/hyperscript.org@0.9.12"] ""
+      script_ [src_ "https://unpkg.com/htmx.org@1.9.11"] ""
+      myCss
+
+    body_ do
+      header_ do
+        div_ [class_ "header-title"] $ h1_ "hbs2-peer dashboard"
+      content
+
+
+
+dashboardRootPage :: Monad m => [Syntax c] -> HtmlT m ()
+dashboardRootPage syn = rootPage do
+
+  let channels = mempty
+  -- [ mchan | ListVal (SymbolVal "channel" : mchan) <- bro ]
+
+  div_ [class_ "container main"] $ do
+    nav_ [class_ "left"] $ do
+      div_ [class_ "info-block"] "Всякая разная рандомная информация хрен знает, что тут пока выводить"
+      div_ [class_ "info-block"] "Всякая разная рандомная информация хрен знает, что тут пока выводить"
+
+    main_ do
+      for_ channels $ \chan -> void $ runMaybeT do
+
+        let title = headDef "unknown" [ t
+                                          | ListVal [ SymbolVal "title", LitStrVal t ] <- chan
+                                          ]
+        let desc = mconcat [ d
+                           | ListVal (SymbolVal "description" : d) <- chan
+                           ] & take 5
+
+        rchan <- headMay ( catMaybes
+                       [ fromStringMay @(RefChanId L4Proto) (Text.unpack rc)
+                       | ListVal [SymbolVal "refchan", LitStrVal rc] <- chan
+                       ] ) & toMPlus
+
+
+        let alias = headMay [ x
+                            | ListVal [SymbolVal "alias", LitStrVal x] <- chan
+                            ]
+
+        let url = case alias of
+                    Just x -> Text.unpack x
+                    Nothing -> (show . pretty . AsBase58) rchan
+
+        lift do
+          div_ [class_ "channel-list-item"] do
+            h2_ $ toHtml title
+
+            p_ $ a_ [href_ (path [url])] (toHtml (show $ pretty $ AsBase58 rchan))
+
+            for_ [ s | LitStrVal s <- desc ] $ \s -> do
+              p_ (toHtml s)
+

hbs2-git/hbs2-git.cabal

@@ -6,7 +6,6 @@ version:            0.24.1.2
 license:            BSD-3-Clause
 license-file:       LICENSE
 author:             Dmitry Zuikov
-maintainer:         dzuikov@gmail.com
 -- copyright:
 category:           System
 build-type:         Simple
@@ -129,7 +128,10 @@ library
 executable hbs2-git-dashboard
     import:           shared-properties
     main-is:          GitDashBoard.hs
-    -- other-modules:
+
+    other-modules:
+      HBS2.Git.Html.Root
+
     -- other-extensions:
     build-depends:
         base, hbs2-peer, hbs2-git, suckless-conf
@@ -137,10 +139,14 @@ executable hbs2-git-dashboard
         , vector
         , optparse-applicative
         , http-types
+        , wai
         , wai-extra
-        , scotty
+        , wai-middleware-static
+        , lucid
+        , lucid-htmx
+        , scotty >= 0.22
 
-    hs-source-dirs:   hbs2-git-dashboard hbs2-git-dashboard/src
+    hs-source-dirs:   hbs2-git-dashboard, hbs2-git-dashboard/src
 
     default-language: GHC2021
 
@@ -189,4 +195,3 @@ executable git-remote-hbs2
     default-language: GHC2021
 
 
-

hbs2-peer/app/HttpWorker.hs

@@ -76,8 +76,8 @@ httpWorker (PeerConfig syn) pmeta e = do
     scotty port $ do
       middleware logStdout
 
-      defaultHandler $ const do
+      -- defaultHandler do
-        status status500
+      --   status status500
 
       get "/size/:hash" do
 

hbs2-peer/lib/HBS2/Peer/Proto/RefChan/Types.hs

@@ -4,7 +4,10 @@
 {-# Language FunctionalDependencies #-}
 {-# LANGUAGE ImplicitParams #-}
 {-# LANGUAGE PatternSynonyms, ViewPatterns #-}
-module HBS2.Peer.Proto.RefChan.Types where
+module HBS2.Peer.Proto.RefChan.Types
+  ( module HBS2.Peer.Proto.RefChan.Types
+  , L4Proto
+  ) where
 
 import HBS2.Prelude.Plated
 import HBS2.Hash