diff --git a/Certificate.hs b/Certificate.hs --- a/Certificate.hs +++ b/Certificate.hs @@ -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 diff --git a/Data/Certificate/KeyDSA.hs b/Data/Certificate/KeyDSA.hs --- a/Data/Certificate/KeyDSA.hs +++ b/Data/Certificate/KeyDSA.hs @@ -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 diff --git a/Data/Certificate/KeyRSA.hs b/Data/Certificate/KeyRSA.hs --- a/Data/Certificate/KeyRSA.hs +++ b/Data/Certificate/KeyRSA.hs @@ -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) diff --git a/Data/Certificate/PEM.hs b/Data/Certificate/PEM.hs deleted file mode 100644 --- a/Data/Certificate/PEM.hs +++ /dev/null @@ -1,67 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - --- | --- Module : Data.Certificate.PEM --- License : BSD-style --- Maintainer : Vincent Hanquez --- 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 diff --git a/Data/Certificate/X509.hs b/Data/Certificate/X509.hs --- a/Data/Certificate/X509.hs +++ b/Data/Certificate/X509.hs @@ -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 diff --git a/Data/Certificate/X509/Cert.hs b/Data/Certificate/X509/Cert.hs --- a/Data/Certificate/X509/Cert.hs +++ b/Data/Certificate/X509/Cert.hs @@ -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) diff --git a/Data/Certificate/X509/Ext.hs b/Data/Certificate/X509/Ext.hs --- a/Data/Certificate/X509/Ext.hs +++ b/Data/Certificate/X509/Ext.hs @@ -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]) diff --git a/Data/Certificate/X509/Internal.hs b/Data/Certificate/X509/Internal.hs --- a/Data/Certificate/X509/Internal.hs +++ b/Data/Certificate/X509/Internal.hs @@ -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 diff --git a/Data/CertificateStore.hs b/Data/CertificateStore.hs new file mode 100644 --- /dev/null +++ b/Data/CertificateStore.hs @@ -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 diff --git a/System/Certificate/X509.hs b/System/Certificate/X509.hs --- a/System/Certificate/X509.hs +++ b/System/Certificate/X509.hs @@ -7,7 +7,7 @@ -- Portability : good -- module System.Certificate.X509 - ( findCertificate + ( getSystemCertificateStore ) where #if defined(WINDOWS) diff --git a/System/Certificate/X509/MacOS.hs b/System/Certificate/X509/MacOS.hs --- a/System/Certificate/X509/MacOS.hs +++ b/System/Certificate/X509/MacOS.hs @@ -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 diff --git a/System/Certificate/X509/Unix.hs b/System/Certificate/X509/Unix.hs --- a/System/Certificate/X509/Unix.hs +++ b/System/Certificate/X509/Unix.hs @@ -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 [] diff --git a/System/Certificate/X509/Win32.hs b/System/Certificate/X509/Win32.hs --- a/System/Certificate/X509/Win32.hs +++ b/System/Certificate/X509/Win32.hs @@ -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 []) diff --git a/certificate.cabal b/certificate.cabal --- a/certificate.cabal +++ b/certificate.cabal @@ -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