From 70631edc306e63d4fedd44c269ad79350561c352 Mon Sep 17 00:00:00 2001 From: Dmitry Zuikov Date: Tue, 26 Mar 2024 11:28:57 +0300 Subject: [PATCH] wip --- .hbs2-git/manifest | 1 + hbs2-core/lib/HBS2/Net/Auth/Schema.hs | 5 +- hbs2-git/hbs2-git-oracle/app/Main.hs | 42 +++++++--- .../lib/HBS2/Git/Oracle/App.hs | 8 +- .../lib/HBS2/Git/Oracle/Run.hs | 83 +++++++++++++++++-- hbs2-peer/app/Browser/Root.hs | 1 - 6 files changed, 112 insertions(+), 28 deletions(-) diff --git a/.hbs2-git/manifest b/.hbs2-git/manifest index 3c5b0196..e65995c2 100644 --- a/.hbs2-git/manifest +++ b/.hbs2-git/manifest @@ -1,5 +1,6 @@ title: "hbs2 project repo" author: "Dmitry Zuikov" public: yes +brief: "HBS2: P2P CAS and protocol framework" Project description TBD diff --git a/hbs2-core/lib/HBS2/Net/Auth/Schema.hs b/hbs2-core/lib/HBS2/Net/Auth/Schema.hs index 5c4150e2..753d7a4a 100644 --- a/hbs2-core/lib/HBS2/Net/Auth/Schema.hs +++ b/hbs2-core/lib/HBS2/Net/Auth/Schema.hs @@ -5,7 +5,7 @@ module HBS2.Net.Auth.Schema , module HBS2.Net.Proto.Types ) where -import HBS2.Prelude +import HBS2.Prelude.Plated import HBS2.OrDie import HBS2.Net.Proto.Types import HBS2.Hash @@ -22,7 +22,8 @@ import Data.ByteString.Lazy qualified as LBS import Data.ByteString (ByteString) import Data.ByteArray ( convert) -data HBS2Basic +data HBS2Basic = HBS2Basic + deriving stock Data type instance Encryption L4Proto = HBS2Basic diff --git a/hbs2-git/hbs2-git-oracle/app/Main.hs b/hbs2-git/hbs2-git-oracle/app/Main.hs index 486661f0..6dfa5a6b 100644 --- a/hbs2-git/hbs2-git-oracle/app/Main.hs +++ b/hbs2-git/hbs2-git-oracle/app/Main.hs @@ -6,15 +6,16 @@ import HBS2.Git.Oracle.Run import Options.Applicative as O + +type PKS = PubKey 'Sign HBS2Basic + +data RunMode = + RunIndex PKS + | RunDump + main :: IO () main = do - let parser = runApp - <$> flag False True ( long "serve" - <> short 's' - <> help "serve" - ) - <*> option pkey ( long "refchan" <> short 'r' <> help "refchan to post" ) - <*> option pkey ( long "author" <> short 'a' <> help "author" ) + let parser = hsubparser ( pRunIndexCmd <> pRunDumpCmd ) join $ execParser (O.info (parser <**> helper) ( fullDesc @@ -22,21 +23,36 @@ main = do <> header "hbs2-git-oracle")) where - pkey = maybeReader fromStringMay + pkey = maybeReader (fromStringMay @(PubKey 'Sign HBS2Basic)) + + pRunIndexCmd = command "index" ( O.info pRunIndex (progDesc "run index") ) + + pRunIndex = do + chan <- option pkey ( long "refchan" <> short 'r' <> help "refchan to post" ) + author <- option pkey ( long "author" <> short 'a' <> help "author" ) + pure $ runApp chan (RunIndex author) + + pRunDumpCmd = command "dump" ( O.info pRunDump (progDesc "run index") ) + pRunDump = do + chan <- option pkey ( long "refchan" <> short 'r' <> help "refchan to post" ) + pure $ runApp chan RunDump + + runApp :: MonadUnliftIO m - => Bool - -> RefChanId L4Proto - -> RefChanAuthor L4Proto + => RefChanId L4Proto + -> RunMode -> m () -runApp _ rchan author = do +runApp chan mode = do setLogging @DEBUG (toStderr . logPrefix "[debug] ") setLogging @WARN (toStderr . logPrefix "[warn] ") setLogging @ERROR (toStderr . logPrefix "[error] ") setLogging @NOTICE (toStderr . logPrefix "[debug] ") - runWithOracleEnv rchan author runOracle + runWithOracleEnv chan $ case mode of + RunIndex a -> runOracleIndex a + RunDump{} -> runDump `finally` do setLoggingOff @DEBUG diff --git a/hbs2-git/hbs2-git-oracle/lib/HBS2/Git/Oracle/App.hs b/hbs2-git/hbs2-git-oracle/lib/HBS2/Git/Oracle/App.hs index 47b5fced..d07eb5e2 100644 --- a/hbs2-git/hbs2-git-oracle/lib/HBS2/Git/Oracle/App.hs +++ b/hbs2-git/hbs2-git-oracle/lib/HBS2/Git/Oracle/App.hs @@ -17,7 +17,7 @@ import Codec.Serialise data OracleEnv = OracleEnv { _refchanId :: RefChanId L4Proto - , _refchanAuthor :: RefChanAuthor L4Proto + -- , _refchanAuthor :: RefChanAuthor L4Proto , _peerAPI :: ServiceCaller PeerAPI UNIX , _reflogAPI :: ServiceCaller RefLogAPI UNIX , _refchanAPI :: ServiceCaller RefChanAPI UNIX @@ -39,10 +39,10 @@ newtype Oracle m a = runWithOracleEnv :: MonadUnliftIO m => RefChanId L4Proto - -> RefChanAuthor L4Proto + -- -> RefChanAuthor L4Proto -> Oracle m () -> m () -runWithOracleEnv rchan author m = do +runWithOracleEnv rchan m = do soname <- detectRPC `orDie` "can't locate rpc" @@ -58,7 +58,7 @@ runWithOracleEnv rchan author m = do let sto = AnyStorage (StorageClient storageAPI) env <- pure $ OracleEnv rchan - author + -- author peerAPI reflogAPI refchanAPI diff --git a/hbs2-git/hbs2-git-oracle/lib/HBS2/Git/Oracle/Run.hs b/hbs2-git/hbs2-git-oracle/lib/HBS2/Git/Oracle/Run.hs index 9586146f..b5176e21 100644 --- a/hbs2-git/hbs2-git-oracle/lib/HBS2/Git/Oracle/Run.hs +++ b/hbs2-git/hbs2-git-oracle/lib/HBS2/Git/Oracle/Run.hs @@ -23,6 +23,7 @@ import Control.Monad.Trans.Maybe import Data.Coerce import Data.Ord import Data.Text qualified as Text +import Data.HashMap.Strict qualified as HM import Control.Monad.Trans.Except import Data.List import Data.ByteString.Lazy qualified as LBS @@ -30,13 +31,16 @@ import Safe {- HLINT ignore "Functor law" -} +deriving instance Data (RefLogKey HBS2Basic) +deriving instance Data (LWWRefKey HBS2Basic) + data GitRepoRefFact = GitRepoFact1 { gitLwwRef :: LWWRefKey HBS2Basic , gitLwwSeq :: Word64 , gitRefLog :: RefLogKey HBS2Basic } - deriving stock (Generic) + deriving stock (Generic,Data) data GitRepoHeadFact = GitRepoHeadFact1 @@ -45,13 +49,13 @@ data GitRepoHeadFact = , gitRepoBrief :: Text , gitRepoEncrypted :: Bool } - deriving stock (Generic) + deriving stock (Generic,Data) data GitRepoFacts = GitRepoRefFact GitRepoRefFact | GitRepoHeadFact HashRef GitRepoHeadFact - deriving stock (Generic) + deriving stock (Generic,Data) instance Serialise GitRepoRefFact @@ -60,7 +64,7 @@ instance Serialise GitRepoFacts instance Pretty GitRepoFacts where pretty (GitRepoRefFact x) = pretty x - pretty (GitRepoHeadFact _ x) = pretty x + pretty (GitRepoHeadFact ha x) = pretty ("gitrpoheadfact",ha,x) instance Pretty GitRepoRefFact where pretty (GitRepoFact1{..}) = @@ -71,9 +75,10 @@ instance Pretty GitRepoHeadFact where parens ( "gitrepoheadfact1" <+> hsep [pretty gitRepoHeadRef]) -runOracle :: forall m . MonadUnliftIO m - => Oracle m () -runOracle = do +runOracleIndex :: forall m . MonadUnliftIO m + => PubKey 'Sign HBS2Basic + -> Oracle m () +runOracleIndex auPk = do debug "hbs2-git-oracle" debug "list all git references from peer" @@ -141,7 +146,6 @@ runOracle = do rchanAPI <- asks _refchanAPI chan <- asks _refchanId - auPk <- asks _refchanAuthor auCreds <- runKeymanClient do loadCredentials auPk >>= orThrowUser "can't load credentials" @@ -154,3 +158,66 @@ runOracle = do void $ callRpcWaitMay @RpcRefChanPropose (TimeoutSec 1) rchanAPI (chan, box) debug $ "posted tx" <+> pretty (hashObject @HbSync (serialise f)) + +runDump :: forall m . MonadUnliftIO m + => Oracle m () +runDump = do + chan <- asks _refchanId + rchanAPI <- asks _refchanAPI + sto <- asks _storage + + void $ runMaybeT do + + rv <- lift (callRpcWaitMay @RpcRefChanGet (TimeoutSec 1) rchanAPI chan) + >>= toMPlus >>= toMPlus + + liftIO $ print $ pretty rv + + facts <- S.toList_ do + walkMerkle @[HashRef] (fromHashRef rv) (getBlock sto) $ \case + Left{} -> pure () + Right txs -> do + for_ txs $ \htx -> void $ runMaybeT do + getBlock sto (fromHashRef htx) + >>= toMPlus + <&> deserialiseOrFail @(RefChanUpdate L4Proto) + >>= toMPlus + >>= \case + Propose _ box -> pure box + _ -> mzero + <&> unboxSignedBox0 + >>= toMPlus + <&> snd + >>= \(ProposeTran _ box) -> toMPlus (unboxSignedBox0 box) + <&> snd + <&> deserialiseOrFail @GitRepoFacts . LBS.fromStrict + >>= toMPlus + >>= lift . S.yield + + let rf = [ (HashRef (hashObject $ serialise f), f) + | f@GitRepoFact1{} <- universeBi facts + ] & HM.fromListWith (\v1 v2 -> if gitLwwSeq v1 > gitLwwSeq v2 then v1 else v2) + + + let rhf = [ (h,f) | (GitRepoHeadFact h f) <- universeBi facts ] + & HM.fromList + + for_ (HM.toList rf) $ \(k, GitRepoFact1{..}) -> do + let d = HM.lookup k rhf + let nm = maybe "" gitRepoName d + let brief = maybe "" gitRepoBrief d + liftIO $ print $ "repo" + <+> pretty gitLwwRef + <+> pretty nm + <+> pretty brief + pure () + + -- let rhf = [ (h,f) | (GitRepoHeadFact h f) <- universeBi facts ] + + -- lift do + -- for_ rf $ \f -> do + -- liftIO $ print $ pretty (hashObject @HbSync (serialise f), f) + + -- for_ rhf $ \(h,f) -> do + -- liftIO $ print $ pretty (h, f) + diff --git a/hbs2-peer/app/Browser/Root.hs b/hbs2-peer/app/Browser/Root.hs index eb221d63..40bcef1c 100644 --- a/hbs2-peer/app/Browser/Root.hs +++ b/hbs2-peer/app/Browser/Root.hs @@ -117,7 +117,6 @@ browserRootPage syn = rootPage do p_ (toHtml s) - channelPage :: Monad m => RefChanId L4Proto -> HtmlT m () channelPage chan = rootPage $ pure ()