-- |
-- Module      : Crypto.Saltine.Core.Sign
-- Copyright   : (c) Joseph Abrahamson 2013
-- License     : MIT
--
-- Maintainer  : me@jspha.com
-- Stability   : experimental
-- Portability : non-portable
--
-- Signatures: "Crypto.Saltine.Core.Sign"
--
-- The 'newKeypair' function randomly generates a secret key and a
-- corresponding public key. The 'sign' function signs a message
-- 'ByteString' using the signer's secret key and returns the
-- resulting signed message. The 'signOpen' function verifies the
-- signature in a signed message using the signer's public key then
-- returns the message without its signature.
--
-- "Crypto.Saltine.Core.Sign" is an EdDSA signature using
-- elliptic-curve Curve25519 (see: <http://ed25519.cr.yp.to/>). See
-- also, \"Daniel J. Bernstein, Niels Duif, Tanja Lange, Peter
-- Schwabe, Bo-Yin Yang. High-speed high-security signatures. Journal
-- of Cryptographic Engineering 2 (2012), 77–89.\"
-- <http://ed25519.cr.yp.to/ed25519-20110926.pdf>.
--
-- This is current information as of 2013 June 6.

module Crypto.Saltine.Core.Sign (
  -- * Documentation
  SecretKey, PublicKey, Keypair(..), Signature,
  newKeypair,
  sign, signOpen,
  signDetached, signVerifyDetached,

  -- * Advanced: Ed25519 to Curve25519
  --
  -- | Ed25519 keys can be converted to X25519 keys, so that the same
  -- key pair can be used both for authenticated encryption
  -- ("Crypto.Saltine.Core.Box") and for signatures
  -- ("Crypto.Saltine.Core.Sign").
  signPublicKeyToScalarMult, signSecretKeyToScalarMult
  ) where

import Crypto.Saltine.Internal.Sign
            ( c_sign_keypair
            , c_sign
            , c_sign_open
            , c_sign_detached
            , c_sign_verify_detached
            , c_sign_ed25519_pk_to_curve25519
            , c_sign_ed25519_sk_to_curve25519
            , SecretKey(..)
            , PublicKey(..)
            , Keypair(..)
            , Signature(..)
            )
import Crypto.Saltine.Internal.Util as U
import Data.ByteString              (ByteString)
import Foreign.Marshal.Alloc
import Foreign.Storable
import System.IO.Unsafe

import qualified Crypto.Saltine.Internal.Sign as Bytes
import qualified Crypto.Saltine.Internal.ScalarMult as SM
import qualified Data.ByteString              as S

-- | Creates a random key of the correct size for 'sign' and
-- 'signOpen' of form @(secretKey, publicKey)@.
newKeypair :: IO Keypair
newKeypair :: IO Keypair
newKeypair = do
  -- This is a little bizarre and a likely source of errors.
  -- _err ought to always be 0.
  ((_err, sk), pk) <- Int
-> (Ptr CChar -> IO (CInt, ByteString))
-> IO ((CInt, ByteString), ByteString)
forall b. Int -> (Ptr CChar -> IO b) -> IO (b, ByteString)
buildUnsafeByteString' Int
Bytes.sign_publickeybytes ((Ptr CChar -> IO (CInt, ByteString))
 -> IO ((CInt, ByteString), ByteString))
-> (Ptr CChar -> IO (CInt, ByteString))
-> IO ((CInt, ByteString), ByteString)
forall a b. (a -> b) -> a -> b
$ \Ptr CChar
pkbuf ->
    Int -> (Ptr CChar -> IO CInt) -> IO (CInt, ByteString)
forall b. Int -> (Ptr CChar -> IO b) -> IO (b, ByteString)
buildUnsafeByteString' Int
Bytes.sign_secretkeybytes ((Ptr CChar -> IO CInt) -> IO (CInt, ByteString))
-> (Ptr CChar -> IO CInt) -> IO (CInt, ByteString)
forall a b. (a -> b) -> a -> b
$ \Ptr CChar
skbuf ->
      Ptr CChar -> Ptr CChar -> IO CInt
c_sign_keypair Ptr CChar
pkbuf Ptr CChar
skbuf
  return $ Keypair (SK sk) (PK pk)

-- | Augments a message with a signature forming a \"signed
-- message\".
sign :: SecretKey
     -> ByteString
     -- ^ Message
     -> ByteString
     -- ^ Signed message
sign :: SecretKey -> ByteString -> ByteString
sign (SK ByteString
k) ByteString
m = IO ByteString -> ByteString
forall a. IO a -> a
unsafePerformIO (IO ByteString -> ByteString) -> IO ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$
  (Ptr CULLong -> IO ByteString) -> IO ByteString
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr CULLong -> IO ByteString) -> IO ByteString)
-> (Ptr CULLong -> IO ByteString) -> IO ByteString
forall a b. (a -> b) -> a -> b
$ \Ptr CULLong
psmlen -> do
    (_err, sm) <- Int -> (Ptr CChar -> IO CInt) -> IO (CInt, ByteString)
forall b. Int -> (Ptr CChar -> IO b) -> IO (b, ByteString)
buildUnsafeByteString' (Int
len Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
Bytes.sign_bytes) ((Ptr CChar -> IO CInt) -> IO (CInt, ByteString))
-> (Ptr CChar -> IO CInt) -> IO (CInt, ByteString)
forall a b. (a -> b) -> a -> b
$ \Ptr CChar
psmbuf ->
      [ByteString] -> ([CStringLen] -> IO CInt) -> IO CInt
forall b. [ByteString] -> ([CStringLen] -> IO b) -> IO b
constByteStrings [ByteString
k, ByteString
m] (([CStringLen] -> IO CInt) -> IO CInt)
-> ([CStringLen] -> IO CInt) -> IO CInt
forall a b. (a -> b) -> a -> b
$ \[(Ptr CChar
pk, Int
_), (Ptr CChar
pm, Int
_)] ->
        Ptr CChar
-> Ptr CULLong -> Ptr CChar -> CULLong -> Ptr CChar -> IO CInt
c_sign Ptr CChar
psmbuf Ptr CULLong
psmlen Ptr CChar
pm (Int -> CULLong
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len) Ptr CChar
pk
    smlen <- peek psmlen
    return $ S.take (fromIntegral smlen) sm
  where len :: Int
len = ByteString -> Int
S.length ByteString
m

-- | Checks a \"signed message\" returning 'Just' the original message
-- iff the signature was generated using the 'SecretKey' corresponding
-- to the given 'PublicKey'. Returns 'Nothing' otherwise.
signOpen :: PublicKey
         -> ByteString
         -- ^ Signed message
         -> Maybe ByteString
         -- ^ Maybe the restored message
signOpen :: PublicKey -> ByteString -> Maybe ByteString
signOpen (PK ByteString
k) ByteString
sm = IO (Maybe ByteString) -> Maybe ByteString
forall a. IO a -> a
unsafePerformIO (IO (Maybe ByteString) -> Maybe ByteString)
-> IO (Maybe ByteString) -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$
  (Ptr CULLong -> IO (Maybe ByteString)) -> IO (Maybe ByteString)
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr CULLong -> IO (Maybe ByteString)) -> IO (Maybe ByteString))
-> (Ptr CULLong -> IO (Maybe ByteString)) -> IO (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$ \Ptr CULLong
pmlen -> do
    (err, m) <- Int -> (Ptr CChar -> IO CInt) -> IO (CInt, ByteString)
forall b. Int -> (Ptr CChar -> IO b) -> IO (b, ByteString)
buildUnsafeByteString' Int
smlen ((Ptr CChar -> IO CInt) -> IO (CInt, ByteString))
-> (Ptr CChar -> IO CInt) -> IO (CInt, ByteString)
forall a b. (a -> b) -> a -> b
$ \Ptr CChar
pmbuf ->
      [ByteString] -> ([CStringLen] -> IO CInt) -> IO CInt
forall b. [ByteString] -> ([CStringLen] -> IO b) -> IO b
constByteStrings [ByteString
k, ByteString
sm] (([CStringLen] -> IO CInt) -> IO CInt)
-> ([CStringLen] -> IO CInt) -> IO CInt
forall a b. (a -> b) -> a -> b
$ \[(Ptr CChar
pk, Int
_), (Ptr CChar
psm, Int
_)] ->
        Ptr CChar
-> Ptr CULLong -> Ptr CChar -> CULLong -> Ptr CChar -> IO CInt
c_sign_open Ptr CChar
pmbuf Ptr CULLong
pmlen Ptr CChar
psm (Int -> CULLong
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
smlen) Ptr CChar
pk
    mlen <- peek pmlen
    case err of
      CInt
0 -> Maybe ByteString -> IO (Maybe ByteString)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ByteString -> IO (Maybe ByteString))
-> Maybe ByteString -> IO (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString) -> ByteString -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
S.take (CULLong -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral CULLong
mlen) ByteString
m
      CInt
_ -> Maybe ByteString -> IO (Maybe ByteString)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return   Maybe ByteString
forall a. Maybe a
Nothing
  where smlen :: Int
smlen = ByteString -> Int
S.length ByteString
sm

-- | Returns just the signature for a message using a SecretKey.
signDetached :: SecretKey
             -> ByteString
             -- ^ Message
             -> Signature
             -- ^ Signature
signDetached :: SecretKey -> ByteString -> Signature
signDetached (SK ByteString
k) ByteString
m = IO Signature -> Signature
forall a. IO a -> a
unsafePerformIO (IO Signature -> Signature) -> IO Signature -> Signature
forall a b. (a -> b) -> a -> b
$
    (Ptr CULLong -> IO Signature) -> IO Signature
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr CULLong -> IO Signature) -> IO Signature)
-> (Ptr CULLong -> IO Signature) -> IO Signature
forall a b. (a -> b) -> a -> b
$ \Ptr CULLong
psmlen -> do
        (_err, sm) <- Int -> (Ptr CChar -> IO CInt) -> IO (CInt, ByteString)
forall b. Int -> (Ptr CChar -> IO b) -> IO (b, ByteString)
buildUnsafeByteString' Int
Bytes.sign_bytes ((Ptr CChar -> IO CInt) -> IO (CInt, ByteString))
-> (Ptr CChar -> IO CInt) -> IO (CInt, ByteString)
forall a b. (a -> b) -> a -> b
$ \Ptr CChar
sigbuf ->
            [ByteString] -> ([CStringLen] -> IO CInt) -> IO CInt
forall b. [ByteString] -> ([CStringLen] -> IO b) -> IO b
constByteStrings [ByteString
k, ByteString
m] (([CStringLen] -> IO CInt) -> IO CInt)
-> ([CStringLen] -> IO CInt) -> IO CInt
forall a b. (a -> b) -> a -> b
$ \[(Ptr CChar
pk, Int
_), (Ptr CChar
pm, Int
_)] ->
                Ptr CChar
-> Ptr CULLong -> Ptr CChar -> CULLong -> Ptr CChar -> IO CInt
c_sign_detached Ptr CChar
sigbuf Ptr CULLong
psmlen Ptr CChar
pm (Int -> CULLong
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len) Ptr CChar
pk
        smlen <- peek psmlen
        return $ Signature $ S.take (fromIntegral smlen) sm
  where len :: Int
len = ByteString -> Int
S.length ByteString
m

-- | Returns @True@ if the signature is valid for the given public key and
-- message.
signVerifyDetached :: PublicKey
                   -> Signature
                   -- ^ Signature
                   -> ByteString
                   -- ^ Message (not signed)
                   -> Bool
signVerifyDetached :: PublicKey -> Signature -> ByteString -> Bool
signVerifyDetached (PK ByteString
k) (Signature ByteString
sig) ByteString
sm = IO Bool -> Bool
forall a. IO a -> a
unsafePerformIO (IO Bool -> Bool) -> IO Bool -> Bool
forall a b. (a -> b) -> a -> b
$
    [ByteString] -> ([CStringLen] -> IO Bool) -> IO Bool
forall b. [ByteString] -> ([CStringLen] -> IO b) -> IO b
constByteStrings [ByteString
k, ByteString
sig, ByteString
sm] (([CStringLen] -> IO Bool) -> IO Bool)
-> ([CStringLen] -> IO Bool) -> IO Bool
forall a b. (a -> b) -> a -> b
$ \[(Ptr CChar
pk, Int
_), (Ptr CChar
psig, Int
_), (Ptr CChar
psm, Int
_)] -> do
        res <- Ptr CChar -> Ptr CChar -> CULLong -> Ptr CChar -> IO CInt
c_sign_verify_detached Ptr CChar
psig Ptr CChar
psm (Int -> CULLong
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len) Ptr CChar
pk
        return (res == 0)
  where len :: Int
len = ByteString -> Int
S.length ByteString
sm

-- | Converts an Ed25519 public key to an X25519 public key.
signPublicKeyToScalarMult :: PublicKey -> Maybe SM.GroupElement
signPublicKeyToScalarMult :: PublicKey -> Maybe GroupElement
signPublicKeyToScalarMult (PK ByteString
pk) = IO (Maybe GroupElement) -> Maybe GroupElement
forall a. IO a -> a
unsafePerformIO (IO (Maybe GroupElement) -> Maybe GroupElement)
-> IO (Maybe GroupElement) -> Maybe GroupElement
forall a b. (a -> b) -> a -> b
$ do
  (err,x) <- Int -> (Ptr CChar -> IO CInt) -> IO (CInt, ByteString)
forall b. Int -> (Ptr CChar -> IO b) -> IO (b, ByteString)
buildUnsafeByteString' Int
SM.scalarmult_bytes ((Ptr CChar -> IO CInt) -> IO (CInt, ByteString))
-> (Ptr CChar -> IO CInt) -> IO (CInt, ByteString)
forall a b. (a -> b) -> a -> b
$ \Ptr CChar
xbuf ->
    [ByteString] -> ([CStringLen] -> IO CInt) -> IO CInt
forall b. [ByteString] -> ([CStringLen] -> IO b) -> IO b
constByteStrings [ByteString
pk] (([CStringLen] -> IO CInt) -> IO CInt)
-> ([CStringLen] -> IO CInt) -> IO CInt
forall a b. (a -> b) -> a -> b
$ \[(Ptr CChar
edbuf,Int
_)] ->
      Ptr CChar -> Ptr CChar -> IO CInt
c_sign_ed25519_pk_to_curve25519 Ptr CChar
xbuf Ptr CChar
edbuf
  case err of
    CInt
0 -> Maybe GroupElement -> IO (Maybe GroupElement)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe GroupElement -> IO (Maybe GroupElement))
-> Maybe GroupElement -> IO (Maybe GroupElement)
forall a b. (a -> b) -> a -> b
$ GroupElement -> Maybe GroupElement
forall a. a -> Maybe a
Just (GroupElement -> Maybe GroupElement)
-> GroupElement -> Maybe GroupElement
forall a b. (a -> b) -> a -> b
$ ByteString -> GroupElement
SM.GE ByteString
x
    CInt
_ -> Maybe GroupElement -> IO (Maybe GroupElement)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return   Maybe GroupElement
forall a. Maybe a
Nothing

-- | Converts an Ed25519 secret key to an X25519 secret key.
signSecretKeyToScalarMult :: SecretKey -> Maybe SM.Scalar
signSecretKeyToScalarMult :: SecretKey -> Maybe Scalar
signSecretKeyToScalarMult (SK ByteString
sk) = IO (Maybe Scalar) -> Maybe Scalar
forall a. IO a -> a
unsafePerformIO (IO (Maybe Scalar) -> Maybe Scalar)
-> IO (Maybe Scalar) -> Maybe Scalar
forall a b. (a -> b) -> a -> b
$ do
  (err,x) <- Int -> (Ptr CChar -> IO CInt) -> IO (CInt, ByteString)
forall b. Int -> (Ptr CChar -> IO b) -> IO (b, ByteString)
buildUnsafeByteString' Int
SM.scalarmult_bytes ((Ptr CChar -> IO CInt) -> IO (CInt, ByteString))
-> (Ptr CChar -> IO CInt) -> IO (CInt, ByteString)
forall a b. (a -> b) -> a -> b
$ \Ptr CChar
xbuf ->
    [ByteString] -> ([CStringLen] -> IO CInt) -> IO CInt
forall b. [ByteString] -> ([CStringLen] -> IO b) -> IO b
constByteStrings [ByteString
sk] (([CStringLen] -> IO CInt) -> IO CInt)
-> ([CStringLen] -> IO CInt) -> IO CInt
forall a b. (a -> b) -> a -> b
$ \[(Ptr CChar
edbuf,Int
_)] ->
      Ptr CChar -> Ptr CChar -> IO CInt
c_sign_ed25519_sk_to_curve25519 Ptr CChar
xbuf Ptr CChar
edbuf
  case err of
    CInt
0 -> Maybe Scalar -> IO (Maybe Scalar)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Scalar -> IO (Maybe Scalar))
-> Maybe Scalar -> IO (Maybe Scalar)
forall a b. (a -> b) -> a -> b
$ Scalar -> Maybe Scalar
forall a. a -> Maybe a
Just (Scalar -> Maybe Scalar) -> Scalar -> Maybe Scalar
forall a b. (a -> b) -> a -> b
$ ByteString -> Scalar
SM.Sc ByteString
x
    CInt
_ -> Maybe Scalar -> IO (Maybe Scalar)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return   Maybe Scalar
forall a. Maybe a
Nothing