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)
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 <- punycode_encode
(fromIntegral inSize)
inBuf
caseBuf
outSizeBuf
outBuf
let rc = fromIntegral c_rc
if rc == fromEnum BIG_OUTPUT
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 :: 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 ->
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 = (CULong)
data Punycode_status = SUCCESS
| BAD_INPUT
| BIG_OUTPUT
| OVERFLOW
instance Enum Punycode_status where
succ SUCCESS = BAD_INPUT
succ BAD_INPUT = BIG_OUTPUT
succ BIG_OUTPUT = OVERFLOW
succ OVERFLOW = error "Punycode_status.succ: OVERFLOW has no successor"
pred BAD_INPUT = SUCCESS
pred BIG_OUTPUT = BAD_INPUT
pred OVERFLOW = BIG_OUTPUT
pred SUCCESS = error "Punycode_status.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 OVERFLOW
fromEnum SUCCESS = 0
fromEnum BAD_INPUT = 1
fromEnum BIG_OUTPUT = 2
fromEnum OVERFLOW = 3
toEnum 0 = SUCCESS
toEnum 1 = BAD_INPUT
toEnum 2 = BIG_OUTPUT
toEnum 3 = OVERFLOW
toEnum unmatched = error ("Punycode_status.toEnum: Cannot match " ++ show unmatched)
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 =<< punycode_strerror rc
throwIO (ErrorCall str)
foreign import ccall safe "Data/Text/IDN/Punycode.chs.h punycode_encode"
punycode_encode :: (CULong -> ((Ptr CUInt) -> ((Ptr CUChar) -> ((Ptr CULong) -> ((Ptr CChar) -> (IO CInt))))))
foreign import ccall safe "Data/Text/IDN/Punycode.chs.h punycode_decode"
punycode_decode :: (CULong -> ((Ptr CChar) -> ((Ptr CULong) -> ((Ptr CUInt) -> ((Ptr CUChar) -> (IO CInt))))))
foreign import ccall safe "Data/Text/IDN/Punycode.chs.h punycode_strerror"
punycode_strerror :: (CInt -> (IO (Ptr CChar)))