3 files changed, 283 insertions, 0 deletions

diff --git a/dht/src/Crypto/Nonce.hs b/dht/src/Crypto/Nonce.hs
new file mode 100644
index 00000000..263f9b0a
--- /dev/null
+++ b/dht/src/Crypto/Nonce.hs
@@ -0,0 +1,49 @@
+{-# LANGUAGE DeriveDataTypeable         #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+module Crypto.Nonce
+    ( Nonce32
+    , generateNonce32
+    , zeros32
+    ) where
+
+import Crypto.Random
+import Data.ByteArray                   as BA
+import Data.ByteString                  as B
+import qualified Data.ByteString.Base64 as Base64
+import Data.ByteString.Char8            as B8
+import Data.Data
+import Data.Serialize
+import Data.Sized
+
+newtype Nonce32 = Nonce32 ByteString
+ deriving (Eq, Ord, ByteArrayAccess, Data)
+
+bin2base64 :: ByteArrayAccess bs => bs -> String
+bin2base64 = B8.unpack . Base64.encode . BA.convert
+
+instance Show Nonce32 where
+    showsPrec d nonce = mappend $ bin2base64 nonce
+
+instance Read Nonce32 where
+    readsPrec _ str = either (const []) id $ do
+        let (ds,ss) = Prelude.splitAt 43 str
+        ss' <- case ss of
+                '=':xs -> Right xs -- optional terminating '='
+                _      -> Right ss
+        bs <- Base64.decode (B8.pack $ ds ++ ['='])
+        if B.length bs == 32
+            then Right [ (Nonce32 bs, ss') ]
+            else Left  "Truncated Nonce32 (expected 43 base64 digits)."
+
+instance Serialize Nonce32 where
+    get = Nonce32 <$> getBytes 32
+    put (Nonce32 bs) = putByteString bs
+
+instance Sized Nonce32 where size = ConstSize 32
+
+
+zeros32 :: Nonce32
+zeros32 = Nonce32 $ BA.replicate 32 0
+
+generateNonce32 :: MonadRandom m => m Nonce32
+generateNonce32 = Nonce32 <$> getRandomBytes 32
diff --git a/dht/src/Crypto/XEd25519.hs b/dht/src/Crypto/XEd25519.hs
new file mode 100644
index 00000000..372f31a8
--- /dev/null
+++ b/dht/src/Crypto/XEd25519.hs
@@ -0,0 +1,185 @@
+module Crypto.XEd25519 where
+
+import Control.Arrow
+import Data.Bits
+import Data.ByteArray as BA
+import Data.Memory.PtrMethods (memCopy)
+import Crypto.Hash
+import Crypto.ECC.Edwards25519
+import Crypto.Error
+import qualified Crypto.PubKey.Ed25519 as Ed25519
+import Foreign.Marshal
+import Foreign.Ptr
+import Foreign.Storable
+import qualified Crypto.PubKey.Curve25519 as X25519
+
+import Crypto.XEd25519.FieldElement
+import Crypto.Nonce
+
+
+data SecretKey = SecretKey { secretScalar :: Scalar }
+
+data PublicKey = PublicKey Ed25519.PublicKey
+ deriving Eq
+
+type Nonce = Nonce32
+
+newtype EncodedPoint = EncodedPoint Point
+
+instance ByteArrayAccess SecretKey where
+    length _ = 32
+    withByteArray (SecretKey scalar) = withByteArray (scalarEncode scalar :: Bytes)
+
+instance ByteArrayAccess PublicKey where
+    length _ = 32
+    withByteArray (PublicKey edpub) = withByteArray edpub
+
+instance ByteArrayAccess EncodedPoint where
+    length _ = 32
+    withByteArray (EncodedPoint pt) f =
+        withByteArray (pointEncode pt :: Bytes) f
+
+
+data Signature = Signature EncodedPoint Scalar
+
+instance ByteArrayAccess Signature where
+    length _ = 64
+    withByteArray (Signature pt scalar) f =
+        withByteArray pt                 $ \ptptr -> do
+        withByteArray (SecretKey scalar) $ \scalarptr -> do
+        allocaBytes 64                   $ \ptr -> do
+            memCopy ptr ptptr 32
+            memCopy (ptr `plusPtr` 32) scalarptr 32
+            f (castPtr ptr)
+
+
+padding :: Bytes
+padding = 0xFE `BA.cons` BA.replicate 31 0xFF
+
+sign :: ByteArrayAccess dta => dta -> Nonce -> SecretKey -> PublicKey -> Signature
+sign dta nonce sec pub = Signature rB s
+ where
+    rB = ge_p3_tobytes $ ge_scalarmult_base r
+
+    r = sc_reduce $ hashFinalize $ (`hashUpdate` padding)
+                                    >>> (`hashUpdate` sec)
+                                    >>> (`hashUpdate` dta)
+                                    >>> (`hashUpdate` nonce) $ hashInit
+
+    h = sc_reduce $ hashFinalize $ (`hashUpdate` rB)
+                                    >>> (`hashUpdate` pub)
+                                    >>> (`hashUpdate` dta) $ hashInit
+
+    -- s = r + ha (mod q)
+    s = sc_muladd h (secretScalar sec) r
+
+
+
+ge_p3_tobytes :: Point -> EncodedPoint
+ge_p3_tobytes = EncodedPoint
+
+ge_scalarmult_base :: Scalar -> Point
+ge_scalarmult_base = toPoint
+
+sc_muladd :: Scalar -> Scalar -> Scalar -> Scalar
+sc_muladd a b c = scalarAdd (scalarMul a b) c
+
+sc_reduce :: Digest SHA512 -> Scalar
+sc_reduce digest = x where CryptoPassed x = scalarDecodeLong digest -- ???
+
+-- Scalar is internally, at least on 64bit machines, represented as 5
+-- 56-bit words in little-endian order, each encoded as a Word64.
+sc_neg :: Scalar -> Scalar
+sc_neg = scalarMul sc_neg1
+
+verify :: ByteArrayAccess dta => PublicKey -> dta -> Signature -> Bool
+verify pub dta signature = Ed25519.verify ed_pub dta ed_sig
+ where
+    CryptoPassed ed_pub = Ed25519.publicKey pub'
+    CryptoPassed ed_sig = Ed25519.signature signature'
+
+    -- Get the sign bit from the s part of the signature.
+    sign_bit = BA.index signature 63 .&. 0x80
+
+    -- Set the sign bit to zero in the s part of the signature.
+    signature' :: Bytes
+    signature' = BA.copyAndFreeze signature $ \ptr -> do
+        let at63 = plusPtr ptr 63
+        byte63 <- peek at63
+        poke at63 $ byte63 .&. (0x7F `asTypeOf` sign_bit)
+
+    -- Restore the sign bit on the verification key, which should have 0 as its
+    -- current sign bit.
+    pub' :: Bytes
+    pub' = BA.copyAndFreeze pub $ \ptr -> do
+        let at31 = plusPtr ptr 31
+        byte31 <- peek at31
+        poke at31 $ (byte31 .&. 0x7F) .|. sign_bit
+
+
+-- typedef crypto_int32 fe[10];
+--
+-- fe means field element.  Here the field is \Z/(2^255-19).
+-- An element t, entries t[0]...t[9], represents the integer
+-- t[0]+2^26 t[1]+2^51 t[2]+2^77 t[3]+2^102 t[4]+...+2^230 t[9].
+-- Bounds on each t[i] vary depending on context.
+
+-- mont_pub_to_ed_pub
+toSigningKey :: X25519.PublicKey -> PublicKey
+toSigningKey mont_pub0 = PublicKey ed_pub
+ where
+    -- Read the public key as a field element
+    mont_pub = fe_frombytes mont_pub0
+
+    -- Convert the Montgomery public key to a twisted Edwards public key
+    fe_ONE = fe_1
+
+    -- Calculate the parameters (u - 1) and (u + 1)
+    mont_pub_minus_one = fe_sub mont_pub fe_ONE
+    mont_pub_plus_one0 = fe_add mont_pub fe_ONE
+
+    -- Prepare inv(u + 1)
+    mont_pub_plus_one = fe_invert mont_pub_plus_one0
+
+    -- Calculate y = (u - 1) * inv(u + 1) (mod p)
+    ed_pub0 = fe_mul mont_pub_minus_one mont_pub_plus_one
+    ed_pub = fe_tobytes ed_pub0
+
+-- mont_priv_to_ed_pair
+toSigningKeyPair :: X25519.SecretKey -> (SecretKey,PublicKey)
+toSigningKeyPair mont_priv0 = (SecretKey ed_priv, PublicKey ed_pub)
+ where
+    -- Prepare a buffer for the twisted Edwards private key
+    ed_priv1 = (throwCryptoError . scalarDecodeLong :: X25519.SecretKey -> Scalar) mont_priv0
+
+    -- Get the twisted edwards public key, including the sign bit
+    ed_pub0 = ge_p3_tobytes $ ge_scalarmult_base ed_priv1
+
+    -- Save the sign bit for later
+    sign_bit = (BA.index ed_pub0 31 `shiftR` 7) .&. 1
+
+    -- Force the sign bit to zero
+    pub' :: Bytes
+    pub' = BA.copyAndFreeze ed_pub0 $ \ptr -> do
+        let at31 = plusPtr ptr 31
+        byte31 <- peek at31
+        poke at31 $ (byte31 .&. 0x7F) `asTypeOf` sign_bit
+
+    CryptoPassed ed_pub = Ed25519.publicKey pub'
+
+
+    -- Prepare the negated private key
+    ed_priv_neg = sc_neg ed_priv1
+
+    -- Get the correct private key based on the sign stored above
+    ed_priv = if sign_bit/=0 then ed_priv_neg
+                             else ed_priv1
+
+-- sc_zero = throwCryptoError $ scalarDecodeLong (b::Bytes)
+--  where
+--     b = BA.pack $ encodeLittleEndian $ 2^252 + 27742317777372353535851937790883648493
+
+sc_neg1 :: Scalar
+sc_neg1 = throwCryptoError $ scalarDecodeLong (b::Bytes)
+ where
+    b = BA.pack $ encodeLittleEndian $ 2^252 + 27742317777372353535851937790883648492
diff --git a/dht/src/Crypto/XEd25519/FieldElement.hs b/dht/src/Crypto/XEd25519/FieldElement.hs
new file mode 100644
index 00000000..7a916107
--- /dev/null
+++ b/dht/src/Crypto/XEd25519/FieldElement.hs
@@ -0,0 +1,49 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeOperators #-}
+module Crypto.XEd25519.FieldElement where
+
+import Crypto.Error
+import qualified Crypto.PubKey.Curve25519 as X25519
+import qualified Crypto.PubKey.Ed25519 as Ed25519
+import Data.ByteArray as BA (pack,unpack,Bytes)
+import Data.Modular
+import Data.Word
+
+-- 2^255 - 19
+type P25519 = 57896044618658097711785492504343953926634992332820282019728792003956564819949
+
+newtype FieldElement = FE (ℤ / P25519)
+
+
+fe_frombytes :: X25519.PublicKey -> FieldElement
+fe_frombytes pub = FE $ toMod $ decodeLittleEndian $ BA.unpack pub
+
+fe_tobytes :: FieldElement -> Ed25519.PublicKey
+fe_tobytes (FE x) = throwCryptoError $ Ed25519.publicKey (b :: Bytes)
+ where
+    b = BA.pack $ take 32 $ (encodeLittleEndian $ unMod x) ++ repeat 0
+
+fe_1 :: FieldElement
+fe_1 = FE $ toMod 1
+
+fe_sub :: FieldElement -> FieldElement -> FieldElement
+fe_sub (FE x) (FE y) = FE $ x - y
+
+fe_add :: FieldElement -> FieldElement -> FieldElement
+fe_add (FE x) (FE y) = FE $ x + y
+
+fe_invert :: FieldElement -> FieldElement
+fe_invert (FE x) = FE $ inv x
+
+fe_mul :: FieldElement -> FieldElement -> FieldElement
+fe_mul (FE x) (FE y) = FE (x * y)
+
+decodeLittleEndian :: [Word8] -> Integer
+decodeLittleEndian [] = 0
+decodeLittleEndian (x:xs) = fromIntegral x + 256 * decodeLittleEndian xs
+
+encodeLittleEndian :: Integer -> [Word8]
+encodeLittleEndian 0 = []
+encodeLittleEndian x = let (bs,b) = divMod x 256
+                        in fromIntegral b : encodeLittleEndian bs
+