packages feed

eccrypto (empty) → 0.0

raw patch · 12 files changed

+1229/−0 lines, 12 filesdep +SHAdep +basedep +bytestringsetup-changed

Dependencies added: SHA, base, bytestring, cereal, crypto-api, vector

Files

+ COPYING view
@@ -0,0 +1,24 @@+Copyright (c) 20[09..], Marcel Fourné+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:+    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.+    * Redistributions in binary form must reproduce the above copyright+      notice, this list of conditions and the following disclaimer in the+      documentation and/or other materials provided with the distribution.+    * Neither the name of the <organization> nor the+      names of its contributors may be used to endorse or promote products+      derived from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY <copyright holder> ''AS IS'' AND ANY+EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL <copyright holder> BE LIABLE FOR ANY+DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES+(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;+LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND+ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS+SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README view
@@ -0,0 +1,16 @@+ECC+---+RSA just doesn't cut it anymore for fast public-key crypto. Keys are large for reasonable security making it quite slow...+Enter elliptic curves: smaller numbers are necessary and everything is faster. Maybe this library is not for embedded system usage, but now people can experiment with ECC for those use-cases where some form of RSA would be chosen otherwise.+++Timing Attack Resistance+------------------------+The point multiplication uses the montgomery ladder algorithm which should be timing attack resistant, but when mul by a number in binary form 1000..0 the operation gets strangely fast (us instead of ms) and 1000..0001 it is strangely slow (1.5 times), which hints to something fishy going on. More research will follow, but sidechannel-resistance is not totally out-of-focus. +Testing has given me the idea that the following-zeroes-case massively benefits from branch-prediction and the trailing-one-case throws it totally off (will have to check that on other CPUs). "More natural" numbers are safer (tested), but I wouldn't dare to say that the matter is resolved.+P.S.: 2^N-1 does not show the cache-problem, only long rows of zeroes.+++Motivation+----------+This is a side-project from which other people may benefit. Due to time-constraints, I can't work as much on it as I would like. If you use/like it or want to make some criticism heard, please write me an email.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ eccrypto.cabal view
@@ -0,0 +1,48 @@+Name:                eccrypto+Version:             0.0+Synopsis:	     Elliptic Curve Cryptography for Haskell+Description:         Elliptic Curve Cryptography in Haskell, evolved for correctness and practical usability from higher-level libraries.+		     .+		     The implementation is pure Haskell and as generic and fast as reasonably possible. Timing-attack resistance is important, failure must be documented.+		     .+		     This library was formerly known and its code originated as hecc, but since this would imply Hyperelliptic ECC, the name was changed. +		     .+		     Also the scope was changed by selecting best internal formats and no longer trying to be overly general, allowing more optimizations.+		     .+		     N.B.: F2 is faulty and slow.+		     .+		     More secure curves will be added.+License:             BSD3+License-file:        COPYING+Copyright:	     (c) Marcel Fourné, 2009-2014+Author:              Marcel Fourné+Maintainer:          Marcel Fourné (haskell@marcelfourne.de)+Category:	     Cryptography+Stability:	     beta+Build-Type:          Simple+Cabal-Version:       >=1.9+Data-Files:	     README+Extra-Source-Files:  src/bench.hs++Library+  hs-source-dirs: src+  Build-Depends:+      base >= 4 && < 5+    , bytestring >= 0.10 && < 0.11+    , cereal >=0.4 && < 0.6+    , SHA >= 1.6.4 && < 1.7+    , crypto-api >= 0.13 && < 0.14+    , vector >= 0.10 && < 0.12+  Exposed-modules:+    Crypto.Common+    Crypto.F2+    Crypto.Fi+    Crypto.ECC.NIST.Base+    Crypto.ECC.NIST.ECDH+    Crypto.ECC.NIST.StandardCurves+    Crypto.ECC.Ed25519.EdDSA+  ghc-options: -Wall++source-repository head+  type:     git+  location: https://github.com/mfourne/hs-eccrypto.git
+ src/Crypto/Common.hs view
@@ -0,0 +1,71 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Crypto.Common+-- Copyright   :  (c) Marcel Fourné 20[09..]+-- License     :  BSD3+-- Maintainer  :  Marcel Fourné (haskell@marcelfourne.de)+-- Stability   :  experimental+-- Portability :  Good+--+-- ECC Base algorithms & point formats for NIST Curves as specified in NISTReCur.pdf[http://csrc.nist.gov/groups/ST/toolkit/documents/dss/NISTReCur.pdf]+-- Re Timing-Attacks: We depend on (==) being resistant for Integer.+-- +-----------------------------------------------------------------------------++{-# OPTIONS_GHC -O2 -feager-blackholing #-}++module Crypto.Common ( wordMax+                     , wordSize+                     , sizeinWords+                     , zero+                     , one+                     , two+                     , three+                     , log2len+                     , testcond+                     )+       where++import Prelude (Num(..),Int,($),(+),(-),(*),fromInteger,Integral,takeWhile,length,iterate,(>),(<=),toInteger,maxBound,rem,quot,quotRem,div)+import qualified Data.Bits as B (Bits(..))+import qualified Data.Word as W (Word)+import qualified Data.Vector.Unboxed as V++-- | return the maximum value storable in a Word+wordMax :: (Integral a) => a+wordMax = fromInteger $ toInteger (maxBound::W.Word)++-- | return the bitSize of a Word+wordSize :: Int+wordSize = B.bitSize (0::W.Word)+{-# INLINE wordSize #-}++-- | determine the needed storage for a bitlength in Words+sizeinWords :: Int -> Int+sizeinWords 0 = 1 -- or error? 0 bit len?!+sizeinWords t = let (w,r) = (abs t) `quotRem` wordSize+                in if r > 0 then w + 1 else w+                                            +-- constant vectors for comparisons etc.+-- | a vector of zeros of requested length+zero :: Int -> V.Vector W.Word+zero l = V.replicate (sizeinWords l) 0+-- | a vector of zeros of requested length, but least significant word 1+one :: Int -> V.Vector W.Word+one l = V.singleton 1 V.++ V.replicate (sizeinWords l - 1)  0+-- | a vector of zeros of requested length, but least significant word 2+two :: Int -> V.Vector W.Word+two l = V.singleton 2 V.++ V.replicate (sizeinWords l - 1)  0+-- | a vector of zeros of requested length, but least significant word 3+three :: Int -> V.Vector W.Word+three l = V.singleton 3 V.++ V.replicate (sizeinWords l - 1) 0++-- | returning the binary length of an Integer+log2len :: (Integral a, B.Bits a) => a -> Int+log2len 0 = 1+log2len n = length (takeWhile (<=n) (iterate (*2) 1))+{-# INLINABLE log2len #-}++-- | we want word w at position i to result in a word to multiply by, eliminating branching+testcond :: W.Word -> Int -> W.Word+testcond w i = B.shift (B.shift w (wordSize - i - 1)) (-(wordSize - 1))
+ src/Crypto/ECC/Ed25519/EdDSA.hs view
@@ -0,0 +1,269 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Crypto.ECC.Bernstein.Ed25519+-- Copyright   :  (c) Marcel Fourné 20[14..]+-- License     :  BSD3+-- Maintainer  :  Marcel Fourné (haskell@marcelfourne.de)+-- Stability   :  alpha+-- Portability :  Good+--+-- Long-time plan: get rid of Integer and do all field arithmetic const-time by hand+-----------------------------------------------------------------------------++{-# OPTIONS_GHC -O2 -feager-blackholing #-}+{-# LANGUAGE ScopedTypeVariables,PackageImports #-}++module Crypto.ECC.Ed25519.EdDSA {-( genkeys+                                , genkeys_simple+                                , sign_detached+                                , sign+                                , verify+                                )-- -}+       where++import Prelude (Eq,Show,(==),(/=),(&&),Int,show,Bool(False,True),(++),($),fail,undefined,(+),(-),(*),otherwise,(<),(>),(<=),(>=),maxBound,rem,quot,quotRem,error,(/),(^),mod,IO,return,not,head,tail,mapM_,Maybe,Either(Left,Right),String,map,Integer,foldr,abs)+import qualified Data.Bits as B (shift,(.&.),(.|.))+import qualified Prelude as P (fromInteger,toInteger,fromIntegral)+import Crypto.Common+import qualified Crypto.Fi as FP+-- import qualified Crypto.FPrime as FP+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as BSL+import qualified Data.Digest.Pure.SHA as H+import qualified Data.Word as W (Word64)+import qualified "crypto-api" Crypto.Random as CR+import qualified Data.Serialize as S+import qualified Data.Serialize.Get as SG (getWord64le)+import qualified Data.Serialize.Put as SP (putWord64le)++-- | working on exactly 256 bits+b :: Int+b = 256++-- | the large prime+q :: FP.FPrime+q = FP.fromInteger b $ 2^(255::Integer) - 19++-- | curve parameter l+l :: FP.FPrime+l = FP.addr q (FP.pow q (FP.fromInteger b 2) (FP.fromInteger b 252)) (FP.fromInteger b 27742317777372353535851937790883648493)++-- | curve parameter d+d :: FP.FPrime+d = FP.mulr q (FP.neg q $ FP.fromInteger b 121665) $ FP.inv q (FP.fromInteger b 121666)++-- | sqrt (-1) on our curve+i :: FP.FPrime+i = FP.pow q 2 (FP.shift (FP.subr q q (FP.fromInteger b 1)) (-2))++-- | wrapper for our hash function+h :: BS.ByteString -> BS.ByteString+h bs = BSL.toStrict $ H.bytestringDigest $ H.sha512 $ BSL.fromStrict bs++-- | the y coordinate of the base point of the curve+by :: FP.FPrime+by = FP.mulr q (FP.fromInteger b 4) (FP.inv q $ FP.fromInteger b 5)++-- additive neutral element+inf :: Point+inf = Point (FP.fromInteger b 0, FP.fromInteger b 1)++-- | special form of FPrime, no bits set+null :: FP.FPrime+null = FP.fromInteger b 0++-- | special form of FPrime, lowest bit set+eins :: FP.FPrime+eins = FP.fromInteger b 1++-- | special form of FPrime, all bits set+alleeins:: FP.FPrime+alleeins = FP.fromInteger b (2^b-1)++-- | recover the x coordinate from the y coordinate and a signum+xrecover :: FP.FPrime -> Integer -> FP.FPrime+xrecover y sign' = let ysqu = FP.pow q y (2::Int)+                       u = FP.subr q ysqu eins+                       v = FP.addr q eins $ FP.mulr q d ysqu+                       beta = FP.mulr q (FP.mulr q u (FP.pow q v (3::Int))) (FP.pow q (FP.mulr q u (FP.pow q v (7::Int))) (FP.shift (FP.sub q (FP.fromInteger b 5)) (-3)))+                       -- v*beta^2 + u == 0? -> z [all-0 or some pattern]; foldr (.|.) 0 [bits from z] -> [0|1] -> [i|eins]+                       fixroot num = let c = FP.addr q (FP.mulr q v (FP.pow q num (2::Int))) u+                                         s = foldr (B..|.) 0 $ listofbits c+                                         pattern = FP.mul alleeins (FP.sub eins s) -- pattern for == -u+                                         invpattern = FP.mul alleeins s -- pattern for /= -u+                                     in FP.add (i B..&. pattern) (eins B..&. invpattern)+                       zwischen = FP.mulr q beta (fixroot beta)+                       signum num sign'' = let signbit = abs (sign'' - (num `mod` 2)) -- y:(0 pos, 1 neg), beta`mod`2:(0 pos, 1 neg)+                                               pat = FP.mul alleeins (FP.sub eins signbit) -- pattern for pos+                                               invpat = FP.mul alleeins signbit -- pattern for neg+                                           in FP.add (eins B..&. pat) (FP.neg q eins B..&. invpat)+                   in FP.mulr q (signum zwischen sign') zwischen++-- | convert a FPrime to a list of FPrimes, each 0 or 1 depending on the inputs bits+listofbits :: FP.FPrime -> [FP.FPrime]+listofbits c = let ex erg pos+                     | pos == 256 = erg+                     | otherwise = ex (FP.condBit c pos:erg) (pos + 1)+               in ex [] (0::Int)++-- | base point on the curve+bPoint :: Point+bPoint = Point (xrecover by 0, FP.redc q by)+-- bPoint = Point (FP.fromInteger b 15112221349535400772501151409588531511454012693041857206046113283949847762202,FP.fromInteger b 46316835694926478169428394003475163141307993866256225615783033603165251855960)++-- | scalar addition+padd :: Point -> Point -> Point+padd (Point (x1,y1)) (Point (x2,y2)) =+  let x1y2 = FP.mulr q x1 y2+      x2y1 = FP.mulr q x2 y1+      y1y2 = FP.mulr q y1 y2+      x1x2 = FP.mulr q x1 x2+      dx1x2y1y2 = FP.mulr q (FP.mulr q d x1x2) y1y2+      x3 = FP.mulr q (FP.addr q x1y2 x2y1) $ FP.inv q (FP.addr q eins dx1x2y1y2)+      y3 = FP.mulr q (FP.addr q y1y2 x1x2) $ FP.inv q (FP.subr q eins dx1x2y1y2)+  in Point (x3,y3)++-- | scalar multiplication, branchfree in k, pattern-matched branch on j (length of k)+pmul :: Point -> FP.FPrime -> Point+pmul (Point (x,y)) k =+  let ex erg j+        | j < 0 = erg+        | otherwise = let s = FP.condBit k j+                          pattern = FP.mul alleeins s+                          invpattern = FP.mul alleeins (FP.sub eins s)+                      in ex (padd (padd erg erg) (Point (x B..&. pattern, FP.add (y B..&. pattern) (eins B..&. invpattern)))) (j - 1)+  in ex inf (log2len k - 1)+{-+-- branching montgomery+      let ex p1 p2 j+            | j < 0 = p1+            | not (FP.testBit k j) = ex (padd p1 p1) (padd p1 p2) (j - 1)+            | otherwise            = ex (padd p1 p2) (padd p2 p2) (j - 1)+      in ex inf (Point (x,y)) (log2len k - 1)+-- -}++-- | check if Point is on the curve, prevents some attacks+ison :: Point -> Bool+ison (Point (x,y)) = FP.addr q (FP.neg q (FP.pow q x(2::Int))) (FP.pow q y (2::Int)) == FP.addr q eins (FP.mulr q (FP.mulr q d (FP.pow q x (2::Int))) (FP.pow q y (2::Int)))+++-- | converts 32 little endian bytes into one FPrime+getFPrime :: S.Get FP.FPrime+getFPrime = do+  lowest <- SG.getWord64le+  lower <- SG.getWord64le+  higher <- SG.getWord64le+  highest <- SG.getWord64le+  return (((P.toInteger lowest) + ((B.shift (P.toInteger lower) 64)::Integer) + (B.shift (P.toInteger higher) 128) + (B.shift (P.toInteger highest) 192))::Integer)+++-- | converts one FPrime into exactly 32 little endian bytes+putFPrime :: FP.FPrime -> S.Put+putFPrime num = do+  let arg = FP.toInteger num+      lowest =  (P.fromInteger $ arg `mod` (2^(64::Integer)))::W.Word64+      lower =   (P.fromInteger $ B.shift (arg `mod` (2^(128::Integer))) (-64))::W.Word64+      higher =  (P.fromInteger $ B.shift (arg `mod` (2^(192::Integer))) (-128))::W.Word64+      highest = (P.fromInteger $ B.shift arg (-192))::W.Word64+  SP.putWord64le lowest+  SP.putWord64le lower+  SP.putWord64le higher+  SP.putWord64le highest++-- | convert a point on the curve to a ByteString+pointtobs :: Point -> BS.ByteString+pointtobs (Point (x,y)) = let yf = FP.add y (FP.shift (x B..&. eins) (b - 1))+                          in S.runPut $ putFPrime yf++-- | convert a ByteString to a point on the curve+bstopoint :: BS.ByteString -> Either String Point+bstopoint bs = do let y = S.runGet getFPrime bs+                  case y of+                    Left _ -> Left "Could not decode Point"+                    Right (y'::FP.FPrime) -> let yf = y' B..&. (alleeins - (2^(b-1)))+                                                 xf = xrecover yf (FP.condBit y' (b-1))                 +                                                 pt = Point (xf,yf)+                                             in if ison pt then Right pt else Left "Point not on curve"++-- | multiply the curve base point by a FPrime, giving a point on the curve+keyPoint :: SecFPrime -> PubKeyPoint+keyPoint = pmul bPoint++--           [b Bits ] +-- BigEndian 01x..x000 ==> ((getFPrime $ h k) .&. (2^254-1-(2^0+2^1+2^2)) .|. (2^254))+-- .&. 28948022309329048855892746252171976963317496166410141009864396001978282409976 .|. 28948022309329048855892746252171976963317496166410141009864396001978282409984+a :: SecKey -> Either String SecFPrime+a k = let hashed = S.runGet getFPrime (h k)+      in case hashed of+        Right h' -> Right (((FP.toInteger h') B..&. 28948022309329048855892746252171976963317496166410141009864396001978282409976 B..|. 28948022309329048855892746252171976963317496166410141009864396001978282409984)::SecFPrime)+        Left e -> Left e++-- Public API + types+-- TODO: make everything more explicit, esp. internals++data Point = Point (FP.FPrime,FP.FPrime) deriving (Eq,Show)++data VerifyResult = SigOK | SigBad deriving (Eq,Show)++type PubKey = BS.ByteString+type PubKeyPoint = Point+type SecKey = BS.ByteString+type SecFPrime = FP.FPrime+type Signature = BS.ByteString+type Message = BS.ByteString++-- | generate a new key pair (secret and derived public key) using some external entropy+genkeys_simple :: IO (Either String (SecKey,PubKey))+genkeys_simple = do+  (g :: CR.SystemRandom) <- CR.newGenIO+  return $ genkeys g+++-- | generate a new key pair (secret and derived public key) using the supplied randomness-generator+genkeys :: (CR.CryptoRandomGen g) => g -> (Either String (SecKey,PubKey))+genkeys g = case CR.genBytes 32 g of+  Left e -> Left (show e)+  Right (bs,g') -> let secret = a bs+                   in case secret of+                     Left e -> Left e+                     Right sec -> let bigA = keyPoint sec+                                      bigAbs = pointtobs bigA+                                  in if ison bigA+                                     then Right (bs,bigAbs)+                                     else Left "private key is not on curve"++-- | sign with secret key the message, resulting in message appended to the signature+sign :: SecKey -> Message -> Either String Signature+sign sk m = case sign_detached sk m of+  Left e    -> Left e+  Right sig -> Right (BS.append sig m)++-- | sign with secret key the message, resulting in a detached signature+sign_detached :: SecKey -> Message -> Either String Signature+sign_detached sk m = let r = S.runGet getFPrime $ h $ BS.append (BS.drop 32 $ h sk) m+                     in case r of+                       Left e -> Left e+                       Right r' -> let rB_ = pointtobs $ keyPoint r'+                                       a' = a sk+                                   in case a' of+                                     Left e -> Left e+                                     Right a'' -> let a_ = pointtobs $ keyPoint a''+                                                      t = S.runGet getFPrime (h $ rB_ `BS.append` a_ `BS.append` m)+                                                  in case t of+                                                    Left e -> Left e+                                                    Right t' -> let s = (r' + (t' * a'')) `mod` l+                                                                    s_ = S.runPut $ putFPrime s+                                                                in Right (BS.append rB_ s_)+++{-+-- | in: public key, message and signature, out: is signature valid for public key and message?+verify :: PubKey -> Signature -> Message -> VerifyResult+verify pk sig m = let r = undefined -- TODO+                      pka = undefined -- TODO+                      sb = undefined -- TODO+                      a' = undefined -- TODO+                  in if pmul sb 8 == padd (pmul r 8) (pmul (pmul a' (getFPrime $ h $ BS.append r $ BS.append pk m)) 8)+                     then SigOK+                     else SigBad+-- -}
+ src/Crypto/ECC/NIST/Base.hs view
@@ -0,0 +1,272 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Crypto.ECC.NIST.Base+-- Copyright   :  (c) Marcel Fourné 20[09..14]+-- License     :  BSD3+-- Maintainer  :  Marcel Fourné (haskell@marcelfourne.de)+-- Stability   :  beta+-- Portability :  Good+--+-- ECC Base algorithms & point formats for NIST Curves as specified in NISTReCur.pdf[http://csrc.nist.gov/groups/ST/toolkit/documents/dss/NISTReCur.pdf]+-- Re Timing-Attacks: The field backends differ in timing-attack resistance. Due to the nature of NIST-curves, there are pitfalls in this module.+-- +-----------------------------------------------------------------------------++{-# OPTIONS_GHC -O2 -feager-blackholing #-}+{-# LANGUAGE GADTs, FlexibleInstances, DeriveDataTypeable , BangPatterns #-}++module Crypto.ECC.NIST.Base ( FP.FPrime+                            , F2.F2+                            , EC(..)+                            , ECPF(..)+                            , affine+                            , export+                            , padd+                            , pdouble+                            , pmul+                            , ison+                            )+       where++import Prelude (Eq,Show,(==),(&&),Integer,Int,show,Bool(False,True),(++),($),fail,undefined,(+),(-),otherwise,(<),div,not,(>),(<=),(>=),maxBound,rem,quot,quotRem,error,mod,(^))+import qualified Prelude as P (fromInteger,toInteger)+-- import qualified Data.Bits as B (shift)+import Data.Typeable(Typeable)+import Crypto.Common+import qualified Crypto.Fi as FP+-- import Crypto.FPrime+import qualified Crypto.F2 as F2++-- | all Elliptic Curves, the parameters being the BitLength L, A, B and P+data EC a where+  -- the Integer Curves, having the form y^2*z=x^3-3*x*z^2+B*z^3 mod P (projective with a = -3); relevant for "ison"+  ECi :: Int          -- the effective bitlength+      -> FP.FPrime    -- b+      -> FP.FPrime    -- p+      -> FP.FPrime    -- r+      -> EC FP.FPrime -- the resulting curve+  -- the Curves on F2, having the form  y^2*z+x*y*z=x^3+a*x^2*z+b*z^3 mod P (projective); relevant for "ison"+  ECb :: Int          -- the effective bitlength+      -> Int          -- a, may be 0 or 1+      -> F2.F2        -- b, may be 1 or something larger+      -> F2.F2        -- p+      -> FP.FPrime    -- r+      -> EC F2.F2     -- the resulting curve+     deriving(Typeable)+instance Eq (EC a) where+  (ECi l b p r) == (ECi l' b' p' r') = l==l' && FP.eq b b' && FP.eq p p' && FP.eq r r'+  (ECb l a b p r) == (ECb l' a' b' p' r') = l==l' && a==a' && F2.eq b b' && F2.eq p p' && FP.eq r r'+  _ == _ = False+instance Show (EC a) where+  show (ECi l b p r) = "Curve with length" ++ show l ++", y^2=x^3-3*x+" ++ show b ++ " mod " ++ show p ++ " and group order " ++ show r ++ "."+  show (ECb l a b p r) = "Curve with length" ++ show l ++", y^2=x^3+" ++ show a ++ "*x+" ++ show (F2.toInteger b) ++ " mod " ++ show (F2.toInteger p) ++ " and group order " ++ show r  ++ "."++-- every point has a curve on which it is valid (has to be tested manually), plus possibly some coordinates+-- parametrised by the kind of numbers one which it may be computed+-- point formats may be translated through functions+-- | data of Elliptic Curve Points+data ECPF a where +  -- Elliptic Curve Point Projective coordinates, three parameters x, y and z, like affine (x/z,y/z)+  ECPp :: FP.FPrime      -- x+       -> FP.FPrime      -- y+       -> FP.FPrime      -- z+       -> ECPF FP.FPrime -- the point+  -- Elliptic Curve Point Projective coordinates in F2, three parameters x, y and z, like affine (x/z,y/z)+  ECPpF2 :: F2.F2        -- x+         -> F2.F2        -- y+         -> F2.F2        -- z+         -> ECPF F2.F2   -- the point+  deriving(Typeable)+instance Eq (ECPF a) where+  (ECPp x y z) == (ECPp x' y' z') = FP.eq x x' && FP.eq y y' && FP.eq z z'+  (ECPpF2 x y z) == (ECPpF2 x' y' z') = F2.eq x x' && F2.eq y y' && F2.eq z z'+  _ == _ = False+instance Show (ECPF a) where+  show (ECPp x y z) = "x: " ++ show x ++ " y: " ++ show y ++ " z: " ++ show z+  show (ECPpF2 x y z) = "x: " ++ show (F2.toInteger x) ++ " y: " ++ show (F2.toInteger y) ++ " z: " ++ show (F2.toInteger z)++-- internal function, codifies point at infinity+isinf :: Int -> ECPF a -> Bool+isinf l (ECPp x y z) = FP.eq x (FP.fromInteger l 0) && FP.eq y (FP.fromInteger l 1) && FP.eq z (FP.fromInteger l 0)+isinf l (ECPpF2 x y z) = F2.eq x (F2.F2 l (zero l)) && F2.eq y (F2.F2 l (one l)) && F2.eq z (F2.F2 l (zero l))++-- | translate point in internal format to a pair of Integers in affine x and y coordinate+-- | this is intended as interface to other libraries+export :: EC a -> ECPF a -> (Integer,Integer)+export c@ECi{} pt@ECPp{} = let (x,y) = affine c pt+                           in (FP.toInteger x, FP.toInteger y)+export c@ECb{} pt@ECPpF2{} = let (x,y) = affine c pt+                             in (F2.toInteger x, F2.toInteger y)                              +export _ _ = error "export parameters of different type"++-- | generic getter, returning the affine x and y-value+affine :: EC a -> ECPF a -> (a,a)+affine (ECi l _ p _)   a@(ECPp x y z)+  | isinf l a = error "converting Point at Infinity"+  | FP.eq z $ FP.fromInteger l 0 = (FP.fromInteger l 0,FP.fromInteger l 0)+  | FP.eq z $ FP.fromInteger l 1 = (x,y)+  | otherwise = let z' = FP.inv p z+                in (FP.mulr p x z', FP.mulr p y z')+affine (ECb l _ _ p _) a@(ECPpF2 x y z)+  | isinf l a = error "converting Point at Infinity"+  | F2.eq z $ F2.F2 l (zero l) = (F2.fromInteger l 0, F2.fromInteger l 0)+  | F2.eq z $ F2.F2 l (one l) = (x,y)+  | otherwise = let z' = F2.inv p z+                in (F2.mulr p x z', F2.mulr p y z')+affine _ _ = error "affine parameters of different type"+{-# INLINABLE affine #-}++-- | add an elliptic point onto itself, base for padd a a+pdouble :: EC a -> ECPF a -> ECPF a+pdouble (ECi l _ p _) p1@(ECPp x1 y1 z1) =+  if isinf l p1+  then p1+  else -- old: let a = ((-3)*z1^(2::Int)+3*x1^(2::Int)) `mod` p+       let a = FP.mulr p (FP.fromInteger l 3) (FP.mulr p (FP.subr p x1 z1) (FP.addr p x1 z1)) -- since alpha == -3 on NIST-curves+           b = FP.mulr p y1 z1+           c = FP.mulr p x1 $ FP.mulr p y1 b+           d = FP.subr p (FP.pow p a (2::Int)) (FP.mulr p (FP.fromInteger l 8) c)+           x3 = FP.mulr p (FP.fromInteger l 2) $ FP.mulr p b d+           y3 = FP.subr p (FP.mulr p a (FP.subr p (FP.mulr p (FP.fromInteger l 4) c) d)) (FP.mulr p (FP.mulr p (FP.fromInteger l 8) (FP.pow p y1 (2::Int))) (FP.pow p b (2::Int)))+           z3 = FP.mulr p (FP.fromInteger l 8) (FP.pow p b (3::Int))+       in ECPp x3 y3 z3+pdouble (ECb l alpha _ p _) p1@(ECPpF2 x1 y1 z1) =+  if isinf l p1+  then p1+  else let a = F2.pow p x1 (2::Int)+           b = F2.addr p a (F2.mulr p y1 z1)+           c = F2.mulr p x1 z1+           d = F2.pow p c (2::Int)+           e = F2.addr p (F2.addr p (F2.pow p b (2::Int)) (F2.mulr p b c)) (if alpha==1 then d else F2.F2 l (zero l))+           x3 = F2.mulr p c e+           y3 = F2.addr p (F2.mulr p (F2.addr p b c) e) (F2.mulr p (F2.pow p a (2::Int)) c)+           z3 =  F2.mulr p c d+       in ECPpF2 x3 y3 z3+pdouble _ _ = error "pdouble parameters of different type"+{-# INLINABLE pdouble #-}++-- | add 2 elliptic points+padd :: EC a -> ECPF a -> ECPF a -> ECPF a+padd curve@(ECi l _ p _) p1@(ECPp x1 y1 z1) p2@(ECPp x2 y2 z2)+        | FP.eq x1 x2 && FP.eq y1 (FP.neg p y2) && FP.eq z1 z2 = ECPp (FP.fromInteger l 0) (FP.fromInteger l 1) (FP.fromInteger l 0) -- Point at Infinity+        | isinf l p1 = p2+        | isinf l p2 = p1+        | p1==p2 = pdouble curve p1+        | otherwise = +            let a = FP.subr p (FP.mulr p y2 z1) (FP.mulr p y1 z2)+                b = FP.subr p (FP.mulr p x2 z1) (FP.mulr p x1 z2)+                c = FP.subr p (FP.subr p (FP.mulr p (FP.pow p a (2::Int)) $ FP.mulr p z1 z2) (FP.pow p b (3::Int))) (FP.mulr p (FP.fromInteger l 2) $ FP.mulr p (FP.pow p b (2::Int)) $ FP.mulr p x1 z2)+                x3 = FP.mulr p b c+                y3 = FP.subr p (FP.mulr p a (FP.subr p (FP.mulr p (FP.pow p b (2::Int)) $ FP.mulr p x1 z2) c)) (FP.mulr p (FP.pow p b (3::Int)) $ FP.mulr p y1 z2)+                z3 = FP.mulr p (FP.pow p b (3::Int)) $ FP.mulr p z1 z2+            in ECPp x3 y3 z3+padd curve@(ECb l alpha _ p _) p1@(ECPpF2 x1 y1 z1) p2@(ECPpF2 x2 y2 z2)+        | F2.eq x1 x2 && F2.eq y1 (F2.addr p x2 y2) && F2.eq z1 z2 = ECPpF2 (F2.F2 l (zero l)) (F2.F2 l (one l)) (F2.F2 l (zero l))  -- Point at Infinity+        | isinf l p1 = p2+        | isinf l p2 = p1+        | p1==p2 = pdouble curve p1+        | otherwise = +            let a = F2.addr p (F2.mulr p y1 z2) (F2.mulr p z1 y2)+                b = F2.addr p (F2.mulr p x1 z2) (F2.mulr p z1 x2)+                c = F2.pow p b (2::Int)+                d = F2.mulr p z1 z2+                e = F2.addr p+                    (F2.mulr p+                     (F2.addr p+                      (F2.addr p+                       (F2.pow p a (2::Int))+                       (F2.mulr p a b)+                      )+                      (F2.mulr p (if alpha==1 then c else F2.F2 l (zero l)) c)+                     )+                     d+                    )+                    (F2.mulr p b c)+                x3 = F2.mulr p b e+                y3 = F2.addr p+                     (F2.mulr p+                      (F2.mulr p+                       c+                       (F2.addr p+                        (F2.mulr p a x1)+                        (F2.mulr p y1 b))+                      )+                      z2+                     )+                     (F2.mulr p (F2.addr p a b) e)+                z3 = F2.mulr p (F2.pow p b (3::Int)) d+            in ECPpF2 x3 y3 z3+padd _ _ _ = error "padd parameters of different type"+{-# INLINABLE padd #-}++-- | "generic" verify, if generic ECP is on EC via getxA and getyA+ison :: EC a -> ECPF a -> Bool+ison (ECi l beta p _) a@(ECPp x y z)+  | isinf l a = True+  | otherwise =+    FP.eq+    (FP.mulr p (FP.pow p y (2::Int)) z)+    (FP.addr p (FP.pow p x (3::Int)) (FP.addr p (FP.mulr p (FP.mulr p (FP.neg p (FP.fromInteger l 3)) x) (FP.pow p z (2::Int))) (FP.mulr p beta (FP.pow p z (3::Int)))))+ison (ECb l alpha beta p _) a@(ECPpF2 x y z)+  | isinf l a = True+  | otherwise =+    F2.eq+    (F2.addr p+     (F2.mulr p (F2.pow p y (2::Int)) z)+     (F2.mulr p (F2.mulr p x y) z)+    )+    (F2.addr p+     (F2.addr p+      (F2.pow p x (3::Int))+      (if alpha==1 then F2.mulr p (F2.pow p x (2::Int)) z else F2.F2 l (zero l))+     )+     (F2.mulr p beta (F2.pow p z (3::Int)))+    )+ison _ _ = error "ison parameters of different type"+{-# INLINABLE ison #-}++-- | Point Multiplication. The implementation is a montgomery ladder, which should be timing-attack-resistant (except for caches...)+pmul :: EC a -> ECPF a -> FP.FPrime -> ECPF a+-- {-+pmul curve@(ECi l _ p _) b@ECPp{} k'  =+  let k = FP.redc (FP.subr p p (FP.fromInteger l 1)) k'+      ex !p1 !p2 !i+        | i < 0 = p1+        | not (FP.testBit k i) = ex (pdouble curve p1) (padd curve p1 p2) (i - 1)+        | otherwise           = ex (padd curve p1 p2) (pdouble curve p2) (i - 1)+  in ex b (pdouble curve b) (log2len k - 2)+pmul curve@(ECb l _ _ p _) b@ECPpF2{} k'  =+  let p' = (FP.fromInteger l $ F2.toInteger p)+      k = FP.redc (FP.subr p' p' (FP.fromInteger l 1)) k'+      ex !p1 !p2 !i+        | i < 0 = p1+        | not (FP.testBit k i) = ex  (pdouble curve p1) (padd curve p1 p2) (i - 1)+        | otherwise           = ex (padd curve p1 p2) (pdouble curve p2) (i - 1)+  in ex b (pdouble curve b) (log2len k - 2)+-- -}+ {-+-- these rely on point addition/doubling to be branching free! i.e. DO NOT USE FOR STANDARD NIST-CURVES! (bc. simpler timing attack w/o FLUSH+RELOAD)+pmul curve@(ECi l _ p _) b@ECPp{} k'+  | k' == 0 = ECPp (FP.fromInteger l 0) (FP.fromInteger l 1) (FP.fromInteger l 0)+  | k' == 1 = b+  | otherwise =+    let k = FP.redc (FP.subr p p (FP.fromInteger l 1)) k'+        ex pt i+          | i < 0 = pt+          | otherwise = let cond = B.shift k (-i) `mod` 2+                        in ex (padd curve (pmul curve b cond) (pdouble curve pt)) (i - 1) -- cond == 1 -> b, cond == 0 -> inf (add neutral)+    in ex b (log2len k - 2) -- begin one after highest bit (always set for i > 0), loglen returns highest bit position +1+pmul curve@(ECb l _ _ p _) b@ECPpF2{} k'+  | k' == 0 = ECPpF2 (F2.fromInteger l 0) (F2.fromInteger l 1) (F2.fromInteger l 0)+  | k' == 1 = b+  | otherwise =+    let p' = (FP.fromInteger l $ F2.toInteger p)+        k = FP.redc (FP.subr p' p' (FP.fromInteger l 1)) k'+        ex pt i+          | i < 0 = pt+          | otherwise = let cond = B.shift k (-i) `mod` 2+                        in ex (padd curve (pmul curve pt cond) (pdouble curve pt)) (i - 1)+    in ex b (log2len k - 2)+-- -}+pmul _ _ _ = error "pmul parameters of different type"+{-# INLINABLE pmul #-}
+ src/Crypto/ECC/NIST/ECDH.hs view
@@ -0,0 +1,30 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Crypto.ECC.NIST.ECDH+-- Copyright   :  (c) Marcel Fourné 20[09..14]+-- License     :  BSD3+-- Maintainer  :  Marcel Fourné (haskell@marcelfourne.de)+-- Stability   :  experimental+-- Portability :  Good+--+-- basic ECDH functions using hecc+--+-----------------------------------------------------------------------------++{-# OPTIONS_GHC -O2 -feager-blackholing #-}++module Crypto.ECC.NIST.ECDH+    where++import Crypto.ECC.NIST.Base+-- import Crypto.ECC.NIST.StandardCurves++-- private key dA of this side and public key qB of the communication partner, returning the simple x coordinate as result+-- to be executed on both sides with fitting parameters...+-- d = pickOne [1..N-1]+-- q = pmul G d+-- | basic ecdh for testing+basicecdh :: EC Integer -> Integer -> ECPF Integer -> Integer+basicecdh c dA qB = if ison c qB then let (x,_) = affine c $ pmul c qB dA+                                      in x+                    else error "point not on curve"
+ src/Crypto/ECC/NIST/StandardCurves.hs view
@@ -0,0 +1,121 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Crypto.ECC.NIST.StandardCurves+-- Copyright   :  (c) Marcel Fourné 20[09..14]+-- License     :  BSD3+-- Maintainer  :  Marcel Fourné (haskell@marcelfourne.de)+-- Stability   :  experimental+-- Portability :  Good+-- +-- ECC NIST Standard Curves, taken from NISTReCur.pdf[http://csrc.nist.gov/groups/ST/toolkit/documents/dss/NISTReCur.pdf]+-- NB: The rigidity of the curve parameters may be manipulatable, for more+--     information see http://safecurves.cr.yp.to/rigid.html+--     Therein mentioned are only the NIST Prime Curves, because...+-- NB F2: Read up on solving the Discrete Logarithm Problem in fields of small characteristic (i.e. here: Binary Curves)+--        and then decide if the results are relevant to you.+-- Recommendation: If your need NIST Curves and you do not know which one, use the Prime Curves.+--+-----------------------------------------------------------------------------++{-# OPTIONS_GHC -O2 -feager-blackholing #-}+{-# LANGUAGE DeriveDataTypeable #-}++module Crypto.ECC.NIST.StandardCurves+    where++import Prelude(Int,Integer,fromInteger)+import Crypto.ECC.NIST.Base (FPrime,F2)+import qualified Crypto.Fi as FP (fromInteger)+import qualified Crypto.F2 as F2 (fromInteger)+import Data.Typeable(Typeable)++-- | Datatype for defined Standard Curves+data StandardCurve = +  -- Curves on Prime Fields+    StandardCurve {stdc_l::Int,stdc_p::FPrime,stdc_r::FPrime,stdc_b::FPrime,stdc_xp::FPrime,stdc_yp::FPrime}+  -- Curves on Binary Fields (F2)+  | StandardCurveF2 {stdcF_l::Int,stdcF_p::F2,stdcF_r::FPrime,stdcF_a::Int,stdcF_b::F2,stdcF_xp::F2,stdcF_yp::F2}+    deriving (Typeable)++-- Nist variety Curves over Prime Fields (large characteristic: p)++-- | NIST Prime Curve P-192+p192:: StandardCurve+p192 = StandardCurve {+         stdc_l = 192,+         stdc_p = FP.fromInteger 192 6277101735386680763835789423207666416083908700390324961279,+         stdc_r = FP.fromInteger 192 6277101735386680763835789423176059013767194773182842284081,+         stdc_b = FP.fromInteger 192 2455155546008943817740293915197451784769108058161191238065,+         stdc_xp = FP.fromInteger 192 602046282375688656758213480587526111916698976636884684818,+         stdc_yp = FP.fromInteger 192 174050332293622031404857552280219410364023488927386650641+       }++-- | NIST Prime Curve P-224+p224:: StandardCurve+p224 = StandardCurve {+         stdc_l = 224,+         stdc_p = FP.fromInteger 224 26959946667150639794667015087019630673557916260026308143510066298881,+         stdc_r = FP.fromInteger 224 26959946667150639794667015087019625940457807714424391721682722368061,+         stdc_b = FP.fromInteger 224 18958286285566608000408668544493926415504680968679321075787234672564,+         stdc_xp = FP.fromInteger 224 19277929113566293071110308034699488026831934219452440156649784352033,+         stdc_yp = FP.fromInteger 224 19926808758034470970197974370888749184205991990603949537637343198772+       }++-- | NIST Prime Curve P-256+p256:: StandardCurve+p256 = StandardCurve {+         stdc_l = 256,+         stdc_p = FP.fromInteger 256 115792089210356248762697446949407573530086143415290314195533631308867097853951,+         stdc_r = FP.fromInteger 256 115792089210356248762697446949407573529996955224135760342422259061068512044369,+         stdc_b = FP.fromInteger 256 41058363725152142129326129780047268409114441015993725554835256314039467401291,+         stdc_xp = FP.fromInteger 256 48439561293906451759052585252797914202762949526041747995844080717082404635286,+         stdc_yp = FP.fromInteger 256 36134250956749795798585127919587881956611106672985015071877198253568414405109+       }++-- | NIST Prime Curve P-384+p384:: StandardCurve+p384 = StandardCurve {+         stdc_l = 384,+         stdc_p = FP.fromInteger 384 39402006196394479212279040100143613805079739270465446667948293404245721771496870329047266088258938001861606973112319,+         stdc_r = FP.fromInteger 384 39402006196394479212279040100143613805079739270465446667946905279627659399113263569398956308152294913554433653942643,+         stdc_b = FP.fromInteger 384 27580193559959705877849011840389048093056905856361568521428707301988689241309860865136260764883745107765439761230575,+         stdc_xp = FP.fromInteger 384 26247035095799689268623156744566981891852923491109213387815615900925518854738050089022388053975719786650872476732087,+         stdc_yp = FP.fromInteger 384 8325710961489029985546751289520108179287853048861315594709205902480503199884419224438643760392947333078086511627871+       }++-- | NIST Prime Curve P-521+p521:: StandardCurve+p521 = StandardCurve {+         stdc_l = 521,+         stdc_p = FP.fromInteger 521 6864797660130609714981900799081393217269435300143305409394463459185543183397656052122559640661454554977296311391480858037121987999716643812574028291115057151,+         stdc_r = FP.fromInteger 521 6864797660130609714981900799081393217269435300143305409394463459185543183397655394245057746333217197532963996371363321113864768612440380340372808892707005449,+         stdc_b = FP.fromInteger 521 1093849038073734274511112390766805569936207598951683748994586394495953116150735016013708737573759623248592132296706313309438452531591012912142327488478985984,+         stdc_xp = FP.fromInteger 521 2661740802050217063228768716723360960729859168756973147706671368418802944996427808491545080627771902352094241225065558662157113545570916814161637315895999846,+         stdc_yp = FP.fromInteger 521 3757180025770020463545507224491183603594455134769762486694567779615544477440556316691234405012945539562144444537289428522585666729196580810124344277578376784+       }++-- Nist variety Curves over Binary Fields (small characteristic: 2; please refer to the new results of solving the Discrete Logarithm Problem in fields of small characterstic, "Cryptopocalypse", Joux et al.)++-- | NIST Binary Field Curve K-283+k283:: StandardCurve+k283 = StandardCurveF2 {+  stdcF_l = 283,+  stdcF_p = F2.fromInteger 283 15541351137805832567355695254588151253139254712417116170014499277911234281641667989665,+  stdcF_r = FP.fromInteger 283 3885337784451458141838923813647037813284811733793061324295874997529815829704422603873,+  stdcF_a = 0,+  stdcF_b = F2.fromInteger 283 1,+  stdcF_xp = F2.fromInteger 283 9737095673315832344313391497449387731784428326114441977662399932694280557468376967222,+  stdcF_yp = F2.fromInteger 283 3497201781826516614681192670485202061196189998012192335594744939847890291586353668697+  }++-- | NIST Binary Field Curve B-283+b283:: StandardCurve+b283 = StandardCurveF2 {+  stdcF_l = 283,+  stdcF_p = F2.fromInteger 283 15541351137805832567355695254588151253139254712417116170014499277911234281641667989665,+  stdcF_r = FP.fromInteger 283 7770675568902916283677847627294075626569625924376904889109196526770044277787378692871,+  stdcF_a = 1,+  stdcF_b = F2.fromInteger 283 4821813576056072374006997780399081180312270030300601270120450341205914644378616963829,+  stdcF_xp = F2.fromInteger 283 11604587487407003699882500449177537465719784002620028212980871291231978603047872962643,+  stdcF_yp = F2.fromInteger 283 6612720053854191978412609357563545875491153188501906352980899759345275170452624446196+  }
+ src/Crypto/F2.hs view
@@ -0,0 +1,189 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Crypto.F2+-- Copyright   :  (c) Marcel Fourné 20[09..]+-- License     :  BSD3+-- Maintainer  :  Marcel Fourné (haskell@marcelfourne.de)+-- Stability   :  alpha+-- Portability :  Good+--+-- Functions for F_{2^{E}}+-- Re Timing-Attacks: We depend on (==) being resistant for Integer.+-- This backend is faulty and slow.+-- +-----------------------------------------------------------------------------++{-# OPTIONS_GHC -O2 -feager-blackholing #-}+{-# LANGUAGE DeriveDataTypeable, BangPatterns #-}++module Crypto.F2 ( F2(..)+                 , eq+                 , add+                 , addr+                 , shift+                 , mul+                 , mulr+                 , testBit+                 , redc+                 , square+                 , pow+                 , inv+                 , fromInteger+                 , toInteger+                 )+       where++import Prelude (Eq,Show,(==),(&&),Integer,Int,show,Bool(False,True),(++),($),fail,undefined,(+),(-),(*),(^),mod,Integral,otherwise,(<),div,not,String,flip,takeWhile,length,iterate,(>),(<=),(>=),maxBound,rem,quot,quotRem,error,(.),max,map,foldl,compare,Ordering(..))+import qualified Prelude as P (toInteger,fromInteger)+import qualified Data.Bits as B (Bits(..),testBit)+import Data.Typeable(Typeable)+import qualified Data.Vector.Unboxed as V+import qualified Data.Word as W (Word)+import Crypto.Common++-- | F2 consist of an exact length of meaningful bits and a representation of those bits in a possibly larger Vector of Words+-- | Note: The vectors use small to large indices, but the Data.Word endianness is of no concern as it is hidden by Data.Bits+-- | This results in indices from 0 to l-1 mapped from left to right across Words+-- | Be careful with those indices! The usage of quotRem with them has caused some headache.+data F2 = F2 {-# UNPACK #-} !Int !(V.Vector W.Word) +        deriving (Show,Typeable)++-- | (==) on F2+eq :: F2 -> F2 -> Bool+eq (F2 la va) (F2 lb vb) = (la == lb) && V.all (== True) (V.zipWith (==) va vb)+{-# INLINABLE eq #-}++-- | (+) on F2+add :: F2 -> F2 -> F2+add (F2 la va) (F2 lb vb) +  | V.length va == V.length vb = F2 (if la>=lb then la else lb) $ V.zipWith B.xor va vb+  | la > lb   = let veclendiff = sizeinWords la - V.length vb -- else fill msbits of smaller F2 with zeros+                in F2 la $ V.zipWith B.xor  va                               (vb V.++ V.replicate veclendiff 0)+  | otherwise = let veclendiff = sizeinWords lb - V.length va+                in F2 lb $ V.zipWith B.xor (va V.++ V.replicate veclendiff 0) vb+{-# INLINABLE add #-}++-- | (+) on F2 modulo p+addr :: F2 -> F2 -> F2 -> F2+addr p a b = redc p $ add a b+{-# INLINABLE addr #-}+  +-- | shift on F2+shift :: F2 -> Int -> F2+shift (F2 !la !va) !i = +    let newbits = la + i+        newlen = sizeinWords newbits+        realshift = i `rem` wordSize+        wordshift = i `quot` wordSize+        svec = case compare realshift 0 of+          GT -> V.replicate wordshift (0::W.Word) V.++ V.map (`B.shift` realshift) va V.++ zero wordSize+          EQ -> V.replicate wordshift (0::W.Word) V.++ va+          LT -> V.replicate wordshift (0::W.Word) V.++ V.map (`B.shift` realshift) va+        svecr = case compare realshift 0 of+          GT -> V.replicate wordshift (0::W.Word) V.++ zero wordSize V.++ V.map (`B.shift` (-(wordSize - realshift))) va+          EQ -> V.replicate wordshift (0::W.Word) V.++ zero la+          LT -> V.drop 1 $ V.replicate wordshift (0::W.Word) V.++ (V.map (`B.shift` (wordSize + realshift)) va V.++ zero wordSize)+        vec = V.zipWith B.xor svec svecr+    in if newbits >= 1+       then F2 newbits $ V.take newlen vec+       else F2 1 $ V.singleton 0+{-# INLINABLE shift #-}++-- | find index1 of word containing bit i at index2, return (index1,index2), index from 0 to bitlength - 1+findindex :: Int -> (Int,Int)+findindex i = i `quotRem` wordSize+{-# INLINABLE findindex #-}+                   +-- | testBit on F2+testBit :: F2 -> Int -> Bool+testBit (F2 !la !va) !i = (i < la) && (let (index1,index2) = findindex i+                                         in (index1 < V.length va) && B.testBit ((V.!) va index1) index2+                                        )+{-# INLINABLE testBit #-}++-- | fill highest bits over official length with 0s+bleachupper :: Int -> F2 -> F2+bleachupper l (F2 _ v) = let (_,ix2) = findindex (l - 1)+                         in F2 l $ V.take (sizeinWords l - 1) v V.++ (V.singleton $ B.shift (B.shift (V.last v) (wordSize - (ix2 + 1))) (-(wordSize - (ix2 + 1))))++-- | polynomial reduction, simple scan+-- TODO: idempotent? not right now -> ERROR!+redc :: F2 -> F2 -> F2+redc m@(F2 !lm _) f@(F2 !lf _)+  | lf >= lm = let null = F2 lm $ zero lm+                   fun f' i+                     | i < lm               = bleachupper lm f'+                     | testBit f' (i - 1) = fun (add (shift m    (i - lm)) f') (i - 1) -- real branch+                     | otherwise          = fun (add (shift null (i - lm)) f') (i - 1) -- for timing-attack-resistance xor with 0s+               in fun f lf+  | otherwise = bleachupper lm f++-- | (*) on F2+-- peasants algorithm+mul :: F2 -> F2 -> F2+mul a@(F2 la _) b@(F2 lb _) =+  let nullen = F2 (2*la) (zero $ 2*la)+      pseudo = F2 lb (zero lb)+      fun i b1 | i < la = fun (i + 1) (add b1 (if testBit a i+                                               -- real branch+                                               then shift b      i+                                               -- for timing-attack-resistance xor with 0s+                                               else shift pseudo i+                                              )+                                      )+               | otherwise = b1+  in fun 0 nullen++-- | (*) on F2, reduced to stay in the field+mulr :: F2 -> F2 -> F2 -> F2+mulr p a b = redc p $ mul a b++-- | squaring on F2+-- TODO: optimize+square :: F2 -> F2+square a = mul a a++-- | the power function on F2 for positive exponents, reducing early+pow :: (B.Bits a, Integral a) => F2 -> F2 -> a -> F2+pow !p !a !k | k <= 0 = error "non-positive exponent for the power function on F2"+             | otherwise =+               let binlog = log2len k+                   ex p1 p2 i+                     | i < 0 = p1+                     | not (B.testBit k i) = ex (redc p $ square p1) (redc p $ mul p1 p2) (i - 1)+                     | otherwise           = ex (redc p $ mul p1 p2) (redc p $ square p2) (i - 1)+               in ex a (redc p $ square a) (binlog - 2)++-- | inversion of F2 in the field+inv :: F2 -> F2 -> F2+inv p a = pow p a (toInteger p - 2)++-- | this is a chunked converter from Integer into eccrypto native format+-- TODO: implement low-level Integer conversion?+fromInteger :: Int -> Integer -> F2+fromInteger l !i = +  let i' = i `rem` (2^l) -- we take only non-negative Integers that fit into l bits+      binlog = log2len i'+      helper a = +        if a <= wordMax+        then V.singleton $ P.fromInteger a+        else let (d,rest) = quotRem a (wordMax + 1)+             in  V.singleton (P.fromInteger rest) V.++ helper d+      filler b = if binlog == l+                 then helper b+                 else let lendiff = sizeinWords l - sizeinWords binlog+                      in helper b V.++ V.replicate lendiff 0+  in F2 l (filler i')+       +-- | this is a chunked converter from eccrypto native format into Integer+-- TODO: implement low-level Integer conversion?+toInteger :: F2 -> Integer+toInteger (F2 !la !va) = +  if la <= wordSize+  then P.toInteger $ V.head va+  else let len = V.length va+           helper r z i = +             if i > 1+             then helper (V.tail r) (z + B.shift (P.toInteger $ V.head r) ((len - i) * wordSize)) (i - 1)+             else z + B.shift (P.toInteger $ V.head r) ((len - i) * wordSize)+       in helper va 0 len
+ src/Crypto/Fi.hs view
@@ -0,0 +1,132 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Crypto.Fi+-- Copyright   :  (c) Marcel Fourné 20[14..]+-- License     :  BSD3+-- Maintainer  :  Marcel Fourné (haskell@marcelfourne.de)+-- Stability   :  beta+-- Portability :  Good+--+-- This is a thin wrapper around Integer to ease transition toward FPrime+-- WARNING! Re Timing-Attacks: This backend is not fully timing attack resistant.+-- +-----------------------------------------------------------------------------++{-# OPTIONS_GHC -O2 -feager-blackholing #-}+{-# LANGUAGE BangPatterns #-}++module Crypto.Fi ( FPrime+                 , eq+                 , add+                 , addr+                 , sub+                 , subr+                 , neg+                 , shift+                 , mul+                 , mulr+                 , redc+                 , square+                 , pow+                 , inv+                 , fromInteger+                 , toInteger+                 , testBit+                 , condBit+                 )+       where++import Prelude (Eq,Show,(==),(&&),Integer,Int,show,Bool(False,True),(++),($),fail,undefined,(+),(-),(*),(^),mod,Integral,otherwise,(<),div,not,String,flip,takeWhile,length,iterate,(>),(<=),(>=),maxBound,rem,quot,quotRem,error)+import qualified Prelude as P (fromInteger,toInteger)+import qualified Data.Bits as B (Bits(..),testBit,shift,(.&.),(.|.))+import Crypto.Common (log2len)++-- | a simple wrapper to ease transition+type FPrime = Integer++-- | most trivial (==) wrapper+eq :: FPrime -> FPrime -> Bool+eq !a !b = a == b+{-# INLINABLE eq #-}++-- | (+) in the field+add :: FPrime -> FPrime -> FPrime+add !a !b = a + b+{-# INLINABLE add #-}++-- | (+) in the field+addr :: FPrime -> FPrime -> FPrime -> FPrime+addr !p !a !b = redc p $ a + b+{-# INLINABLE addr #-}++-- | (-) in the field+sub :: FPrime -> FPrime -> FPrime+sub a b = a - b+{-# INLINABLE sub #-}++-- | (-) in the field+subr :: FPrime -> FPrime -> FPrime -> FPrime+subr p a b = redc p (a - b)+{-# INLINABLE subr #-}++-- | negation in the field+neg :: FPrime -> FPrime -> FPrime+neg !p !a = redc p (-a)+{-# INLINABLE neg #-}++-- | bitshift wrapper+shift :: FPrime -> Int -> FPrime+shift = B.shift++-- | modular reduction, a simple wrapper around mod+redc :: FPrime -> FPrime -> FPrime+redc !p !a = a `mod` p+{-# INLINABLE redc #-}++-- | field multiplication, a * b+mul :: FPrime -> FPrime -> FPrime+mul !a !b = a * b+{-# INLINABLE mul #-}++-- | field multiplication, a * b `mod` p+mulr :: FPrime -> FPrime -> FPrime -> FPrime+mulr !p !a !b = redc p $ a * b+{-# INLINABLE mulr #-}++-- | simple squaring in the field+square :: FPrime -> FPrime -> FPrime+square p a = redc p (a ^ (2::Int))+{-# INLINABLE square #-}++-- | the power function in the field+pow :: (B.Bits a, Integral a) => FPrime -> FPrime -> a -> FPrime+pow !p !a !k = let binlog = log2len k+                   ex p1 p2 i+                     | i < 0 = p1+                     | not (B.testBit k i) = redc p $ ex (square p p1)  (mulr p p1 p2) (i - 1)+                     | otherwise           = redc p $ ex (mulr p p1 p2) (square p p2)  (i - 1)+               in redc p $ ex a (square p a) (binlog - 2)++-- | field inversion+inv :: FPrime -> FPrime -> FPrime+inv !p !a = pow p a (toInteger p - 2)++-- | conversion wrapper with a limit+fromInteger :: Int -> FPrime -> Integer+fromInteger l !a = P.fromInteger (a `mod` (2^l))+{-# INLINABLE fromInteger #-}++-- | a most simple conversion wrapper+toInteger :: FPrime -> Integer+toInteger = P.toInteger +{-# INLINABLE toInteger #-}++-- | a testBit wrapper+testBit :: FPrime -> Int -> Bool+testBit = B.testBit+{-# INLINABLE testBit #-}++-- | like testBit, but give either 0 or 1+condBit :: FPrime -> Int -> FPrime+condBit a i = shift (a B..&. (fromInteger (i+1) ((2^(i+1)-1)::Integer))) (-i)+{-# INLINABLE condBit #-}
+ src/bench.hs view
@@ -0,0 +1,55 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  +-- Copyright   :  (c) Marcel Fourné 20[09..14]+-- License     :  BSD3+-- Maintainer  :  Marcel Fourné (haskell@marcelfourne.de)+--+-- benchmarks+-- recommended:+-- $ ghc --make -threaded bench.hs+-- best performance measured with just 1 thread+--+-----------------------------------------------------------------------------+{-# OPTIONS_GHC -O2 -feager-blackholing #-}++import Crypto.ECC.NIST.Base+import Crypto.ECC.NIST.StandardCurves+import qualified Crypto.F2 as F2 (fromInteger,toInteger)+import Control.Monad.Random+import Criterion+import Criterion.Main++main::IO ()+main = do+  let c1 = ECi (stdc_l p256) (stdc_b p256) (stdc_p p256) (stdc_r p256)+      p1 = ECPp  (stdc_xp p256) (stdc_yp p256) 1+      k10' = 78260987815077071890976764339238653408132491773166348437934213365482899760747+      k11' = 2^254+2^253+2^252+2^251+2^250+2^249+      k12' = 2^254+2^200+2^150+2^100+2^50+1+      c2 = ECi (stdc_l p521) (stdc_b p521) (stdc_p p521) (stdc_r p521)+      p2 = ECPp (stdc_xp p521) (stdc_yp p521) 1+      k20' = 1093849038073734274511112390766805569936207598951683748994586394495953116150735016013708737573759623248592132296706313309438452531591012912142327488478985984+      c3 = ECb (stdcF_l b283) (stdcF_a b283) (stdcF_b b283) (stdcF_p b283) (stdcF_r b283)+      p3 = ECPpF2 (stdcF_xp b283) (stdcF_yp b283) (F2.fromInteger 283 1)+      k30' = 115792089210356248762697446949407573529996955224135760342422259061068512044368+      k31' = 2+      k32' = 3+      k33' = 2^282+  k13' <- evalRandIO $ getRandomR (1,stdc_p p256)+  k21' <- evalRandIO $ getRandomR (1,stdc_p p521)+  k34' <- evalRandIO $ getRandomR (1, F2.toInteger $ stdcF_p b283)+  defaultMain [bgroup "NIST P-256" [ bench "pmul by random value" $ whnf (pmul c1 p1) k13'+                                   , bench "pmul by 2^254" $ whnf (pmul c1 p1 ) (2^254)+                                   , bench "pmul by top 5 bits" $ whnf (pmul c1 p1) k11'+                                   , bench "pmul by 50bit pattern" $ whnf (pmul c1 p1) k12'+                                   ]+{-               +              , bgroup "NIST P-521" [ bench "pmul by random value" $ whnf (pmul c2 p2) k21'+                                    ]+-- -}+{-+              , bgroup "NIST B-283" [ bench "pmul by random value" $ whnf (pmul c3 p3) k34'+                                    ]+-- -}+              ]