{-# 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(..)
, decodeASN1Object
, AlgorithmId(..)
, algorithmASN1S
, algorithmMaybeASN1S
, parseAlgorithm
, parseAlgorithmMaybe
, orElse
) where
import Data.ASN1.BinaryEncoding
import Data.ASN1.BinaryEncoding.Raw
import Data.ASN1.Encoding
import Data.ASN1.OID
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
import Crypto.Store.Error
nullOrNothing :: ASN1 -> Maybe ()
nullOrNothing :: ASN1 -> Maybe ()
nullOrNothing ASN1
Null = forall a. a -> Maybe a
Just ()
nullOrNothing ASN1
_ = forall a. Maybe a
Nothing
intOrNothing :: ASN1 -> Maybe Integer
intOrNothing :: ASN1 -> Maybe Integer
intOrNothing (IntVal Integer
i) = forall a. a -> Maybe a
Just Integer
i
intOrNothing ASN1
_ = forall a. Maybe a
Nothing
dateTimeOrNothing :: ASN1 -> Maybe DateTime
dateTimeOrNothing :: ASN1 -> Maybe DateTime
dateTimeOrNothing (ASN1Time ASN1TimeType
_ DateTime
t Maybe TimezoneOffset
_) = forall a. a -> Maybe a
Just DateTime
t
dateTimeOrNothing ASN1
_ = forall a. Maybe a
Nothing
type OIDTable a = [(a, OID)]
lookupByOID :: OIDTable a -> OID -> Maybe a
lookupByOID :: forall a. OIDTable a -> OID -> Maybe a
lookupByOID OIDTable a
table OID
oid = forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (forall a. Eq a => a -> a -> Bool
(==) OID
oid forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) OIDTable a
table
lookupOID :: Eq a => OIDTable a -> a -> Maybe OID
lookupOID :: forall a. Eq a => OIDTable a -> a -> Maybe OID
lookupOID OIDTable a
table a
a = forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup a
a OIDTable a
table
class Enumerable a where
values :: [a]
newtype OIDNameableWrapper a = OIDNW { forall a. OIDNameableWrapper a -> a
unOIDNW :: a }
deriving (Int -> OIDNameableWrapper a -> ShowS
forall a. Show a => Int -> OIDNameableWrapper a -> ShowS
forall a. Show a => [OIDNameableWrapper a] -> ShowS
forall a. Show a => OIDNameableWrapper a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [OIDNameableWrapper a] -> ShowS
$cshowList :: forall a. Show a => [OIDNameableWrapper a] -> ShowS
show :: OIDNameableWrapper a -> String
$cshow :: forall a. Show a => OIDNameableWrapper a -> String
showsPrec :: Int -> OIDNameableWrapper a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> OIDNameableWrapper a -> ShowS
Show,OIDNameableWrapper a -> OIDNameableWrapper a -> Bool
forall a.
Eq a =>
OIDNameableWrapper a -> OIDNameableWrapper a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: OIDNameableWrapper a -> OIDNameableWrapper a -> Bool
$c/= :: forall a.
Eq a =>
OIDNameableWrapper a -> OIDNameableWrapper a -> Bool
== :: OIDNameableWrapper a -> OIDNameableWrapper a -> Bool
$c== :: forall a.
Eq a =>
OIDNameableWrapper a -> OIDNameableWrapper a -> Bool
Eq)
instance (Enumerable a, OIDable a) => OIDNameable (OIDNameableWrapper a) where
fromObjectID :: OID -> Maybe (OIDNameableWrapper a)
fromObjectID = forall a. OIDTable a -> OID -> Maybe a
lookupByOID [(OIDNameableWrapper a, OID)]
table
where table :: [(OIDNameableWrapper a, OID)]
table = [ (forall a. a -> OIDNameableWrapper a
OIDNW a
val, forall a. OIDable a => a -> OID
getObjectID a
val) | a
val <- forall a. Enumerable a => [a]
values ]
withObjectID :: OIDNameable a
=> String -> OID -> (a -> ParseASN1 e b) -> ParseASN1 e b
withObjectID :: forall a e b.
OIDNameable a =>
String -> OID -> (a -> ParseASN1 e b) -> ParseASN1 e b
withObjectID String
name OID
oid a -> ParseASN1 e b
fn =
case forall a. OIDNameable a => OID -> Maybe a
fromObjectID OID
oid of
Just a
val -> a -> ParseASN1 e b
fn a
val
Maybe a
Nothing ->
forall e a. String -> ParseASN1 e a
throwParseError (String
"Unsupported " forall a. [a] -> [a] -> [a]
++ String
name forall a. [a] -> [a] -> [a]
++ String
": OID " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show OID
oid)
class ProduceASN1Object e obj where
asn1s :: obj -> ASN1Stream e
instance ProduceASN1Object e obj => ProduceASN1Object e [obj] where
asn1s :: [obj] -> ASN1Stream e
asn1s [obj]
l [e]
r = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall e obj. ProduceASN1Object e obj => obj -> ASN1Stream e
asn1s [e]
r [obj]
l
instance ASN1Elem e => ProduceASN1Object e DistinguishedName where
asn1s :: DistinguishedName -> ASN1Stream e
asn1s = forall e.
ASN1Elem e =>
ASN1ConstructionType -> ASN1Stream e -> ASN1Stream e
asn1Container ASN1ConstructionType
Sequence forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e. ASN1Elem e => DistinguishedName -> ASN1Stream e
inner
where
inner :: DistinguishedName -> [e] -> [e]
inner (DistinguishedName [(OID, ASN1CharacterString)]
dn) [e]
cont = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall {e}.
ASN1Elem e =>
(OID, ASN1CharacterString) -> ASN1Stream e
dnSet [e]
cont [(OID, ASN1CharacterString)]
dn
dnSet :: (OID, ASN1CharacterString) -> ASN1Stream e
dnSet (OID
oid, ASN1CharacterString
cs) =
forall e.
ASN1Elem e =>
ASN1ConstructionType -> ASN1Stream e -> ASN1Stream e
asn1Container ASN1ConstructionType
Set forall a b. (a -> b) -> a -> b
$
forall e.
ASN1Elem e =>
ASN1ConstructionType -> ASN1Stream e -> ASN1Stream e
asn1Container ASN1ConstructionType
Sequence (forall e. ASN1Elem e => OID -> ASN1Stream e
gOID OID
oid forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e. ASN1Elem e => ASN1CharacterString -> ASN1Stream e
gASN1String ASN1CharacterString
cs)
instance (Show a, Eq a, ASN1Object a) => ProduceASN1Object ASN1P (SignedExact a) where
asn1s :: SignedExact a -> ASN1Stream ASN1P
asn1s = ByteString -> ASN1Stream ASN1P
gEncoded forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a.
(Show a, Eq a, ASN1Object a) =>
SignedExact a -> ByteString
encodeSignedObject
encodeASN1Object :: ProduceASN1Object ASN1P obj => obj -> ByteString
encodeASN1Object :: forall obj. ProduceASN1Object ASN1P obj => obj -> ByteString
encodeASN1Object = ASN1Stream ASN1P -> ByteString
encodeASN1S forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e obj. ProduceASN1Object e obj => obj -> ASN1Stream e
asn1s
class Monoid e => ParseASN1Object e obj where
parse :: ParseASN1 e obj
instance ParseASN1Object e obj => ParseASN1Object e [obj] where
parse :: ParseASN1 e [obj]
parse = forall e a. ParseASN1 e a -> ParseASN1 e [a]
getMany forall e obj. ParseASN1Object e obj => ParseASN1 e obj
parse
instance Monoid e => ParseASN1Object e DistinguishedName where
parse :: ParseASN1 e DistinguishedName
parse = [(OID, ASN1CharacterString)] -> DistinguishedName
DistinguishedName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e a.
Monoid e =>
ASN1ConstructionType -> ParseASN1 e a -> ParseASN1 e a
onNextContainer ASN1ConstructionType
Sequence ParseASN1 e [(OID, ASN1CharacterString)]
inner
where
inner :: ParseASN1 e [(OID, ASN1CharacterString)]
inner = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e a. ParseASN1 e a -> ParseASN1 e [a]
getMany ParseASN1 e [(OID, ASN1CharacterString)]
parseOne
parseOne :: ParseASN1 e [(OID, ASN1CharacterString)]
parseOne =
forall e a.
Monoid e =>
ASN1ConstructionType -> ParseASN1 e a -> ParseASN1 e a
onNextContainer ASN1ConstructionType
Set forall a b. (a -> b) -> a -> b
$ forall e a. ParseASN1 e a -> ParseASN1 e [a]
getMany forall a b. (a -> b) -> a -> b
$
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
ASN1String ASN1CharacterString
cs <- forall e. Monoid e => ParseASN1 e ASN1
getNext
forall (m :: * -> *) a. Monad m => a -> m a
return (OID
oid, ASN1CharacterString
cs)
instance (Show a, Eq a, ASN1Object a) => ParseASN1Object [ASN1Event] (SignedExact a) where
parse :: ParseASN1 [ASN1Event] (SignedExact a)
parse = forall e a. Monoid e => ParseASN1 e a -> ParseASN1 e (a, e)
withAnnotations ParseASN1 [ASN1Event] [ASN1]
parseSequence forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall {a} {a} {e}.
(Show a, Eq a, ASN1Object a) =>
(a, [ASN1Event]) -> ParseASN1 e (SignedExact a)
finish
where
parseSequence :: ParseASN1 [ASN1Event] [ASN1]
parseSequence = forall e a.
Monoid e =>
ASN1ConstructionType -> ParseASN1 e a -> ParseASN1 e a
onNextContainer ASN1ConstructionType
Sequence (forall e a. ParseASN1 e a -> ParseASN1 e [a]
getMany forall e. Monoid e => ParseASN1 e ASN1
getNext)
finish :: (a, [ASN1Event]) -> ParseASN1 e (SignedExact a)
finish (a
_, [ASN1Event]
events) =
case forall a.
(Show a, Eq a, ASN1Object a) =>
ByteString -> Either String (SignedExact a)
decodeSignedObject ([ASN1Event] -> ByteString
toByteString [ASN1Event]
events) of
Right SignedExact a
se -> forall (m :: * -> *) a. Monad m => a -> m a
return SignedExact a
se
Left String
err -> forall e a. String -> ParseASN1 e a
throwParseError (String
"SignedExact: " forall a. [a] -> [a] -> [a]
++ String
err)
decodeASN1Object :: ParseASN1Object [ASN1Event] obj => ByteString -> Either StoreError obj
decodeASN1Object :: forall obj.
ParseASN1Object [ASN1Event] obj =>
ByteString -> Either StoreError obj
decodeASN1Object ByteString
bs =
case forall a.
ASN1DecodingRepr a =>
a -> ByteString -> Either ASN1Error [ASN1Repr]
decodeASN1Repr' BER
BER ByteString
bs of
Left ASN1Error
e -> forall a b. a -> Either a b
Left (ASN1Error -> StoreError
DecodingError ASN1Error
e)
Right [ASN1Repr]
asn1 ->
case forall e a.
Monoid e =>
ParseASN1 e a -> [(ASN1, e)] -> Either String (a, [(ASN1, e)])
runParseASN1State_ forall e obj. ParseASN1Object e obj => ParseASN1 e obj
parse [ASN1Repr]
asn1 of
Right (obj
obj, []) -> forall a b. b -> Either a b
Right obj
obj
Right (obj, [ASN1Repr])
_ -> forall a b. a -> Either a b
Left (String -> StoreError
ParseFailure String
"Incomplete parse")
Left String
e -> forall a b. a -> Either a b
Left (String -> StoreError
ParseFailure String
e)
data ASN1ObjectExact a = ASN1ObjectExact
{ forall a. ASN1ObjectExact a -> a
exactObject :: a
, forall a. ASN1ObjectExact a -> ByteString
exactObjectRaw :: ByteString
} deriving Int -> ASN1ObjectExact a -> ShowS
forall a. Show a => Int -> ASN1ObjectExact a -> ShowS
forall a. Show a => [ASN1ObjectExact a] -> ShowS
forall a. Show a => ASN1ObjectExact a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ASN1ObjectExact a] -> ShowS
$cshowList :: forall a. Show a => [ASN1ObjectExact a] -> ShowS
show :: ASN1ObjectExact a -> String
$cshow :: forall a. Show a => ASN1ObjectExact a -> String
showsPrec :: Int -> ASN1ObjectExact a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> ASN1ObjectExact a -> ShowS
Show
instance Eq a => Eq (ASN1ObjectExact a)
where ASN1ObjectExact a
a == :: ASN1ObjectExact a -> ASN1ObjectExact a -> Bool
== ASN1ObjectExact a
b = forall a. ASN1ObjectExact a -> a
exactObject ASN1ObjectExact a
a forall a. Eq a => a -> a -> Bool
== forall a. ASN1ObjectExact a -> a
exactObject ASN1ObjectExact a
b
instance ProduceASN1Object ASN1P a => ProduceASN1Object ASN1P (ASN1ObjectExact a) where
asn1s :: ASN1ObjectExact a -> ASN1Stream ASN1P
asn1s = ByteString -> ASN1Stream ASN1P
gEncoded forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ASN1ObjectExact a -> ByteString
exactObjectRaw
instance ParseASN1Object [ASN1Event] a => ParseASN1Object [ASN1Event] (ASN1ObjectExact a) where
parse :: ParseASN1 [ASN1Event] (ASN1ObjectExact a)
parse = do
(a
obj, [ASN1Event]
events) <- forall e a. Monoid e => ParseASN1 e a -> ParseASN1 e (a, e)
withAnnotations forall e obj. ParseASN1Object e obj => ParseASN1 e obj
parse
let objRaw :: ByteString
objRaw = [ASN1Event] -> ByteString
toByteString [ASN1Event]
events
forall (m :: * -> *) a. Monad m => a -> m a
return ASN1ObjectExact { exactObject :: a
exactObject = a
obj, exactObjectRaw :: ByteString
exactObjectRaw = ByteString
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 :: forall e param.
(ASN1Elem e, AlgorithmId param, OIDable (AlgorithmType param)) =>
ASN1ConstructionType -> param -> ASN1Stream e
algorithmASN1S ASN1ConstructionType
ty param
p = forall e.
ASN1Elem e =>
ASN1ConstructionType -> ASN1Stream e -> ASN1Stream e
asn1Container ASN1ConstructionType
ty ([e] -> [e]
oid forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall param e.
(AlgorithmId param, ASN1Elem e) =>
param -> ASN1Stream e
parameterASN1S param
p)
where typ :: AlgorithmType param
typ = forall param. AlgorithmId param => param -> AlgorithmType param
algorithmType param
p
oid :: [e] -> [e]
oid = forall e. ASN1Elem e => OID -> ASN1Stream e
gOID (forall a. OIDable a => a -> OID
getObjectID AlgorithmType param
typ)
algorithmMaybeASN1S :: (ASN1Elem e, AlgorithmId param, OIDable (AlgorithmType param))
=> ASN1ConstructionType -> Maybe param -> ASN1Stream e
algorithmMaybeASN1S :: forall e param.
(ASN1Elem e, AlgorithmId param, OIDable (AlgorithmType param)) =>
ASN1ConstructionType -> Maybe param -> ASN1Stream e
algorithmMaybeASN1S ASN1ConstructionType
_ Maybe param
Nothing = forall a. a -> a
id
algorithmMaybeASN1S ASN1ConstructionType
ty (Just param
p) = forall e param.
(ASN1Elem e, AlgorithmId param, OIDable (AlgorithmType param)) =>
ASN1ConstructionType -> param -> ASN1Stream e
algorithmASN1S ASN1ConstructionType
ty param
p
parseAlgorithm :: forall e param . (Monoid e, AlgorithmId param, OIDNameable (AlgorithmType param))
=> ASN1ConstructionType -> ParseASN1 e param
parseAlgorithm :: forall e param.
(Monoid e, AlgorithmId param, OIDNameable (AlgorithmType param)) =>
ASN1ConstructionType -> ParseASN1 e param
parseAlgorithm 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
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 (param -> String
getName forall a. HasCallStack => a
undefined) OID
oid forall param e.
(AlgorithmId param, Monoid e) =>
AlgorithmType param -> ParseASN1 e param
parseParameter
where
getName :: param -> String
getName :: param -> String
getName = forall param. AlgorithmId param => param -> String
algorithmName
parseAlgorithmMaybe :: forall e param . (Monoid e, AlgorithmId param, OIDNameable (AlgorithmType param))
=> ASN1ConstructionType -> ParseASN1 e (Maybe param)
parseAlgorithmMaybe :: forall e param.
(Monoid e, AlgorithmId param, OIDNameable (AlgorithmType param)) =>
ASN1ConstructionType -> ParseASN1 e (Maybe param)
parseAlgorithmMaybe ASN1ConstructionType
ty = forall e a.
Monoid e =>
ASN1ConstructionType -> ParseASN1 e a -> ParseASN1 e (Maybe a)
onNextContainerMaybe ASN1ConstructionType
ty 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 (param -> String
getName forall a. HasCallStack => a
undefined) OID
oid forall param e.
(AlgorithmId param, Monoid e) =>
AlgorithmType param -> ParseASN1 e param
parseParameter
where
getName :: param -> String
getName :: param -> String
getName = forall param. AlgorithmId param => param -> String
algorithmName
orElse :: Monad m => m (Maybe a) -> m (Maybe a) -> m (Maybe a)
orElse :: forall (m :: * -> *) a.
Monad m =>
m (Maybe a) -> m (Maybe a) -> m (Maybe a)
orElse m (Maybe a)
pa m (Maybe a)
pb = do
Maybe a
va <- m (Maybe a)
pa
case Maybe a
va of
Maybe a
Nothing -> m (Maybe a)
pb
Maybe a
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
va