-- |
-- Module      : Data.X509.Cert
-- License     : BSD-style
-- Maintainer  : Vincent Hanquez <vincent@snarc.org>
-- Stability   : experimental
-- Portability : unknown
--
-- X.509 Certificate types and functions
--
{-# LANGUAGE FlexibleContexts #-}

module Data.X509.Cert (Certificate(..)) where

import Data.ASN1.Types
import Control.Applicative ((<$>), (<*>))
import Data.X509.Internal
import Data.X509.PublicKey
import Data.X509.AlgorithmIdentifier
import Data.X509.DistinguishedName
import Data.X509.ExtensionRaw
import Data.Hourglass

data CertKeyUsage =
          CertKeyUsageDigitalSignature
        | CertKeyUsageNonRepudiation
        | CertKeyUsageKeyEncipherment
        | CertKeyUsageDataEncipherment
        | CertKeyUsageKeyAgreement
        | CertKeyUsageKeyCertSign
        | CertKeyUsageCRLSign
        | CertKeyUsageEncipherOnly
        | CertKeyUsageDecipherOnly
        deriving (Int -> CertKeyUsage -> ShowS
[CertKeyUsage] -> ShowS
CertKeyUsage -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CertKeyUsage] -> ShowS
$cshowList :: [CertKeyUsage] -> ShowS
show :: CertKeyUsage -> String
$cshow :: CertKeyUsage -> String
showsPrec :: Int -> CertKeyUsage -> ShowS
$cshowsPrec :: Int -> CertKeyUsage -> ShowS
Show, CertKeyUsage -> CertKeyUsage -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CertKeyUsage -> CertKeyUsage -> Bool
$c/= :: CertKeyUsage -> CertKeyUsage -> Bool
== :: CertKeyUsage -> CertKeyUsage -> Bool
$c== :: CertKeyUsage -> CertKeyUsage -> Bool
Eq)

-- | X.509 Certificate type.
--
-- This type doesn't include the signature, it's describe in the RFC
-- as tbsCertificate.
data Certificate = Certificate
        { Certificate -> Int
certVersion      :: Int                    -- ^ Version
        , Certificate -> Integer
certSerial       :: Integer                -- ^ Serial number
        , Certificate -> SignatureALG
certSignatureAlg :: SignatureALG           -- ^ Signature algorithm
        , Certificate -> DistinguishedName
certIssuerDN     :: DistinguishedName      -- ^ Issuer DN
        , Certificate -> (DateTime, DateTime)
certValidity     :: (DateTime, DateTime)   -- ^ Validity period (UTC)
        , Certificate -> DistinguishedName
certSubjectDN    :: DistinguishedName      -- ^ Subject DN
        , Certificate -> PubKey
certPubKey       :: PubKey                 -- ^ Public key
        , Certificate -> Extensions
certExtensions   :: Extensions             -- ^ Extensions
        } deriving (Int -> Certificate -> ShowS
[Certificate] -> ShowS
Certificate -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Certificate] -> ShowS
$cshowList :: [Certificate] -> ShowS
show :: Certificate -> String
$cshow :: Certificate -> String
showsPrec :: Int -> Certificate -> ShowS
$cshowsPrec :: Int -> Certificate -> ShowS
Show,Certificate -> Certificate -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Certificate -> Certificate -> Bool
$c/= :: Certificate -> Certificate -> Bool
== :: Certificate -> Certificate -> Bool
$c== :: Certificate -> Certificate -> Bool
Eq)

instance ASN1Object Certificate where
    toASN1 :: Certificate -> ASN1S
toASN1   Certificate
certificate = \[ASN1]
xs -> Certificate -> [ASN1]
encodeCertificateHeader Certificate
certificate forall a. [a] -> [a] -> [a]
++ [ASN1]
xs
    fromASN1 :: [ASN1] -> Either String (Certificate, [ASN1])
fromASN1 [ASN1]
s           = forall a. ParseASN1 a -> [ASN1] -> Either String (a, [ASN1])
runParseASN1State ParseASN1 Certificate
parseCertificate [ASN1]
s

parseCertHeaderVersion :: ParseASN1 Int
parseCertHeaderVersion :: ParseASN1 Int
parseCertHeaderVersion =
    forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
0 forall a. a -> a
id forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a.
ASN1ConstructionType -> ParseASN1 a -> ParseASN1 (Maybe a)
onNextContainerMaybe (ASN1Class -> Int -> ASN1ConstructionType
Container ASN1Class
Context Int
0) (ParseASN1 ASN1
getNext forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall {a}. Num a => ASN1 -> ParseASN1 a
getVer)
  where getVer :: ASN1 -> ParseASN1 a
getVer (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
        getVer ASN1
_          = forall a. String -> ParseASN1 a
throwParseError String
"unexpected type for version"

parseCertHeaderSerial :: ParseASN1 Integer
parseCertHeaderSerial :: ParseASN1 Integer
parseCertHeaderSerial = 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)

parseCertHeaderValidity :: ParseASN1 (DateTime, DateTime)
parseCertHeaderValidity :: ParseASN1 (DateTime, DateTime)
parseCertHeaderValidity = ASN1ConstructionType -> ParseASN1 [ASN1]
getNextContainer ASN1ConstructionType
Sequence forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [ASN1] -> ParseASN1 (DateTime, DateTime)
toTimeBound
  where toTimeBound :: [ASN1] -> ParseASN1 (DateTime, DateTime)
toTimeBound [ ASN1Time ASN1TimeType
_ DateTime
t1 Maybe TimezoneOffset
_, ASN1Time ASN1TimeType
_ DateTime
t2 Maybe TimezoneOffset
_ ] = forall (m :: * -> *) a. Monad m => a -> m a
return (DateTime
t1,DateTime
t2)
        toTimeBound [ASN1]
_                                    = forall a. String -> ParseASN1 a
throwParseError String
"bad validity format"

{- | parse header structure of a x509 certificate. the structure is the following:
        Version
        Serial Number
        Algorithm ID
        Issuer
        Validity
                Not Before
                Not After
        Subject
        Subject Public Key Info
                Public Key Algorithm
                Subject Public Key
        Issuer Unique Identifier (Optional)  (>= 2)
        Subject Unique Identifier (Optional) (>= 2)
        Extensions (Optional)   (>= v3)
-}

parseExtensions :: ParseASN1 Extensions
parseExtensions :: ParseASN1 Extensions
parseExtensions = 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
3) 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

parseCertificate :: ParseASN1 Certificate
parseCertificate :: ParseASN1 Certificate
parseCertificate =
    Int
-> Integer
-> SignatureALG
-> DistinguishedName
-> (DateTime, DateTime)
-> DistinguishedName
-> PubKey
-> Extensions
-> Certificate
Certificate forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParseASN1 Int
parseCertHeaderVersion
                forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParseASN1 Integer
parseCertHeaderSerial
                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 (DateTime, DateTime)
parseCertHeaderValidity
                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 Extensions
parseExtensions

encodeCertificateHeader :: Certificate -> [ASN1]
encodeCertificateHeader :: Certificate -> [ASN1]
encodeCertificateHeader Certificate
cert =
    [ASN1]
eVer forall a. [a] -> [a] -> [a]
++ [ASN1]
eSerial forall a. [a] -> [a] -> [a]
++ [ASN1]
eAlgId forall a. [a] -> [a] -> [a]
++ [ASN1]
eIssuer forall a. [a] -> [a] -> [a]
++ [ASN1]
eValidity forall a. [a] -> [a] -> [a]
++ [ASN1]
eSubject forall a. [a] -> [a] -> [a]
++ [ASN1]
epkinfo forall a. [a] -> [a] -> [a]
++ [ASN1]
eexts
  where eVer :: [ASN1]
eVer      = ASN1ConstructionType -> ASN1S
asn1Container (ASN1Class -> Int -> ASN1ConstructionType
Container ASN1Class
Context Int
0) [Integer -> ASN1
IntVal (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ Certificate -> Int
certVersion Certificate
cert)]
        eSerial :: [ASN1]
eSerial   = [Integer -> ASN1
IntVal forall a b. (a -> b) -> a -> b
$ Certificate -> Integer
certSerial Certificate
cert]
        eAlgId :: [ASN1]
eAlgId    = forall a. ASN1Object a => a -> ASN1S
toASN1 (Certificate -> SignatureALG
certSignatureAlg Certificate
cert) []
        eIssuer :: [ASN1]
eIssuer   = forall a. ASN1Object a => a -> ASN1S
toASN1 (Certificate -> DistinguishedName
certIssuerDN Certificate
cert) []
        (DateTime
t1, DateTime
t2)  = Certificate -> (DateTime, DateTime)
certValidity Certificate
cert
        eValidity :: [ASN1]
eValidity = ASN1ConstructionType -> ASN1S
asn1Container ASN1ConstructionType
Sequence [ASN1TimeType -> DateTime -> Maybe TimezoneOffset -> ASN1
ASN1Time (forall {a}. (Ord a, Time a) => a -> ASN1TimeType
timeType DateTime
t1) DateTime
t1 (forall a. a -> Maybe a
Just (Int -> TimezoneOffset
TimezoneOffset Int
0))
                                           ,ASN1TimeType -> DateTime -> Maybe TimezoneOffset -> ASN1
ASN1Time (forall {a}. (Ord a, Time a) => a -> ASN1TimeType
timeType DateTime
t2) DateTime
t2 (forall a. a -> Maybe a
Just (Int -> TimezoneOffset
TimezoneOffset Int
0))]
        eSubject :: [ASN1]
eSubject  = forall a. ASN1Object a => a -> ASN1S
toASN1 (Certificate -> DistinguishedName
certSubjectDN Certificate
cert) []
        epkinfo :: [ASN1]
epkinfo   = forall a. ASN1Object a => a -> ASN1S
toASN1 (Certificate -> PubKey
certPubKey Certificate
cert) []
        eexts :: [ASN1]
eexts     = case Certificate -> Extensions
certExtensions Certificate
cert of
                      Extensions Maybe [ExtensionRaw]
Nothing -> []
                      Extensions
exts -> ASN1ConstructionType -> ASN1S
asn1Container (ASN1Class -> Int -> ASN1ConstructionType
Container ASN1Class
Context Int
3) forall a b. (a -> b) -> a -> b
$ forall a. ASN1Object a => a -> ASN1S
toASN1 Extensions
exts []
        timeType :: a -> ASN1TimeType
timeType a
t =
            if a
t forall a. Ord a => a -> a -> Bool
>= forall t1 t2. (Timeable t1, Time t2) => t1 -> t2
timeConvert (Int -> Month -> Int -> Date
Date Int
2050 Month
January Int
1)
            then ASN1TimeType
TimeGeneralized
            else ASN1TimeType
TimeUTC