module Network.GnuTLS.X509 (
Certificate(),
PrivateKey(),
--newCertificate,
--newPrivateKey,
importCertificate,
importPrivateKey,
exportCertificate,
exportPrivateKey,
verifySignature,
signData,
certificateRSAParameters,
privateKeyRSAParameters,
privateKeyGetKeyId,
certificateGetKeyId,
getIssuerDnByOid,
getDnByOid,
getExtensionByOid,
checkHostname,
checkIssuer,
)
where
import Foreign
import Foreign.C
import Network.GnuTLS.Attributes
import Network.GnuTLS.GnuTLS
import Network.GnuTLS.Internals
import Network.GnuTLS.GnuTLSMonad
import Network.GnuTLS.Errors
import Network.GnuTLS.OID
import System.Time(ClockTime(TOD))
import Data.ByteString.Internal
import System.Time
newtype Certificate = Certificate (ForeignPtr (Certificate))
withCertificate (Certificate fptr) = withForeignPtr fptr
newtype PrivateKey = PrivateKey (ForeignPtr (PrivateKey))
withPrivateKey (PrivateKey fptr) = withForeignPtr fptr
newtype CertificateRevocationList = CertificateRevocationList (ForeignPtr (CertificateRevocationList))
withCertificateRevocationList (CertificateRevocationList fptr) = withForeignPtr fptr
instance Show PrivateKey where
show _ = "<PrivateKey>"
instance Show Certificate where
show _ = "<Certificate>"
foreign import ccall unsafe "TLS.h &gnutls_x509_crt_deinit" gnutls_x509_crt_deinit :: FunPtr (Ptr Certificate -> IO ())
foreign import ccall unsafe "TLS.h gnutls_x509_crt_init" gnutls_x509_crt_init :: Ptr (Ptr Certificate) -> IO CInt
foreign import ccall unsafe "TLS.h &gnutls_x509_privkey_deinit" gnutls_x509_privkey_deinit :: FunPtr (Ptr PrivateKey -> IO ())
foreign import ccall unsafe "TLS.h gnutls_x509_privkey_init" gnutls_x509_privkey_init :: Ptr (Ptr PrivateKey) -> IO CInt
importCertificate :: Datum d => d -> X509CertificateFormat -> GnuTLSMonad Certificate
importCertificate dat form = unsafePerformIO $ withDatum dat $
\rdat -> alloca $ \ptr -> do
res <- gnutls_x509_crt_init ptr
if res/=0 then return (Left $ GnuTLSError res)
else do
fp <- newForeignPtr gnutls_x509_crt_deinit =<< peek ptr
res2 <- withForeignPtr fp (\cr -> gnutls_x509_crt_import cr rdat (enumCInt form))
if res2/=0 then return (Left $ GnuTLSError res2)
else return (Right $ Certificate fp)
importPrivateKey :: Datum d => d -> X509CertificateFormat -> GnuTLSMonad PrivateKey
importPrivateKey dat form = unsafePerformIO $ withDatum dat $
\rdat -> alloca $ \ptr -> do
res <- gnutls_x509_privkey_init ptr
if res/=0 then return (Left $ GnuTLSError res)
else do
fp <- newForeignPtr gnutls_x509_privkey_deinit =<< peek ptr
res2 <- withForeignPtr fp (\cr -> gnutls_x509_privkey_import cr rdat (enumCInt form))
if res2/=0 then return (Left $ GnuTLSError res2)
else return (Right $ PrivateKey fp)
exportCertificate :: Certificate -> X509CertificateFormat -> GnuTLSMonad ByteString
exportCertificate cert form = unsafePerformIO $ exportCertificate'' cert form 1024
exportPrivateKey :: PrivateKey -> X509CertificateFormat -> GnuTLSMonad ByteString
exportPrivateKey key form = unsafePerformIO $ export'' (exportPrivateKey' key form) 1024
export'' :: (Ptr () -> Ptr CSize -> IO CInt) -> Int -> IO (GnuTLSMonad ByteString)
export'' f sz = do
(str,res) <- createAndTrim' sz $ \ptr -> with (fromIntegral sz) $ \szptr -> do
res <- f (castPtr ptr) szptr
case () of
() | res==0 -> do
rsize <- peek szptr
return (0,fromIntegral rsize,Nothing)
| res==errorShortMemory -> return (0,0,Just Nothing)
| otherwise -> return (0,0,Just $ Just res)
case res of
Nothing -> return $ Right str
Just Nothing -> export'' f (sz+1024)
Just (Just err) -> return $ Left (GnuTLSError err)
exportCertificate'' :: Certificate -> X509CertificateFormat -> Int -> IO (GnuTLSMonad ByteString)
exportCertificate'' cert format sz = export'' (exportCertificate' cert format) sz
exportCertificate' :: Certificate -> X509CertificateFormat -> Ptr () -> Ptr CSize -> IO CInt
exportCertificate' cert format ptr sptr = withCertificate cert $ \cp -> gnutls_x509_crt_export cp (enumCInt format) ptr (castPtr sptr)
exportPrivateKey' :: PrivateKey -> X509CertificateFormat -> Ptr () -> Ptr CSize -> IO CInt
exportPrivateKey' key format ptr sptr = withPrivateKey key $ \cp -> gnutls_x509_privkey_export cp (enumCInt format) ptr (castPtr sptr)
getExpirationTime :: Certificate -> IO (ClockTime)
getExpirationTime a1 =
withCertificate a1 $ \a1' ->
getExpirationTime'_ a1' >>= \res ->
toTime res >>= \res' ->
return (res')
toTime :: Integral n => n -> IO ClockTime
toTime (1) = fail "Error while getting time"
toTime x = return $ TOD (fromIntegral x) 0
verifySignature :: (Datum dat,Datum sign) => Certificate -> dat -> sign -> GnuTLSMonad Bool
verifySignature cert dat sig = unsafePerformIO $ withCertificate cert $
\rcert -> withDatum dat $
\rdat -> withDatum sig $
\rsig -> do
res <- gnutls_x509_crt_verify_data rcert 0 rdat rsig
case () of
() | res == 0 -> return $ Right False
| res == 1 -> return $ Right True
| otherwise -> return $ Left $ GnuTLSError res
signData :: Datum d => PrivateKey -> DigestAlgorithm -> d -> GnuTLSMonad ByteString
signData key alg dat = unsafePerformIO $ signData'' key alg dat 1024
signData'' :: Datum d => PrivateKey -> DigestAlgorithm -> d -> Int -> IO (GnuTLSMonad ByteString)
signData'' key alg dat sz = do
(str,res) <- createAndTrim' sz $ \ptr -> with (fromIntegral sz) $ \szptr -> do
res <- signData' key alg dat (castPtr ptr) szptr
case () of
() | res==0 -> do
rsize <- peek szptr
return (0,fromIntegral rsize,Nothing)
| res==errorShortMemory -> return (0,0,Just Nothing)
| otherwise -> return (0,0,Just $ Just res)
case res of
Nothing -> return $ Right str
Just Nothing -> signData'' key alg dat (sz+1024)
Just (Just err) -> return $ Left (GnuTLSError err)
signData' :: Datum d => PrivateKey -> DigestAlgorithm -> d -> Ptr () -> Ptr CSize -> IO CInt
signData' priv alg dat strptr sptr = withPrivateKey priv $
\rpriv -> withDatum dat $
\rdat -> gnutls_x509_privkey_sign_data rpriv (enumCInt alg) 0 rdat strptr (castPtr sptr)
certificateRSAParameters :: Certificate -> GnuTLSMonad (ByteString,ByteString)
certificateRSAParameters cert = unsafePerformIO $ withCertificate cert $
\rcert -> alloca $ \(ptrM::Ptr (Ptr ())) -> alloca $
\(ptrE::Ptr (Ptr ())) -> do
res <- gnutls_x509_crt_get_pk_rsa_raw rcert (castPtr ptrM) (castPtr ptrE)
if res/=0 then return $ Left (GnuTLSError res)
else do
(cptrM,sizeM) <- peekDatum ptrM
(cptrE,sizeE) <- peekDatum ptrE
fpM <- newForeignPtr c_free_finalizer (castPtr cptrM)
fpE <- newForeignPtr c_free_finalizer (castPtr cptrE)
return $ Right (fromForeignPtr fpM 0 sizeM,fromForeignPtr fpE 0 sizeE)
privateKeyRSAParameters :: PrivateKey -> GnuTLSMonad (ByteString,ByteString,ByteString,ByteString,ByteString,ByteString)
privateKeyRSAParameters key = unsafePerformIO $ withPrivateKey key $
\rkey -> alloca $
\(ptrM::Ptr (Ptr ())) -> alloca $
\(ptrE::Ptr (Ptr ())) -> alloca $
\(ptrD::Ptr (Ptr ())) -> alloca $
\(ptrP::Ptr (Ptr ())) -> alloca $
\(ptrQ::Ptr (Ptr ())) -> alloca $
\(ptrU::Ptr (Ptr ())) -> do
res <- gnutls_x509_privkey_export_rsa_raw rkey
(castPtr ptrM)
(castPtr ptrE)
(castPtr ptrD)
(castPtr ptrP)
(castPtr ptrQ)
(castPtr ptrU)
if res/= 0 then return $ Left (GnuTLSError res)
else do
(cptrM,sizeM) <- peekDatum ptrM
(cptrE,sizeE) <- peekDatum ptrE
(cptrD,sizeD) <- peekDatum ptrD
(cptrP,sizeP) <- peekDatum ptrP
(cptrQ,sizeQ) <- peekDatum ptrQ
(cptrU,sizeU) <- peekDatum ptrU
fpM <- newForeignPtr c_free_finalizer (castPtr cptrM)
fpE <- newForeignPtr c_free_finalizer (castPtr cptrE)
fpD <- newForeignPtr c_free_finalizer (castPtr cptrD)
fpP <- newForeignPtr c_free_finalizer (castPtr cptrP)
fpQ <- newForeignPtr c_free_finalizer (castPtr cptrQ)
fpU <- newForeignPtr c_free_finalizer (castPtr cptrU)
return $ Right
(fromForeignPtr fpM 0 sizeM
,fromForeignPtr fpE 0 sizeE
,fromForeignPtr fpD 0 sizeD
,fromForeignPtr fpP 0 sizeP
,fromForeignPtr fpQ 0 sizeQ
,fromForeignPtr fpU 0 sizeU)
getPeersX509DN :: Certificate -> IO String
getPeersX509DN cert = do
withCertificate cert $ \cp ->
alloca $ \lenp -> do
res <- gnutls_x509_crt_get_dn cp nullPtr lenp
len <- peek lenp
if (len == 0)
then return []
else allocaBytes (fromIntegral len) $ \charp -> do
res2 <- gnutls_x509_crt_get_dn cp charp lenp
throwGnutlsIfNeg res2
len2 <- peek lenp
peekCStringLen (charp, fromIntegral len2)
checkHostname :: Certificate -> String -> GnuTLSMonad Bool
checkHostname a1 a2 =
unsafePerformIO $
withCertificate a1 $ \a1' ->
withCString a2 $ \a2' ->
let {res = checkHostname'_ a1' a2'} in
let {res' = gnuTLSCheckBool res} in
return (res')
checkIssuer :: Certificate -> Certificate -> GnuTLSMonad Bool
checkIssuer a1 a2 =
unsafePerformIO $
withCertificate a1 $ \a1' ->
withCertificate a2 $ \a2' ->
let {res = checkIssuer'_ a1' a2'} in
let {res' = gnuTLSCheckBool res} in
return (res')
activationTime :: ReadWriteAttr Certificate ClockTime ClockTime
activationTime = newAttr g s
where g c = withCertificate c gnutls_x509_crt_get_activation_time >>= return . integralToClockTime
s c (TOD s _) = do withCertificate c $ \cp -> do
gnutls_x509_crt_set_activation_time cp (fromIntegral s) >>= throwGnutlsIf
expirationTime :: ReadWriteAttr Certificate ClockTime ClockTime
expirationTime = newAttr g s
where g c = withCertificate c gnutls_x509_crt_get_expiration_time >>= return . integralToClockTime
s c (TOD s _) = do withCertificate c $ \cp -> do
gnutls_x509_crt_set_expiration_time cp (fromIntegral s) >>= throwGnutlsIf
getIssuerDnByOid :: Certificate -> OID -> Int -> GnuTLSMonad (Maybe ByteString)
getIssuerDnByOid cert str ind = unsafePerformIO (getDnByOid' gnutls_x509_crt_get_issuer_dn_by_oid cert str ind)
getDnByOid :: Certificate
-> OID
-> Int
-> GnuTLSMonad (Maybe ByteString)
getDnByOid cert str ind = unsafePerformIO (getDnByOid' gnutls_x509_crt_get_dn_by_oid cert str ind)
getExtensionByOid :: Certificate
-> OID
-> Int
-> GnuTLSMonad (Maybe (ByteString,Bool))
getExtensionByOid cert str ind
= unsafePerformIO $ alloca $ \crit ->
withCString str $ \cstr ->
withCertificate cert $ \certptr ->
with (1024::Int) $ \szptr ->
createAndTrim' 1024 (\ptr -> do
res <- gnutls_x509_crt_get_extension_by_oid certptr cstr (fromIntegral ind) (castPtr ptr) (castPtr szptr) crit
if res /= 0
then return (0,0,Left $ GnuTLSError res)
else (if ptr == nullPtr
then return $ (0,0,Right False)
else (do
size <- peek szptr
return (0,size,Right True)
))) >>= \(bs,res) -> case res of
Left err -> return $ Left err
Right True -> do
iscrit <- peek crit
return $ Right $ Just (bs,iscrit < 0)
Right False -> return $ Right Nothing
getDnByOid' f cert str ind
= withCString str $ \cstr ->
withCertificate cert $ \certptr ->
with (1024::Int) $ \szptr ->
createAndTrim' 1024 (\ptr -> do
res <- f certptr cstr (fromIntegral ind) 0 (castPtr ptr) (castPtr szptr)
if res /= 0
then return (0,0,Left $ GnuTLSError res)
else (if ptr == nullPtr
then return $ (0,0,Right False)
else (do
size <- peek szptr
return (0,size,Right True)
))) >>= \(bs,res) -> return $ case res of
Left err -> Left err
Right True -> Right $ Just bs
Right False -> Right Nothing
privateKeyGetKeyId :: PrivateKey -> GnuTLSMonad ByteString
privateKeyGetKeyId key = unsafePerformIO $
withPrivateKey key $ \rkey ->
with (20::Int) $ \szptr ->
createAndTrim' 20 (\ptr -> do
res <- gnutls_x509_privkey_get_key_id rkey 0 (castPtr ptr) (castPtr szptr)
if res /= 0
then return (0,0,Just $ GnuTLSError res)
else (do
size <- peek szptr
return (0,size,Nothing)
)) >>= \(bs,res) -> case res of
Nothing -> return (Right bs)
Just err -> return (Left err)
certificateGetKeyId :: Certificate -> GnuTLSMonad ByteString
certificateGetKeyId cert = unsafePerformIO $
withCertificate cert $ \rcert ->
with (20::Int) $ \szptr ->
createAndTrim' 20 (\ptr -> do
res <- gnutls_x509_crt_get_key_id rcert 0 (castPtr ptr) (castPtr szptr)
if res/=0
then return (0,0,Just $ GnuTLSError res)
else (do
size <- peek szptr
return (0,size,Nothing)
)) >>= \(bs,res) -> case res of
Nothing -> return (Right bs)
Just err -> return (Left err)
foreign import ccall unsafe "Network/GnuTLS/X509.chs.h gnutls_x509_crt_import"
gnutls_x509_crt_import :: ((Ptr (Certificate)) -> ((Ptr ()) -> (CInt -> (IO CInt))))
foreign import ccall unsafe "Network/GnuTLS/X509.chs.h gnutls_x509_privkey_import"
gnutls_x509_privkey_import :: ((Ptr (PrivateKey)) -> ((Ptr ()) -> (CInt -> (IO CInt))))
foreign import ccall unsafe "Network/GnuTLS/X509.chs.h gnutls_x509_crt_export"
gnutls_x509_crt_export :: ((Ptr (Certificate)) -> (CInt -> ((Ptr ()) -> ((Ptr CUInt) -> (IO CInt)))))
foreign import ccall unsafe "Network/GnuTLS/X509.chs.h gnutls_x509_privkey_export"
gnutls_x509_privkey_export :: ((Ptr (PrivateKey)) -> (CInt -> ((Ptr ()) -> ((Ptr CUInt) -> (IO CInt)))))
foreign import ccall unsafe "Network/GnuTLS/X509.chs.h gnutls_x509_crt_get_expiration_time"
getExpirationTime'_ :: ((Ptr (Certificate)) -> (IO CLong))
foreign import ccall unsafe "Network/GnuTLS/X509.chs.h gnutls_x509_crt_verify_data"
gnutls_x509_crt_verify_data :: ((Ptr (Certificate)) -> (CUInt -> ((Ptr ()) -> ((Ptr ()) -> (IO CInt)))))
foreign import ccall unsafe "Network/GnuTLS/X509.chs.h gnutls_x509_privkey_sign_data"
gnutls_x509_privkey_sign_data :: ((Ptr (PrivateKey)) -> (CInt -> (CUInt -> ((Ptr ()) -> ((Ptr ()) -> ((Ptr CUInt) -> (IO CInt)))))))
foreign import ccall unsafe "Network/GnuTLS/X509.chs.h gnutls_x509_crt_get_pk_rsa_raw"
gnutls_x509_crt_get_pk_rsa_raw :: ((Ptr (Certificate)) -> ((Ptr ()) -> ((Ptr ()) -> (IO CInt))))
foreign import ccall unsafe "Network/GnuTLS/X509.chs.h gnutls_x509_privkey_export_rsa_raw"
gnutls_x509_privkey_export_rsa_raw :: ((Ptr (PrivateKey)) -> ((Ptr ()) -> ((Ptr ()) -> ((Ptr ()) -> ((Ptr ()) -> ((Ptr ()) -> ((Ptr ()) -> (IO CInt))))))))
foreign import ccall unsafe "Network/GnuTLS/X509.chs.h gnutls_x509_crt_get_dn"
gnutls_x509_crt_get_dn :: ((Ptr (Certificate)) -> ((Ptr CChar) -> ((Ptr CUInt) -> (IO CInt))))
foreign import ccall unsafe "Network/GnuTLS/X509.chs.h gnutls_x509_crt_check_hostname"
checkHostname'_ :: ((Ptr (Certificate)) -> ((Ptr CChar) -> CInt))
foreign import ccall unsafe "Network/GnuTLS/X509.chs.h gnutls_x509_crt_check_issuer"
checkIssuer'_ :: ((Ptr (Certificate)) -> ((Ptr (Certificate)) -> CInt))
foreign import ccall unsafe "Network/GnuTLS/X509.chs.h gnutls_x509_crt_get_activation_time"
gnutls_x509_crt_get_activation_time :: ((Ptr (Certificate)) -> (IO CLong))
foreign import ccall safe "Network/GnuTLS/X509.chs.h gnutls_x509_crt_set_activation_time"
gnutls_x509_crt_set_activation_time :: ((Ptr (Certificate)) -> (CLong -> (IO CInt)))
foreign import ccall unsafe "Network/GnuTLS/X509.chs.h gnutls_x509_crt_get_expiration_time"
gnutls_x509_crt_get_expiration_time :: ((Ptr (Certificate)) -> (IO CLong))
foreign import ccall unsafe "Network/GnuTLS/X509.chs.h gnutls_x509_crt_set_expiration_time"
gnutls_x509_crt_set_expiration_time :: ((Ptr (Certificate)) -> (CLong -> (IO CInt)))
foreign import ccall unsafe "Network/GnuTLS/X509.chs.h gnutls_x509_crt_get_issuer_dn_by_oid"
gnutls_x509_crt_get_issuer_dn_by_oid :: ((Ptr (Certificate)) -> ((Ptr CChar) -> (CInt -> (CUInt -> ((Ptr ()) -> ((Ptr CUInt) -> (IO CInt)))))))
foreign import ccall unsafe "Network/GnuTLS/X509.chs.h gnutls_x509_crt_get_dn_by_oid"
gnutls_x509_crt_get_dn_by_oid :: ((Ptr (Certificate)) -> ((Ptr CChar) -> (CInt -> (CUInt -> ((Ptr ()) -> ((Ptr CUInt) -> (IO CInt)))))))
foreign import ccall unsafe "Network/GnuTLS/X509.chs.h gnutls_x509_crt_get_extension_by_oid"
gnutls_x509_crt_get_extension_by_oid :: ((Ptr (Certificate)) -> ((Ptr CChar) -> (CInt -> ((Ptr ()) -> ((Ptr CUInt) -> ((Ptr CUInt) -> (IO CInt)))))))
foreign import ccall unsafe "Network/GnuTLS/X509.chs.h gnutls_x509_privkey_get_key_id"
gnutls_x509_privkey_get_key_id :: ((Ptr (PrivateKey)) -> (CUInt -> ((Ptr CUChar) -> ((Ptr CUInt) -> (IO CInt)))))
foreign import ccall unsafe "Network/GnuTLS/X509.chs.h gnutls_x509_crt_get_key_id"
gnutls_x509_crt_get_key_id :: ((Ptr (Certificate)) -> (CUInt -> ((Ptr CUChar) -> ((Ptr CUInt) -> (IO CInt)))))