path: root/ToxTransport.hs

{-# LANGUAGE DataKinds                  #-}
{-# LANGUAGE GADTs                      #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE KindSignatures             #-}
{-# LANGUAGE LambdaCase                 #-}
{-# LANGUAGE ScopedTypeVariables        #-}
{-# LANGUAGE TupleSections              #-}
{-# LANGUAGE TypeOperators              #-}
module ToxTransport
    ( toxTransport

    , TransportCrypto(..)
    , SymmetricKey(..)
    , Encrypted8(..)

    , UDPTransport

    -- DHTTransport
    , DHTMessage(..)
    , Ping
    , Pong
    , GetNodes
    , SendNodes
    , CookieRequest
    , Cookie
    , DHTRequest

    -- OnionTransport
    , OnionToOwner(..)
    , OnionMessage(..)
    , DataToRoute(..)
    , AnnounceResponse(..)
    , AnnounceRequest(..)
    , Forwarding(..)
    , ReturnPath(..)
    , OnionRequest(..)
    , OnionResponse(..)
    , Addressed(..)

    -- CryptoTransport
    , NetCrypto(..)
    , CryptoData(..)
    , CryptoMessage(..)
    , CryptoPacket(..)
    , HandshakeData(..)
    , Handshake(..)

    ) where

import Network.QueryResponse
import ToxAddress            as Tox hiding (OnionToOwner, ReturnPath)
import ToxCrypto
import ToxPacket

import Control.Applicative
import Control.Arrow
import Control.Concurrent.STM
import Control.Monad
import Crypto.Hash
import Crypto.Hash.Algorithms
import qualified Data.ByteString as B
         ;import Data.ByteString (ByteString)
import Data.Serialize            as S (Get, Put, Serialize, decode, get, put,
                                       runGet)
import Data.Typeable
import Data.Word
import GHC.TypeLits
import Network.Socket

newtype SymmetricKey = SymmetricKey ByteString

data TransportCrypto = TransportCrypto
    { transportSecret :: SecretKey
    , transportPublic :: PublicKey
    , transportSymmetric :: STM SymmetricKey
    }

type UDPTransport = Transport String SockAddr ByteString
type DHTTransport = Transport String NodeInfo (DHTMessage Encrypted8)

toxTransport ::
      TransportCrypto
          -> (PublicKey -> IO (Maybe NodeInfo))
          -> UDPTransport
          -> IO ( Transport String NodeInfo (DHTMessage Encrypted8)
                , Transport String OnionToOwner (OnionMessage Encrypted)
                , Transport String SockAddr NetCrypto )
toxTransport crypto closeLookup udp = do
    (dht,udp1) <- partitionTransport parseDHTAddr encodeDHTAddr id $ forwardOnions crypto udp
    (onion,udp2) <- partitionTransport parseOnionAddr encodeOnionAddr id udp1
    let netcrypto = layerTransport parseNetCrypto encodeNetCrypto udp2
    return ( forwardDHTRequests crypto closeLookup dht
           , onion
           , netcrypto
           )


type HandleHi a = Maybe (Either String (DHTMessage Encrypted8, NodeInfo)) -> IO a
type HandleLo a = Maybe (Either String (ByteString, SockAddr)) -> IO a

data DHTMessage (f :: * -> *)
    = DHTPing (Assym (f Ping))
    | DHTPong (Assym (f Pong))
    | DHTGetNodes (Assym (f GetNodes))
    | DHTSendNodes (Assym (f SendNodes))
    | DHTCookieRequest (Assym (f CookieRequest))
    | DHTCookie Nonce24 (f Cookie)
    | DHTDHTRequest PublicKey (Assym (f DHTRequest))

instance Sized GetNodes where
    size = ConstSize 32 -- TODO This right?

instance Sized SendNodes where
    size = VarSize $ \(SendNodes ns) -> _nodeFormatSize * length ns

instance Sized Ping where size = ConstSize 1
instance Sized Pong where size = ConstSize 1

newtype Encrypted8 a = E8 (Encrypted (a,Nonce8))
 deriving Serialize

-- instance (Sized a, Sized b) => Sized (a,b) where size = _todo

getDHT :: Sized a => Get (Assym (Encrypted8 a))
getDHT = _todo

getOnionAssym :: Get (Assym (Encrypted DataToRoute))
getOnionAssym = _todo

getCookie :: Get (Nonce24, Encrypted8 Cookie)
getCookie = get

getDHTReqest :: Get (PublicKey, Assym (Encrypted8 DHTRequest))
getDHTReqest = _todo

fanGet :: ByteString -> Get x -> (x -> a) -> (x -> b) -> Either String (a,b)
fanGet bs getIt f nid = fmap (f &&& nid) $ runGet getIt bs

-- Throws an error if called with a non-internet socket.
direct :: Sized a => ByteString
                  -> SockAddr
                  -> (Assym (Encrypted8 a)
                  -> DHTMessage Encrypted8)
                  -> Either String (DHTMessage Encrypted8, NodeInfo)
direct bs saddr f = fanGet bs getDHT f (asymNodeInfo saddr)

-- Throws an error if called with a non-internet socket.
asymNodeInfo saddr asym = either (error . mappend "asymNodeInfo: ") id $ nodeInfo (NodeId $ senderKey asym) saddr

-- Throws an error if called with a non-internet socket.
noReplyAddr saddr = either (error . mappend "noReplyAddr: ") id $ nodeInfo zeroID saddr

parseDHTAddr :: (ByteString, SockAddr) -> Either (DHTMessage Encrypted8,NodeInfo) (ByteString,SockAddr)
parseDHTAddr (msg,saddr)
    | Just (typ,bs) <- B.uncons msg
    , let right = Right (msg,saddr)
          left  = either (const right) Left
    = case typ of
    0x00 -> left $ direct bs saddr DHTPing
    0x01 -> left $ direct bs saddr DHTPong
    0x02 -> left $ direct bs saddr DHTGetNodes
    0x04 -> left $ direct bs saddr DHTSendNodes
    0x18 -> left $ direct bs saddr DHTCookieRequest
    0x19 -> left $ fanGet bs getCookie (uncurry DHTCookie) (const $ noReplyAddr saddr)
    0x20 -> left $ fanGet bs getDHTReqest (uncurry DHTDHTRequest) (asymNodeInfo saddr . snd)
    _ -> right

encodeDHTAddr :: (DHTMessage Encrypted8,NodeInfo) -> (ByteString, SockAddr)
encodeDHTAddr = _todo


data OnionMessage (f :: * -> *)
    = OnionAnnounce (Assym (f (AnnounceRequest,Nonce8)))
    | OnionAnnounceResponse Nonce8 Nonce24 (f AnnounceResponse)
    | OnionToRoute PublicKey (Assym (f DataToRoute)) -- destination key, aliased Assym
    | OnionToRouteResponse (Assym (f DataToRoute))

data OnionToOwner = OnionToOwner NodeInfo (ReturnPath 3)
                  | OnionToMe SockAddr -- SockAddr is immediate peer in route

onionToOwner assym ret3 saddr = do
    ni <- nodeInfo (NodeId $ senderKey assym) saddr
    return $ OnionToOwner ni ret3

onion bs saddr getf = do (f,(assym,ret3)) <- runGet ((,) <$> getf <*> getOnionRequest) bs
                         oaddr <- onionToOwner assym ret3 saddr
                         return (f assym, oaddr)

parseOnionAddr :: (ByteString, SockAddr) -> Either (OnionMessage Encrypted,OnionToOwner) (ByteString,SockAddr)
parseOnionAddr (msg,saddr)
    | Just (typ,bs) <- B.uncons msg
    , let right = Right (msg,saddr)
          query = either (const right) Left
          response = either (const right) (Left . (, OnionToMe saddr))
    = case typ of
    0x83 -> query $ onion bs saddr (pure OnionAnnounce)                          -- Announce Request
    0x85 -> query $ onion bs saddr (OnionToRoute <$> getPublicKey)               -- Onion Data Request
    0x84 -> response $ runGet (OnionAnnounceResponse <$> get <*> get <*> get) bs -- Announce Response
    0x86 -> response $ runGet (OnionToRouteResponse <$> getOnionAssym) bs        -- Onion Data Response
    _ -> right

encodeOnionAddr :: (OnionMessage Encrypted,OnionToOwner) -> (ByteString, SockAddr)
encodeOnionAddr = _todo


-- data CookieAddress = WithoutCookie NodeInfo | CookieAddress Cookie SockAddr

data NetCrypto
    = NetHandshake (Handshake Encrypted)
    | NetCrypto (CryptoPacket Encrypted)

parseNetCrypto :: ByteString -> SockAddr -> Either String (NetCrypto, SockAddr)
parseNetCrypto = _todo

encodeNetCrypto :: NetCrypto -> SockAddr -> (ByteString, SockAddr)
encodeNetCrypto = _todo

data Handshake (f :: * -> *) = Handshake
    { handshakeCookie :: Cookie
    , handshakeNonce :: Nonce24
    , hadshakeData :: f HandshakeData
    }

data HandshakeData = HandshakeData
    { baseNonce :: Nonce24
    , sessionKey :: PublicKey
    , cookieHash :: Digest SHA512
    , otherCookie :: Cookie
    }

data CryptoPacket (f :: * -> *) = CryptoPacket
    { pktNonce :: Word16
    , pktData :: f CryptoData
    }

data CryptoData = CryptoData
    { -- | [our recvbuffers buffer_start, (highest packet number handled + 1), (big endian)]
      bufferStart :: Word32
      -- | [  uint32_t packet number if lossless
      --   , sendbuffer buffer_end  if lossy   , (big endian)]
    , bufferEnd :: Word32
      -- | [data]
    , bufferData :: CryptoMessage
    }

-- TODO: Flesh this out.
data CryptoMessage      -- First byte indicates data
    = Padding           -- ^ 0 padding (skipped until we hit a non zero (data id) byte)
    | PacketRequest     -- ^ 1 packet request packet (lossy packet)
    | KillPacket        -- ^ 2 connection kill packet (lossy packet)
    | UnspecifiedPacket -- ^ 3+ unspecified
    | MessengerLossless -- ^ 16+  reserved for Messenger usage (lossless packets)
    | MessengerLossy    -- ^ 192+ reserved for Messenger usage (lossy packets)
    | Messenger255      -- ^ 255 reserved for Messenger usage (lossless packet)



-- --> CookieRequest WithoutCookie
-- <-- CookieResponse CookieAddress
-- --> Handshake CookieAddress
-- <-- Handshake CookieAddress

-- Handshake packet:
--    [uint8_t 26] (0x1a)
--    [Cookie]
--    [nonce (24 bytes)]
--    [Encrypted message containing:
--        [24 bytes base nonce]
--        [session public key of the peer (32 bytes)]
--        [sha512 hash of the entire Cookie sitting outside the encrypted part]
--        [Other Cookie (used by the other to respond to the handshake packet)]
--    ]

-- cookie response packet (161 bytes):
--
--     [uint8_t 25]
--     [Random nonce (24 bytes)]
--     [Encrypted message containing:
--         [Cookie]
--         [uint64_t echo id (that was sent in the request)]
--     ]
--
--     Encrypted message is encrypted with the exact same symmetric key as the
--     cookie request packet it responds to but with a different nonce.
--     (Encrypted message is encrypted with reqesters's DHT private key,
--     responders's DHT public key and the nonce.)
--
--     Since we don't receive the public key, we will need to lookup the key by
--     the SockAddr... I don't understand why the CookieResponse message is
--     special this way.  TODO: implement a multimap (SockAddr -> SharedSecret)
--     and wrap cookie queries with store/delete.  TODO: Should the entire
--     SharedScret cache be keyed on only SockAddr ?  Perhaps the secret cache
--     should be (NodeId -> Secret) and the cookie-request map should be
--     (SockAddr -> NodeId)

-- Encrypted packets:
--
--  Length    Contents
-- :---------:--------------------------------------------------------------
--  `1`       `uint8_t` (0x1b)
--  `2`       `uint16_t` The last 2 bytes of the nonce used to encrypt this
--  variable   Payload
--
-- The payload is encrypted with the session key and 'base nonce' set by the
-- receiver in their handshake + packet number (starting at 0, big endian math).


--   Byte value   Packet Kind           Return address
-- :----------- :--------------------
--   `0x00`       Ping Request          DHTNode
--   `0x01`       Ping Response         -
--   `0x02`       Nodes Request         DHTNode
--   `0x04`       Nodes Response        -
--   `0x18`       Cookie Request        DHTNode, but without sending pubkey in response
--   `0x19`       Cookie Response       - (no pubkey)
--
--   `0x21`       LAN Discovery         DHTNode (No reply, port 33445, trigger Nodes Request/Response)
--
--   `0x20`       DHT Request           DHTNode/-forward
--
--   `0x1a`       Crypto Handshake      CookieAddress
--
--   `0x1b`       Crypto Data           SessionAddress
--
--   `0x83`       Announce Request      OnionToOwner
--   `0x84`       Announce Response     -
--   `0x85`       Onion Data Request    OnionToOwner
--   `0x86`       Onion Data Response   -
--
--   `0xf0`       Bootstrap Info        SockAddr?
--
--   `0x80`       Onion Request 0       -forward
--   `0x81`       Onion Request 1       -forward
--   `0x82`       Onion Request 2       -forward
--   `0x8c`       Onion Response 3      -return
--   `0x8d`       Onion Response 2      -return
--   `0x8e`       Onion Response 1      -return

forwardOnions :: TransportCrypto -> UDPTransport -> UDPTransport -- HandleHi a -> IO a -> HandleLo a
forwardOnions crypto udp = udp { awaitMessage = await' }
 where
    -- forMe :: HandleHi
    -- forThem :: handleLo
    await' :: HandleLo a -> IO a
    await' forThem = awaitMessage udp $ \case
        m@(Just (Right (bs,saddr))) -> case B.head bs of
            0x80 -> forward forThem bs $ handleOnionRequest (Proxy :: Proxy 0) crypto saddr (forThem m)
            0x81 -> forward forThem bs $ handleOnionRequest (Proxy :: Proxy 1) crypto saddr (forThem m)
            0x82 -> forward forThem bs $ handleOnionRequest (Proxy :: Proxy 2) crypto saddr (forThem m)
            0x8c -> forward forThem bs $ handleOnionResponse (Proxy :: Proxy 3) crypto saddr (forThem m)
            0x8d -> forward forThem bs $ handleOnionResponse (Proxy :: Proxy 2) crypto saddr (forThem m)
            0x8e -> forward forThem bs $ handleOnionResponse (Proxy :: Proxy 1) crypto saddr (forThem m)
            _    -> forThem m
        m -> forThem m

forward :: forall c b b1.
          Serialize b =>
              (Maybe (Either String b1) -> c) -> ByteString -> (b -> c) -> c
forward forMe bs f = either (forMe . Just . Left) f $ decode $ B.tail bs


forwardDHTRequests :: TransportCrypto -> (PublicKey -> IO (Maybe NodeInfo)) -> DHTTransport -> DHTTransport
forwardDHTRequests crypto closeLookup dht = dht { awaitMessage = await' }
 where
    await' :: HandleHi a -> IO a
    await' pass = awaitMessage dht $ \case
        Just (Right (m@(DHTDHTRequest target payload),src)) | target /= transportPublic crypto
            -> do mni <- closeLookup target
                  -- Forward the message if the target is in our close list.
                  forM_ mni $ \ni -> sendMessage dht ni m
                  await' pass
        m -> pass m


-- n = 0, 1, 2
data OnionRequest (n :: Nat) = OnionRequest
    { onionNonce    :: Nonce24
    , onionForward  :: Forwarding (3 - n) (OnionMessage Encrypted)
    , pathFromOwner :: ReturnPath n
    }

instance Serialize (OnionRequest n) where { get = _todo; put = _todo }
instance Serialize (OnionResponse n) where { get = _todo; put = _todo }

-- n = 1, 2, 3
-- Attributed (Encrypted (

data OnionResponse (n :: Nat) = OnionResponse
    { pathToOwner :: ReturnPath n
    , msgToOwner  :: OnionMessage Encrypted
    }

data Addressed a = Addressed { sockAddr :: SockAddr, unaddressed :: a }

data ReturnPath (n :: Nat) where
    NoReturnPath :: ReturnPath 0
    ReturnPath :: Nonce24 -> Encrypted (Addressed (ReturnPath n)) -> ReturnPath (n + 1)

data Forwarding (n :: Nat) msg where
    NotForwarded :: msg -> Forwarding 0 msg
    Forwarding :: Assym (Encrypted (Addressed (Forwarding n msg))) -> Forwarding (n + 1) msg

handleOnionRequest :: KnownNat n => proxy n -> TransportCrypto -> SockAddr -> IO a -> OnionRequest n -> IO a
handleOnionRequest = _todo

handleOnionResponse :: KnownNat n => proxy n -> TransportCrypto -> SockAddr -> IO a -> OnionResponse n -> IO a
handleOnionResponse = _todo

data AnnounceRequest = AnnounceRequest
    { announcePingId  :: Nonce32 -- Ping ID
    , announceSeeking :: NodeId  -- Public key we are searching for
    , announceKey     :: NodeId  -- Public key that we want those sending back data packets to use
    }

instance S.Serialize AnnounceRequest where
    get = AnnounceRequest <$> S.get <*> S.get <*> S.get
    put (AnnounceRequest p s k) = S.put (p,s,k)

getOnionRequest :: Get (Assym (Encrypted msg), ReturnPath 3)
getOnionRequest = _todo

data KeyRecord = NotStored    Nonce32
               | SendBackKey  PublicKey
               | Acknowledged Nonce32

getPublicKey :: Get PublicKey
getPublicKey = _todo

putPublicKey :: PublicKey -> Put
putPublicKey = _todo

instance S.Serialize KeyRecord where
    get = do
        is_stored <- S.get :: S.Get Word8
        case is_stored of
            1 -> SendBackKey  <$> getPublicKey
            2 -> Acknowledged <$> S.get
            _ -> NotStored    <$> S.get
    put (NotStored n32)    = S.put (0 :: Word8) >> S.put n32
    put (SendBackKey key)  = S.put (1 :: Word8) >> putPublicKey key
    put (Acknowledged n32) = S.put (2 :: Word8) >> S.put n32

data AnnounceResponse = AnnounceResponse
    { is_stored     :: KeyRecord
    , announceNodes :: SendNodes
    }

instance Sized AnnounceResponse where
    size = VarSize $ \AnnounceResponse {} -> _todo

instance S.Serialize AnnounceResponse where
    get = AnnounceResponse <$> S.get <*> S.get
    put (AnnounceResponse st ns) = S.put st >> S.put ns

data DataToRoute = DataToRoute
    { dataFromKey :: PublicKey
    , dataToRoute :: Encrypted (Word8,ByteString)
    }