{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE OverloadedStrings #-}
module Data.MIME.QuotedPrintable
(
contentTransferEncodingQuotedPrintable
, q
) where
import Control.Lens (APrism', prism')
import Data.Bool (bool)
import qualified Data.ByteString as B
import qualified Data.ByteString.Internal as B
import Data.Word (Word8)
import Foreign
( Ptr, withForeignPtr, nullPtr, plusPtr, minusPtr
, peek, peekByteOff, poke
)
import System.IO.Unsafe (unsafeDupablePerformIO)
import Data.MIME.Internal
import Data.MIME.Types
data QuotedPrintableMode = QuotedPrintable | Q
deriving (Eq)
encodingRequiredNonEOL :: QuotedPrintableMode -> Word8 -> Bool
encodingRequiredNonEOL mode c = not (
(c >= 33 && c <= 60)
|| (c >= 62 && c <= 126)
|| c == 9
|| c == 32
) || (mode == Q && c == 95 )
encodingRequiredEOL :: QuotedPrintableMode -> Word8 -> Bool
encodingRequiredEOL mode c = not (
(c >= 33 && c <= 60)
|| (c >= 62 && c <= 126)
) || (mode == Q && c == 95 )
encodeQuotedPrintable :: QuotedPrintableMode -> B.ByteString -> B.ByteString
encodeQuotedPrintable mode s = unsafeDupablePerformIO $ do
l <- encodeQuotedPrintable' mode
(\_ _ -> pure ()) id nullPtr s
dfp <- B.mallocByteString l
withForeignPtr dfp $ \dptr ->
encodeQuotedPrintable' mode
poke (B.PS dfp 0) dptr s
encodeQuotedPrintable'
:: QuotedPrintableMode
-> (Ptr Word8 -> Word8 -> IO ())
-> (Int -> r)
-> Ptr Word8
-> B.ByteString
-> IO r
encodeQuotedPrintable' mode poke' mkResult dptr (B.PS sfp soff slen) =
fmap mkResult $ withForeignPtr sfp $ \sptr -> do
let
slimit = sptr `plusPtr` (soff + slen)
crlf :: Ptr Word8 -> IO Bool
crlf ptr
| ptr `plusPtr` 1 >= slimit = pure False
| otherwise = do
c1 <- peek ptr
c2 <- peekByteOff ptr 1
pure $ (c1 :: Word8) == 13 && (c2 :: Word8) == 10
pokeHardLineBreak ptr =
poke' ptr 13 *> poke' (ptr `plusPtr` 1) 10
pokeSoftLineBreak ptr =
poke' ptr 61 *> pokeHardLineBreak (ptr `plusPtr` 1)
pokeEncoded ptr c =
let (hi, lo) = hexEncode c
in poke' ptr 61
*> poke' (ptr `plusPtr` 1) hi
*> poke' (ptr `plusPtr` 2) lo
mapChar 32 | mode == Q = 95
mapChar c = c
fill col !dp !sp
| sp >= slimit = pure $ dp `minusPtr` dptr
| otherwise = do
atEOL <- crlf sp
if atEOL
then pokeHardLineBreak dp
*> fill 0 (dp `plusPtr` 2) (sp `plusPtr` 2)
else do
c <- peek sp
cAtEOL <- crlf (sp `plusPtr` 1)
let
encodingRequired =
(cAtEOL && encodingRequiredEOL mode c)
|| encodingRequiredNonEOL mode c
bytesNeeded = bool 1 3 encodingRequired
c' = mapChar c
case (col + bytesNeeded >= 76, encodingRequired) of
(False, False) ->
poke' dp c'
*> fill (col + bytesNeeded) (dp `plusPtr` bytesNeeded) (sp `plusPtr` 1)
(False, True) ->
pokeEncoded dp c'
*> fill (col + bytesNeeded) (dp `plusPtr` bytesNeeded) (sp `plusPtr` 1)
(True, False) ->
pokeSoftLineBreak dp
*> poke' (dp `plusPtr` 3) c'
*> fill 1 (dp `plusPtr` 4) (sp `plusPtr` 1)
(True, True) ->
pokeSoftLineBreak dp
*> pokeEncoded (dp `plusPtr` 3) c'
*> fill 3 (dp `plusPtr` 6) (sp `plusPtr` 1)
fill 0 dptr (sptr `plusPtr` soff)
decodeQuotedPrintable :: QuotedPrintableMode -> B.ByteString -> Either String B.ByteString
decodeQuotedPrintable mode (B.PS sfp soff slen) = unsafeDupablePerformIO $ do
dfp <- B.mallocByteString slen
result <- withForeignPtr dfp $ \dptr ->
withForeignPtr sfp $ \sptr -> do
let
slimit = sptr `plusPtr` (soff + slen)
fill !dp !sp
| sp >= slimit = pure $ Right (dp `minusPtr` dptr)
| otherwise = do
c <- peek sp
case (c :: Word8) of
61 ->
if sp `plusPtr` 1 >= slimit
then pure $ Left "reached end of input during '=' decoding"
else do
c1 <- peekByteOff sp 1
case c1 of
10 -> fill dp (sp `plusPtr` 2)
_ ->
if sp `plusPtr` 2 >= slimit
then pure $ Left "reached end of input during '=' decoding"
else do
c2 <- peekByteOff sp 2
case (c1, c2) of
(13, 10) ->
fill dp (sp `plusPtr` 3)
_ ->
maybe
(pure $ Left "invalid hex sequence")
(\(hi,lo) -> do
poke dp (hi * 16 + lo)
fill (dp `plusPtr` 1) (sp `plusPtr` 3) )
((,) <$> parseHex c1 <*> parseHex c2)
95 | mode == Q ->
poke dp 32 *> fill (dp `plusPtr` 1) (sp `plusPtr` 1)
32 | mode == Q ->
pure $ Left "space cannot appear in 'Q' encoding"
_ ->
poke dp c *> fill (dp `plusPtr` 1) (sp `plusPtr` 1)
fill dptr (sptr `plusPtr` soff)
pure $ B.PS dfp 0 <$> result
mkPrism :: QuotedPrintableMode -> APrism' B.ByteString B.ByteString
mkPrism mode = prism'
(encodeQuotedPrintable mode)
(either (const Nothing) Just . decodeQuotedPrintable mode)
contentTransferEncodingQuotedPrintable :: ContentTransferEncoding
contentTransferEncodingQuotedPrintable = mkPrism QuotedPrintable
q :: EncodedWordEncoding
q = mkPrism Q