-- |
-- Module      : Data.X509.CRL
-- License     : BSD-style
-- Maintainer  : Vincent Hanquez <vincent@snarc.org>
-- Stability   : experimental
-- Portability : unknown
--
-- Read and Write X509 Certificate Revocation List (CRL).
--
-- follows RFC5280 / RFC6818.
--
{-# 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

-- | Describe a Certificate revocation list
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
(Int -> CRL -> ShowS)
-> (CRL -> String) -> ([CRL] -> ShowS) -> Show CRL
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
(CRL -> CRL -> Bool) -> (CRL -> CRL -> Bool) -> Eq CRL
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)

-- | Describe a revoked certificate identifiable by serial number.
data RevokedCertificate = RevokedCertificate
    { RevokedCertificate -> Integer
revokedSerialNumber :: Integer
    , RevokedCertificate -> DateTime
revokedDate         :: DateTime
    , RevokedCertificate -> Extensions
revokedExtensions   :: Extensions
    } deriving (Int -> RevokedCertificate -> ShowS
[RevokedCertificate] -> ShowS
RevokedCertificate -> String
(Int -> RevokedCertificate -> ShowS)
-> (RevokedCertificate -> String)
-> ([RevokedCertificate] -> ShowS)
-> Show RevokedCertificate
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
(RevokedCertificate -> RevokedCertificate -> Bool)
-> (RevokedCertificate -> RevokedCertificate -> Bool)
-> Eq RevokedCertificate
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 = ParseASN1 CRL -> [ASN1] -> Either String (CRL, [ASN1])
forall a. ParseASN1 a -> [ASN1] -> Either String (a, [ASN1])
runParseASN1State ParseASN1 CRL
parseCRL

instance ASN1Object RevokedCertificate where
    fromASN1 :: [ASN1] -> Either String (RevokedCertificate, [ASN1])
fromASN1 = ParseASN1 RevokedCertificate
-> [ASN1] -> Either String (RevokedCertificate, [ASN1])
forall a. ParseASN1 a -> [ASN1] -> Either String (a, [ASN1])
runParseASN1State (ParseASN1 RevokedCertificate
 -> [ASN1] -> Either String (RevokedCertificate, [ASN1]))
-> ParseASN1 RevokedCertificate
-> [ASN1]
-> Either String (RevokedCertificate, [ASN1])
forall a b. (a -> b) -> a -> b
$
        ASN1ConstructionType
-> ParseASN1 RevokedCertificate -> ParseASN1 RevokedCertificate
forall a. ASN1ConstructionType -> ParseASN1 a -> ParseASN1 a
onNextContainer ASN1ConstructionType
Sequence (ParseASN1 RevokedCertificate -> ParseASN1 RevokedCertificate)
-> ParseASN1 RevokedCertificate -> ParseASN1 RevokedCertificate
forall a b. (a -> b) -> a -> b
$
        Integer -> DateTime -> Extensions -> RevokedCertificate
RevokedCertificate
        (Integer -> DateTime -> Extensions -> RevokedCertificate)
-> ParseASN1 Integer
-> ParseASN1 (DateTime -> Extensions -> RevokedCertificate)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParseASN1 Integer
parseSerialNumber
        ParseASN1 (DateTime -> Extensions -> RevokedCertificate)
-> ParseASN1 DateTime
-> ParseASN1 (Extensions -> RevokedCertificate)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (ParseASN1 ASN1
getNext ParseASN1 ASN1
-> (ASN1 -> ParseASN1 DateTime) -> ParseASN1 DateTime
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ASN1 -> ParseASN1 DateTime
toTime)
        ParseASN1 (Extensions -> RevokedCertificate)
-> ParseASN1 Extensions -> ParseASN1 RevokedCertificate
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParseASN1 Extensions
forall a. ASN1Object a => ParseASN1 a
getObject
      where toTime :: ASN1 -> ParseASN1 DateTime
toTime (ASN1Time ASN1TimeType
_ DateTime
t Maybe TimezoneOffset
_) = DateTime -> ParseASN1 DateTime
forall (f :: * -> *) a. Applicative f => a -> f a
pure DateTime
t
            toTime ASN1
_                = String -> ParseASN1 DateTime
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 ] [ASN1] -> ASN1S
forall a. [a] -> [a] -> [a]
++
        [ Integer -> ASN1
IntVal Integer
serial ] [ASN1] -> ASN1S
forall a. [a] -> [a] -> [a]
++
        [ ASN1TimeType -> DateTime -> Maybe TimezoneOffset -> ASN1
ASN1Time ASN1TimeType
TimeGeneralized DateTime
time (TimezoneOffset -> Maybe TimezoneOffset
forall a. a -> Maybe a
Just (Int -> TimezoneOffset
TimezoneOffset Int
0)) ] [ASN1] -> ASN1S
forall a. [a] -> [a] -> [a]
++
        Extensions -> ASN1S
forall a. ASN1Object a => a -> ASN1S
toASN1 Extensions
crlEntryExtensions [] [ASN1] -> ASN1S
forall a. [a] -> [a] -> [a]
++
        [ ASN1ConstructionType -> ASN1
End ASN1ConstructionType
Sequence ] [ASN1] -> ASN1S
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 -> Integer -> ParseASN1 Integer
forall (m :: * -> *) a. Monad m => a -> m a
return Integer
v
        ASN1
_        -> String -> ParseASN1 Integer
forall a. String -> ParseASN1 a
throwParseError (String
"missing serial" String -> ShowS
forall a. [a] -> [a] -> [a]
++ ASN1 -> String
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 (Integer
 -> SignatureALG
 -> DistinguishedName
 -> DateTime
 -> Maybe DateTime
 -> [RevokedCertificate]
 -> Extensions
 -> CRL)
-> ParseASN1 Integer
-> ParseASN1
     (SignatureALG
      -> DistinguishedName
      -> DateTime
      -> Maybe DateTime
      -> [RevokedCertificate]
      -> Extensions
      -> CRL)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ParseASN1 ASN1
getNext ParseASN1 ASN1 -> (ASN1 -> ParseASN1 Integer) -> ParseASN1 Integer
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ASN1 -> ParseASN1 Integer
forall a. Num a => ASN1 -> ParseASN1 a
getVersion)
        ParseASN1
  (SignatureALG
   -> DistinguishedName
   -> DateTime
   -> Maybe DateTime
   -> [RevokedCertificate]
   -> Extensions
   -> CRL)
-> ParseASN1 SignatureALG
-> ParseASN1
     (DistinguishedName
      -> DateTime
      -> Maybe DateTime
      -> [RevokedCertificate]
      -> Extensions
      -> CRL)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParseASN1 SignatureALG
forall a. ASN1Object a => ParseASN1 a
getObject
        ParseASN1
  (DistinguishedName
   -> DateTime
   -> Maybe DateTime
   -> [RevokedCertificate]
   -> Extensions
   -> CRL)
-> ParseASN1 DistinguishedName
-> ParseASN1
     (DateTime
      -> Maybe DateTime -> [RevokedCertificate] -> Extensions -> CRL)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParseASN1 DistinguishedName
forall a. ASN1Object a => ParseASN1 a
getObject
        ParseASN1
  (DateTime
   -> Maybe DateTime -> [RevokedCertificate] -> Extensions -> CRL)
-> ParseASN1 DateTime
-> ParseASN1
     (Maybe DateTime -> [RevokedCertificate] -> Extensions -> CRL)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (ParseASN1 ASN1
getNext ParseASN1 ASN1
-> (ASN1 -> ParseASN1 DateTime) -> ParseASN1 DateTime
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ASN1 -> ParseASN1 DateTime
getThisUpdate)
        ParseASN1
  (Maybe DateTime -> [RevokedCertificate] -> Extensions -> CRL)
-> ParseASN1 (Maybe DateTime)
-> ParseASN1 ([RevokedCertificate] -> Extensions -> CRL)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParseASN1 (Maybe DateTime)
getNextUpdate
        ParseASN1 ([RevokedCertificate] -> Extensions -> CRL)
-> ParseASN1 [RevokedCertificate] -> ParseASN1 (Extensions -> CRL)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParseASN1 [RevokedCertificate]
parseRevokedCertificates
        ParseASN1 (Extensions -> CRL)
-> ParseASN1 Extensions -> ParseASN1 CRL
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) = a -> ParseASN1 a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> ParseASN1 a) -> a -> ParseASN1 a
forall a b. (a -> b) -> a -> b
$ Integer -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
v
        getVersion ASN1
_          = String -> ParseASN1 a
forall a. String -> ParseASN1 a
throwParseError String
"unexpected type for version"

        getThisUpdate :: ASN1 -> ParseASN1 DateTime
getThisUpdate (ASN1Time ASN1TimeType
_ DateTime
t1 Maybe TimezoneOffset
_) = DateTime -> ParseASN1 DateTime
forall (m :: * -> *) a. Monad m => a -> m a
return DateTime
t1
        getThisUpdate ASN1
_                 = String -> ParseASN1 DateTime
forall a. String -> ParseASN1 a
throwParseError String
"bad this update format, expecting time"

        getNextUpdate :: ParseASN1 (Maybe DateTime)
getNextUpdate = (ASN1 -> Maybe DateTime) -> ParseASN1 (Maybe DateTime)
forall a. (ASN1 -> Maybe a) -> ParseASN1 (Maybe a)
getNextMaybe ASN1 -> Maybe DateTime
timeOrNothing

        timeOrNothing :: ASN1 -> Maybe DateTime
timeOrNothing (ASN1Time ASN1TimeType
_ DateTime
tnext Maybe TimezoneOffset
_) = DateTime -> Maybe DateTime
forall a. a -> Maybe a
Just DateTime
tnext
        timeOrNothing ASN1
_                    = Maybe DateTime
forall a. Maybe a
Nothing

parseRevokedCertificates :: ParseASN1 [RevokedCertificate]
parseRevokedCertificates :: ParseASN1 [RevokedCertificate]
parseRevokedCertificates =
    (Maybe [RevokedCertificate] -> [RevokedCertificate])
-> ParseASN1 (Maybe [RevokedCertificate])
-> ParseASN1 [RevokedCertificate]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([RevokedCertificate]
-> ([RevokedCertificate] -> [RevokedCertificate])
-> Maybe [RevokedCertificate]
-> [RevokedCertificate]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] [RevokedCertificate] -> [RevokedCertificate]
forall a. a -> a
id) (ParseASN1 (Maybe [RevokedCertificate])
 -> ParseASN1 [RevokedCertificate])
-> ParseASN1 (Maybe [RevokedCertificate])
-> ParseASN1 [RevokedCertificate]
forall a b. (a -> b) -> a -> b
$ ASN1ConstructionType
-> ParseASN1 [RevokedCertificate]
-> ParseASN1 (Maybe [RevokedCertificate])
forall a.
ASN1ConstructionType -> ParseASN1 a -> ParseASN1 (Maybe a)
onNextContainerMaybe ASN1ConstructionType
Sequence (ParseASN1 [RevokedCertificate]
 -> ParseASN1 (Maybe [RevokedCertificate]))
-> ParseASN1 [RevokedCertificate]
-> ParseASN1 (Maybe [RevokedCertificate])
forall a b. (a -> b) -> a -> b
$ ParseASN1 RevokedCertificate -> ParseASN1 [RevokedCertificate]
forall a. ParseASN1 a -> ParseASN1 [a]
getMany ParseASN1 RevokedCertificate
forall a. ASN1Object a => ParseASN1 a
getObject

parseCRLExtensions :: ParseASN1 Extensions
parseCRLExtensions :: ParseASN1 Extensions
parseCRLExtensions =
    (Maybe Extensions -> Extensions)
-> ParseASN1 (Maybe Extensions) -> ParseASN1 Extensions
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Maybe Extensions -> Extensions
adapt (ParseASN1 (Maybe Extensions) -> ParseASN1 Extensions)
-> ParseASN1 (Maybe Extensions) -> ParseASN1 Extensions
forall a b. (a -> b) -> a -> b
$ ASN1ConstructionType
-> ParseASN1 Extensions -> ParseASN1 (Maybe Extensions)
forall a.
ASN1ConstructionType -> ParseASN1 a -> ParseASN1 (Maybe a)
onNextContainerMaybe (ASN1Class -> Int -> ASN1ConstructionType
Container ASN1Class
Context Int
0) (ParseASN1 Extensions -> ParseASN1 (Maybe Extensions))
-> ParseASN1 Extensions -> ParseASN1 (Maybe Extensions)
forall a b. (a -> b) -> a -> b
$ ParseASN1 Extensions
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 Maybe [ExtensionRaw]
forall a. Maybe a
Nothing

encodeCRL :: CRL -> ASN1S
encodeCRL :: CRL -> ASN1S
encodeCRL CRL
crl [ASN1]
xs =
    [Integer -> ASN1
IntVal (Integer -> ASN1) -> Integer -> ASN1
forall a b. (a -> b) -> a -> b
$ CRL -> Integer
crlVersion CRL
crl] [ASN1] -> ASN1S
forall a. [a] -> [a] -> [a]
++
    SignatureALG -> ASN1S
forall a. ASN1Object a => a -> ASN1S
toASN1 (CRL -> SignatureALG
crlSignatureAlg CRL
crl) [] [ASN1] -> ASN1S
forall a. [a] -> [a] -> [a]
++
    DistinguishedName -> ASN1S
forall a. ASN1Object a => a -> ASN1S
toASN1 (CRL -> DistinguishedName
crlIssuer CRL
crl) [] [ASN1] -> ASN1S
forall a. [a] -> [a] -> [a]
++
    [ASN1TimeType -> DateTime -> Maybe TimezoneOffset -> ASN1
ASN1Time ASN1TimeType
TimeGeneralized (CRL -> DateTime
crlThisUpdate CRL
crl) (TimezoneOffset -> Maybe TimezoneOffset
forall a. a -> Maybe a
Just (Int -> TimezoneOffset
TimezoneOffset Int
0))] [ASN1] -> ASN1S
forall a. [a] -> [a] -> [a]
++
    ([ASN1] -> (DateTime -> [ASN1]) -> Maybe DateTime -> [ASN1]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\DateTime
t -> [ASN1TimeType -> DateTime -> Maybe TimezoneOffset -> ASN1
ASN1Time ASN1TimeType
TimeGeneralized DateTime
t (TimezoneOffset -> Maybe TimezoneOffset
forall a. a -> Maybe a
Just (Int -> TimezoneOffset
TimezoneOffset Int
0))]) (CRL -> Maybe DateTime
crlNextUpdate CRL
crl)) [ASN1] -> ASN1S
forall a. [a] -> [a] -> [a]
++
    [RevokedCertificate] -> [ASN1]
forall a. ASN1Object a => [a] -> [ASN1]
maybeRevoked (CRL -> [RevokedCertificate]
crlRevokedCertificates CRL
crl) [ASN1] -> ASN1S
forall a. [a] -> [a] -> [a]
++
    Extensions -> [ASN1]
maybeCrlExts (CRL -> Extensions
crlExtensions CRL
crl) [ASN1] -> ASN1S
forall a. [a] -> [a] -> [a]
++
    [ASN1]
xs
  where
    maybeRevoked :: [a] -> [ASN1]
maybeRevoked [] = []
    maybeRevoked [a]
xs' = ASN1ConstructionType -> ASN1S
asn1Container ASN1ConstructionType
Sequence ASN1S -> ASN1S
forall a b. (a -> b) -> a -> b
$ (a -> [ASN1]) -> [a] -> [ASN1]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\a
e -> a -> ASN1S
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) ASN1S -> ASN1S
forall a b. (a -> b) -> a -> b
$ Extensions -> ASN1S
forall a. ASN1Object a => a -> ASN1S
toASN1 Extensions
exts []