-- |
-- 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
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)

-- | 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
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 []