diff --git a/.fixme/log b/.fixme/log index bf7ca57e..e69de29b 100644 --- a/.fixme/log +++ b/.fixme/log @@ -1,3 +0,0 @@ - -(fixme-set "assigned" "HPoqtobDAT" "voidlizard") -(fixme-set "workflow" "test" "HPoqtobDAT") \ No newline at end of file diff --git a/hbs2-core/hbs2-core.cabal b/hbs2-core/hbs2-core.cabal index 1b86abc0..23095e5f 100644 --- a/hbs2-core/hbs2-core.cabal +++ b/hbs2-core/hbs2-core.cabal @@ -120,10 +120,10 @@ library , HBS2.Storage.Operations , HBS2.System.Logger.Simple , HBS2.System.Logger.Simple.Class - , Dialog.Core - , Dialog.Client - , Dialog.Helpers.List - , Dialog.Helpers.Streaming + , HBS2.Net.Dialog.Core + , HBS2.Net.Dialog.Client + , HBS2.Net.Dialog.Helpers.List + , HBS2.Net.Dialog.Helpers.Streaming -- other-modules: diff --git a/hbs2-core/lib/HBS2/Actors/Peer.hs b/hbs2-core/lib/HBS2/Actors/Peer.hs index bf82a7e7..348666ef 100644 --- a/hbs2-core/lib/HBS2/Actors/Peer.hs +++ b/hbs2-core/lib/HBS2/Actors/Peer.hs @@ -11,6 +11,7 @@ module HBS2.Actors.Peer import HBS2.Actors import HBS2.Actors.Peer.Types import HBS2.Clock +import HBS2.Data.Types.Crypto import HBS2.Data.Types.Peer import HBS2.Defaults import HBS2.Events @@ -158,30 +159,8 @@ data PeerEnv e = , _envSweepers :: TVar (HashMap SKey [PeerM e IO ()]) , _envReqMsgLimit :: Cache (Peer e, Integer, Encoded e) () , _envReqProtoLimit :: Cache (Peer e, Integer) () - , _envAsymmetricKeyPair :: AsymmKeypair (Encryption e) - , _envEncryptionKeys :: TVar (HashMap (PeerData e) (CommonSecret (Encryption e))) } -setEncryptionKey :: - ( Hashable (PubKey 'Sign (Encryption L4Proto)) - , Hashable PeerNonce - , Show (PubKey 'Sign (Encryption L4Proto)) - , Show PeerNonce - , Show (CommonSecret (Encryption L4Proto)) - ) => PeerEnv L4Proto -> Peer L4Proto -> PeerData L4Proto -> Maybe (CommonSecret (Encryption L4Proto)) -> IO () -setEncryptionKey penv peer pd msecret = do - atomically $ modifyTVar' (_envEncryptionKeys penv) $ Lens.at pd .~ msecret - case msecret of - Nothing -> trace $ "ENCRYPTION delete key" <+> pretty peer <+> viaShow pd - Just k -> trace $ "ENCRYPTION store key" <+> pretty peer <+> viaShow pd <+> viaShow k - -getEncryptionKey :: - ( Hashable (PubKey 'Sign (Encryption L4Proto)) - , Hashable PeerNonce - ) => PeerEnv L4Proto -> PeerData L4Proto -> IO (Maybe (CommonSecret (Encryption L4Proto))) -getEncryptionKey penv pd = - readTVarIO (_envEncryptionKeys penv) <&> preview (Lens.ix pd) - newtype PeerM e m a = PeerM { fromPeerM :: ReaderT (PeerEnv e) m a } deriving newtype ( Functor , Applicative @@ -435,8 +414,6 @@ newPeerEnv s bus p = do _envSweepers <- liftIO (newTVarIO mempty) _envReqMsgLimit <- liftIO (Cache.newCache (Just defRequestLimit)) _envReqProtoLimit <- liftIO (Cache.newCache (Just defRequestLimit)) - _envAsymmetricKeyPair <- asymmNewKeypair @(Encryption e) - _envEncryptionKeys <- liftIO (newTVarIO mempty) pure PeerEnv {..} runPeerM :: forall e m . ( MonadIO m diff --git a/hbs2-core/lib/HBS2/Data/Types/Refs.hs b/hbs2-core/lib/HBS2/Data/Types/Refs.hs index 241d4d10..541c3434 100644 --- a/hbs2-core/lib/HBS2/Data/Types/Refs.hs +++ b/hbs2-core/lib/HBS2/Data/Types/Refs.hs @@ -8,7 +8,7 @@ module HBS2.Data.Types.Refs import HBS2.Base58 import HBS2.Hash import HBS2.Merkle -import HBS2.Net.Proto.Types (Encryption) +import HBS2.Net.Proto.Types import HBS2.Net.Auth.Credentials import HBS2.Prelude diff --git a/hbs2-core/lib/HBS2/Net/Auth/AccessKey.hs b/hbs2-core/lib/HBS2/Net/Auth/AccessKey.hs index abf84c17..4d4c0b8e 100644 --- a/hbs2-core/lib/HBS2/Net/Auth/AccessKey.hs +++ b/hbs2-core/lib/HBS2/Net/Auth/AccessKey.hs @@ -10,6 +10,7 @@ import HBS2.Data.Types import HBS2.Merkle import HBS2.Net.Auth.Credentials import HBS2.Net.Proto.Definition +import HBS2.Net.Proto.Types import HBS2.Prelude.Plated import Codec.Serialise diff --git a/hbs2-core/lib/HBS2/Net/Auth/Credentials.hs b/hbs2-core/lib/HBS2/Net/Auth/Credentials.hs index 0ae23baf..1a866395 100644 --- a/hbs2-core/lib/HBS2/Net/Auth/Credentials.hs +++ b/hbs2-core/lib/HBS2/Net/Auth/Credentials.hs @@ -28,11 +28,6 @@ import Data.Kind type family EncryptPubKey e :: Type -data CryptoAction = Sign | Encrypt - -type family PubKey ( a :: CryptoAction) e :: Type -type family PrivKey ( a :: CryptoAction) e :: Type - class Signatures e where type family Signature e :: Type makeSign :: PrivKey 'Sign e -> ByteString -> Signature e @@ -207,4 +202,3 @@ instance IsEncoding (PubKey 'Encrypt e) => Pretty (KeyringEntry e) where pretty ke = fill 10 "pub-key:" <+> pretty (AsBase58 (Crypto.encode (view krPk ke))) - diff --git a/hbs2-core/lib/Dialog/Client.hs b/hbs2-core/lib/HBS2/Net/Dialog/Client.hs similarity index 98% rename from hbs2-core/lib/Dialog/Client.hs rename to hbs2-core/lib/HBS2/Net/Dialog/Client.hs index 5d8a987d..21be3275 100644 --- a/hbs2-core/lib/Dialog/Client.hs +++ b/hbs2-core/lib/HBS2/Net/Dialog/Client.hs @@ -1,7 +1,7 @@ {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE StrictData #-} {-# LANGUAGE ImpredicativeTypes #-} -module Dialog.Client where +module HBS2.Net.Dialog.Client where -- import System.Clock -- import System.Timeout @@ -34,8 +34,8 @@ import UnliftIO.Exception import UnliftIO.STM import UnliftIO.Timeout -import Dialog.Core -import Dialog.Helpers.Streaming +import HBS2.Net.Dialog.Core +import HBS2.Net.Dialog.Helpers.Streaming --- diff --git a/hbs2-core/lib/Dialog/Core.hs b/hbs2-core/lib/HBS2/Net/Dialog/Core.hs similarity index 98% rename from hbs2-core/lib/Dialog/Core.hs rename to hbs2-core/lib/HBS2/Net/Dialog/Core.hs index d259e89f..e38691eb 100644 --- a/hbs2-core/lib/Dialog/Core.hs +++ b/hbs2-core/lib/HBS2/Net/Dialog/Core.hs @@ -1,7 +1,7 @@ {-# LANGUAGE StrictData #-} -- {-# LANGUAGE OverloadedLists #-} -- {-# LANGUAGE UndecidableInstances #-} -module Dialog.Core where +module HBS2.Net.Dialog.Core where -- import Data.ByteString.Builder as Builder -- import Data.ByteString.Builder.Internal as Builder @@ -50,7 +50,7 @@ import UnliftIO.STM -- import HBS2.Base58 import Data.ByteString.Base16 qualified as B16 -import Dialog.Helpers.List +import HBS2.Net.Dialog.Helpers.List type Frames = Frames' ByteString newtype Frames' a = Frames { unFrames :: [a] } @@ -78,8 +78,8 @@ tailAfterP p focus = fix \go -> \case --- --- encodeFrames :: Frames -> ByteString -encodeFrames :: Foldable t => t ByteString -> ByteString +encodeFrames :: Frames -> ByteString +-- encodeFrames :: Foldable t => t ByteString -> ByteString encodeFrames = F.toList >>> BSL.toStrict . runPut . \case [] -> pure () diff --git a/hbs2-core/lib/Dialog/Helpers/List.hs b/hbs2-core/lib/HBS2/Net/Dialog/Helpers/List.hs similarity index 91% rename from hbs2-core/lib/Dialog/Helpers/List.hs rename to hbs2-core/lib/HBS2/Net/Dialog/Helpers/List.hs index b086b2e8..2460b993 100644 --- a/hbs2-core/lib/Dialog/Helpers/List.hs +++ b/hbs2-core/lib/HBS2/Net/Dialog/Helpers/List.hs @@ -1,4 +1,4 @@ -module Dialog.Helpers.List where +module HBS2.Net.Dialog.Helpers.List where import Control.Monad.Trans.Writer.CPS qualified as W import Data.Functor.Identity diff --git a/hbs2-core/lib/Dialog/Helpers/Streaming.hs b/hbs2-core/lib/HBS2/Net/Dialog/Helpers/Streaming.hs similarity index 97% rename from hbs2-core/lib/Dialog/Helpers/Streaming.hs rename to hbs2-core/lib/HBS2/Net/Dialog/Helpers/Streaming.hs index a38be2b6..412928a4 100644 --- a/hbs2-core/lib/Dialog/Helpers/Streaming.hs +++ b/hbs2-core/lib/HBS2/Net/Dialog/Helpers/Streaming.hs @@ -1,4 +1,4 @@ -module Dialog.Helpers.Streaming where +module HBS2.Net.Dialog.Helpers.Streaming where import Control.Monad.Fix import Data.ByteString qualified as BS diff --git a/hbs2-core/lib/HBS2/Net/Proto/Dialog.hs b/hbs2-core/lib/HBS2/Net/Proto/Dialog.hs index 76523679..ddaf0959 100644 --- a/hbs2-core/lib/HBS2/Net/Proto/Dialog.hs +++ b/hbs2-core/lib/HBS2/Net/Proto/Dialog.hs @@ -3,8 +3,8 @@ module HBS2.Net.Proto.Dialog ( module HBS2.Net.Proto.Dialog -, module Dialog.Core -, module Dialog.Client +, module HBS2.Net.Dialog.Core +, module HBS2.Net.Dialog.Client ) where import HBS2.Actors.Peer @@ -34,8 +34,8 @@ import Streaming.Prelude qualified as S import UnliftIO.Exception import UnliftIO.STM -import Dialog.Client -import Dialog.Core +import HBS2.Net.Dialog.Client +import HBS2.Net.Dialog.Core --- diff --git a/hbs2-core/lib/HBS2/Net/Proto/EncryptionHandshake.hs b/hbs2-core/lib/HBS2/Net/Proto/EncryptionHandshake.hs index 37964767..2532e2e2 100644 --- a/hbs2-core/lib/HBS2/Net/Proto/EncryptionHandshake.hs +++ b/hbs2-core/lib/HBS2/Net/Proto/EncryptionHandshake.hs @@ -15,6 +15,7 @@ import HBS2.System.Logger.Simple import Crypto.Saltine.Core.Box qualified as Encrypt import Data.ByteString qualified as BS +import Data.Hashable hiding (Hashed) import Data.String.Conversions (cs) import Lens.Micro.Platform @@ -68,6 +69,10 @@ sendBeginEncryptionExchange creds ourpubkey peer = do data EncryptionHandshakeAdapter e m s = EncryptionHandshakeAdapter { encHandshake_considerPeerAsymmKey :: Peer e -> Maybe Encrypt.PublicKey -> m () + + , encAsymmetricKeyPair :: AsymmKeypair (Encryption e) + + , encGetEncryptionKey :: EncryptionKeyIDKey e -> m (Maybe (CommonSecret (Encryption e))) } @@ -88,11 +93,10 @@ encryptionHandshakeProto :: forall e s m . , Show (Nonce ()) ) => EncryptionHandshakeAdapter e m s - -> PeerEnv e -> EncryptionHandshake e -> m () -encryptionHandshakeProto EncryptionHandshakeAdapter{..} penv = \case +encryptionHandshakeProto EncryptionHandshakeAdapter{..} = \case ResetEncryptionKeys -> do peer <- thatPeer proto @@ -104,7 +108,7 @@ encryptionHandshakeProto EncryptionHandshakeAdapter{..} penv = \case encHandshake_considerPeerAsymmKey peer Nothing creds <- getCredentials @s - let ourpubkey = pubKeyFromKeypair @s $ view envAsymmetricKeyPair penv + ourpubkey <- pure $ pubKeyFromKeypair @s $ encAsymmetricKeyPair sendBeginEncryptionExchange @e creds ourpubkey peer BeginEncryptionExchange theirsign theirpubkey -> do @@ -117,7 +121,7 @@ encryptionHandshakeProto EncryptionHandshakeAdapter{..} penv = \case -- взять свои ключи creds <- getCredentials @s - let ourpubkey = pubKeyFromKeypair @s $ view envAsymmetricKeyPair penv + ourpubkey <- pure $ pubKeyFromKeypair @s $ encAsymmetricKeyPair -- подписать нонс let sign = makeSign @s (view peerSignSk creds) ((cs . serialise) ourpubkey) diff --git a/hbs2-core/lib/HBS2/Net/Proto/Peer.hs b/hbs2-core/lib/HBS2/Net/Proto/Peer.hs index c9b6ac23..fd99f402 100644 --- a/hbs2-core/lib/HBS2/Net/Proto/Peer.hs +++ b/hbs2-core/lib/HBS2/Net/Proto/Peer.hs @@ -7,6 +7,7 @@ import HBS2.Actors.Peer import HBS2.Data.Types import HBS2.Events import HBS2.Net.Proto +import HBS2.Net.Proto.Types import HBS2.Clock import HBS2.Net.Proto.Sessions import HBS2.Prelude.Plated @@ -228,3 +229,36 @@ instance ( Serialise (PubKey 'Sign (Encryption e)) => Serialise (PeerHandshake e) + +--- + +data EncryptionKeyIDKey e = + EncryptionKeyIDKey + { ekeyIDPeerSignKey :: PubKey 'Sign (Encryption e) + , ekeyIDPeerNonce :: PeerNonce + } + deriving (Generic) + +deriving instance + ( Show (PubKey 'Sign (Encryption e)) + , Show (Nonce ()) + ) => Show (EncryptionKeyIDKey e) + +deriving instance + ( Eq (PubKey 'Sign (Encryption e)) + , Eq (Nonce ()) + ) => Eq (EncryptionKeyIDKey e) + +instance ( + Hashable (PubKey 'Sign (Encryption e)) + , Hashable (Nonce ()) + ) => Hashable (EncryptionKeyIDKey e) where + hashWithSalt s EncryptionKeyIDKey {..} = + hashWithSalt s (ekeyIDPeerSignKey, ekeyIDPeerNonce) + +encryptionKeyIDKeyFromPeerData :: PeerData e -> EncryptionKeyIDKey e +encryptionKeyIDKeyFromPeerData PeerData{..} = + EncryptionKeyIDKey + { ekeyIDPeerSignKey = _peerSignKey + , ekeyIDPeerNonce = _peerOwnNonce + } diff --git a/hbs2-core/lib/HBS2/Net/Proto/Types.hs b/hbs2-core/lib/HBS2/Net/Proto/Types.hs index f2680a08..7f95a11b 100644 --- a/hbs2-core/lib/HBS2/Net/Proto/Types.hs +++ b/hbs2-core/lib/HBS2/Net/Proto/Types.hs @@ -28,6 +28,11 @@ import Control.Monad.Trans.Maybe -- 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 + type family Encryption e :: Type -- FIXME: move-to-a-crypto-definition-modules @@ -206,4 +211,3 @@ instance FromStringMaybe (PeerAddr L4Proto) where instance Serialise L4Proto instance Serialise (PeerAddr L4Proto) - diff --git a/hbs2-core/test/DialogSpec.hs b/hbs2-core/test/DialogSpec.hs index 1a8e8913..59222f5e 100644 --- a/hbs2-core/test/DialogSpec.hs +++ b/hbs2-core/test/DialogSpec.hs @@ -14,8 +14,8 @@ import GHC.Generics (Generic) import Lens.Micro.Platform import System.IO -import Dialog.Core -import Dialog.Helpers.List +import HBS2.Net.Dialog.Core +import HBS2.Net.Dialog.Helpers.List newtype BSA = BSA { unBSA :: ByteString } deriving (Generic, Show) @@ -57,3 +57,7 @@ testDialog = testGroup "dialog" $ buildList do property' "roundtrip encode Frames" \ xs -> (decodeFrames . encodeFrames) xs == Right xs + property' "encodeFrames is quasidistributive over mappend" \ (xs, ys) -> + BS.drop (BS.length (encodeFrames xs)) (encodeFrames (xs <> ys)) + == encodeFrames ys + diff --git a/hbs2-peer/app/EncryptionKeys.hs b/hbs2-peer/app/EncryptionKeys.hs index dd524d5d..c06dd667 100644 --- a/hbs2-peer/app/EncryptionKeys.hs +++ b/hbs2-peer/app/EncryptionKeys.hs @@ -56,15 +56,14 @@ encryptionHandshakeWorker :: forall e m s . -- , HasCredentials s m ) => PeerConfig - -> PeerEnv e -> PeerCredentials s -> EncryptionHandshakeAdapter e m s -> m () -encryptionHandshakeWorker pconf penv creds EncryptionHandshakeAdapter{..} = do +encryptionHandshakeWorker pconf creds EncryptionHandshakeAdapter{..} = do -- e :: PeerEnv e <- ask - let ourpubkey = pubKeyFromKeypair @s $ _envAsymmetricKeyPair penv + ourpubkey <- pure $ pubKeyFromKeypair @s $ encAsymmetricKeyPair pl <- getPeerLocator @e @@ -75,9 +74,9 @@ encryptionHandshakeWorker pconf penv creds EncryptionHandshakeAdapter{..} = do forM_ peers \peer -> do -- Только если ещё не знаем ключ ноды - mpeerData <- find (KnownPeerKey peer) id - mkey <- liftIO do - join <$> forM mpeerData \peerData -> getEncryptionKey penv peerData + mencKeyID <- (fmap . fmap) encryptionKeyIDKeyFromPeerData $ + find (KnownPeerKey peer) id + mkey <- join <$> mapM encGetEncryptionKey mencKeyID case mkey of Just _ -> pure () Nothing -> sendBeginEncryptionExchange @e creds ourpubkey peer diff --git a/hbs2-peer/app/PeerMain.hs b/hbs2-peer/app/PeerMain.hs index 2f3f3588..1533bc4d 100644 --- a/hbs2-peer/app/PeerMain.hs +++ b/hbs2-peer/app/PeerMain.hs @@ -448,7 +448,7 @@ runPeer :: forall e s . ( e ~ L4Proto , FromStringMaybe (PeerAddr e) , s ~ Encryption e , HasStorage (PeerM e IO) - ) => PeerOpts -> IO () + )=> PeerOpts -> IO () runPeer opts = Exception.handle (\e -> myException e >> performGC @@ -574,32 +574,35 @@ runPeer opts = Exception.handle (\e -> myException e pure $ Just tcpEnv (proxy, penv) <- mdo - proxy <- newProxyMessaging mess tcp >>= \peer -> pure peer + proxy <- newProxyMessaging mess tcp >>= \proxy' -> pure proxy' { _proxy_getEncryptionKey = \peer -> do - mpeerData <- withPeerM penv $ find (KnownPeerKey peer) id - mkey <- join <$> forM mpeerData \peerData -> getEncryptionKey penv peerData + mencKeyID <- (fmap . fmap) encryptionKeyIDKeyFromPeerData $ + withPeerM penv $ find (KnownPeerKey peer) id + mkey <- join <$> forM mencKeyID \encKeyID -> + getEncryptionKey proxy encKeyID case mkey of Nothing -> trace1 $ "ENCRYPTION empty getEncryptionKey" - <+> pretty peer <+> viaShow mpeerData + <+> pretty peer <+> viaShow mencKeyID Just k -> trace1 $ "ENCRYPTION success getEncryptionKey" - <+> pretty peer <+> viaShow mpeerData <+> viaShow k + <+> pretty peer <+> viaShow mencKeyID <+> viaShow k pure mkey , _proxy_clearEncryptionKey = \peer -> do - mpeerData <- withPeerM penv $ find (KnownPeerKey peer) id - forM_ mpeerData \peerData -> setEncryptionKey penv peer peerData Nothing + mencKeyID <- (fmap . fmap) encryptionKeyIDKeyFromPeerData $ + withPeerM penv $ find (KnownPeerKey peer) id + forM_ mencKeyID \encKeyID -> setEncryptionKey proxy peer encKeyID Nothing -- deletePeerAsymmKey brains peer - forM_ mpeerData \peerData -> - deletePeerAsymmKey' brains (show peerData) + forM_ mencKeyID \encKeyID -> + deletePeerAsymmKey' brains (show encKeyID) , _proxy_sendResetEncryptionKeys = \peer -> withPeerM penv do sendResetEncryptionKeys peer , _proxy_sendBeginEncryptionExchange = \peer -> withPeerM penv do sendBeginEncryptionExchange pc - ((pubKeyFromKeypair @s . view envAsymmetricKeyPair) penv) + ((pubKeyFromKeypair @s . _proxy_asymmetricKeyPair) proxy) peer } @@ -687,27 +690,32 @@ runPeer opts = Exception.handle (\e -> myException e ) => EncryptionHandshakeAdapter L4Proto m s encryptionHshakeAdapter = EncryptionHandshakeAdapter { encHandshake_considerPeerAsymmKey = \peer mpubkey -> withPeerM penv do - mpeerData <- withPeerM penv $ find (KnownPeerKey peer) id + mencKeyID <- (fmap . fmap) encryptionKeyIDKeyFromPeerData $ + withPeerM penv $ find (KnownPeerKey peer) id case mpubkey of Nothing -> do - -- trace $ "ENCRYPTION delete key" <+> pretty peer <+> viaShow mpeerData + -- trace $ "ENCRYPTION delete key" <+> pretty peer <+> viaShow mencKeyID -- deletePeerAsymmKey brains peer - forM_ mpeerData \peerData -> - deletePeerAsymmKey' brains (show peerData) + forM_ mencKeyID \encKeyID -> + deletePeerAsymmKey' brains (show encKeyID) Just pk -> do -- emit PeerAsymmInfoKey (PeerAsymmPubKey peer pk) let symmk = genCommonSecret @s - (privKeyFromKeypair @s (view envAsymmetricKeyPair penv)) + (privKeyFromKeypair @s (_proxy_asymmetricKeyPair proxy)) pk - case mpeerData of + case mencKeyID of Nothing -> do -- insertPeerAsymmKey brains peer pk symmk -- insertPeerAsymmKey' brains (show peer) pk symmk - trace $ "ENCRYPTION can not store key. No peerData" - <+> pretty peer <+> viaShow mpeerData - Just peerData -> do - liftIO $ setEncryptionKey penv peer peerData (Just symmk) - insertPeerAsymmKey' brains (show peerData) pk symmk + trace $ "ENCRYPTION can not store key. No encKeyID" + <+> pretty peer <+> viaShow mencKeyID + Just encKeyID -> do + liftIO $ setEncryptionKey proxy peer encKeyID (Just symmk) + insertPeerAsymmKey' brains (show encKeyID) pk symmk + + , encAsymmetricKeyPair = _proxy_asymmetricKeyPair proxy + + , encGetEncryptionKey = liftIO . getEncryptionKey proxy } @@ -724,11 +732,12 @@ runPeer opts = Exception.handle (\e -> myException e addPeers @e pl ps subscribe @e PeerExpiredEventKey \(PeerExpiredEvent peer {-mpeerData-}) -> liftIO do - mpeerData <- withPeerM penv $ find (KnownPeerKey peer) id - forM_ mpeerData \peerData -> setEncryptionKey penv peer peerData Nothing + mencKeyID <- (fmap . fmap) encryptionKeyIDKeyFromPeerData $ + withPeerM penv $ find (KnownPeerKey peer) id + forM_ mencKeyID \encKeyID -> setEncryptionKey proxy peer encKeyID Nothing -- deletePeerAsymmKey brains peer - forM_ mpeerData \peerData -> - deletePeerAsymmKey' brains (show peerData) + forM_ mencKeyID \encKeyID -> + deletePeerAsymmKey' brains (show encKeyID) subscribe @e PeerAnnounceEventKey $ \(PeerAnnounceEvent pip nonce) -> do unless (nonce == pnonce) $ do @@ -871,7 +880,7 @@ runPeer opts = Exception.handle (\e -> myException e peerThread "blockDownloadLoop" (blockDownloadLoop denv) peerThread "encryptionHandshakeWorker" - (EncryptionKeys.encryptionHandshakeWorker @e conf penv pc encryptionHshakeAdapter) + (EncryptionKeys.encryptionHandshakeWorker @e conf pc encryptionHshakeAdapter) let tcpProbeWait :: Timeout 'Seconds tcpProbeWait = (fromInteger . fromMaybe 300) (cfgValue @PeerTcpProbeWaitKey conf) @@ -991,7 +1000,7 @@ runPeer opts = Exception.handle (\e -> myException e , makeResponse (blockChunksProto adapter) , makeResponse blockAnnounceProto , makeResponse (withCredentials @e pc . peerHandShakeProto hshakeAdapter penv) - , makeResponse (withCredentials @e pc . encryptionHandshakeProto encryptionHshakeAdapter penv) + , makeResponse (withCredentials @e pc . encryptionHandshakeProto encryptionHshakeAdapter) , makeResponse (peerExchangeProto pexFilt) , makeResponse (refLogUpdateProto reflogAdapter) , makeResponse (refLogRequestProto reflogReqAdapter) diff --git a/hbs2-peer/app/PeerMain/DialogCliCommand.hs b/hbs2-peer/app/PeerMain/DialogCliCommand.hs index ff6f27fe..bbfbc13f 100644 --- a/hbs2-peer/app/PeerMain/DialogCliCommand.hs +++ b/hbs2-peer/app/PeerMain/DialogCliCommand.hs @@ -2,81 +2,32 @@ module PeerMain.DialogCliCommand where --- import Data.Generics.Labels --- import Data.Generics.Product.Fields +import Data.Generics.Labels +import Data.Generics.Product.Fields import HBS2.Actors.Peer -import HBS2.Base58 -import HBS2.Clock -import HBS2.Net.Proto.RefLog (RefLogKey(..)) -import HBS2.Defaults -import HBS2.Events -import HBS2.Hash -import HBS2.Merkle -import HBS2.Net.Auth.Credentials import HBS2.Net.IP.Addr -import HBS2.Net.Messaging -import HBS2.Net.Messaging.TCP import HBS2.Net.Messaging.UDP -import HBS2.Net.PeerLocator import HBS2.Net.Proto -import HBS2.Net.Proto.Definition import HBS2.Net.Proto.Dialog -import HBS2.Net.Proto.Peer -import HBS2.Net.Proto.PeerAnnounce -import HBS2.Net.Proto.PeerExchange -import HBS2.Net.Proto.PeerMeta -import HBS2.Net.Proto.RefLog -import HBS2.Net.Proto.Sessions -import HBS2.Net.Proto.Types import HBS2.OrDie import HBS2.Prelude -import HBS2.Prelude.Plated -import HBS2.Storage.Simple import HBS2.System.Logger.Simple hiding (info) -import HBS2.System.Logger.Simple qualified as Log -import BlockDownload -import BlockHttpDownload -import Bootstrap -import Brains -import CheckMetrics -import DownloadQ -import HttpWorker import PeerConfig -import PeerInfo -import PeerMeta -import PeerTypes -import ProxyMessaging -import RefLog (reflogWorker) -import RefLog qualified import RPC -import Control.Monad -import Control.Monad.IO.Unlift -import Control.Monad.Reader import Control.Monad.Trans.Cont -import Control.Monad.Trans.Maybe -import Crypto.Saltine.Core.Box qualified as Encrypt -import Data.ByteString qualified as BS -import Data.ByteString.Char8 qualified as BS8 -import Data.ByteString.Lazy (ByteString) -import Data.ByteString.Lazy qualified as LBS import Data.Default import Data.Function import Data.Functor +import Data.Kind import Data.List qualified as List -import Data.Map.Strict qualified as Map -import Data.Maybe -import Data.Monoid qualified as Monoid -import Data.Set qualified as Set import Data.String.Conversions as X (cs) import Data.Void (absurd, Void) import Lens.Micro.Platform import Network.Socket import Options.Applicative -import Streaming as S import Streaming.Prelude qualified as S -import System.Directory import UnliftIO.Async import UnliftIO.Concurrent import UnliftIO.Exception as U @@ -84,7 +35,6 @@ import UnliftIO.Resource -- import System.FilePath.Posix import System.IO -import System.Exit pDialog :: Parser (IO ()) @@ -95,16 +45,16 @@ pDialog = hsubparser $ mempty confOpt :: Parser FilePath confOpt = strOption ( long "config" <> short 'c' <> help "config" ) -data OptInitial (f :: * -> *) a b = OptInitial { unOptInitial :: f a } +newtype OptInitial (f :: Type -> Type) a b = OptInitial { unOptInitial :: f a } deriving (Generic, Show) -data OptResolved (f :: * -> *) a b = OptResolved { unOptResolved :: b } +newtype OptResolved (f :: Type -> Type) a b = OptResolved { unOptResolved :: b } deriving (Generic, Show) type DialOptInitial = DialOpt OptInitial type DialOptResolved = DialOpt OptResolved -data DialOpt (f :: (* -> *) -> * -> * -> *) = DialOpt +data DialOpt (f :: (Type -> Type) -> Type -> Type -> Type) = DialOpt { dialOptConf :: f Maybe FilePath PeerConfig , dialOptAddr :: f Maybe String (Peer L4Proto) } @@ -133,7 +83,7 @@ resolveDialOpt dopt = do `orDieM` "Dial endpoint not set" as <- parseAddrUDP (cs saddr) <&> fmap (fromSockAddr @'UDP . addrAddress) - peer <- (headMay $ List.sortBy (compare `on` addrPriority) as) + peer <- headMay (List.sortBy (compare `on` addrPriority) as) `orDieM` "Can't parse Dial endpoint" pure DialOpt diff --git a/hbs2-peer/app/PeerMain/PeerDialog.hs b/hbs2-peer/app/PeerMain/PeerDialog.hs index 5da04012..7382bd53 100644 --- a/hbs2-peer/app/PeerMain/PeerDialog.hs +++ b/hbs2-peer/app/PeerMain/PeerDialog.hs @@ -6,7 +6,7 @@ import Data.Bool import Data.ByteString qualified as BS import Data.Map qualified as Map -import Dialog.Core +import HBS2.Net.Dialog.Core import HBS2.Net.Proto.Types diff --git a/hbs2-peer/app/PeerTypes.hs b/hbs2-peer/app/PeerTypes.hs index e0251e31..0ecd982b 100644 --- a/hbs2-peer/app/PeerTypes.hs +++ b/hbs2-peer/app/PeerTypes.hs @@ -415,15 +415,9 @@ mkPeerMeta conf penv = do . fromStringMay @(PeerAddr L4Proto) ) =<< cfgValue @PeerListenTCPKey conf - -- let useEncryption = True -- move to config annMetaFromPeerMeta . PeerMeta $ W.execWriter do mHttpPort `forM` \p -> elem "http-port" (TE.encodeUtf8 . Text.pack . show $ p) mTcpPort `forM` \p -> elem "listen-tcp" (TE.encodeUtf8 . Text.pack . show $ p) - -- when useEncryption do - -- elem "ekey" (TE.encodeUtf8 . Text.pack . show $ - -- (Encrypt.publicKey . _envAsymmetricKeyPair) penv - -- -- mayby sign this pubkey by node key ? - -- ) where elem k = W.tell . L.singleton . (k ,) diff --git a/hbs2-peer/app/ProxyMessaging.hs b/hbs2-peer/app/ProxyMessaging.hs index e2cf8d52..69076054 100644 --- a/hbs2-peer/app/ProxyMessaging.hs +++ b/hbs2-peer/app/ProxyMessaging.hs @@ -4,6 +4,9 @@ module ProxyMessaging , newProxyMessaging , runProxyMessaging , sendToPlainProxyMessaging + , getEncryptionKey + , setEncryptionKey + , encryptionKeyIDKeyFromPeerData ) where import HBS2.Prelude.Plated @@ -34,6 +37,7 @@ import Control.Monad.Trans.Maybe import Data.ByteString (ByteString) import Data.ByteString qualified as BS import Data.ByteString.Lazy qualified as LBS +import Data.Hashable hiding (Hashed) import Data.Maybe import Data.String.Conversions (cs) import Data.List qualified as L @@ -41,6 +45,10 @@ import Data.Map (Map) import Data.Map qualified as Map import Lens.Micro.Platform as Lens import Control.Monad +import Data.HashMap.Strict (HashMap) +import Data.HashMap.Strict qualified as HashMap + +import HBS2.Data.Types.Peer -- TODO: protocol-encryption-goes-here @@ -54,6 +62,9 @@ data ProxyMessaging = , _proxy_clearEncryptionKey :: Peer L4Proto -> IO () , _proxy_sendResetEncryptionKeys :: Peer L4Proto -> IO () , _proxy_sendBeginEncryptionExchange :: Peer L4Proto -> IO () + + , _proxy_asymmetricKeyPair :: AsymmKeypair (Encryption L4Proto) + , _proxy_encryptionKeys :: TVar (HashMap (EncryptionKeyIDKey L4Proto) (CommonSecret (Encryption L4Proto))) } -- 1 нода X создаёт себе Encrypt.Keypair @@ -78,8 +89,36 @@ newProxyMessaging u t = liftIO do let _proxy_sendResetEncryptionKeys = const (pure ()) let _proxy_sendBeginEncryptionExchange = const (pure ()) + _proxy_asymmetricKeyPair <- asymmNewKeypair @(Encryption L4Proto) + _proxy_encryptionKeys <- liftIO (newTVarIO mempty) + pure ProxyMessaging {..} +--- + +setEncryptionKey :: + ( Hashable (PubKey 'Sign (Encryption L4Proto)) + , Hashable PeerNonce + , Show (PubKey 'Sign (Encryption L4Proto)) + , Show PeerNonce + , Show (CommonSecret (Encryption L4Proto)) + , Show (EncryptionKeyIDKey L4Proto) + ) => ProxyMessaging -> Peer L4Proto -> EncryptionKeyIDKey L4Proto -> Maybe (CommonSecret (Encryption L4Proto)) -> IO () +setEncryptionKey proxy peer pd msecret = do + atomically $ modifyTVar' (_proxy_encryptionKeys proxy) $ Lens.at pd .~ msecret + case msecret of + Nothing -> trace $ "ENCRYPTION delete key" <+> pretty peer <+> viaShow pd + Just k -> trace $ "ENCRYPTION store key" <+> pretty peer <+> viaShow pd <+> viaShow k + +getEncryptionKey :: + ( Hashable (PubKey 'Sign (Encryption L4Proto)) + , Hashable PeerNonce + ) => ProxyMessaging -> EncryptionKeyIDKey L4Proto -> IO (Maybe (CommonSecret (Encryption L4Proto))) +getEncryptionKey proxy pd = + readTVarIO (_proxy_encryptionKeys proxy) <&> preview (Lens.ix pd) + +--- + runProxyMessaging :: forall m . MonadIO m => ProxyMessaging -> m () @@ -103,7 +142,6 @@ runProxyMessaging env = liftIO do liftIO $ mapM_ waitCatch [u,t] - instance Messaging ProxyMessaging L4Proto LBS.ByteString where sendTo = sendToProxyMessaging