wip

hbs2-browser/assets/icon/lock-closed.svg

@@ -0,0 +1,7 @@
+<svg xmlns="http://www.w3.org/2000/svg" class="icon icon-tabler icon-tabler-lock" width="24" height="24" viewBox="0 0 24 24" stroke-width="1.5" stroke="#2c3e50" fill="none" stroke-linecap="round" stroke-linejoin="round">
+  <path stroke="none" d="M0 0h24v24H0z" fill="none"/>
+  <path d="M5 13a2 2 0 0 1 2 -2h10a2 2 0 0 1 2 2v6a2 2 0 0 1 -2 2h-10a2 2 0 0 1 -2 -2v-6z" />
+  <path d="M11 16a1 1 0 1 0 2 0a1 1 0 0 0 -2 0" />
+  <path d="M8 11v-4a4 4 0 1 1 8 0v4" />
+</svg>
+

hbs2-browser/lib/HBS2/Peer/Browser/Assets.hs

@@ -6,7 +6,7 @@ import Data.FileEmbed
 import Data.ByteString
 
 version :: Int
-version = 6
+version = 7
 
 cssDir :: [(FilePath, ByteString)]
 cssDir = $(embedDir "assets")

hbs2-git/hbs2-git-oracle/lib/DBPipe/SQLite/Generic.hs

@@ -8,6 +8,7 @@ import DBPipe.SQLite qualified as SQL
 import DBPipe.SQLite hiding (insert,columnName)
 
 import GHC.Generics
+import Data.Proxy
 import Data.Text qualified as Text
 import Data.Text (Text)
 import Data.String (IsString(..))
@@ -19,10 +20,13 @@ newtype SQLName = SQLName Text
                   deriving stock (Eq,Ord)
                   deriving newtype (IsString,Monoid,Semigroup,Show)
 
-newtype SQLPart = SQLPart Text
+newtype SQLPart = SQLPart { fromSQL :: Text }
                   deriving stock (Eq,Ord)
                   deriving newtype (IsString,Monoid,Semigroup,Show)
 
+data AllColumns a = AllColumns
+                    deriving stock (Generic)
+
 class ToSQL a where
   toSQL :: a -> SQLPart
 
@@ -67,6 +71,42 @@ instance HasColumnName c => GHasColumnNames (K1 i c) where
 instance GHasColumnNames a => GHasColumnNames (M1 i t a) where
   gColumnNames (M1 a) = gColumnNames a
 
+
+class GColumnNames f where
+  gColumnNames1 :: [SQLName]
+
+instance GColumnNames U1 where
+  gColumnNames1 = []
+
+instance (GColumnNames a, GColumnNames b) => GColumnNames (a :+: b) where
+  gColumnNames1 = gColumnNames1 @a ++ gColumnNames1 @b
+
+instance (GColumnNames a, GColumnNames b) => GColumnNames (a :*: b) where
+  gColumnNames1 = gColumnNames1 @a ++ gColumnNames1 @b
+
+instance (Selector s, HasColumnName c) => GColumnNames (M1 S s (K1 i c)) where
+  gColumnNames1 = [columnName @c]
+
+instance GColumnNames a => GColumnNames (M1 D d a) where
+  gColumnNames1 = gColumnNames1 @a
+
+instance GColumnNames a => GColumnNames (M1 C c a) where
+  gColumnNames1 = gColumnNames1 @a
+
+instance (Generic a, GColumnNames (Rep a)) => HasColumnNames (AllColumns a) where
+  columnNames _ = gColumnNames1 @(Rep a)
+
+-- -- Реализация GHasColumnNames для AllColumns a
+-- instance (Generic a, GHasColumnNames (Rep a)) => GHasColumnNames AllColumns where
+--   gColumnNames _ = gColumnNames (from (undefined :: a))
+
+-- -- Функция для получения списка имен колонок через AllColumns
+-- columnNamesForAll :: forall a. (Generic a, GHasColumnNames AllColumns) => [SQLName]
+-- columnNamesForAll = gColumnNames (AllColumns @a)
+
+-- Пример использования этой функции:
+-- myList = columnNamesFor (Proxy :: Proxy GitRepoListEntry)
+
 data Bound = forall a . ToField a => Bound a
 
 class GToBoundList f where
@@ -107,6 +147,10 @@ newtype OnCoflictIgnore t r = OnCoflictIgnore r
 instance (HasPrimaryKey t, HasColumnNames r) => HasColumnNames (OnCoflictIgnore t r) where
   columnNames (OnCoflictIgnore r) = columnNames r
 
+-- instance (HasColumnNames r) => HasColumnNames (AllColumns r) where
+  -- columnNames _ = gColumnNames @r
+  -- columnNames AllColumns = columnNames r
+
 onConflictIgnore :: (HasTableName t, HasColumnNames r) => r -> OnCoflictIgnore t r
 onConflictIgnore = OnCoflictIgnore
 

hbs2-git/hbs2-git-oracle/lib/HBS2/Git/Oracle/Facts.hs

@@ -10,6 +10,7 @@ import HBS2.Hash
 import DBPipe.SQLite
 import DBPipe.SQLite.Generic
 
+import Data.Aeson
 import GHC.Generics
 import Data.Word
 
@@ -29,7 +30,7 @@ newtype GitLwwRef  = GitLwwRef (LWWRefKey HBS2Basic)
 
 newtype GitLwwSeq  = GitLwwSeq Word64
                      deriving stock (Generic,Data)
-                     deriving newtype (ToField)
+                     deriving newtype (ToField,FromField,ToJSON)
 
 
 newtype GitRepoHeadSeq = GitRepoHeadSeq Word64
@@ -62,7 +63,23 @@ newtype GitManifest = GitManifest (Maybe Text)
 
 newtype GitEncrypted = GitEncrypted (Maybe HashRef)
                        deriving stock (Generic,Data)
-                       deriving newtype (ToField)
+                       deriving newtype (ToField, FromField)
+
+
+instance ToJSON GitLwwRef where
+  toJSON (GitLwwRef k) = toJSON $ show $ pretty k
+
+instance ToJSON GitRepoHeadRef where
+  toJSON (GitRepoHeadRef k) = toJSON $ show $ pretty k
+
+instance ToJSON GitEncrypted where
+  toJSON (GitEncrypted k) = toJSON $ show . pretty <$> k
+
+instance ToJSON GitBrief where
+  toJSON (GitBrief k) = toJSON $ show . pretty <$> k
+
+instance ToJSON GitName where
+  toJSON (GitName k) = toJSON $ show . pretty <$> k
 
 data Facts
 

hbs2-git/hbs2-git-oracle/lib/HBS2/Git/Oracle/Html.hs

@@ -60,7 +60,7 @@ 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|]
 
-renderEntries :: MonadIO m => PluginMethod -> [(HashVal, Text, Text, Word64)] -> m ByteString
+renderEntries :: MonadIO m => PluginMethod -> [GitRepoListEntry] -> m ByteString
 renderEntries (Method _ kw) items = do
 
   now  <- liftIO getPOSIXTime <&> fromIntegral . round
@@ -82,7 +82,13 @@ renderEntries (Method _ kw) items = do
 
             section_ [id_ "repo-search-results"] do
 
-              for_ items $ \(h,n,b,t) -> do
+              for_ items $ \GitRepoListEntry{..} -> 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
@@ -105,8 +111,14 @@ renderEntries (Method _ kw) items = do
 
                     renderMarkdown b
 
-                  div_ [ class_ "attr" ] do
-                    div_ [ class_ "attrname"]  (toHtml $ show days)
+                  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"]
 
 
 wrapped :: Monad m => HtmlT m a -> HtmlT m a
@@ -165,6 +177,18 @@ renderRepoHtml (Method _ kw) page@(GitRepoPage{..}) = pure $ renderBS $ wrapped
         div_ [class_ "attrval", style_ "align: left; width: 20rem;"] do
           span_ [class_ "xclip", onClickCopy ref] (toHtml ref)
 
+      div_  [class_ "attr"] do
+
+        let gk' = headMay [ gk0 | GitEncrypted gk0 <- universeBi page ]
+                   & join <&> Text.pack . show . pretty
+
+        for gk' $ \gk -> do
+          div_ [class_ "attrname"] "encrypted"
+
+          div_ [class_ "attrval", style_ "align: left; width: 20rem;"] do
+            span_ [class_ "xclip", onClickCopy gk] (toHtml gk)
+
+
     section_ [id_ "repo-data"] do
       for_ name' $ \name -> do
         h1_ (toHtml name)

hbs2-git/hbs2-git-oracle/lib/HBS2/Git/Oracle/Run.hs

@@ -24,7 +24,8 @@ import HBS2.Git.Data.Tx
 import HBS2.Peer.HTTP.Root
 import HBS2.Peer.Proto.BrowserPlugin
 
-import DBPipe.SQLite
+import DBPipe.SQLite hiding (columnName)
+import DBPipe.SQLite.Generic
 
 import Data.ByteString.Lazy (ByteString)
 
@@ -255,26 +256,12 @@ instance (MonadUnliftIO m, HasOracleEnv m) => HandleMethod m RpcChannelQuery whe
 
       listEntries (Method _ a) = do
         env <- getOracleEnv
+
         withOracleEnv env do
-          items <- withState $ select_ @_ @(HashVal, Text, Text, Word64) [qc|
-
-              SELECT
-                lwwref,
-                name,
-                brief,
-                repoheadseq
-              FROM (
-                SELECT
-                  lwwref,
-                  name,
-                  brief,
-                  repoheadseq,
-                  ROW_NUMBER() OVER (PARTITION BY lwwref ORDER BY lwwseq DESC, repoheadseq DESC) as rn
-                FROM gitrepofact
-              ) as s0
-              WHERE rn = 1;
-
-                   |]
+          items <- withState $ select_ @_ @GitRepoListEntry [qc|
+              SELECT {fromSQL $ columnListPart (AllColumns @GitRepoListEntry)}
+              FROM vrepofact
+              |]
 
           case HM.lookup "OUTPUT" a of
             Just "html" -> formatHtml items
@@ -302,7 +289,9 @@ instance (MonadUnliftIO m, HasOracleEnv m) => HandleMethod m RpcChannelQuery whe
                              , v.name
                              , v.brief
                              , m.manifest
-                       from vrepofact v left join gitrepomanifest m on v.repohead = m.repohead
+                             , v.gk
+                       from vrepofact v left
+                             join gitrepomanifest m on v.repohead = m.repohead
                        where v.lwwref = ?
                        limit 1
                        |] (Only ref)

hbs2-git/hbs2-git-oracle/lib/HBS2/Git/Oracle/State.hs

@@ -26,11 +26,28 @@ data GitRepoPage =
   , repoPageName     :: GitName
   , repoPageBrief    :: GitBrief
   , repoPageManifest :: GitManifest
+  , repoPageGK0      :: GitEncrypted
   }
   deriving stock (Generic,Data)
 
 instance FromRow GitRepoPage
 
+
+data GitRepoListEntry =
+  GitRepoListEntry
+  { listEntryRef   :: GitLwwRef
+  , listEntrySeq   :: GitLwwSeq
+  , listEntryHead  :: GitRepoHeadRef
+  , listEntryName  :: GitName
+  , listEntryBrief :: GitBrief
+  , listEntryGK0   :: GitEncrypted
+  }
+  deriving stock (Generic,Data)
+
+instance ToJSON GitRepoListEntry
+
+instance FromRow GitRepoListEntry
+
 processedRepoTx :: (LWWRefKey HBS2Basic, HashRef) -> HashVal
 processedRepoTx w = HashVal $ HashRef $ hashObject @HbSync (serialise w)
 
@@ -82,14 +99,16 @@ gitRepoManifestTable = do
 
 gitRepoFactView :: MonadUnliftIO m => DBPipeM m ()
 gitRepoFactView = do
+  ddl [qc|DROP VIEW IF EXISTS vrepofact|]
   ddl [qc|
     CREATE VIEW IF NOT EXISTS vrepofact AS
     SELECT
       lwwref,
+      repoheadseq as lwwseq,
       repohead,
       name,
       brief,
-      repoheadseq
+      gk
     FROM (
       SELECT
         lwwref,
@@ -97,6 +116,7 @@ gitRepoFactView = do
         name,
         brief,
         repoheadseq,
+        gk,
         ROW_NUMBER() OVER (PARTITION BY lwwref ORDER BY lwwseq DESC, repoheadseq DESC) as rn
       FROM gitrepofact
     ) as s0

hbs2-peer/app/Browser/Root.hs

@@ -241,11 +241,16 @@ div .repo-list-item {
 }
 
 .attrval {
-  text-align: left;
   flex-basis: 70%;
   text-align: right;
 }
 
+.icon {
+  flex-basis: 90%;
+  text-align: right;
+}
+
+
 form.search {
   display: flex;
   align-items: center;