certificate 1.1.1 → 1.3.9
raw patch · 14 files changed
Files
- Certificate.hs +71/−45
- Data/Certificate/KeyDSA.hs +33/−44
- Data/Certificate/KeyRSA.hs +95/−50
- Data/Certificate/PEM.hs +0/−67
- Data/Certificate/X509.hs +103/−71
- Data/Certificate/X509/Cert.hs +262/−259
- Data/Certificate/X509/Ext.hs +77/−69
- Data/Certificate/X509/Internal.hs +11/−84
- Data/CertificateStore.hs +40/−0
- System/Certificate/X509.hs +1/−1
- System/Certificate/X509/MacOS.hs +16/−13
- System/Certificate/X509/Unix.hs +31/−46
- System/Certificate/X509/Win32.hs +16/−18
- certificate.cabal +14/−10
Certificate.hs view
@@ -1,29 +1,40 @@ {-# LANGUAGE DeriveDataTypeable, OverloadedStrings #-} +import Data.Either import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy.Char8 as LC import qualified Data.ByteString as B import qualified Data.Text.Lazy as T import Data.Text.Lazy.Encoding (decodeUtf8) import qualified Data.Certificate.X509 as X509+import Data.Certificate.X509.Cert as Cert import Data.Certificate.KeyRSA as KeyRSA import Data.Certificate.KeyDSA as KeyDSA-import Data.Certificate.PEM+import Data.List (find)+import Data.PEM (pemParseBS, pemContent, pemName) import System.Console.CmdArgs import Control.Monad import Control.Applicative ((<$>)) import Data.Maybe import System.Exit-import System.Certificate.X509 as SysCert+import System.Certificate.X509+import Data.CertificateStore -- for signing/verifying certificate import qualified Crypto.Hash.SHA1 as SHA1+import qualified Crypto.Hash.SHA224 as SHA224+import qualified Crypto.Hash.SHA256 as SHA256+import qualified Crypto.Hash.SHA512 as SHA512 import qualified Crypto.Hash.MD2 as MD2 import qualified Crypto.Hash.MD5 as MD5-import qualified Crypto.Cipher.RSA as RSA-import qualified Crypto.Cipher.DSA as DSA+import qualified Crypto.PubKey.HashDescr as HD+import qualified Crypto.PubKey.RSA as RSA+import qualified Crypto.PubKey.RSA.PKCS15 as RSA+import qualified Crypto.PubKey.DSA as DSA -import Data.ASN1.DER (decodeASN1Stream, ASN1(..), ASN1ConstructionType(..))+import Data.ASN1.Encoding+import Data.ASN1.BinaryEncoding+import Data.ASN1.Stream import Data.ASN1.BitArray import Text.Printf import Numeric@@ -34,8 +45,11 @@ | n > 0xa = showHex n "" | otherwise = "0" ++ showHex n "" -showDN dn = mapM_ (\(oid, (_,t)) -> putStrLn (" " ++ show oid ++ ": " ++ t)) dn+hexdump' :: B.ByteString -> String+hexdump' = hexdump . L.fromChunks . (:[]) +showDN (X509.DistinguishedName dn) = mapM_ (\(oid, (_,t)) -> putStrLn (" " ++ show oid ++ ": " ++ t)) dn+ showExts es = do mapM_ showExt es putStrLn "known extensions decoded: "@@ -68,16 +82,16 @@ printf " modulus: %x\n" (RSA.public_n pubkey) printf " e : %x\n" (RSA.public_e pubkey) X509.PubKeyDSA pubkey -> do- let (p,q,g) = DSA.public_params pubkey+ let params = DSA.public_params pubkey putStrLn "public key DSA:" printf " pub : %x\n" (DSA.public_y pubkey)- printf " p : %d\n" p- printf " q : %x\n" q- printf " g : %x\n" g+ printf " p : %d\n" (DSA.params_p params)+ printf " q : %x\n" (DSA.params_q params)+ printf " g : %x\n" (DSA.params_g params) X509.PubKeyUnknown oid ws -> do printf "public key unknown: %s\n" (show oid) printf " raw bytes: %s\n" (show ws)- case decodeASN1Stream $ L.pack ws of+ case decodeASN1 BER $ L.pack ws of Left err -> printf " asn1 decoding failed: %s\n" (show err) Right l -> printf " asn1 decoding:\n" >> showASN1 4 l pk ->@@ -104,15 +118,15 @@ , "coefficient: " ++ (show $ RSA.private_qinv privkey) ] -showDSAKey :: KeyDSA.Private -> String-showDSAKey key = unlines- [ "version: " ++ (show $ KeyDSA.version key)- , "priv " ++ (show $ KeyDSA.priv key)- , "pub: " ++ (show $ KeyDSA.pub key)- , "p: " ++ (show $ KeyDSA.p key)- , "q: " ++ (show $ KeyDSA.q key)- , "g: " ++ (show $ KeyDSA.g key)+showDSAKey :: (DSA.PublicKey,DSA.PrivateKey) -> String+showDSAKey (pubkey,privkey) = unlines+ [ "priv " ++ (printf "%x" $ DSA.private_x privkey)+ , "pub: " ++ (printf "%x" $ DSA.public_y pubkey)+ , "p: " ++ (printf "%x" $ DSA.params_p params)+ , "q: " ++ (printf "%x" $ DSA.params_q params)+ , "g: " ++ (printf "%x" $ DSA.params_g params) ]+ where params = DSA.private_params privkey showASN1 :: Int -> [ASN1] -> IO () showASN1 at = prettyPrint at where@@ -153,26 +167,29 @@ p (BMPString t) = putStr ("bmpstring: " ++ t) p (Other tc tn x) = putStr "other" -doMain :: CertMainOpts -> IO ()-doMain opts@(X509 _ _ _ _ _) = do- cert <- maybe (error "cannot read PEM certificate") (id) . parsePEMCert <$> B.readFile (head $ files opts)+parsePEMCert = either (const []) (rights . map getCert) . pemParseBS+ where getCert pem = either Left (\x -> Right (pemContent pem,x)) $ X509.decodeCertificate $ L.fromChunks [pemContent pem] +processCert opts (cert, x509) = do when (raw opts) $ putStrLn $ hexdump $ L.fromChunks [cert]- when (asn1 opts) $ case decodeASN1Stream $ L.fromChunks [cert] of+ when (asn1 opts) $ case decodeASN1' BER cert of Left err -> error ("decoding ASN1 failed: " ++ show err) Right asn1 -> showASN1 0 asn1 - let x509o = X509.decodeCertificate $ L.fromChunks [cert]- let x509 = case x509o of- Left err -> error ("decoding certificate failed: " ++ show err)- Right c -> c when (text opts || not (or [asn1 opts,raw opts])) $ showCert x509- when (verify opts) $ verifyCert x509- exitSuccess+ when (hash opts) $ hashCert x509+ when (verify opts) $ getSystemCertificateStore >>= flip verifyCert x509 where- verifyCert x509@(X509.X509 cert _ _ sigalg sig) = do- sysx509 <- SysCert.findCertificate (matchsysX509 cert)- case sysx509 of+ hashCert x509@(X509.X509 cert _ _ _ _) = do+ putStrLn ("subject(MD5): " ++ hexdump' (X509.hashDN_old subject))+ putStrLn ("issuer(MD5): " ++ hexdump' (X509.hashDN_old issuer))+ putStrLn ("subject(SHA1): " ++ hexdump' (X509.hashDN subject))+ putStrLn ("issuer(SHA1): " ++ hexdump' (X509.hashDN issuer))+ where+ subject = X509.certSubjectDN cert+ issuer = X509.certIssuerDN cert+ verifyCert store x509@(X509.X509 cert _ _ sigalg sig) = do+ case findCertificate (X509.certIssuerDN cert) store of Nothing -> putStrLn "couldn't find signing certificate" Just (X509.X509 syscert _ _ _ _) -> do verifyAlg (B.concat $ L.toChunks $ X509.getSigningData x509)@@ -180,16 +197,21 @@ sigalg (X509.certPubKey syscert) - rsaVerify h hdesc pk a b = either (Left . show) (Right) $ RSA.verify h hdesc pk a b+ rsaVerify hdesc pk a b = Right $ RSA.verify hdesc pk a b verifyF (X509.SignatureALG hash X509.PubKeyALG_RSA) (X509.PubKeyRSA rsak) =- let (f, asn1) = case hash of- X509.HashMD2 -> (MD2.hash, "\x30\x20\x30\x0c\x06\x08\x2a\x86\x48\x86\xf7\x0d\x02\x05\x05\x00\x02\x10")- X509.HashMD5 -> (MD5.hash, "\x30\x20\x30\x0c\x06\x08\x2a\x86\x48\x86\xf7\x0d\x02\x05\x05\x00\x04\x10")- X509.HashSHA1 -> (SHA1.hash, "\x30\x21\x30\x09\x06\x05\x2b\x0e\x03\x02\x1a\x05\x00\x04\x14")- _ -> error ("unsupported hash in RSA: " ++ show hash)+ let hdesc = case hash of+ -- "ASN.1 DER X algorithm designator prefix"+ X509.HashMD2 -> HD.hashDescrMD2+ X509.HashMD5 -> HD.hashDescrMD5+ X509.HashSHA1 -> HD.hashDescrSHA1+ X509.HashSHA224 -> HD.hashDescrSHA224+ X509.HashSHA256 -> HD.hashDescrSHA256+ X509.HashSHA384 -> HD.hashDescrSHA384+ X509.HashSHA512 -> HD.hashDescrSHA512+ _ -> error ("unsupported hash in RSA: " ++ show hash) in- rsaVerify f asn1 rsak+ rsaVerify hdesc rsak verifyF (X509.SignatureALG _ X509.PubKeyALG_DSA) (X509.PubKeyDSA dsak) = (\_ _ -> Left "unimplemented DSA checking")@@ -208,20 +230,22 @@ let x = X509.certSubjectDN syscert let y = X509.certIssuerDN cert x == y++doMain :: CertMainOpts -> IO ()+doMain opts@(X509 {}) = B.readFile (head $ files opts) >>= mapM_ (processCert opts) . parsePEMCert doMain (Key files) = do- content <- B.readFile $ head files- let pems = parsePEMs content- let rsadata = findPEM "RSA PRIVATE KEY" pems- let dsadata = findPEM "DSA PRIVATE KEY" pems+ pems <- either error id . pemParseBS <$> B.readFile (head files)+ let rsadata = find ((== "RSA PRIVATE KEY") . pemName) pems+ let dsadata = find ((== "DSA PRIVATE KEY") . pemName) pems case (rsadata, dsadata) of (Just x, _) -> do- let rsaKey = KeyRSA.decodePrivate $ L.fromChunks [x]+ let rsaKey = KeyRSA.decodePrivate $ L.fromChunks [pemContent x] case rsaKey of Left err -> error err Right k -> putStrLn $ showRSAKey k (_, Just x) -> do- let rsaKey = KeyDSA.decodePrivate $ L.fromChunks [x]+ let rsaKey = KeyDSA.decodePrivate $ L.fromChunks [pemContent x] case rsaKey of Left err -> error err Right k -> putStrLn $ showDSAKey k@@ -235,6 +259,7 @@ , text :: Bool , raw :: Bool , verify :: Bool+ , hash :: Bool } | Key { files :: [FilePath]@@ -247,6 +272,7 @@ , text = def , raw = def , verify = def+ , hash = def } &= help "x509 certificate related commands" keyOpts = Key
Data/Certificate/KeyDSA.hs view
@@ -9,55 +9,44 @@ -- module Data.Certificate.KeyDSA- ( Private(..)- , decodePrivate- , encodePrivate- ) where+ ( decodePrivate+ , encodePrivate+ ) where -import Data.ASN1.DER (encodeASN1Stream, ASN1(..), ASN1ConstructionType(..))-import Data.ASN1.BER (decodeASN1Stream)+import Data.ASN1.Stream+import Data.ASN1.Encoding+import Data.ASN1.BinaryEncoding import qualified Data.ByteString.Lazy as L--data Private = Private- { version :: Int- , priv :: Integer- , pub :: Integer- , p :: Integer- , q :: Integer- , g :: Integer- }+import qualified Crypto.Types.PubKey.DSA as DSA -parsePrivate :: [ASN1] -> Either String Private+parsePrivate :: [ASN1] -> Either String (DSA.PublicKey, DSA.PrivateKey) parsePrivate- [ Start Sequence- , IntVal ver, IntVal p_pub, IntVal p_priv, IntVal p_p, IntVal p_g, IntVal p_q- , End Sequence ] =- Right $ Private- { version = fromIntegral ver- , priv = p_priv- , pub = p_pub- , p = p_p- , q = p_q- , g = p_g- }+ [ Start Sequence+ , IntVal 0, IntVal p, IntVal q, IntVal g, IntVal pub, IntVal priv+ , End Sequence ] = Right (pubkey, privkey)+ where+ privkey = DSA.PrivateKey { DSA.private_params = params, DSA.private_x = priv }+ pubkey = DSA.PublicKey { DSA.public_params = params, DSA.public_y = pub }+ params = DSA.Params { DSA.params_p = p, DSA.params_g = g, DSA.params_q = q } +parsePrivate (Start Sequence : IntVal n : _)+ | n == 0 = Left "DSA key format: not recognized"+ | otherwise = Left ("DSA key format: unknown version " ++ show n) parsePrivate _ = Left "unexpected format" -decodePrivate :: L.ByteString -> Either String Private-decodePrivate dat = either (Left . show) parsePrivate $ decodeASN1Stream dat+decodePrivate :: L.ByteString -> Either String (DSA.PublicKey, DSA.PrivateKey)+decodePrivate dat = either (Left . show) parsePrivate $ decodeASN1 BER dat -encodePrivate :: Private -> L.ByteString-encodePrivate pk =- case encodeASN1Stream pkseq of- Left err -> error $ show err- Right lbs -> lbs- where pkseq =- [ Start Sequence- , IntVal $ fromIntegral $ version pk- , IntVal $ pub pk- , IntVal $ priv pk- , IntVal $ p pk- , IntVal $ g pk- , IntVal $ q pk- , End Sequence- ]+encodePrivate :: (DSA.PublicKey, DSA.PrivateKey) -> L.ByteString+encodePrivate (pubkey, privkey) = encodeASN1 DER pkseq+ where pkseq =+ [ Start Sequence+ , IntVal 0+ , IntVal $ DSA.params_p params+ , IntVal $ DSA.params_q params+ , IntVal $ DSA.params_g params+ , IntVal $ DSA.public_y pubkey+ , IntVal $ DSA.private_x privkey+ , End Sequence+ ]+ params = DSA.private_params privkey
Data/Certificate/KeyRSA.hs view
@@ -5,68 +5,113 @@ -- Stability : experimental -- Portability : unknown ----- Read/Write Private RSA Key+-- Read\/Write Private\/Public RSA Key -- module Data.Certificate.KeyRSA- ( decodePrivate- , encodePrivate- ) where+ ( decodePublic+ , decodePrivate+ , encodePublic+ , encodePrivate+ , parse_RSA+ ) where -import Data.ASN1.DER (encodeASN1Stream, ASN1(..), ASN1ConstructionType(..))-import Data.ASN1.BER (decodeASN1Stream)+import Data.ASN1.Stream+import Data.ASN1.Encoding+import Data.ASN1.BinaryEncoding+import Data.ASN1.BitArray import qualified Data.ByteString.Lazy as L import qualified Crypto.Types.PubKey.RSA as RSA +parsePublic :: [ASN1] -> Either String RSA.PublicKey+parsePublic+ [ Start Sequence+ , Start Sequence+ , OID [1,2,840,113549,1,1,1] -- PubKeyALG_RSA+ , Null+ , End Sequence+ , BitString (BitArray _ as1n)+ , End Sequence ] = parse_RSA as1n+parsePublic _ = Left "unexpected format"++decodePublic :: L.ByteString -> Either String RSA.PublicKey+decodePublic dat = either (Left . show) parsePublic $ decodeASN1 BER dat++encodePublic :: RSA.PublicKey -> L.ByteString+encodePublic p = encodeASN1 DER+ [ Start Sequence+ , Start Sequence+ , OID [1,2,840,113549,1,1,1] -- PubKeyALG_RSA+ , Null+ , End Sequence+ , BitString $ toBitArray innerSeq 0+ , End Sequence ]+ where innerSeq = encodeASN1 DER [ Start Sequence+ , IntVal $ RSA.public_n p+ , IntVal $ RSA.public_e p+ , End Sequence+ ]+ parsePrivate :: [ASN1] -> Either String (RSA.PublicKey, RSA.PrivateKey) parsePrivate- [ Start Sequence- , IntVal 0, IntVal p_modulus, IntVal pub_exp- , IntVal priv_exp, IntVal p_p1, IntVal p_p2- , IntVal p_exp1, IntVal p_exp2, IntVal p_coef- , End Sequence ] = Right (pubkey, privkey)- where- privkey = RSA.PrivateKey- { RSA.private_size = calculate_modulus p_modulus 1- , RSA.private_n = p_modulus- , RSA.private_d = priv_exp- , RSA.private_p = p_p1- , RSA.private_q = p_p2- , RSA.private_dP = p_exp1- , RSA.private_dQ = p_exp2- , RSA.private_qinv = p_coef- }- pubkey = RSA.PublicKey- { RSA.public_size = calculate_modulus p_modulus 1- , RSA.public_n = p_modulus- , RSA.public_e = pub_exp- }- calculate_modulus n i = if (2 ^ (i * 8)) > n- then i- else calculate_modulus n (i+1)+ [ Start Sequence+ , IntVal 0, IntVal p_modulus, IntVal pub_exp+ , IntVal priv_exp, IntVal p_p1, IntVal p_p2+ , IntVal p_exp1, IntVal p_exp2, IntVal p_coef+ , End Sequence ] = Right (pubkey, privkey)+ where+ privkey = RSA.PrivateKey+ { RSA.private_pub = pubkey+ , RSA.private_d = priv_exp+ , RSA.private_p = p_p1+ , RSA.private_q = p_p2+ , RSA.private_dP = p_exp1+ , RSA.private_dQ = p_exp2+ , RSA.private_qinv = p_coef+ }+ pubkey = RSA.PublicKey+ { RSA.public_size = calculate_modulus p_modulus 1+ , RSA.public_n = p_modulus+ , RSA.public_e = pub_exp+ }+ calculate_modulus n i = if (2 ^ (i * 8)) > n+ then i+ else calculate_modulus n (i+1) parsePrivate (Start Sequence : IntVal n : _)- | n == 0 = Left "RSA key format: not recognized"- | otherwise = Left ("RSA key format: unknown version " ++ show n)+ | n == 0 = Left "RSA key format: not recognized"+ | otherwise = Left ("RSA key format: unknown version " ++ show n) parsePrivate _ = Left "unexpected format" decodePrivate :: L.ByteString -> Either String (RSA.PublicKey, RSA.PrivateKey)-decodePrivate dat = either (Left . show) parsePrivate $ decodeASN1Stream dat+decodePrivate dat = either (Left . show) parsePrivate $ decodeASN1 BER dat encodePrivate :: (RSA.PublicKey, RSA.PrivateKey) -> L.ByteString-encodePrivate (pubkey, privkey) =- case encodeASN1Stream pkseq of- Left err -> error $ show err- Right lbs -> lbs- where pkseq =- [ Start Sequence- , IntVal 0- , IntVal $ RSA.private_n privkey- , IntVal $ RSA.public_e pubkey- , IntVal $ RSA.private_d privkey- , IntVal $ RSA.private_p privkey- , IntVal $ RSA.private_q privkey- , IntVal $ RSA.private_dP privkey- , IntVal $ RSA.private_dQ privkey- , IntVal $ fromIntegral $ RSA.private_qinv privkey- , End Sequence- ]+encodePrivate (pubkey, privkey) = encodeASN1 DER pkseq+ where pkseq =+ [ Start Sequence+ , IntVal 0+ , IntVal $ RSA.private_n privkey+ , IntVal $ RSA.public_e pubkey+ , IntVal $ RSA.private_d privkey+ , IntVal $ RSA.private_p privkey+ , IntVal $ RSA.private_q privkey+ , IntVal $ RSA.private_dP privkey+ , IntVal $ RSA.private_dQ privkey+ , IntVal $ fromIntegral $ RSA.private_qinv privkey+ , End Sequence+ ]++{- | parse a RSA pubkeys from ASN1 encoded bits.+ - return RSA.PublicKey (len-modulus, modulus, e) if successful -}+parse_RSA :: L.ByteString -> Either String RSA.PublicKey+parse_RSA bits =+ case decodeASN1 BER bits of+ Right [Start Sequence, IntVal modulus, IntVal pubexp, End Sequence] ->+ Right $ RSA.PublicKey+ { RSA.public_size = calculate_modulus modulus 1+ , RSA.public_n = modulus+ , RSA.public_e = pubexp+ }+ _ -> Left "bad RSA format"+ where+ calculate_modulus n i = if (2 ^ (i * 8)) > n then i else calculate_modulus n (i+1)
− Data/Certificate/PEM.hs
@@ -1,67 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}---- |--- Module : Data.Certificate.PEM--- License : BSD-style--- Maintainer : Vincent Hanquez <vincent@snarc.org>--- Stability : experimental--- Portability : unknown------ Read PEM files----module Data.Certificate.PEM- ( parsePEMCert- , parsePEMCertReq- , parsePEMKey- , parsePEMKeyRSA- , parsePEMKeyDSA- , parsePEMs- , findPEM- ) where--import Data.ByteString (ByteString)-import qualified Data.ByteString as B-import qualified Data.ByteString.Char8 as BC-import Data.ByteString.Base64-import Data.List--type PEM = (String, ByteString)--takeTillEnd :: [ByteString] -> ([ByteString], [ByteString])-takeTillEnd ls = break (BC.isPrefixOf "-----END ") ls--findSectionName :: ByteString -> String-findSectionName s = BC.unpack $ B.take (B.length x - 5) x- where x = B.drop 11 s--parsePEMSections :: [ByteString] -> [PEM]-parsePEMSections [] = []-parsePEMSections (x:xs)- | "-----BEGIN " `B.isPrefixOf` x =- let (content, rest) = takeTillEnd xs in- case decode $ B.concat content of- Left _ -> parsePEMSections rest- Right y -> (findSectionName x, y) : parsePEMSections rest- | otherwise = parsePEMSections xs--parsePEMs :: ByteString -> [PEM]-parsePEMs content = parsePEMSections $ BC.lines content--findPEM :: String -> [PEM] -> Maybe ByteString-findPEM name = maybe Nothing (Just . snd) . find ((==) name . fst)--parsePEMCert :: ByteString -> Maybe ByteString-parsePEMCert = findPEM "CERTIFICATE" . parsePEMs--parsePEMCertReq :: ByteString -> Maybe ByteString-parsePEMCertReq = findPEM "CERTIFICATE REQUEST" . parsePEMs--parsePEMKeyRSA :: ByteString -> Maybe ByteString-parsePEMKeyRSA = findPEM "RSA PRIVATE KEY" . parsePEMs--parsePEMKeyDSA :: ByteString -> Maybe ByteString-parsePEMKeyDSA = findPEM "DSA PRIVATE KEY" . parsePEMs--{-# DEPRECATED parsePEMKey "use parsePEMKeyRSA now" #-}-parsePEMKey :: ByteString -> Maybe ByteString-parsePEMKey = parsePEMKeyRSA
Data/Certificate/X509.hs view
@@ -9,61 +9,75 @@ -- module Data.Certificate.X509- (- -- * Data Structure- X509(..)- -- * Data Structure (reexported from X509Cert)- , SignatureALG(..)- , HashALG(..)- , PubKeyALG(..)- , PubKey(..)- , ASN1StringType(..)- , ASN1String- , Certificate(..)- , module Data.Certificate.X509.Ext+ (+ -- * Data Structure+ X509(..)+ -- * Data Structure (reexported from X509Cert)+ , SignatureALG(..)+ , HashALG(..)+ , PubKeyALG(..)+ , PubKey(..)+ , OID+ , ASN1StringType(..)+ , ASN1String+ , DistinguishedName(..)+ , Certificate(..)+ , module Data.Certificate.X509.Ext - -- * helper for signing/veryfing certificate- , getSigningData+ -- * helper for signing/veryfing certificate+ , getSigningData - -- * serialization from ASN1 bytestring- , decodeCertificate- , encodeCertificate- ) where+ -- * serialization from ASN1 bytestring+ , decodeCertificate+ , encodeCertificate + -- * Distinguished names related function+ , decodeDN+ , encodeDN+ , hashDN+ , hashDN_old+ ) where++import Data.Char import Data.Word-import Data.ASN1.DER-import Data.ASN1.Stream (getConstructedEndRepr)-import Data.ASN1.Raw (toBytes)+import Data.ASN1.Encoding+import Data.ASN1.BinaryEncoding+import qualified Data.ASN1.BinaryEncoding.Raw as Raw (toLazyByteString)+import Data.ASN1.Stream import Data.ASN1.BitArray+import Data.ASN1.Object+import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L import Data.Certificate.X509.Internal-import Data.Certificate.X509.Cert+import Data.Certificate.X509.Cert hiding (encodeDN)+import qualified Data.Certificate.X509.Cert as Cert import Data.Certificate.X509.Ext +import qualified Crypto.Hash.MD5 as MD5+import qualified Crypto.Hash.SHA1 as SHA1+ data X509 = X509- { x509Cert :: Certificate -- ^ the certificate part of a X509 structure- , x509CachedSigningData :: (Maybe L.ByteString) -- ^ a cache of the raw representation of the x509 part for signing+ { x509Cert :: Certificate -- ^ the certificate part of a X509 structure+ , x509CachedSigningData :: (Maybe L.ByteString) -- ^ a cache of the raw representation of the x509 part for signing -- since encoding+decoding might not result in the same data being signed.- , x509CachedData :: (Maybe L.ByteString) -- ^ a cache of the raw representation of the whole x509.- , x509SignatureALG :: SignatureALG -- ^ the signature algorithm used.- , x509Signature :: [Word8] -- ^ the signature.- } deriving (Show)+ , x509CachedData :: (Maybe L.ByteString) -- ^ a cache of the raw representation of the whole x509.+ , x509SignatureALG :: SignatureALG -- ^ the signature algorithm used.+ , x509Signature :: [Word8] -- ^ the signature.+ } deriving (Show) instance Eq X509 where- x1 == x2 =- (x509Cert x1 == x509Cert x2) &&- (x509SignatureALG x1 == x509SignatureALG x2) &&- (x509Signature x1 == x509Signature x2)+ x1 == x2 =+ (x509Cert x1 == x509Cert x2) &&+ (x509SignatureALG x1 == x509SignatureALG x2) &&+ (x509Signature x1 == x509Signature x2) {- | get signing data related to a X509 message, - which is either the cached data or the encoded certificate -} getSigningData :: X509 -> L.ByteString getSigningData (X509 _ (Just e) _ _ _) = e-getSigningData (X509 cert Nothing _ _ _) = e- where- (Right e) = encodeASN1Stream header- header = asn1Container Sequence $ encodeCertificateHeader cert+getSigningData (X509 cert Nothing _ _ _) = encodeASN1 DER header+ where header = asn1Container Sequence $ toASN1 cert {- | decode an X509 from a bytestring - the structure is the following:@@ -72,44 +86,62 @@ - Certificate Signature -} decodeCertificate :: L.ByteString -> Either String X509-decodeCertificate by = either (Left . show) parseRootASN1 $ decodeASN1StreamRepr by- where- {- | parse root structure of a x509 certificate. this has to be a sequence of 3 objects :- - * the header- - * the signature algorithm- - * the signature -}- parseRootASN1 l = onContainer rootseq $ \l2 ->- let (certrepr,rem1) = getConstructedEndRepr l2 in- let (sigalgseq,rem2) = getConstructedEndRepr rem1 in- let (sigseq,_) = getConstructedEndRepr rem2 in- let cert = onContainer certrepr (runParseASN1 parseCertificate . map fst) in- case (cert, map fst sigseq) of- (Right c, [BitString b]) ->- let certevs = toBytes $ concatMap snd certrepr in- let sigalg = onContainer sigalgseq (parseSigAlg . map fst) in- Right $ X509 c (Just certevs) (Just by) sigalg (L.unpack $ bitArrayGetData b)- (Left err, _) -> Left $ ("certificate error: " ++ show err)- _ -> Left $ "certificate structure error"- where- (rootseq, _) = getConstructedEndRepr l+decodeCertificate by = either (Left . show) parseRootASN1 $ decodeASN1Repr BER by+ where+ {- | parse root structure of a x509 certificate. this has to be a sequence of 3 objects :+ - * the header+ - * the signature algorithm+ - * the signature -}+ parseRootASN1 l = onContainer (fst $ getConstructedEndRepr l) $ \l2 ->+ let (certrepr,rem1) = getConstructedEndRepr l2 in+ let (sigalgseq,rem2) = getConstructedEndRepr rem1 in+ let (sigseq,_) = getConstructedEndRepr rem2 in+ let cert = onContainer certrepr (either Left (Right . fst) . fromASN1 . map fst) in+ case (cert, map fst sigseq) of+ (Right c, [BitString b]) ->+ let certevs = Raw.toLazyByteString $ concatMap snd certrepr in+ let sigalg = onContainer sigalgseq (parseSigAlg . map fst) in+ Right $ X509 c (Just certevs) (Just by) sigalg (L.unpack $ bitArrayGetData b)+ (Left err, _) -> Left $ ("certificate error: " ++ show err)+ _ -> Left $ "certificate structure error" - onContainer ((Start _, _) : l) f =- case reverse l of- ((End _, _) : l2) -> f $ reverse l2- _ -> f []- onContainer _ f = f []+ onContainer ((Start _, _) : l) f =+ case reverse l of+ ((End _, _) : l2) -> f $ reverse l2+ _ -> f []+ onContainer _ f = f [] - parseSigAlg [ OID oid, Null ] = oidSig oid- parseSigAlg _ = SignatureALG_Unknown []+ parseSigAlg [ OID oid, Null ] = oidSig oid+ parseSigAlg _ = SignatureALG_Unknown [] {-| encode a X509 certificate to a bytestring -} encodeCertificate :: X509 -> L.ByteString encodeCertificate (X509 _ _ (Just lbs) _ _ ) = lbs-encodeCertificate (X509 cert _ Nothing sigalg sigbits) = case encodeASN1Stream rootSeq of- Right x -> x- Left err -> error (show err)- where- esigalg = asn1Container Sequence [OID (sigOID sigalg), Null]- esig = BitString $ toBitArray (L.pack sigbits) 0- header = asn1Container Sequence $ encodeCertificateHeader cert- rootSeq = asn1Container Sequence (header ++ esigalg ++ [esig])+encodeCertificate (X509 cert _ Nothing sigalg sigbits) = encodeASN1 DER rootSeq+ where+ esigalg = asn1Container Sequence [OID (sigOID sigalg), Null]+ esig = BitString $ toBitArray (L.pack sigbits) 0+ header = asn1Container Sequence $ toASN1 cert+ rootSeq = asn1Container Sequence (header ++ esigalg ++ [esig])++decodeDN :: L.ByteString -> Either String DistinguishedName+decodeDN by = either (Left . show) (runParseASN1 parseDN) $ decodeASN1 BER by++encodeDN :: DistinguishedName -> L.ByteString+encodeDN dn = encodeASN1 DER $ Cert.encodeDN dn++-- | Make an openssl style hash of distinguished name+hashDN :: DistinguishedName -> B.ByteString+hashDN = shorten . SHA1.hash . encodeASN1' DER . Cert.encodeDNinner toLowerUTF8+ where toLowerUTF8 (_, s) = (UTF8, map asciiToLower s)+ asciiToLower c+ | c >= 'A' && c <= 'Z' = toLower c+ | otherwise = c++-- | Create an openssl style old hash of distinguished name+hashDN_old :: DistinguishedName -> B.ByteString+hashDN_old = shorten . MD5.hash . encodeASN1' DER . Cert.encodeDN++shorten :: B.ByteString -> B.ByteString+shorten b = B.pack $ map i [3,2,1,0]+ where i n = B.index b n
Data/Certificate/X509/Cert.hs view
@@ -1,40 +1,47 @@ module Data.Certificate.X509.Cert- ( - -- * Data Structure- SignatureALG(..)- , HashALG(..)- , PubKeyALG(..)- , PubKey(..)- , ASN1StringType(..)- , ASN1String- , Certificate(..)+ (+ -- * Data Structure+ SignatureALG(..)+ , HashALG(..)+ , PubKeyALG(..)+ , PubKey(..)+ , ECDSA_Hash(..)+ , ASN1StringType(..)+ , ASN1String+ , Certificate(..)+ , DistinguishedName(..)+ , OID - -- various OID- , oidCommonName- , oidCountry- , oidOrganization- , oidOrganizationUnit+ -- various OID+ , oidCommonName+ , oidCountry+ , oidOrganization+ , oidOrganizationUnit - -- signature to/from oid- , oidSig- , sigOID+ -- signature to/from oid+ , oidSig+ , sigOID - -- * certificate to/from asn1- , parseCertificate- , encodeCertificateHeader+ -- * Parse and encode a single distinguished name+ , parseDN+ , encodeDNinner+ , encodeDN - -- * extensions- , module Data.Certificate.X509.Ext- ) where+ -- * extensions+ , module Data.Certificate.X509.Ext+ ) where import Data.Word-import Data.List (find, sortBy)-import Data.ASN1.DER+import Data.Monoid+import Data.List (find)+import Data.ASN1.Stream+import Data.ASN1.Encoding+import Data.ASN1.BinaryEncoding import Data.ASN1.BitArray+import Data.ASN1.Object import Data.Maybe import Data.Time.Calendar import Data.Time.Clock (DiffTime, secondsToDiffTime)-import Data.ByteString.Lazy (ByteString) import qualified Data.ByteString.Lazy as L import Control.Applicative ((<$>)) import Control.Monad.State@@ -44,131 +51,122 @@ import qualified Crypto.Types.PubKey.RSA as RSA import qualified Crypto.Types.PubKey.DSA as DSA +import Data.Certificate.KeyRSA (parse_RSA)+ data HashALG =- HashMD2- | HashMD5- | HashSHA1- | HashSHA224- | HashSHA256- | HashSHA384- | HashSHA512- deriving (Show,Eq)+ HashMD2+ | HashMD5+ | HashSHA1+ | HashSHA224+ | HashSHA256+ | HashSHA384+ | HashSHA512+ deriving (Show,Eq) data PubKeyALG =- PubKeyALG_RSA- | PubKeyALG_DSA- | PubKeyALG_ECDSA- | PubKeyALG_DH- | PubKeyALG_Unknown OID- deriving (Show,Eq)+ PubKeyALG_RSA+ | PubKeyALG_DSA+ | PubKeyALG_ECDSA+ | PubKeyALG_DH+ | PubKeyALG_Unknown OID+ deriving (Show,Eq) data SignatureALG =- SignatureALG HashALG PubKeyALG- | SignatureALG_Unknown OID- deriving (Show,Eq)+ SignatureALG HashALG PubKeyALG+ | SignatureALG_Unknown OID+ deriving (Show,Eq) +data ECDSA_Hash = ECDSA_Hash_SHA384+ deriving (Show,Eq)+ data PubKey =- PubKeyRSA RSA.PublicKey -- ^ RSA public key- | PubKeyDSA DSA.PublicKey -- ^ DSA public key- | PubKeyDH (Integer,Integer,Integer,Maybe Integer,([Word8], Integer))- -- ^ DH format with (p,g,q,j,(seed,pgenCounter))- | PubKeyECDSA [ASN1] -- ^ ECDSA format not done yet FIXME- | PubKeyUnknown OID [Word8] -- ^ unrecognized format- deriving (Show,Eq)+ PubKeyRSA RSA.PublicKey -- ^ RSA public key+ | PubKeyDSA DSA.PublicKey -- ^ DSA public key+ | PubKeyDH (Integer,Integer,Integer,Maybe Integer,([Word8], Integer))+ -- ^ DH format with (p,g,q,j,(seed,pgenCounter))+ | PubKeyECDSA ECDSA_Hash L.ByteString -- ^ ECDSA format not done yet FIXME+ | PubKeyUnknown OID [Word8] -- ^ unrecognized format+ deriving (Show,Eq) type Time = (Day, DiffTime, Bool) data CertKeyUsage =- CertKeyUsageDigitalSignature- | CertKeyUsageNonRepudiation- | CertKeyUsageKeyEncipherment- | CertKeyUsageDataEncipherment- | CertKeyUsageKeyAgreement- | CertKeyUsageKeyCertSign- | CertKeyUsageCRLSign- | CertKeyUsageEncipherOnly- | CertKeyUsageDecipherOnly- deriving (Show, Eq)+ CertKeyUsageDigitalSignature+ | CertKeyUsageNonRepudiation+ | CertKeyUsageKeyEncipherment+ | CertKeyUsageDataEncipherment+ | CertKeyUsageKeyAgreement+ | CertKeyUsageKeyCertSign+ | CertKeyUsageCRLSign+ | CertKeyUsageEncipherOnly+ | CertKeyUsageDecipherOnly+ deriving (Show, Eq) -data ASN1StringType = UTF8 | Printable | Univ | BMP | IA5 | T61 deriving (Show,Eq)+data ASN1StringType = UTF8 | Printable | Univ | BMP | IA5 | T61 deriving (Show,Eq,Ord,Enum) type ASN1String = (ASN1StringType, String) +newtype DistinguishedName = DistinguishedName { getDistinguishedElements :: [(OID, ASN1String)] }+ deriving (Show,Eq,Ord)++instance Monoid DistinguishedName where+ mempty = DistinguishedName []+ mappend (DistinguishedName l1) (DistinguishedName l2) = DistinguishedName (l1++l2)+ data Certificate = Certificate- { certVersion :: Int -- ^ Certificate Version- , certSerial :: Integer -- ^ Certificate Serial number- , certSignatureAlg :: SignatureALG -- ^ Certificate Signature algorithm- , certIssuerDN :: [ (OID, ASN1String) ] -- ^ Certificate Issuer DN- , certSubjectDN :: [ (OID, ASN1String) ] -- ^ Certificate Subject DN- , certValidity :: (Time, Time) -- ^ Certificate Validity period- , certPubKey :: PubKey -- ^ Certificate Public key- , certExtensions :: Maybe [ExtensionRaw] -- ^ Certificate Extensions- } deriving (Show,Eq)+ { certVersion :: Int -- ^ Certificate Version+ , certSerial :: Integer -- ^ Certificate Serial number+ , certSignatureAlg :: SignatureALG -- ^ Certificate Signature algorithm+ , certIssuerDN :: DistinguishedName -- ^ Certificate Issuer DN+ , certSubjectDN :: DistinguishedName -- ^ Certificate Subject DN+ , certValidity :: (Time, Time) -- ^ Certificate Validity period+ , certPubKey :: PubKey -- ^ Certificate Public key+ , certExtensions :: Maybe [ExtensionRaw] -- ^ Certificate Extensions+ } deriving (Show,Eq) +instance ASN1Object Certificate where+ toASN1 certificate = encodeCertificateHeader certificate+ fromASN1 s = runParseASN1State parseCertificate s+ oidCommonName, oidCountry, oidOrganization, oidOrganizationUnit :: OID oidCommonName = [2,5,4,3] oidCountry = [2,5,4,6] oidOrganization = [2,5,4,10] oidOrganizationUnit = [2,5,4,11] -{- | parse a RSA pubkeys from ASN1 encoded bits.- - return PubKeyRSA (len-modulus, modulus, e) if successful -}-parse_RSA :: ByteString -> ParseASN1 PubKey-parse_RSA bits =- case decodeASN1Stream $ bits of- Right [Start Sequence, IntVal modulus, IntVal pubexp, End Sequence] ->- return $ PubKeyRSA $ RSA.PublicKey- { RSA.public_size = calculate_modulus modulus 1- , RSA.public_n = modulus- , RSA.public_e = pubexp- }- _ ->- throwError ("bad RSA format")- where- calculate_modulus n i = if (2 ^ (i * 8)) > n then i else calculate_modulus n (i+1)--parse_ECDSA :: ByteString -> ParseASN1 PubKey-parse_ECDSA bits =- case decodeASN1Stream bits of- Right l -> return $ PubKeyECDSA l- Left _ -> return $ PubKeyUnknown (pubkeyalgOID PubKeyALG_ECDSA) (L.unpack bits)- parseCertHeaderVersion :: ParseASN1 Int-parseCertHeaderVersion = do- v <- onNextContainerMaybe (Container Context 0) $ do- n <- getNext- case n of- IntVal v -> return $ fromIntegral v- _ -> throwError "unexpected type for version"- return $ maybe 1 id v+parseCertHeaderVersion =+ maybe 1 id <$> onNextContainerMaybe (Container Context 0) (getNext >>= getVer)+ where getVer (IntVal v) = return $ fromIntegral v+ getVer _ = throwError "unexpected type for version" parseCertHeaderSerial :: ParseASN1 Integer parseCertHeaderSerial = do- n <- getNext- case n of- IntVal v -> return v- _ -> throwError ("missing serial" ++ show n)+ n <- getNext+ case n of+ IntVal v -> return v+ _ -> throwError ("missing serial" ++ show n) sig_table :: [ (OID, SignatureALG) ] sig_table =- [ ([1,2,840,113549,1,1,5], SignatureALG HashSHA1 PubKeyALG_RSA)- , ([1,2,840,113549,1,1,4], SignatureALG HashMD5 PubKeyALG_RSA)- , ([1,2,840,113549,1,1,2], SignatureALG HashMD2 PubKeyALG_RSA)- , ([1,2,840,113549,1,1,11], SignatureALG HashSHA256 PubKeyALG_RSA)- , ([1,2,840,113549,1,1,12], SignatureALG HashSHA384 PubKeyALG_RSA)- , ([1,2,840,10040,4,3], SignatureALG HashSHA1 PubKeyALG_DSA)- , ([1,2,840,10045,4,3,1], SignatureALG HashSHA224 PubKeyALG_ECDSA)- , ([1,2,840,10045,4,3,2], SignatureALG HashSHA256 PubKeyALG_ECDSA)- , ([1,2,840,10045,4,3,3], SignatureALG HashSHA384 PubKeyALG_ECDSA)- , ([1,2,840,10045,4,3,4], SignatureALG HashSHA512 PubKeyALG_ECDSA)- ]+ [ ([1,2,840,113549,1,1,5], SignatureALG HashSHA1 PubKeyALG_RSA)+ , ([1,2,840,113549,1,1,4], SignatureALG HashMD5 PubKeyALG_RSA)+ , ([1,2,840,113549,1,1,2], SignatureALG HashMD2 PubKeyALG_RSA)+ , ([1,2,840,113549,1,1,11], SignatureALG HashSHA256 PubKeyALG_RSA)+ , ([1,2,840,113549,1,1,12], SignatureALG HashSHA384 PubKeyALG_RSA)+ , ([1,2,840,10040,4,3], SignatureALG HashSHA1 PubKeyALG_DSA)+ , ([1,2,840,10045,4,3,1], SignatureALG HashSHA224 PubKeyALG_ECDSA)+ , ([1,2,840,10045,4,3,2], SignatureALG HashSHA256 PubKeyALG_ECDSA)+ , ([1,2,840,10045,4,3,3], SignatureALG HashSHA384 PubKeyALG_ECDSA)+ , ([1,2,840,10045,4,3,4], SignatureALG HashSHA512 PubKeyALG_ECDSA)+ ] pk_table :: [ (OID, PubKeyALG) ] pk_table =- [ ([1,2,840,113549,1,1,1], PubKeyALG_RSA)- , ([1,2,840,10040,4,1], PubKeyALG_DSA)- , ([1,2,840,10045,2,1], PubKeyALG_ECDSA)- , ([1,2,840,10046,2,1], PubKeyALG_DH)- ]+ [ ([1,2,840,113549,1,1,1], PubKeyALG_RSA)+ , ([1,2,840,10040,4,1], PubKeyALG_DSA)+ , ([1,2,840,10045,2,1], PubKeyALG_ECDSA)+ , ([1,2,840,10046,2,1], PubKeyALG_DH)+ ] oidSig :: OID -> SignatureALG oidSig oid = maybe (SignatureALG_Unknown oid) id $ lookup oid sig_table@@ -188,16 +186,16 @@ pubkeyToAlg (PubKeyRSA _) = PubKeyALG_RSA pubkeyToAlg (PubKeyDSA _) = PubKeyALG_DSA pubkeyToAlg (PubKeyDH _) = PubKeyALG_DH-pubkeyToAlg (PubKeyECDSA _) = PubKeyALG_ECDSA+pubkeyToAlg (PubKeyECDSA _ _) = PubKeyALG_ECDSA pubkeyToAlg (PubKeyUnknown oid _) = PubKeyALG_Unknown oid parseCertHeaderAlgorithmID :: ParseASN1 SignatureALG parseCertHeaderAlgorithmID = do- n <- getNextContainer Sequence- case n of- [ OID oid, Null ] -> return $ oidSig oid- [ OID oid ] -> return $ oidSig oid- _ -> throwError ("algorithm ID bad format " ++ show n)+ n <- getNextContainer Sequence+ case n of+ [ OID oid, Null ] -> return $ oidSig oid+ [ OID oid ] -> return $ oidSig oid+ _ -> throwError ("algorithm ID bad format " ++ show n) asn1String :: ASN1 -> ASN1String asn1String (PrintableString x) = (Printable, x)@@ -216,166 +214,171 @@ encodeAsn1String (IA5, x) = IA5String x encodeAsn1String (T61, x) = T61String x -parseCertHeaderDN :: ParseASN1 [(OID, ASN1String)]-parseCertHeaderDN = sortByOID <$> onNextContainer Sequence getDNs where- sortByOID = sortBy (\a b -> fst a `compare` fst b)- getDNs = do- n <- hasNext- if n- then liftM2 (:) parseDNOne getDNs- else return []- parseDNOne = onNextContainer Set $ do- s <- getNextContainer Sequence- case s of- [OID oid, val] -> return (oid, asn1String val)- _ -> throwError "expecting sequence"+parseDN :: ParseASN1 DistinguishedName+parseDN = DistinguishedName <$> onNextContainer Sequence getDNs where+ getDNs = do+ n <- hasNext+ if n+ then liftM2 (:) parseOneDN getDNs+ else return [] +parseOneDN :: ParseASN1 (OID, ASN1String)+parseOneDN = onNextContainer Set $ do+ s <- getNextContainer Sequence+ case s of+ [OID oid, val] -> return (oid, asn1String val)+ _ -> throwError "expecting sequence"+ parseCertHeaderValidity :: ParseASN1 (Time, Time)-parseCertHeaderValidity = do- n <- getNextContainer Sequence- case n of- [ UTCTime t1, UTCTime t2 ] -> return (convertTime t1, convertTime t2)- _ -> throwError "bad validity format"- where convertTime (y,m,d,h,mi,s,u) =- let day = fromGregorian (fromIntegral y) m d in- let dtime = secondsToDiffTime (fromIntegral h * 3600 + fromIntegral mi * 60 + fromIntegral s) in- (day, dtime, u)+parseCertHeaderValidity = getNextContainer Sequence >>= toTimeBound+ where toTimeBound [ UTCTime t1, UTCTime t2 ] = return (convertTime t1, convertTime t2)+ toTimeBound [ GeneralizedTime t1, GeneralizedTime t2 ] = return (convertTime t1, convertTime t2)+ toTimeBound _ = throwError "bad validity format" + convertTime (y,m,d,h,mi,s,u) =+ let day = fromGregorian (fromIntegral y) m d+ dtime = secondsToDiffTime (fromIntegral h * 3600 + fromIntegral mi * 60 + fromIntegral s)+ in (day, dtime, u)+ parseCertHeaderSubjectPK :: ParseASN1 PubKey parseCertHeaderSubjectPK = onNextContainer Sequence $ do- l <- getNextContainer Sequence- bits <- getNextBitString- case l of- [OID pkalg,Null] -> do- let sig = oidPubKey pkalg- case sig of- PubKeyALG_RSA -> parse_RSA bits- _ -> return $ PubKeyUnknown pkalg $ L.unpack bits- [OID pkalg,OID _] -> do- let sig = oidPubKey pkalg- case sig of- PubKeyALG_ECDSA -> parse_ECDSA bits- _ -> return $ PubKeyUnknown pkalg $ L.unpack bits- [OID pkalg,Start Sequence,IntVal p,IntVal q,IntVal g,End Sequence] -> do- let sig = oidPubKey pkalg- case decodeASN1Stream bits of- Right [IntVal dsapub] -> return $ PubKeyDSA $ DSA.PublicKey- { DSA.public_params = (p, q, g), DSA.public_y = dsapub }- _ -> return $ PubKeyUnknown pkalg $ L.unpack bits- n ->- throwError ("subject public key bad format : " ++ show n)+ l <- getNextContainer Sequence+ bits <- getNextBitString+ case l of+ (OID pkalg):xs -> toKey (oidPubKey pkalg) xs bits+ _ -> throwError ("subject public unknown key format : " ++ show l)+ where toKey PubKeyALG_RSA _ bits = do+ either (throwError) (return . PubKeyRSA) (parse_RSA bits)+ toKey PubKeyALG_ECDSA xs bits = do+ case xs of+ [(OID [1,3,132,0,34])] -> return $ PubKeyECDSA ECDSA_Hash_SHA384 bits+ _ -> return $ PubKeyUnknown (pubkeyalgOID PubKeyALG_ECDSA) $ L.unpack bits+ toKey PubKeyALG_DSA [Start Sequence,IntVal p,IntVal q,IntVal g,End Sequence] bits = do+ case decodeASN1 BER bits of+ Right [IntVal dsapub] -> return $ PubKeyDSA $ DSA.PublicKey+ { DSA.public_params = DSA.Params+ { DSA.params_p = p+ , DSA.params_q = q+ , DSA.params_g = g }+ , DSA.public_y = dsapub }+ _ -> return $ PubKeyUnknown (pubkeyalgOID PubKeyALG_DSA) $ L.unpack bits+ toKey (PubKeyALG_Unknown oid) _ bits = return $ PubKeyUnknown oid $ L.unpack bits+ toKey other _ bits = return $ PubKeyUnknown (pubkeyalgOID other) $ L.unpack bits - where getNextBitString = getNext >>= \bs -> case bs of- BitString bits -> return $ bitArrayGetData bits- _ -> throwError "expecting bitstring"+ getNextBitString = getNext >>= \bs -> case bs of+ BitString bits -> return $ bitArrayGetData bits+ _ -> throwError "expecting bitstring" parseCertExtensions :: ParseASN1 (Maybe [ExtensionRaw])-parseCertExtensions = onNextContainerMaybe (Container Context 3) (sortByOID . mapMaybe extractExtension <$> onNextContainer Sequence getSequences)- where- sortByOID = sortBy (\(a,_,_) (b,_,_) -> a `compare` b)- getSequences = do- n <- hasNext- if n- then getNextContainer Sequence >>= \sq -> liftM (sq :) getSequences- else return []- extractExtension [OID oid,Boolean True,OctetString obj] = case decodeASN1Stream obj of- Left _ -> Nothing- Right r -> Just (oid, True, r)- extractExtension [OID oid,OctetString obj] = case decodeASN1Stream obj of- Left _ -> Nothing- Right r -> Just (oid, False, r)- extractExtension _ = Nothing+parseCertExtensions = onNextContainerMaybe (Container Context 3) (mapMaybe extractExtension <$> onNextContainer Sequence getSequences)+ where+ getSequences = do+ n <- hasNext+ if n+ then getNextContainer Sequence >>= \sq -> liftM (sq :) getSequences+ else return []+ extractExtension [OID oid,Boolean True,OctetString obj] = case decodeASN1 BER obj of+ Left _ -> Nothing+ Right r -> Just (oid, True, r)+ extractExtension [OID oid,OctetString obj] = case decodeASN1 BER obj of+ Left _ -> Nothing+ Right r -> Just (oid, False, r)+ extractExtension _ = Nothing {- | parse header structure of a x509 certificate. the structure the following:- Version- Serial Number- Algorithm ID- Issuer- Validity- Not Before- Not After- Subject- Subject Public Key Info- Public Key Algorithm- Subject Public Key- Issuer Unique Identifier (Optional) (>= 2)- Subject Unique Identifier (Optional) (>= 2)- Extensions (Optional) (>= v3)+ Version+ Serial Number+ Algorithm ID+ Issuer+ Validity+ Not Before+ Not After+ Subject+ Subject Public Key Info+ Public Key Algorithm+ Subject Public Key+ Issuer Unique Identifier (Optional) (>= 2)+ Subject Unique Identifier (Optional) (>= 2)+ Extensions (Optional) (>= v3) -} parseCertificate :: ParseASN1 Certificate parseCertificate = do- version <- parseCertHeaderVersion- serial <- parseCertHeaderSerial- sigalg <- parseCertHeaderAlgorithmID- issuer <- parseCertHeaderDN- validity <- parseCertHeaderValidity- subject <- parseCertHeaderDN- pk <- parseCertHeaderSubjectPK- exts <- parseCertExtensions- hnext <- hasNext- when hnext $ throwError "expecting End Of Data."- - return $ Certificate- { certVersion = version- , certSerial = serial- , certSignatureAlg = sigalg- , certIssuerDN = issuer- , certSubjectDN = subject- , certValidity = validity- , certPubKey = pk- , certExtensions = exts- }+ version <- parseCertHeaderVersion+ serial <- parseCertHeaderSerial+ sigalg <- parseCertHeaderAlgorithmID+ issuer <- parseDN+ validity <- parseCertHeaderValidity+ subject <- parseDN+ pk <- parseCertHeaderSubjectPK+ exts <- parseCertExtensions+ hnext <- hasNext+ when hnext $ throwError "expecting End Of Data."+ + return $ Certificate+ { certVersion = version+ , certSerial = serial+ , certSignatureAlg = sigalg+ , certIssuerDN = issuer+ , certSubjectDN = subject+ , certValidity = validity+ , certPubKey = pk+ , certExtensions = exts+ } -encodeDN :: [ (OID, ASN1String) ] -> [ASN1]-encodeDN dn = asn1Container Sequence $ concatMap dnSet dn- where- dnSet (oid, stringy) = asn1Container Set (asn1Container Sequence [OID oid, encodeAsn1String stringy])+encodeDNinner :: (ASN1String -> ASN1String) -> DistinguishedName -> [ASN1]+encodeDNinner f (DistinguishedName dn) = concatMap dnSet dn+ where dnSet (oid, stringy) = asn1Container Set (asn1Container Sequence [OID oid, encodeAsn1String (f stringy)]) +encodeDN :: DistinguishedName -> [ASN1]+encodeDN dn = asn1Container Sequence $ encodeDNinner id dn+ encodePK :: PubKey -> [ASN1] encodePK k@(PubKeyRSA pubkey) =- asn1Container Sequence (asn1Container Sequence [pkalg,Null] ++ [BitString $ toBitArray bits 0])- where- pkalg = OID $ pubkeyalgOID $ pubkeyToAlg k- (Right bits) = encodeASN1Stream $ asn1Container Sequence [IntVal (RSA.public_n pubkey), IntVal (RSA.public_e pubkey)]+ asn1Container Sequence (asn1Container Sequence [pkalg,Null] ++ [BitString $ toBitArray bits 0])+ where+ pkalg = OID $ pubkeyalgOID $ pubkeyToAlg k+ bits = encodeASN1 DER $ asn1Container Sequence [IntVal (RSA.public_n pubkey), IntVal (RSA.public_e pubkey)] encodePK k@(PubKeyDSA pubkey) =- asn1Container Sequence (asn1Container Sequence ([pkalg] ++ dsaseq) ++ [BitString $ toBitArray bits 0])- where- pkalg = OID $ pubkeyalgOID $ pubkeyToAlg k- dsaseq = asn1Container Sequence [IntVal p,IntVal q,IntVal g]- (p,q,g) = DSA.public_params pubkey- (Right bits) = encodeASN1Stream [IntVal $ DSA.public_y pubkey]+ asn1Container Sequence (asn1Container Sequence ([pkalg] ++ dsaseq) ++ [BitString $ toBitArray bits 0])+ where+ pkalg = OID $ pubkeyalgOID $ pubkeyToAlg k+ dsaseq = asn1Container Sequence [IntVal (DSA.params_p params)+ ,IntVal (DSA.params_q params)+ ,IntVal (DSA.params_g params)]+ params = DSA.public_params pubkey+ bits = encodeASN1 DER [IntVal $ DSA.public_y pubkey] encodePK k@(PubKeyUnknown _ l) =- asn1Container Sequence (asn1Container Sequence [pkalg,Null] ++ [BitString $ toBitArray (L.pack l) 0])- where- pkalg = OID $ pubkeyalgOID $ pubkeyToAlg k+ asn1Container Sequence (asn1Container Sequence [pkalg,Null] ++ [BitString $ toBitArray (L.pack l) 0])+ where+ pkalg = OID $ pubkeyalgOID $ pubkeyToAlg k encodeExts :: Maybe [ExtensionRaw] -> [ASN1] encodeExts Nothing = [] encodeExts (Just l) = asn1Container (Container Context 3) $ concatMap encodeExt l- where encodeExt (oid, critical, asn1) = case encodeASN1Stream asn1 of- Left _ -> error "cannot encode asn1 extension"- Right bs -> asn1Container Sequence ([OID oid] ++ (if critical then [Boolean True] else []) ++ [OctetString bs])+ where encodeExt (oid, critical, asn1) =+ let bs = encodeASN1 DER asn1+ in asn1Container Sequence ([OID oid] ++ (if critical then [Boolean True] else []) ++ [OctetString bs]) encodeCertificateHeader :: Certificate -> [ASN1] encodeCertificateHeader cert =- eVer ++ eSerial ++ eAlgId ++ eIssuer ++ eValidity ++ eSubject ++ epkinfo ++ eexts- where- eVer = asn1Container (Container Context 0) [IntVal (fromIntegral $ certVersion cert)]- eSerial = [IntVal $ certSerial cert]- eAlgId = asn1Container Sequence [OID (sigOID $ certSignatureAlg cert), Null]- eIssuer = encodeDN $ certIssuerDN cert- (t1, t2) = certValidity cert- eValidity = asn1Container Sequence [UTCTime $ unconvertTime t1, UTCTime $ unconvertTime t2]- eSubject = encodeDN $ certSubjectDN cert- epkinfo = encodePK $ certPubKey cert- eexts = encodeExts $ certExtensions cert+ eVer ++ eSerial ++ eAlgId ++ eIssuer ++ eValidity ++ eSubject ++ epkinfo ++ eexts+ where+ eVer = asn1Container (Container Context 0) [IntVal (fromIntegral $ certVersion cert)]+ eSerial = [IntVal $ certSerial cert]+ eAlgId = asn1Container Sequence [OID (sigOID $ certSignatureAlg cert), Null]+ eIssuer = encodeDN $ certIssuerDN cert+ (t1, t2) = certValidity cert+ eValidity = asn1Container Sequence [UTCTime $ unconvertTime t1, UTCTime $ unconvertTime t2]+ eSubject = encodeDN $ certSubjectDN cert+ epkinfo = encodePK $ certPubKey cert+ eexts = encodeExts $ certExtensions cert - unconvertTime (day, difftime, z) =- let (y, m, d) = toGregorian day in- let seconds = floor $ toRational difftime in- let h = seconds `div` 3600 in- let mi = (seconds `div` 60) `mod` 60 in- let s = seconds `mod` 60 in- (fromIntegral y,m,d,h,mi,s,z)+ unconvertTime (day, difftime, z) =+ let (y, m, d) = toGregorian day in+ let seconds = floor $ toRational difftime in+ let h = seconds `div` 3600 in+ let mi = (seconds `div` 60) `mod` 60 in+ let s = seconds `mod` 60 in+ (fromIntegral y,m,d,h,mi,s,z)
Data/Certificate/X509/Ext.hs view
@@ -8,40 +8,42 @@ -- extension processing module. -- module Data.Certificate.X509.Ext- ( ExtensionRaw- , Extension(..)- -- * Common extension usually found in x509v3- , ExtBasicConstraints(..)- , ExtKeyUsage(..)- , ExtKeyUsageFlag(..)- , ExtSubjectKeyId(..)- , ExtSubjectAltName(..)- , ExtAuthorityKeyId(..)- -- * Accessor turning extension into a specific one- , extensionGet- ) where+ ( ExtensionRaw+ , Extension(..)+ -- * Common extension usually found in x509v3+ , ExtBasicConstraints(..)+ , ExtKeyUsage(..)+ , ExtKeyUsageFlag(..)+ , ExtSubjectKeyId(..)+ , ExtSubjectAltName(..)+ , ExtAuthorityKeyId(..)+ -- * Accessor turning extension into a specific one+ , extensionGet+ ) where import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as BC import qualified Data.ByteString.Lazy as L-import Data.ASN1.DER+import Data.ASN1.Types+import Data.ASN1.Stream import Data.ASN1.BitArray import Data.Certificate.X509.Internal+import Control.Monad.Error type ExtensionRaw = (OID, Bool, [ASN1]) -- | key usage flag that is found in the key usage extension field. data ExtKeyUsageFlag =- KeyUsage_digitalSignature -- (0)- | KeyUsage_nonRepudiation -- (1) recent X.509 ver have renamed this bit to contentCommitment- | KeyUsage_keyEncipherment -- (2)- | KeyUsage_dataEncipherment -- (3)- | KeyUsage_keyAgreement -- (4)- | KeyUsage_keyCertSign -- (5)- | KeyUsage_cRLSign -- (6)- | KeyUsage_encipherOnly -- (7)- | KeyUsage_decipherOnly -- (8)- deriving (Show,Eq,Ord,Enum)+ KeyUsage_digitalSignature -- (0)+ | KeyUsage_nonRepudiation -- (1) recent X.509 ver have renamed this bit to contentCommitment+ | KeyUsage_keyEncipherment -- (2)+ | KeyUsage_dataEncipherment -- (3)+ | KeyUsage_keyAgreement -- (4)+ | KeyUsage_keyCertSign -- (5)+ | KeyUsage_cRLSign -- (6)+ | KeyUsage_encipherOnly -- (7)+ | KeyUsage_decipherOnly -- (8)+ deriving (Show,Eq,Ord,Enum) {- -- RFC 5280@@ -52,78 +54,84 @@ -} class Extension a where- extOID :: a -> OID- extEncode :: a -> [ASN1]- extDecode :: [ASN1] -> Either String a+ extOID :: a -> OID+ extEncode :: a -> [ASN1]+ extDecode :: [ASN1] -> Either String a extensionGet :: Extension a => [ExtensionRaw] -> Maybe a extensionGet [] = Nothing extensionGet ((oid,_,asn1):xs) = case extDecode asn1 of- Right b- | oid == extOID b -> Just b- | otherwise -> extensionGet xs- Left _ -> extensionGet xs+ Right b+ | oid == extOID b -> Just b+ | otherwise -> extensionGet xs+ Left _ -> extensionGet xs -data ExtBasicConstraints = ExtBasicConstraints Bool- deriving (Show,Eq)+data ExtBasicConstraints = ExtBasicConstraints Bool (Maybe Integer)+ deriving (Show,Eq) instance Extension ExtBasicConstraints where- extOID = const [2,5,29,19]- extEncode (ExtBasicConstraints b) = [Start Sequence,Boolean b,End Sequence]- extDecode [Start Sequence,Boolean b,End Sequence] = Right (ExtBasicConstraints b)- extDecode [Start Sequence,End Sequence] = Right (ExtBasicConstraints False)- extDecode _ = Left "unknown sequence"+ extOID = const [2,5,29,19]+ extEncode (ExtBasicConstraints b Nothing) = [Start Sequence,Boolean b,End Sequence]+ extEncode (ExtBasicConstraints b (Just i)) = [Start Sequence,Boolean b,IntVal i,End Sequence] + extDecode [Start Sequence,Boolean b,IntVal v,End Sequence]+ | v >= 0 = Right (ExtBasicConstraints b (Just v))+ | otherwise = Left "invalid pathlen"+ extDecode [Start Sequence,Boolean b,End Sequence] = Right (ExtBasicConstraints b Nothing)+ extDecode [Start Sequence,End Sequence] = Right (ExtBasicConstraints False Nothing)+ extDecode _ = Left "unknown sequence"+ data ExtKeyUsage = ExtKeyUsage [ExtKeyUsageFlag]- deriving (Show,Eq)+ deriving (Show,Eq) instance Extension ExtKeyUsage where- extOID = const [2,5,29,15]- extEncode (ExtKeyUsage flags) = [BitString $ flagsToBits flags]- extDecode [BitString bits] = Right $ ExtKeyUsage $ bitsToFlags bits- extDecode _ = Left "unknown sequence"+ extOID = const [2,5,29,15]+ extEncode (ExtKeyUsage flags) = [BitString $ flagsToBits flags]+ extDecode [BitString bits] = Right $ ExtKeyUsage $ bitsToFlags bits+ extDecode _ = Left "unknown sequence" data ExtSubjectKeyId = ExtSubjectKeyId L.ByteString- deriving (Show,Eq)+ deriving (Show,Eq) instance Extension ExtSubjectKeyId where- extOID = const [2,5,29,14]- extEncode (ExtSubjectKeyId o) = [OctetString o]- extDecode [OctetString o] = Right $ ExtSubjectKeyId o- extDecode _ = Left "unknown sequence"+ extOID = const [2,5,29,14]+ extEncode (ExtSubjectKeyId o) = [OctetString o]+ extDecode [OctetString o] = Right $ ExtSubjectKeyId o+ extDecode _ = Left "unknown sequence" data ExtSubjectAltName = ExtSubjectAltName [String]- deriving (Show,Eq)+ deriving (Show,Eq) instance Extension ExtSubjectAltName where- extOID = const [2,5,29,17]- extEncode (ExtSubjectAltName names) =- [Start Sequence]- ++ map (Other Context 2 . BC.pack) names- ++ [End Sequence]- extDecode l = runParseASN1 parse l where- parse = do- c <- getNextContainer Sequence- return $ ExtSubjectAltName $ map toStringy c- toStringy (Other Context 2 b) = BC.unpack b- toStringy b = error ("not coping with anything else " ++ show b)+ extOID = const [2,5,29,17]+ extEncode (ExtSubjectAltName names) =+ [Start Sequence]+ ++ map (Other Context 2 . BC.pack) names+ ++ [End Sequence]+ extDecode l = runParseASN1 parse l where+ parse = do+ c <- getNextContainer Sequence+ r <- sequence $ map toStringy c+ return $ ExtSubjectAltName r+ toStringy (Other Context 2 b) = return $ BC.unpack b+ toStringy b = throwError ("ExtSubjectAltName: not coping with anything else " ++ show b) data ExtAuthorityKeyId = ExtAuthorityKeyId B.ByteString- deriving (Show,Eq)+ deriving (Show,Eq) instance Extension ExtAuthorityKeyId where- extOID _ = [2,5,29,35]- extEncode (ExtAuthorityKeyId keyid) =- [Start Sequence,Other Context 0 keyid,End Sequence]- extDecode [Start Sequence,Other Context 0 keyid,End Sequence] =- Right $ ExtAuthorityKeyId keyid- extDecode _ = Left "unknown sequence"+ extOID _ = [2,5,29,35]+ extEncode (ExtAuthorityKeyId keyid) =+ [Start Sequence,Other Context 0 keyid,End Sequence]+ extDecode [Start Sequence,Other Context 0 keyid,End Sequence] =+ Right $ ExtAuthorityKeyId keyid+ extDecode _ = Left "unknown sequence" bitsToFlags :: Enum a => BitArray -> [a] bitsToFlags bits = concat $ flip map [0..(bitArrayLength bits-1)] $ \i -> do- let isSet = bitArrayGetBit bits i- if isSet then [toEnum $ fromIntegral i] else []+ let isSet = bitArrayGetBit bits i+ if isSet then [toEnum $ fromIntegral i] else [] flagsToBits :: Enum a => [a] -> BitArray flagsToBits flags = foldl bitArraySetBit bitArrayEmpty $ map (fromIntegral . fromEnum) flags- where bitArrayEmpty = BitArray 2 (L.pack [0,0])+ where bitArrayEmpty = BitArray 2 (L.pack [0,0])
Data/Certificate/X509/Internal.hs view
@@ -1,95 +1,22 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}- module Data.Certificate.X509.Internal- ( ParseASN1- , runParseASN1- , onNextContainer- , onNextContainerMaybe- , getNextContainer- , getNextContainerMaybe- , getNext- , hasNext- , makeASN1Sequence- , asn1Container- , OID- ) where+ ( module Data.ASN1.Parse+ , makeASN1Sequence+ , asn1Container+ , OID+ ) where -import Data.ASN1.DER-import Data.ASN1.Stream (getConstructedEnd)-import Control.Monad.State-import Control.Monad.Error+import Data.ASN1.Stream+import Data.ASN1.Parse type OID = [Integer] -newtype ParseASN1 a = P { runP :: ErrorT String (State [ASN1]) a }- deriving (Functor, Monad, MonadError String)--runParseASN1 :: ParseASN1 a -> [ASN1] -> Either String a-runParseASN1 f s =- case runState (runErrorT (runP f)) s of- (Left err, _) -> Left err- (Right r, _) -> Right r--getNext :: ParseASN1 ASN1-getNext = do- list <- P (lift get)- case list of- [] -> throwError "empty"- (h:l) -> P (lift (put l)) >> return h--getNextContainer :: ASN1ConstructionType -> ParseASN1 [ASN1]-getNextContainer ty = do- list <- P (lift get)- case list of- [] -> throwError "empty"- (h:l) -> if h == Start ty- then do- let (l1, l2) = getConstructedEnd 0 l- P (lift $ put l2) >> return l1- else throwError "not an expected container"---onNextContainer :: ASN1ConstructionType -> ParseASN1 a -> ParseASN1 a-onNextContainer ty f = do- n <- getNextContainer ty- case runParseASN1 f n of- Left err -> throwError err- Right r -> return r--getNextContainerMaybe :: ASN1ConstructionType -> ParseASN1 (Maybe [ASN1])-getNextContainerMaybe ty = do- list <- P (lift get)- case list of- [] -> return Nothing- (h:l) -> if h == Start ty- then do- let (l1, l2) = getConstructedEnd 0 l- P (lift $ put l2) >> return (Just l1)- else return Nothing--onNextContainerMaybe :: ASN1ConstructionType -> ParseASN1 a -> ParseASN1 (Maybe a)-onNextContainerMaybe ty f = do- n <- getNextContainerMaybe ty- case n of- Just l -> case runParseASN1 f l of- Left err -> throwError err- Right r -> return $ Just r- Nothing -> return Nothing--hasNext :: ParseASN1 Bool-hasNext = do- list <- P (lift get)- case list of- [] -> return False- _ -> return True- asn1Container :: ASN1ConstructionType -> [ASN1] -> [ASN1] asn1Container ty l = [Start ty] ++ l ++ [End ty] makeASN1Sequence :: [ASN1] -> [[ASN1]] makeASN1Sequence list =- let (l1, l2) = getConstructedEnd 0 list in- case l2 of- [] -> []- _ -> l1 : makeASN1Sequence l2+ let (l1, l2) = getConstructedEnd 0 list in+ case l2 of+ [] -> []+ _ -> l1 : makeASN1Sequence l2
+ Data/CertificateStore.hs view
@@ -0,0 +1,40 @@+module Data.CertificateStore+ ( CertificateStore+ , makeCertificateStore+ -- * Queries+ , findCertificate+ , listCertificates+ ) where++import Data.List (foldl')+import Data.Monoid+import Data.Certificate.X509+import qualified Data.Map as M+import Control.Monad (mplus)++-- | A Collection of certificate or store of certificates.+data CertificateStore = CertificateStore (M.Map DistinguishedName X509)+ | CertificateStores [CertificateStore]++instance Monoid CertificateStore where+ mempty = CertificateStore M.empty+ mappend s1@(CertificateStore _) s2@(CertificateStore _) = CertificateStores [s1,s2]+ mappend (CertificateStores l) s2@(CertificateStore _) = CertificateStores (l ++ [s2])+ mappend s1@(CertificateStore _) (CertificateStores l) = CertificateStores ([s1] ++ l)+ mappend (CertificateStores l1) (CertificateStores l2) = CertificateStores (l1 ++ l2)++-- | Create a certificate store out of a list of X509 certificate+makeCertificateStore :: [X509] -> CertificateStore+makeCertificateStore = CertificateStore . foldl' accumulate M.empty+ where accumulate m x509 = M.insert (certSubjectDN $ x509Cert x509) x509 m++-- | Find a certificate using the subject distinguished name+findCertificate :: DistinguishedName -> CertificateStore -> Maybe X509+findCertificate dn store = lookupIn store+ where lookupIn (CertificateStore m) = M.lookup dn m+ lookupIn (CertificateStores l) = foldl mplus Nothing $ map lookupIn l++-- | List all certificates in a store+listCertificates :: CertificateStore -> [X509]+listCertificates (CertificateStore store) = map snd $ M.toList store+listCertificates (CertificateStores l) = concatMap listCertificates l
System/Certificate/X509.hs view
@@ -7,7 +7,7 @@ -- Portability : good -- module System.Certificate.X509- ( findCertificate+ ( getSystemCertificateStore ) where #if defined(WINDOWS)
System/Certificate/X509/MacOS.hs view
@@ -1,23 +1,26 @@ module System.Certificate.X509.MacOS- ( findCertificate+ ( getSystemCertificateStore ) where +import Data.PEM (pemParseLBS, PEM(..)) import Data.Certificate.X509-import Data.Certificate.PEM import System.Process-import Data.ByteString hiding (filter, map) import qualified Data.ByteString.Lazy as LBS import Control.Applicative import Data.Either-import Data.Maybe -keyChain :: String-keyChain = "/System/Library/Keychains/SystemRootCertificates.keychain"+import Data.CertificateStore -findCertificate :: (X509 -> Bool) -> IO (Maybe X509)-findCertificate f = do- (_, Just hout, _, ph) <- createProcess (proc "security" ["find-certificate", "-pa", keyChain]) { std_out = CreatePipe }- pems <- parsePEMs <$> hGetContents hout- _ <- waitForProcess ph- let targets = rights $ map (decodeCertificate . LBS.fromChunks . pure . snd) $ filter ((=="CERTIFICATE") . fst) pems- return $ listToMaybe $ filter f targets+rootCAKeyChain :: String+rootCAKeyChain = "/System/Library/Keychains/SystemRootCertificates.keychain"++listInKeyChain :: String -> IO [X509]+listInKeyChain keyChain = do+ (_, Just hout, _, ph) <- createProcess (proc "security" ["find-certificate", "-pa", keyChain]) { std_out = CreatePipe }+ pems <- either error id . pemParseLBS <$> LBS.hGetContents hout+ let targets = rights $ map (decodeCertificate . LBS.fromChunks . pure . pemContent) $ filter ((=="CERTIFICATE") . pemName) pems+ _ <- targets `seq` waitForProcess ph+ return targets++getSystemCertificateStore :: IO CertificateStore+getSystemCertificateStore = makeCertificateStore <$> listInKeyChain rootCAKeyChain
System/Certificate/X509/Unix.hs view
@@ -13,26 +13,26 @@ -- default is SYSTEM_CERTIFICATE_PATH -- module System.Certificate.X509.Unix- ( getSystemPath- , readAll- , findCertificate- ) where+ ( getSystemCertificateStore+ ) where -import System.Directory (getDirectoryContents)+import System.Directory (getDirectoryContents, doesFileExist) import System.Environment (getEnv)-import Data.List (isPrefixOf)+import System.FilePath ((</>)) +import Data.List (isPrefixOf)+import Data.PEM (PEM(..), pemParseBS) import Data.Either import Data.Certificate.X509-import Data.Certificate.PEM import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L+import Data.CertificateStore import Control.Applicative ((<$>))-import Control.Exception-import Control.Monad+import Control.Monad (filterM)+import qualified Control.Exception as E -import Prelude hiding (catch)+import Data.Char defaultSystemPath :: FilePath defaultSystemPath = "/etc/ssl/certs/"@@ -40,42 +40,27 @@ envPathOverride :: String envPathOverride = "SYSTEM_CERTIFICATE_PATH" -getSystemPath :: IO FilePath-getSystemPath = catch (getEnv envPathOverride) inDefault- where- inDefault :: IOException -> IO FilePath- inDefault _ = return defaultSystemPath--data ReadErr =- Exception IOException- | CertError String- deriving (Show,Eq)+listDirectoryCerts :: FilePath -> IO [FilePath]+listDirectoryCerts path = (map (path </>) . filter isCert <$> getDirectoryContents path)+ >>= filterM doesFileExist+ where isHashedFile s = length s == 10+ && isDigit (s !! 9)+ && (s !! 8) == '.'+ && all isHexDigit (take 8 s)+ isCert x = (not $ isPrefixOf "." x) && (not $ isHashedFile x) -readCertificate :: FilePath -> IO (Either ReadErr X509)-readCertificate file = do- rawdata <- try $ B.readFile file :: IO (Either IOException B.ByteString)- either (return . Left . Exception) parseCert $ rawdata- where- parseCert pemdata = case parsePEMCert pemdata of- Nothing -> return $ Left $ CertError "certificate not in PEM format"- Just certdata -> do- return $ either (Left . CertError) Right $ decodeCertificate $ L.fromChunks [certdata]+getSystemCertificateStore :: IO CertificateStore+getSystemCertificateStore = makeCertificateStore . concat <$> (getSystemPath >>= listDirectoryCerts >>= mapM readCertificates) -readAll :: IO [Either ReadErr X509]-readAll = do- path <- getSystemPath- certfiles <- filter (not . isPrefixOf ".") <$> getDirectoryContents path- forM certfiles $ \certfile -> readCertificate (path ++ certfile)+getSystemPath :: IO FilePath+getSystemPath = E.catch (getEnv envPathOverride) inDefault+ where+ inDefault :: E.IOException -> IO FilePath+ inDefault _ = return defaultSystemPath -findCertificate :: (X509 -> Bool) -> IO (Maybe X509)-findCertificate f = do- path <- getSystemPath- certfiles <- filter (not . isPrefixOf ".") <$> getDirectoryContents path- loop $ map (path ++) certfiles- where- loop [] = return Nothing- loop (x:xs) = do- ox509 <- readCertificate x- case ox509 of- Left _ -> loop xs- Right x509 -> if f x509 then return $ Just x509 else loop xs+readCertificates :: FilePath -> IO [X509]+readCertificates file = E.catch (either (const []) (rights . map getCert) . pemParseBS <$> B.readFile file) skipIOError+ where+ getCert pem = decodeCertificate $ L.fromChunks [pemContent pem]+ skipIOError :: E.IOException -> IO [X509]+ skipIOError _ = return []
System/Certificate/X509/Win32.hs view
@@ -1,7 +1,8 @@ module System.Certificate.X509.Win32- ( findCertificate+ ( getSystemCertificateStore ) where +{- import Foreign.Marshal.Alloc (allocaBytes) import Foreign.Ptr (castPtr) @@ -18,6 +19,7 @@ import Data.Certificate.X509.Cert import Data.Bits+import Data.CertificateStore defaultSystemPath :: FilePath defaultSystemPath = "SOFTWARE\\Microsoft\\SystemCertificates\\CA\\Certificates"@@ -35,26 +37,22 @@ B.create (fromIntegral len) (\bptr -> B.memcpy bptr mem len) | otherwise = error "certificate blob have unexpected type" -getSystemPath :: IO FilePath-getSystemPath = undefined- data ReadErr = Exception IOException | CertError String deriving (Show,Eq) -findCertificate :: (X509 -> Bool) -> IO (Maybe X509)-findCertificate f = do- hashes <- listSubDirectories defaultSystemPath- loop hashes- where- readCertificate path = do- b <- openValue path "Blob" fromBlob- return $ decodeCertificate $ L.fromChunks [b]+readCertificate dir hash = do+ b <- openValue path "Blob" fromBlob+ return $ decodeCertificate $ L.fromChunks [b]+ where path = dir ++ "\\" ++ hash - loop [] = return Nothing- loop (x:xs) = do- cert <- readCertificate (defaultSystemPath ++ "\\" ++ x)- case cert of- Left _ -> loop xs- Right x509 -> if f x509 then return $ Just x509 else loop xs+listIn dir = listSubDirectories dir >>= \hs -> (rights <$> mapM (readCertificate dir) hs)++getSystemCertificateStore :: IO CertificateStore+getSystemCertificateStore = makeCertificateStore <$> listIn defaultSystemPath+-}+import Data.CertificateStore++getSystemCertificateStore :: IO CertificateStore+getSystemCertificateStore = return (makeCertificateStore [])
certificate.cabal view
@@ -1,5 +1,5 @@ Name: certificate-Version: 1.1.1+Version: 1.3.9 Description: Certificates and Key reader/writer .@@ -29,29 +29,32 @@ Build-Depends: base >= 3 && < 5 , bytestring , mtl- , asn1-data >= 0.6.1.3 && < 0.7- , base64-bytestring- , crypto-pubkey-types+ , pem >= 0.1 && < 0.3+ , asn1-data >= 0.7.1 && < 0.8.0+ , crypto-pubkey-types >= 0.4 && < 0.5+ , cryptohash+ , containers , directory+ , filepath+ , process , time Exposed-modules: Data.Certificate.X509 Data.Certificate.X509.Cert Data.Certificate.X509.Ext- Data.Certificate.PEM Data.Certificate.KeyDSA Data.Certificate.KeyRSA+ Data.CertificateStore System.Certificate.X509- Other-modules: Data.Certificate.X509.Internal System.Certificate.X509.Unix+ System.Certificate.X509.MacOS+ Other-modules: Data.Certificate.X509.Internal ghc-options: -Wall if os(windows) cpp-options: -DWINDOWS Build-Depends: Win32- Other-modules: System.Certificate.X509.Win32+ Exposed-modules: System.Certificate.X509.Win32 if os(OSX) cpp-options: -DMACOSX- Build-Depends: process- Other-modules: System.Certificate.X509.MacOS Executable certificate Main-Is: Certificate.hs@@ -60,7 +63,7 @@ Build-depends: cmdargs , text >= 0.11 , cryptohash- , cryptocipher >= 0.3.0+ , crypto-pubkey , directory else Buildable: False@@ -76,3 +79,4 @@ source-repository head type: git location: git://github.com/vincenthz/hs-certificate+ subdir: certificate