diff --git a/hbs2-core/lib/HBS2/Merkle.hs b/hbs2-core/lib/HBS2/Merkle.hs index 2a8da3ba..f8e3f36c 100644 --- a/hbs2-core/lib/HBS2/Merkle.hs +++ b/hbs2-core/lib/HBS2/Merkle.hs @@ -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 (forM_, traverse_) import Data.List qualified as List +import Data.Text (Text) import GHC.Generics import Lens.Micro.Platform import Prettyprinter @@ -76,8 +77,14 @@ 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 - { _mtaAnn :: !Ann + { _mtaMeta :: !AnnMetaData + , _mtaCrypt :: !MTreeEncryption , _mtaTree :: !(MTree a) } deriving stock (Generic,Data,Show) @@ -87,13 +94,12 @@ instance Serialise a => Serialise (MTreeAnn a) data MerkleEncryptionType deriving stock (Data) -data Ann - = NullAnn - | GroupKeyCrypt (Hash HbSync) - -- FIXME more annotation schemes +data MTreeEncryption + = NullEncryption + | CryptAccessKeyNaClAsymm (Hash HbSync) deriving stock (Generic,Data,Show) -instance Serialise Ann +instance Serialise MTreeEncryption data MTree a = MNode MNodeData [Hash HbSync] | MLeaf a deriving stock (Generic,Data,Show) diff --git a/hbs2-core/lib/HBS2/Net/Auth/AccessKey.hs b/hbs2-core/lib/HBS2/Net/Auth/AccessKey.hs index 7af126ed..eb7f92fd 100644 --- a/hbs2-core/lib/HBS2/Net/Auth/AccessKey.hs +++ b/hbs2-core/lib/HBS2/Net/Auth/AccessKey.hs @@ -18,6 +18,7 @@ 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 @@ -40,9 +41,98 @@ newtype EncryptedBox = EncryptedBox { unEncryptedBox :: ByteString } instance Serialise EncryptedBox -newtype AccessKeyV1 e = AccessKeyV1 +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 (AccessKeyV1 e) +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) = maybe1 b58_1 Nothing fromCbor + + where + fromCbor s = deserialiseOrFail @(GroupKey e 'NaClAsymm) s + & either (const Nothing) Just + + b58_1 = B8.lines bs & dropWhile hdr + & filter ( not . B8.null ) + & B8.concat + & fromBase58 + & fmap LBS.fromStrict + + hdr s = B8.isPrefixOf "#" s || B8.null s + +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 = + deserialise . LBS.fromStrict =<< Encrypt.boxSealOpen (_krPk kr) (_krSk kr) bs diff --git a/hbs2-core/lib/HBS2/Net/Proto/Definition.hs b/hbs2-core/lib/HBS2/Net/Proto/Definition.hs index bf82e3b2..52a21c0c 100644 --- a/hbs2-core/lib/HBS2/Net/Proto/Definition.hs +++ b/hbs2-core/lib/HBS2/Net/Proto/Definition.hs @@ -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 + + diff --git a/hbs2-peer/app/BlockDownload.hs b/hbs2-peer/app/BlockDownload.hs index d7a82c99..b2e31dea 100644 --- a/hbs2-peer/app/BlockDownload.hs +++ b/hbs2-peer/app/BlockDownload.hs @@ -187,13 +187,18 @@ processBlock h = do Just (AnnRef{}) -> pure () - Just (MerkleAnn (MTreeAnn ann t)) -> do - case ann of - NullAnn -> pure () - GroupKeyCrypt hk -> addDownload hk + 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 t (liftIO . getBlock sto) handleHrr + walkMerkleTree (_mtaTree ann) (liftIO . getBlock sto) handleHrr Just (Merkle{}) -> do debug $ "GOT MERKLE. requesting nodes/leaves" <+> pretty h diff --git a/hbs2/Main.hs b/hbs2/Main.hs index f1195e7b..39aa5f3c 100644 --- a/hbs2/Main.hs +++ b/hbs2/Main.hs @@ -16,17 +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 @@ -59,15 +64,18 @@ newtype CatHashesOnly = CatHashesOnly Bool deriving stock (Data,Generic) +newtype OptKeyringFile = OptKeyringFile { unOptKeyringFile :: FilePath } + deriving newtype (Eq,Ord,IsString) + deriving stock (Data) + newtype OptInit = OptInit { fromOptInit :: Bool } deriving newtype (Eq,Ord,Pretty) deriving stock (Data,Generic) data OptEncryption e = OptEncryption - { encryptFromSecKey :: Maybe (PrivKey 'Encrypt e) - , encryptToSecKey :: PrivKey 'Encrypt e - , encryptToPubKey :: PubKey 'Encrypt e - , encryptToGroup :: [PubKey 'Encrypt e] + { encoptGroupkeyFile :: FilePath + , encoptKeyringFile :: Maybe FilePath + , encoptFromPubKey :: Maybe Text } deriving stock (Data) @@ -83,7 +91,7 @@ data CatOpts = CatOpts { catMerkleHash :: Maybe MerkleHash , catHashesOnly :: Maybe CatHashesOnly - , catPathToKeyring :: Maybe FilePath + , catPathToKeyring :: Maybe OptKeyringFile } deriving stock (Data) @@ -134,46 +142,54 @@ runCat opts ss = do Nothing -> die $ show $ "missed block: " <+> pretty hx Just blk -> LBS.putStr blk - let walkAnn :: Ann -> MTree [HashRef] -> IO () - walkAnn ann t = do - bprocess :: Int -> ByteString -> IO ByteString <- case ann of - NullAnn -> pure (\_ -> pure) - GroupKeyCrypt crypth -> do - mblk <- getBlock ss crypth - case mblk of - Nothing -> die $ show $ "missed block: " <+> pretty crypth - Just blk -> do - -- FIXME apply crypto scheme from `crypth` to stream of blk's - -- extract AccessKeyV1 from blk - -- find in it any pubkey known to us - -- decrypt corresponding EncryptedBox - -- get actual (PrivKey 'Encrypt e) to use for merkle decryption - pure $ \blnum blk -> do - -- convert blnum to Crypto.Saltine.Core.Box.Nonce - -- decrypt blk with this nonce and priv key - undefined + 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 - flip evalStateT firstNumOfBlock $ - walkMerkleTree t (lift . getBlock ss) $ \(hr :: Either (Hash HbSync) [HashRef]) -> 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 -> lift $ void $ hPrint stderr $ "missed block:" <+> pretty hx + Left hx -> void $ hPrint stderr $ "missed block:" <+> pretty hx Right (hrr :: [HashRef]) -> do forM_ hrr $ \(HashRef hx) -> do if honly then do - lift $ print $ pretty hx + print $ pretty hx else do - mblk <- lift $ getBlock ss hx - case mblk of - Nothing -> lift $ die $ show $ "missed block: " <+> pretty hx - Just blk -> do - blnum <- get - modify (+1) - lift $ LBS.putStr =<< bprocess blnum blk + 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 (MTreeAnn ann hs) -> walkAnn ann hs + MerkleAnn ann -> walkAnn ann AnnRef h -> do let lnk = deserialise @AnnotatedHashRef obj let mbHead = headMay [ h @@ -190,9 +206,6 @@ runStore opts ss | justInit = do where justInit = maybe False fromOptInit (uniLastMay @OptInit opts) -firstNumOfBlock :: Int -firstNumOfBlock = 1 - runStore opts ss = do let fname = uniLastMay @OptInputFile opts @@ -204,32 +217,39 @@ runStore opts ss = do root <- putAsMerkle ss handle print $ "merkle-root: " <+> pretty root Just encOpts -> do + gk :: GroupKey MerkleEncryptionType 'NaClAsymm + <- (parseGroupKey . AsGroupKeyFile <$> BS.readFile (encoptGroupkeyFile encOpts)) + `orDie` "bad groupkey file" - -- FIXME generate AccessKeyV1, store it accKeyh <- maybe (die "can not store access key") pure - =<< (putBlock ss . serialise) do - AccessKeyV1 (undefined :: [(PubKey 'Encrypt e, EncryptedBox)]) + =<< (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 () - -- FIXME get keys to enrypt encryptedChunks = rawChunks - & S.zip (S.enumFrom firstNumOfBlock) - & S.map (\(blnum, blk) -> do - -- FIXME convert blnum to Crypto.Saltine.Core.Box.Nonce - -- encrypt blk with this nonce and priv key - undefined + & S.mapM (fmap LBS.fromStrict . Encrypt.boxSeal ((_krPk . encryptionKey) gk) . LBS.toStrict) mhash <- putAsMerkle ss encryptedChunks + mtree <- ((deserialise =<<) <$> getBlock ss (fromMerkleHash mhash)) + `orDie` "merkle tree was not stored properly with `putAsMerkle`" mannh <- maybe (die "can not store MerkleAnn") pure - =<< (putBlock ss . serialise) do - MerkleAnn (MTreeAnn (GroupKeyCrypt accKeyh) (undefined mhash)) + =<< (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 uuid <- UUID.nextRandom <&> (hashObject @HbSync . UUID.toASCIIBytes) @@ -312,6 +332,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 @@ -328,16 +349,25 @@ main = join . customExecParser (prefs showHelpOnError) $ o <- common file <- optional $ strArgument ( metavar "FILE" ) init <- optional $ flag' True ( long "init" <> help "just init storage") <&> OptInit - -- FIXME option to encrypt - encOps :: Maybe (OptEncryption MerkleEncryptionType) <- optional $ undefined - pure $ withStore o (runStore ( StoreOpts init file encOps )) + groupkeyFile <- optional $ strOption ( long "groupkey" <> help "path to groupkey file" ) + encoptKeyringFile <- optional $ strOption ( long "keyring" <> help "path to keyring file" ) + encoptFromPubKey <- optional $ strOption ( metavar "PUB-KEY-BAS58" ) + pure do + let encOps :: Maybe (OptEncryption MerkleEncryptionType) + encOps = groupkeyFile <&> \encoptGroupkeyFile -> OptEncryption{..} + withStore o (runStore ( StoreOpts init file encOps )) pCat = do o <- common hash <- optional $ strArgument ( metavar "HASH" ) onlyh <- optional $ flag' True ( short 'H' <> long "hashes-only" <> help "list only block hashes" ) keyringFile <- optional $ strOption ( long "keyring" <> help "path to keyring file" ) - pure $ withStore o $ runCat $ CatOpts hash (CatHashesOnly <$> onlyh) keyringFile + 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 diff --git a/hbs2/hbs2.cabal b/hbs2/hbs2.cabal index 70f8f29f..39b4e654 100644 --- a/hbs2/hbs2.cabal +++ b/hbs2/hbs2.cabal @@ -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