{-# LANGUAGE ForeignFunctionInterface #-}

-- |
-- Module: Codec.Binary.QuotedPrintable
-- Copyright: (c) 2012 Magnus Therning
-- License: BSD3
--
-- Implementation of Quoted-Printable based on RFC 2045
-- (<http://tools.ietf.org/html/rfc2045>).
module Codec.Binary.QuotedPrintable
    ( qpEncode
    , qpEncodeSL
    , qpDecode
    , encode
    , decode
    ) where

import Data.List
import Foreign
import Foreign.C.Types
import System.IO.Unsafe as U
import qualified Data.ByteString as BS
import qualified Data.ByteString.Unsafe as BSU

castEnum :: (Enum a, Enum b) => a -> b
castEnum :: a -> b
castEnum = Int -> b
forall a. Enum a => Int -> a
toEnum (Int -> b) -> (a -> Int) -> a -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Int
forall a. Enum a => a -> Int
fromEnum

foreign import ccall "static qp.h qp_enc"
    c_qp_enc :: Word8 -> Ptr Word8 -> CSize -> Ptr Word8 -> Ptr CSize -> Ptr (Ptr Word8) -> Ptr CSize -> IO ()

foreign import ccall "static qp.h qp_dec"
    c_qp_dec :: Ptr Word8 -> CSize -> Ptr Word8 -> Ptr CSize -> Ptr (Ptr Word8) -> Ptr CSize -> IO CInt

-- | Encoding function.
--
-- This function encodes /everything/ that is passed in, it will not try to
-- guess the native line ending for your architecture.  In other words, if you
-- are using this to encode text you need to split it into separate lines
-- before encoding.
--
-- This function allocates enough space to hold twice the size of the indata
-- (or at least 512 bytes) and then encodes as much as possible of the indata.
-- That means there is a risk that the encoded data won't fit and in that case
-- the second part of the pair contains the remainder of the indata.
--
-- >>> qpEncode $ Data.ByteString.Char8.pack "="
-- ("=3D","")
-- >>> snd $ qpEncode $ Data.ByteString.Char8.pack $ Data.List.take 171 $ repeat '='
-- "="
--
-- All space (0x20) and tab (0x9) characters are encoded:
--
-- >>> qpEncode $ Data.ByteString.Char8.pack " \t"
-- ("=20=09","")
--
-- Since the input is supposed to have been split prior to calling this
-- function all occurances of CR and LF are encoded.
--
-- >>> qpEncode $ Data.ByteString.Char8.pack "\n\r\r\n\n\r"
-- ("=0A=0D=0D=0A=0A=0D","")
--
-- Soft line breaks are inserted as needed
--
-- >>> qpEncode $ Data.ByteString.Char8.pack "========================="
-- ("=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=\r\n=3D","")
qpEncode :: BS.ByteString -> (BS.ByteString, BS.ByteString)
qpEncode :: ByteString -> (ByteString, ByteString)
qpEncode = Word8 -> ByteString -> (ByteString, ByteString)
qpEnc' Word8
1

-- | Single line encoding function.
--
-- Like 'qpEncode', but without inserting soft line breaks.
qpEncodeSL :: BS.ByteString -> (BS.ByteString, BS.ByteString)
qpEncodeSL :: ByteString -> (ByteString, ByteString)
qpEncodeSL = Word8 -> ByteString -> (ByteString, ByteString)
qpEnc' Word8
0

qpEnc' :: Word8 -> BS.ByteString -> (BS.ByteString, BS.ByteString)
qpEnc' :: Word8 -> ByteString -> (ByteString, ByteString)
qpEnc' Word8
split ByteString
bs = IO (ByteString, ByteString) -> (ByteString, ByteString)
forall a. IO a -> a
U.unsafePerformIO (IO (ByteString, ByteString) -> (ByteString, ByteString))
-> IO (ByteString, ByteString) -> (ByteString, ByteString)
forall a b. (a -> b) -> a -> b
$ ByteString
-> (CStringLen -> IO (ByteString, ByteString))
-> IO (ByteString, ByteString)
forall a. ByteString -> (CStringLen -> IO a) -> IO a
BSU.unsafeUseAsCStringLen ByteString
bs ((CStringLen -> IO (ByteString, ByteString))
 -> IO (ByteString, ByteString))
-> (CStringLen -> IO (ByteString, ByteString))
-> IO (ByteString, ByteString)
forall a b. (a -> b) -> a -> b
$ \ (Ptr CChar
inBuf, Int
inLen) -> do
    let maxOutBuf :: Int
maxOutBuf = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
512 (Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
inLen)
    Ptr Word8
outBuf <- Int -> IO (Ptr Word8)
forall a. Int -> IO (Ptr a)
mallocBytes Int
maxOutBuf
    (Ptr CSize -> IO (ByteString, ByteString))
-> IO (ByteString, ByteString)
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr CSize -> IO (ByteString, ByteString))
 -> IO (ByteString, ByteString))
-> (Ptr CSize -> IO (ByteString, ByteString))
-> IO (ByteString, ByteString)
forall a b. (a -> b) -> a -> b
$ \ Ptr CSize
pOutLen ->
        (Ptr (Ptr Word8) -> IO (ByteString, ByteString))
-> IO (ByteString, ByteString)
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr (Ptr Word8) -> IO (ByteString, ByteString))
 -> IO (ByteString, ByteString))
-> (Ptr (Ptr Word8) -> IO (ByteString, ByteString))
-> IO (ByteString, ByteString)
forall a b. (a -> b) -> a -> b
$ \ Ptr (Ptr Word8)
pRemBuf ->
            (Ptr CSize -> IO (ByteString, ByteString))
-> IO (ByteString, ByteString)
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr CSize -> IO (ByteString, ByteString))
 -> IO (ByteString, ByteString))
-> (Ptr CSize -> IO (ByteString, ByteString))
-> IO (ByteString, ByteString)
forall a b. (a -> b) -> a -> b
$ \ Ptr CSize
pRemLen -> do
                Ptr CSize -> CSize -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr CSize
pOutLen (Int -> CSize
forall a b. (Enum a, Enum b) => a -> b
castEnum Int
maxOutBuf)
                Word8
-> Ptr Word8
-> CSize
-> Ptr Word8
-> Ptr CSize
-> Ptr (Ptr Word8)
-> Ptr CSize
-> IO ()
c_qp_enc Word8
split (Ptr CChar -> Ptr Word8
forall a b. Ptr a -> Ptr b
castPtr Ptr CChar
inBuf) (Int -> CSize
forall a b. (Enum a, Enum b) => a -> b
castEnum Int
inLen) Ptr Word8
outBuf Ptr CSize
pOutLen Ptr (Ptr Word8)
pRemBuf Ptr CSize
pRemLen
                CSize
outLen <- Ptr CSize -> IO CSize
forall a. Storable a => Ptr a -> IO a
peek Ptr CSize
pOutLen
                Ptr Word8
newOutBuf <- Ptr Word8 -> Int -> IO (Ptr Word8)
forall a. Ptr a -> Int -> IO (Ptr a)
reallocBytes Ptr Word8
outBuf (CSize -> Int
forall a b. (Enum a, Enum b) => a -> b
castEnum CSize
outLen)
                Ptr Word8
remBuf <- Ptr (Ptr Word8) -> IO (Ptr Word8)
forall a. Storable a => Ptr a -> IO a
peek Ptr (Ptr Word8)
pRemBuf
                CSize
remLen <- Ptr CSize -> IO CSize
forall a. Storable a => Ptr a -> IO a
peek Ptr CSize
pRemLen
                ByteString
remBs <- CStringLen -> IO ByteString
BS.packCStringLen (Ptr Word8 -> Ptr CChar
forall a b. Ptr a -> Ptr b
castPtr Ptr Word8
remBuf, CSize -> Int
forall a b. (Enum a, Enum b) => a -> b
castEnum CSize
remLen)
                ByteString
outBs <- Ptr Word8 -> Int -> IO () -> IO ByteString
BSU.unsafePackCStringFinalizer Ptr Word8
newOutBuf (CSize -> Int
forall a b. (Enum a, Enum b) => a -> b
castEnum CSize
outLen) (Ptr Word8 -> IO ()
forall a. Ptr a -> IO ()
free Ptr Word8
newOutBuf)
                (ByteString, ByteString) -> IO (ByteString, ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString
outBs, ByteString
remBs)

-- | Decoding function.
--
-- >>> qpDecode $ Data.ByteString.Char8.pack "foobar"
-- Right "foobar"
-- >>> qpDecode $ Data.ByteString.Char8.pack "1=20+=201=20=3D=202"
-- Right "1 + 1 = 2"
--
-- The input data is allowed to use lowercase letters in the hexadecimal
-- representation of an octets value, even though the standard says that only
-- uppercase letters may be used:
--
-- >>> qpDecode $ Data.ByteString.Char8.pack "=3D"
-- Right "="
-- >>> qpDecode $ Data.ByteString.Char8.pack "=3d"
-- Right "="
--
-- It also allows the input to encode _all_ octets in the hexadecimal
-- representation:
--
-- >>> qpDecode $ Data.ByteString.Char8.pack "=20!"
-- Right (" !","")
-- >>> qpDecode $ Data.ByteString.Char8.pack "=20=21"
-- Right (" !","")
--
-- A @Left@ value is only ever returned on decoding errors.
--
-- >>> qpDecode $ Data.ByteString.Char8.pack "=2"
-- Right ("","=2")
-- >>> qpDecode $ Data.ByteString.Char8.pack "=2g"
-- Left ("","=2g")
--
-- Per the specification a CRLF pair is left in, but a single CR or LF is an
-- error.
--
-- >>> qpDecode $ Data.ByteString.Char8.pack "\r\n"
-- Right ("\r\n","")
-- >>> qpDecode $ Data.ByteString.Char8.pack "\n"
-- Left ("","\n")
-- >>> qpDecode $ Data.ByteString.Char8.pack "\r"
-- Left ("","\r")
--
-- the same goes for space and tab characters
--
-- >>> qpDecode $ Data.ByteString.Char8.pack " \t"
-- Right (" \t","")
--
-- The function deals properly with soft line breaks.
--
-- >>> qpDecode $ Data.ByteString.Char8.pack " =\r\n"
-- Right (" ","")
qpDecode :: BS.ByteString -> Either (BS.ByteString, BS.ByteString) (BS.ByteString, BS.ByteString)
qpDecode :: ByteString
-> Either (ByteString, ByteString) (ByteString, ByteString)
qpDecode ByteString
bs = IO (Either (ByteString, ByteString) (ByteString, ByteString))
-> Either (ByteString, ByteString) (ByteString, ByteString)
forall a. IO a -> a
U.unsafePerformIO (IO (Either (ByteString, ByteString) (ByteString, ByteString))
 -> Either (ByteString, ByteString) (ByteString, ByteString))
-> IO (Either (ByteString, ByteString) (ByteString, ByteString))
-> Either (ByteString, ByteString) (ByteString, ByteString)
forall a b. (a -> b) -> a -> b
$ ByteString
-> (CStringLen
    -> IO (Either (ByteString, ByteString) (ByteString, ByteString)))
-> IO (Either (ByteString, ByteString) (ByteString, ByteString))
forall a. ByteString -> (CStringLen -> IO a) -> IO a
BSU.unsafeUseAsCStringLen ByteString
bs ((CStringLen
  -> IO (Either (ByteString, ByteString) (ByteString, ByteString)))
 -> IO (Either (ByteString, ByteString) (ByteString, ByteString)))
-> (CStringLen
    -> IO (Either (ByteString, ByteString) (ByteString, ByteString)))
-> IO (Either (ByteString, ByteString) (ByteString, ByteString))
forall a b. (a -> b) -> a -> b
$ \ (Ptr CChar
inBuf, Int
inLen) -> do
    Ptr Word8
outBuf <- Int -> IO (Ptr Word8)
forall a. Int -> IO (Ptr a)
mallocBytes Int
inLen
    (Ptr CSize
 -> IO (Either (ByteString, ByteString) (ByteString, ByteString)))
-> IO (Either (ByteString, ByteString) (ByteString, ByteString))
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr CSize
  -> IO (Either (ByteString, ByteString) (ByteString, ByteString)))
 -> IO (Either (ByteString, ByteString) (ByteString, ByteString)))
-> (Ptr CSize
    -> IO (Either (ByteString, ByteString) (ByteString, ByteString)))
-> IO (Either (ByteString, ByteString) (ByteString, ByteString))
forall a b. (a -> b) -> a -> b
$ \ Ptr CSize
pOutLen ->
        (Ptr (Ptr Word8)
 -> IO (Either (ByteString, ByteString) (ByteString, ByteString)))
-> IO (Either (ByteString, ByteString) (ByteString, ByteString))
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr (Ptr Word8)
  -> IO (Either (ByteString, ByteString) (ByteString, ByteString)))
 -> IO (Either (ByteString, ByteString) (ByteString, ByteString)))
-> (Ptr (Ptr Word8)
    -> IO (Either (ByteString, ByteString) (ByteString, ByteString)))
-> IO (Either (ByteString, ByteString) (ByteString, ByteString))
forall a b. (a -> b) -> a -> b
$ \ Ptr (Ptr Word8)
pRemBuf ->
            (Ptr CSize
 -> IO (Either (ByteString, ByteString) (ByteString, ByteString)))
-> IO (Either (ByteString, ByteString) (ByteString, ByteString))
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr CSize
  -> IO (Either (ByteString, ByteString) (ByteString, ByteString)))
 -> IO (Either (ByteString, ByteString) (ByteString, ByteString)))
-> (Ptr CSize
    -> IO (Either (ByteString, ByteString) (ByteString, ByteString)))
-> IO (Either (ByteString, ByteString) (ByteString, ByteString))
forall a b. (a -> b) -> a -> b
$ \ Ptr CSize
pRemLen -> do
                Ptr CSize -> CSize -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr CSize
pOutLen (Int -> CSize
forall a b. (Enum a, Enum b) => a -> b
castEnum Int
inLen)
                CInt
r <- Ptr Word8
-> CSize
-> Ptr Word8
-> Ptr CSize
-> Ptr (Ptr Word8)
-> Ptr CSize
-> IO CInt
c_qp_dec (Ptr CChar -> Ptr Word8
forall a b. Ptr a -> Ptr b
castPtr Ptr CChar
inBuf) (Int -> CSize
forall a b. (Enum a, Enum b) => a -> b
castEnum Int
inLen) Ptr Word8
outBuf Ptr CSize
pOutLen Ptr (Ptr Word8)
pRemBuf Ptr CSize
pRemLen
                CSize
outLen <- Ptr CSize -> IO CSize
forall a. Storable a => Ptr a -> IO a
peek Ptr CSize
pOutLen
                Ptr Word8
newOutBuf <- Ptr Word8 -> Int -> IO (Ptr Word8)
forall a. Ptr a -> Int -> IO (Ptr a)
reallocBytes Ptr Word8
outBuf (CSize -> Int
forall a b. (Enum a, Enum b) => a -> b
castEnum CSize
outLen)
                Ptr Word8
remBuf <- Ptr (Ptr Word8) -> IO (Ptr Word8)
forall a. Storable a => Ptr a -> IO a
peek Ptr (Ptr Word8)
pRemBuf
                CSize
remLen <- Ptr CSize -> IO CSize
forall a. Storable a => Ptr a -> IO a
peek Ptr CSize
pRemLen
                ByteString
remBs <- CStringLen -> IO ByteString
BS.packCStringLen (Ptr Word8 -> Ptr CChar
forall a b. Ptr a -> Ptr b
castPtr Ptr Word8
remBuf, CSize -> Int
forall a b. (Enum a, Enum b) => a -> b
castEnum CSize
remLen)
                ByteString
outBs <- Ptr Word8 -> Int -> IO () -> IO ByteString
BSU.unsafePackCStringFinalizer Ptr Word8
newOutBuf (CSize -> Int
forall a b. (Enum a, Enum b) => a -> b
castEnum CSize
outLen) (Ptr Word8 -> IO ()
forall a. Ptr a -> IO ()
free Ptr Word8
newOutBuf)
                if CInt
r CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
== CInt
0
                    then Either (ByteString, ByteString) (ByteString, ByteString)
-> IO (Either (ByteString, ByteString) (ByteString, ByteString))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either (ByteString, ByteString) (ByteString, ByteString)
 -> IO (Either (ByteString, ByteString) (ByteString, ByteString)))
-> Either (ByteString, ByteString) (ByteString, ByteString)
-> IO (Either (ByteString, ByteString) (ByteString, ByteString))
forall a b. (a -> b) -> a -> b
$ (ByteString, ByteString)
-> Either (ByteString, ByteString) (ByteString, ByteString)
forall a b. b -> Either a b
Right (ByteString
outBs, ByteString
remBs)
                    else Either (ByteString, ByteString) (ByteString, ByteString)
-> IO (Either (ByteString, ByteString) (ByteString, ByteString))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either (ByteString, ByteString) (ByteString, ByteString)
 -> IO (Either (ByteString, ByteString) (ByteString, ByteString)))
-> Either (ByteString, ByteString) (ByteString, ByteString)
-> IO (Either (ByteString, ByteString) (ByteString, ByteString))
forall a b. (a -> b) -> a -> b
$ (ByteString, ByteString)
-> Either (ByteString, ByteString) (ByteString, ByteString)
forall a b. a -> Either a b
Left (ByteString
outBs, ByteString
remBs)

-- | Convenient function that calls 'qpEncode' repeatedly until the whole input
-- data is encoded.
encode :: BS.ByteString -> BS.ByteString
encode :: ByteString -> ByteString
encode = [ByteString] -> ByteString
BS.concat ([ByteString] -> ByteString)
-> (ByteString -> [ByteString]) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString -> Bool) -> [ByteString] -> [ByteString]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Bool -> Bool
not (Bool -> Bool) -> (ByteString -> Bool) -> ByteString -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Bool
BS.null) ([ByteString] -> [ByteString])
-> (ByteString -> [ByteString]) -> ByteString -> [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString -> Maybe (ByteString, ByteString))
-> ByteString -> [ByteString]
forall b a. (b -> Maybe (a, b)) -> b -> [a]
unfoldr ((ByteString, ByteString) -> Maybe (ByteString, ByteString)
forall a. a -> Maybe a
Just ((ByteString, ByteString) -> Maybe (ByteString, ByteString))
-> (ByteString -> (ByteString, ByteString))
-> ByteString
-> Maybe (ByteString, ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> (ByteString, ByteString)
qpEncode)

-- | A synonym for 'qpDec'.
decode :: BS.ByteString -> Either (BS.ByteString, BS.ByteString) BS.ByteString
decode :: ByteString -> Either (ByteString, ByteString) ByteString
decode = ((ByteString, ByteString)
 -> Either (ByteString, ByteString) ByteString)
-> ((ByteString, ByteString)
    -> Either (ByteString, ByteString) ByteString)
-> Either (ByteString, ByteString) (ByteString, ByteString)
-> Either (ByteString, ByteString) ByteString
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (ByteString, ByteString)
-> Either (ByteString, ByteString) ByteString
forall a b. a -> Either a b
Left (ByteString, ByteString)
-> Either (ByteString, ByteString) ByteString
forall b. (b, ByteString) -> Either (b, ByteString) b
goR (Either (ByteString, ByteString) (ByteString, ByteString)
 -> Either (ByteString, ByteString) ByteString)
-> (ByteString
    -> Either (ByteString, ByteString) (ByteString, ByteString))
-> ByteString
-> Either (ByteString, ByteString) ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString
-> Either (ByteString, ByteString) (ByteString, ByteString)
qpDecode
  where
    goR :: (b, ByteString) -> Either (b, ByteString) b
goR a :: (b, ByteString)
a@(b
d, ByteString
r) = if ByteString -> Bool
BS.null ByteString
r then b -> Either (b, ByteString) b
forall a b. b -> Either a b
Right b
d else (b, ByteString) -> Either (b, ByteString) b
forall a b. a -> Either a b
Left (b, ByteString)
a