{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
module Crypto.Store.CMS.Util
(
nullOrNothing
, intOrNothing
, dateTimeOrNothing
, OIDTable
, lookupOID
, Enumerable(..)
, OIDNameableWrapper(..)
, withObjectID
, ASN1Event
, ASN1ObjectExact(..)
, ProduceASN1Object(..)
, encodeASN1Object
, ParseASN1Object(..)
, fromASN1Repr
, AlgorithmId(..)
, algorithmASN1S
, algorithmMaybeASN1S
, parseAlgorithm
, parseAlgorithmMaybe
, orElse
) where
import Data.ASN1.BinaryEncoding.Raw
import Data.ASN1.OID
import Data.ASN1.Stream
import Data.ASN1.Types
import Data.ByteString (ByteString)
import Data.List (find)
import Data.X509
import Time.Types (DateTime)
import Crypto.Store.ASN1.Generate
import Crypto.Store.ASN1.Parse
nullOrNothing :: ASN1 -> Maybe ()
nullOrNothing Null = Just ()
nullOrNothing _ = Nothing
intOrNothing :: ASN1 -> Maybe Integer
intOrNothing (IntVal i) = Just i
intOrNothing _ = Nothing
dateTimeOrNothing :: ASN1 -> Maybe DateTime
dateTimeOrNothing (ASN1Time _ t _) = Just t
dateTimeOrNothing _ = Nothing
type OIDTable a = [(a, OID)]
lookupByOID :: OIDTable a -> OID -> Maybe a
lookupByOID table oid = fst <$> find ((==) oid . snd) table
lookupOID :: Eq a => OIDTable a -> a -> Maybe OID
lookupOID table a = lookup a table
class Enumerable a where
values :: [a]
newtype OIDNameableWrapper a = OIDNW { unOIDNW :: a }
deriving (Show,Eq)
instance (Enumerable a, OIDable a) => OIDNameable (OIDNameableWrapper a) where
fromObjectID = lookupByOID table
where table = [ (OIDNW val, getObjectID val) | val <- values ]
withObjectID :: OIDNameable a
=> String -> OID -> (a -> ParseASN1 e b) -> ParseASN1 e b
withObjectID name oid fn =
case fromObjectID oid of
Just val -> fn val
Nothing ->
throwParseError ("Unsupported " ++ name ++ ": OID " ++ show oid)
class ProduceASN1Object e obj where
asn1s :: obj -> ASN1Stream e
instance ProduceASN1Object e obj => ProduceASN1Object e [obj] where
asn1s l r = foldr asn1s r l
instance ASN1Elem e => ProduceASN1Object e DistinguishedName where
asn1s = asn1Container Sequence . inner
where
inner (DistinguishedName dn) cont = foldr dnSet cont dn
dnSet (oid, cs) =
asn1Container Set $
asn1Container Sequence (gOID oid . gASN1String cs)
instance (Show a, Eq a, ASN1Object a) => ProduceASN1Object ASN1P (SignedExact a) where
asn1s = gEncoded . encodeSignedObject
encodeASN1Object :: ProduceASN1Object ASN1P obj => obj -> ByteString
encodeASN1Object = encodeASN1S . asn1s
class Monoid e => ParseASN1Object e obj where
parse :: ParseASN1 e obj
instance ParseASN1Object e obj => ParseASN1Object e [obj] where
parse = getMany parse
instance Monoid e => ParseASN1Object e DistinguishedName where
parse = DistinguishedName <$> onNextContainer Sequence inner
where
inner = concat <$> getMany parseOne
parseOne =
onNextContainer Set $ getMany $
onNextContainer Sequence $ do
OID oid <- getNext
ASN1String cs <- getNext
return (oid, cs)
instance (Show a, Eq a, ASN1Object a) => ParseASN1Object [ASN1Event] (SignedExact a) where
parse = withAnnotations parseSequence >>= finish
where
parseSequence = onNextContainer Sequence (getMany getNext)
finish (_, events) =
case decodeSignedObject (toByteString events) of
Right se -> return se
Left err -> throwParseError ("SignedExact: " ++ err)
fromASN1Repr :: ParseASN1Object [ASN1Event] obj
=> [ASN1Repr] -> Either String (obj, [ASN1Repr])
fromASN1Repr = runParseASN1State_ parse
data ASN1ObjectExact a = ASN1ObjectExact
{ exactObject :: a
, exactObjectRaw :: ByteString
} deriving Show
instance Eq a => Eq (ASN1ObjectExact a)
where a == b = exactObject a == exactObject b
instance ProduceASN1Object ASN1P a => ProduceASN1Object ASN1P (ASN1ObjectExact a) where
asn1s = gEncoded . exactObjectRaw
instance ParseASN1Object [ASN1Event] a => ParseASN1Object [ASN1Event] (ASN1ObjectExact a) where
parse = do
(obj, events) <- withAnnotations parse
let objRaw = toByteString events
return ASN1ObjectExact { exactObject = obj, exactObjectRaw = objRaw }
class AlgorithmId param where
type AlgorithmType param
algorithmName :: param -> String
algorithmType :: param -> AlgorithmType param
parameterASN1S :: ASN1Elem e => param -> ASN1Stream e
parseParameter :: Monoid e => AlgorithmType param -> ParseASN1 e param
algorithmASN1S :: (ASN1Elem e, AlgorithmId param, OIDable (AlgorithmType param))
=> ASN1ConstructionType -> param -> ASN1Stream e
algorithmASN1S ty p = asn1Container ty (oid . parameterASN1S p)
where typ = algorithmType p
oid = gOID (getObjectID typ)
algorithmMaybeASN1S :: (ASN1Elem e, AlgorithmId param, OIDable (AlgorithmType param))
=> ASN1ConstructionType -> Maybe param -> ASN1Stream e
algorithmMaybeASN1S _ Nothing = id
algorithmMaybeASN1S ty (Just p) = algorithmASN1S ty p
parseAlgorithm :: forall e param . (Monoid e, AlgorithmId param, OIDNameable (AlgorithmType param))
=> ASN1ConstructionType -> ParseASN1 e param
parseAlgorithm ty = onNextContainer ty $ do
OID oid <- getNext
withObjectID (getName undefined) oid parseParameter
where
getName :: param -> String
getName = algorithmName
parseAlgorithmMaybe :: forall e param . (Monoid e, AlgorithmId param, OIDNameable (AlgorithmType param))
=> ASN1ConstructionType -> ParseASN1 e (Maybe param)
parseAlgorithmMaybe ty = onNextContainerMaybe ty $ do
OID oid <- getNext
withObjectID (getName undefined) oid parseParameter
where
getName :: param -> String
getName = algorithmName
orElse :: Monad m => m (Maybe a) -> m (Maybe a) -> m (Maybe a)
orElse pa pb = do
va <- pa
case va of
Nothing -> pb
_ -> return va