wip

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 stock (Eq,Show,Generic)
-                   deriving newtype (ToField,FromField,ToHtml)
+                   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
+  , 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
+selectRepoList = fmap fixName <$> withState do
-  select_ @_ @RepoListItem [qc|select
+  select_ @_ @RepoListItem [qc|select r.lww
-                                    r.lww
+                                    , r.seq
-                                  , n.name
+                                    , r.name
-                                  , b.brief
+                                    , r.brief
-                               from repo r join name n on r.lww = n.lww
+                                    , r.gk0
-                                           join brief b on b.lww = r.lww
+                               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|

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
+        for_ items $ \item@RepoListItem{..} -> do
-
+          toHtml (WithTime now item)
-          -- 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"]
-
 
 
       pure ()

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