Start with Elliptic Curve point math. Slow, but it works.
This commit is contained in:
2
test-generator/.gitignore
vendored
Normal file
2
test-generator/.gitignore
vendored
Normal file
@@ -0,0 +1,2 @@
|
||||
dist/
|
||||
dist-newstyle/
|
||||
41
test-generator/Database.hs
Normal file
41
test-generator/Database.hs
Normal file
@@ -0,0 +1,41 @@
|
||||
module Database(
|
||||
Database,
|
||||
emptyDatabase,
|
||||
generateNum, genSign
|
||||
)
|
||||
where
|
||||
|
||||
import Crypto.Random(DRG(..),SystemDRG)
|
||||
import Data.Bits(shiftL,testBit)
|
||||
import qualified Data.ByteString as S
|
||||
import Data.Map.Strict(Map)
|
||||
import qualified Data.Map.Strict as Map
|
||||
|
||||
type Database = (Map String [Integer], SystemDRG)
|
||||
|
||||
emptyDatabase :: SystemDRG -> Database
|
||||
emptyDatabase g0 = (Map.empty, g0)
|
||||
|
||||
generateNum :: Database -> String -> Int -> (Integer, Database)
|
||||
generateNum (db, rng0) varname size =
|
||||
let (x, rng1) = randomBytesGenerate (size `div` 8) rng0
|
||||
x' = integerize x
|
||||
before = Map.findWithDefault [] varname db
|
||||
in if length (filter (== x') before) < 10
|
||||
then (x', (Map.insert varname (x':before) db, rng1))
|
||||
else generateNum (db, rng1) varname size
|
||||
|
||||
genSign :: (Integer, Database) -> (Integer, Database)
|
||||
genSign (x, (db, rng0)) =
|
||||
let (n, rng1) = randomBytesGenerate 0 rng0
|
||||
n' = integerize n
|
||||
in if testBit n' 0 then (0 - x, (db, rng1)) else (x, (db, rng1))
|
||||
|
||||
integerize :: S.ByteString -> Integer
|
||||
integerize = go 0
|
||||
where
|
||||
go acc bstr =
|
||||
case S.uncons bstr of
|
||||
Nothing -> acc
|
||||
Just (v,rest) ->
|
||||
go ((acc `shiftL` 8) + fromIntegral v) rest
|
||||
108
test-generator/ECDSATesting.hs
Normal file
108
test-generator/ECDSATesting.hs
Normal file
@@ -0,0 +1,108 @@
|
||||
module ECDSATesting(
|
||||
ecdsaTasks
|
||||
)
|
||||
where
|
||||
|
||||
import Crypto.PubKey.ECC.Prim(scalarGenerate,pointAdd,pointNegate,pointDouble,pointBaseMul,pointMul)
|
||||
import Crypto.PubKey.ECC.Types(Curve,CurveName(..),Point(..),getCurveByName)
|
||||
import Crypto.Random(withDRG)
|
||||
import qualified Data.Map.Strict as Map
|
||||
import Math(showX)
|
||||
import Task(Task(..))
|
||||
|
||||
curves :: [(String, Curve)]
|
||||
curves = [("P192", getCurveByName SEC_p192r1)]
|
||||
|
||||
negateTest :: String -> Curve -> Task
|
||||
negateTest name curve = Task {
|
||||
taskName = name ++ " point negation",
|
||||
taskFile = "../testdata/ecc/negate/" ++ name ++ ".test",
|
||||
taskTest = go,
|
||||
taskCount = 1000
|
||||
}
|
||||
where
|
||||
go (memory0, drg) =
|
||||
let (scalar, drg') = withDRG drg (scalarGenerate curve)
|
||||
point = pointBaseMul curve scalar
|
||||
dbl = pointNegate curve point
|
||||
in case (point, dbl) of
|
||||
(PointO, _) -> go (memory0, drg')
|
||||
(_, PointO) -> go (memory0, drg')
|
||||
(Point basex basey, Point dblx dbly) ->
|
||||
let res = Map.fromList [("x", showX basex), ("y", showX basey),
|
||||
("a", showX dblx), ("b", showX dbly)]
|
||||
in (res, scalar, (memory0, drg'))
|
||||
|
||||
doubleTest :: String -> Curve -> Task
|
||||
doubleTest name curve = Task {
|
||||
taskName = name ++ " point doubling",
|
||||
taskFile = "../testdata/ecc/double/" ++ name ++ ".test",
|
||||
taskTest = go,
|
||||
taskCount = 1000
|
||||
}
|
||||
where
|
||||
go (memory0, drg) =
|
||||
let (scalar, drg') = withDRG drg (scalarGenerate curve)
|
||||
point = pointBaseMul curve scalar
|
||||
dbl = pointDouble curve point
|
||||
in case (point, dbl) of
|
||||
(PointO, _) -> go (memory0, drg')
|
||||
(_, PointO) -> go (memory0, drg')
|
||||
(Point basex basey, Point dblx dbly) ->
|
||||
let res = Map.fromList [("x", showX basex), ("y", showX basey),
|
||||
("a", showX dblx), ("b", showX dbly)]
|
||||
in (res, scalar, (memory0, drg'))
|
||||
|
||||
addTest :: String -> Curve -> Task
|
||||
addTest name curve = Task {
|
||||
taskName = name ++ " point addition",
|
||||
taskFile = "../testdata/ecc/add/" ++ name ++ ".test",
|
||||
taskTest = go,
|
||||
taskCount = 1000
|
||||
}
|
||||
where
|
||||
go (memory0, drg0) =
|
||||
let (scalar1, drg1) = withDRG drg0 (scalarGenerate curve)
|
||||
(scalar2, drg2) = withDRG drg1 (scalarGenerate curve)
|
||||
point1 = pointBaseMul curve scalar1
|
||||
point2 = pointBaseMul curve scalar2
|
||||
pointr = pointAdd curve point1 point2
|
||||
in case (point1, point2, pointr) of
|
||||
(Point x1 y1, Point x2 y2, Point xr yr) ->
|
||||
let res = Map.fromList [("x", showX x1), ("y", showX y1),
|
||||
("u", showX x2), ("v", showX y2),
|
||||
("a", showX xr), ("b", showX yr)]
|
||||
in (res, scalar1, (memory0, drg2))
|
||||
_ ->
|
||||
go (memory0, drg2)
|
||||
|
||||
scaleTest :: String -> Curve -> Task
|
||||
scaleTest name curve = Task {
|
||||
taskName = name ++ " point scaling",
|
||||
taskFile = "../testdata/ecc/scale/" ++ name ++ ".test",
|
||||
taskTest = go,
|
||||
taskCount = 1000
|
||||
}
|
||||
where
|
||||
go (memory0, drg0) =
|
||||
let (scalar0, drg1) = withDRG drg0 (scalarGenerate curve)
|
||||
(scalar1, drg2) = withDRG drg1 (scalarGenerate curve)
|
||||
point = pointBaseMul curve scalar0
|
||||
respnt = pointMul curve scalar1 point
|
||||
in case (point, respnt) of
|
||||
(PointO, _) -> go (memory0, drg2)
|
||||
(_, PointO) -> go (memory0, drg2)
|
||||
(Point basex basey, Point resx resy) ->
|
||||
let res = Map.fromList [("x", showX basex), ("y", showX basey),
|
||||
("k", showX scalar1),
|
||||
("a", showX resx), ("b", showX resy)]
|
||||
in (res, scalar0, (memory0, drg2))
|
||||
|
||||
generateTasks :: (String, Curve) -> [Task]
|
||||
generateTasks (name, curve) = [negateTest name curve,
|
||||
doubleTest name curve,
|
||||
addTest name curve,
|
||||
scaleTest name curve]
|
||||
|
||||
ecdsaTasks :: [Task]
|
||||
ecdsaTasks = concatMap generateTasks curves
|
||||
39
test-generator/Main.hs
Normal file
39
test-generator/Main.hs
Normal file
@@ -0,0 +1,39 @@
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
import Control.Concurrent(forkIO)
|
||||
import Control.Concurrent.Chan(Chan,newChan,readChan,writeChan)
|
||||
import Control.Concurrent.MVar(MVar,newMVar,modifyMVar)
|
||||
import Control.Exception(SomeException,catch)
|
||||
import Control.Monad(replicateM_,void)
|
||||
import Crypto.Random(SystemDRG,getSystemDRG)
|
||||
import ECDSATesting(ecdsaTasks)
|
||||
import GHC.Conc(getNumCapabilities)
|
||||
import System.Console.AsciiProgress
|
||||
import Task(Task, runTask)
|
||||
|
||||
taskExecutor :: MVar [Task] -> Chan () -> SystemDRG -> IO SystemDRG
|
||||
taskExecutor taskList done gen =
|
||||
do mnext <- modifyMVar taskList (\case
|
||||
[] -> return ([], Nothing)
|
||||
(x:xs) -> return (xs, Just x))
|
||||
case mnext of
|
||||
Nothing -> do writeChan done ()
|
||||
return gen
|
||||
Just x -> do gen' <- runTask gen x
|
||||
taskExecutor taskList done gen'
|
||||
|
||||
spawnExecutor :: MVar [Task] -> Chan () -> IO ()
|
||||
spawnExecutor tasks done =
|
||||
do gen <- getSystemDRG
|
||||
void (forkIO (catch (void (taskExecutor tasks done gen)) handler))
|
||||
where
|
||||
handler :: SomeException -> IO ()
|
||||
handler e = putStrLn ("ERROR: " ++ show e)
|
||||
|
||||
main :: IO ()
|
||||
main = displayConsoleRegions $
|
||||
do
|
||||
executors <- getNumCapabilities
|
||||
done <- newChan
|
||||
tasks <- newMVar (ecdsaTasks)
|
||||
replicateM_ executors (spawnExecutor tasks done)
|
||||
replicateM_ executors (void $ readChan done)
|
||||
158
test-generator/Math.hs
Normal file
158
test-generator/Math.hs
Normal file
@@ -0,0 +1,158 @@
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
module Math(
|
||||
extendedGCD
|
||||
, barrett, computeK, base
|
||||
, modulate, modulate'
|
||||
, isqrt
|
||||
, divmod
|
||||
, showX, showB
|
||||
)
|
||||
where
|
||||
|
||||
import Data.Bits(shiftL,shiftR)
|
||||
import GHC.Integer.GMP.Internals(recipModInteger)
|
||||
import Numeric(showHex)
|
||||
|
||||
data AlgState = AlgState {
|
||||
u :: Integer,
|
||||
v :: Integer,
|
||||
bigA :: Integer,
|
||||
bigB :: Integer,
|
||||
bigC :: Integer,
|
||||
bigD :: Integer
|
||||
}
|
||||
|
||||
printState :: AlgState -> IO ()
|
||||
printState a =
|
||||
do putStrLn ("u: " ++ showX (u a))
|
||||
putStrLn ("v: " ++ showX (v a))
|
||||
putStrLn ("A: " ++ showX (bigA a))
|
||||
putStrLn ("B: " ++ showX (bigB a))
|
||||
putStrLn ("C: " ++ showX (bigC a))
|
||||
putStrLn ("D: " ++ showX (bigD a))
|
||||
|
||||
extendedGCD :: Integer -> Integer -> (Integer, Integer, Integer)
|
||||
extendedGCD x y = (a, b, g * (v finalState))
|
||||
where
|
||||
(x', y', g, initState) = initialState x y 1
|
||||
finalState = runAlgorithm x' y' initState
|
||||
a = bigC finalState
|
||||
b = bigD finalState
|
||||
|
||||
initialState :: Integer -> Integer -> Integer -> (Integer, Integer, Integer, AlgState)
|
||||
initialState x y g | even x && even y = initialState (x `div` 2) (y `div` 2) (g * 2)
|
||||
| otherwise = (x, y, g, AlgState x y 1 0 0 1)
|
||||
|
||||
runAlgorithm :: Integer -> Integer -> AlgState -> AlgState
|
||||
runAlgorithm x y state | u state == 0 = state
|
||||
| otherwise = runAlgorithm x y state6
|
||||
where
|
||||
state4 = step4 x y state
|
||||
state5 = step5 x y state4
|
||||
state6 = step6 state5
|
||||
|
||||
step4 :: Integer -> Integer -> AlgState -> AlgState
|
||||
step4 x y input@AlgState{..} | even u = step4 x y input'
|
||||
| otherwise = input
|
||||
where
|
||||
input' = AlgState u' v bigA' bigB' bigC bigD
|
||||
u' = u `div` 2
|
||||
bigA' | even bigA && even bigB = bigA `div` 2
|
||||
| otherwise = (bigA + y) `div` 2
|
||||
bigB' | even bigA && even bigB = bigB `div` 2
|
||||
| otherwise = (bigB - x) `div` 2
|
||||
|
||||
step5 :: Integer -> Integer -> AlgState -> AlgState
|
||||
step5 x y input@AlgState{..} | even v = step5 x y input'
|
||||
| otherwise = input
|
||||
where
|
||||
input' = AlgState u v' bigA bigB bigC' bigD'
|
||||
v' = v `div` 2
|
||||
bigC' | even bigC && even bigD = bigC `div` 2
|
||||
| otherwise = (bigC + y) `div` 2
|
||||
bigD' | even bigC && even bigD = bigD `div` 2
|
||||
| otherwise = (bigD - x) `div` 2
|
||||
|
||||
step6 :: AlgState -> AlgState
|
||||
step6 AlgState{..}
|
||||
| u >= v = AlgState (u - v) v (bigA - bigC) (bigB - bigD) bigC bigD
|
||||
| otherwise = AlgState u (v - u) bigA bigB (bigC - bigA) (bigD - bigB)
|
||||
|
||||
barrett :: Integer -> Integer
|
||||
barrett m = (base ^ (2 * k)) `div` m
|
||||
where
|
||||
k = computeK m
|
||||
|
||||
computeK :: Integer -> Int
|
||||
computeK v = go 0 1
|
||||
where
|
||||
go k acc | v <= acc = k
|
||||
| otherwise = go (k + 1) (acc * base)
|
||||
|
||||
base :: Integer
|
||||
base = 2 ^ (64 :: Integer)
|
||||
|
||||
modulate :: Integer -> Int -> Integer
|
||||
modulate x size = x `mod` (2 ^ size)
|
||||
|
||||
modulate' :: Integer -> Int -> Integer
|
||||
modulate' x size = signum x * (abs x `mod` (2 ^ size))
|
||||
|
||||
showX :: (Integral a, Show a) => a -> String
|
||||
showX x | x < 0 = "-" ++ showX (abs x)
|
||||
| otherwise = showHex x ""
|
||||
|
||||
showB :: Bool -> String
|
||||
showB False = "0"
|
||||
showB True = "1"
|
||||
|
||||
isqrt :: Int -> Integer -> Integer
|
||||
isqrt bits val = final
|
||||
where
|
||||
bit' = part1 (1 `shiftL` (bits - 2))
|
||||
--
|
||||
part1 x | x > val = part1 (x `shiftR` 2)
|
||||
| otherwise = x
|
||||
--
|
||||
final = loop val 0 bit'
|
||||
--
|
||||
loop num res bit
|
||||
| bit == 0 = res
|
||||
| otherwise = let (num', res') = adjust num res bit
|
||||
in loop num' (res' `shiftR` 1) (bit `shiftR` 2)
|
||||
adjust num res bit
|
||||
| num >= (res + bit) = (num - (res + bit), res + (bit `shiftL` 1))
|
||||
| otherwise = (num, res)
|
||||
|
||||
divmod :: Integer -> Integer -> Integer -> Maybe Integer
|
||||
divmod x y m =
|
||||
let y' = y `mod` m
|
||||
in case recipModInteger y' m of
|
||||
0 -> Nothing
|
||||
i -> Just ((x * i) `mod` m)
|
||||
|
||||
_run :: Integer -> Integer -> IO ()
|
||||
_run inputx inputy =
|
||||
do let (x, y, g, initState) = initialState inputx inputy 1
|
||||
finalState <- go x y initState
|
||||
putStrLn ("-- FINAL STATE -----------------------")
|
||||
printState finalState
|
||||
putStrLn ("Final value: " ++ showX (g * v finalState))
|
||||
putStrLn ("-- RUN ------")
|
||||
printState (runAlgorithm x y initState)
|
||||
putStrLn ("-- NORMAL ------")
|
||||
let (a, b, v) = extendedGCD inputx inputy
|
||||
putStrLn ("a: " ++ showX a)
|
||||
putStrLn ("b: " ++ showX b)
|
||||
putStrLn ("v: " ++ showX v)
|
||||
|
||||
where
|
||||
go x y state =
|
||||
do putStrLn "-- STATE -----------------------------"
|
||||
printState state
|
||||
if u state == 0
|
||||
then return state
|
||||
else do let state' = step4 x y state
|
||||
state'' = step5 x y state'
|
||||
state''' = step6 state''
|
||||
go x y state'''
|
||||
50
test-generator/Task.hs
Normal file
50
test-generator/Task.hs
Normal file
@@ -0,0 +1,50 @@
|
||||
module Task(
|
||||
Test,
|
||||
Task(..),
|
||||
runTask
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Monad(foldM, forM_)
|
||||
import Crypto.Random(SystemDRG)
|
||||
import qualified Data.Map.Strict as Map
|
||||
import Database
|
||||
import System.Console.AsciiProgress
|
||||
import System.Directory(createDirectoryIfMissing,doesFileExist)
|
||||
import System.FilePath(takeDirectory)
|
||||
import System.IO(Handle,IOMode(..),hPutStrLn,withFile)
|
||||
|
||||
type Test = Database -> (Map.Map String String, Integer, Database)
|
||||
|
||||
data Task = Task {
|
||||
taskName :: String,
|
||||
taskFile :: FilePath,
|
||||
taskTest :: Test,
|
||||
taskCount :: Int
|
||||
}
|
||||
|
||||
runTask :: SystemDRG -> Task -> IO SystemDRG
|
||||
runTask gen task =
|
||||
do createDirectoryIfMissing True (takeDirectory (taskFile task))
|
||||
alreadyDone <- doesFileExist (taskFile task)
|
||||
if alreadyDone
|
||||
then return gen
|
||||
else withFile (taskFile task) WriteMode $ \ hndl ->
|
||||
do pg <- newProgressBar def{ pgOnCompletion = Just ("Finished " ++ taskName task),
|
||||
pgFormat = taskName task ++ " " ++ pgFormat def,
|
||||
pgTotal = fromIntegral (taskCount task) }
|
||||
let initval = emptyDatabase gen
|
||||
(_, gen') <- foldM (writer hndl pg (taskTest task)) initval [0..taskCount task]
|
||||
return gen'
|
||||
where
|
||||
writer :: Handle -> ProgressBar -> Test -> Database -> Int -> IO Database
|
||||
writer hndl pg runner db x =
|
||||
do let (output, key, acc@(db',gen')) = runner db
|
||||
before = Map.findWithDefault [] "RESULT" db'
|
||||
if length (filter (== key) before) >= 10
|
||||
then writer hndl pg runner acc x
|
||||
else do forM_ (Map.toList output) $ \ (outkey, val) ->
|
||||
hPutStrLn hndl (outkey ++ ": " ++ val)
|
||||
tick pg
|
||||
return (Map.insert "RESULT" (key : before) db', gen')
|
||||
|
||||
34
test-generator/gcd.hs
Normal file
34
test-generator/gcd.hs
Normal file
@@ -0,0 +1,34 @@
|
||||
import Numeric
|
||||
|
||||
data Set = Set { r :: Integer, s :: Integer, t :: Integer }
|
||||
|
||||
step :: Set -> Set -> Set
|
||||
step old new = Set r' s' t'
|
||||
where
|
||||
quotient = r old `div` r new
|
||||
r' = r old - (r new * quotient)
|
||||
s' = s old - (s new * quotient)
|
||||
t' = t old - (t new * quotient)
|
||||
|
||||
run :: Integer -> Integer -> IO Set
|
||||
run self rhs = go (Set self 1 0) (Set rhs 0 1)
|
||||
where
|
||||
go old new | r new == 0 =
|
||||
do putStrLn "------------------------------"
|
||||
putStrLn ("res_r: " ++ showX (r old))
|
||||
putStrLn ("res_s: " ++ showX (s old))
|
||||
putStrLn ("res_t: " ++ showX (t old))
|
||||
return old
|
||||
| otherwise =
|
||||
do putStrLn "------------------------------"
|
||||
putStrLn ("old_r: " ++ showX (r old))
|
||||
putStrLn ("old_s: " ++ showX (s old))
|
||||
putStrLn ("old_t: " ++ showX (t old))
|
||||
putStrLn ("new_r: " ++ showX (r new))
|
||||
putStrLn ("new_s: " ++ showX (s new))
|
||||
putStrLn ("new_t: " ++ showX (t new))
|
||||
go new (step old new)
|
||||
|
||||
showX :: Integer -> String
|
||||
showX x | x < 0 = "-" ++ showX (abs x)
|
||||
| otherwise = showHex x ""
|
||||
28
test-generator/test-generator.cabal
Normal file
28
test-generator/test-generator.cabal
Normal file
@@ -0,0 +1,28 @@
|
||||
cabal-version: >=1.10
|
||||
-- Initial package description 'test-generator.cabal' generated by 'cabal
|
||||
-- init'. For further documentation, see
|
||||
-- http://haskell.org/cabal/users-guide/
|
||||
|
||||
name: test-generator
|
||||
version: 0.1.0.0
|
||||
synopsis: Test generation helper
|
||||
-- description:
|
||||
homepage: http://github.com/acw
|
||||
-- bug-reports:
|
||||
license: ISC
|
||||
license-file: ../LICENSE
|
||||
author: Adam Wick
|
||||
maintainer: awick@uhsure.com
|
||||
-- copyright:
|
||||
category: Testing
|
||||
build-type: Simple
|
||||
extra-source-files: CHANGELOG.md
|
||||
|
||||
executable gen-tests
|
||||
main-is: Main.hs
|
||||
other-modules: Database, ECDSATesting, Math, Task
|
||||
-- other-extensions:
|
||||
build-depends: base >=4.11 && < 4.14, ascii-progress, bytestring, containers, cryptonite, directory, filepath, integer-gmp, random
|
||||
hs-source-dirs: .
|
||||
default-language: Haskell2010
|
||||
ghc-options: -Wall -O2 -threaded -rtsopts -with-rtsopts=-N
|
||||
Reference in New Issue
Block a user