idn 0.1.0.0 → 0.1.1.0
raw patch · 5 files changed
+102/−19 lines, 5 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
Files
- idn.cabal +2/−2
- src/Data/Text/IDN.hs +37/−7
- src/Data/Text/IDN/Internal/Unicode.hs +32/−1
- src/Data/Text/IDN/Internal/Validation.hs +21/−7
- src/Data/Text/IDN/Types.hs +10/−2
idn.cabal view
@@ -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
src/Data/Text/IDN.hs view
@@ -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)
src/Data/Text/IDN/Internal/Unicode.hs view
@@ -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
src/Data/Text/IDN/Internal/Validation.hs view
@@ -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)
src/Data/Text/IDN/Types.hs view
@@ -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. --