-- |
-- Module      : Crypto.Store.CMS.OriginatorInfo
-- License     : BSD-style
-- Maintainer  : Olivier Chéron <olivier.cheron@gmail.com>
-- Stability   : experimental
-- Portability : unknown
--
--
{-# 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

-- | Data types where choice "other" is available.
class HasChoiceOther a where
    -- | Return true when choice "other" is selected.
    hasChoiceOther :: a -> Bool

instance (HasChoiceOther a, Foldable f) => HasChoiceOther (f a) where
    hasChoiceOther :: f a -> Bool
hasChoiceOther = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any forall a. HasChoiceOther a => a -> Bool
hasChoiceOther

-- | Information about the originator of the content info, to be used when
-- a key management algorithm requires this information.
data OriginatorInfo = OriginatorInfo
    { OriginatorInfo -> [CertificateChoice]
originatorCerts :: [CertificateChoice]
      -- ^ The collection of certificates
    , OriginatorInfo -> [RevocationInfoChoice]
originatorCRLs  :: [RevocationInfoChoice]
      -- ^ The collection of CRLs
    }
    deriving (Int -> OriginatorInfo -> ShowS
[OriginatorInfo] -> ShowS
OriginatorInfo -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [OriginatorInfo] -> ShowS
$cshowList :: [OriginatorInfo] -> ShowS
show :: OriginatorInfo -> String
$cshow :: OriginatorInfo -> String
showsPrec :: Int -> OriginatorInfo -> ShowS
$cshowsPrec :: Int -> OriginatorInfo -> ShowS
Show,OriginatorInfo -> OriginatorInfo -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: OriginatorInfo -> OriginatorInfo -> Bool
$c/= :: OriginatorInfo -> OriginatorInfo -> Bool
== :: OriginatorInfo -> OriginatorInfo -> Bool
$c== :: OriginatorInfo -> OriginatorInfo -> Bool
Eq)

instance Semigroup OriginatorInfo where
    OriginatorInfo [CertificateChoice]
a [RevocationInfoChoice]
b <> :: OriginatorInfo -> OriginatorInfo -> OriginatorInfo
<> OriginatorInfo [CertificateChoice]
c [RevocationInfoChoice]
d = [CertificateChoice] -> [RevocationInfoChoice] -> OriginatorInfo
OriginatorInfo ([CertificateChoice]
a forall a. Semigroup a => a -> a -> a
<> [CertificateChoice]
c) ([RevocationInfoChoice]
b forall a. Semigroup a => a -> a -> a
<> [RevocationInfoChoice]
d)

instance Monoid OriginatorInfo where
    mempty :: OriginatorInfo
mempty = [CertificateChoice] -> [RevocationInfoChoice] -> OriginatorInfo
OriginatorInfo [] []
    mappend :: OriginatorInfo -> OriginatorInfo -> OriginatorInfo
mappend = forall a. Semigroup a => a -> a -> a
(<>)

instance HasChoiceOther OriginatorInfo where
    hasChoiceOther :: OriginatorInfo -> Bool
hasChoiceOther OriginatorInfo{[RevocationInfoChoice]
[CertificateChoice]
originatorCRLs :: [RevocationInfoChoice]
originatorCerts :: [CertificateChoice]
originatorCRLs :: OriginatorInfo -> [RevocationInfoChoice]
originatorCerts :: OriginatorInfo -> [CertificateChoice]
..} =
        forall a. HasChoiceOther a => a -> Bool
hasChoiceOther [CertificateChoice]
originatorCerts Bool -> Bool -> Bool
|| forall a. HasChoiceOther a => a -> Bool
hasChoiceOther [RevocationInfoChoice]
originatorCRLs

instance ProduceASN1Object ASN1P OriginatorInfo where
    asn1s :: OriginatorInfo -> ASN1Stream ASN1P
asn1s = ASN1ConstructionType -> OriginatorInfo -> ASN1Stream ASN1P
originatorInfoASN1S ASN1ConstructionType
Sequence

instance ParseASN1Object [ASN1Event] OriginatorInfo where
    parse :: ParseASN1 [ASN1Event] OriginatorInfo
parse = ASN1ConstructionType -> ParseASN1 [ASN1Event] OriginatorInfo
parseOriginatorInfo ASN1ConstructionType
Sequence

-- | Generate ASN.1 with the specified constructed type for the originator
-- information.
originatorInfoASN1S :: ASN1ConstructionType -> OriginatorInfo -> ASN1PS
originatorInfoASN1S :: ASN1ConstructionType -> OriginatorInfo -> ASN1Stream ASN1P
originatorInfoASN1S ASN1ConstructionType
ty OriginatorInfo{[RevocationInfoChoice]
[CertificateChoice]
originatorCRLs :: [RevocationInfoChoice]
originatorCerts :: [CertificateChoice]
originatorCRLs :: OriginatorInfo -> [RevocationInfoChoice]
originatorCerts :: OriginatorInfo -> [CertificateChoice]
..} =
    forall e.
ASN1Elem e =>
ASN1ConstructionType -> ASN1Stream e -> ASN1Stream e
asn1Container ASN1ConstructionType
ty forall a b. (a -> b) -> a -> b
$ forall {t :: * -> *} {e} {a}.
(Foldable t, ASN1Elem e, ProduceASN1Object e (t a)) =>
Int -> t a -> [e] -> [e]
gen Int
0 [CertificateChoice]
originatorCerts forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {t :: * -> *} {e} {a}.
(Foldable t, ASN1Elem e, ProduceASN1Object e (t a)) =>
Int -> t a -> [e] -> [e]
gen Int
1 [RevocationInfoChoice]
originatorCRLs
  where
    gen :: Int -> t a -> [e] -> [e]
gen Int
tag t a
list
        | forall (t :: * -> *) a. Foldable t => t a -> Bool
null t a
list = forall a. a -> a
id
        | Bool
otherwise = forall e.
ASN1Elem e =>
ASN1ConstructionType -> ASN1Stream e -> ASN1Stream e
asn1Container (ASN1Class -> Int -> ASN1ConstructionType
Container ASN1Class
Context Int
tag) (forall e obj. ProduceASN1Object e obj => obj -> ASN1Stream e
asn1s t a
list)

-- | Parse originator information with the specified constructed type.
parseOriginatorInfo :: ASN1ConstructionType
                    -> ParseASN1 [ASN1Event] OriginatorInfo
parseOriginatorInfo :: ASN1ConstructionType -> ParseASN1 [ASN1Event] OriginatorInfo
parseOriginatorInfo ASN1ConstructionType
ty = forall e a.
Monoid e =>
ASN1ConstructionType -> ParseASN1 e a -> ParseASN1 e a
onNextContainer ASN1ConstructionType
ty forall a b. (a -> b) -> a -> b
$ do
    [CertificateChoice]
certs <- forall {e} {a}. ParseASN1Object e a => Int -> ParseASN1 e [a]
parseOptList Int
0
    [RevocationInfoChoice]
crls  <- forall {e} {a}. ParseASN1Object e a => Int -> ParseASN1 e [a]
parseOptList Int
1
    forall (m :: * -> *) a. Monad m => a -> m a
return OriginatorInfo { originatorCerts :: [CertificateChoice]
originatorCerts = [CertificateChoice]
certs
                          , originatorCRLs :: [RevocationInfoChoice]
originatorCRLs  = [RevocationInfoChoice]
crls
                          }
  where
    parseOptList :: Int -> ParseASN1 e [a]
parseOptList Int
tag =
        forall a. a -> Maybe a -> a
fromMaybe [] forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e a.
Monoid e =>
ASN1ConstructionType -> ParseASN1 e a -> ParseASN1 e (Maybe a)
onNextContainerMaybe (ASN1Class -> Int -> ASN1ConstructionType
Container ASN1Class
Context Int
tag) forall e obj. ParseASN1Object e obj => ParseASN1 e obj
parse

-- | Union type related to certificate formats.
data CertificateChoice
    = CertificateCertificate SignedCertificate -- ^ X.509 certificate
    | CertificateOther OtherCertificateFormat  -- ^ Other format
    deriving (Int -> CertificateChoice -> ShowS
[CertificateChoice] -> ShowS
CertificateChoice -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CertificateChoice] -> ShowS
$cshowList :: [CertificateChoice] -> ShowS
show :: CertificateChoice -> String
$cshow :: CertificateChoice -> String
showsPrec :: Int -> CertificateChoice -> ShowS
$cshowsPrec :: Int -> CertificateChoice -> ShowS
Show,CertificateChoice -> CertificateChoice -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CertificateChoice -> CertificateChoice -> Bool
$c/= :: CertificateChoice -> CertificateChoice -> Bool
== :: CertificateChoice -> CertificateChoice -> Bool
$c== :: CertificateChoice -> CertificateChoice -> Bool
Eq)

instance HasChoiceOther CertificateChoice where
    hasChoiceOther :: CertificateChoice -> Bool
hasChoiceOther (CertificateOther OtherCertificateFormat
_) = Bool
True
    hasChoiceOther CertificateChoice
_                    = Bool
False

instance ProduceASN1Object ASN1P CertificateChoice where
    asn1s :: CertificateChoice -> ASN1Stream ASN1P
asn1s (CertificateCertificate SignedCertificate
cert) = forall e obj. ProduceASN1Object e obj => obj -> ASN1Stream e
asn1s SignedCertificate
cert
    asn1s (CertificateOther OtherCertificateFormat
other) =
        forall e.
ASN1Elem e =>
ASN1ConstructionType -> OtherCertificateFormat -> ASN1Stream e
otherCertificateFormatASN1PS (ASN1Class -> Int -> ASN1ConstructionType
Container ASN1Class
Context Int
3) OtherCertificateFormat
other

instance ParseASN1Object [ASN1Event] CertificateChoice where
    parse :: ParseASN1 [ASN1Event] CertificateChoice
parse = ParseASN1 [ASN1Event] CertificateChoice
parseMain forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ParseASN1 [ASN1Event] CertificateChoice
parseOther
      where parseMain :: ParseASN1 [ASN1Event] CertificateChoice
parseMain  = SignedCertificate -> CertificateChoice
CertificateCertificate forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e obj. ParseASN1Object e obj => ParseASN1 e obj
parse
            parseOther :: ParseASN1 [ASN1Event] CertificateChoice
parseOther = OtherCertificateFormat -> CertificateChoice
CertificateOther forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                forall e.
Monoid e =>
ASN1ConstructionType -> ParseASN1 e OtherCertificateFormat
parseOtherCertificateFormat (ASN1Class -> Int -> ASN1ConstructionType
Container ASN1Class
Context Int
3)

-- | Union type related to revocation info formats.
data RevocationInfoChoice
    = RevocationInfoCRL SignedCRL
      -- ^ A CRL, ARL, Delta CRL, or an ACRL
    | RevocationInfoOther OtherRevocationInfoFormat
      -- ^ Other format
    deriving (Int -> RevocationInfoChoice -> ShowS
[RevocationInfoChoice] -> ShowS
RevocationInfoChoice -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RevocationInfoChoice] -> ShowS
$cshowList :: [RevocationInfoChoice] -> ShowS
show :: RevocationInfoChoice -> String
$cshow :: RevocationInfoChoice -> String
showsPrec :: Int -> RevocationInfoChoice -> ShowS
$cshowsPrec :: Int -> RevocationInfoChoice -> ShowS
Show,RevocationInfoChoice -> RevocationInfoChoice -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RevocationInfoChoice -> RevocationInfoChoice -> Bool
$c/= :: RevocationInfoChoice -> RevocationInfoChoice -> Bool
== :: RevocationInfoChoice -> RevocationInfoChoice -> Bool
$c== :: RevocationInfoChoice -> RevocationInfoChoice -> Bool
Eq)

instance HasChoiceOther RevocationInfoChoice where
    hasChoiceOther :: RevocationInfoChoice -> Bool
hasChoiceOther (RevocationInfoOther OtherRevocationInfoFormat
_) = Bool
True
    hasChoiceOther RevocationInfoChoice
_                       = Bool
False

instance ProduceASN1Object ASN1P RevocationInfoChoice where
    asn1s :: RevocationInfoChoice -> ASN1Stream ASN1P
asn1s (RevocationInfoCRL SignedCRL
crl) = forall e obj. ProduceASN1Object e obj => obj -> ASN1Stream e
asn1s SignedCRL
crl
    asn1s (RevocationInfoOther OtherRevocationInfoFormat
other) =
        forall e.
ASN1Elem e =>
ASN1ConstructionType -> OtherRevocationInfoFormat -> ASN1Stream e
otherRevocationInfoFormatASN1PS (ASN1Class -> Int -> ASN1ConstructionType
Container ASN1Class
Context Int
1) OtherRevocationInfoFormat
other

instance ParseASN1Object [ASN1Event] RevocationInfoChoice where
    parse :: ParseASN1 [ASN1Event] RevocationInfoChoice
parse = ParseASN1 [ASN1Event] RevocationInfoChoice
parseMain forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ParseASN1 [ASN1Event] RevocationInfoChoice
parseOther
      where parseMain :: ParseASN1 [ASN1Event] RevocationInfoChoice
parseMain  = SignedCRL -> RevocationInfoChoice
RevocationInfoCRL forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e obj. ParseASN1Object e obj => ParseASN1 e obj
parse
            parseOther :: ParseASN1 [ASN1Event] RevocationInfoChoice
parseOther = OtherRevocationInfoFormat -> RevocationInfoChoice
RevocationInfoOther forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                forall e.
Monoid e =>
ASN1ConstructionType -> ParseASN1 e OtherRevocationInfoFormat
parseOtherRevocationInfoFormat (ASN1Class -> Int -> ASN1ConstructionType
Container ASN1Class
Context Int
1)

-- | Certificate information in a format not supported natively.
data OtherCertificateFormat = OtherCertificateFormat
    { OtherCertificateFormat -> OID
otherCertFormat :: OID    -- ^ Format identifier
    , OtherCertificateFormat -> [ASN1]
otherCertValues :: [ASN1] -- ^ ASN.1 values using this format
    }
    deriving (Int -> OtherCertificateFormat -> ShowS
[OtherCertificateFormat] -> ShowS
OtherCertificateFormat -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [OtherCertificateFormat] -> ShowS
$cshowList :: [OtherCertificateFormat] -> ShowS
show :: OtherCertificateFormat -> String
$cshow :: OtherCertificateFormat -> String
showsPrec :: Int -> OtherCertificateFormat -> ShowS
$cshowsPrec :: Int -> OtherCertificateFormat -> ShowS
Show,OtherCertificateFormat -> OtherCertificateFormat -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: OtherCertificateFormat -> OtherCertificateFormat -> Bool
$c/= :: OtherCertificateFormat -> OtherCertificateFormat -> Bool
== :: OtherCertificateFormat -> OtherCertificateFormat -> Bool
$c== :: OtherCertificateFormat -> OtherCertificateFormat -> Bool
Eq)

otherCertificateFormatASN1PS :: ASN1Elem e
                             => ASN1ConstructionType
                             -> OtherCertificateFormat
                             -> ASN1Stream e
otherCertificateFormatASN1PS :: forall e.
ASN1Elem e =>
ASN1ConstructionType -> OtherCertificateFormat -> ASN1Stream e
otherCertificateFormatASN1PS ASN1ConstructionType
ty OtherCertificateFormat{OID
[ASN1]
otherCertValues :: [ASN1]
otherCertFormat :: OID
otherCertValues :: OtherCertificateFormat -> [ASN1]
otherCertFormat :: OtherCertificateFormat -> OID
..} =
    forall e.
ASN1Elem e =>
ASN1ConstructionType -> ASN1Stream e -> ASN1Stream e
asn1Container ASN1ConstructionType
ty ([e] -> [e]
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. [e] -> [e]
v)
  where f :: [e] -> [e]
f = forall e. ASN1Elem e => OID -> ASN1Stream e
gOID OID
otherCertFormat
        v :: [e] -> [e]
v = forall e. ASN1Elem e => [ASN1] -> ASN1Stream e
gMany [ASN1]
otherCertValues

parseOtherCertificateFormat :: Monoid e
                            => ASN1ConstructionType
                            -> ParseASN1 e OtherCertificateFormat
parseOtherCertificateFormat :: forall e.
Monoid e =>
ASN1ConstructionType -> ParseASN1 e OtherCertificateFormat
parseOtherCertificateFormat ASN1ConstructionType
ty = forall e a.
Monoid e =>
ASN1ConstructionType -> ParseASN1 e a -> ParseASN1 e a
onNextContainer ASN1ConstructionType
ty forall a b. (a -> b) -> a -> b
$ do
    OID OID
f <- forall e. Monoid e => ParseASN1 e ASN1
getNext
    [ASN1]
v <- forall e a. ParseASN1 e a -> ParseASN1 e [a]
getMany forall e. Monoid e => ParseASN1 e ASN1
getNext
    forall (m :: * -> *) a. Monad m => a -> m a
return OtherCertificateFormat { otherCertFormat :: OID
otherCertFormat = OID
f
                                  , otherCertValues :: [ASN1]
otherCertValues = [ASN1]
v }

-- | Revocation information in a format not supported natively.
data OtherRevocationInfoFormat = OtherRevocationInfoFormat
    { OtherRevocationInfoFormat -> OID
otherRevInfoFormat :: OID    -- ^ Format identifier
    , OtherRevocationInfoFormat -> [ASN1]
otherRevInfoValues :: [ASN1] -- ^ ASN.1 values using this format
    }
    deriving (Int -> OtherRevocationInfoFormat -> ShowS
[OtherRevocationInfoFormat] -> ShowS
OtherRevocationInfoFormat -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [OtherRevocationInfoFormat] -> ShowS
$cshowList :: [OtherRevocationInfoFormat] -> ShowS
show :: OtherRevocationInfoFormat -> String
$cshow :: OtherRevocationInfoFormat -> String
showsPrec :: Int -> OtherRevocationInfoFormat -> ShowS
$cshowsPrec :: Int -> OtherRevocationInfoFormat -> ShowS
Show,OtherRevocationInfoFormat -> OtherRevocationInfoFormat -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: OtherRevocationInfoFormat -> OtherRevocationInfoFormat -> Bool
$c/= :: OtherRevocationInfoFormat -> OtherRevocationInfoFormat -> Bool
== :: OtherRevocationInfoFormat -> OtherRevocationInfoFormat -> Bool
$c== :: OtherRevocationInfoFormat -> OtherRevocationInfoFormat -> Bool
Eq)

otherRevocationInfoFormatASN1PS :: ASN1Elem e
                                => ASN1ConstructionType
                                -> OtherRevocationInfoFormat
                                -> ASN1Stream e
otherRevocationInfoFormatASN1PS :: forall e.
ASN1Elem e =>
ASN1ConstructionType -> OtherRevocationInfoFormat -> ASN1Stream e
otherRevocationInfoFormatASN1PS ASN1ConstructionType
ty OtherRevocationInfoFormat{OID
[ASN1]
otherRevInfoValues :: [ASN1]
otherRevInfoFormat :: OID
otherRevInfoValues :: OtherRevocationInfoFormat -> [ASN1]
otherRevInfoFormat :: OtherRevocationInfoFormat -> OID
..} =
    forall e.
ASN1Elem e =>
ASN1ConstructionType -> ASN1Stream e -> ASN1Stream e
asn1Container ASN1ConstructionType
ty ([e] -> [e]
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. [e] -> [e]
v)
  where f :: [e] -> [e]
f = forall e. ASN1Elem e => OID -> ASN1Stream e
gOID OID
otherRevInfoFormat
        v :: [e] -> [e]
v = forall e. ASN1Elem e => [ASN1] -> ASN1Stream e
gMany [ASN1]
otherRevInfoValues

parseOtherRevocationInfoFormat :: Monoid e
                               => ASN1ConstructionType
                               -> ParseASN1 e OtherRevocationInfoFormat
parseOtherRevocationInfoFormat :: forall e.
Monoid e =>
ASN1ConstructionType -> ParseASN1 e OtherRevocationInfoFormat
parseOtherRevocationInfoFormat ASN1ConstructionType
ty = forall e a.
Monoid e =>
ASN1ConstructionType -> ParseASN1 e a -> ParseASN1 e a
onNextContainer ASN1ConstructionType
ty forall a b. (a -> b) -> a -> b
$ do
    OID OID
f <- forall e. Monoid e => ParseASN1 e ASN1
getNext
    [ASN1]
v <- forall e a. ParseASN1 e a -> ParseASN1 e [a]
getMany forall e. Monoid e => ParseASN1 e ASN1
getNext
    forall (m :: * -> *) a. Monad m => a -> m a
return OtherRevocationInfoFormat { otherRevInfoFormat :: OID
otherRevInfoFormat = OID
f
                                     , otherRevInfoValues :: [ASN1]
otherRevInfoValues = [ASN1]
v }