-- |
-- 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 = (dtTime val) { todNSec = 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)