path: root/ToxTransport.hs

{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE DataKinds,KindSignatures #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE TupleSections #-}
module ToxTransport where

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

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

newtype SymmetricKey = SymmetricKey ByteString

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

transportDecrypt :: TransportCrypto -> Assym (Encrypted a) -> Either String a
transportDecrypt = _todo

-- layer :: TransportCrypto
          -- -> Transport String SockAddr    ByteString
          -- -> Transport String Tox.Address ByteString
-- layer crypto = layerTransport (toxParse crypto) (toxEncode crypto)

toxEncode :: TransportCrypto -> ByteString -> Tox.Address -> (ByteString, SockAddr)
toxEncode = _todo

-- toxParse :: TransportCrypto -> ByteString -> SockAddr -> Either String (ByteString, Tox.Address)
-- toxParse crypto bs saddr = case B.head bs of _todo

data Message = Todo | DHTReq DHTRequest | AnnounceReq AnnounceRequest

-- awaitMessage :: forall a. (Maybe (Either err (x, addr)) -> IO a) -> IO a

type UDPTransport = Transport String SockAddr ByteString

{-
toxTransport :: TransportCrypto -> Transport String SockAddr ByteString -> Transport String Tox.Address Message
toxTransport crypto (Transport await send close) = Transport await' send' close
 where
    await' :: HandleHi a -> IO a
    await' forMe = fix $ await . handleOnion crypto forMe

    send' = _todo
-}
toxTransport ::
      TransportCrypto
          -> UDPTransport
          -> IO ( Transport String NodeInfo (DirectMessage Encrypted8)
                , Transport String OnionToOwner (OnionMessage Encrypted)
                , Transport String SockAddr ByteString )
toxTransport crypto udp = do
    (dht,udp1) <- partitionTransport parseDHTAddr encodeDHTAddr id $ handleOnion crypto udp
    (onion,udp2) <- partitionTransport parseOnionAddr encodeOnionAddr id udp1
    return (dht,onion,udp2)


type HandleHi a = Maybe (Either String (Message, Tox.Address)) -> IO a
type HandleLo a = Maybe (Either String (ByteString, SockAddr)) -> IO a

data DirectMessage (f :: * -> *)
    = DirectPing (Assym (f Ping))
    | DirectPong (Assym (f Pong))
    | DirectGetNodes (Assym (f GetNodes))
    | DirectSendNodes (Assym (f SendNodes))
    | DirectCookieRequest (Assym (f CookieRequest))
    | DirectCookie Nonce24 (f Cookie)
    | DirectDHTRequest 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

getDirect :: Sized a => Get (Assym (Encrypted8 a))
getDirect = _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)
                  -> DirectMessage Encrypted8)
                  -> Either String (DirectMessage Encrypted8, NodeInfo)
direct bs saddr f = fanGet bs getDirect 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 (DirectMessage 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 DirectPing
    0x01 -> left $ direct bs saddr DirectPong
    0x02 -> left $ direct bs saddr DirectGetNodes
    0x04 -> left $ direct bs saddr DirectSendNodes
    0x18 -> left $ direct bs saddr DirectCookieRequest
    0x19 -> left $ fanGet bs getCookie (uncurry DirectCookie) (const $ noReplyAddr saddr)
    0x20 -> left $ fanGet bs getDHTReqest (uncurry DirectDHTRequest) (asymNodeInfo saddr . snd)
    _ -> right

encodeDHTAddr :: (DirectMessage 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

-- 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)

--   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

handleOnion :: TransportCrypto -> UDPTransport -> UDPTransport -- HandleHi a -> IO a -> HandleLo a
handleOnion 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

parseMessage :: Word8 -> ByteString -> Either String (Message,Address)
--     Announce :: Aliased Assymetric -> ReturnPath 3 -> Packet --0x83
parseMessage 0x83 bs = _todo -- Announce Request      OnionToOwner
parseMessage _ _ = _todo

handleDHTRequest :: forall a. TransportCrypto -> SockAddr -> HandleHi a -> IO a -> DHTRequestPacket -> IO a
handleDHTRequest crypto saddr forMe forThem (DHTRequestPacket target payload)
    | target == transportPublic crypto = forMe' payload
    | otherwise                        = _todo -- lookup target in close list, forward message
                                         >> forThem
 where
    forMe' :: Assym (Encrypted DHTRequest) -> IO a
    forMe' payload = do
        case (,) <$> transportDecrypt crypto payload <*> eaddr of
            Left e         -> forMe (Just (Left e))
            Right (p,addr) -> forMe (Just (Right (DHTReq p,addr)))

    eaddr :: Either String Tox.Address
    eaddr = fmap DHTNode $ nodeInfo (NodeId $ senderKey payload) saddr

data Attributed a = Attributed
    { author          :: PublicKey
    , attributedNonce :: Nonce24
    , attributed      :: a
    }

--   `0x83`       Announce Request      OnionToOwner
--   `0x85`       Onion Data Request    OnionToOwner
data OPacket -- payload of an onion request


--   `0x84`       Announce Response     -
--   `0x86`       Onion Data Response   -
data RPacket -- payload of an onion response

-- n = 0, 1, 2
data OnionRequest (n :: Nat) = OnionRequest
    { onionNonce    :: Nonce24
    , onionForward  :: Forwarding (3 - n) OPacket
    , 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  :: RPacket
    }

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 :: Attributed (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 Size a = ConstSize Int
            | VarSize (a -> Int)

data PacketChunk a
    = Plain a
    | Assymetric a
    | Symmetric a
    -}


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)
    }