{-# LINE 1 "src/Sodium/Crypto/Sign.hsc" #-}
{-# LANGUAGE CPP #-}

-- This file is part of the Wire Server implementation.
--
-- Copyright (C) 2022 Wire Swiss GmbH <opensource@wire.com>
--
-- This program is free software: you can redistribute it and/or modify it under
-- the terms of the GNU Affero General Public License as published by the Free
-- Software Foundation, either version 3 of the License, or (at your option) any
-- later version.
--
-- This program is distributed in the hope that it will be useful, but WITHOUT
-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more
-- details.
--
-- You should have received a copy of the GNU Affero General Public License along
-- with this program. If not, see <https://www.gnu.org/licenses/>.

module Sodium.Crypto.Sign
  ( PublicKey (..),
    SecretKey (..),
    Signature (..),
    newKeyPair,
    sign,
    signature,
    signatureLength,
    verify,
    verifyWith,
  )
where

import Data.ByteString qualified as B
import Data.ByteString.Base64.URL
import Data.ByteString.Char8 (pack, unpack)
import Data.ByteString.Internal qualified as I
import Data.ByteString.Unsafe qualified as U
import Foreign hiding (void)
import Foreign.C
import Imports

newtype PublicKey = PublicKey {PublicKey -> ByteString
pubBytes :: ByteString} deriving (PublicKey -> PublicKey -> Bool
(PublicKey -> PublicKey -> Bool)
-> (PublicKey -> PublicKey -> Bool) -> Eq PublicKey
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: PublicKey -> PublicKey -> Bool
== :: PublicKey -> PublicKey -> Bool
$c/= :: PublicKey -> PublicKey -> Bool
/= :: PublicKey -> PublicKey -> Bool
Eq, Eq PublicKey
Eq PublicKey =>
(PublicKey -> PublicKey -> Ordering)
-> (PublicKey -> PublicKey -> Bool)
-> (PublicKey -> PublicKey -> Bool)
-> (PublicKey -> PublicKey -> Bool)
-> (PublicKey -> PublicKey -> Bool)
-> (PublicKey -> PublicKey -> PublicKey)
-> (PublicKey -> PublicKey -> PublicKey)
-> Ord PublicKey
PublicKey -> PublicKey -> Bool
PublicKey -> PublicKey -> Ordering
PublicKey -> PublicKey -> PublicKey
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: PublicKey -> PublicKey -> Ordering
compare :: PublicKey -> PublicKey -> Ordering
$c< :: PublicKey -> PublicKey -> Bool
< :: PublicKey -> PublicKey -> Bool
$c<= :: PublicKey -> PublicKey -> Bool
<= :: PublicKey -> PublicKey -> Bool
$c> :: PublicKey -> PublicKey -> Bool
> :: PublicKey -> PublicKey -> Bool
$c>= :: PublicKey -> PublicKey -> Bool
>= :: PublicKey -> PublicKey -> Bool
$cmax :: PublicKey -> PublicKey -> PublicKey
max :: PublicKey -> PublicKey -> PublicKey
$cmin :: PublicKey -> PublicKey -> PublicKey
min :: PublicKey -> PublicKey -> PublicKey
Ord)

newtype SecretKey = SecretKey {SecretKey -> ByteString
secBytes :: ByteString} deriving (SecretKey -> SecretKey -> Bool
(SecretKey -> SecretKey -> Bool)
-> (SecretKey -> SecretKey -> Bool) -> Eq SecretKey
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SecretKey -> SecretKey -> Bool
== :: SecretKey -> SecretKey -> Bool
$c/= :: SecretKey -> SecretKey -> Bool
/= :: SecretKey -> SecretKey -> Bool
Eq, Eq SecretKey
Eq SecretKey =>
(SecretKey -> SecretKey -> Ordering)
-> (SecretKey -> SecretKey -> Bool)
-> (SecretKey -> SecretKey -> Bool)
-> (SecretKey -> SecretKey -> Bool)
-> (SecretKey -> SecretKey -> Bool)
-> (SecretKey -> SecretKey -> SecretKey)
-> (SecretKey -> SecretKey -> SecretKey)
-> Ord SecretKey
SecretKey -> SecretKey -> Bool
SecretKey -> SecretKey -> Ordering
SecretKey -> SecretKey -> SecretKey
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: SecretKey -> SecretKey -> Ordering
compare :: SecretKey -> SecretKey -> Ordering
$c< :: SecretKey -> SecretKey -> Bool
< :: SecretKey -> SecretKey -> Bool
$c<= :: SecretKey -> SecretKey -> Bool
<= :: SecretKey -> SecretKey -> Bool
$c> :: SecretKey -> SecretKey -> Bool
> :: SecretKey -> SecretKey -> Bool
$c>= :: SecretKey -> SecretKey -> Bool
>= :: SecretKey -> SecretKey -> Bool
$cmax :: SecretKey -> SecretKey -> SecretKey
max :: SecretKey -> SecretKey -> SecretKey
$cmin :: SecretKey -> SecretKey -> SecretKey
min :: SecretKey -> SecretKey -> SecretKey
Ord)

newtype Signature = Signature {Signature -> ByteString
sigBytes :: ByteString} deriving (Signature -> Signature -> Bool
(Signature -> Signature -> Bool)
-> (Signature -> Signature -> Bool) -> Eq Signature
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Signature -> Signature -> Bool
== :: Signature -> Signature -> Bool
$c/= :: Signature -> Signature -> Bool
/= :: Signature -> Signature -> Bool
Eq, Eq Signature
Eq Signature =>
(Signature -> Signature -> Ordering)
-> (Signature -> Signature -> Bool)
-> (Signature -> Signature -> Bool)
-> (Signature -> Signature -> Bool)
-> (Signature -> Signature -> Bool)
-> (Signature -> Signature -> Signature)
-> (Signature -> Signature -> Signature)
-> Ord Signature
Signature -> Signature -> Bool
Signature -> Signature -> Ordering
Signature -> Signature -> Signature
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Signature -> Signature -> Ordering
compare :: Signature -> Signature -> Ordering
$c< :: Signature -> Signature -> Bool
< :: Signature -> Signature -> Bool
$c<= :: Signature -> Signature -> Bool
<= :: Signature -> Signature -> Bool
$c> :: Signature -> Signature -> Bool
> :: Signature -> Signature -> Bool
$c>= :: Signature -> Signature -> Bool
>= :: Signature -> Signature -> Bool
$cmax :: Signature -> Signature -> Signature
max :: Signature -> Signature -> Signature
$cmin :: Signature -> Signature -> Signature
min :: Signature -> Signature -> Signature
Ord)

instance Read PublicKey where
  readsPrec :: Int -> ReadS PublicKey
readsPrec Int
_ = ReadS PublicKey
-> (ByteString -> [(PublicKey, String)])
-> Either String ByteString
-> [(PublicKey, String)]
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ReadS PublicKey
forall a. HasCallStack => String -> a
error (\ByteString
k -> [(ByteString -> PublicKey
PublicKey ByteString
k, String
"")]) (Either String ByteString -> [(PublicKey, String)])
-> (String -> Either String ByteString) -> ReadS PublicKey
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either String ByteString
decode (ByteString -> Either String ByteString)
-> (String -> ByteString) -> String -> Either String ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ByteString
pack

instance Read SecretKey where
  readsPrec :: Int -> ReadS SecretKey
readsPrec Int
_ = ReadS SecretKey
-> (ByteString -> [(SecretKey, String)])
-> Either String ByteString
-> [(SecretKey, String)]
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ReadS SecretKey
forall a. HasCallStack => String -> a
error (\ByteString
k -> [(ByteString -> SecretKey
SecretKey ByteString
k, String
"")]) (Either String ByteString -> [(SecretKey, String)])
-> (String -> Either String ByteString) -> ReadS SecretKey
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either String ByteString
decode (ByteString -> Either String ByteString)
-> (String -> ByteString) -> String -> Either String ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ByteString
pack

instance Read Signature where
  readsPrec :: Int -> ReadS Signature
readsPrec Int
_ = ReadS Signature
-> (ByteString -> [(Signature, String)])
-> Either String ByteString
-> [(Signature, String)]
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ReadS Signature
forall a. HasCallStack => String -> a
error (\ByteString
k -> [(ByteString -> Signature
Signature ByteString
k, String
"")]) (Either String ByteString -> [(Signature, String)])
-> (String -> Either String ByteString) -> ReadS Signature
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either String ByteString
decode (ByteString -> Either String ByteString)
-> (String -> ByteString) -> String -> Either String ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ByteString
pack

instance Show PublicKey where
  show :: PublicKey -> String
show = ByteString -> String
unpack (ByteString -> String)
-> (PublicKey -> ByteString) -> PublicKey -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
encode (ByteString -> ByteString)
-> (PublicKey -> ByteString) -> PublicKey -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PublicKey -> ByteString
pubBytes

instance Show SecretKey where
  show :: SecretKey -> String
show = ByteString -> String
unpack (ByteString -> String)
-> (SecretKey -> ByteString) -> SecretKey -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
encode (ByteString -> ByteString)
-> (SecretKey -> ByteString) -> SecretKey -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SecretKey -> ByteString
secBytes

instance Show Signature where
  show :: Signature -> String
show = ByteString -> String
unpack (ByteString -> String)
-> (Signature -> ByteString) -> Signature -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
encode (ByteString -> ByteString)
-> (Signature -> ByteString) -> Signature -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Signature -> ByteString
sigBytes

-- | Please note that this function is not thread-safe.
newKeyPair :: IO (PublicKey, SecretKey)
newKeyPair :: IO (PublicKey, SecretKey)
newKeyPair = do
  Int
pl <- Word -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word -> Int) -> IO Word -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Word
publicKeyLength
  Int
sl <- Word -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word -> Int) -> IO Word -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Word
secretKeyLength
  ForeignPtr Word8
pk <- Int -> IO (ForeignPtr Word8)
forall a. Int -> IO (ForeignPtr a)
I.mallocByteString Int
pl
  ForeignPtr Word8
sk <- Int -> IO (ForeignPtr Word8)
forall a. Int -> IO (ForeignPtr a)
I.mallocByteString Int
sl

  ForeignPtr Word8 -> (Ptr Word8 -> IO ()) -> IO ()
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr Word8
pk ((Ptr Word8 -> IO ()) -> IO ()) -> (Ptr Word8 -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
ppk ->
    ForeignPtr Word8 -> (Ptr Word8 -> IO ()) -> IO ()
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr Word8
sk ((Ptr Word8 -> IO ()) -> IO ()) -> (Ptr Word8 -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
psk ->
      IO CInt -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO CInt -> IO ()) -> IO CInt -> IO ()
forall a b. (a -> b) -> a -> b
$ Ptr CUChar -> Ptr CUChar -> IO CInt
c_crypto_sign_keypair (Ptr Word8 -> Ptr CUChar
forall a b. Ptr a -> Ptr b
castPtr Ptr Word8
ppk) (Ptr Word8 -> Ptr CUChar
forall a b. Ptr a -> Ptr b
castPtr Ptr Word8
psk)

  (PublicKey, SecretKey) -> IO (PublicKey, SecretKey)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return
    ( ByteString -> PublicKey
PublicKey (ForeignPtr Word8 -> Int -> Int -> ByteString
I.fromForeignPtr ForeignPtr Word8
pk Int
0 Int
pl),
      ByteString -> SecretKey
SecretKey (ForeignPtr Word8 -> Int -> Int -> ByteString
I.fromForeignPtr ForeignPtr Word8
sk Int
0 Int
sl)
    )

sign :: SecretKey -> ByteString -> IO ByteString
sign :: SecretKey -> ByteString -> IO ByteString
sign SecretKey
k ByteString
b = do
  Int
siglen <- Word -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word -> Int) -> IO Word -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Word
signatureLength
  ByteString -> (CStringLen -> IO ByteString) -> IO ByteString
forall a. ByteString -> (CStringLen -> IO a) -> IO a
U.unsafeUseAsCStringLen ByteString
b ((CStringLen -> IO ByteString) -> IO ByteString)
-> (CStringLen -> IO ByteString) -> IO ByteString
forall a b. (a -> b) -> a -> b
$ \(Ptr CChar
m, Int
mlen) ->
    ByteString -> (Ptr CChar -> IO ByteString) -> IO ByteString
forall a. ByteString -> (Ptr CChar -> IO a) -> IO a
U.unsafeUseAsCString (SecretKey -> ByteString
secBytes SecretKey
k) ((Ptr CChar -> IO ByteString) -> IO ByteString)
-> (Ptr CChar -> IO ByteString) -> IO ByteString
forall a b. (a -> b) -> a -> b
$ \Ptr CChar
sk ->
      Int -> (Ptr Word8 -> IO Int) -> IO ByteString
I.createAndTrim (Int
mlen Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
siglen) ((Ptr Word8 -> IO Int) -> IO ByteString)
-> (Ptr Word8 -> IO Int) -> IO ByteString
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
sm ->
        (Ptr CULLong -> IO Int) -> IO Int
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr CULLong -> IO Int) -> IO Int)
-> (Ptr CULLong -> IO Int) -> IO Int
forall a b. (a -> b) -> a -> b
$ \Ptr CULLong
smlen -> do
          IO CInt -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO CInt -> IO ()) -> IO CInt -> IO ()
forall a b. (a -> b) -> a -> b
$ Ptr CUChar
-> Ptr CULLong -> Ptr CUChar -> CULLong -> Ptr CUChar -> IO CInt
c_crypto_sign (Ptr Word8 -> Ptr CUChar
forall a b. Ptr a -> Ptr b
castPtr Ptr Word8
sm) Ptr CULLong
smlen (Ptr CChar -> Ptr CUChar
forall a b. Ptr a -> Ptr b
castPtr Ptr CChar
m) (Int -> CULLong
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
mlen) (Ptr CChar -> Ptr CUChar
forall a b. Ptr a -> Ptr b
castPtr Ptr CChar
sk)
          CULLong -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (CULLong -> Int) -> IO CULLong -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr CULLong -> IO CULLong
forall a. Storable a => Ptr a -> IO a
peek Ptr CULLong
smlen

signature :: SecretKey -> ByteString -> IO Signature
signature :: SecretKey -> ByteString -> IO Signature
signature SecretKey
k ByteString
m = do
  ByteString
sm <- SecretKey -> ByteString -> IO ByteString
sign SecretKey
k ByteString
m
  Signature -> IO Signature
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Signature -> IO Signature) -> Signature -> IO Signature
forall a b. (a -> b) -> a -> b
$ ByteString -> Signature
Signature (Int -> ByteString -> ByteString
B.take (ByteString -> Int
B.length ByteString
sm Int -> Int -> Int
forall a. Num a => a -> a -> a
- ByteString -> Int
B.length ByteString
m) ByteString
sm)

verify :: PublicKey -> ByteString -> IO Bool
verify :: PublicKey -> ByteString -> IO Bool
verify PublicKey
k ByteString
m =
  ByteString -> (CStringLen -> IO Bool) -> IO Bool
forall a. ByteString -> (CStringLen -> IO a) -> IO a
U.unsafeUseAsCStringLen ByteString
m ((CStringLen -> IO Bool) -> IO Bool)
-> (CStringLen -> IO Bool) -> IO Bool
forall a b. (a -> b) -> a -> b
$ \(Ptr CChar
ms, Int
mslen) ->
    ByteString -> (Ptr CChar -> IO Bool) -> IO Bool
forall a. ByteString -> (Ptr CChar -> IO a) -> IO a
U.unsafeUseAsCString (PublicKey -> ByteString
pubBytes PublicKey
k) ((Ptr CChar -> IO Bool) -> IO Bool)
-> (Ptr CChar -> IO Bool) -> IO Bool
forall a b. (a -> b) -> a -> b
$ \Ptr CChar
pk ->
      (Ptr CULLong -> IO Bool) -> IO Bool
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr CULLong -> IO Bool) -> IO Bool)
-> (Ptr CULLong -> IO Bool) -> IO Bool
forall a b. (a -> b) -> a -> b
$ \Ptr CULLong
pmlen -> do
        ForeignPtr Any
out <- Int -> IO (ForeignPtr Any)
forall a. Int -> IO (ForeignPtr a)
I.mallocByteString Int
mslen
        CInt
res <- ForeignPtr Any -> (Ptr Any -> IO CInt) -> IO CInt
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr Any
out ((Ptr Any -> IO CInt) -> IO CInt)
-> (Ptr Any -> IO CInt) -> IO CInt
forall a b. (a -> b) -> a -> b
$ \Ptr Any
pout ->
          Ptr CUChar
-> Ptr CULLong -> Ptr CUChar -> CULLong -> Ptr CUChar -> IO CInt
c_crypto_sign_open (Ptr Any -> Ptr CUChar
forall a b. Ptr a -> Ptr b
castPtr Ptr Any
pout) Ptr CULLong
pmlen (Ptr CChar -> Ptr CUChar
forall a b. Ptr a -> Ptr b
castPtr Ptr CChar
ms) (Int -> CULLong
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
mslen) (Ptr CChar -> Ptr CUChar
forall a b. Ptr a -> Ptr b
castPtr Ptr CChar
pk)
        Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (CInt
res CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
== CInt
0)

verifyWith :: PublicKey -> Signature -> ByteString -> IO Bool
verifyWith :: PublicKey -> Signature -> ByteString -> IO Bool
verifyWith PublicKey
k Signature
s ByteString
m = PublicKey -> ByteString -> IO Bool
verify PublicKey
k (Signature -> ByteString
sigBytes Signature
s ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
m)

secretKeyLength :: IO Word
secretKeyLength :: IO Word
secretKeyLength = CSize -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral (CSize -> Word) -> IO CSize -> IO Word
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO CSize
c_crypto_sign_secretkeybytes
{-# INLINE secretKeyLength #-}

publicKeyLength :: IO Word
publicKeyLength :: IO Word
publicKeyLength = CSize -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral (CSize -> Word) -> IO CSize -> IO Word
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO CSize
c_crypto_sign_publickeybytes
{-# INLINE publicKeyLength #-}

signatureLength :: IO Word
signatureLength :: IO Word
signatureLength = CSize -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral (CSize -> Word) -> IO CSize -> IO Word
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO CSize
c_crypto_sign_bytes
{-# INLINE signatureLength #-}

-----------------------------------------------------------------------------
-- FFI



foreign import ccall unsafe "crypto_sign.h crypto_sign_bytes"
  c_crypto_sign_bytes :: IO CSize

foreign import ccall unsafe "crypto_sign.h crypto_sign_publickeybytes"
  c_crypto_sign_publickeybytes :: IO CSize

foreign import ccall unsafe "crypto_sign.h crypto_sign_secretkeybytes"
  c_crypto_sign_secretkeybytes :: IO CSize

foreign import ccall unsafe "crypto_sign.h crypto_sign_keypair"
  c_crypto_sign_keypair :: Ptr CUChar -> Ptr CUChar -> IO CInt

foreign import ccall unsafe "crypto_sign.h crypto_sign"
  c_crypto_sign ::
    Ptr CUChar -> -- signed message
    Ptr CULLong -> -- signed message length
    Ptr CUChar -> -- plain text message
    CULLong -> -- plain text length
    Ptr CUChar -> -- secret key
    IO CInt

foreign import ccall unsafe "crypto_sign.h crypto_sign_open"
  c_crypto_sign_open ::
    Ptr CUChar -> -- plain text message
    Ptr CULLong -> -- plain text message length
    Ptr CUChar -> -- signed message
    CULLong -> -- signed message length
    Ptr CUChar -> -- public key
    IO CInt