{-|
Module      : Botan.Low.PubKey.Sign
Description : Signature Generation
Copyright   : (c) 2023-2024, Apotheca Labs
              (c) 2024-2025, Haskell Foundation
License     : BSD-3-Clause
Maintainer  : joris@well-typed.com, leo@apotheca.io
Stability   : experimental
Portability : POSIX
-}

module Botan.Low.PubKey.Sign (

  -- * Public key signatures
    Sign(..)
  , SigningFlags (..)
  , signingFlags
  , withSign
  , signCreate
  , signDestroy
  , signOutputLength
  , signUpdate
  , signFinish

  ) where

import           Botan.Bindings.ConstPtr (ConstPtr (..))
import           Botan.Bindings.PubKey.Sign
import           Botan.Low.Error.Internal
import           Botan.Low.Internal.ByteString
import           Botan.Low.Make
import           Botan.Low.PubKey
import           Botan.Low.Remake
import           Botan.Low.RNG
import           Control.DeepSeq
import           Data.ByteString (ByteString)
import qualified Data.ByteString as ByteString
import           Data.Word
import           Foreign.C.Types
import           Foreign.ForeignPtr
import           Foreign.Marshal.Alloc
import           Foreign.Ptr
import           Foreign.Storable

-- /*
-- * Signature Generation
-- */

newtype Sign = MkSign { Sign -> ForeignPtr BotanPKOpSignStruct
foreignPtr :: ForeignPtr BotanPKOpSignStruct }

withSign     :: Sign -> (BotanPKOpSign -> IO a) -> IO a
signDestroy  :: Sign -> IO ()
createSign   :: (Ptr BotanPKOpSign -> IO CInt) -> IO Sign
(Sign -> (BotanPKOpSign -> IO a) -> IO a
withSign, Sign -> IO ()
signDestroy, (Ptr BotanPKOpSign -> IO CInt) -> IO Sign
createSign)
    = (Ptr BotanPKOpSignStruct -> BotanPKOpSign)
-> (BotanPKOpSign -> Ptr BotanPKOpSignStruct)
-> (ForeignPtr BotanPKOpSignStruct -> Sign)
-> (Sign -> ForeignPtr BotanPKOpSignStruct)
-> FinalizerPtr BotanPKOpSignStruct
-> (Sign -> (BotanPKOpSign -> IO a) -> IO a, Sign -> IO (),
    (Ptr BotanPKOpSign -> IO CInt) -> IO Sign)
forall botan struct object a.
Storable botan =>
(Ptr struct -> botan)
-> (botan -> Ptr struct)
-> (ForeignPtr struct -> object)
-> (object -> ForeignPtr struct)
-> FinalizerPtr struct
-> (object -> (botan -> IO a) -> IO a, object -> IO (),
    (Ptr botan -> IO CInt) -> IO object)
mkBindings
        Ptr BotanPKOpSignStruct -> BotanPKOpSign
MkBotanPKOpSign (.ptr)
        ForeignPtr BotanPKOpSignStruct -> Sign
MkSign (.foreignPtr)
        FinalizerPtr BotanPKOpSignStruct
botan_pk_op_sign_destroy

data SigningFlags =
    StandardFormatSignature
  | DERFormatSignature

signingFlags :: SigningFlags -> Word32
signingFlags :: SigningFlags -> Word32
signingFlags SigningFlags
StandardFormatSignature = Word32
forall a. (Eq a, Num a) => a
BOTAN_PUBKEY_STD_FORMAT_SIGNATURE
signingFlags SigningFlags
DERFormatSignature      = Word32
forall a. (Eq a, Num a) => a
BOTAN_PUBKEY_DER_FORMAT_SIGNATURE

signCreate
    :: PrivKey      -- ^ __key__
    -> EMSAName     -- ^ __hash_and_padding__
    -> SigningFlags -- ^ __flags__
    -> IO Sign      -- ^ __op__
signCreate :: PrivKey -> ByteString -> SigningFlags -> IO Sign
signCreate PrivKey
sk ByteString
algo SigningFlags
flags = PrivKey -> (BotanPrivKey -> IO Sign) -> IO Sign
forall a. PrivKey -> (BotanPrivKey -> IO a) -> IO a
withPrivKey PrivKey
sk ((BotanPrivKey -> IO Sign) -> IO Sign)
-> (BotanPrivKey -> IO Sign) -> IO Sign
forall a b. (a -> b) -> a -> b
$ \ BotanPrivKey
skPtr -> do
    ByteString -> (Ptr CChar -> IO Sign) -> IO Sign
forall a. ByteString -> (Ptr CChar -> IO a) -> IO a
asCString ByteString
algo ((Ptr CChar -> IO Sign) -> IO Sign)
-> (Ptr CChar -> IO Sign) -> IO Sign
forall a b. (a -> b) -> a -> b
$ \ Ptr CChar
algoPtr -> do
        (Ptr BotanPKOpSign -> IO CInt) -> IO Sign
createSign ((Ptr BotanPKOpSign -> IO CInt) -> IO Sign)
-> (Ptr BotanPKOpSign -> IO CInt) -> IO Sign
forall a b. (a -> b) -> a -> b
$ \ Ptr BotanPKOpSign
out -> Ptr BotanPKOpSign
-> BotanPrivKey -> ConstPtr CChar -> Word32 -> IO CInt
botan_pk_op_sign_create
            Ptr BotanPKOpSign
out
            BotanPrivKey
skPtr
            (Ptr CChar -> ConstPtr CChar
forall a. Ptr a -> ConstPtr a
ConstPtr Ptr CChar
algoPtr)
            (SigningFlags -> Word32
signingFlags SigningFlags
flags)

signOutputLength
    :: Sign     -- ^ __op__
    -> IO Int   -- ^ __olen__
signOutputLength :: Sign -> IO Int
signOutputLength = WithPtr Sign BotanPKOpSign
-> GetSize BotanPKOpSign -> Sign -> IO Int
forall typ ptr. WithPtr typ ptr -> GetSize ptr -> typ -> IO Int
mkGetSize Sign -> (BotanPKOpSign -> IO a) -> IO a
WithPtr Sign BotanPKOpSign
withSign GetSize BotanPKOpSign
botan_pk_op_sign_output_length

signUpdate
    :: Sign         -- ^ __op__
    -> ByteString   -- ^ __in[]__
    -> IO ()
-- signUpdate = mkSetBytesLen withSign botan_pk_op_sign_update
signUpdate :: Sign -> ByteString -> IO ()
signUpdate = WithPtr Sign BotanPKOpSign
-> (BotanPKOpSign -> ConstPtr Word8 -> CSize -> IO CInt)
-> Sign
-> ByteString
-> IO ()
forall object botan.
(forall a. object -> (botan -> IO a) -> IO a)
-> (botan -> ConstPtr Word8 -> CSize -> IO CInt)
-> object
-> ByteString
-> IO ()
mkWithObjectSetterCBytesLen Sign -> (BotanPKOpSign -> IO a) -> IO a
WithPtr Sign BotanPKOpSign
withSign BotanPKOpSign -> ConstPtr Word8 -> CSize -> IO CInt
botan_pk_op_sign_update

-- | Finish signing
--
-- Depending on the algorithm, signatures produced using StandardFormatSignature
-- may have trailing null bytes.
signFinish
    :: Sign             -- ^ __op__
    -> RNG              -- ^ __rng__
    -> IO ByteString    -- ^ __sig[]__
-- TODO: Signature type
-- NOTE: This function is still highly suspect
signFinish :: Sign -> RNG -> IO ByteString
signFinish Sign
sign RNG
rng = Sign -> (BotanPKOpSign -> IO ByteString) -> IO ByteString
WithPtr Sign BotanPKOpSign
withSign Sign
sign ((BotanPKOpSign -> IO ByteString) -> IO ByteString)
-> (BotanPKOpSign -> IO ByteString) -> IO ByteString
forall a b. (a -> b) -> a -> b
$ \ BotanPKOpSign
signPtr -> do
    RNG -> (BotanRNG -> IO ByteString) -> IO ByteString
forall a. RNG -> (BotanRNG -> IO a) -> IO a
withRNG RNG
rng ((BotanRNG -> IO ByteString) -> IO ByteString)
-> (BotanRNG -> IO ByteString) -> IO ByteString
forall a b. (a -> b) -> a -> b
$ \ BotanRNG
botanRNG -> do
        -- NOTE: Investigation into DER format shows lots of trailing nulls that may need to be trimmed
        --  using the output of szPtr if sz is just an upper-bound estimate
        -- sz <- signOutputLength sign
        -- allocBytes sz $ \ sigPtr -> do
        --     alloca $ \ szPtr -> do
        --         poke szPtr (fromIntegral sz)
        --         throwBotanIfNegative_ $ botan_pk_op_sign_finish signPtr botanRNG sigPtr szPtr
        -- NOTE: This doesn't work, I think the output length poke is necessary
        -- allocBytesQuerying $ \ sigPtr szPtr -> do
        --     botan_pk_op_sign_finish signPtr botanRNG sigPtr szPtr
        -- NOTE: Trying combo, this should be packaged as allocBytesUpperBound or something
        --  We get an upper bound, allocate at least that many, poke the size, perform the
        --  op, read the actual size, and trim.
        Int
sz <- Sign -> IO Int
signOutputLength Sign
sign
        (CSize
sz',ByteString
bytes) <- Int -> (Ptr Word8 -> IO CSize) -> IO (CSize, ByteString)
forall byte a. Int -> (Ptr byte -> IO a) -> IO (a, ByteString)
allocBytesWith Int
sz ((Ptr Word8 -> IO CSize) -> IO (CSize, ByteString))
-> (Ptr Word8 -> IO CSize) -> IO (CSize, ByteString)
forall a b. (a -> b) -> a -> b
$ \ Ptr Word8
sigPtr -> do
            (Ptr CSize -> IO CSize) -> IO CSize
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr CSize -> IO CSize) -> IO CSize)
-> (Ptr CSize -> IO CSize) -> IO CSize
forall a b. (a -> b) -> a -> b
$ \ Ptr CSize
szPtr -> do
                Ptr CSize -> CSize -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr CSize
szPtr (Int -> CSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
sz)
                HasCallStack => IO CInt -> IO ()
IO CInt -> IO ()
throwBotanIfNegative_ (IO CInt -> IO ()) -> IO CInt -> IO ()
forall a b. (a -> b) -> a -> b
$ BotanPKOpSign -> BotanRNG -> Ptr Word8 -> Ptr CSize -> IO CInt
botan_pk_op_sign_finish BotanPKOpSign
signPtr BotanRNG
botanRNG Ptr Word8
sigPtr Ptr CSize
szPtr
                Ptr CSize -> IO CSize
forall a. Storable a => Ptr a -> IO a
peek Ptr CSize
szPtr
        ByteString -> IO ByteString
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> IO ByteString) -> ByteString -> IO ByteString
forall a b. NFData a => (a -> b) -> a -> b
$!! Int -> ByteString -> ByteString
ByteString.take (CSize -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral CSize
sz') ByteString
bytes

-- /**
-- * Signature Scheme Utility Functions
-- */

-- TODO: botan_pkcs_hash_id