mirror of https://github.com/voidlizard/hbs2
167 lines
4.8 KiB
Haskell
167 lines
4.8 KiB
Haskell
{-# Language TemplateHaskell #-}
|
||
{-# Language UndecidableInstances #-}
|
||
module HBS2.Net.Proto.Peer where
|
||
|
||
import HBS2.Base58
|
||
import HBS2.Data.Types
|
||
import HBS2.Events
|
||
import HBS2.Net.Proto
|
||
import HBS2.Clock
|
||
import HBS2.Net.Proto.Sessions
|
||
import HBS2.Prelude.Plated
|
||
|
||
import Data.Maybe
|
||
import Codec.Serialise()
|
||
import Data.ByteString qualified as BS
|
||
import Data.Hashable
|
||
import Lens.Micro.Platform
|
||
import Type.Reflection (someTypeRep)
|
||
|
||
import Prettyprinter
|
||
|
||
type PingSign e = Signature e
|
||
type PingNonce = BS.ByteString
|
||
|
||
newtype PeerData e =
|
||
PeerData
|
||
{ _peerSignKey :: PubKey 'Sign e
|
||
}
|
||
deriving stock (Typeable,Generic)
|
||
|
||
makeLenses 'PeerData
|
||
|
||
data PeerHandshake e =
|
||
PeerPing PingNonce
|
||
| PeerPong (Signature e) (PeerData e)
|
||
deriving stock (Generic)
|
||
|
||
newtype KnownPeer e = KnownPeer (PeerData e)
|
||
deriving stock (Typeable,Generic)
|
||
|
||
newtype instance SessionKey e (KnownPeer e) =
|
||
KnownPeerKey (Peer e)
|
||
deriving stock (Generic,Typeable)
|
||
|
||
type instance SessionData e (KnownPeer e) = KnownPeer e
|
||
|
||
newtype instance SessionKey e (PeerHandshake e) =
|
||
PeerHandshakeKey (Peer e)
|
||
deriving stock (Generic, Typeable)
|
||
|
||
type instance SessionData e (PeerHandshake e) = PingNonce
|
||
|
||
|
||
|
||
sendPing :: forall e m . ( MonadIO m
|
||
, Request e (PeerHandshake e) m
|
||
, Sessions e (PeerHandshake e) m
|
||
, HasNonces (PeerHandshake e) m
|
||
, Nonce (PeerHandshake e) ~ PingNonce
|
||
, Pretty (Peer e)
|
||
)
|
||
=> Peer e -> m ()
|
||
|
||
sendPing pip = do
|
||
nonce <- newNonce @(PeerHandshake e)
|
||
update nonce (PeerHandshakeKey pip) id
|
||
liftIO $ print $ "sendPing" <+> pretty pip <+> pretty (AsBase58 nonce)
|
||
request pip (PeerPing @e nonce)
|
||
|
||
peerHandShakeProto :: forall e m . ( MonadIO m
|
||
, Response e (PeerHandshake e) m
|
||
, Request e (PeerHandshake e) m
|
||
, Sessions e (PeerHandshake e) m
|
||
, Sessions e (KnownPeer e) m
|
||
, HasNonces (PeerHandshake e) m
|
||
, Nonce (PeerHandshake e) ~ PingNonce
|
||
, Signatures e
|
||
, Pretty (Peer e)
|
||
, HasCredentials e m
|
||
, EventEmitter e (PeerHandshake e) m
|
||
)
|
||
=> PeerHandshake e -> m ()
|
||
|
||
peerHandShakeProto =
|
||
\case
|
||
PeerPing nonce -> do
|
||
pip <- thatPeer proto
|
||
-- TODO: взять свои ключи
|
||
creds <- getCredentials @e
|
||
liftIO $ print $ "PING" <+> pretty pip <+> pretty (AsBase58 nonce)
|
||
|
||
-- TODO: подписать нонс
|
||
let sign = makeSign @e (view peerSignSk creds) nonce
|
||
|
||
-- TODO: отправить обратно вместе с публичным ключом
|
||
response (PeerPong @e sign (PeerData (view peerSignPk creds)))
|
||
|
||
-- TODO: да и пингануть того самим
|
||
|
||
se <- find (KnownPeerKey pip) id <&> isJust
|
||
|
||
unless se $ do
|
||
sendPing pip
|
||
|
||
PeerPong sign d -> do
|
||
pip <- thatPeer proto
|
||
|
||
se' <- find @e (PeerHandshakeKey pip) id
|
||
|
||
maybe1 se' (pure ()) $ \nonce -> do
|
||
liftIO $ print $ pretty "PONG" <+> pretty (AsBase58 nonce)
|
||
|
||
let pk = view peerSignKey d
|
||
|
||
let signed = verifySign @e pk sign nonce
|
||
|
||
liftIO $ print $ "SIGNED: " <+> pretty signed
|
||
|
||
expire (PeerHandshakeKey pip)
|
||
|
||
update (KnownPeer d) (KnownPeerKey pip) id
|
||
|
||
emit KnownPeerEventKey (KnownPeerEvent pip d)
|
||
|
||
where
|
||
proto = Proxy @(PeerHandshake e)
|
||
|
||
|
||
data instance EventKey e (PeerHandshake e) =
|
||
KnownPeerEventKey
|
||
deriving stock (Typeable, Eq,Generic)
|
||
|
||
data instance Event e (PeerHandshake e) =
|
||
KnownPeerEvent (Peer e) (PeerData e)
|
||
deriving stock (Typeable)
|
||
|
||
instance Typeable (KnownPeer e) => Hashable (EventKey e (KnownPeer e)) where
|
||
hashWithSalt salt _ = hashWithSalt salt (someTypeRep p)
|
||
where
|
||
p = Proxy @(KnownPeer e)
|
||
|
||
instance EventType ( Event e ( PeerHandshake e) ) where
|
||
isPersistent = True
|
||
|
||
instance Expires (EventKey e (PeerHandshake e)) where
|
||
expiresIn _ = Nothing
|
||
|
||
instance Hashable (Peer e) => Hashable (EventKey e (PeerHandshake e))
|
||
|
||
deriving instance Eq (Peer e) => Eq (SessionKey e (KnownPeer e))
|
||
instance Hashable (Peer e) => Hashable (SessionKey e (KnownPeer e))
|
||
|
||
deriving instance Eq (Peer e) => Eq (SessionKey e (PeerHandshake e))
|
||
instance Hashable (Peer e) => Hashable (SessionKey e (PeerHandshake e))
|
||
|
||
instance ( Serialise (PubKey 'Sign e)
|
||
, Serialise (Signature e) )
|
||
|
||
=> Serialise (PeerData e)
|
||
|
||
instance ( Serialise (PubKey 'Sign e)
|
||
, Serialise (Signature e)
|
||
)
|
||
|
||
=> Serialise (PeerHandshake e)
|
||
|