wip

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

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)
+makeLenses 'RepoListPred
-import Generic.Data -- (gdataDefault, Generically(..))
--- import Data.Data (Data)
 
--- 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
+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)

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
+        for_ headz $ \(l, tx, rh, rhead) -> do
-          insertRepoHead l rh rhead
+          insertRepoHead l tx rh rhead
 
   -- db <- asks _db
 

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.Git.Data.Tx.Git
-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
 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 ()
+repoPage :: (DashBoardPerks m, MonadReader DashBoardEnv m) => RepoListItem -> HtmlT m ()
-      -- for_ channels $ \chan -> void $ runMaybeT do
+repoPage RepoListItem{..} = rootPage do
 
-      --   let title = headDef "unknown" [ t
+  sto <- asks _sto
-      --                                     | ListVal [ SymbolVal "title", LitStrVal t ] <- chan
+  mhead <- lift $ readRepoHeadFromTx sto (coerce rlRepoTx)
-      --                                     ]
-      --   let desc = mconcat [ d
-      --                      | ListVal (SymbolVal "description" : d) <- chan
-      --                      ] & take 5
 
-      --   rchan <- headMay ( catMaybes
+  let manifest = _repoManifest . snd =<< mhead
-      --                  [ fromStringMay @(RefChanId L4Proto) (Text.unpack rc)
+
-      --                  | ListVal [SymbolVal "refchan", LitStrVal rc] <- chan
+  debug $ yellow "HEAD" <+> pretty rlRepoTx
-      --                  ] ) & toMPlus
+
+  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)