diff --git a/docs/devlog.md b/docs/devlog.md index 8416977c..25cffd00 100644 --- a/docs/devlog.md +++ b/docs/devlog.md @@ -1,3 +1,5 @@ +## 2023-09-25 + ## 2023-14-08 PR: hbs2-git-config-location diff --git a/flake.lock b/flake.lock index ba4f51f9..1188bc8e 100644 --- a/flake.lock +++ b/flake.lock @@ -295,15 +295,16 @@ ] }, "locked": { - "lastModified": 1689215736, - "narHash": "sha256-cd/iK5ttyls62RI5JYYANf2O8rV6Ubu1a/4VXDrQCBc=", + "lastModified": 1695116151, + "narHash": "sha256-AjjfTL41SRZFy9HjQ6XKvS9kjfplkJKBIkcBvi1mKkc=", "owner": "voidlizard", "repo": "suckless-conf", - "rev": "0ee3ef62e833df65da99af3feba9feaa7ef4d12b", + "rev": "eef15613402380b9b67c68a0e8a22a71250daa98", "type": "github" }, "original": { "owner": "voidlizard", + "ref": "master", "repo": "suckless-conf", "type": "github" } diff --git a/flake.nix b/flake.nix index baddc891..539976db 100644 --- a/flake.nix +++ b/flake.nix @@ -12,7 +12,7 @@ inputs = { fixme.url = "github:voidlizard/fixme"; fixme.inputs.nixpkgs.follows = "nixpkgs"; - suckless-conf.url = "github:voidlizard/suckless-conf"; + suckless-conf.url = "github:voidlizard/suckless-conf/master"; suckless-conf.inputs.nixpkgs.follows = "nixpkgs"; saltine = { diff --git a/hbs2-core/hbs2-core.cabal b/hbs2-core/hbs2-core.cabal index 9db89d3a..96d43cd5 100644 --- a/hbs2-core/hbs2-core.cabal +++ b/hbs2-core/hbs2-core.cabal @@ -84,12 +84,14 @@ library , HBS2.Data.Types.Peer , HBS2.Data.Types.Refs , HBS2.Data.Types.SignedBox + , HBS2.Data.Types.EncryptedBox , HBS2.Data.Bundle , HBS2.Defaults , HBS2.Events , HBS2.Hash , HBS2.Merkle - , HBS2.Net.Auth.AccessKey + , HBS2.Net.Auth.GroupKeyAsymm + , HBS2.Net.Auth.GroupKeySymm , HBS2.Net.Auth.Credentials , HBS2.Net.IP.Addr , HBS2.Net.Messaging @@ -120,7 +122,8 @@ library , HBS2.Prelude , HBS2.Prelude.Plated , HBS2.Storage - , HBS2.Storage.Operations + , HBS2.Storage.Operations.Class + , HBS2.Storage.Operations.ByteString , HBS2.System.Logger.Simple , HBS2.System.Logger.Simple.Class , HBS2.Net.Dialog.Core diff --git a/hbs2-core/lib/HBS2/Data/Bundle.hs b/hbs2-core/lib/HBS2/Data/Bundle.hs index 49b1c63b..58433b6b 100644 --- a/hbs2-core/lib/HBS2/Data/Bundle.hs +++ b/hbs2-core/lib/HBS2/Data/Bundle.hs @@ -4,7 +4,7 @@ module HBS2.Data.Bundle where import HBS2.Prelude import HBS2.Storage -import HBS2.Storage.Operations +import HBS2.Storage.Operations.ByteString import HBS2.Hash import HBS2.Data.Types.Refs import HBS2.Data.Types.SignedBox @@ -14,17 +14,12 @@ import HBS2.Data.Detect import Data.Word -import Data.Function import Codec.Compression.GZip as GZip import Codec.Serialise import Control.Monad -import Control.Monad.Trans.Maybe import Data.ByteString.Lazy.Char8 (ByteString) import Data.ByteString.Lazy.Char8 qualified as LBS -import Data.Functor -import Data.List qualified as List import Data.Either -import Data.Maybe import Streaming.Prelude qualified as S import Streaming() diff --git a/hbs2-core/lib/HBS2/Data/Detect.hs b/hbs2-core/lib/HBS2/Data/Detect.hs index 86538142..01032ec9 100644 --- a/hbs2-core/lib/HBS2/Data/Detect.hs +++ b/hbs2-core/lib/HBS2/Data/Detect.hs @@ -95,8 +95,10 @@ deepScan l miss from reader sink = do -- FIXME: ASAP-support-encryption CryptAccessKeyNaClAsymm{} -> do - err "deepScan does not support encryption yet" - pure () + lift $ walkTree (_mtaTree ann) + + EncryptGroupNaClSymm{} -> do + lift $ walkTree (_mtaTree ann) SeqRef (SequentialRef _ (AnnotatedHashRef ann hx)) -> do lift $ maybe1 ann (pure ()) sinkDeep diff --git a/hbs2-core/lib/HBS2/Data/Types/EncryptedBox.hs b/hbs2-core/lib/HBS2/Data/Types/EncryptedBox.hs new file mode 100644 index 00000000..ba5389aa --- /dev/null +++ b/hbs2-core/lib/HBS2/Data/Types/EncryptedBox.hs @@ -0,0 +1,14 @@ +module HBS2.Data.Types.EncryptedBox where + +import HBS2.Prelude.Plated + +import Codec.Serialise +import Data.ByteString (ByteString) + +-- TODO: encryption-type-into-tags +-- FIXME: show-scrambled? +newtype EncryptedBox t = EncryptedBox { unEncryptedBox :: ByteString } + deriving stock (Generic,Show,Data) + +instance Serialise (EncryptedBox t) + diff --git a/hbs2-core/lib/HBS2/Data/Types/Refs.hs b/hbs2-core/lib/HBS2/Data/Types/Refs.hs index 78a782b9..9731809b 100644 --- a/hbs2-core/lib/HBS2/Data/Types/Refs.hs +++ b/hbs2-core/lib/HBS2/Data/Types/Refs.hs @@ -23,6 +23,7 @@ newtype HashRef = HashRef { fromHashRef :: Hash HbSync } deriving stock (Data,Generic,Show) + instance Pretty (AsBase58 HashRef) where pretty (AsBase58 x) = pretty x -- TODO: should be instance Pretty (AsBase58 (Hash HbSync)) @@ -30,6 +31,16 @@ instance Pretty (AsBase58 HashRef) where instance FromStringMaybe HashRef where fromStringMay = fmap HashRef . fromStringMay +newtype TheHashRef t = TheHashRef { fromTheHashRef :: Hash HbSync } + deriving newtype (Eq,Ord,IsString,Pretty,Hashable) + deriving stock (Data,Generic,Show) + +instance Pretty (AsBase58 (TheHashRef t)) where + pretty (AsBase58 x) = pretty x + +instance FromStringMaybe (TheHashRef t) where + fromStringMay = fmap TheHashRef . fromStringMay + data HashRefObject = HashRefObject HashRef (Maybe HashRefMetadata) deriving stock (Data,Show,Generic) diff --git a/hbs2-core/lib/HBS2/Hash.hs b/hbs2-core/lib/HBS2/Hash.hs index f58cb187..5ae79bc7 100644 --- a/hbs2-core/lib/HBS2/Hash.hs +++ b/hbs2-core/lib/HBS2/Hash.hs @@ -39,6 +39,8 @@ data HsHash type family HashType ( a :: Type) where HashType HbSync = Blake2b_256 +type HbSyncHash = HashType HbSync + newtype instance Hash HbSync = HbSyncHash ByteString deriving stock (Eq,Ord,Data,Generic) @@ -54,7 +56,6 @@ class Hashed t a where hashObject :: a -> Hash t - instance Hashed HbSync ByteString where hashObject s = HbSyncHash $! BA.convert digest where diff --git a/hbs2-core/lib/HBS2/Merkle.hs b/hbs2-core/lib/HBS2/Merkle.hs index b95f15d0..9330bb29 100644 --- a/hbs2-core/lib/HBS2/Merkle.hs +++ b/hbs2-core/lib/HBS2/Merkle.hs @@ -87,7 +87,7 @@ data MTreeAnn a = MTreeAnn , _mtaCrypt :: !MTreeEncryption , _mtaTree :: !(MTree a) } - deriving stock (Generic,Data,Show) + deriving stock (Generic,Data,Show) instance Serialise a => Serialise (MTreeAnn a) @@ -97,7 +97,8 @@ data MerkleEncryptionType data MTreeEncryption = NullEncryption | CryptAccessKeyNaClAsymm (Hash HbSync) - deriving stock (Generic,Data,Show) + | EncryptGroupNaClSymm (Hash HbSync) + deriving stock (Eq,Generic,Data,Show) instance Serialise MTreeEncryption diff --git a/hbs2-core/lib/HBS2/Net/Auth/AccessKey.hs b/hbs2-core/lib/HBS2/Net/Auth/GroupKeyAsymm.hs similarity index 82% rename from hbs2-core/lib/HBS2/Net/Auth/AccessKey.hs rename to hbs2-core/lib/HBS2/Net/Auth/GroupKeyAsymm.hs index 4d4c0b8e..95c5dc84 100644 --- a/hbs2-core/lib/HBS2/Net/Auth/AccessKey.hs +++ b/hbs2-core/lib/HBS2/Net/Auth/GroupKeyAsymm.hs @@ -1,12 +1,12 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} -{-# Language TemplateHaskell #-} {-# Language UndecidableInstances #-} {-# Language AllowAmbiguousTypes #-} {-# Language ConstraintKinds #-} -module HBS2.Net.Auth.AccessKey where +module HBS2.Net.Auth.GroupKeyAsymm where import HBS2.Base58 import HBS2.Data.Types +import HBS2.Data.Types.EncryptedBox import HBS2.Merkle import HBS2.Net.Auth.Credentials import HBS2.Net.Proto.Definition @@ -31,10 +31,6 @@ type ForAccessKey s = ( Crypto.IsEncoding (PubKey 'Encrypt s) ) -newtype EncryptedBox = EncryptedBox { unEncryptedBox :: ByteString } - deriving stock (Generic) - -instance Serialise EncryptedBox --- @@ -42,7 +38,7 @@ data family AccessKey s newtype instance AccessKey s = AccessKeyNaClAsymm - { permitted :: [(PubKey 'Encrypt s, EncryptedBox)] + { permitted :: [(PubKey 'Encrypt s, EncryptedBox (KeyringEntry s))] } deriving stock (Generic) @@ -50,37 +46,35 @@ instance ForAccessKey s => Serialise (AccessKey s) --- -data family GroupKey s -data instance GroupKey s = +data instance GroupKey 'Asymm s = GroupKeyNaClAsymm { recipientPk :: PubKey 'Encrypt s , accessKey :: AccessKey s } deriving stock (Generic) -instance ForAccessKey s => Serialise (GroupKey s) +instance ForAccessKey s => Serialise (GroupKey 'Asymm s) --- -newtype AsGroupKeyFile a = AsGroupKeyFile a -- FIXME: integration-regression-test-for-groupkey -- Добавить тест: сгенерировали groupkey/распарсили groupkey parseGroupKey :: forall s . ForAccessKey s - => AsGroupKeyFile ByteString -> Maybe (GroupKey s) + => AsGroupKeyFile ByteString -> Maybe (GroupKey 'Asymm s) parseGroupKey (AsGroupKeyFile bs) = parseSerialisableFromBase58 bs -instance ( Serialise (GroupKey s) +instance ( Serialise (GroupKey 'Asymm s) ) - => Pretty (AsBase58 (GroupKey s)) where + => Pretty (AsBase58 (GroupKey 'Asymm s)) where pretty (AsBase58 c) = pretty . B8.unpack . toBase58 . LBS.toStrict . serialise $ c -instance Pretty (AsBase58 a) => Pretty (AsGroupKeyFile (AsBase58 a)) where +instance ForAccessKey s => Pretty (AsGroupKeyFile (AsBase58 (GroupKey 'Asymm s))) where pretty (AsGroupKeyFile pc) = "# hbs2 groupkey file" <> line <> co where co = vcat $ fmap pretty @@ -101,7 +95,7 @@ parsePubKeys = sequenceA . fmap (Crypto.decode <=< fromBase58) . B8.lines mkEncryptedKey :: forall s . (ForAccessKey s, PubKey 'Encrypt s ~ Encrypt.PublicKey) => KeyringEntry s -> PubKey 'Encrypt s - -> IO EncryptedBox + -> IO (EncryptedBox (KeyringEntry s)) mkEncryptedKey kr pk = EncryptedBox <$> Encrypt.boxSeal pk ((LBS.toStrict . serialise) kr) @@ -109,7 +103,7 @@ openEncryptedKey :: forall s . ( ForAccessKey s , PrivKey 'Encrypt s ~ Encrypt.SecretKey , PubKey 'Encrypt s ~ Encrypt.PublicKey ) - => EncryptedBox + => EncryptedBox (KeyringEntry s) -> KeyringEntry s -> Maybe (KeyringEntry s) diff --git a/hbs2-core/lib/HBS2/Net/Auth/GroupKeySymm.hs b/hbs2-core/lib/HBS2/Net/Auth/GroupKeySymm.hs new file mode 100644 index 00000000..d5bead92 --- /dev/null +++ b/hbs2-core/lib/HBS2/Net/Auth/GroupKeySymm.hs @@ -0,0 +1,292 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# Language UndecidableInstances #-} +{-# Language AllowAmbiguousTypes #-} +{-# Language ConstraintKinds #-} +module HBS2.Net.Auth.GroupKeySymm where + +import HBS2.Prelude.Plated +import HBS2.Base58 +import HBS2.Data.Types.EncryptedBox +import HBS2.Data.Types.Refs +import HBS2.Hash +import HBS2.Merkle +import HBS2.Data.Detect +import HBS2.Net.Auth.Credentials +import HBS2.Net.Proto.Types +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 +import Control.Monad +import Control.Monad.Except +import Control.Monad.Identity +import Control.Monad.Trans.Maybe +import Control.Monad.Writer +import Crypto.Saltine.Class qualified as Saltine +import Crypto.Saltine.Core.Box qualified as AK +import Crypto.Saltine.Core.SecretBox (Key) +import Crypto.Saltine.Core.SecretBox qualified as SK +import Data.ByteString.Lazy (ByteString) +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.Maybe +import Data.Word (Word64) +import Data.ByteArray() +import Network.ByteOrder qualified as N +import Streaming.Prelude qualified as S +import Lens.Micro.Platform + +import Streaming qualified as S +import Streaming (Stream(..), Of(..)) + +import System.IO.Unsafe (unsafePerformIO) + +import Data.Bits (xor) + +type GroupSecretAsymm = Key + +data instance GroupKey 'Symm s = + GroupKeySymm + { recipients :: [(PubKey 'Encrypt s, EncryptedBox GroupSecretAsymm)] + } + deriving stock (Generic) + +instance Serialise Key +instance Serialise SK.Nonce + +-- NOTE: hardcoded-hbs2-basic-auth-type +data instance ToEncrypt 'Symm s LBS.ByteString = + ToEncryptSymmBS + { toEncryptSecret :: GroupSecretAsymm + , toEncryptData :: Stream (Of LBS.ByteString) IO () + , toEncryptGroupKey :: GroupKey 'Symm s + } + + +type ForGroupKeySymm s = ( Eq (PubKey 'Encrypt s) + , PubKey 'Encrypt s ~ AK.PublicKey + , PrivKey 'Encrypt s ~ AK.SecretKey + , Serialise (PubKey 'Encrypt s) + , Serialise GroupSecretAsymm + , Serialise SK.Nonce + , FromStringMaybe (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)) + where + prettyEntry (pk, _) = "member" <+> dquotes (pretty (AsBase58 pk)) + + +instance ForGroupKeySymm s => Pretty (AsGroupKeyFile (GroupKey 'Symm s)) where + pretty (AsGroupKeyFile pc) = "# hbs2 symmetric group key file" + <> line <> co + where + co = vcat $ fmap pretty + $ chunksOf 60 + $ show + $ pretty (AsBase58 (serialise pc)) + + +parseGroupKey :: forall s . (ForGroupKeySymm s, Serialise (GroupKey 'Symm s)) + => AsGroupKeyFile ByteString + -> Maybe (GroupKey 'Symm s) + +parseGroupKey (AsGroupKeyFile bs) = parseSerialisableFromBase58 (LBS8.toStrict bs) + +instance ( Serialise (GroupKey 'Asymm s) + ) + + => Pretty (AsBase58 (GroupKey 'Asymm s)) where + pretty (AsBase58 c) = + pretty . B8.unpack . toBase58 . LBS.toStrict . serialise $ c + +generateGroupKey :: forall s m . (ForGroupKeySymm s, MonadIO m) + => [PubKey 'Encrypt s] + -> m (GroupKey 'Symm s) + +generateGroupKey pks' = GroupKeySymm <$> create + where + pks = List.sort (List.nub pks') + + create = do + sk <- liftIO SK.newKey + forM pks $ \pk -> do + box <- liftIO $ AK.boxSeal pk (LBS.toStrict $ serialise sk) <&> EncryptedBox + pure (pk, box) + +lookupGroupKey :: ForGroupKeySymm s + => PrivKey 'Encrypt s + -> PubKey 'Encrypt s + -> GroupKey 'Symm s + -> Maybe GroupSecretAsymm + +lookupGroupKey sk pk gk = runIdentity $ runMaybeT do + (EncryptedBox bs) <- MaybeT $ pure $ List.lookup pk (recipients gk) + -- error "FOUND SHIT!" + gkBs <- MaybeT $ pure $ AK.boxSealOpen pk sk bs + -- error $ "DECRYPTED SHIT!" + MaybeT $ pure $ deserialiseOrFail (LBS.fromStrict gkBs) & either (const Nothing) Just + +-- FIXME: move-to-appropriate-place +class NonceFrom a nonce where + nonceFrom :: nonce -> a -> nonce + +typicalNonceLength :: Integral a => a +typicalNonceLength = unsafePerformIO SK.newNonce & Saltine.encode & B8.length & fromIntegral + +typicalKeyLength :: Integral a => a +typicalKeyLength = unsafePerformIO SK.newKey & Saltine.encode & B8.length & fromIntegral + +instance NonceFrom Word64 SK.Nonce where + -- FIXME: maybe-slow-nonceFrom + nonceFrom n0 w = fromJust $ Saltine.decode nss + where + ws = noncePrefix <> N.bytestring64 w + ns = Saltine.encode n0 + nss = BS.packZipWith xor ns ws + + noncePrefix = BS.replicate (typicalNonceLength - 8) 0 + +-- Раз уж такое, то будем писать метаинформацию +-- В блок #0, +-- А HashRef#1 - будет ссылка на групповой ключ +-- Таким образом, мы обеспечим прозрачное скачивание +-- блоков, не будем экспонировать лишнюю метаинформацию, +-- но вместе с тем раздуваем количество раундтрипов, +-- это вообще касается такого способа сохранения +-- Merkle Tree. +-- Но накладные расходны не так велики, упрощается +-- сборка мусора, упрощается код. Нам не надо делать +-- специальную обработку на каждый тип данных, +-- достаточно иметь [HashRef]. + +instance ( MonadIO m + , MonadError OperationError m + , Storage sto h ByteString m + , Storage sto h ByteString IO + , h ~ HbSync + , ForGroupKeySymm s + ) => MerkleWriter (ToEncrypt 'Symm s ByteString) h sto m where + + type instance ToBlockW (ToEncrypt 'Symm s ByteString) = ByteString + + writeAsMerkle sto source = do + + let gk = toEncryptGroupKey source + + let key = toEncryptSecret source + + gkh <- writeAsMerkle sto (serialise gk) <&> HashRef + + let prk = HKDF.extractSkip @_ @HbSyncHash (Saltine.encode key) + + hashes' <- liftIO $ toEncryptData source + + & S.mapM ( \bs -> do + let (BA.SipHash w64) = BA.sipHash (BA.SipKey 11940070621075034887 442907749530188102) (LBS.toStrict bs) + let hbs = N.bytestring64 w64 + let key0 = HKDF.expand prk hbs typicalKeyLength & Saltine.decode & fromJust + let nonceS = BS.take typicalNonceLength (hbs <> BS.replicate typicalNonceLength 0) + let nonce = Saltine.decode nonceS & fromJust + let encrypted = SK.secretbox key0 nonce (LBS.toStrict bs) + pure $ serialise (hbs, encrypted) + ) + + & S.mapM (enqueueBlock sto) + & S.map (fmap HashRef) + & S.toList_ + + let hashes = catMaybes hashes' + +-- -- FIXME: handle-hardcode + let pt = toPTree (MaxSize 256) (MaxNum 256) hashes -- FIXME: settings + + -- FIXME: this-might-not-be-true + result <- runWriterT $ makeMerkle 0 pt $ \(_,mt,bss) -> do + void $ lift $ putBlock sto bss + tell [mt] + + let root = headMay (snd result) + + tree <- maybe (throwError StorageError) pure root + + let ann = MTreeAnn NoMetaData (EncryptGroupNaClSymm (fromHashRef gkh)) tree + + putBlock sto (serialise ann) >>= maybe (throwError StorageError) pure + + +instance ( MonadIO m + , MonadError OperationError m + , h ~ HbSync + , Storage s h ByteString m + -- TODO: why? + , sch ~ HBS2Basic + ) => MerkleReader (ToDecrypt 'Symm sch ByteString) s h m where + + data instance TreeKey (ToDecrypt 'Symm sch ByteString) = ToDecryptBS [KeyringEntry sch] (Hash HbSync) + + type instance ToBlockR (ToDecrypt 'Symm sch ByteString) = ByteString + type instance ReadResult (ToDecrypt 'Symm sch ByteString) = ByteString + + readFromMerkle sto (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}) -> Just (_mtaTree ann, g) + _ -> Nothing + + (tree, gkh) <- maybe1 tree' (throwError UnsupportedFormat) pure + + gkbs <- readFromMerkle sto (SimpleKey gkh) + + gk <- either (const $ throwError GroupKeyNotFound) pure (deserialiseOrFail @(GroupKey 'Symm sch) gkbs) + + let gksec' = [ lookupGroupKey sk pk gk | (pk,sk) <- keys ] & catMaybes & headMay + + gksec <- maybe1 gksec' (throwError GroupKeyNotFound) pure + + let prk = HKDF.extractSkip @_ @HbSyncHash (Saltine.encode gksec) + + hashes <- S.toList_ $ + walkMerkleTree tree (lift . getBlock sto) $ \case + Left{} -> throwError MissedBlockError + Right hrr -> S.each hrr + + ss <- forM hashes $ \h -> do + blk <- getBlock sto (fromHashRef h) >>= maybe (throwError MissedBlockError) pure + + (hbs, bss) <- either (const $ throwError UnsupportedFormat) + pure + (deserialiseOrFail @(BS.ByteString, BS.ByteString) blk) + + + let nonceS = BS.take typicalNonceLength (hbs <> BS.replicate typicalNonceLength 0) + let key0 = HKDF.expand prk hbs typicalKeyLength & Saltine.decode & fromJust + let nonce = Saltine.decode nonceS & fromJust + let unboxed = SK.secretboxOpen key0 nonce bss + + maybe1 unboxed (throwError DecryptionError) (pure . LBS.fromStrict) + + pure $ mconcat ss + + + diff --git a/hbs2-core/lib/HBS2/Net/Proto/Definition.hs b/hbs2-core/lib/HBS2/Net/Proto/Definition.hs index c0db1b9a..35b9b6c3 100644 --- a/hbs2-core/lib/HBS2/Net/Proto/Definition.hs +++ b/hbs2-core/lib/HBS2/Net/Proto/Definition.hs @@ -24,7 +24,7 @@ import HBS2.Net.Proto.PeerMeta import HBS2.Net.Proto.RefLog import HBS2.Net.Proto.RefChan import HBS2.Net.Messaging.Unix (UNIX) -import HBS2.Prelude +import HBS2.Prelude.Plated import Control.Monad import Data.Functor @@ -48,6 +48,7 @@ type instance PrivKey 'Sign HBS2Basic = Sign.SecretKey type instance PubKey 'Encrypt HBS2Basic = Encrypt.PublicKey type instance PrivKey 'Encrypt HBS2Basic = Encrypt.SecretKey + -- FIXME: proper-serialise-for-keys -- Возможно, нужно написать ручные инстансы Serialise -- использовать encode/decode для каждого инстанса ниже $(c:end + 4) diff --git a/hbs2-core/lib/HBS2/Net/Proto/Types.hs b/hbs2-core/lib/HBS2/Net/Proto/Types.hs index 7f95a11b..75c1ce2b 100644 --- a/hbs2-core/lib/HBS2/Net/Proto/Types.hs +++ b/hbs2-core/lib/HBS2/Net/Proto/Types.hs @@ -24,17 +24,30 @@ import System.Random qualified as Random import Codec.Serialise import Data.Maybe import Control.Monad.Trans.Maybe +import Data.ByteString (ByteString) -- e -> Transport (like, UDP or TChan) -- p -> L4 Protocol (like Ping/Pong) data CryptoAction = Sign | Encrypt -type family PubKey ( a :: CryptoAction) e :: Type -type family PrivKey ( a :: CryptoAction) e :: Type +data GroupKeyScheme = Symm | Asymm + deriving stock (Eq,Ord,Show,Data,Generic) + +type family PubKey (a :: CryptoAction) e :: Type +type family PrivKey (a :: CryptoAction) e :: Type type family Encryption e :: Type +data family GroupKey (scheme :: GroupKeyScheme) s + +-- TODO: move-to-an-appropriate-place +newtype AsGroupKeyFile a = AsGroupKeyFile a + +data family ToEncrypt (scheme :: GroupKeyScheme) s a -- = ToEncrypt a + +data family ToDecrypt (scheme :: GroupKeyScheme) s a + -- FIXME: move-to-a-crypto-definition-modules data HBS2Basic diff --git a/hbs2-core/lib/HBS2/Storage/Operations.hs b/hbs2-core/lib/HBS2/Storage/Operations.hs deleted file mode 100644 index 2d746cd1..00000000 --- a/hbs2-core/lib/HBS2/Storage/Operations.hs +++ /dev/null @@ -1,38 +0,0 @@ -{-# Language AllowAmbiguousTypes #-} -{-# Language UndecidableInstances #-} -module HBS2.Storage.Operations where - -import HBS2.Prelude.Plated -import HBS2.Hash -import HBS2.Storage -import HBS2.Merkle -import HBS2.Data.Types.Refs -import HBS2.Defaults - -import Streaming.Prelude qualified as S -import Streaming qualified as S -import Data.Functor -import Data.Function - -import Data.Bifunctor -import Data.ByteString.Lazy (ByteString) -import Data.ByteString.Lazy qualified as B - - -class (MonadIO m, Storage storage hash block m) => MerkleWriter block hash storage m where - writeAsMerkle :: storage -> block -> m (Hash hash) - -instance (MonadIO m, h ~ HbSync, Storage s h ByteString m) => MerkleWriter ByteString h s m where - writeAsMerkle sto bs = do - - hashes <- S.each (B.unpack bs) - & S.chunksOf (fromIntegral defBlockSize) - & S.mapped (fmap (first B.pack) . S.toList) - & S.mapM (\blk -> enqueueBlock sto blk >> pure blk) - & S.map (HashRef . hashObject) - & S.toList_ - - -- FIXME: handle-hardcode - let pt = toPTree (MaxSize 256) (MaxNum 256) hashes -- FIXME: settings - makeMerkle 0 pt $ \(_,_,bss) -> void $ putBlock sto bss - diff --git a/hbs2-core/lib/HBS2/Storage/Operations/ByteString.hs b/hbs2-core/lib/HBS2/Storage/Operations/ByteString.hs new file mode 100644 index 00000000..a00319e0 --- /dev/null +++ b/hbs2-core/lib/HBS2/Storage/Operations/ByteString.hs @@ -0,0 +1,68 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# Language AllowAmbiguousTypes #-} +{-# Language UndecidableInstances #-} +module HBS2.Storage.Operations.ByteString + ( module HBS2.Storage.Operations.Class + , module HBS2.Storage.Operations.ByteString + ) where + +import HBS2.Prelude.Plated +import HBS2.Hash +import HBS2.Storage +import HBS2.Merkle +import HBS2.Data.Types.Refs +import HBS2.Defaults + +import HBS2.Storage.Operations.Class + +import Streaming.Prelude qualified as S +import Streaming qualified as S +import Data.Function + +import Control.Monad.Except +import Data.Bifunctor +import Data.ByteString.Lazy (ByteString) +import Data.ByteString.Lazy qualified as LBS + + +instance (MonadIO m, h ~ HbSync, Storage s h ByteString m) => MerkleWriter ByteString h s m where + type instance ToBlockW ByteString = ByteString + writeAsMerkle sto bs = do + + hashes <- S.each (LBS.unpack bs) + & S.chunksOf (fromIntegral defBlockSize) + & S.mapped (fmap (first LBS.pack) . S.toList) + & S.mapM (\blk -> enqueueBlock sto blk >> pure blk) + & S.map (HashRef . hashObject) + & S.toList_ + + -- FIXME: handle-hardcode + let pt = toPTree (MaxSize 256) (MaxNum 256) hashes -- FIXME: settings + makeMerkle 0 pt $ \(_,_,bss) -> void $ putBlock sto bss + + +instance ( MonadIO m + , MonadError OperationError m + , Storage s HbSync ByteString m + ) => MerkleReader ByteString s HbSync m where + + newtype instance TreeKey ByteString = SimpleKey (Hash HbSync) + type instance ToBlockR ByteString = ByteString + type instance ReadResult ByteString = ByteString + + readFromMerkle sto (SimpleKey h) = do + + pieces <- S.toList_ $ do + walkMerkle h (lift . getBlock sto) $ \case + Left{} -> throwError MissedBlockError + + Right (hrr :: [HashRef]) -> do + + forM_ hrr $ \hx -> do + blk <- lift (getBlock sto (fromHashRef hx)) + >>= maybe (throwError MissedBlockError) pure + S.yield blk + + pure $ mconcat pieces + + diff --git a/hbs2-core/lib/HBS2/Storage/Operations/Class.hs b/hbs2-core/lib/HBS2/Storage/Operations/Class.hs new file mode 100644 index 00000000..b7a47ca2 --- /dev/null +++ b/hbs2-core/lib/HBS2/Storage/Operations/Class.hs @@ -0,0 +1,31 @@ +{-# Language AllowAmbiguousTypes #-} +module HBS2.Storage.Operations.Class where + +import HBS2.Prelude.Plated +import HBS2.Hash +import HBS2.Storage + +import Data.Kind + +data OperationError = + StorageError + | CryptoError + | DecryptionError + | MissedBlockError + | UnsupportedFormat + | GroupKeyNotFound + deriving (Generic,Show,Data,Typeable) + +-- instance Exception OperationError + +class (MonadIO m, Storage storage hash (ToBlockW s) m) => MerkleWriter s hash storage m where + type family ToBlockW s :: Type + writeAsMerkle :: storage -> s -> m (Hash hash) + + +class (MonadIO m, Storage storage h (ToBlockR s) m) => MerkleReader s storage h m where + data family TreeKey s :: Type + type family ToBlockR s :: Type + type family ReadResult s :: Type + readFromMerkle :: storage -> TreeKey s -> m (ReadResult s) + diff --git a/hbs2-peer/app/BlockDownload.hs b/hbs2-peer/app/BlockDownload.hs index 7eaedf38..442188ae 100644 --- a/hbs2-peer/app/BlockDownload.hs +++ b/hbs2-peer/app/BlockDownload.hs @@ -156,9 +156,10 @@ processBlock h = do ShortMetadata {} -> pure () AnnHashRef hx -> addDownload parent hx - case (_mtaCrypt ann) of + case _mtaCrypt ann of NullEncryption -> pure () CryptAccessKeyNaClAsymm h -> addDownload parent h + EncryptGroupNaClSymm h -> addDownload parent h debug $ "GOT WRAPPED MERKLE. requesting nodes/leaves" <+> pretty h walkMerkleTree (_mtaTree ann) (liftIO . getBlock sto) handleHrr diff --git a/hbs2-storage-simple/lib/HBS2/Storage/Simple/Extra.hs b/hbs2-storage-simple/lib/HBS2/Storage/Simple/Extra.hs index bbeee924..36e5aa9a 100644 --- a/hbs2-storage-simple/lib/HBS2/Storage/Simple/Extra.hs +++ b/hbs2-storage-simple/lib/HBS2/Storage/Simple/Extra.hs @@ -32,9 +32,11 @@ import System.IO pieces :: Integral a => a pieces = 1024 +-- FIXME: to-remove-in-a-sake-of-operations-class class SimpleStorageExtra a where putAsMerkle :: forall h . (IsSimpleStorageKey h, Hashed h ByteString) => SimpleStorage h -> a -> IO MerkleHash +-- TODO: move-to-hbs2-storage-operations readChunked :: MonadIO m => Handle -> Int -> S.Stream (S.Of ByteString) m () readChunked handle size = fuu where @@ -45,6 +47,24 @@ readChunked handle size = fuu S.yield chunk next +-- TODO: sparse-merkle-tree-representation +-- Блоки пишутся таким образом потому, +-- что хотелось, что бы листы являлись частями +-- исходной информации без всяких метаданных, +-- то есть каждый блок в отдельности является +-- только частью исходных данных, а их конкатенация +-- является этими самыми данными. Это менее оптимальное +-- представление для передачи, но в этом есть смысл. +-- +-- то есть у нас есть Merkle Tree которое как бы +-- является торрентом неограниченного размера, +-- скачиваемого по частям, в котором множество +-- указателей на реальные файлы. Имеет смысл. +-- +-- Мы в принципе можем измененить способ записи, +-- интересно, что при этом особо ничего не поменяется --- +-- то есть система будет продолжать работать. + instance SimpleStorageExtra Handle where putAsMerkle ss handle = do diff --git a/hbs2-storage-simple/test/Main.hs b/hbs2-storage-simple/test/Main.hs index c820789a..c9f12f04 100644 --- a/hbs2-storage-simple/test/Main.hs +++ b/hbs2-storage-simple/test/Main.hs @@ -5,8 +5,6 @@ import Test.Tasty.HUnit import TestSimpleStorage -import HBS2.Storage - main :: IO () main = defaultMain $ @@ -16,6 +14,7 @@ main = , testCase "testSimpleStorageNoKeys" testSimpleStorageNoKeys , testCase "testSimpleStorageRefs" testSimpleStorageRefs , testCase "testSimpleStorageBundles" testSimpleStorageBundles + , testCase "testSimpleStorageSymmEncryption" testSimpleStorageSymmEncryption ] diff --git a/hbs2-storage-simple/test/TestSimpleStorage.hs b/hbs2-storage-simple/test/TestSimpleStorage.hs index f4c97dcc..1eee77aa 100644 --- a/hbs2-storage-simple/test/TestSimpleStorage.hs +++ b/hbs2-storage-simple/test/TestSimpleStorage.hs @@ -255,3 +255,18 @@ testSimpleStorageBundles = do assertBool "all-blocks-here-again" (not (null (catMaybes hereWeGoAgain))) +testSimpleStorageSymmEncryption :: IO () +testSimpleStorageSymmEncryption = do + withSystemTempDirectory "simpleStorageTest" $ \dir -> do + + let opts = [ StoragePrefix (dir ".storage") + ] + + storage <- simpleStorageInit opts :: IO (SimpleStorage HbSync) + + worker <- async (simpleStorageWorker storage) + + link worker + + assertBool "nothing" True + diff --git a/hbs2/Main.hs b/hbs2/Main.hs index 853df799..9c0e5627 100644 --- a/hbs2/Main.hs +++ b/hbs2/Main.hs @@ -3,15 +3,20 @@ module Main where import HBS2.Base58 import HBS2.Data.Detect import HBS2.Data.Types +import HBS2.Data.Types.EncryptedBox import HBS2.Defaults import HBS2.Merkle import HBS2.Net.Proto.Types -import HBS2.Net.Auth.AccessKey +import HBS2.Net.Auth.GroupKeyAsymm as Asymm +import HBS2.Net.Auth.GroupKeySymm qualified as Symm +import HBS2.Net.Auth.GroupKeySymm +-- (ToEncrypt(..)) import HBS2.Net.Auth.Credentials import HBS2.Net.Proto.Definition() import HBS2.Net.Proto.RefLog(RefLogKey(..)) import HBS2.Net.Proto.AnyRef(AnyRefKey(..)) import HBS2.Prelude.Plated +import HBS2.Storage.Operations.Class import HBS2.Storage.Simple import HBS2.Storage.Simple.Extra import HBS2.Data.Bundle @@ -20,9 +25,13 @@ import HBS2.OrDie import HBS2.System.Logger.Simple hiding (info) +import Data.Config.Suckless +import Data.Config.Suckless.KeyValue + import Control.Concurrent.Async import Control.Concurrent.STM import Control.Monad +import Control.Monad.Except import Control.Monad.Trans.Maybe import Crypto.Saltine.Core.Box qualified as Encrypt import Data.ByteString.Lazy qualified as LBS @@ -36,7 +45,9 @@ import Data.Map.Strict qualified as Map import Data.Monoid qualified as Monoid import Options.Applicative import System.Directory +import Data.Either import Data.Maybe +import Data.Text qualified as Text import Lens.Micro.Platform -- import System.FilePath.Posix import System.IO @@ -49,19 +60,19 @@ import Streaming.Prelude qualified as S tracePrefix :: SetLoggerEntry -tracePrefix = logPrefix "[trace] " +tracePrefix = logPrefix "[trace] " . toStderr debugPrefix :: SetLoggerEntry -debugPrefix = logPrefix "[debug] " +debugPrefix = logPrefix "[debug] " . toStderr errorPrefix :: SetLoggerEntry -errorPrefix = logPrefix "[error] " +errorPrefix = logPrefix "[error] " . toStderr warnPrefix :: SetLoggerEntry -warnPrefix = logPrefix "[warn] " +warnPrefix = logPrefix "[warn] " . toStderr noticePrefix :: SetLoggerEntry -noticePrefix = logPrefix "[notice] " +noticePrefix = logPrefix "[notice] " . toStderr newtype CommonOpts = @@ -87,16 +98,22 @@ newtype OptGroupkeyFile = OptGroupkeyFile { unOptGroupkeyFile :: FilePath } deriving newtype (Eq,Ord,IsString) deriving stock (Data) +newtype OptEncPubKey = OptEncPubKey { unOptEncPk :: PubKey 'Encrypt HBS2Basic } + deriving newtype (Eq,Ord) + deriving stock (Data) + newtype OptInit = OptInit { fromOptInit :: Bool } deriving newtype (Eq,Ord,Pretty) deriving stock (Data,Generic) data StoreOpts = StoreOpts - { storeInit :: Maybe OptInit - , storeInputFile :: Maybe OptInputFile + { storeInit :: Maybe OptInit + , storeInputFile :: Maybe OptInputFile , storeGroupkeyFile :: Maybe OptGroupkeyFile - , storeBase58Meta :: Maybe String + , storeBase58Meta :: Maybe String + , storeEncPubKey :: Maybe OptEncPubKey + , storeKeyringFile :: Maybe OptKeyringFile } deriving stock (Data) @@ -122,6 +139,9 @@ newtype NewRefOpts = deriving stock (Data) +data EncSchema = EncSymm (GroupKey 'Symm HBS2Basic) + | EncAsymm (GroupKey 'Asymm HBS2Basic) + runHash :: HashOpts -> SimpleStorage HbSync -> IO () runHash opts _ = do withBinaryFile (hashFp opts) ReadMode $ \h -> do @@ -173,6 +193,10 @@ runCat opts ss = do walkAnn ann = do bprocess :: Hash HbSync -> ByteString -> IO ByteString <- case (_mtaCrypt ann) of NullEncryption -> pure (const pure) + + EncryptGroupNaClSymm{} -> do + die "EncryptGroupNaClSymm is not supported yet" + CryptAccessKeyNaClAsymm crypth -> do keyringFile <- pure (uniLastMay @OptKeyringFile opts <&> unOptKeyringFile) @@ -183,7 +207,7 @@ runCat opts ss = do `orDie` "bad keyring file" blkc <- getBlock ss crypth `orDie` (show $ "missed block: " <+> pretty crypth) - recipientKeys :: [(PubKey 'Encrypt s, EncryptedBox)] + recipientKeys :: [(PubKey 'Encrypt s, EncryptedBox (KeyringEntry s))] <- pure (deserialiseMay blkc) `orDie` "can not deserialise access key" @@ -215,8 +239,26 @@ runCat opts ss = do case q of Blob h -> getBlock ss h >>= maybe (die "blob not found") LBS.putStr + Merkle t -> walkMerkleTree t (getBlock ss) stepInside + MerkleAnn ann | honly -> do + walkMerkleTree (_mtaTree ann) (getBlock ss) $ \case + Left hx -> err $ "missed block" <+> pretty hx + Right hr -> print $ vcat (fmap pretty hr) + + MerkleAnn ann@(MTreeAnn {_mtaCrypt = EncryptGroupNaClSymm{}}) -> do + + krf <- pure (uniLastMay @OptKeyringFile opts) `orDie` "keyring file not set" + s <- BS.readFile (unOptKeyringFile krf) + cred <- pure (parseCredentials @HBS2Basic (AsCredFile s)) `orDie` "bad keyring file" + let keyring = view peerKeyring cred + + elbs <- runExceptT $ readFromMerkle ss (ToDecryptBS keyring mhash) + case elbs of + Right lbs -> LBS.putStr lbs + Left e -> die (show e) + MerkleAnn ann -> walkAnn ann -- FIXME: what-if-multiple-seq-ref-? @@ -265,32 +307,64 @@ runStore opts ss = do print $ "merkle-root: " <+> pretty root Just gkfile -> do - gk :: GroupKey HBS2Basic - <- (parseGroupKey . AsGroupKeyFile <$> BS.readFile (unOptGroupkeyFile gkfile)) - `orDie` "bad groupkey file" - accKeyh <- (putBlock ss . serialise . permitted . accessKey) gk - `orDie` "can not store access key" + gkSymm <- Symm.parseGroupKey @HBS2Basic . AsGroupKeyFile <$> LBS.readFile (unOptGroupkeyFile gkfile) + gkAsymm <- Asymm.parseGroupKey . AsGroupKeyFile <$> BS.readFile (unOptGroupkeyFile gkfile) - let rawChunks :: S.Stream (S.Of ByteString) IO () - rawChunks = readChunked handle (fromIntegral defBlockSize) -- FIXME: to settings! + let mbGk = EncSymm <$> gkSymm <|> EncAsymm <$> gkAsymm - encryptedChunks :: S.Stream (S.Of ByteString) IO () - encryptedChunks = rawChunks - & S.mapM (fmap LBS.fromStrict . Encrypt.boxSeal (recipientPk gk) . LBS.toStrict) + case mbGk of + Nothing -> die "unknown or invalid group key" - mhash <- putAsMerkle ss encryptedChunks - mtree <- ((either (const Nothing) Just . deserialiseOrFail =<<) <$> getBlock ss (fromMerkleHash mhash)) - `orDie` "merkle tree was not stored properly with `putAsMerkle`" + Just (EncSymm gk) -> do + pk <- unOptEncPk <$> pure (uniLastMay @OptEncPubKey opts) `orDie` "public key not specified" + krf <- pure (uniLastMay @OptKeyringFile opts) `orDie` "keyring file not set" - mannh <- maybe (die "can not store MerkleAnn") pure - =<< (putBlock ss . serialise @(MTreeAnn [HashRef])) do - MTreeAnn NoMetaData (CryptAccessKeyNaClAsymm accKeyh) mtree + s <- BS.readFile (unOptKeyringFile krf) + cred <- pure (parseCredentials @HBS2Basic (AsCredFile s)) `orDie` "bad keyring file" - print $ "merkle-ann-root: " <+> pretty mannh + sk <- pure (headMay [ (view krPk k, view krSk k) + | k <- view peerKeyring cred + , view krPk k == pk + ]) `orDie` "secret key not found" -runNewGroupkey :: forall s . (s ~ HBS2Basic) => FilePath -> IO () -runNewGroupkey pubkeysFile = do + gks <- pure (Symm.lookupGroupKey (snd sk) pk gk) `orDie` ("can't find secret key for " <> show (pretty (AsBase58 (fst sk)))) + + let segments :: S.Stream (S.Of ByteString) IO () + segments = readChunked handle (fromIntegral defBlockSize) + + let source = ToEncryptSymmBS gks segments gk + + r <- runExceptT $ writeAsMerkle ss source + + case r of + Left e -> die (show e) + Right h -> print (pretty h) + + Just (EncAsymm gk) -> do + + accKeyh <- (putBlock ss . serialise . permitted . accessKey) gk + `orDie` "can not store access key" + + let rawChunks :: S.Stream (S.Of ByteString) IO () + rawChunks = readChunked handle (fromIntegral defBlockSize) -- FIXME: to settings! + + encryptedChunks :: S.Stream (S.Of ByteString) IO () + encryptedChunks = rawChunks + & S.mapM (fmap LBS.fromStrict . Encrypt.boxSeal (recipientPk gk) . LBS.toStrict) + + mhash <- putAsMerkle ss encryptedChunks + mtree <- ((either (const Nothing) Just . deserialiseOrFail =<<) <$> getBlock ss (fromMerkleHash mhash)) + `orDie` "merkle tree was not stored properly with `putAsMerkle`" + + mannh <- maybe (die "can not store MerkleAnn") pure + =<< (putBlock ss . serialise @(MTreeAnn [HashRef])) do + MTreeAnn NoMetaData (CryptAccessKeyNaClAsymm accKeyh) mtree + + print $ "merkle-ann-root: " <+> pretty mannh + +runNewGroupKeyAsymm :: forall s . (s ~ HBS2Basic) => FilePath -> IO () +runNewGroupKeyAsymm pubkeysFile = do s <- BS.readFile pubkeysFile pubkeys <- pure (parsePubKeys @s s) `orDie` "bad pubkeys file" keypair <- newKeypair @s Nothing @@ -414,14 +488,14 @@ main = join . customExecParser (prefs showHelpOnError) $ <> command "cat" (info pCat (progDesc "cat block")) <> command "hash" (info pHash (progDesc "calculates hash")) <> command "fsck" (info pFsck (progDesc "check storage constistency")) - <> command "deps" ( info pDeps (progDesc "print dependencies")) - <> command "del" ( info pDel (progDesc "del block")) + <> command "deps" (info pDeps (progDesc "print dependencies")) + <> command "del" (info pDel (progDesc "del block")) <> command "keyring-new" (info pNewKey (progDesc "generates a new keyring")) <> command "keyring-list" (info pKeyList (progDesc "list public keys from keyring")) <> command "keyring-key-add" (info pKeyAdd (progDesc "adds a new keypair into the keyring")) <> command "keyring-key-del" (info pKeyDel (progDesc "removes a keypair from the keyring")) <> command "show-peer-key" (info pShowPeerKey (progDesc "show peer key from credential file")) - <> command "groupkey-new" (info pNewGroupkey (progDesc "generates a new groupkey")) + <> command "groupkey" (info pGroupKey (progDesc "group key commands")) <> command "reflog" (info pReflog (progDesc "reflog commands")) <> command "bundle" (info pBundle (progDesc "bundle commands")) <> command "anyref" (info pAnyRef (progDesc "anyref commands")) @@ -435,9 +509,16 @@ main = join . customExecParser (prefs showHelpOnError) $ o <- common file <- optional $ strArgument ( metavar "FILE" ) init' <- optional $ flag' True ( long "init" <> help "just init storage") <&> OptInit - groupkeyFile <- optional $ strOption ( long "groupkey" <> help "path to groupkey file" ) + groupkeyFile <- optional $ strOption ( long "groupkey" <> short 'g' <> help "path to groupkey file" ) b58meta <- optional $ strOption ( long "short-meta-base58" <> help "pass escaped metadata string") - pure $ withStore o (runStore ( StoreOpts init' file (OptGroupkeyFile <$> groupkeyFile) b58meta)) + pk <- optional $ option epk ( long "public-key" <> short 'P' <> help "public key of group key") + kr <- optional $ strOption ( long "keyring" <> short 'k' <> help "keyring file") <&> OptKeyringFile + pure $ withStore o (runStore ( StoreOpts init' file (OptGroupkeyFile <$> groupkeyFile) b58meta pk kr)) + + epk :: ReadM OptEncPubKey + epk = eitherReader $ \arg -> do + let mpk = fromStringMay @(PubKey 'Encrypt HBS2Basic) arg + maybe1 mpk (Left "invalid public key") (pure . OptEncPubKey) pCat = do o <- common @@ -448,9 +529,42 @@ main = join . customExecParser (prefs showHelpOnError) $ pure $ withStore o $ runCat $ CatOpts hash (CatHashesOnly <$> onlyh) (OptKeyringFile <$> keyringFile) raw - pNewGroupkey = do + pGroupKey = hsubparser ( command "asymm" (info pGroupKeyAsymm (progDesc "asymmetric group keys") ) + <> command "symm" (info pGroupKeySymm (progDesc "symmetric group keys") ) + ) + + + pGroupKeyAsymm = hsubparser ( command "gen" (info pGroupKeyAsymmNew (progDesc "generate") ) + ) + + pGroupKeyAsymmNew = do pubkeysFile <- strArgument ( metavar "FILE" <> help "path to a file with a list of recipient public keys" ) - pure $ runNewGroupkey pubkeysFile + pure $ runNewGroupKeyAsymm pubkeysFile + + + pGroupKeySymm = hsubparser ( command "gen" (info pGroupKeySymmGen (progDesc "generate") ) + <> command "dump" (info pGroupKeySymmDump (progDesc "dump") ) + ) + + pGroupKeySymmGen = do + fn <- optional $ strArgument ( metavar "FILE" <> help "group key definition file" ) + pure $ do + syn <- maybe1 fn getContents readFile <&> parseTop <&> fromRight mempty + + let members = [ fromStringMay @(PubKey 'Encrypt HBS2Basic) (Text.unpack s) + | (ListVal (Key "member" [LitStrVal s]) ) <- syn + ] & catMaybes + + gk <- Symm.generateGroupKey @HBS2Basic members + print $ pretty (AsGroupKeyFile gk) + + pGroupKeySymmDump = do + fn <- optional $ strArgument ( metavar "FILE" <> help "group key file" ) + pure $ do + gk <- ( maybe1 fn LBS.getContents LBS.readFile + <&> Symm.parseGroupKey @HBS2Basic . AsGroupKeyFile ) `orDie` "Invalid group key file" + + print $ pretty gk pHash = do o <- common diff --git a/hbs2/hbs2.cabal b/hbs2/hbs2.cabal index ec761066..3ec649ec 100644 --- a/hbs2/hbs2.cabal +++ b/hbs2/hbs2.cabal @@ -79,12 +79,14 @@ executable hbs2 , interpolatedstring-perl6 , memory , microlens-platform + , mtl , optparse-applicative , prettyprinter , safe , saltine , serialise , streaming + , suckless-conf , text , transformers , uniplate