-- |
-- 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
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Attribute] -> ShowS
$cshowList :: [Attribute] -> ShowS
show :: Attribute -> String
$cshow :: Attribute -> String
showsPrec :: Int -> Attribute -> ShowS
$cshowsPrec :: Int -> Attribute -> ShowS
Show,Attribute -> Attribute -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Attribute -> Attribute -> Bool
$c/= :: Attribute -> Attribute -> Bool
== :: Attribute -> Attribute -> Bool
$c== :: Attribute -> Attribute -> Bool
Eq)

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

instance Monoid e => ParseASN1Object e Attribute where
    parse :: ParseASN1 e Attribute
parse = forall e a.
Monoid e =>
ASN1ConstructionType -> ParseASN1 e a -> ParseASN1 e a
onNextContainer ASN1ConstructionType
Sequence forall a b. (a -> b) -> a -> b
$ do
        OID OID
oid <- forall e. Monoid e => ParseASN1 e ASN1
getNext
        [ASN1]
vals <- forall e a.
Monoid e =>
ASN1ConstructionType -> ParseASN1 e a -> ParseASN1 e a
onNextContainer ASN1ConstructionType
Set (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 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
_  []    = forall a. a -> a
id
attributesASN1S ASN1ConstructionType
ty [Attribute]
attrs = forall e.
ASN1Elem e =>
ASN1ConstructionType -> ASN1Stream e -> ASN1Stream e
asn1Container ASN1ConstructionType
ty (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 = 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 ASN1ConstructionType
ty 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 forall a. Eq a => a -> a -> Bool
== OID
oid ] of
        []    -> forall a. Maybe a
Nothing
        ([ASN1]
v:[[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 = forall a. (a -> Bool) -> [a] -> [a]
filter (OID -> Bool
p 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. (OID -> Bool) -> [Attribute] -> [Attribute]
filterAttributes (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 -> forall a. Maybe a
Nothing
        Just [ASN1]
s  -> forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const forall a. Maybe a
Nothing) forall a. a -> Maybe a
Just (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 = forall a. OID -> [Attribute] -> ParseASN1 () a -> Maybe a
runParseAttribute OID
contentType [Attribute]
attrs forall a b. (a -> b) -> a -> b
$ do
    OID OID
oid <- forall e. Monoid e => ParseASN1 e ASN1
getNext
    forall a e b.
OIDNameable a =>
String -> OID -> (a -> ParseASN1 e b) -> ParseASN1 e b
withObjectID String
"content type" OID
oid 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 (forall e. ASN1Elem e => OID -> ASN1Stream e
gOID forall a b. (a -> b) -> a -> b
$ 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 = forall a. OID -> [Attribute] -> ParseASN1 () a -> Maybe a
runParseAttribute OID
messageDigest [Attribute]
attrs forall a b. (a -> b) -> a -> b
$ do
    OctetString ByteString
d <- forall e. Monoid e => ParseASN1 e ASN1
getNext
    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 (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 = forall a. OID -> [Attribute] -> ParseASN1 () a -> Maybe a
runParseAttribute OID
signingTime [Attribute]
attrs forall a b. (a -> b) -> a -> b
$ do
    ASN1Time ASN1TimeType
_ DateTime
t Maybe TimezoneOffset
offset <- forall e. Monoid e => ParseASN1 e ASN1
getNext
    let validOffset :: Bool
validOffset = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (forall a. Eq a => a -> a -> Bool
== Int -> TimezoneOffset
TimezoneOffset Int
0) Maybe TimezoneOffset
offset
    if Bool
validOffset
        then forall (m :: * -> *) a. Monad m => a -> m a
return DateTime
t
        else 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 = forall a. a -> Maybe a
Just (Int -> TimezoneOffset
TimezoneOffset Int
0)
        ty :: ASN1TimeType
ty | DateTime
t forall a. Ord a => a -> a -> Bool
>= 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 forall a. Ord a => a -> a -> Bool
<  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 (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 <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO DateTime
dateCurrent
    forall (m :: * -> *) a. Monad m => a -> m a
return (DateTime -> [Attribute] -> [Attribute]
setSigningTimeAttr DateTime
t [Attribute]
attrs)