{-# LANGUAGE BangPatterns #-}

-- |
-- Module      : Crypto.Number.ModArithmetic.Pub
-- License     : BSD-style
-- Stability   : experimental
-- Portability : Good
--
-- The C exponentiation for an exponent that is not a secret, and the R^2
-- it keeps per modulus.  Internal: 'expPub' is behind 'expFast', and
-- 'expPubBytes' behind RSA's public-key operation.
module Crypto.Number.ModArithmetic.Pub (
    expPub,
    expPubBytes,
) where

import Crypto.Internal.ByteArray (
    ByteArray,
    ByteArrayAccess,
    Bytes,
    allocRet,
    withByteArray,
 )
import qualified Crypto.Internal.ByteArray as B
import Crypto.Internal.Compat (unsafeDoIO)
import Crypto.Number.Basic
import qualified Crypto.Number.Serialize.Internal as Internal
import Data.IORef (IORef, atomicModifyIORef', newIORef)
import Data.Word (Word32, Word8)
import Foreign.C.Types (CInt (..))
import Foreign.Marshal.Alloc (allocaBytes)
import Foreign.Ptr (Ptr, plusPtr)
import System.IO.Unsafe (unsafePerformIO)

-- | The windowless exponentiation in C, for an exponent that is not a
--   secret.  'Nothing' when the C declines, which it does on every machine
--   where what the caller already has is faster -- so this is an
--   optimisation and never the only path.  The base has to be reduced and
--   the exponent positive, which the caller sees to.
expPub :: Integer -> Integer -> Integer -> Maybe Integer
expPub :: Integer -> Integer -> Integer -> Maybe Integer
expPub Integer
b Integer
e Integer
m = IO (Maybe Integer) -> Maybe Integer
forall a. IO a -> a
unsafeDoIO (IO (Maybe Integer) -> Maybe Integer)
-> IO (Maybe Integer) -> Maybe Integer
forall a b. (a -> b) -> a -> b
$ do
    Maybe (Bytes, Bytes)
known <- Integer -> IO (Maybe (Bytes, Bytes))
r2For Integer
m
    case Maybe (Bytes, Bytes)
known of
        Maybe (Bytes, Bytes)
Nothing -> Maybe Integer -> IO (Maybe Integer)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Integer
forall a. Maybe a
Nothing
        Just (Bytes
r2, Bytes
modu) ->
            Int -> (Ptr Word8 -> IO (Maybe Integer)) -> IO (Maybe Integer)
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 Integer)) -> IO (Maybe Integer))
-> (Ptr Word8 -> IO (Maybe Integer)) -> IO (Maybe Integer)
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
start -> 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
start [Int]
widths of
                (Ptr Word8
out : Ptr Word8
base : Ptr Word8
expo : [Ptr Word8]
_) -> do
                    Int
_ <- Integer -> Ptr Word8 -> Int -> IO Int
Internal.i2ospOf Integer
b Ptr Word8
base Int
mLen
                    Int
_ <- Integer -> Ptr Word8 -> Int -> IO Int
Internal.i2ospOf Integer
e Ptr Word8
expo Int
eLen
                    CInt
r <- Bytes -> (Ptr Word8 -> IO CInt) -> IO CInt
forall ba p a. ByteArrayAccess ba => ba -> (Ptr p -> IO a) -> IO a
forall p a. Bytes -> (Ptr p -> IO a) -> IO a
withByteArray Bytes
modu ((Ptr Word8 -> IO CInt) -> IO CInt)
-> (Ptr Word8 -> IO CInt) -> IO CInt
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
pm -> Bytes -> (Ptr Word8 -> IO CInt) -> IO CInt
forall ba p a. ByteArrayAccess ba => ba -> (Ptr p -> IO a) -> IO a
forall p a. Bytes -> (Ptr p -> IO a) -> IO a
withByteArray Bytes
r2 ((Ptr Word8 -> IO CInt) -> IO CInt)
-> (Ptr Word8 -> IO CInt) -> IO CInt
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
pr2 ->
                        Ptr Word8
-> Ptr Word8
-> Word32
-> Ptr Word8
-> Word32
-> Ptr Word8
-> Word32
-> Ptr Word8
-> IO CInt
c_powm_pub_r2
                            Ptr Word8
out
                            Ptr Word8
base
                            (Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
mLen)
                            Ptr Word8
expo
                            (Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
eLen)
                            Ptr Word8
pm
                            (Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
mLen)
                            Ptr Word8
pr2
                    if CInt
r CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
== CInt
0
                        then do
                            !Integer
v <- Ptr Word8 -> Int -> IO Integer
Internal.os2ip Ptr Word8
out Int
mLen
                            Maybe Integer -> IO (Maybe Integer)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
v)
                        else Maybe Integer -> IO (Maybe Integer)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Integer
forall a. Maybe a
Nothing
                [Ptr Word8]
_ -> Maybe Integer -> IO (Maybe Integer)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Integer
forall a. Maybe a
Nothing
  where
    !mLen :: Int
mLen = Integer -> Int
numBytes Integer
m
    !eLen :: Int
eLen = Integer -> Int
numBytes Integer
e
    widths :: [Int]
widths = [Int
mLen, Int
mLen, Int
eLen]

-- | The same with the base and the answer as big-endian bytes, as long as
--   the modulus: what RSA verification has in hand, so neither goes through
--   an 'Integer'.  'Nothing' also when the base is not below the modulus.
expPubBytes
    :: (ByteArrayAccess bi, ByteArray bo) => Integer -> Integer -> bi -> Maybe bo
expPubBytes :: forall bi bo.
(ByteArrayAccess bi, ByteArray bo) =>
Integer -> Integer -> bi -> Maybe bo
expPubBytes Integer
e Integer
m bi
b
    | Integer
e Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
0 Bool -> Bool -> Bool
|| Integer
m Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
1 Bool -> Bool -> Bool
|| Integer -> Bool
forall a. Integral a => a -> Bool
even Integer
m Bool -> Bool -> Bool
|| bi -> Int
forall ba. ByteArrayAccess ba => ba -> Int
B.length bi
b Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
mLen = Maybe bo
forall a. Maybe a
Nothing
    | Bool
otherwise = IO (Maybe bo) -> Maybe bo
forall a. IO a -> a
unsafeDoIO (IO (Maybe bo) -> Maybe bo) -> IO (Maybe bo) -> Maybe bo
forall a b. (a -> b) -> a -> b
$ do
        Maybe (Bytes, Bytes)
known <- Integer -> IO (Maybe (Bytes, Bytes))
r2For Integer
m
        case Maybe (Bytes, Bytes)
known of
            Maybe (Bytes, Bytes)
Nothing -> Maybe bo -> IO (Maybe bo)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe bo
forall a. Maybe a
Nothing
            Just (Bytes
r2, Bytes
modu)
                | Bool -> Bool
not (bi -> Bytes -> Bool
forall a b.
(ByteArrayAccess a, ByteArrayAccess b) =>
a -> b -> Bool
below bi
b Bytes
modu) -> Maybe bo -> IO (Maybe bo)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe bo
forall a. Maybe a
Nothing
                | Bool
otherwise -> Int -> (Ptr Word8 -> IO (Maybe bo)) -> IO (Maybe bo)
forall a b. Int -> (Ptr a -> IO b) -> IO b
allocaBytes Int
eLen ((Ptr Word8 -> IO (Maybe bo)) -> IO (Maybe bo))
-> (Ptr Word8 -> IO (Maybe bo)) -> IO (Maybe bo)
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
expo -> do
                    Int
_ <- Integer -> Ptr Word8 -> Int -> IO Int
Internal.i2ospOf Integer
e Ptr Word8
expo Int
eLen
                    (CInt
r, bo
out) <- Int -> (Ptr Word8 -> IO CInt) -> IO (CInt, bo)
forall ba p a. ByteArray ba => Int -> (Ptr p -> IO a) -> IO (a, ba)
forall p a. Int -> (Ptr p -> IO a) -> IO (a, bo)
allocRet Int
mLen ((Ptr Word8 -> IO CInt) -> IO (CInt, bo))
-> (Ptr Word8 -> IO CInt) -> IO (CInt, bo)
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
pout ->
                        bi -> (Ptr Word8 -> IO CInt) -> IO CInt
forall ba p a. ByteArrayAccess ba => ba -> (Ptr p -> IO a) -> IO a
forall p a. bi -> (Ptr p -> IO a) -> IO a
withByteArray bi
b ((Ptr Word8 -> IO CInt) -> IO CInt)
-> (Ptr Word8 -> IO CInt) -> IO CInt
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
pb -> Bytes -> (Ptr Word8 -> IO CInt) -> IO CInt
forall ba p a. ByteArrayAccess ba => ba -> (Ptr p -> IO a) -> IO a
forall p a. Bytes -> (Ptr p -> IO a) -> IO a
withByteArray Bytes
modu ((Ptr Word8 -> IO CInt) -> IO CInt)
-> (Ptr Word8 -> IO CInt) -> IO CInt
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
pm ->
                            Bytes -> (Ptr Word8 -> IO CInt) -> IO CInt
forall ba p a. ByteArrayAccess ba => ba -> (Ptr p -> IO a) -> IO a
forall p a. Bytes -> (Ptr p -> IO a) -> IO a
withByteArray Bytes
r2 ((Ptr Word8 -> IO CInt) -> IO CInt)
-> (Ptr Word8 -> IO CInt) -> IO CInt
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
pr2 ->
                                Ptr Word8
-> Ptr Word8
-> Word32
-> Ptr Word8
-> Word32
-> Ptr Word8
-> Word32
-> Ptr Word8
-> IO CInt
c_powm_pub_r2
                                    Ptr Word8
pout
                                    Ptr Word8
pb
                                    (Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
mLen)
                                    Ptr Word8
expo
                                    (Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
eLen)
                                    Ptr Word8
pm
                                    (Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
mLen)
                                    Ptr Word8
pr2
                    Maybe bo -> IO (Maybe bo)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (if CInt
r CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
== CInt
0 then bo -> Maybe bo
forall a. a -> Maybe a
Just bo
out else Maybe bo
forall a. Maybe a
Nothing)
  where
    !mLen :: Int
mLen = Integer -> Int
numBytes Integer
m
    !eLen :: Int
eLen = Integer -> Int
numBytes Integer
e

-- big-endian numbers of one length: the first byte that differs decides
below :: (ByteArrayAccess a, ByteArrayAccess b) => a -> b -> Bool
below :: forall a b.
(ByteArrayAccess a, ByteArrayAccess b) =>
a -> b -> Bool
below a
x b
y = Int -> Bool
go Int
0
  where
    n :: Int
n = a -> Int
forall ba. ByteArrayAccess ba => ba -> Int
B.length a
x
    go :: Int -> Bool
go Int
i
        | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
n = Bool
False
        | Bool
otherwise = case Word8 -> Word8 -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (a -> Int -> Word8
forall a. ByteArrayAccess a => a -> Int -> Word8
B.index a
x Int
i) (b -> Int -> Word8
forall a. ByteArrayAccess a => a -> Int -> Word8
B.index b
y Int
i) of
            Ordering
EQ -> Int -> Bool
go (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
            Ordering
o -> Ordering
o Ordering -> Ordering -> Bool
forall a. Eq a => a -> a -> Bool
== Ordering
LT

-- | R^2 mod m for the public path, and m in bytes, kept for the last few
-- moduli, since a program verifies under the same keys again and again.
-- 'Nothing' is kept too: it means the C declines this modulus, which is
-- then not asked again.
r2For :: Integer -> IO (Maybe (Bytes, Bytes))
r2For :: Integer -> IO (Maybe (Bytes, Bytes))
r2For Integer
m = do
    Maybe (Maybe (Bytes, Bytes))
found <- IORef [(Integer, Maybe (Bytes, Bytes))]
-> ([(Integer, Maybe (Bytes, Bytes))]
    -> ([(Integer, Maybe (Bytes, Bytes))],
        Maybe (Maybe (Bytes, Bytes))))
-> IO (Maybe (Maybe (Bytes, Bytes)))
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef [(Integer, Maybe (Bytes, Bytes))]
r2Table (([(Integer, Maybe (Bytes, Bytes))]
  -> ([(Integer, Maybe (Bytes, Bytes))],
      Maybe (Maybe (Bytes, Bytes))))
 -> IO (Maybe (Maybe (Bytes, Bytes))))
-> ([(Integer, Maybe (Bytes, Bytes))]
    -> ([(Integer, Maybe (Bytes, Bytes))],
        Maybe (Maybe (Bytes, Bytes))))
-> IO (Maybe (Maybe (Bytes, Bytes)))
forall a b. (a -> b) -> a -> b
$ \[(Integer, Maybe (Bytes, Bytes))]
ks -> case ((Integer, Maybe (Bytes, Bytes)) -> Bool)
-> [(Integer, Maybe (Bytes, Bytes))]
-> ([(Integer, Maybe (Bytes, Bytes))],
    [(Integer, Maybe (Bytes, Bytes))])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break ((Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
m) (Integer -> Bool)
-> ((Integer, Maybe (Bytes, Bytes)) -> Integer)
-> (Integer, Maybe (Bytes, Bytes))
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Integer, Maybe (Bytes, Bytes)) -> Integer
forall a b. (a, b) -> a
fst) [(Integer, Maybe (Bytes, Bytes))]
ks of
        ([(Integer, Maybe (Bytes, Bytes))]
before, (Integer, Maybe (Bytes, Bytes))
hit : [(Integer, Maybe (Bytes, Bytes))]
after) -> ((Integer, Maybe (Bytes, Bytes))
hit (Integer, Maybe (Bytes, Bytes))
-> [(Integer, Maybe (Bytes, Bytes))]
-> [(Integer, Maybe (Bytes, Bytes))]
forall a. a -> [a] -> [a]
: [(Integer, Maybe (Bytes, Bytes))]
before [(Integer, Maybe (Bytes, Bytes))]
-> [(Integer, Maybe (Bytes, Bytes))]
-> [(Integer, Maybe (Bytes, Bytes))]
forall a. [a] -> [a] -> [a]
++ [(Integer, Maybe (Bytes, Bytes))]
after, Maybe (Bytes, Bytes) -> Maybe (Maybe (Bytes, Bytes))
forall a. a -> Maybe a
Just ((Integer, Maybe (Bytes, Bytes)) -> Maybe (Bytes, Bytes)
forall a b. (a, b) -> b
snd (Integer, Maybe (Bytes, Bytes))
hit))
        ([(Integer, Maybe (Bytes, Bytes))],
 [(Integer, Maybe (Bytes, Bytes))])
_ -> ([(Integer, Maybe (Bytes, Bytes))]
ks, Maybe (Maybe (Bytes, Bytes))
forall a. Maybe a
Nothing)
    case Maybe (Maybe (Bytes, Bytes))
found of
        Just Maybe (Bytes, Bytes)
r2 -> Maybe (Bytes, Bytes) -> IO (Maybe (Bytes, Bytes))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Bytes, Bytes)
r2
        Maybe (Maybe (Bytes, Bytes))
Nothing -> do
            let mLen :: Int
mLen = Integer -> Int
numBytes Integer
m
            (Maybe Bytes
r2, Bytes
modu) <- Int -> (Ptr Word8 -> IO (Maybe Bytes)) -> IO (Maybe Bytes, Bytes)
forall ba p a. ByteArray ba => Int -> (Ptr p -> IO a) -> IO (a, ba)
forall p a. Int -> (Ptr p -> IO a) -> IO (a, Bytes)
allocRet Int
mLen ((Ptr Word8 -> IO (Maybe Bytes)) -> IO (Maybe Bytes, Bytes))
-> (Ptr Word8 -> IO (Maybe Bytes)) -> IO (Maybe Bytes, Bytes)
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
modu -> do
                Int
_ <- Integer -> Ptr Word8 -> Int -> IO Int
Internal.i2ospOf Integer
m Ptr Word8
modu Int
mLen
                (CInt
r, Bytes
out) <- Int -> (Ptr Word8 -> IO CInt) -> IO (CInt, Bytes)
forall ba p a. ByteArray ba => Int -> (Ptr p -> IO a) -> IO (a, ba)
forall p a. Int -> (Ptr p -> IO a) -> IO (a, Bytes)
allocRet Int
mLen ((Ptr Word8 -> IO CInt) -> IO (CInt, Bytes))
-> (Ptr Word8 -> IO CInt) -> IO (CInt, Bytes)
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
pout -> Ptr Word8 -> Ptr Word8 -> Word32 -> IO CInt
c_powm_r2 Ptr Word8
pout Ptr Word8
modu (Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
mLen)
                Maybe Bytes -> IO (Maybe Bytes)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (if CInt
r CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
== CInt
0 then Bytes -> Maybe Bytes
forall a. a -> Maybe a
Just Bytes
out else Maybe Bytes
forall a. Maybe a
Nothing)
            let kept :: Maybe (Bytes, Bytes)
kept = (Bytes -> (Bytes, Bytes)) -> Maybe Bytes -> Maybe (Bytes, Bytes)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Bytes
x -> (Bytes
x, Bytes
modu)) Maybe Bytes
r2
            IORef [(Integer, Maybe (Bytes, Bytes))]
-> ([(Integer, Maybe (Bytes, Bytes))]
    -> ([(Integer, Maybe (Bytes, Bytes))], ()))
-> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef [(Integer, Maybe (Bytes, Bytes))]
r2Table (([(Integer, Maybe (Bytes, Bytes))]
  -> ([(Integer, Maybe (Bytes, Bytes))], ()))
 -> IO ())
-> ([(Integer, Maybe (Bytes, Bytes))]
    -> ([(Integer, Maybe (Bytes, Bytes))], ()))
-> IO ()
forall a b. (a -> b) -> a -> b
$ \[(Integer, Maybe (Bytes, Bytes))]
ks -> (Int
-> [(Integer, Maybe (Bytes, Bytes))]
-> [(Integer, Maybe (Bytes, Bytes))]
forall a. Int -> [a] -> [a]
take Int
r2TableSize ((Integer
m, Maybe (Bytes, Bytes)
kept) (Integer, Maybe (Bytes, Bytes))
-> [(Integer, Maybe (Bytes, Bytes))]
-> [(Integer, Maybe (Bytes, Bytes))]
forall a. a -> [a] -> [a]
: [(Integer, Maybe (Bytes, Bytes))]
ks), ())
            Maybe (Bytes, Bytes) -> IO (Maybe (Bytes, Bytes))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Bytes, Bytes)
kept

r2TableSize :: Int
r2TableSize :: Int
r2TableSize = Int
8

r2Table :: IORef [(Integer, Maybe (Bytes, Bytes))]
r2Table :: IORef [(Integer, Maybe (Bytes, Bytes))]
r2Table = IO (IORef [(Integer, Maybe (Bytes, Bytes))])
-> IORef [(Integer, Maybe (Bytes, Bytes))]
forall a. IO a -> a
unsafePerformIO ([(Integer, Maybe (Bytes, Bytes))]
-> IO (IORef [(Integer, Maybe (Bytes, Bytes))])
forall a. a -> IO (IORef a)
newIORef [])
{-# NOINLINE r2Table #-}

-- safe, as the secure one is: the call is tens of microseconds at RSA
-- sizes, and the hundred nanoseconds this costs over an unsafe call is
-- nothing beside holding a capability for that long in a server
foreign import ccall safe "crypton_powm_pub_r2"
    c_powm_pub_r2
        :: Ptr Word8
        -> Ptr Word8
        -> Word32
        -> Ptr Word8
        -> Word32
        -> Ptr Word8
        -> Word32
        -> Ptr Word8
        -> IO CInt

foreign import ccall unsafe "crypton_powm_r2"
    c_powm_r2 :: Ptr Word8 -> Ptr Word8 -> Word32 -> IO CInt