{-# LANGUAGE FlexibleContexts #-}
module Data.X509.CRL
( CRL(..)
, RevokedCertificate(..)
) where
import Control.Applicative
import Data.Hourglass (DateTime, TimezoneOffset(..))
import Data.ASN1.Types
import Data.X509.DistinguishedName
import Data.X509.AlgorithmIdentifier
import Data.X509.ExtensionRaw
import Data.X509.Internal
data CRL = CRL
{ CRL -> Integer
crlVersion :: Integer
, CRL -> SignatureALG
crlSignatureAlg :: SignatureALG
, CRL -> DistinguishedName
crlIssuer :: DistinguishedName
, CRL -> DateTime
crlThisUpdate :: DateTime
, CRL -> Maybe DateTime
crlNextUpdate :: Maybe DateTime
, CRL -> [RevokedCertificate]
crlRevokedCertificates :: [RevokedCertificate]
, CRL -> Extensions
crlExtensions :: Extensions
} deriving (Int -> CRL -> ShowS
[CRL] -> ShowS
CRL -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CRL] -> ShowS
$cshowList :: [CRL] -> ShowS
show :: CRL -> String
$cshow :: CRL -> String
showsPrec :: Int -> CRL -> ShowS
$cshowsPrec :: Int -> CRL -> ShowS
Show,CRL -> CRL -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CRL -> CRL -> Bool
$c/= :: CRL -> CRL -> Bool
== :: CRL -> CRL -> Bool
$c== :: CRL -> CRL -> Bool
Eq)
data RevokedCertificate = RevokedCertificate
{ RevokedCertificate -> Integer
revokedSerialNumber :: Integer
, RevokedCertificate -> DateTime
revokedDate :: DateTime
, RevokedCertificate -> Extensions
revokedExtensions :: Extensions
} deriving (Int -> RevokedCertificate -> ShowS
[RevokedCertificate] -> ShowS
RevokedCertificate -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RevokedCertificate] -> ShowS
$cshowList :: [RevokedCertificate] -> ShowS
show :: RevokedCertificate -> String
$cshow :: RevokedCertificate -> String
showsPrec :: Int -> RevokedCertificate -> ShowS
$cshowsPrec :: Int -> RevokedCertificate -> ShowS
Show,RevokedCertificate -> RevokedCertificate -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RevokedCertificate -> RevokedCertificate -> Bool
$c/= :: RevokedCertificate -> RevokedCertificate -> Bool
== :: RevokedCertificate -> RevokedCertificate -> Bool
$c== :: RevokedCertificate -> RevokedCertificate -> Bool
Eq)
instance ASN1Object CRL where
toASN1 :: CRL -> ASN1S
toASN1 CRL
crl = CRL -> ASN1S
encodeCRL CRL
crl
fromASN1 :: [ASN1] -> Either String (CRL, [ASN1])
fromASN1 = forall a. ParseASN1 a -> [ASN1] -> Either String (a, [ASN1])
runParseASN1State ParseASN1 CRL
parseCRL
instance ASN1Object RevokedCertificate where
fromASN1 :: [ASN1] -> Either String (RevokedCertificate, [ASN1])
fromASN1 = forall a. ParseASN1 a -> [ASN1] -> Either String (a, [ASN1])
runParseASN1State forall a b. (a -> b) -> a -> b
$
forall a. ASN1ConstructionType -> ParseASN1 a -> ParseASN1 a
onNextContainer ASN1ConstructionType
Sequence forall a b. (a -> b) -> a -> b
$
Integer -> DateTime -> Extensions -> RevokedCertificate
RevokedCertificate
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParseASN1 Integer
parseSerialNumber
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (ParseASN1 ASN1
getNext forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ASN1 -> ParseASN1 DateTime
toTime)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. ASN1Object a => ParseASN1 a
getObject
where toTime :: ASN1 -> ParseASN1 DateTime
toTime (ASN1Time ASN1TimeType
_ DateTime
t Maybe TimezoneOffset
_) = forall (f :: * -> *) a. Applicative f => a -> f a
pure DateTime
t
toTime ASN1
_ = forall a. String -> ParseASN1 a
throwParseError String
"bad revocation date"
toASN1 :: RevokedCertificate -> ASN1S
toASN1 (RevokedCertificate Integer
serial DateTime
time Extensions
crlEntryExtensions) = \[ASN1]
xs ->
[ ASN1ConstructionType -> ASN1
Start ASN1ConstructionType
Sequence ] forall a. [a] -> [a] -> [a]
++
[ Integer -> ASN1
IntVal Integer
serial ] forall a. [a] -> [a] -> [a]
++
[ ASN1TimeType -> DateTime -> Maybe TimezoneOffset -> ASN1
ASN1Time ASN1TimeType
TimeGeneralized DateTime
time (forall a. a -> Maybe a
Just (Int -> TimezoneOffset
TimezoneOffset Int
0)) ] forall a. [a] -> [a] -> [a]
++
forall a. ASN1Object a => a -> ASN1S
toASN1 Extensions
crlEntryExtensions [] forall a. [a] -> [a] -> [a]
++
[ ASN1ConstructionType -> ASN1
End ASN1ConstructionType
Sequence ] forall a. [a] -> [a] -> [a]
++
[ASN1]
xs
parseSerialNumber :: ParseASN1 Integer
parseSerialNumber :: ParseASN1 Integer
parseSerialNumber = do
ASN1
n <- ParseASN1 ASN1
getNext
case ASN1
n of
IntVal Integer
v -> forall (m :: * -> *) a. Monad m => a -> m a
return Integer
v
ASN1
_ -> forall a. String -> ParseASN1 a
throwParseError (String
"missing serial" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show ASN1
n)
parseCRL :: ParseASN1 CRL
parseCRL :: ParseASN1 CRL
parseCRL = do
Integer
-> SignatureALG
-> DistinguishedName
-> DateTime
-> Maybe DateTime
-> [RevokedCertificate]
-> Extensions
-> CRL
CRL forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ParseASN1 ASN1
getNext forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall {a}. Num a => ASN1 -> ParseASN1 a
getVersion)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. ASN1Object a => ParseASN1 a
getObject
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. ASN1Object a => ParseASN1 a
getObject
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (ParseASN1 ASN1
getNext forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ASN1 -> ParseASN1 DateTime
getThisUpdate)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParseASN1 (Maybe DateTime)
getNextUpdate
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParseASN1 [RevokedCertificate]
parseRevokedCertificates
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParseASN1 Extensions
parseCRLExtensions
where getVersion :: ASN1 -> ParseASN1 a
getVersion (IntVal Integer
v) = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
v
getVersion ASN1
_ = forall a. String -> ParseASN1 a
throwParseError String
"unexpected type for version"
getThisUpdate :: ASN1 -> ParseASN1 DateTime
getThisUpdate (ASN1Time ASN1TimeType
_ DateTime
t1 Maybe TimezoneOffset
_) = forall (m :: * -> *) a. Monad m => a -> m a
return DateTime
t1
getThisUpdate ASN1
_ = forall a. String -> ParseASN1 a
throwParseError String
"bad this update format, expecting time"
getNextUpdate :: ParseASN1 (Maybe DateTime)
getNextUpdate = forall a. (ASN1 -> Maybe a) -> ParseASN1 (Maybe a)
getNextMaybe ASN1 -> Maybe DateTime
timeOrNothing
timeOrNothing :: ASN1 -> Maybe DateTime
timeOrNothing (ASN1Time ASN1TimeType
_ DateTime
tnext Maybe TimezoneOffset
_) = forall a. a -> Maybe a
Just DateTime
tnext
timeOrNothing ASN1
_ = forall a. Maybe a
Nothing
parseRevokedCertificates :: ParseASN1 [RevokedCertificate]
parseRevokedCertificates :: ParseASN1 [RevokedCertificate]
parseRevokedCertificates =
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] forall a. a -> a
id) forall a b. (a -> b) -> a -> b
$ forall a.
ASN1ConstructionType -> ParseASN1 a -> ParseASN1 (Maybe a)
onNextContainerMaybe ASN1ConstructionType
Sequence forall a b. (a -> b) -> a -> b
$ forall a. ParseASN1 a -> ParseASN1 [a]
getMany forall a. ASN1Object a => ParseASN1 a
getObject
parseCRLExtensions :: ParseASN1 Extensions
parseCRLExtensions :: ParseASN1 Extensions
parseCRLExtensions =
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Maybe Extensions -> Extensions
adapt forall a b. (a -> b) -> a -> b
$ forall a.
ASN1ConstructionType -> ParseASN1 a -> ParseASN1 (Maybe a)
onNextContainerMaybe (ASN1Class -> Int -> ASN1ConstructionType
Container ASN1Class
Context Int
0) forall a b. (a -> b) -> a -> b
$ forall a. ASN1Object a => ParseASN1 a
getObject
where adapt :: Maybe Extensions -> Extensions
adapt (Just Extensions
e) = Extensions
e
adapt Maybe Extensions
Nothing = Maybe [ExtensionRaw] -> Extensions
Extensions forall a. Maybe a
Nothing
encodeCRL :: CRL -> ASN1S
encodeCRL :: CRL -> ASN1S
encodeCRL CRL
crl [ASN1]
xs =
[Integer -> ASN1
IntVal forall a b. (a -> b) -> a -> b
$ CRL -> Integer
crlVersion CRL
crl] forall a. [a] -> [a] -> [a]
++
forall a. ASN1Object a => a -> ASN1S
toASN1 (CRL -> SignatureALG
crlSignatureAlg CRL
crl) [] forall a. [a] -> [a] -> [a]
++
forall a. ASN1Object a => a -> ASN1S
toASN1 (CRL -> DistinguishedName
crlIssuer CRL
crl) [] forall a. [a] -> [a] -> [a]
++
[ASN1TimeType -> DateTime -> Maybe TimezoneOffset -> ASN1
ASN1Time ASN1TimeType
TimeGeneralized (CRL -> DateTime
crlThisUpdate CRL
crl) (forall a. a -> Maybe a
Just (Int -> TimezoneOffset
TimezoneOffset Int
0))] forall a. [a] -> [a] -> [a]
++
(forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\DateTime
t -> [ASN1TimeType -> DateTime -> Maybe TimezoneOffset -> ASN1
ASN1Time ASN1TimeType
TimeGeneralized DateTime
t (forall a. a -> Maybe a
Just (Int -> TimezoneOffset
TimezoneOffset Int
0))]) (CRL -> Maybe DateTime
crlNextUpdate CRL
crl)) forall a. [a] -> [a] -> [a]
++
forall {a}. ASN1Object a => [a] -> [ASN1]
maybeRevoked (CRL -> [RevokedCertificate]
crlRevokedCertificates CRL
crl) forall a. [a] -> [a] -> [a]
++
Extensions -> [ASN1]
maybeCrlExts (CRL -> Extensions
crlExtensions CRL
crl) forall a. [a] -> [a] -> [a]
++
[ASN1]
xs
where
maybeRevoked :: [a] -> [ASN1]
maybeRevoked [] = []
maybeRevoked [a]
xs' = ASN1ConstructionType -> ASN1S
asn1Container ASN1ConstructionType
Sequence forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\a
e -> forall a. ASN1Object a => a -> ASN1S
toASN1 a
e []) [a]
xs'
maybeCrlExts :: Extensions -> [ASN1]
maybeCrlExts (Extensions Maybe [ExtensionRaw]
Nothing) = []
maybeCrlExts Extensions
exts = ASN1ConstructionType -> ASN1S
asn1Container (ASN1Class -> Int -> ASN1ConstructionType
Container ASN1Class
Context Int
0) forall a b. (a -> b) -> a -> b
$ forall a. ASN1Object a => a -> ASN1S
toASN1 Extensions
exts []