    -- |
    -- Module      : Crypto.Store.CMS.Attribute
    -- License     : BSD-style
    -- Maintainer  : Olivier Chéron <olivier.cheron@gmail.com>
    -- Stability   : experimental
    -- Portability : unknown
    --
    -- CMS attributes
    {-# LANGUAGE FlexibleInstances #-}
    {-# LANGUAGE MultiParamTypeClasses #-}
    {-# LANGUAGE RecordWildCards #-}
    module Crypto.Store.CMS.Attribute
        ( Attribute(..)
        , attributesASN1S
        , parseAttributes
        -- * Generic attribute
        , findAttribute
        , setAttribute
        , filterAttributes
        -- * Implementing attributes
        , setAttributeASN1S
        , runParseAttribute
        -- * Standard attributes
        , getContentTypeAttr
        , setContentTypeAttr
        , getMessageDigestAttr
        , setMessageDigestAttr
        , getSigningTimeAttr
        , setSigningTimeAttr
        , setSigningTimeAttrCurrent
        ) where

    import Control.Monad.IO.Class

    import Data.ASN1.Types
    import Data.ByteString (ByteString)
    import Data.Hourglass
    import Data.Maybe (fromMaybe)

    import System.Hourglass (dateCurrent)

    import Crypto.Store.ASN1.Generate
    import Crypto.Store.ASN1.Parse
    import Crypto.Store.CMS.Type
    import Crypto.Store.CMS.Util

    -- | An attribute extending the parent structure with arbitrary data.
    data Attribute = Attribute
        { Attribute -> OID
    attrType   :: OID    -- ^ Attribute type
        , Attribute -> [ASN1]
    attrValues :: [ASN1] -- ^ Attribute values
        }
        deriving (Int -> Attribute -> ShowS
    [Attribute] -> ShowS
    Attribute -> String
    (Int -> Attribute -> ShowS)
    -> (Attribute -> String)
    -> ([Attribute] -> ShowS)
    -> Show Attribute
    forall a.
    (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
    $cshowsPrec :: Int -> Attribute -> ShowS
    showsPrec :: Int -> Attribute -> ShowS
    $cshow :: Attribute -> String
    show :: Attribute -> String
    $cshowList :: [Attribute] -> ShowS
    showList :: [Attribute] -> ShowS
    Show,Attribute -> Attribute -> Bool
    (Attribute -> Attribute -> Bool)
    -> (Attribute -> Attribute -> Bool) -> Eq Attribute
    forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
    $c== :: Attribute -> Attribute -> Bool
    == :: Attribute -> Attribute -> Bool
    $c/= :: Attribute -> Attribute -> Bool
    /= :: Attribute -> Attribute -> Bool
    Eq)

    instance ASN1Elem e => ProduceASN1Object e Attribute where
        asn1s :: Attribute -> ASN1Stream e
    asn1s Attribute{OID
    [ASN1]
    attrType :: Attribute -> OID
    attrValues :: Attribute -> [ASN1]
    attrType :: OID
    attrValues :: [ASN1]
    ..} =
            ASN1ConstructionType -> ASN1Stream e -> ASN1Stream e
    forall e.
    ASN1Elem e =>
    ASN1ConstructionType -> ASN1Stream e -> ASN1Stream e
    asn1Container ASN1ConstructionType
    Sequence
                (OID -> ASN1Stream e
    forall e. ASN1Elem e => OID -> ASN1Stream e
    gOID OID
    attrType ASN1Stream e -> ASN1Stream e -> ASN1Stream e
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . ASN1ConstructionType -> ASN1Stream e -> ASN1Stream e
    forall e.
    ASN1Elem e =>
    ASN1ConstructionType -> ASN1Stream e -> ASN1Stream e
    asn1Container ASN1ConstructionType
    Set ([ASN1] -> ASN1Stream e
    forall e. ASN1Elem e => [ASN1] -> ASN1Stream e
    gMany [ASN1]
    attrValues))

    instance Monoid e => ParseASN1Object e Attribute where
        parse :: ParseASN1 e Attribute
    parse = ASN1ConstructionType
    -> ParseASN1 e Attribute -> ParseASN1 e Attribute
    forall e a.
    Monoid e =>
    ASN1ConstructionType -> ParseASN1 e a -> ParseASN1 e a
    onNextContainer ASN1ConstructionType
    Sequence (ParseASN1 e Attribute -> ParseASN1 e Attribute)
    -> ParseASN1 e Attribute -> ParseASN1 e Attribute
    forall a b. (a -> b) -> a -> b
    $ do
            OID OID
    oid <- ParseASN1 e ASN1
    forall e. Monoid e => ParseASN1 e ASN1
    getNext
            [ASN1]
    vals <- ASN1ConstructionType -> ParseASN1 e [ASN1] -> ParseASN1 e [ASN1]
    forall e a.
    Monoid e =>
    ASN1ConstructionType -> ParseASN1 e a -> ParseASN1 e a
    onNextContainer ASN1ConstructionType
    Set (ParseASN1 e ASN1 -> ParseASN1 e [ASN1]
    forall e a. ParseASN1 e a -> ParseASN1 e [a]
    getMany ParseASN1 e ASN1
    forall e. Monoid e => ParseASN1 e ASN1
    getNext)
            Attribute -> ParseASN1 e Attribute
    forall a. a -> ParseASN1 e a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Attribute { attrType :: OID
    attrType = OID
    oid, attrValues :: [ASN1]
    attrValues = [ASN1]
    vals }

    -- | Produce the ASN.1 stream for a list of attributes.
    attributesASN1S :: ASN1Elem e
                    => ASN1ConstructionType -> [Attribute] -> ASN1Stream e
    attributesASN1S :: forall e.
    ASN1Elem e =>
    ASN1ConstructionType -> [Attribute] -> ASN1Stream e
    attributesASN1S ASN1ConstructionType
    _  []    = [e] -> [e]
    forall a. a -> a
    id
    attributesASN1S ASN1ConstructionType
    ty [Attribute]
    attrs = ASN1ConstructionType -> ([e] -> [e]) -> [e] -> [e]
    forall e.
    ASN1Elem e =>
    ASN1ConstructionType -> ASN1Stream e -> ASN1Stream e
    asn1Container ASN1ConstructionType
    ty ([Attribute] -> [e] -> [e]
    forall e obj. ProduceASN1Object e obj => obj -> ASN1Stream e
    asn1s [Attribute]
    attrs)

    -- | Parse a list of attributes.
    parseAttributes :: Monoid e => ASN1ConstructionType -> ParseASN1 e [Attribute]
    parseAttributes :: forall e.
    Monoid e =>
    ASN1ConstructionType -> ParseASN1 e [Attribute]
    parseAttributes ASN1ConstructionType
    ty = [Attribute] -> Maybe [Attribute] -> [Attribute]
    forall a. a -> Maybe a -> a
    fromMaybe [] (Maybe [Attribute] -> [Attribute])
    -> ParseASN1 e (Maybe [Attribute]) -> ParseASN1 e [Attribute]
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> ASN1ConstructionType
    -> ParseASN1 e [Attribute] -> ParseASN1 e (Maybe [Attribute])
    forall e a.
    Monoid e =>
    ASN1ConstructionType -> ParseASN1 e a -> ParseASN1 e (Maybe a)
    onNextContainerMaybe ASN1ConstructionType
    ty ParseASN1 e [Attribute]
    forall e obj. ParseASN1Object e obj => ParseASN1 e obj
    parse

    -- | Return the values for the first attribute with the specified type.
    findAttribute :: OID -> [Attribute] -> Maybe [ASN1]
    findAttribute :: OID -> [Attribute] -> Maybe [ASN1]
    findAttribute OID
    oid [Attribute]
    attrs =
        case [ Attribute -> [ASN1]
    attrValues Attribute
    a | Attribute
    a <- [Attribute]
    attrs, Attribute -> OID
    attrType Attribute
    a OID -> OID -> Bool
    forall a. Eq a => a -> a -> Bool
    == OID
    oid ] of
            []    -> Maybe [ASN1]
    forall a. Maybe a
    Nothing
            ([ASN1]
    v:[[ASN1]]
    _) -> [ASN1] -> Maybe [ASN1]
    forall a. a -> Maybe a
    Just [ASN1]
    v

    -- | Filter a list of attributes based on a predicate applied to attribute type.
    filterAttributes :: (OID -> Bool) -> [Attribute] -> [Attribute]
    filterAttributes :: (OID -> Bool) -> [Attribute] -> [Attribute]
    filterAttributes OID -> Bool
    p = (Attribute -> Bool) -> [Attribute] -> [Attribute]
    forall a. (a -> Bool) -> [a] -> [a]
    filter (OID -> Bool
    p (OID -> Bool) -> (Attribute -> OID) -> Attribute -> Bool
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Attribute -> OID
    attrType)

    -- | Add or replace an attribute in a list of attributes.
    setAttribute :: OID -> [ASN1] -> [Attribute] -> [Attribute]
    setAttribute :: OID -> [ASN1] -> [Attribute] -> [Attribute]
    setAttribute OID
    oid [ASN1]
    vals = (:) Attribute
    attr ([Attribute] -> [Attribute])
    -> ([Attribute] -> [Attribute]) -> [Attribute] -> [Attribute]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (OID -> Bool) -> [Attribute] -> [Attribute]
    filterAttributes (OID -> OID -> Bool
    forall a. Eq a => a -> a -> Bool
    /= OID
    oid)
      where attr :: Attribute
    attr = Attribute { attrType :: OID
    attrType = OID
    oid, attrValues :: [ASN1]
    attrValues = [ASN1]
    vals }

    -- | Find an attribute with the specified attribute and run a parser on the
    -- attribute value when found.  'Nothing' is returned if the attribute could not
    -- be found but also when the parse failed.
    runParseAttribute :: OID -> [Attribute] -> ParseASN1 () a -> Maybe a
    runParseAttribute :: forall a. OID -> [Attribute] -> ParseASN1 () a -> Maybe a
    runParseAttribute OID
    oid [Attribute]
    attrs ParseASN1 () a
    p =
        case OID -> [Attribute] -> Maybe [ASN1]
    findAttribute OID
    oid [Attribute]
    attrs of
            Maybe [ASN1]
    Nothing -> Maybe a
    forall a. Maybe a
    Nothing
            Just [ASN1]
    s  -> (String -> Maybe a) -> (a -> Maybe a) -> Either String a -> Maybe a
    forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
    either (Maybe a -> String -> Maybe a
    forall a b. a -> b -> a
    const Maybe a
    forall a. Maybe a
    Nothing) a -> Maybe a
    forall a. a -> Maybe a
    Just (ParseASN1 () a -> [ASN1] -> Either String a
    forall a. ParseASN1 () a -> [ASN1] -> Either String a
    runParseASN1 ParseASN1 () a
    p [ASN1]
    s)

    -- | Add or replace an attribute in a list of attributes, using 'ASN1S'.
    setAttributeASN1S :: OID -> ASN1S -> [Attribute] -> [Attribute]
    setAttributeASN1S :: OID -> ASN1S -> [Attribute] -> [Attribute]
    setAttributeASN1S OID
    oid ASN1S
    g = OID -> [ASN1] -> [Attribute] -> [Attribute]
    setAttribute OID
    oid (ASN1S
    g [])

    -- Content type

    contentType :: OID
    contentType :: OID
    contentType = [Integer
    1,Integer
    2,Integer
    840,Integer
    113549,Integer
    1,Integer
    9,Integer
    3]

    -- | Return the value of the @contentType@ attribute.
    getContentTypeAttr :: [Attribute] -> Maybe ContentType
    getContentTypeAttr :: [Attribute] -> Maybe ContentType
    getContentTypeAttr [Attribute]
    attrs = OID -> [Attribute] -> ParseASN1 () ContentType -> Maybe ContentType
    forall a. OID -> [Attribute] -> ParseASN1 () a -> Maybe a
    runParseAttribute OID
    contentType [Attribute]
    attrs (ParseASN1 () ContentType -> Maybe ContentType)
    -> ParseASN1 () ContentType -> Maybe ContentType
    forall a b. (a -> b) -> a -> b
    $ do
        OID OID
    oid <- ParseASN1 () ASN1
    forall e. Monoid e => ParseASN1 e ASN1
    getNext
        String
    -> OID
    -> (ContentType -> ParseASN1 () ContentType)
    -> ParseASN1 () ContentType
    forall a e b.
    OIDNameable a =>
    String -> OID -> (a -> ParseASN1 e b) -> ParseASN1 e b
    withObjectID String
    "content type" OID
    oid ContentType -> ParseASN1 () ContentType
    forall a. a -> ParseASN1 () a
    forall (m :: * -> *) a. Monad m => a -> m a
    return

    -- | Add or replace the @contentType@ attribute in a list of attributes.
    setContentTypeAttr :: ContentType -> [Attribute] -> [Attribute]
    setContentTypeAttr :: ContentType -> [Attribute] -> [Attribute]
    setContentTypeAttr ContentType
    ct = OID -> ASN1S -> [Attribute] -> [Attribute]
    setAttributeASN1S OID
    contentType (OID -> ASN1S
    forall e. ASN1Elem e => OID -> ASN1Stream e
    gOID (OID -> ASN1S) -> OID -> ASN1S
    forall a b. (a -> b) -> a -> b
    $ ContentType -> OID
    forall a. OIDable a => a -> OID
    getObjectID ContentType
    ct)

    -- Message digest

    messageDigest :: OID
    messageDigest :: OID
    messageDigest = [Integer
    1,Integer
    2,Integer
    840,Integer
    113549,Integer
    1,Integer
    9,Integer
    4]

    -- | Return the value of the @messageDigest@ attribute.
    getMessageDigestAttr :: [Attribute] -> Maybe ByteString
    getMessageDigestAttr :: [Attribute] -> Maybe ByteString
    getMessageDigestAttr [Attribute]
    attrs = OID -> [Attribute] -> ParseASN1 () ByteString -> Maybe ByteString
    forall a. OID -> [Attribute] -> ParseASN1 () a -> Maybe a
    runParseAttribute OID
    messageDigest [Attribute]
    attrs (ParseASN1 () ByteString -> Maybe ByteString)
    -> ParseASN1 () ByteString -> Maybe ByteString
    forall a b. (a -> b) -> a -> b
    $ do
        OctetString ByteString
    d <- ParseASN1 () ASN1
    forall e. Monoid e => ParseASN1 e ASN1
    getNext
        ByteString -> ParseASN1 () ByteString
    forall a. a -> ParseASN1 () a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ByteString
    d

    -- | Add or replace the @messageDigest@ attribute in a list of attributes.
    setMessageDigestAttr :: ByteString -> [Attribute] -> [Attribute]
    setMessageDigestAttr :: ByteString -> [Attribute] -> [Attribute]
    setMessageDigestAttr ByteString
    d = OID -> ASN1S -> [Attribute] -> [Attribute]
    setAttributeASN1S OID
    messageDigest (ByteString -> ASN1S
    forall e. ASN1Elem e => ByteString -> ASN1Stream e
    gOctetString ByteString
    d)

    -- Signing time

    signingTime :: OID
    signingTime :: OID
    signingTime = [Integer
    1,Integer
    2,Integer
    840,Integer
    113549,Integer
    1,Integer
    9,Integer
    5]

    -- | Return the value of the @signingTime@ attribute.
    getSigningTimeAttr :: [Attribute] -> Maybe DateTime
    getSigningTimeAttr :: [Attribute] -> Maybe DateTime
    getSigningTimeAttr [Attribute]
    attrs = OID -> [Attribute] -> ParseASN1 () DateTime -> Maybe DateTime
    forall a. OID -> [Attribute] -> ParseASN1 () a -> Maybe a
    runParseAttribute OID
    signingTime [Attribute]
    attrs (ParseASN1 () DateTime -> Maybe DateTime)
    -> ParseASN1 () DateTime -> Maybe DateTime
    forall a b. (a -> b) -> a -> b
    $ do
        ASN1Time ASN1TimeType
    _ DateTime
    t Maybe TimezoneOffset
    offset <- ParseASN1 () ASN1
    forall e. Monoid e => ParseASN1 e ASN1
    getNext
        let validOffset :: Bool
    validOffset = Bool -> (TimezoneOffset -> Bool) -> Maybe TimezoneOffset -> Bool
    forall b a. b -> (a -> b) -> Maybe a -> b
    maybe Bool
    True (TimezoneOffset -> TimezoneOffset -> Bool
    forall a. Eq a => a -> a -> Bool
    == Int -> TimezoneOffset
    TimezoneOffset Int
    0) Maybe TimezoneOffset
    offset
        if Bool
    validOffset
            then DateTime -> ParseASN1 () DateTime
    forall a. a -> ParseASN1 () a
    forall (m :: * -> *) a. Monad m => a -> m a
    return DateTime
    t
            else String -> ParseASN1 () DateTime
    forall a. String -> ParseASN1 () a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail String
    "getSigningTimeAttr: invalid timezone"

    -- | Add or replace the @signingTime@ attribute in a list of attributes.
    setSigningTimeAttr :: DateTime -> [Attribute] -> [Attribute]
    setSigningTimeAttr :: DateTime -> [Attribute] -> [Attribute]
    setSigningTimeAttr DateTime
    t =
        let normalize :: DateTime -> DateTime
    normalize DateTime
    val = DateTime
    val { dtTime :: TimeOfDay
    dtTime = (DateTime -> TimeOfDay
    dtTime DateTime
    val) { todNSec :: NanoSeconds
    todNSec = NanoSeconds
    0 } }
            offset :: Maybe TimezoneOffset
    offset = TimezoneOffset -> Maybe TimezoneOffset
    forall a. a -> Maybe a
    Just (Int -> TimezoneOffset
    TimezoneOffset Int
    0)
            ty :: ASN1TimeType
    ty | DateTime
    t DateTime -> DateTime -> Bool
    forall a. Ord a => a -> a -> Bool
    >= Date -> DateTime
    forall t1 t2. (Timeable t1, Time t2) => t1 -> t2
    timeConvert (Int -> Month -> Int -> Date
    Date Int
    2050 Month
    January Int
    1) = ASN1TimeType
    TimeGeneralized
               | DateTime
    t DateTime -> DateTime -> Bool
    forall a. Ord a => a -> a -> Bool
    <  Date -> DateTime
    forall t1 t2. (Timeable t1, Time t2) => t1 -> t2
    timeConvert (Int -> Month -> Int -> Date
    Date Int
    1950 Month
    January Int
    1) = ASN1TimeType
    TimeGeneralized
               | Bool
    otherwise                              = ASN1TimeType
    TimeUTC
         in OID -> ASN1S -> [Attribute] -> [Attribute]
    setAttributeASN1S OID
    signingTime (ASN1TimeType -> DateTime -> Maybe TimezoneOffset -> ASN1S
    forall e.
    ASN1Elem e =>
    ASN1TimeType -> DateTime -> Maybe TimezoneOffset -> ASN1Stream e
    gASN1Time ASN1TimeType
    ty (DateTime -> DateTime
    normalize DateTime
    t) Maybe TimezoneOffset
    offset)

    -- | Add or replace the @signingTime@ attribute in a list of attributes with the
    -- current time.  This is equivalent to calling 'setSigningTimeAttr' with the
    -- result of 'dateCurrent'.
    setSigningTimeAttrCurrent :: MonadIO m => [Attribute] -> m [Attribute]
    setSigningTimeAttrCurrent :: forall (m :: * -> *). MonadIO m => [Attribute] -> m [Attribute]
    setSigningTimeAttrCurrent [Attribute]
    attrs = do
        DateTime
    t <- IO DateTime -> m DateTime
    forall a. IO a -> m a
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
    liftIO IO DateTime
    dateCurrent
        [Attribute] -> m [Attribute]
    forall a. a -> m a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (DateTime -> [Attribute] -> [Attribute]
    setSigningTimeAttr DateTime
    t [Attribute]
    attrs)