summaryrefslogtreecommitdiff
path: root/src/Network/Tox/Session.hs
blob: 88221b11ce7299d3b018f80a4167544579715b88 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
{-# LANGUAGE TupleSections #-}
module Network.Tox.Session where

import Control.Concurrent.STM
import Control.Monad
import Data.Functor.Identity
import Data.Word
import Network.Socket

import Crypto.Tox
import Data.PacketBuffer            (PacketInboundEvent (..))
import Data.Tox.Message
import DPut
import Network.Lossless
import Network.QueryResponse
import Network.SessionTransports
import Network.Tox.Crypto.Transport
import Network.Tox.DHT.Transport    (Cookie)
import Network.Tox.Handshake

type SessionKey = SecretKey

data SessionParams = SessionParams
    { spCrypto           :: TransportCrypto
    , spSessions         :: Sessions (CryptoPacket Encrypted)
    , spGetSentHandshake :: SecretKey -> SockAddr
                                      -> Cookie Identity
                                      -> Cookie Encrypted
                                      -> IO (Maybe (SessionKey, HandshakeData))
    , spOnNewSession     :: Session -> IO ()
    }

data Session = Session
    { sOurKey            :: SecretKey
    , sTheirAddr         :: SockAddr
    , sSentHandshake     :: HandshakeData
    , sReceivedHandshake :: Handshake Identity
    , sResendPackets     :: [Word32] -> IO ()
      -- ^ If they request that we re-send certain packets, this method is how
      -- that is accomplished.
    , sMissingInbound    :: IO ([Word32],Word32)
      -- ^ This list of sequence numbers should be periodically polled and if
      -- it is not empty, we should request they re-send these packets.  For
      -- convenience, a lower bound for the numbers in the list is also
      -- returned.  Suggested polling interval: a few seconds.
    , sTransport         :: Transport String () CryptoMessage
    , sSessionID         :: Int
    }

handshakeH :: SessionParams
              -> SockAddr
              -> Handshake Encrypted
              -> IO (Maybe a)
handshakeH sp saddr handshake = do
    decryptHandshake (spCrypto sp) handshake
        >>= either (\err -> return ())
                   (uncurry $ plainHandshakeH sp saddr)
    return Nothing


plainHandshakeH :: SessionParams
                   -> SockAddr
                   -> SecretKey
                   -> Handshake Identity
                   -> IO ()
plainHandshakeH sp saddr skey handshake = do
    let hd = runIdentity $ handshakeData handshake
        prelude = show saddr ++ " --> "
    dput XNetCrypto $ prelude ++ "handshake: " ++ show (otherCookie hd, baseNonce hd)
    sent <- spGetSentHandshake sp skey saddr (handshakeCookie handshake) (otherCookie hd)
    -- TODO: this is always returning sent = Nothing
    dput XNetCrypto $ prelude ++ "plainHandshakeH: cached outgoing: " ++ show (fmap (baseNonce . snd) sent)
    forM_ sent $ \(hd_skey,hd_sent) -> do
    sk <- SessionKeys (spCrypto sp)
                      hd_skey
                      (sessionKey hd)
                      <$> atomically (newTVar $ baseNonce hd)
                      <*> atomically (newTVar $ baseNonce hd_sent)
    m <- newSession (spSessions sp) (\() p -> return p) (decryptPacket sk) saddr
    dput XNetCrypto $ prelude ++ "plainHandshakeH: session " ++ maybe "Nothing" (const "Just") m
    forM_ m $ \(sid, t) -> do
        (t2,resend,getMissing)
            <- lossless (\cp a -> return $ fmap (,a) $ checkLossless $ runIdentity $ pktData cp)
                        (\seqno p _ -> encryptPacket sk $ bookKeeping seqno p)
                        ()
                        t
        let _ = t :: TransportA String () (CryptoPacket Identity) (CryptoPacket Encrypted)
            _ = t2 :: Transport String () CryptoMessage
        sendMessage t2 () $ OneByte ONLINE
        spOnNewSession sp Session
            { sOurKey            = skey
            , sTheirAddr         = saddr
            , sSentHandshake     = hd_sent
            , sReceivedHandshake = handshake
            , sResendPackets     = resend
            , sMissingInbound    = getMissing
            , sTransport         = t2
            , sSessionID         = sid
            }
    return ()

decryptPacket :: SessionKeys -> SockAddr -> CryptoPacket Encrypted -> IO (Maybe (CryptoPacket Identity, ()))
decryptPacket sk saddr (CryptoPacket n16 ciphered) = do
    (n,δ) <- atomically $ do
        n <- readTVar (skNonceIncoming sk)
        let δ = n16 - nonce24ToWord16 n
        return ( n `addtoNonce24` fromIntegral δ, δ )
    secret <- lookupSharedSecret (skCrypto sk) (skMe sk) (skThem sk) n
    case decodePlain =<< decrypt secret ciphered of
        Left e  -> return Nothing
        Right x -> do
            when ( δ  > 43690 )
                $ atomically $ writeTVar (skNonceIncoming sk) (n `addtoNonce24` 21845)
            return $ Just ( CryptoPacket n16 (pure x), () )

encryptPacket :: SessionKeys -> CryptoData -> IO (CryptoPacket Encrypted)
encryptPacket sk plain = do
    n24 <- atomically $ do
        n24 <- readTVar (skNonceOutgoing sk)
        modifyTVar' (skNonceOutgoing sk) incrementNonce24
        return n24
    secret <- lookupSharedSecret (skCrypto sk) (skMe sk) (skThem sk) n24
    let ciphered = encrypt secret $ encodePlain $ plain
    return $ CryptoPacket (nonce24ToWord16 n24) ciphered

data SessionKeys = SessionKeys
    { skCrypto        :: TransportCrypto
    , skMe            :: SecretKey
    , skThem          :: PublicKey
    , skNonceIncoming :: TVar Nonce24 -- +21845 when a threshold is reached.
    , skNonceOutgoing :: TVar Nonce24 -- +1 on every packet
    }


-- From spec.md:
--
--   Data in the encrypted packets:
--
--    [our recvbuffers buffer_start, (highest packet number handled + 1), (big endian)]
--    [uint32_t packet number if lossless, sendbuffer buffer_end if lossy, (big endian)]
--    [data]


bookKeeping :: SequenceInfo -> CryptoMessage -> CryptoData
bookKeeping (SequenceInfo seqno ack) m = CryptoData
    { bufferStart = ack   :: Word32
    , bufferEnd   = seqno :: Word32
    , bufferData  = m
    }

checkLossless :: CryptoData -> PacketInboundEvent CryptoMessage
checkLossless cd@CryptoData{ bufferStart = ack
                           , bufferEnd   = no
                           , bufferData  = x   } = tag no x' ack
 where
    x' = decodeRawCryptoMsg cd
    tag = case lossyness (msgID x') of Lossy -> PacketReceivedLossy
                                       _     -> PacketReceived