From 5796ea3c73084a69687466114ab75aac9d86cc7f Mon Sep 17 00:00:00 2001 From: Dmitry Zuikov Date: Mon, 2 Sep 2024 11:59:16 +0300 Subject: [PATCH] refchan:init --- .fixme-new/config | 1 + fixme-new/fixme.cabal | 1 + fixme-new/lib/Fixme/Run.hs | 138 ++++++++++++++++-- fixme-new/lib/Fixme/Types.hs | 9 ++ hbs2-cli/lib/HBS2/CLI/Run/KeyMan.hs | 4 +- hbs2-cli/lib/HBS2/CLI/Run/RefChan.hs | 5 +- .../HBS2/KeyMan/Keys/Direct.hs | 16 ++ 7 files changed, 159 insertions(+), 15 deletions(-) diff --git a/.fixme-new/config b/.fixme-new/config index 005a8e79..d8f078f6 100644 --- a/.fixme-new/config +++ b/.fixme-new/config @@ -59,3 +59,4 @@ fixme-comments ";" "--" (define (stage) (fixme:stage:show)) +(refchan 3WtddmcE8zzgBAPR7Bu7mKMaVMTN423NNXSPUJp3Hx42) \ No newline at end of file diff --git a/fixme-new/fixme.cabal b/fixme-new/fixme.cabal index 9dc380b6..98f19070 100644 --- a/fixme-new/fixme.cabal +++ b/fixme-new/fixme.cabal @@ -57,6 +57,7 @@ common shared-properties , hbs2-storage-simple , hbs2-keyman-direct-lib , hbs2-git + , hbs2-cli , db-pipe , suckless-conf , fuzzy-parse diff --git a/fixme-new/lib/Fixme/Run.hs b/fixme-new/lib/Fixme/Run.hs index 964ffaff..3f20085a 100644 --- a/fixme-new/lib/Fixme/Run.hs +++ b/fixme-new/lib/Fixme/Run.hs @@ -10,12 +10,20 @@ import Fixme.Scan.Git.Local as Git import Fixme.Scan as Scan import Fixme.Log +import HBS2.KeyMan.Keys.Direct + import HBS2.Git.Local.CLI import HBS2.Peer.Proto.RefChan.Types +import HBS2.CLI.Run.KeyMan (keymanNewCredentials) + import HBS2.OrDie import HBS2.Peer.CLI.Detect +import HBS2.Net.Auth.GroupKeySymm +import HBS2.Data.Types.SignedBox import HBS2.Base58 +import HBS2.Storage.Operations.ByteString +import HBS2.Net.Auth.Credentials import HBS2.Merkle import HBS2.Data.Types.Refs import HBS2.Storage @@ -45,12 +53,12 @@ import Control.Monad.Identity import Lens.Micro.Platform import System.Environment import System.Process.Typed +import Control.Monad import Control.Monad.Trans.Cont import Control.Monad.Trans.Maybe import System.IO.Temp as Temp import System.IO qualified as IO - {- HLINT ignore "Functor law" -} @@ -122,6 +130,7 @@ runFixmeCLI m = do <*> newTVarIO mempty <*> newTVarIO (1,3) <*> newTVarIO mzero + <*> newTVarIO mzero -- FIXME: defer-evolve -- не все действия требуют БД, @@ -177,6 +186,11 @@ runCLI = do runTop forms +notEmpty :: [a] -> Maybe [a] +notEmpty = \case + [] -> Nothing + x -> Just x + runTop :: forall m . FixmePerks m => [Syntax C] -> FixmeM m () runTop forms = do @@ -304,6 +318,18 @@ runTop forms = do entry $ bindMatch "env:show" $ nil_ $ const $ do lift printEnv + entry $ bindMatch "refchan:show" $ nil_ $ const do + tref <- lift $ asks fixmeEnvRefChan + r <- readTVarIO tref + liftIO $ print $ pretty (fmap AsBase58 r) + + entry $ bindMatch "refchan" $ nil_ \case + [SignPubKeyLike rchan] -> do + tref<- lift $ asks fixmeEnvRefChan + atomically $ writeTVar tref (Just rchan) + + _ -> throwIO $ BadFormException @C nil + entry $ bindMatch "git:commits" $ const $ do co <- lift listCommits <&> fmap (mkStr @C . view _1) pure $ mkList co @@ -383,6 +409,10 @@ runTop forms = do entry $ bindMatch "fixme:stage:clean" $ nil_ $ const do lift cleanStage + entry $ bindMatch "fixme:config:path" $ const do + co <- localConfig + pure $ mkStr @C co + entry $ bindMatch "git:import" $ nil_ $ const do lift $ scanGitLocal mempty Nothing @@ -409,24 +439,106 @@ runTop forms = do entry $ bindMatch "refchan:init" $ nil_ $ const $ do let rch0 = refChanHeadDefault @L4Proto + sto <- lift getStorage + peer <- lift $ getClientAPI @PeerAPI @UNIX + rchanApi <- lift $ getClientAPI @RefChanAPI @UNIX - rch <- flip runContT pure do + confFile <- localConfig + conf <- liftIO (readFile confFile) + <&> parseTop + <&> either (error.show) (fmap (fixContext @_ @C)) - notice $ yellow "1. find group key" + let already = headMay [ x + | ListVal [StringLike "refchan", SignPubKeyLike x] <- conf + ] - -- TODO: use-hbs2-git-api? - (e, gkh, _) <- readProcess (shell [qc|git hbs2 key|]) - <&> over _2 (fromStringMay @HashRef . headDef "" . lines . LBS8.unpack) + flip runContT pure $ callCC \done -> do - notice $ "gkh:" <+> pretty gkh + when (isJust already) do + warn $ red "refchan is already set" <+> pretty (fmap AsBase58 already) - notice $ yellow "2. generate refchan head" - notice $ yellow "3. subscribe peer to this refchan" - notice $ yellow "4. post refcha head" - notice $ yellow "5. add def-refchan ins to the config" - notice $ green "6. we're done" + poked <- lift $ callRpcWaitMay @RpcPoke (TimeoutSec 1) peer () + >>= orThrowUser "hbs2-peer not connected" + <&> parseTop + <&> fromRight mempty - pure () + pkey <- [ fromStringMay @(PubKey 'Sign 'HBS2Basic) x + | ListVal [SymbolVal "peer-key:", StringLike x ] <- poked + ] & headMay . catMaybes & orThrowUser "hbs2-peer key not set" + + + notice $ green "default peer" <+> pretty (AsBase58 pkey) + + + signK' <- lift $ runKeymanClientRO $ listCredentials + <&> headMay + + signK <- ContT $ maybe1 signK' (throwIO $ userError "no default author key found in hbs2-keyman") + + notice $ green "default author" <+> pretty (AsBase58 signK) + + -- TODO: use-hbs2-git-api? + (_, gkh', _) <- readProcess (shell [qc|git hbs2 key|]) + <&> over _2 ( (fromStringMay @HashRef) <=< (notEmpty . headDef "" . lines . LBS8.unpack) ) + <&> \x -> case view _1 x of + ExitFailure _ -> set _2 Nothing x + ExitSuccess -> x + + notice $ green "group key" <+> maybe "none" pretty gkh' + + readers <- fromMaybe mempty <$> runMaybeT do + gh <- toMPlus gkh' + gk <- loadGroupKeyMaybe @'HBS2Basic sto gh + >>= toMPlus + pure $ HM.keys (recipients gk) + + notice $ green "readers" <+> pretty (length readers) + + let rch1 = rch0 & set refChanHeadReaders (HS.fromList readers) + & set refChanHeadAuthors (HS.singleton signK) + & set refChanHeadPeers (HM.singleton pkey 1) + + + let unlucky = HM.null (view refChanHeadPeers rch1) + || HS.null (view refChanHeadAuthors rch1) + + + liftIO $ print $ pretty rch1 + + if unlucky then do + warn $ red $ "refchan definition is not complete;" <+> + "you may add missed keys, edit the" <+> + "defition and add if manually or repeat init attempt" + <> line + else do + notice "refchan definition seems okay, adding new refchan" + refchan <- lift $ keymanNewCredentials (Just "refchan") 0 + + creds <- lift $ runKeymanClientRO $ loadCredentials refchan + >>= orThrowUser "can't load credentials" + + let box = makeSignedBox @'HBS2Basic (view peerSignPk creds) (view peerSignSk creds) rch1 + + href <- writeAsMerkle sto (serialise box) + + callService @RpcPollAdd peer (refchan, "refchan", 17) + >>= orThrowUser "can't subscribe to refchan" + + callService @RpcRefChanHeadPost rchanApi (HashRef href) + >>= orThrowUser "can't post refchan head" + + liftIO $ appendFile confFile $ + show $ pretty ( mkList @C [ mkSym "refchan" + , mkSym (show $ pretty (AsBase58 refchan)) ] + ) + + pure () + + -- notice $ yellow "2. generate refchan head" + -- notice $ yellow "3. subscribe peer to this refchan" + -- notice $ yellow "4. post refcha head" + -- notice $ yellow "5. add def-refchan ins to the config" + -- notice $ green "6. we're done" entry $ bindMatch "set-template" $ nil_ \case diff --git a/fixme-new/lib/Fixme/Types.hs b/fixme-new/lib/Fixme/Types.hs index e5fb6b7c..0c427f11 100644 --- a/fixme-new/lib/Fixme/Types.hs +++ b/fixme-new/lib/Fixme/Types.hs @@ -1,4 +1,5 @@ {-# LANGUAGE PatternSynonyms, ViewPatterns, TemplateHaskell #-} +{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Fixme.Types ( module Fixme.Types @@ -293,6 +294,7 @@ data FixmeEnv = , fixmeEnvMacro :: TVar (HashMap Id (Syntax C)) , fixmeEnvCatContext :: TVar (Int,Int) , fixmeEnvMyEndpoints :: TVar (Maybe MyPeerClientEndpoints) + , fixmeEnvRefChan :: TVar (Maybe (PubKey 'Sign 'HBS2Basic)) } @@ -352,6 +354,7 @@ fixmeEnvBare = <*> newTVarIO mempty <*> newTVarIO (1,3) <*> newTVarIO mzero + <*> newTVarIO mzero withFixmeEnv :: FixmePerks m => FixmeEnv -> FixmeM m a -> m a withFixmeEnv env what = runReaderT ( fromFixmeM what) env @@ -376,6 +379,12 @@ instance (FixmePerks m, MonadReader FixmeEnv m) => HasClientAPI RefChanAPI UNIX instance (FixmePerks m, MonadReader FixmeEnv m) => HasClientAPI StorageAPI UNIX m where getClientAPI = getApiOrThrow peerStorageAPI + +instance (FixmePerks m, MonadReader FixmeEnv m) => HasStorage m where + getStorage = do + api <- getClientAPI @StorageAPI @UNIX + pure $ AnyStorage (StorageClient api) + getApiOrThrow :: (MonadReader FixmeEnv m, MonadIO m) => Getting b MyPeerClientEndpoints b -> m b getApiOrThrow getter = diff --git a/hbs2-cli/lib/HBS2/CLI/Run/KeyMan.hs b/hbs2-cli/lib/HBS2/CLI/Run/KeyMan.hs index 43a92c3b..68846f19 100644 --- a/hbs2-cli/lib/HBS2/CLI/Run/KeyMan.hs +++ b/hbs2-cli/lib/HBS2/CLI/Run/KeyMan.hs @@ -1,5 +1,7 @@ module HBS2.CLI.Run.KeyMan - (keymanEntries) where + ( module HBS2.CLI.Run.KeyMan + , keymanNewCredentials + ) where import HBS2.CLI.Prelude import HBS2.CLI.Run.Internal diff --git a/hbs2-cli/lib/HBS2/CLI/Run/RefChan.hs b/hbs2-cli/lib/HBS2/CLI/Run/RefChan.hs index 878ba42e..16cddd63 100644 --- a/hbs2-cli/lib/HBS2/CLI/Run/RefChan.hs +++ b/hbs2-cli/lib/HBS2/CLI/Run/RefChan.hs @@ -1,4 +1,7 @@ -module HBS2.CLI.Run.RefChan where +module HBS2.CLI.Run.RefChan + ( module HBS2.CLI.Run.RefChan + , keymanNewCredentials + ) where import HBS2.CLI.Prelude import HBS2.CLI.Run.Internal diff --git a/hbs2-keyman/hbs2-keyman-direct-lib/HBS2/KeyMan/Keys/Direct.hs b/hbs2-keyman/hbs2-keyman-direct-lib/HBS2/KeyMan/Keys/Direct.hs index 5fb1eb81..d8081eb5 100644 --- a/hbs2-keyman/hbs2-keyman-direct-lib/HBS2/KeyMan/Keys/Direct.hs +++ b/hbs2-keyman/hbs2-keyman-direct-lib/HBS2/KeyMan/Keys/Direct.hs @@ -70,6 +70,22 @@ runKeymanClient action = do void $ ContT $ bracket (async (runPipe db)) cancel lift $ withDB db (fromKeyManClient action) +listCredentials :: forall m . + ( MonadIO m + , SerialisedCredentials 'HBS2Basic + ) + => KeyManClient m [PubKey 'Sign 'HBS2Basic] +listCredentials = KeyManClient do + select_ [qc| + select f.key + from keytype t + join keyfile f on t.key = f.key + left join keyweight w on w.key = f.key + where t.type = 'sign' + order by w.weight desc nulls last + limit 100 |] + <&> mapMaybe ( fromStringMay . fromOnly ) + loadCredentials :: forall a m . ( MonadIO m , SomePubKeyPerks a