diff --git a/Certificate.hs b/Certificate.hs --- a/Certificate.hs +++ b/Certificate.hs @@ -6,7 +6,8 @@ import qualified Data.Text.Lazy as T import Data.Text.Lazy.Encoding (decodeUtf8) import Data.Certificate.X509 -import Data.Certificate.Key +import Data.Certificate.KeyRSA as KeyRSA +import Data.Certificate.KeyDSA as KeyDSA import Data.Certificate.PEM import System.Console.CmdArgs import Control.Monad @@ -14,12 +15,9 @@ import Data.Maybe import System.Exit -import Data.ASN1.DER +import Data.ASN1.DER (decodeASN1Stream, ASN1(..), ASN1ConstructionType(..)) import Numeric -readprivate :: FilePath -> IO (Either String PrivateKey) -readprivate file = B.readFile file >>= return . maybe (Left "no valid private RSA key found") (decodePrivateKey . L.fromChunks . (:[])) . parsePEMKeyRSA - hexdump :: L.ByteString -> String hexdump bs = concatMap hex $ L.unpack bs where hex n @@ -30,8 +28,8 @@ showExts e = putStrLn $ show e -showCert :: Certificate -> IO () -showCert cert = do +showCert :: X509 -> IO () +showCert (X509 cert _ sigalg sigbits) = do putStrLn ("version: " ++ show (certVersion cert)) putStrLn ("serial: " ++ show (certSerial cert)) putStrLn ("sigalg: " ++ show (certSignatureAlg cert)) @@ -43,61 +41,79 @@ putStrLn ("pk: " ++ show (certPubKey cert)) putStrLn "exts:" showExts $ certExtensions cert - putStrLn ("sig: " ++ show (certSignature cert)) - putStrLn ("other: " ++ show (certOthers cert)) + putStrLn ("sigAlg: " ++ show sigalg) + putStrLn ("sig: " ++ show sigbits) -showKey :: PrivateKey -> String -showKey key = unlines - [ "version: " ++ (show $ privKey_version key) - , "len-modulus: " ++ (show $ privKey_lenmodulus key) - , "modulus: " ++ (show $ privKey_modulus key) - , "public exponant: " ++ (show $ privKey_public_exponant key) - , "private exponant: " ++ (show $ privKey_private_exponant key) - , "p1: " ++ (show $ privKey_p1 key) - , "p2: " ++ (show $ privKey_p2 key) - , "exp1: " ++ (show $ privKey_exp1 key) - , "exp2: " ++ (show $ privKey_exp2 key) - , "coefficient: " ++ (show $ privKey_coef key) +showRSAKey :: KeyRSA.Private -> String +showRSAKey key = unlines + [ "version: " ++ (show $ KeyRSA.version key) + , "len-modulus: " ++ (show $ KeyRSA.lenmodulus key) + , "modulus: " ++ (show $ KeyRSA.modulus key) + , "public exponant: " ++ (show $ KeyRSA.public_exponant key) + , "private exponant: " ++ (show $ KeyRSA.private_exponant key) + , "p1: " ++ (show $ KeyRSA.p1 key) + , "p2: " ++ (show $ KeyRSA.p2 key) + , "exp1: " ++ (show $ KeyRSA.exp1 key) + , "exp2: " ++ (show $ KeyRSA.exp2 key) + , "coefficient: " ++ (show $ KeyRSA.coef key) ] -showASN1 :: ASN1 -> IO () +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) + ] + +showASN1 :: [ASN1] -> IO () showASN1 = prettyPrint 0 where - prettyPrint l a = indent l >> p l a >> putStrLn "" - indent l = putStr (replicate l ' ') - p _ (EOC) = putStr "" - p _ (Boolean b) = putStr ("bool: " ++ show b) - p _ (IntVal i) = putStr ("int: " ++ showHex i "") - p _ (BitString i bs) = putStr ("bitstring: " ++ hexdump bs) - 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.unpack t) - p l (Sequence o) = putStrLn "sequence" >> mapM_ (prettyPrint (l+1)) o >> indent l >> putStr "end-sequence" - p l (Set o) = putStrLn "set" >> mapM_ (prettyPrint (l+1)) o >> indent l >> putStr "end-set" - p _ (NumericString bs) = putStr "numericstring:" - p _ (PrintableString t) = putStr ("printablestring: " ++ T.unpack 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.unpack t) - p _ (CharacterString bs) = putStr "characterstring:" - p _ (BMPString t) = putStr ("bmpstring: " ++ T.unpack t) - p l (Other tc tn x) = putStr "other:" + indent n = putStr (replicate n ' ') -mainX509 :: CertMainOpts -> IO () -mainX509 opts = do + 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 i bs) = putStr ("bitstring: " ++ hexdump bs) + 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.unpack 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.unpack 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.unpack t) + p (CharacterString bs) = putStr "characterstring:" + p (BMPString t) = putStr ("bmpstring: " ++ T.unpack t) + p (Other tc tn x) = putStr "other" + +doMain :: CertMainOpts -> IO () +doMain opts@(X509Opt _ _ _ _) = do cert <- maybe (error "cannot read PEM certificate") (id) . parsePEMCert <$> B.readFile (head $ files opts) when (raw opts) $ putStrLn $ hexdump $ L.fromChunks [cert] - when (asn1 opts) $ case decodeASN1 $ L.fromChunks [cert] of + when (asn1 opts) $ case decodeASN1Stream $ L.fromChunks [cert] of Left err -> error ("decoding ASN1 failed: " ++ show err) Right asn1 -> showASN1 asn1 when (text opts || not (or [asn1 opts,raw opts])) $ case decodeCertificate $ L.fromChunks [cert] of @@ -105,30 +121,42 @@ Right c -> showCert c exitSuccess -mainKey :: CertMainOpts -> IO () -mainKey opts = do - c <- readprivate $ head $ files opts - case c of - Left err -> error err - Right cert -> putStrLn $ showKey cert +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 + case (rsadata, dsadata) of + (Just x, _) -> do + let rsaKey = KeyRSA.decodePrivate $ L.fromChunks [x] + case rsaKey of + Left err -> error err + Right k -> putStrLn $ showRSAKey k + (_, Just x) -> do + let rsaKey = KeyDSA.decodePrivate $ L.fromChunks [x] + case rsaKey of + Left err -> error err + Right k -> putStrLn $ showDSAKey k + _ -> do + putStrLn "no recognized private key found" data CertMainOpts = - X509 + X509Opt { files :: [FilePath] - , asn1 :: Bool - , text :: Bool - , raw :: Bool + , asn1 :: Bool + , text :: Bool + , raw :: Bool } | Key { files :: [FilePath] } deriving (Show,Data,Typeable) -x509Opts = X509 +x509Opts = X509Opt { files = def &= args &= typFile - , asn1 = def - , text = def - , raw = def + , asn1 = def + , text = def + , raw = def } &= help "x509 certificate related commands" keyOpts = Key @@ -136,10 +164,8 @@ } &= help "keys related commands" mode = cmdArgsMode $ modes [x509Opts,keyOpts] - &= help "create, manipulate certificate (x509,etc) and keys" &= program "certificate" &= summary "certificate v0.1" + &= help "create, manipulate certificate (x509,etc) and keys" + &= program "certificate" + &= summary "certificate v0.1" -main = do - x <- cmdArgsRun mode - case x of - X509 _ _ _ _ -> mainX509 x - Key _ -> mainKey x +main = cmdArgsRun mode >>= doMain diff --git a/Data/Certificate/Key.hs b/Data/Certificate/Key.hs deleted file mode 100644 --- a/Data/Certificate/Key.hs +++ /dev/null @@ -1,73 +0,0 @@ --- | --- Module : Data.Certificate.Key --- License : BSD-style --- Maintainer : Vincent Hanquez --- Stability : experimental --- Portability : unknown --- --- Read/Write Private Key --- - -module Data.Certificate.Key ( - PrivateKey(..), - decodePrivateKey, - encodePrivateKey - ) where - -import Data.ASN1.DER hiding (decodeASN1) -import Data.ASN1.BER (decodeASN1) -import qualified Data.ByteString.Lazy as L - -data PrivateKey = PrivateKey - { privKey_version :: Int - , privKey_lenmodulus :: Int - , privKey_modulus :: Integer - , privKey_public_exponant :: Integer - , privKey_private_exponant :: Integer - , privKey_p1 :: Integer - , privKey_p2 :: Integer - , privKey_exp1 :: Integer - , privKey_exp2 :: Integer - , privKey_coef :: Integer - } - -parsePrivateKey :: ASN1 -> Either String PrivateKey -parsePrivateKey x = - case x of - Sequence [ IntVal ver, IntVal modulus, IntVal pub_exp - , IntVal priv_exp, IntVal p1, IntVal p2 - , IntVal exp1, IntVal exp2, IntVal coef ] -> - Right $ PrivateKey - { privKey_version = fromIntegral ver - , privKey_lenmodulus = calculate_modulus modulus 1 - , privKey_modulus = modulus - , privKey_public_exponant = pub_exp - , privKey_private_exponant = priv_exp - , privKey_p1 = p1 - , privKey_p2 = p2 - , privKey_exp1 = exp1 - , privKey_exp2 = exp2 - , privKey_coef = coef } - _ -> - Left "unexpected format" - where - calculate_modulus n i = if (2 ^ (i * 8)) > n then i else calculate_modulus n (i+1) - -decodePrivateKey :: L.ByteString -> Either String PrivateKey -decodePrivateKey dat = either (Left . show) parsePrivateKey $ decodeASN1 dat - -encodePrivateKey :: PrivateKey -> L.ByteString -encodePrivateKey pk = encodeASN1 pkseq - where - pkseq = Sequence [ IntVal ver, IntVal modulus, IntVal pub_exp - , IntVal priv_exp, IntVal p1, IntVal p2 - , IntVal exp1, IntVal exp2, IntVal coef ] - ver = fromIntegral $ privKey_version pk - modulus = privKey_modulus pk - pub_exp = privKey_public_exponant pk - priv_exp = privKey_private_exponant pk - p1 = privKey_p1 pk - p2 = privKey_p2 pk - exp1 = privKey_exp1 pk - exp2 = privKey_exp2 pk - coef = fromIntegral $ privKey_coef pk diff --git a/Data/Certificate/KeyDSA.hs b/Data/Certificate/KeyDSA.hs new file mode 100644 --- /dev/null +++ b/Data/Certificate/KeyDSA.hs @@ -0,0 +1,63 @@ +-- | +-- Module : Data.Certificate.Key +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : unknown +-- +-- Read/Write Private Key +-- + +module Data.Certificate.KeyDSA + ( Private(..) + , decodePrivate + , encodePrivate + ) where + +import Data.ASN1.DER (encodeASN1Stream, ASN1(..), ASN1ConstructionType(..)) +import Data.ASN1.BER (decodeASN1Stream) +import qualified Data.ByteString.Lazy as L + +data Private = Private + { version :: Int + , priv :: Integer + , pub :: Integer + , p :: Integer + , q :: Integer + , g :: Integer + } + +parsePrivate :: [ASN1] -> Either String Private +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 + } + +parsePrivate _ = Left "unexpected format" + +decodePrivate :: L.ByteString -> Either String Private +decodePrivate dat = either (Left . show) parsePrivate $ decodeASN1Stream 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 + ] diff --git a/Data/Certificate/KeyRSA.hs b/Data/Certificate/KeyRSA.hs new file mode 100644 --- /dev/null +++ b/Data/Certificate/KeyRSA.hs @@ -0,0 +1,77 @@ +-- | +-- Module : Data.Certificate.Key +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : unknown +-- +-- Read/Write Private RSA Key +-- + +module Data.Certificate.KeyRSA + ( Private(..) + , decodePrivate + , encodePrivate + ) where + +import Data.ASN1.DER (encodeASN1Stream, ASN1(..), ASN1ConstructionType(..)) +import Data.ASN1.BER (decodeASN1Stream) +import qualified Data.ByteString.Lazy as L + +data Private = Private + { version :: Int + , lenmodulus :: Int + , modulus :: Integer + , public_exponant :: Integer + , private_exponant :: Integer + , p1 :: Integer + , p2 :: Integer + , exp1 :: Integer + , exp2 :: Integer + , coef :: Integer + } + +parsePrivate :: [ASN1] -> Either String Private +parsePrivate + [ Start Sequence + , IntVal ver, 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 $ Private + { version = fromIntegral ver + , lenmodulus = calculate_modulus p_modulus 1 + , modulus = p_modulus + , public_exponant = pub_exp + , private_exponant = priv_exp + , p1 = p_p1 + , p2 = p_p2 + , exp1 = p_exp1 + , exp2 = p_exp2 + , coef = p_coef + } + where + calculate_modulus n i = if (2 ^ (i * 8)) > n then i else calculate_modulus n (i+1) +parsePrivate _ = Left "unexpected format" + +decodePrivate :: L.ByteString -> Either String Private +decodePrivate dat = either (Left . show) parsePrivate $ decodeASN1Stream 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 $ modulus pk + , IntVal $ public_exponant pk + , IntVal $ private_exponant pk + , IntVal $ p1 pk + , IntVal $ p2 pk + , IntVal $ exp1 pk + , IntVal $ exp2 pk + , IntVal $ fromIntegral $ coef pk + , End Sequence + ] diff --git a/Data/Certificate/PEM.hs b/Data/Certificate/PEM.hs --- a/Data/Certificate/PEM.hs +++ b/Data/Certificate/PEM.hs @@ -16,6 +16,7 @@ , parsePEMKeyRSA , parsePEMKeyDSA , parsePEMs + , findPEM ) where import Data.ByteString (ByteString) diff --git a/Data/Certificate/X509.hs b/Data/Certificate/X509.hs --- a/Data/Certificate/X509.hs +++ b/Data/Certificate/X509.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - -- | -- Module : Data.Certificate.X509 -- License : BSD-style @@ -13,19 +11,16 @@ module Data.Certificate.X509 ( -- * Data Structure - SignatureALG(..) + X509(..) + -- * Data Structure (reexported from X509Cert) + , SignatureALG(..) , PubKeyALG(..) , PubKeyDesc(..) , PubKey(..) - , Certificate(..) , ASN1StringType(..) , ASN1String - - -- * some common OIDs found in certificate Distinguish Names - , oidCommonName - , oidCountry - , oidOrganization - , oidOrganizationUnit + , Certificate(..) + , CertificateExts(..) -- * serialization from ASN1 bytestring , decodeCertificate @@ -33,437 +28,61 @@ ) where import Data.Word -import Data.List (find) import Data.ASN1.DER -import Data.Maybe -import Data.ByteString.Lazy (ByteString) -import Data.Text.Lazy (Text) +import Data.ASN1.Stream (getConstructedEndRepr) +import Data.ASN1.Raw (toBytes) import qualified Data.ByteString.Lazy as L -import Control.Monad.State -import Control.Monad.Error -{- -the structure of an X509 Certificate is the following: - -Certificate - 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) - ... -Certificate Signature Algorithm -Certificate Signature --} - -{- -data CertError = - CertErrorMissing String - | CertErrorBadFormat String - | CertErrorMisc String - deriving (Show) --} -type OID = [Integer] - -data SignatureALG = - SignatureALG_md5WithRSAEncryption - | SignatureALG_md2WithRSAEncryption - | SignatureALG_sha1WithRSAEncryption - | SignatureALG_dsaWithSHA1 - | SignatureALG_ecdsaWithSHA384 - | SignatureALG_Unknown OID - deriving (Show, Eq) - -data PubKeyALG = - PubKeyALG_RSA - | PubKeyALG_DSA - | PubKeyALG_ECDSA - | PubKeyALG_Unknown OID - deriving (Show,Eq) - -data PubKeyDesc = - PubKeyRSA (Int, Integer, Integer) -- ^ RSA format with (len modulus, modulus, e) - | PubKeyDSA (Integer, Integer, Integer, Integer) -- ^ DSA format with (pub, p, q, g) - | PubKeyECDSA ASN1 -- ^ ECDSA format not done yet FIXME - | PubKeyUnknown [Word8] -- ^ unrecognized format - deriving (Show,Eq) +import Data.Certificate.X509Internal +import Data.Certificate.X509Cert -data PubKey = PubKey PubKeyALG PubKeyDesc -- OID RSA|DSA|rawdata +data X509 = X509 Certificate (Maybe L.ByteString) SignatureALG [Word8] deriving (Show,Eq) --- FIXME use a proper standard type for representing time. -type Time = (Int, Int, Int, Int, Int, Int, Bool) - -data CertKeyUsage = - CertKeyUsageDigitalSignature - | CertKeyUsageNonRepudiation - | CertKeyUsageKeyEncipherment - | CertKeyUsageDataEncipherment - | CertKeyUsageKeyAgreement - | CertKeyUsageKeyCertSign - | CertKeyUsageCRLSign - | CertKeyUsageEncipherOnly - | CertKeyUsageDecipherOnly - deriving (Show, Eq) - -data CertificateExts = CertificateExts - { certExtKeyUsage :: Maybe (Bool, [CertKeyUsage]) - , certExtBasicConstraints :: Maybe (Bool, Bool) - , certExtSubjectKeyIdentifier :: Maybe (Bool, [Word8]) - , certExtPolicies :: Maybe (Bool) - , certExtOthers :: [ (OID, Bool, ASN1) ] - } deriving (Show,Eq) - -data ASN1StringType = UTF8 | Printable | Univ | BMP | IA5 deriving (Show,Eq) -type ASN1String = (ASN1StringType, Text) - -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] - -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 CertificateExts -- ^ Certificate Extensions - , certSignature :: Maybe (SignatureALG, [Word8]) -- ^ Certificate Signature Algorithm and Signature - , certOthers :: [ASN1] -- ^ any others fields not parsed - } deriving (Show,Eq) - -{- | parse a RSA pubkeys from ASN1 encoded bits. - - return PubKeyRSA (len-modulus, modulus, e) if successful -} -parse_RSA :: ByteString -> PubKeyDesc -parse_RSA bits = - case decodeASN1 $ bits of - Right (Sequence [ IntVal modulus, IntVal pubexp ]) -> - PubKeyRSA (calculate_modulus modulus 1, modulus, pubexp) - _ -> - PubKeyUnknown $ L.unpack bits - where - calculate_modulus n i = if (2 ^ (i * 8)) > n then i else calculate_modulus n (i+1) - -parse_ECDSA :: ByteString -> PubKeyDesc -parse_ECDSA bits = - case decodeASN1 bits of - Right l -> PubKeyECDSA l - Left x -> PubKeyUnknown $ map (fromIntegral . fromEnum) $ show x - -newtype ParseCert a = P { runP :: ErrorT String (State [ASN1]) a } - deriving (Monad, MonadError String) - -runParseCert :: ParseCert a -> [ASN1] -> Either String a -runParseCert f s = - case runState (runErrorT (runP f)) s of - (Left err, _) -> Left err - (Right r, _) -> Right r - -getNext :: ParseCert ASN1 -getNext = do - list <- P (lift get) - case list of - [] -> throwError "empty" - (h:l) -> P (lift (put l)) >> return h - -getRemaining :: ParseCert [ASN1] -getRemaining = P (lift get) - -hasNext :: ParseCert Bool -hasNext = do - list <- P (lift get) - case list of - [] -> return False - _ -> return True - -lookNext :: ParseCert ASN1 -lookNext = do - list <- P (lift get) - case list of - [] -> throwError "empty" - (h:_) -> return h - -parseCertHeaderVersion :: ParseCert Int -parseCertHeaderVersion = do - n <- lookNext - v <- case n of - Other Context 0 (Right [ IntVal v ]) -> getNext >> return (fromIntegral v) - _ -> return 1 - return v - -parseCertHeaderSerial :: ParseCert 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_sha1WithRSAEncryption) - , ([1,2,840,113549,1,1,4], SignatureALG_md5WithRSAEncryption) - , ([1,2,840,113549,1,1,2], SignatureALG_md2WithRSAEncryption) - , ([1,2,840,10040,4,3], SignatureALG_dsaWithSHA1) - , ([1,2,840,10045,4,3,3], SignatureALG_ecdsaWithSHA384) - ] - -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) - ] - -oidSig :: OID -> SignatureALG -oidSig oid = maybe (SignatureALG_Unknown oid) snd $ find ((==) oid . fst) sig_table - -oidPubKey :: OID -> PubKeyALG -oidPubKey oid = maybe (PubKeyALG_Unknown oid) snd $ find ((==) oid . fst) 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 - -parseCertHeaderAlgorithmID :: ParseCert SignatureALG -parseCertHeaderAlgorithmID = do - n <- getNext - case n of - Sequence [ OID oid, Null ] -> return $ oidSig oid - Sequence [ 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 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 - -parseCertHeaderDN :: ParseCert [ (OID, ASN1String) ] -parseCertHeaderDN = do - n <- getNext - case n of - Sequence l -> mapM parseDNOne l - _ -> throwError "Distinguished name bad format" - where - parseDNOne (Set [ Sequence [OID oid, val]]) = return (oid, asn1String val) - parseDNOne _ = throwError "field in dn bad format" - -parseCertHeaderValidity :: ParseCert (Time, Time) -parseCertHeaderValidity = do - n <- getNext - case n of - Sequence [ UTCTime t1, UTCTime t2 ] -> return (t1, t2) - _ -> throwError "bad validity format" - -matchPubKey :: ASN1 -> ParseCert PubKey -matchPubKey (Sequence[Sequence[OID pkalg,Null],BitString _ bits]) = do - let sig = oidPubKey pkalg - let desc = case sig of - PubKeyALG_RSA -> parse_RSA bits - _ -> PubKeyUnknown $ L.unpack bits - return $ PubKey sig desc - -matchPubKey (Sequence[Sequence[OID pkalg,OID pkgalg2],BitString _ bits]) = do - let sig = oidPubKey pkalg - let desc = case sig of - PubKeyALG_ECDSA -> parse_ECDSA bits - _ -> PubKeyUnknown $ L.unpack bits - return $ PubKey sig desc - - -matchPubKey (Sequence[Sequence[OID pkalg,Sequence[IntVal p,IntVal q,IntVal g]], BitString _ pubenc ]) = do - let sig = oidPubKey pkalg - case decodeASN1 pubenc of - Right (IntVal dsapub) -> return $ PubKey sig (PubKeyDSA (dsapub, p, q, g)) - _ -> throwError "unrecognized DSA pub format" - - -matchPubKey n = throwError ("subject public key bad format : " ++ show n) - -parseCertHeaderSubjectPK :: ParseCert PubKey -parseCertHeaderSubjectPK = getNext >>= matchPubKey - --- RFC 5280 -parseCertExtensionHelper :: [ASN1] -> State CertificateExts () -parseCertExtensionHelper l = do - forM_ (mapMaybe extractStruct l) $ \e -> case e of - ([2,5,29,14], critical, Right (OctetString x)) -> - modify (\s -> s { certExtSubjectKeyIdentifier = Just (critical, L.unpack x) }) - {- - ([2,5,29,15], critical, Right (BitString _ _)) -> - all the flags: - digitalSignature (0), - nonRepudiation (1), -- recent editions of X.509 have renamed this bit to contentCommitment - keyEncipherment (2), - dataEncipherment (3), - keyAgreement (4), - keyCertSign (5), - cRLSign (6), - encipherOnly (7), - decipherOnly (8) } - - return () - -} - ([2,5,29,19], critical, Right (Sequence [Boolean True])) -> - modify (\s -> s { certExtBasicConstraints = Just (critical, True) }) - {- - ([2,5,29,31], critical, obj) -> -- distributions points - return () - ([2,5,29,32], critical, obj) -> -- policies - return () - ([2,5,29,33], critical, obj) -> -- policies mapping - return () - ([2,5,29,35], critical, obj) -> -- authority key identifer - return () - -} - (oid, critical, Right obj) -> - modify (\s -> s { certExtOthers = (oid, critical, obj) : certExtOthers s }) - (_, True, Left _) -> fail "critical extension not understood" - (_, False, Left _) -> return () - where - extractStruct (Sequence [ OID oid, Boolean True, OctetString obj ]) = Just (oid, True, decodeASN1 obj) - extractStruct (Sequence [ OID oid, OctetString obj ]) = Just (oid, False, decodeASN1 obj) - extractStruct _ = Nothing - -parseCertExtensions :: ParseCert (Maybe CertificateExts) -parseCertExtensions = do - h <- hasNext - if h - then do - n <- lookNext - case n of - Other Context 3 (Right [Sequence l]) -> do - _ <- getNext - let def = CertificateExts - { certExtKeyUsage = Nothing - , certExtBasicConstraints = Nothing - , certExtSubjectKeyIdentifier = Nothing - , certExtPolicies = Nothing - , certExtOthers = [] - } - return $ Just $ execState (parseCertExtensionHelper l) def - Other Context 3 _ -> - throwError "certificate header bad format" - _ -> - return Nothing - else return Nothing - -{- | parse header structure of a x509 certificate. it contains - - the version, the serial number, the issuer DN, the validity period, - - the subject DN, and the public keys -} -parseCertificate :: ParseCert Certificate -parseCertificate = do - version <- parseCertHeaderVersion - serial <- parseCertHeaderSerial - sigalg <- parseCertHeaderAlgorithmID - issuer <- parseCertHeaderDN - validity <- parseCertHeaderValidity - subject <- parseCertHeaderDN - pk <- parseCertHeaderSubjectPK - exts <- parseCertExtensions - l <- getRemaining - - return $ Certificate - { certVersion = version - , certSerial = serial - , certSignatureAlg = sigalg - , certIssuerDN = issuer - , certSubjectDN = subject - , certValidity = validity - , certPubKey = pk - , certSignature = Nothing - , certExtensions = exts - , certOthers = l - } - -{- | parse root structure of a x509 certificate. this has to be a sequence of 3 objects : - - * the header - - * the signature algorithm - - * the signature -} -processCertificate :: ASN1 -> Either String Certificate -processCertificate (Sequence [ header, sigalg, sig ]) = do - let sigAlg = - case sigalg of - Sequence [ OID oid, Null ] -> oidSig oid - _ -> SignatureALG_Unknown [] - let sigbits = - case sig of - BitString _ bits -> bits - _ -> error "signature not in right format" - case header of - Sequence l -> - let cert = runParseCert parseCertificate l in - either Left (\c -> Right $ c { certSignature = Just (sigAlg, L.unpack sigbits) }) cert - _ -> Left "Certificate is not a sequence" - -processCertificate x = Left ("certificate root element error: " ++ show x) - -{- | decode a X509 certificate from a bytestring -} -decodeCertificate :: L.ByteString -> Either String Certificate -decodeCertificate by = either (Left . show) processCertificate $ decodeASN1 by - -encodeDN :: [ (OID, ASN1String) ] -> ASN1 -encodeDN dn = Sequence $ map dnSet dn - where - dnSet (oid, stringy) = Set [ Sequence [ OID oid, encodeAsn1String stringy ]] - -encodePK :: PubKey -> ASN1 -encodePK (PubKey sig (PubKeyRSA (_, modulus, e))) = Sequence [ Sequence [ OID $ pubkeyalgOID sig, Null ], BitString 0 bits ] - where bits = encodeASN1 $ Sequence [ IntVal modulus, IntVal e ] - -encodePK (PubKey sig (PubKeyDSA (pub, p, q, g))) = Sequence [ Sequence [ OID $ pubkeyalgOID sig, dsaseq ], BitString 0 bits ] +{- | 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 $ decodeASN1StreamRepr by where - dsaseq = Sequence [ IntVal p, IntVal q, IntVal g ] - bits = encodeASN1 $ IntVal pub + {- | 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) sigalg (L.unpack b) + (Left err, _) -> Left $ ("certificate error: " ++ show err) + _ -> Left $ "certificate structure error" + where + (rootseq, _) = getConstructedEndRepr l -encodePK (PubKey sig (PubKeyUnknown l)) = Sequence [ Sequence [ OID $ pubkeyalgOID sig, Null ], BitString 0 (L.pack l) ] + onContainer ((Start _, _) : l) f = + case reverse l of + ((End _, _) : l2) -> f $ reverse l2 + _ -> f [] + onContainer _ f = f [] -encodeCertificateHeader :: Certificate -> [ASN1] -encodeCertificateHeader cert = - [ eVer, eSerial, eAlgId, eIssuer, eValidity, eSubject, epkinfo ] ++ others - where - eVer = Other Context 0 (Right [ IntVal (fromIntegral $ certVersion cert) ]) - eSerial = IntVal $ certSerial cert - eAlgId = Sequence [ OID (sigOID $ certSignatureAlg cert), Null ] - eIssuer = encodeDN $ certIssuerDN cert - (t1, t2) = certValidity cert - eValidity = Sequence [ UTCTime t1, UTCTime t2 ] - eSubject = encodeDN $ certSubjectDN cert - epkinfo = encodePK $ certPubKey cert - others = [] + parseSigAlg [ OID oid, Null ] = oidSig oid + parseSigAlg _ = SignatureALG_Unknown [] {-| encode a X509 certificate to a bytestring -} -encodeCertificate :: Certificate -> L.ByteString -encodeCertificate cert = encodeASN1 rootSeq +encodeCertificate :: X509 -> L.ByteString +encodeCertificate (X509 cert _ sigalg sigbits) = case encodeASN1Stream rootSeq of + Right x -> x + Left err -> error (show err) where - (sigalg, sigbits) = fromJust $ certSignature cert - esigalg = Sequence [ OID (sigOID sigalg), Null ] - esig = BitString 0 $ L.pack sigbits - header = Sequence $ encodeCertificateHeader cert - rootSeq = Sequence [ header, esigalg, esig ] + esigalg = asn1Container Sequence [OID (sigOID sigalg), Null] + esig = BitString 0 $ L.pack sigbits + header = asn1Container Sequence $ encodeCertificateHeader cert + rootSeq = asn1Container Sequence (header ++ esigalg ++ [esig]) diff --git a/Data/Certificate/X509Cert.hs b/Data/Certificate/X509Cert.hs new file mode 100644 --- /dev/null +++ b/Data/Certificate/X509Cert.hs @@ -0,0 +1,376 @@ +module Data.Certificate.X509Cert + ( + -- * Data Structure + SignatureALG(..) + , PubKeyALG(..) + , PubKeyDesc(..) + , PubKey(..) + , ASN1StringType(..) + , ASN1String + , Certificate(..) + , CertificateExts(..) + + -- various OID + , oidCommonName + , oidCountry + , oidOrganization + , oidOrganizationUnit + + -- signature to/from oid + , oidSig + , sigOID + + -- * certificate to/from asn1 + , parseCertificate + , encodeCertificateHeader + ) where + +import Data.Word +import Data.List (find) +import Data.ASN1.DER +import Data.Maybe +import Data.ByteString.Lazy (ByteString) +import Data.Text.Lazy (Text) +import qualified Data.ByteString.Lazy as L +import Control.Monad.State +import Control.Monad.Error +import Data.Certificate.X509Internal + +type OID = [Integer] + +data SignatureALG = + SignatureALG_md5WithRSAEncryption + | SignatureALG_md2WithRSAEncryption + | SignatureALG_sha1WithRSAEncryption + | SignatureALG_dsaWithSHA1 + | SignatureALG_ecdsaWithSHA384 + | SignatureALG_Unknown OID + deriving (Show, Eq) + +data PubKeyALG = + PubKeyALG_RSA + | PubKeyALG_DSA + | PubKeyALG_ECDSA + | PubKeyALG_Unknown OID + deriving (Show,Eq) + +data PubKeyDesc = + PubKeyRSA (Int, Integer, Integer) -- ^ RSA format with (len modulus, modulus, e) + | PubKeyDSA (Integer, Integer, Integer, Integer) -- ^ DSA format with (pub, p, q, g) + | PubKeyECDSA [ASN1] -- ^ ECDSA format not done yet FIXME + | PubKeyUnknown [Word8] -- ^ unrecognized format + deriving (Show,Eq) + +data PubKey = PubKey PubKeyALG PubKeyDesc -- OID RSA|DSA|rawdata + deriving (Show,Eq) + +-- FIXME use a proper standard type for representing time. +type Time = (Int, Int, Int, Int, Int, Int, Bool) + +data CertKeyUsage = + CertKeyUsageDigitalSignature + | CertKeyUsageNonRepudiation + | CertKeyUsageKeyEncipherment + | CertKeyUsageDataEncipherment + | CertKeyUsageKeyAgreement + | CertKeyUsageKeyCertSign + | CertKeyUsageCRLSign + | CertKeyUsageEncipherOnly + | CertKeyUsageDecipherOnly + deriving (Show, Eq) + +data ASN1StringType = UTF8 | Printable | Univ | BMP | IA5 deriving (Show,Eq) +type ASN1String = (ASN1StringType, Text) + +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 CertificateExts -- ^ Certificate Extensions + } deriving (Show,Eq) + +data CertificateExts = CertificateExts + { certExtKeyUsage :: Maybe (Bool, [CertKeyUsage]) + , certExtBasicConstraints :: Maybe (Bool, Bool) + , certExtSubjectKeyIdentifier :: Maybe (Bool, [Word8]) + , certExtPolicies :: Maybe (Bool) + , certExtOthers :: [ (OID, Bool, [ASN1]) ] + } deriving (Show,Eq) + +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 -> PubKeyDesc +parse_RSA bits = + case decodeASN1Stream $ bits of + Right [Start Sequence, IntVal modulus, IntVal pubexp, End Sequence] -> + PubKeyRSA (calculate_modulus modulus 1, modulus, pubexp) + _ -> + PubKeyUnknown $ L.unpack bits + where + calculate_modulus n i = if (2 ^ (i * 8)) > n then i else calculate_modulus n (i+1) + +parse_ECDSA :: ByteString -> PubKeyDesc +parse_ECDSA bits = + case decodeASN1Stream bits of + Right l -> PubKeyECDSA l + Left x -> PubKeyUnknown $ map (fromIntegral . fromEnum) $ show x +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 + +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_sha1WithRSAEncryption) + , ([1,2,840,113549,1,1,4], SignatureALG_md5WithRSAEncryption) + , ([1,2,840,113549,1,1,2], SignatureALG_md2WithRSAEncryption) + , ([1,2,840,10040,4,3], SignatureALG_dsaWithSHA1) + , ([1,2,840,10045,4,3,3], SignatureALG_ecdsaWithSHA384) + ] + +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) + ] + +oidSig :: OID -> SignatureALG +oidSig oid = maybe (SignatureALG_Unknown oid) snd $ find ((==) oid . fst) sig_table + +oidPubKey :: OID -> PubKeyALG +oidPubKey oid = maybe (PubKeyALG_Unknown oid) snd $ find ((==) oid . fst) 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 + +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 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 + +parseCertHeaderDN :: ParseASN1 [ (OID, ASN1String) ] +parseCertHeaderDN = do + onNextContainer Sequence getDNs + where + getDNs = do + n <- hasNext + if n + then do + dn <- parseDNOne + liftM (dn :) getDNs + else return [] + parseDNOne = 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 (t1, t2) + _ -> throwError "bad validity format" + +parseCertHeaderSubjectPK :: ParseASN1 PubKey +parseCertHeaderSubjectPK = onNextContainer Sequence $ do + l <- getNextContainer Sequence + bits <- getNextBitString + case l of + [OID pkalg,Null] -> do + let sig = oidPubKey pkalg + let desc = case sig of + PubKeyALG_RSA -> parse_RSA bits + _ -> PubKeyUnknown $ L.unpack bits + return $ PubKey sig desc + [OID pkalg,OID pkalg2] -> do + let sig = oidPubKey pkalg + let desc = case sig of + PubKeyALG_ECDSA -> parse_ECDSA bits + _ -> PubKeyUnknown $ L.unpack bits + return $ PubKey sig desc + [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 $ PubKey sig (PubKeyDSA (dsapub, p, q, g)) + _ -> throwError "unrecognized DSA pub format" + n -> + throwError ("subject public key bad format : " ++ show n) + + where getNextBitString = getNext >>= \bs -> case bs of + BitString _ bits -> return bits + _ -> throwError "expecting bitstring" + +-- RFC 5280 +parseCertExtensionHelper :: [[ASN1]] -> State CertificateExts () +parseCertExtensionHelper l = do + forM_ (mapMaybe extractStruct l) $ \e -> case e of + ([2,5,29,14], critical, Right [OctetString x]) -> + modify (\s -> s { certExtSubjectKeyIdentifier = Just (critical, L.unpack x) }) + {- + ([2,5,29,15], critical, Right (BitString _ _)) -> + all the flags: + digitalSignature (0), + nonRepudiation (1), -- recent editions of X.509 have renamed this bit to contentCommitment + keyEncipherment (2), + dataEncipherment (3), + keyAgreement (4), + keyCertSign (5), + cRLSign (6), + encipherOnly (7), + decipherOnly (8) } + + return () + -} + ([2,5,29,19], critical, Right [Start Sequence, Boolean True, End Sequence]) -> + modify (\s -> s { certExtBasicConstraints = Just (critical, True) }) + {- + ([2,5,29,31], critical, obj) -> -- distributions points + return () + ([2,5,29,32], critical, obj) -> -- policies + return () + ([2,5,29,33], critical, obj) -> -- policies mapping + return () + ([2,5,29,35], critical, obj) -> -- authority key identifer + return () + -} + (oid, critical, Right obj) -> + modify (\s -> s { certExtOthers = (oid, critical, obj) : certExtOthers s }) + (_, True, Left _) -> fail "critical extension not understood" + (_, False, Left _) -> return () + where + extractStruct [OID oid,Boolean True,OctetString obj] = Just (oid, True, decodeASN1Stream obj) + extractStruct [OID oid,OctetString obj] = Just (oid, False, decodeASN1Stream obj) + extractStruct _ = Nothing + +parseCertExtensions :: ParseASN1 (Maybe CertificateExts) +parseCertExtensions = do + onNextContainerMaybe (Container Context 3) $ do + let def = CertificateExts + { certExtKeyUsage = Nothing + , certExtBasicConstraints = Nothing + , certExtSubjectKeyIdentifier = Nothing + , certExtPolicies = Nothing + , certExtOthers = [] + } + l <- getNextContainer Sequence + return $ execState (parseCertExtensionHelper $ makeASN1Sequence l) def + +{- | 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 <- 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 + } + +encodeDN :: [ (OID, ASN1String) ] -> [ASN1] +encodeDN dn = asn1Container Sequence $ concatMap dnSet dn + where + dnSet (oid, stringy) = asn1Container Set (asn1Container Sequence [OID oid, encodeAsn1String stringy]) + +encodePK :: PubKey -> [ASN1] +encodePK (PubKey sig (PubKeyRSA (_, modulus, e))) = + asn1Container Sequence (asn1Container Sequence [ OID $ pubkeyalgOID sig, Null ] ++ [BitString 0 bits]) + where + (Right bits) = encodeASN1Stream $ asn1Container Sequence [IntVal modulus, IntVal e] + +encodePK (PubKey sig (PubKeyDSA (pub, p, q, g))) = + asn1Container Sequence (asn1Container Sequence ([OID $ pubkeyalgOID sig] ++ dsaseq) ++ [BitString 0 bits]) + where + dsaseq = asn1Container Sequence [IntVal p,IntVal q,IntVal g] + (Right bits) = encodeASN1Stream [IntVal pub] + +encodePK (PubKey sig (PubKeyUnknown l)) = + asn1Container Sequence (asn1Container Sequence [OID $ pubkeyalgOID sig, Null] ++ [BitString 0 $ L.pack l]) + +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 t1, UTCTime t2] + eSubject = encodeDN $ certSubjectDN cert + epkinfo = encodePK $ certPubKey cert + eexts = [] -- FIXME encode extensions diff --git a/Data/Certificate/X509Internal.hs b/Data/Certificate/X509Internal.hs new file mode 100644 --- /dev/null +++ b/Data/Certificate/X509Internal.hs @@ -0,0 +1,92 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module Data.Certificate.X509Internal + ( ParseASN1 + , runParseASN1 + , onNextContainer + , onNextContainerMaybe + , getNextContainer + , getNextContainerMaybe + , getNext + , hasNext + , makeASN1Sequence + , asn1Container + ) where + +import Data.ASN1.DER +import Data.ASN1.Stream (getConstructedEnd) +import Control.Monad.State +import Control.Monad.Error + +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 + diff --git a/certificate.cabal b/certificate.cabal --- a/certificate.cabal +++ b/certificate.cabal @@ -1,5 +1,5 @@ Name: certificate -Version: 0.4.0 +Version: 0.6.0 Description: Certificates and Key reader/writer . @@ -27,15 +27,17 @@ Library Build-Depends: base >= 3 && < 7, - binary >= 0.5, bytestring, text >= 0.11, mtl, - asn1-data >= 0.3 && < 0.4, + asn1-data >= 0.4.5 && < 0.5, base64-bytestring Exposed-modules: Data.Certificate.X509, + Data.Certificate.X509Cert, Data.Certificate.PEM, - Data.Certificate.Key + Data.Certificate.KeyDSA + Data.Certificate.KeyRSA + Other-modules: Data.Certificate.X509Internal ghc-options: -Wall Executable certificate