diff --git a/cabal.project b/cabal.project index de11fd3a..a6b282eb 100644 --- a/cabal.project +++ b/cabal.project @@ -1,5 +1,6 @@ packages: **/*.cabal examples/*/*.cabal + **/*/*.cabal allow-newer: all diff --git a/fixme-new/fixme.cabal b/fixme-new/fixme.cabal index 2746bf20..b13aa4b6 100644 --- a/fixme-new/fixme.cabal +++ b/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 diff --git a/flake.nix b/flake.nix index 1369b82f..5a917f68 100644 --- a/flake.nix +++ b/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"; diff --git a/hbs2-cli/hbs2-cli.cabal b/hbs2-cli/hbs2-cli.cabal index 666b3b42..a26981d7 100644 --- a/hbs2-cli/hbs2-cli.cabal +++ b/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 diff --git a/hbs2-core/lib/HBS2/Net/Auth/GroupKeySymm.hs b/hbs2-core/lib/HBS2/Net/Auth/GroupKeySymm.hs index d3a71e2f..af97a470 100644 --- a/hbs2-core/lib/HBS2/Net/Auth/GroupKeySymm.hs +++ b/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 diff --git a/hbs2-core/lib/HBS2/Net/Messaging/Unix.hs b/hbs2-core/lib/HBS2/Net/Messaging/Unix.hs index 08e5d423..ea67083e 100644 --- a/hbs2-core/lib/HBS2/Net/Messaging/Unix.hs +++ b/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 diff --git a/hbs2-git/hbs2-git.cabal b/hbs2-git/hbs2-git.cabal index 7b052e7a..214886cf 100644 --- a/hbs2-git/hbs2-git.cabal +++ b/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 diff --git a/hbs2-keyman/app/Main.hs b/hbs2-keyman/app/Main.hs deleted file mode 100644 index 2f2229c9..00000000 --- a/hbs2-keyman/app/Main.hs +++ /dev/null @@ -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 - - diff --git a/hbs2-keyman/src/HBS2/KeyMan/App/Types.hs b/hbs2-keyman/hbs2-keyman-direct-lib/HBS2/KeyMan/App/Types.hs similarity index 100% rename from hbs2-keyman/src/HBS2/KeyMan/App/Types.hs rename to hbs2-keyman/hbs2-keyman-direct-lib/HBS2/KeyMan/App/Types.hs diff --git a/hbs2-keyman/src/HBS2/KeyMan/Config.hs b/hbs2-keyman/hbs2-keyman-direct-lib/HBS2/KeyMan/Config.hs similarity index 100% rename from hbs2-keyman/src/HBS2/KeyMan/Config.hs rename to hbs2-keyman/hbs2-keyman-direct-lib/HBS2/KeyMan/Config.hs diff --git a/hbs2-keyman/src/HBS2/KeyMan/Keys/Direct.hs b/hbs2-keyman/hbs2-keyman-direct-lib/HBS2/KeyMan/Keys/Direct.hs similarity index 100% rename from hbs2-keyman/src/HBS2/KeyMan/Keys/Direct.hs rename to hbs2-keyman/hbs2-keyman-direct-lib/HBS2/KeyMan/Keys/Direct.hs diff --git a/hbs2-keyman/src/HBS2/KeyMan/Prelude.hs b/hbs2-keyman/hbs2-keyman-direct-lib/HBS2/KeyMan/Prelude.hs similarity index 100% rename from hbs2-keyman/src/HBS2/KeyMan/Prelude.hs rename to hbs2-keyman/hbs2-keyman-direct-lib/HBS2/KeyMan/Prelude.hs diff --git a/hbs2-keyman/src/HBS2/KeyMan/State.hs b/hbs2-keyman/hbs2-keyman-direct-lib/HBS2/KeyMan/State.hs similarity index 100% rename from hbs2-keyman/src/HBS2/KeyMan/State.hs rename to hbs2-keyman/hbs2-keyman-direct-lib/HBS2/KeyMan/State.hs diff --git a/hbs2-keyman/hbs2-keyman-direct-lib/LICENSE b/hbs2-keyman/hbs2-keyman-direct-lib/LICENSE new file mode 100644 index 00000000..3086ee5d --- /dev/null +++ b/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. diff --git a/hbs2-keyman/hbs2-keyman-direct-lib/hbs2-keyman-direct-lib.cabal b/hbs2-keyman/hbs2-keyman-direct-lib/hbs2-keyman-direct-lib.cabal new file mode 100644 index 00000000..5909fc37 --- /dev/null +++ b/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 + diff --git a/hbs2-keyman/hbs2-keyman/LICENSE b/hbs2-keyman/hbs2-keyman/LICENSE new file mode 100644 index 00000000..3086ee5d --- /dev/null +++ b/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. diff --git a/hbs2-keyman/hbs2-keyman/Main.hs b/hbs2-keyman/hbs2-keyman/Main.hs new file mode 100644 index 00000000..db567fc3 --- /dev/null +++ b/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 + + diff --git a/hbs2-keyman/hbs2-keyman.cabal b/hbs2-keyman/hbs2-keyman/hbs2-keyman.cabal similarity index 86% rename from hbs2-keyman/hbs2-keyman.cabal rename to hbs2-keyman/hbs2-keyman/hbs2-keyman.cabal index f983c78f..3e8462cb 100644 --- a/hbs2-keyman/hbs2-keyman.cabal +++ b/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 diff --git a/hbs2-peer/hbs2-peer.cabal b/hbs2-peer/hbs2-peer.cabal index 2373b4b3..80ad71e6 100644 --- a/hbs2-peer/hbs2-peer.cabal +++ b/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 diff --git a/hbs2-peer/lib/HBS2/Peer/RPC/Client/RefChan.hs b/hbs2-peer/lib/HBS2/Peer/RPC/Client/RefChan.hs index d3a23760..0ef914ab 100644 --- a/hbs2-peer/lib/HBS2/Peer/RPC/Client/RefChan.hs +++ b/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 + + diff --git a/hbs2-peer/lib/HBS2/Peer/RPC/Client/Unix.hs b/hbs2-peer/lib/HBS2/Peer/RPC/Client/Unix.hs index 83a765f9..96766d64 100644 --- a/hbs2-peer/lib/HBS2/Peer/RPC/Client/Unix.hs +++ b/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,23 +30,24 @@ withRPC2 :: forall (api :: [Type]) e m r . ( e ~ UNIX withRPC2 soname action = do - debug $ "withRPC2" <+> pretty soname + flip runContT pure do - client1 <- newMessagingUnix False 1.0 soname + trace $ "withRPC2" <+> pretty soname - m1 <- async $ runMessagingUnix client1 - -- link m1 + client1 <- newMessagingUnix False 1.0 soname - caller <- makeServiceCaller @api @UNIX (fromString soname) - p2 <- liftIO $ async $ runReaderT (runServiceClient @api @e caller) client1 + m1 <- ContT $ withAsync (runMessagingUnix client1) + -- link m1 - r <- action caller + caller <- makeServiceCaller @api @UNIX (fromString soname) + p2 <- ContT $ withAsync (liftIO $ runReaderT (runServiceClient @api @e caller) client1) - pause @'Seconds 0.05 - cancel p2 + r <- lift $ action caller - void $ waitAnyCatchCancel [m1, p2] + pause @'Seconds 0.05 + cancel p2 - pure r + void $ waitAnyCatchCancel [m1, p2] + pure r diff --git a/hbs2-sync/hbs2-sync.cabal b/hbs2-sync/hbs2-sync.cabal index 4b7f3f2e..dcfdb1df 100644 --- a/hbs2-sync/hbs2-sync.cabal +++ b/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 diff --git a/hbs2/hbs2.cabal b/hbs2/hbs2.cabal index d73c3f4a..416627b0 100644 --- a/hbs2/hbs2.cabal +++ b/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