Separated conduit parser and general tox-manager stuff.

1 files changed, 11 insertions, 489 deletions

diff --git a/ToxToXMPP.hs b/ToxToXMPP.hs
index 9979526a..1493827a 100644
--- a/ToxToXMPP.hs
+++ b/ToxToXMPP.hs
@@ -3,80 +3,22 @@
 {-# LANGUAGE NamedFieldPuns           #-}
 {-# LANGUAGE NondecreasingIndentation #-}
 {-# LANGUAGE ViewPatterns             #-}
-module ToxToXMPP
-    ( forkAccountWatcher
-    , JabberClients
-    , PerClient
-    , initPerClient
-    , toxQSearch
-    , toxAnnounceInterval
-    , xmppToTox
-    , toxToXmpp
-    , interweave
-    ) where
+module ToxToXMPP where
 
-import Control.Applicative
-import Data.Conduit                    as C
-import qualified Data.Conduit.List     as CL
+import Crypto.Tox
+import Data.Conduit                 as C
+import qualified Data.Conduit.List  as CL
 import Data.Monoid
-import Data.Text.Encoding              as T
-import Data.XML.Types                  as XML
+import qualified Data.Text          as T
+         ;import Data.Text          (Text)
+import Data.Text.Encoding           as T
+import Data.XML.Types               as XML
 import EventUtil
-import Network.Tox.Crypto.Transport    as Tox
-import Network.Tox.Handshake           (HandshakeParams (..))
-import qualified Text.XML.Stream.Parse as XML
-import Util                            (unsplitJID)
-import XMPPServer                      as XMPP
-
-
-import Announcer
-import Announcer.Tox
-import Connection
-import Network.QueryResponse
-import Network.Tox.DHT.Handlers (nodeSearch, nodesOfInterest)
--- import Control.Concurrent
-import Control.Concurrent.STM
-import Control.Monad
-import Crypto.Tox
-import qualified Data.HashMap.Strict         as HashMap
-import Data.Maybe
-import qualified Data.Set                    as Set
-import qualified Data.Text                   as T
-import Data.Time.Clock.POSIX
 import Network.Address
-import Network.Kademlia.Search
-import qualified Network.Tox                 as Tox
-import Network.Tox.ContactInfo               as Tox
-import qualified Network.Tox.Crypto.Handlers as Tox
-         ;import Network.Tox.Crypto.Handlers (UponCookie (..))
--- import qualified Network.Tox.DHT.Handlers    as Tox
-import ClientState
-import Data.Bits
-import Data.Function
-import qualified Data.Map                    as Map
-import Data.Text                             (Text)
-import Data.Word
-import qualified Network.Kademlia.Routing    as R
-import Network.Tox
-import Network.Tox.DHT.Handlers
-import qualified Network.Tox.DHT.Transport   as Tox
-         ;import Network.Tox.DHT.Transport   (FriendRequest (..), dhtpk)
+import Network.Tox.Crypto.Transport as Tox
 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 XMPPServer                            (ClientAddress)
-#ifdef THREAD_DEBUG
-import Control.Concurrent.Lifted.Instrument
-#else
-import Control.Concurrent.Lifted
-import GHC.Conc                  (labelThread)
-#endif
-import DPut
-import Nesting
-import XMPPToTox
+import Util                         (unsplitJID)
+import XMPPServer                   as XMPP
 
 toxToXmpp :: Monad m => SockAddr -> PublicKey -> Text -> Conduit Tox.CryptoMessage m XML.Event
 toxToXmpp laddr me theirhost = do
@@ -126,423 +68,3 @@ xmppInstantMessage namespace mfrom mto style text = do
     C.yield $   EventEndElement "{http://jabber.org/protocol/xhtml-im}html"
     C.yield $ EventEndElement (ns "message")
 
-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
-
-
-