1 files changed, 255 insertions, 0 deletions

diff --git a/src/Network/Tox.hs b/src/Network/Tox.hs
new file mode 100644
index 00000000..c88dbcd4
--- /dev/null
+++ b/src/Network/Tox.hs
@@ -0,0 +1,255 @@
+{-# 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 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.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.BitTorrent.DHT.Search          (Search (..))
+import qualified Network.DHT.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 hiding (Assym)
+import Network.Tox.Transport
+import Network.Tox.Address
+import qualified Network.Tox.DHT.Transport as DHT
+import qualified Network.Tox.DHT.Handlers as DHT
+import qualified Network.Tox.Onion.Transport as Onion
+import qualified Network.Tox.Onion.Handlers as Onion
+import Network.Tox.Crypto.Transport (NetCrypto)
+import Text.XXD
+
+newCrypto :: IO TransportCrypto
+newCrypto = do
+    secret <- generateSecretKey
+    let pubkey = toPublic secret
+    (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
+        , transportSymmetric = return $ SymmetricKey symkey
+        , transportNewNonce = do
+            drg1 <- readTVar noncevar
+            let (nonce, drg2) = withDRG drg1 (Nonce24 <$> getRandomBytes 24)
+            writeTVar noncevar drg2
+            return nonce
+        }
+
+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))
+                -> (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 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 (contramapT intKey intMapMethods) gen
+            intmap_var <- atomically $ newTVar (drg, mempty)
+            return $ Right (intmapT,intmap_var)
+         else do
+            let mapT = transactionMethods (contramapT 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 = tbl
+                }
+        mkclient (tbl,var) handlers =
+            let client = Client
+                    { clientNet           = addHandler (handleMessage client) $ modifynet client net
+                    , clientDispatcher    = dispatch tbl var handlers -- (fmap (contramapAddr (\(ToxPath ni _) -> ni)) . handlers)
+                    , clientErrorReporter = (printErrors stderr) { 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
+    , toxCrypto :: Transport String SockAddr NetCrypto
+    , toxRouting :: DHT.Routing
+    , toxTokens :: TVar SessionTokens
+    , toxAnnouncedKeys :: TVar Onion.AnnouncedKeys
+    }
+
+addVerbosity :: Show addr => Transport err addr ByteString -> Transport err addr 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])) $ 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])) $ 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
+
+newTox :: TVar Onion.AnnouncedKeys -> SockAddr -> IO Tox
+newTox keydb addr = do
+    udp <- addVerbosity <$> udpTransport addr
+    crypto <- newCrypto
+    drg <- drgNew
+    let lookupClose _ = return Nothing
+    (dhtcrypt,onioncrypt,cryptonet) <- toxTransport crypto lookupClose udp
+
+    routing <- DHT.newRouting addr crypto updateIP updateIP
+    let dhtnet0 = layerTransport (DHT.decrypt crypto) (DHT.encrypt crypto) dhtcrypt
+    dhtclient <- newClient drg dhtnet0 DHT.classify (myAddr routing) (DHT.handlers routing)
+                    $ \client net -> onInbound (DHT.updateRouting client routing) net
+
+    toks <- do
+        nil <- nullSessionTokens
+        atomically $ newTVar nil { maxInterval = 20 } -- 20 second timeout on announce ping-ids.
+    oniondrg <- drgNew
+    let onionnet = layerTransport (Onion.decrypt crypto) (Onion.encrypt crypto) onioncrypt
+    onionclient <- newClient oniondrg onionnet Onion.classify (const $ return $ Onion.OnionToMe addr)
+                    (Onion.handlers onionnet routing toks keydb)
+                    (const id)
+    return Tox
+        { toxDHT = dhtclient
+        , toxOnion = onionclient
+        , toxCrypto = cryptonet
+        , toxRouting = routing
+        , toxTokens = toks
+        , toxAnnouncedKeys = keydb
+        }
+
+forkTox :: Tox -> IO (IO ())
+forkTox tox = do
+    _ <- forkListener "toxCrypto" (toxCrypto tox)
+    _ <- forkListener "toxOnion" (clientNet $ toxOnion tox)
+    forkListener "toxDHT" (clientNet $ toxDHT tox)
+