voidlizard
/
hbs2
mirror of https://github.com/voidlizard/hbs2
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

wip

This commit is contained in:
Dmitry Zuikov 2024-04-05 13:46:33 +03:00
parent ff94ef96f2
commit 6a3197c794
8 changed files with 137 additions and 31 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
hbs2-browser/assets/icon/lock-closed.svg Normal file
View File

@ -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>
Side by Side

After

Width:  |  Height:  |  Size: 468 B

2
hbs2-browser/lib/HBS2/Peer/Browser/Assets.hs
View File

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

46
hbs2-git/hbs2-git-oracle/lib/DBPipe/SQLite/Generic.hs
View File

@ -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

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

@ -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

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

@ -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)

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

@ -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)

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

@ -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

7
hbs2-peer/app/Browser/Root.hs
View File

@ -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;