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-18 17:51:49 +03:00
parent 78a58039b2
commit af847eae05
6 changed files with 152 additions and 36 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
cabal.project
View File

@ -3,6 +3,8 @@ packages: **/*.cabal
allow-newer: all
constraints: pandoc ==3.1.11
-- executable-static: True
-- profiling: True
-- library-profiling: False

1
hbs2-fixer/hbs2-fixer.cabal
View File

@ -68,7 +68,6 @@ common shared-properties
, streaming
, streaming-bytestring
, streaming-commons
, streaming-utils
, cryptonite
, directory
, exceptions

2
hbs2-git/hbs2-git-dashboard/GitDashBoard.hs
View File

@ -192,7 +192,7 @@ runDashboardWeb wo = do
middleware $ staticPolicy (noDots >-> addBase f)
get "/" do
html =<< renderTextT (dashboardRootPage mempty)
html =<< lift (renderTextT dashboardRootPage)
runScotty :: DashBoardPerks m => DashBoardM m ()

70
hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/State.hs
View File

@ -1,5 +1,6 @@
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ViewPatterns #-}
module HBS2.Git.DashBoard.State where
@ -27,6 +28,7 @@ import Data.Config.Suckless
import DBPipe.SQLite hiding (insert)
import DBPipe.SQLite.Generic as G
import Lucid.Base
import Data.Maybe
import Data.Text qualified as Text
import Text.InterpolatedString.Perl6 (qc)
@ -49,6 +51,15 @@ evolveDB = do
)
|]
ddl [qc|
create table if not exists repochannel
( lww text not null
, channel text not null
, primary key (lww,channel)
)
|]
ddl [qc|
create table if not exists brief
( lww text not null
@ -81,23 +92,40 @@ instance ToField HashRef where
instance Pretty (AsBase58 (PubKey 'Sign s)) => ToField (LWWRefKey s) where
toField x = toField $ show $ pretty (AsBase58 x)
instance FromField (LWWRefKey HBS2Basic) where
fromField = fmap fromString . fromField @String
newtype TxHash = TxHash HashRef
deriving stock (Generic)
deriving newtype (ToField)
newtype RepoName = RepoName Text
deriving newtype (ToField)
deriving stock (Generic)
deriving newtype (ToField,FromField,ToHtml)
newtype RepoBrief = RepoBrief Text
deriving newtype (ToField)
deriving stock (Generic)
deriving newtype (ToField,FromField)
newtype RepoLww = RepoLww (LWWRefKey 'HBS2Basic)
deriving newtype (ToField)
deriving stock (Generic)
deriving newtype (ToField,FromField)
newtype RepoChannel = RepoChannel MyRefChan
instance ToField RepoChannel where
toField (RepoChannel x) = toField $ show $ pretty (AsBase58 x)
data TxProcessedTable
data RepoTable
data RepoChannelTable
data RepoNameTable
data RepoBriefTable
instance HasTableName RepoChannelTable where
tableName = "repochannel"
instance HasTableName RepoTable where
tableName = "repo"
@ -122,9 +150,15 @@ instance HasColumnName RepoName where
instance HasColumnName RepoBrief where
columnName = "brief"
instance HasColumnName RepoChannel where
columnName = "channel"
instance HasPrimaryKey TxProcessedTable where
primaryKey = [G.columnName @TxHash]
instance HasPrimaryKey RepoChannelTable where
primaryKey = [G.columnName @RepoLww, G.columnName @RepoChannel]
instance HasPrimaryKey RepoTable where
primaryKey = [G.columnName @RepoLww]
@ -146,10 +180,29 @@ asRefChan = \case
getIndexEntries :: (DashBoardPerks m, HasConf m, MonadReader DashBoardEnv m) => m [MyRefChan]
getIndexEntries = do
conf <- getConf
pure [ s | ListVal [ SymbolVal "index", PRefChan s] <- conf ]
data RepoListItem =
RepoListItem
{ rlRepoLww :: RepoLww
, rlRepoName :: RepoName
, rlRepoBrief :: RepoBrief
}
deriving stock (Generic)
instance FromRow RepoListItem
selectRepoList :: (DashBoardPerks m, MonadReader DashBoardEnv m) => m [RepoListItem]
selectRepoList = withState do
select_ @_ @RepoListItem [qc|select
r.lww
, n.name
, b.brief
from repo r join name n on r.lww = n.lww
join brief b on b.lww = r.lww
|]
updateIndex :: (DashBoardPerks m, HasConf m, MonadReader DashBoardEnv m) => m ()
updateIndex = do
debug "updateIndex"
@ -196,12 +249,17 @@ updateIndex = do
insert @RepoTable $ onConflictIgnore @RepoTable (Only (RepoLww gitIndexTxRef))
insert @RepoChannelTable $
onConflictIgnore @RepoChannelTable (RepoLww gitIndexTxRef, RepoChannel rc)
-- FIXME: on-conflict-update!
for_ nm $ \n -> do
insert @RepoNameTable $ onConflictIgnore @RepoNameTable (RepoLww gitIndexTxRef, n)
insert @RepoNameTable $
onConflictIgnore @RepoNameTable (RepoLww gitIndexTxRef, n)
for_ bri $ \n -> do
insert @RepoBriefTable $ onConflictIgnore @RepoBriefTable (RepoLww gitIndexTxRef, n)
insert @RepoBriefTable $
onConflictIgnore @RepoBriefTable (RepoLww gitIndexTxRef, n)
lift $ withState $ transactional do
for_ txs $ \t -> do

112
hbs2-git/hbs2-git-dashboard/src/HBS2/Git/Web/Html/Root.hs
View File

@ -1,12 +1,17 @@
module HBS2.Git.Web.Html.Root where
import HBS2.Prelude
import HBS2.Git.DashBoard.Types
import HBS2.Git.DashBoard.State
import HBS2.Base58
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
@ -43,11 +48,10 @@ rootPage content = do
dashboardRootPage :: Monad m => [Syntax c] -> HtmlT m ()
dashboardRootPage syn = rootPage do
dashboardRootPage :: (DashBoardPerks m, MonadReader DashBoardEnv m) => HtmlT m ()
dashboardRootPage = rootPage do
let channels = mempty
-- [ mchan | ListVal (SymbolVal "channel" : mchan) <- bro ]
items <- lift selectRepoList
div_ [class_ "container main"] $ do
nav_ [class_ "left"] $ do
@ -55,35 +59,87 @@ dashboardRootPage syn = rootPage do
div_ [class_ "info-block"] "Всякая разная рандомная информация хрен знает, что тут пока выводить"
main_ do
for_ channels $ \chan -> void $ runMaybeT do
let title = headDef "unknown" [ t
| ListVal [ SymbolVal "title", LitStrVal t ] <- chan
]
let desc = mconcat [ d
| ListVal (SymbolVal "description" : d) <- chan
] & take 5
rchan <- headMay ( catMaybes
[ fromStringMay @(RefChanId L4Proto) (Text.unpack rc)
| ListVal [SymbolVal "refchan", LitStrVal rc] <- chan
] ) & toMPlus
section_ do
h1_ "Git repositories"
form_ [class_ "search"] do
input_ [type_ "search", id_ "search"]
button_ [class_ "search"] mempty
let alias = headMay [ x
| ListVal [SymbolVal "alias", LitStrVal x] <- chan
]
section_ [id_ "repo-search-results"] do
let url = case alias of
Just x -> Text.unpack x
Nothing -> (show . pretty . AsBase58) rchan
for_ items $ \RepoListItem{..} -> do
lift do
div_ [class_ "channel-list-item"] do
h2_ $ toHtml title
-- 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
p_ $ a_ [href_ (path [url])] (toHtml (show $ pretty $ AsBase58 rchan))
-- let days = "updated" <+> if d == 0 then "today" else viaShow d <+> "days ago"
-- where d = ( now - t ) `div` 86400
for_ [ s | LitStrVal s <- desc ] $ \s -> do
p_ (toHtml s)
-- let s = if Text.length n > 2 then n else "unnamed"
-- let refpart = Text.take 8 $ Text.pack $ show $ pretty h
-- let sref = show $ pretty h
-- let ref = Text.pack sref
-- let suff = ["repo", sref]
-- let url = path (hrefBase <> suff)
div_ [class_ "repo-list-item"] do
div_ [class_ "repo-info", style_ "flex: 1; flex-basis: 70%;"] do
h2_ $ toHtml rlRepoName
-- [class_ "xclip", onClickCopy ref] $ toHtml (s <> "-" <> refpart)
-- p_ $ a_ [href_ url] (toHtml ref)
-- renderMarkdown b
-- 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"]
pure ()
-- for_ channels $ \chan -> void $ runMaybeT do
-- let title = headDef "unknown" [ t
-- | ListVal [ SymbolVal "title", LitStrVal t ] <- chan
-- ]
-- let desc = mconcat [ d
-- | ListVal (SymbolVal "description" : d) <- chan
-- ] & take 5
-- rchan <- headMay ( catMaybes
-- [ fromStringMay @(RefChanId L4Proto) (Text.unpack rc)
-- | ListVal [SymbolVal "refchan", LitStrVal rc] <- chan
-- ] ) & toMPlus
-- 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)

1
hbs2-git/hbs2-git.cabal
View File

@ -162,6 +162,7 @@ executable hbs2-git-dashboard
, wai-middleware-static-embedded
, lucid
, lucid-htmx
, pandoc
, scotty >= 0.22
hs-source-dirs: