path: root/Tox.hs

{-# 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"