From 8fe93b8e1d1d968bdf0b8a35335b060d92a9d7d7 Mon Sep 17 00:00:00 2001 From: joe Date: Sat, 8 Jul 2017 22:10:40 -0400 Subject: WIP: Tox encryption. --- src/Network/DatagramServer/Mainline.hs | 23 ++++++- src/Network/DatagramServer/Tox.hs | 118 ++++++++++++++++++++++++++++++--- src/Network/DatagramServer/Types.hs | 33 ++++++++- 3 files changed, 161 insertions(+), 13 deletions(-) (limited to 'src/Network/DatagramServer') 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" -- cgit v1.2.3