2 files changed, 101 insertions, 27 deletions

diff --git a/src/Network/Tox/DHT/Transport.hs b/src/Network/Tox/DHT/Transport.hs
index 2e5649d3..51ec2e80 100644
--- a/src/Network/Tox/DHT/Transport.hs
+++ b/src/Network/Tox/DHT/Transport.hs
@@ -260,30 +260,6 @@ data FriendRequest = FriendRequest
     }
  deriving (Eq, Show)
 
-data NoSpam = NoSpam !Word32 !(Maybe Word16)
-
-instance Read NoSpam where
-    readsPrec d s = case break isSpace s of
-        (ws,rs) | (length ws == 8)  -> base64decode rs (NoSpam <$> get <*> (Just <$> get)) ws
-        (ws,rs) | (length ws == 12) -> base16decode rs (NoSpam <$> get <*> (Just <$> get)) ws
-        _                           -> []
-
-base64decode :: Monad m => t1 -> Get t -> String -> m (t, t1)
-base64decode rs getter s =
-    either fail (\a -> return (a,rs))
-        $ runGet getter
-           =<< Base64.decode (B8.pack s)
-
-base16decode :: Monad m => t1 -> Get t -> String -> m (t, t1)
-base16decode rs getter s =
-    either fail (\a -> return (a,rs))
-        $ runGet getter
-        $ fst
-        $ Base16.decode (B8.pack s)
-
-verifyChecksum :: PublicKey -> Word16 -> Either String ()
-verifyChecksum _ _ = return () -- TODO
-
 
 -- When sent as a DHT request packet (this is the data sent in the DHT request
 -- packet):
diff --git a/src/Network/Tox/NodeId.hs b/src/Network/Tox/NodeId.hs
index 95604108..0ffc3d22 100644
--- a/src/Network/Tox/NodeId.hs
+++ b/src/Network/Tox/NodeId.hs
@@ -10,6 +10,7 @@
 {-# LANGUAGE GADTs                      #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE KindSignatures             #-}
+{-# LANGUAGE LambdaCase                 #-}
 {-# LANGUAGE PatternSynonyms            #-}
 {-# LANGUAGE ScopedTypeVariables        #-}
 {-# LANGUAGE TupleSections              #-}
@@ -25,8 +26,14 @@ module Network.Tox.NodeId
     , getIP
     , xorNodeId
     , testNodeIdBit
-    , sampleNodeId) where
-
+    , sampleNodeId
+    , NoSpam(..)
+    , NoSpamId(..)
+    , parseNoSpamId
+    , nospam64
+    , verifyChecksum) where
+
+import Debug.Trace
 import Control.Applicative
 import Control.Arrow
 import Control.Monad
@@ -47,6 +54,8 @@ import Data.Char
 import Data.Data
 import Data.Hashable
 import Data.IP
+import Data.List
+import Data.Maybe
 import Data.Serialize                         as S
 import Data.Word
 import Foreign.Storable
@@ -54,12 +63,16 @@ import GHC.TypeLits
 import Network.Address                        hiding (nodePort)
 import System.IO.Unsafe                       (unsafeDupablePerformIO)
 import qualified Text.ParserCombinators.ReadP as RP
-import Text.Read
+import Text.Read hiding (get)
 import Data.Bits
 import Crypto.Tox
 import Foreign.Ptr
 import Data.Function
 import System.Endian
+import qualified Data.Text as Text
+         ;import Data.Text (Text)
+import Util (splitJID)
+import Text.Printf
 
 -- | perform io for hashes that do allocation and ffi.
 -- unsafeDupablePerformIO is used when possible as the
@@ -468,3 +481,88 @@ class KnownNat n => OnionPacket n where
 instance OnionPacket 0 where mkOnion _ = id
 instance OnionPacket 3 where mkOnion = OnionResponse3
 -}
+
+data NoSpam = NoSpam !Word32 !(Maybe Word16)
+ deriving (Eq,Ord,Show)
+
+instance Read NoSpam where
+    readsPrec d s = case break isSpace s of
+        ('$':ws    ,rs) | (length ws == 8)  -> base64decode rs (NoSpam <$> get <*> (Just <$> get)) ws
+        ('0':'x':ws,rs) | (length ws == 12) -> base16decode rs (NoSpam <$> get <*> (Just <$> get)) ws
+        _                                   -> []
+
+base64decode :: Monad m => t1 -> Get t -> String -> m (t, t1)
+base64decode rs getter s =
+    either fail (\a -> return (a,rs))
+        $ runGet getter
+           =<< Base64.decode (C8.pack $ map (nmtoken64 False) s)
+
+base16decode :: Monad m => t1 -> Get t -> String -> m (t, t1)
+base16decode rs getter s =
+    either fail (\a -> return (a,rs))
+        $ runGet getter
+        $ fst
+        $ Base16.decode (C8.pack s)
+
+verifyChecksum :: PublicKey -> Word16 -> Either String ()
+verifyChecksum _ _ = return () -- TODO
+
+data NoSpamId = NoSpamId NoSpam PublicKey
+ deriving (Eq,Ord)
+
+
+nospam64 :: NoSpam -> String
+nospam64 (NoSpam w32 Nothing) = n ++ "???"
+    where n = take 5 $ nospam64 (NoSpam w32 (Just 0))
+nospam64 (NoSpam w32 (Just w16)) = map (nmtoken64 True) $ C8.unpack $ Base64.encode $ runPut $ do
+    put w32
+    put w16
+
+instance Show NoSpamId where
+    show (NoSpamId nspam pub) = '$' : nospam64 nspam ++ "@" ++ show (key2id pub) ++ ".tox"
+
+instance Read NoSpamId where
+    readsPrec d s = either fail id $ do
+        (jid,xs) <- Right $ break isSpace s
+        nsid <- parseNoSpamId $ Text.pack jid
+        return [(nsid,xs)]
+
+parseNoSpamId :: Text -> Either String NoSpamId
+parseNoSpamId jid = do
+    (Just u,h,_) <- Right $ splitJID jid
+    (base64,".tox") <- Right $ splitAt 43 $ Text.unpack h
+    pub <- id2key <$> readEither base64
+    let ustr = Text.unpack u
+    '$' : b64digits <- Right ustr -- TODO: support 0x prefix also.
+    NoSpam nospam (Just x) <- readEither $ map (\case; '?' -> '0'; c -> c) ustr
+    let nlo = fromIntegral nospam :: Word16
+        nhi = fromIntegral (nospam `shiftR` 16) :: Word16
+        sum = x `xor` nlo `xor` nhi `xor` xorsum pub
+        -- Find any question mark indices.
+        qs  = catMaybes $ zipWith (\case; '?' -> Just ; _ -> const Nothing) b64digits [0..7]
+        -- Break up the /sum/ into a numbered list of two-bit non-zero nibbles.
+        ns  = filter (\case; (_,0) -> False; _ -> True)
+              $ zip [0..7]
+              $ unfoldr (\s -> Just (s .&. 0xC000, s `shiftL` 2)) sum
+        -- Represent the nospam value as a Word64
+        n64 = shiftL (fromIntegral nospam) 32 .|. shiftL (fromIntegral x) 16 :: Word64
+
+        -- q=0   1   2   3   4   5   6   7
+        -- 012 345 670 123 456 701 234 567
+        nibblePlace n q = case mod (n - 3 * q) 8 of
+                p | p < 3 -> Just (q,p)
+                _         -> Nothing
+
+        solve []         !ac = Right ac
+        solve ((n,b):ns) !ac = do
+            -- Find nibble p of question-digit q that corresponds to nibble n.
+            (q,p) <- maybe (Left "Unsolvable nospam.") Right
+                     $ foldr (<|>) Nothing $ map (nibblePlace n) qs
+            let bitpos = q * 6 + p * 2
+                ac' = ac `xor` shiftR (fromIntegral b `shiftL` 48) bitpos
+            solve ns ac'
+
+    n64' <- solve ns n64
+    let nospam' = fromIntegral (n64' `shiftR` 32)
+        cksum'  = fromIntegral (n64' `shiftR` 16)
+    return $ NoSpamId (NoSpam nospam' (Just cksum')) pub