4 files changed, 132 insertions, 86 deletions

diff --git a/dht/dht-client.cabal b/dht/dht-client.cabal
index c58aa82a..a2a86b95 100644
--- a/dht/dht-client.cabal
+++ b/dht/dht-client.cabal
@@ -249,7 +249,7 @@ library
 
 
 
-  C-sources:           Presence/monitortty.c
+  C-sources:           Presence/monitortty.c cbits/crc4_itu.c
 
   -- if flag(aeson)
   build-depends: aeson, aeson-pretty, unordered-containers, vector
diff --git a/dht/src/Codec/AsciiKey256.hs b/dht/src/Codec/AsciiKey256.hs
new file mode 100644
index 00000000..6040f454
--- /dev/null
+++ b/dht/src/Codec/AsciiKey256.hs
@@ -0,0 +1,124 @@
+{-# LANGUAGE TupleSections #-}
+module Codec.AsciiKey256 where
+
+import Control.Applicative
+import Control.Monad
+import qualified Data.ByteArray               as BA
+         ;import Data.ByteArray               as BA (ByteArrayAccess)
+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
+import Data.Int
+import qualified Data.Text                    as T
+         ;import Data.Text                    (Text)
+import Data.Word
+import Foreign.Ptr
+import qualified Text.ParserCombinators.ReadP as RP
+
+stripSuffix :: Text -> Text -> Maybe Text
+stripSuffix suf x = case T.splitAt (T.length x - T.length suf) x of
+    (y,end) | end == suf -> Just y
+            | otherwise  -> Nothing
+
+hexdigit :: Char -> Bool
+hexdigit c = ('0' <= c && c <= '9') || ( 'a' <= c && c <= 'f') || ( 'A' <= c && c <= 'F')
+
+b64digit :: Char -> Bool
+b64digit '.' = True
+b64digit '+' = True
+b64digit '-' = True
+b64digit '/' = True
+b64digit c = ('0' <= c && c <= '9') || ( 'a' <= c && c <= 'z') || ( 'A' <= c && c <= 'Z')
+
+-- | Convert to and from a Base64 variant that uses .- instead of +/.
+nmtoken64 :: Bool -> Char -> Char
+nmtoken64 False '.' = '+'
+nmtoken64 False '-' = '/'
+nmtoken64 True  '+' = '.'
+nmtoken64 True  '/' = '-'
+nmtoken64 _     c   = c
+
+
+-- Apply substitutions for mistaken z-base32 digits.
+fixupDigit32 :: Char -> Char
+fixupDigit32 'l' = '1'
+fixupDigit32 '2' = 'z'
+fixupDigit32 'v' = 'u'
+fixupDigit32  c  =  c
+
+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'
+                 ]
+
+
+-- | Parse 43-digit base64 token into 32-byte bytestring.
+parseToken32 :: String -> Either String ByteString
+parseToken32 str = fmap (BA.drop 1) $ Base64.decode $ C8.pack $ 'A':map (nmtoken64 False) (take 43 str)
+
+-- | Encode 43-digit base64 token from 32-byte bytestring.
+showToken32 :: ByteArrayAccess bin => bin -> String
+showToken32 bs = map (nmtoken64 True) $ C8.unpack $ BA.drop 1 $ Base64.encode $ BA.cons 0 $ BA.convert bs
+
+
+-- | 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 62-digit z-base32 token from 32-byte bytestring.
+show32Token32 :: ByteArrayAccess bin => bin -> String
+show32Token32 bs = map (nmtoken64 True) $ C8.unpack $ BA.drop 1 $ Base32.encode $ BA.cons 0 $ BA.convert bs
+
+
+readsPrecKey256 :: (ByteString -> Maybe a) -> [Char] -> [(a, [Char])]
+readsPrecKey256 publicKey str
+        | (bs,_) <- Base16.decode (C8.pack $ take 64 str)
+        , Just pub <- publicKey bs
+                    = [ (pub, drop (2 * B.length bs) str) ]
+        | Right bs <- parse32Token32 str
+        , Just pub <- publicKey bs
+                    = [ (pub, drop 52 str) ]
+        | Right bs <- parseToken32 str
+        , Just pub <- publicKey bs
+                    = [ (pub, drop 43 str) ]
+        | otherwise = []
+
+
+parseKey256 :: (Monad m, Alternative m) => String -> m ByteString
+parseKey256 nidstr = do
+        let nidbs  = C8.pack nidstr
+            (bs,_) = Base16.decode nidbs
+            enid   = case C8.length nidbs of
+                        52 -> Base32.decode (C8.pack $ 'y' : map (fixupDigit32 . toLower) nidstr)
+                        43 -> Base64.decode (C8.pack $ 'A' : map (nmtoken64 False) nidstr)
+                        _  -> Left "Wrong size of key."
+        idbs <- (guard (B.length bs == 32) >> return bs)
+                <|> either fail (return . B.drop 1) enid
+        return idbs
+
+readP_key256 :: RP.ReadP ByteString
+readP_key256 = do
+      (is64,hexhash) <- foldr1 (RP.+++)
+        [ fmap (16,) (sequence $ replicate 64 (RP.satisfy isHexDigit))
+        , fmap (32,) (sequence $ replicate 52 (RP.satisfy zb32digit))
+        , fmap (64,) (sequence $ replicate 43 (RP.satisfy b64digit))
+        ]
+      let failure = fail "Bad key."
+      case is64 of
+        32 -> case Base32.decode $ C8.pack $ 'y' : map (fixupDigit32 . toLower) hexhash of
+                  Right bs | B.length bs - 1==32 -> return (BA.drop 1 bs)
+                  _                              -> failure
+        64 -> case Base64.decode $ C8.pack $ 'A' : map (nmtoken64 False) hexhash of
+                  Right bs | B.length bs - 1==32 -> return (BA.drop 1 bs)
+                  _                              -> failure
+        16 -> case Base16.decode $ C8.pack hexhash of
+                  (bs,rem) | B.length bs == 32 &&  B.null rem -> return bs
+                  _                                           -> failure
+        _ -> failure
diff --git a/dht/src/Data/Tox/Msg.hs b/dht/src/Data/Tox/Msg.hs
index 2951193d..8819faa7 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) = show64Token32 ed
+    show (ChatID ed) = showToken32 ed
 
 data InviteType = GroupInvite { groupName :: Text }
                 | AcceptedInvite
diff --git a/dht/src/Network/Tox/NodeId.hs b/dht/src/Network/Tox/NodeId.hs
index 311095ec..68888fdd 100644
--- a/dht/src/Network/Tox/NodeId.hs
+++ b/dht/src/Network/Tox/NodeId.hs
@@ -38,7 +38,7 @@ module Network.Tox.NodeId
     , ToxContact(..)
     , ToxProgress(..)
     , parseToken32
-    , show64Token32
+    , showToken32
     , show32Token32
     , nodeInfoFromJSON
     ) where
@@ -91,6 +91,7 @@ import System.Endian
 import qualified Data.Text as Text
          ;import Data.Text (Text)
 import Util (splitJID)
+import Codec.AsciiKey256
 
 -- | perform io for hashes that do allocation and ffi.
 -- unsafeDupablePerformIO is used when possible as the
@@ -163,42 +164,8 @@ zeroKey = throwCryptoError $ publicKey $ B.replicate 32 0
 zeroID :: NodeId
 zeroID = NodeId (replicate 4 0) (Just zeroKey)
 
--- | Convert to and from a Base64 variant that uses .- instead of +/.
-nmtoken64 :: Bool -> Char -> Char
-nmtoken64 False '.' = '+'
-nmtoken64 False '-' = '/'
-nmtoken64 True  '+' = '.'
-nmtoken64 True  '/' = '-'
-nmtoken64 _     c   = c
-
--- | Parse 43-digit base64 token into 32-byte bytestring.
-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.
-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 = []
+    readsPrec _ str = readsPrecKey256 (fmap key2id . maybeCryptoError . publicKey) str
 
 instance Show NodeId where
     show nid = show32Token32 $ id2key nid
@@ -279,14 +246,7 @@ 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 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
+        idbs <- parseKey256 nidstr
         return $ NodeInfo (bs2id idbs) ip (fromIntegral (portnum :: Word16))
 
 getIP :: Word8 -> S.Get IP
@@ -320,31 +280,6 @@ instance S.Serialize NodeInfo where
         S.put port
         S.put nid
 
-hexdigit :: Char -> Bool
-hexdigit c = ('0' <= c && c <= '9') || ( 'a' <= c && c <= 'f') || ( 'A' <= c && c <= 'F')
-
-b64digit :: Char -> Bool
-b64digit '.' = True
-b64digit '+' = True
-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 ']')
@@ -360,23 +295,10 @@ instance Read NodeInfo where
     RP.skipSpaces
     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) <- 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))
-                        ]
+        nodeidAt = do
+                      nid <- bs2id <$> readP_key256
                       RP.char '@' RP.+++ RP.satisfy isSpace
                       addrstr <- parseAddr
-                      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."
-                        _  -> 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)
     (nid,addrstr) <- ( nodeidAt RP.+++ ( (zeroID,) <$> parseAddr) )
     (ip,port) <- case RP.readP_to_S (ip_w_port i) addrstr of