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

-- TODO support extension
instance ASN1Object RevokedCertificate where
    fromASN1 :: [ASN1] -> Either String (RevokedCertificate, [ASN1])
fromASN1 (Start ASN1ConstructionType
Sequence : IntVal Integer
serial : ASN1Time ASN1TimeType
_ DateTime
t Maybe TimezoneOffset
_ : End ASN1ConstructionType
Sequence : [ASN1]
xs) =
        (RevokedCertificate, [ASN1])
-> Either String (RevokedCertificate, [ASN1])
forall a b. b -> Either a b
Right (Integer -> DateTime -> Extensions -> RevokedCertificate
RevokedCertificate Integer
serial DateTime
t (Maybe [ExtensionRaw] -> Extensions
Extensions Maybe [ExtensionRaw]
forall a. Maybe a
Nothing), [ASN1]
xs)
    fromASN1 [ASN1]
l = String -> Either String (RevokedCertificate, [ASN1])
forall a b. a -> Either a b
Left (String
"fromASN1: X509.RevokedCertificate: unknown format:" String -> ShowS
forall a. [a] -> [a] -> [a]
++ [ASN1] -> String
forall a. Show a => a -> String
show [ASN1]
l)
    toASN1 :: RevokedCertificate -> ASN1S
toASN1 (RevokedCertificate Integer
serial DateTime
time Extensions
_) = \[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]
: ASN1ConstructionType -> ASN1
End ASN1ConstructionType
Sequence ASN1 -> ASN1S
forall a. a -> [a] -> [a]
: [ASN1]
xs

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]
getRevokedCertificates
        ParseASN1 (Extensions -> CRL)
-> ParseASN1 Extensions -> ParseASN1 CRL
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParseASN1 Extensions
forall a. ASN1Object a => ParseASN1 a
getObject
  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

        getRevokedCertificates :: ParseASN1 [RevokedCertificate]
getRevokedCertificates = 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
$ ParseASN1 RevokedCertificate -> ParseASN1 [RevokedCertificate]
forall a. ParseASN1 a -> ParseASN1 [a]
getMany ParseASN1 RevokedCertificate
forall a. ASN1Object a => ParseASN1 a
getObject

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]
++
    [ASN1ConstructionType -> ASN1
Start ASN1ConstructionType
Sequence] [ASN1] -> ASN1S
forall a. [a] -> [a] -> [a]
++
    [ASN1]
revoked [ASN1] -> ASN1S
forall a. [a] -> [a] -> [a]
++
    [ASN1ConstructionType -> ASN1
End ASN1ConstructionType
Sequence] [ASN1] -> ASN1S
forall a. [a] -> [a] -> [a]
++
    Extensions -> ASN1S
forall a. ASN1Object a => a -> ASN1S
toASN1 (CRL -> Extensions
crlExtensions CRL
crl) [] [ASN1] -> ASN1S
forall a. [a] -> [a] -> [a]
++
    [ASN1]
xs
  where
    revoked :: [ASN1]
revoked = (RevokedCertificate -> [ASN1]) -> [RevokedCertificate] -> [ASN1]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\RevokedCertificate
e -> RevokedCertificate -> ASN1S
forall a. ASN1Object a => a -> ASN1S
toASN1 RevokedCertificate
e []) (CRL -> [RevokedCertificate]
crlRevokedCertificates CRL
crl)