mirror of https://github.com/voidlizard/hbs2
414 lines
9.8 KiB
Haskell
414 lines
9.8 KiB
Haskell
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
|
{-# LANGUAGE TemplateHaskell #-}
|
|
{-# LANGUAGE UndecidableInstances #-}
|
|
{-# LANGUAGE AllowAmbiguousTypes #-}
|
|
{-# LANGUAGE PatternSynonyms #-}
|
|
{-# LANGUAGE ViewPatterns #-}
|
|
module HBS2.Git.DashBoard.State
|
|
( module HBS2.Git.DashBoard.State
|
|
, Only(..)
|
|
, transactional
|
|
) where
|
|
|
|
import HBS2.Git.DashBoard.Prelude
|
|
import HBS2.Git.DashBoard.Types
|
|
|
|
import HBS2.Git.Data.Tx.Git
|
|
|
|
import DBPipe.SQLite hiding (insert)
|
|
import DBPipe.SQLite.Generic as G
|
|
|
|
import Lucid.Base
|
|
import Data.Text qualified as Text
|
|
import Data.Word
|
|
import Data.List qualified as List
|
|
|
|
data RepoListPred =
|
|
RepoListPred
|
|
{ _repoListByLww :: Maybe (LWWRefKey 'HBS2Basic)
|
|
, _repoListLimit :: Maybe Int
|
|
}
|
|
|
|
makeLenses 'RepoListPred
|
|
|
|
instance Semigroup RepoListPred where
|
|
(<>) _ b = mempty & set repoListByLww (view repoListByLww b)
|
|
& set repoListLimit (view repoListLimit b)
|
|
|
|
instance Monoid RepoListPred where
|
|
mempty = RepoListPred Nothing Nothing
|
|
|
|
type MyRefChan = RefChanId L4Proto
|
|
|
|
|
|
evolveDB :: DashBoardPerks m => DBPipeM m ()
|
|
evolveDB = do
|
|
|
|
ddl [qc|
|
|
create table if not exists repo
|
|
( lww text not null
|
|
, primary key (lww)
|
|
)
|
|
|]
|
|
|
|
|
|
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
|
|
, brief text not null
|
|
, primary key (lww)
|
|
)
|
|
|]
|
|
|
|
ddl [qc|
|
|
create table if not exists name
|
|
( lww text not null
|
|
, name text not null
|
|
, primary key (lww)
|
|
)
|
|
|]
|
|
|
|
|
|
createRepoHeadTable
|
|
createRepoListView
|
|
|
|
ddl [qc|
|
|
create table if not exists processed
|
|
( hash text not null
|
|
, primary key (hash)
|
|
)
|
|
|]
|
|
|
|
pure ()
|
|
|
|
|
|
instance ToField HashRef where
|
|
toField x = toField $ show $ pretty x
|
|
|
|
instance FromField HashRef where
|
|
fromField = fmap (fromString @HashRef) . fromField @String
|
|
|
|
instance Pretty (AsBase58 (PubKey 'Sign s)) => ToField (LWWRefKey s) where
|
|
toField x = toField $ show $ pretty (AsBase58 x)
|
|
|
|
instance Pretty (AsBase58 (PubKey 'Sign s)) => ToField (RefLogKey s) where
|
|
toField x = toField $ show $ pretty (AsBase58 x)
|
|
|
|
instance IsRefPubKey s => FromField (RefLogKey s) where
|
|
fromField = fmap (fromString @(RefLogKey s)) . fromField @String
|
|
|
|
instance FromField (LWWRefKey HBS2Basic) where
|
|
fromField = fmap fromString . fromField @String
|
|
|
|
|
|
newtype TxHash = TxHash HashRef
|
|
deriving stock (Generic)
|
|
deriving newtype (ToField)
|
|
|
|
|
|
newtype RepoHeadTx = RepoHeadTx HashRef
|
|
deriving stock (Generic)
|
|
deriving newtype (ToField,FromField,Pretty)
|
|
|
|
newtype RepoName = RepoName Text
|
|
deriving stock (Eq,Show,Generic)
|
|
deriving newtype (ToField,FromField,ToHtml,IsString)
|
|
|
|
newtype RepoBrief = RepoBrief Text
|
|
deriving stock (Generic)
|
|
deriving newtype (ToField,FromField)
|
|
|
|
newtype RepoLww = RepoLww (LWWRefKey 'HBS2Basic)
|
|
deriving stock (Generic)
|
|
deriving newtype (ToField,FromField,Pretty)
|
|
|
|
newtype RepoLwwSeq = RepoLwwSeq Integer
|
|
deriving stock (Generic)
|
|
deriving newtype (ToField,FromField,Pretty)
|
|
|
|
newtype RepoChannel = RepoChannel MyRefChan
|
|
|
|
|
|
newtype RepoHeadRef = RepoHeadRef HashRef
|
|
deriving stock (Generic)
|
|
deriving newtype (ToField,FromField)
|
|
|
|
|
|
newtype RepoHeadSeq = RepoHeadSeq Word64
|
|
deriving stock (Generic)
|
|
deriving newtype (ToField,FromField)
|
|
|
|
newtype RepoRefLog = RepoRefLog (RefLogKey 'HBS2Basic)
|
|
deriving stock (Generic)
|
|
deriving newtype (ToField,FromField)
|
|
|
|
newtype RepoHeadGK0 = RepoHeadGK0 (Maybe HashRef)
|
|
deriving stock (Generic)
|
|
deriving newtype (ToField,FromField)
|
|
|
|
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"
|
|
|
|
instance HasTableName RepoNameTable where
|
|
tableName = "name"
|
|
|
|
instance HasTableName RepoBriefTable where
|
|
tableName = "brief"
|
|
|
|
instance HasTableName TxProcessedTable where
|
|
tableName = "processed"
|
|
|
|
instance HasColumnName TxHash where
|
|
columnName = "hash"
|
|
|
|
instance HasColumnName RepoLww where
|
|
columnName = "lww"
|
|
|
|
instance HasColumnName RepoLwwSeq where
|
|
columnName = "lwwseq"
|
|
|
|
instance HasColumnName RepoName where
|
|
columnName = "name"
|
|
|
|
instance HasColumnName RepoBrief where
|
|
columnName = "brief"
|
|
|
|
instance HasColumnName RepoRefLog where
|
|
columnName = "reflog"
|
|
|
|
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]
|
|
|
|
instance HasPrimaryKey RepoNameTable where
|
|
primaryKey = [G.columnName @RepoLww]
|
|
|
|
instance HasPrimaryKey RepoBriefTable where
|
|
primaryKey = [G.columnName @RepoLww]
|
|
|
|
|
|
pattern PRefChan :: MyRefChan -> Syntax C
|
|
pattern PRefChan s <- ListVal [ SymbolVal "refchan" , asRefChan -> Just s ]
|
|
|
|
asRefChan :: Syntax C -> Maybe MyRefChan
|
|
asRefChan = \case
|
|
LitStrVal s -> fromStringMay @MyRefChan (Text.unpack s)
|
|
_ -> Nothing
|
|
|
|
getIndexEntries :: (DashBoardPerks m, HasConf m, MonadReader DashBoardEnv m) => m [MyRefChan]
|
|
getIndexEntries = do
|
|
conf <- getConf
|
|
pure [ s | ListVal [ SymbolVal "index", PRefChan s] <- conf ]
|
|
|
|
|
|
data NiceTS = NiceTS
|
|
|
|
data RepoListItem =
|
|
RepoListItem
|
|
{ rlRepoLww :: RepoLww
|
|
, rlRepoSeq :: RepoHeadSeq
|
|
, rlRepoHead :: RepoHeadRef
|
|
, rlRepoTx :: RepoHeadTx
|
|
, rlRepoName :: RepoName
|
|
, rlRepoBrief :: RepoBrief
|
|
, rlRepoGK0 :: RepoHeadGK0
|
|
}
|
|
deriving stock (Generic)
|
|
|
|
-- deriving instance Data RepoListItem via Generically RepoListItem
|
|
|
|
rlRepoLwwAsText :: SimpleGetter RepoListItem Text
|
|
rlRepoLwwAsText =
|
|
to \RepoListItem{..} -> do
|
|
Text.pack $ show $ pretty $ rlRepoLww
|
|
|
|
instance FromRow RepoListItem
|
|
|
|
|
|
|
|
selectRepoList :: (DashBoardPerks m, MonadReader DashBoardEnv m) => RepoListPred -> m [RepoListItem]
|
|
selectRepoList pred = fmap fixName <$> withState do
|
|
|
|
let onLww = maybe1 (view repoListByLww pred) mempty $ \w -> [("r.lww = ?", w)]
|
|
let claus = onLww
|
|
|
|
let where_ | List.null claus = "true"
|
|
| otherwise = Text.intercalate " and " (fmap fst claus)
|
|
|
|
let limit_ = case view repoListLimit pred of
|
|
Nothing -> mempty
|
|
Just n -> show $ "limit" <+> pretty n
|
|
|
|
let params = fmap snd claus
|
|
|
|
let sql = [qc|
|
|
select r.lww
|
|
, r.seq
|
|
, r.repohead
|
|
, r.tx
|
|
, r.name
|
|
, r.brief
|
|
, r.gk0
|
|
from repolistview r
|
|
where {where_}
|
|
{limit_}
|
|
|]
|
|
|
|
debug $ yellow "selectRepoList" <+> pretty sql
|
|
|
|
select @RepoListItem sql params
|
|
where
|
|
fixName x@RepoListItem{..} | Text.length (coerce rlRepoName) < 3 = x { rlRepoName = fixed }
|
|
| otherwise = x
|
|
where fixed = Text.pack (show $ pretty (coerce @_ @(LWWRefKey 'HBS2Basic) rlRepoLww) ) & RepoName
|
|
|
|
createRepoListView :: DashBoardPerks m => DBPipeM m ()
|
|
createRepoListView = do
|
|
ddl [qc|
|
|
drop view if exists repolistview
|
|
|]
|
|
|
|
ddl [qc|
|
|
create view repolistview as
|
|
|
|
with repolist as (
|
|
select
|
|
r.lww,
|
|
0 as lwwseq,
|
|
0 as seq,
|
|
null as reflog,
|
|
null as repohead,
|
|
null as tx,
|
|
coalesce(n.name, r.lww) as name,
|
|
coalesce(b.brief, '') as brief,
|
|
null as gk0
|
|
from repo r
|
|
left join name n on r.lww = n.lww
|
|
left join brief b on r.lww = b.lww
|
|
union
|
|
select
|
|
lww,
|
|
lwwseq,
|
|
reflog,
|
|
seq,
|
|
repohead,
|
|
tx,
|
|
name,
|
|
brief,
|
|
gk0
|
|
from repohead
|
|
),
|
|
ranked_repos as (
|
|
select
|
|
lww,
|
|
lwwseq,
|
|
reflog,
|
|
seq,
|
|
repohead,
|
|
tx,
|
|
name,
|
|
brief,
|
|
gk0,
|
|
row_number() over (partition by lww order by lwwseq desc, seq desc) as rn
|
|
from repolist
|
|
order by seq desc
|
|
)
|
|
|
|
select lww, lwwseq, reflog, seq, repohead, tx, name, brief, gk0
|
|
from ranked_repos
|
|
where rn = 1;
|
|
|
|
|]
|
|
|
|
|
|
createRepoHeadTable :: DashBoardPerks m => DBPipeM m ()
|
|
createRepoHeadTable = do
|
|
ddl [qc|
|
|
create table if not exists repohead
|
|
( lww text not null
|
|
, lwwseq integer not null
|
|
, reflog text not null
|
|
, repohead text not null
|
|
, tx text not null
|
|
, seq integer not null
|
|
, gk0 text null
|
|
, name text
|
|
, brief text
|
|
, primary key (lww,lwwseq,repohead)
|
|
)
|
|
|]
|
|
|
|
data RepoHeadTable
|
|
|
|
instance HasTableName RepoHeadTable where
|
|
tableName = "repohead"
|
|
|
|
instance HasPrimaryKey RepoHeadTable where
|
|
primaryKey = ["lww", "lwwseq", "repohead"]
|
|
|
|
instance HasColumnName RepoHeadRef where
|
|
columnName = "repohead"
|
|
|
|
instance HasColumnName RepoHeadSeq where
|
|
columnName = "seq"
|
|
|
|
instance HasColumnName RepoHeadGK0 where
|
|
columnName = "gk0"
|
|
|
|
instance HasColumnName RepoHeadTx where
|
|
columnName = "tx"
|
|
|
|
|
|
insertRepoHead :: (DashBoardPerks m, MonadReader DashBoardEnv m)
|
|
=> LWWRefKey 'HBS2Basic
|
|
-> RepoLwwSeq
|
|
-> RepoRefLog
|
|
-> RepoHeadTx
|
|
-> RepoHeadRef
|
|
-> RepoHead
|
|
-> DBPipeM m ()
|
|
insertRepoHead lww lwwseq rlog tx rf rh = do
|
|
insert @RepoHeadTable $ onConflictIgnore @RepoHeadTable
|
|
( RepoLww lww
|
|
, lwwseq
|
|
, rlog
|
|
, rf
|
|
, tx
|
|
, RepoHeadSeq (_repoHeadTime rh)
|
|
, RepoHeadGK0 (_repoHeadGK0 rh)
|
|
, RepoName (_repoHeadName rh)
|
|
, RepoBrief (_repoHeadBrief rh)
|
|
)
|
|
|
|
pure ()
|
|
|
|
|