{-# LANGUAGE EmptyDataDecls           #-}
{-# LANGUAGE ForeignFunctionInterface #-}
{-# OPTIONS_HADDOCK prune             #-}
-- |An interface to PKCS#10 certificate request.
module OpenSSL.X509.Request
    ( -- * Type
      X509Req
    , X509_REQ -- private

      -- * Functions to manipulate request
    , newX509Req
    , wrapX509Req -- private
    , withX509ReqPtr -- private

    , signX509Req
    , verifyX509Req

    , printX509Req
    , writeX509ReqDER

    , makeX509FromReq

      -- * Accessors
    , getVersion
    , setVersion

    , getSubjectName
    , setSubjectName

    , getPublicKey
    , setPublicKey

    , addExtensions
    )
    where

import           Control.Monad
import           Data.Maybe
import           Foreign
import           Foreign.C
import           OpenSSL.BIO
import           OpenSSL.EVP.Digest hiding (digest)
import           OpenSSL.EVP.PKey
import           OpenSSL.EVP.Verify
import           OpenSSL.EVP.Internal
import           OpenSSL.Utils
import           OpenSSL.X509 (X509)
import qualified OpenSSL.X509 as Cert
import           OpenSSL.X509.Name
import           Data.ByteString.Lazy (ByteString)
import           OpenSSL.Stack

-- |@'X509Req'@ is an opaque object that represents PKCS#10
-- certificate request.
newtype X509Req  = X509Req (ForeignPtr X509_REQ)
data    X509_REQ

data    X509_EXT

foreign import ccall unsafe "X509_REQ_new"
        _new :: IO (Ptr X509_REQ)

foreign import ccall unsafe "&X509_REQ_free"
        _free :: FunPtr (Ptr X509_REQ -> IO ())

foreign import ccall unsafe "X509_REQ_sign"
        _sign :: Ptr X509_REQ -> Ptr EVP_PKEY -> Ptr EVP_MD -> IO CInt

foreign import ccall unsafe "X509_REQ_verify"
        _verify :: Ptr X509_REQ -> Ptr EVP_PKEY -> IO CInt

foreign import ccall unsafe "X509_REQ_print"
        _print :: Ptr BIO_ -> Ptr X509_REQ -> IO CInt

foreign import ccall unsafe "i2d_X509_REQ_bio"
        _req_to_der :: Ptr BIO_ -> Ptr X509_REQ -> IO CInt

foreign import ccall unsafe "HsOpenSSL_X509_REQ_get_version"
        _get_version :: Ptr X509_REQ -> IO CLong

foreign import ccall unsafe "X509_REQ_set_version"
        _set_version :: Ptr X509_REQ -> CLong -> IO CInt

foreign import ccall unsafe "HsOpenSSL_X509_REQ_get_subject_name"
        _get_subject_name :: Ptr X509_REQ -> IO (Ptr X509_NAME)

foreign import ccall unsafe "X509_REQ_set_subject_name"
        _set_subject_name :: Ptr X509_REQ -> Ptr X509_NAME -> IO CInt

foreign import ccall unsafe "X509_REQ_get_pubkey"
        _get_pubkey :: Ptr X509_REQ -> IO (Ptr EVP_PKEY)

foreign import ccall unsafe "X509_REQ_set_pubkey"
        _set_pubkey :: Ptr X509_REQ -> Ptr EVP_PKEY -> IO CInt

foreign import ccall unsafe "X509V3_EXT_nconf_nid"
        _ext_create :: Ptr a -> Ptr b -> CInt -> CString -> IO (Ptr X509_EXT)

foreign import ccall unsafe "X509_REQ_add_extensions"
        _req_add_extensions :: Ptr X509_REQ -> Ptr STACK -> IO CInt


-- |@'newX509Req'@ creates an empty certificate request. You must set
-- the following properties to and sign it (see 'signX509Req') to
-- actually use the certificate request.
--
--  [/Version/] See 'setVersion'.
--
--  [/Subject Name/] See 'setSubjectName'.
--
--  [/Public Key/] See 'setPublicKey'.
--
newX509Req :: IO X509Req
newX509Req :: IO X509Req
newX509Req = IO (Ptr X509_REQ)
_new IO (Ptr X509_REQ) -> (Ptr X509_REQ -> IO X509Req) -> IO X509Req
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Ptr X509_REQ -> IO X509Req
wrapX509Req


wrapX509Req :: Ptr X509_REQ -> IO X509Req
wrapX509Req :: Ptr X509_REQ -> IO X509Req
wrapX509Req = (ForeignPtr X509_REQ -> X509Req)
-> IO (ForeignPtr X509_REQ) -> IO X509Req
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ForeignPtr X509_REQ -> X509Req
X509Req (IO (ForeignPtr X509_REQ) -> IO X509Req)
-> (Ptr X509_REQ -> IO (ForeignPtr X509_REQ))
-> Ptr X509_REQ
-> IO X509Req
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FinalizerPtr X509_REQ -> Ptr X509_REQ -> IO (ForeignPtr X509_REQ)
forall a. FinalizerPtr a -> Ptr a -> IO (ForeignPtr a)
newForeignPtr FinalizerPtr X509_REQ
_free


withX509ReqPtr :: X509Req -> (Ptr X509_REQ -> IO a) -> IO a
withX509ReqPtr :: X509Req -> (Ptr X509_REQ -> IO a) -> IO a
withX509ReqPtr (X509Req ForeignPtr X509_REQ
req) = ForeignPtr X509_REQ -> (Ptr X509_REQ -> IO a) -> IO a
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr X509_REQ
req

-- |@'signX509Req'@ signs a certificate request with a subject private
-- key.
signX509Req :: KeyPair key =>
               X509Req      -- ^ The request to be signed.
            -> key          -- ^ The private key to sign with.
            -> Maybe Digest -- ^ A hashing algorithm to use. If
                            --   @Nothing@ the most suitable algorithm
                            --   for the key is automatically used.
            -> IO ()
signX509Req :: X509Req -> key -> Maybe Digest -> IO ()
signX509Req X509Req
req key
pkey Maybe Digest
mDigest
    = X509Req -> (Ptr X509_REQ -> IO ()) -> IO ()
forall a. X509Req -> (Ptr X509_REQ -> IO a) -> IO a
withX509ReqPtr X509Req
req  ((Ptr X509_REQ -> IO ()) -> IO ())
-> (Ptr X509_REQ -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ Ptr X509_REQ
reqPtr  ->
      key -> (Ptr EVP_PKEY -> IO ()) -> IO ()
forall k a. PKey k => k -> (Ptr EVP_PKEY -> IO a) -> IO a
withPKeyPtr'   key
pkey ((Ptr EVP_PKEY -> IO ()) -> IO ())
-> (Ptr EVP_PKEY -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ Ptr EVP_PKEY
pkeyPtr ->
      do Digest
digest <- case Maybe Digest
mDigest of
                     Just Digest
md -> Digest -> IO Digest
forall (m :: * -> *) a. Monad m => a -> m a
return Digest
md
                     Maybe Digest
Nothing -> key -> IO Digest
forall k. PKey k => k -> IO Digest
pkeyDefaultMD key
pkey
         Digest -> (Ptr EVP_MD -> IO ()) -> IO ()
forall a. Digest -> (Ptr EVP_MD -> IO a) -> IO a
withMDPtr Digest
digest ((Ptr EVP_MD -> IO ()) -> IO ()) -> (Ptr EVP_MD -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ Ptr EVP_MD
digestPtr ->
             Ptr X509_REQ -> Ptr EVP_PKEY -> Ptr EVP_MD -> IO CInt
_sign Ptr X509_REQ
reqPtr Ptr EVP_PKEY
pkeyPtr Ptr EVP_MD
digestPtr
                  IO CInt -> (CInt -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (CInt -> Bool) -> CInt -> IO ()
forall a. (a -> Bool) -> a -> IO ()
failIf_ (CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
== CInt
0)

-- |@'verifyX509Req'@ verifies a signature of certificate request with
-- a subject public key.
verifyX509Req :: PublicKey key =>
                 X509Req -- ^ The request to be verified.
              -> key     -- ^ The public key to verify with.
              -> IO VerifyStatus
verifyX509Req :: X509Req -> key -> IO VerifyStatus
verifyX509Req X509Req
req key
pkey
    = X509Req -> (Ptr X509_REQ -> IO VerifyStatus) -> IO VerifyStatus
forall a. X509Req -> (Ptr X509_REQ -> IO a) -> IO a
withX509ReqPtr X509Req
req  ((Ptr X509_REQ -> IO VerifyStatus) -> IO VerifyStatus)
-> (Ptr X509_REQ -> IO VerifyStatus) -> IO VerifyStatus
forall a b. (a -> b) -> a -> b
$ \ Ptr X509_REQ
reqPtr  ->
      key -> (Ptr EVP_PKEY -> IO VerifyStatus) -> IO VerifyStatus
forall k a. PKey k => k -> (Ptr EVP_PKEY -> IO a) -> IO a
withPKeyPtr'   key
pkey ((Ptr EVP_PKEY -> IO VerifyStatus) -> IO VerifyStatus)
-> (Ptr EVP_PKEY -> IO VerifyStatus) -> IO VerifyStatus
forall a b. (a -> b) -> a -> b
$ \ Ptr EVP_PKEY
pkeyPtr ->
      Ptr X509_REQ -> Ptr EVP_PKEY -> IO CInt
_verify Ptr X509_REQ
reqPtr Ptr EVP_PKEY
pkeyPtr
           IO CInt -> (CInt -> IO VerifyStatus) -> IO VerifyStatus
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= CInt -> IO VerifyStatus
interpret
    where
      interpret :: CInt -> IO VerifyStatus
      interpret :: CInt -> IO VerifyStatus
interpret CInt
1 = VerifyStatus -> IO VerifyStatus
forall (m :: * -> *) a. Monad m => a -> m a
return VerifyStatus
VerifySuccess
      interpret CInt
0 = VerifyStatus -> IO VerifyStatus
forall (m :: * -> *) a. Monad m => a -> m a
return VerifyStatus
VerifyFailure
      interpret CInt
_ = IO VerifyStatus
forall a. IO a
raiseOpenSSLError

-- |@'printX509Req' req@ translates a certificate request into
-- human-readable format.
printX509Req :: X509Req -> IO String
printX509Req :: X509Req -> IO String
printX509Req X509Req
req
    = do BIO
mem <- IO BIO
newMem
         BIO -> (Ptr BIO_ -> IO ()) -> IO ()
forall a. BIO -> (Ptr BIO_ -> IO a) -> IO a
withBioPtr BIO
mem ((Ptr BIO_ -> IO ()) -> IO ()) -> (Ptr BIO_ -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ Ptr BIO_
memPtr ->
             X509Req -> (Ptr X509_REQ -> IO ()) -> IO ()
forall a. X509Req -> (Ptr X509_REQ -> IO a) -> IO a
withX509ReqPtr X509Req
req ((Ptr X509_REQ -> IO ()) -> IO ())
-> (Ptr X509_REQ -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ Ptr X509_REQ
reqPtr ->
                 Ptr BIO_ -> Ptr X509_REQ -> IO CInt
_print Ptr BIO_
memPtr Ptr X509_REQ
reqPtr
                      IO CInt -> (CInt -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (CInt -> Bool) -> CInt -> IO ()
forall a. (a -> Bool) -> a -> IO ()
failIf_ (CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
/= CInt
1)
         BIO -> IO String
bioRead BIO
mem

{- DER encoding ------------------------------------------------------------- -}

-- |@'writeX509ReqDER' req@ writes a PKCS#10 certificate request to DER string.
writeX509ReqDER :: X509Req -> IO ByteString
writeX509ReqDER :: X509Req -> IO ByteString
writeX509ReqDER X509Req
req
    = do BIO
mem <- IO BIO
newMem
         BIO -> (Ptr BIO_ -> IO ()) -> IO ()
forall a. BIO -> (Ptr BIO_ -> IO a) -> IO a
withBioPtr BIO
mem ((Ptr BIO_ -> IO ()) -> IO ()) -> (Ptr BIO_ -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ Ptr BIO_
memPtr ->
             X509Req -> (Ptr X509_REQ -> IO ()) -> IO ()
forall a. X509Req -> (Ptr X509_REQ -> IO a) -> IO a
withX509ReqPtr X509Req
req ((Ptr X509_REQ -> IO ()) -> IO ())
-> (Ptr X509_REQ -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ Ptr X509_REQ
reqPtr ->
                 Ptr BIO_ -> Ptr X509_REQ -> IO CInt
_req_to_der Ptr BIO_
memPtr Ptr X509_REQ
reqPtr
                      IO CInt -> (CInt -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (CInt -> Bool) -> CInt -> IO ()
forall a. (a -> Bool) -> a -> IO ()
failIf_ (CInt -> CInt -> Bool
forall a. Ord a => a -> a -> Bool
< CInt
0)
         BIO -> IO ByteString
bioReadLBS BIO
mem


-- |@'getVersion' req@ returns the version number of certificate
-- request.
getVersion :: X509Req -> IO Int
getVersion :: X509Req -> IO Int
getVersion X509Req
req
    = X509Req -> (Ptr X509_REQ -> IO Int) -> IO Int
forall a. X509Req -> (Ptr X509_REQ -> IO a) -> IO a
withX509ReqPtr X509Req
req ((Ptr X509_REQ -> IO Int) -> IO Int)
-> (Ptr X509_REQ -> IO Int) -> IO Int
forall a b. (a -> b) -> a -> b
$ \ Ptr X509_REQ
reqPtr ->
      (CLong -> Int) -> IO CLong -> IO Int
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM CLong -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (IO CLong -> IO Int) -> IO CLong -> IO Int
forall a b. (a -> b) -> a -> b
$ Ptr X509_REQ -> IO CLong
_get_version Ptr X509_REQ
reqPtr

-- |@'setVersion' req ver@ updates the version number of certificate
-- request.
setVersion :: X509Req -> Int -> IO ()
setVersion :: X509Req -> Int -> IO ()
setVersion X509Req
req Int
ver
    = X509Req -> (Ptr X509_REQ -> IO ()) -> IO ()
forall a. X509Req -> (Ptr X509_REQ -> IO a) -> IO a
withX509ReqPtr X509Req
req ((Ptr X509_REQ -> IO ()) -> IO ())
-> (Ptr X509_REQ -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ Ptr X509_REQ
reqPtr ->
      Ptr X509_REQ -> CLong -> IO CInt
_set_version Ptr X509_REQ
reqPtr (Int -> CLong
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
ver)
           IO CInt -> (CInt -> IO CInt) -> IO CInt
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (CInt -> Bool) -> CInt -> IO CInt
forall a. (a -> Bool) -> a -> IO a
failIf (CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
/= CInt
1)
           IO CInt -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>  () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- |@'getSubjectName' req wantLongName@ returns the subject name of
-- certificate request. See 'OpenSSL.X509.getSubjectName' of
-- "OpenSSL.X509".
getSubjectName :: X509Req -> Bool -> IO [(String, String)]
getSubjectName :: X509Req -> Bool -> IO [(String, String)]
getSubjectName X509Req
req Bool
wantLongName
    = X509Req
-> (Ptr X509_REQ -> IO [(String, String)]) -> IO [(String, String)]
forall a. X509Req -> (Ptr X509_REQ -> IO a) -> IO a
withX509ReqPtr X509Req
req ((Ptr X509_REQ -> IO [(String, String)]) -> IO [(String, String)])
-> (Ptr X509_REQ -> IO [(String, String)]) -> IO [(String, String)]
forall a b. (a -> b) -> a -> b
$ \ Ptr X509_REQ
reqPtr ->
      do Ptr X509_NAME
namePtr <- Ptr X509_REQ -> IO (Ptr X509_NAME)
_get_subject_name Ptr X509_REQ
reqPtr
         Ptr X509_NAME -> Bool -> IO [(String, String)]
peekX509Name Ptr X509_NAME
namePtr Bool
wantLongName

-- |@'setSubjectName' req name@ updates the subject name of
-- certificate request. See 'OpenSSL.X509.setSubjectName' of
-- "OpenSSL.X509".
setSubjectName :: X509Req -> [(String, String)] -> IO ()
setSubjectName :: X509Req -> [(String, String)] -> IO ()
setSubjectName X509Req
req [(String, String)]
subject
    = X509Req -> (Ptr X509_REQ -> IO ()) -> IO ()
forall a. X509Req -> (Ptr X509_REQ -> IO a) -> IO a
withX509ReqPtr X509Req
req ((Ptr X509_REQ -> IO ()) -> IO ())
-> (Ptr X509_REQ -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ Ptr X509_REQ
reqPtr ->
      [(String, String)] -> (Ptr X509_NAME -> IO ()) -> IO ()
forall a. [(String, String)] -> (Ptr X509_NAME -> IO a) -> IO a
withX509Name [(String, String)]
subject ((Ptr X509_NAME -> IO ()) -> IO ())
-> (Ptr X509_NAME -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ Ptr X509_NAME
namePtr ->
      Ptr X509_REQ -> Ptr X509_NAME -> IO CInt
_set_subject_name Ptr X509_REQ
reqPtr Ptr X509_NAME
namePtr
           IO CInt -> (CInt -> IO CInt) -> IO CInt
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (CInt -> Bool) -> CInt -> IO CInt
forall a. (a -> Bool) -> a -> IO a
failIf (CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
/= CInt
1)
           IO CInt -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>  () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- |@'getPublicKey' req@ returns the public key of the subject of
-- certificate request.
getPublicKey :: X509Req -> IO SomePublicKey
getPublicKey :: X509Req -> IO SomePublicKey
getPublicKey X509Req
req
    = X509Req -> (Ptr X509_REQ -> IO SomePublicKey) -> IO SomePublicKey
forall a. X509Req -> (Ptr X509_REQ -> IO a) -> IO a
withX509ReqPtr X509Req
req ((Ptr X509_REQ -> IO SomePublicKey) -> IO SomePublicKey)
-> (Ptr X509_REQ -> IO SomePublicKey) -> IO SomePublicKey
forall a b. (a -> b) -> a -> b
$ \ Ptr X509_REQ
reqPtr ->
      (Maybe SomePublicKey -> SomePublicKey)
-> IO (Maybe SomePublicKey) -> IO SomePublicKey
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Maybe SomePublicKey -> SomePublicKey
forall a. HasCallStack => Maybe a -> a
fromJust
           ( Ptr X509_REQ -> IO (Ptr EVP_PKEY)
_get_pubkey Ptr X509_REQ
reqPtr
             IO (Ptr EVP_PKEY)
-> (Ptr EVP_PKEY -> IO (Ptr EVP_PKEY)) -> IO (Ptr EVP_PKEY)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Ptr EVP_PKEY -> IO (Ptr EVP_PKEY)
forall a. Ptr a -> IO (Ptr a)
failIfNull
             IO (Ptr EVP_PKEY) -> (Ptr EVP_PKEY -> IO VaguePKey) -> IO VaguePKey
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Ptr EVP_PKEY -> IO VaguePKey
wrapPKeyPtr
             IO VaguePKey
-> (VaguePKey -> IO (Maybe SomePublicKey))
-> IO (Maybe SomePublicKey)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= VaguePKey -> IO (Maybe SomePublicKey)
forall k. PKey k => VaguePKey -> IO (Maybe k)
fromPKey
           )

-- |@'setPublicKey' req@ updates the public key of the subject of
-- certificate request.
setPublicKey :: PublicKey key => X509Req -> key -> IO ()
setPublicKey :: X509Req -> key -> IO ()
setPublicKey X509Req
req key
pkey
    = X509Req -> (Ptr X509_REQ -> IO ()) -> IO ()
forall a. X509Req -> (Ptr X509_REQ -> IO a) -> IO a
withX509ReqPtr X509Req
req  ((Ptr X509_REQ -> IO ()) -> IO ())
-> (Ptr X509_REQ -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ Ptr X509_REQ
reqPtr  ->
      key -> (Ptr EVP_PKEY -> IO ()) -> IO ()
forall k a. PKey k => k -> (Ptr EVP_PKEY -> IO a) -> IO a
withPKeyPtr'   key
pkey ((Ptr EVP_PKEY -> IO ()) -> IO ())
-> (Ptr EVP_PKEY -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ Ptr EVP_PKEY
pkeyPtr ->
      Ptr X509_REQ -> Ptr EVP_PKEY -> IO CInt
_set_pubkey Ptr X509_REQ
reqPtr Ptr EVP_PKEY
pkeyPtr
           IO CInt -> (CInt -> IO CInt) -> IO CInt
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (CInt -> Bool) -> CInt -> IO CInt
forall a. (a -> Bool) -> a -> IO a
failIf (CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
/= CInt
1)
           IO CInt -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>  () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()


-- |@'addExtensions' req [(nid, str)]@
--
-- E.g., nid 85 = 'subjectAltName' http://osxr.org:8080/openssl/source/crypto/objects/objects.h#0476
--
-- (TODO: more docs; NID type)
addExtensions :: X509Req -> [(Int, String)] -> IO CInt
addExtensions :: X509Req -> [(Int, String)] -> IO CInt
addExtensions X509Req
req [(Int, String)]
exts =
  X509Req -> (Ptr X509_REQ -> IO CInt) -> IO CInt
forall a. X509Req -> (Ptr X509_REQ -> IO a) -> IO a
withX509ReqPtr X509Req
req ((Ptr X509_REQ -> IO CInt) -> IO CInt)
-> (Ptr X509_REQ -> IO CInt) -> IO CInt
forall a b. (a -> b) -> a -> b
$ \Ptr X509_REQ
reqPtr -> do
    [Ptr X509_EXT]
extPtrs <- [(Int, String)]
-> ((Int, String) -> IO (Ptr X509_EXT)) -> IO [Ptr X509_EXT]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(Int, String)]
exts (Int, String) -> IO (Ptr X509_EXT)
forall a. Integral a => (a, String) -> IO (Ptr X509_EXT)
make
    [Ptr X509_EXT] -> (Ptr STACK -> IO CInt) -> IO CInt
forall a b. [Ptr a] -> (Ptr STACK -> IO b) -> IO b
withStack [Ptr X509_EXT]
extPtrs ((Ptr STACK -> IO CInt) -> IO CInt)
-> (Ptr STACK -> IO CInt) -> IO CInt
forall a b. (a -> b) -> a -> b
$ Ptr X509_REQ -> Ptr STACK -> IO CInt
_req_add_extensions Ptr X509_REQ
reqPtr

  where
    make :: (a, String) -> IO (Ptr X509_EXT)
make (a
nid, String
str) = String -> (CString -> IO (Ptr X509_EXT)) -> IO (Ptr X509_EXT)
forall a. String -> (CString -> IO a) -> IO a
withCString String
str ((CString -> IO (Ptr X509_EXT)) -> IO (Ptr X509_EXT))
-> (CString -> IO (Ptr X509_EXT)) -> IO (Ptr X509_EXT)
forall a b. (a -> b) -> a -> b
$ Ptr Any -> Ptr Any -> CInt -> CString -> IO (Ptr X509_EXT)
forall a b. Ptr a -> Ptr b -> CInt -> CString -> IO (Ptr X509_EXT)
_ext_create Ptr Any
forall a. Ptr a
nullPtr Ptr Any
forall a. Ptr a
nullPtr (a -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
nid)


-- |@'makeX509FromReq' req cert@ creates an empty X.509 certificate
-- and copies as much data from the request as possible. The resulting
-- certificate doesn't have the following data and it isn't signed so
-- you must fill them and sign it yourself.
--
--   * Serial number
--
--   * Validity (Not Before and Not After)
--
-- Example:
--
-- > import Data.Time.Clock
-- >
-- > genCert :: X509 -> EvpPKey -> Integer -> Int -> X509Req -> IO X509
-- > genCert caCert caKey serial days req
-- >     = do cert <- makeX509FromReq req caCert
-- >          now  <- getCurrentTime
-- >          setSerialNumber cert serial
-- >          setNotBefore cert $ addUTCTime (-1) now
-- >          setNotAfter  cert $ addUTCTime (days * 24 * 60 * 60) now
-- >          signX509 cert caKey Nothing
-- >          return cert
--
makeX509FromReq :: X509Req
                -> X509
                -> IO X509
makeX509FromReq :: X509Req -> X509 -> IO X509
makeX509FromReq X509Req
req X509
caCert
    = do SomePublicKey
reqPubKey <- X509Req -> IO SomePublicKey
getPublicKey X509Req
req
         VerifyStatus
verified  <- X509Req -> SomePublicKey -> IO VerifyStatus
forall key. PublicKey key => X509Req -> key -> IO VerifyStatus
verifyX509Req X509Req
req SomePublicKey
reqPubKey

         Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (VerifyStatus
verified VerifyStatus -> VerifyStatus -> Bool
forall a. Eq a => a -> a -> Bool
== VerifyStatus
VerifyFailure)
                  (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"makeX509FromReq: the request isn't properly signed by its own key."

         X509
cert <- IO X509
Cert.newX509
         X509 -> Int -> IO ()
Cert.setVersion X509
cert Int
2 -- Version 2 means X509 v3. It's confusing.
         X509 -> [(String, String)] -> IO ()
Cert.setIssuerName  X509
cert ([(String, String)] -> IO ()) -> IO [(String, String)] -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< X509 -> Bool -> IO [(String, String)]
Cert.getSubjectName X509
caCert Bool
False
         X509 -> [(String, String)] -> IO ()
Cert.setSubjectName X509
cert ([(String, String)] -> IO ()) -> IO [(String, String)] -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< X509Req -> Bool -> IO [(String, String)]
getSubjectName X509Req
req Bool
False
         X509 -> SomePublicKey -> IO ()
forall key. PublicKey key => X509 -> key -> IO ()
Cert.setPublicKey   X509
cert (SomePublicKey -> IO ()) -> IO SomePublicKey -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< X509Req -> IO SomePublicKey
getPublicKey X509Req
req

         X509 -> IO X509
forall (m :: * -> *) a. Monad m => a -> m a
return X509
cert