diff --git a/hbs2-browser/assets/icon/lock-closed.svg b/hbs2-browser/assets/icon/lock-closed.svg new file mode 100644 index 00000000..5d7c4d6f --- /dev/null +++ b/hbs2-browser/assets/icon/lock-closed.svg @@ -0,0 +1,7 @@ + + + + + + + diff --git a/hbs2-browser/lib/HBS2/Peer/Browser/Assets.hs b/hbs2-browser/lib/HBS2/Peer/Browser/Assets.hs index 80fb5fcc..aa00bf3f 100644 --- a/hbs2-browser/lib/HBS2/Peer/Browser/Assets.hs +++ b/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") diff --git a/hbs2-git/hbs2-git-oracle/lib/DBPipe/SQLite/Generic.hs b/hbs2-git/hbs2-git-oracle/lib/DBPipe/SQLite/Generic.hs index 14d8abff..174ac347 100644 --- a/hbs2-git/hbs2-git-oracle/lib/DBPipe/SQLite/Generic.hs +++ b/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 diff --git a/hbs2-git/hbs2-git-oracle/lib/HBS2/Git/Oracle/Facts.hs b/hbs2-git/hbs2-git-oracle/lib/HBS2/Git/Oracle/Facts.hs index 5ae10457..ea21029e 100644 --- a/hbs2-git/hbs2-git-oracle/lib/HBS2/Git/Oracle/Facts.hs +++ b/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 diff --git a/hbs2-git/hbs2-git-oracle/lib/HBS2/Git/Oracle/Html.hs b/hbs2-git/hbs2-git-oracle/lib/HBS2/Git/Oracle/Html.hs index d257b552..a9d08103 100644 --- a/hbs2-git/hbs2-git-oracle/lib/HBS2/Git/Oracle/Html.hs +++ b/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) diff --git a/hbs2-git/hbs2-git-oracle/lib/HBS2/Git/Oracle/Run.hs b/hbs2-git/hbs2-git-oracle/lib/HBS2/Git/Oracle/Run.hs index 40cc5c2c..7ba8d1fc 100644 --- a/hbs2-git/hbs2-git-oracle/lib/HBS2/Git/Oracle/Run.hs +++ b/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) diff --git a/hbs2-git/hbs2-git-oracle/lib/HBS2/Git/Oracle/State.hs b/hbs2-git/hbs2-git-oracle/lib/HBS2/Git/Oracle/State.hs index b5f7a6bf..0ba1612d 100644 --- a/hbs2-git/hbs2-git-oracle/lib/HBS2/Git/Oracle/State.hs +++ b/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 diff --git a/hbs2-peer/app/Browser/Root.hs b/hbs2-peer/app/Browser/Root.hs index 37562b78..5251aea6 100644 --- a/hbs2-peer/app/Browser/Root.hs +++ b/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;