X25519 Diffie-Hellman seems to work

reference/Crypto/X25519/BaseField.hs

@@ -0,0 +1,67 @@
+
+-- | The base field of Curve25519
+
+module Crypto.X25519.BaseField where
+
+--------------------------------------------------------------------------------
+
+import Data.Bits
+import Data.Ratio
+import System.Random
+
+--------------------------------------------------------------------------------
+
+primeP :: Integer
+primeP = 2^255 - 19
+
+modP :: Integer -> Integer
+modP x = mod x primeP
+
+newtype Fp 
+  = Fp Integer 
+  deriving (Eq,Show)
+
+fromFp :: Fp -> Integer
+fromFp (Fp x) = x
+
+toFp :: Integer -> Fp
+toFp n = Fp (modP n)
+
+instance Num Fp where
+  fromInteger   = toFp
+  negate (Fp x) = toFp $ negate x
+  Fp x + Fp y   = toFp $ x + y
+  Fp x - Fp y   = toFp $ x - y
+  Fp x * Fp y   = toFp $ x * y
+  abs x    = x
+  signum _ = Fp 1
+
+isZero :: Fp -> Bool
+isZero (Fp x) = x == 0
+
+pow :: Fp -> Integer -> Fp
+pow base expo
+  | expo <  0  = pow (inv base) (negate expo)
+  | otherwise  = go 1 base expo 
+  where
+    go :: Fp -> Fp -> Integer -> Fp
+    go !acc !s 0  = acc
+    go !acc !s !e = case e .&. 1 of
+      0 -> go  acc    (s*s) (shiftR e 1)
+      1 -> go (acc*s) (s*s) (shiftR e 1)
+
+inv :: Fp -> Fp
+inv x = pow x (primeP - 2)
+
+instance Fractional Fp where
+  fromRational r = toFp (numerator r) / toFp (denominator r)
+  recip = inv
+  x / y = x * inv y
+
+randomFp :: IO Fp
+randomFp = Fp <$> randomRIO (0,primeP-1)
+
+randomFpNonZero :: IO Fp
+randomFpNonZero = Fp <$> randomRIO (1,primeP-1)
+
+--------------------------------------------------------------------------------

reference/Crypto/X25519/DH.hs

@@ -0,0 +1,94 @@
+
+-- | Public key cryptography (Diffie-Hellman) over X25519
+
+module Crypto.X25519.DH where
+
+--------------------------------------------------------------------------------
+
+import Data.Bits
+import Data.Word
+
+import Crypto.X25519.BaseField
+import Crypto.X25519.ScalarField
+import Crypto.X25519.Elliptic
+
+import Control.Monad
+import System.Random
+
+import Octet
+
+--------------------------------------------------------------------------------
+
+sanityDiffieHellman :: IO ()
+sanityDiffieHellman = do
+  alice <- randomKeyPair
+  bob   <- randomKeyPair
+  putStrLn $ "Alice: " ++ show alice
+  putStrLn $ "Bob:   " ++ show bob
+  let sharedAlice = scalarMul (secretKeyToInteger $ fst alice) (pubKeyToGroup $ snd bob  )
+  let sharedBob   = scalarMul (secretKeyToInteger $ fst bob  ) (pubKeyToGroup $ snd alice)
+  putStrLn $ "shared secret of Alice = " ++ show (xcoordAsWordLE sharedAlice)
+  putStrLn $ "shared secret of Bob   = " ++ show (xcoordAsWordLE sharedBob  )
+  print (sharedAlice == sharedBob)
+
+--------------------------------------------------------------------------------
+
+-- | 32 bytes, little-endian
+newtype PubKey 
+  = PK Word256
+  deriving (Eq,Show,IsWord)
+
+-- | 32 bytes, little-endian. Warning: Not all such byte vectors are valid secret keys!!
+newtype SecretKey 
+  = SK Word256
+  deriving (Eq,Show,IsWord)
+
+xcoordAsWordLE :: G -> Word256
+xcoordAsWordLE pt = fromIntegerLE (xcoordAsInteger pt)
+
+secretKeyToPubKey :: SecretKey -> PubKey
+secretKeyToPubKey sk = pubKeyFromGroup g where
+  g = scalarMul (secretKeyToInteger sk) basePoint
+
+-- | Clear bits 0, 1, 2 of the first byte, clear bit 7 of the last
+-- byte, and set bit 6 of the last byte. (NOTE: it's all little-endian!)
+maskSecretKey :: Word256 -> SecretKey
+maskSecretKey (W256 bs) = SK (W256 masked) where
+  b0  = bs !! 0
+  b31 = bs !! 31
+  masked =  (b0 .&. 0xf8)
+         :  [ bs!!i | i<- [1..30] ]
+         ++ [ (b31 .&. 0x7f) .|. 0x40 ]
+
+randomSecretKey :: IO SecretKey
+randomSecretKey = do
+  bs <- replicateM 32 (randomIO :: IO Word8)
+  return (maskSecretKey $ W256 bs)
+
+randomKeyPair :: IO (SecretKey,PubKey) 
+randomKeyPair = do
+  sk <- randomSecretKey
+  let pk = secretKeyToPubKey sk
+  return (sk,pk)
+
+--------------------------------------------------------------------------------
+
+pubKeyToGroup :: PubKey -> G
+pubKeyToGroup pk = Gx (toFp (pubKeyToInteger pk))
+
+pubKeyFromGroup :: G -> PubKey
+pubKeyFromGroup (Gx x) = pubKeyFromInteger (fromFp x)
+
+pubKeyToInteger :: PubKey -> Integer
+pubKeyToInteger (PK w) = toIntegerLE w
+
+secretKeyToInteger :: SecretKey -> Integer
+secretKeyToInteger (SK w) = toIntegerLE w
+
+pubKeyFromInteger :: Integer -> PubKey
+pubKeyFromInteger n = PK (fromIntegerLE n)
+
+secretKeyFromInteger :: Integer -> SecretKey 
+secretKeyFromInteger n = SK (fromIntegerLE n)
+
+--------------------------------------------------------------------------------

reference/Crypto/X25519/Elliptic.hs

@@ -0,0 +1,119 @@
+
+-- | The cyclic subgroup of Curve25519
+--
+-- Curve25519 is the Montgomery curve defined by
+--
+-- > y^2 = x^3 + 486662*x^2 + x
+--
+-- over the prime field @p = 2^255 - 19@
+--
+-- See <https://cr.yp.to/ecdh/curve25519-20060209.pdf>
+--
+-- Note: In the @X = x/z@ representation, we can do efficient doubling and 
+-- efficient scalar multiplication, but not clear how to do addition.
+--
+-- But we are only using X25519 (Diffie-Hellman), no signatures
+--
+
+{-# LANGUAGE Strict #-}
+module Crypto.X25519.Elliptic where
+
+--------------------------------------------------------------------------------
+
+import Data.Bits
+
+import Crypto.X25519.BaseField
+import Crypto.X25519.ScalarField
+
+--------------------------------------------------------------------------------
+
+constA, constA' :: Fp
+constA  = Fp 486662
+constA' = Fp 121665         -- (A-2) / 4
+
+-- | We only store the @x@ coordinate, with @z=1@ being implicit
+newtype G 
+  = Gx Fp
+  deriving (Eq,Show)
+
+xcoordAsInteger :: G -> Integer
+xcoordAsInteger (Gx x) = fromFp x
+
+-- | We store both the @x@ and $z$ coordinates
+data G'
+  = Gxz !Fp !Fp
+  deriving (Eq,Show)
+
+toProj :: G -> G'
+toProj (Gx x) = Gxz x 1
+
+fromProj :: G' -> G
+fromProj (Gxz x z) = Gx (x/z)
+
+basePoint :: G
+basePoint = Gx 9
+
+basePoint' :: G'
+basePoint' = Gxz 9 1
+
+inf :: G'
+inf = Gxz 1 0
+
+--------------------------------------------------------------------------------
+
+affDouble :: G -> G
+affDouble = fromProj . projDouble . toProj
+
+--------------------------------------------------------------------------------
+
+projDouble :: G' -> G'
+projDouble (Gxz x z) = Gxz x2 z2 where
+  u = (x-z) * (x-z)
+  v = (x+z) * (x+z)
+  x2 = u * v
+  m2 = v - u
+  z2 = m2 * (v + constA' * m2)
+
+-- | Given Q, Q' and Q-Q' (assuming not 0 or inf), we compute Q+Q'
+projLadderStep :: G' -> G' -> G -> G'
+projLadderStep (Gxz x z ) (Gxz x' z') (Gx x1) = Gxz x3 z3 where
+   u = (x - z) * (x' + z')
+   v = (x + z) * (x' - z')
+   x3 = (u + v) * (u + v)  -- * z1 = 1
+   z3 = (u - v) * (u - v) * x1
+
+--------------------------------------------------------------------------------
+
+(**) :: Fq -> G -> G
+(**) expo base = scalarMul (fromFq expo) base
+
+scalarMul :: Integer -> G -> G
+scalarMul expo base = fromProj $ montgomeryLadder expo base
+
+montgomeryLadder :: Integer -> G -> G' 
+montgomeryLadder expo base = fst (go expo) where
+  -- returns (n*base, (n+1)*base) 
+  go :: Integer -> (G', G')
+  go 0 = (inf , toProj base)
+  go n = case n .&. 1 of
+    0 -> (projDouble a   , ladderStep a b)    -- 2k   = 2*k       ; 2k+1 = k + (k+1)
+    1 -> (ladderStep a b , projDouble b  )    -- 2k+1 = k + (k+1) ; 2k+2 = 2*(k+1)
+    where 
+      (a,b) = go (shiftR n 1)
+
+  ladderStep a b = projLadderStep a b base
+
+--------------------------------------------------------------------------------
+
+sanityCheck :: Bool
+sanityCheck = (scalarMul priv basePoint == pub) where
+  priv =    34637982121745647379369242364578736860238507147912635042240559108083448531832
+  pub  = Gx 24771927253352877576321681419849838916408500873060548523943816650212634100610
+
+{- 
+-- test case:
+priv = 34637982121745647379369242364578736860238507147912635042240559108083448531832
+pub  = 24771927253352877576321681419849838916408500873060548523943816650212634100610
+-}
+
+--------------------------------------------------------------------------------

reference/Crypto/X25519/ScalarField.hs

@@ -0,0 +1,40 @@
+
+-- | The scalar field of Curve25519
+
+module Crypto.X25519.ScalarField where
+
+--------------------------------------------------------------------------------
+
+import System.Random
+
+--------------------------------------------------------------------------------
+
+primeQ :: Integer
+primeQ = 2^252 + 27742317777372353535851937790883648493
+
+modQ :: Integer -> Integer
+modQ x = mod x primeQ 
+
+newtype Fq
+  = Fq Integer 
+  deriving (Eq,Show)
+
+fromFq :: Fq -> Integer
+fromFq (Fq x) = x
+
+toFq :: Integer -> Fq
+toFq n = Fq (modQ n)
+
+instance Num Fq where
+  fromInteger  = toFq
+  negate (Fq x) = toFq $ negate x
+  Fq x + Fq y   = toFq $ x + y
+  Fq x - Fq y   = toFq $ x - y
+  Fq x * Fq y   = toFq $ x * y
+  abs x    = x
+  signum _ = Fq 1
+
+randomFqNonZero :: IO Fq
+randomFqNonZero = Fq <$> randomRIO (1,primeQ-1)
+
+--------------------------------------------------------------------------------

reference/Octet.hs

@@ -0,0 +1,256 @@
+
+{-# LANGUAGE ScopedTypeVariables, TypeApplications #-}
+module Octet where
+
+--------------------------------------------------------------------------------
+
+import Data.Bits
+import Data.Word
+import Data.Proxy
+import Data.Char
+
+import Control.Monad
+import System.Random
+
+import Data.ByteString (ByteString)
+import qualified Data.ByteString as B
+
+import Text.Printf
+
+--------------------------------------------------------------------------------
+
+class ByteVec a where
+  vecLength  :: Proxy a -> Int
+  toBytes    :: a -> [Word8]
+  fromBytes  :: [Word8] -> a
+
+toIntegerLE :: ByteVec a => a -> Integer
+toIntegerLE = bytesToIntegerLE . toBytes
+
+toIntegerBE :: ByteVec a => a -> Integer
+toIntegerBE = bytesToIntegerBE . toBytes
+
+fromIntegerLE :: forall a. ByteVec a => Integer -> a
+fromIntegerLE = fromBytes . bytesFromIntegerLE (vecLength (Proxy @a))
+
+fromIntegerBE :: forall a. ByteVec a => Integer -> a
+fromIntegerBE = fromBytes . bytesFromIntegerBE (vecLength (Proxy @a))
+
+--------------------------------------------------------------------------------
+
+-- | 128-bit words, stored in Big-Endian order!
+newtype Word128 
+  = W128 [Word8]
+  deriving Eq
+
+-- | 256-bit words, stored in Big-Endian order!
+newtype Word256 
+  = W256 [Word8]
+  deriving Eq
+
+fromWord128 :: Word128 -> [Word8]
+fromWord128 (W128 bs) =bs
+
+fromWord256 :: Word256 -> [Word8]
+fromWord256 (W256 bs) = bs
+
+instance Show Word128 where show (W128 bs) = showBytes bs
+instance Show Word256 where show (W256 bs) = showBytes bs
+
+stringToByteList :: String -> [Word8]
+stringToByteList = map readByte . splitString where
+
+  readByte :: String -> Word8
+  readByte [a,b] = read ("0x" ++ [a,b])
+
+  splitString :: String -> [String]
+  splitString []         = []
+  splitString (a:b:rest) = [a,b] : splitString rest
+  splitString [_]        = error "stringToByteList: odd length"
+
+stringToWord128 :: String -> Word128
+stringToWord128 str 
+  | length bs == 16  = W128 bs
+  | otherwise        = error "stringToWord128: expecting 32 hex characters"
+  where
+    bs = stringToByteList str
+
+stringToWord256 :: String -> Word256
+stringToWord256 str 
+  | length bs == 32  = W256 bs
+  | otherwise        = error "stringToWord256: expecting 64 hex characters"
+  where
+    bs = stringToByteList str
+
+--------------------------------------------------------------------------------
+-- TODO: make this nicer...
+
+xor128 :: Word128 -> Word128 -> Word128
+xor128 (W128 as) (W128 bs) = W128 (zipWith xor as bs)
+
+xor256 :: Word256 -> Word256 -> Word256
+xor256 (W256 as) (W256 bs) = W256 (zipWith xor as bs)
+
+add128 :: Word128 -> Word128 -> Word128
+add128 x y = wordFromInteger $ mod (wordToInteger x + wordToInteger y) (2^128)
+
+add256 :: Word256 -> Word256 -> Word256
+add256 x y = wordFromInteger $ mod (wordToInteger x + wordToInteger y) (2^256)
+
+join64 :: Word64 -> Word64 -> Word128
+join64 hi lo = W128 (toBytesBE hi ++ toBytesBE lo)
+
+join128 :: Word128 -> Word128 -> Word256
+join128 hi lo = W256 (fromWord128 hi ++ fromWord128 lo)
+
+split64 :: Word128 -> (Word64, Word64)
+split64 (W128 bs) = (fromBytesBE hi, fromBytesBE lo) where (hi, lo) = splitAt 8 bs
+
+split128 :: Word256 -> (Word128, Word128)
+split128 (W256 bs) = (fromBytesBE hi, fromBytesBE lo) where (hi, lo) = splitAt 16 bs
+
+rnd128 :: IO Word128
+rnd128 = W128 <$> replicateM 16 randomIO 
+
+rnd256 :: IO Word256
+rnd256 = W256 <$> replicateM 32 randomIO 
+
+--------------------------------------------------------------------------------
+
+class IsWord a where
+  toBytesLE   :: a -> [Word8]
+  toBytesBE   :: a -> [Word8]
+  fromBytesLE :: [Word8] -> a 
+  fromBytesBE :: [Word8] -> a 
+  wordToInteger   :: a -> Integer
+  wordFromInteger :: Integer -> a
+  --
+  wordToInteger = bytesToIntegerBE . toBytesBE
+  toBytesLE   = reverse . toBytesBE
+  toBytesBE   = reverse . toBytesLE
+  fromBytesLE = fromBytesBE . reverse
+  fromBytesBE = fromBytesLE . reverse
+
+instance IsWord Word32 where
+  toBytesLE   = bytesFromIntegerLE 4 . fromIntegral
+  fromBytesLE = fromInteger . bytesToIntegerLE 
+  wordToInteger   = fromIntegral
+  wordFromInteger = fromInteger
+
+instance IsWord Word64 where
+  toBytesLE   = bytesFromIntegerLE 8 . fromIntegral
+  fromBytesLE = fromInteger . bytesToIntegerLE 
+  wordToInteger   = fromIntegral
+  wordFromInteger = fromInteger
+
+instance IsWord Word128 where
+  toBytesBE       = fromWord128
+  fromBytesBE bs  = if length bs == 16 then W128 bs else error "fromBytesBE/Word128: wrong input size"
+  wordFromInteger = W128 . bytesFromIntegerBE 16
+
+instance IsWord Word256 where
+  toBytesBE      = fromWord256
+  fromBytesBE bs = if length bs == 32 then W256 bs else error "fromBytesBE/Word256: wrong input size"
+  wordFromInteger = W256 . bytesFromIntegerBE 32
+
+--------------------------------------------------------------------------------
+
+instance ByteVec Word128 where
+  vecLength _       = 16
+  fromBytes bs      = W128 $ take 16 $ bs ++ repeat 0
+  toBytes (W128 bs) = bs
+
+instance ByteVec Word256 where
+  vecLength _       = 32
+  fromBytes bs      = W256 $ take 32 $ bs ++ repeat 0
+  toBytes (W256 bs) = bs
+
+--------------------------------------------------------------------------------
+ 
+bytesToIntegerLE :: [Word8] -> Integer
+bytesToIntegerLE = go where
+  go []     = 0
+  go (b:bs) = fromIntegral b + shiftL (go bs) 8
+
+bytesToIntegerBE :: [Word8] -> Integer
+bytesToIntegerBE = bytesToIntegerLE . reverse
+
+bytesFromIntegerLE :: Int -> Integer -> [Word8]
+bytesFromIntegerLE = go where
+  go 0 0 = []
+  go 0 _ = error "bytesFromIntegerLE: does not fit"
+  go k x = fromInteger (x .&. 255) : go (k-1) (shiftR x 8)
+
+bytesFromIntegerBE :: Int -> Integer -> [Word8]
+bytesFromIntegerBE len x = reverse (bytesFromIntegerLE len x)
+
+--------------------------------------------------------------------------------
+
+showBytes :: [Word8] -> String
+showBytes bs = concat [ printf "%02x" b | b <- bs ]
+
+toHexStringLE :: IsWord a => a -> String
+toHexStringLE = showBytes . toBytesLE
+
+toHexStringBE :: IsWord a => a -> String
+toHexStringBE = showBytes . toBytesBE
+
+ord8 :: Char -> Word8
+ord8 = fromIntegral . ord
+
+chr8 :: Word8 -> Char
+chr8 = chr . fromIntegral
+
+--------------------------------------------------------------------------------
+
+class ToByteString a where
+  toByteStringBE :: a -> ByteString
+
+instance ToByteString Word8 where
+  toByteStringBE w = B.singleton w
+
+instance ToByteString Word16 where
+  toByteStringBE w = B.pack [ fromIntegral (shiftR w 8) , fromIntegral (w .&. 0xff) ]
+
+instance ToByteString Word32 where
+  toByteStringBE w = B.append 
+    (toByteStringBE @Word16 (fromIntegral (shiftR w 16 ))) 
+    (toByteStringBE @Word16 (fromIntegral (w .&. 0xffff)))
+
+instance ToByteString Word64 where
+  toByteStringBE w = B.append 
+    (toByteStringBE @Word32 (fromIntegral (shiftR w 32     ))) 
+    (toByteStringBE @Word32 (fromIntegral (w .&. 0xffffffff)))
+
+--------------------------------------------------------------------------------
+
+class FromByteString a where
+  fromByteStringBE :: ByteString -> (a,ByteString)
+
+fromByteStringBE_ :: FromByteString a => ByteString -> a
+fromByteStringBE_ bs = case fromByteStringBE bs of
+  (y,rest) -> if B.null rest 
+    then y 
+    else error "fromByteStringBE_: cannot parse"
+    
+instance FromByteString Word8 where
+  fromByteStringBE bs = case B.unpack (B.take 1 bs) of
+    [a] -> ( a , B.drop 1 bs )
+    _   -> error "fromByteStringBE/Word8: unexpected end of input"
+
+instance FromByteString Word16 where
+  fromByteStringBE bs = case B.unpack (B.take 2 bs) of
+    [a,b] -> let y = shiftL (fromIntegral a) 8 .|. (fromIntegral b) 
+             in  ( y , B.drop 2 bs )
+    _   -> error "fromByteStringBE/Word16: unexpected end of input"
+
+instance FromByteString Word32 where
+  fromByteStringBE bs = case B.unpack (B.take 4 bs) of
+    [a,b,c,d] -> let y = shiftL (fromIntegral a) 24 .|. 
+                         shiftL (fromIntegral b) 16 .|. 
+                         shiftL (fromIntegral c)  8 .|. 
+                                (fromIntegral d) 
+                 in  ( y , B.drop 4 bs )
+    _   -> error "fromByteStringBE/Word32: unexpected end of input"
+
+--------------------------------------------------------------------------------