certificate-1.3.9/0000755000000000000000000000000012224415310012166 5ustar0000000000000000certificate-1.3.9/LICENSE0000644000000000000000000000272412224415310013200 0ustar0000000000000000Copyright (c) 2010 Vincent Hanquez All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 3. Neither the name of the author nor the names of his contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. certificate-1.3.9/Tests.hs0000644000000000000000000000007612224415310013627 0ustar0000000000000000import qualified Tests.Unit as Unit main = do Unit.runTests certificate-1.3.9/Certificate.hs0000644000000000000000000002541112224415310014747 0ustar0000000000000000{-# 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.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 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.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.Encoding import Data.ASN1.BinaryEncoding import Data.ASN1.Stream import Data.ASN1.BitArray import Text.Printf import Numeric hexdump :: L.ByteString -> String hexdump bs = concatMap hex $ L.unpack bs where hex n | n > 0xa = showHex n "" | otherwise = "0" ++ showHex n "" 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: " showKnownExtension (X509.extensionGet es :: Maybe X509.ExtBasicConstraints) showKnownExtension (X509.extensionGet es :: Maybe X509.ExtKeyUsage) showKnownExtension (X509.extensionGet es :: Maybe X509.ExtSubjectKeyId) showKnownExtension (X509.extensionGet es :: Maybe X509.ExtSubjectAltName) showKnownExtension (X509.extensionGet es :: Maybe X509.ExtAuthorityKeyId) where showExt (oid,critical,asn1) = do putStrLn (" OID: " ++ show oid ++ " critical: " ++ show critical) putStrLn (" " ++ show asn1) showKnownExtension Nothing = return () showKnownExtension (Just e) = putStrLn (" " ++ show e) showCert :: X509.X509 -> IO () showCert (X509.X509 cert _ _ sigalg sigbits) = do putStrLn ("version: " ++ show (X509.certVersion cert)) putStrLn ("serial: " ++ show (X509.certSerial cert)) putStrLn ("sigalg: " ++ show (X509.certSignatureAlg cert)) putStrLn "issuer:" showDN $ X509.certIssuerDN cert putStrLn "subject:" showDN $ X509.certSubjectDN cert putStrLn ("valid: " ++ show (X509.certValidity cert)) case X509.certPubKey cert of X509.PubKeyRSA pubkey -> do putStrLn "public key RSA:" printf " len : %d\n" (RSA.public_size pubkey) printf " modulus: %x\n" (RSA.public_n pubkey) printf " e : %x\n" (RSA.public_e pubkey) X509.PubKeyDSA pubkey -> do let params = DSA.public_params pubkey putStrLn "public key DSA:" printf " pub : %x\n" (DSA.public_y pubkey) 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 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 -> printf "public key: %s\n" (show pk) case X509.certExtensions cert of Nothing -> return () Just es -> do putStrLn "extensions:" showExts es putStrLn ("sigAlg: " ++ show sigalg) putStrLn ("sig: " ++ show sigbits) showRSAKey :: (RSA.PublicKey,RSA.PrivateKey) -> String showRSAKey (pubkey,privkey) = unlines [ "len-modulus: " ++ (show $ RSA.public_size pubkey) , "modulus: " ++ (show $ RSA.public_n pubkey) , "public exponant: " ++ (show $ RSA.public_e pubkey) , "private exponant: " ++ (show $ RSA.private_d privkey) , "p1: " ++ (show $ RSA.private_p privkey) , "p2: " ++ (show $ RSA.private_q privkey) , "exp1: " ++ (show $ RSA.private_dP privkey) , "exp2: " ++ (show $ RSA.private_dQ privkey) , "coefficient: " ++ (show $ RSA.private_qinv privkey) ] 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 indent n = putStr (replicate n ' ') prettyPrint n [] = return () prettyPrint n (x@(Start _) : xs) = indent n >> p x >> putStrLn "" >> prettyPrint (n+1) xs prettyPrint n (x@(End _) : xs) = indent (n-1) >> p x >> putStrLn "" >> prettyPrint (n-1) xs prettyPrint n (x : xs) = indent n >> p x >> putStrLn "" >> prettyPrint n xs p (Boolean b) = putStr ("bool: " ++ show b) p (IntVal i) = putStr ("int: " ++ showHex i "") p (BitString bits) = putStr ("bitstring: " ++ (hexdump $ bitArrayGetData bits)) p (OctetString bs) = putStr ("octetstring: " ++ hexdump bs) p (Null) = putStr "null" p (OID is) = putStr ("OID: " ++ show is) p (Real d) = putStr "real" p (Enumerated) = putStr "enum" p (UTF8String t) = putStr ("utf8string:" ++ t) p (Start Sequence) = putStr "sequence" p (End Sequence) = putStr "end-sequence" p (Start Set) = putStr "set" p (End Set) = putStr "end-set" p (Start _) = putStr "container" p (End _) = putStr "end-container" p (NumericString bs) = putStr "numericstring:" p (PrintableString t) = putStr ("printablestring: " ++ t) p (T61String bs) = putStr "t61string:" p (VideoTexString bs) = putStr "videotexstring:" p (IA5String bs) = putStr "ia5string:" p (UTCTime time) = putStr ("utctime: " ++ show time) p (GeneralizedTime time) = putStr ("generalizedtime: " ++ show time) p (GraphicString bs) = putStr "graphicstring:" p (VisibleString bs) = putStr "visiblestring:" p (GeneralString bs) = putStr "generalstring:" p (UniversalString t) = putStr ("universalstring:" ++ t) p (CharacterString bs) = putStr "characterstring:" p (BMPString t) = putStr ("bmpstring: " ++ t) p (Other tc tn x) = putStr "other" 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 decodeASN1' BER cert of Left err -> error ("decoding ASN1 failed: " ++ show err) Right asn1 -> showASN1 0 asn1 when (text opts || not (or [asn1 opts,raw opts])) $ showCert x509 when (hash opts) $ hashCert x509 when (verify opts) $ getSystemCertificateStore >>= flip verifyCert x509 where 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) (B.pack sig) sigalg (X509.certPubKey syscert) rsaVerify hdesc pk a b = Right $ RSA.verify hdesc pk a b verifyF (X509.SignatureALG hash X509.PubKeyALG_RSA) (X509.PubKeyRSA rsak) = 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 hdesc rsak verifyF (X509.SignatureALG _ X509.PubKeyALG_DSA) (X509.PubKeyDSA dsak) = (\_ _ -> Left "unimplemented DSA checking") verifyF _ _ = (\_ _ -> Left "unexpected/wrong signature") verifyAlg toSign expectedSig sigalg pk = let f = verifyF sigalg pk in case f toSign expectedSig of Left err -> putStrLn ("certificate couldn't be verified: something happened: " ++ show err) Right True -> putStrLn "certificate verified" Right False -> putStrLn "certificate not verified" matchsysX509 cert (X509.X509 syscert _ _ _ _) = do 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 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 [pemContent x] case rsaKey of Left err -> error err Right k -> putStrLn $ showRSAKey k (_, Just x) -> do let rsaKey = KeyDSA.decodePrivate $ L.fromChunks [pemContent x] case rsaKey of Left err -> error err Right k -> putStrLn $ showDSAKey k _ -> do putStrLn "no recognized private key found" data CertMainOpts = X509 { files :: [FilePath] , asn1 :: Bool , text :: Bool , raw :: Bool , verify :: Bool , hash :: Bool } | Key { files :: [FilePath] } deriving (Show,Data,Typeable) x509Opts = X509 { files = def &= args &= typFile , asn1 = def , text = def , raw = def , verify = def , hash = def } &= help "x509 certificate related commands" keyOpts = Key { files = def &= args &= typFile } &= help "keys related commands" mode = cmdArgsMode $ modes [x509Opts,keyOpts] &= help "create, manipulate certificate (x509,etc) and keys" &= program "certificate" &= summary "certificate v0.1" main = cmdArgsRun mode >>= doMain certificate-1.3.9/certificate.cabal0000644000000000000000000000510312224415310015433 0ustar0000000000000000Name: certificate Version: 1.3.9 Description: Certificates and Key reader/writer . At the moment only X509 certificate and unencrypted private key are supported, but will include PGP certificate and pkcs8 private keys License: BSD3 License-file: LICENSE Copyright: Vincent Hanquez Author: Vincent Hanquez Maintainer: Vincent Hanquez Synopsis: Certificates and Key Reader/Writer Build-Type: Simple Category: Data stability: experimental Homepage: http://github.com/vincenthz/hs-certificate Cabal-Version: >=1.6 Flag test Description: Build unit test Default: False Flag executable Description: Build the executable Default: False Library Build-Depends: base >= 3 && < 5 , bytestring , mtl , 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.KeyDSA Data.Certificate.KeyRSA Data.CertificateStore System.Certificate.X509 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 Exposed-modules: System.Certificate.X509.Win32 if os(OSX) cpp-options: -DMACOSX Executable certificate Main-Is: Certificate.hs if flag(executable) Buildable: True Build-depends: cmdargs , text >= 0.11 , cryptohash , crypto-pubkey , directory else Buildable: False executable Tests Main-is: Tests.hs if flag(test) Buildable: True Build-Depends: base >= 3 && < 7, directory, HUnit, QuickCheck >= 2, bytestring else Buildable: False source-repository head type: git location: git://github.com/vincenthz/hs-certificate subdir: certificate certificate-1.3.9/Setup.hs0000644000000000000000000000005612224415310013623 0ustar0000000000000000import Distribution.Simple main = defaultMain certificate-1.3.9/System/0000755000000000000000000000000012224415310013452 5ustar0000000000000000certificate-1.3.9/System/Certificate/0000755000000000000000000000000012224415310015674 5ustar0000000000000000certificate-1.3.9/System/Certificate/X509.hs0000644000000000000000000000066612224415310016705 0ustar0000000000000000{-# LANGUAGE CPP #-} -- | -- Module : System.Certificate.X509 -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : good -- module System.Certificate.X509 ( getSystemCertificateStore ) where #if defined(WINDOWS) import System.Certificate.X509.Win32 #elif defined(MACOSX) import System.Certificate.X509.MacOS #else import System.Certificate.X509.Unix #endif certificate-1.3.9/System/Certificate/X509/0000755000000000000000000000000012224415310016341 5ustar0000000000000000certificate-1.3.9/System/Certificate/X509/Unix.hs0000644000000000000000000000441212224415310017621 0ustar0000000000000000-- | -- Module : System.Certificate.X509 -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : unix only -- -- this module is portable to unix system where there is usually -- a /etc/ssl/certs with system X509 certificates. -- -- the path can be dynamically override using the environment variable -- defined by envPathOverride in the module, which by -- default is SYSTEM_CERTIFICATE_PATH -- module System.Certificate.X509.Unix ( getSystemCertificateStore ) where import System.Directory (getDirectoryContents, doesFileExist) import System.Environment (getEnv) 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.Monad (filterM) import qualified Control.Exception as E import Data.Char defaultSystemPath :: FilePath defaultSystemPath = "/etc/ssl/certs/" envPathOverride :: String envPathOverride = "SYSTEM_CERTIFICATE_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 = E.catch (getEnv envPathOverride) inDefault where inDefault :: E.IOException -> IO FilePath inDefault _ = return defaultSystemPath 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 [] certificate-1.3.9/System/Certificate/X509/MacOS.hs0000644000000000000000000000172012224415310017637 0ustar0000000000000000module System.Certificate.X509.MacOS ( getSystemCertificateStore ) where import Data.PEM (pemParseLBS, PEM(..)) import Data.Certificate.X509 import System.Process import qualified Data.ByteString.Lazy as LBS import Control.Applicative import Data.Either import Data.CertificateStore 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 certificate-1.3.9/System/Certificate/X509/Win32.hs0000644000000000000000000000341412224415310017601 0ustar0000000000000000module System.Certificate.X509.Win32 ( getSystemCertificateStore ) where {- import Foreign.Marshal.Alloc (allocaBytes) import Foreign.Ptr (castPtr) import Control.Exception (bracket, IOException) import Control.Applicative ((<$>)) import System.Win32.Registry import qualified Data.ByteString as B import qualified Data.ByteString.Internal as B import qualified Data.ByteString.Lazy as L import Data.Certificate.X509 import Data.Certificate.X509.Cert import Data.Bits import Data.CertificateStore defaultSystemPath :: FilePath defaultSystemPath = "SOFTWARE\\Microsoft\\SystemCertificates\\CA\\Certificates" listSubDirectories path = bracket openKey regCloseKey regEnumKeys where openKey = regOpenKeyEx hKEY_LOCAL_MACHINE path (kEY_ENUMERATE_SUB_KEYS .|. kEY_READ) openValue path key toByteS = bracket openKey regCloseKey $ \hkey -> allocaBytes 4096 $ \mem -> do regQueryValueEx hkey key mem 4096 >>= toByteS mem where openKey = regOpenKeyEx hKEY_LOCAL_MACHINE path kEY_QUERY_VALUE fromBlob mem ty | ty == rEG_BINARY = do len <- B.c_strlen (castPtr mem) B.create (fromIntegral len) (\bptr -> B.memcpy bptr mem len) | otherwise = error "certificate blob have unexpected type" data ReadErr = Exception IOException | CertError String deriving (Show,Eq) readCertificate dir hash = do b <- openValue path "Blob" fromBlob return $ decodeCertificate $ L.fromChunks [b] where path = dir ++ "\\" ++ hash listIn dir = listSubDirectories dir >>= \hs -> (rights <$> mapM (readCertificate dir) hs) getSystemCertificateStore :: IO CertificateStore getSystemCertificateStore = makeCertificateStore <$> listIn defaultSystemPath -} import Data.CertificateStore getSystemCertificateStore :: IO CertificateStore getSystemCertificateStore = return (makeCertificateStore []) certificate-1.3.9/Data/0000755000000000000000000000000012224415310013037 5ustar0000000000000000certificate-1.3.9/Data/CertificateStore.hs0000644000000000000000000000330712224415310016635 0ustar0000000000000000module 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 certificate-1.3.9/Data/Certificate/0000755000000000000000000000000012224415310015261 5ustar0000000000000000certificate-1.3.9/Data/Certificate/KeyDSA.hs0000644000000000000000000000355212224415310016702 0ustar0000000000000000-- | -- Module : Data.Certificate.Key -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : unknown -- -- Read/Write Private Key -- module Data.Certificate.KeyDSA ( decodePrivate , encodePrivate ) where import Data.ASN1.Stream import Data.ASN1.Encoding import Data.ASN1.BinaryEncoding import qualified Data.ByteString.Lazy as L import qualified Crypto.Types.PubKey.DSA as DSA parsePrivate :: [ASN1] -> Either String (DSA.PublicKey, DSA.PrivateKey) parsePrivate [ 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 (DSA.PublicKey, DSA.PrivateKey) decodePrivate dat = either (Left . show) parsePrivate $ decodeASN1 BER dat 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 certificate-1.3.9/Data/Certificate/KeyRSA.hs0000644000000000000000000001077312224415310016723 0ustar0000000000000000-- | -- Module : Data.Certificate.Key -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : unknown -- -- Read\/Write Private\/Public RSA Key -- module Data.Certificate.KeyRSA ( decodePublic , decodePrivate , encodePublic , encodePrivate , parse_RSA ) where 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_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) parsePrivate _ = Left "unexpected format" decodePrivate :: L.ByteString -> Either String (RSA.PublicKey, RSA.PrivateKey) decodePrivate dat = either (Left . show) parsePrivate $ decodeASN1 BER dat encodePrivate :: (RSA.PublicKey, RSA.PrivateKey) -> L.ByteString 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) certificate-1.3.9/Data/Certificate/X509.hs0000644000000000000000000001412212224415310016262 0ustar0000000000000000-- | -- Module : Data.Certificate.X509 -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : unknown -- -- Read/Write X509 certificate -- module Data.Certificate.X509 ( -- * 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 -- * 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.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 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 -- 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) instance Eq X509 where 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 _ _ _) = encodeASN1 DER header where header = asn1Container Sequence $ toASN1 cert {- | decode an X509 from a bytestring - the structure is the following: - Certificate - Certificate Signature Algorithm - Certificate Signature -} decodeCertificate :: L.ByteString -> Either String X509 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 [] 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) = 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 certificate-1.3.9/Data/Certificate/X509/0000755000000000000000000000000012224415310015726 5ustar0000000000000000certificate-1.3.9/Data/Certificate/X509/Internal.hs0000644000000000000000000000103112224415310020031 0ustar0000000000000000module Data.Certificate.X509.Internal ( module Data.ASN1.Parse , makeASN1Sequence , asn1Container , OID ) where import Data.ASN1.Stream import Data.ASN1.Parse type OID = [Integer] 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 certificate-1.3.9/Data/Certificate/X509/Ext.hs0000644000000000000000000001215312224415310017024 0ustar0000000000000000-- | -- Module : Data.Certificate.X509.Ext -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : unknown -- -- 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 import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as BC import qualified Data.ByteString.Lazy as L 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) {- -- RFC 5280 oidDistributionPoints, oidPolicies, oidPoliciesMapping :: OID oidDistributionPoints = [2,5,29,31] oidPolicies = [2,5,29,32] oidPoliciesMapping = [2,5,29,33] -} class Extension a where 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 data ExtBasicConstraints = ExtBasicConstraints Bool (Maybe Integer) deriving (Show,Eq) instance Extension ExtBasicConstraints where 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) 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" data ExtSubjectKeyId = ExtSubjectKeyId L.ByteString 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" data ExtSubjectAltName = ExtSubjectAltName [String] 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 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) 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" 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 [] flagsToBits :: Enum a => [a] -> BitArray flagsToBits flags = foldl bitArraySetBit bitArrayEmpty $ map (fromIntegral . fromEnum) flags where bitArrayEmpty = BitArray 2 (L.pack [0,0]) certificate-1.3.9/Data/Certificate/X509/Cert.hs0000644000000000000000000003746512224415310017176 0ustar0000000000000000module Data.Certificate.X509.Cert ( -- * Data Structure SignatureALG(..) , HashALG(..) , PubKeyALG(..) , PubKey(..) , ECDSA_Hash(..) , ASN1StringType(..) , ASN1String , Certificate(..) , DistinguishedName(..) , OID -- various OID , oidCommonName , oidCountry , oidOrganization , oidOrganizationUnit -- signature to/from oid , oidSig , sigOID -- * Parse and encode a single distinguished name , parseDN , encodeDNinner , encodeDN -- * extensions , module Data.Certificate.X509.Ext ) where import Data.Word 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 qualified Data.ByteString.Lazy as L import Control.Applicative ((<$>)) import Control.Monad.State import Control.Monad.Error import Data.Certificate.X509.Internal import Data.Certificate.X509.Ext 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) data PubKeyALG = 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) 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 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) 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 :: 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] parseCertHeaderVersion :: ParseASN1 Int 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) 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) ] 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) ] oidSig :: OID -> SignatureALG oidSig oid = maybe (SignatureALG_Unknown oid) id $ lookup oid sig_table oidPubKey :: OID -> PubKeyALG oidPubKey oid = maybe (PubKeyALG_Unknown oid) id $ lookup oid pk_table sigOID :: SignatureALG -> OID sigOID (SignatureALG_Unknown oid) = oid sigOID sig = maybe [] fst $ find ((==) sig . snd) sig_table pubkeyalgOID :: PubKeyALG -> OID pubkeyalgOID (PubKeyALG_Unknown oid) = oid pubkeyalgOID sig = maybe [] fst $ find ((==) sig . snd) pk_table pubkeyToAlg :: PubKey -> PubKeyALG pubkeyToAlg (PubKeyRSA _) = PubKeyALG_RSA pubkeyToAlg (PubKeyDSA _) = PubKeyALG_DSA pubkeyToAlg (PubKeyDH _) = PubKeyALG_DH 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) asn1String :: ASN1 -> ASN1String asn1String (PrintableString x) = (Printable, x) asn1String (UTF8String x) = (UTF8, x) asn1String (UniversalString x) = (Univ, x) asn1String (BMPString x) = (BMP, x) asn1String (IA5String x) = (IA5, x) asn1String (T61String x) = (IA5, x) asn1String x = error ("not a print string " ++ show x) encodeAsn1String :: ASN1String -> ASN1 encodeAsn1String (Printable, x) = PrintableString x encodeAsn1String (UTF8, x) = UTF8String x encodeAsn1String (Univ, x) = UniversalString x encodeAsn1String (BMP, x) = BMPString x encodeAsn1String (IA5, x) = IA5String x encodeAsn1String (T61, x) = T61String x 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 = 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):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 getNextBitString = getNext >>= \bs -> case bs of BitString bits -> return $ bitArrayGetData bits _ -> throwError "expecting bitstring" parseCertExtensions :: ParseASN1 (Maybe [ExtensionRaw]) 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) -} parseCertificate :: ParseASN1 Certificate parseCertificate = do 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 } 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 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 (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 encodeExts :: Maybe [ExtensionRaw] -> [ASN1] encodeExts Nothing = [] encodeExts (Just l) = asn1Container (Container Context 3) $ concatMap encodeExt l 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 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)