diff --git a/Certificate.hs b/Certificate.hs --- a/Certificate.hs +++ b/Certificate.hs @@ -7,6 +7,7 @@ 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.List (find) @@ -16,7 +17,8 @@ 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 @@ -38,8 +40,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: " @@ -167,11 +172,19 @@ Right asn1 -> showASN1 0 asn1 when (text opts || not (or [asn1 opts,raw opts])) $ showCert x509 - when (verify opts) $ verifyCert x509 + 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) @@ -236,6 +249,7 @@ , text :: Bool , raw :: Bool , verify :: Bool + , hash :: Bool } | Key { files :: [FilePath] @@ -248,6 +262,7 @@ , text = def , raw = def , verify = def + , hash = def } &= help "x509 certificate related commands" keyOpts = Key diff --git a/Data/Certificate/X509.hs b/Data/Certificate/X509.hs --- a/Data/Certificate/X509.hs +++ b/Data/Certificate/X509.hs @@ -20,7 +20,7 @@ , OID , ASN1StringType(..) , ASN1String - , DistinguishedName + , DistinguishedName(..) , Certificate(..) , module Data.Certificate.X509.Ext @@ -31,17 +31,22 @@ , decodeCertificate , encodeCertificate - -- * serialization from ASN1 bytestring + -- * Distinguished names related function , decodeDN , encodeDN + , hashDN + , hashDN_old ) where +import Data.Char import Data.Word 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 @@ -49,6 +54,9 @@ 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 @@ -69,7 +77,7 @@ getSigningData :: X509 -> L.ByteString getSigningData (X509 _ (Just e) _ _ _) = e getSigningData (X509 cert Nothing _ _ _) = encodeASN1 DER header - where header = asn1Container Sequence $ encodeCertificateHeader cert + where header = asn1Container Sequence $ toASN1 cert {- | decode an X509 from a bytestring - the structure is the following: @@ -84,11 +92,11 @@ - * the header - * the signature algorithm - * the signature -} - parseRootASN1 l = onContainer rootseq $ \l2 -> + 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 (runParseASN1 parseCertificate . map fst) 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 @@ -96,8 +104,6 @@ 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 onContainer ((Start _, _) : l) f = case reverse l of @@ -115,7 +121,7 @@ where esigalg = asn1Container Sequence [OID (sigOID sigalg), Null] esig = BitString $ toBitArray (L.pack sigbits) 0 - header = asn1Container Sequence $ encodeCertificateHeader cert + header = asn1Container Sequence $ toASN1 cert rootSeq = asn1Container Sequence (header ++ esigalg ++ [esig]) decodeDN :: L.ByteString -> Either String DistinguishedName @@ -123,3 +129,19 @@ 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 @@ -9,7 +9,7 @@ , ASN1StringType(..) , ASN1String , Certificate(..) - , DistinguishedName + , DistinguishedName(..) , OID -- various OID @@ -22,12 +22,9 @@ , oidSig , sigOID - -- * certificate to/from asn1 - , parseCertificate - , encodeCertificateHeader - -- * Parse and encode a single distinguished name , parseDN + , encodeDNinner , encodeDN -- * extensions @@ -35,11 +32,13 @@ ) where import Data.Word -import Data.List (find, sortBy) +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) @@ -103,11 +102,16 @@ | 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) -type DistinguishedName = [(OID, ASN1String)] +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 @@ -119,6 +123,10 @@ , 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] @@ -126,13 +134,10 @@ oidOrganizationUnit = [2,5,4,11] 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 @@ -209,11 +214,8 @@ encodeAsn1String (IA5, x) = IA5String x encodeAsn1String (T61, x) = T61String x -parseCertHeaderDN :: ParseASN1 [(OID, ASN1String)] -parseCertHeaderDN = parseDN - -parseDN :: ParseASN1 [(OID, ASN1String)] -parseDN = onNextContainer Sequence getDNs where +parseDN :: ParseASN1 DistinguishedName +parseDN = DistinguishedName <$> onNextContainer Sequence getDNs where getDNs = do n <- hasNext if n @@ -265,9 +267,8 @@ _ -> throwError "expecting bitstring" parseCertExtensions :: ParseASN1 (Maybe [ExtensionRaw]) -parseCertExtensions = onNextContainerMaybe (Container Context 3) (sortByOID . mapMaybe extractExtension <$> onNextContainer Sequence getSequences) +parseCertExtensions = onNextContainerMaybe (Container Context 3) (mapMaybe extractExtension <$> onNextContainer Sequence getSequences) where - sortByOID = sortBy (\(a,_,_) (b,_,_) -> a `compare` b) getSequences = do n <- hasNext if n @@ -302,9 +303,9 @@ version <- parseCertHeaderVersion serial <- parseCertHeaderSerial sigalg <- parseCertHeaderAlgorithmID - issuer <- parseCertHeaderDN + issuer <- parseDN validity <- parseCertHeaderValidity - subject <- parseCertHeaderDN + subject <- parseDN pk <- parseCertHeaderSubjectPK exts <- parseCertExtensions hnext <- hasNext @@ -314,19 +315,19 @@ { certVersion = version , certSerial = serial , certSignatureAlg = sigalg - , certIssuerDN = sortByOID issuer - , certSubjectDN = sortByOID subject + , certIssuerDN = issuer + , certSubjectDN = subject , certValidity = validity , certPubKey = pk , certExtensions = exts } - where sortByOID = sortBy (\a b -> fst a `compare` fst b) +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 :: [ (OID, ASN1String) ] -> [ASN1] -encodeDN dn = asn1Container Sequence $ concatMap dnSet dn - where - dnSet (oid, stringy) = asn1Container Set (asn1Container Sequence [OID oid, encodeAsn1String stringy]) +encodeDN :: DistinguishedName -> [ASN1] +encodeDN dn = asn1Container Sequence $ encodeDNinner id dn encodePK :: PubKey -> [ASN1] encodePK k@(PubKeyRSA pubkey) = 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,24 +1,26 @@ module System.Certificate.X509.MacOS - ( findCertificate + ( getSystemCertificateStore ) where import Data.PEM (pemParseLBS, PEM(..)) import Data.Certificate.X509 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 <- either error id . pemParseLBS <$> LBS.hGetContents hout - let targets = rights $ map (decodeCertificate . LBS.fromChunks . pure . pemContent) $ filter ((=="CERTIFICATE") . pemName) pems - let cert = listToMaybe $ filter f targets - _ <- cert `seq` waitForProcess ph - return cert +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 @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} -- | -- Module : System.Certificate.X509 -- License : BSD-style @@ -14,27 +13,26 @@ -- default is SYSTEM_CERTIFICATE_PATH -- module System.Certificate.X509.Unix - ( getSystemPath - , readAll - , findCertificate + ( getSystemCertificateStore ) where -import System.Directory (getDirectoryContents) +import System.Directory (getDirectoryContents, doesFileExist) import System.Environment (getEnv) -import Data.List (isPrefixOf, find) +import System.FilePath (()) +import Data.List (isPrefixOf) import Data.PEM (PEM(..), pemParseBS) import Data.Either import Data.Certificate.X509 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 (filterM) +import qualified Control.Exception as E -#if !MIN_VERSION_base(4,6,0) -import Prelude hiding (catch) -#endif +import Data.Char defaultSystemPath :: FilePath defaultSystemPath = "/etc/ssl/certs/" @@ -42,28 +40,24 @@ envPathOverride :: String envPathOverride = "SYSTEM_CERTIFICATE_PATH" -listSystemCertificates :: IO [FilePath] -listSystemCertificates = do - path <- getSystemPath - map (path ++) . filter (not . isPrefixOf ".") <$> getDirectoryContents path +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) +getSystemCertificateStore :: IO CertificateStore +getSystemCertificateStore = makeCertificateStore . concat <$> (getSystemPath >>= listDirectoryCerts >>= mapM readCertificates) + getSystemPath :: IO FilePath -getSystemPath = catch (getEnv envPathOverride) inDefault +getSystemPath = E.catch (getEnv envPathOverride) inDefault where - inDefault :: IOException -> IO FilePath + inDefault :: E.IOException -> IO FilePath inDefault _ = return defaultSystemPath readCertificates :: FilePath -> IO [X509] readCertificates file = either (const []) (rights . map getCert) . pemParseBS <$> B.readFile file where getCert pem = decodeCertificate $ L.fromChunks [pemContent pem] - -readAll :: IO [X509] -readAll = do - certfiles <- listSystemCertificates - concat . rights <$> mapM (trySE . readCertificates) certfiles - -findCertificate :: (X509 -> Bool) -> IO (Maybe X509) -findCertificate f = find f <$> readAll - -trySE :: IO a -> IO (Either SomeException a) -trySE = try 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,5 +1,5 @@ module System.Certificate.X509.Win32 - ( findCertificate + ( getSystemCertificateStore ) where import Foreign.Marshal.Alloc (allocaBytes) @@ -19,6 +19,8 @@ import Data.Bits +import Data.CertificateStore + defaultSystemPath :: FilePath defaultSystemPath = "SOFTWARE\\Microsoft\\SystemCertificates\\CA\\Certificates" @@ -32,29 +34,20 @@ fromBlob mem ty | ty == rEG_BINARY = do len <- B.c_strlen (castPtr mem) - B.create (fromIntegral len) (\bptr -> B.memcpy bptr mem (fromIntegral len)) + 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 diff --git a/certificate.cabal b/certificate.cabal --- a/certificate.cabal +++ b/certificate.cabal @@ -1,5 +1,5 @@ Name: certificate -Version: 1.2.9 +Version: 1.3.0 Description: Certificates and Key reader/writer . @@ -32,7 +32,10 @@ , pem >= 0.1 && < 0.2 , asn1-data >= 0.7.1 , crypto-pubkey-types >= 0.1 && < 0.2 + , cryptohash + , containers , directory + , filepath , process , time Exposed-modules: Data.Certificate.X509 @@ -40,6 +43,7 @@ Data.Certificate.X509.Ext Data.Certificate.KeyDSA Data.Certificate.KeyRSA + Data.CertificateStore System.Certificate.X509 System.Certificate.X509.Unix System.Certificate.X509.MacOS