Moved Codec.AsciiKey256 to tox-crypto.

4 files changed, 208 insertions, 1 deletions

diff --git a/tox-crypto/cbits/crc4_itu.c b/tox-crypto/cbits/crc4_itu.c
new file mode 100644
index 00000000..8e3b0489
--- /dev/null
+++ b/tox-crypto/cbits/crc4_itu.c
@@ -0,0 +1,44 @@
+/*-----------------------------------------------------------------
+|  crc4_itu.c
+|
+|  CRC4-ITU library using lookup table method.
+|
+*-------------------------------------------------------------------*/
+
+#include <stddef.h>
+
+static unsigned char const crc4itu_bbox[256] = {
+        0x0, 0x7, 0xe, 0x9, 0x5, 0x2, 0xb, 0xc, 0xa, 0xd, 0x4, 0x3, 0xf, 0x8, 0x1, 0x6,
+        0xd, 0xa, 0x3, 0x4, 0x8, 0xf, 0x6, 0x1, 0x7, 0x0, 0x9, 0xe, 0x2, 0x5, 0xc, 0xb,
+        0x3, 0x4, 0xd, 0xa, 0x6, 0x1, 0x8, 0xf, 0x9, 0xe, 0x7, 0x0, 0xc, 0xb, 0x2, 0x5,
+        0xe, 0x9, 0x0, 0x7, 0xb, 0xc, 0x5, 0x2, 0x4, 0x3, 0xa, 0xd, 0x1, 0x6, 0xf, 0x8,
+        0x6, 0x1, 0x8, 0xf, 0x3, 0x4, 0xd, 0xa, 0xc, 0xb, 0x2, 0x5, 0x9, 0xe, 0x7, 0x0,
+        0xb, 0xc, 0x5, 0x2, 0xe, 0x9, 0x0, 0x7, 0x1, 0x6, 0xf, 0x8, 0x4, 0x3, 0xa, 0xd,
+        0x5, 0x2, 0xb, 0xc, 0x0, 0x7, 0xe, 0x9, 0xf, 0x8, 0x1, 0x6, 0xa, 0xd, 0x4, 0x3,
+        0x8, 0xf, 0x6, 0x1, 0xd, 0xa, 0x3, 0x4, 0x2, 0x5, 0xc, 0xb, 0x7, 0x0, 0x9, 0xe,
+        0xc, 0xb, 0x2, 0x5, 0x9, 0xe, 0x7, 0x0, 0x6, 0x1, 0x8, 0xf, 0x3, 0x4, 0xd, 0xa,
+        0x1, 0x6, 0xf, 0x8, 0x4, 0x3, 0xa, 0xd, 0xb, 0xc, 0x5, 0x2, 0xe, 0x9, 0x0, 0x7,
+        0xf, 0x8, 0x1, 0x6, 0xa, 0xd, 0x4, 0x3, 0x5, 0x2, 0xb, 0xc, 0x0, 0x7, 0xe, 0x9,
+        0x2, 0x5, 0xc, 0xb, 0x7, 0x0, 0x9, 0xe, 0x8, 0xf, 0x6, 0x1, 0xd, 0xa, 0x3, 0x4,
+        0xa, 0xd, 0x4, 0x3, 0xf, 0x8, 0x1, 0x6, 0x0, 0x7, 0xe, 0x9, 0x5, 0x2, 0xb, 0xc,
+        0x7, 0x0, 0x9, 0xe, 0x2, 0x5, 0xc, 0xb, 0xd, 0xa, 0x3, 0x4, 0x8, 0xf, 0x6, 0x1,
+        0x9, 0xe, 0x7, 0x0, 0xc, 0xb, 0x2, 0x5, 0x3, 0x4, 0xd, 0xa, 0x6, 0x1, 0x8, 0xf,
+        0x4, 0x3, 0xa, 0xd, 0x1, 0x6, 0xf, 0x8, 0xe, 0x9, 0x0, 0x7, 0xb, 0xc, 0x5, 0x2
+};
+
+/**
+ * CRC4-ITU function
+ *
+ * Parameters:
+ *   crc    Existing CRC value (usually 0x00) before process a new one.
+ *   data   Pointer to data to be hashed with CRC
+ *   len    Size of data
+ *
+ * Returns: CRC value in lowest 4 bits.
+ */
+unsigned char crc4itu(unsigned char crc, unsigned char *data, unsigned int len) {
+        if (data == NULL) return 0;
+        crc &= 0xf;
+        while (len--) crc = crc4itu_bbox[crc ^ *data++];
+        return crc;
+}
diff --git a/tox-crypto/src/Codec/AsciiKey256.hs b/tox-crypto/src/Codec/AsciiKey256.hs
new file mode 100644
index 00000000..0212d1d0
--- /dev/null
+++ b/tox-crypto/src/Codec/AsciiKey256.hs
@@ -0,0 +1,149 @@
+{-# LANGUAGE TupleSections #-}
+module Codec.AsciiKey256 where
+
+import Control.Applicative
+import Control.Monad
+import Control.Monad.Fail                     as MF
+import Data.Bits
+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 System.IO.Unsafe
+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.
+parseBase64Key256 :: String -> Either String ByteString
+parseBase64Key256 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.
+showBase64Key256 :: ByteArrayAccess bin => bin -> String
+showBase64Key256 bs = map (nmtoken64 True) $ C8.unpack $ BA.drop 1 $ Base64.encode $ BA.cons 0 $ BA.convert bs
+
+foreign import ccall "crc4itu" c_crc4itu :: Word8        -- ^ init crc
+                                            -> Ptr Word8 -- ^ data to checksum
+                                            -> Int32     -- ^ length of data
+                                            -> IO Word8  -- crc in low 4 bits
+
+-- | CRC4-ITU. Return crc in lowest 4 bits.
+crc4itu :: ByteArrayAccess ba => Word8 -- ^ Existing CRC value (usually 0x00) before process a new one.
+                                 -> ba -- ^ Data to checksum.
+                                 -> Word8
+crc4itu crc0 b = unsafePerformIO $ BA.withByteArray b $ \p ->
+    c_crc4itu crc0 p (fromIntegral $ BA.length b)
+
+-- | Parse 52-digit z-base32 token into 32-byte bytestring.
+parseBase32Key256 :: String -> Either String ByteString
+parseBase32Key256 str = do
+    bs <- Base32.decode $ C8.pack $ map (fixupDigit32 . toLower) (take 52 str) ++ "y"
+    case BA.splitAt 32 bs of
+        (key,mac) | crc4itu 0 key == shiftR (BA.index mac 0) 4
+            -> Right key
+        _   -> Left "Failed cyclic redundancy check."
+
+-- | Encode 52-digit z-base32 token from 32-byte bytestring.
+showBase32Key256 :: ByteArrayAccess bin => bin -> String
+showBase32Key256 bs = C8.unpack $ B.take 52 $ Base32.encode (b `B.snoc` shiftL crc 4)
+ where
+    b = BA.convert bs
+    crc = crc4itu 0 bs
+
+-- | Encode 32-byte bytestring for display.
+showKey256 :: ByteArrayAccess bin => bin -> String
+showKey256 = showBase32Key256
+
+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 <- parseBase32Key256 str
+        , Just pub <- publicKey bs
+                    = [ (pub, drop 52 str) ]
+        | Right bs <- parseBase64Key256 str
+        , Just pub <- publicKey bs
+                    = [ (pub, drop 43 str) ]
+        | otherwise = []
+
+
+parseKey256 :: (MonadFail 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 -> parseBase32Key256 nidstr
+                        43 -> parseBase64Key256 nidstr
+                        _  -> Left "Wrong size of key."
+        idbs <- (guard (B.length bs == 32) >> return bs)
+                <|> either MF.fail return 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 = MF.fail "Bad key."
+      case is64 of
+        32 -> case parseBase32Key256 hexhash of
+                  Right bs -> return bs
+                  _        -> failure
+        64 -> case parseBase64Key256 hexhash of
+                  Right bs -> return 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/tox-crypto/src/Crypto/Tox.hs b/tox-crypto/src/Crypto/Tox.hs
index 04b55d94..602ead0a 100644
--- a/tox-crypto/src/Crypto/Tox.hs
+++ b/tox-crypto/src/Crypto/Tox.hs
@@ -67,6 +67,16 @@ module Crypto.Tox
     , encodeSecret
     , decodeSecret
     , xorsum
+    , Codec.AsciiKey256.showBase32Key256
+    , Codec.AsciiKey256.showBase64Key256
+    , Codec.AsciiKey256.showKey256
+    , Codec.AsciiKey256.parseBase64Key256
+    , Codec.AsciiKey256.parseBase32Key256
+    , Codec.AsciiKey256.parseKey256
+    , Codec.AsciiKey256.readP_key256
+    , Codec.AsciiKey256.readsPrecKey256
+    , Codec.AsciiKey256.stripSuffix
+    , Codec.AsciiKey256.nmtoken64
     ) where
 
 import Control.Arrow
@@ -99,6 +109,7 @@ import Foreign.Marshal.Alloc
 import Foreign.Ptr
 import Foreign.Storable
 import System.Endian
+import Codec.AsciiKey256
 import Control.Concurrent.STM
 #ifdef CRYPTONITE_BACKPORT
 import Crypto.ECC.Class
diff --git a/tox-crypto/tox-crypto.cabal b/tox-crypto/tox-crypto.cabal
index 678cccd5..370b1a85 100644
--- a/tox-crypto/tox-crypto.cabal
+++ b/tox-crypto/tox-crypto.cabal
@@ -16,8 +16,9 @@ extra-source-files:  CHANGELOG.md
 cabal-version:       >=1.10
 
 library
+  C-sources: cbits/crc4_itu.c
   exposed-modules:     Crypto.Tox
-  other-modules: DebugTag
+  other-modules: DebugTag, Codec.AsciiKey256
   other-extensions:    CPP
         , GeneralizedNewtypeDeriving
         , ScopedTypeVariables
@@ -40,8 +41,10 @@ library
           base
         , cpu
         , memory
+        , base32-bytestring
         , base64-bytestring
         , base16-bytestring
+        , text
         , cereal
         , word64-map
         , contravariant