wip

cabal.project

@@ -1,5 +1,6 @@
 packages: **/*.cabal
   examples/*/*.cabal
+  **/*/*.cabal
 
 allow-newer: all
 

fixme-new/fixme.cabal

@@ -55,7 +55,7 @@ common shared-properties
         hbs2-core
       , hbs2-peer
       , hbs2-storage-simple
-      , hbs2-keyman
+      , hbs2-keyman-direct-lib
       , hbs2-git
       , db-pipe
       , suckless-conf

flake.nix

@@ -44,6 +44,7 @@ outputs = { self, nixpkgs, haskell-flake-utils, ... }@inputs:
      "hbs2-git"
      "hbs2-qblf"
      "hbs2-keyman"
+     "hbs2-keyman-direct-lib"
      "hbs2-fixer"
      "hbs2-cli"
      "hbs2-sync"
@@ -68,7 +69,8 @@ outputs = { self, nixpkgs, haskell-flake-utils, ... }@inputs:
      "hbs2-core"   = "./hbs2-core";
      "hbs2-storage-simple" = "./hbs2-storage-simple";
      "hbs2-peer"   = "./hbs2-peer";
-     "hbs2-keyman" = "./hbs2-keyman";
+     "hbs2-keyman" = "./hbs2-keyman/hbs2-keyman";
+     "hbs2-keyman-direct-lib" = "./hbs2-keyman/hbs2-keyman-direct-lib";
      "hbs2-git"    = "./hbs2-git";
      "hbs2-fixer"  = "./hbs2-fixer";
      "hbs2-cli"    = "./hbs2-cli";

hbs2-cli/hbs2-cli.cabal

@@ -57,7 +57,7 @@ common shared-properties
         hbs2-core
       , hbs2-peer
       , hbs2-storage-simple
-      , hbs2-keyman
+      , hbs2-keyman-direct-lib
       , db-pipe
       , suckless-conf
 

hbs2-core/lib/HBS2/Net/Auth/GroupKeySymm.hs

@@ -88,7 +88,7 @@ type Recipients s = HashMap (PubKey 'Encrypt s) (EncryptedBox GroupSecret)
 
 -- NOTE: breaking-change
 
-data GroupKeyIdScheme = GroupKeyIdJustHash
+data GroupKeyIdScheme = GroupKeyIdBasic1 -- encrypt zeroes then hash
                         deriving stock (Eq,Ord,Generic,Show)
 
 newtype GroupKeyId = GroupKeyId N.ByteString
@@ -99,7 +99,7 @@ instance Pretty GroupKeyId where
 
 instance Pretty GroupKeyIdScheme where
   pretty = \case
-    GroupKeyIdJustHash -> "just-hash"
+    GroupKeyIdBasic1  -> "basic1"
 
 -- NOTE: not-a-monoid
 --  это моноид, но опасный, потому, что секретные ключи у двух разных
@@ -219,6 +219,7 @@ instance (Pretty (AsBase58 (PubKey 'Encrypt s)) ) => Pretty (GroupKey 'Symm s) w
         GroupKeySymmFancy{} -> ";" <+> "fancy group key" <> line
                                <> "group-key-id" <+> pretty (getGroupKeyId g) <> line
                                <> "group-key-id-scheme" <+> pretty (getGroupKeyIdScheme g) <> line
+                               <> "group-key-timestamp" <+> pretty (getGroupKeyTimestamp g) <> line
 
 
 instance ForGroupKeySymm s => FromStringMaybe (GroupKey 'Symm s) where
@@ -267,6 +268,9 @@ generateGroupKeyPlain mbk rcpt = do
   what <- generateGroupKeyFancy @s mbk rcpt
   pure $ GroupKeySymmPlain (recipients what)
 
+groupKeyCheckSeed :: N.ByteString
+groupKeyCheckSeed = BS.replicate 32 0
+
 generateGroupKeyFancy :: forall s m . (ForGroupKeySymm s, MonadIO m, PubKey 'Encrypt s ~ AK.PublicKey)
                  => Maybe GroupSecret
                  -> [PubKey 'Encrypt s]
@@ -280,11 +284,11 @@ generateGroupKeyFancy mbk pks = create
       rcpt <- forM pks $ \pk -> do
                 box <- liftIO $ AK.boxSeal pk (LBS.toStrict $ serialise sk) <&> EncryptedBox
                 pure (pk, box)
-      let enc = SK.secretbox sk (nonceFrom (mempty :: ByteString)) (LBS.toStrict $ serialise sk)
+      let enc = SK.secretbox sk (nonceFrom (mempty :: ByteString)) groupKeyCheckSeed
       let ha = hashObject @HbSync enc
       pure $ GroupKeySymmFancy
                 (HashMap.fromList rcpt)
-                (Just GroupKeyIdJustHash)
+                (Just GroupKeyIdBasic1)
                 (Just (GroupKeyId (coerce ha)))
                 now
 

hbs2-core/lib/HBS2/Net/Messaging/Unix.hs

@@ -225,10 +225,10 @@ runMessagingUnix env = do
     clientLoop m = fix \next -> do
       m
       if not (MUDontRetry `elem` msgUnixOpts env) then do
-        debug "LOOP!"
+        trace "LOOP!"
         next
       else do
-        debug "LOOP EXIT"
+        trace "LOOP EXIT"
 
     handleClient | MUDontRetry `elem` msgUnixOpts env  = \_ w -> handleAny throwStopped w
                  | otherwise =  handleAny
@@ -237,8 +237,6 @@ runMessagingUnix env = do
 
     runClient = liftIO $ clientLoop $ handleClient logAndRetry $ flip runContT pure $ do
 
-      debug "HERE WE GO AGAIN!"
-
       let sa   = SockAddrUnix (msgUnixSockPath env)
       let p  = msgUnixSockPath env
       let who = PeerUNIX p

hbs2-git/hbs2-git.cabal

@@ -55,7 +55,7 @@ common shared-properties
         hbs2-core
       , hbs2-peer
       , hbs2-storage-simple
-      , hbs2-keyman
+      , hbs2-keyman-direct-lib
       , db-pipe
       , suckless-conf
 

hbs2-keyman/app/Main.hs

@@ -1,144 +0,0 @@
-module Main where
-
-import HBS2.KeyMan.Prelude
-import HBS2.KeyMan.App.Types
-import HBS2.KeyMan.Config
-import HBS2.KeyMan.State
-
-import HBS2.Net.Auth.Credentials
-
-import HBS2.Data.KeyRing qualified as KeyRing
-
-import HBS2.System.Dir
-
-
-import Data.Config.Suckless.KeyValue
-import Data.Config.Suckless
-
-import Options.Applicative qualified as O
-import Data.Text qualified as Text
-import Options.Applicative hiding (info)
-import Data.Set qualified as Set
-import Data.ByteString qualified as BS
-import Control.Monad.Trans.Maybe
-import Control.Monad.Reader
-
-
-data GlobalOptions = GlobalOptions
-  {
-  }
-
-type Command m = m ()
-
--- Парсер для глобальных опций
-globalOptions :: Parser GlobalOptions
-globalOptions = pure GlobalOptions
-
-type AppPerks m = (MonadIO m, MonadUnliftIO m, MonadReader AppEnv m, HasConf m, SerialisedCredentials 'HBS2Basic)
-
--- TODO: key-mamagement-command-about-to-move-here
-
-commands :: (AppPerks m) => Parser (Command m)
-commands = hsubparser
-  (  command "update"     (O.info (updateKeys <**> helper) (progDesc "update keys" ))
-  <> command "list"       (O.info (listKeysCmd <**> helper) (progDesc "list keys" ))
-  <> command "disclose"   (O.info (discloseKeyCmd <**> helper) (progDesc "disclose credentials" ))
-  <> command "set-weight" (O.info (setWeightCmd <**> helper) (progDesc "set weight for a key"))
-  <> command "add-mask"   (O.info (addPath <**> helper) (progDesc "add path/mask to search keys, ex. '/home/user/keys/*.key'"))
-  <> command "config"     (O.info (showConfig <**> helper) (progDesc "show hbs2-keyman config"))
-  )
-
-opts :: (AppPerks m) => ParserInfo (GlobalOptions, Command m)
-opts = O.info (liftA2 (,) globalOptions commands <**> helper)
-  ( fullDesc
- <> header "hbs2-keyman" )
-
-
-showConfig :: (AppPerks m) => Parser (Command m)
-showConfig = do
-  pure do
-    readConfig >>=  liftIO . print . vcat . fmap pretty
-
-addPath :: (AppPerks m) => Parser (Command m)
-addPath = do
-  masks <- many $ strArgument (metavar "KEYFILE-MASK")
-  pure do
-    cfg <- getConfigPath <&> takeDirectory
-    mkdir cfg
-    for_ masks $ \m -> do
-      liftIO $ appendFile (cfg </> "config") (show $ "key-files" <+> dquotes (pretty m) <> line)
-
-listKeysCmd :: (AppPerks m) => Parser (Command m)
-listKeysCmd = pure do
-  kw <- withState listKeys
-  liftIO $ print $ vcat (fmap pretty kw)
-
-updateKeys :: (AppPerks m) => Parser (Command m)
-updateKeys = do
-  prune <- flag False True ( long "prune" <> short 'p' <> help "prune keys for missed files")
-  pure do
-
-    conf <- getConf
-
-    masks <- cfgValue @KeyFilesOpt @(Set String) <&> Set.toList
-    files <- KeyRing.findFilesBy masks
-
-    when prune do
-      -- here <- doesPathExist fn
-      --
-      keys <- withState listKeys
-      for_ keys $ \k -> void $ runMaybeT do
-        fn <- keyFile k & toMPlus <&> Text.unpack
-        here <- doesPathExist fn
-        unless here do
-          info $ "prune" <+> pretty fn
-          lift $ withState $ deleteKey (keyId k)
-
-    for_ files $ \fn -> runMaybeT do
-
-      bs <- liftIO $ BS.readFile fn
-
-      krf <- parseCredentials @'HBS2Basic (AsCredFile bs) & toMPlus
-
-      let skp = view peerSignPk krf
-
-      withState do
-        -- info $ pretty (AsBase58 skp) <+> pretty "sign" <+> pretty fn
-        updateKeyFile (SomePubKey @'Sign skp) fn
-        updateKeyType (SomePubKey @'Sign skp)
-
-        for_ (view peerKeyring  krf) $ \(KeyringEntry pk _ _) -> do
-          -- info $ pretty (AsBase58 pk) <+> pretty "encrypt" <+> pretty fn
-          updateKeyFile (SomePubKey @'Encrypt pk) fn
-          updateKeyType (SomePubKey @'Encrypt pk)
-
-        commitAll
-
-    -- scanning refchans for group keys
-
-    let rchans = [ r | ListVal [SymbolVal "refchan", SignPubKeyLike r] <- conf ]
-
-    for_ rchans $ \rchan -> do
-      notice $ yellow "scanning refchan" <+> pretty (AsBase58 rchan)
-
-
-setWeightCmd :: (AppPerks m) => Parser (Command m)
-setWeightCmd = do
-  k <- argument str (metavar "KEY" <> help "Key identifier")
-  v <- argument auto (metavar "WEIGHT" <> help "Weight value")
-  pure do
-    withState $ updateKeyWeight k v
-
-discloseKeyCmd :: (AppPerks m) => Parser (Command m)
-discloseKeyCmd  = do
-  -- k <- argument str (metavar "KEY" <> help "Key identifier")
-  -- v <- argument auto (metavar "WEIGHT" <> help "Weight value")
-  pure do
-    notice "WIP"
-
-main :: IO ()
-main = do
-  (_, action) <- execParser opts
-  runApp action
-
-

hbs2-keyman/hbs2-keyman-direct-lib/LICENSE

@@ -0,0 +1,30 @@
+Copyright (c) 2023, Dmitry Zuikov
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+    * Redistributions of source code must retain the above copyright
+      notice, this list of conditions and the following disclaimer.
+
+    * Redistributions in binary form must reproduce the above
+      copyright notice, this list of conditions and the following
+      disclaimer in the documentation and/or other materials provided
+      with the distribution.
+
+    * Neither the name of Dmitry Zuikov nor the names of other
+      contributors may be used to endorse or promote products derived
+      from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

hbs2-keyman/hbs2-keyman-direct-lib/hbs2-keyman-direct-lib.cabal

@@ -0,0 +1,109 @@
+cabal-version:      3.0
+name:               hbs2-keyman-direct-lib
+version:            0.24.1.2
+-- synopsis:
+-- description:
+license:            BSD-3-Clause
+license-file:       LICENSE
+author:             Dmitry Zuikov
+maintainer:         dzuikov@gmail.com
+-- copyright:
+category:           Data
+build-type:         Simple
+-- extra-doc-files:    CHANGELOG.md
+-- extra-source-files:
+
+common warnings
+    ghc-options: -Wall -fno-warn-type-defaults
+
+common common-deps
+    build-depends:
+          base, hbs2-core, hbs2-storage-simple, suckless-conf, db-pipe
+        , async
+        , bytestring
+        , cache
+        , containers
+        , data-default
+        , deepseq
+        , directory
+        , filepath
+        , filepattern
+        , generic-lens
+        , hashable
+        , heaps
+        , microlens-platform
+        , mtl
+        , mwc-random
+        , prettyprinter
+        , QuickCheck
+        , random
+        , random-shuffle
+        , resourcet
+        , safe
+        , serialise
+        , split
+        , stm
+        , streaming
+        , tasty
+        , tasty-hunit
+        , temporary
+        , text
+        , timeit
+        , transformers
+        , uniplate
+        , unordered-containers
+        , vector
+        , prettyprinter-ansi-terminal
+        , interpolatedstring-perl6
+        , unliftio
+
+  default-extensions:
+                       ApplicativeDo
+                     , BangPatterns
+                     , BlockArguments
+                     , ConstraintKinds
+                     , DataKinds
+                     , DeriveDataTypeable
+                     , DeriveGeneric
+                     , DerivingStrategies
+                     , DerivingVia
+                     , ExtendedDefaultRules
+                     , FlexibleContexts
+                     , FlexibleInstances
+                     , GADTs
+                     , GeneralizedNewtypeDeriving
+                     , ImportQualifiedPost
+                     , LambdaCase
+                     , MultiParamTypeClasses
+                     , OverloadedStrings
+                     , OverloadedLabels
+                     , QuasiQuotes
+                     , RankNTypes
+                     , RecordWildCards
+                     , RecursiveDo
+                     , ScopedTypeVariables
+                     , StandaloneDeriving
+                     , TupleSections
+                     , TypeApplications
+                     , TypeFamilies
+                     , TypeOperators
+
+
+
+library
+    import:           warnings
+    import:           common-deps
+
+    exposed-modules:
+      HBS2.KeyMan.App.Types
+      HBS2.KeyMan.Prelude
+      HBS2.KeyMan.Config
+      HBS2.KeyMan.State
+      HBS2.KeyMan.Keys.Direct
+
+    -- other-modules:
+    -- other-extensions:
+    build-depends:    base
+    hs-source-dirs:   .
+    default-language: GHC2021
+

hbs2-keyman/hbs2-keyman/LICENSE

@@ -0,0 +1,30 @@
+Copyright (c) 2023, Dmitry Zuikov
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+    * Redistributions of source code must retain the above copyright
+      notice, this list of conditions and the following disclaimer.
+
+    * Redistributions in binary form must reproduce the above
+      copyright notice, this list of conditions and the following
+      disclaimer in the documentation and/or other materials provided
+      with the distribution.
+
+    * Neither the name of Dmitry Zuikov nor the names of other
+      contributors may be used to endorse or promote products derived
+      from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

hbs2-keyman/hbs2-keyman/Main.hs

@@ -0,0 +1,250 @@
+module Main where
+
+import HBS2.KeyMan.Prelude
+import HBS2.KeyMan.App.Types
+import HBS2.KeyMan.Config
+import HBS2.KeyMan.State
+
+import HBS2.Net.Auth.Credentials
+
+import HBS2.Data.KeyRing qualified as KeyRing
+
+import HBS2.System.Dir
+
+import HBS2.Net.Auth.GroupKeySymm
+import HBS2.Storage
+import HBS2.Storage.Operations.ByteString
+import HBS2.Data.Types.SignedBox
+import HBS2.Peer.Proto.RefChan
+import HBS2.Peer.CLI.Detect
+import HBS2.Peer.RPC.Client
+import HBS2.Peer.RPC.Client.Unix
+import HBS2.Peer.RPC.Client.RefChan
+import HBS2.Peer.RPC.API.RefChan
+import HBS2.Peer.RPC.API.Storage
+import HBS2.Peer.RPC.Client.StorageClient
+
+import Data.Config.Suckless.KeyValue
+import Data.Config.Suckless
+
+import Data.List qualified as List
+import Options.Applicative qualified as O
+import Data.Text qualified as Text
+import Options.Applicative hiding (info,action)
+import Data.Set qualified as Set
+import Data.ByteString qualified as BS
+import Data.ByteString qualified as LBS
+import Data.Maybe
+import Control.Monad.Trans.Maybe
+import Control.Monad.Trans.Cont
+import Control.Monad.Reader
+import Control.Monad.Except
+import Codec.Serialise
+import Data.Coerce
+
+import Streaming.Prelude qualified as S
+
+data GlobalOptions = GlobalOptions
+  {
+  }
+
+type Command m = m ()
+
+-- Парсер для глобальных опций
+globalOptions :: Parser GlobalOptions
+globalOptions = pure GlobalOptions
+
+type AppPerks m = (MonadIO m, MonadUnliftIO m, MonadReader AppEnv m, HasConf m, SerialisedCredentials 'HBS2Basic)
+
+-- TODO: key-mamagement-command-about-to-move-here
+
+commands :: (AppPerks m) => Parser (Command m)
+commands = hsubparser
+  (  command "update"     (O.info (updateKeys <**> helper) (progDesc "update keys" ))
+  <> command "list"       (O.info (listKeysCmd <**> helper) (progDesc "list keys" ))
+  <> command "disclose"   (O.info (discloseKeyCmd <**> helper) (progDesc "disclose credentials" ))
+  <> command "set-weight" (O.info (setWeightCmd <**> helper) (progDesc "set weight for a key"))
+  <> command "add-mask"   (O.info (addPath <**> helper) (progDesc "add path/mask to search keys, ex. '/home/user/keys/*.key'"))
+  <> command "config"     (O.info (showConfig <**> helper) (progDesc "show hbs2-keyman config"))
+  )
+
+opts :: (AppPerks m) => ParserInfo (GlobalOptions, Command m)
+opts = O.info (liftA2 (,) globalOptions commands <**> helper)
+  ( fullDesc
+ <> header "hbs2-keyman" )
+
+
+showConfig :: (AppPerks m) => Parser (Command m)
+showConfig = do
+  pure do
+    readConfig >>=  liftIO . print . vcat . fmap pretty
+
+addPath :: (AppPerks m) => Parser (Command m)
+addPath = do
+  masks <- many $ strArgument (metavar "KEYFILE-MASK")
+  pure do
+    cfg <- getConfigPath <&> takeDirectory
+    mkdir cfg
+    for_ masks $ \m -> do
+      liftIO $ appendFile (cfg </> "config") (show $ "key-files" <+> dquotes (pretty m) <> line)
+
+listKeysCmd :: (AppPerks m) => Parser (Command m)
+listKeysCmd = pure do
+  kw <- withState listKeys
+  liftIO $ print $ vcat (fmap pretty kw)
+
+
+data RChanScanEnv =
+  RChanScanEnv
+  { storage     :: AnyStorage
+  , refchanAPI  ::  ServiceCaller RefChanAPI UNIX
+  }
+
+newtype ScanRefChansM m a = ScanRefChansM { fromScanRefChansM :: ReaderT RChanScanEnv m a }
+                            deriving newtype ( Applicative
+                                             , Functor
+                                             , Monad
+                                             , MonadIO
+                                             , MonadUnliftIO
+                                             , MonadReader RChanScanEnv
+                                             , MonadTrans
+                                             )
+
+runScan :: Monad m => RChanScanEnv -> ScanRefChansM m a -> m a
+runScan env action = runReaderT ( fromScanRefChansM action ) env
+
+
+instance Monad m => HasClientAPI RefChanAPI UNIX (ScanRefChansM m) where
+  getClientAPI = asks refchanAPI
+
+instance Monad m => HasStorage (ScanRefChansM m) where
+  getStorage = asks storage
+
+
+updateKeys :: forall proto m . (AppPerks m, proto ~ UNIX) => Parser (Command m)
+updateKeys = do
+  prune <- flag False True ( long "prune" <> short 'p' <> help "prune keys for missed files")
+  pure do
+    updateLocalKeys prune
+    updateGroupKeys
+
+  where
+
+    updateGroupKeys = do
+      -- scanning refchans for group keys
+      conf <- getConf
+      let rchans = [ r | ListVal [SymbolVal "refchan", SignPubKeyLike r] <- conf ]
+
+      flip runContT pure $ callCC \exit -> do
+        when (List.null rchans) $ exit ()
+        so' <- detectRPC
+        so <- ContT $ maybe1 so' (warn $ yellow "peer is down")
+
+        rpc <- ContT $ withRPC2 @RefChanAPI so
+        sto <- ContT (withRPC2 @StorageAPI so) <&> AnyStorage . StorageClient
+
+        txs <- S.toList_ do
+          runScan (RChanScanEnv sto rpc) do
+
+            for_ rchans $ \r -> do
+
+              walkRefChanTx @proto (const $ pure True) r $ \tx0 -> \case
+                P _  (ProposeTran _ box) -> do
+
+                  notice $ green "got the fucking tx" <+> pretty tx0
+
+                  void $ runMaybeT do
+                    (_,bs) <- unboxSignedBox0 box & toMPlus
+
+                    AnnotatedHashRef _ gkh <- deserialiseOrFail @AnnotatedHashRef (LBS.fromStrict bs)
+                                                & toMPlus . either (const Nothing) Just
+
+                    -- FIXME: request-download-for-missed-groupkeys
+                    -- FIXME: implement-download-with-timeout
+                    gkbs <- runExceptT (readFromMerkle sto (SimpleKey (coerce gkh)))
+                              >>= toMPlus
+
+                    -- FIXME: do-it-right
+                    --   если смогли скачать -- то уже потом не будем обрабатывать
+                    --   потенциальная проблема -- мусорная транзакция, которая так и
+                    --   будет болтаться, если она не AnnotatedHashRef
+                    lift $ lift $ S.yield (Left tx0)
+
+                    gk <- deserialiseOrFail @(GroupKey 'Symm HBS2Basic) gkbs & toMPlus
+
+                    gkId <- getGroupKeyId gk & toMPlus
+
+                    --TODO: verify-group-key-id-if-possible
+
+                    notice $ green "found gk0" <+> pretty gkId <+> pretty gkh
+
+                    pure ()
+                    -- here <- hasBlock sto (coerce gkh)
+
+                    -- when (isJust here) do
+                    --   notice $ green "got the fucking GK" <+> pretty gkh
+
+                _ -> do
+                  lift $ S.yield (Left tx0)
+                  trace $ "ignore accept tx" <+> pretty tx0
+
+        pure ()
+
+    updateLocalKeys prune = do
+
+      masks <- cfgValue @KeyFilesOpt @(Set String) <&> Set.toList
+      files <- KeyRing.findFilesBy masks
+
+      when prune do
+        -- here <- doesPathExist fn
+        --
+        keys <- withState listKeys
+        for_ keys $ \k -> void $ runMaybeT do
+          fn <- keyFile k & toMPlus <&> Text.unpack
+          here <- doesPathExist fn
+          unless here do
+            info $ "prune" <+> pretty fn
+            lift $ withState $ deleteKey (keyId k)
+
+      for_ files $ \fn -> runMaybeT do
+
+        bs <- liftIO $ BS.readFile fn
+
+        krf <- parseCredentials @'HBS2Basic (AsCredFile bs) & toMPlus
+
+        let skp = view peerSignPk krf
+
+        withState do
+          -- info $ pretty (AsBase58 skp) <+> pretty "sign" <+> pretty fn
+          updateKeyFile (SomePubKey @'Sign skp) fn
+          updateKeyType (SomePubKey @'Sign skp)
+
+          for_ (view peerKeyring  krf) $ \(KeyringEntry pk _ _) -> do
+            -- info $ pretty (AsBase58 pk) <+> pretty "encrypt" <+> pretty fn
+            updateKeyFile (SomePubKey @'Encrypt pk) fn
+            updateKeyType (SomePubKey @'Encrypt pk)
+
+          commitAll
+
+
+
+setWeightCmd :: (AppPerks m) => Parser (Command m)
+setWeightCmd = do
+  k <- argument str (metavar "KEY" <> help "Key identifier")
+  v <- argument auto (metavar "WEIGHT" <> help "Weight value")
+  pure do
+    withState $ updateKeyWeight k v
+
+discloseKeyCmd :: (AppPerks m) => Parser (Command m)
+discloseKeyCmd  = do
+  -- k <- argument str (metavar "KEY" <> help "Key identifier")
+  -- v <- argument auto (metavar "WEIGHT" <> help "Weight value")
+  pure do
+    notice "WIP"
+
+main :: IO ()
+main = do
+  (_, action) <- execParser opts
+  runApp action
+
+

hbs2-keyman/hbs2-keyman/hbs2-keyman.cabal

@@ -90,23 +90,6 @@ common common-deps
 
 
 
-library
-    import:           warnings
-    import:           common-deps
-
-    exposed-modules:
-      HBS2.KeyMan.App.Types
-      HBS2.KeyMan.Prelude
-      HBS2.KeyMan.Config
-      HBS2.KeyMan.State
-      HBS2.KeyMan.Keys.Direct
-
-    -- other-modules:
-    -- other-extensions:
-    build-depends:    base
-    hs-source-dirs:   src
-    default-language: GHC2021
-
 executable hbs2-keyman
     import:           warnings
     import:           common-deps
@@ -116,9 +99,10 @@ executable hbs2-keyman
     -- other-extensions:
     build-depends:
           base
-        , hbs2-keyman
+        , hbs2-keyman-direct-lib
+        , hbs2-peer
         , optparse-applicative
 
-    hs-source-dirs:   app
+    hs-source-dirs:   .
     default-language: GHC2021
 

hbs2-peer/hbs2-peer.cabal

@@ -284,7 +284,7 @@ executable hbs2-peer
                     , Paths_hbs2_peer
 
     -- other-extensions:
-    build-depends:    base, hbs2-peer, hbs2-keyman, vty
+    build-depends:    base, hbs2-peer, hbs2-keyman-direct-lib, vty
 
     hs-source-dirs:   app
 

hbs2-peer/lib/HBS2/Peer/RPC/Client/RefChan.hs

@@ -190,3 +190,5 @@ walkRefChanTx filt puk action = do
             tx   <- ContT $ maybe1 (unpackRefChanUpdate h lbs) none
             lift $ action h tx
 
+
+

hbs2-peer/lib/HBS2/Peer/RPC/Client/Unix.hs

@@ -18,6 +18,7 @@ import HBS2.System.Logger.Simple
 import Data.Kind
 import Control.Monad.Reader
 import UnliftIO
+import Control.Monad.Trans.Cont
 
 withRPC2 :: forall (api :: [Type]) e m r . ( e ~ UNIX
                              , HasProtocol e (ServiceProto api e)
@@ -29,17 +30,19 @@ withRPC2 :: forall (api :: [Type]) e m r . ( e ~ UNIX
 
 withRPC2 soname action = do
 
-  debug $ "withRPC2" <+> pretty soname
+  flip runContT pure do
+
+    trace $ "withRPC2" <+> pretty soname
 
     client1 <- newMessagingUnix False 1.0 soname
 
-  m1 <- async $ runMessagingUnix client1
+    m1 <- ContT $ withAsync (runMessagingUnix client1)
     -- link m1
 
     caller <- makeServiceCaller @api @UNIX (fromString soname)
-  p2 <- liftIO $ async $ runReaderT (runServiceClient @api @e caller) client1
+    p2 <- ContT $ withAsync (liftIO $ runReaderT (runServiceClient @api @e caller) client1)
 
-  r <- action caller
+    r <- lift $ action caller
 
     pause @'Seconds 0.05
     cancel p2
@@ -48,4 +51,3 @@ withRPC2 soname action = do
 
     pure r
 
-

hbs2-sync/hbs2-sync.cabal

@@ -56,7 +56,7 @@ common shared-properties
         hbs2-core
       , hbs2-peer
       , hbs2-storage-simple
-      , hbs2-keyman
+      , hbs2-keyman-direct-lib
       , db-pipe
       , suckless-conf
 

hbs2/hbs2.cabal

@@ -64,7 +64,7 @@ executable hbs2
     other-modules:
       Paths_hbs2
     -- other-extensions:
-    build-depends:    base, hbs2-core, hbs2-peer, hbs2-storage-simple, hbs2-keyman
+    build-depends:    base, hbs2-core, hbs2-peer, hbs2-storage-simple, hbs2-keyman-direct-lib
                     , aeson
                     , async
                     , base58-bytestring