From 817fd837bf5f74871019efd6321ee40c36332d66 Mon Sep 17 00:00:00 2001 From: Dmitry Zuikov Date: Fri, 19 Apr 2024 10:45:14 +0300 Subject: [PATCH] wip --- .../src/HBS2/Git/DashBoard/State.hs | 70 ++++++++++---- .../src/HBS2/Git/Web/Html/Root.hs | 94 ++++++++++--------- hbs2-git/hbs2-git.cabal | 3 + 3 files changed, 103 insertions(+), 64 deletions(-) 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 cd65509e..a9c43d8f 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 @@ -21,6 +21,15 @@ import Lucid.Base import Data.Text qualified as Text import Data.Word +-- import Data.Generics.Generic (genericDataType) + +import GHC.Generics (Generic) +import Generic.Data -- (gdataDefault, Generically(..)) +-- import Data.Data (Data) + +-- import Generics.Deriving.Uniplate qualified as U + + type MyRefChan = RefChanId L4Proto @@ -76,6 +85,9 @@ evolveDB = do instance ToField HashRef where toField x = toField $ show $ pretty x +instance FromField HashRef where + fromField = fmap (fromString @HashRef) . fromField @String + instance Pretty (AsBase58 (PubKey 'Sign s)) => ToField (LWWRefKey s) where toField x = toField $ show $ pretty (AsBase58 x) @@ -88,8 +100,8 @@ newtype TxHash = TxHash HashRef deriving newtype (ToField) newtype RepoName = RepoName Text - deriving stock (Generic) - deriving newtype (ToField,FromField,ToHtml) + deriving stock (Eq,Show,Generic) + deriving newtype (ToField,FromField,ToHtml,IsString) newtype RepoBrief = RepoBrief Text deriving stock (Generic) @@ -97,7 +109,7 @@ newtype RepoBrief = RepoBrief Text newtype RepoLww = RepoLww (LWWRefKey 'HBS2Basic) deriving stock (Generic) - deriving newtype (ToField,FromField) + deriving newtype (ToField,FromField,Pretty) newtype RepoChannel = RepoChannel MyRefChan @@ -109,12 +121,12 @@ newtype RepoHeadRef = RepoHeadRef HashRef newtype RepoHeadSeq = RepoHeadSeq Word64 deriving stock (Generic) - deriving newtype (ToField) + deriving newtype (ToField,FromField) newtype RepoHeadGK0 = RepoHeadGK0 (Maybe HashRef) deriving stock (Generic) - deriving newtype (ToField) + deriving newtype (ToField,FromField) instance ToField RepoChannel where toField (RepoChannel x) = toField $ show $ pretty (AsBase58 x) @@ -185,28 +197,41 @@ getIndexEntries = do pure [ s | ListVal [ SymbolVal "index", PRefChan s] <- conf ] +data NiceTS = NiceTS + data RepoListItem = RepoListItem - { rlRepoLww :: RepoLww - , rlRepoName :: RepoName - , rlRepoBrief :: RepoBrief + { rlRepoLww :: RepoLww + , rlRepoSeq :: RepoHeadSeq + , rlRepoName :: RepoName + , rlRepoBrief :: RepoBrief + , rlRepoGK0 :: RepoHeadGK0 } deriving stock (Generic) +-- deriving instance Data RepoListItem via Generically RepoListItem + +rlRepoLwwAsText :: SimpleGetter RepoListItem Text +rlRepoLwwAsText = + to \RepoListItem{..} -> do + Text.pack $ show $ pretty $ rlRepoLww + 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 +selectRepoList = fmap fixName <$> withState do + select_ @_ @RepoListItem [qc|select r.lww + , r.seq + , r.name + , r.brief + , r.gk0 + from repolistview r |] - - + where + fixName x@RepoListItem{..} | Text.length (coerce rlRepoName) < 3 = x { rlRepoName = fixed } + | otherwise = x + where fixed = Text.pack (show $ pretty (coerce @_ @(LWWRefKey 'HBS2Basic) rlRepoLww) ) & RepoName createRepoListView :: DashBoardPerks m => DBPipeM m () createRepoListView = do @@ -222,7 +247,8 @@ with repolist as ( r.lww, 0 as seq, coalesce(n.name, r.lww) as name, - coalesce(b.brief, '') as brief + coalesce(b.brief, '') as brief, + null as gk0 from repo r left join name n on r.lww = n.lww left join brief b on r.lww = b.lww @@ -231,7 +257,8 @@ with repolist as ( lww, seq, name, - brief + brief, + gk0 from repohead ), ranked_repos as ( @@ -240,17 +267,20 @@ ranked_repos as ( seq, name, brief, + gk0, row_number() over (partition by lww order by seq desc) as rn from repolist + order by seq desc ) -select lww, seq, name, brief +select lww, seq, name, brief, gk0 from ranked_repos where rn = 1; |] + createRepoHeadTable :: DashBoardPerks m => DBPipeM m () createRepoHeadTable = do ddl [qc| 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 031672a8..714729d8 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,8 +1,7 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module HBS2.Git.Web.Html.Root where -import HBS2.Prelude - +import HBS2.Git.DashBoard.Prelude import HBS2.Git.DashBoard.Types import HBS2.Git.DashBoard.State @@ -17,11 +16,13 @@ import Data.Maybe import Data.Text qualified as Text import Lucid.Base import Lucid.Html5 hiding (for_) +import Lucid.Htmx import Text.Pandoc hiding (getPOSIXTime) import Control.Monad.Identity import System.FilePath import Text.InterpolatedString.Perl6 (q) +import Data.Word rootPath :: [String] -> [String] rootPath = ("/":) @@ -33,8 +34,12 @@ myCss :: Monad m => HtmlT m () myCss = do link_ [rel_ "stylesheet", href_ (path ["css/custom.css"])] +hyper_ :: Text -> Attribute +hyper_ = makeAttribute "_" - +onClickCopy :: Text -> Attribute +onClickCopy s = + hyper_ [qc|on click writeText('{s}') into the navigator's clipboard add .clicked to me wait 2s remove .clicked from me|] markdownToHtml :: Text -> Either PandocError String markdownToHtml markdown = runPure $ do @@ -54,7 +59,45 @@ renderMarkdown markdown = case markdownToHtml markdown of instance ToHtml RepoBrief where toHtml (RepoBrief txt) = toHtmlRaw (renderMarkdown' txt) - toHtmlRaw (RepoBrief txt) = toHtmlRaw ("JOPA:" <> renderMarkdown' txt) + toHtmlRaw (RepoBrief txt) = toHtmlRaw (renderMarkdown' txt) + +data WithTime a = WithTime Integer a + +instance ToHtml (WithTime RepoListItem) where + toHtmlRaw = pure mempty + + toHtml (WithTime t it@RepoListItem{..}) = do + + let now = t + + let locked = isJust $ coerce @_ @(Maybe HashRef) rlRepoGK0 + + let url = path ["repo", Text.unpack $ view rlRepoLwwAsText it] + let t = fromIntegral $ coerce @_ @Word64 rlRepoSeq + + let updated = "" <+> d + where + sec = now - t + d | sec > 86400 = pretty (sec `div` 86400) <+> "days ago" + | sec > 3600 = pretty (sec `div` 3600) <+> "hours ago" + | otherwise = pretty (sec `div` 60) <+> "minutes ago" + + div_ [class_ "repo-list-item"] do + div_ [class_ "repo-info", style_ "flex: 1; flex-basis: 70%;"] do + + h2_ [class_ "xclip", onClickCopy (view rlRepoLwwAsText it)] $ toHtml rlRepoName + p_ $ a_ [href_ url] (toHtml $ view rlRepoLwwAsText it) + + toHtml rlRepoBrief + + div_ [ ] do + div_ [ class_ "attr" ] do + div_ [ class_ "attrname"] (toHtml $ show updated) + + when locked do + div_ [ class_ "attr" ] do + div_ [ class_ "attrval icon"] do + img_ [src_ "/icon/lock-closed.svg"] rootPage :: Monad m => HtmlT m () -> HtmlT m () rootPage content = do @@ -78,6 +121,7 @@ rootPage content = do dashboardRootPage :: (DashBoardPerks m, MonadReader DashBoardEnv m) => HtmlT m () dashboardRootPage = rootPage do + now <- liftIO getPOSIXTime <&> fromIntegral . round items <- lift selectRepoList div_ [class_ "container main"] $ do @@ -96,46 +140,8 @@ dashboardRootPage = rootPage do section_ [id_ "repo-search-results"] do - for_ items $ \RepoListItem{..} -> do - - -- 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 - - -- let days = "updated" <+> if d == 0 then "today" else viaShow d <+> "days ago" - -- where d = ( now - t ) `div` 86400 - - -- 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) - - toHtml rlRepoBrief - -- 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"] - + for_ items $ \item@RepoListItem{..} -> do + toHtml (WithTime now item) pure () diff --git a/hbs2-git/hbs2-git.cabal b/hbs2-git/hbs2-git.cabal index d8c8dff6..64a2ad0c 100644 --- a/hbs2-git/hbs2-git.cabal +++ b/hbs2-git/hbs2-git.cabal @@ -156,6 +156,9 @@ executable hbs2-git-dashboard build-depends: base, hbs2-git-dashboard-assets, hbs2-peer, hbs2-git, suckless-conf , binary + , generic-deriving + , generic-data + , deriving-compat , vector , optparse-applicative , http-types