mirror of https://github.com/voidlizard/hbs2
wip
This commit is contained in:
Dmitry Zuikov
parent
179f85545b
commit
ced6892a31
|
|
@ -89,7 +89,7 @@ nav.left {
|
|||
}
|
||||
|
||||
nav.left .info-block {
|
||||
margin-bottom: 4rem;
|
||||
margin-bottom: 2rem;
|
||||
padding-left: 1em;
|
||||
padding-right: 1.2em;
|
||||
}
|
||||
|
|
|
|||
File diff suppressed because one or more lines are too long
|
After Width: | Height: | Size: 29 KiB |
File diff suppressed because one or more lines are too long
|
After Width: | Height: | Size: 28 KiB |
|
|
@ -376,7 +376,7 @@ updateIndexPeriodially = do
|
|||
debug $ red "SYNC" <+> pretty cmd
|
||||
void $ runProcess $ shell cmd
|
||||
|
||||
lift $ buildCommitTreeIndex dir
|
||||
lift $ buildCommitTreeIndex (coerce lww)
|
||||
|
||||
|
||||
main :: IO ()
|
||||
|
|
|
|||
|
|
@ -105,6 +105,7 @@ evolveDB = do
|
|||
|
||||
createRepoTreeIndexTable
|
||||
createRepoBlobIndexTable
|
||||
createRepoCommitTable
|
||||
|
||||
|
||||
instance ToField GitHash where
|
||||
|
|
@ -185,6 +186,7 @@ data RepoTable
|
|||
data RepoChannelTable
|
||||
data RepoNameTable
|
||||
data RepoBriefTable
|
||||
data RepoCommitTable
|
||||
|
||||
instance HasTableName RepoChannelTable where
|
||||
tableName = "repochannel"
|
||||
|
|
@ -201,6 +203,9 @@ instance HasTableName RepoBriefTable where
|
|||
instance HasTableName TxProcessedTable where
|
||||
tableName = "processed"
|
||||
|
||||
instance HasTableName RepoCommitTable where
|
||||
tableName = "repocommit"
|
||||
|
||||
instance HasColumnName TxHash where
|
||||
columnName = "hash"
|
||||
|
||||
|
|
@ -222,6 +227,9 @@ instance HasColumnName RepoRefLog where
|
|||
instance HasColumnName RepoChannel where
|
||||
columnName = "channel"
|
||||
|
||||
instance HasColumnName RepoCommit where
|
||||
columnName = "kommit"
|
||||
|
||||
instance HasPrimaryKey TxProcessedTable where
|
||||
primaryKey = [G.columnName @TxHash]
|
||||
|
||||
|
|
@ -237,6 +245,8 @@ instance HasPrimaryKey RepoNameTable where
|
|||
instance HasPrimaryKey RepoBriefTable where
|
||||
primaryKey = [G.columnName @RepoLww]
|
||||
|
||||
instance HasPrimaryKey RepoCommitTable where
|
||||
primaryKey = [G.columnName @RepoLww, G.columnName @RepoCommit]
|
||||
|
||||
pattern PRefChan :: MyRefChan -> Syntax C
|
||||
pattern PRefChan s <- ListVal [ SymbolVal "refchan" , asRefChan -> Just s ]
|
||||
|
|
@ -457,6 +467,15 @@ createRepoTreeIndexTable = do
|
|||
|]
|
||||
|
||||
|
||||
createRepoCommitTable :: (DashBoardPerks m) => DBPipeM m ()
|
||||
createRepoCommitTable = do
|
||||
ddl [qc|
|
||||
create table if not exists repocommit
|
||||
( lww text not null
|
||||
, kommit text not null
|
||||
, primary key (lww,kommit)
|
||||
)
|
||||
|]
|
||||
|
||||
|
||||
isProcessed :: (DashBoardPerks m) => HashRef -> DBPipeM m Bool
|
||||
|
|
@ -473,6 +492,9 @@ insertProcessed href = do
|
|||
|] (Only href)
|
||||
|
||||
|
||||
newtype RepoCommit = RepoCommit GitHash
|
||||
deriving newtype (FromField,ToField,Pretty)
|
||||
|
||||
newtype TreeCommit = TreeCommit GitHash
|
||||
deriving newtype (FromField,ToField,Pretty)
|
||||
|
||||
|
|
@ -620,8 +642,10 @@ readBlob repo hash = do
|
|||
<&> fromRight mempty
|
||||
|
||||
|
||||
buildCommitTreeIndex :: (DashBoardPerks m, MonadReader DashBoardEnv m) => FilePath -> m ()
|
||||
buildCommitTreeIndex dir = do
|
||||
buildCommitTreeIndex :: (DashBoardPerks m, MonadReader DashBoardEnv m) => LWWRefKey 'HBS2Basic -> m ()
|
||||
buildCommitTreeIndex lww = do
|
||||
|
||||
dir <- repoDataPath lww
|
||||
|
||||
let syntaxMap = Sky.defaultSyntaxMap
|
||||
|
||||
|
|
@ -634,75 +658,81 @@ buildCommitTreeIndex dir = do
|
|||
|
||||
withState do
|
||||
|
||||
for_ commits $ \co -> void $ runMaybeT do
|
||||
let hkey = ("commit-for-tree-index", co) & serialise & hashObject @HbSync & HashRef
|
||||
for_ commits $ \co -> do
|
||||
let hkey = ("commit-for-tree-index", co, lww) & serialise & hashObject @HbSync & HashRef
|
||||
|
||||
done <- lift $ isProcessed hkey
|
||||
here <- (select [qc|select 1 from repocommit where lww = ? and kommit = ?|] (lww, co))
|
||||
<&> listToMaybe @(Only Int) <&> isJust
|
||||
|
||||
guard (not done)
|
||||
unless here do
|
||||
|
||||
let cmd = [qc|git --git-dir {dir} cat-file commit {pretty co}|]
|
||||
transactional do
|
||||
|
||||
root <- gitRunCommand cmd
|
||||
<&> fromRight mempty
|
||||
<&> LBS8.lines
|
||||
<&> \case
|
||||
(TreeHash ha : _) -> Just ha
|
||||
_ -> Nothing
|
||||
>>= toMPlus
|
||||
insert @RepoCommitTable $ onConflictIgnore @RepoCommitTable (RepoLww lww, RepoCommit co)
|
||||
|
||||
lift $ transactional do
|
||||
let cmd = [qc|git --git-dir {dir} cat-file commit {pretty co}|]
|
||||
|
||||
items <- gitRunCommand [qc|git --git-dir {dir} ls-tree -l -r -t {pretty co}|]
|
||||
<&> fromRight mempty
|
||||
<&> fmap LBS8.words . LBS8.lines
|
||||
<&> mapMaybe \case
|
||||
[_,"tree",h,_,n] ->
|
||||
(reverse $ splitDirectories $ LBS8.unpack n,) <$> fmap Right (fromStringMay @GitHash (LBS8.unpack h))
|
||||
root' <- gitRunCommand cmd
|
||||
<&> fromRight mempty
|
||||
<&> LBS8.lines
|
||||
<&> \case
|
||||
(TreeHash ha : _) -> Just ha
|
||||
_ -> Nothing
|
||||
|
||||
[_,"blob",h,size,n] -> do
|
||||
let fn = headMay (reverse $ splitDirectories $ LBS8.unpack n)
|
||||
<&> List.singleton
|
||||
items <- gitRunCommand [qc|git --git-dir {dir} ls-tree -l -r -t {pretty co}|]
|
||||
<&> fromRight mempty
|
||||
<&> fmap LBS8.words . LBS8.lines
|
||||
<&> mapMaybe \case
|
||||
[_,"tree",h,_,n] ->
|
||||
(reverse $ splitDirectories $ LBS8.unpack n,) <$> fmap Right (fromStringMay @GitHash (LBS8.unpack h))
|
||||
|
||||
let ha = fromStringMay @GitHash (LBS8.unpack h)
|
||||
let sz = readMay @Integer (LBS8.unpack size)
|
||||
[_,"blob",h,size,n] -> do
|
||||
let fn = headMay (reverse $ splitDirectories $ LBS8.unpack n)
|
||||
<&> List.singleton
|
||||
|
||||
let syn = Sky.syntaxesByFilename syntaxMap (LBS8.unpack n)
|
||||
& headMay
|
||||
<&> Text.toLower . Sky.sName
|
||||
let ha = fromStringMay @GitHash (LBS8.unpack h)
|
||||
let sz = readMay @Integer (LBS8.unpack size)
|
||||
|
||||
(,) <$> fn <*> fmap Left ( (,,) <$> ha <*> sz <*> pure syn )
|
||||
let syn = Sky.syntaxesByFilename syntaxMap (LBS8.unpack n)
|
||||
& headMay
|
||||
<&> Text.toLower . Sky.sName
|
||||
|
||||
_ -> Nothing
|
||||
(,) <$> fn <*> fmap Left ( (,,) <$> ha <*> sz <*> pure syn )
|
||||
|
||||
let trees = Map.fromList [ (k,v) | (k,Right v) <- items ]
|
||||
_ -> Nothing
|
||||
|
||||
let blobs = [ (k,v) | ([k],Left v) <- items ]
|
||||
let trees = Map.fromList [ (k,v) | (k,Right v) <- items ]
|
||||
|
||||
for_ blobs $ \(fn, (hash, size, syn)) -> do
|
||||
insertBlob (BlobHash hash, BlobName fn, BlobSize size, BlobSyn syn)
|
||||
let blobs = [ (k,v) | ([k],Left v) <- items ]
|
||||
|
||||
for_ (Map.toList trees) $ \(t,h0) -> do
|
||||
for_ blobs $ \(fn, (hash, size, syn)) -> do
|
||||
insertBlob (BlobHash hash, BlobName fn, BlobSize size, BlobSyn syn)
|
||||
|
||||
case t of
|
||||
[x] -> insertTree (TreeCommit co,TreeParent root,TreeTree h0,1,TreePath x)
|
||||
_ -> pure ()
|
||||
|
||||
let child = tailSafe t
|
||||
debug $ red "TREE-REL:" <+> pretty t
|
||||
let parent = Map.lookup child trees
|
||||
for_ root' \root -> do
|
||||
|
||||
for_ parent $ \p -> do
|
||||
debug $ red "FOUND SHIT:" <+> pretty (h0,p)
|
||||
insertTree ( TreeCommit co
|
||||
, TreeParent p
|
||||
, TreeTree h0
|
||||
, TreeLevel (length t)
|
||||
, TreePath (headDef "" t)
|
||||
)
|
||||
for_ (Map.toList trees) $ \(t,h0) -> do
|
||||
|
||||
case t of
|
||||
[x] -> insertTree (TreeCommit co,TreeParent root,TreeTree h0,1,TreePath x)
|
||||
_ -> pure ()
|
||||
|
||||
let child = tailSafe t
|
||||
debug $ red "TREE-REL:" <+> pretty t
|
||||
let parent = Map.lookup child trees
|
||||
|
||||
for_ parent $ \p -> do
|
||||
debug $ red "FOUND SHIT:" <+> pretty (h0,p)
|
||||
insertTree ( TreeCommit co
|
||||
, TreeParent p
|
||||
, TreeTree h0
|
||||
, TreeLevel (length t)
|
||||
, TreePath (headDef "" t)
|
||||
)
|
||||
-- insertTree co p h0
|
||||
|
||||
insertProcessed hkey
|
||||
|
||||
-- insertProcessed hkey
|
||||
|
||||
|
||||
gitShowTree :: (DashBoardPerks m, MonadReader DashBoardEnv m)
|
||||
|
|
|
|||
|
|
@ -321,7 +321,10 @@ rootPage content = do
|
|||
|
||||
body_ do
|
||||
header_ do
|
||||
div_ [class_ "header-title"] $ h1_ [] $ a_ [href_ (toURL RepoListPage)] "hbs2-peer dashboard"
|
||||
div_ [class_ "header-title"] $ h1_ [] $ do
|
||||
a_ [href_ (toURL RepoListPage)] "hbs2-peer dashboard"
|
||||
|
||||
|
||||
content
|
||||
|
||||
|
||||
|
|
@ -838,6 +841,13 @@ repoPage tab lww params = rootPage do
|
|||
div_ [class_ "container main"] $ do
|
||||
nav_ [class_ "left"] $ do
|
||||
|
||||
div_ [class_ "info-block" ] do
|
||||
div_ [ class_ "attr" ] do
|
||||
img_ [src_ "/icon/tree-up.svg"]
|
||||
small_ do
|
||||
a_ [ href_ "/"] "back to projects"
|
||||
|
||||
|
||||
div_ [class_ "info-block" ] do
|
||||
for_ author $ \a -> do
|
||||
div_ [ class_ "attr" ] do
|
||||
|
|
@ -849,6 +859,11 @@ repoPage tab lww params = rootPage do
|
|||
div_ [ class_ "attrname"] "public:"
|
||||
div_ [ class_ "attrval"] $ toHtml p
|
||||
|
||||
div_ [class_ "info-block" ] do
|
||||
when (Text.length manifest > 100) do
|
||||
div_ [ class_ "attr" ] do
|
||||
div_ [ class_ "attrname"] do
|
||||
a_ [ href_ (toURL (RepoPage ManifestTab lww))] "Manifest"
|
||||
|
||||
for_ mbHead $ \rh -> do
|
||||
|
||||
|
|
@ -877,7 +892,6 @@ repoPage tab lww params = rootPage do
|
|||
|
||||
nav_ [ role_ "tab-control" ] do
|
||||
repoMenu do
|
||||
repoMenuItem mempty $ a_ [href_ "/"] "root"
|
||||
|
||||
let menu t = if isActiveTab tab t then repoMenuItem0 else repoMenuItem
|
||||
|
||||
|
|
@ -886,9 +900,6 @@ repoPage tab lww params = rootPage do
|
|||
, hxTarget_ "#repo-tab-data"
|
||||
] "commits"
|
||||
|
||||
menu ManifestTab [ hxGet_ (toURL (RepoManifest lww))
|
||||
, hxTarget_ "#repo-tab-data"
|
||||
] "manifest"
|
||||
|
||||
menu (TreeTab Nothing)
|
||||
[ hxGet_ (toURL (RepoRefs lww))
|
||||
|
|
|
|||
Loading…
Reference in New Issue