{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RecordWildCards #-}
module Crypto.Store.CMS.OriginatorInfo
( OriginatorInfo(..)
, CertificateChoice(..)
, OtherCertificateFormat(..)
, RevocationInfoChoice(..)
, OtherRevocationInfoFormat(..)
, originatorInfoASN1S
, parseOriginatorInfo
, hasChoiceOther
) where
import Control.Applicative
import Data.ASN1.Types
import Data.Maybe (fromMaybe)
import Data.Semigroup
import Data.X509
import Crypto.Store.ASN1.Generate
import Crypto.Store.ASN1.Parse
import Crypto.Store.CMS.Util
class HasChoiceOther a where
hasChoiceOther :: a -> Bool
instance (HasChoiceOther a, Foldable f) => HasChoiceOther (f a) where
hasChoiceOther = any hasChoiceOther
data OriginatorInfo = OriginatorInfo
{ originatorCerts :: [CertificateChoice]
, originatorCRLs :: [RevocationInfoChoice]
}
deriving (Show,Eq)
instance Semigroup OriginatorInfo where
OriginatorInfo a b <> OriginatorInfo c d = OriginatorInfo (a <> c) (b <> d)
instance Monoid OriginatorInfo where
mempty = OriginatorInfo [] []
mappend (OriginatorInfo a b) (OriginatorInfo c d) =
OriginatorInfo (mappend a c) (mappend b d)
instance HasChoiceOther OriginatorInfo where
hasChoiceOther OriginatorInfo{..} =
hasChoiceOther originatorCerts || hasChoiceOther originatorCRLs
instance ProduceASN1Object ASN1P OriginatorInfo where
asn1s = originatorInfoASN1S Sequence
instance ParseASN1Object [ASN1Event] OriginatorInfo where
parse = parseOriginatorInfo Sequence
originatorInfoASN1S :: ASN1ConstructionType -> OriginatorInfo -> ASN1PS
originatorInfoASN1S ty OriginatorInfo{..} =
asn1Container ty $ gen 0 originatorCerts . gen 1 originatorCRLs
where
gen tag list
| null list = id
| otherwise = asn1Container (Container Context tag) (asn1s list)
parseOriginatorInfo :: ASN1ConstructionType
-> ParseASN1 [ASN1Event] OriginatorInfo
parseOriginatorInfo ty = onNextContainer ty $ do
certs <- parseOptList 0
crls <- parseOptList 1
return OriginatorInfo { originatorCerts = certs
, originatorCRLs = crls
}
where
parseOptList tag =
fromMaybe [] <$> onNextContainerMaybe (Container Context tag) parse
data CertificateChoice
= CertificateCertificate SignedCertificate
| CertificateOther OtherCertificateFormat
deriving (Show,Eq)
instance HasChoiceOther CertificateChoice where
hasChoiceOther (CertificateOther _) = True
hasChoiceOther _ = False
instance ProduceASN1Object ASN1P CertificateChoice where
asn1s (CertificateCertificate cert) = asn1s cert
asn1s (CertificateOther other) =
otherCertificateFormatASN1PS (Container Context 3) other
instance ParseASN1Object [ASN1Event] CertificateChoice where
parse = parseMain <|> parseOther
where parseMain = CertificateCertificate <$> parse
parseOther = CertificateOther <$>
parseOtherCertificateFormat (Container Context 3)
data RevocationInfoChoice
= RevocationInfoCRL SignedCRL
| RevocationInfoOther OtherRevocationInfoFormat
deriving (Show,Eq)
instance HasChoiceOther RevocationInfoChoice where
hasChoiceOther (RevocationInfoOther _) = True
hasChoiceOther _ = False
instance ProduceASN1Object ASN1P RevocationInfoChoice where
asn1s (RevocationInfoCRL crl) = asn1s crl
asn1s (RevocationInfoOther other) =
otherRevocationInfoFormatASN1PS (Container Context 1) other
instance ParseASN1Object [ASN1Event] RevocationInfoChoice where
parse = parseMain <|> parseOther
where parseMain = RevocationInfoCRL <$> parse
parseOther = RevocationInfoOther <$>
parseOtherRevocationInfoFormat (Container Context 1)
data OtherCertificateFormat = OtherCertificateFormat
{ otherCertFormat :: OID
, otherCertValues :: [ASN1]
}
deriving (Show,Eq)
otherCertificateFormatASN1PS :: ASN1Elem e
=> ASN1ConstructionType
-> OtherCertificateFormat
-> ASN1Stream e
otherCertificateFormatASN1PS ty OtherCertificateFormat{..} =
asn1Container ty (f . v)
where f = gOID otherCertFormat
v = gMany otherCertValues
parseOtherCertificateFormat :: Monoid e
=> ASN1ConstructionType
-> ParseASN1 e OtherCertificateFormat
parseOtherCertificateFormat ty = onNextContainer ty $ do
OID f <- getNext
v <- getMany getNext
return OtherCertificateFormat { otherCertFormat = f
, otherCertValues = v }
data OtherRevocationInfoFormat = OtherRevocationInfoFormat
{ otherRevInfoFormat :: OID
, otherRevInfoValues :: [ASN1]
}
deriving (Show,Eq)
otherRevocationInfoFormatASN1PS :: ASN1Elem e
=> ASN1ConstructionType
-> OtherRevocationInfoFormat
-> ASN1Stream e
otherRevocationInfoFormatASN1PS ty OtherRevocationInfoFormat{..} =
asn1Container ty (f . v)
where f = gOID otherRevInfoFormat
v = gMany otherRevInfoValues
parseOtherRevocationInfoFormat :: Monoid e
=> ASN1ConstructionType
-> ParseASN1 e OtherRevocationInfoFormat
parseOtherRevocationInfoFormat ty = onNextContainer ty $ do
OID f <- getNext
v <- getMany getNext
return OtherRevocationInfoFormat { otherRevInfoFormat = f
, otherRevInfoValues = v }