{-# LANGUAGE BangPatterns #-}

-- |
-- Module      : Crypto.Internal.ECC
-- License     : BSD-style
-- Maintainer  : Kazu Yamamoto <kazu@iij.ad.jp>
-- Stability   : experimental
-- Portability : Good
--
-- The C scalar multiplication for curves over a prime field, which both of
-- the elliptic curve APIs reach for.
module Crypto.Internal.ECC (
    MulResult (..),
    CurveField (..),
    curveMul,
    primeCurveMul,
    primeCurveTableMul,
    baseTable,
    binaryCurveMul,
    binaryCurveC,
) where

import Crypto.Internal.Compat (unsafeDoIO)
import Crypto.Number.Basic (numBits, numBytes)
import Crypto.Number.F2m (addF2m, divF2m, mulF2m, squareF2m)
import qualified Crypto.Number.Serialize.Internal as Internal
import Crypto.PubKey.ECC.Types (
    Curve (..),
    CurveCommon (..),
    CurveName,
    CurvePrime (..),
    Point (..),
    getCurveByName,
 )
import Data.Bits (testBit)
import Data.Word (Word32, Word8)
import Foreign.C.Types (CInt (..))
import Foreign.ForeignPtr (ForeignPtr, mallocForeignPtrBytes, withForeignPtr)
import Foreign.Marshal.Alloc (allocaBytes)
import Foreign.Ptr (Ptr, plusPtr)

-- | What the C made of it.
data MulResult
    = -- | the point it arrived at
      MulPoint !Integer !Integer
    | -- | the point at infinity, which has no coordinates
      MulInfinity
    | -- | not something the C works with, so the caller has to
      MulUnsupported
    deriving (Int -> MulResult -> ShowS
[MulResult] -> ShowS
MulResult -> String
(Int -> MulResult -> ShowS)
-> (MulResult -> String)
-> ([MulResult] -> ShowS)
-> Show MulResult
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> MulResult -> ShowS
showsPrec :: Int -> MulResult -> ShowS
$cshow :: MulResult -> String
show :: MulResult -> String
$cshowList :: [MulResult] -> ShowS
showList :: [MulResult] -> ShowS
Show, MulResult -> MulResult -> Bool
(MulResult -> MulResult -> Bool)
-> (MulResult -> MulResult -> Bool) -> Eq MulResult
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: MulResult -> MulResult -> Bool
== :: MulResult -> MulResult -> Bool
$c/= :: MulResult -> MulResult -> Bool
/= :: MulResult -> MulResult -> Bool
Eq)

-- | Multiply a point by a scalar on the curve @y^2 = x^3 + a*x + b@ over the
-- field of @p@, which has to be an odd prime.  The point has to be on the
-- curve and not the point at infinity, and its coordinates, @a@ and @b@ have
-- to be under @p@; the caller has all of that to hand and the C does not
-- check it.
--
-- The scalar is walked four bits at a time over the whole of the width asked
-- for, so its value is hidden but that width is not.  Ask for the width of
-- the curve's order, which is public, and every scalar in range costs the
-- same.
primeCurveMul
    :: Integer
    -- ^ p
    -> Integer
    -- ^ a
    -> Integer
    -- ^ b
    -> Int
    -- ^ how many bytes of scalar to walk
    -> Integer
    -- ^ the scalar
    -> Integer
    -- ^ the point's x
    -> Integer
    -- ^ the point's y
    -> MulResult
primeCurveMul :: Integer
-> Integer
-> Integer
-> Int
-> Integer
-> Integer
-> Integer
-> MulResult
primeCurveMul Integer
p Integer
a Integer
b Int
klen Integer
k Integer
px Integer
py
    | Integer
p Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
0 Bool -> Bool -> Bool
|| Integer -> Bool
forall a. Integral a => a -> Bool
even Integer
p Bool -> Bool -> Bool
|| Int
klen Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 Bool -> Bool -> Bool
|| Integer
k Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
0 = MulResult
MulUnsupported
    | Bool
otherwise = IO MulResult -> MulResult
forall a. IO a -> a
unsafeDoIO (IO MulResult -> MulResult) -> IO MulResult -> MulResult
forall a b. (a -> b) -> a -> b
$
        Int -> (Ptr Word8 -> IO MulResult) -> IO MulResult
forall a b. Int -> (Ptr a -> IO b) -> IO b
allocaBytes ([Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [Int]
widths) ((Ptr Word8 -> IO MulResult) -> IO MulResult)
-> (Ptr Word8 -> IO MulResult) -> IO MulResult
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
base -> case (Ptr Word8 -> Int -> Ptr Word8)
-> Ptr Word8 -> [Int] -> [Ptr Word8]
forall b a. (b -> a -> b) -> b -> [a] -> [b]
scanl Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
plusPtr Ptr Word8
base [Int]
widths of
            (Ptr Word8
outx : Ptr Word8
outy : Ptr Word8
cx : Ptr Word8
cy : Ptr Word8
ca : Ptr Word8
cb : Ptr Word8
cp : Ptr Word8
ck : [Ptr Word8]
_) -> do
                Int
_ <- Integer -> Ptr Word8 -> Int -> IO Int
Internal.i2ospOf Integer
px Ptr Word8
cx Int
plen
                Int
_ <- Integer -> Ptr Word8 -> Int -> IO Int
Internal.i2ospOf Integer
py Ptr Word8
cy Int
plen
                Int
_ <- Integer -> Ptr Word8 -> Int -> IO Int
Internal.i2ospOf Integer
a Ptr Word8
ca Int
plen
                Int
_ <- Integer -> Ptr Word8 -> Int -> IO Int
Internal.i2ospOf Integer
b Ptr Word8
cb Int
plen
                Int
_ <- Integer -> Ptr Word8 -> Int -> IO Int
Internal.i2ospOf Integer
p Ptr Word8
cp Int
plen
                Int
_ <- Integer -> Ptr Word8 -> Int -> IO Int
Internal.i2ospOf Integer
k Ptr Word8
ck Int
klen
                CInt
r <-
                    Ptr Word8
-> Ptr Word8
-> Ptr Word8
-> Ptr Word8
-> Ptr Word8
-> Word32
-> Ptr Word8
-> Ptr Word8
-> Ptr Word8
-> Word32
-> IO CInt
c_ecc_mul
                        Ptr Word8
outx
                        Ptr Word8
outy
                        Ptr Word8
cx
                        Ptr Word8
cy
                        Ptr Word8
ck
                        (Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
klen)
                        Ptr Word8
ca
                        Ptr Word8
cb
                        Ptr Word8
cp
                        (Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
plen)
                -- the scalar is the caller's secret, and this is the last place
                -- it is written out in the clear
                Integer -> Ptr Word8 -> Int -> IO Int
Internal.i2ospOf Integer
0 Ptr Word8
ck Int
klen IO Int -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                case CInt
r of
                    CInt
0 -> do
                        !Integer
x <- Ptr Word8 -> Int -> IO Integer
Internal.os2ip Ptr Word8
outx Int
plen
                        !Integer
y <- Ptr Word8 -> Int -> IO Integer
Internal.os2ip Ptr Word8
outy Int
plen
                        MulResult -> IO MulResult
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer -> Integer -> MulResult
MulPoint Integer
x Integer
y)
                    CInt
1 -> MulResult -> IO MulResult
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return MulResult
MulInfinity
                    CInt
_ -> MulResult -> IO MulResult
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return MulResult
MulUnsupported
            [Ptr Word8]
_ -> MulResult -> IO MulResult
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return MulResult
MulUnsupported -- there are eight, but say so anyway
  where
    !plen :: Int
plen = Integer -> Int
numBytes Integer
p
    -- What the buffer holds, in this order: the two coordinates out, the two
    -- in, a, b, the prime, and the scalar.  The room to take and where each
    -- one starts both come from here, so they cannot drift apart.
    --
    -- They did once, and nothing caught it: the memory is a pinned array on
    -- the GHC heap, so writing past it is invisible to valgrind, which sees
    -- one large allocation, and to the sanity checks of the debug RTS, which
    -- found nothing when the mistake was put back to try them.  One runner
    -- out of eighteen died of it and the rest went green.  The way to be
    -- right about this is not to have two numbers to keep the same.
    widths :: [Int]
widths = [Int
plen, Int
plen, Int
plen, Int
plen, Int
plen, Int
plen, Int
plen, Int
klen]

foreign import ccall unsafe "crypton_ecc_table_size"
    c_ecc_table_size :: Word32 -> Word32 -> Word32

foreign import ccall safe "crypton_ecc_table_build"
    c_ecc_table_build
        :: Ptr Word8
        -> Ptr Word8
        -> Ptr Word8
        -> Word32
        -> Ptr Word8
        -> Ptr Word8
        -> Ptr Word8
        -> Word32
        -> IO CInt

foreign import ccall safe "crypton_ecc_table_mul"
    c_ecc_table_mul
        :: Ptr Word8
        -> Ptr Word8
        -> Ptr Word8
        -> Ptr Word8
        -> Word32
        -> Ptr Word8
        -> Ptr Word8
        -> Ptr Word8
        -> Word32
        -> IO CInt

foreign import ccall safe "crypton_ecc_mul"
    c_ecc_mul
        :: Ptr Word8
        -> Ptr Word8
        -> Ptr Word8
        -> Ptr Word8
        -> Ptr Word8
        -> Word32
        -> Ptr Word8
        -> Ptr Word8
        -> Ptr Word8
        -> Word32
        -> IO CInt

-- | What a curve is made of, as much of it as a multiplication needs.
data CurveField
    = -- | over a prime field: the prime, a and b
      Prime !Integer !Integer !Integer
    | -- | over a binary field: the polynomial and b
      Binary !Integer !Integer
    deriving (Int -> CurveField -> ShowS
[CurveField] -> ShowS
CurveField -> String
(Int -> CurveField -> ShowS)
-> (CurveField -> String)
-> ([CurveField] -> ShowS)
-> Show CurveField
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CurveField -> ShowS
showsPrec :: Int -> CurveField -> ShowS
$cshow :: CurveField -> String
show :: CurveField -> String
$cshowList :: [CurveField] -> ShowS
showList :: [CurveField] -> ShowS
Show, CurveField -> CurveField -> Bool
(CurveField -> CurveField -> Bool)
-> (CurveField -> CurveField -> Bool) -> Eq CurveField
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CurveField -> CurveField -> Bool
== :: CurveField -> CurveField -> Bool
$c/= :: CurveField -> CurveField -> Bool
/= :: CurveField -> CurveField -> Bool
Eq)

-- | Multiply a point by a scalar, through the C wherever the C takes it.
--
-- Both elliptic curve APIs come here, so that the decision -- the table for a
-- base point, the C for anything else, what is left over -- is made once and
-- in one place.  One of those APIs cannot be reached from outside the library
-- on a curve over a binary field, and this is how that copy stays the same
-- code as the copy everybody runs.
--
-- The caller has seen to it that the point is on the curve, which is what the
-- C takes for granted, and deals with 'MulUnsupported' in whatever way it
-- has.
curveMul
    :: CurveField
    -> Integer
    -- ^ the order of the curve
    -> Integer
    -- ^ the scalar
    -> Integer
    -- ^ the point's x
    -> Integer
    -- ^ the point's y
    -> Bool
    -- ^ whether that point is the curve's base point
    -> MulResult
curveMul :: CurveField
-> Integer -> Integer -> Integer -> Integer -> Bool -> MulResult
curveMul CurveField
field Integer
order Integer
k Integer
px Integer
py Bool
isBase = case CurveField
field of
    Prime Integer
p Integer
a Integer
b
        | Bool
isBase
        , Int
klen Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Integer -> Int
numBytes Integer
order
        , Just ForeignPtr Word8
table <- Integer
-> Integer
-> Integer
-> Int
-> Integer
-> Integer
-> Maybe (ForeignPtr Word8)
baseTable Integer
p Integer
a Integer
b Int
klen Integer
px Integer
py ->
            ForeignPtr Word8
-> Integer -> Integer -> Integer -> Int -> Integer -> MulResult
primeCurveTableMul ForeignPtr Word8
table Integer
p Integer
a Integer
b Int
klen Integer
k
        | Bool
otherwise -> Integer
-> Integer
-> Integer
-> Int
-> Integer
-> Integer
-> Integer
-> MulResult
primeCurveMul Integer
p Integer
a Integer
b Int
klen Integer
k Integer
px Integer
py
    Binary Integer
fx Integer
b
        | Integer
px Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
0 -> MulResult
MulUnsupported -- its own negation, and easier the long way
        | Bool
otherwise -> case Integer
-> Integer -> Int -> Integer -> Integer -> Integer -> MulResult
binaryCurveC Integer
fx Integer
b Int
klen Integer
k Integer
px Integer
py of
            -- the ladder in Haskell, for a field the C will not take
            MulResult
MulUnsupported -> Integer
-> Integer -> Int -> Integer -> Integer -> Integer -> MulResult
binaryCurveMul Integer
fx Integer
b (Int
klen Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
8) Integer
k Integer
px Integer
py
            MulResult
r -> MulResult
r
  where
    -- Walk the width of the order, which is public, so a scalar in range --
    -- which is every secret one -- costs the same whatever it is.  A scalar
    -- may still be given out of range, and then the width has to follow it or
    -- the high bits would be dropped.
    !klen :: Int
klen = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max (Integer -> Int
numBytes Integer
k) (Integer -> Int
numBytes Integer
order)

-- | The table for the base point of a curve the library knows, which is the
-- point signing and making a key multiply and the only point worth keeping a
-- table for.  The curves are told apart by their numbers, which are public,
-- so both of the elliptic curve APIs find the same table.
--
-- Each is built when it is first wanted and kept for as long as the program
-- runs, and a curve nobody multiplies the base point of never has one built.
-- Building costs 2.8 ms for secp256k1, 5.5 for secp384r1 and 10.6 for
-- secp521r1, and the last two take 221 KB and 456 KB.  A multiplication with
-- the table takes about a third of what one without it takes, so the build
-- pays for itself after about fifteen of them: a program that signs many
-- times wins, and one that signs once and exits does not.
baseTable
    :: Integer
    -- ^ p
    -> Integer
    -- ^ a
    -> Integer
    -- ^ b
    -> Int
    -- ^ how many bytes of scalar are wanted
    -> Integer
    -- ^ the base point's x
    -> Integer
    -- ^ the base point's y
    -> Maybe (ForeignPtr Word8)
baseTable :: Integer
-> Integer
-> Integer
-> Int
-> Integer
-> Integer
-> Maybe (ForeignPtr Word8)
baseTable Integer
p Integer
a Integer
b Int
klen Integer
gx Integer
gy =
    case (Integer, Integer, Integer, Int, Integer, Integer)
-> [((Integer, Integer, Integer, Int, Integer, Integer),
     Maybe (ForeignPtr Word8))]
-> Maybe (Maybe (ForeignPtr Word8))
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (Integer
p, Integer
a, Integer
b, Int
klen, Integer
gx, Integer
gy) [((Integer, Integer, Integer, Int, Integer, Integer),
  Maybe (ForeignPtr Word8))]
baseTables of
        Just Maybe (ForeignPtr Word8)
table -> Maybe (ForeignPtr Word8)
table
        Maybe (Maybe (ForeignPtr Word8))
Nothing -> Maybe (ForeignPtr Word8)
forall a. Maybe a
Nothing

type TableKey = (Integer, Integer, Integer, Int, Integer, Integer)

baseTables :: [(TableKey, Maybe (ForeignPtr Word8))]
baseTables :: [((Integer, Integer, Integer, Int, Integer, Integer),
  Maybe (ForeignPtr Word8))]
baseTables =
    [ ((Integer
p, Integer
a, Integer
b, Int
klen, Integer
gx, Integer
gy), Integer
-> Integer
-> Integer
-> Int
-> Integer
-> Integer
-> Maybe (ForeignPtr Word8)
primeCurveTable Integer
p Integer
a Integer
b Int
klen Integer
gx Integer
gy)
    | CurveName
name <- [CurveName
forall a. Bounded a => a
minBound .. CurveName
forall a. Bounded a => a
maxBound] :: [CurveName]
    , CurveFP (CurvePrime Integer
p CurveCommon
cc) <- [CurveName -> Curve
getCurveByName CurveName
name]
    , Point Integer
gx Integer
gy <- [CurveCommon -> Point
ecc_g CurveCommon
cc]
    , let a :: Integer
a = CurveCommon -> Integer
ecc_a CurveCommon
cc
    , let b :: Integer
b = CurveCommon -> Integer
ecc_b CurveCommon
cc
    , let klen :: Int
klen = Integer -> Int
numBytes (CurveCommon -> Integer
ecc_n CurveCommon
cc)
    ]
{-# NOINLINE baseTables #-}

-- | The multiples of a point that 'primeCurveTableMul' wants: for every four
-- bits of a scalar, the sixteen points those bits can call for.  Building it
-- costs a few thousand point operations, and what it saves is all the
-- doublings of every multiplication that uses it, so it is worth keeping for
-- as long as the point is -- which for a curve's base point is forever.
--
-- The arguments are as for 'primeCurveMul'.  'Nothing' means the C would not
-- take them.
primeCurveTable
    :: Integer
    -- ^ p
    -> Integer
    -- ^ a
    -> Integer
    -- ^ b
    -> Int
    -- ^ how many bytes of scalar the table is to cover
    -> Integer
    -- ^ the point's x
    -> Integer
    -- ^ the point's y
    -> Maybe (ForeignPtr Word8)
primeCurveTable :: Integer
-> Integer
-> Integer
-> Int
-> Integer
-> Integer
-> Maybe (ForeignPtr Word8)
primeCurveTable Integer
p Integer
a Integer
b Int
klen Integer
px Integer
py
    | Integer
p Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
0 Bool -> Bool -> Bool
|| Integer -> Bool
forall a. Integral a => a -> Bool
even Integer
p Bool -> Bool -> Bool
|| Int
klen Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 Bool -> Bool -> Bool
|| Word32
size Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
0 = Maybe (ForeignPtr Word8)
forall a. Maybe a
Nothing
    | Bool
otherwise = IO (Maybe (ForeignPtr Word8)) -> Maybe (ForeignPtr Word8)
forall a. IO a -> a
unsafeDoIO (IO (Maybe (ForeignPtr Word8)) -> Maybe (ForeignPtr Word8))
-> IO (Maybe (ForeignPtr Word8)) -> Maybe (ForeignPtr Word8)
forall a b. (a -> b) -> a -> b
$ do
        ForeignPtr Word8
table <- Int -> IO (ForeignPtr Word8)
forall a. Int -> IO (ForeignPtr a)
mallocForeignPtrBytes (Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
size)
        Int
-> (Ptr Word8 -> IO (Maybe (ForeignPtr Word8)))
-> IO (Maybe (ForeignPtr Word8))
forall a b. Int -> (Ptr a -> IO b) -> IO b
allocaBytes ([Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [Int]
widths) ((Ptr Word8 -> IO (Maybe (ForeignPtr Word8)))
 -> IO (Maybe (ForeignPtr Word8)))
-> (Ptr Word8 -> IO (Maybe (ForeignPtr Word8)))
-> IO (Maybe (ForeignPtr Word8))
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
base -> case (Ptr Word8 -> Int -> Ptr Word8)
-> Ptr Word8 -> [Int] -> [Ptr Word8]
forall b a. (b -> a -> b) -> b -> [a] -> [b]
scanl Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
plusPtr Ptr Word8
base [Int]
widths of
            (Ptr Word8
cx : Ptr Word8
cy : Ptr Word8
ca : Ptr Word8
cb : Ptr Word8
cp : [Ptr Word8]
_) -> do
                Int
_ <- Integer -> Ptr Word8 -> Int -> IO Int
Internal.i2ospOf Integer
px Ptr Word8
cx Int
plen
                Int
_ <- Integer -> Ptr Word8 -> Int -> IO Int
Internal.i2ospOf Integer
py Ptr Word8
cy Int
plen
                Int
_ <- Integer -> Ptr Word8 -> Int -> IO Int
Internal.i2ospOf Integer
a Ptr Word8
ca Int
plen
                Int
_ <- Integer -> Ptr Word8 -> Int -> IO Int
Internal.i2ospOf Integer
b Ptr Word8
cb Int
plen
                Int
_ <- Integer -> Ptr Word8 -> Int -> IO Int
Internal.i2ospOf Integer
p Ptr Word8
cp Int
plen
                CInt
r <- ForeignPtr Word8 -> (Ptr Word8 -> IO CInt) -> IO CInt
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr Word8
table ((Ptr Word8 -> IO CInt) -> IO CInt)
-> (Ptr Word8 -> IO CInt) -> IO CInt
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
t ->
                    Ptr Word8
-> Ptr Word8
-> Ptr Word8
-> Word32
-> Ptr Word8
-> Ptr Word8
-> Ptr Word8
-> Word32
-> IO CInt
c_ecc_table_build
                        Ptr Word8
t
                        Ptr Word8
cx
                        Ptr Word8
cy
                        (Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
klen)
                        Ptr Word8
ca
                        Ptr Word8
cb
                        Ptr Word8
cp
                        (Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
plen)
                Maybe (ForeignPtr Word8) -> IO (Maybe (ForeignPtr Word8))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (ForeignPtr Word8) -> IO (Maybe (ForeignPtr Word8)))
-> Maybe (ForeignPtr Word8) -> IO (Maybe (ForeignPtr Word8))
forall a b. (a -> b) -> a -> b
$ if CInt
r CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
== CInt
0 then ForeignPtr Word8 -> Maybe (ForeignPtr Word8)
forall a. a -> Maybe a
Just ForeignPtr Word8
table else Maybe (ForeignPtr Word8)
forall a. Maybe a
Nothing
            [Ptr Word8]
_ -> Maybe (ForeignPtr Word8) -> IO (Maybe (ForeignPtr Word8))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (ForeignPtr Word8)
forall a. Maybe a
Nothing -- there are five, but say so anyway
  where
    !plen :: Int
plen = Integer -> Int
numBytes Integer
p
    !size :: Word32
size = Word32 -> Word32 -> Word32
c_ecc_table_size (Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
plen) (Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
klen)
    -- the point, a, b and the prime, all of the prime's width.  The room to
    -- take and where each one starts both come from here, so they cannot
    -- drift apart: they did once, and nothing caught it -- see the note on
    -- primeCurveMul.
    widths :: [Int]
widths = [Int
plen, Int
plen, Int
plen, Int
plen, Int
plen]

-- | Multiply the point a table was built for by a scalar of the width the
-- table was built for.  One addition for every four bits and no doublings.
primeCurveTableMul
    :: ForeignPtr Word8
    -- ^ the table
    -> Integer
    -- ^ p
    -> Integer
    -- ^ a
    -> Integer
    -- ^ b
    -> Int
    -- ^ the width the table was built for
    -> Integer
    -- ^ the scalar
    -> MulResult
primeCurveTableMul :: ForeignPtr Word8
-> Integer -> Integer -> Integer -> Int -> Integer -> MulResult
primeCurveTableMul ForeignPtr Word8
table Integer
p Integer
a Integer
b Int
klen Integer
k
    | Integer
p Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
0 Bool -> Bool -> Bool
|| Integer -> Bool
forall a. Integral a => a -> Bool
even Integer
p Bool -> Bool -> Bool
|| Int
klen Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 Bool -> Bool -> Bool
|| Integer
k Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
0 = MulResult
MulUnsupported
    | Bool
otherwise = IO MulResult -> MulResult
forall a. IO a -> a
unsafeDoIO (IO MulResult -> MulResult) -> IO MulResult -> MulResult
forall a b. (a -> b) -> a -> b
$
        Int -> (Ptr Word8 -> IO MulResult) -> IO MulResult
forall a b. Int -> (Ptr a -> IO b) -> IO b
allocaBytes ([Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [Int]
widths) ((Ptr Word8 -> IO MulResult) -> IO MulResult)
-> (Ptr Word8 -> IO MulResult) -> IO MulResult
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
base -> case (Ptr Word8 -> Int -> Ptr Word8)
-> Ptr Word8 -> [Int] -> [Ptr Word8]
forall b a. (b -> a -> b) -> b -> [a] -> [b]
scanl Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
plusPtr Ptr Word8
base [Int]
widths of
            (Ptr Word8
outx : Ptr Word8
outy : Ptr Word8
ca : Ptr Word8
cb : Ptr Word8
cp : Ptr Word8
ck : [Ptr Word8]
_) -> do
                Int
_ <- Integer -> Ptr Word8 -> Int -> IO Int
Internal.i2ospOf Integer
a Ptr Word8
ca Int
plen
                Int
_ <- Integer -> Ptr Word8 -> Int -> IO Int
Internal.i2ospOf Integer
b Ptr Word8
cb Int
plen
                Int
_ <- Integer -> Ptr Word8 -> Int -> IO Int
Internal.i2ospOf Integer
p Ptr Word8
cp Int
plen
                Int
_ <- Integer -> Ptr Word8 -> Int -> IO Int
Internal.i2ospOf Integer
k Ptr Word8
ck Int
klen
                CInt
r <- ForeignPtr Word8 -> (Ptr Word8 -> IO CInt) -> IO CInt
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr Word8
table ((Ptr Word8 -> IO CInt) -> IO CInt)
-> (Ptr Word8 -> IO CInt) -> IO CInt
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
t ->
                    Ptr Word8
-> Ptr Word8
-> Ptr Word8
-> Ptr Word8
-> Word32
-> Ptr Word8
-> Ptr Word8
-> Ptr Word8
-> Word32
-> IO CInt
c_ecc_table_mul
                        Ptr Word8
outx
                        Ptr Word8
outy
                        Ptr Word8
t
                        Ptr Word8
ck
                        (Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
klen)
                        Ptr Word8
ca
                        Ptr Word8
cb
                        Ptr Word8
cp
                        (Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
plen)
                Integer -> Ptr Word8 -> Int -> IO Int
Internal.i2ospOf Integer
0 Ptr Word8
ck Int
klen IO Int -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                case CInt
r of
                    CInt
0 -> do
                        !Integer
x <- Ptr Word8 -> Int -> IO Integer
Internal.os2ip Ptr Word8
outx Int
plen
                        !Integer
y <- Ptr Word8 -> Int -> IO Integer
Internal.os2ip Ptr Word8
outy Int
plen
                        MulResult -> IO MulResult
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer -> Integer -> MulResult
MulPoint Integer
x Integer
y)
                    CInt
1 -> MulResult -> IO MulResult
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return MulResult
MulInfinity
                    CInt
_ -> MulResult -> IO MulResult
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return MulResult
MulUnsupported
            [Ptr Word8]
_ -> MulResult -> IO MulResult
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return MulResult
MulUnsupported -- there are six, but say so anyway
  where
    !plen :: Int
plen = Integer -> Int
numBytes Integer
p
    widths :: [Int]
widths = [Int
plen, Int
plen, Int
plen, Int
plen, Int
plen, Int
klen]

-- | Multiply a point by a scalar on the curve @y^2 + x*y = x^3 + a*x^2 + b@
-- over the binary field of @fx@, by Montgomery's ladder.
--
-- The ladder carries the multiples of two consecutive numbers, whose
-- difference is therefore the point itself, and every bit of the scalar costs
-- one addition and one doubling of them whichever way it goes.  Only the x
-- coordinates are carried -- the difference being known is what lets them be
-- -- and the y is worked out at the end from the two of them, which is what
-- makes the coordinates projective: one division for the whole
-- multiplication rather than one for every step.
--
-- The point has to be on the curve and to have an x, which is what the
-- caller has to hand: the one point with no x is its own negation and is
-- easier multiplied the long way.  The scalar is walked over the whole of
-- the width asked for, so its value is hidden but that width is not.
binaryCurveMul
    :: Integer
    -- ^ the polynomial the field is over
    -> Integer
    -- ^ b
    -> Int
    -- ^ how many bits of scalar to walk
    -> Integer
    -- ^ the scalar
    -> Integer
    -- ^ the point's x
    -> Integer
    -- ^ the point's y
    -> MulResult
binaryCurveMul :: Integer
-> Integer -> Int -> Integer -> Integer -> Integer -> MulResult
binaryCurveMul Integer
fx Integer
b Int
bits Integer
k Integer
x Integer
y
    | Int
bits Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 Bool -> Bool -> Bool
|| Integer
k Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
0 Bool -> Bool -> Bool
|| Integer
x Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
0 = MulResult
MulUnsupported
    | Bool
otherwise = ((Integer, Integer), (Integer, Integer)) -> MulResult
recover (Int
-> (Integer, Integer)
-> (Integer, Integer)
-> ((Integer, Integer), (Integer, Integer))
go (Int
bits Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) (Integer
1, Integer
0) (Integer
x, Integer
1))
  where
    infixl 6 .+.
    .+. :: Integer -> Integer -> Integer
(.+.) = Integer -> Integer -> Integer
addF2m
    sqr :: Integer -> Integer
sqr = Integer -> Integer -> Integer
squareF2m Integer
fx
    mul :: Integer -> Integer -> Integer
mul = Integer -> Integer -> Integer -> Integer
mulF2m Integer
fx

    -- The two of them added, which the difference between them being the
    -- point makes possible from their x coordinates alone.  It does not
    -- matter which way round they come.
    madd :: (Integer, Integer) -> (Integer, Integer) -> (Integer, Integer)
madd (Integer
xa, Integer
za) (Integer
xb, Integer
zb) =
        let t1 :: Integer
t1 = Integer -> Integer -> Integer
mul Integer
xa Integer
zb
            t2 :: Integer
t2 = Integer -> Integer -> Integer
mul Integer
xb Integer
za
            z :: Integer
z = Integer -> Integer
sqr (Integer
t1 Integer -> Integer -> Integer
.+. Integer
t2)
         in (Integer -> Integer -> Integer
mul Integer
x Integer
z Integer -> Integer -> Integer
.+. Integer -> Integer -> Integer
mul Integer
t1 Integer
t2, Integer
z)

    -- One of them doubled.
    mdouble :: (Integer, Integer) -> (Integer, Integer)
mdouble (Integer
xa, Integer
za) =
        let xa2 :: Integer
xa2 = Integer -> Integer
sqr Integer
xa
            za2 :: Integer
za2 = Integer -> Integer
sqr Integer
za
         in (Integer -> Integer
sqr Integer
xa2 Integer -> Integer -> Integer
.+. Integer -> Integer -> Integer
mul Integer
b (Integer -> Integer
sqr Integer
za2), Integer -> Integer -> Integer
mul Integer
xa2 Integer
za2)

    -- Nothing is at infinity to begin with and the point is next to it, and
    -- from there each bit takes the pair to twice where it was.  The bangs
    -- are what make both halves happen: without them the one the bit does not
    -- call for would stay a thunk, and the work would follow the scalar.
    go :: Int
-> (Integer, Integer)
-> (Integer, Integer)
-> ((Integer, Integer), (Integer, Integer))
go Int
i (Integer, Integer)
p1 (Integer, Integer)
p2
        | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 = ((Integer, Integer)
p1, (Integer, Integer)
p2)
        | Integer -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit Integer
k Int
i =
            let !s :: (Integer, Integer)
s = (Integer, Integer) -> (Integer, Integer) -> (Integer, Integer)
madd (Integer, Integer)
p1 (Integer, Integer)
p2
                !d :: (Integer, Integer)
d = (Integer, Integer) -> (Integer, Integer)
mdouble (Integer, Integer)
p2
             in Int
-> (Integer, Integer)
-> (Integer, Integer)
-> ((Integer, Integer), (Integer, Integer))
go (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) (Integer, Integer)
s (Integer, Integer)
d
        | Bool
otherwise =
            let !s :: (Integer, Integer)
s = (Integer, Integer) -> (Integer, Integer) -> (Integer, Integer)
madd (Integer, Integer)
p1 (Integer, Integer)
p2
                !d :: (Integer, Integer)
d = (Integer, Integer) -> (Integer, Integer)
mdouble (Integer, Integer)
p1
             in Int
-> (Integer, Integer)
-> (Integer, Integer)
-> ((Integer, Integer), (Integer, Integer))
go (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) (Integer, Integer)
d (Integer, Integer)
s

    -- x1 is the answer and x2 is one point further on; together with the
    -- point they give the y that the ladder does not carry.
    recover :: ((Integer, Integer), (Integer, Integer)) -> MulResult
recover ((Integer
x1, Integer
z1), (Integer
x2, Integer
z2))
        | Integer
z1 Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
0 = MulResult
MulInfinity -- the multiple is at infinity
        | Integer
z2 Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
0 = Integer -> Integer -> MulResult
MulPoint Integer
x (Integer
x Integer -> Integer -> Integer
.+. Integer
y) -- the one after it is, so this is -P
        | Bool
otherwise = case (Integer -> Integer -> Integer -> Maybe Integer
divF2m Integer
fx Integer
x1 Integer
z1, Integer -> Integer -> Integer -> Maybe Integer
divF2m Integer
fx Integer
x2 Integer
z2) of
            (Just Integer
xa, Just Integer
xb) ->
                let u :: Integer
u = Integer
xa Integer -> Integer -> Integer
.+. Integer
x
                    v :: Integer
v = Integer
xb Integer -> Integer -> Integer
.+. Integer
x
                    inner :: Integer
inner = Integer -> Integer -> Integer
mul Integer
u Integer
v Integer -> Integer -> Integer
.+. Integer -> Integer
sqr Integer
x Integer -> Integer -> Integer
.+. Integer
y
                 in case Integer -> Integer -> Integer -> Maybe Integer
divF2m Integer
fx (Integer -> Integer -> Integer
mul Integer
u Integer
inner) Integer
x of
                        Just Integer
w -> Integer -> Integer -> MulResult
MulPoint Integer
xa (Integer
w Integer -> Integer -> Integer
.+. Integer
y)
                        Maybe Integer
Nothing -> MulResult
MulUnsupported
            (Maybe Integer, Maybe Integer)
_ -> MulResult
MulUnsupported

-- | Multiply a point by a scalar on a curve over a binary field, in C.
--
-- The ladder is the same one 'binaryCurveMul' walks, but the field arithmetic
-- is carry-less multiplication -- the processor's where it has it, and four
-- interleaved groups of bits where it does not -- rather than 'Integer'
-- shifts and exclusive ors, and nothing in it branches on the scalar or
-- indexes memory with it.
--
-- The point has to be on the curve and to have an x, and the scalar is walked
-- over the whole of the width asked for, as for 'primeCurveMul'.
binaryCurveC
    :: Integer
    -- ^ the polynomial the field is over
    -> Integer
    -- ^ b
    -> Int
    -- ^ how many bytes of scalar to walk
    -> Integer
    -- ^ the scalar
    -> Integer
    -- ^ the point's x
    -> Integer
    -- ^ the point's y
    -> MulResult
binaryCurveC :: Integer
-> Integer -> Int -> Integer -> Integer -> Integer -> MulResult
binaryCurveC Integer
fx Integer
b Int
klen Integer
k Integer
px Integer
py
    | Integer
fx Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
1 Bool -> Bool -> Bool
|| Int
klen Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 Bool -> Bool -> Bool
|| Integer
k Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
0 Bool -> Bool -> Bool
|| Integer
px Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
0 Bool -> Bool -> Bool
|| Int
flen Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 = MulResult
MulUnsupported
    | Bool
otherwise = IO MulResult -> MulResult
forall a. IO a -> a
unsafeDoIO (IO MulResult -> MulResult) -> IO MulResult -> MulResult
forall a b. (a -> b) -> a -> b
$
        Int -> (Ptr Word8 -> IO MulResult) -> IO MulResult
forall a b. Int -> (Ptr a -> IO b) -> IO b
allocaBytes ([Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [Int]
widths) ((Ptr Word8 -> IO MulResult) -> IO MulResult)
-> (Ptr Word8 -> IO MulResult) -> IO MulResult
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
base -> case (Ptr Word8 -> Int -> Ptr Word8)
-> Ptr Word8 -> [Int] -> [Ptr Word8]
forall b a. (b -> a -> b) -> b -> [a] -> [b]
scanl Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
plusPtr Ptr Word8
base [Int]
widths of
            (Ptr Word8
outx : Ptr Word8
outy : Ptr Word8
cx : Ptr Word8
cy : Ptr Word8
cb : Ptr Word8
cf : Ptr Word8
ck : [Ptr Word8]
_) -> do
                Int
_ <- Integer -> Ptr Word8 -> Int -> IO Int
Internal.i2ospOf Integer
px Ptr Word8
cx Int
flen
                Int
_ <- Integer -> Ptr Word8 -> Int -> IO Int
Internal.i2ospOf Integer
py Ptr Word8
cy Int
flen
                Int
_ <- Integer -> Ptr Word8 -> Int -> IO Int
Internal.i2ospOf Integer
b Ptr Word8
cb Int
flen
                Int
_ <- Integer -> Ptr Word8 -> Int -> IO Int
Internal.i2ospOf Integer
fx Ptr Word8
cf Int
fxlen
                Int
_ <- Integer -> Ptr Word8 -> Int -> IO Int
Internal.i2ospOf Integer
k Ptr Word8
ck Int
klen
                CInt
r <-
                    Ptr Word8
-> Ptr Word8
-> Ptr Word8
-> Ptr Word8
-> Ptr Word8
-> Word32
-> Ptr Word8
-> Word32
-> Ptr Word8
-> Word32
-> IO CInt
c_f2m_mul
                        Ptr Word8
outx
                        Ptr Word8
outy
                        Ptr Word8
cx
                        Ptr Word8
cy
                        Ptr Word8
ck
                        (Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
klen)
                        Ptr Word8
cb
                        (Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
flen)
                        Ptr Word8
cf
                        (Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
fxlen)
                Integer -> Ptr Word8 -> Int -> IO Int
Internal.i2ospOf Integer
0 Ptr Word8
ck Int
klen IO Int -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                case CInt
r of
                    CInt
0 -> do
                        !Integer
x <- Ptr Word8 -> Int -> IO Integer
Internal.os2ip Ptr Word8
outx Int
flen
                        !Integer
y <- Ptr Word8 -> Int -> IO Integer
Internal.os2ip Ptr Word8
outy Int
flen
                        MulResult -> IO MulResult
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer -> Integer -> MulResult
MulPoint Integer
x Integer
y)
                    CInt
1 -> MulResult -> IO MulResult
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return MulResult
MulInfinity
                    CInt
_ -> MulResult -> IO MulResult
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return MulResult
MulUnsupported
            [Ptr Word8]
_ -> MulResult -> IO MulResult
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return MulResult
MulUnsupported -- there are seven, but say so anyway
  where
    -- the field is the degree of the polynomial, which is one under its width
    !flen :: Int
flen = (Integer -> Int
numBits Integer
fx Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
7) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
8
    !fxlen :: Int
fxlen = Integer -> Int
numBytes Integer
fx
    widths :: [Int]
widths = [Int
flen, Int
flen, Int
flen, Int
flen, Int
flen, Int
fxlen, Int
klen]

foreign import ccall safe "crypton_f2m_mul"
    c_f2m_mul
        :: Ptr Word8
        -> Ptr Word8
        -> Ptr Word8
        -> Ptr Word8
        -> Ptr Word8
        -> Word32
        -> Ptr Word8
        -> Word32
        -> Ptr Word8
        -> Word32
        -> IO CInt