{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Crypto.Store.X509
( SignedObject()
, readPubKeyFile
, readPubKeyFileFromMemory
, pemToPubKey
, writePubKeyFile
, writePubKeyFileToMemory
, pubKeyToPEM
, readSignedObject
, readSignedObjectFromMemory
, writeSignedObject
, writeSignedObjectToMemory
, readPEMs
, writePEMs
) where
import Data.ASN1.Types
import Data.ASN1.BinaryEncoding
import Data.ASN1.Encoding
import Data.Maybe
import Data.Proxy
import qualified Data.X509 as X509
import qualified Data.ByteString as B
import qualified Crypto.PubKey.RSA as RSA
import Crypto.Store.ASN1.Generate
import Crypto.Store.ASN1.Parse
import Crypto.Store.CMS.Util
import Crypto.Store.PEM
class (ASN1Object a, Eq a, Show a) => SignedObject a where
signedObjectName :: proxy a -> String
otherObjectNames :: proxy a -> [String]
instance SignedObject X509.Certificate where
signedObjectName _ = "CERTIFICATE"
otherObjectNames _ = ["X509 CERTIFICATE"]
instance SignedObject X509.CRL where
signedObjectName _ = "X509 CRL"
otherObjectNames _ = []
validObjectName :: SignedObject a => proxy a -> String -> Bool
validObjectName prx name =
name == signedObjectName prx || name `elem` otherObjectNames prx
readPubKeyFile :: FilePath -> IO [X509.PubKey]
readPubKeyFile path = accumulate <$> readPEMs path
readPubKeyFileFromMemory :: B.ByteString -> [X509.PubKey]
readPubKeyFileFromMemory = either (const []) accumulate . pemParseBS
accumulate :: [PEM] -> [X509.PubKey]
accumulate = catMaybes . foldr (flip pemToPubKey) []
pemToPubKey :: [Maybe X509.PubKey] -> PEM -> [Maybe X509.PubKey]
pemToPubKey acc pem =
case decodeASN1' BER (pemContent pem) of
Left _ -> acc
Right asn1 -> run (getParser $ pemName pem) asn1 : acc
where
run p asn1 =
case p asn1 of
Right (pubKey, []) -> Just pubKey
_ -> Nothing
getParser "PUBLIC KEY" = fromASN1
getParser "RSA PUBLIC KEY" = runParseASN1State rsapkParser
getParser _ = const (Left undefined)
rsapkParser = (\(RSAPublicKey pub) -> X509.PubKeyRSA pub) <$> parse
readSignedObject :: SignedObject a => FilePath -> IO [X509.SignedExact a]
readSignedObject path = accumulate' <$> readPEMs path
readSignedObjectFromMemory :: SignedObject a
=> B.ByteString
-> [X509.SignedExact a]
readSignedObjectFromMemory = either (const []) accumulate' . pemParseBS
accumulate' :: forall a. SignedObject a => [PEM] -> [X509.SignedExact a]
accumulate' = foldr pemToSigned []
where
prx = Proxy :: Proxy a
pemToSigned pem acc
| validObjectName prx (pemName pem) =
case X509.decodeSignedObject $ pemContent pem of
Left _ -> acc
Right obj -> obj : acc
| otherwise = acc
writePubKeyFile :: FilePath -> [X509.PubKey] -> IO ()
writePubKeyFile path = writePEMs path . map pubKeyToPEM
writePubKeyFileToMemory :: [X509.PubKey] -> B.ByteString
writePubKeyFileToMemory = pemsWriteBS . map pubKeyToPEM
pubKeyToPEM :: X509.PubKey -> PEM
pubKeyToPEM pubKey = mkPEM "PUBLIC KEY" (encodeASN1S $ gMany asn1)
where asn1 = toASN1 pubKey []
writeSignedObject :: SignedObject a => FilePath -> [X509.SignedExact a] -> IO ()
writeSignedObject path = writePEMs path . map signedToPEM
writeSignedObjectToMemory :: SignedObject a => [X509.SignedExact a] -> B.ByteString
writeSignedObjectToMemory = pemsWriteBS . map signedToPEM
signedToPEM :: forall a. SignedObject a => X509.SignedExact a -> PEM
signedToPEM obj = mkPEM (signedObjectName prx) (X509.encodeSignedObject obj)
where prx = Proxy :: Proxy a
mkPEM :: String -> B.ByteString -> PEM
mkPEM name bs = PEM { pemName = name, pemHeader = [], pemContent = bs}
newtype RSAPublicKey = RSAPublicKey RSA.PublicKey
instance ASN1Elem e => ProduceASN1Object e RSAPublicKey where
asn1s (RSAPublicKey pub) = asn1Container Sequence (n . e)
where
n = gIntVal (RSA.public_n pub)
e = gIntVal (RSA.public_e pub)
instance Monoid e => ParseASN1Object e RSAPublicKey where
parse = onNextContainer Sequence $ do
IntVal modulus <- getNext
IntVal pubexp <- getNext
let pub = RSA.PublicKey { RSA.public_size = calculate_modulus modulus 1
, RSA.public_n = modulus
, RSA.public_e = pubexp
}
return (RSAPublicKey pub)
where
calculate_modulus n i
| (2 ^ (i * 8)) > n = i
| otherwise = calculate_modulus n (i + 1)