Merge pull request #75 from ocheron/hostname-matching

Certificate name validation

x509-validation/Data/X509/Validation.hs

@@ -33,6 +33,7 @@ import Control.Applicative
 import Control.Monad (when)
 import Data.Default.Class
 import Data.ASN1.Types
+import Data.Char (toLower)
 import Data.X509
 import Data.X509.CertificateStore
 import Data.X509.Validation.Signature
@@ -330,42 +331,47 @@ getNames cert = (commonName >>= asn1CharacterToString, altNames)
 validateCertificateName :: HostName -> Certificate -> [FailedReason]
 validateCertificateName fqhn cert
     | not $ null altNames =
-        findMatch [] $ map (matchDomain . splitDot) altNames
+        findMatch [] $ map matchDomain altNames
     | otherwise =
         case commonName of
             Nothing -> [NoCommonName]
-            Just cn -> findMatch [] $ [matchDomain $ splitDot $ cn]
+            Just cn -> findMatch [] $ [matchDomain cn]
   where (commonName, altNames) = getNames cert
 
         findMatch :: [FailedReason] -> [[FailedReason]] -> [FailedReason]
         findMatch _   []      = [NameMismatch fqhn]
         findMatch _   ([]:_)  = []
         findMatch acc (_ :xs) = findMatch acc xs
 
-        matchDomain :: [String] -> [FailedReason]
-        matchDomain l
-            | length (filter (== "") l) > 0 = [InvalidName (intercalate "." l)]
-            | head l == "*"                 = wildcardMatch (reverse $ drop 1 l)
-            | l == splitDot fqhn            = [] -- success: we got a match
-            | otherwise                     = [NameMismatch fqhn]
+        matchDomain :: String -> [FailedReason]
+        matchDomain name = case splitDot name of
+            l | any (== "") l       -> [InvalidName name]
+              | head l == "*"       -> wildcardMatch (drop 1 l)
+              | l == splitDot fqhn  -> [] -- success: we got a match
+              | otherwise           -> [NameMismatch fqhn]
 
-        -- only 1 wildcard is valid, and if multiples are present
+        -- A wildcard matches a single domain name component.
+        --
+        -- e.g. *.server.com will match www.server.com but not www.m.server.com
+        --
+        -- Only 1 wildcard is valid and only for the left-most component. If
+        -- used at other positions or if multiples are present
         -- they won't have a wildcard meaning but will be match as normal star
         -- character to the fqhn and inevitably will fail.
         --
         -- e.g. *.*.server.com will try to litteraly match the '*' subdomain of server.com
         --
         -- Also '*' is not accepted as a valid wildcard
         wildcardMatch l
-            | null l                                         = [InvalidWildcard] -- '*' is always invalid
-            | l == take (length l) (reverse $ splitDot fqhn) = [] -- success: we got a match
-            | otherwise                                      = [NameMismatch fqhn]
+            | null l                      = [InvalidWildcard] -- '*' is always invalid
+            | l == drop 1 (splitDot fqhn) = [] -- success: we got a match
+            | otherwise                   = [NameMismatch fqhn]
 
         splitDot :: String -> [String]
         splitDot [] = [""]
         splitDot x  =
             let (y, z) = break (== '.') x in
-            y : (if z == "" then [] else splitDot $ drop 1 z)
+            map toLower y : (if z == "" then [] else splitDot $ drop 1 z)
 
 
 -- | return true if the 'subject' certificate's issuer match