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
data Idna_rc = SUCCESS
| STRINGPREP_ERROR
| PUNYCODE_ERROR
| CONTAINS_NON_LDH
| CONTAINS_LDH
| CONTAINS_MINUS
| INVALID_LENGTH
| NO_ACE_PREFIX
| ROUNDTRIP_VERIFY_ERROR
| CONTAINS_ACE_PREFIX
| ICONV_ERROR
| MALLOC_ERROR
| DLOPEN_ERROR
instance Enum Idna_rc where
succ SUCCESS = STRINGPREP_ERROR
succ STRINGPREP_ERROR = PUNYCODE_ERROR
succ PUNYCODE_ERROR = CONTAINS_NON_LDH
succ CONTAINS_NON_LDH = CONTAINS_MINUS
succ CONTAINS_LDH = CONTAINS_MINUS
succ CONTAINS_MINUS = INVALID_LENGTH
succ INVALID_LENGTH = NO_ACE_PREFIX
succ NO_ACE_PREFIX = ROUNDTRIP_VERIFY_ERROR
succ ROUNDTRIP_VERIFY_ERROR = CONTAINS_ACE_PREFIX
succ CONTAINS_ACE_PREFIX = ICONV_ERROR
succ ICONV_ERROR = MALLOC_ERROR
succ MALLOC_ERROR = DLOPEN_ERROR
succ DLOPEN_ERROR = error "Idna_rc.succ: DLOPEN_ERROR has no successor"
pred STRINGPREP_ERROR = SUCCESS
pred PUNYCODE_ERROR = STRINGPREP_ERROR
pred CONTAINS_NON_LDH = PUNYCODE_ERROR
pred CONTAINS_LDH = PUNYCODE_ERROR
pred CONTAINS_MINUS = CONTAINS_NON_LDH
pred INVALID_LENGTH = CONTAINS_MINUS
pred NO_ACE_PREFIX = INVALID_LENGTH
pred ROUNDTRIP_VERIFY_ERROR = NO_ACE_PREFIX
pred CONTAINS_ACE_PREFIX = ROUNDTRIP_VERIFY_ERROR
pred ICONV_ERROR = CONTAINS_ACE_PREFIX
pred MALLOC_ERROR = ICONV_ERROR
pred DLOPEN_ERROR = MALLOC_ERROR
pred SUCCESS = error "Idna_rc.pred: SUCCESS has no predecessor"
enumFromTo from to = go from
where
end = fromEnum to
go v = case compare (fromEnum v) end of
LT -> v : go (succ v)
EQ -> [v]
GT -> []
enumFrom from = enumFromTo from DLOPEN_ERROR
fromEnum SUCCESS = 0
fromEnum STRINGPREP_ERROR = 1
fromEnum PUNYCODE_ERROR = 2
fromEnum CONTAINS_NON_LDH = 3
fromEnum CONTAINS_LDH = 3
fromEnum CONTAINS_MINUS = 4
fromEnum INVALID_LENGTH = 5
fromEnum NO_ACE_PREFIX = 6
fromEnum ROUNDTRIP_VERIFY_ERROR = 7
fromEnum CONTAINS_ACE_PREFIX = 8
fromEnum ICONV_ERROR = 9
fromEnum MALLOC_ERROR = 201
fromEnum DLOPEN_ERROR = 202
toEnum 0 = SUCCESS
toEnum 1 = STRINGPREP_ERROR
toEnum 2 = PUNYCODE_ERROR
toEnum 3 = CONTAINS_NON_LDH
toEnum 4 = CONTAINS_MINUS
toEnum 5 = INVALID_LENGTH
toEnum 6 = NO_ACE_PREFIX
toEnum 7 = ROUNDTRIP_VERIFY_ERROR
toEnum 8 = CONTAINS_ACE_PREFIX
toEnum 9 = ICONV_ERROR
toEnum 201 = MALLOC_ERROR
toEnum 202 = DLOPEN_ERROR
toEnum unmatched = error ("Idna_rc.toEnum: Cannot match " ++ show unmatched)
data Idna_flags = ALLOW_UNASSIGNED
| USE_STD3_ASCII_RULES
instance Enum Idna_flags where
succ ALLOW_UNASSIGNED = USE_STD3_ASCII_RULES
succ USE_STD3_ASCII_RULES = error "Idna_flags.succ: USE_STD3_ASCII_RULES has no successor"
pred USE_STD3_ASCII_RULES = ALLOW_UNASSIGNED
pred ALLOW_UNASSIGNED = error "Idna_flags.pred: ALLOW_UNASSIGNED has no predecessor"
enumFromTo from to = go from
where
end = fromEnum to
go v = case compare (fromEnum v) end of
LT -> v : go (succ v)
EQ -> [v]
GT -> []
enumFrom from = enumFromTo from USE_STD3_ASCII_RULES
fromEnum ALLOW_UNASSIGNED = 1
fromEnum USE_STD3_ASCII_RULES = 2
toEnum 1 = ALLOW_UNASSIGNED
toEnum 2 = USE_STD3_ASCII_RULES
toEnum unmatched = error ("Idna_flags.toEnum: Cannot match " ++ show unmatched)
data Flags = Flags
{ verifySTD3 :: Bool
, allowUnassigned :: Bool
}
deriving (Show, Eq)
defaultFlags :: Flags
defaultFlags = Flags True False
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 <- 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
idn_free (castPtr outBuf)
return (Right bytes)
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 <- 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)
idn_free (castPtr outBuf)
return (fromUCS4 ucs4)
encodeFlags :: Flags -> CInt
encodeFlags flags = foldr (.|.) 0 bits where
bitAt f e = if f flags then fromIntegral (fromEnum e) else 0
bits = [ bitAt verifySTD3 USE_STD3_ASCII_RULES
, bitAt allowUnassigned ALLOW_UNASSIGNED
]
cToError :: CInt -> Error
cToError rc = IDNAError (T.pack str) where
c_strerror = idna_strerror
str = Unsafe.unsafePerformIO (c_strerror rc >>= peekCString)
throwError :: CInt -> IO a
throwError rc = do
str <- peekCString =<< idna_strerror rc
throwIO (ErrorCall str)
foreign import ccall safe "Data/Text/IDN/IDNA.chs.h idna_to_ascii_4z"
idna_to_ascii_4z :: ((Ptr CUInt) -> ((Ptr (Ptr CChar)) -> (CInt -> (IO CInt))))
foreign import ccall safe "Data/Text/IDN/IDNA.chs.h idn_free"
idn_free :: ((Ptr ()) -> (IO ()))
foreign import ccall safe "Data/Text/IDN/IDNA.chs.h idna_to_unicode_8z4z"
idna_to_unicode_8z4z :: ((Ptr CChar) -> ((Ptr (Ptr CUInt)) -> (CInt -> (IO CInt))))
foreign import ccall safe "Data/Text/IDN/IDNA.chs.h idna_strerror"
idna_strerror :: (CInt -> (IO (Ptr CChar)))