diff --git a/Data/Text/IDN/IDNA.chs b/Data/Text/IDN/IDNA.chs deleted file mode 100644 --- a/Data/Text/IDN/IDNA.chs +++ /dev/null @@ -1,117 +0,0 @@ -{-# LANGUAGE ForeignFunctionInterface #-} - --- Copyright (C) 2010 John Millikin --- --- This program is free software: you can redistribute it and/or modify --- it under the terms of the GNU General Public License as published by --- the Free Software Foundation, either version 3 of the License, or --- any later version. --- --- This program is distributed in the hope that it will be useful, --- but WITHOUT ANY WARRANTY; without even the implied warranty of --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the --- GNU General Public License for more details. --- --- You should have received a copy of the GNU General Public License --- along with this program. If not, see . - -module Data.Text.IDN.IDNA - ( Flags (..) - , Error - , defaultFlags - , toASCII - , toUnicode - ) where - -import Control.Exception (ErrorCall(..), throwIO) -import qualified Data.ByteString as B -import qualified Data.Text as T - -import Foreign -import Foreign.C - -import Data.Text.IDN.Internal - -#include -#include - -{# enum Idna_rc {} with prefix = "IDNA_" #} - -{# enum Idna_flags {} with prefix = "IDNA_" #} - -data Flags = Flags - { verifySTD3 :: Bool - -- ^ Check output to make sure it is a STD3-conforming host name - - , allowUnassigned :: Bool - -- ^ Allow unassigned Unicode code points - } - deriving (Show, Eq) - --- | @defaultFlags = Flags True False@ -defaultFlags :: Flags -defaultFlags = Flags True False - --- | Convert a Unicode domain name to an ASCII 'B.ByteString'. The domain --- name may contain several labels, separated by periods. --- --- @toASCII@ never alters a sequence of code points that are all in the --- ASCII range to begin with (although it could fail). Applying @toASCII@ --- multiple times gives the same result as applying it once. -toASCII :: Flags -> T.Text -> Either Error B.ByteString -toASCII flags input = - unsafePerformIO $ - withArray0 0 (toUCS4 input) $ \buf -> - let c_flags = encodeFlags flags in - alloca $ \outBufPtr -> do - c_rc <- {# call idna_to_ascii_4z #} - (castPtr buf) outBufPtr c_flags - - let rc = fromIntegral c_rc - if rc /= fromEnum SUCCESS - then return (Left (cToError c_rc)) - else do - outBuf <- peek outBufPtr - bytes <- B.packCString outBuf - {# call idn_free #} (castPtr outBuf) - return (Right bytes) - --- | Convert a possibly ACE-encoded domain name to Unicode. The domain --- name may contain several labels, separated by dots. --- --- Aside from memory allocation failure, @toUnicode@ always succeeds. --- If the input cannot be decoded, it is returned unchanged. -toUnicode :: Flags -> B.ByteString -> T.Text -toUnicode flags input = - unsafePerformIO $ - B.useAsCString input $ \buf -> - let c_flags = encodeFlags flags in - alloca $ \outBufPtr -> do - c_rc <- {# call idna_to_unicode_8z4z #} - (castPtr buf) outBufPtr c_flags - - let rc = fromIntegral c_rc - if rc == fromEnum MALLOC_ERROR - then throwError c_rc - else do - outBuf <- peek outBufPtr - ucs4 <- peekArray0 0 (castPtr outBuf) - {# call idn_free #} (castPtr outBuf) - return (fromUCS4 ucs4) - -encodeFlags :: Flags -> CInt -encodeFlags flags = foldr (.|.) 0 bits where - bitAt f e = if f flags then 0 else fromIntegral (fromEnum e) - bits = [ bitAt verifySTD3 USE_STD3_ASCII_RULES - , bitAt allowUnassigned ALLOW_UNASSIGNED - ] - -cToError :: CInt -> Error -cToError rc = IDNAError (T.pack str) where - c_strerror = {# call idna_strerror #} - str = unsafePerformIO (c_strerror rc >>= peekCString) - -throwError :: CInt -> IO a -throwError rc = do - str <- peekCString =<< {# call idna_strerror #} rc - throwIO (ErrorCall str) diff --git a/Data/Text/IDN/Internal.hs b/Data/Text/IDN/Internal.hs deleted file mode 100644 --- a/Data/Text/IDN/Internal.hs +++ /dev/null @@ -1,35 +0,0 @@ --- Copyright (C) 2010 John Millikin --- --- This program is free software: you can redistribute it and/or modify --- it under the terms of the GNU General Public License as published by --- the Free Software Foundation, either version 3 of the License, or --- any later version. --- --- This program is distributed in the hope that it will be useful, --- but WITHOUT ANY WARRANTY; without even the implied warranty of --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the --- GNU General Public License for more details. --- --- You should have received a copy of the GNU General Public License --- along with this program. If not, see . - -module Data.Text.IDN.Internal - ( Error (..) - , toUCS4 - , fromUCS4 - ) where - -import qualified Data.Text as T -import Data.Char (chr, ord) - -import qualified Foreign as F - -data Error = IDNAError T.Text - | StringPrepError T.Text - deriving (Show, Eq) - -toUCS4 :: T.Text -> [F.Word32] -toUCS4 = map (fromIntegral . ord) . T.unpack - -fromUCS4 :: [F.Word32] -> T.Text -fromUCS4 = T.pack . map (chr . fromIntegral) diff --git a/Data/Text/IDN/Punycode.chs b/Data/Text/IDN/Punycode.chs deleted file mode 100644 --- a/Data/Text/IDN/Punycode.chs +++ /dev/null @@ -1,143 +0,0 @@ -{-# LANGUAGE ForeignFunctionInterface #-} - --- Copyright (C) 2010 John Millikin --- --- This program is free software: you can redistribute it and/or modify --- it under the terms of the GNU General Public License as published by --- the Free Software Foundation, either version 3 of the License, or --- any later version. --- --- This program is distributed in the hope that it will be useful, --- but WITHOUT ANY WARRANTY; without even the implied warranty of --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the --- GNU General Public License for more details. --- --- You should have received a copy of the GNU General Public License --- along with this program. If not, see . - --- | Punycode is a simple and efficient transfer encoding syntax designed --- for use with Internationalized Domain Names in Applications (IDNA). It --- uniquely and reversibly transforms a Unicode string into ASCII. ASCII --- characters in the Unicode string are represented literally, and non-ASCII --- characters are represented by ASCII characters that are allowed in host --- name labels (letters, digits, and hyphens). -module Data.Text.IDN.Punycode - ( encode - , decode - ) where - -import Control.Exception (ErrorCall(..), throwIO) -import Control.Monad (unless) -import Data.List (unfoldr) -import qualified Data.ByteString as B -import qualified Data.Text as T - -import Foreign -import Foreign.C - -import Data.Text.IDN.Internal (toUCS4, fromUCS4) - -#include - --- | Encode unicode into an ASCII-only 'B.ByteString'. If provided, the --- case predicate indicates whether to uppercase the corresponding character --- after decoding. -encode :: T.Text - -> Maybe (Integer -> Bool) - -> B.ByteString -encode input maybeIsCase = unsafePerformIO io where - inSize = T.length input - - flags = flip fmap maybeIsCase $ \isCase -> let - step idx = Just (fromBool (isCase idx), idx + 1) - in unfoldr step 0 - - io = maybeWith (withArray . take inSize) flags impl - - impl caseBuf = withArray (toUCS4 input) (loop caseBuf inSize . castPtr) - - loop caseBuf outMax inBuf = do - res <- tryEnc caseBuf outMax inBuf - case res of - Nothing -> loop caseBuf (outMax + 50) inBuf - Just (Right bytes) -> return bytes - Just (Left rc) -> cToError rc - - tryEnc caseBuf outMax inBuf = - allocaBytes outMax $ \outBuf -> - alloca $ \outSizeBuf -> do - poke outSizeBuf (fromIntegral outMax) - c_rc <- {# call punycode_encode #} - (fromIntegral inSize) - inBuf - caseBuf - outSizeBuf - outBuf - - let rc = fromIntegral c_rc - if rc == fromEnum OVERFLOW - then return Nothing - else if rc == fromEnum SUCCESS - then do - outSize <- peek outSizeBuf - bytes <- peekOut outBuf outSize - return (Just (Right bytes)) - else return (Just (Left c_rc)) - - peekOut outBuf outSize = B.packCStringLen cstr where - cstr = (outBuf, fromIntegral outSize) - --- | Decode a 'B.ByteString' into unicode. The second component of the --- result is a case predicate; it indicates whether a particular character --- position of the result string should be upper-cased. --- --- Returns 'Nothing' if the input is invalid. -decode :: B.ByteString - -> Maybe (T.Text, (Integer -> Bool)) -decode input = unsafePerformIO $ - let outMax = B.length input in - B.useAsCStringLen input $ \(inBuf, inSize) -> - alloca $ \outSizeBuf -> - allocaArray outMax $ \outBuf -> do - - flagForeign <- mallocForeignPtrArray outMax - poke outSizeBuf (fromIntegral outMax) - - c_rc <- withForeignPtr flagForeign $ \flagBuf -> - {# call punycode_decode #} - (fromIntegral inSize) - inBuf - outSizeBuf - outBuf - flagBuf - - let rc = fromIntegral c_rc - if rc == fromEnum BAD_INPUT - then return Nothing - else do - unless (rc == fromEnum SUCCESS) (cToError c_rc) - - outSize <- peek outSizeBuf - ucs4 <- peekArray (fromIntegral outSize) (castPtr outBuf) - let text = fromUCS4 ucs4 - return (Just (text, checkCaseFlag flagForeign outSize)) - -type SizeT = {# type size_t #} - -{# enum Punycode_status {} with prefix = "PUNYCODE_" #} - -checkCaseFlag :: ForeignPtr CUChar -> SizeT -> Integer -> Bool -checkCaseFlag ptr csize = checkIdx where - intsize = toInteger csize - checkIdx idx | idx < 0 = False - checkIdx idx | idx >= intsize = False - checkIdx idx = - unsafePerformIO $ - withForeignPtr ptr $ \buf -> do - cuchar <- peekElemOff buf (fromInteger idx) - return (toBool cuchar) - -cToError :: CInt -> IO a -cToError rc = do - str <- peekCString =<< {# call punycode_strerror #} rc - throwIO (ErrorCall str) diff --git a/Data/Text/IDN/StringPrep.chs b/Data/Text/IDN/StringPrep.chs deleted file mode 100644 --- a/Data/Text/IDN/StringPrep.chs +++ /dev/null @@ -1,147 +0,0 @@ -{-# LANGUAGE ForeignFunctionInterface #-} - --- Copyright (C) 2010 John Millikin --- --- This program is free software: you can redistribute it and/or modify --- it under the terms of the GNU General Public License as published by --- the Free Software Foundation, either version 3 of the License, or --- any later version. --- --- This program is distributed in the hope that it will be useful, --- but WITHOUT ANY WARRANTY; without even the implied warranty of --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the --- GNU General Public License for more details. --- --- You should have received a copy of the GNU General Public License --- along with this program. If not, see . - -module Data.Text.IDN.StringPrep - ( - -- * Stringprep - Flags (..) - , Error - , defaultFlags - , stringprep - - -- * Profiles - , Profile - , iscsi - , kerberos5 - , nameprep - , sasl - , saslAnonymous - , trace - , xmppNode - , xmppResource - ) where - -import qualified Data.ByteString as B -import qualified Data.Text as T -import qualified Data.Text.Encoding as TE - -import Foreign -import Foreign.C - -import Data.Text.IDN.Internal - -#include - -{# pointer *Stringprep_profile as Profile newtype #} - -{# enum Stringprep_rc {} with prefix = "STRINGPREP_" #} - -{# enum Stringprep_profile_flags {} with prefix = "STRINGPREP_" #} - -data Flags = Flags - { enableNFKC :: Bool - -- ^ Enable the NFKC normalization, as well as selecting the NFKC - -- case folding tables. Usually the profile specifies BIDI and NFKC - -- settings, and applications should not override it unless in - -- special situations. - - , enableBidi :: Bool - -- ^ Enable the BIDI step. Usually the profile specifies BIDI and - -- NFKC settings, and applications should not override it unless in - -- special situations. - - , allowUnassigned :: Bool - -- ^ If false, 'stringprep' will return an error if the input - -- contains characters not assigned to the profile. - } - deriving (Show, Eq) - --- | @defaultFlags = Flags True True False@ -defaultFlags :: Flags -defaultFlags = Flags True True False - -stringprep :: Profile -> Flags -> T.Text -> Either Error T.Text -stringprep profile flags input = unsafePerformIO io where - io = B.useAsCString utf8 (loop inSize) - - utf8 = TE.encodeUtf8 input - c_flags = encodeFlags flags - inSize = B.length utf8 + 1 -- + 1 for NUL - - loop outSize inBuf = do - res <- tryPrep outSize inBuf - case res of - Nothing -> loop (outSize + 50) inBuf - Just (Right bytes) -> return (Right (TE.decodeUtf8 bytes)) - Just (Left rc) -> return (Left (cToError rc)) - - tryPrep outSize inBuf = allocaBytes outSize $ \outBuf -> do - copyArray outBuf inBuf inSize - let csize = fromIntegral outSize - c_rc <- {# call stringprep as c_stringprep #} - outBuf csize c_flags profile - - let rc = fromIntegral c_rc - if rc == fromEnum TOO_SMALL_BUFFER - then return Nothing - else if rc == fromEnum OK - then fmap (Just . Right) (B.packCString outBuf) - else return (Just (Left c_rc)) - -encodeFlags :: Flags -> CInt -encodeFlags flags = foldr (.|.) 0 bits where - bitAt f e = if f flags then 0 else fromIntegral (fromEnum e) - bits = [ bitAt enableNFKC NO_NFKC - , bitAt enableBidi NO_BIDI - , bitAt allowUnassigned NO_UNASSIGNED - ] - -cToError :: CInt -> Error -cToError rc = StringPrepError (T.pack str) where - c_strerror = {# call stringprep_strerror #} - str = unsafePerformIO (c_strerror rc >>= peekCString) - --- | iSCSI (RFC 3722) -foreign import ccall "&stringprep_iscsi" - iscsi :: Profile - --- | Kerberos 5 -foreign import ccall "&stringprep_kerberos5" - kerberos5 :: Profile - --- | Nameprep (RFC 3491) -foreign import ccall "&stringprep_nameprep" - nameprep :: Profile - --- | SASLprep (RFC 4013) -foreign import ccall "&stringprep_saslprep" - sasl :: Profile - --- | Draft SASL ANONYMOUS -foreign import ccall "&stringprep_plain" - saslAnonymous :: Profile - -foreign import ccall "&stringprep_trace" - trace :: Profile - --- | XMPP node (RFC 3920) -foreign import ccall "&stringprep_xmpp_nodeprep" - xmppNode :: Profile - --- | XMPP resource (RFC 3920) -foreign import ccall "&stringprep_xmpp_resourceprep" - xmppResource :: Profile diff --git a/gnuidn.cabal b/gnuidn.cabal --- a/gnuidn.cabal +++ b/gnuidn.cabal @@ -1,27 +1,33 @@ name: gnuidn -version: 0.2 -stability: experimental -synopsis: Bindings for GNU IDN +version: 0.2.1 license: GPL-3 license-file: license.txt author: John Millikin maintainer: jmillikin@gmail.com build-type: Simple -cabal-version: >=1.6 +cabal-version: >= 1.6 category: Codec, Text +stability: experimental +homepage: https://john-millikin.com/software/haskell-gnuidn/ bug-reports: mailto:jmillikin@gmail.com -homepage: http://john-millikin.com/software/bindings/gnuidn/ -tested-with: GHC==6.12.1 +synopsis: Bindings for GNU IDN + source-repository head - type: bazaar - location: http://john-millikin.com/software/bindings/gnuidn/ + type: git + location: https://john-millikin.com/code/haskell-gnuidn/ +source-repository this + type: git + location: https://john-millikin.com/code/haskell-gnuidn/ + tag: haskell-gnuidn_0.2.1 + library - ghc-options: -Wall + ghc-options: -Wall -O2 + hs-source-dirs: lib build-depends: - base >= 3 && < 5 + base >= 4.0 && < 5.0 , text , bytestring diff --git a/lib/Data/Text/IDN/IDNA.chs b/lib/Data/Text/IDN/IDNA.chs new file mode 100644 --- /dev/null +++ b/lib/Data/Text/IDN/IDNA.chs @@ -0,0 +1,118 @@ +{-# LANGUAGE ForeignFunctionInterface #-} + +-- Copyright (C) 2010 John Millikin +-- +-- This program is free software: you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation, either version 3 of the License, or +-- any later version. +-- +-- This program is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with this program. If not, see . + +module Data.Text.IDN.IDNA + ( Flags (..) + , Error + , defaultFlags + , toASCII + , toUnicode + ) where + +import Control.Exception (ErrorCall(..), throwIO) +import qualified Data.ByteString as B +import qualified Data.Text as T +import qualified System.IO.Unsafe as Unsafe + +import Foreign +import Foreign.C + +import Data.Text.IDN.Internal + +#include +#include + +{# enum Idna_rc {} with prefix = "IDNA_" #} + +{# enum Idna_flags {} with prefix = "IDNA_" #} + +data Flags = Flags + { verifySTD3 :: Bool + -- ^ Check output to make sure it is a STD3-conforming host name + + , allowUnassigned :: Bool + -- ^ Allow unassigned Unicode code points + } + deriving (Show, Eq) + +-- | @defaultFlags = Flags True False@ +defaultFlags :: Flags +defaultFlags = Flags True False + +-- | Convert a Unicode domain name to an ASCII 'B.ByteString'. The domain +-- name may contain several labels, separated by periods. +-- +-- @toASCII@ never alters a sequence of code points that are all in the +-- ASCII range to begin with (although it could fail). Applying @toASCII@ +-- multiple times gives the same result as applying it once. +toASCII :: Flags -> T.Text -> Either Error B.ByteString +toASCII flags input = + Unsafe.unsafePerformIO $ + withArray0 0 (toUCS4 input) $ \buf -> + let c_flags = encodeFlags flags in + alloca $ \outBufPtr -> do + c_rc <- {# call idna_to_ascii_4z #} + (castPtr buf) outBufPtr c_flags + + let rc = fromIntegral c_rc + if rc /= fromEnum SUCCESS + then return (Left (cToError c_rc)) + else do + outBuf <- peek outBufPtr + bytes <- B.packCString outBuf + {# call idn_free #} (castPtr outBuf) + return (Right bytes) + +-- | Convert a possibly ACE-encoded domain name to Unicode. The domain +-- name may contain several labels, separated by dots. +-- +-- Aside from memory allocation failure, @toUnicode@ always succeeds. +-- If the input cannot be decoded, it is returned unchanged. +toUnicode :: Flags -> B.ByteString -> T.Text +toUnicode flags input = + Unsafe.unsafePerformIO $ + B.useAsCString input $ \buf -> + let c_flags = encodeFlags flags in + alloca $ \outBufPtr -> do + c_rc <- {# call idna_to_unicode_8z4z #} + (castPtr buf) outBufPtr c_flags + + let rc = fromIntegral c_rc + if rc == fromEnum MALLOC_ERROR + then throwError c_rc + else do + outBuf <- peek outBufPtr + ucs4 <- peekArray0 0 (castPtr outBuf) + {# call idn_free #} (castPtr outBuf) + return (fromUCS4 ucs4) + +encodeFlags :: Flags -> CInt +encodeFlags flags = foldr (.|.) 0 bits where + bitAt f e = if f flags then 0 else fromIntegral (fromEnum e) + bits = [ bitAt verifySTD3 USE_STD3_ASCII_RULES + , bitAt allowUnassigned ALLOW_UNASSIGNED + ] + +cToError :: CInt -> Error +cToError rc = IDNAError (T.pack str) where + c_strerror = {# call idna_strerror #} + str = Unsafe.unsafePerformIO (c_strerror rc >>= peekCString) + +throwError :: CInt -> IO a +throwError rc = do + str <- peekCString =<< {# call idna_strerror #} rc + throwIO (ErrorCall str) diff --git a/lib/Data/Text/IDN/Internal.hs b/lib/Data/Text/IDN/Internal.hs new file mode 100644 --- /dev/null +++ b/lib/Data/Text/IDN/Internal.hs @@ -0,0 +1,35 @@ +-- Copyright (C) 2010 John Millikin +-- +-- This program is free software: you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation, either version 3 of the License, or +-- any later version. +-- +-- This program is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with this program. If not, see . + +module Data.Text.IDN.Internal + ( Error (..) + , toUCS4 + , fromUCS4 + ) where + +import qualified Data.Text as T +import Data.Char (chr, ord) + +import qualified Foreign as F + +data Error = IDNAError T.Text + | StringPrepError T.Text + deriving (Show, Eq) + +toUCS4 :: T.Text -> [F.Word32] +toUCS4 = map (fromIntegral . ord) . T.unpack + +fromUCS4 :: [F.Word32] -> T.Text +fromUCS4 = T.pack . map (chr . fromIntegral) diff --git a/lib/Data/Text/IDN/Punycode.chs b/lib/Data/Text/IDN/Punycode.chs new file mode 100644 --- /dev/null +++ b/lib/Data/Text/IDN/Punycode.chs @@ -0,0 +1,144 @@ +{-# LANGUAGE ForeignFunctionInterface #-} + +-- Copyright (C) 2010 John Millikin +-- +-- This program is free software: you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation, either version 3 of the License, or +-- any later version. +-- +-- This program is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with this program. If not, see . + +-- | Punycode is a simple and efficient transfer encoding syntax designed +-- for use with Internationalized Domain Names in Applications (IDNA). It +-- uniquely and reversibly transforms a Unicode string into ASCII. ASCII +-- characters in the Unicode string are represented literally, and non-ASCII +-- characters are represented by ASCII characters that are allowed in host +-- name labels (letters, digits, and hyphens). +module Data.Text.IDN.Punycode + ( encode + , decode + ) where + +import Control.Exception (ErrorCall(..), throwIO) +import Control.Monad (unless) +import Data.List (unfoldr) +import qualified Data.ByteString as B +import qualified Data.Text as T +import qualified System.IO.Unsafe as Unsafe + +import Foreign +import Foreign.C + +import Data.Text.IDN.Internal (toUCS4, fromUCS4) + +#include + +-- | Encode unicode into an ASCII-only 'B.ByteString'. If provided, the +-- case predicate indicates whether to uppercase the corresponding character +-- after decoding. +encode :: T.Text + -> Maybe (Integer -> Bool) + -> B.ByteString +encode input maybeIsCase = Unsafe.unsafePerformIO io where + inSize = T.length input + + flags = flip fmap maybeIsCase $ \isCase -> let + step idx = Just (fromBool (isCase idx), idx + 1) + in unfoldr step 0 + + io = maybeWith (withArray . take inSize) flags impl + + impl caseBuf = withArray (toUCS4 input) (loop caseBuf inSize . castPtr) + + loop caseBuf outMax inBuf = do + res <- tryEnc caseBuf outMax inBuf + case res of + Nothing -> loop caseBuf (outMax + 50) inBuf + Just (Right bytes) -> return bytes + Just (Left rc) -> cToError rc + + tryEnc caseBuf outMax inBuf = + allocaBytes outMax $ \outBuf -> + alloca $ \outSizeBuf -> do + poke outSizeBuf (fromIntegral outMax) + c_rc <- {# call punycode_encode #} + (fromIntegral inSize) + inBuf + caseBuf + outSizeBuf + outBuf + + let rc = fromIntegral c_rc + if rc == fromEnum OVERFLOW + then return Nothing + else if rc == fromEnum SUCCESS + then do + outSize <- peek outSizeBuf + bytes <- peekOut outBuf outSize + return (Just (Right bytes)) + else return (Just (Left c_rc)) + + peekOut outBuf outSize = B.packCStringLen cstr where + cstr = (outBuf, fromIntegral outSize) + +-- | Decode a 'B.ByteString' into unicode. The second component of the +-- result is a case predicate; it indicates whether a particular character +-- position of the result string should be upper-cased. +-- +-- Returns 'Nothing' if the input is invalid. +decode :: B.ByteString + -> Maybe (T.Text, (Integer -> Bool)) +decode input = Unsafe.unsafePerformIO $ + let outMax = B.length input in + B.useAsCStringLen input $ \(inBuf, inSize) -> + alloca $ \outSizeBuf -> + allocaArray outMax $ \outBuf -> do + + flagForeign <- mallocForeignPtrArray outMax + poke outSizeBuf (fromIntegral outMax) + + c_rc <- withForeignPtr flagForeign $ \flagBuf -> + {# call punycode_decode #} + (fromIntegral inSize) + inBuf + outSizeBuf + outBuf + flagBuf + + let rc = fromIntegral c_rc + if rc == fromEnum BAD_INPUT + then return Nothing + else do + unless (rc == fromEnum SUCCESS) (cToError c_rc) + + outSize <- peek outSizeBuf + ucs4 <- peekArray (fromIntegral outSize) (castPtr outBuf) + let text = fromUCS4 ucs4 + return (Just (text, checkCaseFlag flagForeign outSize)) + +type SizeT = {# type size_t #} + +{# enum Punycode_status {} with prefix = "PUNYCODE_" #} + +checkCaseFlag :: ForeignPtr CUChar -> SizeT -> Integer -> Bool +checkCaseFlag ptr csize = checkIdx where + intsize = toInteger csize + checkIdx idx | idx < 0 = False + checkIdx idx | idx >= intsize = False + checkIdx idx = + Unsafe.unsafePerformIO $ + withForeignPtr ptr $ \buf -> do + cuchar <- peekElemOff buf (fromInteger idx) + return (toBool cuchar) + +cToError :: CInt -> IO a +cToError rc = do + str <- peekCString =<< {# call punycode_strerror #} rc + throwIO (ErrorCall str) diff --git a/lib/Data/Text/IDN/StringPrep.chs b/lib/Data/Text/IDN/StringPrep.chs new file mode 100644 --- /dev/null +++ b/lib/Data/Text/IDN/StringPrep.chs @@ -0,0 +1,148 @@ +{-# LANGUAGE ForeignFunctionInterface #-} + +-- Copyright (C) 2010 John Millikin +-- +-- This program is free software: you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation, either version 3 of the License, or +-- any later version. +-- +-- This program is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with this program. If not, see . + +module Data.Text.IDN.StringPrep + ( + -- * Stringprep + Flags (..) + , Error + , defaultFlags + , stringprep + + -- * Profiles + , Profile + , iscsi + , kerberos5 + , nameprep + , sasl + , saslAnonymous + , trace + , xmppNode + , xmppResource + ) where + +import qualified Data.ByteString as B +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import qualified System.IO.Unsafe as Unsafe + +import Foreign +import Foreign.C + +import Data.Text.IDN.Internal + +#include + +{# pointer *Stringprep_profile as Profile newtype #} + +{# enum Stringprep_rc {} with prefix = "STRINGPREP_" #} + +{# enum Stringprep_profile_flags {} with prefix = "STRINGPREP_" #} + +data Flags = Flags + { enableNFKC :: Bool + -- ^ Enable the NFKC normalization, as well as selecting the NFKC + -- case folding tables. Usually the profile specifies BIDI and NFKC + -- settings, and applications should not override it unless in + -- special situations. + + , enableBidi :: Bool + -- ^ Enable the BIDI step. Usually the profile specifies BIDI and + -- NFKC settings, and applications should not override it unless in + -- special situations. + + , allowUnassigned :: Bool + -- ^ If false, 'stringprep' will return an error if the input + -- contains characters not assigned to the profile. + } + deriving (Show, Eq) + +-- | @defaultFlags = Flags True True False@ +defaultFlags :: Flags +defaultFlags = Flags True True False + +stringprep :: Profile -> Flags -> T.Text -> Either Error T.Text +stringprep profile flags input = Unsafe.unsafePerformIO io where + io = B.useAsCString utf8 (loop inSize) + + utf8 = TE.encodeUtf8 input + c_flags = encodeFlags flags + inSize = B.length utf8 + 1 -- + 1 for NUL + + loop outSize inBuf = do + res <- tryPrep outSize inBuf + case res of + Nothing -> loop (outSize + 50) inBuf + Just (Right bytes) -> return (Right (TE.decodeUtf8 bytes)) + Just (Left rc) -> return (Left (cToError rc)) + + tryPrep outSize inBuf = allocaBytes outSize $ \outBuf -> do + copyArray outBuf inBuf inSize + let csize = fromIntegral outSize + c_rc <- {# call stringprep as c_stringprep #} + outBuf csize c_flags profile + + let rc = fromIntegral c_rc + if rc == fromEnum TOO_SMALL_BUFFER + then return Nothing + else if rc == fromEnum OK + then fmap (Just . Right) (B.packCString outBuf) + else return (Just (Left c_rc)) + +encodeFlags :: Flags -> CInt +encodeFlags flags = foldr (.|.) 0 bits where + bitAt f e = if f flags then 0 else fromIntegral (fromEnum e) + bits = [ bitAt enableNFKC NO_NFKC + , bitAt enableBidi NO_BIDI + , bitAt allowUnassigned NO_UNASSIGNED + ] + +cToError :: CInt -> Error +cToError rc = StringPrepError (T.pack str) where + c_strerror = {# call stringprep_strerror #} + str = Unsafe.unsafePerformIO (c_strerror rc >>= peekCString) + +-- | iSCSI (RFC 3722) +foreign import ccall "&stringprep_iscsi" + iscsi :: Profile + +-- | Kerberos 5 +foreign import ccall "&stringprep_kerberos5" + kerberos5 :: Profile + +-- | Nameprep (RFC 3491) +foreign import ccall "&stringprep_nameprep" + nameprep :: Profile + +-- | SASLprep (RFC 4013) +foreign import ccall "&stringprep_saslprep" + sasl :: Profile + +-- | Draft SASL ANONYMOUS +foreign import ccall "&stringprep_plain" + saslAnonymous :: Profile + +foreign import ccall "&stringprep_trace" + trace :: Profile + +-- | XMPP node (RFC 3920) +foreign import ccall "&stringprep_xmpp_nodeprep" + xmppNode :: Profile + +-- | XMPP resource (RFC 3920) +foreign import ccall "&stringprep_xmpp_resourceprep" + xmppResource :: Profile