certificate 1.2.9 → 1.3.0

raw patch · 9 files changed

+177/−106 lines, 9 filesdep +containersdep +filepathPVP ok

version bump matches the API change (PVP)

Dependencies added: containers, filepath

API changes (from Hackage documentation)

Files

• Certificate.hs +21/−6
• Data/Certificate/X509.hs +30/−8
• Data/Certificate/X509/Cert.hs +32/−31
• Data/CertificateStore.hs +40/−0
• System/Certificate/X509.hs +1/−1
• System/Certificate/X509/MacOS.hs +15/−13
• System/Certificate/X509/Unix.hs +21/−27
• System/Certificate/X509/Win32.hs +12/−19
• certificate.cabal +5/−1

@@ -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

@@ -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

@@ -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) =

@@ -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

@@ -7,7 +7,7 @@ -- Portability : good -- module System.Certificate.X509-	( findCertificate+	( getSystemCertificateStore 	) where  #if defined(WINDOWS)

@@ -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

@@ -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

@@ -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

@@ -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