Encrypted channels negotiated with DH

6 files changed, 354 insertions, 64 deletions

diff --git a/erebos.cabal b/erebos.cabal
index a51e61a..259f9b6 100644
--- a/erebos.cabal
+++ b/erebos.cabal
@@ -19,6 +19,7 @@ executable erebos
   ghc-options:         -Wall
   main-is:             Main.hs
   other-modules:       Identity,
+                       Channel,
                        Network,
                        PubKey,
                        Storage,
@@ -29,6 +30,7 @@ executable erebos
                        FlexibleInstances,
                        FunctionalDependencies,
                        LambdaCase,
+                       ScopedTypeVariables,
                        TupleSections
 
   -- other-extensions:
@@ -37,7 +39,6 @@ executable erebos
                        bytestring >=0.10 && <0.11,
                        cereal >= 0.5 && <0.6,
                        containers >= 0.6 && <0.7,
-                       crypto-api >= 0.13 && <0.14,
                        cryptonite >=0.25 && <0.26,
                        directory >= 1.3 && <1.4,
                        filepath >=1.4 && <1.5,
diff --git a/src/Channel.hs b/src/Channel.hs
new file mode 100644
index 0000000..ee10e89
--- /dev/null
+++ b/src/Channel.hs
@@ -0,0 +1,152 @@
+module Channel (
+    Channel,
+    ChannelRequest, ChannelRequestData(..),
+    ChannelAccept, ChannelAcceptData(..),
+
+    createChannelRequest,
+    acceptChannelRequest,
+    acceptedChannel,
+
+    channelEncrypt,
+    channelDecrypt,
+) where
+
+import Control.Monad
+import Control.Monad.Except
+import Control.Monad.Fail
+
+import Crypto.Cipher.AES
+import Crypto.Cipher.Types
+import Crypto.Data.Padding
+import Crypto.Error
+import Crypto.Random
+
+import Data.ByteArray
+import qualified Data.ByteArray as BA
+import Data.ByteString (ByteString)
+import qualified Data.ByteString as B
+import Data.List
+import qualified Data.Text as T
+
+import Identity
+import PubKey
+import Storage
+
+data Channel = Channel
+    { chPeers :: [Stored Identity]
+    , chKey :: ScrubbedBytes
+    }
+    deriving (Show)
+
+type ChannelRequest = Signed ChannelRequestData
+
+data ChannelRequestData = ChannelRequest
+    { crPeers :: [Stored Identity]
+    , crKey :: Stored PublicKexKey
+    }
+
+type ChannelAccept = Signed ChannelAcceptData
+
+data ChannelAcceptData = ChannelAccept
+    { caRequest :: Stored ChannelRequest
+    , caKey :: Stored PublicKexKey
+    }
+
+
+instance Storable Channel where
+    store' ch = storeRec $ do
+        mapM_ (storeRef "peer") $ chPeers ch
+        storeText "enc" $ T.pack "aes-128-gcm"
+        storeBinary "key" $ chKey ch
+
+    load' = loadRec $ do
+        enc <- loadText "enc"
+        guard $ enc == "aes-128-gcm"
+        Channel
+            <$> loadRefs "peer"
+            <*> loadBinary "key"
+
+instance Storable ChannelRequestData where
+    store' cr = storeRec $ do
+        mapM_ (storeRef "peer") $ crPeers cr
+        storeRef "key" $ crKey cr
+
+    load' = loadRec $ ChannelRequest
+        <$> loadRefs "peer"
+        <*> loadRef "key"
+
+instance Storable ChannelAcceptData where
+    store' ca = storeRec $ do
+        storeRef "req" $ caRequest ca
+        storeText "enc" $ T.pack "aes-128-gcm"
+        storeRef "key" $ caKey ca
+
+    load' = loadRec $ do
+        enc <- loadText "enc"
+        guard $ enc == "aes-128-gcm"
+        ChannelAccept
+            <$> loadRef "req"
+            <*> loadRef "key"
+
+
+createChannelRequest :: Stored Identity -> Stored Identity -> IO (Stored ChannelRequest)
+createChannelRequest self peer = do
+    let st = storedStorage self
+    (_, xpublic) <- generateKeys st
+    Just skey <- loadKey $ idKeyMessage $ fromStored $ signedData $ fromStored self
+    wrappedStore st =<< sign skey =<< wrappedStore st ChannelRequest { crPeers = sort [self, peer], crKey = xpublic }
+
+acceptChannelRequest :: Stored Identity -> Stored Identity -> Stored ChannelRequest -> ExceptT [String] IO (Stored ChannelAccept, Stored Channel)
+acceptChannelRequest self peer req = do
+    guard $ (crPeers $ fromStored $ signedData $ fromStored req) == sort [self, peer]
+    guard $ (idKeyMessage $ fromStored $ signedData $ fromStored peer) `elem` (map (sigKey . fromStored) $ signedSignature $ fromStored req)
+
+    let st = storedStorage self
+        KeySizeFixed ksize = cipherKeySize (undefined :: AES128)
+    liftIO $ do
+        (xsecret, xpublic) <- generateKeys st
+        Just skey <- loadKey $ idKeyMessage $ fromStored $ signedData $ fromStored self
+        acc <- wrappedStore st =<< sign skey =<< wrappedStore st ChannelAccept { caRequest = req, caKey = xpublic }
+        ch <- wrappedStore st Channel
+            { chPeers = crPeers $ fromStored $ signedData $ fromStored req
+            , chKey = BA.take ksize $ dhSecret xsecret $
+                fromStored $ crKey $ fromStored $ signedData $ fromStored req
+            }
+        return (acc, ch)
+
+acceptedChannel :: Stored Identity -> Stored Identity -> Stored ChannelAccept -> ExceptT [String] IO (Stored Channel)
+acceptedChannel self peer acc = do
+    let st = storedStorage self
+        req = caRequest $ fromStored $ signedData $ fromStored acc
+        KeySizeFixed ksize = cipherKeySize (undefined :: AES128)
+
+    guard $ (crPeers $ fromStored $ signedData $ fromStored req) == sort [self, peer]
+    guard $ (idKeyMessage $ fromStored $ signedData $ fromStored peer) `elem` (map (sigKey . fromStored) $ signedSignature $ fromStored acc)
+    guard $ (idKeyMessage $ fromStored $ signedData $ fromStored self) `elem` (map (sigKey . fromStored) $ signedSignature $ fromStored req)
+
+    Just xsecret <- liftIO $ loadKey $ crKey $ fromStored $ signedData $ fromStored req
+    liftIO $ wrappedStore st Channel
+        { chPeers = crPeers $ fromStored $ signedData $ fromStored req
+        , chKey = BA.take ksize $ dhSecret xsecret $
+            fromStored $ caKey $ fromStored $ signedData $ fromStored acc
+        }
+
+
+channelEncrypt :: (ByteArray ba, MonadRandom m, MonadFail m) => Channel -> ba -> m ba
+channelEncrypt ch plain = do
+    CryptoPassed (cipher :: AES128) <- return $ cipherInit $ chKey ch
+    let bsize = blockSize cipher
+    (iv :: ByteString) <- getRandomBytes bsize
+    CryptoPassed aead <- return $ aeadInit AEAD_GCM cipher iv
+    let (tag, ctext) = aeadSimpleEncrypt aead B.empty (pad (PKCS7 bsize) plain) bsize
+    return $ BA.concat [ convert iv, convert tag, ctext ]
+
+channelDecrypt :: (ByteArray ba, MonadFail m) => Channel -> ba -> m ba
+channelDecrypt ch body = do
+    CryptoPassed (cipher :: AES128) <- return $ cipherInit $ chKey ch
+    let bsize = blockSize cipher
+        (iv, body') = BA.splitAt bsize body
+        (tag, ctext) = BA.splitAt bsize body'
+    CryptoPassed aead <- return $ aeadInit AEAD_GCM cipher iv
+    Just plain <- return $ unpad (PKCS7 bsize) =<< aeadSimpleDecrypt aead B.empty ctext (AuthTag $ convert tag)
+    return plain
diff --git a/src/Identity.hs b/src/Identity.hs
index 07356d8..c1561b6 100644
--- a/src/Identity.hs
+++ b/src/Identity.hs
@@ -15,15 +15,17 @@ data IdentityData = Identity
     , idPrev :: Maybe (Stored Identity)
     , idOwner :: Maybe (Stored Identity)
     , idKeyIdentity :: Stored PublicKey
+    , idKeyMessage :: Stored PublicKey
     }
     deriving (Show)
 
-emptyIdentity :: Stored PublicKey -> IdentityData
-emptyIdentity key = Identity
+emptyIdentity :: Stored PublicKey -> Stored PublicKey -> IdentityData
+emptyIdentity key kmsg = Identity
     { idName = Nothing
     , idPrev = Nothing
     , idOwner = Nothing
     , idKeyIdentity = key
+    , idKeyMessage = kmsg
     }
 
 instance Storable IdentityData where
@@ -32,9 +34,11 @@ instance Storable IdentityData where
         storeMbRef "prev" $ idPrev idt
         storeMbRef "owner" $ idOwner idt
         storeRef "key-id" $ idKeyIdentity idt
+        storeRef "key-msg" $ idKeyMessage idt
 
     load' = loadRec $ Identity
         <$> loadMbText "name"
         <*> loadMbRef "prev"
         <*> loadMbRef "owner"
         <*> loadRef "key-id"
+        <*> loadRef "key-msg"
diff --git a/src/Main.hs b/src/Main.hs
index 40540fe..2a4dc4e 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -26,11 +26,13 @@ main = do
         name <- T.getLine
 
         (secret, public) <- generateKeys st
+        (_secretMsg, publicMsg) <- generateKeys st
         (devSecret, devPublic) <- generateKeys st
+        (_devSecretMsg, devPublicMsg) <- generateKeys st
 
-        owner <- wrappedStore st =<< sign secret =<< wrappedStore st (emptyIdentity public) { idName = Just name }
+        owner <- wrappedStore st =<< sign secret =<< wrappedStore st (emptyIdentity public publicMsg) { idName = Just name }
         base <- signAdd devSecret =<< sign secret =<<
-            wrappedStore st (emptyIdentity devPublic) { idOwner = Just owner }
+            wrappedStore st (emptyIdentity devPublic devPublicMsg) { idOwner = Just owner }
 
         Right h <- replaceHead base (Left (st, "identity"))
         return h
diff --git a/src/Network.hs b/src/Network.hs
index f294835..1056265 100644
--- a/src/Network.hs
+++ b/src/Network.hs
@@ -11,12 +11,15 @@ import Control.Monad.Except
 
 import qualified Data.ByteString.Char8 as BC
 import qualified Data.ByteString.Lazy as BL
+import qualified Data.Map as M
 import qualified Data.Text as T
 
 import Network.Socket
 import Network.Socket.ByteString (recvFrom, sendTo)
 
+import Channel
 import Identity
+import PubKey
 import Storage
 
 
@@ -25,8 +28,9 @@ discoveryPort = "29665"
 
 
 data Peer = Peer
-    { peerIdentity :: Stored Identity
-    , peerAddress :: PeerAddress
+    { peerAddress :: PeerAddress
+    , peerIdentity :: Maybe (Stored Identity)
+    , peerChannels :: [Channel]
     }
     deriving (Show)
 
@@ -37,6 +41,8 @@ data PeerAddress = DatagramAddress SockAddr
 data TransportHeader = AnnouncePacket Ref
                      | IdentityRequest Ref Ref
                      | IdentityResponse Ref
+                     | TrChannelRequest Ref
+                     | TrChannelAccept Ref
 
 transportToObject :: TransportHeader -> Object
 transportToObject = \case
@@ -53,6 +59,14 @@ transportToObject = \case
         [ (BC.pack "TRANS", RecText $ T.pack "idresp")
         , (BC.pack "identity", RecRef ref)
         ]
+    TrChannelRequest ref -> Rec
+        [ (BC.pack "TRANS", RecText $ T.pack "chreq")
+        , (BC.pack "req", RecRef ref)
+        ]
+    TrChannelAccept ref -> Rec
+        [ (BC.pack "TRANS", RecText $ T.pack "chacc")
+        , (BC.pack "acc", RecRef ref)
+        ]
 
 transportFromObject :: Object -> Maybe TransportHeader
 transportFromObject (Rec items)
@@ -69,71 +83,152 @@ transportFromObject (Rec items)
     , Just (RecRef ref) <- lookup (BC.pack "identity") items
     = Just $ IdentityResponse ref
 
+    | Just (RecText trans) <- lookup (BC.pack "TRANS") items, trans == T.pack "chreq"
+    , Just (RecRef ref) <- lookup (BC.pack "req") items
+    = Just $ TrChannelRequest ref
+
+    | Just (RecText trans) <- lookup (BC.pack "TRANS") items, trans == T.pack "chacc"
+    , Just (RecRef ref) <- lookup (BC.pack "acc") items
+    = Just $ TrChannelAccept ref
+
 transportFromObject _ = Nothing
 
 
 peerDiscovery :: String -> Stored Identity -> IO (Chan Peer)
 peerDiscovery bhost sidentity = do
-    chan <- newChan
+    chanPeer <- newChan
+    peers <- newMVar M.empty
+
+    let open addr = do
+            sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)
+            setSocketOption sock ReuseAddr 1
+            setSocketOption sock Broadcast 1
+            setCloseOnExecIfNeeded =<< fdSocket sock
+            bind sock (addrAddress addr)
+            return sock
+
+        loop sock = do
+            baddr:_ <- getAddrInfo (Just $ defaultHints { addrSocketType = Datagram }) (Just bhost) (Just discoveryPort)
+            void $ sendTo sock (BL.toStrict $ serializeObject $ transportToObject $ AnnouncePacket $ storedRef sidentity) (addrAddress baddr)
+            forever $ do
+                (msg, paddr) <- recvFrom sock 4096
+                let packet' = packet sock paddr
+                case runExcept $ deserializeObjects (storedStorage sidentity) $ BL.fromStrict msg of
+                     Left err -> putStrLn $ show paddr ++ ": " ++ err
+                     Right (obj:objs) | Just tpack <- transportFromObject obj -> packet' tpack objs
+                     _ -> putStrLn $ show paddr ++ ": invalid transport packet"
+
+        packet sock paddr (AnnouncePacket ref) _ = do
+            putStrLn $ "Got announce: " ++ show ref ++ " from " ++ show paddr
+            when (ref /= storedRef sidentity) $ void $ sendTo sock (BL.toStrict $ BL.concat
+                [ serializeObject $ transportToObject $ IdentityRequest ref (storedRef sidentity)
+                , BL.concat $ map (lazyLoadBytes . storedRef) $ collectStoredObjects $ wrappedLoad $ storedRef sidentity
+                ]) paddr
+
+        packet _ paddr (IdentityRequest ref from) [] = do
+            putStrLn $ "Got identity request: for " ++ show ref ++ " by " ++ show from ++ " from " ++ show paddr ++ " without content"
+
+        packet sock paddr (IdentityRequest ref from) (obj:objs) = do
+            putStrLn $ "Got identity request: for " ++ show ref ++ " by " ++ show from ++ " from " ++ show paddr
+            print (obj:objs)
+            from' <- store (storedStorage sidentity) obj
+            if from == from'
+               then do forM_ objs $ store $ storedStorage sidentity
+                       let peer = Peer (DatagramAddress paddr) (Just $ wrappedLoad from) []
+                       modifyMVar_ peers $ return . M.insert paddr peer
+                       writeChan chanPeer peer
+                       void $ sendTo sock (BL.toStrict $ BL.concat
+                           [ serializeObject $ transportToObject $ IdentityResponse (storedRef sidentity)
+                           , BL.concat $ map (lazyLoadBytes . storedRef) $ collectStoredObjects $ wrappedLoad $ storedRef sidentity
+                           ]) paddr
+               else putStrLn $ "Mismatched content"
+
+        packet _ paddr (IdentityResponse ref) [] = do
+            putStrLn $ "Got identity response: by " ++ show ref ++ " from " ++ show paddr ++ " without content"
+
+        packet sock paddr (IdentityResponse ref) (obj:objs) = do
+            putStrLn $ "Got identity response: by " ++ show ref ++ " from " ++ show paddr
+            print (obj:objs)
+            ref' <- store (storedStorage sidentity) obj
+            if ref == ref'
+               then do forM_ objs $ store $ storedStorage sidentity
+                       let pidentity = wrappedLoad ref
+                           peer = Peer (DatagramAddress paddr) (Just pidentity) []
+                       modifyMVar_ peers $ return . M.insert paddr peer
+                       writeChan chanPeer peer
+                       req <- createChannelRequest sidentity pidentity
+                       void $ sendTo sock (BL.toStrict $ BL.concat
+                           [ serializeObject $ transportToObject $ TrChannelRequest (storedRef req)
+                           , lazyLoadBytes $ storedRef req
+                           , lazyLoadBytes $ storedRef $ signedData $ fromStored req
+                           , lazyLoadBytes $ storedRef $ crKey $ fromStored $ signedData $ fromStored req
+                           , BL.concat $ map (lazyLoadBytes . storedRef) $ signedSignature $ fromStored req
+                           ]) paddr
+               else putStrLn $ "Mismatched content"
+
+        packet _ paddr (TrChannelRequest _) [] = do
+            putStrLn $ "Got channel request: from " ++ show paddr ++ " without content"
+
+        packet sock paddr (TrChannelRequest ref) (obj:objs) = do
+            putStrLn $ "Got channel request: from " ++ show paddr
+            print (obj:objs)
+            ref' <- store (storedStorage sidentity) obj
+            if ref == ref'
+               then do forM_ objs $ store $ storedStorage sidentity
+                       let request = wrappedLoad ref :: Stored ChannelRequest
+                       modifyMVar_ peers $ \pval -> case M.lookup paddr pval of
+                           Just peer | Just pid <- peerIdentity peer ->
+                               runExceptT (acceptChannelRequest sidentity pid request) >>= \case
+                                   Left errs -> do mapM_ putStrLn ("Invalid channel request" : errs)
+                                                   return pval
+                                   Right (acc, channel) -> do
+                                       putStrLn $ "Got channel: " ++ show (storedRef channel)
+                                       let peer' = peer { peerChannels = fromStored channel : peerChannels peer }
+                                       writeChan chanPeer peer'
+                                       void $ sendTo sock (BL.toStrict $ BL.concat
+                                           [ serializeObject $ transportToObject $ TrChannelAccept (storedRef acc)
+                                           , lazyLoadBytes $ storedRef acc
+                                           , lazyLoadBytes $ storedRef $ signedData $ fromStored acc
+                                           , lazyLoadBytes $ storedRef $ caKey $ fromStored $ signedData $ fromStored acc
+                                           , BL.concat $ map (lazyLoadBytes . storedRef) $ signedSignature $ fromStored acc
+                                           ]) paddr
+                                       return $ M.insert paddr peer' pval
+
+                           _ -> do putStrLn $ "Invalid channel request - no peer identity"
+                                   return pval
+               else putStrLn $ "Mismatched content"
+
+        packet _ paddr (TrChannelAccept _) [] = do
+            putStrLn $ "Got channel accept: from " ++ show paddr ++ " without content"
+
+        packet _ paddr (TrChannelAccept ref) (obj:objs) = do
+            putStrLn $ "Got channel accept: from " ++ show paddr
+            print (obj:objs)
+            ref' <- store (storedStorage sidentity) obj
+            if ref == ref'
+               then do forM_ objs $ store $ storedStorage sidentity
+                       let accepted = wrappedLoad ref :: Stored ChannelAccept
+                       modifyMVar_ peers $ \pval -> case M.lookup paddr pval of
+                           Just peer | Just pid <- peerIdentity peer ->
+                               runExceptT (acceptedChannel sidentity pid accepted) >>= \case
+                                   Left errs -> do mapM_ putStrLn ("Invalid channel accept" : errs)
+                                                   return pval
+                                   Right channel -> do
+                                       putStrLn $ "Got channel: " ++ show (storedRef channel)
+                                       let peer' = peer { peerChannels = fromStored channel : peerChannels peer }
+                                       writeChan chanPeer peer'
+                                       return $ M.insert paddr peer' pval
+                           _ -> do putStrLn $ "Invalid channel accept - no peer identity"
+                                   return pval
+
+               else putStrLn $ "Mismatched content"
+
     void $ forkIO $ withSocketsDo $ do
         let hints = defaultHints
               { addrFlags = [AI_PASSIVE]
               , addrSocketType = Datagram
               }
         addr:_ <- getAddrInfo (Just hints) Nothing (Just discoveryPort)
-        bracket (open addr) close (loop chan)
-    return chan
-  where
-    open addr = do
-        sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)
-        setSocketOption sock ReuseAddr 1
-        setSocketOption sock Broadcast 1
-        setCloseOnExecIfNeeded =<< fdSocket sock
-        bind sock (addrAddress addr)
-        return sock
-
-    loop chan sock = do
-        baddr:_ <- getAddrInfo (Just $ defaultHints { addrSocketType = Datagram }) (Just bhost) (Just discoveryPort)
-        void $ sendTo sock (BL.toStrict $ serializeObject $ transportToObject $ AnnouncePacket $ storedRef sidentity) (addrAddress baddr)
-        forever $ do
-            (msg, peer) <- recvFrom sock 4096
-            let packet' = packet chan sock peer
-            case runExcept $ deserializeObjects (storedStorage sidentity) $ BL.fromStrict msg of
-                 Left err -> putStrLn $ show peer ++ ": " ++ err
-                 Right (obj:objs) | Just tpack <- transportFromObject obj -> packet' tpack objs
-                 _ -> putStrLn $ show peer ++ ": invalid transport packet"
-
-    packet _ sock peer (AnnouncePacket ref) _ = do
-        putStrLn $ "Got announce: " ++ show ref ++ " from " ++ show peer
-        when (ref /= storedRef sidentity) $ void $ sendTo sock (BL.toStrict $ BL.concat
-            [ serializeObject $ transportToObject $ IdentityRequest ref (storedRef sidentity)
-            , BL.concat $ map (lazyLoadBytes . storedRef) $ collectStoredObjects $ wrappedLoad $ storedRef sidentity
-            ]) peer
-
-    packet _ _ peer (IdentityRequest ref from) [] = do
-        putStrLn $ "Got identity request: for " ++ show ref ++ " by " ++ show from ++ " from " ++ show peer ++ " without content"
-
-    packet chan sock peer (IdentityRequest ref from) (obj:objs) = do
-        putStrLn $ "Got identity request: for " ++ show ref ++ " by " ++ show from ++ " from " ++ show peer
-        print (obj:objs)
-        from' <- store (storedStorage sidentity) obj
-        if from == from'
-           then do forM_ objs $ store $ storedStorage sidentity
-                   writeChan chan $ Peer (wrappedLoad from) (DatagramAddress peer)
-                   void $ sendTo sock (BL.toStrict $ BL.concat
-                       [ serializeObject $ transportToObject $ IdentityResponse (storedRef sidentity)
-                       , BL.concat $ map (lazyLoadBytes . storedRef) $ collectStoredObjects $ wrappedLoad $ storedRef sidentity
-                       ]) peer
-           else putStrLn $ "Mismatched content"
-
-    packet _ _ peer (IdentityResponse ref) [] = do
-        putStrLn $ "Got identity response: by " ++ show ref ++ " from " ++ show peer ++ " without content"
-
-    packet chan _ peer (IdentityResponse ref) (obj:objs) = do
-        putStrLn $ "Got identity response: by " ++ show ref ++ " from " ++ show peer
-        print (obj:objs)
-        ref' <- store (storedStorage sidentity) obj
-        if ref == ref'
-           then do forM_ objs $ store $ storedStorage sidentity
-                   writeChan chan $ Peer (wrappedLoad ref) (DatagramAddress peer)
-           else putStrLn $ "Mismatched content"
+        bracket (open addr) close loop
+
+    return chanPeer
diff --git a/src/PubKey.hs b/src/PubKey.hs
index 0022343..6dc8080 100644
--- a/src/PubKey.hs
+++ b/src/PubKey.hs
@@ -3,6 +3,9 @@ module PubKey (
     KeyPair(generateKeys), loadKey,
     Signature(sigKey), Signed, signedData, signedSignature,
     sign, signAdd,
+
+    PublicKexKey, SecretKexKey,
+    dhSecret,
 ) where
 
 import Control.Monad
@@ -10,6 +13,7 @@ import Control.Monad.Except
 
 import Crypto.Error
 import qualified Crypto.PubKey.Ed25519 as ED
+import qualified Crypto.PubKey.Curve25519 as CX
 
 import Data.ByteArray
 import Data.ByteString (ByteString)
@@ -98,3 +102,35 @@ signAdd (SecretKey secret spublic) (Signed val sigs) = do
         sig = ED.sign secret public $ storedRef val
     ssig <- wrappedStore (storedStorage val) $ Signature spublic sig
     return $ Signed val (ssig : sigs)
+
+
+data PublicKexKey = PublicKexKey CX.PublicKey
+    deriving (Show)
+
+data SecretKexKey = SecretKexKey CX.SecretKey (Stored PublicKexKey)
+
+instance KeyPair SecretKexKey PublicKexKey where
+    keyGetPublic (SecretKexKey _ pub) = pub
+    keyGetData (SecretKexKey sec _) = convert sec
+    keyFromData kdata spub = SecretKexKey <$> maybeCryptoError (CX.secretKey kdata) <*> pure spub
+    generateKeys st = do
+        secret <- CX.generateSecretKey
+        public <- wrappedStore st $ PublicKexKey $ CX.toPublic secret
+        let pair = SecretKexKey secret public
+        storeKey pair
+        return (pair, public)
+
+instance Storable PublicKexKey where
+    store' (PublicKexKey pk) = storeRec $ do
+        storeText "type" $ T.pack "x25519"
+        storeBinary "pubkey" pk
+
+    load' = loadRec $ do
+        ktype <- loadText "type"
+        guard $ ktype == "x25519"
+        maybe (throwError "public key decoding failed") (return . PublicKexKey) .
+            maybeCryptoError . (CX.publicKey :: ScrubbedBytes -> CryptoFailable CX.PublicKey) =<<
+                loadBinary "pubkey"
+
+dhSecret :: SecretKexKey -> PublicKexKey -> ScrubbedBytes
+dhSecret (SecretKexKey secret _) (PublicKexKey public) = convert $ CX.dh public secret