diff --git a/Data/X509/Validation.hs b/Data/X509/Validation.hs --- a/Data/X509/Validation.hs +++ b/Data/X509/Validation.hs @@ -1,3 +1,6 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ViewPatterns #-} + -- | -- Module : Data.X509.Validation -- License : BSD-style @@ -35,14 +38,17 @@ module Data.X509.Validation.Signature, ) where -import Control.Applicative import Control.Monad (when) import Data.ASN1.Types +import Data.Bits +import Data.ByteString (unpack) import Data.Char (toLower) import Data.Default import Data.Hourglass +import Data.IP (IPv4, IPv6, toIPv4, toIPv6) import Data.List import Data.Maybe +import Data.Word (Word8) import Data.X509 import Data.X509.CertificateStore import Data.X509.Validation.Cache @@ -50,6 +56,7 @@ import Data.X509.Validation.Signature import Data.X509.Validation.Types import System.Hourglass +import Text.Read (readMaybe) -- | Possible reason of certificate and chain failure. -- @@ -403,10 +410,47 @@ unAltName (AltNameDNS s) = Just s unAltName _ = Nothing +data IPAddress + = IPv4Address IPv4 + | IPv6Address IPv6 + deriving (Eq) + +getIPs :: Certificate -> [IPAddress] +getIPs cert = fromMaybe [] (toAltName <$> (extensionGet $ certExtensions cert)) + where + toAltName (ExtSubjectAltName names) = catMaybes $ map unAltName names + + unAltName (AltNameIP s) = case unpack s of + [a, b, c, d] -> Just $ IPv4Address $ toIPv4 $ fmap fromIntegral [a, b, c, d] + [a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p] -> + Just $ + IPv6Address $ + toIPv6 + [ fuse a b + , fuse c d + , fuse e f + , fuse g h + , fuse i j + , fuse k l + , fuse m n + , fuse o p + ] + _ -> Nothing + unAltName _ = Nothing + + fuse :: Word8 -> Word8 -> Int + fuse a b = shiftL (fromIntegral a) 8 .|. (fromIntegral b) + +parseIPAddress :: HostName -> Maybe IPAddress +parseIPAddress (readMaybe -> Just ipV4) = Just $ IPv4Address ipV4 +parseIPAddress (readMaybe -> Just ipV6) = Just $ IPv6Address ipV6 +parseIPAddress _ = Nothing + -- | Validate that the fqhn is matched by at least one name in the certificate. -- If the subjectAltname extension is present, then the certificate commonName --- is ignored, and only the DNS names, if any, in the subjectAltName are --- considered. Otherwise, the commonName from the subjectDN is used. +-- is ignored, and only the DNS names and IP Addresses, if any, in the +-- subjectAltName are considered. Otherwise, the commonName from the subjectDN +-- is used. -- -- Note that DNS names in the subjectAltName are in IDNA A-label form. If the -- destination hostname is a UTF-8 name, it must be provided to the TLS context @@ -414,7 +458,12 @@ validateCertificateName :: HostName -> Certificate -> [FailedReason] validateCertificateName fqhn cert | not $ null altNames = - findMatch [] $ map matchDomain altNames + case parseIPAddress fqhn of + Nothing -> findMatch [] $ map matchDomain altNames + Just ip -> + if elem ip (getIPs cert) + then [] + else [NameMismatch fqhn] | otherwise = case commonName of Nothing -> [NoCommonName] diff --git a/Tests/Tests.hs b/Tests/Tests.hs --- a/Tests/Tests.hs +++ b/Tests/Tests.hs @@ -17,6 +17,8 @@ import Data.X509.CertificateStore import Data.X509.Validation +import qualified Data.ByteString as BS + import Data.Hourglass import System.Hourglass @@ -513,6 +515,47 @@ , AltNameDNS "dummy2" ] +-- | Tests certificate SubjectAltName against expected IP Address, with or +-- without 'checkFQHN'. +testSubjectAltNameIP + :: IO (RData pub priv) + -- ^ Common test resources + -> BS.ByteString + -- ^ Certificate SubjectAltName + -> HostName + -- ^ Connection identification + -> Bool + -- ^ Value for 'checkFQHN' + -> [FailedReason] + -- ^ Expected validation result + -> TestTree +testSubjectAltNameIP res ip hostname check expected = testWithRes res caseName $ \rd -> do + pair <- + mkCertificate + 2 + 100 + dn + (present rd) + (ext : leafStdExts) + (CA $ intermediate rd) + (keys1 rd) + assertValidationResult rd checks hostname [pair, intermediate rd] expected + where + caseName = if null hostname then "empty" else hostname + checks = defaultChecks{checkFQHN = check} + dn = mkDn "cn-not-used" -- this CN value is to be tested too + -- (to make sure CN is *not* considered when a + -- SubjectAltName exists) + ext = + mkExtension False $ + -- wraps test value with other values + ExtSubjectAltName + [ AltNameDNS "dummy1" + , AltNameRFC822 "test@example.com" + , AltNameIP ip + , AltNameDNS "dummy2" + ] + -- | Tests 'checkLeafKeyUsage'. testLeafKeyUsage :: IO (RData pub priv) @@ -797,6 +840,52 @@ "cn-not-used" True [NameMismatch "cn-not-used"] + , testGroup + "IP addresses" + [ testSubjectAltNameIP res (BS.pack [10, 0, 0, 1]) "10.0.0.1" True [] + , testSubjectAltNameIP + res + (BS.pack [10, 0, 0, 1]) + "10.0.0.2" + True + [NameMismatch "10.0.0.2"] + , testSubjectAltNameIP + res + (BS.pack [10, 0, 0, 1]) + "10.0.0.1.example.com" + True + [NameMismatch "10.0.0.1.example.com"] + , testSubjectAltNameIP + res + (BS.pack [10, 0, 0, 1]) + "266.0.0.1" + True + [NameMismatch "266.0.0.1"] -- 266 read in Word8 is 10 + , testSubjectAltNameIP + res + (BS.pack [0x20, 0x01, 0x0d, 0xb8, 0x85, 0xa3, 0, 0, 0, 0, 0x8a, 0x2e, 0x03, 0x70, 0x73, 0x34]) + "2001:0db8:85a3:0000:0000:8a2e:0370:7334" + True + [] + , testSubjectAltNameIP + res + (BS.pack [0x20, 0x01, 0x0d, 0xb8, 0x85, 0xa3, 0, 0, 0, 0, 0x8a, 0x2e, 0x03, 0x70, 0x73, 0x34]) + "2001:0db8:85a3::8a2e:0370:7334" + True + [] + , testSubjectAltNameIP + res + (BS.pack [0x20, 0x01, 0x0d, 0xb8, 0x85, 0xa3, 0, 0, 0, 0, 0x8a, 0x2e, 0x03, 0x70, 0x73, 0x34]) + "2001:0db8:85a3:0:0:8a2e:0370:7334" + True + [] + , testSubjectAltNameIP + res + (BS.pack [0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1]) + "::1" + True + [] + ] , testGroup "disabled" [ testSubjectAltName res "www.example.com" "www.example.com" False [] diff --git a/crypton-x509-validation.cabal b/crypton-x509-validation.cabal --- a/crypton-x509-validation.cabal +++ b/crypton-x509-validation.cabal @@ -1,5 +1,5 @@ Name: crypton-x509-validation -version: 1.6.13 +version: 1.6.14 Description: X.509 Certificate and CRL validation. please see README License: BSD3 License-file: LICENSE @@ -28,6 +28,7 @@ , crypton-x509 >= 1.7.5 , crypton-x509-store >= 1.6 , crypton >= 0.24 + , iproute >= 1.2.2 Exposed-modules: Data.X509.Validation Other-modules: Data.X509.Validation.Signature Data.X509.Validation.Fingerprint