diff --git a/idn.cabal b/idn.cabal --- a/idn.cabal +++ b/idn.cabal @@ -1,6 +1,6 @@ cabal-version: 2.2 name: idn -version: 0.1.0.0 +version: 0.1.1.0 synopsis: Pure Haskell IDN and Punycode implementation description: Pure Haskell implementation of Internationalized Domain Names (IDN) @@ -9,7 +9,7 @@ license: BSD-3-Clause license-file: LICENSE author: Ian Duncan -maintainer: team@fractal.example +maintainer: ian@iankduncan.com category: Text, Web build-type: Simple tested-with: GHC ==9.6.6 diff --git a/src/Data/Text/IDN.hs b/src/Data/Text/IDN.hs --- a/src/Data/Text/IDN.hs +++ b/src/Data/Text/IDN.hs @@ -112,9 +112,16 @@ -- | Process a single label to ASCII form. processLabelToASCII :: Label -> Either IDNError Label -processLabelToASCII (ALabel t) = - -- Already ASCII, validate it - validateLabel t >> return (ALabel t) +processLabelToASCII (ALabel t) + | "xn--" `T.isPrefixOf` t = do + -- It's a Punycode A-label, validate it by decoding and re-encoding + -- This uses processLabelToUnicode which validates Punycode properly + ulabel <- processLabelToUnicode (ALabel t) + -- Then re-process back to ASCII to get a validated A-label + processLabelToASCII ulabel + | otherwise = + -- Regular ASCII label, just validate + validateLabel t >> return (ALabel t) processLabelToASCII (ULabel t) | isAsciiLabel t = do @@ -144,13 +151,36 @@ processLabelToUnicode (ALabel t) | "xn--" `T.isPrefixOf` t = do -- Punycode A-label, decode it + -- RFC 5891 Section 5.4: A-labels must be lowercase let encoded = T.drop 4 t - decoded <- case decodePunycode encoded of + encodedLower = T.toLower encoded + + -- Check if original was already lowercase (uppercase in Punycode is invalid) + if encoded /= encodedLower + then Left (PunycodeDecodeError encoded "A-label must be lowercase") + else pure () + + decoded <- case decodePunycode encodedLower of Left err -> Left (PunycodeDecodeError encoded (T.pack (show err))) Right d -> Right d - validateLabel decoded - return (ULabel decoded) - + + -- Punycode-encoded labels must contain at least one non-ASCII character + -- If the decoded result is pure ASCII, it shouldn't have been encoded + if isAsciiLabel decoded + then Left (PunycodeDecodeError encoded "Punycode used for pure ASCII label") + else pure () + + -- RFC 5891 Section 4.4: Verify round-trip consistency + -- Re-encode and check it matches the lowercase normalized form + reencoded <- case encodePunycode decoded of + Left err -> Left (PunycodeDecodeError decoded (T.pack (show err))) + Right e -> Right e + if reencoded /= encodedLower + then Left (PunycodeDecodeError encoded "Round-trip re-encoding failed") + else do + validateLabel decoded + return (ULabel decoded) + | otherwise = -- Pure ASCII label, validate and return validateLabel t >> return (ALabel t) diff --git a/src/Data/Text/IDN/Internal/Unicode.hs b/src/Data/Text/IDN/Internal/Unicode.hs --- a/src/Data/Text/IDN/Internal/Unicode.hs +++ b/src/Data/Text/IDN/Internal/Unicode.hs @@ -220,7 +220,7 @@ -- Explicit CONTEXTJ code points | cp == 0x200C = CONTEXTJ -- Zero Width Non-Joiner | cp == 0x200D = CONTEXTJ -- Zero Width Joiner - -- Explicit CONTEXTO code points + -- Explicit CONTEXTO code points | cp == 0x00B7 = CONTEXTO -- Middle Dot | cp == 0x0375 = CONTEXTO -- Greek Lower Numeral Sign (Keraia) | cp == 0x05F3 = CONTEXTO -- Hebrew Punctuation Geresh @@ -228,6 +228,24 @@ | cp == 0x30FB = CONTEXTO -- Katakana Middle Dot | cp >= 0x0660 && cp <= 0x0669 = CONTEXTO -- Arabic-Indic Digits | cp >= 0x06F0 && cp <= 0x06F9 = CONTEXTO -- Extended Arabic-Indic Digits + -- RFC 5892 Section 2.6: Exceptions (PVALID) + | cp == 0x00DF = PVALID -- LATIN SMALL LETTER SHARP S + | cp == 0x03C2 = PVALID -- GREEK SMALL LETTER FINAL SIGMA + | cp == 0x06FD = PVALID -- ARABIC SIGN SINDHI AMPERSAND + | cp == 0x06FE = PVALID -- ARABIC SIGN SINDHI POSTPOSITION MEN + | cp == 0x0F0B = PVALID -- TIBETAN MARK INTERSYLLABIC TSHEG + | cp == 0x3007 = PVALID -- IDEOGRAPHIC NUMBER ZERO + -- RFC 5892 Section 2.6: Exceptions (DISALLOWED) + | cp == 0x0640 = DISALLOWED -- ARABIC TATWEEL + | cp == 0x07FA = DISALLOWED -- NKO LAJANYALAN + | cp == 0x302E = DISALLOWED -- HANGUL SINGLE DOT TONE MARK + | cp == 0x302F = DISALLOWED -- HANGUL DOUBLE DOT TONE MARK + | cp == 0x3031 = DISALLOWED -- VERTICAL KANA REPEAT MARK + | cp == 0x3032 = DISALLOWED -- VERTICAL KANA REPEAT WITH VOICED SOUND MARK + | cp == 0x3033 = DISALLOWED -- VERTICAL KANA REPEAT MARK UPPER HALF + | cp == 0x3034 = DISALLOWED -- VERTICAL KANA REPEAT WITH VOICED SOUND MARK UPPER HALF + | cp == 0x3035 = DISALLOWED -- VERTICAL KANA REPEAT MARK LOWER HALF + | cp == 0x303B = DISALLOWED -- VERTICAL IDEOGRAPHIC ITERATION MARK -- ASCII exceptions that are DISALLOWED (per RFC 5892) | cp `elem` [0x0020, 0x007F] = DISALLOWED -- Space and DEL -- ASCII printable range (0x21-0x7E) is mostly PVALID @@ -313,11 +331,24 @@ parseScriptName "Greek" = Right Greek parseScriptName "Hiragana" = Right Hiragana parseScriptName "Katakana" = Right Katakana +parseScriptName "Han" = Right Han parseScriptName "Hangul" = Right Hangul parseScriptName "Latin" = Right Latin parseScriptName "Cyrillic" = Right Cyrillic parseScriptName "Devanagari" = Right Devanagari +parseScriptName "Bengali" = Right Bengali +parseScriptName "Gurmukhi" = Right Gurmukhi +parseScriptName "Gujarati" = Right Gujarati +parseScriptName "Oriya" = Right Oriya +parseScriptName "Tamil" = Right Tamil +parseScriptName "Telugu" = Right Telugu +parseScriptName "Kannada" = Right Kannada +parseScriptName "Malayalam" = Right Malayalam parseScriptName "Thai" = Right Thai +parseScriptName "Lao" = Right Lao +parseScriptName "Tibetan" = Right Tibetan +parseScriptName "Myanmar" = Right Myanmar +parseScriptName "Georgian" = Right Georgian parseScriptName _ = Right OtherScript isComment :: T.Text -> Bool diff --git a/src/Data/Text/IDN/Internal/Validation.hs b/src/Data/Text/IDN/Internal/Validation.hs --- a/src/Data/Text/IDN/Internal/Validation.hs +++ b/src/Data/Text/IDN/Internal/Validation.hs @@ -51,11 +51,21 @@ _ -> pure () -- | ZERO WIDTH NON-JOINER (U+200C) - RFC 5892 Appendix A.1 +-- Allowed after Virama OR in Arabic script contexts matching the regexp validateZWNJ :: Text -> Int -> Char -> Either IDNError () validateZWNJ label pos c = - if pos > 0 && isVirama (T.index label (pos - 1)) - then pure () - else Left (InvalidContext c ZWNJRule pos label) + let precededByVirama = pos > 0 && isVirama (T.index label (pos - 1)) + -- Arabic context: check if surrounded by Arabic joining characters + -- Per W3C ALREQ, ZWNJ is used in Arabic between joining letters + inArabicContext = pos > 0 && pos < T.length label - 1 && + isArabicJoining (T.index label (pos - 1)) && + isArabicJoining (T.index label (pos + 1)) + in if precededByVirama || inArabicContext + then pure () + else Left (InvalidContext c ZWNJRule pos label) + where + -- Characters in Arabic script that can join (simplified check) + isArabicJoining ch = scriptOf ch == Just Arabic && ord ch >= 0x0620 && ord ch <= 0x06FF -- | ZERO WIDTH JOINER (U+200D) - RFC 5892 Appendix A.2 validateZWJ :: Text -> Int -> Char -> Either IDNError () @@ -74,18 +84,22 @@ else Left (InvalidContext c MiddleDotRule pos label) -- | GREEK LOWER NUMERAL SIGN (U+0375) - RFC 5892 Appendix A.4 +-- The script of the following character MUST be Greek validateGreekKeraia :: Text -> Int -> Char -> Either IDNError () validateGreekKeraia label pos c = - let hasGreek = T.any (\ch -> scriptOf ch == Just Greek) label - in if hasGreek + let followedByGreek = pos < T.length label - 1 && + scriptOf (T.index label (pos + 1)) == Just Greek + in if followedByGreek then pure () else Left (InvalidContext c GreekKeraiaRule pos label) -- | HEBREW PUNCTUATION (U+05F3, U+05F4) - RFC 5892 Appendix A.5/A.6 +-- The script of the preceding character MUST be Hebrew validateHebrewPunctuation :: Text -> Int -> Char -> Either IDNError () validateHebrewPunctuation label pos c = - let hasHebrew = T.any (\ch -> scriptOf ch == Just Hebrew) label - in if hasHebrew + let precededByHebrew = pos > 0 && + scriptOf (T.index label (pos - 1)) == Just Hebrew + in if precededByHebrew then pure () else Left (InvalidContext c HebrewGereshRule pos label) diff --git a/src/Data/Text/IDN/Types.hs b/src/Data/Text/IDN/Types.hs --- a/src/Data/Text/IDN/Types.hs +++ b/src/Data/Text/IDN/Types.hs @@ -202,16 +202,24 @@ -- Left EmptyLabel mkDomainName :: Text -> Either IDNError DomainName mkDomainName text = do - if T.null text + if T.null text then Left EmptyLabel else if T.length text > 253 then Left (TotalDomainTooLong (T.length text) 253) else do - let labelTexts = T.splitOn "." text + -- RFC 3490 Section 3.1: Normalize alternative dot separators + -- U+3002 IDEOGRAPHIC FULL STOP, U+FF0E FULLWIDTH FULL STOP, U+FF61 HALFWIDTH IDEOGRAPHIC FULL STOP + let normalized = T.map normalizeDot text + labelTexts = T.splitOn "." normalized labelList <- traverse mkLabel labelTexts case NE.nonEmpty labelList of Nothing -> Left EmptyLabel Just ne -> Right (DomainName ne) + where + normalizeDot '\x3002' = '.' -- IDEOGRAPHIC FULL STOP + normalizeDot '\xFF0E' = '.' -- FULLWIDTH FULL STOP + normalizeDot '\xFF61' = '.' -- HALFWIDTH IDEOGRAPHIC FULL STOP + normalizeDot c = c -- | IDNA2008 code point status per RFC 5892. --