From 778bf36e856a0e1b7a8d8eb727414a1ab4f96e72 Mon Sep 17 00:00:00 2001 From: Balazs Komuves Date: Sun, 26 Apr 2026 16:14:37 +0200 Subject: [PATCH] X25519 Diffie-Hellman seems to work --- reference/Crypto/X25519/BaseField.hs | 67 +++++++ reference/Crypto/X25519/DH.hs | 94 +++++++++ reference/Crypto/X25519/Elliptic.hs | 119 ++++++++++++ reference/Crypto/X25519/ScalarField.hs | 40 ++++ reference/Octet.hs | 256 +++++++++++++++++++++++++ 5 files changed, 576 insertions(+) create mode 100644 reference/Crypto/X25519/BaseField.hs create mode 100644 reference/Crypto/X25519/DH.hs create mode 100644 reference/Crypto/X25519/Elliptic.hs create mode 100644 reference/Crypto/X25519/ScalarField.hs create mode 100644 reference/Octet.hs diff --git a/reference/Crypto/X25519/BaseField.hs b/reference/Crypto/X25519/BaseField.hs new file mode 100644 index 0000000..09c0683 --- /dev/null +++ b/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) + +-------------------------------------------------------------------------------- diff --git a/reference/Crypto/X25519/DH.hs b/reference/Crypto/X25519/DH.hs new file mode 100644 index 0000000..968838d --- /dev/null +++ b/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) + +-------------------------------------------------------------------------------- diff --git a/reference/Crypto/X25519/Elliptic.hs b/reference/Crypto/X25519/Elliptic.hs new file mode 100644 index 0000000..35c9bfb --- /dev/null +++ b/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 +-- +-- 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 +-} + +-------------------------------------------------------------------------------- diff --git a/reference/Crypto/X25519/ScalarField.hs b/reference/Crypto/X25519/ScalarField.hs new file mode 100644 index 0000000..5f534d9 --- /dev/null +++ b/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) + +-------------------------------------------------------------------------------- diff --git a/reference/Octet.hs b/reference/Octet.hs new file mode 100644 index 0000000..3aed034 --- /dev/null +++ b/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" + +--------------------------------------------------------------------------------