path: root/ToxMessage.hs

{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE DeriveFunctor, DeriveTraversable,DeriveDataTypeable #-}
{-# LANGUAGE GADTs #-}
module ToxMessage where

import Data.ByteString (ByteString)
import qualified Crypto.MAC.Poly1305 as Poly1305 (Auth(..))
import qualified Crypto.PubKey.Curve25519 as Curve25519
import Data.ByteArray as BA (ByteArrayAccess, Bytes)
import qualified Data.ByteArray as BA
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as C8
import qualified Data.ByteString.Base16 as Base16
import Data.Bits
import Data.Hashable
import Data.Bits.ByteString ()
import Data.Word
import Data.Data
import Data.Ord
import Data.Serialize
import Foreign.Ptr
import Foreign.Marshal.Alloc
import System.Endian
import Foreign.Storable

newtype Auth = Auth Poly1305.Auth
 deriving (Eq, ByteArrayAccess)

instance Ord Auth where
    compare (Auth a) (Auth b) = comparing (BA.convert :: Poly1305.Auth -> Bytes) a b

instance Data Auth where
    gfoldl k z x = z x

    -- Well, this is a little wonky... XXX
    gunfold k z c = k (z (Auth . Poly1305.Auth . (BA.convert :: ByteString -> Bytes)))

    toConstr _ = con_Auth

    dataTypeOf _ = mkDataType "ToxMessage" [con_Auth]

con_Auth = mkConstr (dataTypeOf (Auth (error "con_Auth"))) "Auth" [] Prefix

instance Serialize Auth where
    get = Auth . Poly1305.Auth . BA.convert <$> getBytes 16
    put (Auth (Poly1305.Auth bs)) = putByteString $ BA.convert bs
--
-- | An 'Aliased' 'PubKey' is one that is not the DHT key and so should not go
-- into the kademlia routing table buckets.
--
-- Note: This includes the long-term tox-id key that humans use to friend each
-- other and is often refered to as your "real public key" by the Tox
-- documents.  For the purposes of the DHT, it is an alias.
newtype Aliased a = Aliased a
 deriving (Eq,Ord,Show,Data,Functor,Foldable,Traversable,Serialize)

newtype Nonce24 = Nonce24 ByteString
 deriving (Eq, Ord, ByteArrayAccess,Data)

quoted :: ShowS -> ShowS
quoted shows s = '"':shows ('"':s)

bin2hex :: ByteArrayAccess bs => bs -> String
bin2hex = C8.unpack . Base16.encode . BA.convert

instance Show Nonce24 where
    showsPrec d nonce = quoted (mappend $ bin2hex nonce)

instance Serialize Nonce24 where
    get = Nonce24 <$> getBytes 24
    put (Nonce24 bs) = putByteString bs

newtype Nonce8 = Nonce8 Word64
 deriving (Eq, Ord, Data, Serialize)

instance ByteArrayAccess Nonce8 where
    length _ = 8
    withByteArray (Nonce8 w64) kont =
        allocaBytes 8 $ \p -> do
            poke (castPtr p :: Ptr Word64) $ toBE64 w64
            kont p

instance Show Nonce8 where
    showsPrec d nonce = quoted (mappend $ bin2hex nonce)




-- TODO: This should probably be represented by Curve25519.PublicKey, but
-- ByteString has more instances...
newtype PubKey = PubKey ByteString
 deriving (Eq,Ord,Data, ByteArrayAccess, Bits, Hashable)

instance Serialize PubKey where
    get = PubKey <$> getBytes 32
    put (PubKey bs) = putByteString bs

instance Show PubKey where
    show (PubKey bs) = C8.unpack $ Base16.encode bs

instance FiniteBits PubKey where
    finiteBitSize _ = 256

instance Read PubKey where
    readsPrec _ str
        | (bs, xs) <- Base16.decode $ C8.pack str
        , B.length bs == 32
                    = [ (PubKey bs, drop 64 str) ]
        | otherwise = []



-- | A chunk of data encrypted with public-key cryptography.
data ImplicitAssymetric = ImplicitAssymetric
    { assymetricAuth  :: Auth
    , assymetricBytes :: ByteString
    }
 deriving (Eq, Ord,Data)

getRemaining = remaining >>= getBytes

instance Serialize ImplicitAssymetric where
    get = ImplicitAssymetric <$> get <*> getRemaining
    put (ImplicitAssymetric auth bs) = put auth >> putByteString bs

-- | Like ImplicitAssymetric, but includes the nonce used to encrypt.
data UnclaimedAssymetric = UnclaimedAssymetric
    { assymetricNonce :: Nonce24
    , assymetricData  :: !ImplicitAssymetric
    }
 deriving (Eq, Ord, Data)

instance Serialize UnclaimedAssymetric where
    get = UnclaimedAssymetric <$> get <*> get
    put (UnclaimedAssymetric nonce dta) = put nonce >> put dta

-- | Like UnclaimedAssymetric, but includes the public key of the sender.
data Assymetric = Assymetric
    { senderKey :: PubKey
    , sent      :: !UnclaimedAssymetric
    }
 deriving (Eq, Ord,Data)

-- get requires isolate.
instance Serialize Assymetric where
    get = Assymetric <$> get <*> get
    put (Assymetric key dta) = put key >> put dta

newtype Cookie = Cookie UnclaimedAssymetric
 deriving (Eq, Ord,Data)

data Symmetric = Symmetric
    { symmetricNonce :: Nonce24
    , symmetricAuth  :: Auth
    , symmetricBytes :: ByteString
    }
 deriving (Eq, Ord,Data)

data Packet where
    Ping          :: Assymetric -> Packet -- 0x00 -- Assymetric query
    Pong          :: Assymetric -> Packet -- 0x01 -- Assymetric response

    GetNodes      :: Assymetric -> Packet -- 0x02 -- Assymetric query
    SendNodes     :: Assymetric -> Packet -- 0x04 -- Assymetric response

    CookieRequest :: Assymetric -> Packet -- 0x18
    CookieResponse :: UnclaimedAssymetric -> Packet -- 0x19

    OnionRequest0 :: Assymetric -> Packet -- 0x80


    CryptoHandshake :: Cookie -> UnclaimedAssymetric -> Packet -- 0x1a

    CryptoData :: Word16 -> ImplicitAssymetric -> Packet -- 0x1b

    DHTRequest :: PubKey -> Assymetric -> Packet -- 0x20 -- Sometimes Assymetric query

    DataToRoute :: PubKey -> Aliased Assymetric -> Packet
    DataToRouteResponse :: Aliased Assymetric -> Packet

    LanDiscovery :: PubKey -> Packet  -- 0x21

    OnionRequest1 :: Aliased Assymetric -> Symmetric -> Packet -- 0x81
    OnionRequest2 :: Aliased Assymetric -> Symmetric -> Packet -- 0x82

    OnionRequest3 :: ByteString -> Symmetric -> Packet -- 0x82

    Announce :: Aliased Assymetric -> Packet --0x83
    AnnounceResponse :: Nonce8 -> UnclaimedAssymetric -> Packet -- 0x84

    OnionResponse3 :: Symmetric -> ByteString -> Packet -- 0x8c
    OnionResponse2 :: Symmetric -> ByteString -> Packet -- 0x8d
    OnionResponse1 :: Symmetric -> ByteString -> Packet -- 0x8e


    GetBootstrapInfo :: ByteString -> Packet -- 0xf0 + 77 bytes                         -- ByteString query
    BootstrapInfo :: Word32 -> ByteString -> Packet -- 0xf0 + version + (256 byte motd) -- ByteSTring response

 deriving (Eq, Ord,Data)

newtype PacketKind = PacketKind Word8
 deriving (Eq, Ord, Serialize)

pktKind :: Packet -> PacketKind

-- These are (Assymetric -> Assymetric) queries.
pktKind Ping             {} = PacketKind 0x00
pktKind Pong             {} = PacketKind 0x01
pktKind GetNodes         {} = PacketKind 0x02
pktKind SendNodes        {} = PacketKind 0x04


-- This is a (Assymetric -> UnclaimedAssymetric) query
pktKind CookieRequest    {} = PacketKind 0x18
pktKind CookieResponse   {} = PacketKind 0x19

-- Query (Assymetric -> (Nonce8,UnclaimedAssymetric))
pktKind Announce         {} = PacketKind 0x83
pktKind AnnounceResponse {} = PacketKind 0x84

-- Query (Assymetric -> ByteString)
pktKind OnionRequest0    {} = PacketKind 0x80


-- This is a (ByteString -> ByteString) query
pktKind GetBootstrapInfo {} = PacketKind 0xf0
pktKind BootstrapInfo    {} = PacketKind 0xf0


-- Trigering event. No direct response. (PubKey -> ())
pktKind LanDiscovery     {} = PacketKind 0x21

-- Two cases:
--  Half-established:    (Cookie,UnclaimedAssymetric) -> (Cookie,UnclaimedAssymetric)
--  Session established: (Cookie,UnclaimedAssymetric) -> (Word16,ImplicitAssymetric)
pktKind CryptoHandshake  {} = PacketKind 0x1a

-- Session data, no direct response.
--   (reponse to CryptoHandshake, or other data)
pktKind CryptoData       {} = PacketKind 0x1b

-- Two cases:
--    ( (PubKey, Assymetric) -> response )
--    ( (PubKey, Assymetric) -> ()       )
pktKind DHTRequest       {} = PacketKind 0x20


-- Query ( (PubKey,Aliased Assymetric) -> Aliased Assymetric)
pktKind DataToRoute      {}    = PacketKind 0x85
pktKind DataToRouteResponse {} = PacketKind 0x86

-- 3 Queries ( (Aliased Assymetric, Symmetric )
--            -> ( Symmetric, ByteString )     )
pktKind OnionRequest1    {} = PacketKind 0x81
pktKind OnionResponse1   {} = PacketKind 0x8e

pktKind OnionRequest2    {} = PacketKind 0x82
pktKind OnionResponse2   {} = PacketKind 0x8d

pktKind OnionRequest3    {} = PacketKind 0x82
pktKind OnionResponse3   {} = PacketKind 0x8c

data PacketClass =
    AssymetricClass (Assymetric -> Packet) (Packet -> Assymetric)
    | AliasedClass (Aliased Assymetric -> Packet) (Packet -> Aliased Assymetric)
    | NoncedUnclaimedClass (Nonce8 -> UnclaimedAssymetric -> Packet)
                           (Packet -> (Nonce8, UnclaimedAssymetric))
    | Unclassified

pktClass :: PacketKind -> PacketClass
pktClass (PacketKind 0) = AssymetricClass Ping (\(Ping a) -> a)
pktClass (PacketKind 1) = AssymetricClass Pong (\(Pong a) -> a)
pktClass (PacketKind 2) = AssymetricClass GetNodes (\(GetNodes a) -> a)
pktClass (PacketKind 4) = AssymetricClass SendNodes (\(SendNodes a) -> a)

pktClass (PacketKind 0x18) = AssymetricClass CookieRequest (\(CookieRequest a) -> a)
pktClass (PacketKind 0x80) = AssymetricClass OnionRequest0 (\(OnionRequest0 a) -> a)
pktClass (PacketKind 0x86) = AssymetricClass (DataToRouteResponse . Aliased) (\(DataToRouteResponse (Aliased a)) -> a)

pkgClass (PacketKind 0x83) = AliasedClass Announce (\(Announce a)-> a)
pkgClass (PacketKind 0x84) = NoncedUnclaimedClass AnnounceResponse (\(AnnounceResponse n8 uncl)-> (n8,uncl))

    -- (indexConstr (dataTypeOf (error "dataTypeOf Packet" :: Packet)) 0) -- Ping

instance Serialize Packet where
    get = getPacket
    put = putPacket

getPacket = do
    typ <- get
    case pktClass typ of
        AssymetricClass toPacket _      -> toPacket <$> get
        AliasedClass    toPacket _      -> toPacket <$> get
        NoncedUnclaimedClass toPacket _ -> toPacket <$> get <*> get

putPacket p = do
    put $ pktKind p
    case pktClass (pktKind p) of
        AssymetricClass _ fromPacket      -> put $ fromPacket p
        AliasedClass    _ fromPacket      -> put $ fromPacket p
        NoncedUnclaimedClass _ fromPacket -> put $ fromPacket p -- putting a pair.

{-
data Packet' where
    :: Assymetric -> Packet
    :: UnclaimedAssymetric -> Packet
    :: Word16 -> ImplicitAssymetric -> Packet
    :: PubKey -> Assymetric -> Packet
    :: PubKey -> Packet
    :: Aliased Assymetric -> Symmetric -> Packet
    :: ByteString -> Symmetric -> Packet
    :: Aliased Assymetric -> Packet
    :: Symmetric -> ByteString -> Packet
    :: ByteString -> Packet
    :: Word32 -> ByteString -> Packet
-}