mirror of https://github.com/voidlizard/hbs2
wip
This commit is contained in:
Dmitry Zuikov
parent
f2c5a531f1
commit
26977db619
|
|
@ -1,5 +1,6 @@
|
|||
packages: **/*.cabal
|
||||
examples/*/*.cabal
|
||||
**/*/*.cabal
|
||||
|
||||
allow-newer: all
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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";
|
||||
|
|
|
|||
|
|
@ -57,7 +57,7 @@ common shared-properties
|
|||
hbs2-core
|
||||
, hbs2-peer
|
||||
, hbs2-storage-simple
|
||||
, hbs2-keyman
|
||||
, hbs2-keyman-direct-lib
|
||||
, db-pipe
|
||||
, suckless-conf
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -55,7 +55,7 @@ common shared-properties
|
|||
hbs2-core
|
||||
, hbs2-peer
|
||||
, hbs2-storage-simple
|
||||
, hbs2-keyman
|
||||
, hbs2-keyman-direct-lib
|
||||
, db-pipe
|
||||
, suckless-conf
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
||||
|
|
@ -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.
|
||||
|
|
@ -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
|
||||
|
||||
|
|
@ -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.
|
||||
|
|
@ -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
|
||||
|
||||
|
||||
|
|
@ -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
|
||||
|
||||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -190,3 +190,5 @@ walkRefChanTx filt puk action = do
|
|||
tx <- ContT $ maybe1 (unpackRefChanUpdate h lbs) none
|
||||
lift $ action h tx
|
||||
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -56,7 +56,7 @@ common shared-properties
|
|||
hbs2-core
|
||||
, hbs2-peer
|
||||
, hbs2-storage-simple
|
||||
, hbs2-keyman
|
||||
, hbs2-keyman-direct-lib
|
||||
, db-pipe
|
||||
, suckless-conf
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in New Issue