WIP: Tox encryption.

3 files changed, 161 insertions, 13 deletions

diff --git a/src/Network/DatagramServer/Mainline.hs b/src/Network/DatagramServer/Mainline.hs
index 89a275c1..1f07b13f 100644
--- a/src/Network/DatagramServer/Mainline.hs
+++ b/src/Network/DatagramServer/Mainline.hs
@@ -79,6 +79,7 @@ import Data.Typeable
 import Network.Socket (SockAddr (..),PortNumber,HostAddress)
 import Text.PrettyPrint                as PP hiding ((<>))
 import Text.PrettyPrint.HughesPJClass  hiding (($$), (<>))
+import Data.Hashable
 
 
 -- | This transaction ID is generated by the querying node and is
@@ -290,6 +291,9 @@ instance Envelope KMessageOf where
         }
       deriving (Show, Eq, Ord, Typeable)
 
+    newtype PacketDestination KMessageOf = MainlineNode SockAddr
+      deriving (Show, Eq, Ord, Typeable)
+
     envelopePayload (Q q) = queryArgs q
     envelopePayload (R r) = respVals r
     envelopePayload (E _) = error "TODO: messagePayload for KError"
@@ -302,6 +306,9 @@ instance Envelope KMessageOf where
     envelopeClass (R r) = Response (respIP r)
     envelopeClass (E e) = Error e
 
+    -- replyAddress :: envelope a -> SockAddr -> PacketDestination envelope
+    makeAddress _ addr = MainlineNode addr
+
     buildReply self addr qry response =
         (R (KResponse response (envelopeTransaction qry) (Just $ ReflectedIP addr)))
 
@@ -311,6 +318,20 @@ instance Envelope KMessageOf where
 
     fromRoutableNode = not . queryIsReadOnly
 
+instance Hashable (PacketDestination KMessageOf) where
+  hashWithSalt s (MainlineNode sockaddr) = hashWithSalt s (show sockaddr)
+
+-- Serialize, Pretty) PacketDestination KMessageOf = MainlineNode SockAddr
+instance Serialize (PacketDestination KMessageOf) where
+    put (MainlineNode addr) = putSockAddr addr
+    get = MainlineNode <$> getSockAddr
+
+instance Pretty (PacketDestination KMessageOf) where
+    pPrint (MainlineNode addr) = PP.text $ show addr
+
+instance Address (PacketDestination KMessageOf) where
+    toSockAddr (MainlineNode addr) = addr
+    fromSockAddr addr = Just $ MainlineNode addr
 
 instance WireFormat BValue KMessageOf where
     type SerializableTo BValue = BEncode
@@ -323,7 +344,7 @@ instance WireFormat BValue KMessageOf where
     decodeHeaders _ = BE.fromBEncode
     decodePayload kmsg = mapM BE.fromBEncode kmsg
 
-    encodeHeaders _ kmsg = L.toStrict $ BE.encode kmsg
+    encodeHeaders _ kmsg _ = L.toStrict $ BE.encode kmsg
     encodePayload msg = fmap BE.toBEncode msg
 
 -- | KRPC 'compact list' compatible encoding: contact information for
diff --git a/src/Network/DatagramServer/Tox.hs b/src/Network/DatagramServer/Tox.hs
index f666b951..8d2f9289 100644
--- a/src/Network/DatagramServer/Tox.hs
+++ b/src/Network/DatagramServer/Tox.hs
@@ -11,10 +11,13 @@
 {-# LANGUAGE TupleSections         #-}
 {-# LANGUAGE TypeFamilies          #-}
 {-# LANGUAGE UnboxedTuples         #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE RankNTypes #-}
 module Network.DatagramServer.Tox where
 
 import Data.Bits
 import Data.ByteString (ByteString)
+import Data.ByteArray as BA (ByteArrayAccess,length,withByteArray)
 import qualified Data.Serialize as S
 -- import qualified Data.ByteString.Lazy  as L
 import qualified Data.ByteString.Char8 as Char8
@@ -23,12 +26,25 @@ import Data.Word
 import Data.LargeWord
 import Data.IP
 import Data.Serialize
--- import Network.Address (NodeInfo(..)) -- Serialize IP
+import Network.Address
 import GHC.Generics (Generic)
 import Network.Socket
 import Network.DatagramServer.Types
 import qualified Network.DatagramServer.Types as Envelope (NodeId)
 import Crypto.PubKey.ECC.Types
+import Crypto.PubKey.Curve25519
+import Crypto.ECC.Class
+import qualified Crypto.Cipher.XSalsa as Salsa20
+import Data.LargeWord
+import Foreign.Ptr
+import Foreign.Storable
+import Foreign.Marshal.Alloc
+import Data.Typeable
+import StaticAssert
+import Crypto.Error.Types
+import Data.Hashable
+import Text.PrettyPrint as PP hiding ((<>))
+import Text.PrettyPrint.HughesPJClass  hiding (($$), (<>))
 
 
 type Key32   = Word256 -- 32 byte key
@@ -203,7 +219,9 @@ instance Serialize NodeFormat where
 --   [Sendback data, length=8 bytes]
 --   ]
 
-data ToxCipherContext = ToxCipherContext -- TODO
+data ToxCipherContext = ToxCipherContext
+    { dhtSecretKey :: SecretKey
+    }
 
 newtype Ciphered = Ciphered { cipheredBytes :: ByteString }
 
@@ -227,29 +245,51 @@ putMessage (Message {..}) = do
         let Ciphered bs = msgPayload
         putByteString bs
 
+id2key :: NodeId Message -> PublicKey
+id2key recipient = case publicKey recipient of
+    CryptoPassed key -> key
+    CryptoFailed e   -> error ("id2key: "++show e)
+
+lookupSecret :: ToxCipherContext -> NodeId Message -> TransactionID Message -> Salsa20.State
+lookupSecret ctx recipient nonce = Salsa20.initialize 20 key nonce
+ where
+    key = ecdh (Proxy :: Proxy Curve_X25519) (dhtSecretKey ctx) (id2key recipient) -- ByteArrayAccess b => b
+
 decipher :: ToxCipherContext -> Message Ciphered -> Either String (Message ByteString)
-decipher = error "TODO TOX: decipher"
+decipher ctx ciphered = Right (fst . Salsa20.combine st . cipheredBytes <$> ciphered)
+ where
+    st = lookupSecret ctx (msgClient ciphered) (msgNonce ciphered)
 
-encipher :: ToxCipherContext -> Message ByteString -> Message Ciphered
-encipher = error "TODO TOX: encipher"
+encipher :: ToxCipherContext -> NodeId Message -> Message ByteString -> Message Ciphered
+encipher ctx recipient plain = Ciphered . fst . Salsa20.combine st <$> plain
+ where
+    st = lookupSecret ctx recipient (msgNonce plain)
 
 -- see rfc7748
+--
+-- Crypto.ECC
+-- Crypto.PubKey.Curve25519
+-- Crypto.Cipher.XSalsa
+--
 curve25519 :: Curve
 curve25519 = CurveFP (CurvePrime prime curvecommon)
  where
     prime = 2^255 - 19 -- (≅ 1 modulo 4)
 
+    sqrt_of_39420360 = 14781619447589544791020593568409986887264606134616475288964881837755586237401
+
     -- 1 * v^2 = u^3 + 486662*u^2 + u
 
     curvecommon = CurveCommon
         { ecc_a = 486662
         , ecc_b = 1
-        , ecc_g = Point 9 14781619447589544791020593568409986887264606134616475288964881837755586237401 -- base point
+        , ecc_g = Point 9 sqrt_of_39420360 -- base point
         , ecc_n = 2^252 + 0x14def9dea2f79cd65812631a5cf5d3ed -- order
         , ecc_h = 8 -- cofactor
         }
 
-
+-- crypto_box uses xsalsa20 symmetric encryption and poly1305 authentication.
+-- https://en.wikipedia.org/wiki/Poly1305
 
 instance Envelope Message where
     newtype TransactionID Message = TID Nonce24
@@ -263,6 +303,11 @@ instance Envelope Message where
     newtype QueryExtra Message = QueryNonce { qryNonce :: Nonce8 }
     newtype ResponseExtra Message = ResponseNonce { rspNonce :: Nonce8 }
 
+    data PacketDestination Message = ToxAddr { toxID :: NodeId Message
+                                             , toxSockAddr :: SockAddr
+                                             }
+        deriving (Eq,Ord,Show)
+
     envelopePayload = msgPayload
 
     envelopeTransaction = msgNonce
@@ -272,15 +317,70 @@ instance Envelope Message where
     envelopeClass Message { msgType = GetNodes  } = Query GetNodes
     envelopeClass Message { msgType = SendNodes } = Response Nothing
 
+    makeAddress qry = ToxAddr (either id msgClient qry)
+
     buildReply self addr qry payload = (fmap (const payload) qry) { msgClient = self }
 
     -- buildQuery :: NodeId envelope -> SockAddr -> QueryMethod envelope -> TransactionID envelope -> a -> IO (envelope a)
-    -- buildQuery nid addr meth tid q = todo
+    buildQuery nid addr meth tid q = return $ Message
+        { msgType = meth
+        , msgClient = nid
+        , msgNonce = tid
+        , msgPayload = q
+        }
 
     uniqueTransactionId cnt = do
       return $ either (error "failed to create TransactionId") TID
              $ S.decode $ Char8.pack (take 24 $ show cnt ++ repeat ' ')
 
+
+staticAssert isLittleEndian -- assumed by 'withWord64Ptr'
+
+with3Word64Ptr :: Nonce24 -> (Ptr Word64 -> IO a) -> IO a
+with3Word64Ptr (LargeKey wlo (LargeKey wmid whi)) kont =
+    allocaBytes (sizeOf wlo * 3) $ \p -> do
+        pokeElemOff p 0 wlo
+        pokeElemOff p 1 wmid
+        pokeElemOff p 2 whi
+        kont p
+
+with4Word64Ptr :: Key32 -> (Ptr Word64 -> IO a) -> IO a
+with4Word64Ptr (LargeKey wlo (LargeKey wmid (LargeKey whi whighest))) kont =
+    allocaBytes (sizeOf wlo * 4) $ \p -> do
+        pokeElemOff p 0 wlo
+        pokeElemOff p 1 wmid
+        pokeElemOff p 2 whi
+        pokeElemOff p 3 whighest
+        kont p
+
+
+instance ByteArrayAccess (TransactionID Message) where
+    length _ = 24
+    withByteArray (TID nonce) kont = with3Word64Ptr nonce (kont . castPtr)
+
+instance ByteArrayAccess (NodeId Message) where
+    length _ = 32
+    withByteArray (NodeId nonce) kont = with4Word64Ptr nonce (kont . castPtr)
+
+
+instance Hashable (NodeId Message) where
+    hashWithSalt s (NodeId (LargeKey a (LargeKey b (LargeKey c d)))) =
+        hashWithSalt s (a,b,c,d)
+
+instance Hashable (PacketDestination Message) where
+    hashWithSalt s (ToxAddr nid addr) = hashWithSalt s nid
+
+instance Serialize (PacketDestination Message) where
+    put (ToxAddr (NodeId nid) addr) = put nid >> putSockAddr addr
+    get = ToxAddr <$> (NodeId <$> get) <*> getSockAddr
+
+instance Pretty (PacketDestination Message) where
+    pPrint = PP.text . show
+
+instance Address (PacketDestination Message) where
+    toSockAddr (ToxAddr _ addr) = addr
+    fromSockAddr _ = Nothing
+
 instance WireFormat ByteString Message where
     type SerializableTo ByteString = Serialize
     type CipherContext ByteString Message = ToxCipherContext
@@ -289,6 +389,6 @@ instance WireFormat ByteString Message where
     encodePayload = fmap encode
 
     decodeHeaders ctx bs = runGet getMessage bs >>= decipher ctx
-    encodeHeaders ctx msg = runPut $ putMessage $ encipher ctx msg
+    encodeHeaders ctx msg recipient = runPut $ putMessage $ encipher ctx (toxID recipient) msg
 
 instance Read (NodeId Message) where readsPrec d s = map (\(w,xs) -> (NodeId w, xs)) $ decodeHex s
diff --git a/src/Network/DatagramServer/Types.hs b/src/Network/DatagramServer/Types.hs
index 13f79afb..14968764 100644
--- a/src/Network/DatagramServer/Types.hs
+++ b/src/Network/DatagramServer/Types.hs
@@ -96,11 +96,21 @@ class Envelope envelope where
     data NodeId envelope
     data QueryExtra envelope
     data ResponseExtra envelope
+    data PacketDestination envelope
 
     envelopePayload     :: envelope a -> a
     envelopeTransaction :: envelope a -> TransactionID envelope
     envelopeClass       :: envelope a -> MessageClass envelope
 
+    -- | > replyAddress qry addr
+    --
+    --    [ qry ]  received query message
+    --
+    --    [ addr ] SockAddr of query origin
+    --
+    -- Returns: Destination address for reply.
+    makeAddress :: Either (NodeId envelope) (envelope a) -> SockAddr -> PacketDestination envelope
+
     -- | > buildReply self addr qry response
     --
     --    [ self ]     this node's id.
@@ -320,8 +330,7 @@ genBucketSample' gen self (q,m,b)
         h = xor b (complement m .&. BS.last hd)
         t = m .&. BS.head tl
 
-
-class Envelope envelope => WireFormat raw envelope where
+class (Envelope envelope, Address (PacketDestination envelope)) => WireFormat raw envelope where
     type SerializableTo raw :: * -> Constraint
     type CipherContext raw envelope
 
@@ -336,7 +345,7 @@ class Envelope envelope => WireFormat raw envelope where
     decodeHeaders :: CipherContext raw envelope -> raw -> Either String (envelope raw)
     decodePayload :: SerializableTo raw a => envelope raw -> Either String (envelope a)
 
-    encodeHeaders :: CipherContext raw envelope -> envelope raw -> ByteString
+    encodeHeaders :: CipherContext raw envelope -> envelope raw -> PacketDestination envelope -> ByteString
     encodePayload :: SerializableTo raw a => envelope a -> envelope raw
 
 encodeHexDoc :: Serialize x => x -> Doc
@@ -359,3 +368,21 @@ instance (Pretty ip, Pretty (NodeId dht)) => Pretty [NodeInfo dht ip u] where
   pPrint = PP.vcat . PP.punctuate "," . map pPrint
 
 
+
+putSockAddr (SockAddrInet port addr)
+    = put (0x34 :: Word8) >> put port >> put addr
+putSockAddr (SockAddrInet6 port flow addr scope)
+    = put (0x36 :: Word8) >> put port >> put addr >> put scope >> put flow
+putSockAddr (SockAddrUnix path)
+    = put (0x75 :: Word8) >> put path
+putSockAddr (SockAddrCan num)
+    = put (0x63 :: Word8) >> put num
+
+getSockAddr = do
+    c <- get
+    case c :: Word8 of
+        0x34 -> SockAddrInet <$> get <*> get
+        0x36 -> (\p a s f -> SockAddrInet6 p f a s) <$> get <*> get <*> get <*> get
+        0x75 -> SockAddrUnix <$> get
+        0x63 -> SockAddrCan <$> get
+        _ -> fail "getSockAddr"