From c829a6d37c7cd2b6286924f9a3ddcc590612094a Mon Sep 17 00:00:00 2001 From: Dmitry Zuikov Date: Thu, 12 Oct 2023 09:58:13 +0300 Subject: [PATCH] group-keys / repository-encryption to test --- .fixme/log | 2 - docs/devlog.md | 19 ++ docs/todo/git-encryption.planb | 29 ++ docs/todo/hbs2-git-private-repoes.txt | 18 + flake.nix | 1 + hbs2-core/lib/HBS2/Actors/Peer/Types.hs | 24 +- hbs2-core/lib/HBS2/Net/Auth/GroupKeySymm.hs | 103 ++++-- hbs2-core/lib/HBS2/Net/Proto/RefLog.hs | 2 +- hbs2-core/lib/HBS2/Prelude.hs | 24 +- .../lib/HBS2/Storage/Operations/ByteString.hs | 18 + .../lib/HBS2/Storage/Operations/Class.hs | 2 +- hbs2-git/examples/config/encrypted-ref | 18 + hbs2-git/examples/config/encrypted-ref-2 | 30 ++ hbs2-git/git-hbs2/GitRemoteMain.hs | 49 ++- hbs2-git/git-hbs2/GitRemotePush.hs | 54 +-- hbs2-git/git-hbs2/GitRemoteTypes.hs | 25 +- hbs2-git/git-hbs2/Main.hs | 29 ++ hbs2-git/hbs2-git.cabal | 11 +- hbs2-git/hie.yaml | 2 + hbs2-git/lib/HBS2/Git/Types.hs | 2 + hbs2-git/lib/HBS2Git/Alerts.hs | 9 + hbs2-git/lib/HBS2Git/Annotations.hs | 24 ++ hbs2-git/lib/HBS2Git/App.hs | 322 +++++++++++++----- hbs2-git/lib/HBS2Git/Config.hs | 22 +- hbs2-git/lib/HBS2Git/Encryption.hs | 57 ++++ hbs2-git/lib/HBS2Git/Encryption/KeyInfo.hs | 55 +++ hbs2-git/lib/HBS2Git/Export.hs | 45 ++- hbs2-git/lib/HBS2Git/Import.hs | 76 ++++- hbs2-git/lib/HBS2Git/KeysCommand.hs | 80 +++++ hbs2-git/lib/HBS2Git/KeysMetaData.hs | 266 +++++++++++++++ hbs2-git/lib/HBS2Git/ListRefs.hs | 3 + hbs2-git/lib/HBS2Git/PrettyStuff.hs | 14 +- hbs2-git/lib/HBS2Git/State.hs | 133 ++++++++ hbs2-git/lib/HBS2Git/Types.hs | 24 +- hbs2-tests/test/PrototypeGenericService.hs | 15 +- hbs2/Main.hs | 12 +- 36 files changed, 1394 insertions(+), 225 deletions(-) create mode 100644 docs/todo/git-encryption.planb create mode 100644 hbs2-git/examples/config/encrypted-ref create mode 100644 hbs2-git/examples/config/encrypted-ref-2 create mode 100644 hbs2-git/hie.yaml create mode 100644 hbs2-git/lib/HBS2Git/Alerts.hs create mode 100644 hbs2-git/lib/HBS2Git/Annotations.hs create mode 100644 hbs2-git/lib/HBS2Git/Encryption.hs create mode 100644 hbs2-git/lib/HBS2Git/Encryption/KeyInfo.hs create mode 100644 hbs2-git/lib/HBS2Git/KeysCommand.hs create mode 100644 hbs2-git/lib/HBS2Git/KeysMetaData.hs diff --git a/.fixme/log b/.fixme/log index 25d0bae8..e69de29b 100644 --- a/.fixme/log +++ b/.fixme/log @@ -1,2 +0,0 @@ - -fixme-del "3PJf47D9oE" \ No newline at end of file diff --git a/docs/devlog.md b/docs/devlog.md index a1b992ae..83b9173b 100644 --- a/docs/devlog.md +++ b/docs/devlog.md @@ -1,3 +1,22 @@ +## 2023-10-11 + +запостили аннотацию с ключами. +теперь пробуем её процессировать. + +и вот этот волнующий момент + +... тестируем, как работает удаление ключа. + - не работает пока что (почему?) + +... и еще раз тестируем удаление/добавление ключей + +## 2023-10-10 + +Начинацию операем. + +Шаг 1. Выяснить, что нам вообще надо добавить нового автора + + ## 2023-10-08 Конечно, грустно, что девлог превратился в черти-что. diff --git a/docs/todo/git-encryption.planb b/docs/todo/git-encryption.planb new file mode 100644 index 00000000..cbceb187 --- /dev/null +++ b/docs/todo/git-encryption.planb @@ -0,0 +1,29 @@ + +;; Plan-B file + +;; исходный файл гипотетической утилиты для планирования +;; когда я её сделаю? ну, после шифрования, наверное. +;; пока будем тут планировать + +;; из этой штуки можно будет и TODO генерировать для fixme + +[ task keyinfo + +] + +[ plan + + -> git-hbs2-tools-key-command + -> hbs2-config-parse + -> key-info + -> key-info-test + -> key-data + -> key-metadata + -> inject-key-metadata + -> handle-key-metadata + -> encrypt-git-log + -> decrypt-git-log + -> git-encryption-a1 +] + + diff --git a/docs/todo/hbs2-git-private-repoes.txt b/docs/todo/hbs2-git-private-repoes.txt index f4fa18c1..a29bae00 100644 --- a/docs/todo/hbs2-git-private-repoes.txt +++ b/docs/todo/hbs2-git-private-repoes.txt @@ -45,5 +45,23 @@ TODO: git-group-key hbs2-git не будет знать, какой ключ использовать. +TODO: support-metadata-in-git-log-tree + Помещать метаданные в меркл-дерево журналов, + при первом прогоне для каждой новой транзакции + сначала обрабатывать метаданные, если они не обработаны, + вторым проходом обрабатывать уже сами транзы. + + +TODO: tools:generate-group-key-for-ref + Добавить функцию генерации/перегенерации группового + ключа по KeyInfo. + + 1. Ключ отсутствует + 2. Ключ присутствует, KeyInfo expired + 3. Ключ присутствует, KeyInfo не expired + + +TODO: tools:list-group-keys + Выводить имеющиеся ключи/шифрованные ссылки diff --git a/flake.nix b/flake.nix index 539976db..8b2daa17 100644 --- a/flake.nix +++ b/flake.nix @@ -71,6 +71,7 @@ outputs = { self, nixpkgs, haskell-flake-utils, ... }@inputs: shellExtBuildInputs = {pkgs}: with pkgs; [ haskellPackages.haskell-language-server haskellPackages.cbor-tool + haskellPackages.htags pkg-config inputs.hspup.packages.${pkgs.system}.default inputs.fixme.packages.${pkgs.system}.default diff --git a/hbs2-core/lib/HBS2/Actors/Peer/Types.hs b/hbs2-core/lib/HBS2/Actors/Peer/Types.hs index df63c8f3..9fc6e280 100644 --- a/hbs2-core/lib/HBS2/Actors/Peer/Types.hs +++ b/hbs2-core/lib/HBS2/Actors/Peer/Types.hs @@ -25,19 +25,19 @@ instance {-# OVERLAPPABLE #-} -- instance HasConf m => HasConf (ResponseM e m) -instance (IsKey HbSync) => Storage AnyStorage HbSync ByteString IO where - putBlock (AnyStorage s) = putBlock s - enqueueBlock (AnyStorage s) = enqueueBlock s - getBlock (AnyStorage s) = getBlock s - getChunk (AnyStorage s) = getChunk s - hasBlock (AnyStorage s) = hasBlock s - updateRef (AnyStorage s) = updateRef s - getRef (AnyStorage s) = getRef s - delBlock (AnyStorage s) = delBlock s - delRef (AnyStorage s) = delRef s +instance (IsKey HbSync, MonadIO m) => Storage AnyStorage HbSync ByteString m where + putBlock (AnyStorage s) = liftIO . putBlock s + enqueueBlock (AnyStorage s) = liftIO . enqueueBlock s + getBlock (AnyStorage s) = liftIO . getBlock s + getChunk (AnyStorage s) h a b = liftIO $ getChunk s h a b + hasBlock (AnyStorage s) = liftIO . hasBlock s + updateRef (AnyStorage s) r v = liftIO $ updateRef s r v + getRef (AnyStorage s) = liftIO . getRef s + delBlock (AnyStorage s) = liftIO . delBlock s + delRef (AnyStorage s) = liftIO . delRef s -data AnyStorage = forall zu . ( Storage zu HbSync ByteString IO - ) => AnyStorage zu +data AnyStorage = forall zu . ( Storage zu HbSync ByteString IO + ) => AnyStorage zu class HasStorage m where getStorage :: m AnyStorage diff --git a/hbs2-core/lib/HBS2/Net/Auth/GroupKeySymm.hs b/hbs2-core/lib/HBS2/Net/Auth/GroupKeySymm.hs index da6b205d..13473440 100644 --- a/hbs2-core/lib/HBS2/Net/Auth/GroupKeySymm.hs +++ b/hbs2-core/lib/HBS2/Net/Auth/GroupKeySymm.hs @@ -1,8 +1,13 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} +{-# Language TemplateHaskell #-} {-# Language UndecidableInstances #-} {-# Language AllowAmbiguousTypes #-} {-# Language ConstraintKinds #-} -module HBS2.Net.Auth.GroupKeySymm where +module HBS2.Net.Auth.GroupKeySymm + ( module HBS2.Net.Auth.GroupKeySymm + , module HBS2.Net.Proto.Types + , KeyringEntry(..), krPk, krSk + ) where import HBS2.Prelude.Plated import HBS2.Base58 @@ -17,9 +22,6 @@ import HBS2.Storage.Operations.Class import HBS2.Storage.Operations.ByteString import HBS2.Storage(Storage(..)) -import HBS2.System.Logger.Simple - -import Data.ByteArray.Hash qualified as BA import Codec.Serialise import Crypto.KDF.HKDF qualified as HKDF @@ -37,10 +39,9 @@ import Data.ByteString.Char8 qualified as B8 import Data.ByteString qualified as BS import Data.ByteString.Lazy qualified as LBS import Data.ByteString.Lazy.Char8 qualified as LBS8 -import Data.Function -import Data.Functor -import Data.List qualified as List import Data.List.Split (chunksOf) +import Data.HashMap.Strict (HashMap) +import Data.HashMap.Strict qualified as HashMap import Data.Maybe import Data.Word (Word64) import Data.ByteArray() @@ -57,12 +58,25 @@ import Data.Bits (xor) type GroupSecretAsymm = Key +-- NOTE: breaking-change + +-- NOTE: not-a-monoid +-- это моноид, но опасный, потому, что секретные ключи у двух разных +-- групповых ключей могут быть разными, и если +-- просто объединить два словаря - какой-то секретный +-- ключ может быть потерян. а что делать-то, с другой стороны? data instance GroupKey 'Symm s = GroupKeySymm - { recipients :: [(PubKey 'Encrypt s, EncryptedBox GroupSecretAsymm)] + { recipients :: HashMap (PubKey 'Encrypt s) (EncryptedBox GroupSecretAsymm) } deriving stock (Generic) +instance ForGroupKeySymm s => Monoid (GroupKey 'Symm s) where + mempty = GroupKeySymm mempty + +instance ForGroupKeySymm s => Semigroup (GroupKey 'Symm s) where + (<>) (GroupKeySymm a) (GroupKeySymm b) = GroupKeySymm (a <> b) + instance Serialise Key instance Serialise SK.Nonce @@ -73,8 +87,9 @@ data instance ToEncrypt 'Symm s LBS.ByteString = , toEncryptNonce :: BS.ByteString , toEncryptData :: Stream (Of LBS.ByteString) IO () , toEncryptGroupKey :: GroupKey 'Symm s + , toEncryptMeta :: AnnMetaData } - + deriving (Generic) type ForGroupKeySymm s = ( Eq (PubKey 'Encrypt s) , PubKey 'Encrypt s ~ AK.PublicKey @@ -88,11 +103,16 @@ type ForGroupKeySymm s = ( Eq (PubKey 'Encrypt s) instance ForGroupKeySymm s => Serialise (GroupKey 'Symm s) instance Pretty (AsBase58 (PubKey 'Encrypt s)) => Pretty (GroupKey 'Symm s) where - pretty g = vcat (fmap prettyEntry (recipients g)) + pretty g = vcat (fmap prettyEntry (HashMap.toList (recipients g))) where prettyEntry (pk, _) = "member" <+> dquotes (pretty (AsBase58 pk)) +instance ForGroupKeySymm s => FromStringMaybe (GroupKey 'Symm s) where + fromStringMay s = runIdentity $ runMaybeT do + bs <- toMPlus $ fromBase58 $ B8.pack s + toMPlus $ deserialiseOrFail @(GroupKey 'Symm s) (LBS.fromStrict bs) + instance ForGroupKeySymm s => Pretty (AsGroupKeyFile (GroupKey 'Symm s)) where pretty (AsGroupKeyFile pc) = "# hbs2 symmetric group key file" <> line <> co @@ -109,10 +129,10 @@ parseGroupKey :: forall s . (ForGroupKeySymm s, Serialise (GroupKey 'Symm s)) parseGroupKey (AsGroupKeyFile bs) = parseSerialisableFromBase58 (LBS8.toStrict bs) -instance ( Serialise (GroupKey 'Asymm s) +instance ( Serialise (GroupKey 'Symm s) ) - => Pretty (AsBase58 (GroupKey 'Asymm s)) where + => Pretty (AsBase58 (GroupKey 'Symm s)) where pretty (AsBase58 c) = pretty . B8.unpack . toBase58 . LBS.toStrict . serialise $ c @@ -121,11 +141,9 @@ generateGroupKey :: forall s m . (ForGroupKeySymm s, MonadIO m) -> [PubKey 'Encrypt s] -> m (GroupKey 'Symm s) -generateGroupKey mbk pks' = GroupKeySymm <$> create +generateGroupKey mbk pks = GroupKeySymm <$> create where - pks = List.sort (List.nub pks') - - create = do + create = HashMap.fromList <$> do sk <- maybe1 mbk (liftIO SK.newKey) pure forM pks $ \pk -> do box <- liftIO $ AK.boxSeal pk (LBS.toStrict $ serialise sk) <&> EncryptedBox @@ -138,7 +156,7 @@ lookupGroupKey :: ForGroupKeySymm s -> Maybe GroupSecretAsymm lookupGroupKey sk pk gk = runIdentity $ runMaybeT do - (EncryptedBox bs) <- MaybeT $ pure $ List.lookup pk (recipients gk) + (EncryptedBox bs) <- MaybeT $ pure $ HashMap.lookup pk (recipients gk) -- error "FOUND SHIT!" gkBs <- MaybeT $ pure $ AK.boxSealOpen pk sk bs -- error $ "DECRYPTED SHIT!" @@ -230,7 +248,7 @@ instance ( MonadIO m tree <- maybe (throwError StorageError) pure root - let ann = MTreeAnn NoMetaData (EncryptGroupNaClSymm (fromHashRef gkh) nonceS) tree + let ann = MTreeAnn (toEncryptMeta source) (EncryptGroupNaClSymm (fromHashRef gkh) nonceS) tree putBlock sto (serialise ann) >>= maybe (throwError StorageError) pure @@ -243,31 +261,20 @@ instance ( MonadIO m , sch ~ HBS2Basic ) => MerkleReader (ToDecrypt 'Symm sch ByteString) s h m where - data instance TreeKey (ToDecrypt 'Symm sch ByteString) = ToDecryptBS [KeyringEntry sch] (Hash HbSync) + data instance TreeKey (ToDecrypt 'Symm sch ByteString) = + ToDecryptBS [KeyringEntry sch] (Hash HbSync) + | ToDecryptBS2 (GroupKey 'Symm sch) B8.ByteString [KeyringEntry sch] (MTree [HashRef]) type instance ToBlockR (ToDecrypt 'Symm sch ByteString) = ByteString type instance ReadResult (ToDecrypt 'Symm sch ByteString) = ByteString - readFromMerkle sto (ToDecryptBS ke h) = do + readFromMerkle sto decrypt = do - let keys = [ (view krPk x, view krSk x) | x <- ke ] - - bs <- getBlock sto h >>= maybe (throwError MissedBlockError) pure - let what = tryDetect h bs - - let tree' = case what of - MerkleAnn ann@(MTreeAnn {_mtaCrypt = EncryptGroupNaClSymm g n}) -> Just (_mtaTree ann, (g,n)) - _ -> Nothing - - (tree, (gkh,nonceS)) <- maybe1 tree' (throwError UnsupportedFormat) pure - - gkbs <- readFromMerkle sto (SimpleKey gkh) - - gk <- either (const $ throwError GroupKeyNotFound) pure (deserialiseOrFail @(GroupKey 'Symm sch) gkbs) + (keys, gk, nonceS, tree) <- decryptDataFrom decrypt let gksec' = [ lookupGroupKey sk pk gk | (pk,sk) <- keys ] & catMaybes & headMay - gksec <- maybe1 gksec' (throwError GroupKeyNotFound) pure + gksec <- maybe1 gksec' (throwError (GroupKeyNotFound 2)) pure let prk = HKDF.extractSkip @_ @HbSyncHash (Saltine.encode gksec) let key0 = HKDF.expand prk nonceS typicalKeyLength & Saltine.decode & fromJust @@ -282,6 +289,7 @@ instance ( MonadIO m blk <- getBlock sto (fromHashRef h) >>= maybe (throwError MissedBlockError) pure let nonceI = nonceFrom (nonce0, i) + let unboxed = SK.secretboxOpen key0 nonceI (LBS.toStrict blk) maybe1 unboxed (throwError DecryptionError) (pure . LBS.fromStrict) @@ -290,3 +298,28 @@ instance ( MonadIO m pure $ mconcat ss + where + + decryptDataFrom = \case + ToDecryptBS2 gk nonce ke tree -> do + let keys = [ (view krPk x, view krSk x) | x <- ke ] + pure (keys, gk, nonce, tree) + + ToDecryptBS ke h -> do + let keys = [ (view krPk x, view krSk x) | x <- ke ] + + bs <- getBlock sto h >>= maybe (throwError MissedBlockError) pure + let what = tryDetect h bs + + let tree' = case what of + MerkleAnn ann@(MTreeAnn {_mtaCrypt = EncryptGroupNaClSymm g n}) -> Just (_mtaTree ann, (g,n)) + _ -> Nothing + + (tree, (gkh,nonceS)) <- maybe1 tree' (throwError UnsupportedFormat) pure + + gkbs <- readFromMerkle sto (SimpleKey gkh) + + gk <- either (const $ throwError (GroupKeyNotFound 1)) pure (deserialiseOrFail @(GroupKey 'Symm sch) gkbs) + + pure (keys, gk, nonceS, tree) + diff --git a/hbs2-core/lib/HBS2/Net/Proto/RefLog.hs b/hbs2-core/lib/HBS2/Net/Proto/RefLog.hs index fed42d6f..cc15346d 100644 --- a/hbs2-core/lib/HBS2/Net/Proto/RefLog.hs +++ b/hbs2-core/lib/HBS2/Net/Proto/RefLog.hs @@ -22,7 +22,7 @@ import Data.ByteString (ByteString) import Type.Reflection (someTypeRep) import Lens.Micro.Platform -newtype RefLogKey s = RefLogKey (PubKey 'Sign s) +newtype RefLogKey s = RefLogKey { fromRefLogKey :: PubKey 'Sign s } deriving stock instance IsRefPubKey s => Eq (RefLogKey s) diff --git a/hbs2-core/lib/HBS2/Prelude.hs b/hbs2-core/lib/HBS2/Prelude.hs index 1273cd07..43be1855 100644 --- a/hbs2-core/lib/HBS2/Prelude.hs +++ b/hbs2-core/lib/HBS2/Prelude.hs @@ -1,3 +1,4 @@ +{-# Language FunctionalDependencies #-} module HBS2.Prelude ( module Data.String , module Safe @@ -6,6 +7,7 @@ module HBS2.Prelude , void, guard, when, unless , maybe1 , eitherToMaybe + , ToMPlus(..) , Hashable , lift , AsFileName(..) @@ -16,6 +18,7 @@ module HBS2.Prelude , ToByteString(..) , FromByteString(..) , Text.Text + , (&), (<&>) ) where import Data.Typeable as X @@ -25,10 +28,13 @@ import Data.ByteString (ByteString) import Data.String (IsString(..)) import Safe import Control.Monad.IO.Class (MonadIO(..)) -import Control.Monad (void,guard,when,unless) +import Control.Monad (guard,when,unless,MonadPlus(..)) import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.Maybe +import Data.Kind import Data.Function +import Data.Functor import Data.Char qualified as Char import Data.Text qualified as Text import Data.Hashable @@ -62,3 +68,19 @@ class ToByteString a where class FromByteString a where fromByteString :: ByteString -> Maybe a + + +class MonadPlus m => ToMPlus m a where + type family ToMPlusResult a :: Type + toMPlus :: a -> m (ToMPlusResult a) + +instance Monad m => ToMPlus (MaybeT m) (Maybe a) where + type instance ToMPlusResult (Maybe a) = a + toMPlus Nothing = mzero + toMPlus (Just a) = MaybeT (pure (Just a)) + +instance Monad m => ToMPlus (MaybeT m) (Either x a) where + type instance ToMPlusResult (Either x a) = a + toMPlus (Left{}) = mzero + toMPlus (Right x) = MaybeT $ pure (Just x) + diff --git a/hbs2-core/lib/HBS2/Storage/Operations/ByteString.hs b/hbs2-core/lib/HBS2/Storage/Operations/ByteString.hs index cac73f1d..37d43327 100644 --- a/hbs2-core/lib/HBS2/Storage/Operations/ByteString.hs +++ b/hbs2-core/lib/HBS2/Storage/Operations/ByteString.hs @@ -24,6 +24,8 @@ import Control.Monad.Except import Data.Bifunctor import Data.ByteString.Lazy (ByteString) import Data.ByteString.Lazy qualified as LBS +-- hbs2-core/lib/HBS2/Net/Auth/Credentials.hs +-- importimport Data.List.Split (chunksOf) instance (MonadIO m, h ~ HbSync, Storage s h ByteString m) => MerkleWriter ByteString h s m where @@ -69,3 +71,19 @@ instance ( MonadIO m pure $ mconcat pieces +readChunkedBS :: (Integral a, Monad m) + => ByteString + -> a + -> S.Stream (S.Of ByteString) m () + +readChunkedBS bs size = foo bs + where + foo = + fix $ \loop leftover -> do + let (chunk, rest) = LBS.splitAt (fromIntegral size) leftover + unless (LBS.null chunk) do + S.yield chunk + loop rest + + + diff --git a/hbs2-core/lib/HBS2/Storage/Operations/Class.hs b/hbs2-core/lib/HBS2/Storage/Operations/Class.hs index b7a47ca2..95d0a378 100644 --- a/hbs2-core/lib/HBS2/Storage/Operations/Class.hs +++ b/hbs2-core/lib/HBS2/Storage/Operations/Class.hs @@ -13,7 +13,7 @@ data OperationError = | DecryptionError | MissedBlockError | UnsupportedFormat - | GroupKeyNotFound + | GroupKeyNotFound Int deriving (Generic,Show,Data,Typeable) -- instance Exception OperationError diff --git a/hbs2-git/examples/config/encrypted-ref b/hbs2-git/examples/config/encrypted-ref new file mode 100644 index 00000000..815ee636 --- /dev/null +++ b/hbs2-git/examples/config/encrypted-ref @@ -0,0 +1,18 @@ +rpc unix "/tmp/hbs2-rpc.socket" + +keyring "/home/dmz/dmz-data/hbs2/HBcSZnjpEcA88S19S5QwC5N4yyKZY4SvAuBWqHQhK6wV.key" + +keyring "/home/dmz/w/hbs2/test1.key" +keyring "/home/dmz/w/hbs2/test2.key" +keyring "/home/dmz/w/hbs2/test3.key" +keyring "/home/dmz/w/hbs2/test4.key" +keyring "/home/dmz/w/hbs2/test5.key" + +[ encrypted "EDRuSaFmWbCnyUNtFbgCtqfiCrYPJvnY9pZB81AbSTbr" + (ttl 86400) + (owner "21MU19xcRbhhPakPJCG6Jyrf7Xv6JMCyMDEfCk16hR5G") + (member "21MU19xcRbhhPakPJCG6Jyrf7Xv6JMCyMDEfCk16hR5G") + (member "GcTjPEDSTCKNKnwPZWBjudeTqSie2fvYfsoSAzUKTRZ5") +] + + diff --git a/hbs2-git/examples/config/encrypted-ref-2 b/hbs2-git/examples/config/encrypted-ref-2 new file mode 100644 index 00000000..8d1ea976 --- /dev/null +++ b/hbs2-git/examples/config/encrypted-ref-2 @@ -0,0 +1,30 @@ +rpc unix "/tmp/hbs2-rpc.socket" + +branch "master" +branch "hbs2-git" + +keyring "/home/dmz/dmz-data/hbs2/BTThPdHKF8XnEq4m6wzbKHKA6geLFK4ydYhBXAqBdHSP.key" +keyring "/home/dmz/dmz-data/hbs2/HBcSZnjpEcA88S19S5QwC5N4yyKZY4SvAuBWqHQhK6wV.key" + +keyring "/home/dmz/w/hbs2/k5.key" + +;;keyring "/home/dmz/w/hbs2/test1.key" +;;keyring "/home/dmz/w/hbs2/test2.key" +;;keyring "/home/dmz/w/hbs2/test6.key" +;; keyring "/home/dmz/w/hbs2/test3.key" + +decrypt "/home/dmz/w/hbs2/au11.key" +decrypt "/home/dmz/w/hbs2/owner.key" +decrypt "/home/dmz/w/hbs2/k5.key" + +[ encrypted "HFKuPTyaQLLmfgfVveu5GA4spt4c6oQBMUo1aeQ4abXG" + (ttl 86400) + (owner "21MU19xcRbhhPakPJCG6Jyrf7Xv6JMCyMDEfCk16hR5G") + (member "H9miZgHYg84wZM8Hu93t7iLHcKnZytAEgcB26LGbLTz4") + (member "2jsaezeu8iCRYBqMVBauCxnkHXvP3CkEFLeVxE8bRfvH") + (member "FNGD1oNh9AVXw1v7ZFpC5V2P2GGYRoUwnP6qwTw9JGpn") + (member "J2FWG3uib7TpZsu1k8sz8cekC3VH1ggNBhZKJxtUce4Q") + (member "E9WGzRzmD5G5SHbz9u7n3WKCz1eaVNPvT5f1NEKUQ6FU") + (keyring "/home/dmz/w/hbs2/owner.key") +] + diff --git a/hbs2-git/git-hbs2/GitRemoteMain.hs b/hbs2-git/git-hbs2/GitRemoteMain.hs index 7fe106dd..8dfeb873 100644 --- a/hbs2-git/git-hbs2/GitRemoteMain.hs +++ b/hbs2-git/git-hbs2/GitRemoteMain.hs @@ -40,6 +40,7 @@ import Text.InterpolatedString.Perl6 (qc) import UnliftIO.IO as UIO import Control.Monad.Catch import Control.Monad.Trans.Resource +import Lens.Micro.Platform send :: MonadIO m => BS.ByteString -> m () @@ -74,24 +75,48 @@ capabilities :: BS.ByteString capabilities = BS.unlines ["push","fetch"] +getGlobalOptionFromURL :: HasGlobalOptions m => [String] -> m () +getGlobalOptionFromURL args = do + + case args of + [_, ss] -> do + let (_, suff) = Text.breakOn "?" (Text.pack ss) + & over _2 (Text.dropWhile (== '?')) + & over _2 (Text.splitOn "&") + & over _2 (fmap (over _2 (Text.dropWhile (=='=')) . Text.break (== '='))) + & over _2 (filter (\(k,_) -> k /= "")) + + forM_ suff $ \(k,v) -> do + addGlobalOption (Text.unpack k) (Text.unpack v) + + _ -> pure () loop :: forall m . ( MonadIO m , MonadCatch m , MonadUnliftIO m , MonadMask m - , HasProgress (RunWithConfig (GitRemoteApp m)) - , HasStorage (RunWithConfig (GitRemoteApp m)) - , HasRPC (RunWithConfig (GitRemoteApp m)) - ) => [String] -> GitRemoteApp m () + , HasProgress m + , HasConf m + , HasStorage m + , HasRPC m + , HasRefCredentials m + , HasEncryptionKeys m + , HasGlobalOptions m + ) => [String] -> m () loop args = do trace $ "args:" <+> pretty args - let ref' = case args of - [_, s] -> Text.stripPrefix "hbs2://" (Text.pack s) <&> fromString @RepoRef . Text.unpack - _ -> Nothing + ref <- case args of + [_, ss] -> do + let (s, _) = Text.breakOn "?" (Text.pack ss) - ref <- pure ref' `orDie` ("invalid reference: " <> show args) + let r = Text.stripPrefix "hbs2://" s <&> fromString @RepoRef . Text.unpack + + pure r `orDie` [qc|bad reference {args}||] + + _ -> do + die [qc|bad reference: {args}|] trace $ "ref:" <+> pretty ref @@ -230,10 +255,16 @@ main = do runWithRPC $ \rpc -> do env <- RemoteEnv <$> liftIO (newTVarIO mempty) + <*> liftIO (newTVarIO mempty) + <*> liftIO (newTVarIO mempty) <*> pure rpc runRemoteM env do - loop args + runWithConfig syn $ do + getGlobalOptionFromURL args + loadCredentials mempty + loadKeys + loop args shutUp diff --git a/hbs2-git/git-hbs2/GitRemotePush.hs b/hbs2-git/git-hbs2/GitRemotePush.hs index 0a75e64a..4f60a8ec 100644 --- a/hbs2-git/git-hbs2/GitRemotePush.hs +++ b/hbs2-git/git-hbs2/GitRemotePush.hs @@ -44,6 +44,11 @@ newtype RunWithConfig m a = runWithConfig :: MonadIO m => [Syntax C] -> RunWithConfig m a -> m a runWithConfig conf m = runReaderT (fromWithConf m) conf + +instance (Monad m, HasGlobalOptions m) => HasGlobalOptions (RunWithConfig m) where + addGlobalOption k v = lift $ addGlobalOption k v + getGlobalOption k = lift $ getGlobalOption k + instance (Monad m, HasStorage m) => HasStorage (RunWithConfig m) where getStorage = lift getStorage @@ -57,44 +62,43 @@ instance MonadIO m => HasRefCredentials (RunWithConfig (GitRemoteApp m)) where getCredentials = lift . getCredentials setCredentials r c = lift $ setCredentials r c + +instance MonadIO m => HasEncryptionKeys (RunWithConfig (GitRemoteApp m)) where + addEncryptionKey = lift . addEncryptionKey + findEncryptionKey = lift . findEncryptionKey + enumEncryptionKeys = lift enumEncryptionKeys + push :: forall m . ( MonadIO m , MonadCatch m - , HasProgress (RunWithConfig (GitRemoteApp m)) - , MonadMask (RunWithConfig (GitRemoteApp m)) - , HasStorage (RunWithConfig (GitRemoteApp m)) + , HasConf m + , HasRefCredentials m + , HasEncryptionKeys m + , HasGlobalOptions m + , HasStorage m + , HasRPC m , MonadUnliftIO m , MonadMask m ) - => RepoRef -> [Maybe GitRef] -> GitRemoteApp m (Maybe GitRef) - + => RepoRef -> [Maybe GitRef] -> m (Maybe GitRef) push remote what@[Just bFrom , Just br] = do - (_, syn) <- Config.configInit - dbPath <- makeDbPath remote - db <- dbEnv dbPath - - runWithConfig syn do - _ <- cfgValue @ConfBranch @(Set GitRef) <&> transformBi normalizeRef - loadCredentials mempty - trace $ "PUSH PARAMS" <+> pretty what - gh <- gitGetHash (normalizeRef bFrom) `orDie` [qc|can't read hash for ref {pretty br}|] - _ <- traceTime "TIME: exportRefOnly" $ exportRefOnly () remote (Just bFrom) br gh - importRefLogNew False remote - pure (Just br) + _ <- cfgValue @ConfBranch @(Set GitRef) <&> transformBi normalizeRef + trace $ "PUSH PARAMS" <+> pretty what + gh <- gitGetHash (normalizeRef bFrom) `orDie` [qc|can't read hash for ref {pretty br}|] + _ <- traceTime "TIME: exportRefOnly" $ exportRefOnly () remote (Just bFrom) br gh + importRefLogNew False remote + pure (Just br) push remote [Nothing, Just br] = do - (_, syn) <- Config.configInit - runWithConfig syn do - _ <- cfgValue @ConfBranch @(Set GitRef) <&> transformBi normalizeRef - loadCredentials mempty - trace $ "deleting remote reference" <+> pretty br - exportRefDeleted () remote br - importRefLogNew False remote - pure (Just br) + _ <- cfgValue @ConfBranch @(Set GitRef) <&> transformBi normalizeRef + trace $ "deleting remote reference" <+> pretty br + exportRefDeleted () remote br + importRefLogNew False remote + pure (Just br) push r w = do warn $ "ignoring weird push" <+> pretty w <+> pretty r diff --git a/hbs2-git/git-hbs2/GitRemoteTypes.hs b/hbs2-git/git-hbs2/GitRemoteTypes.hs index 4e3a5bb8..a6fa6143 100644 --- a/hbs2-git/git-hbs2/GitRemoteTypes.hs +++ b/hbs2-git/git-hbs2/GitRemoteTypes.hs @@ -4,7 +4,8 @@ module GitRemoteTypes where import HBS2.Prelude import HBS2.OrDie -import HBS2.Net.Auth.Credentials (PeerCredentials) +import HBS2.Net.Proto +import HBS2.Net.Auth.Credentials import HBS2.Net.Proto.Definition() import HBS2.Peer.RPC.Client.StorageClient @@ -20,6 +21,8 @@ import Control.Monad.Trans.Resource data RemoteEnv = RemoteEnv { _reCreds :: TVar (HashMap RepoRef (PeerCredentials Schema)) + , _reKeys :: TVar (HashMap (PubKey 'Encrypt Schema) (PrivKey 'Encrypt Schema)) + , _reOpts :: TVar (HashMap String String) , _reRpc :: RPCEndpoints } @@ -48,6 +51,16 @@ instance Monad m => HasRPC (GitRemoteApp m) where runRemoteM :: MonadIO m => RemoteEnv -> GitRemoteApp m a -> m a runRemoteM env m = runReaderT (fromRemoteApp m) env + +instance MonadIO m => HasGlobalOptions (GitRemoteApp m) where + addGlobalOption k v = + asks (view reOpts ) >>= \t -> liftIO $ atomically $ + modifyTVar' t (HashMap.insert k v) + + getGlobalOption k = do + hm <- asks (view reOpts) >>= liftIO . readTVarIO + pure (HashMap.lookup k hm) + instance MonadIO m => HasRefCredentials (GitRemoteApp m) where setCredentials ref cred = do @@ -56,8 +69,16 @@ instance MonadIO m => HasRefCredentials (GitRemoteApp m) where getCredentials ref = do hm <- asks (view reCreds) >>= liftIO . readTVarIO - pure (HashMap.lookup ref hm) `orDie` "keyring not set" + pure (HashMap.lookup ref hm) `orDie` "keyring not set (3)" +instance MonadIO m => HasEncryptionKeys (GitRemoteApp m) where + addEncryptionKey ke = do + asks (view reKeys) >>= \t -> liftIO $ atomically do + modifyTVar' t (HashMap.insert (view krPk ke) (view krSk ke)) + findEncryptionKey puk = (asks (view reKeys) >>= \t -> liftIO $ readTVarIO t) <&> HashMap.lookup puk + enumEncryptionKeys = do + them <- (asks (view reKeys) >>= \t -> liftIO $ readTVarIO t) <&> HashMap.toList + pure $ [KeyringEntry k s Nothing | (k,s) <- them ] diff --git a/hbs2-git/git-hbs2/Main.hs b/hbs2-git/git-hbs2/Main.hs index 65659ef1..ae90d2bc 100644 --- a/hbs2-git/git-hbs2/Main.hs +++ b/hbs2-git/git-hbs2/Main.hs @@ -1,13 +1,17 @@ module Main where import HBS2.Prelude +import HBS2.OrDie import HBS2Git.App import HBS2Git.Export import HBS2Git.ListRefs +import HBS2Git.KeysCommand +import HBS2.Net.Proto.Definition() import RunShow +import Data.Functor import Options.Applicative as O import Control.Monad @@ -24,6 +28,7 @@ main = join . customExecParser (prefs showHelpOnError) $ <> command "list-refs" (info pListRefs (progDesc "list refs")) <> command "show" (info pShow (progDesc "show various types of objects")) <> command "tools" (info pTools (progDesc "misc tools")) + <> command "key" (info pKeys (progDesc "manage keys")) ) pExport = do @@ -57,3 +62,27 @@ main = join . customExecParser (prefs showHelpOnError) $ ref <- strArgument (metavar "HASH-REF") pure $ runApp WithLog (runToolsGetRefs ref) + + pKeys = hsubparser ( command "list" (info pKeysList (progDesc "list keys for refs")) + <> command "refs" (info pKeyRefsList (progDesc "list encrypted refs")) + <> command "update" (info pKeyUpdate (progDesc "update key for the ref")) + ) + + + pKeyUpdate = do + ref <- strArgument (metavar "REF-KEY") + pure $ do + rk <- pure (fromStringMay ref) `orDie` "invalid REF-KEY" + runApp WithLog (runKeysUpdate rk) + + pKeyRefsList = do + pure $ do + runApp WithLog runKeyRefsList + + pKeysList = do + ref <- strArgument (metavar "REF-KEY") + pure $ do + rk <- pure (fromStringMay ref) `orDie` "invalid REF-KEY" + runApp WithLog (runKeysList rk) + + diff --git a/hbs2-git/hbs2-git.cabal b/hbs2-git/hbs2-git.cabal index 680c7751..cc18aebe 100644 --- a/hbs2-git/hbs2-git.cabal +++ b/hbs2-git/hbs2-git.cabal @@ -70,6 +70,7 @@ common shared-properties , exceptions , filelock , filepath + , filepattern , hashable , http-conduit , interpolatedstring-perl6 @@ -102,15 +103,21 @@ library exposed-modules: HBS2.Git.Types - HBS2.Git.Local - HBS2.Git.Local.CLI + HBS2Git.Alerts + HBS2Git.Annotations HBS2Git.App + HBS2Git.KeysMetaData HBS2Git.Config HBS2Git.Evolve HBS2Git.Export + HBS2Git.Encryption + HBS2Git.Encryption.KeyInfo HBS2Git.GitRepoLog HBS2Git.Import + HBS2Git.KeysCommand HBS2Git.ListRefs + HBS2.Git.Local + HBS2.Git.Local.CLI HBS2Git.PrettyStuff HBS2Git.State HBS2Git.Types diff --git a/hbs2-git/hie.yaml b/hbs2-git/hie.yaml new file mode 100644 index 00000000..04cd2439 --- /dev/null +++ b/hbs2-git/hie.yaml @@ -0,0 +1,2 @@ +cradle: + cabal: diff --git a/hbs2-git/lib/HBS2/Git/Types.hs b/hbs2-git/lib/HBS2/Git/Types.hs index 4deeef81..8cd329a1 100644 --- a/hbs2-git/lib/HBS2/Git/Types.hs +++ b/hbs2-git/lib/HBS2/Git/Types.hs @@ -128,5 +128,7 @@ shutUp = do setLoggingOff @ERROR setLoggingOff @NOTICE setLoggingOff @TRACE + setLoggingOff @INFO + setLoggingOff @WARN diff --git a/hbs2-git/lib/HBS2Git/Alerts.hs b/hbs2-git/lib/HBS2Git/Alerts.hs new file mode 100644 index 00000000..9c8e3449 --- /dev/null +++ b/hbs2-git/lib/HBS2Git/Alerts.hs @@ -0,0 +1,9 @@ +module HBS2Git.Alerts where + +import HBS2.Prelude + +import Text.InterpolatedString.Perl6 (qc) + +noKeyInfoMsg :: forall a . Pretty a => a -> String +noKeyInfoMsg repo = + [qc|*** No KeyInfo found, maybe malformed 'encryption' section for {pretty repo} in config|] diff --git a/hbs2-git/lib/HBS2Git/Annotations.hs b/hbs2-git/lib/HBS2Git/Annotations.hs new file mode 100644 index 00000000..1de591aa --- /dev/null +++ b/hbs2-git/lib/HBS2Git/Annotations.hs @@ -0,0 +1,24 @@ +module HBS2Git.Annotations where + +import HBS2.Prelude.Plated +import HBS2.Data.Types.Refs + +import HBS2Git.Encryption + +import Codec.Serialise + +data Annotation = + GK1 HashRef (GroupKey 'Symm HBS2Basic) + deriving (Generic) + +data Annotations = + NoAnnotations + | SmallAnnotations [Annotation] + deriving (Generic) + +instance Serialise Annotation +instance Serialise Annotations + + + + diff --git a/hbs2-git/lib/HBS2Git/App.hs b/hbs2-git/lib/HBS2Git/App.hs index a8c3104b..51cedf74 100644 --- a/hbs2-git/lib/HBS2Git/App.hs +++ b/hbs2-git/lib/HBS2Git/App.hs @@ -5,10 +5,11 @@ module HBS2Git.App ( module HBS2Git.App , module HBS2Git.Types , HasStorage(..) + , HasConf(..) ) where -import HBS2.Prelude +import HBS2.Prelude.Plated import HBS2.Actors.Peer.Types import HBS2.Data.Types.Refs import HBS2.Base58 @@ -16,7 +17,8 @@ import HBS2.OrDie import HBS2.Hash import HBS2.Clock import HBS2.Storage -import HBS2.Storage.Operations.ByteString +import HBS2.Storage.Operations.ByteString as OP +import HBS2.Net.Auth.GroupKeySymm qualified as Symm import HBS2.System.Logger.Simple import HBS2.Merkle import HBS2.Git.Types @@ -32,8 +34,12 @@ import HBS2.Peer.RPC.API.RefLog import HBS2Git.Types import HBS2Git.Config as Config +import HBS2Git.State +import HBS2Git.KeysMetaData +import HBS2Git.Encryption import HBS2Git.Evolve import HBS2Git.PrettyStuff +import HBS2Git.Alerts import Data.Maybe import Control.Monad.Trans.Maybe @@ -41,7 +47,9 @@ import Data.Foldable import Data.Either import Control.Monad.Reader import Control.Monad.Trans.Resource -import Control.Monad.Except (runExceptT,throwError) +-- import Control.Monad.Except (runExceptT,throwError) +import Control.Monad.Except (runExceptT) +import Control.Monad.Catch import Crypto.Saltine.Core.Sign qualified as Sign import Data.ByteString.Lazy.Char8 (ByteString) import Data.ByteString.Char8 qualified as B8 @@ -50,20 +58,22 @@ import Data.Set (Set) import Data.Set qualified as Set import Lens.Micro.Platform import System.Directory +import System.FilePattern.Directory -- import System.FilePath import System.FilePath import System.Process.Typed import Text.InterpolatedString.Perl6 (qc) -import Network.HTTP.Simple -import Network.HTTP.Types.Status +-- import Network.HTTP.Simple +-- import Network.HTTP.Types.Status import Control.Concurrent.STM (flushTQueue) import Codec.Serialise import Data.HashMap.Strict qualified as HashMap +import Data.HashSet qualified as HashSet import Data.List qualified as List import Data.Text qualified as Text -- import Data.IORef -import System.IO.Unsafe (unsafePerformIO) -import Data.Cache qualified as Cache +-- import System.IO.Unsafe (unsafePerformIO) +-- import Data.Cache qualified as Cache -- import Control.Concurrent.Async import System.Environment @@ -113,6 +123,16 @@ infoPrefix = toStderr data WithLog = NoLog | WithLog + +instance MonadIO m => HasGlobalOptions (App m) where + addGlobalOption k v = + asks (view appOpts ) >>= \t -> liftIO $ atomically $ + modifyTVar' t (HashMap.insert k v) + + getGlobalOption k = do + hm <- asks (view appOpts) >>= liftIO . readTVarIO + pure (HashMap.lookup k hm) + instance MonadIO m => HasRefCredentials (App m) where setCredentials ref cred = do asks (view appRefCred) >>= \t -> liftIO $ atomically $ @@ -120,7 +140,18 @@ instance MonadIO m => HasRefCredentials (App m) where getCredentials ref = do hm <- asks (view appRefCred) >>= liftIO . readTVarIO - pure (HashMap.lookup ref hm) `orDie` "keyring not set" + pure (HashMap.lookup ref hm) `orDie` "keyring not set (1)" + +instance MonadIO m => HasEncryptionKeys (App m) where + addEncryptionKey ke = do + asks (view appKeys) >>= \t -> liftIO $ atomically do + modifyTVar' t (HashMap.insert (view krPk ke) (view krSk ke)) + + findEncryptionKey puk = (asks (view appKeys) >>= \t -> liftIO $ readTVarIO t) <&> HashMap.lookup puk + + enumEncryptionKeys = do + them <- (asks (view appKeys) >>= \t -> liftIO $ readTVarIO t) <&> HashMap.toList + pure $ [KeyringEntry k s Nothing | (k,s) <- them ] instance (Monad m, HasStorage m) => (HasStorage (ResourceT m)) where getStorage = lift getStorage @@ -134,62 +165,6 @@ instance MonadIO m => HasRPC (App m) where withApp :: MonadIO m => AppEnv -> App m a -> m a withApp env m = runReaderT (fromApp m) env -{-# NOINLINE hBS2PeerCatAPI #-} -hBS2PeerCatAPI :: IORef (Maybe API) -hBS2PeerCatAPI = unsafePerformIO (newIORef Nothing) - -detectHBS2PeerCatAPI :: MonadIO m => m API -detectHBS2PeerCatAPI = do - -- FIXME: hardcoded-hbs2-peer - - v <- liftIO $ readIORef hBS2PeerCatAPI - - case v of - Just x -> pure x - Nothing -> do - (_, o, _) <- readProcess (shell [qc|hbs2-peer poke|]) - - let dieMsg = "hbs2-peer is down or it's http is inactive" - - let answ = parseTop (LBS.unpack o) & fromRight mempty - - let po = headMay [ n | ListVal (Key "http-port:" [LitIntVal n]) <- answ ] - -- shutUp - - pnum <- pure po `orDie` dieMsg - - debug $ pretty "using http port" <+> pretty po - - let api = [qc|http://localhost:{pnum}/cat|] - - liftIO $ writeIORef hBS2PeerCatAPI (Just api) - - pure api - - -detectHBS2PeerSizeAPI :: MonadIO m => m API -detectHBS2PeerSizeAPI = do - api <- detectHBS2PeerCatAPI - let new = Text.replace "/cat" "/size" $ Text.pack api - pure $ Text.unpack new - -detectHBS2PeerPutAPI :: MonadIO m => m API -detectHBS2PeerPutAPI = do - api <- detectHBS2PeerCatAPI - let new = Text.replace "/cat" "/" $ Text.pack api - pure $ Text.unpack new - -detectHBS2PeerRefLogGetAPI :: MonadIO m => m API -detectHBS2PeerRefLogGetAPI = do - api <- detectHBS2PeerCatAPI - let new = Text.replace "/cat" "/reflog" $ Text.pack api - pure $ Text.unpack new - - -getAppStateDir :: forall m . MonadIO m => m FilePath -getAppStateDir = liftIO $ getXdgDirectory XdgData Config.appName - - runWithRPC :: forall m . MonadUnliftIO m => (RPCEndpoints -> m ()) -> m () runWithRPC action = do @@ -276,8 +251,10 @@ runApp l m = do runWithRPC $ \rpc -> do mtCred <- liftIO $ newTVarIO mempty - let env = AppEnv pwd (pwd ".git") syn xdgstate mtCred rpc - runReaderT (fromApp m) (set appRpc rpc env) + mtKeys <- liftIO $ newTVarIO mempty + mtOpt <- liftIO $ newTVarIO mempty + let env = AppEnv pwd (pwd ".git") syn xdgstate mtCred mtKeys mtOpt rpc + runReaderT (fromApp (loadKeys >> m)) (set appRpc rpc env) debug $ vcat (fmap pretty syn) @@ -347,7 +324,11 @@ calcRank h = fromMaybe 0 <$> runMaybeT do pure $ sum n postRefUpdate :: ( MonadIO m + , MonadMask m + , HasStorage m + , HasConf m , HasRefCredentials m + , HasEncryptionKeys m , HasRPC m , IsRefPubKey Schema ) @@ -362,7 +343,11 @@ postRefUpdate ref seqno hash = do cred <- getCredentials ref let pubk = view peerSignPk cred let privk = view peerSignSk cred - let tran = SequentialRef seqno (AnnotatedHashRef Nothing hash) + + ann <- genKeysAnnotations ref + + -- вот прямо сюда ОЧЕНЬ удобно вставить метаданные для GK1 + let tran = SequentialRef seqno (AnnotatedHashRef ann hash) let bs = serialise tran & LBS.toStrict msg <- makeRefLogUpdate @HBS2L4Proto pubk privk bs @@ -373,17 +358,46 @@ postRefUpdate ref seqno hash = do >>= either (err . viaShow) (const $ pure ()) -storeObject :: (MonadIO m, HasStorage m, HasConf m) - => ByteString -> ByteString -> m (Maybe HashRef) -storeObject = storeObjectRPC +storeObject :: ( MonadIO m + , MonadMask m + , HasStorage m + , HasConf m + , HasRefCredentials m + , HasEncryptionKeys m + ) + => RepoRef + -> ByteString + -> ByteString + -> m (Maybe HashRef) +storeObject repo meta bs = do + encrypted <- isRefEncrypted (fromRefLogKey repo) + info $ "encrypted" <+> pretty repo <> colon <+> if encrypted then "yes" else "no" + storeObjectRPC encrypted repo meta bs -storeObjectRPC :: (MonadIO m, HasStorage m) - => ByteString + + +data WriteOp = WritePlain | WriteEncrypted B8.ByteString + +storeObjectRPC :: ( MonadIO m + , MonadMask m + , HasStorage m + , HasConf m + , HasRefCredentials m + , HasEncryptionKeys m + ) + => Bool + -> RepoRef + -> ByteString -> ByteString -> m (Maybe HashRef) -storeObjectRPC meta bs = do + +storeObjectRPC False repo meta bs = do sto <- getStorage + db <- makeDbPath repo >>= dbEnv + runMaybeT do + + h <- liftIO $ writeAsMerkle sto bs let txt = LBS.unpack meta & Text.pack blk <- MaybeT $ liftIO $ getBlock sto h @@ -392,15 +406,58 @@ storeObjectRPC meta bs = do mtree <- MaybeT $ deserialiseOrFail @(MTree [HashRef]) blk & either (const $ pure Nothing) (pure . Just) + -- TODO: upadte-metadata-right-here let ann = serialise (MTreeAnn (ShortMetadata txt) NullEncryption mtree) MaybeT $ liftIO $ putBlock sto ann <&> fmap HashRef -makeDbPath :: MonadIO m => RepoRef -> m FilePath -makeDbPath h = do - state <- getAppStateDir - liftIO $ createDirectoryIfMissing True state - pure $ state show (pretty (AsBase58 h)) +storeObjectRPC True repo meta bs = do + + sto <- getStorage + db <- makeDbPath repo >>= dbEnv + + runMaybeT do + + let txt = LBS.unpack meta & Text.pack + + ki <- lift $ getKeyInfo (fromRefLogKey repo) >>= maybe noKeyInfo pure + gkh0 <- withDB db $ stateGetLocalKey ki >>= maybe noKeyFound pure + + gk0 <- runExceptT (readFromMerkle sto (SimpleKey (fromHashRef gkh0))) + >>= either (const $ noKeyFound) (pure . deserialiseOrFail @(GroupKey 'Symm HBS2Basic)) + >>= either (const $ noKeyFound) pure + + let pk = keyInfoOwner ki + + sk <- lift (findEncryptionKey pk) >>= maybe noKeyFound pure + + gks <- maybe noKeyFound pure (Symm.lookupGroupKey sk pk gk0) + + let nonce = hashObject @HbSync bs & serialise + & LBS.drop 2 + & LBS.toStrict + + let bsStream = readChunkedBS bs defBlockSize + let source = ToEncryptSymmBS gks nonce bsStream gk0 (ShortMetadata txt) + + h <- runExceptT (writeAsMerkle sto source) >>= either (const cantWriteMerkle) pure + + pure (HashRef h) + + where + + cantWriteMerkle :: forall a m . MonadIO m => m a + cantWriteMerkle = die "Can't write encrypted merkle tree" + + noKeyFound :: forall a m . MonadIO m => m a + noKeyFound = do + liftIO $ hPutDoc stderr (red $ "No group key found for repo" <+> pretty repo <> line) + die "*** fatal" + + noKeyInfo = do + liftIO $ hPutDoc stderr (red $ pretty (noKeyInfoMsg repo) <> line) + die "*** fatal" + loadCredentials :: ( MonadIO m , HasConf m @@ -408,20 +465,23 @@ loadCredentials :: ( MonadIO m ) => [FilePath] -> m () loadCredentials fp = do - trace $ "loadCredentials" <+> pretty fp + debug $ "loadCredentials" <+> pretty fp krOpt' <- cfgValue @KeyRingFiles @(Set FilePath) <&> Set.toList let krOpt = List.nub $ fp <> krOpt' - when (null krOpt) do - die "keyring not set" + void $ runMaybeT do - for_ krOpt $ \fn -> do - (puk, cred) <- loadKeyring fn - trace $ "got creds for" <+> pretty (AsBase58 puk) - setCredentials (RefLogKey puk) cred - pure () + when (null krOpt) do + debug "keyring not set (2)" + mzero + + for_ krOpt $ \fn -> do + (puk, cred) <- loadKeyring fn + trace $ "got creds for" <+> pretty (AsBase58 puk) + lift $ setCredentials (RefLogKey puk) cred + pure () loadCredentials' :: ( MonadIO m @@ -429,16 +489,96 @@ loadCredentials' :: ) => FilePath -> m Sign.PublicKey loadCredentials' fn = do - (puk, cred) <- loadKeyring fn + (puk, cred) <- runMaybeT (loadKeyring fn) `orDie` [qc|Can't load credentials {fn}|] trace $ "got creds for" <+> pretty (AsBase58 puk) setCredentials (RefLogKey puk) cred pure puk -loadKeyring :: (MonadIO m) => FilePath -> m (Sign.PublicKey, PeerCredentials Schema) +loadKeyring :: (MonadIO m, MonadPlus m) => FilePath -> m (Sign.PublicKey, PeerCredentials Schema) loadKeyring fn = do krData <- liftIO $ B8.readFile fn - cred <- pure (parseCredentials @Schema (AsCredFile krData)) `orDie` "bad keyring file" - let puk = view peerSignPk cred - pure (puk, cred) + + let cred' = parseCredentials @Schema (AsCredFile krData) + + maybe1 cred' mzero $ \cred -> do + let puk = view peerSignPk cred + pure (puk, cred) +makeFilter :: String -> (String, [String]) +makeFilter = norm . over _1 sub1 . over _2 List.singleton . go "" + where + go pref ( cn : cs ) | cn `elem` "?*" = (p0, p1 <> p2) + where + (p0, p1) = splitFileName pref + p2 = cn : cs + + go pref ( '/' : cn : cs ) | cn `elem` "?*" = (pref <> ['/'], cn : cs) + + go pref ( c : cs ) = go (pref <> [c]) cs + + go pref [] = (pref, "") + + sub1 "" = "." + sub1 x = x + + norm (xs, [""]) = (p1, [p2]) + where + (p1, p2) = splitFileName xs + + norm x = x + +loadKeys :: ( MonadIO m + , HasConf m + , HasEncryptionKeys m + , HasGlobalOptions m + ) => m () +loadKeys = do + conf <- getConf + + trace $ "loadKeys" + + kp <- liftIO $ lookupEnv "HBS2KEYS" + + found1 <- findKeyFiles =<< liftIO (lookupEnv "HBS2KEYS") + found2 <- findKeyFiles =<< getGlobalOption "key" + + found <- liftIO $ mapM canonicalizePath (found1 <> found2) + + let enc = [ args | (ListVal @C (SymbolVal "encrypted" : (LitStrVal r) : args)) <- conf ] + + let owners = [ fromStringMay @(PubKey 'Encrypt Schema) (Text.unpack o) + | ListVal @C (Key "owner" [LitStrVal o]) <- universeBi enc + ] & catMaybes & HashSet.fromList + + + let members = [ fromStringMay @(PubKey 'Encrypt Schema) (Text.unpack o) + | ListVal @C (Key "member" [LitStrVal o]) <- universeBi enc + ] & catMaybes & HashSet.fromList + + let decrypt = [ Text.unpack o + | ListVal @C (Key "decrypt" [LitStrVal o]) <- conf + ] + + let keyrings = [ Text.unpack o | ListVal @C (Key "keyring" [LitStrVal o]) <- universeBi enc + ] <> decrypt <> found + & List.nub + + forM_ keyrings $ \k -> void $ runMaybeT do + trace $ "loadKeys: keyring" <+> pretty k + (_, pc) <- loadKeyring k + + forM_ (view peerKeyring pc) $ \ke -> do + let pk = view krPk ke + + trace $ "loadKeyring: key" <+> pretty (AsBase58 pk) + lift $ addEncryptionKey ke + + + where + findKeyFiles w = do + let flt = makeFilter <$> w + maybe1 flt (pure mempty) $ + \(p, fmask) -> liftIO do + getDirectoryFiles p fmask <&> fmap (p) + diff --git a/hbs2-git/lib/HBS2Git/Config.hs b/hbs2-git/lib/HBS2Git/Config.hs index 73813d7b..508c613f 100644 --- a/hbs2-git/lib/HBS2Git/Config.hs +++ b/hbs2-git/lib/HBS2Git/Config.hs @@ -4,6 +4,7 @@ module HBS2Git.Config ) where import HBS2.Prelude +import HBS2.Base58 import HBS2.System.Logger.Simple import HBS2.OrDie @@ -18,9 +19,6 @@ import System.FilePath import System.Directory import System.Environment -import System.IO (stderr) - --- type C = MegaParsec appName :: FilePath appName = "hbs2-git" @@ -57,6 +55,8 @@ configPath _ = liftIO do pwd <- liftIO getCurrentDirectory git <- findGitDir pwd byEnv <- lookupEnv "GIT_DIR" + -- hPrint stderr ("BY-ENV", byEnv) + -- hPrint stderr =<< getEnvironment path <- pure (git <|> byEnv) `orDie` "*** hbs2-git: .git directory not found" pure (takeDirectory path ".hbs2") @@ -70,11 +70,9 @@ data ConfigPathInfo = ConfigPathInfo { getConfigPathInfo :: MonadIO m => m ConfigPathInfo getConfigPathInfo = do trace "getConfigPathInfo" - gitDir <- findWorkingGitDir - pwd <- configPath "" <&> takeDirectory - confP <- configPath pwd + confP <- configPath "" + let pwd = takeDirectory confP let confFile = confP "config" - trace $ "git dir" <+> pretty gitDir trace $ "confPath:" <+> pretty confP pure ConfigPathInfo { configRepoParentDir = pwd, @@ -100,3 +98,13 @@ configInit = liftIO do cookieFile :: MonadIO m => m FilePath cookieFile = configPath "" <&> ( "cookie") +getAppStateDir :: forall m . MonadIO m => m FilePath +getAppStateDir = liftIO $ getXdgDirectory XdgData appName + + +makeDbPath :: MonadIO m => RepoRef -> m FilePath +makeDbPath h = do + state <- getAppStateDir + liftIO $ createDirectoryIfMissing True state + pure $ state show (pretty (AsBase58 h)) + diff --git a/hbs2-git/lib/HBS2Git/Encryption.hs b/hbs2-git/lib/HBS2Git/Encryption.hs new file mode 100644 index 00000000..5c6146fe --- /dev/null +++ b/hbs2-git/lib/HBS2Git/Encryption.hs @@ -0,0 +1,57 @@ +module HBS2Git.Encryption + ( module HBS2Git.Encryption + , module HBS2Git.Encryption.KeyInfo + , module HBS2.Net.Auth.GroupKeySymm + ) where + +import HBS2.Prelude.Plated + +import HBS2.Base58 +import HBS2.Net.Proto.Types hiding (Cookie) +import HBS2.Net.Auth.GroupKeySymm hiding (Cookie) +import HBS2.Net.Proto.Definition() + + +import HBS2Git.Encryption.KeyInfo + +import Data.Config.Suckless.Syntax +import Data.Config.Suckless.KeyValue + +import Data.Function +import Data.HashSet qualified as HashSet +import Data.Maybe +import Data.Text qualified as Text +import Data.Time.Clock.POSIX + +-- type ForEncryption ? + +isRefEncrypted :: (MonadIO m, HasConf m) => PubKey 'Sign HBS2Basic -> m Bool +isRefEncrypted ref = do + conf <- getConf + + let ee = [ True + | (ListVal @C (SymbolVal "encrypted" : (LitStrVal r) : _)) <- conf + , fromStringMay (Text.unpack r) == Just ref + ] + + -- liftIO $ hPutDoc stderr $ "isRefEncrypted" <+> pretty (AsBase58 ref) <+> pretty ee <+> pretty (not (null ee)) <> line + + pure $ not $ null ee + +getKeyInfo :: (MonadIO m, HasConf m) => PubKey 'Sign HBS2Basic -> m (Maybe KeyInfo) +getKeyInfo ref = do + conf <- getConf + + now <- liftIO getPOSIXTime + let every = [ keyInfoFrom now syn | syn <- conf + , isJust (keyInfoFrom now syn) + ] & catMaybes + + pure (lastMay [ x | x <- every, keyInfoRef x == ref ]) + + +genGK0 :: (MonadIO m) => KeyInfo -> m (GroupKey 'Symm HBS2Basic) +genGK0 ki = generateGroupKey @HBS2Basic Nothing members + where + members = HashSet.toList ( keyInfoOwner ki `HashSet.insert` keyInfoMembers ki ) + diff --git a/hbs2-git/lib/HBS2Git/Encryption/KeyInfo.hs b/hbs2-git/lib/HBS2Git/Encryption/KeyInfo.hs new file mode 100644 index 00000000..46c2bf52 --- /dev/null +++ b/hbs2-git/lib/HBS2Git/Encryption/KeyInfo.hs @@ -0,0 +1,55 @@ +module HBS2Git.Encryption.KeyInfo where + +import HBS2.Prelude.Plated +import HBS2.Hash + +import HBS2.Net.Proto.Types hiding (Cookie) +-- import HBS2.Net.Auth.GroupKeySymm hiding (Cookie) +import HBS2.Net.Proto.Definition() + +import Data.Config.Suckless.Syntax +import Data.Config.Suckless.KeyValue + +import Codec.Serialise +import Data.HashSet +import Data.HashSet qualified as HashSet +import Data.Text qualified as Text +import Data.Time.Clock.POSIX (POSIXTime) +import Data.Maybe + + +data KeyInfo = + KeyInfo + { keyInfoNonce :: Integer + , keyInfoRef :: PubKey 'Sign HBS2Basic + , keyInfoOwner :: PubKey 'Encrypt HBS2Basic + , keyInfoMembers :: HashSet (PubKey 'Encrypt HBS2Basic) + } + deriving (Eq,Ord,Show,Generic) + +instance Serialise KeyInfo + +instance Hashed HbSync KeyInfo where + hashObject ki = hashObject (serialise ki) + + + +keyInfoFrom :: POSIXTime -> Syntax C -> Maybe KeyInfo +keyInfoFrom t (ListVal @C (SymbolVal "encrypted" : (LitStrVal r) : args)) = + KeyInfo <$> nonce + <*> ref + <*> owner + <*> members + + where + nonce = Just $ maybe 0 (round t `div`) ttl + ref = fromStringMay (Text.unpack r) + ttl = Just $ lastDef 86400 [ x | ListVal @C (Key "ttl" [LitIntVal x]) <- args ] + owner = fromStringMay =<< lastMay [ Text.unpack o | ListVal @C (Key "owner" [LitStrVal o]) <- args ] + members = Just $ HashSet.fromList + $ catMaybes + [ fromStringMay (Text.unpack o) | ListVal @C (Key "member" [LitStrVal o]) <- args ] + + -- keypath = lastMay [ Text.unpack p | ListVal @C (Key "keyring" [LitStrVal p]) <- args ] + +keyInfoFrom _ _ = Nothing diff --git a/hbs2-git/lib/HBS2Git/Export.hs b/hbs2-git/lib/HBS2Git/Export.hs index f52c9590..213760a9 100644 --- a/hbs2-git/lib/HBS2Git/Export.hs +++ b/hbs2-git/lib/HBS2Git/Export.hs @@ -14,7 +14,6 @@ import HBS2.Data.Types.Refs import HBS2.OrDie import HBS2.System.Logger.Simple import HBS2.Net.Proto.Definition() -import HBS2.Clock import HBS2.Base58 import HBS2.Net.Proto.RefLog @@ -24,6 +23,7 @@ import HBS2.Git.Local.CLI import HBS2Git.App import HBS2Git.State import HBS2Git.Config +import HBS2Git.KeysMetaData import HBS2Git.GitRepoLog import HBS2Git.PrettyStuff @@ -77,6 +77,7 @@ exportRefDeleted :: forall o m . ( MonadIO m , MonadUnliftIO m , HasConf m , HasRefCredentials m + , HasEncryptionKeys m , HasProgress m , HasStorage m , HasRPC m @@ -131,7 +132,9 @@ exportRefDeleted _ repo ref = do <> "type:" <+> "hbs2-git-push-log" <> line - logMerkle <- storeObject meta content `orDie` [qc|Can't store push log|] + updateGK0 repo + + logMerkle <- storeObject repo meta content `orDie` [qc|Can't store push log|] postRefUpdate repo 0 logMerkle pure logMerkle @@ -155,6 +158,20 @@ newtype ExportT m a = ExportT { fromExportT :: ReaderT ExportEnv m a } , MonadThrow ) +instance (Monad m, HasStorage m) => HasStorage (ExportT m) where + getStorage = lift getStorage + +instance (Monad m, HasConf m) => HasConf (ExportT m) where + getConf = lift getConf + +instance (Monad m, HasRPC m) => HasRPC (ExportT m) where + getRPC = lift getRPC + +instance (Monad m, HasEncryptionKeys m) => HasEncryptionKeys (ExportT m) where + addEncryptionKey = lift . addEncryptionKey + findEncryptionKey k = lift $ findEncryptionKey k + enumEncryptionKeys = lift enumEncryptionKeys + withExportEnv :: MonadIO m => ExportEnv -> ExportT m a -> m a withExportEnv env f = runReaderT (fromExportT f) env @@ -163,16 +180,18 @@ writeLogSegments :: forall m . ( MonadIO m , HasRPC m , MonadMask m , HasRefCredentials m + , HasEncryptionKeys m , HasConf m ) => ( Int -> m () ) + -> RepoRef -> GitHash -> [GitHash] -> Int -> [(GitLogEntry, LBS.ByteString)] -> ExportT m [HashRef] -writeLogSegments onProgress val objs chunkSize trailing = do +writeLogSegments onProgress repo val objs chunkSize trailing = do db <- asks $ view exportDB written <- asks $ view exportWritten @@ -233,7 +252,8 @@ writeLogSegments onProgress val objs chunkSize trailing = do let gzipped = compressWith compressOpts content - logMerkle <- lift $ storeObject meta gzipped `orDie` [qc|Can't store push log|] + -- let nonce = hashObject @HbSync (serialise segments) + logMerkle <- lift $ storeObject repo meta gzipped `orDie` [qc|Can't store push log|] trace $ "PUSH LOG HASH: " <+> pretty logMerkle trace $ "POSTING REFERENCE UPDATE TRANSACTION" <+> pretty remote <+> pretty logMerkle @@ -250,6 +270,7 @@ exportRefOnly :: forall o m . ( MonadIO m , MonadUnliftIO m , HasConf m , HasRefCredentials m + , HasEncryptionKeys m , HasProgress m , HasStorage m , HasRPC m @@ -275,6 +296,8 @@ exportRefOnly _ remote rfrom ref val = do h <- MaybeT $ readRef remote calcRank h + updateGK0 remote + trace $ "exportRefOnly" <+> pretty remote <+> pretty ref <+> pretty val -- 1. get max ref value for known REMOTE branch @@ -362,10 +385,10 @@ exportRefOnly _ remote rfrom ref val = do -- we need context entries to determine log HEAD operation sequence -- so only the last section needs it alongwith headEntry - logz <- lift $ withExportEnv env (writeLogSegments upd val objects batch [ (ctx, ctxBs) - , (rank, rankBs) - , (headEntry, repoHeadStr) - ]) + logz <- lift $ withExportEnv env (writeLogSegments upd remote val objects batch [ (ctx, ctxBs) + , (rank, rankBs) + , (headEntry, repoHeadStr) + ]) -- NOTE: отдаём только последнюю секцию лога, -- что бы оставить совместимость @@ -373,6 +396,8 @@ exportRefOnly _ remote rfrom ref val = do --- + + runExport :: forall m . ( MonadIO m , MonadUnliftIO m , MonadCatch m @@ -380,11 +405,13 @@ runExport :: forall m . ( MonadIO m , MonadMask (App m) , HasStorage (App m) , HasRPC (App m) + , HasEncryptionKeys (App m) ) => Maybe FilePath -> RepoRef -> App m () runExport mfp repo = do loadCredentials (maybeToList mfp) + loadKeys let krf = fromMaybe "keyring-file" mfp & takeFileName runExport'' krf repo @@ -397,12 +424,14 @@ runExport' :: forall m . ( MonadIO m , MonadMask (App m) , HasStorage (App m) , HasRPC (App m) + , HasEncryptionKeys (App m) ) => FilePath -> App m () runExport' fp = do repo <- loadCredentials' fp + loadKeys runExport'' (takeFileName fp) (RefLogKey repo) --- diff --git a/hbs2-git/lib/HBS2Git/Import.hs b/hbs2-git/lib/HBS2Git/Import.hs index e48c31d1..4d042dcb 100644 --- a/hbs2-git/lib/HBS2Git/Import.hs +++ b/hbs2-git/lib/HBS2Git/Import.hs @@ -7,6 +7,9 @@ import HBS2.OrDie import HBS2.System.Logger.Simple import HBS2.Merkle import HBS2.Hash +import HBS2.Storage.Operations.Class +import HBS2.Storage.Operations.ByteString(TreeKey(..)) +import HBS2.Net.Auth.GroupKeySymm import HBS2.Net.Proto.RefLog import Text.InterpolatedString.Perl6 (qc) import HBS2.Data.Detect hiding (Blob) @@ -14,7 +17,9 @@ import HBS2.Data.Detect hiding (Blob) import HBS2.Git.Local import HBS2Git.GitRepoLog import HBS2Git.App +import HBS2Git.Config import HBS2Git.State +import HBS2Git.KeysMetaData import HBS2.Git.Local.CLI import Data.Fixed @@ -27,6 +32,7 @@ import Data.ByteString.Lazy.Char8 qualified as LBS import Lens.Micro.Platform import Data.Set qualified as Set import Codec.Serialise +import Control.Monad.Except (runExceptT) import Control.Monad.Catch import Control.Monad.Trans.Resource import System.Directory @@ -36,12 +42,13 @@ import System.IO (openBinaryFile) import System.FilePath.Posix import Data.HashMap.Strict qualified as HashMap import Data.Text qualified as Text -import Data.Config.Suckless import Data.Either import Streaming.ByteString qualified as SB import Streaming.Zip qualified as SZip +import HBS2Git.PrettyStuff + data RunImportOpts = RunImportOpts { _runImportDry :: Maybe Bool @@ -114,6 +121,7 @@ importRefLogNew :: ( MonadIO m , MonadCatch m , MonadMask m , HasStorage m + , HasEncryptionKeys m , HasImportOpts opts ) => opts -> RepoRef -> m () @@ -122,6 +130,8 @@ importRefLogNew opts ref = runResourceT do let force = importForce opts + sto <- getStorage + let myTempDir = "hbs-git" temp <- liftIO getCanonicalTemporaryDirectory (_,dir) <- allocate (createTempDirectory temp myTempDir) removeDirectoryRecursive @@ -158,12 +168,22 @@ importRefLogNew opts ref = runResourceT do sp0 <- withDB db savepointNew withDB db $ savepointBegin sp0 + -- TODO: scan-metadata-transactions-first + -- Сканируем транзы, обрабатываем транзакции с метаданными + -- Пишем транзакции с журналами, что бы обрабатывались следующим + -- проходом только они. Таким образом не меняется сложность. + + decrypt <- lift enumEncryptionKeys + + debug $ "Decrypt" <> vcat (fmap pretty decrypt) + + -- TODO: exclude-metadata-transactions forM_ entries $ \e -> do missed <- lift $ readBlock e <&> isNothing when missed do - debug $ "MISSED BLOCK" <+> pretty e + warn $ "MISSED BLOCK" <+> pretty e let fname = show (pretty e) let fpath = dir fname @@ -172,9 +192,14 @@ importRefLogNew opts ref = runResourceT do runMaybeT $ do bs <- MaybeT $ lift $ readBlock e - refupd <- MaybeT $ pure $ deserialiseOrFail @(RefLogUpdate HBS2L4Proto) bs & either (const Nothing) Just - payload <- MaybeT $ pure $ deserialiseOrFail (LBS.fromStrict $ view refLogUpdData refupd) & either (const Nothing) Just - let (SequentialRef _ (AnnotatedHashRef _ h)) = payload + refupd <- toMPlus $ deserialiseOrFail @(RefLogUpdate HBS2L4Proto) bs + payload <- toMPlus $ deserialiseOrFail (LBS.fromStrict $ view refLogUpdData refupd) + + -- NOTE: good-place-to-process-hash-log-update-first + let (SequentialRef _ (AnnotatedHashRef ann' h)) = payload + + forM_ ann' (withDB db . importKeysAnnotations ref e) + trace $ "PUSH LOG HASH" <+> pretty h treeBs <- MaybeT $ lift $ readBlock h @@ -197,10 +222,43 @@ importRefLogNew opts ref = runResourceT do unless (here && not force) do + (src, enc) <- case something of + + MerkleAnn (MTreeAnn _ sc@(EncryptGroupNaClSymm g nonce) tree) -> do + + gk10' <- runExceptT $ readFromMerkle sto (SimpleKey g) + + -- FIXME: nicer-error-handling + gk10'' <- either (const $ err ("GK0 not found:" <+> pretty g) >> mzero) pure gk10' + + gk10 <- toMPlus (deserialiseOrFail gk10'') + + gk11 <- withDB db $ stateListGK1 (HashRef g) + + let gk1 = mconcat $ gk10 : gk11 + + -- elbs <- runExceptT $ readFromMerkle sto (ToDecryptBS decrypt (fromHashRef h)) + elbs <- runExceptT $ readFromMerkle sto (ToDecryptBS2 gk1 nonce decrypt tree) + + case elbs of + Left{} -> do + let lock = toStringANSI $ red "x" + hPutStrLn stderr [qc|import [{lock}] {pretty e}|] + mzero + + Right lbs -> (,True) <$> pure do + SB.fromLazy lbs + pure (fromIntegral (LBS.length lbs)) + + -- FIXME: remove-debug + MerkleAnn{} -> pure (blockSource h, False) + + _ -> pure (blockSource h, False) + sz <- if gzipped then do - SB.toHandle fh $ SZip.gunzip (blockSource h) + SB.toHandle fh $ SZip.gunzip src else - SB.toHandle fh (blockSource h) + SB.toHandle fh src release keyFh @@ -213,8 +271,10 @@ importRefLogNew opts ref = runResourceT do num <- liftIO $ readTVarIO tnum trace $ "LOG ENTRY COUNT" <+> pretty num + let lock = toStringANSI $ if enc then yellow "@" else " " + let pref = take 16 (show (pretty e)) - let name = [qc|import {pref}... {realToFrac sz / (1024*1024) :: Fixed E3}|] + let name = [qc|import [{lock}] {pref}... {realToFrac sz / (1024*1024) :: Fixed E3}|] oMon <- newProgressMonitor name num diff --git a/hbs2-git/lib/HBS2Git/KeysCommand.hs b/hbs2-git/lib/HBS2Git/KeysCommand.hs new file mode 100644 index 00000000..546bec12 --- /dev/null +++ b/hbs2-git/lib/HBS2Git/KeysCommand.hs @@ -0,0 +1,80 @@ +module HBS2Git.KeysCommand + ( module HBS2Git.KeysCommand + , module HBS2.Net.Proto.Types + , CryptoAction(..) + ) where + +import HBS2.Prelude.Plated +import HBS2.Base58 +import HBS2.OrDie +import HBS2.Net.Proto.Types + +import HBS2Git.App +import HBS2Git.Encryption +import HBS2.System.Logger.Simple + + +import Data.Function +import Data.Time.Clock.POSIX +import Data.Maybe + + +runKeyRefsList :: (MonadIO m, HasConf m) => m () +runKeyRefsList = do + conf <- getConf + + now <- liftIO getPOSIXTime + + let every = [ keyInfoRef <$> keyInfoFrom now syn | syn <- conf + , isJust (keyInfoFrom now syn) + ] & catMaybes + + liftIO $ print $ vcat (fmap (pretty . AsBase58) every) + + + +runKeysUpdate :: (MonadIO m, HasConf m) => PubKey 'Sign HBS2Basic -> m () +runKeysUpdate ref = do + conf <- getConf + + -- TODO: generate-GK0 + -- generate basic key for OWNER only + + now <- liftIO getPOSIXTime + let every = [ keyInfoFrom now syn | syn <- conf + , isJust (keyInfoFrom now syn) + ] & catMaybes + + this <- pure (lastMay [ x | x <- every, keyInfoRef x == ref ]) + `orDie` "Not found encrypted section for given ref" + + gk0 <- generateGroupKey @HBS2Basic Nothing [keyInfoOwner this] + + pure () + + -- now <- liftIO getPOSIXTime + + -- let every = [ keyInfoFrom now syn | syn <- conf + -- , isJust (keyInfoFrom now syn) + -- ] & catMaybes + + -- let keys = [ x | x <- every, keyInfoRef x == ref ] + + -- info $ viaShow keys + + +runKeysList :: (MonadIO m, HasConf m) => PubKey 'Sign HBS2Basic -> m () +runKeysList ref = do + conf <- getConf + + now <- liftIO getPOSIXTime + + let every = [ keyInfoFrom now syn | syn <- conf + , isJust (keyInfoFrom now syn) + ] & catMaybes + + let keys = [ x | x <- every, keyInfoRef x == ref ] + + info $ viaShow keys + + diff --git a/hbs2-git/lib/HBS2Git/KeysMetaData.hs b/hbs2-git/lib/HBS2Git/KeysMetaData.hs new file mode 100644 index 00000000..d91817e3 --- /dev/null +++ b/hbs2-git/lib/HBS2Git/KeysMetaData.hs @@ -0,0 +1,266 @@ +module HBS2Git.KeysMetaData where + +import HBS2.Prelude.Plated +import HBS2.Hash +import HBS2.Base58 +import HBS2.Data.Detect +import HBS2.Data.Types.Refs +import HBS2.Merkle +import HBS2.Net.Auth.GroupKeySymm +import HBS2.Net.Proto.RefLog +import HBS2.OrDie +import HBS2.Storage +import HBS2.Storage.Operations.ByteString +import HBS2.System.Logger.Simple +import HBS2.Net.Proto.Definition() + +import HBS2Git.Types +import HBS2Git.Alerts +import HBS2Git.Annotations +import HBS2Git.Encryption +import HBS2Git.State +import HBS2Git.PrettyStuff +import HBS2Git.Config + +import Codec.Serialise +import Control.Monad +import Control.Monad.Catch (MonadMask) +import Control.Monad.Except (runExceptT) +import Control.Monad.Trans.Maybe +import Data.ByteString.Lazy (ByteString) +import Data.ByteString.Lazy.Char8 qualified as LBS +import Data.Either +import Data.HashMap.Strict qualified as HashMap +import Data.HashSet qualified as HashSet +import Data.List qualified as List +import Data.Function (on) +import Data.Maybe +import Lens.Micro.Platform +import Streaming.Prelude qualified as S +import System.IO +import Text.InterpolatedString.Perl6 (qc) + + +updateGK0 :: forall m . ( MonadIO m + -- , HasRPC m + , MonadMask m + , HasStorage m + , HasConf m + , HasEncryptionKeys m + ) + => RepoRef + -> m () +updateGK0 repo = void $ runMaybeT do + + guard =<< lift (isRefEncrypted (fromRefLogKey repo)) + + db <- makeDbPath repo >>= dbEnv + -- FIXME: check-if-for-die-good-here + ki <- lift $ getKeyInfo (fromRefLogKey repo) + `orDie` noKeyInfoMsg repo + + -- 2. Если нет GK0 или он expired + mbGk0Hash <- withDB db $ stateGetLocalKey ki + + -- 2.1 Генерируем новый GK0 + gk0Hash <- lift $ maybe1 mbGk0Hash (makeNewGK0 ki) pure + + when (isNothing mbGk0Hash) do + liftIO $ hPutDoc stderr $ "New GK0" <+> pretty gk0Hash <> line + + withDB db $ statePutLocalKey ki gk0Hash repo + + debug $ "GK0" <+> pretty gk0Hash + + where + makeNewGK0 ki = do + sto <- getStorage + gk <- genGK0 ki <&> serialise + liftIO $ writeAsMerkle sto (gk :: ByteString) <&> HashRef + +genKeysAnnotations :: forall m . ( MonadIO m + , MonadMask m + , HasStorage m + , HasConf m + , HasEncryptionKeys m + ) + => RepoRef + -> m (Maybe HashRef) + +genKeysAnnotations repo = do + sto <- getStorage + + runMaybeT do + + guard =<< lift (isRefEncrypted (fromRefLogKey repo)) + + db <- makeDbPath repo >>= dbEnv + -- TODO: generate-and-update-keys-metadata + -- 1. get GK0 + + ki <- lift $ getKeyInfo (fromRefLogKey repo) + `orDie` noKeyInfoMsg repo + + gk0Hash <- withDB db $ stateGetLocalKey ki + `orDie` noKeyInfoMsg repo + + let processedKey = serialise ("GENKEYMETADATA", gk0Hash) + + isNewKey <- withDB db $ not <$> stateGetProcessed processedKey + + sp0 <- withDB db savepointNew + withDB db $ savepointBegin sp0 + + -- FIXME: excess-data-roundtrip + gk0newBs <- (runExceptT (readFromMerkle sto (SimpleKey (fromHashRef gk0Hash)))) + `orDie` [qc|*** Can't load GK0 {pretty gk0Hash}, maybe storage failure|] + + -- теперь нам надо как-то узнать, что ключ новый и нам надо обработать + -- новых читателей. + -- Вариант #1: писать авторов в стейт. если они не обработаны еще, + -- то обрабатывать. + + -- 2.2 Генерируем новый GK1 ∀ members + -- FIXME: might-be-slow + + guard isNewKey + + -- notice $ "NEW KEY APPEARED" <+> pretty gk0Hash + + h <- toMPlus =<< getRef sto (refAlias repo) + + gk0hs <- HashSet.fromList <$> S.toList_ (findAllGK0 sto h) + + let keySource = do + forM_ gk0hs $ \gkh -> void $ runMaybeT do + gbs <- toMPlus =<< runExceptT (readFromMerkle sto (SimpleKey gkh)) + gk0 <- toMPlus $ deserialiseOrFail @(GroupKey 'Symm HBS2Basic) gbs + -- TODO: decrypt-secret-right-here + lift $ S.yield (gkh, gk0) + + allKeys <- S.toList_ keySource <&> HashMap.fromList + + -- ∀ gk0: + -- - вытащить секрет (найти, кем расшифровать) recipients + -- - взять вообще всех recipients и сформировать новый GK1 + -- для каждого из recipients из allKeys + + -- взять все доступные пары ключей? + keys <- lift enumEncryptionKeys <&> fmap (\x -> (view krPk x, view krSk x)) + + new' <- forM (HashMap.toList allKeys) $ \(hx, gk0) -> do + let gksec' = [ lookupGroupKey sk pk gk0 | (pk,sk) <- keys ] & catMaybes & headMay + case gksec' of + Nothing -> pure (Left hx) + Just sec -> pure $ Right (hx, gk0, sec) + + let missed = lefts new' + + forM_ missed $ \miss -> do + warn $ "new group key: unavailable keys for gk" <+> pretty miss + + let new = rights new' + + gk0new <- pure (deserialiseOrFail @(GroupKey 'Symm HBS2Basic) gk0newBs) + `orDie` [qc|*** Malformed/corrupted group key {pretty gk0Hash}|] + + let rcpt0 = recipients gk0new + + gnew <- forM new $ \(hx, gk0, sec) -> do + + -- TODO: test-if-key-removing-works + let newRcpt = (recipients gk0new & HashMap.keysSet) + `HashSet.difference` + (recipients gk0 & HashMap.keysSet) + + let r1 = HashMap.keys $ recipients gk0 <> recipients gk0new + + let r11 = [ x | x <- r1, HashMap.member x rcpt0 ] + + gk1 <- generateGroupKey @HBS2Basic (Just sec) r11 + + pure (hx, newRcpt, gk1) + + let nr = HashSet.unions $ fmap (view _2) gnew + + ann <- if HashSet.null nr then do + pure mempty + else do + forM gnew $ \(gk0h, _, gk1) -> do + pure (GK1 (HashRef gk0h) gk1) + + + annHash <- if List.null ann then do + pure Nothing + else do + Just . HashRef <$> writeAsMerkle sto (serialise (SmallAnnotations ann)) + + debug $ "ANNOTATIONS" <+> pretty annHash + + withDB db do + statePutProcessed processedKey + savepointRelease sp0 + + toMPlus annHash + + where + + -- FIXME: deepScan-ScanShallow-broken + -- TODO: deal-with-missed-blocks + findAllGK0 sto h = do + -- TODO: performance-memoize-possible + -- можно мемоизировать для h + deepScan ScanDeep (const none) h (getBlock sto) $ \hx -> do + void $ runMaybeT do + blk <- toMPlus =<< getBlock sto hx + refupd <- toMPlus $ deserialiseOrFail @(RefLogUpdate HBS2L4Proto) blk + payload <- toMPlus $ deserialiseOrFail (LBS.fromStrict $ view refLogUpdData refupd) + + let (SequentialRef _ (AnnotatedHashRef _ ht)) = payload + + treeBs <- toMPlus =<< getBlock sto (fromHashRef ht) + + enc <- toMPlus (deserialiseOrFail @(MTreeAnn [HashRef]) treeBs) + <&> _mtaCrypt + + case enc of + EncryptGroupNaClSymm g _ -> do + -- liftIO $ hPutDoc stderr $ "GK0 FOR" <+> pretty + lift $ S.yield g + + _ -> pure () + + +importKeysAnnotations :: forall m . ( MonadIO m + , MonadMask m + , HasStorage m + ) + => RepoRef + -> HashRef + -> HashRef + -> DB m () + +importKeysAnnotations repo e href = do + sto <- lift getStorage + -- db <- makeDbPath repo >>= dbEnv + void $ runMaybeT do + -- liftIO $ hPutDoc stderr $ "GOT ANNOTATION" <+> pretty e <+> pretty href <> line + ebs <- runExceptT $ readFromMerkle sto (SimpleKey (fromHashRef href)) + bs <- toMPlus ebs + + anns <- toMPlus $ deserialiseOrFail @Annotations bs + + let entries = case anns of + SmallAnnotations e -> [ gk1 | gk1@(GK1{}) <- e ] + _ -> mempty + + + forM_ entries $ \(GK1 gk0h gk1) -> do + + -- liftIO $ hPutDoc stderr $ "IMPORTING GK1 FOR" <+> pretty gk0h <> line + + forM_ (HashMap.toList (recipients gk1)) $ \(pk,box) -> do + let gk1small = GroupKeySymm @HBS2Basic (HashMap.singleton pk box) + lift $ statePutGK1 gk0h pk gk1small + + diff --git a/hbs2-git/lib/HBS2Git/ListRefs.hs b/hbs2-git/lib/HBS2Git/ListRefs.hs index d6720bb3..fb5559f7 100644 --- a/hbs2-git/lib/HBS2Git/ListRefs.hs +++ b/hbs2-git/lib/HBS2Git/ListRefs.hs @@ -1,5 +1,7 @@ module HBS2Git.ListRefs where +import HBS2.Prelude + import HBS2Git.Types import HBS2.Prelude import HBS2Git.App @@ -9,6 +11,7 @@ import HBS2.System.Logger.Simple import HBS2.Git.Local.CLI import HBS2.Git.Types import HBS2Git.Import (importRefLogNew) +import HBS2Git.Config import HBS2Git.State import HBS2Git.PrettyStuff diff --git a/hbs2-git/lib/HBS2Git/PrettyStuff.hs b/hbs2-git/lib/HBS2Git/PrettyStuff.hs index bdfaedd4..688dee5a 100644 --- a/hbs2-git/lib/HBS2Git/PrettyStuff.hs +++ b/hbs2-git/lib/HBS2Git/PrettyStuff.hs @@ -1,5 +1,9 @@ -module HBS2Git.PrettyStuff where +module HBS2Git.PrettyStuff + ( module HBS2Git.PrettyStuff + , hPutDoc + ) where +import Data.Text qualified as Text import Prettyprinter import Prettyprinter.Render.Terminal @@ -9,9 +13,15 @@ green = annotate (color Green) yellow :: Doc AnsiStyle -> Doc AnsiStyle yellow = annotate (color Yellow) - red :: Doc AnsiStyle -> Doc AnsiStyle red = annotate (color Red) +blue :: Doc AnsiStyle -> Doc AnsiStyle +blue = annotate (color Blue) + section :: Doc ann section = line <> line + +toStringANSI :: Doc AnsiStyle -> String +toStringANSI doc = Text.unpack $ renderStrict $ layoutPretty defaultLayoutOptions doc + diff --git a/hbs2-git/lib/HBS2Git/State.hs b/hbs2-git/lib/HBS2Git/State.hs index 0ef9a7c0..8dcd0a78 100644 --- a/hbs2-git/lib/HBS2Git/State.hs +++ b/hbs2-git/lib/HBS2Git/State.hs @@ -1,7 +1,11 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} +{-# Language UndecidableInstances #-} module HBS2Git.State where import HBS2.Prelude +import HBS2.Base58 +import HBS2.Net.Auth.GroupKeySymm hiding (Cookie) + import HBS2Git.Types import HBS2.Data.Types.Refs import HBS2.Git.Types @@ -10,6 +14,7 @@ import HBS2.Hash import HBS2.System.Logger.Simple import HBS2Git.Config (cookieFile) +import HBS2Git.Encryption import Control.Monad.Trans.Resource import Data.Functor @@ -63,6 +68,19 @@ instance ToField GitObjectType where instance FromField HashRef where fromField = fmap fromString . fromField @String +instance ToField (RefLogKey HBS2Basic) where + toField rk = toField (show (pretty rk)) + +newtype Base58Field a = Base58Field { unBaseB8Field :: a } + +instance Pretty (AsBase58 a) => ToField (Base58Field a) where + toField (Base58Field a) = toField (show (pretty (AsBase58 a))) + +instance FromStringMaybe a => FromField (Base58Field a) where + fromField x = + fromField @String x + <&> fromStringMay @a + >>= maybe (fail "can't parse base58 value") (pure . Base58Field) newtype DB m a = DB { fromDB :: ReaderT DBEnv m a } @@ -216,6 +234,35 @@ stateInit = do ); |] + + liftIO $ execute_ conn [qc| + CREATE TABLE IF NOT EXISTS groupkeylocal + ( keyhash text not null + , ref text not null + , timestamp DATETIME DEFAULT CURRENT_TIMESTAMP + , valuehash text not null + , primary key (keyhash) + ); + |] + + liftIO $ execute_ conn [qc| + CREATE TABLE IF NOT EXISTS gk1 + ( gk0 text not null + , pk text not null + , gk1 text not null + , primary key (gk0, pk) + ); + |] + + liftIO $ execute_ conn [qc| + CREATE TABLE IF NOT EXISTS processed + ( hash text not null + , cookie text not null + , timestamp DATETIME DEFAULT CURRENT_TIMESTAMP + , primary key (hash) + ); + |] + liftIO $ execute_ conn [qc| DROP VIEW IF EXISTS v_log_depth; |] @@ -523,3 +570,89 @@ stateGenCookie = do pure cookie +stateListLocalKeys :: MonadIO m => DB m [HashRef] +stateListLocalKeys = do + undefined + +stateGetLocalKey :: MonadIO m + => KeyInfo + -> DB m (Maybe HashRef) +stateGetLocalKey ki = do + conn <- stateConnection + let h = hashObject @HbSync ki & HashRef + liftIO $ query conn [qc|select valuehash from groupkeylocal where keyhash = ? limit 1|] (Only h) + <&> fmap fromOnly . listToMaybe + +statePutLocalKey :: MonadIO m + => KeyInfo + -> HashRef + -> RefLogKey HBS2Basic + -> DB m () + +statePutLocalKey ki gkh reflog = do + conn <- stateConnection + let sql = [qc| + INSERT INTO groupkeylocal (keyhash, ref, valuehash) + VALUES (?,?,?) + ON CONFLICT (keyhash) DO UPDATE SET + ref = excluded.ref, valuehash = excluded.valuehash + |] + + liftIO $ execute conn sql (HashRef (hashObject @HbSync ki), reflog, gkh) + pure () + + +statePutProcessed :: (MonadIO m, Hashed HbSync b) => b -> DB m () +statePutProcessed h = do + conn <- stateConnection + cookie <- asks (view dbCookie) + liftIO $ execute conn [qc| + insert into processed (hash, cookie) values (?, ?) + on conflict (hash) do nothing + |] (HashRef (hashObject @HbSync h), cookie) + +stateGetProcessed :: (MonadIO m, Hashed HbSync b) => b -> DB m Bool +stateGetProcessed h = do + conn <- stateConnection + cookie <- asks (view dbCookie) + r <- liftIO $ query @_ @(Only Int) conn [qc| + select 1 from processed where hash = ? and cookie = ? limit 1 + |] (HashRef (hashObject @HbSync h), cookie) + pure $ not $ null r + + +statePutGK1 :: MonadIO m => HashRef + -> PubKey 'Encrypt HBS2Basic + -> GroupKey 'Symm HBS2Basic + -> DB m () + +statePutGK1 gk0 pk gk1 = do + conn <- stateConnection + liftIO $ execute conn [qc| + insert into gk1 (gk0, pk, gk1) values (?, ?, ?) + on conflict (gk0, pk) do nothing + |] (gk0, Base58Field pk, Base58Field gk1) + +stateGetGK1 :: MonadIO m + => HashRef + -> PubKey 'Encrypt HBS2Basic + -> DB m (Maybe (GroupKey 'Symm HBS2Basic)) + +stateGetGK1 gk0 pk = do + conn <- stateConnection + r <- liftIO $ query conn [qc| + select gk1 from gk1 where gk0 = ? and pk = ? limit 1 + |] (gk0, Base58Field pk) + pure $ listToMaybe $ fmap (unBaseB8Field . fromOnly) r + +stateListGK1 :: MonadIO m + => HashRef + -> DB m [GroupKey 'Symm HBS2Basic] + +stateListGK1 gk0 = do + conn <- stateConnection + r <- liftIO $ query conn [qc| + select gk1 from gk1 where gk0 = ? + |] (Only gk0) + pure $ fmap (unBaseB8Field . fromOnly) r + diff --git a/hbs2-git/lib/HBS2Git/Types.hs b/hbs2-git/lib/HBS2Git/Types.hs index 78a31518..f08f512f 100644 --- a/hbs2-git/lib/HBS2Git/Types.hs +++ b/hbs2-git/lib/HBS2Git/Types.hs @@ -6,18 +6,19 @@ module HBS2Git.Types ( module HBS2Git.Types , module Control.Monad.IO.Class , HasStorage(..) + , HasConf(..) , AnyStorage(..) + , RefLogKey(..) ) where import HBS2.Prelude.Plated import HBS2.Hash -import HBS2.Base58 +import HBS2.Clock import HBS2.Git.Types import HBS2.Actors.Peer.Types (HasStorage(..),AnyStorage(..)) import HBS2.Peer.RPC.Client.Unix hiding (Cookie) import HBS2.Net.Proto.RefLog (RefLogKey(..)) -import HBS2.Net.Proto.Types hiding (Cookie) import HBS2.Net.Auth.Credentials import HBS2.Peer.RPC.API.Peer @@ -30,13 +31,9 @@ import Data.Config.Suckless import System.ProgressBar import System.Exit as Exit -import Control.Monad.Trans.Maybe import Control.Applicative import Control.Monad.IO.Class import Control.Monad.Reader -import Data.Text qualified as Text -import Data.Text (Text) -import Data.ByteString.Lazy (ByteString) import Data.ByteString.Lazy.Char8 qualified as LBS import Database.SQLite.Simple (Connection) import Data.Char (isSpace) @@ -44,14 +41,12 @@ import Data.List qualified as List import Lens.Micro.Platform import Data.HashMap.Strict (HashMap) import Data.HashMap.Strict qualified as HashMap -import Codec.Serialise import Control.Concurrent.STM import System.IO qualified as IO import System.IO (Handle) import Data.Kind import Control.Monad.Catch import Control.Monad.IO.Unlift -import Control.Monad.Trans.Resource import System.TimeIt @@ -102,6 +97,8 @@ data AppEnv = , _appConf :: [Syntax C] , _appStateDir :: FilePath , _appRefCred :: TVar (HashMap RepoRef (PeerCredentials Schema)) + , _appKeys :: TVar (HashMap (PubKey 'Encrypt Schema) (PrivKey 'Encrypt Schema)) + , _appOpts :: TVar (HashMap String String) , _appRpc :: RPCEndpoints } @@ -184,6 +181,15 @@ class MonadIO m => HasRefCredentials m where getCredentials :: RepoRef -> m (PeerCredentials Schema) setCredentials :: RepoRef -> PeerCredentials Schema -> m () +class MonadIO m => HasGlobalOptions m where + addGlobalOption :: String -> String -> m () + getGlobalOption :: String -> m (Maybe String) + +class MonadIO m => HasEncryptionKeys m where + addEncryptionKey :: KeyringEntry Schema -> m () + findEncryptionKey :: PubKey 'Encrypt Schema -> m (Maybe (PrivKey 'Encrypt Schema)) + enumEncryptionKeys :: m [KeyringEntry Schema] + newtype App m a = App { fromApp :: ReaderT AppEnv m a } deriving newtype ( Applicative @@ -201,6 +207,7 @@ newtype App m a = instance MonadIO m => HasConf (App m) where getConf = asks (view appConf) + hPrint :: (Show a, MonadIO m) => Handle -> a -> m () hPrint h s = liftIO $ IO.hPrint h s @@ -220,6 +227,7 @@ exitFailure = do die :: MonadIO m => String -> m a die s = do shutUp + pause @'Seconds 0.1 liftIO $ Exit.die s traceTime :: MonadIO m => String -> m a -> m a diff --git a/hbs2-tests/test/PrototypeGenericService.hs b/hbs2-tests/test/PrototypeGenericService.hs index c068424a..15c22c81 100644 --- a/hbs2-tests/test/PrototypeGenericService.hs +++ b/hbs2-tests/test/PrototypeGenericService.hs @@ -41,9 +41,11 @@ instance HasProtocol UNIX (ServiceProto MyServiceMethods1 UNIX) where -- instance (MonadIO m, HasProtocol UNIX (ServiceProto MyServiceMethods1 UNIX)) => HasTimeLimits UNIX (ServiceProto MyServiceMethods1 UNIX) m where -- tryLockForPeriod _ _ = pure True + +type instance Input Method1 = String +type instance Output Method1 = String + instance MonadIO m => HandleMethod m Method1 where - type instance Input Method1 = String - type instance Output Method1 = String handleMethod n = do debug $ "SERVICE1. METHOD1" <+> pretty n case n of @@ -51,11 +53,12 @@ instance MonadIO m => HandleMethod m Method1 where "PECHEN" -> pure "TRESKI" _ -> pure "X3" -instance MonadIO m => HandleMethod m Method2 where - type instance Input Method2 = () - type instance Output Method2 = () - handleMethod _ = pure () +type instance Input Method2 = () +type instance Output Method2 = () + +instance MonadIO m => HandleMethod m Method2 where + handleMethod _ = pure () instance (HasProtocol UNIX (ServiceProto api UNIX), MonadUnliftIO m) => HasDeferred UNIX (ServiceProto api UNIX) m where diff --git a/hbs2/Main.hs b/hbs2/Main.hs index 7ce33dc2..11bd18ca 100644 --- a/hbs2/Main.hs +++ b/hbs2/Main.hs @@ -378,7 +378,7 @@ runStore opts ss = runResourceT do let segments = readChunked fh (fromIntegral defBlockSize) - let source = ToEncryptSymmBS gks nonce segments gk + let source = ToEncryptSymmBS gks nonce segments gk NoMetaData r <- runExceptT $ writeAsMerkle ss source @@ -415,9 +415,10 @@ runNewGroupKeyAsymm pubkeysFile = do List.sort pubkeys `forM` \pk -> (pk, ) <$> mkEncryptedKey keypair pk print $ pretty $ AsGroupKeyFile $ AsBase58 $ GroupKeyNaClAsymm (_krPk keypair) accesskey -runNewKey :: forall s . (s ~ HBS2Basic) => IO () -runNewKey = do - cred <- newCredentials @s +runNewKey :: forall s . (s ~ HBS2Basic) => Int -> IO () +runNewKey n = do + cred0 <- newCredentials @s + cred <- foldM (\cred _ -> addKeyPair Nothing cred) cred0 [1..n] print $ pretty $ AsCredFile $ AsBase58 cred runListKeys :: forall s . (s ~ HBS2Basic) => FilePath -> IO () @@ -649,7 +650,8 @@ main = join . customExecParser (prefs showHelpOnError) $ pure $ withStore o $ runHash $ HashOpts hash pNewKey = do - pure runNewKey + n <- optional $ option auto ( short 'n' <> long "number") + pure $ runNewKey (fromMaybe 0 n) pShowPeerKey = do fp <- optional $ strArgument ( metavar "FILE" )