HsOpenSSL-0.7: OpenSSL/X509.hsc

{- -*- haskell -*- -}

{-# OPTIONS_HADDOCK prune #-}

-- |An interface to X.509 certificate.

module OpenSSL.X509
    ( -- * Type
      X509
    , X509_

      -- * Functions to manipulate certificate
    , newX509
    , wrapX509 -- private
    , withX509Ptr -- private
    , withX509Stack -- private
    , unsafeX509ToPtr -- private
    , touchX509 -- private

    , compareX509

    , signX509
    , verifyX509

    , printX509

      -- * Accessors
    , getVersion
    , setVersion

    , getSerialNumber
    , setSerialNumber

    , getIssuerName
    , setIssuerName

    , getSubjectName
    , setSubjectName

    , getNotBefore
    , setNotBefore

    , getNotAfter
    , setNotAfter

    , getPublicKey
    , setPublicKey

    , getSubjectEmail
    )
    where

import           Control.Monad
import           Data.Time.Clock
import           Data.Maybe
import           Foreign
import           Foreign.C
import           OpenSSL.ASN1
import           OpenSSL.BIO
import           OpenSSL.EVP.Digest hiding (digest)
import           OpenSSL.EVP.PKey
import           OpenSSL.EVP.Verify
import           OpenSSL.Utils
import           OpenSSL.Stack
import           OpenSSL.X509.Name

-- |@'X509'@ is an opaque object that represents X.509 certificate.
newtype X509  = X509 (ForeignPtr X509_)
data    X509_


foreign import ccall unsafe "X509_new"
        _new :: IO (Ptr X509_)

foreign import ccall unsafe "&X509_free"
        _free :: FunPtr (Ptr X509_ -> IO ())

foreign import ccall unsafe "X509_print"
        _print :: Ptr BIO_ -> Ptr X509_ -> IO CInt

foreign import ccall unsafe "X509_cmp"
        _cmp :: Ptr X509_ -> Ptr X509_ -> IO CInt

foreign import ccall unsafe "HsOpenSSL_X509_get_version"
        _get_version :: Ptr X509_ -> IO CLong

foreign import ccall unsafe "X509_set_version"
        _set_version :: Ptr X509_ -> CLong -> IO CInt

foreign import ccall unsafe "X509_get_serialNumber"
        _get_serialNumber :: Ptr X509_ -> IO (Ptr ASN1_INTEGER)

foreign import ccall unsafe "X509_set_serialNumber"
        _set_serialNumber :: Ptr X509_ -> Ptr ASN1_INTEGER -> IO CInt

foreign import ccall unsafe "X509_get_issuer_name"
        _get_issuer_name :: Ptr X509_ -> IO (Ptr X509_NAME)

foreign import ccall unsafe "X509_set_issuer_name"
        _set_issuer_name :: Ptr X509_ -> Ptr X509_NAME -> IO CInt

foreign import ccall unsafe "X509_get_subject_name"
        _get_subject_name :: Ptr X509_ -> IO (Ptr X509_NAME)

foreign import ccall unsafe "X509_set_subject_name"
        _set_subject_name :: Ptr X509_ -> Ptr X509_NAME -> IO CInt

foreign import ccall unsafe "HsOpenSSL_X509_get_notBefore"
        _get_notBefore :: Ptr X509_ -> IO (Ptr ASN1_TIME)

foreign import ccall unsafe "X509_set_notBefore"
        _set_notBefore :: Ptr X509_ -> Ptr ASN1_TIME -> IO CInt

foreign import ccall unsafe "HsOpenSSL_X509_get_notAfter"
        _get_notAfter :: Ptr X509_ -> IO (Ptr ASN1_TIME)

foreign import ccall unsafe "X509_set_notAfter"
        _set_notAfter :: Ptr X509_ -> Ptr ASN1_TIME -> IO CInt

foreign import ccall unsafe "X509_get_pubkey"
        _get_pubkey :: Ptr X509_ -> IO (Ptr EVP_PKEY)

foreign import ccall unsafe "X509_set_pubkey"
        _set_pubkey :: Ptr X509_ -> Ptr EVP_PKEY -> IO CInt

foreign import ccall unsafe "X509_get1_email"
        _get1_email :: Ptr X509_ -> IO (Ptr STACK)

foreign import ccall unsafe "X509_email_free"
        _email_free :: Ptr STACK -> IO ()

foreign import ccall unsafe "X509_sign"
        _sign :: Ptr X509_ -> Ptr EVP_PKEY -> Ptr EVP_MD -> IO CInt

foreign import ccall unsafe "X509_verify"
        _verify :: Ptr X509_ -> Ptr EVP_PKEY -> IO CInt

-- |@'newX509'@ creates an empty certificate. You must set the
-- following properties to and sign it (see 'signX509') to actually
-- use the certificate.
--
--   [/Version/] See 'setVersion'.
--
--   [/Serial number/] See 'setSerialNumber'.
--
--   [/Issuer name/] See 'setIssuerName'.
--
--   [/Subject name/] See 'setSubjectName'.
--
--   [/Validity/] See 'setNotBefore' and 'setNotAfter'.
--
--   [/Public Key/] See 'setPublicKey'.
--
newX509 :: IO X509
newX509 = _new >>= failIfNull >>= wrapX509


wrapX509 :: Ptr X509_ -> IO X509
wrapX509 x509Ptr = newForeignPtr _free x509Ptr >>= return . X509


withX509Ptr :: X509 -> (Ptr X509_ -> IO a) -> IO a
withX509Ptr (X509 x509) = withForeignPtr x509


withX509Stack :: [X509] -> (Ptr STACK -> IO a) -> IO a
withX509Stack = withForeignStack unsafeX509ToPtr touchX509


unsafeX509ToPtr :: X509 -> Ptr X509_
unsafeX509ToPtr (X509 x509) = unsafeForeignPtrToPtr x509


touchX509 :: X509 -> IO ()
touchX509 (X509 x509) = touchForeignPtr x509

-- |@'compareX509' cert1 cert2@ compares two certificates.
compareX509 :: X509 -> X509 -> IO Ordering
compareX509 cert1 cert2
    = withX509Ptr cert1 $ \ cert1Ptr ->
      withX509Ptr cert2 $ \ cert2Ptr ->
      _cmp cert1Ptr cert2Ptr >>= return . interpret
    where
      interpret :: CInt -> Ordering
      interpret n
          | n > 0     = GT
          | n < 0     = LT
          | otherwise = EQ

-- |@'signX509'@ signs a certificate with an issuer private key.
signX509 :: KeyPair key =>
            X509         -- ^ The certificate 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 ()
signX509 x509 key mDigest
    = withX509Ptr x509 $ \ x509Ptr ->
      withPKeyPtr' key $ \ pkeyPtr ->
      do digest <- case mDigest of
                     Just md -> return md
                     Nothing -> pkeyDefaultMD key
         withMDPtr digest $ \ digestPtr ->
             _sign x509Ptr pkeyPtr digestPtr
                  >>= failIf_ (== 0)
         return ()

-- |@'verifyX509'@ verifies a signature of certificate with an issuer
-- public key.
verifyX509 :: PublicKey key =>
              X509 -- ^ The certificate to be verified.
           -> key  -- ^ The public key to verify with.
           -> IO VerifyStatus
verifyX509 x509 key
    = withX509Ptr x509 $ \ x509Ptr ->
      withPKeyPtr' key $ \ pkeyPtr ->
      _verify x509Ptr pkeyPtr
           >>= interpret
    where
      interpret :: CInt -> IO VerifyStatus
      interpret 1 = return VerifySuccess
      interpret 0 = return VerifyFailure
      interpret _ = raiseOpenSSLError

-- |@'printX509' cert@ translates a certificate into human-readable
-- format.
printX509 :: X509 -> IO String
printX509 x509
    = do mem <- newMem
         withX509Ptr x509 $ \ x509Ptr ->
             withBioPtr mem $ \ memPtr ->
                 _print memPtr x509Ptr
                      >>= failIf_ (/= 1)
         bioRead mem

-- |@'getVersion' cert@ returns the version number of certificate. It
-- seems the number is 0-origin: version 2 means X.509 v3.
getVersion :: X509 -> IO Int
getVersion x509
    = withX509Ptr x509 $ \ x509Ptr ->
      liftM fromIntegral $ _get_version x509Ptr

-- |@'setVersion' cert ver@ updates the version number of certificate.
setVersion :: X509 -> Int -> IO ()
setVersion x509 ver
    = withX509Ptr x509 $ \ x509Ptr ->
      _set_version x509Ptr (fromIntegral ver)
           >>= failIf (/= 1)
           >>  return ()

-- |@'getSerialNumber' cert@ returns the serial number of certificate.
getSerialNumber :: X509 -> IO Integer
getSerialNumber x509
    = withX509Ptr x509 $ \ x509Ptr ->
      _get_serialNumber x509Ptr
           >>= peekASN1Integer

-- |@'setSerialNumber' cert num@ updates the serial number of
-- certificate.
setSerialNumber :: X509 -> Integer -> IO ()
setSerialNumber x509 serial
    = withX509Ptr x509 $ \ x509Ptr ->
      withASN1Integer serial $ \ serialPtr ->
      _set_serialNumber x509Ptr serialPtr
           >>= failIf (/= 1)
           >>  return ()

-- |@'getIssuerName'@ returns the issuer name of certificate.
getIssuerName :: X509 -- ^ The certificate to examine.
              -> Bool -- ^ @True@ if you want the keys of each parts
                      --   to be of long form (e.g. \"commonName\"),
                      --   or @False@ if you don't (e.g. \"CN\").
              -> IO [(String, String)] -- ^ Pairs of key and value,
                                       -- for example \[(\"C\",
                                       -- \"JP\"), (\"ST\",
                                       -- \"Some-State\"), ...\].
getIssuerName x509 wantLongName
    = withX509Ptr x509 $ \ x509Ptr ->
      do namePtr <- _get_issuer_name x509Ptr
         peekX509Name namePtr wantLongName

-- |@'setIssuerName' cert name@ updates the issuer name of
-- certificate. Keys of each parts may be of either long form or short
-- form. See 'getIssuerName'.
setIssuerName :: X509 -> [(String, String)] -> IO ()
setIssuerName x509 issuer
    = withX509Ptr x509 $ \ x509Ptr ->
      withX509Name issuer $ \ namePtr ->
      _set_issuer_name x509Ptr namePtr
           >>= failIf (/= 1)
           >>  return ()

-- |@'getSubjectName' cert wantLongName@ returns the subject name of
-- certificate. See 'getIssuerName'.
getSubjectName :: X509 -> Bool -> IO [(String, String)]
getSubjectName x509 wantLongName
    = withX509Ptr x509 $ \ x509Ptr ->
      do namePtr <- _get_subject_name x509Ptr
         peekX509Name namePtr wantLongName

-- |@'setSubjectName' cert name@ updates the subject name of
-- certificate. See 'setIssuerName'.
setSubjectName :: X509 -> [(String, String)] -> IO ()
setSubjectName x509 subject
    = withX509Ptr x509 $ \ x509Ptr ->
      withX509Name subject $ \ namePtr ->
      _set_subject_name x509Ptr namePtr
           >>= failIf (/= 1)
           >>  return ()

-- |@'getNotBefore' cert@ returns the time when the certificate begins
-- to be valid.
getNotBefore :: X509 -> IO UTCTime
getNotBefore x509
    = withX509Ptr x509 $ \ x509Ptr ->
      _get_notBefore x509Ptr
           >>= peekASN1Time

-- |@'setNotBefore' cert utc@ updates the time when the certificate
-- begins to be valid.
setNotBefore :: X509 -> UTCTime -> IO ()
setNotBefore x509 utc
    = withX509Ptr x509 $ \ x509Ptr ->
      withASN1Time utc $ \ time ->
      _set_notBefore x509Ptr time
           >>= failIf (/= 1)
           >>  return ()

-- |@'getNotAfter' cert@ returns the time when the certificate
-- expires.
getNotAfter :: X509 -> IO UTCTime
getNotAfter x509
    = withX509Ptr x509 $ \ x509Ptr ->
      _get_notAfter x509Ptr
           >>= peekASN1Time

-- |@'setNotAfter' cert utc@ updates the time when the certificate
-- expires.
setNotAfter :: X509 -> UTCTime -> IO ()
setNotAfter x509 utc
    = withX509Ptr x509 $ \ x509Ptr ->
      withASN1Time utc $ \ time ->
      _set_notAfter x509Ptr time
           >>= failIf (/= 1)
           >>  return ()

-- |@'getPublicKey' cert@ returns the public key of the subject of
-- certificate.
getPublicKey :: X509 -> IO SomePublicKey
getPublicKey x509
    = withX509Ptr x509 $ \ x509Ptr ->
      _get_pubkey x509Ptr
           >>= failIfNull
           >>= wrapPKeyPtr
           >>= fromPKey
           >>= return . fromJust

-- |@'setPublicKey' cert pubkey@ updates the public key of the subject
-- of certificate.
setPublicKey :: PublicKey key => X509 -> key -> IO ()
setPublicKey x509 key
    = withX509Ptr x509 $ \ x509Ptr ->
      withPKeyPtr' key $ \ pkeyPtr ->
      _set_pubkey x509Ptr pkeyPtr
           >>= failIf (/= 1)
           >>  return ()

-- |@'getSubjectEmail' cert@ returns every subject email addresses in
-- the certificate.
getSubjectEmail :: X509 -> IO [String]
getSubjectEmail x509
    = withX509Ptr x509 $ \ x509Ptr ->
      do st   <- _get1_email x509Ptr
         list <- mapStack peekCString st
         _email_free st
         return list