mirror of https://github.com/voidlizard/hbs2
Draft merkle wrapper for encryption (#1)
* Draft merkle wrapper for encryption * wip encryption * encryption to check * Fixes by comments * Drop keyring, pubkey opts from store command * Fix wrong deserialise call * Edit README.md. Add example of store encrypted file * minor issues found --------- Co-authored-by: Dmitry Zuikov <dzuikov@gmail.com>
This commit is contained in:
Sergey Ivanov
GitHub
parent
d7a41affb7
commit
eb43510f23
13
README.md
13
README.md
|
|
@ -10,3 +10,16 @@ hbs2-peer run -p .peers/1 -k .peers/1/key -l addr:port -r rpcaddr:rpcport
|
|||
|
||||
```
|
||||
|
||||
|
||||
## Как сохранять зашифрованный файл
|
||||
|
||||
```
|
||||
keyring-new > kr
|
||||
keyring-list kr
|
||||
; создаём файл со списком публичных ключей
|
||||
; строчки из выхлопа команды keyring-list
|
||||
groupkey-new path/to/file/with/list/of/pubkeys > groupkey
|
||||
store --groupkey groupkey file/to/store
|
||||
; получаем хэш
|
||||
cat --keyring kr <хэш>
|
||||
```
|
||||
|
|
|
|||
|
|
@ -1,3 +1,26 @@
|
|||
## 2023-02-16
|
||||
|
||||
FIXME: group-key-is-public
|
||||
|
||||
```
|
||||
cat ./group1.key
|
||||
# hbs2 groupkey file
|
||||
# keep it private
|
||||
|
||||
```
|
||||
|
||||
group key is actually public. it contains
|
||||
encrypted records
|
||||
|
||||
|
||||
FIXME: group-key-new-brokes-on-empty-line
|
||||
```
|
||||
cat pub
|
||||
3YpCdSGw7BdTVTpaWUMxF1DbWcTwAsH6ai3wRXfvCYx6
|
||||
|
||||
./bin/hbs2 groupkey-new ./pub
|
||||
bad pubkeys file
|
||||
```
|
||||
|
||||
## 2023-02-15
|
||||
|
||||
|
|
|
|||
|
|
@ -76,6 +76,7 @@ library
|
|||
, HBS2.Events
|
||||
, HBS2.Hash
|
||||
, HBS2.Merkle
|
||||
, HBS2.Net.Auth.AccessKey
|
||||
, HBS2.Net.Auth.Credentials
|
||||
, HBS2.Net.IP.Addr
|
||||
, HBS2.Net.Messaging
|
||||
|
|
|
|||
|
|
@ -9,18 +9,21 @@ import Codec.Serialise (deserialiseOrFail)
|
|||
import Data.ByteString.Lazy (ByteString)
|
||||
import Data.Either
|
||||
import Data.Function
|
||||
import Data.Functor
|
||||
|
||||
data BlobType = Merkle (Hash HbSync)
|
||||
| MerkleAnn (MTreeAnn [HashRef])
|
||||
| AnnRef (Hash HbSync)
|
||||
| Blob (Hash HbSync)
|
||||
deriving (Show,Data)
|
||||
|
||||
|
||||
tryDetect :: Hash HbSync -> ByteString -> BlobType
|
||||
tryDetect hash obj = rights [mbLink, mbMerkle] & headDef orBlob
|
||||
tryDetect hash obj = rights [mbAnn, mbLink, mbMerkle] & headDef orBlob
|
||||
|
||||
where
|
||||
mbLink = deserialiseOrFail @AnnotatedHashRef obj >> pure (AnnRef hash)
|
||||
mbMerkle = deserialiseOrFail @(MTree [HashRef]) obj >> pure (Merkle hash)
|
||||
mbAnn = deserialiseOrFail obj <&> MerkleAnn
|
||||
orBlob = Blob hash
|
||||
|
||||
|
|
|
|||
|
|
@ -7,11 +7,12 @@ import HBS2.Hash
|
|||
|
||||
import Codec.Serialise
|
||||
import Data.ByteString (ByteString)
|
||||
import Data.ByteString.Lazy qualified as LBS
|
||||
import Data.ByteString qualified as BS
|
||||
import Data.ByteString.Lazy qualified as LBS
|
||||
import Data.Data
|
||||
import Data.Foldable (traverse_)
|
||||
import Data.Foldable (forM_, traverse_)
|
||||
import Data.List qualified as List
|
||||
import Data.Text (Text)
|
||||
import GHC.Generics
|
||||
import Lens.Micro.Platform
|
||||
import Prettyprinter
|
||||
|
|
@ -76,6 +77,30 @@ makeLenses ''MNodeData
|
|||
|
||||
instance Serialise MNodeData
|
||||
|
||||
data AnnMetaData = NoMetaData | ShortMetadata Text | AnnHashRef (Hash HbSync)
|
||||
deriving stock (Generic,Data,Show)
|
||||
|
||||
instance Serialise AnnMetaData
|
||||
|
||||
data MTreeAnn a = MTreeAnn
|
||||
{ _mtaMeta :: !AnnMetaData
|
||||
, _mtaCrypt :: !MTreeEncryption
|
||||
, _mtaTree :: !(MTree a)
|
||||
}
|
||||
deriving stock (Generic,Data,Show)
|
||||
|
||||
instance Serialise a => Serialise (MTreeAnn a)
|
||||
|
||||
data MerkleEncryptionType
|
||||
deriving stock (Data)
|
||||
|
||||
data MTreeEncryption
|
||||
= NullEncryption
|
||||
| CryptAccessKeyNaClAsymm (Hash HbSync)
|
||||
deriving stock (Generic,Data,Show)
|
||||
|
||||
instance Serialise MTreeEncryption
|
||||
|
||||
data MTree a = MNode MNodeData [Hash HbSync] | MLeaf a
|
||||
deriving stock (Generic,Data,Show)
|
||||
|
||||
|
|
@ -159,3 +184,13 @@ walkMerkle root flookup sink = walkMerkle' root flookup withTree
|
|||
(Right (MNode _ _)) -> pure ()
|
||||
Left hx -> sink (Left hx)
|
||||
|
||||
|
||||
walkMerkleTree :: (Serialise (MTree a), Monad m)
|
||||
=> MTree a
|
||||
-> ( Hash HbSync -> m (Maybe LBS.ByteString) )
|
||||
-> ( Either (Hash HbSync) a -> m () )
|
||||
-> m ()
|
||||
|
||||
walkMerkleTree tree flookup sink = case tree of
|
||||
(MLeaf s) -> sink (Right s)
|
||||
(MNode _ hashes) -> forM_ hashes \h -> walkMerkle h flookup sink
|
||||
|
|
|
|||
|
|
@ -0,0 +1,125 @@
|
|||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
{-# Language TemplateHaskell #-}
|
||||
{-# Language UndecidableInstances #-}
|
||||
{-# Language AllowAmbiguousTypes #-}
|
||||
{-# Language ConstraintKinds #-}
|
||||
module HBS2.Net.Auth.AccessKey where
|
||||
|
||||
import HBS2.Base58
|
||||
import HBS2.Data.Detect
|
||||
import HBS2.Data.Types
|
||||
import HBS2.Defaults
|
||||
import HBS2.Merkle
|
||||
import HBS2.Net.Auth.Credentials
|
||||
import HBS2.Net.Messaging.UDP (UDP)
|
||||
import HBS2.Net.Proto.Definition()
|
||||
import HBS2.Net.Proto.Types
|
||||
import HBS2.OrDie
|
||||
import HBS2.Prelude.Plated
|
||||
|
||||
import Codec.Serialise
|
||||
import Control.Monad ((<=<))
|
||||
import Crypto.Saltine.Core.Sign (Keypair(..))
|
||||
import Crypto.Saltine.Core.Sign qualified as Sign
|
||||
import Crypto.Saltine.Core.Box qualified as Encrypt
|
||||
import Crypto.Saltine.Class qualified as Crypto
|
||||
import Crypto.Saltine.Class (IsEncoding)
|
||||
import Data.ByteString.Lazy.Char8 qualified as LBS
|
||||
import Data.ByteString.Char8 qualified as B8
|
||||
import Data.ByteString.Char8 (ByteString)
|
||||
import Data.Function
|
||||
import Data.List.Split (chunksOf)
|
||||
import Data.Text (Text)
|
||||
import Data.List qualified as List
|
||||
import Lens.Micro.Platform
|
||||
import Data.Kind
|
||||
import Prettyprinter
|
||||
|
||||
|
||||
newtype EncryptedBox = EncryptedBox { unEncryptedBox :: ByteString }
|
||||
deriving stock (Generic)
|
||||
|
||||
instance Serialise EncryptedBox
|
||||
|
||||
data EncryptionSchema = NaClAsymm
|
||||
|
||||
---
|
||||
|
||||
data family AccessKey e ( s :: EncryptionSchema )
|
||||
|
||||
newtype instance AccessKey e 'NaClAsymm =
|
||||
AccessKeyNaClAsymm
|
||||
{ permitted :: [(PubKey 'Encrypt e, EncryptedBox)]
|
||||
}
|
||||
deriving stock (Generic)
|
||||
|
||||
instance Serialise (AccessKey e 'NaClAsymm)
|
||||
|
||||
---
|
||||
|
||||
data family GroupKey e ( s :: EncryptionSchema )
|
||||
|
||||
data instance GroupKey e 'NaClAsymm =
|
||||
GroupKeyNaClAsymm
|
||||
{ encryptionKey :: KeyringEntry e
|
||||
, permittedPubKeys :: [PubKey 'Encrypt e]
|
||||
}
|
||||
deriving stock (Generic)
|
||||
|
||||
instance Serialise (GroupKey e 'NaClAsymm)
|
||||
|
||||
---
|
||||
|
||||
newtype AsGroupKeyFile a = AsGroupKeyFile a
|
||||
|
||||
-- FIXME: integration-regression-test-for-groupkey
|
||||
-- Добавить тест: сгенерировали groupkey/распарсили groupkey
|
||||
|
||||
parseGroupKey :: forall e . ()
|
||||
=> AsGroupKeyFile ByteString -> Maybe (GroupKey e 'NaClAsymm)
|
||||
parseGroupKey (AsGroupKeyFile bs) = parseSerialisableFromBase58 bs
|
||||
|
||||
instance ( Serialise (GroupKey e s)
|
||||
)
|
||||
|
||||
=> Pretty (AsBase58 (GroupKey e s)) where
|
||||
pretty (AsBase58 c) =
|
||||
pretty . B8.unpack . toBase58 . LBS.toStrict . serialise $ c
|
||||
|
||||
|
||||
instance Pretty (AsBase58 a) => Pretty (AsGroupKeyFile (AsBase58 a)) where
|
||||
pretty (AsGroupKeyFile pc) = "# hbs2 groupkey file" <> line
|
||||
<> "# keep it private" <> line <> line
|
||||
<> co
|
||||
where
|
||||
co = vcat $ fmap pretty
|
||||
$ chunksOf 60
|
||||
$ show
|
||||
$ pretty pc
|
||||
|
||||
|
||||
-- newtype ListGroupKeyKeys e s = ListGroupKeyKeys (GroupKey e s)
|
||||
|
||||
-- instance ()
|
||||
-- => Pretty (ListGroupKeyKeys e 'NaClAsymm) where
|
||||
-- pretty (ListGroupKeyKeys (GroupKeyNaClAsymm keypair pubkeys)) =
|
||||
-- fill 10 "recipient public keys:"
|
||||
-- <+> vcat (pretty . AsBase58 . Crypto.encode <$> pubkeys)
|
||||
-- <> line
|
||||
-- <> pretty keypair
|
||||
|
||||
---
|
||||
|
||||
parsePubKeys :: forall e . ()
|
||||
=> ByteString -> Maybe [PubKey 'Encrypt e]
|
||||
|
||||
parsePubKeys = sequenceA . fmap (Crypto.decode <=< fromBase58) . B8.lines
|
||||
|
||||
---
|
||||
|
||||
mkEncryptedKey :: KeyringEntry MerkleEncryptionType -> PubKey 'Encrypt MerkleEncryptionType -> IO EncryptedBox
|
||||
mkEncryptedKey kr pk = EncryptedBox <$> Encrypt.boxSeal pk ((LBS.toStrict . serialise) kr)
|
||||
|
||||
openEncryptedKey :: EncryptedBox -> KeyringEntry MerkleEncryptionType -> Maybe (KeyringEntry MerkleEncryptionType)
|
||||
openEncryptedKey (EncryptedBox bs) kr =
|
||||
either (const Nothing) Just . deserialiseOrFail . LBS.fromStrict =<< Encrypt.boxSealOpen (_krPk kr) (_krSk kr) bs
|
||||
|
|
@ -125,11 +125,12 @@ parseCredentials :: forall e . ( Signatures e
|
|||
, SerialisedCredentials e
|
||||
)
|
||||
=> AsCredFile ByteString -> Maybe (PeerCredentials e)
|
||||
parseCredentials (AsCredFile bs) = parseSerialisableFromBase58 bs
|
||||
|
||||
parseCredentials (AsCredFile bs) = maybe1 b58_1 Nothing fromCbor
|
||||
|
||||
parseSerialisableFromBase58 :: Serialise a => ByteString -> Maybe a
|
||||
parseSerialisableFromBase58 bs = maybe1 b58_1 Nothing fromCbor
|
||||
where
|
||||
fromCbor s = deserialiseOrFail @(PeerCredentials e) s
|
||||
fromCbor s = deserialiseOrFail s
|
||||
& either (const Nothing) Just
|
||||
|
||||
b58_1 = B8.lines bs & dropWhile hdr
|
||||
|
|
|
|||
|
|
@ -8,6 +8,7 @@ module HBS2.Net.Proto.Definition
|
|||
|
||||
import HBS2.Clock
|
||||
import HBS2.Defaults
|
||||
import HBS2.Merkle
|
||||
import HBS2.Net.Auth.Credentials
|
||||
import HBS2.Net.Messaging.UDP
|
||||
import HBS2.Net.Proto
|
||||
|
|
@ -140,4 +141,10 @@ instance Signatures UDP where
|
|||
makeSign = Sign.signDetached
|
||||
verifySign = Sign.signVerifyDetached
|
||||
|
||||
instance Signatures MerkleEncryptionType where
|
||||
type Signature MerkleEncryptionType = Sign.Signature
|
||||
makeSign = Sign.signDetached
|
||||
verifySign = Sign.signVerifyDetached
|
||||
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -160,14 +160,7 @@ processBlock h = do
|
|||
|
||||
when (isJust bt) (removeFromWip h)
|
||||
|
||||
case bt of
|
||||
Nothing -> addDownload h
|
||||
|
||||
Just (AnnRef{}) -> pure ()
|
||||
|
||||
Just (Merkle{}) -> do
|
||||
debug $ "GOT MERKLE. requesting nodes/leaves" <+> pretty h
|
||||
walkMerkle h (liftIO . getBlock sto) $ \(hrr :: Either (Hash HbSync) [HashRef]) -> do
|
||||
let handleHrr = \(hrr :: Either (Hash HbSync) [HashRef]) -> do
|
||||
|
||||
case hrr of
|
||||
Left hx -> addDownload hx
|
||||
|
|
@ -189,6 +182,27 @@ processBlock h = do
|
|||
else do
|
||||
addDownload blk
|
||||
|
||||
case bt of
|
||||
Nothing -> addDownload h
|
||||
|
||||
Just (AnnRef{}) -> pure ()
|
||||
|
||||
Just (MerkleAnn ann) -> do
|
||||
case (_mtaMeta ann) of
|
||||
NoMetaData -> pure ()
|
||||
ShortMetadata {} -> pure ()
|
||||
AnnHashRef h -> addDownload h
|
||||
|
||||
case (_mtaCrypt ann) of
|
||||
NullEncryption -> pure ()
|
||||
CryptAccessKeyNaClAsymm h -> addDownload h
|
||||
|
||||
debug $ "GOT WRAPPED MERKLE. requesting nodes/leaves" <+> pretty h
|
||||
walkMerkleTree (_mtaTree ann) (liftIO . getBlock sto) handleHrr
|
||||
|
||||
Just (Merkle{}) -> do
|
||||
debug $ "GOT MERKLE. requesting nodes/leaves" <+> pretty h
|
||||
walkMerkle h (liftIO . getBlock sto) handleHrr
|
||||
|
||||
Just (Blob{}) -> do
|
||||
pure ()
|
||||
|
|
|
|||
|
|
@ -43,6 +43,21 @@ instance SimpleStorageExtra Handle where
|
|||
& S.map (HashRef . hashObject)
|
||||
& S.toList_
|
||||
|
||||
putAsMerkle ss hashes
|
||||
|
||||
instance SimpleStorageExtra (S.Stream (S.Of ByteString) IO ()) where
|
||||
putAsMerkle ss streamChunks = do
|
||||
|
||||
hashes <- streamChunks
|
||||
& S.mapM (\blk -> enqueueBlock ss blk >> pure blk)
|
||||
& S.map (HashRef . hashObject)
|
||||
& S.toList_
|
||||
|
||||
putAsMerkle ss hashes
|
||||
|
||||
instance SimpleStorageExtra [HashRef] where
|
||||
putAsMerkle ss hashes = do
|
||||
|
||||
let pt = toPTree (MaxSize pieces) (MaxNum pieces) hashes -- FIXME: settings
|
||||
|
||||
root <- makeMerkle 0 pt $ \(_,_,bs) -> void $ putBlock ss bs
|
||||
|
|
|
|||
115
hbs2/Main.hs
115
hbs2/Main.hs
|
|
@ -5,6 +5,7 @@ import HBS2.Data.Detect
|
|||
import HBS2.Data.Types
|
||||
import HBS2.Defaults
|
||||
import HBS2.Merkle
|
||||
import HBS2.Net.Auth.AccessKey
|
||||
import HBS2.Net.Auth.Credentials
|
||||
import HBS2.Net.Messaging.UDP (UDP)
|
||||
import HBS2.Net.Proto.Definition()
|
||||
|
|
@ -15,16 +16,22 @@ import HBS2.Storage.Simple.Extra
|
|||
import HBS2.OrDie
|
||||
|
||||
|
||||
import Data.ByteString.Lazy (ByteString)
|
||||
import Control.Arrow ((&&&))
|
||||
import Control.Concurrent.Async
|
||||
import Control.Monad
|
||||
import Control.Monad.IO.Class
|
||||
import Control.Monad.Trans.Maybe
|
||||
import Control.Monad.Trans.State.Strict
|
||||
import Crypto.Saltine.Core.Box qualified as Encrypt
|
||||
import Data.ByteString.Lazy qualified as LBS
|
||||
import Data.ByteString qualified as BS
|
||||
import Data.ByteString.Lazy (ByteString)
|
||||
import Data.Either
|
||||
import Data.Function
|
||||
import Data.Functor
|
||||
import Data.Map.Strict qualified as Map
|
||||
import Data.Monoid qualified as Monoid
|
||||
import Data.Text (Text)
|
||||
import Data.UUID qualified as UUID
|
||||
import Data.UUID.V4 qualified as UUID
|
||||
import Options.Applicative
|
||||
|
|
@ -57,6 +64,14 @@ newtype CatHashesOnly = CatHashesOnly Bool
|
|||
deriving stock (Data,Generic)
|
||||
|
||||
|
||||
newtype OptKeyringFile = OptKeyringFile { unOptKeyringFile :: FilePath }
|
||||
deriving newtype (Eq,Ord,IsString)
|
||||
deriving stock (Data)
|
||||
|
||||
newtype OptGroupkeyFile = OptGroupkeyFile { unOptGroupkeyFile :: FilePath }
|
||||
deriving newtype (Eq,Ord,IsString)
|
||||
deriving stock (Data)
|
||||
|
||||
newtype OptInit = OptInit { fromOptInit :: Bool }
|
||||
deriving newtype (Eq,Ord,Pretty)
|
||||
deriving stock (Data,Generic)
|
||||
|
|
@ -65,6 +80,7 @@ data StoreOpts =
|
|||
StoreOpts
|
||||
{ storeInit :: Maybe OptInit
|
||||
, storeInputFile :: Maybe OptInputFile
|
||||
, storeGroupkeyFile :: Maybe OptGroupkeyFile
|
||||
}
|
||||
deriving stock (Data)
|
||||
|
||||
|
|
@ -72,6 +88,7 @@ data CatOpts =
|
|||
CatOpts
|
||||
{ catMerkleHash :: Maybe MerkleHash
|
||||
, catHashesOnly :: Maybe CatHashesOnly
|
||||
, catPathToKeyring :: Maybe OptKeyringFile
|
||||
}
|
||||
deriving stock (Data)
|
||||
|
||||
|
|
@ -122,9 +139,54 @@ runCat opts ss = do
|
|||
Nothing -> die $ show $ "missed block: " <+> pretty hx
|
||||
Just blk -> LBS.putStr blk
|
||||
|
||||
let walkAnn :: MTreeAnn [HashRef] -> IO ()
|
||||
walkAnn ann = do
|
||||
bprocess :: Hash HbSync -> ByteString -> IO ByteString <- case (_mtaCrypt ann) of
|
||||
NullEncryption -> pure (const pure)
|
||||
CryptAccessKeyNaClAsymm crypth -> do
|
||||
|
||||
keyringFile <- pure (uniLastMay @OptKeyringFile opts <&> unOptKeyringFile)
|
||||
`orDie` "block encrypted. keyring required"
|
||||
s <- BS.readFile keyringFile
|
||||
ourKeys <- _peerKeyring
|
||||
<$> pure (parseCredentials @MerkleEncryptionType (AsCredFile s))
|
||||
`orDie` "bad keyring file"
|
||||
|
||||
blkc <- getBlock ss crypth `orDie` (show $ "missed block: " <+> pretty crypth)
|
||||
recipientKeys :: [(PubKey 'Encrypt MerkleEncryptionType, EncryptedBox)]
|
||||
<- pure ((either (const Nothing) Just . deserialiseOrFail) blkc)
|
||||
`orDie` "can not deserialise access key"
|
||||
|
||||
(ourkr, box)
|
||||
<- pure (Monoid.getFirst
|
||||
(foldMap (\kr@(KeyringEntry pk sk _)
|
||||
-> Monoid.First ((kr, )
|
||||
<$> Map.lookup pk (Map.fromList recipientKeys)))
|
||||
ourKeys))
|
||||
`orDie` "no available recipient key"
|
||||
|
||||
kr <- pure (openEncryptedKey box ourkr)
|
||||
`orDie` "can not open sealed secret key with our key"
|
||||
|
||||
pure $ \hx blk ->
|
||||
pure ((fmap LBS.fromStrict . Encrypt.boxSealOpen (_krPk kr) (_krSk kr) . LBS.toStrict) blk)
|
||||
`orDie` (show $ "can not decode block: " <+> pretty hx)
|
||||
|
||||
walkMerkleTree (_mtaTree ann) (getBlock ss) $ \(hr :: Either (Hash HbSync) [HashRef]) -> do
|
||||
case hr of
|
||||
Left hx -> void $ hPrint stderr $ "missed block:" <+> pretty hx
|
||||
Right (hrr :: [HashRef]) -> do
|
||||
forM_ hrr $ \(HashRef hx) -> do
|
||||
if honly then do
|
||||
print $ pretty hx
|
||||
else do
|
||||
blk <- getBlock ss hx `orDie` (show $ "missed block: " <+> pretty hx)
|
||||
LBS.putStr =<< bprocess hx blk
|
||||
|
||||
case q of
|
||||
Blob h -> getBlock ss h >>= maybe (die "blob not found") LBS.putStr
|
||||
Merkle h -> walk h
|
||||
MerkleAnn ann -> walkAnn ann
|
||||
AnnRef h -> do
|
||||
let lnk = deserialise @AnnotatedHashRef obj
|
||||
let mbHead = headMay [ h
|
||||
|
|
@ -141,16 +203,49 @@ runStore opts ss | justInit = do
|
|||
where
|
||||
justInit = maybe False fromOptInit (uniLastMay @OptInit opts)
|
||||
|
||||
|
||||
runStore opts ss = do
|
||||
|
||||
let fname = uniLastMay @OptInputFile opts
|
||||
|
||||
handle <- maybe (pure stdin) (flip openFile ReadMode . unOptFile) fname
|
||||
|
||||
case (uniLastMay @OptGroupkeyFile opts) of
|
||||
Nothing -> do
|
||||
root <- putAsMerkle ss handle
|
||||
|
||||
print $ "merkle-root: " <+> pretty root
|
||||
Just gkfile -> do
|
||||
gk :: GroupKey MerkleEncryptionType 'NaClAsymm
|
||||
<- (parseGroupKey . AsGroupKeyFile <$> BS.readFile (unOptGroupkeyFile gkfile))
|
||||
`orDie` "bad groupkey file"
|
||||
|
||||
accKeyh <- maybe (die "can not store access key") pure
|
||||
=<< (putBlock ss . serialise @[(PubKey 'Encrypt MerkleEncryptionType, EncryptedBox)])
|
||||
=<< (permittedPubKeys gk `forM` \pk -> (pk, ) <$> mkEncryptedKey (encryptionKey gk) pk)
|
||||
|
||||
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 ((_krPk . encryptionKey) 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
|
||||
|
||||
runNewGroupkey :: FilePath -> IO ()
|
||||
runNewGroupkey pubkeysFile = do
|
||||
s <- BS.readFile pubkeysFile
|
||||
pubkeys <- pure (parsePubKeys s) `orDie` "bad pubkeys file"
|
||||
keypair <- newKeypair @MerkleEncryptionType Nothing
|
||||
print $ pretty $ AsGroupKeyFile $ AsBase58
|
||||
$ GroupKeyNaClAsymm keypair pubkeys
|
||||
|
||||
runNewRef :: Data opts => opts -> MerkleHash -> SimpleStorage HbSync -> IO ()
|
||||
runNewRef opts mhash ss = do
|
||||
|
|
@ -234,6 +329,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"))
|
||||
)
|
||||
|
||||
common = do
|
||||
|
|
@ -250,13 +346,20 @@ main = join . customExecParser (prefs showHelpOnError) $
|
|||
o <- common
|
||||
file <- optional $ strArgument ( metavar "FILE" )
|
||||
init <- optional $ flag' True ( long "init" <> help "just init storage") <&> OptInit
|
||||
pure $ withStore o (runStore ( StoreOpts init file ))
|
||||
groupkeyFile <- optional $ strOption ( long "groupkey" <> help "path to groupkey file" )
|
||||
pure $ withStore o (runStore ( StoreOpts init file (OptGroupkeyFile <$> groupkeyFile) ))
|
||||
|
||||
pCat = do
|
||||
o <- common
|
||||
hash <- optional $ strArgument ( metavar "HASH" )
|
||||
onlyh <- optional $ flag' True ( short 'H' <> long "hashes-only" <> help "list only block hashes" )
|
||||
pure $ withStore o $ runCat $ CatOpts hash (CatHashesOnly <$> onlyh)
|
||||
keyringFile <- optional $ strOption ( long "keyring" <> help "path to keyring file" )
|
||||
pure $ withStore o $ runCat
|
||||
$ CatOpts hash (CatHashesOnly <$> onlyh) (OptKeyringFile <$> keyringFile)
|
||||
|
||||
pNewGroupkey = do
|
||||
pubkeysFile <- strArgument ( metavar "FILE" <> help "path to a file with a list of recipient public keys" )
|
||||
pure $ runNewGroupkey pubkeysFile
|
||||
|
||||
pHash = do
|
||||
o <- common
|
||||
|
|
@ -280,7 +383,7 @@ main = join . customExecParser (prefs showHelpOnError) $
|
|||
|
||||
|
||||
pKeyDel = do
|
||||
s <- strArgument ( metavar "PUB-KEY-BAS58" )
|
||||
s <- strArgument ( metavar "PUB-KEY-BASE58" )
|
||||
f <- strArgument ( metavar "KEYRING-FILE" )
|
||||
pure (runKeyDel s f)
|
||||
|
||||
|
|
|
|||
|
|
@ -49,6 +49,7 @@ common shared-properties
|
|||
, MultiParamTypeClasses
|
||||
, OverloadedStrings
|
||||
, QuasiQuotes
|
||||
, RecordWildCards
|
||||
, ScopedTypeVariables
|
||||
, StandaloneDeriving
|
||||
, TupleSections
|
||||
|
|
@ -81,6 +82,7 @@ executable hbs2
|
|||
, optparse-applicative
|
||||
, prettyprinter
|
||||
, safe
|
||||
, saltine
|
||||
, serialise
|
||||
, streaming
|
||||
, text
|
||||
|
|
|
|||
Loading…
Reference in New Issue