summaryrefslogtreecommitdiff
path: root/HandshakeCache.hs
blob: 6f9d466fd8a71e3744e3c542cc57c85c08bc1a82 (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
module HandshakeCache where

import Control.Concurrent.STM
import Control.Monad
import Data.Functor.Identity
import qualified Data.Map.Strict as Map
         ;import Data.Map.Strict (Map)
import Data.Time.Clock.POSIX
import Network.Socket
import Data.Bool

import Crypto.Hash

import Crypto.Tox
import qualified Data.MinMaxPSQ     as MM
         ;import Data.MinMaxPSQ     (MinMaxPSQ')
import DPut
import Network.Tox.Crypto.Transport (Handshake, HandshakeData (..))
import Network.Tox.DHT.Handlers     (createCookieSTM)
import Network.Tox.DHT.Transport    (Cookie (..), CookieData (..), NodeInfo,
                                     key2id, nodeInfo)
import Network.Tox.Handshake

data HandshakeCache = HandshakeCache
    { -- Note that currently we are storing sent handshakes keyed by the
      -- remotely issued cookie.  This probably means that it's possible for
      -- one your contacts that you are trying to open a session with to
      -- prevent you from opening a session with another contact if they know
      -- the cookie that person issued you.
      hscTable  :: TVar (MinMaxPSQ' (Cookie Encrypted) POSIXTime (SecretKey,HandshakeData))
    , hscSend   :: SockAddr -> Handshake Encrypted -> IO ()
    , hscCrypto :: TransportCrypto
    , hscPendingCookies :: TVar (Map (PublicKey,PublicKey) ())
    }


newHandshakeCache :: TransportCrypto -> (SockAddr -> Handshake Encrypted -> IO ()) -> IO HandshakeCache
newHandshakeCache crypto send = atomically $ do
    tbl <- newTVar MM.empty
    pcs <- newTVar Map.empty
    return HandshakeCache
        { hscTable  = tbl
        , hscSend   = send
        , hscCrypto = crypto
        , hscPendingCookies = pcs
        }

getSentHandshake :: HandshakeCache
                    -> SecretKey
                    -> SockAddr
                    -> Cookie Identity -- locally issued
                    -> Cookie Encrypted -- remotely issued
                    -> IO (Maybe (SecretKey, HandshakeData))
getSentHandshake hscache me their_addr (Cookie _ (Identity cd)) ecookie = do
    now <- getPOSIXTime
    io <- atomically $ do
        m <- checkExpiry now . MM.lookup' ecookie <$> readTVar (hscTable hscache)
        case m of
            Just s  -> return $ return $ Just s
            Nothing -> do
                let them = longTermKey cd
                case nodeInfo (key2id $ dhtKey cd) their_addr of
                    Left _ -> return $ return Nothing -- Non-internet address.
                    Right their_node -> do
                        (s,hs) <- cacheHandshakeSTM hscache me them their_node ecookie now
                        return $ do
                            hscSend hscache their_addr hs
                            return $ Just s
    io


checkExpiry :: POSIXTime -> Maybe (POSIXTime,r) -> Maybe r
checkExpiry now m = do
    (tm,s) <- m
    guard $ tm + 5 {- seconds -} > now
    return s

hashCookie :: HashAlgorithm a => Cookie Encrypted -> Digest a
hashCookie (Cookie n24 encrypted)
    = hashFinalize $ hashUpdate (hashUpdate hashInit n24) encrypted

cacheHandshakeSTM :: HandshakeCache
                    -> SecretKey        -- ^ my ToxID key
                    -> PublicKey        -- ^ them
                    -> NodeInfo         -- ^ their DHT node
                    -> Cookie Encrypted -- ^ issued to me by them
                    -> POSIXTime        -- ^ current time
                    -> STM ((SecretKey,HandshakeData), Handshake Encrypted)
cacheHandshakeSTM hscache me them their_node ecookie timestamp = do
    newsession <- transportNewKey (hscCrypto hscache)
    freshCookie <- createCookieSTM timestamp (hscCrypto hscache) their_node them
    n24 <- transportNewNonce (hscCrypto hscache)
    let hsdata = HandshakeData
            { baseNonce   = n24
            , sessionKey  = toPublic newsession
            , cookieHash  = hashCookie ecookie
            , otherCookie = freshCookie
            }
    hs <- encodeHandshake timestamp (hscCrypto hscache) me them ecookie hsdata
    modifyTVar' (hscTable hscache) $ MM.insertTake' 20 ecookie (newsession,hsdata) timestamp
    return ((newsession,hsdata),hs)

cacheHandshake :: HandshakeCache
                    -> SecretKey
                    -> PublicKey
                    -> NodeInfo
                    -> Cookie Encrypted
                    -> IO (Handshake Encrypted)
cacheHandshake hscache me them their_node ecookie = do
    timestamp <- getPOSIXTime
    dput XNetCrypto $ "cacheHandshake " ++ show (key2id them,ecookie)
    atomically $ snd <$> cacheHandshakeSTM hscache me them their_node ecookie timestamp

haveCachedCookie :: HandshakeCache
                    -> PublicKey
                    -> PublicKey
                    -> STM Bool
haveCachedCookie hscache me them = do
    m <- Map.lookup (me,them) <$> readTVar (hscPendingCookies hscache)
    return $ maybe True (const False) m


setPendingCookie :: HandshakeCache
                    -> PublicKey
                    -> PublicKey
                    -> Bool
                    -> STM ()
setPendingCookie hscache me them pending = do
    modifyTVar' (hscPendingCookies hscache) $ Map.alter (const $ bool Nothing (Just ()) pending)
                                                        (me,them)