From af847eae059f4b39c27d88a79516b30adb893309 Mon Sep 17 00:00:00 2001 From: Dmitry Zuikov Date: Thu, 18 Apr 2024 17:51:49 +0300 Subject: [PATCH] wip --- cabal.project | 2 + hbs2-fixer/hbs2-fixer.cabal | 1 - hbs2-git/hbs2-git-dashboard/GitDashBoard.hs | 2 +- .../src/HBS2/Git/DashBoard/State.hs | 70 ++++++++++- .../src/HBS2/Git/Web/Html/Root.hs | 112 +++++++++++++----- hbs2-git/hbs2-git.cabal | 1 + 6 files changed, 152 insertions(+), 36 deletions(-) diff --git a/cabal.project b/cabal.project index 42ba3ea8..e23d8cda 100644 --- a/cabal.project +++ b/cabal.project @@ -3,6 +3,8 @@ packages: **/*.cabal allow-newer: all +constraints: pandoc ==3.1.11 + -- executable-static: True -- profiling: True -- library-profiling: False diff --git a/hbs2-fixer/hbs2-fixer.cabal b/hbs2-fixer/hbs2-fixer.cabal index e6aa884f..01beff6a 100644 --- a/hbs2-fixer/hbs2-fixer.cabal +++ b/hbs2-fixer/hbs2-fixer.cabal @@ -68,7 +68,6 @@ common shared-properties , streaming , streaming-bytestring , streaming-commons - , streaming-utils , cryptonite , directory , exceptions diff --git a/hbs2-git/hbs2-git-dashboard/GitDashBoard.hs b/hbs2-git/hbs2-git-dashboard/GitDashBoard.hs index ff34b851..5e54893d 100644 --- a/hbs2-git/hbs2-git-dashboard/GitDashBoard.hs +++ b/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 () diff --git a/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/State.hs b/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/State.hs index 013d4464..20749e0a 100644 --- a/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/State.hs +++ b/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 diff --git a/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/Web/Html/Root.hs b/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/Web/Html/Root.hs index 1a20c472..af4b3c10 100644 --- a/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/Web/Html/Root.hs +++ b/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 syn = rootPage do +dashboardRootPage :: (DashBoardPerks m, MonadReader DashBoardEnv m) => HtmlT m () +dashboardRootPage = rootPage do - let channels = mempty - -- [ mchan | ListVal (SymbolVal "channel" : mchan) <- bro ] + items <- lift selectRepoList 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 - | 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 + section_ do + h1_ "Git repositories" + form_ [class_ "search"] do + input_ [type_ "search", id_ "search"] + button_ [class_ "search"] mempty - let alias = headMay [ x - | ListVal [SymbolVal "alias", LitStrVal x] <- chan - ] + section_ [id_ "repo-search-results"] do - let url = case alias of - Just x -> Text.unpack x - Nothing -> (show . pretty . AsBase58) rchan + for_ items $ \RepoListItem{..} -> do - lift do - div_ [class_ "channel-list-item"] do - h2_ $ toHtml title + -- let t = coerce @_ @Word64 listEntrySeq + -- let h = coerce @_ @(LWWRefKey HBS2Basic) listEntryRef + -- 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 - p_ (toHtml s) + -- let s = if Text.length n > 2 then n else "unnamed" + -- 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) diff --git a/hbs2-git/hbs2-git.cabal b/hbs2-git/hbs2-git.cabal index 063a0b83..4920c5fb 100644 --- a/hbs2-git/hbs2-git.cabal +++ b/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: