wip, refchans+encryption, dev

hbs2-core/lib/HBS2/Actors/Peer.hs

@@ -302,7 +302,6 @@ instance ( MonadIO m
          , PeerMessaging e
          , HasTimeLimits e msg m
          , Show (Peer e)
-         , Show msg
          ) => Request e msg m where
   request peer_e msg = do
     let proto = protoId @e @msg (Proxy @msg)
@@ -318,8 +317,8 @@ instance ( MonadIO m
       -- liftIO $ print "request!"
     allowed <- tryLockForPeriod peer_e msg
 
-    when (not allowed) do
+    unless allowed do
-      trace $ "REQUEST: not allowed to send" <+> viaShow msg
+      trace $ "REQUEST: not allowed to send for proto" <+> viaShow proto
 
     when allowed do
       sendTo pipe (To peer_e) (From me) (AnyMessage @(Encoded e) @e proto (encode msg))

hbs2-core/lib/HBS2/Net/Proto/Definition.hs

@@ -7,7 +7,6 @@ module HBS2.Net.Proto.Definition
   where
 
 import HBS2.Clock
-import HBS2.Data.Types.Crypto
 import HBS2.Defaults
 import HBS2.Hash
 import HBS2.Net.Auth.Credentials
@@ -35,8 +34,6 @@ import Crypto.Saltine.Class qualified as Crypto
 import Crypto.Saltine.Core.Sign qualified as Sign
 import Crypto.Saltine.Core.Box qualified as Encrypt
 
-import HBS2.Data.Types.Crypto
-
 
 type instance Encryption L4Proto = HBS2Basic
 
@@ -52,11 +49,6 @@ type instance PrivKey 'Encrypt HBS2Basic = Encrypt.SecretKey
 --   но возможно, будет работать и так, ведь ключи
 --   это же всего лишь байтстроки внутри.
 
-instance Serialise Sign.PublicKey
-instance Serialise Encrypt.PublicKey
-instance Serialise Sign.SecretKey
-instance Serialise Encrypt.SecretKey
-
 deserialiseCustom :: (Serialise a, MonadPlus m) => ByteString -> m a
 deserialiseCustom = either (const mzero) pure . deserialiseOrFail
 -- deserialiseCustom = either (\msg -> trace ("deserialiseCustom: " <> show msg) mzero) pure . deserialiseOrFail
@@ -209,11 +201,8 @@ instance Expires (EventKey L4Proto (PeerAnnounce L4Proto)) where
 instance Expires (EventKey L4Proto (PeerMetaProto L4Proto)) where
   expiresIn _ = Just 600
 
--- instance MonadIO m => HasNonces () m where
+instance Expires (SessionKey L4Proto (EncryptionHandshake L4Proto)) where
---   type instance Nonce (PeerHandshake L4Proto) = BS.ByteString
+  expiresIn _ = Just defCookieTimeoutSec
---   newNonce = do
---     n <- liftIO ( Crypto.newNonce <&> Crypto.encode )
---     pure $ BS.take 32 n
 
 instance MonadIO m => HasNonces (PeerHandshake L4Proto) m where
   type instance Nonce (PeerHandshake L4Proto) = BS.ByteString
@@ -239,13 +228,6 @@ instance MonadIO m => HasNonces () m where
     n <- liftIO ( Crypto.newNonce <&> Crypto.encode )
     pure $ BS.take 32 n
 
-instance Serialise Sign.Signature
-
-instance Signatures HBS2Basic where
-  type Signature HBS2Basic = Sign.Signature
-  makeSign = Sign.signDetached
-  verifySign = Sign.signVerifyDetached
-
 instance Asymm HBS2Basic where
   type AsymmKeypair HBS2Basic = Encrypt.Keypair
   type AsymmPrivKey HBS2Basic = Encrypt.SecretKey

hbs2-core/lib/HBS2/Net/Proto/EncryptionHandshake.hs

@@ -83,7 +83,7 @@ encryptionHandshakeProto :: forall e s m .
     , Serialise (PubKey 'Encrypt (Encryption e))
     , s ~ Encryption e
     , e ~ L4Proto
-    , PubKey Encrypt s ~ Encrypt.PublicKey
+    , PubKey 'Encrypt s ~ Encrypt.PublicKey
     , Show (PubKey 'Sign s)
     , Show (Nonce ())
     )

hbs2-core/lib/HBS2/Net/Proto/RefChan.hs

@@ -5,8 +5,6 @@
 {-# LANGUAGE ImplicitParams #-}
 module HBS2.Net.Proto.RefChan where
 
--- import HBS2.Actors.Peer.Types
-import HBS2.Data.Types.Peer
 import HBS2.Prelude.Plated
 import HBS2.Hash
 import HBS2.Data.Detect
@@ -21,6 +19,7 @@ import HBS2.Net.Proto.BlockAnnounce
 import HBS2.Net.Proto.Sessions
 import HBS2.Data.Types.Refs
 import HBS2.Actors.Peer.Types
+import HBS2.Data.Types.Peer
 import HBS2.Storage
 
 import Data.Config.Suckless
@@ -153,9 +152,6 @@ data RefChanHead e =
   | RefChanGetHead (RefChanId e)
   deriving stock (Generic)
 
-instance Show (RefChanHead e) where
-  show _ = "RefChanHead"
-
 instance ForRefChans e => Serialise (RefChanHead e)
 
 
@@ -226,9 +222,6 @@ data RefChanUpdate e =
   | Accept  (RefChanId e) (SignedBox (AcceptTran e) e)  -- подписано ключом пира
   deriving stock (Generic)
 
-instance Show (RefChanUpdate e) where
-  show _ = "RefChanUpdate"
-
 instance ForRefChans e => Serialise (RefChanUpdate e)
 
 data RefChanRequest e =
@@ -236,9 +229,6 @@ data RefChanRequest e =
   | RefChanResponse (RefChanId e) HashRef
   deriving stock (Generic,Typeable)
 
-instance Show (RefChanRequest e) where
-  show _ = "RefChanRequest"
-
 instance ForRefChans e => Serialise (RefChanRequest e)
 
 data instance EventKey e (RefChanRequest e) =
@@ -488,89 +478,85 @@ refChanUpdateProto self pc adapter msg = do
         -- --  рассылаем ли себе? что бы был хоть один accept
         lift $ refChanUpdateProto True pc adapter accept
 
-     Accept chan box -> undefined
+     Accept chan box -> deferred proto do
-                          -- TODO: fix refchain
-      -- deferred proto do
 
---        debug $ "RefChanUpdate/ACCEPT" <+> pretty h0
+       debug $ "RefChanUpdate/ACCEPT" <+> pretty h0
 
---        (peerKey, AcceptTran headRef hashRef) <- MaybeT $ pure $ unboxSignedBox0 box
+       (peerKey, AcceptTran headRef hashRef) <- MaybeT $ pure $ unboxSignedBox0 box
 
---        let refchanKey = RefChanHeadKey @s chan
+       let refchanKey = RefChanHeadKey @s chan
---        h <- MaybeT $ liftIO $ getRef sto refchanKey
+       h <- MaybeT $ liftIO $ getRef sto refchanKey
 
---        guard (HashRef h == headRef)
+       guard (HashRef h == headRef)
 
---        lift $ gossip msg
+       lift $ gossip msg
 
---        -- тут может так случиться, что propose еще нет
+       -- тут может так случиться, что propose еще нет
---        -- UDP вообще не гарантирует порядок доставки, а отправляем мы транзы
+       -- UDP вообще не гарантирует порядок доставки, а отправляем мы транзы
---        -- почти одновременно. ну или не успело записаться. и что делать?
+       -- почти одновременно. ну или не успело записаться. и что делать?
 
---        here <- liftIO (hasBlock sto (fromHashRef hashRef)) <&> isJust
+       here <- liftIO (hasBlock sto (fromHashRef hashRef)) <&> isJust
 
---        unless here do
+       unless here do
---         warn $ "No propose transaction saved yet!" <+> pretty hashRef
+        warn $ "No propose transaction saved yet!" <+> pretty hashRef
 
---        tranBs <- MaybeT $ liftIO $ getBlock sto (fromHashRef hashRef)
+       tranBs <- MaybeT $ liftIO $ getBlock sto (fromHashRef hashRef)
 
---        tran <- MaybeT $ pure $ deserialiseOrFail @(RefChanUpdate e) tranBs & either (const Nothing) Just
+       tran <- MaybeT $ pure $ deserialiseOrFail @(RefChanUpdate e) tranBs & either (const Nothing) Just
 
---        headBlock <- MaybeT $ getActualRefChanHead @e refchanKey
+       headBlock <- MaybeT $ getActualRefChanHead @e refchanKey
 
---        proposed <- MaybeT $ pure $ case tran of
+       proposed <- MaybeT $ pure $ case tran of
---                       Propose _ pbox -> Just pbox
+                      Propose _ pbox -> Just pbox
---                       _              -> Nothing
+                      _              -> Nothing
 
 
---        (_, ptran) <- MaybeT $ pure $ unboxSignedBox0 @(ProposeTran e) @e proposed
+       (_, ptran) <- MaybeT $ pure $ unboxSignedBox0 @(ProposeTran e) @e proposed
 
---        debug $ "ACCEPT FROM:" <+> pretty (AsBase58 peerKey) <+> pretty h0
+       debug $ "ACCEPT FROM:" <+> pretty (AsBase58 peerKey) <+> pretty h0
 
---        -- compiler bug?
+       -- compiler bug?
---        let (ProposeTran _ pbox) = ptran
+       let (ProposeTran _ pbox) = ptran
 
---        (authorKey, _) <- MaybeT $ pure $ unboxSignedBox0 pbox
+       (authorKey, _) <- MaybeT $ pure $ unboxSignedBox0 pbox
 
---        -- может, и не надо второй раз проверять
+       -- может, и не надо второй раз проверять
---        guard $ checkACL headBlock peerKey authorKey
+       guard $ checkACL headBlock peerKey authorKey
 
---        debug $ "JUST GOT TRANSACTION FROM STORAGE! ABOUT TO CHECK IT" <+> pretty hashRef
+       debug $ "JUST GOT TRANSACTION FROM STORAGE! ABOUT TO CHECK IT" <+> pretty hashRef
 
---        rcRound <- MaybeT $ find (RefChanRoundKey @e hashRef) id
+       rcRound <- MaybeT $ find (RefChanRoundKey @e hashRef) id
 
---        atomically $ modifyTVar (view refChanRoundAccepts rcRound) (HashMap.insert peerKey ())
+       atomically $ modifyTVar (view refChanRoundAccepts rcRound) (HashMap.insert peerKey ())
 
---        -- TODO: garbage-collection-strongly-required
+       -- TODO: garbage-collection-strongly-required
---        ha <- MaybeT $ liftIO $ putBlock sto (serialise msg)
+       ha <- MaybeT $ liftIO $ putBlock sto (serialise msg)
 
---        atomically $ modifyTVar (view refChanRoundTrans rcRound) (HashSet.insert (HashRef ha))
+       atomically $ modifyTVar (view refChanRoundTrans rcRound) (HashSet.insert (HashRef ha))
---        -- atomically $ modifyTVar (view refChanRoundTrans rcRound) (HashSet.insert hashRef) -- propose just in case we missed it?
+       -- atomically $ modifyTVar (view refChanRoundTrans rcRound) (HashSet.insert hashRef) -- propose just in case we missed it?
 
---        accepts <- atomically $ readTVar (view refChanRoundAccepts rcRound) <&> HashMap.size
+       accepts <- atomically $ readTVar (view refChanRoundAccepts rcRound) <&> HashMap.size
 
---        debug $ "ACCEPTS:" <+> pretty accepts
+       debug $ "ACCEPTS:" <+> pretty accepts
 
---        closed <- readTVarIO (view refChanRoundClosed rcRound)
+       closed <- readTVarIO (view refChanRoundClosed rcRound)
 
---        -- FIXME: round!
+       -- FIXME: round!
---        when (fromIntegral accepts >= view refChanHeadQuorum headBlock && not closed) do
+       when (fromIntegral accepts >= view refChanHeadQuorum headBlock && not closed) do
---          debug $ "ROUND!" <+> pretty accepts <+> pretty hashRef
+         debug $ "ROUND!" <+> pretty accepts <+> pretty hashRef
 
---          trans <- atomically $ readTVar (view refChanRoundTrans rcRound) <&> HashSet.toList
+         trans <- atomically $ readTVar (view refChanRoundTrans rcRound) <&> HashSet.toList
 
---          forM_ trans $ \t -> do
+         forM_ trans $ \t -> do
---           lift $ refChanWriteTran adapter t
+          lift $ refChanWriteTran adapter t
---           debug $ "WRITING TRANS" <+> pretty t
+          debug $ "WRITING TRANS" <+> pretty t
 
---          let pips  = view refChanHeadPeers headBlock & HashMap.keys & HashSet.fromList
+         let pips  = view refChanHeadPeers headBlock & HashMap.keys & HashSet.fromList
---          votes <- readTVarIO (view refChanRoundAccepts rcRound) <&> HashSet.fromList . HashMap.keys
+         votes <- readTVarIO (view refChanRoundAccepts rcRound) <&> HashSet.fromList . HashMap.keys
 
---          when (pips `HashSet.isSubsetOf` votes) do
+         when (pips `HashSet.isSubsetOf` votes) do
---           debug $ "CLOSING ROUND" <+> pretty hashRef <+> pretty (length trans)
+          debug $ "CLOSING ROUND" <+> pretty hashRef <+> pretty (length trans)
---           atomically $ writeTVar (view refChanRoundClosed rcRound) True
+          atomically $ writeTVar (view refChanRoundClosed rcRound) True
-
---       lift $ refChanUpdateProto True pc adapter msg
 
   where
     proto = Proxy @(RefChanUpdate e)

hbs2-core/lib/HBS2/Net/Proto/Types.hs

@@ -111,8 +111,7 @@ data ReqLimPeriod = NoLimit
                   | ReqLimPerProto   (Timeout 'Seconds)
                   | ReqLimPerMessage (Timeout 'Seconds)
 
-class (KnownNat (ProtocolId p), HasPeer e, Show (Encoded e)
+class (KnownNat (ProtocolId p), HasPeer e ) => HasProtocol e p | p -> e  where
-    ) => HasProtocol e p | p -> e  where
   type family ProtocolId p = (id :: Nat) | id -> p
   type family Encoded e :: Type
 

hbs2-peer/app/EncryptionKeys.hs

@@ -16,6 +16,7 @@ import HBS2.Net.Proto.Peer
 import HBS2.Net.Proto.Sessions
 import HBS2.Prelude.Plated
 import HBS2.Storage
+import HBS2.Net.Proto.Definition()
 import HBS2.System.Logger.Simple
 
 import PeerConfig
@@ -48,7 +49,7 @@ encryptionHandshakeWorker :: forall e m s .
     -- , HasPeer e
     -- , HasNonces (EncryptionHandshake e) m
     -- , Request e (EncryptionHandshake e) m
-    -- , Sessions e (EncryptionHandshake e) m
+    , Sessions e (EncryptionHandshake e) m
     -- , Sessions e (PeerInfo e) m
     -- , Sessions e (KnownPeer e) m
     -- , Pretty (Peer e)
@@ -80,3 +81,4 @@ encryptionHandshakeWorker pconf penv creds EncryptionHandshakeAdapter{..} = do
             case mkey of
                 Just _ -> pure ()
                 Nothing -> sendBeginEncryptionExchange @e creds ourpubkey peer
+