{-# LANGUAGE DeriveDataTypeable       #-}
{-# LANGUAGE EmptyDataDecls           #-}
{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE CApiFFI                  #-}
{-# OPTIONS_HADDOCK prune             #-}
-- |An interface to Certificate Revocation List.
module OpenSSL.X509.Revocation
    ( -- * Types
      CRL
    , X509_CRL -- privae
    , RevokedCertificate(..)

      -- * Functions to manipulate revocation list
    , newCRL
    , wrapCRL -- private
    , withCRLPtr -- private

    , signCRL
    , verifyCRL

    , printCRL

    , sortCRL

      -- * Accessors
    , getVersion
    , setVersion

    , getLastUpdate
    , setLastUpdate

    , getNextUpdate
    , setNextUpdate

    , getIssuerName
    , setIssuerName

    , getRevokedList
    , addRevoked
    , getRevoked
    )
    where
#include "HsOpenSSL.h"
import Control.Monad
#if OPENSSL_VERSION_NUMBER < 0x10000000
import Data.List
#endif
import Data.Time.Clock
import Data.Typeable
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.EVP.Internal
import OpenSSL.Stack
import OpenSSL.Utils
import OpenSSL.X509.Name

-- |@'CRL'@ is an opaque object that represents Certificate Revocation
-- List.
newtype CRL          = CRL (ForeignPtr X509_CRL)
data {-# CTYPE "openssl/x509.h" "X509_CRL" #-} X509_CRL
data {-# CTYPE "openssl/x509.h" "X509_REVOKED" #-} X509_REVOKED

-- |@'RevokedCertificate'@ represents a revoked certificate in a
-- list. Each certificates are supposed to be distinguishable by
-- issuer name and serial number, so it is sufficient to have only
-- serial number on each entries.
data RevokedCertificate
    = RevokedCertificate {
        revSerialNumber   :: Integer
      , revRevocationDate :: UTCTime
      }
    deriving (Show, Eq, Typeable)


foreign import capi unsafe "openssl/x509.h X509_CRL_new"
        _new :: IO (Ptr X509_CRL)

foreign import capi unsafe "openssl/x509.h &X509_CRL_free"
        _free :: FunPtr (Ptr X509_CRL -> IO ())

foreign import capi unsafe "openssl/x509.h X509_CRL_sign"
        _sign :: Ptr X509_CRL -> Ptr EVP_PKEY -> Ptr EVP_MD -> IO CInt

foreign import capi unsafe "openssl/x509.h X509_CRL_verify"
        _verify :: Ptr X509_CRL -> Ptr EVP_PKEY -> IO CInt

foreign import capi unsafe "openssl/x509.h X509_CRL_print"
        _print :: Ptr BIO_ -> Ptr X509_CRL -> IO CInt

foreign import capi unsafe "HsOpenSSL.h HsOpenSSL_X509_CRL_get_version"
        _get_version :: Ptr X509_CRL -> IO CLong

foreign import capi unsafe "openssl/x509.h X509_CRL_set_version"
        _set_version :: Ptr X509_CRL -> CLong -> IO CInt

foreign import capi unsafe "HsOpenSSL.h HsOpenSSL_X509_CRL_get_lastUpdate"
        _get_lastUpdate :: Ptr X509_CRL -> IO (Ptr ASN1_TIME)

foreign import capi unsafe "HsOpenSSL.h HsOpenSSL_X509_CRL_get_nextUpdate"
        _get_nextUpdate :: Ptr X509_CRL -> IO (Ptr ASN1_TIME)

#if OPENSSL_VERSION_NUMBER >= 0x10100000L
foreign import capi unsafe "openssl/x509.h X509_CRL_set1_lastUpdate"
        _set_lastUpdate :: Ptr X509_CRL -> Ptr ASN1_TIME -> IO CInt

foreign import capi unsafe "openssl/x509.h X509_CRL_set1_nextUpdate"
        _set_nextUpdate :: Ptr X509_CRL -> Ptr ASN1_TIME -> IO CInt
#else
foreign import capi unsafe "openssl/x509.h X509_CRL_set_lastUpdate"
        _set_lastUpdate :: Ptr X509_CRL -> Ptr ASN1_TIME -> IO CInt

foreign import capi unsafe "openssl/x509.h X509_CRL_set_nextUpdate"
        _set_nextUpdate :: Ptr X509_CRL -> Ptr ASN1_TIME -> IO CInt
#endif

foreign import capi unsafe "HsOpenSSL.h HsOpenSSL_X509_CRL_get_issuer"
        _get_issuer_name :: Ptr X509_CRL -> IO (Ptr X509_NAME)

foreign import capi unsafe "openssl/x509.h X509_CRL_set_issuer_name"
        _set_issuer_name :: Ptr X509_CRL -> Ptr X509_NAME -> IO CInt

foreign import capi unsafe "HsOpenSSL.h HsOpenSSL_X509_CRL_get_REVOKED"
        _get_REVOKED :: Ptr X509_CRL -> IO (Ptr STACK)

foreign import capi unsafe "openssl/x509.h X509_CRL_add0_revoked"
        _add0_revoked :: Ptr X509_CRL -> Ptr X509_REVOKED -> IO CInt

#if OPENSSL_VERSION_NUMBER >= 0x10000000
-- This function is only available on OpenSSL 1.0.0 or later.
foreign import capi unsafe "openssl/x509.h X509_CRL_get0_by_serial"
        _get0_by_serial :: Ptr X509_CRL -> Ptr (Ptr X509_REVOKED)
                        -> Ptr ASN1_INTEGER -> IO CInt
#endif

foreign import capi unsafe "openssl/x509.h X509_CRL_sort"
        _sort :: Ptr X509_CRL -> IO CInt



foreign import capi unsafe "openssl/x509.h X509_REVOKED_new"
        _new_revoked :: IO (Ptr X509_REVOKED)

foreign import capi unsafe "openssl/x509.h X509_REVOKED_free"
        freeRevoked :: Ptr X509_REVOKED -> IO ()

foreign import capi unsafe "openssl/x509.h X509_REVOKED_set_serialNumber"
        _set_serialNumber :: Ptr X509_REVOKED -> Ptr ASN1_INTEGER -> IO CInt

foreign import capi unsafe "openssl/x509.h X509_REVOKED_set_revocationDate"
        _set_revocationDate :: Ptr X509_REVOKED -> Ptr ASN1_TIME -> IO CInt

-- |@'newCRL'@ creates an empty revocation list. You must set the
-- following properties to and sign it (see 'signCRL') to actually use
-- the revocation list. If you have any certificates to be listed, you
-- must of course add them (see 'addRevoked') before signing the list.
--
--   [/Version/] See 'setVersion'.
--
--   [/Last Update/] See 'setLastUpdate'.
--
--   [/Next Update/] See 'setNextUpdate'.
--
--   [/Issuer Name/] See 'setIssuerName'.
--
newCRL :: IO CRL
newCRL = _new >>= wrapCRL


wrapCRL :: Ptr X509_CRL -> IO CRL
wrapCRL = fmap CRL . newForeignPtr _free


withCRLPtr :: CRL -> (Ptr X509_CRL -> IO a) -> IO a
withCRLPtr (CRL crl) = withForeignPtr crl

-- |@'signCRL'@ signs a revocation list with an issuer private key.
signCRL :: KeyPair key =>
           CRL          -- ^ The revocation list 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 ()
signCRL crl key mDigest
    = withCRLPtr crl   $ \ crlPtr  ->
      withPKeyPtr' key $ \ pkeyPtr ->
      do digest <- case mDigest of
                     Just md -> return md
                     Nothing -> pkeyDefaultMD key
         withMDPtr digest $ \ digestPtr ->
             _sign crlPtr pkeyPtr digestPtr
                  >>= failIf_ (== 0)
         return ()

-- |@'verifyCRL'@ verifies a signature of revocation list with an
-- issuer public key.
verifyCRL :: PublicKey key => CRL -> key -> IO VerifyStatus
verifyCRL crl key
    = withCRLPtr crl   $ \ crlPtr ->
      withPKeyPtr' key $ \ pkeyPtr ->
      _verify crlPtr pkeyPtr
           >>= interpret
    where
      interpret :: CInt -> IO VerifyStatus
      interpret 1 = return VerifySuccess
      interpret 0 = return VerifyFailure
      interpret _ = raiseOpenSSLError

-- |@'printCRL'@ translates a revocation list into human-readable
-- format.
printCRL :: CRL -> IO String
printCRL crl
    = do mem <- newMem
         withBioPtr mem $ \ memPtr ->
             withCRLPtr crl $ \ crlPtr ->
                 _print memPtr crlPtr
                      >>= failIf_ (/= 1)
         bioRead mem

-- |@'getVersion' crl@ returns the version number of revocation list.
getVersion :: CRL -> IO Int
getVersion crl
    = withCRLPtr crl $ \ crlPtr ->
      liftM fromIntegral $ _get_version crlPtr

-- |@'setVersion' crl ver@ updates the version number of revocation
-- list.
setVersion :: CRL -> Int -> IO ()
setVersion crl ver
    = withCRLPtr crl $ \ crlPtr ->
      _set_version crlPtr (fromIntegral ver)
           >>= failIf (/= 1)
           >>  return ()

-- |@'getLastUpdate' crl@ returns the time when the revocation list
-- has last been updated.
getLastUpdate :: CRL -> IO UTCTime
getLastUpdate crl
    = withCRLPtr crl $ \ crlPtr ->
      _get_lastUpdate crlPtr
           >>= peekASN1Time

-- |@'setLastUpdate' crl utc@ updates the time when the revocation
-- list has last been updated.
setLastUpdate :: CRL -> UTCTime -> IO ()
setLastUpdate crl utc
    = withCRLPtr crl $ \ crlPtr ->
      withASN1Time utc $ \ time ->
      _set_lastUpdate crlPtr time
           >>= failIf (/= 1)
           >>  return ()

-- |@'getNextUpdate' crl@ returns the time when the revocation list
-- will next be updated.
getNextUpdate :: CRL -> IO UTCTime
getNextUpdate crl
    = withCRLPtr crl $ \ crlPtr ->
      _get_nextUpdate crlPtr
           >>= peekASN1Time

-- |@'setNextUpdate' crl utc@ updates the time when the revocation
-- list will next be updated.
setNextUpdate :: CRL -> UTCTime -> IO ()
setNextUpdate crl utc
    = withCRLPtr crl $ \ crlPtr ->
      withASN1Time utc $ \ time ->
      _set_nextUpdate crlPtr time
           >>= failIf (/= 1)
           >>  return ()

-- |@'getIssuerName' crl wantLongName@ returns the issuer name of
-- revocation list. See 'OpenSSL.X509.getIssuerName' of
-- "OpenSSL.X509".
getIssuerName :: CRL -> Bool -> IO [(String, String)]
getIssuerName crl wantLongName
    = withCRLPtr crl $ \ crlPtr ->
      do namePtr <- _get_issuer_name crlPtr
         peekX509Name namePtr wantLongName

-- |@'setIssuerName' crl name@ updates the issuer name of revocation
-- list. See 'OpenSSL.X509.setIssuerName' of "OpenSSL.X509".
setIssuerName :: CRL -> [(String, String)] -> IO ()
setIssuerName crl issuer
    = withCRLPtr crl  $ \ crlPtr  ->
      withX509Name issuer $ \ namePtr ->
      _set_issuer_name crlPtr namePtr
           >>= failIf (/= 1)
           >>  return ()

-- |@'getRevokedList' crl@ returns the list of revoked certificates.
getRevokedList :: CRL -> IO [RevokedCertificate]
getRevokedList crl
    = withCRLPtr crl $ \ crlPtr ->
        _get_REVOKED crlPtr >>= mapStack peekRevoked

getSerialNumber :: Ptr X509_REVOKED -> IO (Ptr ASN1_INTEGER)
getRevocationDate :: Ptr X509_REVOKED -> IO (Ptr ASN1_TIME)

#if OPENSSL_VERSION_NUMBER >= 0x10100000L

foreign import capi unsafe "openssl/x509.h X509_REVOKED_get0_serialNumber"
        _get0_serialNumber :: Ptr X509_REVOKED -> IO (Ptr ASN1_INTEGER)

foreign import capi unsafe "openssl/x509.h X509_REVOKED_get0_revocationDate"
        _get0_revocationDate :: Ptr X509_REVOKED -> IO (Ptr ASN1_TIME)

getSerialNumber = _get0_serialNumber
getRevocationDate = _get0_revocationDate

#else

getSerialNumber = (#peek X509_REVOKED, serialNumber  )
getRevocationDate = (#peek X509_REVOKED, revocationDate)

#endif

peekRevoked :: Ptr X509_REVOKED -> IO RevokedCertificate
peekRevoked rev = do
  serial <- peekASN1Integer =<< getSerialNumber rev
  date   <- peekASN1Time    =<< getRevocationDate rev
  return RevokedCertificate { revSerialNumber   = serial
                            , revRevocationDate = date
                            }

newRevoked :: RevokedCertificate -> IO (Ptr X509_REVOKED)
newRevoked revoked
    = do revPtr  <- _new_revoked

         seriRet <- withASN1Integer (revSerialNumber revoked) $
                    _set_serialNumber revPtr

         dateRet <- withASN1Time (revRevocationDate revoked) $
                    _set_revocationDate revPtr

         if seriRet /= 1 || dateRet /= 1 then
             freeRevoked revPtr >> raiseOpenSSLError
           else
             return revPtr

-- |@'addRevoked' crl revoked@ add the certificate to the revocation
-- list.
addRevoked :: CRL -> RevokedCertificate -> IO ()
addRevoked crl revoked
    = withCRLPtr crl $ \ crlPtr ->
      do revPtr <- newRevoked revoked
         ret    <- _add0_revoked crlPtr revPtr
         case ret of
           1 -> return ()
           _ -> freeRevoked revPtr >> raiseOpenSSLError

-- |@'getRevoked' crl serial@ looks up the corresponding revocation.
getRevoked :: CRL -> Integer -> IO (Maybe RevokedCertificate)
#if OPENSSL_VERSION_NUMBER >= 0x10000000
getRevoked crl serial =
  withCRLPtr crl  $ \crlPtr ->
  alloca          $ \revPtr ->
  withASN1Integer serial $ \serialPtr -> do
    r <- _get0_by_serial crlPtr revPtr serialPtr
    if r == 1
      then fmap Just $ peek revPtr >>= peekRevoked
      else return Nothing
#else
getRevoked crl serial = find p `fmap` getRevokedList crl
    where
      p :: RevokedCertificate -> Bool
      p = ((==) serial) . revSerialNumber
#endif

-- |@'sortCRL' crl@ sorts the certificates in the revocation list.
sortCRL :: CRL -> IO ()
sortCRL crl
    = withCRLPtr crl $ \ crlPtr ->
        _sort crlPtr >>= failIf_ (/= 1)