Tox-XMPP: Switched to z-base32 domain names.

6 files changed, 92 insertions, 39 deletions

diff --git a/dht/Presence/Presence.hs b/dht/Presence/Presence.hs
index a09a517d..dcc76c5b 100644
--- a/dht/Presence/Presence.hs
+++ b/dht/Presence/Presence.hs
@@ -251,7 +251,11 @@ chooseResourceName state k (Remote addr) clientsNameForMe desired = do
     flgs <- atomically $ newTVar 0
     profile <- fmap (fromMaybe ".")
         $ forM ((,) <$> clientsNameForMe <*> toxManager state) $ \(wanted_profile0,toxman) ->
-        case Text.splitAt 43 wanted_profile0 of
+        case splitLast4 wanted_profile0 of
+            ("*",".tox") -> do
+                dput XMisc $ "TODO: Match single tox key profile or generate first."
+                -- TODO: Match single tox key profile or generate first.
+                _todo
             (pub,".tox") -> do
                 cdir <- ConfigFiles.configPath (L.fromChunks [Text.encodeUtf8 user]) "." ""
 #if !MIN_VERSION_directory(1,2,5)
@@ -274,10 +278,6 @@ chooseResourceName state k (Remote addr) clientsNameForMe desired = do
                             -- fall back to the Unix account login.
                             dput XMisc "failed to find tox secret"
                             return "."
-            ("*.tox","") -> do
-                dput XMisc $ "TODO: Match single tox key profile or generate first."
-                -- TODO: Match single tox key profile or generate first.
-                _todo
             _ -> return "."
     let client = ClientState { clientResource = maybe "fallback" id mtty
                              , clientUser     = user
@@ -361,7 +361,7 @@ rosterGetStuff what state k = forClient state k (return [])
       PresenceState { server = sv } -> do
         let conns = manager state $ clientProfile client
         -- Grok peers to associate with from the roster:
-        let isTox = do (me  , ".tox") <- Just $ Text.splitAt 43 (clientProfile client)
+        let isTox = do (me  , ".tox") <- Just $ splitLast4 (clientProfile client)
                        return me
             noToxUsers (u,h,r)
                 | Text.isSuffixOf ".tox" h = unsplitJID (Nothing,h,r)
@@ -373,8 +373,8 @@ rosterGetStuff what state k = forClient state k (return [])
             let policySetter = fromMaybe (Connection.setPolicy conns host) $ do
                     isTox
                     toxman <- toxManager state
-                    (them, ".tox") <- Just $ Text.splitAt 43 host
-                    meid <- readMaybe $ Text.unpack $ Text.take 43 (clientProfile client)
+                    (them, ".tox") <- Just $ splitLast4 host
+                    meid <- readMaybe $ Text.unpack $ Text.dropEnd 4 (clientProfile client)
                     themid <- readMaybe $ Text.unpack them
                     return $ Connection.setPolicy (toxConnections toxman)
                                                   (ToxContact meid themid)
@@ -547,7 +547,7 @@ eofConn state saddr cdta = do
         Right (k,_) -> do
             forClient state k (return ()) $ \client -> do
             forM_ (toxManager state) $ \toxman -> do
-                case Text.splitAt 43 (clientProfile client) of
+                case splitLast4 (clientProfile client) of
                     (pub,".tox") -> deactivateAccount toxman k (clientProfile client)
                     _            -> return ()
             stanza <- makePresenceStanza "jabber:server" Nothing Offline
@@ -665,12 +665,12 @@ deliverMessage state fail msg =
                          -- In case the client sends us a lower-cased version of the base64
                          -- tox key hostname, we resolve it by comparing it with roster entries.
                          xs <- getBuddiesAndSolicited state (clientProfile client) $ \case
-                            rh | (_,".tox") <- Text.splitAt 43 rh
+                            rh | (_,".tox") <- splitLast4 rh
                                , Text.toLower rh == Text.toLower th
                                -> return True
                             _ -> return False
                          fmap join $ forM (listToMaybe xs) $ \(_,rmu,_,h) -> do
-                             let (them,_) = Text.splitAt 43 h
+                             let (them,_) = splitLast4 h
                              maddr <- resolveToxPeer toxman me them
                              let to' = unsplitJID (mu,h,rsc)
                              return $ fmap (to',) maddr
@@ -1168,17 +1168,21 @@ clientSubscriptionRequest state fail k stanza chan = do
                                      (connChan con)
         let policySetter = fromMaybe (Connection.setPolicy conns h) $ do
                 (toxman,_,_) <- weAreTox state client h
-                meid <- readMaybe $ Text.unpack $ Text.take 43 (clientProfile client)
+                meid <- readMaybe $ Text.unpack $ case splitLast4 (clientProfile client) of
+                            (h,".tox") -> h
+                            _          -> clientProfile client
                 themid <- readMaybe $ Text.unpack h
                 Just $ Connection.setPolicy (toxConnections toxman) (ToxContact meid themid)
         -- Add peer if we are not already associated ...
         policySetter Connection.TryingToConnect
 
+splitLast4 h = Text.splitAt (Text.length h - 4) h
+
 weAreTox :: PresenceState stat -> ClientState -> Text -> Maybe (ToxManager ClientAddress,Text{- me -},Text{- them -})
 weAreTox state client h = do
     toxman <- toxManager state
-    (me  , ".tox") <- Just $ Text.splitAt 43 (clientProfile client)
-    (them, ".tox") <- Just $ Text.splitAt 43 h
+    (me  , ".tox") <- Just $ splitLast4 (clientProfile client)
+    (them, ".tox") <- Just $ splitLast4 h
     return (toxman,me,them)
 
 resolvedFromRoster
diff --git a/dht/ToxManager.hs b/dht/ToxManager.hs
index dceb9210..51567b27 100644
--- a/dht/ToxManager.hs
+++ b/dht/ToxManager.hs
@@ -89,6 +89,13 @@ stringToKey_ s = let (xs,ys) = break (==':') s
                                        them <- readMaybe (drop 1 ys)
                                        return $ ToxContact me them
 
+dropExtension :: T.Text -> T.Text
+dropExtension pubname = case T.dropWhileEnd (/='.') pubname of
+    x | T.null x  -> pubname
+      | otherwise -> case T.dropEnd 1 pubname of
+            y | T.null y  -> pubname -- Avoid changing "." to empty string.
+              | otherwise -> y
+
 -- |
 --
 -- These hooks will be invoked in order to connect to *.tox hosts in a user's
@@ -139,7 +146,7 @@ toxman ssvar announcer toxbkts tox presence = ToxManager
     , deactivateAccount      = \k pubname -> do
        dput XMan $ "toxman DECTIVATE (todo) 1 " ++ show pubname
        let ContactInfo{ accounts } = Tox.toxContactInfo tox
-           mpubid = readMaybe $ T.unpack $ T.take 43 pubname
+           mpubid = readMaybe $ T.unpack $ dropExtension pubname
        bStopped <- fmap (fromMaybe Nothing) $ atomically $ do
         forM mpubid $ \pubid -> do
         refs <- do
diff --git a/dht/examples/dhtd.hs b/dht/examples/dhtd.hs
index 5f0eead8..3e9f8ff5 100644
--- a/dht/examples/dhtd.hs
+++ b/dht/examples/dhtd.hs
@@ -1302,21 +1302,27 @@ onNewToxSession sv ssvar invc ContactInfo{accounts} addrTox netcrypto = do
     return ()
 
 selectManager :: Maybe (t -> ToxManager clientAddress) -> Manager Tcp.TCPStatus T.Text -> T.Text -> Manager Pending T.Text
-selectManager mtman tcp profile = case T.splitAt 43 profile of
+selectManager mtman tcp profile = case T.splitAt (T.length profile - 4) profile of
     (k,".tox") | Just tman <- mtman
                -> let -- The following error call is safe because the toxConnections field
                       -- does not make use of the PresenceState passed to tman.
                       tox = toxConnections $ tman $ error "PresenseState"
                       tkey them = do
                         me <- readMaybe (T.unpack k)
-                        them <- case T.splitAt 43 them of
+                        them <- case T.splitAt 52 them of
                             (them0,".tox") -> readMaybe (T.unpack them0)
-                            _              -> Nothing
+                            _              -> case T.splitAt 43 them of
+                                (them0,".tox") -> readMaybe (T.unpack them0)
+                                _              -> Nothing
                         return (Tox.ToxContact me them)
                   in Manager
                     { resolvePeer = \themhost -> do
                         r <- fromMaybe (return []) $ do
-                            (themT,".tox") <- Just $ T.splitAt 43 themhost
+                            themT <- case T.splitAt 52 themhost of
+                                (ts,".tox") -> Just ts
+                                _           -> case T.splitAt 43 themhost of
+                                    (ts,".tox") -> Just ts
+                                    _           -> Nothing
                             them <- readMaybe $ T.unpack themT
                             me <- readMaybe $ T.unpack k
                             let contact = Tox.ToxContact me them
diff --git a/dht/src/Data/Tox/Msg.hs b/dht/src/Data/Tox/Msg.hs
index 8819faa7..2951193d 100644
--- a/dht/src/Data/Tox/Msg.hs
+++ b/dht/src/Data/Tox/Msg.hs
@@ -260,7 +260,7 @@ instance Read ChatID where
         | otherwise = []
 
 instance Show ChatID where
-    show (ChatID ed) = showToken32 ed
+    show (ChatID ed) = show64Token32 ed
 
 data InviteType = GroupInvite { groupName :: Text }
                 | AcceptedInvite
diff --git a/dht/src/Network/Tox/NodeId.hs b/dht/src/Network/Tox/NodeId.hs
index e0169199..311095ec 100644
--- a/dht/src/Network/Tox/NodeId.hs
+++ b/dht/src/Network/Tox/NodeId.hs
@@ -38,7 +38,8 @@ module Network.Tox.NodeId
     , ToxContact(..)
     , ToxProgress(..)
     , parseToken32
-    , showToken32
+    , show64Token32
+    , show32Token32
     , nodeInfoFromJSON
     ) where
 
@@ -61,6 +62,7 @@ import qualified Data.ByteArray               as BA
 import qualified Data.ByteString              as B
          ;import Data.ByteString              (ByteString)
 import qualified Data.ByteString.Base16       as Base16
+import qualified Data.ByteString.Base32.Z     as Base32
 import qualified Data.ByteString.Base64       as Base64
 import qualified Data.ByteString.Char8        as C8
 import Data.Char
@@ -173,22 +175,33 @@ nmtoken64 _     c   = c
 parseToken32 :: String -> Either String ByteString
 parseToken32 str = fmap (BA.drop 1) $ Base64.decode $ C8.pack $ 'A':map (nmtoken64 False) (take 43 str)
 
+-- | Parse 52-digit z-base32 token into 32-byte bytestring.
+parse32Token32 :: String -> Either String ByteString
+parse32Token32 str = fmap (BA.drop 1) $ Base32.decode $ C8.pack $ 'y':map (fixupDigit32 . toLower) (take 52 str)
+
 -- | Encode 32-byte bytestring as 43-digit base64 token.
-showToken32 :: ByteArrayAccess bin => bin -> String
-showToken32 bs = map (nmtoken64 True) $ C8.unpack $ BA.drop 1 $ Base64.encode $ BA.cons 0 $ BA.convert bs
+show64Token32 :: ByteArrayAccess bin => bin -> String
+show64Token32 bs = map (nmtoken64 True) $ C8.unpack $ BA.drop 1 $ Base64.encode $ BA.cons 0 $ BA.convert bs
+
+-- | Encode 32-byte bytestring as 52-digit z-base32 token.
+show32Token32 :: ByteArrayAccess bin => bin -> String
+show32Token32 bs = map (nmtoken64 True) $ C8.unpack $ BA.drop 1 $ Base32.encode $ BA.cons 0 $ BA.convert bs
 
 instance Read NodeId where
     readsPrec _ str
         | (bs,_) <- Base16.decode (C8.pack $ take 64 str)
         , CryptoPassed pub <- publicKey bs -- B.length bs == 32
                     = [ (key2id pub, drop (2 * B.length bs) str) ]
+        | Right bs <- parse32Token32 str
+        , CryptoPassed pub <- publicKey bs -- B.length bs == 32
+                    = [ (key2id pub, drop 52 str) ]
         | Right bs <- parseToken32 str
         , CryptoPassed pub <- publicKey bs -- B.length bs == 32
                     = [ (key2id pub, drop 43 str) ]
         | otherwise = []
 
 instance Show NodeId where
-    show nid = showToken32 $ id2key nid
+    show nid = show32Token32 $ id2key nid
 
 instance S.Serialize NodeId where
     get = key2id <$> getPublicKey
@@ -266,8 +279,12 @@ nodeInfoFromJSON prefer4 (JSON.Object v) = do
                       <|> maybe empty (return . IPv6) (ip6str >>= readMaybe)
                 else maybe empty (return . IPv6) (ip6str >>= readMaybe)
                       <|> maybe empty (return . IPv4) (ip4str >>= readMaybe)
-        let (bs,_) = Base16.decode (C8.pack nidstr)
-            enid   = Base64.decode (C8.pack $ 'A' : map (nmtoken64 False) nidstr)
+        let nidbs  = C8.pack nidstr
+            (bs,_) = Base16.decode nidbs
+            enid   = case C8.length nidbs of
+                        43 -> Base64.decode (C8.pack $ 'A' : map (nmtoken64 False) nidstr)
+                        52 -> Base32.decode (C8.pack $ 'y' : map (fixupDigit32 . toLower) nidstr)
+                        _  -> Left "Wrong size of node-id."
         idbs <- (guard (B.length bs == 32) >> return bs)
                 <|> either fail (return . B.drop 1) enid
         return $ NodeInfo (bs2id idbs) ip (fromIntegral (portnum :: Word16))
@@ -313,6 +330,21 @@ b64digit '-' = True
 b64digit '/' = True
 b64digit c = ('0' <= c && c <= '9') || ( 'a' <= c && c <= 'z') || ( 'A' <= c && c <= 'Z')
 
+zb32digit :: Char -> Bool
+zb32digit '1' = True
+zb32digit c = or [ '3' <= c && c <= '9'
+                 , 'a' <= c && c <= 'k'
+                 , 'm' <= c && c <= 'u'
+                 , 'w' <= c && c <= 'z'
+                 ]
+
+-- Apply substitutions for mistaken z-base32 digits.
+fixupDigit32 :: Char -> Char
+fixupDigit32 'l' = '1'
+fixupDigit32 '2' = 'z'
+fixupDigit32 'v' = 'u'
+fixupDigit32  c  =  c
+
 ip_w_port :: Int -> RP.ReadP (IP, PortNumber)
 ip_w_port i = do
             ip <- RP.between (RP.char '[') (RP.char ']')
@@ -326,19 +358,23 @@ ip_w_port i = do
 instance Read NodeInfo where
   readsPrec i = RP.readP_to_S $ do
     RP.skipSpaces
-    let n = 43 -- characters in node id.
-        parseAddr = RP.between (RP.char '(') (RP.char ')') (RP.munch (/=')'))
+    let parseAddr = RP.between (RP.char '(') (RP.char ')') (RP.munch (/=')'))
                       RP.+++ RP.munch (\c -> not (isSpace c) && not (c `elem` ("{}()"::[Char])))
-        nodeidAt = do (is64,hexhash) <-
-                        fmap (True,) (sequence $ replicate n (RP.satisfy b64digit))
-                          RP.+++ fmap (False,) (sequence $ replicate 64 (RP.satisfy isHexDigit))
+        nodeidAt = do (is64,hexhash) <- foldr1 (RP.+++)
+                        [ fmap (32,) (sequence $ replicate 52 (RP.satisfy zb32digit))
+                        , fmap (64,) (sequence $ replicate 43 (RP.satisfy b64digit))
+                        , fmap (16,) (sequence $ replicate 64 (RP.satisfy isHexDigit))
+                        ]
                       RP.char '@' RP.+++ RP.satisfy isSpace
                       addrstr <- parseAddr
-                      nid <- if is64
-                                then case Base64.decode $ C8.pack $ 'A' : map (nmtoken64 False) hexhash of
+                      nid <- case is64 of
+                        32 -> case Base32.decode $ C8.pack $ 'y' : map (fixupDigit32 . toLower) hexhash of
+                                  Right bs | B.length bs - 1==32 -> return (bs2id $ BA.drop 1 bs)
+                                  _                              -> fail "Bad node id."
+                        64 -> case Base64.decode $ C8.pack $ 'A' : map (nmtoken64 False) hexhash of
                                   Right bs | B.length bs - 1==32 -> return (bs2id $ BA.drop 1 bs)
                                   _                              -> fail "Bad node id."
-                                else case Base16.decode $ C8.pack hexhash of
+                        _  -> case Base16.decode $ C8.pack hexhash of
                                   (bs,rem) | B.length bs == 32 &&  B.null rem -> return (bs2id bs)
                                   _                                           -> fail "Bad node id."
                       return (nid,addrstr)
@@ -617,10 +653,10 @@ parseNoSpamJID jid = do
     (u,h) <- maybe (Left "Invalid JID.") Right
                 $ let (mu,h,_) = splitJID jid
                   in fmap (, h) mu
-    base64 <- case splitAt 43 $ Text.unpack h of
-                (base64,".tox") -> Right base64
-                _               -> Left "Hostname should be 43 base64 digits followed by .tox."
-    pub <- id2key <$> readEither base64
+    based <- case splitAt 52 $ Text.unpack h of
+                (base32,".tox") -> Right base32
+                _               -> Left "Hostname should be 52 z-base32 digits followed by .tox."
+    pub <- id2key <$> readEither based
     let ustr = Text.unpack u
     case ustr of
         '$' : b64digits       -> solveBase64NoSpamID b64digits pub
diff --git a/dht/vnet/screen-shell.sh b/dht/vnet/screen-shell.sh
index fa420b9d..ab274f39 100755
--- a/dht/vnet/screen-shell.sh
+++ b/dht/vnet/screen-shell.sh
@@ -11,4 +11,4 @@ digit=$(printf '%X' $count)
 cd ep$digit
 port=$(( 33400 + $count ))
 pwd
-../dhtd tox=$(ifaddr ep$digit):$port,bt=,xmpp=
+../dhtd --noavahi tox=$(ifaddr ep$digit):$port,bt=,xmpp= -v TCP,Onion