refchan:init

.fixme-new/config

@@ -59,3 +59,4 @@ fixme-comments ";" "--"
 (define (stage) (fixme:stage:show))
 
 
+(refchan 3WtddmcE8zzgBAPR7Bu7mKMaVMTN423NNXSPUJp3Hx42)

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

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?
+           flip runContT pure $ callCC \done -> do
-               (e, gkh, _) <- readProcess (shell [qc|git hbs2 key|])
-                                <&> over _2 (fromStringMay @HashRef . headDef "" . lines . LBS8.unpack)
 
-               notice $ "gkh:" <+> pretty gkh
+             when (isJust already) do
+              warn $ red "refchan is already set" <+> pretty (fmap AsBase58 already)
 
-               notice $ yellow "2. generate refchan head"
+             poked <- lift $ callRpcWaitMay @RpcPoke (TimeoutSec 1) peer ()
-               notice $ yellow "3. subscribe peer to this refchan"
+                        >>= orThrowUser "hbs2-peer not connected"
-               notice $ yellow "4. post refcha head"
+                        <&> parseTop
-               notice $ yellow "5. add def-refchan ins to the config"
+                        <&> fromRight mempty
-               notice $ green  "6. we're done"
 
-           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

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 =

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

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

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