1 files changed, 263 insertions, 0 deletions

diff --git a/Tox.hs b/Tox.hs
new file mode 100644
index 00000000..4fd54f04
--- /dev/null
+++ b/Tox.hs
@@ -0,0 +1,263 @@
+{-# LANGUAGE DeriveDataTypeable         #-}
+{-# LANGUAGE DeriveFoldable             #-}
+{-# LANGUAGE DeriveFunctor              #-}
+{-# LANGUAGE DeriveGeneric              #-}
+{-# LANGUAGE DeriveTraversable          #-}
+{-# LANGUAGE FlexibleInstances          #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE PatternSynonyms            #-}
+module Tox where
+
+import Control.Arrow
+import qualified Crypto.Cipher.Salsa    as Salsa
+import qualified Crypto.Cipher.XSalsa   as XSalsa
+import Crypto.ECC.Class
+import qualified Crypto.Error           as Cryptonite
+import Crypto.Error.Types
+import qualified Crypto.MAC.Poly1305    as Poly1305
+import Crypto.PubKey.Curve25519
+import Crypto.PubKey.ECC.Types
+import Data.Bool
+import Data.ByteArray                   as BA
+import Data.ByteString                  (ByteString)
+import Data.ByteString                  as B
+import qualified Data.ByteString.Base16 as Base16
+import qualified Data.ByteString.Char8  as C8
+import Data.ByteString.Lazy             (toStrict)
+import Data.Data
+import Data.IP
+import qualified Data.Serialize         as S
+import Data.Typeable
+import Data.Word
+import GHC.Generics                     (Generic)
+import Network.Address                  (Address, fromSockAddr, sockAddrPort,
+                                         toSockAddr, withPort)
+import Network.QueryResponse
+import Network.Socket
+import Data.Monoid
+
+newtype NodeId = NodeId ByteString
+ deriving (Eq,Ord,Show,ByteArrayAccess)
+
+instance S.Serialize NodeId where
+    get = NodeId <$> S.getBytes 32
+    put (NodeId bs) = S.putByteString bs
+
+data NodeInfo = NodeInfo
+  { nodeId   :: NodeId
+  , nodeIP :: IP
+  , nodePort :: PortNumber
+  }
+
+nodeAddr :: NodeInfo -> SockAddr
+nodeAddr (NodeInfo _ ip port) = toSockAddr ip `withPort` port
+
+nodeInfo :: NodeId -> SockAddr -> Either String NodeInfo
+nodeInfo nid saddr
+    | Just ip <- fromSockAddr saddr
+    , Just port <- sockAddrPort saddr = Right $ NodeInfo nid ip port
+    | otherwise                       = Left "Address family not supported."
+
+type TransactionId = Nonce8
+-- TODO
+-- data TransactionId = TransactionId
+--  { transactionKey :: Nonce8  -- ^ Used to lookup pending query.
+--  , cryptoNonce    :: Nonce24 -- ^ Used during encryption and decryption layer.
+--  }
+--
+-- Ensure that cryptoNonce is ignored by 'TableMethods'
+
+newtype Method = MessageType Word8
+ deriving (Eq, Ord, S.Serialize)
+
+pattern PingType      = MessageType 0
+pattern PongType      = MessageType 1
+pattern GetNodesType  = MessageType 2
+pattern SendNodesType = MessageType 4
+
+instance Show Method where
+    showsPrec d PingType        = mappend "PingType"
+    showsPrec d PongType        = mappend "PongType"
+    showsPrec d GetNodesType    = mappend "GetNodesType"
+    showsPrec d SendNodesType   = mappend "SendNodesType"
+    showsPrec d (MessageType x) = mappend "MessageType " . showsPrec (d+1) x
+
+-- XXX: Possibly Word64 would be a better implementation.
+newtype Nonce8 = Nonce8 ByteString
+ deriving (Eq, Ord, ByteArrayAccess)
+
+instance Show Nonce8 where
+    showsPrec d nonce = quoted (mappend $ bin2hex nonce)
+
+newtype Nonce24 = Nonce24 ByteString
+ deriving (Eq, Ord, ByteArrayAccess)
+
+instance Show Nonce24 where
+    showsPrec d nonce = quoted (mappend $ bin2hex nonce)
+
+instance S.Serialize Nonce24 where
+    get = Nonce24 <$> S.getBytes 24
+    put (Nonce24 bs) = S.putByteString bs
+
+quoted :: ShowS -> ShowS
+quoted shows s = '"':shows ('"':s)
+
+bin2hex :: ByteArrayAccess bs => bs -> String
+bin2hex = C8.unpack . Base16.encode . convert
+
+
+data Message a = Message
+    { msgType    :: Method
+    , msgOrigin  :: NodeId
+    , msgNonce   :: Nonce24
+    , msgPayload :: a
+    }
+ deriving (Eq, Show, Generic, Functor, Foldable, Traversable)
+
+data Ciphered = Ciphered { cipheredMAC   :: Poly1305.Auth
+                         , cipheredBytes :: ByteString }
+ deriving Eq
+
+getMessage :: S.Get (Message Ciphered)
+getMessage = do
+        typ <- S.get
+        nid <- S.get
+        tid <- S.get
+        mac <- Poly1305.Auth . convert <$> S.getBytes 16
+        cnt <- S.remaining
+        bs <- S.getBytes cnt
+        return Message { msgType    = typ
+                       , msgOrigin  = nid
+                       , msgNonce   = tid
+                       , msgPayload = Ciphered mac bs }
+
+putMessage :: Message Ciphered -> S.Put
+putMessage (Message {..}) = do
+        S.put msgType
+        S.put msgOrigin
+        S.put msgNonce
+        let Ciphered (Poly1305.Auth mac) bs = msgPayload
+        S.putByteString (convert mac)
+        S.putByteString bs
+
+-- TODO: Cache symmetric keys.
+data SecretsCache = SecretsCache
+newEmptyCache = return SecretsCache
+
+id2key :: NodeId -> PublicKey
+id2key recipient = case publicKey recipient of
+    CryptoPassed key -> key
+    -- This should never happen because a NodeId is 32 bytes.
+    CryptoFailed e   -> error ("Unexpected pattern fail: "++show e)
+
+zeros32 :: Bytes
+zeros32 = BA.replicate 32 0
+
+zeros24 :: Bytes
+zeros24 = BA.take 24 zeros32
+
+hsalsa20 k n = a <> b
+ where
+    Salsa.State st = XSalsa.initialize 20 k n
+    (_, as) = BA.splitAt 4 st
+    (a, xs) = BA.splitAt 16 as
+    (_, bs) = BA.splitAt 24 xs
+    (b, _ ) = BA.splitAt 16 bs
+
+
+computeSharedSecret :: SecretKey -> NodeId -> Nonce24 -> (Poly1305.State, XSalsa.State)
+computeSharedSecret sk recipient nonce = (hash, crypt)
+ where
+    -- diffie helman
+    shared = ecdh (Proxy :: Proxy Curve_X25519) sk (id2key recipient)
+    -- shared secret XSalsa key
+    k = hsalsa20 shared zeros24
+    -- cipher state
+    st0 = XSalsa.initialize 20 k nonce
+    -- Poly1305 key
+    (rs, crypt) = XSalsa.combine st0 zeros32
+    -- Since rs is 32 bytes, this pattern should never fail...
+    Cryptonite.CryptoPassed hash = Poly1305.initialize rs
+
+
+encryptMessage :: SecretKey -> SecretsCache -> NodeId -> Message ByteString -> Message Ciphered
+encryptMessage sk _ recipient plaintext
+    = withSecret encipherAndHash sk recipient (msgNonce plaintext) <$> plaintext
+
+decryptMessage :: SecretKey -> SecretsCache -> Message Ciphered -> Either String (Message ByteString)
+decryptMessage sk _ ciphertext
+    = mapM (withSecret decipherAndAuth sk (msgOrigin ciphertext) (msgNonce ciphertext)) ciphertext
+
+withSecret f sk recipient nonce x = f hash crypt x
+ where
+    (hash, crypt) = computeSharedSecret sk recipient nonce
+
+
+encipherAndHash :: Poly1305.State -> XSalsa.State -> ByteString -> Ciphered
+encipherAndHash hash crypt m = Ciphered a c
+  where
+    c = fst . XSalsa.combine crypt $ m
+    a = Poly1305.finalize . Poly1305.update hash $ c
+
+decipherAndAuth :: Poly1305.State -> XSalsa.State -> Ciphered -> Either String ByteString
+decipherAndAuth hash crypt (Ciphered mac c)
+    | (a == mac) = Right m
+    | otherwise  = Left "decipherAndAuth: auth fail"
+  where
+    m = fst . XSalsa.combine crypt $ c
+    a = Poly1305.finalize . Poly1305.update hash $ c
+
+
+parsePacket :: SecretKey -> SecretsCache -> ByteString -> SockAddr -> Either String (Message ByteString, NodeInfo)
+parsePacket sk cache bs addr = do ciphered <- S.runGet getMessage bs
+                                  msg <- decryptMessage sk cache ciphered
+                                  ni <- nodeInfo (msgOrigin msg) addr
+                                  return (msg, ni)
+
+encodePacket :: SecretKey -> SecretsCache -> Message ByteString -> NodeInfo -> (ByteString, SockAddr)
+encodePacket sk cache msg ni = ( S.runPut . putMessage $ encryptMessage sk cache (nodeId ni) msg
+                               , nodeAddr ni )
+
+newClient addr = do
+    udp <- udpTransport addr
+    secret <- generateSecretKey
+    cache <- newEmptyCache
+    let net = layerTransport (parsePacket secret cache) (encodePacket secret cache) udp
+    return net
+
+last8 :: ByteString -> Nonce8
+last8 bs
+    | let len = B.length bs
+    , (len >= 8)            = Nonce8 $ B.drop (len - 8) bs
+    | otherwise             = Nonce8 $ B.replicate 8 0
+
+classify :: Message ByteString -> MessageClass String Method TransactionId
+classify (Message { msgType = typ, msgPayload = bs }) = cls (last8 bs)
+ where
+    cls = case typ of
+            PingType      -> IsQuery PingType
+            GetNodesType  -> IsQuery GetNodesType
+            PongType      -> IsResponse
+            SendNodesType -> IsResponse
+
+encodePayload typ _ (Nonce8 tid) self dest b
+    = Message { msgType    = typ
+              , msgOrigin  = nodeId self
+              , msgNonce   = error "encodePayload"
+              , msgPayload = S.encode b <> tid
+              }
+
+decodePayload :: S.Serialize a => Message ByteString -> Either String a
+decodePayload msg = S.decode $ msgPayload msg
+
+handler typ f = Just $ MethodHandler decodePayload (encodePayload typ) f
+
+handlers :: Method -> Maybe (MethodHandler String TransactionId NodeInfo (Message ByteString) ())
+handlers PingType     = handler PingType pingH
+handlers GetNodesType = error "find_node"
+handlers _            = Nothing
+
+data Ping = Ping
+
+pingH :: NodeInfo -> Ping -> IO Ping
+pingH = error "pingH"