-- This file is part of purebred-email -- Copyright (C) 2017-2020 Fraser Tweedale -- -- purebred-email is free software: you can redistribute it and/or modify -- it under the terms of the GNU Affero General Public License as published by -- the Free Software Foundation, either version 3 of the License, or -- (at your option) 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 Affero General Public License for more details. -- -- You should have received a copy of the GNU Affero General Public License -- along with this program. If not, see . {-# LANGUAGE BangPatterns #-} {-# LANGUAGE OverloadedStrings #-} {- | Implementation of Quoted-Printable Content-Transfer-Encoding. -} module Data.MIME.QuotedPrintable ( contentTransferEncodingQuotedPrintable , q , QuotedPrintableMode(..) , encodingRequiredEOL , encodingRequiredNonEOL ) 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) -- | Whether it is required to encode a character -- (where that character does not precede EOL). encodingRequiredNonEOL :: QuotedPrintableMode -> Word8 -> Bool encodingRequiredNonEOL mode c = (c < 32 {- ' ' -} && c /= 9 {- \t -}) || c == 61 {- = -} || c >= 127 || mode == Q && (c == 95 {- _ -} || c == 9 {- \t -} || c == 63 {- ? -}) -- | Whether it is required to encode a character -- (where that character does precede EOL). encodingRequiredEOL :: QuotedPrintableMode -> Word8 -> Bool encodingRequiredEOL mode c = not ( (c >= 33 && c <= 60) || (c >= 62 && c <= 126) ) || (mode == Q && c == 95 {- underscore -}) -- | Two-pass solution: first determine output length, then -- do the copy. -- output length. 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 ()) -- "poke" function -> (Int -> r) -- "return" function -> Ptr Word8 -- ^ dest pointer; **assumed to be big enough to hold output**. -- Can pass a bogus pointer (e.g. nullPtr) if the poke function -- ignores its argument; this can be used for a first pass that -- just computes the required length. -> B.ByteString -- ^ input string -> IO r encodeQuotedPrintable' mode poke' mkResult dptr (B.PS sfp soff slen) = fmap mkResult $ withForeignPtr sfp $ \sptr -> do let slimit = sptr `plusPtr` (soff + slen) -- is there a crlf at this location? crlf :: Ptr Word8 -> IO Bool crlf ptr | mode == Q = pure False -- always encode CRLF in 'Q' mode | 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 -- Do not wrap lines in Q mode. This is not correct, -- but encoded-word wrapping needs separate encoded-words -- including the leading =?... and trailing ?= wrapLimit = if mode == Q then maxBound else 76 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 >= wrapLimit, 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 -- Precise length of decoded string is not yet known, but -- it cannot be longer than input, and is likely to be not -- much shorter. Therefore allocate slen bytes and only -- use as much as we need. 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 {- = -} -> -- NOTE: strictly, only =\r\n is a valid soft line -- break, but we accept =\n as well. 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) -- soft line break (=\n) _ -> 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) {- CRLF -} -> -- Soft Line Break (=\r\n) 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) -- otherwise assume that the char is valid and copy it to dst 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