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-09-27 12:18:42 +03:00
parent beb6cd7bef
commit 8e20e4cd65
14 changed files with 175 additions and 46 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
fixme-new/lib/Fixme/Config.hs
View File

@ -10,16 +10,16 @@ import System.Directory (getXdgDirectory, XdgDirectory(..))
binName :: FixmePerks m => m FilePath
binName = liftIO getProgName
localConfigDir :: FixmePerks m => m FilePath
localConfigDir :: (FixmePerks m, MonadReader FixmeEnv m) => m FilePath
localConfigDir = do
p <- pwd
p <- asks fixmeEnvWorkDir >>= readTVarIO
b <- binName
pure (p </> ("." <> b))
fixmeWorkDir :: FixmePerks m => m FilePath
fixmeWorkDir = localConfigDir <&> takeDirectory >>= canonicalizePath
fixmeWorkDir :: (FixmePerks m, MonadReader FixmeEnv m) => m FilePath
fixmeWorkDir = asks fixmeEnvWorkDir >>= readTVarIO
localConfig:: FixmePerks m => m FilePath
localConfig:: (FixmePerks m, MonadReader FixmeEnv m) => m FilePath
localConfig = localConfigDir <&> (</> "config")
userConfigs :: FixmePerks m => m [FilePath]
@ -36,6 +36,6 @@ userConfigs= do
localDBName :: FilePath
localDBName = "state.db"
localDBPath :: FixmePerks m => m FilePath
localDBPath :: (FixmePerks m, MonadReader FixmeEnv m) => m FilePath
localDBPath = localConfigDir <&> (</> localDBName)

2
fixme-new/lib/Fixme/GK.hs
View File

@ -30,7 +30,7 @@ data GroupKeyOpError =
instance Exception GroupKeyOpError
groupKeyFile :: forall m . FixmePerks m => m FilePath
groupKeyFile :: forall m . (FixmePerks m, MonadReader FixmeEnv m) => m FilePath
groupKeyFile = do
dir <- localConfigDir
pure $ dir </> "gk0"

13
fixme-new/lib/Fixme/Run.hs
View File

@ -113,12 +113,11 @@ runWithRPC FixmeEnv{..} m = do
runFixmeCLI :: forall a m . FixmePerks m => FixmeM m a -> m a
runFixmeCLI m = do
dbPath <- localDBPath
git <- findGitDir
env <- FixmeEnv
<$> newMVar ()
<*> newTVarIO mempty
<*> newTVarIO dbPath
<*> (pwd >>= newTVarIO)
<*> newTVarIO Nothing
<*> newTVarIO git
<*> newTVarIO mempty
@ -146,7 +145,6 @@ runFixmeCLI m = do
-- не все действия требуют БД,
-- хорошо бы, что бы она не создавалась,
-- если не требуется
mkdir (takeDirectory dbPath)
recover env do
runReaderT ( setupLogger >> fromFixmeM (handle @_ @SomeException (err . viaShow) evolve >> m) ) env
`finally` flushLoggers
@ -233,7 +231,7 @@ runTop forms = do
entry $ bindMatch "fixme-files" $ nil_ \case
StringLikeList xs -> do
w <- fixmeWorkDir
w <- lift fixmeWorkDir
t <- lift $ asks fixmeEnvFileMask
atomically (modifyTVar t (<> fmap (w </>) xs))
@ -241,7 +239,7 @@ runTop forms = do
entry $ bindMatch "fixme-exclude" $ nil_ \case
StringLikeList xs -> do
w <- fixmeWorkDir
w <- lift fixmeWorkDir
t <- lift $ asks fixmeEnvFileExclude
atomically (modifyTVar t (<> fmap (w </>) xs))
@ -451,7 +449,7 @@ runTop forms = do
[StringLike path] -> do
ppath <- if List.isPrefixOf "." path then do
dir <- localConfigDir
dir <- lift localConfigDir
let rest = tail $ splitDirectories path
pure $ joinPath (dir:rest)
else do
@ -544,10 +542,11 @@ runTop forms = do
<&> fromMaybe "hbs2-peer not connected"
liftIO $ putStrLn poked
conf <- readConfig
argz <- liftIO getArgs
conf <- readConfig
let args = zipWith (\i s -> bindValue (mkId ("$_" <> show i)) (mkStr @C s )) [1..] argz
& HM.unions

8
fixme-new/lib/Fixme/Run/Internal.hs
View File

@ -199,6 +199,10 @@ printEnv = do
attr <- asks fixmeEnvAttribs >>= readTVarIO <&> HS.toList
vals <- asks fixmeEnvAttribValues >>= readTVarIO <&> HM.toList
dir <- asks fixmeEnvWorkDir >>= readTVarIO
liftIO $ print $ "; workdir" <+> pretty dir
for_ tags $ \m -> do
liftIO $ print $ "fixme-prefix" <+> pretty m
@ -229,8 +233,8 @@ printEnv = do
for_ g $ \git -> do
liftIO $ print $ "fixme-git-dir" <+> dquotes (pretty git)
dbPath <- asks fixmeEnvDbPath >>= readTVarIO
liftIO $ print $ "fixme-state-path" <+> dquotes (pretty dbPath)
dbPath <- localDBPath
liftIO $ print $ "; fixme-state-path" <+> dquotes (pretty dbPath)
(before,after) <- asks fixmeEnvCatContext >>= readTVarIO

9
fixme-new/lib/Fixme/State.hs
View File

@ -103,19 +103,24 @@ instance FromField HashRef where
fromField = fmap (fromString @HashRef) . fromField @String
evolve :: FixmePerks m => FixmeM m ()
evolve = withState do
evolve = do
dbPath <- localDBPath
debug $ "evolve" <+> pretty dbPath
mkdir (takeDirectory dbPath)
withState do
createTables
withState :: forall m a . (FixmePerks m, MonadReader FixmeEnv m) => DBPipeM m a -> m a
withState what = do
lock <- asks fixmeLock
db <- withMVar lock $ \_ -> do
t <- asks fixmeEnvDb
mdb <- readTVarIO t
case mdb of
Just d -> pure (Right d)
Nothing -> do
path <- asks fixmeEnvDbPath >>= readTVarIO
path <- localDBPath
newDb <- try @_ @IOException (newDBPipeEnv dbPipeOptsDef path)
case newDb of
Left e -> pure (Left e)

7
fixme-new/lib/Fixme/Types.hs
View File

@ -13,6 +13,7 @@ import DBPipe.SQLite hiding (field)
import HBS2.Git.Local
import HBS2.OrDie
import HBS2.System.Dir
import HBS2.Storage as Exported
import HBS2.Peer.CLI.Detect
import HBS2.Peer.RPC.Client as Exported hiding (encode,decode)
@ -344,7 +345,7 @@ data FixmeEnv =
FixmeEnv
{ fixmeLock :: MVar ()
, fixmeEnvOpts :: TVar FixmeOpts
, fixmeEnvDbPath :: TVar FilePath
, fixmeEnvWorkDir :: TVar FilePath
, fixmeEnvDb :: TVar (Maybe DBPipeEnv)
, fixmeEnvGitDir :: TVar (Maybe FilePath)
, fixmeEnvFileMask :: TVar [FilePattern]
@ -411,11 +412,11 @@ newtype FixmeM m a = FixmeM { fromFixmeM :: ReaderT FixmeEnv m a }
fixmeEnvBare :: forall m . FixmePerks m => m FixmeEnv
fixmeEnvBare =
fixmeEnvBare = do
FixmeEnv
<$> newMVar ()
<*> newTVarIO mempty
<*> newTVarIO ":memory:"
<*> (pwd >>= newTVarIO)
<*> newTVarIO Nothing
<*> newTVarIO Nothing
<*> newTVarIO mempty

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

@ -508,6 +508,7 @@ theDict = do
getRpcSocketEntry
rpcPingEntry
rpcIndexEntry
debugEntries
where
@ -582,6 +583,13 @@ theDict = do
withMyRPCClient so $ \caller -> do
void $ callService @IndexNowRPC caller ()
debugEntries = do
entry $ bindMatch "debug:select-repo-fixme" $ nil_ $ const $ lift do
rs <- selectRepoFixme
for_ rs $ \(r,f) -> do
liftIO $ print $ pretty r <+> pretty (AsBase58 f)
main :: IO ()
main = do
argz <- getArgs

11
hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/Fixme.hs Normal file
View File

@ -0,0 +1,11 @@
module HBS2.Git.DashBoard.Fixme where
import HBS2.Git.DashBoard.Prelude
import HBS2.Git.DashBoard.Types
-- import Fixme.State
-- runFixme ::

24
hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/Manifest.hs
View File

@ -1,3 +1,5 @@
{-# Language PatternSynonyms #-}
{-# Language ViewPatterns #-}
module HBS2.Git.DashBoard.Manifest where
import HBS2.Git.DashBoard.Prelude
@ -7,6 +9,28 @@ import Data.Text qualified as Text
import Data.Either
import Streaming.Prelude qualified as S
pattern FixmeRefChanP :: forall {c} . PubKey Sign HBS2Basic -> Syntax c
pattern FixmeRefChanP x <- ListVal [ SymbolVal "fixme:"
, ListVal [ SymbolVal "refchan", SignPubKeyLike x
]]
pattern PinnedRefBlob :: forall {c}. Text -> Text -> GitHash -> Syntax c
pattern PinnedRefBlob syn name hash <- ListVal [ SymbolVal "blob"
, SymbolVal (Id syn)
, LitStrVal name
, asGitHash -> Just hash
]
{-# COMPLETE PinnedRefBlob #-}
asGitHash :: forall c . Syntax c -> Maybe GitHash
asGitHash = \case
LitStrVal s -> fromStringMay (Text.unpack s)
_ -> Nothing
parseManifest :: Monad m => RepoHead -> m ([Syntax C], Text)
parseManifest mhead = do

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

@ -57,8 +57,6 @@ instance Semigroup RepoListPred where
instance Monoid RepoListPred where
mempty = RepoListPred Nothing Nothing
type MyRefChan = RefChanId L4Proto
type MyRefLogKey = RefLogKey 'HBS2Basic
evolveDB :: DashBoardPerks m => DBPipeM m ()
evolveDB = do
@ -183,6 +181,8 @@ newtype RepoLwwSeq = RepoLwwSeq Integer
newtype RepoChannel = RepoChannel MyRefChan
newtype RefChanField = RefChanField MyRefChan
deriving stock (Generic)
newtype RepoHeadRef = RepoHeadRef HashRef
deriving stock (Generic)
@ -201,9 +201,20 @@ newtype RepoHeadGK0 = RepoHeadGK0 (Maybe HashRef)
deriving stock (Generic)
deriving newtype (ToField,FromField)
newtype Base58Field a = Base58Field { fromBase58Field :: a }
deriving stock (Eq,Ord,Generic)
instance ToField RepoChannel where
toField (RepoChannel x) = toField $ show $ pretty (AsBase58 x)
instance ToField RefChanField where
toField (RefChanField x) = toField $ show $ pretty (AsBase58 x)
instance FromField RefChanField where
fromField w = fromField @String w
>>= maybe (fail "invalid key") (pure . RefChanField) . fromStringMay
data TxProcessedTable
data RepoTable
data RepoChannelTable
@ -452,6 +463,15 @@ createRepoHeadTable = do
)
|]
ddl [qc|
create table if not exists repoheadfixme
( lww text not null
, lwwseq integer not null
, refchan text not null
, primary key (lww, lwwseq)
)
|]
data RepoHeadTable
instance HasTableName RepoHeadTable where
@ -496,6 +516,29 @@ insertRepoHead lww lwwseq rlog tx rf rh = do
pure ()
insertRepoFixme :: (DashBoardPerks m, MonadReader DashBoardEnv m)
=> LWWRefKey 'HBS2Basic
-> RepoLwwSeq
-> MyRefChan
-> DBPipeM m ()
insertRepoFixme lww lwwseq r = do
S.insert [qc|
insert into repoheadfixme (lww, lwwseq, refchan) values(?,?,?)
on conflict (lww, lwwseq) do update set refchan = excluded.refchan
|]
(lww, lwwseq, RefChanField r)
selectRepoFixme :: (DashBoardPerks m, MonadReader DashBoardEnv m)
=> m [(RepoLww, MyRefChan)]
selectRepoFixme = do
let sql = [qc|
select lww, refchan from (select lww, refchan, max(lwwseq) from repoheadfixme group by lww)
|]
withState $ select_ @_ @(RepoLww, RefChanField) sql
<&> fmap (over _2 coerce)
-- FIXME: what-if-two-repo-shares-one-reflog?
selectLwwByRefLog :: (DashBoardPerks m, MonadReader DashBoardEnv m) => RepoRefLog -> m (Maybe RepoLww)
selectLwwByRefLog rlog = withState do
@ -961,7 +1004,7 @@ deleteFixmeAllowed = do
withState $ S.insert_ sql
checkFixmeAllowed :: (DashBoardPerks m, MonadReader DashBoardEnv m)
=> RepoRefLog
=> RepoLww
-> m Bool
checkFixmeAllowed r = do
@ -981,6 +1024,10 @@ checkFixmeAllowed r = do
pure $ not $ List.null w
-- listFixmeRefChans :: (DashBoardPerks m, MonadReader DashBoardEnv m) => m [Rep
-- listFixmeRefChans
rpcSocketKey :: String
rpcSocketKey =
hashObject @HbSync (serialise "rpc-socket-name") & pretty & show

45
hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/State/Index/Peer.hs
View File

@ -3,15 +3,41 @@ module HBS2.Git.DashBoard.State.Index.Peer where
import HBS2.Git.DashBoard.Prelude
import HBS2.Git.DashBoard.Types
import HBS2.Git.DashBoard.State
import HBS2.Git.DashBoard.Manifest
import HBS2.Git.Data.LWWBlock
import HBS2.Git.Data.Tx.Git
import HBS2.System.Dir
import Streaming.Prelude qualified as S
import System.Process.Typed
{- HLINT ignore "Functor law" -}
seconds = TimeoutSec
updateFixmeFor :: ( MonadUnliftIO m
, MonadReader DashBoardEnv m
)
=> RepoLww
-> MyRefChan
-> m ()
updateFixmeFor (RepoLww lw) f = do
p <- fixmeDataPath f
debug $ red "UPDATE-FIXME-FOR" <+> pretty (AsBase58 lw) <+> pretty (AsBase58 f) <+> pretty p
let rcp = show $ pretty (AsBase58 f)
mkdir p
let cmdStr = [qc|fixme-new refchan {rcp} and fixme:refchan:import|]
let cmd = shell cmdStr & setWorkingDir p
debug $ "run fixme for:" <+> pretty rcp <+> pretty cmdStr
void $ runProcess cmd
updateIndexFromPeer :: (DashBoardPerks m, MonadReader DashBoardEnv m) => m ()
updateIndexFromPeer = do
debug "updateIndexFromPeer"
@ -36,6 +62,7 @@ updateIndexFromPeer = do
lift $ S.yield (r,lwval,RefLogKey @'HBS2Basic rk,blk)
for_ repos $ \(lw,wv,rk,LWWBlockData{..}) -> do
mhead <- callRpcWaitMay @RpcRefLogGet (TimeoutSec 1) reflog (coerce rk)
@ -64,10 +91,24 @@ updateIndexFromPeer = do
for_ txs $ \(n,tx,blk) -> void $ runMaybeT do
(rhh, rhead) <- readRepoHeadFromTx sto tx >>= toMPlus
debug $ yellow "found repo head" <+> pretty rhh <+> pretty "for" <+> pretty lw
lift $ S.yield (lw, RepoHeadTx tx, RepoHeadRef rhh, rhead)
(man, _) <- parseManifest rhead
let fme = headMay [ x | FixmeRefChanP x <- man ]
lift $ S.yield (lw, RepoHeadTx tx, RepoHeadRef rhh, rhead, fme)
withState $ transactional do
for_ headz $ \(l, tx, rh, rhead) -> do
for_ headz $ \(l, tx, rh, rhead, fme) -> do
let rlwwseq = RepoLwwSeq (fromIntegral $ lwwSeq wv)
insertRepoHead l rlwwseq (RepoRefLog rk) tx rh rhead
for_ fme $ \f -> do
insertRepoFixme l rlwwseq f
fxe <- selectRepoFixme
for_ fxe $ \(r,f) -> do
allowed <- checkFixmeAllowed r
when allowed do
env <-ask
addJob (withDashBoardEnv env $ updateFixmeFor r f)

6
hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/Types.hs
View File

@ -21,6 +21,9 @@ import System.FilePath
import Data.Word
type MyRefChan = RefChanId L4Proto
type MyRefLogKey = RefLogKey 'HBS2Basic
data HttpPortOpt
data DevelopAssetsOpt
@ -61,6 +64,9 @@ makeLenses 'DashBoardEnv
repoDataPath :: (DashBoardPerks m, MonadReader DashBoardEnv m) => LWWRefKey 'HBS2Basic -> m FilePath
repoDataPath lw = asks _dataDir <&> (</> (show $ pretty lw)) >>= canonicalizePath
fixmeDataPath :: (DashBoardPerks m, MonadReader DashBoardEnv m) => MyRefChan -> m FilePath
fixmeDataPath rchan = asks _dataDir <&> (</> (show $ "fixme-" <> pretty (AsBase58 rchan))) >>= canonicalizePath
type DashBoardPerks m = MonadUnliftIO m
newtype DashBoardM m a = DashBoardM { fromDashBoardM :: ReaderT DashBoardEnv m a }

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

@ -885,25 +885,6 @@ instance ToHtml (ShortRef (LWWRefKey 'HBS2Basic)) where
toHtmlRaw (ShortRef a) = toHtml (shortRef 14 3 (show $ pretty a))
pattern PinnedRefBlob :: forall {c}. Text -> Text -> GitHash -> Syntax c
pattern PinnedRefBlob syn name hash <- ListVal [ SymbolVal "blob"
, SymbolVal (Id syn)
, LitStrVal name
, asGitHash -> Just hash
]
{-# COMPLETE PinnedRefBlob #-}
asGitHash :: forall c . Syntax c -> Maybe GitHash
asGitHash = \case
LitStrVal s -> fromStringMay (Text.unpack s)
_ -> Nothing
pattern FixmeRefChanP :: forall {c} . PubKey Sign HBS2Basic -> Syntax c
pattern FixmeRefChanP x <- ListVal [ SymbolVal "fixme:"
, ListVal [ SymbolVal "refchan", SignPubKeyLike x
]]
repoPage :: (MonadIO m, DashBoardPerks m, MonadReader DashBoardEnv m)
=> RepoPageTabs
-> LWWRefKey 'HBS2Basic
@ -928,7 +909,7 @@ repoPage tab lww params = rootPage do
let public = headMay [ s | ListVal [ SymbolVal "public:", SymbolVal (Id s) ] <- meta ]
let pinned = [ (name,r) | ListVal [ SymbolVal "pinned:", r@(PinnedRefBlob _ name _) ] <- meta ] & take 5
allowed <- lift $ checkFixmeAllowed (RepoRefLog (coerce lww))
allowed <- lift $ checkFixmeAllowed (RepoLww lww)
let fixme = headMay [ x | allowed, FixmeRefChanP x <- meta ]
debug $ red "META" <+> pretty meta
@ -1075,3 +1056,4 @@ repoPage tab lww params = rootPage do
repoForks lww
div_ [id_ "repo-tab-data-embedded"] mempty

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

@ -154,6 +154,7 @@ executable hbs2-git-dashboard
HBS2.Git.DashBoard.State.Index.Channels
HBS2.Git.DashBoard.State.Index.Peer
HBS2.Git.DashBoard.Manifest
HBS2.Git.DashBoard.Fixme
HBS2.Git.Web.Html.Root
-- other-extensions: