mirror of https://github.com/voidlizard/hbs2
symmetric, deterministic merkle-tree encryption
suckless-conf bumped
This commit is contained in:
Dmitry Zuikov
parent
0f0085d4b6
commit
7572b3ffe9
|
|
@ -1,3 +1,5 @@
|
|||
## 2023-09-25
|
||||
|
||||
## 2023-14-08
|
||||
|
||||
PR: hbs2-git-config-location
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
}
|
||||
|
|
|
|||
|
|
@ -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 = {
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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()
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
||||
|
|
@ -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)
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
||||
|
|
@ -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
|
||||
|
||||
|
||||
|
||||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
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
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
@ -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
|
||||
|
||||
|
||||
|
|
@ -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)
|
||||
|
||||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
]
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
148
hbs2/Main.hs
148
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,6 +98,10 @@ 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)
|
||||
|
|
@ -97,6 +112,8 @@ data StoreOpts =
|
|||
, storeInputFile :: Maybe OptInputFile
|
||||
, storeGroupkeyFile :: Maybe OptGroupkeyFile
|
||||
, 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,9 +307,41 @@ 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"
|
||||
|
||||
gkSymm <- Symm.parseGroupKey @HBS2Basic . AsGroupKeyFile <$> LBS.readFile (unOptGroupkeyFile gkfile)
|
||||
gkAsymm <- Asymm.parseGroupKey . AsGroupKeyFile <$> BS.readFile (unOptGroupkeyFile gkfile)
|
||||
|
||||
let mbGk = EncSymm <$> gkSymm <|> EncAsymm <$> gkAsymm
|
||||
|
||||
case mbGk of
|
||||
Nothing -> die "unknown or invalid group key"
|
||||
|
||||
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"
|
||||
|
||||
s <- BS.readFile (unOptKeyringFile krf)
|
||||
cred <- pure (parseCredentials @HBS2Basic (AsCredFile s)) `orDie` "bad keyring file"
|
||||
|
||||
sk <- pure (headMay [ (view krPk k, view krSk k)
|
||||
| k <- view peerKeyring cred
|
||||
, view krPk k == pk
|
||||
]) `orDie` "secret key not found"
|
||||
|
||||
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"
|
||||
|
|
@ -289,8 +363,8 @@ runStore opts ss = do
|
|||
|
||||
print $ "merkle-ann-root: " <+> pretty mannh
|
||||
|
||||
runNewGroupkey :: forall s . (s ~ HBS2Basic) => FilePath -> IO ()
|
||||
runNewGroupkey pubkeysFile = do
|
||||
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
|
||||
|
|
@ -421,7 +495,7 @@ main = join . customExecParser (prefs showHelpOnError) $
|
|||
<> 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
|
||||
|
|
|
|||
|
|
@ -79,12 +79,14 @@ executable hbs2
|
|||
, interpolatedstring-perl6
|
||||
, memory
|
||||
, microlens-platform
|
||||
, mtl
|
||||
, optparse-applicative
|
||||
, prettyprinter
|
||||
, safe
|
||||
, saltine
|
||||
, serialise
|
||||
, streaming
|
||||
, suckless-conf
|
||||
, text
|
||||
, transformers
|
||||
, uniplate
|
||||
|
|
|
|||
Loading…
Reference in New Issue