Separated conduit parser and general tox-manager stuff.

1 files changed, 455 insertions, 9 deletions

diff --git a/ToxManager.hs b/ToxManager.hs
index 6d0149cf..6fb13c21 100644
--- a/ToxManager.hs
+++ b/ToxManager.hs
@@ -1,33 +1,59 @@
-{-# LANGUAGE CPP            #-}
-{-# LANGUAGE LambdaCase     #-}
-{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE CPP                      #-}
+{-# LANGUAGE LambdaCase               #-}
+{-# LANGUAGE NamedFieldPuns           #-}
+{-# LANGUAGE NondecreasingIndentation #-}
+{-# LANGUAGE ViewPatterns             #-}
+
 module ToxManager where
 
 import Announcer
 import Announcer.Tox
+import ClientState
 import Connection
--- import Control.Concurrent
 import Control.Concurrent.STM
 import Control.Monad
 import Crypto.Tox
+import Data.Bits
+import Data.Function
 import qualified Data.HashMap.Strict         as HashMap
 import qualified Data.Map                    as Map
 import Data.Maybe
+import qualified Data.Set                    as Set
 import qualified Data.Text                   as T
-import Network.Kademlia.Routing              as R
+         ;import Data.Text                   (Text)
+import Data.Time.Clock.POSIX
+import Data.Word
+import DPut
+import Network.Address
+import qualified Network.Kademlia.Routing    as R
+         ;import Network.Kademlia.Routing    as R
 import Network.Kademlia.Search
+import Network.QueryResponse
 import qualified Network.Tox                 as Tox
+         ;import Network.Tox
 import Network.Tox.ContactInfo               as Tox
 import qualified Network.Tox.Crypto.Handlers as Tox
--- import qualified Network.Tox.DHT.Handlers    as Tox
+         ;import Network.Tox.Crypto.Handlers (UponCookie (..))
+import Network.Tox.DHT.Handlers              (nodeSearch, nodesOfInterest)
+import Network.Tox.DHT.Handlers
 import qualified Network.Tox.DHT.Transport   as Tox
+         ;import Network.Tox.DHT.Transport   (FriendRequest (..), dhtpk)
+import Network.Tox.Handshake                 (HandshakeParams (..))
+import Network.Tox.NodeId
 import qualified Network.Tox.Onion.Handlers  as Tox
 import qualified Network.Tox.Onion.Transport as Tox
+         ;import Network.Tox.Onion.Transport (OnionData (..))
 import Presence
 import Text.Read
-import ToxToXMPP
-import XMPPServer
-import DPut
+import Util                                  (unsplitJID)
+import XMPPServer                            as XMPP
+#ifdef THREAD_DEBUG
+import Control.Concurrent.Lifted.Instrument
+#else
+import Control.Concurrent.Lifted
+import GHC.Conc                  (labelThread)
+#endif
+
 
 
 toxAnnounceSendData :: Tox.Tox JabberClients
@@ -154,3 +180,423 @@ toxman announcer toxbkts tox presence = ToxManager
             return $ addrToPeerKey . Remote . Tox.nodeAddr . snd <$> maddr
     }
 
+key2jid :: Word32 -> PublicKey -> Text
+key2jid nospam key = T.pack $ show $ NoSpamId nsp key
+ where
+    nsp = NoSpam nospam (Just sum)
+    sum = nlo `xor` nhi `xor` xorsum key
+    nlo = fromIntegral (0x0FFFF .&. nospam) :: Word16
+    nhi = fromIntegral (0x0FFFF .&. (nospam `shiftR` 16)) :: Word16
+
+type JabberClients = Map.Map ClientAddress PerClient
+
+data PerClient = PerClient
+    { pcDeliveredFRs :: TVar (Set.Set Tox.FriendRequest)
+    }
+
+initPerClient :: STM PerClient
+initPerClient = do
+    frs <- newTVar Set.empty
+    return PerClient
+        { pcDeliveredFRs = frs
+        }
+
+data ToxToXMPP = ToxToXMPP
+    { txAnnouncer :: Announcer
+    , txAccount   :: Account JabberClients
+    , txPresence  :: PresenceState
+    , txTox       :: Tox JabberClients
+    }
+
+default_nospam :: Word32
+default_nospam = 0x6a7a27fc -- big-endian base64: anon/A==
+
+nodeinfoStaleTime  :: POSIXTime
+nodeinfoStaleTime = 600
+
+nodeinfoSearchInterval :: POSIXTime
+nodeinfoSearchInterval = 15
+
+data Awaiting v = Since POSIXTime
+data Acquired v = At POSIXTime v
+data Moot v     = Moot
+
+data NNS a b c = NNS { -- NetcryptoNegotiationState
+  sessionDesired  :: Bool,
+  theirPublicKey  :: a Tox.DHTPublicKey,
+  theirAddress    :: b NodeInfo,
+  theirCookie     :: c (Tox.Cookie Encrypted),
+  sessionIsActive :: Bool
+}
+
+data NS
+  = Stage1 (NNS Moot Moot Moot)
+  | Stage2 (NNS Awaiting Moot Moot)
+  | Stage3 (NNS Acquired Awaiting Moot)
+  | Stage4 (NNS Acquired Acquired Awaiting)
+  | Stage5 (NNS Acquired Acquired Acquired)
+
+gotDhtPubkey :: Tox.DHTPublicKey -> ToxToXMPP -> PublicKey -> IO ()
+gotDhtPubkey theirDhtKey tx theirKey = do
+  contact <- atomically $ getContact theirKey (txAccount tx) >>= mapM (readTVar . contactLastSeenAddr)
+  forM_ contact $ \lastSeen -> do
+    case lastSeen of
+      Nothing -> doSearch
+      Just (tm, _) -> do
+        now <- getPOSIXTime
+        when (now - tm > nodeinfoStaleTime) doSearch
+  where
+    tox :: Tox JabberClients
+    tox = txTox tx
+
+    myPublicKey = toPublic $ userSecret (txAccount tx)
+    me = key2id myPublicKey
+
+    doSearch = do
+      let akey = akeyConnect (txAnnouncer tx) me theirKey
+      atomically $ registerNodeCallback (toxRouting tox) (nic akey)
+      scheduleSearch (txAnnouncer tx) akey meth theirDhtKey
+
+    target :: NodeId
+    target = key2id $ dhtpk theirDhtKey
+
+    meth :: SearchMethod Tox.DHTPublicKey
+    meth =
+      SearchMethod
+      { sSearch       = nodeSearch (toxDHT tox) (nodesOfInterest $ toxRouting tox)
+      , sNearestNodes = nearNodes tox
+      , sTarget       = target
+      , sInterval     = nodeinfoSearchInterval
+      , sWithResult   = \r sr -> return ()
+      }
+    nic akey =
+      NodeInfoCallback
+      { interestingNodeId = target
+      , listenerId        = 2
+      , observedAddress   = observe akey
+      , rumoredAddress    = assume akey
+      }
+
+    assume :: AnnounceKey -> POSIXTime -> SockAddr -> NodeInfo -> STM ()
+    assume akey time addr ni =
+      tput XNodeinfoSearch $ show ("rumor", akey, time, addr, ni)
+
+    observe :: AnnounceKey -> POSIXTime -> NodeInfo -> STM ()
+    observe akey time ni@(nodeAddr -> addr) = do
+      tput XNodeinfoSearch $ show ("observation", akey, time, addr)
+      setContactAddr time theirKey ni (txAccount tx)
+
+gotAddr :: NodeInfo -> ToxToXMPP -> PublicKey -> IO ()
+gotAddr ni@(nodeAddr -> addr) tx theirKey = do
+  dhtkey <- (fmap.fmap) snd $
+            fmap join $
+            atomically $
+            traverse readTVar =<< fmap contactKeyPacket <$> getContact theirKey (txAccount tx)
+  forM_ dhtkey $ gotAddr' ni tx theirKey
+
+gotAddr' :: NodeInfo -> ToxToXMPP -> PublicKey -> Tox.DHTPublicKey -> IO ()
+gotAddr' ni@(nodeAddr -> addr) tx theirKey theirDhtKey = atomically blee
+
+  where
+    myPublicKey = toPublic $ userSecret (txAccount tx)
+    me          = key2id myPublicKey
+    akey        = akeyConnect (txAnnouncer tx) me theirKey
+
+    blee = do
+      scheduleImmediately (txAnnouncer tx) akey $
+        ScheduledItem $ getCookie ni (activeSesh addr) (getContact theirKey (txAccount tx))
+
+    tox :: Tox JabberClients
+    tox = txTox tx
+
+    byAddr :: TVar (Map.Map SockAddr Tox.NetCryptoSession)
+    byAddr = Tox.netCryptoSessions (toxCryptoSessions tox)
+
+    crypto = Tox.transportCrypto $ toxCryptoSessions tox
+
+    readNcVar :: (Tox.NetCryptoSession -> TVar b) -> SockAddr -> STM (Maybe b)
+    readNcVar v addr = traverse readTVar =<< fmap v . Map.lookup addr <$> readTVar byAddr
+
+    chillSesh :: SockAddr -> STM (Maybe (Status Tox.ToxProgress))
+    chillSesh = readNcVar Tox.ncState
+
+    activeSesh :: SockAddr -> STM Bool
+    activeSesh a = chillSesh a >>= return . \case
+      Just Established -> True
+      _                -> False
+
+    readCookie :: SockAddr -> STM (Maybe (UponCookie (Tox.Cookie Encrypted)))
+    readCookie = readNcVar Tox.ncCookie
+    readCookie' :: SockAddr -> STM (Maybe (Tox.Cookie Encrypted))
+    readCookie' = fmap join . (fmap.fmap) Tox.toMaybe . readCookie
+
+    client :: Network.Tox.DHT.Handlers.Client
+    client = toxDHT tox
+
+    getCookie
+      :: NodeInfo
+      -> STM Bool
+      -> STM (Maybe Contact)
+      -> Announcer
+      -> AnnounceKey
+      -> POSIXTime
+      -> STM (IO ())
+    getCookie ni isActive getC ann akey now = getCookieAgain
+      where
+        getCookieAgain = do
+          tput XNodeinfoSearch $ show ("getCookieAgain", akey)
+          mbContact  <- getC
+          case mbContact of
+            Nothing      -> return $ return ()
+            Just contact -> do
+              active <- isActive
+              return $ when (not active) getCookieIO
+
+        callRealShakeHands = realShakeHands (userSecret (txAccount tx)) theirKey (dhtpk theirDhtKey) (toxCryptoSessions tox) (nodeAddr ni)
+
+        reschedule n f = scheduleRel ann akey f n
+        reschedule' n f = reschedule n (ScheduledItem $ \_ _ now -> f now)
+
+        cookieMaxAge = 60 * 5
+
+        getCookieIO :: IO ()
+        getCookieIO = do
+          dput XUnused "getCookieIO - entered"
+          cookieRequest crypto client myPublicKey ni >>= \case
+            Nothing -> atomically $ reschedule' 5 (const getCookieAgain)
+            Just cookie -> do
+              void $ callRealShakeHands cookie
+              cookieCreationStamp <- getPOSIXTime
+              let shaker :: POSIXTime -> STM (IO ())
+                  shaker now = do
+                    active <- isActive
+                    if (active)
+                      then return $ return ()
+                      else if (now > cookieCreationStamp + cookieMaxAge)
+                             then return $
+                                  dput XUnused "getCookieIO/shaker - cookie expired" >>
+                                  getCookieIO
+                             else do
+                               reschedule' 5 shaker
+                               return . void $ callRealShakeHands cookie
+              atomically $ reschedule' 5 shaker
+
+realShakeHands :: SecretKey -> PublicKey -> PublicKey -> Tox.NetCryptoSessions -> SockAddr -> Tox.Cookie Encrypted -> IO Bool
+realShakeHands myseckey theirpubkey theirDhtKey allsessions saddr cookie = do
+  dput XUnused "realShakeHands"
+  let hp =
+        HParam
+        { hpOtherCookie = cookie
+        , hpMySecretKey = myseckey
+        , hpCookieRemotePubkey = theirpubkey
+        , hpCookieRemoteDhtkey = theirDhtKey
+        , hpTheirBaseNonce = Nothing
+        , hpTheirSessionKeyPublic = Nothing
+        }
+  newsession <- generateSecretKey
+  timestamp <- getPOSIXTime
+  (myhandshake, ioAction) <-
+    atomically $
+    Tox.freshCryptoSession allsessions saddr newsession timestamp hp
+  ioAction
+  -- send handshake
+  isJust <$> forM myhandshake (Tox.sendHandshake allsessions saddr)
+
+dispatch :: ToxToXMPP -> ContactEvent -> IO ()
+dispatch tx (SessionEstablished theirKey)                    = stopConnecting tx theirKey "established"
+dispatch tx (SessionTerminated theirKey)                     = startConnecting tx theirKey "terminated"
+dispatch tx (AddrChange   theirKey saddr)                    = gotAddr saddr tx theirKey
+dispatch tx (PolicyChange theirkey TryingToConnect         ) = startConnecting tx theirkey "policy"
+dispatch tx (PolicyChange theirkey policy                  ) = stopConnecting tx theirkey "policy"
+dispatch tx (OnionRouted  theirKey (OnionDHTPublicKey pkey)) = gotDhtPubkey pkey tx theirKey
+dispatch tx (OnionRouted  theirkey (OnionFriendRequest fr) ) = do
+    let ToxToXMPP { txAnnouncer = acr
+                  , txAccount   = acnt
+                  , txPresence  = st } = tx
+    k2c <- atomically $ do
+        refs <- readTVar (accountExtra acnt)
+        k2c <- Map.intersectionWith (,) refs <$> readTVar (ckeyToChan st)
+        clients <- readTVar (clients st)
+        return $ Map.intersectionWith (,) k2c clients
+    -- TODO: Below we're using a hard coded default as their jabber user id.
+    -- This isn't the right thing, but we don't know their user-id.  Perhaps
+    -- there should be a way to parse it out of the friend request text.  Maybe
+    -- after a zero-termination, or as visible text (nospam:...).
+    let theirjid = key2jid default_nospam theirkey
+    forM_ k2c $ \((PerClient{pcDeliveredFRs},conn),client) -> do
+        alreadyDelivered <- atomically $ do
+            frs <- readTVar pcDeliveredFRs
+            writeTVar pcDeliveredFRs $ Set.insert fr frs
+            return $ Set.member fr frs
+        when (not alreadyDelivered) $ do
+        self <- localJID (clientUser client) (clientProfile client) (clientResource client)
+        ask <- presenceSolicitation theirjid self
+        -- TODO Send friend-request text as an instant message or at least
+        -- embed it in the stanza as a <status> element.
+        sendModifiedStanzaToClient ask (connChan conn)
+
+interweave :: [a] -> [a] -> [a]
+interweave []     ys = ys
+interweave (x:xs) ys = x : interweave ys xs
+
+akeyDHTKeyShare :: Announcer -> NodeId -> PublicKey -> AnnounceKey
+akeyDHTKeyShare announcer me them =
+    packAnnounceKey announcer $ "dhtkey(" ++ (take 8 $ show me) ++ ")" ++ show (key2id them)
+
+akeyConnect :: Announcer -> NodeId -> PublicKey -> AnnounceKey
+akeyConnect announcer me them =
+    packAnnounceKey announcer $ "connect(" ++ (take 8 $ show me) ++ ")" ++ show (key2id them)
+
+
+-- | Returns a list of nospam values to use for friend requests to send to a
+-- remote peer.  This list is non-empty only when it is desirable to send
+-- friend requests.
+checkSoliciting :: PresenceState -> PublicKey -> PublicKey -> Contact -> IO [NoSpam]
+checkSoliciting presence me them contact = do
+    let theirhost = T.pack $ show (key2id them) ++ ".tox"
+        myhost = T.pack $ show (key2id me) ++ ".tox"
+    xs <- getBuddiesAndSolicited presence myhost $ \h -> do
+        return $ T.toLower h == T.toLower theirhost
+    return $ do
+        (is_buddy,their_u,my_uid,xmpp_client_profile) <- xs
+        guard $ xmpp_client_profile == myhost
+        NoSpamId nospam _ <- case fmap T.unpack $ their_u of
+            Just ('$':_)     -> maybeToList $ readMaybe $ T.unpack $ unsplitJID (their_u,theirhost,Nothing)
+            Just ('0':'x':_) -> maybeToList $ readMaybe $ T.unpack $ unsplitJID (their_u,theirhost,Nothing)
+            _                -> maybeToList $ readMaybe $ T.unpack $ key2jid default_nospam them
+        return nospam
+
+nearNodes :: Tox extra -> NodeId -> STM [NodeInfo]
+nearNodes tox nid = do
+  bkts4 <- readTVar $ routing4 $ toxRouting tox
+  bkts6 <- readTVar $ routing6 $ toxRouting tox
+  let nss =
+        map
+          (R.kclosest (searchSpace (toxQSearch tox)) searchK nid)
+          [bkts4, bkts6]
+  return $ foldr interweave [] nss
+
+startConnecting0 :: ToxToXMPP -> PublicKey -> Contact -> String -> IO ()
+startConnecting0 tx them contact reason = do
+        dput XMan $ "START CONNECTING " ++ show (key2id them) ++ "("++reason++")"
+        -- TODO  When a connection is already established, this function should
+        -- be a no-op.  This occurs when an XMPP client disconnects and
+        -- reconnects while a session is established.
+        let ToxToXMPP { txTox       = tox
+                      , txAnnouncer = announcer
+                      , txAccount   = acnt     } = tx
+        let nearNodes nid = do
+                bkts4 <- readTVar $ routing4 $ toxRouting tox
+                bkts6 <- readTVar $ routing6 $ toxRouting tox
+                let nss = map (R.kclosest (searchSpace (toxQSearch tox)) searchK nid)
+                              [bkts4,bkts6]
+                return $ foldr interweave [] nss
+        wanted <- atomically $ (==Just TryingToConnect) <$> readTVar (contactPolicy contact)
+        let mypub = toPublic $ userSecret acnt
+            me  = key2id mypub
+        soliciting <- checkSoliciting (txPresence tx) mypub them contact
+        when wanted $ do
+            akey <- return $ akeyDHTKeyShare announcer me them
+                    -- We send this packet every 30 seconds if there is more
+                    -- than one peer (in the 8) that says they our friend is
+                    -- announced on them. This packet can also be sent through
+                    -- the DHT module as a DHT request packet (see DHT) if we
+                    -- know the DHT public key of the friend and are looking
+                    -- for them in the DHT but have not connected to them yet.
+                    -- 30 second is a reasonable timeout to not flood the
+                    -- network with too many packets while making sure the
+                    -- other will eventually receive the packet. Since packets
+                    -- are sent through every peer that knows the friend,
+                    -- resending it right away without waiting has a high
+                    -- likelihood of failure as the chances of packet loss
+                    -- happening to all (up to to 8) packets sent is low.
+                    --
+            let meth = SearchMethod (toxQSearch tox) onResult nearNodes (key2id them) 30
+                 where
+                  onResult theirkey rendezvous = do
+                    dkey <- Tox.getContactInfo tox
+                    let tr    = Tox.toxToRoute tox
+                        route = Tox.AnnouncedRendezvous theirkey rendezvous
+                    dput XMan $ unwords [ take 8 (show $ key2id mypub) ++ ":"
+                                        , "Sending my DHT-key"
+                                        , show (key2id $ Tox.dhtpk dkey)
+                                        , "to"
+                                        , show (key2id theirkey)
+                                        , "via"
+                                        , show (Tox.rendezvousNode rendezvous)
+                                        ]
+                    sendMessage tr route (mypub,Tox.OnionDHTPublicKey dkey)
+                    forM_ soliciting $ \cksum@(NoSpam nospam _)-> do
+                        dput XMan $ unwords [ take 8 (show $ key2id mypub) ++ ":"
+                                            , "Sending friend-request"
+                                            , "with nospam"
+                                            , "(" ++ nospam64 cksum ++ "," ++nospam16 cksum ++ ")"
+                                            , "to"
+                                            , show (key2id theirkey)
+                                            , "via"
+                                            , show (Tox.rendezvousNode rendezvous)
+                                            ]
+                        let fr = FriendRequest
+                                    { friendNoSpam      = nospam
+                                    , friendRequestText = "XMPP friend request"
+                                    }
+                        sendMessage tr route (mypub,Tox.OnionFriendRequest fr)
+            scheduleSearch announcer akey meth them
+
+startConnecting :: ToxToXMPP -> PublicKey -> String -> IO ()
+startConnecting tx them reason = do
+    mc <- atomically $ HashMap.lookup (key2id them)
+                        <$> readTVar (contacts $ txAccount tx)
+    forM_ mc $ flip (startConnecting0 tx them) reason
+
+
+stopConnecting :: ToxToXMPP -> PublicKey -> String -> IO ()
+stopConnecting ToxToXMPP{txAnnouncer=announcer,txAccount=acnt} them reason = do
+    dput XMan $ "STOP CONNECTING " ++ show (key2id them) ++ "("++reason++")"
+    let pub  = toPublic $ userSecret acnt
+        me   = key2id pub
+        akeyC = akeyConnect     announcer me them
+        akeyD = akeyDHTKeyShare announcer me them
+    cancel announcer akeyC
+    cancel announcer akeyD
+
+forkAccountWatcher :: Account JabberClients -> Tox JabberClients -> PresenceState -> Announcer -> IO ThreadId
+forkAccountWatcher acc tox st announcer = forkIO $ do
+    myThreadId >>= flip labelThread ("tox-xmpp:"
+                                      ++ show (key2id $ toPublic $ userSecret acc))
+    (chan,cs) <- atomically $ do
+                chan <- dupTChan $ eventChan acc -- duplicate broadcast channel for reading.
+                contacts <- readTVar (contacts acc)
+                return (chan,contacts)
+    let tx = ToxToXMPP { txAnnouncer = announcer
+                       , txAccount   = acc
+                       , txPresence  = st
+                       , txTox       = tox
+                       }
+    forM_ (HashMap.toList cs) $ \(them,c) -> do
+        startConnecting0 tx (id2key them) c "enabled account"
+
+    -- Loop endlessly until accountExtra is null.
+    fix $ \loop -> do
+    mev <- atomically $
+            (Just <$> readTChan chan)
+            `orElse` do
+                refs <- readTVar $ accountExtra acc
+                check $ Map.null refs
+                return Nothing
+
+    forM_ mev $ \ev -> dispatch tx ev >> loop
+
+    cs <- atomically $ readTVar (contacts acc)
+    forM_ (HashMap.toList cs) $ \(them,c) -> do
+        stopConnecting tx (id2key them) "disabled account"
+
+
+toxQSearch :: Tox extra -> Search Tox.NodeId (IP, PortNumber) Nonce32 Tox.NodeInfo Tox.Rendezvous
+toxQSearch tox = Tox.toxidSearch (Tox.onionTimeout tox) (Tox.toxCryptoKeys tox) (Tox.toxOnion tox)
+
+toxAnnounceInterval :: POSIXTime
+toxAnnounceInterval = 15
+
+
+