summaryrefslogtreecommitdiff
path: root/src/Network/Tox.hs
blob: 29591a230655c0336aadd595b704f8f3968f17a8 (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
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
{-# LANGUAGE DeriveDataTypeable         #-}
{-# LANGUAGE DeriveFoldable             #-}
{-# LANGUAGE DeriveFunctor              #-}
{-# LANGUAGE DeriveGeneric              #-}
{-# LANGUAGE DeriveTraversable          #-}
{-# LANGUAGE ExistentialQuantification  #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase                 #-}
{-# LANGUAGE NamedFieldPuns             #-}
{-# LANGUAGE PatternSynonyms            #-}
{-# LANGUAGE RankNTypes                 #-}
{-# LANGUAGE ScopedTypeVariables        #-}
{-# LANGUAGE TupleSections              #-}
module Network.Tox where

import Debug.Trace
import Control.Exception hiding (Handler)
import Control.Applicative
import Control.Arrow
import Control.Concurrent                     (MVar)
import Control.Concurrent.STM
import Control.Monad
import Control.Monad.Fix
import qualified Crypto.Cipher.ChaChaPoly1305 as Symmetric
import qualified Crypto.Cipher.Salsa          as Salsa
import qualified Crypto.Cipher.XSalsa         as XSalsa
import Crypto.ECC.Class
import qualified Crypto.Error                 as Cryptonite
import Crypto.Error.Types
import qualified Crypto.MAC.Poly1305          as Poly1305
import Crypto.PubKey.Curve25519
import Crypto.PubKey.ECC.Types
import Crypto.Random
import qualified Data.Aeson                   as JSON
         ;import Data.Aeson                   (FromJSON, ToJSON, (.=))
import Data.Bitraversable                     (bisequence)
import Data.Bits
import Data.Bits.ByteString                   ()
import Data.Bool
import qualified Data.ByteArray               as BA
         ;import Data.ByteArray               (ByteArrayAccess, Bytes)
import qualified Data.ByteString              as B
         ;import Data.ByteString              (ByteString)
import qualified Data.ByteString.Base16       as Base16
import qualified Data.ByteString.Char8        as C8
import Data.ByteString.Lazy                   (toStrict)
import Data.Char
import Data.Data
import Data.Functor.Contravariant
import Data.Hashable
import Data.IP
import Data.Maybe
import qualified Data.MinMaxPSQ               as MinMaxPSQ
         ;import Data.MinMaxPSQ               (MinMaxPSQ')
import Data.Monoid
import Data.Ord
import qualified Data.Serialize               as S
import Data.Time.Clock.POSIX                  (POSIXTime, getPOSIXTime)
import Data.Typeable
import Data.Word
import qualified Data.Wrapper.PSQ             as PSQ
         ;import Data.Wrapper.PSQ             (PSQ)
import qualified Data.Wrapper.PSQInt          as Int
import Foreign.Marshal.Alloc
import Foreign.Ptr
import Foreign.Storable
import GHC.Generics                           (Generic)
import System.Global6
import Network.Kademlia
import Network.Address                        (Address, WantIP (..), either4or6,
                                               fromSockAddr, ipFamily, setPort,
                                               sockAddrPort, testIdBit,
                                               toSockAddr, un4map)
import Network.Kademlia.Search          (Search (..))
import qualified Network.Kademlia.Routing          as R
import Network.QueryResponse
import Network.Socket
import System.Endian
import System.IO
import qualified Text.ParserCombinators.ReadP as RP
import Text.Printf
import Text.Read
import Control.TriadCommittee
import Network.BitTorrent.DHT.Token           as Token
import GHC.TypeLits

import Crypto.Tox
import Data.Word64Map                        (fitsInInt)
import Network.Tox.Crypto.Transport          (NetCrypto)
import qualified Network.Tox.DHT.Handlers    as DHT
import qualified Network.Tox.DHT.Transport   as DHT
import Network.Tox.NodeId
import qualified Network.Tox.Onion.Handlers  as Onion
import qualified Network.Tox.Onion.Transport as Onion
import Network.Tox.Transport
import OnionRouter
import Roster
import Text.XXD

newCrypto :: IO TransportCrypto
newCrypto = do
    secret <- generateSecretKey
    alias <- generateSecretKey
    ralias <- generateSecretKey
    let pubkey    = toPublic secret
        aliaspub  = toPublic alias
        raliaspub = toPublic ralias
    ukeys <- atomically $ newTVar []
    (symkey, drg) <- do
        drg0 <- getSystemDRG
        return $ randomBytesGenerate 32 drg0 :: IO (ByteString, SystemDRG)
    noncevar <- atomically $ newTVar $ fst $ withDRG drg drgNew
    hPutStrLn stderr $ "secret(tox) = " ++ DHT.showHex secret
    hPutStrLn stderr $ "public(tox) = " ++ DHT.showHex pubkey
    hPutStrLn stderr $ "symmetric(tox) = " ++ DHT.showHex symkey
    return TransportCrypto
        { transportSecret = secret
        , transportPublic = pubkey
        , onionAliasSecret = alias
        , onionAliasPublic = aliaspub
        , rendezvousSecret = ralias
        , rendezvousPublic = raliaspub
        , transportSymmetric = return $ SymmetricKey symkey
        , transportNewNonce = do
            drg1 <- readTVar noncevar
            let (nonce, drg2) = withDRG drg1 (Nonce24 <$> getRandomBytes 24)
            writeTVar noncevar drg2
            return nonce
        , userKeys = ukeys
        }

updateIP :: TVar (R.BucketList NodeInfo) -> SockAddr -> STM ()
updateIP tblvar a = do
    bkts <- readTVar tblvar
    case nodeInfo (nodeId (R.thisNode bkts)) a of
        Right ni -> writeTVar tblvar (bkts { R.thisNode = ni })
        Left _   -> return ()

genNonce24 :: DRG g =>
              TVar (g, pending) -> DHT.TransactionId -> IO DHT.TransactionId
genNonce24 var (DHT.TransactionId nonce8 _) = atomically $ do
    (g,pending) <- readTVar var
    let (bs, g') = randomBytesGenerate 24 g
    writeTVar var (g',pending)
    return $ DHT.TransactionId nonce8 (Nonce24 bs)


gen :: forall gen. DRG gen => gen -> (DHT.TransactionId, gen)
gen g = let (bs, g')  = randomBytesGenerate 24 g
            (ws, g'') = randomBytesGenerate 8 g'
            Right w   = S.runGet S.getWord64be ws
        in ( DHT.TransactionId (Nonce8 w) (Nonce24 bs), g'' )

intKey :: DHT.TransactionId -> Int
intKey (DHT.TransactionId (Nonce8 w) _) = fromIntegral w

nonceKey :: DHT.TransactionId -> Nonce8
nonceKey (DHT.TransactionId n _) = n

myAddr :: DHT.Routing -> Maybe NodeInfo -> IO NodeInfo
myAddr routing maddr = atomically $ do
    let var = case flip DHT.prefer4or6 Nothing <$> maddr of
                Just Want_IP6 -> DHT.routing6 routing
                _             -> DHT.routing4 routing
    a <- readTVar var
    return $ R.thisNode a

newClient :: (DRG g, Show addr, Show meth) =>
              g -> Transport String addr x
                -> (x -> MessageClass String meth DHT.TransactionId)
                -> (Maybe addr -> IO addr)
                -> (meth -> Maybe (MethodHandler String DHT.TransactionId addr x))
                -> (forall d. TransactionMethods d DHT.TransactionId addr x -> TransactionMethods d DHT.TransactionId addr x)
                -> (Client String meth DHT.TransactionId addr x -> Transport String addr x -> Transport String addr x)
                -> IO (Client String meth DHT.TransactionId addr x)
newClient drg net classify selfAddr handlers modifytbl modifynet = do
    -- If we have 8-byte keys for IntMap, then use it for transaction lookups.
    -- Otherwise, use ordinary Map.  The details of which will be hidden by an
    -- existential closure (see mkclient below).
    tblvar <-
      if fitsInInt (Proxy :: Proxy Word64)
        then do
            let intmapT = transactionMethods (contramap intKey intMapMethods) gen
            intmap_var <- atomically $ newTVar (drg, mempty)
            return $ Right (intmapT,intmap_var)
         else do
            let mapT = transactionMethods (contramap nonceKey mapMethods) gen
            map_var <- atomically $ newTVar (drg, mempty)
            return $ Left (mapT,map_var)
    let dispatch tbl var handlers = DispatchMethods
                { classifyInbound = classify
                , lookupHandler = handlers -- var
                , tableMethods = modifytbl tbl
                }
        eprinter = printErrors stderr
        mkclient (tbl,var) handlers =
            let client = Client
                    { clientNet           = addHandler eprinter (handleMessage client) $ modifynet client net
                    , clientDispatcher    = dispatch tbl var handlers
                    , clientErrorReporter = eprinter { reportTimeout = reportTimeout ignoreErrors }
                    , clientPending       = var
                    , clientAddress       = selfAddr
                    , clientResponseId    = genNonce24 var
                    }
            in client
    return $ either mkclient mkclient tblvar handlers

data Tox = Tox
    { toxDHT :: DHT.Client
    , toxOnion :: Onion.Client RouteId
    , toxToRoute :: Transport String Onion.AnnouncedRendezvous (PublicKey,Onion.OnionData)
    , toxCrypto :: Transport String SockAddr NetCrypto
    , toxCryptoKeys :: TransportCrypto
    , toxRouting :: DHT.Routing
    , toxTokens :: TVar SessionTokens
    , toxAnnouncedKeys :: TVar Onion.AnnouncedKeys
    , toxOnionRoutes :: OnionRouter
    , toxRoster :: Roster
    }

getContactInfo :: Tox -> IO DHT.DHTPublicKey
getContactInfo Tox{toxCryptoKeys,toxRouting} = join $ atomically $ do
    r4 <- readTVar $ DHT.routing4 toxRouting
    r6 <- readTVar $ DHT.routing6 toxRouting
    nonce <- transportNewNonce toxCryptoKeys
    let self = nodeId n4
        n4 = R.thisNode r4
        n6 = R.thisNode r6
        n4s = R.kclosest DHT.toxSpace 4 self r4
        n6s = R.kclosest DHT.toxSpace 4 self r6
        ns = filter (DHT.isGlobal . nodeIP) [n4,n6]
              ++ concat (zipWith (\a b -> [a,b]) n4s n6s)
    return $ do
    timestamp <- round . (* 1000000) <$> getPOSIXTime
    return DHT.DHTPublicKey
        { dhtpkNonce = timestamp
        , dhtpk      = id2key self
        , dhtpkNodes = DHT.SendNodes $ take 4 ns
        }

isLocalHost :: SockAddr -> Bool
isLocalHost (SockAddrInet _ host32) = (fromBE32 host32 == 0x7f000001)
isLocalHost _                       = False

addVerbosity :: Transport err SockAddr ByteString -> Transport err SockAddr ByteString
addVerbosity tr =
    tr { awaitMessage = \kont -> awaitMessage tr $ \m -> do
            forM_ m $ mapM_ $ \(msg,addr) -> do
                when (not (B.null msg || elem (B.head msg) [0,1,2,4,0x81,0x82,0x8c,0x8d])) $ do
                    mapM_ (\x -> hPutStrLn stderr ( (show addr) ++ " --> " ++ x))
                          $ xxd 0 msg
            kont m
       , sendMessage = \addr msg -> do
            when (not (B.null msg || elem (B.head msg) [0,1,2,4,0x81,0x8c,0x8d])) $ do
                mapM_ (\x -> hPutStrLn stderr ( (show addr) ++ " <-- " ++ x))
                      $ xxd 0 msg
            sendMessage tr addr msg
       }

newKeysDatabase :: IO (TVar Onion.AnnouncedKeys)
newKeysDatabase =
    atomically $ newTVar $ Onion.AnnouncedKeys PSQ.empty MinMaxPSQ.empty


getOnionAlias :: TransportCrypto -> STM NodeInfo -> Maybe (Onion.OnionDestination r) -> IO (Onion.OnionDestination r)
getOnionAlias crypto dhtself remoteNode = atomically $ do
    ni <- dhtself
    let alias = case remoteNode of
            Just (Onion.OnionDestination (Onion.AnnouncingAlias _ uk) _ _)
              -> ni { nodeId = key2id uk }
            _ -> ni { nodeId = key2id (onionAliasPublic crypto) }
    return $ Onion.OnionDestination Onion.SearchingAlias alias Nothing


newTox :: TVar Onion.AnnouncedKeys -> SockAddr -> IO Tox
newTox keydb addr = do
    udp <- addVerbosity <$> udpTransport addr
    crypto <- newCrypto
    drg <- drgNew
    let lookupClose _ = return Nothing

    routing <- DHT.newRouting addr crypto updateIP updateIP
    orouter <- newOnionRouter
    (dhtcrypt,onioncrypt,dtacrypt,cryptonet) <- toxTransport crypto orouter lookupClose udp
    let dhtnet0 = layerTransport (DHT.decrypt crypto) (DHT.encrypt crypto) dhtcrypt
    dhtclient <- newClient drg dhtnet0 DHT.classify (myAddr routing) (DHT.handlers routing) id
                    $ \client net -> onInbound (DHT.updateRouting client routing orouter) net

    orouter <- forkRouteBuilder orouter $ \nid ni -> maybe [] (\(_,ns,_)->ns) <$> DHT.getNodes dhtclient nid ni

    toks <- do
        nil <- nullSessionTokens
        atomically $ newTVar nil { maxInterval = 20 } -- 20 second timeout on announce ping-ids.
    oniondrg <- drgNew
    let onionnet = layerTransportM (Onion.decrypt crypto) (Onion.encrypt crypto) onioncrypt
    onionclient <- newClient oniondrg onionnet Onion.classify
                    (getOnionAlias crypto $ R.thisNode <$> readTVar (DHT.routing4 routing))
                    (Onion.handlers onionnet routing toks keydb)
                    (hookQueries orouter DHT.transactionKey)
                    (const id)

    roster <- newRoster
    return Tox
        { toxDHT = dhtclient
        , toxOnion = onionclient
        , toxToRoute = onInbound (updateRoster roster) dtacrypt
        , toxCrypto = cryptonet
        , toxCryptoKeys = crypto
        , toxRouting = routing
        , toxTokens = toks
        , toxAnnouncedKeys = keydb
        , toxOnionRoutes = orouter
        , toxRoster = roster
        }

onionTimeout :: Tox -> DHT.TransactionId -> Onion.OnionDestination RouteId -> STM (Onion.OnionDestination RouteId, Int)
onionTimeout Tox { toxOnionRoutes = or } (DHT.TransactionId n8 _) od = lookupTimeout or n8 od

forkTox :: Tox -> IO (IO ())
forkTox tox = do
    _ <- forkListener "toxCrypto" (toxCrypto tox)
    _ <- forkListener "toxToRoute" (toxToRoute tox)
    _ <- forkListener "toxOnion" (clientNet $ toxOnion tox)
    forkListener "toxDHT" (clientNet $ toxDHT tox)