conduit-iconv-0.1.0.0: Data/Conduit/IConv.hs
{-# LANGUAGE ForeignFunctionInterface #-}
-- | A "Data.Conduit#t:Conduit" based on "Codec.Text.IConv" for
-- converting a "Data.ByteString" from one character set encoding to another
module Data.Conduit.IConv
(
convert
) where
import Data.Conduit
import qualified Data.Conduit.List as CL
import qualified Data.ByteString as B
import qualified Data.ByteString.Unsafe as BU
import Control.Applicative ((<$>))
import Foreign hiding (unsafePerformIO)
import Foreign.C
import System.IO.Unsafe (unsafePerformIO)
-- | Convert text from one named character encoding to another.
--
-- Encoding names can be e.g. @\"UTF-8\"@ or @\"ISO-8559-1\"@. Appending
-- @\"\/\/IGNORE\"@ to the output encoding will cause encoding errors to be
-- ignored and the characters to be dropped, @\"\/\/IGNORE,TRANSLIT\"@ will
-- cause them to be replaced by a replacement character.
--
-- Without this encoding errors will cause an exception.
--
-- On errors this will call "Control.Monad#v:fail"
convert :: Monad m => String -- ^ Name of input character encoding
-> String -- ^ Name of output character encoding
-> Conduit B.ByteString m B.ByteString
convert inputEncoding outputEncoding =
let initialConvert = iconvConvert inputEncoding outputEncoding
in run initialConvert
where
run f = do
maybeInput <- await
case maybeInput of
Nothing -> return ()
Just input -> do
let res = f input
case res of
ConvertSuccess c f' -> do
CL.sourceList c
run f'
ConvertUnsupportedConversionError -> fail "Unsupported conversion"
ConvertUnexpectedOpenError s -> fail ("Unexpected open error: " ++ s)
ConvertInvalidInputError -> fail "Invalid input"
ConvertUnexpectedConversionError s -> fail ("Unexpected conversion error: " ++ s)
-- Stream based API around iconv()
data ConvertResult =
ConvertSuccess [B.ByteString] (B.ByteString -> ConvertResult)
| ConvertUnsupportedConversionError
| ConvertUnexpectedOpenError String
| ConvertInvalidInputError
| ConvertUnexpectedConversionError String
iconvConvert :: String -> String -> B.ByteString -> ConvertResult
iconvConvert inputEncoding outputEncoding input =
let eCtx = iconvOpen inputEncoding outputEncoding
in
case eCtx of
Left UnsupportedConversion -> ConvertUnsupportedConversionError
Left (UnexpectedOpenError (Errno errno)) -> ConvertUnexpectedOpenError (show errno)
Right ctx -> convertInput ctx B.empty [] input
where
convertInput ctx remaining converted newInput
| B.null newInput =
ConvertSuccess converted (convertInput ctx remaining [])
| B.null remaining =
let res = iconv ctx newInput
in
case res of
Converted c r -> ConvertSuccess (converted ++ [c]) (convertInput ctx r [])
MoreData c r -> convertInput ctx B.empty (converted ++ [c]) r
InvalidInput c _ -> ConvertSuccess (converted ++ [c]) (const ConvertInvalidInputError)
UnexpectedError (Errno errno) -> ConvertUnexpectedConversionError (show errno)
| otherwise =
let tmpInput = remaining `B.append` B.take 32 newInput
res = iconv ctx tmpInput
in
case res of
Converted c r -> let processed = B.length tmpInput - B.length r
consumedInput = processed - B.length remaining
in
if processed < B.length remaining then
ConvertSuccess converted (convertInput ctx (remaining `B.append` newInput) [])
else
convertInput ctx B.empty (converted ++ [c]) (B.drop consumedInput newInput)
MoreData c r -> let processed = B.length tmpInput - B.length r
consumedInput = processed - B.length remaining
in
if processed < B.length remaining then
ConvertSuccess converted (convertInput ctx (remaining `B.append` newInput) [])
else
convertInput ctx B.empty (converted ++ [c]) (B.drop consumedInput newInput)
InvalidInput c _ -> ConvertSuccess (converted ++ [c]) (const ConvertInvalidInputError)
UnexpectedError (Errno errno) -> ConvertUnexpectedConversionError (show errno)
-- Thin wrapper around iconv_open()
newtype IConvT = IConvT (ForeignPtr IConvT)
data IConvOpenError =
UnsupportedConversion
| UnexpectedOpenError Errno
iconvOpen :: String -> String -> Either IConvOpenError IConvT
iconvOpen inputEncoding outputEncoding = unsafePerformIO $ do
ptr <- withCString inputEncoding $ \inputEncodingPtr ->
withCString outputEncoding $ \outputEncodingPtr ->
c_iconv_open outputEncodingPtr inputEncodingPtr
case ptrToIntPtr ptr of
(-1) -> do
errno <- getErrno
return $ Left $
if errno == eINVAL then
UnsupportedConversion
else
UnexpectedOpenError errno
_ -> do
fPtr <- newForeignPtr c_iconv_close ptr
return $ Right (IConvT fPtr)
-- Thin wrapper around iconv()
data IConvResult =
Converted B.ByteString B.ByteString
| MoreData B.ByteString B.ByteString
| InvalidInput B.ByteString B.ByteString
| UnexpectedError Errno
iconv :: IConvT -> B.ByteString -> IConvResult
iconv (IConvT fPtr) input = unsafePerformIO $
withForeignPtr fPtr $ \ptr ->
BU.unsafeUseAsCStringLen input $ \(inPtr, inLeft) ->
with inPtr $ \inPtrPtr ->
with (fromIntegral inLeft) $ \inLeftPtr ->
let outLeft = max (inLeft + 16) 4096 in -- 16 byte padding just in case
mallocBytes outLeft >>= \outPtr ->
BU.unsafePackCStringLen (outPtr, outLeft) >>= \output -> -- created here already to be garbage collected in case of async exceptions
with outPtr $ \outPtrPtr ->
with (fromIntegral outLeft) $ \outLeftPtr -> do
res <- c_iconv ptr inPtrPtr inLeftPtr outPtrPtr outLeftPtr
inLeft' <- fromIntegral <$> peek inLeftPtr
outLeft' <- fromIntegral <$> peek outLeftPtr
let output' = B.take (outLeft - outLeft') output
remaining = B.drop (inLeft - inLeft') input
if res /= (-1) then
return $ Converted output' remaining
else do
errno <- getErrno
case () of
_ | errno == e2BIG -> return $
if outLeft == outLeft' then -- we processed nothing and it's still too big?!
UnexpectedError errno
else
MoreData output' remaining
| errno == eINVAL -> return $ Converted output' remaining -- nothing converted here is no error as with future data we might be able to convert
| errno == eILSEQ -> return $
if outLeft == outLeft' then -- we processed nothing
UnexpectedError errno
else
InvalidInput output' remaining
| otherwise -> return $ UnexpectedError errno
-- Taken from Codec.Text.IConv
foreign import ccall unsafe "hsiconv.h hs_wrap_iconv_open"
c_iconv_open :: CString -- to code
-> CString -- from code
-> IO (Ptr IConvT)
foreign import ccall unsafe "hsiconv.h hs_wrap_iconv"
c_iconv :: Ptr IConvT
-> Ptr (Ptr CChar) -- in buf
-> Ptr CSize -- in buf bytes left
-> Ptr (Ptr CChar) -- out buf
-> Ptr CSize -- out buf bytes left
-> IO CSize
foreign import ccall unsafe "hsiconv.h &hs_wrap_iconv_close"
c_iconv_close :: FinalizerPtr IConvT