From ac3274e9f79b606e24c0c5b58e16134d1ca15587 Mon Sep 17 00:00:00 2001 From: Dmitry Zuikov Date: Fri, 19 Apr 2024 12:16:24 +0300 Subject: [PATCH] wip --- hbs2-git/hbs2-git-dashboard/GitDashBoard.hs | 19 ++++ .../src/HBS2/Git/DashBoard/State.hs | 89 ++++++++++++++----- .../HBS2/Git/DashBoard/State/Index/Peer.hs | 6 +- .../src/HBS2/Git/Web/Html/Root.hs | 62 +++++-------- 4 files changed, 115 insertions(+), 61 deletions(-) diff --git a/hbs2-git/hbs2-git-dashboard/GitDashBoard.hs b/hbs2-git/hbs2-git-dashboard/GitDashBoard.hs index adff4799..dcfbf364 100644 --- a/hbs2-git/hbs2-git-dashboard/GitDashBoard.hs +++ b/hbs2-git/hbs2-git-dashboard/GitDashBoard.hs @@ -159,6 +159,8 @@ data WebOptions = { _assetsOverride :: Maybe FilePath } +orFall :: m r -> Maybe a -> ContT r m a +orFall a mb = ContT $ maybe1 mb a runDashboardWeb :: WebOptions -> ScottyT (DashBoardM IO) () runDashboardWeb wo = do @@ -175,6 +177,23 @@ runDashboardWeb wo = do get "/" do html =<< lift (renderTextT dashboardRootPage) + get "/repo/:lww" do + lwws' <- captureParam @String "lww" <&> fromStringMay @(LWWRefKey HBS2Basic) + + env <- lift ask + + 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 (repoPage item) + runScotty :: DashBoardPerks m => DashBoardM m () runScotty = do 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 a9c43d8f..61c02018 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,4 +1,5 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE PatternSynonyms #-} @@ -20,15 +21,22 @@ import DBPipe.SQLite.Generic as G import Lucid.Base import Data.Text qualified as Text import Data.Word +import Data.List qualified as List --- import Data.Generics.Generic (genericDataType) +data RepoListPred = + RepoListPred + { _repoListByLww :: Maybe (LWWRefKey 'HBS2Basic) + , _repoListLimit :: Maybe Int + } -import GHC.Generics (Generic) -import Generic.Data -- (gdataDefault, Generically(..)) --- import Data.Data (Data) +makeLenses 'RepoListPred --- import Generics.Deriving.Uniplate qualified as U +instance Semigroup RepoListPred where + (<>) _ b = mempty & set repoListByLww (view repoListByLww b) + & set repoListLimit (view repoListLimit b) +instance Monoid RepoListPred where + mempty = RepoListPred Nothing Nothing type MyRefChan = RefChanId L4Proto @@ -99,6 +107,11 @@ newtype TxHash = TxHash HashRef deriving stock (Generic) deriving newtype (ToField) + +newtype RepoHeadTx = RepoHeadTx HashRef + deriving stock (Generic) + deriving newtype (ToField,FromField,Pretty) + newtype RepoName = RepoName Text deriving stock (Eq,Show,Generic) deriving newtype (ToField,FromField,ToHtml,IsString) @@ -116,7 +129,7 @@ newtype RepoChannel = RepoChannel MyRefChan newtype RepoHeadRef = RepoHeadRef HashRef deriving stock (Generic) - deriving newtype (ToField) + deriving newtype (ToField,FromField) newtype RepoHeadSeq = RepoHeadSeq Word64 @@ -203,6 +216,8 @@ data RepoListItem = RepoListItem { rlRepoLww :: RepoLww , rlRepoSeq :: RepoHeadSeq + , rlRepoHead :: RepoHeadRef + , rlRepoTx :: RepoHeadTx , rlRepoName :: RepoName , rlRepoBrief :: RepoBrief , rlRepoGK0 :: RepoHeadGK0 @@ -218,16 +233,39 @@ rlRepoLwwAsText = instance FromRow RepoListItem -selectRepoList :: (DashBoardPerks m, MonadReader DashBoardEnv m) => m [RepoListItem] -selectRepoList = fmap fixName <$> withState do - select_ @_ @RepoListItem [qc|select r.lww - , r.seq - , r.name - , r.brief - , r.gk0 - from repolistview r - |] + +selectRepoList :: (DashBoardPerks m, MonadReader DashBoardEnv m) => RepoListPred -> m [RepoListItem] +selectRepoList pred = fmap fixName <$> withState do + + let onLww = maybe1 (view repoListByLww pred) mempty $ \w -> [("r.lww = ?", w)] + let claus = onLww + + let where_ | List.null claus = "true" + | otherwise = Text.intercalate " and " (fmap fst claus) + + let limit_ = case view repoListLimit pred of + Nothing -> mempty + Just n -> show $ "limit" <+> pretty n + + let params = fmap snd claus + + let sql = [qc| + select r.lww + , r.seq + , r.repohead + , r.tx + , r.name + , r.brief + , r.gk0 + from repolistview r + where {where_} + {limit_} + |] + + debug $ yellow "selectRepoList" <+> pretty sql + + select @RepoListItem sql params where fixName x@RepoListItem{..} | Text.length (coerce rlRepoName) < 3 = x { rlRepoName = fixed } | otherwise = x @@ -246,6 +284,8 @@ with repolist as ( select r.lww, 0 as seq, + null as repohead, + null as tx, coalesce(n.name, r.lww) as name, coalesce(b.brief, '') as brief, null as gk0 @@ -256,6 +296,8 @@ with repolist as ( select lww, seq, + repohead, + tx, name, brief, gk0 @@ -265,6 +307,8 @@ ranked_repos as ( select lww, seq, + repohead, + tx, name, brief, gk0, @@ -273,20 +317,20 @@ ranked_repos as ( order by seq desc ) -select lww, seq, name, brief, gk0 +select lww, seq, repohead, tx, name, brief, gk0 from ranked_repos where rn = 1; |] - createRepoHeadTable :: DashBoardPerks m => DBPipeM m () createRepoHeadTable = do ddl [qc| create table if not exists repohead ( lww text not null , repohead text not null + , tx text not null , seq integer not null , gk0 text null , name text @@ -312,15 +356,20 @@ instance HasColumnName RepoHeadSeq where instance HasColumnName RepoHeadGK0 where columnName = "gk0" +instance HasColumnName RepoHeadTx where + columnName = "tx" + insertRepoHead :: (DashBoardPerks m, MonadReader DashBoardEnv m) => LWWRefKey 'HBS2Basic - -> HashRef + -> RepoHeadTx + -> RepoHeadRef -> RepoHead -> DBPipeM m () -insertRepoHead lww href rh = do +insertRepoHead lww tx rf rh = do insert @RepoHeadTable $ onConflictIgnore @RepoHeadTable ( RepoLww lww - , RepoHeadRef href + , rf + , tx , RepoHeadSeq (_repoHeadTime rh) , RepoHeadGK0 (_repoHeadGK0 rh) , RepoName (_repoHeadName rh) diff --git a/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/State/Index/Peer.hs b/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/State/Index/Peer.hs index 8d4dc925..e4d7848e 100644 --- a/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/State/Index/Peer.hs +++ b/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/State/Index/Peer.hs @@ -57,11 +57,11 @@ updateIndexFromPeer = do for_ txs $ \(n,tx,blk) -> void $ runMaybeT do (rhh, rhead) <- readRepoHeadFromTx sto tx >>= toMPlus debug $ yellow "found repo head" <+> pretty rhh <+> pretty "for" <+> pretty lw - lift $ S.yield (lw, rhh, rhead) + lift $ S.yield (lw, RepoHeadTx tx, RepoHeadRef rhh, rhead) withState $ transactional do - for_ headz $ \(l, rh, rhead) -> do - insertRepoHead l rh rhead + for_ headz $ \(l, tx, rh, rhead) -> do + insertRepoHead l tx rh rhead -- db <- asks _db 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 714729d8..378437b1 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 @@ -5,23 +5,16 @@ import HBS2.Git.DashBoard.Prelude import HBS2.Git.DashBoard.Types import HBS2.Git.DashBoard.State -import HBS2.Base58 -import HBS2.Peer.Proto.RefChan.Types +import HBS2.Git.Data.Tx.Git -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 import Lucid.Html5 hiding (for_) import Lucid.Htmx +import Control.Applicative import Text.Pandoc hiding (getPOSIXTime) -import Control.Monad.Identity import System.FilePath -import Text.InterpolatedString.Perl6 (q) import Data.Word rootPath :: [String] -> [String] @@ -121,8 +114,9 @@ rootPage content = do dashboardRootPage :: (DashBoardPerks m, MonadReader DashBoardEnv m) => HtmlT m () dashboardRootPage = rootPage do + items <- lift $ selectRepoList mempty + now <- liftIO getPOSIXTime <&> fromIntegral . round - items <- lift selectRepoList div_ [class_ "container main"] $ do nav_ [class_ "left"] $ do @@ -144,36 +138,28 @@ dashboardRootPage = rootPage do toHtml (WithTime now item) - pure () - -- for_ channels $ \chan -> void $ runMaybeT do +repoPage :: (DashBoardPerks m, MonadReader DashBoardEnv m) => RepoListItem -> HtmlT m () +repoPage RepoListItem{..} = rootPage do - -- let title = headDef "unknown" [ t - -- | ListVal [ SymbolVal "title", LitStrVal t ] <- chan - -- ] - -- let desc = mconcat [ d - -- | ListVal (SymbolVal "description" : d) <- chan - -- ] & take 5 + sto <- asks _sto + mhead <- lift $ readRepoHeadFromTx sto (coerce rlRepoTx) - -- rchan <- headMay ( catMaybes - -- [ fromStringMay @(RefChanId L4Proto) (Text.unpack rc) - -- | ListVal [SymbolVal "refchan", LitStrVal rc] <- chan - -- ] ) & toMPlus + let manifest = _repoManifest . snd =<< mhead + + debug $ yellow "HEAD" <+> pretty rlRepoTx + + div_ [class_ "container main"] $ do + nav_ [class_ "left"] $ do + div_ [class_ "info-block"] "Всякая разная рандомная информация хрен знает, что тут пока выводить" + div_ [class_ "info-block"] "Всякая разная рандомная информация хрен знает, что тут пока выводить" + + main_ do + + section_ [id_ "repo-data"] do + h1_ (toHtml $ rlRepoName) + + for_ manifest $ \m -> do + toHtmlRaw (renderMarkdown' m) - -- 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)