{-# LANGUAGE EmptyDataDecls #-}
{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE CApiFFI #-}
{-# OPTIONS_HADDOCK prune #-}
module OpenSSL.X509.Request
(
X509Req
, X509_REQ
, newX509Req
, wrapX509Req
, withX509ReqPtr
, signX509Req
, verifyX509Req
, printX509Req
, writeX509ReqDER
, makeX509FromReq
, 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
newtype X509Req = X509Req (ForeignPtr X509_REQ)
data {-# CTYPE "openssl/x509.h" "X509_REQ" #-} X509_REQ
data X509_EXT
foreign import capi unsafe "openssl/x509.h X509_REQ_new"
_new :: IO (Ptr X509_REQ)
foreign import capi unsafe "openssl/x509.h &X509_REQ_free"
_free :: FunPtr (Ptr X509_REQ -> IO ())
foreign import capi unsafe "openssl/x509.h X509_REQ_sign"
_sign :: Ptr X509_REQ -> Ptr EVP_PKEY -> Ptr EVP_MD -> IO CInt
foreign import capi unsafe "openssl/x509.h X509_REQ_verify"
_verify :: Ptr X509_REQ -> Ptr EVP_PKEY -> IO CInt
foreign import capi unsafe "openssl/x509.h X509_REQ_print"
_print :: Ptr BIO_ -> Ptr X509_REQ -> IO CInt
foreign import capi unsafe "openssl/x509.h i2d_X509_REQ_bio"
_req_to_der :: Ptr BIO_ -> Ptr X509_REQ -> IO CInt
foreign import capi unsafe "HsOpenSSL.h HsOpenSSL_X509_REQ_get_version"
_get_version :: Ptr X509_REQ -> IO CLong
foreign import capi unsafe "openssl/x509.h X509_REQ_set_version"
_set_version :: Ptr X509_REQ -> CLong -> IO CInt
foreign import capi unsafe "HsOpenSSL.h HsOpenSSL_X509_REQ_get_subject_name"
_get_subject_name :: Ptr X509_REQ -> IO (Ptr X509_NAME)
foreign import capi unsafe "openssl/x509.h X509_REQ_set_subject_name"
_set_subject_name :: Ptr X509_REQ -> Ptr X509_NAME -> IO CInt
foreign import capi unsafe "openssl/x509.h X509_REQ_get_pubkey"
_get_pubkey :: Ptr X509_REQ -> IO (Ptr EVP_PKEY)
foreign import capi unsafe "openssl/x509.h X509_REQ_set_pubkey"
_set_pubkey :: Ptr X509_REQ -> Ptr EVP_PKEY -> IO CInt
foreign import capi unsafe "openssl/x509v3.h X509V3_EXT_nconf_nid"
_ext_create :: Ptr a -> Ptr b -> CInt -> CString -> IO (Ptr X509_EXT)
foreign import capi unsafe "openssl/x509.h X509_REQ_add_extensions"
_req_add_extensions :: Ptr X509_REQ -> Ptr STACK -> IO CInt
newX509Req :: IO X509Req
newX509Req :: IO X509Req
newX509Req = IO (Ptr X509_REQ)
_new 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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ForeignPtr X509_REQ -> X509Req
X509Req forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. FinalizerPtr a -> Ptr a -> IO (ForeignPtr a)
newForeignPtr FunPtr (Ptr X509_REQ -> IO ())
_free
withX509ReqPtr :: X509Req -> (Ptr X509_REQ -> IO a) -> IO a
withX509ReqPtr :: forall a. X509Req -> (Ptr X509_REQ -> IO a) -> IO a
withX509ReqPtr (X509Req ForeignPtr X509_REQ
req) = forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr X509_REQ
req
signX509Req :: KeyPair key =>
X509Req
-> key
-> Maybe Digest
-> IO ()
signX509Req :: forall key. KeyPair key => X509Req -> key -> Maybe Digest -> IO ()
signX509Req X509Req
req key
pkey Maybe Digest
mDigest
= forall a. X509Req -> (Ptr X509_REQ -> IO a) -> IO a
withX509ReqPtr X509Req
req forall a b. (a -> b) -> a -> b
$ \ Ptr X509_REQ
reqPtr ->
forall k a. PKey k => k -> (Ptr EVP_PKEY -> IO a) -> IO a
withPKeyPtr' key
pkey forall a b. (a -> b) -> a -> b
$ \ Ptr EVP_PKEY
pkeyPtr ->
do Digest
digest <- case Maybe Digest
mDigest of
Just Digest
md -> forall (m :: * -> *) a. Monad m => a -> m a
return Digest
md
Maybe Digest
Nothing -> forall k. PKey k => k -> IO Digest
pkeyDefaultMD key
pkey
forall a. Digest -> (Ptr EVP_MD -> IO a) -> IO a
withMDPtr Digest
digest 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
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. (a -> Bool) -> a -> IO ()
failIf_ (forall a. Eq a => a -> a -> Bool
== CInt
0)
verifyX509Req :: PublicKey key =>
X509Req
-> key
-> IO VerifyStatus
verifyX509Req :: forall key. PublicKey key => X509Req -> key -> IO VerifyStatus
verifyX509Req X509Req
req key
pkey
= forall a. X509Req -> (Ptr X509_REQ -> IO a) -> IO a
withX509ReqPtr X509Req
req forall a b. (a -> b) -> a -> b
$ \ Ptr X509_REQ
reqPtr ->
forall k a. PKey k => k -> (Ptr EVP_PKEY -> IO a) -> IO a
withPKeyPtr' key
pkey 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
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 = forall (m :: * -> *) a. Monad m => a -> m a
return VerifyStatus
VerifySuccess
interpret CInt
0 = forall (m :: * -> *) a. Monad m => a -> m a
return VerifyStatus
VerifyFailure
interpret CInt
_ = forall a. IO a
raiseOpenSSLError
printX509Req :: X509Req -> IO String
printX509Req :: X509Req -> IO String
printX509Req X509Req
req
= do BIO
mem <- IO BIO
newMem
forall a. BIO -> (Ptr BIO_ -> IO a) -> IO a
withBioPtr BIO
mem forall a b. (a -> b) -> a -> b
$ \ Ptr BIO_
memPtr ->
forall a. X509Req -> (Ptr X509_REQ -> IO a) -> IO a
withX509ReqPtr X509Req
req 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
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. (a -> Bool) -> a -> IO ()
failIf_ (forall a. Eq a => a -> a -> Bool
/= CInt
1)
BIO -> IO String
bioRead BIO
mem
writeX509ReqDER :: X509Req -> IO ByteString
writeX509ReqDER :: X509Req -> IO ByteString
writeX509ReqDER X509Req
req
= do BIO
mem <- IO BIO
newMem
forall a. BIO -> (Ptr BIO_ -> IO a) -> IO a
withBioPtr BIO
mem forall a b. (a -> b) -> a -> b
$ \ Ptr BIO_
memPtr ->
forall a. X509Req -> (Ptr X509_REQ -> IO a) -> IO a
withX509ReqPtr X509Req
req 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
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. (a -> Bool) -> a -> IO ()
failIf_ (forall a. Ord a => a -> a -> Bool
< CInt
0)
BIO -> IO ByteString
bioReadLBS BIO
mem
getVersion :: X509Req -> IO Int
getVersion :: X509Req -> IO Int
getVersion X509Req
req
= forall a. X509Req -> (Ptr X509_REQ -> IO a) -> IO a
withX509ReqPtr X509Req
req forall a b. (a -> b) -> a -> b
$ \ Ptr X509_REQ
reqPtr ->
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ Ptr X509_REQ -> IO CLong
_get_version Ptr X509_REQ
reqPtr
setVersion :: X509Req -> Int -> IO ()
setVersion :: X509Req -> Int -> IO ()
setVersion X509Req
req Int
ver
= forall a. X509Req -> (Ptr X509_REQ -> IO a) -> IO a
withX509ReqPtr X509Req
req forall a b. (a -> b) -> a -> b
$ \ Ptr X509_REQ
reqPtr ->
Ptr X509_REQ -> CLong -> IO CInt
_set_version Ptr X509_REQ
reqPtr (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
ver)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. (a -> Bool) -> a -> IO a
failIf (forall a. Eq a => a -> a -> Bool
/= CInt
1)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return ()
getSubjectName :: X509Req -> Bool -> IO [(String, String)]
getSubjectName :: X509Req -> Bool -> IO [(String, String)]
getSubjectName X509Req
req Bool
wantLongName
= forall a. X509Req -> (Ptr X509_REQ -> IO a) -> IO a
withX509ReqPtr X509Req
req 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 :: X509Req -> [(String, String)] -> IO ()
setSubjectName :: X509Req -> [(String, String)] -> IO ()
setSubjectName X509Req
req [(String, String)]
subject
= forall a. X509Req -> (Ptr X509_REQ -> IO a) -> IO a
withX509ReqPtr X509Req
req forall a b. (a -> b) -> a -> b
$ \ Ptr X509_REQ
reqPtr ->
forall a. [(String, String)] -> (Ptr X509_NAME -> IO a) -> IO a
withX509Name [(String, String)]
subject 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
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. (a -> Bool) -> a -> IO a
failIf (forall a. Eq a => a -> a -> Bool
/= CInt
1)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return ()
getPublicKey :: X509Req -> IO SomePublicKey
getPublicKey :: X509Req -> IO SomePublicKey
getPublicKey X509Req
req
= forall a. X509Req -> (Ptr X509_REQ -> IO a) -> IO a
withX509ReqPtr X509Req
req forall a b. (a -> b) -> a -> b
$ \ Ptr X509_REQ
reqPtr ->
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. HasCallStack => Maybe a -> a
fromJust
( Ptr X509_REQ -> IO (Ptr EVP_PKEY)
_get_pubkey Ptr X509_REQ
reqPtr
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. Ptr a -> IO (Ptr a)
failIfNull
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Ptr EVP_PKEY -> IO VaguePKey
wrapPKeyPtr
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall k. PKey k => VaguePKey -> IO (Maybe k)
fromPKey
)
setPublicKey :: PublicKey key => X509Req -> key -> IO ()
setPublicKey :: forall key. PublicKey key => X509Req -> key -> IO ()
setPublicKey X509Req
req key
pkey
= forall a. X509Req -> (Ptr X509_REQ -> IO a) -> IO a
withX509ReqPtr X509Req
req forall a b. (a -> b) -> a -> b
$ \ Ptr X509_REQ
reqPtr ->
forall k a. PKey k => k -> (Ptr EVP_PKEY -> IO a) -> IO a
withPKeyPtr' key
pkey 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
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. (a -> Bool) -> a -> IO a
failIf (forall a. Eq a => a -> a -> Bool
/= CInt
1)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return ()
addExtensions :: X509Req -> [(Int, String)] -> IO CInt
addExtensions :: X509Req -> [(Int, String)] -> IO CInt
addExtensions X509Req
req [(Int, String)]
exts =
forall a. X509Req -> (Ptr X509_REQ -> IO a) -> IO a
withX509ReqPtr X509Req
req forall a b. (a -> b) -> a -> b
$ \Ptr X509_REQ
reqPtr -> do
[Ptr X509_EXT]
extPtrs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(Int, String)]
exts forall {a}. Integral a => (a, String) -> IO (Ptr X509_EXT)
make
forall a b. [Ptr a] -> (Ptr STACK -> IO b) -> IO b
withStack [Ptr X509_EXT]
extPtrs 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) = forall a. String -> (CString -> IO a) -> IO a
withCString String
str forall a b. (a -> b) -> a -> b
$ forall a b. Ptr a -> Ptr b -> CInt -> CString -> IO (Ptr X509_EXT)
_ext_create forall a. Ptr a
nullPtr forall a. Ptr a
nullPtr (forall a b. (Integral a, Num b) => a -> b
fromIntegral a
nid)
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 <- forall key. PublicKey key => X509Req -> key -> IO VerifyStatus
verifyX509Req X509Req
req SomePublicKey
reqPubKey
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (VerifyStatus
verified forall a. Eq a => a -> a -> Bool
== VerifyStatus
VerifyFailure)
forall a b. (a -> b) -> a -> b
$ 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
X509 -> [(String, String)] -> IO ()
Cert.setIssuerName X509
cert 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 forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< X509Req -> Bool -> IO [(String, String)]
getSubjectName X509Req
req Bool
False
forall key. PublicKey key => X509 -> key -> IO ()
Cert.setPublicKey X509
cert forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< X509Req -> IO SomePublicKey
getPublicKey X509Req
req
forall (m :: * -> *) a. Monad m => a -> m a
return X509
cert