diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,9 @@ +# Revision history for data-rfc5280 + +`data-rfc5280` uses [PVP Versioning][1]. + +## 0.1.0.0 -- 2026-09-05 + +* Initial version. + +[1]: https://pvp.haskell.org diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2026, Tim Emiola + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Tim Emiola nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,4 @@ +import Distribution.Simple + + +main = defaultMain diff --git a/data-rfc5280.cabal b/data-rfc5280.cabal new file mode 100644 --- /dev/null +++ b/data-rfc5280.cabal @@ -0,0 +1,100 @@ +cabal-version: 3.0 +name: data-rfc5280 +version: 0.1.0.0 +synopsis: Represent the standard X.509v3 certificate extensions +description: + @data-rfc5280@ provides Haskell types for the standard X.509v3 + certificate extensions defined in [RFC 5280](https://datatracker.ietf.org/doc/html/rfc5280#section-4.2) + + Extensions covered include @BasicConstraints@, @KeyUsage@, + @ExtendedKeyUsage@, @SubjectAltName@, @IssuerAltName@, + @AuthorityKeyIdentifier@, @SubjectKeyIdentifier@, @CertificatePolicies@, + @PolicyMappings@, @NameConstraints@, @CRLDistributionPoints@, + @AuthorityInfoAccess@, and @InhibitAnyPolicy@. + + The package also provides typeclasses that support serialisation to to OpenSSL configuration format + + See the [README](https://github.com/adetokunbo/data-rfc5280/blob/main/README.md) for more details + +license: BSD-3-Clause +license-file: LICENSE +author: Tim Emiola +maintainer: adetokunbo@emio.la +category: Cryptography +homepage: https://github.com/adetokunbo/data-rfc5280#readme +bug-reports: + https://github.com/adetokunbo/data-rfc5280/issues +tested-with: GHC ==8.10.7 || ==9.0.2 || ==9.2.8 || ==9.4.8 || ==9.6.6 || ==9.8.4 || ==9.10.1 || ==9.12.1 +build-type: Simple +extra-source-files: + ChangeLog.md + +source-repository head + type: git + location: https://github.com/adetokunbo/data-rfc5280.git + +library + exposed-modules: + Data.Rfc5280 + Data.Rfc5280.Assert + Data.Rfc5280.AuthorityInfoAccess + Data.Rfc5280.AuthorityKeyIdentifier + Data.Rfc5280.BasicConstraints + Data.Rfc5280.CertificatePolicies + Data.Rfc5280.CRLDistributionPoints + Data.Rfc5280.ExtKeyUsage + Data.Rfc5280.GeneralName + Data.Rfc5280.HasOID + Data.Rfc5280.InhibitAnyPolicy + Data.Rfc5280.IssuerAltName + Data.Rfc5280.PolicyMappings + Data.Rfc5280.KeyUsage + Data.Rfc5280.NameConstraints + Data.Rfc5280.SubjectAltName + Data.Rfc5280.SubjectKeyIdentifier + other-modules: + Data.Rfc5280.Internal + hs-source-dirs: src + build-depends: + , base >=4.10 && <5 + , bytestring >=0.10.8.2 && <0.11 || >=0.11.3.1 && <0.13 + , email-validate >=2.3 && <2.4 + , ip >=1.3 && <1.9 + , modern-uri >=0.3 && <0.4 + , nonempty-containers >=0.3 && <0.4 + , text >=1.2 && <2.2 + + default-language: Haskell2010 + ghc-options: -Wall -Wincomplete-uni-patterns -Wpartial-fields -fwarn-tabs + +test-suite test + type: exitcode-stdio-1.0 + main-is: Spec.hs + hs-source-dirs: test + other-modules: + Rfc5280Spec + Rfc5280.AssertSpec + Rfc5280.AuthorityInfoAccessSpec + Rfc5280.CRLDistributionPointsSpec + Rfc5280.Fixtures + Rfc5280.GeneralNameSpec + Rfc5280.Generators + Rfc5280.HasOIDSpec + Rfc5280.InhibitAnyPolicySpec + Rfc5280.IssuerAltNameSpec + Rfc5280.NameConstraintsSpec + Rfc5280.PolicyMappingsSpec + Rfc5280.SubjectAltNameSpec + default-language: Haskell2010 + ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall -fwarn-tabs + build-depends: + , base + , bytestring + , email-validate >=2.3 && <2.4 + , hspec >=2.7 && < 2.12 + , ip >=1.3 && <1.9 + , modern-uri >=0.3 && <0.4 + , QuickCheck >=2.13 && < 2.16 + , text >=1.2 && <2.2 + , data-rfc5280 + diff --git a/src/Data/Rfc5280.hs b/src/Data/Rfc5280.hs new file mode 100644 --- /dev/null +++ b/src/Data/Rfc5280.hs @@ -0,0 +1,167 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PatternSynonyms #-} + +{- | +Module : Data.Rfc5280 +Copyright : (c) 2026 Tim Emiola +Maintainer : Tim Emiola +SPDX-License-Identifier: BSD3 + +Represent the standard X.509v3 certificate extensions from RFC 5280. +Each section below provides constructors for one or more extension types; +'renderConfig' serialises any of them to OpenSSL configuration format. +-} +module Data.Rfc5280 + ( -- * Extension types + BasicConstraints (..) + , BasicConstraintsError (..) + , mkBasicConstraints + , KeyUsageBit (..) + , KeyUsage + , ExtKeyUsagePurpose (..) + , ExtKeyUsage + , SubjectKeyIdentifier (..) + , AuthorityKeyIdentifier (..) + , mkAuthorityKeyIdentifier + , CertificatePolicies (..) + , mkCertificatePolicies + + -- * OID construction + , OID + , OIDError (..) + , mkOID + + -- * General names + , GeneralName (DNS, IPAddr, EmailAddr, URIName, Other) + , pattern RegisteredID + , DnsName + , dnsNameText + , OtherName + , pattern OtherName + , onTypeId + , onEncoding + , onValue + , Asn1StringType (..) + , DNSNameError (..) + , OtherNameError (..) + , mkDnsName + , mkDnsConstraint + , mkRegisteredID + , mkOtherName + , mkOther + + -- * Alt-name extensions + , SubjectAltName (..) + , mkSubjectAltName + , IssuerAltName (..) + , mkIssuerAltName + + -- * CRL extensions + , CRLDistributionPoints (..) + , mkCRLDistributionPoints + , DistributionPoint (..) + , mkDistributionPoint + + -- * Name constraints + , NameConstraints (..) + , mkNameConstraints + , NameConstraint (..) + + -- * Policy extensions + , InhibitAnyPolicy (..) + , InhibitAnyPolicyError (..) + , mkInhibitAnyPolicy + , PolicyMappings (..) + , mkPolicyMappings + , PolicyMapping (..) + , mkPolicyMapping + + -- * Criticality wrapper and OID lookup + , Extension (..) + , HasOID (..) + + -- * Render to OpenSSL config format + , RenderConfig (..) + , renderConfig + + -- * Lifting results into MonadIO + , assertRight + , assertJust + + -- * Re-exported for convenience + + -- | 'NonEmpty' from "Data.List.NonEmpty"; 'fromList' from "Data.Set.NonEmpty". + , fromList + , NonEmpty (..) + ) +where + +import Data.ByteString (ByteString) +import Data.ByteString.Builder (toLazyByteString) +import qualified Data.ByteString.Lazy as LBS +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Rfc5280.Assert (assertJust, assertRight) +import Data.Rfc5280.AuthorityKeyIdentifier + ( AuthorityKeyIdentifier (..) + , mkAuthorityKeyIdentifier + ) +import Data.Rfc5280.BasicConstraints + ( BasicConstraints (..) + , BasicConstraintsError (..) + , mkBasicConstraints + ) +import Data.Rfc5280.CRLDistributionPoints + ( CRLDistributionPoints (..) + , DistributionPoint (..) + , mkCRLDistributionPoints + , mkDistributionPoint + ) +import Data.Rfc5280.CertificatePolicies + ( CertificatePolicies (..) + , mkCertificatePolicies + ) +import Data.Rfc5280.ExtKeyUsage (ExtKeyUsage, ExtKeyUsagePurpose (..)) +import Data.Rfc5280.GeneralName + ( Asn1StringType (..) + , DNSNameError (..) + , DnsName + , GeneralName (DNS, EmailAddr, IPAddr, Other, URIName) + , OtherName + , OtherNameError (..) + , dnsNameText + , mkDnsConstraint + , mkDnsName + , mkOther + , mkOtherName + , mkRegisteredID + , onEncoding + , onTypeId + , onValue + , pattern OtherName + , pattern RegisteredID + ) +import Data.Rfc5280.HasOID (Extension (..), HasOID (..)) +import Data.Rfc5280.InhibitAnyPolicy (InhibitAnyPolicy (..), InhibitAnyPolicyError (..), mkInhibitAnyPolicy) +import Data.Rfc5280.Internal (OID, OIDError (..), RenderConfig (..), mkOID) +import Data.Rfc5280.IssuerAltName (IssuerAltName (..), mkIssuerAltName) +import Data.Rfc5280.KeyUsage (KeyUsage, KeyUsageBit (..)) +import Data.Rfc5280.NameConstraints + ( NameConstraint (..) + , NameConstraints (..) + , mkNameConstraints + ) +import Data.Rfc5280.PolicyMappings + ( PolicyMapping (..) + , PolicyMappings (..) + , mkPolicyMapping + , mkPolicyMappings + ) +import Data.Rfc5280.SubjectAltName (SubjectAltName (..), mkSubjectAltName) +import Data.Rfc5280.SubjectKeyIdentifier (SubjectKeyIdentifier (..)) +import Data.Set.NonEmpty (fromList) + + +-- | Render an extension value as a strict 'ByteString' in OpenSSL configuration format. +renderConfig :: (RenderConfig a) => a -> ByteString +renderConfig = LBS.toStrict . toLazyByteString . renderBuilder diff --git a/src/Data/Rfc5280/Assert.hs b/src/Data/Rfc5280/Assert.hs new file mode 100644 --- /dev/null +++ b/src/Data/Rfc5280/Assert.hs @@ -0,0 +1,34 @@ +{- | +Module : Data.Rfc5280.Assert +Copyright : (c) 2026 Tim Emiola +Maintainer : Tim Emiola +SPDX-License-Identifier: BSD3 + +Helpers for lifting RFC 5280 smart-constructor results into 'MonadIO'. + +'assertRight' and 'assertJust' convert the two common failure containers +('Either' and 'Maybe') into any 'MonadIO' context, throwing a 'userError' +when the value is absent. +-} +module Data.Rfc5280.Assert + ( assertRight + , assertJust + ) +where + +import Control.Exception (throwIO) +import Control.Monad.IO.Class (MonadIO, liftIO) + + +{- | Lift an @Either e a@ into any 'MonadIO', throwing a 'userError' with +'show' of the error on 'Left'. +-} +assertRight :: (Show e, MonadIO m) => Either e a -> m a +assertRight = either (liftIO . throwIO . userError . show) pure + + +{- | Lift a @Maybe a@ into any 'MonadIO', throwing a 'userError' with the +given message on 'Nothing'. +-} +assertJust :: (MonadIO m) => String -> Maybe a -> m a +assertJust msg = maybe (liftIO . throwIO . userError $ msg) pure diff --git a/src/Data/Rfc5280/AuthorityInfoAccess.hs b/src/Data/Rfc5280/AuthorityInfoAccess.hs new file mode 100644 --- /dev/null +++ b/src/Data/Rfc5280/AuthorityInfoAccess.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE OverloadedStrings #-} + +{- | +Module : Data.Rfc5280.AuthorityInfoAccess +Copyright : (c) 2026 Tim Emiola +Maintainer : Tim Emiola +SPDX-License-Identifier: BSD3 + +Provides 'AuthorityInfoAccess', representing the X.509 Authority Information +Access extension (RFC 5280 §4.2.2.1). +-} +module Data.Rfc5280.AuthorityInfoAccess + ( AuthorityInfoAccess (..) + , mkAuthorityInfoAccess + , AccessDescription (..) + ) +where + +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Rfc5280.GeneralName (GeneralName) +import Data.Rfc5280.HasOID (HasOID (..)) +import Data.Rfc5280.Internal (RenderConfig (..), intersperseCommas) + + +{- | A single access point within an 'AuthorityInfoAccess' extension. + +The 'GeneralName' location is almost always a 'URIName' in practice, but +any variant is permitted by RFC 5280. +-} +data AccessDescription + = -- | An OCSP responder location. Rendered as @OCSP;\@. + OCSP !GeneralName + | -- | A CA issuers location. Rendered as @caIssuers;\@. + CAIssuers !GeneralName + deriving (Eq, Show) + + +{- | Represents the AuthorityInfoAccess extension (RFC 5280 §4.2.2.1). + +Contains one or more 'AccessDescription' values. Use 'mkAuthorityInfoAccess' +to construct a value. +-} +newtype AuthorityInfoAccess = AuthorityInfoAccess (NonEmpty AccessDescription) + deriving (Eq, Show) + + +-- | Construct an 'AuthorityInfoAccess' from one or more 'AccessDescription' values. +mkAuthorityInfoAccess :: AccessDescription -> [AccessDescription] -> AuthorityInfoAccess +mkAuthorityInfoAccess x xs = AuthorityInfoAccess (x :| xs) + + +instance HasOID AuthorityInfoAccess where + extensionOID _ = 1 :| [3, 6, 1, 5, 5, 7, 1, 1] + + +instance RenderConfig AccessDescription where + renderBuilder (OCSP loc) = "OCSP;" <> renderBuilder loc + renderBuilder (CAIssuers loc) = "caIssuers;" <> renderBuilder loc + + +instance RenderConfig AuthorityInfoAccess where + renderBuilder (AuthorityInfoAccess xs) = intersperseCommas (fmap renderBuilder xs) diff --git a/src/Data/Rfc5280/AuthorityKeyIdentifier.hs b/src/Data/Rfc5280/AuthorityKeyIdentifier.hs new file mode 100644 --- /dev/null +++ b/src/Data/Rfc5280/AuthorityKeyIdentifier.hs @@ -0,0 +1,75 @@ +{-# LANGUAGE OverloadedStrings #-} + +{- | +Module : Data.Rfc5280.AuthorityKeyIdentifier +Copyright : (c) 2026 Tim Emiola +Maintainer : Tim Emiola +SPDX-License-Identifier: BSD3 + +Provides the 'AuthorityKeyIdentifier' extension type and its smart constructor. +-} +module Data.Rfc5280.AuthorityKeyIdentifier + ( AuthorityKeyIdentifier (..) + , mkAuthorityKeyIdentifier + ) +where + +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Rfc5280.HasOID (HasOID (..)) +import Data.Rfc5280.Internal (RenderConfig (..), intersperseCommas) + + +{- | Represents the AuthorityKeyIdentifier extension + +See . +-} +data AuthorityKeyIdentifier = AuthorityKeyIdentifier + { akiKeyId :: !Bool + -- ^ include key ID + , akiKeyIdAlways :: !Bool + {- ^ always include the key identifier, even if the issuer certificate + has no SubjectKeyIdentifier extension + -} + , akiIssuer :: !Bool + -- ^ include issuer name + serial + , akiIssuerAlways :: !Bool + {- ^ always include the issuer name and serial, even if the issuer certificate + has no SubjectKeyIdentifier extension + -} + } + deriving (Eq, Show) + + +{- | Construct an 'AuthorityKeyIdentifier', normalising the @always@ flags: +if @keyIdAlways@ is 'True', @keyId@ is set to 'True'; if @issuerAlways@ is +'True', @issuer@ is set to 'True'. +-} +mkAuthorityKeyIdentifier :: Bool -> Bool -> Bool -> Bool -> AuthorityKeyIdentifier +mkAuthorityKeyIdentifier keyId keyIdAlways issuer issuerAlways = + AuthorityKeyIdentifier + { akiKeyId = keyId || keyIdAlways + , akiKeyIdAlways = keyIdAlways + , akiIssuer = issuer || issuerAlways + , akiIssuerAlways = issuerAlways + } + + +instance HasOID AuthorityKeyIdentifier where + extensionOID _ = 2 :| [5, 29, 35] + + +instance RenderConfig AuthorityKeyIdentifier where + renderBuilder aki = + let keyId + | akiKeyIdAlways aki = Just "keyid:always" + | akiKeyId aki = Just "keyid" + | otherwise = Nothing + issuer + | akiIssuerAlways aki = Just "issuer:always" + | akiIssuer aki = Just "issuer" + | otherwise = Nothing + in case (keyId, issuer) of + (Nothing, Nothing) -> mempty + (Nothing, Just x) -> x + (Just x, Nothing) -> x + (Just x, Just y) -> intersperseCommas (x :| [y]) diff --git a/src/Data/Rfc5280/BasicConstraints.hs b/src/Data/Rfc5280/BasicConstraints.hs new file mode 100644 --- /dev/null +++ b/src/Data/Rfc5280/BasicConstraints.hs @@ -0,0 +1,69 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} + +{- | +Module : Data.Rfc5280.BasicConstraints +Copyright : (c) 2026 Tim Emiola +Maintainer : Tim Emiola +SPDX-License-Identifier: BSD3 + + +Provides the 'BasicConstraints' extension type and its smart constructor. +-} +module Data.Rfc5280.BasicConstraints + ( BasicConstraints (..) + , BasicConstraintsError (..) + , mkBasicConstraints + ) +where + +import Data.ByteString.Builder (intDec) +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Rfc5280.HasOID (HasOID (..)) +import Data.Rfc5280.Internal (RenderConfig (..)) + + +{- | Represents the basic constraints extension + +See . +-} +data BasicConstraints + = BasicConstraints + { bcIsCA :: !Bool + -- ^ is the subject of the certificate a certificate authority + , bcPathLength :: !(Maybe Int) + {- ^ the maximum number of non-self-issued intermediate certificates + that may follow this certificate in the path; only meaningful when + 'bcIsCA' is 'True' + -} + } + deriving (Eq, Show) + + +-- | Failure modes for 'mkBasicConstraints'. +data BasicConstraintsError + = -- | @pathLenConstraint@ is present but @cA@ is @FALSE@. + PathLenWithoutCA + deriving (Eq, Show) + + +{- | Construct a 'BasicConstraints', validating that @pathLenConstraint@ is +absent when @cA@ is @FALSE@ (RFC 5280 §4.2.1.9). +-} +mkBasicConstraints :: Bool -> Maybe Int -> Either BasicConstraintsError BasicConstraints +mkBasicConstraints False (Just _) = Left PathLenWithoutCA +mkBasicConstraints isCA pathLen = Right $ BasicConstraints{bcIsCA = isCA, bcPathLength = pathLen} + + +instance HasOID BasicConstraints where + extensionOID _ = 2 :| [5, 29, 19] + + +instance RenderConfig BasicConstraints where + renderBuilder bc = + let BasicConstraints{bcIsCA, bcPathLength} = bc + bcPrefix = "CA:" + bcSuffix = if bcIsCA then "TRUE" else "FALSE" + withPathLen x = ",pathLen" <> intDec x + pathLen = maybe "" withPathLen bcPathLength + in (bcPrefix <> bcSuffix <> pathLen) diff --git a/src/Data/Rfc5280/CRLDistributionPoints.hs b/src/Data/Rfc5280/CRLDistributionPoints.hs new file mode 100644 --- /dev/null +++ b/src/Data/Rfc5280/CRLDistributionPoints.hs @@ -0,0 +1,67 @@ +{- | +Module : Data.Rfc5280.CRLDistributionPoints +Copyright : (c) 2026 Tim Emiola +Maintainer : Tim Emiola +SPDX-License-Identifier: BSD3 + +Provides 'CRLDistributionPoints', representing the X.509 CRL Distribution +Points extension (RFC 5280 §4.2.1.13). + +Only simple distribution points are modelled: each point carries a single +full-name 'GeneralName' location. The @reasons@, @cRLIssuer@, and +@nameRelativeToCRLIssuer@ fields from the RFC are not yet supported; those +require section-based OpenSSL config syntax which this library does not produce. +-} +module Data.Rfc5280.CRLDistributionPoints + ( CRLDistributionPoints (..) + , mkCRLDistributionPoints + , DistributionPoint (..) + , mkDistributionPoint + ) +where + +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Rfc5280.GeneralName (GeneralName) +import Data.Rfc5280.HasOID (HasOID (..)) +import Data.Rfc5280.Internal (RenderConfig (..), intersperseCommas) + + +{- | A single CRL distribution point, identified by its full-name location. + +In the OpenSSL config format, each 'DistributionPoint' renders as the +'GeneralName' of its location. In practice the location is almost always +a 'URIName'. +-} +newtype DistributionPoint = DistributionPoint GeneralName + deriving (Eq, Show) + + +{- | Represents the CRLDistributionPoints extension (RFC 5280 §4.2.1.13). + +Contains one or more 'DistributionPoint' values. Use 'mkCRLDistributionPoints' +to construct a value. +-} +newtype CRLDistributionPoints = CRLDistributionPoints (NonEmpty DistributionPoint) + deriving (Eq, Show) + + +-- | Construct a 'DistributionPoint' from a 'GeneralName' full-name location. +mkDistributionPoint :: GeneralName -> DistributionPoint +mkDistributionPoint = DistributionPoint + + +-- | Construct a 'CRLDistributionPoints' from one or more 'DistributionPoint' values. +mkCRLDistributionPoints :: DistributionPoint -> [DistributionPoint] -> CRLDistributionPoints +mkCRLDistributionPoints x xs = CRLDistributionPoints (x :| xs) + + +instance HasOID CRLDistributionPoints where + extensionOID _ = 2 :| [5, 29, 31] + + +instance RenderConfig DistributionPoint where + renderBuilder (DistributionPoint name) = renderBuilder name + + +instance RenderConfig CRLDistributionPoints where + renderBuilder (CRLDistributionPoints pts) = intersperseCommas (fmap renderBuilder pts) diff --git a/src/Data/Rfc5280/CertificatePolicies.hs b/src/Data/Rfc5280/CertificatePolicies.hs new file mode 100644 --- /dev/null +++ b/src/Data/Rfc5280/CertificatePolicies.hs @@ -0,0 +1,39 @@ +{- | +Module : Data.Rfc5280.CertificatePolicies +Copyright : (c) 2026 Tim Emiola +Maintainer : Tim Emiola +SPDX-License-Identifier: BSD3 + +Provides the 'CertificatePolicies' extension type and its smart constructor. +-} +module Data.Rfc5280.CertificatePolicies + ( CertificatePolicies (..) + , mkCertificatePolicies + ) +where + +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Rfc5280.HasOID (HasOID (..)) +import Data.Rfc5280.Internal (OID, RenderConfig (..), intersperseCommas, oidBuilder) + + +{- | Represents @CertificatePolicies@ (RFC 5280 §4.2.1.4). + +Only the policy OIDs are modelled. @PolicyQualifierInfo@ entries (CPS URIs, +user notices) are not yet supported. +-} +newtype CertificatePolicies = CertificatePolicies (NonEmpty OID) + deriving (Eq, Show) + + +-- | Construct @CertificatePolicies@ from a non-empty sequence of OIDs. +mkCertificatePolicies :: OID -> [OID] -> CertificatePolicies +mkCertificatePolicies x xs = CertificatePolicies $ x :| xs + + +instance HasOID CertificatePolicies where + extensionOID _ = 2 :| [5, 29, 32] + + +instance RenderConfig CertificatePolicies where + renderBuilder (CertificatePolicies xs) = intersperseCommas $ fmap oidBuilder xs diff --git a/src/Data/Rfc5280/ExtKeyUsage.hs b/src/Data/Rfc5280/ExtKeyUsage.hs new file mode 100644 --- /dev/null +++ b/src/Data/Rfc5280/ExtKeyUsage.hs @@ -0,0 +1,72 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} + +{- | +Module : Data.Rfc5280.ExtKeyUsage +Copyright : (c) 2026 Tim Emiola +Maintainer : Tim Emiola +SPDX-License-Identifier: BSD3 + +Provides the 'ExtKeyUsage' extension type. +-} +module Data.Rfc5280.ExtKeyUsage + ( ExtKeyUsagePurpose (..) + , ExtKeyUsage + ) +where + +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Rfc5280.HasOID (HasOID (..)) +import Data.Rfc5280.Internal (RenderConfig (..), intersperseCommas) +import qualified Data.Set.NonEmpty as NES + + +{- | Represents the bits that can set for @ExtKeyUsage@ + +See . +-} +data ExtKeyUsagePurpose + = -- | TLS WWW server authentication. Renders as @\"serverAuth\"@. + ServerAuth + | -- | TLS WWW client authentication. Renders as @\"clientAuth\"@. + ClientAuth + | -- | Signing of downloadable executable code. Renders as @\"codeSigning\"@. + CodeSigning + | -- | Email protection (S\/MIME). Renders as @\"emailProtection\"@. + EmailProtection + | {- | Binding an object hash to a trusted time source. Renders as + @\"timeStamping\"@. + -} + TimeStamping + | -- | Signing OCSP responses. Renders as @\"OCSPSigning\"@ (capital OCSP). + OCSPSigning + | {- | Permits any extended key usage purpose. Renders as + @\"anyExtendedKeyUsage\"@ (lowercase @any@). + -} + AnyExtendedKeyUsage + deriving (Eq, Show, Ord, Enum, Bounded) + + +instance RenderConfig ExtKeyUsagePurpose where + renderBuilder ServerAuth = "serverAuth" + renderBuilder ClientAuth = "clientAuth" + renderBuilder CodeSigning = "codeSigning" + renderBuilder EmailProtection = "emailProtection" + renderBuilder TimeStamping = "timeStamping" + renderBuilder OCSPSigning = "OCSPSigning" + renderBuilder AnyExtendedKeyUsage = "anyExtendedKeyUsage" + + +{- | Represents the @ExtKeyUsage@ extension + +See . +-} +type ExtKeyUsage = NES.NESet ExtKeyUsagePurpose + + +instance HasOID ExtKeyUsage where + extensionOID _ = 2 :| [5, 29, 37] + + +instance RenderConfig ExtKeyUsage where + renderBuilder = intersperseCommas . fmap renderBuilder . NES.toList diff --git a/src/Data/Rfc5280/GeneralName.hs b/src/Data/Rfc5280/GeneralName.hs new file mode 100644 --- /dev/null +++ b/src/Data/Rfc5280/GeneralName.hs @@ -0,0 +1,313 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} + +{- | +Module : Data.Rfc5280.GeneralName +Copyright : (c) 2026 Tim Emiola +Maintainer : Tim Emiola +SPDX-License-Identifier: BSD3 + +Provides 'GeneralName', the common name type used across several X.509 +extensions, including SubjectAltName and AuthorityInfoAccess. + +'DirectoryName', x400Address, and ediPartyName are not yet modelled. +-} +module Data.Rfc5280.GeneralName + ( GeneralName (DNS, IPAddr, EmailAddr, URIName, Other) + , pattern RegisteredID + , DnsName + , dnsNameText + , OtherName + , pattern OtherName + , onTypeId + , onEncoding + , onValue + , Asn1StringType (..) + , DNSNameError (..) + , OtherNameError (..) + , mkDnsName + , mkDnsConstraint + , mkRegisteredID + , mkOtherName + , mkOther + ) +where + +import Data.Bifunctor (first) +import Data.ByteString.Builder (byteString) +import Data.Char (isAlphaNum, isAscii) +import Data.Rfc5280.Internal (OID, OIDError, RenderConfig (..), mkOID, oidBuilder) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import Net.IP (IP) +import qualified Net.IP as IP +import Text.Email.Validate (EmailAddress) +import qualified Text.Email.Validate as Email +import Text.URI (URI) +import qualified Text.URI as URI + + +{- | A validated DNS hostname. + +The constructor is not exported; use 'mkDnsName' for standard hostnames or +'mkDnsConstraint' for name-constraint subtree names (which may have a leading +dot such as @\".example.com\"@). +-} +newtype DnsName = DnsName Text + deriving (Eq, Show) + + +-- | Extract the underlying 'Text' from a 'DnsName'. +dnsNameText :: DnsName -> Text +dnsNameText (DnsName t) = t + + +{- | A general name as defined in RFC 5280 §4.1.2.6. + +Used in extensions such as SubjectAltName and AuthorityInfoAccess. +-} +data GeneralName + = -- | A DNS hostname. Rendered as @DNS:\@. Construct via 'mkDnsName'. + DNS !DnsName + | -- | An IPv4 or IPv6 address. Rendered as @IP:\@. + IPAddr !IP + | -- | An email address. Rendered as @email:\@. + EmailAddr !EmailAddress + | -- | A URI. Rendered as @URI:\@. + URIName !URI + | -- Internal constructor; exposed for matching via 'pattern RegisteredID'. + RegisteredID_ !OID + | {- | An arbitrary other name. Rendered as + @otherName:\;\:\@, where @\@ is the + OpenSSL tag string for the 'Asn1StringType'. + -} + Other !OtherName + deriving (Eq, Show) + + +{- | Match a 'GeneralName' carrying an ASN.1 registered object identifier. + +This is a unidirectional pattern: it can be used in pattern matches but not +to construct a 'GeneralName'. Use 'mkRegisteredID' to construct one, which +validates the OID arcs via 'mkOID'. +-} +pattern RegisteredID :: OID -> GeneralName +pattern RegisteredID o <- RegisteredID_ o + + +{-# COMPLETE DNS, IPAddr, EmailAddr, URIName, RegisteredID, Other #-} + + +{- | The fields of an @otherName@ general name (RFC 5280 §4.1.2.6). + +Carries the type OID, the ASN.1 string encoding, and the string value. +The 'MkOtherName' constructor is not exported; use 'mkOtherName' to construct +a value and 'pattern OtherName' to match one. +-} +data OtherName = MkOtherName + { onTypeId :: !OID + -- ^ OID identifying the name type. + , onEncoding :: !Asn1StringType + -- ^ ASN.1 string encoding for the value. + , onValue :: !Text + -- ^ The string value. + } + deriving (Eq, Show) + + +{- | Match an 'OtherName' value. + +This is a unidirectional pattern: it can be used in pattern matches but not +to construct an 'OtherName'. Use 'mkOtherName' to construct one, which +validates the OID arcs and checks the value against the declared encoding. +-} +pattern OtherName :: OID -> Asn1StringType -> Text -> OtherName +pattern OtherName oid enc val <- + MkOtherName{onTypeId = oid, onEncoding = enc, onValue = val} + + +{-# COMPLETE OtherName #-} + + +{- | The ASN.1 string encoding for an 'OtherName' value. + +Covers the four types commonly used in practice for X.509 extension values. +The ASN.1 standard defines additional string types — including +'VisibleString', 'UniversalString', 'TeletexString', 'NumericString', and +'GeneralString' — but these are not modelled here because they are either +legacy types or primarily relevant to distinguished name components rather +than extension values: + +* 'TeletexString' and 'UniversalString' appeared in early X.509 DN fields + but are discouraged by RFC 5280 and superseded by 'UTF8String'. +* 'NumericString' is for digit-only fields such as the @serialNumber@ DN + attribute; it has no common use in extension values. +* 'VisibleString' and 'GeneralString' appear only in edge cases and legacy + structures. + +For the vast majority of 'OtherName' use cases — including Microsoft UPN +(which uses 'UTF8String') and email addresses (which use 'IA5String') — the +four modelled constructors are sufficient. +-} +data Asn1StringType + = -- | UTF-8 encoding. Rendered as @UTF8@. + UTF8String + | -- | ASCII (IA5) encoding. Rendered as @IA5@. + IA5String + | -- | PrintableString encoding. Rendered as @PRINTABLE@. + PrintableString + | -- | BMP (UCS-2) encoding. Rendered as @BMP@. + BMPString + deriving (Eq, Show) + + +instance RenderConfig Asn1StringType where + renderBuilder UTF8String = "UTF8" + renderBuilder IA5String = "IA5" + renderBuilder PrintableString = "PRINTABLE" + renderBuilder BMPString = "BMP" + + +instance RenderConfig GeneralName where + renderBuilder (DNS (DnsName t)) = "DNS:" <> byteString (TE.encodeUtf8 t) + renderBuilder (IPAddr ip) = "IP:" <> byteString (TE.encodeUtf8 (IP.encode ip)) + renderBuilder (EmailAddr addr) = "email:" <> byteString (Email.toByteString addr) + renderBuilder (URIName uri) = "URI:" <> byteString (TE.encodeUtf8 (URI.render uri)) + renderBuilder (RegisteredID_ o) = "RID:" <> oidBuilder o + renderBuilder (Other on) = + "otherName:" + <> oidBuilder (onTypeId on) + <> ";" + <> renderBuilder (onEncoding on) + <> ":" + <> byteString (TE.encodeUtf8 (onValue on)) + + +-- | Failure modes for 'mkDnsName' and 'mkDnsConstraint'. +data DNSNameError + = -- | The name or a label within it is empty. + NameEmpty + | -- | The name exceeds 253 characters. + NameTooLong + | -- | A label exceeds 63 characters. + LabelTooLong + | -- | A label starts with a hyphen. + LabelLeadingHyphen + | -- | A label ends with a hyphen. + LabelTrailingHyphen + | -- | A label contains a character outside @[A-Za-z0-9-]@. + LabelInvalidChar + deriving (Eq, Show) + + +{- | Construct a 'DnsName', validating against RFC 1123 hostname rules. + +Returns @Left@ with a 'DNSNameError' if the name is invalid. Accepts a +wildcard @*@ as the first label (e.g. @\"*.example.com\"@). IDNA\/punycode +encoding of Unicode hostnames must be done by the caller before passing to +this function. + +To construct a name-constraint subtree name with a leading dot (e.g. +@\".example.com\"@), use 'mkDnsConstraint' instead. +-} +mkDnsName :: Text -> Either DNSNameError DnsName +mkDnsName t + | T.null t = Left NameEmpty + | T.length t > 253 = Left NameTooLong + | otherwise = validateLabels (T.splitOn "." t) >> Right (DnsName t) + where + validateLabels [] = Left NameEmpty + validateLabels (l : ls) = validateFirst l >> mapM_ validateLabel ls + + validateFirst "*" = Right () + validateFirst l = validateLabel l + + validateLabel l + | T.null l = Left NameEmpty + | T.length l > 63 = Left LabelTooLong + | otherwise = + case (T.uncons l, T.unsnoc l) of + (Just ('-', _), _) -> Left LabelLeadingHyphen + (_, Just (_, '-')) -> Left LabelTrailingHyphen + _ + | T.all isValidChar l -> Right () + | otherwise -> Left LabelInvalidChar + + isValidChar c = isAlphaNum c || c == '-' + + +{- | Construct a 'DnsName' for use as an RFC 5280 name-constraint subtree. + +Accepts an optional leading dot (e.g. @\".example.com\"@), which denotes the +domain and all its subdomains. The remainder after stripping the leading dot +must satisfy the same RFC 1123 rules as 'mkDnsName'. + +Use 'mkDnsName' for ordinary hostname values; use this function only when +constructing a 'NameConstraints' subtree entry. +-} +mkDnsConstraint :: Text -> Either DNSNameError DnsName +mkDnsConstraint t = case T.stripPrefix "." t of + Just rest -> mkDnsName rest >> Right (DnsName t) + Nothing -> mkDnsName t + + +-- | Failure modes for 'mkOtherName'. +data OtherNameError + = -- | The OID arcs are invalid; see 'OIDError'. + InvalidOID + | -- | The value contains a code point above U+007F. + IA5NonAscii + | -- | The value contains a character outside the PrintableString alphabet. + PrintableInvalidChar + | -- | The value contains a code point above U+FFFF. + BMPNonBMP + deriving (Eq, Show) + + +{- | Construct an 'OtherName', validating the OID and the text value against +the declared 'Asn1StringType' character set. + +Returns @Left@ with an 'OtherNameError' if validation fails. The OID is +validated via 'mkOID'. Character-set constraints: + +* 'UTF8String' — any 'Text' is accepted. +* 'IA5String' — all code points must be ≤ U+007F. +* 'PrintableString' — all characters must be in @[A-Za-z0-9 \'()+,-./:=?]@. +* 'BMPString' — all code points must be ≤ U+FFFF. +-} +mkOtherName :: Int -> [Int] -> Asn1StringType -> Text -> Either OtherNameError OtherName +mkOtherName firstArc restArcs enc val = do + oid <- first (const InvalidOID) (mkOID firstArc restArcs) + validateEncoding enc val + return (MkOtherName oid enc val) + where + validateEncoding UTF8String _ = Right () + validateEncoding IA5String t + | T.all (\c -> fromEnum c <= 127) t = Right () + | otherwise = Left IA5NonAscii + validateEncoding PrintableString t + | T.all isPrintableChar t = Right () + | otherwise = Left PrintableInvalidChar + validateEncoding BMPString t + | T.all (\c -> fromEnum c <= 0xFFFF) t = Right () + | otherwise = Left BMPNonBMP + + isPrintableChar c = (isAscii c && isAlphaNum c) || c `elem` (" '()+,-./:=?" :: String) + + +{- | Construct a 'GeneralName' carrying a validated ASN.1 registered object +identifier. + +The OID arcs are validated via 'mkOID'. Returns @Left 'OIDError'@ if +validation fails. +-} +mkRegisteredID :: Int -> [Int] -> Either OIDError GeneralName +mkRegisteredID firstArc restArcs = RegisteredID_ <$> mkOID firstArc restArcs + + +{- | Construct a @'Other' 'OtherName'@ 'GeneralName', validating the OID and +encoding in the same way as 'mkOtherName'. +-} +mkOther :: Int -> [Int] -> Asn1StringType -> Text -> Either OtherNameError GeneralName +mkOther firstArc restArcs enc val = Other <$> mkOtherName firstArc restArcs enc val diff --git a/src/Data/Rfc5280/HasOID.hs b/src/Data/Rfc5280/HasOID.hs new file mode 100644 --- /dev/null +++ b/src/Data/Rfc5280/HasOID.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE OverloadedStrings #-} + +{- | +Module : Data.Rfc5280.HasOID +Copyright : (c) 2026 Tim Emiola +Maintainer : Tim Emiola +SPDX-License-Identifier: BSD3 + +Provides the 'HasOID' typeclass for associating extension types with their +RFC 5280 OIDs, and the 'Extension' wrapper for pairing a value with its +criticality flag. +-} +module Data.Rfc5280.HasOID + ( HasOID (..) + , Extension (..) + ) +where + +import Data.Proxy (Proxy) +import Data.Rfc5280.Internal (OID, RenderConfig (..)) + + +-- | Associates an extension type with its RFC 5280 OID. +class HasOID a where + -- | Return the OID assigned to extension type @a@ by RFC 5280. + extensionOID :: Proxy a -> OID + + +{- | Pairs an extension value with its RFC 5280 criticality flag. + +See . +-} +data Extension a = Extension + { extCritical :: !Bool + -- ^ 'True' if the extension is marked critical. + , extValue :: !a + -- ^ The extension value. + } + deriving (Eq, Show) + + +{- | Renders as @\"critical,\\"@ when 'extCritical' is 'True', +or just @\@ otherwise. +-} +instance (RenderConfig a) => RenderConfig (Extension a) where + renderBuilder (Extension critical val) + | critical = "critical," <> renderBuilder val + | otherwise = renderBuilder val diff --git a/src/Data/Rfc5280/InhibitAnyPolicy.hs b/src/Data/Rfc5280/InhibitAnyPolicy.hs new file mode 100644 --- /dev/null +++ b/src/Data/Rfc5280/InhibitAnyPolicy.hs @@ -0,0 +1,54 @@ +{- | +Module : Data.Rfc5280.InhibitAnyPolicy +Copyright : (c) 2026 Tim Emiola +Maintainer : Tim Emiola +SPDX-License-Identifier: BSD3 + +Provides 'InhibitAnyPolicy', representing the X.509 Inhibit anyPolicy +extension (RFC 5280 §4.2.1.14). +-} +module Data.Rfc5280.InhibitAnyPolicy + ( InhibitAnyPolicy (..) + , InhibitAnyPolicyError (..) + , mkInhibitAnyPolicy + ) +where + +import Data.ByteString.Builder (intDec) +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Rfc5280.HasOID (HasOID (..)) +import Data.Rfc5280.Internal (RenderConfig (..)) + + +{- | Represents the InhibitAnyPolicy extension (RFC 5280 §4.2.1.14). + +The value is the @SkipCerts@ integer, indicating how many additional +certificates may appear in the path before anyPolicy is no longer +acceptable. Use 'mkInhibitAnyPolicy' to construct a value. +-} +newtype InhibitAnyPolicy = InhibitAnyPolicy Int + deriving (Eq, Show) + + +-- | Failure modes for 'mkInhibitAnyPolicy'. +data InhibitAnyPolicyError + = -- | The skip-certs value is negative. + NegativeSkipCerts + deriving (Eq, Show) + + +{- | Construct an 'InhibitAnyPolicy', validating that the skip-certs value +is non-negative. +-} +mkInhibitAnyPolicy :: Int -> Either InhibitAnyPolicyError InhibitAnyPolicy +mkInhibitAnyPolicy n + | n < 0 = Left NegativeSkipCerts + | otherwise = Right (InhibitAnyPolicy n) + + +instance HasOID InhibitAnyPolicy where + extensionOID _ = 2 :| [5, 29, 54] + + +instance RenderConfig InhibitAnyPolicy where + renderBuilder (InhibitAnyPolicy n) = intDec n diff --git a/src/Data/Rfc5280/Internal.hs b/src/Data/Rfc5280/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Data/Rfc5280/Internal.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE OverloadedStrings #-} + +{- | +Module : Data.Rfc5280.Internal +Copyright : (c) 2026 Tim Emiola +Maintainer : Tim Emiola +SPDX-License-Identifier: BSD3 + +Internal helpers shared across X.509 extension modules. Not part of the +public API stability guarantee. +-} +module Data.Rfc5280.Internal + ( -- * Rendering + RenderConfig (..) + + -- * OID + , OID + , OIDError (..) + , mkOID + , oidBuilder + + -- * Builder helpers + , intersperseCommas + , intersperseWith + ) +where + +import Data.ByteString.Builder (Builder, intDec) +import Data.Foldable (foldl') +import Data.List.NonEmpty (NonEmpty (..)) + + +{- | Types that can be rendered to a configuration value as a 'Builder'. +Implemented by all extension types; used by 'Data.Rfc5280.renderConfig'. +-} +class RenderConfig a where + -- | Render a value as a 'Builder' in OpenSSL extension configuration format. + renderBuilder :: a -> Builder + + +-- | An ASN.1 object identifier. Construct with 'mkOID'. +type OID = NonEmpty Int + + +-- | Failure modes for 'mkOID'. +data OIDError + = -- | First arc is not 0, 1, or 2. + InvalidFirstArc + | -- | One or more subsequent arcs are negative. + NegativeArc + deriving (Eq, Show) + + +{- | Construct an 'OID', validating that the first arc is 0–2 and all arcs +are non-negative. + +The second-arc ≤ 39 constraint from X.660 is not enforced; it only applies +under first arcs 0 and 1 and is rarely violated in practice. +-} +mkOID :: Int -> [Int] -> Either OIDError OID +mkOID first rest + | first < 0 || first > 2 = Left InvalidFirstArc + | any (< 0) rest = Left NegativeArc + | otherwise = Right (first :| rest) + + +-- | Render an 'OID' as a dot-separated sequence of integers. +oidBuilder :: OID -> Builder +oidBuilder = intersperseWith "." . fmap intDec + + +-- | Render a non-empty list of 'Builder' values separated by commas. +intersperseCommas :: NonEmpty Builder -> Builder +intersperseCommas = intersperseWith "," + + +-- | Render a non-empty list of 'Builder' values separated by @sep@. +intersperseWith :: Builder -> NonEmpty Builder -> Builder +intersperseWith sep (x :| xs) = x <> foldl' (\acc y -> acc <> sep <> y) "" xs diff --git a/src/Data/Rfc5280/IssuerAltName.hs b/src/Data/Rfc5280/IssuerAltName.hs new file mode 100644 --- /dev/null +++ b/src/Data/Rfc5280/IssuerAltName.hs @@ -0,0 +1,41 @@ +{- | +Module : Data.Rfc5280.IssuerAltName +Copyright : (c) 2026 Tim Emiola +Maintainer : Tim Emiola +SPDX-License-Identifier: BSD3 + +Provides 'IssuerAltName', representing the X.509 Issuer Alternative Name +extension (RFC 5280 §4.2.1.7). +-} +module Data.Rfc5280.IssuerAltName + ( IssuerAltName (..) + , mkIssuerAltName + ) +where + +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Rfc5280.GeneralName (GeneralName) +import Data.Rfc5280.HasOID (HasOID (..)) +import Data.Rfc5280.Internal (RenderConfig (..), intersperseCommas) + + +{- | Represents the IssuerAltName extension (RFC 5280 §4.2.1.7). + +Contains one or more 'GeneralName' values identifying the issuer. Use +'mkIssuerAltName' to construct a value. +-} +newtype IssuerAltName = IssuerAltName (NonEmpty GeneralName) + deriving (Eq, Show) + + +-- | Construct an 'IssuerAltName' from one or more 'GeneralName' values. +mkIssuerAltName :: GeneralName -> [GeneralName] -> IssuerAltName +mkIssuerAltName x xs = IssuerAltName (x :| xs) + + +instance HasOID IssuerAltName where + extensionOID _ = 2 :| [5, 29, 18] + + +instance RenderConfig IssuerAltName where + renderBuilder (IssuerAltName names) = intersperseCommas (fmap renderBuilder names) diff --git a/src/Data/Rfc5280/KeyUsage.hs b/src/Data/Rfc5280/KeyUsage.hs new file mode 100644 --- /dev/null +++ b/src/Data/Rfc5280/KeyUsage.hs @@ -0,0 +1,92 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} + +{- | +Module : Data.Rfc5280.KeyUsage +Copyright : (c) 2026 Tim Emiola +Maintainer : Tim Emiola +SPDX-License-Identifier: BSD3 + +Provides the 'KeyUsage' extension type. +-} +module Data.Rfc5280.KeyUsage + ( KeyUsageBit (..) + , KeyUsage + ) +where + +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Rfc5280.HasOID (HasOID (..)) +import Data.Rfc5280.Internal (RenderConfig (..), intersperseCommas) +import qualified Data.Set.NonEmpty as NES + + +{- | Represents the bits that can set for @KeyUsage@ + +See . +-} +data KeyUsageBit + = {- | Verifying digital signatures other than signatures on certificates or + CRLs. Renders as @\"digitalSignature\"@. + -} + DigitalSignature + | {- | Verifying digital signatures to provide non-repudiation of signing + actions (also called @contentCommitment@). Renders as @\"nonRepudiation\"@. + -} + NonRepudiation + | {- | Enciphering private or secret keys (key transport). Renders as + @\"keyEncipherment\"@. + -} + KeyEncipherment + | {- | Directly enciphering raw user data without an intermediate symmetric + cipher. Renders as @\"dataEncipherment\"@. + -} + DataEncipherment + | {- | Key agreement protocols (e.g. Diffie-Hellman). Renders as + @\"keyAgreement\"@. + -} + KeyAgreement + | {- | Verifying signatures on public-key certificates. Renders as + @\"keyCertSign\"@. + -} + KeyCertSign + | {- | Verifying signatures on certificate revocation lists. Renders as + @\"cRLSign\"@. + -} + CRLSign + | {- | Enciphering data only during key agreement (used with 'KeyAgreement'). + Renders as @\"encipherOnly\"@. + -} + EncipherOnly + | {- | Deciphering data only during key agreement (used with 'KeyAgreement'). + Renders as @\"decipherOnly\"@. + -} + DecipherOnly + deriving (Eq, Show, Ord, Enum, Bounded) + + +instance RenderConfig KeyUsageBit where + renderBuilder DigitalSignature = "digitalSignature" + renderBuilder NonRepudiation = "nonRepudiation" + renderBuilder KeyEncipherment = "keyEncipherment" + renderBuilder DataEncipherment = "dataEncipherment" + renderBuilder KeyAgreement = "keyAgreement" + renderBuilder KeyCertSign = "keyCertSign" + renderBuilder CRLSign = "cRLSign" + renderBuilder EncipherOnly = "encipherOnly" + renderBuilder DecipherOnly = "decipherOnly" + + +{- | Represents the 'KeyUsage' extension + +See . +-} +type KeyUsage = NES.NESet KeyUsageBit + + +instance HasOID KeyUsage where + extensionOID _ = 2 :| [5, 29, 15] + + +instance RenderConfig KeyUsage where + renderBuilder = intersperseCommas . fmap renderBuilder . NES.toList diff --git a/src/Data/Rfc5280/NameConstraints.hs b/src/Data/Rfc5280/NameConstraints.hs new file mode 100644 --- /dev/null +++ b/src/Data/Rfc5280/NameConstraints.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE OverloadedStrings #-} + +{- | +Module : Data.Rfc5280.NameConstraints +Copyright : (c) 2026 Tim Emiola +Maintainer : Tim Emiola +SPDX-License-Identifier: BSD3 + +Provides 'NameConstraints', representing the X.509 Name Constraints extension +(RFC 5280 §4.2.1.10). + +The @minimum@ and @maximum@ fields of @GeneralSubtree@ are not modelled; they +are almost never used in practice and are not supported in OpenSSL config format. +-} +module Data.Rfc5280.NameConstraints + ( NameConstraints (..) + , mkNameConstraints + , NameConstraint (..) + ) +where + +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Rfc5280.GeneralName (GeneralName) +import Data.Rfc5280.HasOID (HasOID (..)) +import Data.Rfc5280.Internal (RenderConfig (..), intersperseCommas) + + +{- | A single name constraint, either permitting or excluding a subtree +identified by a 'GeneralName'. +-} +data NameConstraint + = -- | A permitted subtree. Rendered as @permitted;\@. + Permitted !GeneralName + | -- | An excluded subtree. Rendered as @excluded;\@. + Excluded !GeneralName + deriving (Eq, Show) + + +{- | Represents the NameConstraints extension (RFC 5280 §4.2.1.10). + +Contains one or more 'NameConstraint' values. Use 'mkNameConstraints' to +construct a value. +-} +newtype NameConstraints = NameConstraints (NonEmpty NameConstraint) + deriving (Eq, Show) + + +-- | Construct a 'NameConstraints' from one or more 'NameConstraint' values. +mkNameConstraints :: NameConstraint -> [NameConstraint] -> NameConstraints +mkNameConstraints x xs = NameConstraints (x :| xs) + + +instance HasOID NameConstraints where + extensionOID _ = 2 :| [5, 29, 30] + + +instance RenderConfig NameConstraint where + renderBuilder (Permitted name) = "permitted;" <> renderBuilder name + renderBuilder (Excluded name) = "excluded;" <> renderBuilder name + + +instance RenderConfig NameConstraints where + renderBuilder (NameConstraints cs) = intersperseCommas (fmap renderBuilder cs) diff --git a/src/Data/Rfc5280/PolicyMappings.hs b/src/Data/Rfc5280/PolicyMappings.hs new file mode 100644 --- /dev/null +++ b/src/Data/Rfc5280/PolicyMappings.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE OverloadedStrings #-} + +{- | +Module : Data.Rfc5280.PolicyMappings +Copyright : (c) 2026 Tim Emiola +Maintainer : Tim Emiola +SPDX-License-Identifier: BSD3 + +Provides 'PolicyMappings', representing the X.509 Policy Mappings extension +(RFC 5280 §4.2.1.5). +-} +module Data.Rfc5280.PolicyMappings + ( PolicyMappings (..) + , mkPolicyMappings + , PolicyMapping (..) + , mkPolicyMapping + ) +where + +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Rfc5280.HasOID (HasOID (..)) +import Data.Rfc5280.Internal (OID, RenderConfig (..), intersperseCommas, oidBuilder) + + +{- | A single policy mapping, pairing an issuer domain policy OID with a +subject domain policy OID. +-} +data PolicyMapping = PolicyMapping + { pmIssuerDomainPolicy :: !OID + -- ^ The issuer's policy OID. + , pmSubjectDomainPolicy :: !OID + -- ^ The subject's corresponding policy OID. + } + deriving (Eq, Show) + + +{- | Represents the PolicyMappings extension (RFC 5280 §4.2.1.5). + +Contains one or more 'PolicyMapping' pairs. Use 'mkPolicyMappings' to +construct a value. +-} +newtype PolicyMappings = PolicyMappings (NonEmpty PolicyMapping) + deriving (Eq, Show) + + +-- | Construct a 'PolicyMapping' from an issuer domain policy OID and a subject domain policy OID. +mkPolicyMapping :: OID -> OID -> PolicyMapping +mkPolicyMapping = PolicyMapping + + +-- | Construct a 'PolicyMappings' from one or more 'PolicyMapping' values. +mkPolicyMappings :: PolicyMapping -> [PolicyMapping] -> PolicyMappings +mkPolicyMappings x xs = PolicyMappings (x :| xs) + + +instance HasOID PolicyMappings where + extensionOID _ = 2 :| [5, 29, 33] + + +instance RenderConfig PolicyMapping where + renderBuilder pm = oidBuilder (pmIssuerDomainPolicy pm) <> ":" <> oidBuilder (pmSubjectDomainPolicy pm) + + +instance RenderConfig PolicyMappings where + renderBuilder (PolicyMappings ms) = intersperseCommas (fmap renderBuilder ms) diff --git a/src/Data/Rfc5280/SubjectAltName.hs b/src/Data/Rfc5280/SubjectAltName.hs new file mode 100644 --- /dev/null +++ b/src/Data/Rfc5280/SubjectAltName.hs @@ -0,0 +1,41 @@ +{- | +Module : Data.Rfc5280.SubjectAltName +Copyright : (c) 2026 Tim Emiola +Maintainer : Tim Emiola +SPDX-License-Identifier: BSD3 + +Provides 'SubjectAltName', representing the X.509 Subject Alternative Name +extension (RFC 5280 §4.2.1.6). +-} +module Data.Rfc5280.SubjectAltName + ( SubjectAltName (..) + , mkSubjectAltName + ) +where + +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Rfc5280.GeneralName (GeneralName) +import Data.Rfc5280.HasOID (HasOID (..)) +import Data.Rfc5280.Internal (RenderConfig (..), intersperseCommas) + + +{- | Represents the SubjectAltName extension (RFC 5280 §4.2.1.6). + +Contains one or more 'GeneralName' values identifying the subject. Use +'mkSubjectAltName' to construct a value. +-} +newtype SubjectAltName = SubjectAltName (NonEmpty GeneralName) + deriving (Eq, Show) + + +-- | Construct a 'SubjectAltName' from one or more 'GeneralName' values. +mkSubjectAltName :: GeneralName -> [GeneralName] -> SubjectAltName +mkSubjectAltName x xs = SubjectAltName (x :| xs) + + +instance HasOID SubjectAltName where + extensionOID _ = 2 :| [5, 29, 17] + + +instance RenderConfig SubjectAltName where + renderBuilder (SubjectAltName names) = intersperseCommas (fmap renderBuilder names) diff --git a/src/Data/Rfc5280/SubjectKeyIdentifier.hs b/src/Data/Rfc5280/SubjectKeyIdentifier.hs new file mode 100644 --- /dev/null +++ b/src/Data/Rfc5280/SubjectKeyIdentifier.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE OverloadedStrings #-} + +{- | +Module : Data.Rfc5280.SubjectKeyIdentifier +Copyright : (c) 2026 Tim Emiola +Maintainer : Tim Emiola +SPDX-License-Identifier: BSD3 + +Provides the 'SubjectKeyIdentifier' extension type. +-} +module Data.Rfc5280.SubjectKeyIdentifier + ( SubjectKeyIdentifier (..) + ) +where + +import Data.ByteString (ByteString) +import Data.ByteString.Builder (byteString) +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Rfc5280.HasOID (HasOID (..)) +import Data.Rfc5280.Internal (RenderConfig (..)) + + +-- | Represents a SubjectKeyIdentifier value (RFC 5280 §4.2.1.2). +data SubjectKeyIdentifier + = {- | A raw key identifier. The caller supplies the bytes directly — + typically the SHA-1 hash of the BIT STRING value of the + subjectPublicKey field. + -} + Raw !ByteString + | {- | Use the default hash method: the 160-bit SHA-1 hash of the + subjectPublicKey BIT STRING, as defined in RFC 5280 §4.2.1.2. + -} + HashMethod + deriving (Eq, Show) + + +instance HasOID SubjectKeyIdentifier where + extensionOID _ = 2 :| [5, 29, 14] + + +instance RenderConfig SubjectKeyIdentifier where + renderBuilder (Raw x) = byteString x + renderBuilder HashMethod = "hash" diff --git a/test/Rfc5280/AssertSpec.hs b/test/Rfc5280/AssertSpec.hs new file mode 100644 --- /dev/null +++ b/test/Rfc5280/AssertSpec.hs @@ -0,0 +1,30 @@ +{- | +Module : Rfc5280.AssertSpec +Copyright : (c) 2026 Tim Emiola +Maintainer : Tim Emiola +SPDX-License-Identifier: BSD3 + +Tests for 'Data.Rfc5280.Assert'. +-} +module Rfc5280.AssertSpec (spec) where + +import Data.Rfc5280.Assert (assertJust, assertRight) +import Test.Hspec + + +spec :: Spec +spec = do + describe "assertRight" $ do + it "returns the value on Right" $ do + result <- assertRight (Right 42 :: Either String Int) + result `shouldBe` 42 + it "fails on Left" $ + assertRight (Left "oops" :: Either String Int) + `shouldThrow` anyException + describe "assertJust" $ do + it "returns the value on Just" $ do + result <- assertJust "missing" (Just 42) + result `shouldBe` (42 :: Int) + it "fails with the given message on Nothing" $ + assertJust "missing" (Nothing :: Maybe Int) + `shouldThrow` anyException diff --git a/test/Rfc5280/AuthorityInfoAccessSpec.hs b/test/Rfc5280/AuthorityInfoAccessSpec.hs new file mode 100644 --- /dev/null +++ b/test/Rfc5280/AuthorityInfoAccessSpec.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE OverloadedStrings #-} + +{- | +Module : Rfc5280.AuthorityInfoAccessSpec +Copyright : (c) 2026 Tim Emiola +Maintainer : Tim Emiola +SPDX-License-Identifier: BSD3 + +Tests for 'Data.Rfc5280.AuthorityInfoAccess'. +-} +module Rfc5280.AuthorityInfoAccessSpec (spec) where + +import qualified Data.ByteString as BS +import Data.Rfc5280 (renderConfig) +import Data.Rfc5280.Assert (assertRight) +import Data.Rfc5280.AuthorityInfoAccess +import Data.Rfc5280.GeneralName +import Rfc5280.Generators (validDnsName) +import Test.Hspec +import Test.Hspec.QuickCheck (prop) +import Test.QuickCheck (forAll) +import Text.URI (mkURI) + + +spec :: Spec +spec = describe "module Data.Rfc5280.AuthorityInfoAccess" $ do + context "mkAuthorityInfoAccess" $ do + it "renders a single OCSP entry" $ do + uri <- mkURI "http://ocsp.example.com" + renderConfig (mkAuthorityInfoAccess (OCSP (URIName uri)) []) + `shouldBe` "OCSP;URI:http://ocsp.example.com" + it "renders a single CAIssuers entry" $ do + uri <- mkURI "http://ca.example.com/issuer.crt" + renderConfig (mkAuthorityInfoAccess (CAIssuers (URIName uri)) []) + `shouldBe` "caIssuers;URI:http://ca.example.com/issuer.crt" + it "renders OCSP and CAIssuers together" $ do + ocspUri <- mkURI "http://ocsp.example.com" + issuerUri <- mkURI "http://ca.example.com/issuer.crt" + renderConfig + ( mkAuthorityInfoAccess + (OCSP (URIName ocspUri)) + [CAIssuers (URIName issuerUri)] + ) + `shouldBe` "OCSP;URI:http://ocsp.example.com,caIssuers;URI:http://ca.example.com/issuer.crt" + it "renders an Other name as OCSP location" $ do + gn <- assertRight (mkOther 1 [2, 3] UTF8String "value") + renderConfig (mkAuthorityInfoAccess (OCSP gn) []) + `shouldBe` "OCSP;otherName:1.2.3;UTF8:value" + prop "OCSP entries always start with OCSP;" $ + forAll validDnsName $ \dn -> + BS.isPrefixOf "OCSP;" (renderConfig (mkAuthorityInfoAccess (OCSP (DNS dn)) [])) + prop "CAIssuers entries always start with caIssuers;" $ + forAll validDnsName $ \dn -> + BS.isPrefixOf "caIssuers;" (renderConfig (mkAuthorityInfoAccess (CAIssuers (DNS dn)) [])) diff --git a/test/Rfc5280/CRLDistributionPointsSpec.hs b/test/Rfc5280/CRLDistributionPointsSpec.hs new file mode 100644 --- /dev/null +++ b/test/Rfc5280/CRLDistributionPointsSpec.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE OverloadedStrings #-} + +{- | +Module : Rfc5280.CRLDistributionPointsSpec +Copyright : (c) 2026 Tim Emiola +Maintainer : Tim Emiola +SPDX-License-Identifier: BSD3 + +Tests for 'Data.Rfc5280.CRLDistributionPoints'. +-} +module Rfc5280.CRLDistributionPointsSpec (spec) where + +import qualified Data.ByteString as BS +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Rfc5280 (renderConfig) +import Data.Rfc5280.Assert (assertRight) +import Data.Rfc5280.CRLDistributionPoints +import Data.Rfc5280.GeneralName +import Rfc5280.Generators (validDnsName, vectorOf1) +import Test.Hspec +import Test.Hspec.QuickCheck (prop) +import Test.QuickCheck (choose, forAll, (===)) +import Text.URI (mkURI) + + +spec :: Spec +spec = describe "module Data.Rfc5280.CRLDistributionPoints" $ do + context "mkCRLDistributionPoints" $ do + it "renders a single URI distribution point" $ do + uri <- mkURI "http://crl.example.com/crl.crl" + renderConfig (mkCRLDistributionPoints (mkDistributionPoint (URIName uri)) []) + `shouldBe` "URI:http://crl.example.com/crl.crl" + it "renders two URI distribution points" $ do + uri1 <- mkURI "http://crl1.example.com/crl.crl" + uri2 <- mkURI "http://crl2.example.com/crl.crl" + renderConfig + ( mkCRLDistributionPoints + (mkDistributionPoint (URIName uri1)) + [mkDistributionPoint (URIName uri2)] + ) + `shouldBe` "URI:http://crl1.example.com/crl.crl,URI:http://crl2.example.com/crl.crl" + it "renders a DNS-name distribution point" $ do + dn <- assertRight (mkDnsName "crl.example.com") + renderConfig (mkCRLDistributionPoints (mkDistributionPoint (DNS dn)) []) + `shouldBe` "DNS:crl.example.com" + it "renders an Other distribution point" $ do + gn <- assertRight (mkOther 1 [2, 3] UTF8String "value") + renderConfig + ( mkCRLDistributionPoints + (mkDistributionPoint gn) + [] + ) + `shouldBe` "otherName:1.2.3;UTF8:value" + prop "a single distribution point contains no comma" $ + forAll validDnsName $ \dn -> + BS.elem 0x2C (renderConfig (mkCRLDistributionPoints (mkDistributionPoint (DNS dn)) [])) === False + prop "n distribution points produce exactly n-1 comma separators" $ + forAll (choose (1, 6)) $ \n -> + forAll (vectorOf1 n validDnsName) $ \(h :| tl) -> + let pts = + mkCRLDistributionPoints + (mkDistributionPoint (DNS h)) + (map (mkDistributionPoint . DNS) tl) + bs = renderConfig pts + in BS.length (BS.filter (== 0x2C) bs) === n - 1 diff --git a/test/Rfc5280/Fixtures.hs b/test/Rfc5280/Fixtures.hs new file mode 100644 --- /dev/null +++ b/test/Rfc5280/Fixtures.hs @@ -0,0 +1,38 @@ +{- | +Module : Rfc5280.Fixtures +Copyright : (c) 2026 Tim Emiola +Maintainer : Tim Emiola +SPDX-License-Identifier: BSD3 + +Shared test helpers for X.509 extension test suites. + +'testIP' and 'testEmail' lift external-library decoders that use 'Maybe' and +@Either String@ respectively into 'MonadIO', throwing a 'userError' when +decoding fails. +-} +module Rfc5280.Fixtures + ( testIP + , testEmail + ) +where + +import Control.Exception (throwIO) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Data.ByteString (ByteString) +import Data.Rfc5280.Assert (assertJust) +import Data.Text (Text) +import qualified Data.Text as T +import Net.IP (IP) +import qualified Net.IP as IP +import Text.Email.Validate (EmailAddress, validate) + + +-- | Decode an IP address, throwing a 'userError' with a descriptive message if invalid. +testIP :: (MonadIO m) => Text -> m IP +testIP t = assertJust ("could not decode IP address: " <> T.unpack t) (IP.decode t) + + +-- | Parse an email address, throwing a 'userError' with a descriptive message if invalid. +testEmail :: (MonadIO m) => ByteString -> m EmailAddress +testEmail bs = + either (\e -> liftIO . throwIO . userError $ "invalid email address: " <> e) pure (validate bs) diff --git a/test/Rfc5280/GeneralNameSpec.hs b/test/Rfc5280/GeneralNameSpec.hs new file mode 100644 --- /dev/null +++ b/test/Rfc5280/GeneralNameSpec.hs @@ -0,0 +1,108 @@ +{-# LANGUAGE OverloadedStrings #-} + +{- | +Module : Rfc5280.GeneralNameSpec +Copyright : (c) 2026 Tim Emiola +Maintainer : Tim Emiola +SPDX-License-Identifier: BSD3 + +Tests for 'Data.Rfc5280.GeneralName'. +-} +module Rfc5280.GeneralNameSpec (spec) where + +import Data.Either (isLeft) +import Data.Rfc5280 (NonEmpty (..), renderConfig) +import Data.Rfc5280.Assert (assertRight) +import Data.Rfc5280.GeneralName +import qualified Data.Text as T +import Rfc5280.Fixtures (testEmail, testIP) +import Rfc5280.Generators (nameWithInvalidChar, validDNSName) +import Test.Hspec +import Test.Hspec.QuickCheck (prop) +import Test.QuickCheck (forAll, (===)) +import Text.URI (mkURI) + + +spec :: Spec +spec = describe "module Data.Rfc5280.GeneralName" $ do + context "DNS" $ + it "converts to ByteString" $ do + dn <- assertRight (mkDnsName "example.com") + renderConfig (DNS dn) `shouldBe` "DNS:example.com" + context "IPAddr (IPv4)" $ + it "converts to ByteString" $ do + ip <- testIP "192.0.2.1" + renderConfig (IPAddr ip) `shouldBe` "IP:192.0.2.1" + context "IPAddr (IPv6)" $ + it "converts to ByteString" $ do + ip <- testIP "::1" + renderConfig (IPAddr ip) `shouldBe` "IP:::1" + context "EmailAddr" $ + it "converts to ByteString" $ do + addr <- testEmail "user@example.com" + renderConfig (EmailAddr addr) `shouldBe` "email:user@example.com" + context "URIName" $ + it "converts to ByteString" $ do + uri <- mkURI "https://example.com" + renderConfig (URIName uri) `shouldBe` "URI:https://example.com" + context "RegisteredID" $ + it "converts to ByteString" $ do + rid <- assertRight (mkRegisteredID 2 [5, 4, 3]) + renderConfig rid `shouldBe` "RID:2.5.4.3" + context "Other (UTF8String)" $ + it "converts to ByteString" $ do + gn <- assertRight (mkOther 1 [2, 3] UTF8String "hello") + renderConfig gn `shouldBe` "otherName:1.2.3;UTF8:hello" + context "Other (IA5String)" $ + it "converts to ByteString" $ do + gn <- assertRight (mkOther 1 [2, 3] IA5String "hello") + renderConfig gn `shouldBe` "otherName:1.2.3;IA5:hello" + context "Other (PrintableString)" $ + it "converts to ByteString" $ do + gn <- assertRight (mkOther 1 [2, 3] PrintableString "Hello World") + renderConfig gn `shouldBe` "otherName:1.2.3;PRINTABLE:Hello World" + context "Other (BMPString)" $ + it "converts to ByteString" $ do + gn <- assertRight (mkOther 1 [2, 3] BMPString "hello") + renderConfig gn `shouldBe` "otherName:1.2.3;BMP:hello" + context "mkDnsName" $ do + it "accepts a simple hostname" $ + fmap dnsNameText (mkDnsName "example.com") `shouldBe` Right "example.com" + it "accepts a multi-label hostname" $ + fmap dnsNameText (mkDnsName "foo.bar.example.com") `shouldBe` Right "foo.bar.example.com" + it "accepts a wildcard first label" $ + fmap dnsNameText (mkDnsName "*.example.com") `shouldBe` Right "*.example.com" + it "accepts a single label" $ + fmap dnsNameText (mkDnsName "localhost") `shouldBe` Right "localhost" + it "rejects an empty name" $ + mkDnsName "" `shouldBe` Left NameEmpty + it "rejects a label ending with a hyphen" $ + mkDnsName "example-.com" `shouldBe` Left LabelTrailingHyphen + it "rejects a label starting with a hyphen" $ + mkDnsName "-example.com" `shouldBe` Left LabelLeadingHyphen + it "rejects an empty label" $ + mkDnsName "example..com" `shouldBe` Left NameEmpty + it "rejects a label exceeding 63 characters" $ + mkDnsName (T.replicate 64 "a" <> ".com") `shouldBe` Left LabelTooLong + it "rejects a name exceeding 253 characters" $ + mkDnsName (T.intercalate "." (replicate 5 (T.replicate 50 "a"))) `shouldBe` Left NameTooLong + prop "accepts any validly-constructed hostname" $ + forAll validDNSName $ + \t -> fmap dnsNameText (mkDnsName t) === Right t + prop "rejects any name containing an invalid label character" $ + forAll nameWithInvalidChar $ + \t -> isLeft (mkDnsName t) + context "mkOtherName" $ do + it "accepts a valid OID and UTF8String value" $ do + on <- assertRight (mkOtherName 1 [2, 3] UTF8String "hello") + onTypeId on `shouldBe` (1 :| [2, 3]) + onEncoding on `shouldBe` UTF8String + onValue on `shouldBe` "hello" + it "rejects a negative OID arc" $ + mkOtherName (-1) [2, 3] UTF8String "hello" `shouldBe` Left InvalidOID + it "rejects IA5String value containing a non-ASCII character" $ + mkOtherName 1 [2, 3] IA5String "h\xe9llo" `shouldBe` Left IA5NonAscii + it "rejects PrintableString value containing a character outside the alphabet" $ + mkOtherName 1 [2, 3] PrintableString "user@example" `shouldBe` Left PrintableInvalidChar + it "rejects BMPString value containing a non-BMP character" $ + mkOtherName 1 [2, 3] BMPString "\x1F600" `shouldBe` Left BMPNonBMP diff --git a/test/Rfc5280/Generators.hs b/test/Rfc5280/Generators.hs new file mode 100644 --- /dev/null +++ b/test/Rfc5280/Generators.hs @@ -0,0 +1,71 @@ +{-# LANGUAGE OverloadedStrings #-} + +{- | +Module : Rfc5280.Generators +Copyright : (c) 2026 Tim Emiola +Maintainer : Tim Emiola +SPDX-License-Identifier: BSD3 + +Shared QuickCheck generators for X.509 extension test suites. +-} +module Rfc5280.Generators + ( validLabel + , validDNSName + , validDnsName + , nameWithInvalidChar + , vectorOf1 + ) +where + +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Rfc5280.GeneralName (DnsName, mkDnsName) +import qualified Data.Text as T +import Test.QuickCheck (Gen, choose, elements, vectorOf) + + +-- | Generates a DNS label of 1–10 lowercase alphanumeric characters. +validLabel :: Gen T.Text +validLabel = do + n <- choose (1, 10) + T.pack <$> vectorOf n (elements (['a' .. 'z'] ++ ['0' .. '9'])) + + +-- | Generates a valid DNS name of 1–4 alphanumeric-only labels. +validDNSName :: Gen T.Text +validDNSName = do + n <- choose (1, 4) + labels <- vectorOf n validLabel + return $ T.intercalate "." labels + + +{- | Generates a valid 'DnsName'. + +Wraps 'validDNSName' and applies 'mkDnsName'; panics if the generator +produces an invalid name (which it never should). +-} +validDnsName :: Gen DnsName +validDnsName = do + t <- validDNSName + case mkDnsName t of + Right dn -> return dn + Left err -> error $ "validDNSName produced invalid DNS name: " <> show err + + +{- | Like 'vectorOf' but returns a 'NonEmpty' list, guaranteeing at least one +element. The count @n@ must be ≥ 1; callers should enforce this with +'choose' or similar. +-} +vectorOf1 :: Int -> Gen a -> Gen (NonEmpty a) +vectorOf1 n gen = do + h <- gen + tl <- vectorOf (n - 1) gen + return (h :| tl) + + +-- | Generates a single label with one invalid character injected in the middle. +nameWithInvalidChar :: Gen T.Text +nameWithInvalidChar = do + prefix <- validLabel + badChar <- elements "!@#$%^&*()" + suffix <- validLabel + return $ prefix <> T.singleton badChar <> suffix diff --git a/test/Rfc5280/HasOIDSpec.hs b/test/Rfc5280/HasOIDSpec.hs new file mode 100644 --- /dev/null +++ b/test/Rfc5280/HasOIDSpec.hs @@ -0,0 +1,57 @@ +{-# LANGUAGE OverloadedStrings #-} + +{- | +Module : Rfc5280.HasOIDSpec +Copyright : (c) 2026 Tim Emiola +Maintainer : Tim Emiola +SPDX-License-Identifier: BSD3 + +Tests for 'Data.Rfc5280.HasOID'. +-} +module Rfc5280.HasOIDSpec (spec) where + +import Data.Proxy (Proxy (..)) +import Data.Rfc5280 + ( AuthorityKeyIdentifier + , BasicConstraints (..) + , CertificatePolicies + , ExtKeyUsage + , KeyUsage + , NonEmpty (..) + , SubjectKeyIdentifier + , renderConfig + ) +import Data.Rfc5280.AuthorityInfoAccess (AuthorityInfoAccess) +import Data.Rfc5280.HasOID (Extension (..), HasOID (..), extensionOID) +import Data.Rfc5280.SubjectAltName (SubjectAltName) +import Test.Hspec + + +spec :: Spec +spec = describe "module Data.Rfc5280.HasOID" $ do + context "extensionOID" $ do + it "returns the OID for BasicConstraints" $ + extensionOID (Proxy :: Proxy BasicConstraints) `shouldBe` (2 :| [5, 29, 19]) + it "returns the OID for KeyUsage" $ + extensionOID (Proxy :: Proxy KeyUsage) `shouldBe` (2 :| [5, 29, 15]) + it "returns the OID for ExtKeyUsage" $ + extensionOID (Proxy :: Proxy ExtKeyUsage) `shouldBe` (2 :| [5, 29, 37]) + it "returns the OID for SubjectKeyIdentifier" $ + extensionOID (Proxy :: Proxy SubjectKeyIdentifier) `shouldBe` (2 :| [5, 29, 14]) + it "returns the OID for AuthorityKeyIdentifier" $ + extensionOID (Proxy :: Proxy AuthorityKeyIdentifier) `shouldBe` (2 :| [5, 29, 35]) + it "returns the OID for CertificatePolicies" $ + extensionOID (Proxy :: Proxy CertificatePolicies) `shouldBe` (2 :| [5, 29, 32]) + it "returns the OID for SubjectAltName" $ + extensionOID (Proxy :: Proxy SubjectAltName) `shouldBe` (2 :| [5, 29, 17]) + it "returns the OID for AuthorityInfoAccess" $ + extensionOID (Proxy :: Proxy AuthorityInfoAccess) `shouldBe` (1 :| [3, 6, 1, 5, 5, 7, 1, 1]) + context "Extension (RenderConfig)" $ do + it "prepends 'critical,' when extCritical is True" $ + renderConfig (Extension True notCA) `shouldBe` "critical,CA:FALSE" + it "renders the value unchanged when extCritical is False" $ + renderConfig (Extension False notCA) `shouldBe` "CA:FALSE" + + +notCA :: BasicConstraints +notCA = BasicConstraints{bcIsCA = False, bcPathLength = Nothing} diff --git a/test/Rfc5280/InhibitAnyPolicySpec.hs b/test/Rfc5280/InhibitAnyPolicySpec.hs new file mode 100644 --- /dev/null +++ b/test/Rfc5280/InhibitAnyPolicySpec.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE OverloadedStrings #-} + +{- | +Module : Rfc5280.InhibitAnyPolicySpec +Copyright : (c) 2026 Tim Emiola +Maintainer : Tim Emiola +SPDX-License-Identifier: BSD3 + +Tests for 'Data.Rfc5280.InhibitAnyPolicy'. +-} +module Rfc5280.InhibitAnyPolicySpec (spec) where + +import Data.Rfc5280 (renderConfig) +import Data.Rfc5280.InhibitAnyPolicy +import Test.Hspec + + +spec :: Spec +spec = describe "module Data.Rfc5280.InhibitAnyPolicy" $ do + context "mkInhibitAnyPolicy" $ do + it "accepts zero" $ + mkInhibitAnyPolicy 0 `shouldBe` Right (InhibitAnyPolicy 0) + it "accepts a positive value" $ + mkInhibitAnyPolicy 2 `shouldBe` Right (InhibitAnyPolicy 2) + it "rejects a negative value" $ + mkInhibitAnyPolicy (-1) `shouldBe` Left NegativeSkipCerts + context "RenderConfig" $ do + it "renders zero" $ + renderConfig (InhibitAnyPolicy 0) `shouldBe` "0" + it "renders a positive value" $ + renderConfig (InhibitAnyPolicy 5) `shouldBe` "5" diff --git a/test/Rfc5280/IssuerAltNameSpec.hs b/test/Rfc5280/IssuerAltNameSpec.hs new file mode 100644 --- /dev/null +++ b/test/Rfc5280/IssuerAltNameSpec.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE OverloadedStrings #-} + +{- | +Module : Rfc5280.IssuerAltNameSpec +Copyright : (c) 2026 Tim Emiola +Maintainer : Tim Emiola +SPDX-License-Identifier: BSD3 + +Tests for 'Data.Rfc5280.IssuerAltName'. +-} +module Rfc5280.IssuerAltNameSpec (spec) where + +import qualified Data.ByteString as BS +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Rfc5280 (renderConfig) +import Data.Rfc5280.Assert (assertRight) +import Data.Rfc5280.GeneralName +import Data.Rfc5280.IssuerAltName +import Rfc5280.Fixtures (testEmail, testIP) +import Rfc5280.Generators (validDnsName, vectorOf1) +import Test.Hspec +import Test.Hspec.QuickCheck (prop) +import Test.QuickCheck (choose, forAll, (===)) + + +spec :: Spec +spec = describe "module Data.Rfc5280.IssuerAltName" $ do + context "mkIssuerAltName" $ do + it "renders a single DNS name" $ do + dn <- assertRight (mkDnsName "example.com") + renderConfig (mkIssuerAltName (DNS dn) []) + `shouldBe` "DNS:example.com" + it "renders two DNS names" $ do + dn1 <- assertRight (mkDnsName "example.com") + dn2 <- assertRight (mkDnsName "www.example.com") + renderConfig (mkIssuerAltName (DNS dn1) [DNS dn2]) + `shouldBe` "DNS:example.com,DNS:www.example.com" + it "renders a wildcard alongside its base domain" $ do + wild <- assertRight (mkDnsName "*.example.com") + base <- assertRight (mkDnsName "example.com") + renderConfig (mkIssuerAltName (DNS wild) [DNS base]) + `shouldBe` "DNS:*.example.com,DNS:example.com" + it "renders mixed DNS, IP and email names" $ do + ip <- testIP "192.0.2.1" + addr <- testEmail "user@example.com" + dn <- assertRight (mkDnsName "example.com") + renderConfig + ( mkIssuerAltName + (DNS dn) + [IPAddr ip, EmailAddr addr] + ) + `shouldBe` "DNS:example.com,IP:192.0.2.1,email:user@example.com" + it "renders an Other name" $ do + gn <- assertRight (mkOther 1 [2, 3] UTF8String "value") + renderConfig (mkIssuerAltName gn []) + `shouldBe` "otherName:1.2.3;UTF8:value" + prop "a single-name IAN contains no comma" $ + forAll validDnsName $ \dn -> + BS.elem 0x2C (renderConfig (mkIssuerAltName (DNS dn) [])) === False + prop "n DNS names produce exactly n-1 comma separators" $ + forAll (choose (1, 6)) $ \n -> + forAll (vectorOf1 n validDnsName) $ \(h :| tl) -> + let bs = renderConfig (mkIssuerAltName (DNS h) (map DNS tl)) + in BS.length (BS.filter (== 0x2C) bs) === n - 1 diff --git a/test/Rfc5280/NameConstraintsSpec.hs b/test/Rfc5280/NameConstraintsSpec.hs new file mode 100644 --- /dev/null +++ b/test/Rfc5280/NameConstraintsSpec.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE OverloadedStrings #-} + +{- | +Module : Rfc5280.NameConstraintsSpec +Copyright : (c) 2026 Tim Emiola +Maintainer : Tim Emiola +SPDX-License-Identifier: BSD3 + +Tests for 'Data.Rfc5280.NameConstraints'. +-} +module Rfc5280.NameConstraintsSpec (spec) where + +import qualified Data.ByteString as BS +import Data.Rfc5280 (renderConfig) +import Data.Rfc5280.Assert (assertRight) +import Data.Rfc5280.GeneralName +import Data.Rfc5280.NameConstraints +import Rfc5280.Generators (validDnsName) +import Test.Hspec +import Test.Hspec.QuickCheck (prop) +import Test.QuickCheck (forAll, (===)) + + +spec :: Spec +spec = describe "module Data.Rfc5280.NameConstraints" $ do + context "mkNameConstraints" $ do + it "renders a single permitted DNS constraint" $ do + dn <- assertRight (mkDnsConstraint ".example.com") + renderConfig (mkNameConstraints (Permitted (DNS dn)) []) + `shouldBe` "permitted;DNS:.example.com" + it "renders a single excluded DNS constraint" $ do + dn <- assertRight (mkDnsConstraint ".example.com") + renderConfig (mkNameConstraints (Excluded (DNS dn)) []) + `shouldBe` "excluded;DNS:.example.com" + it "renders a single excluded email constraint" $ do + dn <- assertRight (mkDnsConstraint ".example.org") + renderConfig (mkNameConstraints (Excluded (DNS dn)) []) + `shouldBe` "excluded;DNS:.example.org" + it "renders permitted and excluded constraints together" $ do + permitted <- assertRight (mkDnsConstraint ".example.com") + excluded <- assertRight (mkDnsConstraint ".evil.example.com") + renderConfig + ( mkNameConstraints + (Permitted (DNS permitted)) + [Excluded (DNS excluded)] + ) + `shouldBe` "permitted;DNS:.example.com,excluded;DNS:.evil.example.com" + it "renders multiple permitted constraints" $ do + dn1 <- assertRight (mkDnsConstraint ".example.com") + dn2 <- assertRight (mkDnsConstraint ".example.org") + renderConfig + ( mkNameConstraints + (Permitted (DNS dn1)) + [Permitted (DNS dn2)] + ) + `shouldBe` "permitted;DNS:.example.com,permitted;DNS:.example.org" + prop "a permitted constraint output starts with \"permitted;\"" $ + forAll validDnsName $ \dn -> + BS.isPrefixOf "permitted;" (renderConfig (mkNameConstraints (Permitted (DNS dn)) [])) === True + prop "an excluded constraint output starts with \"excluded;\"" $ + forAll validDnsName $ \dn -> + BS.isPrefixOf "excluded;" (renderConfig (mkNameConstraints (Excluded (DNS dn)) [])) === True diff --git a/test/Rfc5280/PolicyMappingsSpec.hs b/test/Rfc5280/PolicyMappingsSpec.hs new file mode 100644 --- /dev/null +++ b/test/Rfc5280/PolicyMappingsSpec.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE OverloadedStrings #-} + +{- | +Module : Rfc5280.PolicyMappingsSpec +Copyright : (c) 2026 Tim Emiola +Maintainer : Tim Emiola +SPDX-License-Identifier: BSD3 + +Tests for 'Data.Rfc5280.PolicyMappings'. +-} +module Rfc5280.PolicyMappingsSpec (spec) where + +import Data.Rfc5280 (NonEmpty (..), renderConfig) +import Data.Rfc5280.PolicyMappings +import Test.Hspec + + +spec :: Spec +spec = describe "module Data.Rfc5280.PolicyMappings" $ do + context "mkPolicyMappings" $ do + it "renders a single mapping" $ + renderConfig (mkPolicyMappings (mkPolicyMapping (1 :| [2, 3]) (2 :| [5, 4])) []) + `shouldBe` "1.2.3:2.5.4" + it "renders two mappings" $ + renderConfig + ( mkPolicyMappings + (mkPolicyMapping (1 :| [2, 3]) (2 :| [5, 4])) + [mkPolicyMapping (1 :| [2, 4]) (2 :| [5, 5])] + ) + `shouldBe` "1.2.3:2.5.4,1.2.4:2.5.5" + it "renders a mapping with multi-arc OIDs" $ + renderConfig + ( mkPolicyMappings + (mkPolicyMapping (2 :| [16, 840, 1, 101, 3, 2, 1, 3, 6]) (2 :| [16, 840, 1, 101, 3, 2, 1, 12, 4])) + [] + ) + `shouldBe` "2.16.840.1.101.3.2.1.3.6:2.16.840.1.101.3.2.1.12.4" diff --git a/test/Rfc5280/SubjectAltNameSpec.hs b/test/Rfc5280/SubjectAltNameSpec.hs new file mode 100644 --- /dev/null +++ b/test/Rfc5280/SubjectAltNameSpec.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE OverloadedStrings #-} + +{- | +Module : Rfc5280.SubjectAltNameSpec +Copyright : (c) 2026 Tim Emiola +Maintainer : Tim Emiola +SPDX-License-Identifier: BSD3 + +Tests for 'Data.Rfc5280.SubjectAltName'. +-} +module Rfc5280.SubjectAltNameSpec (spec) where + +import qualified Data.ByteString as BS +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Rfc5280 (renderConfig) +import Data.Rfc5280.Assert (assertRight) +import Data.Rfc5280.GeneralName +import Data.Rfc5280.SubjectAltName +import Rfc5280.Fixtures (testEmail, testIP) +import Rfc5280.Generators (validDnsName, vectorOf1) +import Test.Hspec +import Test.Hspec.QuickCheck (prop) +import Test.QuickCheck (choose, forAll, (===)) + + +spec :: Spec +spec = describe "module Data.Rfc5280.SubjectAltName" $ do + context "mkSubjectAltName" $ do + it "renders a single DNS name" $ do + dn <- assertRight (mkDnsName "example.com") + renderConfig (mkSubjectAltName (DNS dn) []) + `shouldBe` "DNS:example.com" + it "renders two DNS names" $ do + dn1 <- assertRight (mkDnsName "example.com") + dn2 <- assertRight (mkDnsName "www.example.com") + renderConfig (mkSubjectAltName (DNS dn1) [DNS dn2]) + `shouldBe` "DNS:example.com,DNS:www.example.com" + it "renders a wildcard alongside its base domain" $ do + wild <- assertRight (mkDnsName "*.example.com") + base <- assertRight (mkDnsName "example.com") + renderConfig (mkSubjectAltName (DNS wild) [DNS base]) + `shouldBe` "DNS:*.example.com,DNS:example.com" + it "renders mixed DNS, IP and email names" $ do + ip <- testIP "192.0.2.1" + addr <- testEmail "user@example.com" + dn <- assertRight (mkDnsName "example.com") + renderConfig + ( mkSubjectAltName + (DNS dn) + [IPAddr ip, EmailAddr addr] + ) + `shouldBe` "DNS:example.com,IP:192.0.2.1,email:user@example.com" + it "renders an Other name" $ do + gn <- assertRight (mkOther 1 [2, 3] UTF8String "value") + renderConfig (mkSubjectAltName gn []) + `shouldBe` "otherName:1.2.3;UTF8:value" + prop "a single-name SAN contains no comma" $ + forAll validDnsName $ \dn -> + BS.elem 0x2C (renderConfig (mkSubjectAltName (DNS dn) [])) === False + prop "n DNS names produce exactly n-1 comma separators" $ + forAll (choose (1, 6)) $ \n -> + forAll (vectorOf1 n validDnsName) $ \(h :| tl) -> + let bs = renderConfig (mkSubjectAltName (DNS h) (map DNS tl)) + in BS.length (BS.filter (== 0x2C) bs) === n - 1 diff --git a/test/Rfc5280Spec.hs b/test/Rfc5280Spec.hs new file mode 100644 --- /dev/null +++ b/test/Rfc5280Spec.hs @@ -0,0 +1,157 @@ +{-# LANGUAGE OverloadedStrings #-} + +{- | +Module : Rfc5280Spec +Copyright : (c) 2026 Tim Emiola +Maintainer : Tim Emiola +SPDX-License-Identifier: BSD3 +-} +module Rfc5280Spec (spec) where + +import Data.Rfc5280 +import Test.Hspec + + +spec :: Spec +spec = describe "module Data.Rfc5280" $ do + context "BasicConstraints" $ do + it "renders a non-CA certificate" $ + renderConfig notCA `shouldBe` "CA:FALSE" + it "renders a CA certificate" $ + renderConfig isCA `shouldBe` "CA:TRUE" + it "renders a CA certificate with path length" $ + renderConfig caWithPathLen `shouldBe` "CA:TRUE,pathLen3" + context "KeyUsage" $ do + it "renders multiple bits" $ + renderConfig simpleKeyUsage `shouldBe` "digitalSignature,cRLSign" + it "renders a single bit without a comma" $ + renderConfig singleKeyUsage `shouldBe` "digitalSignature" + it "renders all bits in Enum order" $ + renderConfig allKeyUsageBits + `shouldBe` "digitalSignature,nonRepudiation,keyEncipherment,dataEncipherment,keyAgreement,keyCertSign,cRLSign,encipherOnly,decipherOnly" + context "ExtKeyUsage" $ do + it "renders multiple purposes" $ + renderConfig simpleExtKeyUsage `shouldBe` "serverAuth,codeSigning" + it "renders a single purpose without a comma" $ + renderConfig singleExtKeyUsage `shouldBe` "serverAuth" + it "renders all purposes in Enum order" $ + renderConfig allExtKeyUsagePurposes + `shouldBe` "serverAuth,clientAuth,codeSigning,emailProtection,timeStamping,OCSPSigning,anyExtendedKeyUsage" + context "SubjectKeyIdentifier" $ do + it "renders the hash method" $ + renderConfig HashMethod `shouldBe` "hash" + it "renders raw bytes" $ + renderConfig (Raw "abc") `shouldBe` "abc" + context "AuthorityKeyIdentifier" $ do + it "renders keyid:always" $ + renderConfig simpleAKI `shouldBe` "keyid:always" + it "renders keyid" $ + renderConfig keyIdOnly `shouldBe` "keyid" + it "renders issuer" $ + renderConfig issuerOnly `shouldBe` "issuer" + it "renders issuer:always" $ + renderConfig issuerAlwaysAKI `shouldBe` "issuer:always" + it "renders keyid:always and issuer:always combined" $ + renderConfig bothAlways `shouldBe` "keyid:always,issuer:always" + it "renders empty when all flags are disabled" $ + renderConfig allDisabled `shouldBe` "" + context "CertificatePolicies" $ do + it "renders a single OID" $ + renderConfig simpleCP `shouldBe` "1.2.3.4" + it "renders multiple OIDs" $ + renderConfig twoOIDs `shouldBe` "1.2.3.4,2.5.4.3" + context "mkBasicConstraints" $ do + it "accepts a non-CA without path length" $ + mkBasicConstraints False Nothing `shouldBe` Right notCA + it "accepts a CA without path length" $ + mkBasicConstraints True Nothing `shouldBe` Right isCA + it "accepts a CA with path length" $ + mkBasicConstraints True (Just 3) `shouldBe` Right caWithPathLen + it "rejects a non-CA with path length" $ + mkBasicConstraints False (Just 0) `shouldBe` Left PathLenWithoutCA + context "mkAuthorityKeyIdentifier" $ + it "sets keyId when keyIdAlways is True" $ + mkAuthorityKeyIdentifier False True False False + `shouldBe` AuthorityKeyIdentifier + { akiKeyId = True + , akiKeyIdAlways = True + , akiIssuer = False + , akiIssuerAlways = False + } + context "mkOID" $ do + it "accepts a valid OID" $ + mkOID 1 [2, 3, 4] `shouldBe` Right (1 :| [2, 3, 4]) + it "rejects a negative first arc" $ + mkOID (-1) [] `shouldBe` Left InvalidFirstArc + it "rejects a first arc greater than 2" $ + mkOID 3 [] `shouldBe` Left InvalidFirstArc + it "rejects a negative subsequent arc" $ + mkOID 1 [-1] `shouldBe` Left NegativeArc + + +notCA :: BasicConstraints +notCA = BasicConstraints{bcIsCA = False, bcPathLength = Nothing} + + +isCA :: BasicConstraints +isCA = BasicConstraints{bcIsCA = True, bcPathLength = Nothing} + + +caWithPathLen :: BasicConstraints +caWithPathLen = BasicConstraints{bcIsCA = True, bcPathLength = Just 3} + + +simpleKeyUsage :: KeyUsage +simpleKeyUsage = fromList $ DigitalSignature :| [CRLSign] + + +singleKeyUsage :: KeyUsage +singleKeyUsage = fromList $ DigitalSignature :| [] + + +allKeyUsageBits :: KeyUsage +allKeyUsageBits = fromList $ DigitalSignature :| [NonRepudiation, KeyEncipherment, DataEncipherment, KeyAgreement, KeyCertSign, CRLSign, EncipherOnly, DecipherOnly] + + +simpleExtKeyUsage :: ExtKeyUsage +simpleExtKeyUsage = fromList $ ServerAuth :| [CodeSigning] + + +singleExtKeyUsage :: ExtKeyUsage +singleExtKeyUsage = fromList $ ServerAuth :| [] + + +allExtKeyUsagePurposes :: ExtKeyUsage +allExtKeyUsagePurposes = fromList $ ServerAuth :| [ClientAuth, CodeSigning, EmailProtection, TimeStamping, OCSPSigning, AnyExtendedKeyUsage] + + +simpleAKI :: AuthorityKeyIdentifier +simpleAKI = AuthorityKeyIdentifier{akiKeyId = True, akiKeyIdAlways = True, akiIssuer = False, akiIssuerAlways = False} + + +keyIdOnly :: AuthorityKeyIdentifier +keyIdOnly = AuthorityKeyIdentifier{akiKeyId = True, akiKeyIdAlways = False, akiIssuer = False, akiIssuerAlways = False} + + +issuerOnly :: AuthorityKeyIdentifier +issuerOnly = AuthorityKeyIdentifier{akiKeyId = False, akiKeyIdAlways = False, akiIssuer = True, akiIssuerAlways = False} + + +issuerAlwaysAKI :: AuthorityKeyIdentifier +issuerAlwaysAKI = AuthorityKeyIdentifier{akiKeyId = False, akiKeyIdAlways = False, akiIssuer = False, akiIssuerAlways = True} + + +bothAlways :: AuthorityKeyIdentifier +bothAlways = AuthorityKeyIdentifier{akiKeyId = False, akiKeyIdAlways = True, akiIssuer = False, akiIssuerAlways = True} + + +allDisabled :: AuthorityKeyIdentifier +allDisabled = AuthorityKeyIdentifier{akiKeyId = False, akiKeyIdAlways = False, akiIssuer = False, akiIssuerAlways = False} + + +simpleCP :: CertificatePolicies +simpleCP = mkCertificatePolicies (1 :| [2, 3, 4]) [] + + +twoOIDs :: CertificatePolicies +twoOIDs = mkCertificatePolicies (1 :| [2, 3, 4]) [2 :| [5, 4, 3]] diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,46 @@ +{- | +Module : Main +Copyright : (c) 2026 Tim Emiola +Maintainer : Tim Emiola +SPDX-License-Identifier: BSD3 + +Test suite entry point for data-rfc5280. +-} +module Main where + +import qualified Rfc5280.AssertSpec as Assert +import qualified Rfc5280.AuthorityInfoAccessSpec as AuthorityInfoAccess +import qualified Rfc5280.CRLDistributionPointsSpec as CRLDistributionPoints +import qualified Rfc5280.GeneralNameSpec as GeneralName +import qualified Rfc5280.HasOIDSpec as HasOID +import qualified Rfc5280.InhibitAnyPolicySpec as InhibitAnyPolicy +import qualified Rfc5280.IssuerAltNameSpec as IssuerAltName +import qualified Rfc5280.NameConstraintsSpec as NameConstraints +import qualified Rfc5280.PolicyMappingsSpec as PolicyMappings +import qualified Rfc5280.SubjectAltNameSpec as SubjectAltName +import qualified Rfc5280Spec as Extension +import System.IO + ( BufferMode (..) + , hSetBuffering + , stderr + , stdout + ) +import Test.Hspec + + +main :: IO () +main = do + hSetBuffering stdout NoBuffering + hSetBuffering stderr NoBuffering + hspec $ do + Assert.spec + Extension.spec + AuthorityInfoAccess.spec + CRLDistributionPoints.spec + GeneralName.spec + HasOID.spec + InhibitAnyPolicy.spec + IssuerAltName.spec + NameConstraints.spec + PolicyMappings.spec + SubjectAltName.spec