wip

cabal.project

@@ -3,6 +3,8 @@ packages: **/*.cabal
 
 allow-newer: all
 
+constraints: pandoc ==3.1.11
+
 -- executable-static: True
 -- profiling: True
 -- library-profiling: False

hbs2-fixer/hbs2-fixer.cabal

@@ -68,7 +68,6 @@ common shared-properties
                , streaming
                , streaming-bytestring
                , streaming-commons
-               , streaming-utils
                , cryptonite
                , directory
                , exceptions

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

@@ -192,7 +192,7 @@ runDashboardWeb wo = do
       middleware $ staticPolicy (noDots >-> addBase f)
 
   get "/" do
-    html =<< renderTextT (dashboardRootPage mempty)
+    html =<< lift (renderTextT dashboardRootPage)
 
 
 runScotty :: DashBoardPerks m => DashBoardM m ()

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

@@ -1,5 +1,6 @@
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 {-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE AllowAmbiguousTypes #-}
 {-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE ViewPatterns #-}
 module HBS2.Git.DashBoard.State where
@@ -27,6 +28,7 @@ import Data.Config.Suckless
 import DBPipe.SQLite hiding (insert)
 import DBPipe.SQLite.Generic as G
 
+import Lucid.Base
 import Data.Maybe
 import Data.Text qualified as Text
 import Text.InterpolatedString.Perl6 (qc)
@@ -49,6 +51,15 @@ evolveDB = do
       )
   |]
 
+
+  ddl [qc|
+    create table if not exists repochannel
+      ( lww text not null
+      , channel text not null
+      , primary key (lww,channel)
+      )
+  |]
+
   ddl [qc|
     create table if not exists brief
       (  lww text not null
@@ -81,23 +92,40 @@ instance ToField HashRef where
 instance Pretty (AsBase58 (PubKey 'Sign s)) => ToField (LWWRefKey s) where
   toField x = toField $ show $ pretty (AsBase58 x)
 
+instance FromField (LWWRefKey HBS2Basic) where
+  fromField = fmap fromString . fromField @String
+
+
 newtype TxHash = TxHash HashRef
+                 deriving stock (Generic)
                  deriving newtype (ToField)
 
 newtype RepoName = RepoName Text
-                   deriving newtype (ToField)
+                   deriving stock (Generic)
+                   deriving newtype (ToField,FromField,ToHtml)
 
 newtype RepoBrief = RepoBrief Text
-                   deriving newtype (ToField)
+                   deriving stock (Generic)
+                   deriving newtype (ToField,FromField)
 
 newtype RepoLww = RepoLww (LWWRefKey 'HBS2Basic)
-                  deriving newtype (ToField)
+                  deriving stock (Generic)
+                  deriving newtype (ToField,FromField)
+
+newtype RepoChannel = RepoChannel MyRefChan
+
+instance ToField RepoChannel where
+  toField (RepoChannel x) = toField $ show $ pretty (AsBase58 x)
 
 data TxProcessedTable
 data RepoTable
+data RepoChannelTable
 data RepoNameTable
 data RepoBriefTable
 
+instance HasTableName RepoChannelTable where
+  tableName = "repochannel"
+
 instance HasTableName RepoTable where
   tableName = "repo"
 
@@ -122,9 +150,15 @@ instance HasColumnName RepoName where
 instance HasColumnName RepoBrief where
   columnName = "brief"
 
+instance HasColumnName RepoChannel where
+  columnName = "channel"
+
 instance HasPrimaryKey TxProcessedTable where
   primaryKey = [G.columnName @TxHash]
 
+instance HasPrimaryKey RepoChannelTable where
+  primaryKey = [G.columnName @RepoLww, G.columnName @RepoChannel]
+
 instance HasPrimaryKey RepoTable where
   primaryKey = [G.columnName @RepoLww]
 
@@ -146,10 +180,29 @@ asRefChan = \case
 getIndexEntries :: (DashBoardPerks m, HasConf m, MonadReader DashBoardEnv m) => m [MyRefChan]
 getIndexEntries = do
   conf <- getConf
-
   pure [ s | ListVal [ SymbolVal "index", PRefChan s] <- conf ]
 
 
+data RepoListItem =
+  RepoListItem
+  { rlRepoLww   :: RepoLww
+  , rlRepoName  :: RepoName
+  , rlRepoBrief :: RepoBrief
+  }
+  deriving stock (Generic)
+
+instance FromRow RepoListItem
+
+selectRepoList :: (DashBoardPerks m, MonadReader DashBoardEnv m) => m [RepoListItem]
+selectRepoList = withState do
+  select_ @_ @RepoListItem [qc|select
+                                    r.lww
+                                  , n.name
+                                  , b.brief
+                               from repo r join name n on r.lww = n.lww
+                                           join brief b on b.lww = r.lww
+                              |]
+
 updateIndex :: (DashBoardPerks m, HasConf m, MonadReader DashBoardEnv m) => m ()
 updateIndex = do
   debug "updateIndex"
@@ -196,12 +249,17 @@ updateIndex = do
 
               insert @RepoTable $ onConflictIgnore @RepoTable (Only (RepoLww gitIndexTxRef))
 
+              insert @RepoChannelTable $
+                onConflictIgnore @RepoChannelTable (RepoLww gitIndexTxRef, RepoChannel rc)
+
               -- FIXME: on-conflict-update!
               for_ nm $ \n -> do
-                insert @RepoNameTable $ onConflictIgnore @RepoNameTable (RepoLww gitIndexTxRef, n)
+                insert @RepoNameTable $
+                  onConflictIgnore @RepoNameTable (RepoLww gitIndexTxRef, n)
 
               for_ bri $ \n -> do
-                insert @RepoBriefTable $ onConflictIgnore @RepoBriefTable (RepoLww gitIndexTxRef, n)
+                insert @RepoBriefTable $
+                  onConflictIgnore @RepoBriefTable (RepoLww gitIndexTxRef, n)
 
         lift $ withState $ transactional do
           for_ txs $ \t -> do

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

@@ -1,12 +1,17 @@
 module HBS2.Git.Web.Html.Root where
 
 import HBS2.Prelude
+
+import HBS2.Git.DashBoard.Types
+import HBS2.Git.DashBoard.State
+
 import HBS2.Base58
 import HBS2.Peer.Proto.RefChan.Types
 
 import Data.Config.Suckless
 
 import Control.Monad.Trans.Maybe
+import Control.Monad.Reader
 import Data.Maybe
 import Data.Text qualified as Text
 import Lucid.Base
@@ -43,11 +48,10 @@ rootPage content  = do
 
 
 
-dashboardRootPage :: Monad m => [Syntax c] -> HtmlT m ()
+dashboardRootPage :: (DashBoardPerks m, MonadReader DashBoardEnv m) => HtmlT m ()
-dashboardRootPage syn = rootPage do
+dashboardRootPage = rootPage do
 
-  let channels = mempty
+  items <- lift selectRepoList
-  -- [ mchan | ListVal (SymbolVal "channel" : mchan) <- bro ]
 
   div_ [class_ "container main"] $ do
     nav_ [class_ "left"] $ do
@@ -55,35 +59,87 @@ dashboardRootPage syn = rootPage do
       div_ [class_ "info-block"] "Всякая разная рандомная информация хрен знает, что тут пока выводить"
 
     main_ do
-      for_ channels $ \chan -> void $ runMaybeT do
 
-        let title = headDef "unknown" [ t
+      section_ do
-                                          | ListVal [ SymbolVal "title", LitStrVal t ] <- chan
+        h1_ "Git repositories"
-                                          ]
+        form_ [class_ "search"] do
-        let desc = mconcat [ d
+            input_ [type_ "search", id_ "search"]
-                           | ListVal (SymbolVal "description" : d) <- chan
+            button_ [class_ "search"] mempty
-                           ] & take 5
-
-        rchan <- headMay ( catMaybes
-                       [ fromStringMay @(RefChanId L4Proto) (Text.unpack rc)
-                       | ListVal [SymbolVal "refchan", LitStrVal rc] <- chan
-                       ] ) & toMPlus
 
 
-        let alias = headMay [ x
+      section_ [id_ "repo-search-results"] do
-                            | ListVal [SymbolVal "alias", LitStrVal x] <- chan
-                            ]
 
-        let url = case alias of
+        for_ items $ \RepoListItem{..} -> do
-                    Just x -> Text.unpack x
-                    Nothing -> (show . pretty . AsBase58) rchan
 
-        lift do
+          -- let t = coerce @_ @Word64 listEntrySeq
-          div_ [class_ "channel-list-item"] do
+          -- let h = coerce @_ @(LWWRefKey HBS2Basic) listEntryRef
-            h2_ $ toHtml title
+          -- let n = coerce @_ @(Maybe Text) listEntryName & fromMaybe ""
+          -- let b = coerce @_ @(Maybe Text) listEntryBrief & fromMaybe ""
+          -- let locked = listEntryGK0 & coerce @_ @(Maybe HashRef) & isJust
 
-            p_ $ a_ [href_ (path [url])] (toHtml (show $ pretty $ AsBase58 rchan))
+          -- let days = "updated" <+> if d == 0 then "today" else viaShow d <+> "days ago"
+          --       where d = ( now - t ) `div` 86400
 
-            for_ [ s | LitStrVal s <- desc ] $ \s -> do
+          -- let s = if Text.length n > 2 then n else "unnamed"
-              p_ (toHtml s)
+          -- let refpart = Text.take 8 $ Text.pack $ show $ pretty h
+          -- let sref = show $ pretty h
+          -- let ref =  Text.pack sref
+
+          -- let suff = ["repo", sref]
+
+          -- let url = path (hrefBase <> suff)
+
+          div_ [class_ "repo-list-item"] do
+            div_ [class_ "repo-info", style_ "flex: 1; flex-basis: 70%;"] do
+
+              h2_ $ toHtml rlRepoName
+              -- [class_ "xclip", onClickCopy ref] $ toHtml (s <> "-" <> refpart)
+
+              -- p_ $ a_ [href_ url] (toHtml ref)
+
+              -- renderMarkdown b
+
+            -- div_ [ ] do
+            --   div_ [ class_ "attr" ] do
+            --     div_ [ class_ "attrname"]  (toHtml $ show days)
+
+              -- when locked do
+              --   div_ [ class_ "attr" ] do
+              --     div_ [ class_ "attrval icon"] do
+              --       img_ [src_ "/icon/lock-closed.svg"]
+
+
+
+      pure ()
+      -- 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

@@ -162,6 +162,7 @@ executable hbs2-git-dashboard
         , wai-middleware-static-embedded
         , lucid
         , lucid-htmx
+        , pandoc
         , scotty >= 0.22
 
     hs-source-dirs: