-- This file is part of purebred-email
-- Copyright (C) 2018-2021  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 <http://www.gnu.org/licenses/>.

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}

{- |

@encoded-word@s for representing non-7bit ASCII data in headers
(RFC 2047 and RFC 2231).

-}
module Data.MIME.EncodedWord
  (
    decodeEncodedWord
  , decodeEncodedWords
  , EncodedWord
  , encodedWord
  , buildEncodedWord
  , encodeEncodedWords
  , chooseEncodedWordEncoding
  ) where

import Control.Applicative ((<|>), liftA2, optional)
import Data.Maybe (fromMaybe)
import Data.Monoid (Sum(Sum), Any(Any))

import Control.Lens (to, clonePrism, review, view, foldMapOf)
import Data.Attoparsec.ByteString
import Data.Attoparsec.ByteString.Char8 (char8)
import Data.ByteString.Lens (bytes)
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as L
import qualified Data.ByteString.Builder as Builder
import qualified Data.CaseInsensitive as CI
import qualified Data.Text as T
import qualified Data.Text.Encoding as T

import Data.MIME.Charset
import Data.MIME.Error (EncodingError)
import Data.MIME.TransferEncoding
import Data.MIME.Base64
import Data.MIME.QuotedPrintable
import Data.IMF.Syntax (ci, takeTillString)

{-# ANN module ("HLint: ignore Eta reduce" :: String) #-}

data EncodedWord = EncodedWord
  { EncodedWord -> CI ByteString
_encodedWordCharset :: CI.CI B.ByteString
  , EncodedWord -> Maybe (CI ByteString)
_encodedWordLanguage :: Maybe (CI.CI B.ByteString)
  , EncodedWord -> CI ByteString
_encodedWordEncoding :: CI.CI B.ByteString
  , EncodedWord -> ByteString
_encodedWordText :: B.ByteString
  }

instance HasTransferEncoding EncodedWord where
  type TransferDecoded EncodedWord = TransferDecodedEncodedWord
  transferEncodingName :: (CI ByteString -> f (CI ByteString))
-> EncodedWord -> f EncodedWord
transferEncodingName = (EncodedWord -> CI ByteString)
-> (CI ByteString -> f (CI ByteString))
-> EncodedWord
-> f EncodedWord
forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to EncodedWord -> CI ByteString
_encodedWordEncoding
  transferEncodedData :: (ByteString -> f ByteString) -> EncodedWord -> f EncodedWord
transferEncodedData = (EncodedWord -> ByteString)
-> (ByteString -> f ByteString) -> EncodedWord -> f EncodedWord
forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to EncodedWord -> ByteString
_encodedWordText
  transferDecoded :: Optic' p f EncodedWord (Either e (TransferDecoded EncodedWord))
transferDecoded = (EncodedWord -> Either e TransferDecodedEncodedWord)
-> Optic' p f EncodedWord (Either e TransferDecodedEncodedWord)
forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to ((EncodedWord -> Either e TransferDecodedEncodedWord)
 -> Optic' p f EncodedWord (Either e TransferDecodedEncodedWord))
-> (EncodedWord -> Either e TransferDecodedEncodedWord)
-> Optic' p f EncodedWord (Either e TransferDecodedEncodedWord)
forall a b. (a -> b) -> a -> b
$ \a :: EncodedWord
a@(EncodedWord CI ByteString
charset Maybe (CI ByteString)
lang CI ByteString
_ ByteString
_) ->
    CI ByteString
-> Maybe (CI ByteString)
-> ByteString
-> TransferDecodedEncodedWord
TransferDecodedEncodedWord CI ByteString
charset Maybe (CI ByteString)
lang (ByteString -> TransferDecodedEncodedWord)
-> Either e ByteString -> Either e TransferDecodedEncodedWord
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Getting (Either e ByteString) EncodedWord (Either e ByteString)
-> EncodedWord -> Either e ByteString
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (Either e ByteString) EncodedWord (Either e ByteString)
forall a e (p :: * -> * -> *) (f :: * -> *).
(HasTransferEncoding a, AsTransferEncodingError e, Profunctor p,
 Contravariant f) =>
Optic' p f a (Either e ByteString)
transferDecodedBytes EncodedWord
a
  transferEncode :: TransferDecoded EncodedWord -> EncodedWord
transferEncode = TransferDecoded EncodedWord -> EncodedWord
TransferDecodedEncodedWord -> EncodedWord
transferEncodeEncodedWord


data TransferDecodedEncodedWord = TransferDecodedEncodedWord
  { TransferDecodedEncodedWord -> CI ByteString
_transDecWordCharset :: CI.CI B.ByteString
  , TransferDecodedEncodedWord -> Maybe (CI ByteString)
_transDecWordLanguage :: Maybe (CI.CI B.ByteString)
  , TransferDecodedEncodedWord -> ByteString
_transDecWordText :: B.ByteString
  }

-- | 'charsetEncode' uses UTF-8, but sets the charset to @us-ascii@
-- if the text only contains ASCII characters.  No language is set
-- upon encoding.
--
instance HasCharset TransferDecodedEncodedWord where
  type Decoded TransferDecodedEncodedWord = T.Text
  charsetName :: (Maybe (CI ByteString) -> f (Maybe (CI ByteString)))
-> TransferDecodedEncodedWord -> f TransferDecodedEncodedWord
charsetName = (TransferDecodedEncodedWord -> Maybe (CI ByteString))
-> (Maybe (CI ByteString) -> f (Maybe (CI ByteString)))
-> TransferDecodedEncodedWord
-> f TransferDecodedEncodedWord
forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to (CI ByteString -> Maybe (CI ByteString)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CI ByteString -> Maybe (CI ByteString))
-> (TransferDecodedEncodedWord -> CI ByteString)
-> TransferDecodedEncodedWord
-> Maybe (CI ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TransferDecodedEncodedWord -> CI ByteString
_transDecWordCharset)
  charsetData :: (ByteString -> f ByteString)
-> TransferDecodedEncodedWord -> f TransferDecodedEncodedWord
charsetData = (TransferDecodedEncodedWord -> ByteString)
-> (ByteString -> f ByteString)
-> TransferDecodedEncodedWord
-> f TransferDecodedEncodedWord
forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to TransferDecodedEncodedWord -> ByteString
_transDecWordText
  charsetDecoded :: CharsetLookup
-> forall (p :: * -> * -> *) (f :: * -> *).
   (Profunctor p, Contravariant f) =>
   Optic'
     p
     f
     TransferDecodedEncodedWord
     (Either e (Decoded TransferDecodedEncodedWord))
charsetDecoded CharsetLookup
charsets = CharsetLookup
-> Optic' p f TransferDecodedEncodedWord (Either e Text)
forall a e (p :: * -> * -> *) (f :: * -> *).
(HasCharset a, AsCharsetError e, Profunctor p, Contravariant f) =>
CharsetLookup -> Optic' p f a (Either e Text)
charsetText CharsetLookup
charsets

  charsetEncode :: Decoded TransferDecodedEncodedWord -> TransferDecodedEncodedWord
charsetEncode Decoded TransferDecodedEncodedWord
s =
    let
      bs :: ByteString
bs = Text -> ByteString
T.encodeUtf8 Text
Decoded TransferDecodedEncodedWord
s
      charset :: CI ByteString
charset = if (Word8 -> Bool) -> ByteString -> Bool
B.all (Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
< Word8
0x80) ByteString
bs then CI ByteString
"us-ascii" else CI ByteString
"utf-8"
    in CI ByteString
-> Maybe (CI ByteString)
-> ByteString
-> TransferDecodedEncodedWord
TransferDecodedEncodedWord CI ByteString
charset Maybe (CI ByteString)
forall a. Maybe a
Nothing ByteString
bs

-- NOTE: may not be > 75 chars long
--
-- NOTE: DOES NOT PARSE THE LEADING "=?"
--
encodedWord :: Parser EncodedWord
encodedWord :: Parser EncodedWord
encodedWord =
  CI ByteString
-> Maybe (CI ByteString)
-> CI ByteString
-> ByteString
-> EncodedWord
EncodedWord
  (CI ByteString
 -> Maybe (CI ByteString)
 -> CI ByteString
 -> ByteString
 -> EncodedWord)
-> Parser ByteString (CI ByteString)
-> Parser
     ByteString
     (Maybe (CI ByteString)
      -> CI ByteString -> ByteString -> EncodedWord)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString -> Parser ByteString (CI ByteString)
forall s. FoldCase s => Parser s -> Parser (CI s)
ci Parser ByteString
token
  Parser
  ByteString
  (Maybe (CI ByteString)
   -> CI ByteString -> ByteString -> EncodedWord)
-> Parser ByteString (Maybe (CI ByteString))
-> Parser ByteString (CI ByteString -> ByteString -> EncodedWord)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser ByteString (CI ByteString)
-> Parser ByteString (Maybe (CI ByteString))
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Char -> Parser Word8
char8 Char
'*' Parser Word8
-> Parser ByteString (CI ByteString)
-> Parser ByteString (CI ByteString)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ByteString -> Parser ByteString (CI ByteString)
forall s. FoldCase s => Parser s -> Parser (CI s)
ci Parser ByteString
token)
  Parser ByteString (CI ByteString -> ByteString -> EncodedWord)
-> Parser ByteString (CI ByteString)
-> Parser ByteString (ByteString -> EncodedWord)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Parser Word8
qmark Parser Word8
-> Parser ByteString (CI ByteString)
-> Parser ByteString (CI ByteString)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ByteString -> Parser ByteString (CI ByteString)
forall s. FoldCase s => Parser s -> Parser (CI s)
ci Parser ByteString
token)
  Parser ByteString (ByteString -> EncodedWord)
-> Parser ByteString -> Parser EncodedWord
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Parser Word8
qmark Parser Word8 -> Parser ByteString -> Parser ByteString
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ByteString
encodedText Parser ByteString -> Parser Word8 -> Parser ByteString
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser Word8
qmark Parser ByteString -> Parser Word8 -> Parser ByteString
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser Word8
eq)
  where
    eq :: Parser Word8
eq = Char -> Parser Word8
char8 Char
'='
    qmark :: Parser Word8
qmark = Char -> Parser Word8
char8 Char
'?'
    token :: Parser ByteString
token = (Word8 -> Bool) -> Parser ByteString
takeWhile1 (\Word8
c -> Word8
c Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
>= Word8
33 Bool -> Bool -> Bool
&& Word8
c Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word8
126 Bool -> Bool -> Bool
&& String -> Word8 -> Bool
notInClass String
"()<>@,;:\\\"/[]?.=*" Word8
c)

    -- any printable ascii char other than ? or SPACE
    encodedText :: Parser ByteString
encodedText = (Word8 -> Bool) -> Parser ByteString
takeWhile1 (\Word8
c -> (Word8
c Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
>= Word8
33 Bool -> Bool -> Bool
&& Word8
c Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
< Word8
63) Bool -> Bool -> Bool
|| (Word8
c Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
> Word8
63 Bool -> Bool -> Bool
&& Word8
c Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word8
127))

serialiseEncodedWord :: EncodedWord -> B.ByteString
serialiseEncodedWord :: EncodedWord -> ByteString
serialiseEncodedWord = ByteString -> ByteString
L.toStrict (ByteString -> ByteString)
-> (EncodedWord -> ByteString) -> EncodedWord -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> ByteString
Builder.toLazyByteString (Builder -> ByteString)
-> (EncodedWord -> Builder) -> EncodedWord -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EncodedWord -> Builder
buildEncodedWord

buildEncodedWord :: EncodedWord -> Builder.Builder
buildEncodedWord :: EncodedWord -> Builder
buildEncodedWord (EncodedWord CI ByteString
charset Maybe (CI ByteString)
lang CI ByteString
enc ByteString
s) =
  Builder
"=?" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
Builder.byteString (CI ByteString -> ByteString
forall s. CI s -> s
CI.original CI ByteString
charset)
  Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
-> (CI ByteString -> Builder) -> Maybe (CI ByteString) -> Builder
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Builder
"" (\CI ByteString
l -> Builder
"*" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
Builder.byteString (CI ByteString -> ByteString
forall s. CI s -> s
CI.original CI ByteString
l)) Maybe (CI ByteString)
lang
  Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"?" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
Builder.byteString (CI ByteString -> ByteString
forall s. CI s -> s
CI.original CI ByteString
enc)
  Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"?" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
Builder.byteString ByteString
s Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"?="


transferEncodeEncodedWord :: TransferDecodedEncodedWord -> EncodedWord
transferEncodeEncodedWord :: TransferDecodedEncodedWord -> EncodedWord
transferEncodeEncodedWord (TransferDecodedEncodedWord CI ByteString
charset Maybe (CI ByteString)
lang ByteString
s) =
  let (CI ByteString
enc, EncodedWordEncoding
p) = (CI ByteString, EncodedWordEncoding)
-> Maybe (CI ByteString, EncodedWordEncoding)
-> (CI ByteString, EncodedWordEncoding)
forall a. a -> Maybe a -> a
fromMaybe (CI ByteString
"Q", EncodedWordEncoding
q) (ByteString -> Maybe (CI ByteString, EncodedWordEncoding)
chooseEncodedWordEncoding ByteString
s)
  in CI ByteString
-> Maybe (CI ByteString)
-> CI ByteString
-> ByteString
-> EncodedWord
EncodedWord CI ByteString
charset Maybe (CI ByteString)
lang CI ByteString
enc (AReview ByteString ByteString -> ByteString -> ByteString
forall b (m :: * -> *) t. MonadReader b m => AReview t b -> m t
review (EncodedWordEncoding
-> Prism ByteString ByteString ByteString ByteString
forall s t a b. APrism s t a b -> Prism s t a b
clonePrism EncodedWordEncoding
p) ByteString
s)

-- | RFC 2047 and RFC 2231 define the /encoded-words/ mechanism for
-- embedding non-ASCII data in headers.  This function locates
-- encoded-words and decodes them.
--
-- @
-- λ> T.putStrLn $ decodeEncodedWords defaultCharsets "hello =?utf-8?B?5LiW55WM?=!"
-- hello 世界!
-- @
--
-- If parsing fails or the encoding is unrecognised the encoded-word
-- is left unchanged in the result.
--
-- @
-- λ> T.putStrLn $ decodeEncodedWords defaultCharsets "=?utf-8?B?bogus?="
-- =?utf-8?B?bogus?=
--
-- λ> T.putStrLn $ decodeEncodedWords defaultCharsets "=?utf-8?X?unrecognised_encoding?="
-- =?utf-8?X?unrecognised_encoding?=
-- @
--
-- Language specification is supported (the datum is discarded).
--
-- @
-- λ> T.putStrLn $ decodeEncodedWords defaultCharsets "=?utf-8*es?Q?hola_mundo!?="
-- hola mundo!
-- @
--
decodeEncodedWords :: CharsetLookup -> B.ByteString -> T.Text
decodeEncodedWords :: CharsetLookup -> ByteString -> Text
decodeEncodedWords CharsetLookup
charsets ByteString
s =
  (String -> Text)
-> ([Either ByteString EncodedWord] -> Text)
-> Either String [Either ByteString EncodedWord]
-> Text
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Text -> String -> Text
forall a b. a -> b -> a
const (ByteString -> Text
decodeLenient ByteString
s)) ((Either ByteString EncodedWord -> Text)
-> [Either ByteString EncodedWord] -> Text
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Either ByteString EncodedWord -> Text
conv) (Parser [Either ByteString EncodedWord]
-> ByteString -> Either String [Either ByteString EncodedWord]
forall a. Parser a -> ByteString -> Either String a
parseOnly Parser [Either ByteString EncodedWord]
tokens ByteString
s)
  where
    tokens :: Parser [Either B.ByteString EncodedWord]
    tokens :: Parser [Either ByteString EncodedWord]
tokens = (Either ByteString EncodedWord
 -> [Either ByteString EncodedWord]
 -> [Either ByteString EncodedWord])
-> Parser ByteString (Either ByteString EncodedWord)
-> Parser [Either ByteString EncodedWord]
-> Parser [Either ByteString EncodedWord]
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (:) (ByteString -> Either ByteString EncodedWord
forall a b. a -> Either a b
Left (ByteString -> Either ByteString EncodedWord)
-> Parser ByteString
-> Parser ByteString (Either ByteString EncodedWord)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> Parser ByteString
takeTillString ByteString
"=?") Parser [Either ByteString EncodedWord]
more
          Parser [Either ByteString EncodedWord]
-> Parser [Either ByteString EncodedWord]
-> Parser [Either ByteString EncodedWord]
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ((Either ByteString EncodedWord
-> [Either ByteString EncodedWord]
-> [Either ByteString EncodedWord]
forall a. a -> [a] -> [a]
:[]) (Either ByteString EncodedWord -> [Either ByteString EncodedWord])
-> (ByteString -> Either ByteString EncodedWord)
-> ByteString
-> [Either ByteString EncodedWord]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either ByteString EncodedWord
forall a b. a -> Either a b
Left (ByteString -> [Either ByteString EncodedWord])
-> Parser ByteString -> Parser [Either ByteString EncodedWord]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString
takeByteString)
    more :: Parser [Either ByteString EncodedWord]
more = (Either ByteString EncodedWord
 -> [Either ByteString EncodedWord]
 -> [Either ByteString EncodedWord])
-> Parser ByteString (Either ByteString EncodedWord)
-> Parser [Either ByteString EncodedWord]
-> Parser [Either ByteString EncodedWord]
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (:) (EncodedWord -> Either ByteString EncodedWord
forall a b. b -> Either a b
Right (EncodedWord -> Either ByteString EncodedWord)
-> Parser EncodedWord
-> Parser ByteString (Either ByteString EncodedWord)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser EncodedWord
encodedWord Parser ByteString (Either ByteString EncodedWord)
-> Parser ByteString (Either ByteString EncodedWord)
-> Parser ByteString (Either ByteString EncodedWord)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Either ByteString EncodedWord
-> Parser ByteString (Either ByteString EncodedWord)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString -> Either ByteString EncodedWord
forall a b. a -> Either a b
Left ByteString
"=?")) Parser [Either ByteString EncodedWord]
tokens
    conv :: Either ByteString EncodedWord -> Text
conv = (ByteString -> Text)
-> (EncodedWord -> Text) -> Either ByteString EncodedWord -> Text
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ByteString -> Text
decodeLenient (CharsetLookup -> EncodedWord -> Text
decodeEncodedWord CharsetLookup
charsets)

-- | Decode an 'EncodedWord'.  If transfer or charset decoding fails,
-- returns the serialised encoded word.
decodeEncodedWord :: CharsetLookup -> EncodedWord -> T.Text
decodeEncodedWord :: CharsetLookup -> EncodedWord -> Text
decodeEncodedWord CharsetLookup
charsets EncodedWord
w =
  (EncodingError -> Text)
-> (Text -> Text) -> Either EncodingError Text -> Text
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either
    (ByteString -> Text
decodeLenient (ByteString -> Text)
-> (EncodingError -> ByteString) -> EncodingError -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> EncodingError -> ByteString
forall a b. a -> b -> a
const (EncodedWord -> ByteString
serialiseEncodedWord EncodedWord
w) :: EncodingError -> T.Text)
    Text -> Text
forall a. a -> a
id
    (Getting
  (Either EncodingError TransferDecodedEncodedWord)
  EncodedWord
  (Either EncodingError TransferDecodedEncodedWord)
-> EncodedWord -> Either EncodingError TransferDecodedEncodedWord
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting
  (Either EncodingError TransferDecodedEncodedWord)
  EncodedWord
  (Either EncodingError TransferDecodedEncodedWord)
forall a e (p :: * -> * -> *) (f :: * -> *).
(HasTransferEncoding a, AsTransferEncodingError e, Profunctor p,
 Contravariant f) =>
Optic' p f a (Either e (TransferDecoded a))
transferDecoded EncodedWord
w Either EncodingError TransferDecodedEncodedWord
-> (TransferDecodedEncodedWord -> Either EncodingError Text)
-> Either EncodingError Text
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Getting
  (Either EncodingError Text)
  TransferDecodedEncodedWord
  (Either EncodingError Text)
-> TransferDecodedEncodedWord -> Either EncodingError Text
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (CharsetLookup
-> forall (p :: * -> * -> *) (f :: * -> *).
   (Profunctor p, Contravariant f) =>
   Optic'
     p
     f
     TransferDecodedEncodedWord
     (Either EncodingError (Decoded TransferDecodedEncodedWord))
forall a e.
(HasCharset a, AsCharsetError e) =>
CharsetLookup
-> forall (p :: * -> * -> *) (f :: * -> *).
   (Profunctor p, Contravariant f) =>
   Optic' p f a (Either e (Decoded a))
charsetDecoded CharsetLookup
charsets))

-- | This function encodes necessary parts of some text
--
-- Currently turns the whole text into a single encoded word, if necessary.
encodeEncodedWords :: T.Text -> B.ByteString
encodeEncodedWords :: Text -> ByteString
encodeEncodedWords Text
t = ByteString
-> ((CI ByteString, EncodedWordEncoding) -> ByteString)
-> Maybe (CI ByteString, EncodedWordEncoding)
-> ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ByteString
utf8 (ByteString -> (CI ByteString, EncodedWordEncoding) -> ByteString
forall a b. a -> b -> a
const ByteString
ew) (ByteString -> Maybe (CI ByteString, EncodedWordEncoding)
chooseEncodedWordEncoding ByteString
utf8)
  where
    ew :: ByteString
ew = ByteString -> [ByteString] -> ByteString
B.intercalate ByteString
" " ([ByteString] -> ByteString)
-> (ByteString -> [ByteString]) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString -> ByteString) -> [ByteString] -> [ByteString]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> ByteString
encOrNot ([ByteString] -> [ByteString])
-> (ByteString -> [ByteString]) -> ByteString -> [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> ByteString -> [ByteString]
B.split Word8
32 (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ ByteString
utf8
    encOrNot :: ByteString -> ByteString
encOrNot ByteString
s = ByteString
-> ((CI ByteString, EncodedWordEncoding) -> ByteString)
-> Maybe (CI ByteString, EncodedWordEncoding)
-> ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ByteString
s (ByteString -> (CI ByteString, EncodedWordEncoding) -> ByteString
forall b.
b
-> (CI ByteString, APrism ByteString ByteString b b) -> ByteString
g ByteString
s) (ByteString -> Maybe (CI ByteString, EncodedWordEncoding)
chooseEncodedWordEncoding ByteString
s)
    g :: b
-> (CI ByteString, APrism ByteString ByteString b b) -> ByteString
g b
s (CI ByteString
enc, APrism ByteString ByteString b b
p) = EncodedWord -> ByteString
serialiseEncodedWord (EncodedWord -> ByteString) -> EncodedWord -> ByteString
forall a b. (a -> b) -> a -> b
$
      CI ByteString
-> Maybe (CI ByteString)
-> CI ByteString
-> ByteString
-> EncodedWord
EncodedWord CI ByteString
"utf-8" Maybe (CI ByteString)
forall a. Maybe a
Nothing CI ByteString
enc (AReview ByteString b -> b -> ByteString
forall b (m :: * -> *) t. MonadReader b m => AReview t b -> m t
review (APrism ByteString ByteString b b -> Prism ByteString ByteString b b
forall s t a b. APrism s t a b -> Prism s t a b
clonePrism APrism ByteString ByteString b b
p) b
s)
    utf8 :: ByteString
utf8 = Text -> ByteString
T.encodeUtf8 Text
t

chooseEncodedWordEncoding :: B.ByteString -> Maybe (TransferEncodingName, TransferEncoding)
chooseEncodedWordEncoding :: ByteString -> Maybe (CI ByteString, EncodedWordEncoding)
chooseEncodedWordEncoding ByteString
s
  | Bool -> Bool
not Bool
doEnc = Maybe (CI ByteString, EncodedWordEncoding)
forall a. Maybe a
Nothing
  | Int
nQP Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
nB64 = (CI ByteString, EncodedWordEncoding)
-> Maybe (CI ByteString, EncodedWordEncoding)
forall a. a -> Maybe a
Just (CI ByteString
"Q", EncodedWordEncoding
q)
  | Bool
otherwise = (CI ByteString, EncodedWordEncoding)
-> Maybe (CI ByteString, EncodedWordEncoding)
forall a. a -> Maybe a
Just (CI ByteString
"B", EncodedWordEncoding
b)
  where
    -- https://tools.ietf.org/html/rfc5322#section-3.5 'text'
    needEnc :: a -> Bool
needEnc a
c = a
c a -> a -> Bool
forall a. Ord a => a -> a -> Bool
> a
127 Bool -> Bool -> Bool
|| a
c a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
0
    qpBytes :: Word8 -> p
qpBytes Word8
c
      | QuotedPrintableMode -> Word8 -> Bool
encodingRequiredNonEOL QuotedPrintableMode
Q Word8
c = p
3
      | Bool
otherwise = p
1
    (Any Bool
doEnc, Sum Int
nQP) = Getting (Any, Sum Int) ByteString Word8
-> (Word8 -> (Any, Sum Int)) -> ByteString -> (Any, Sum Int)
forall r s a. Getting r s a -> (a -> r) -> s -> r
foldMapOf Getting (Any, Sum Int) ByteString Word8
forall t. IsByteString t => IndexedTraversal' Int t Word8
bytes (\Word8
c -> (Bool -> Any
Any (Word8 -> Bool
forall a. (Ord a, Num a) => a -> Bool
needEnc Word8
c), Int -> Sum Int
forall a. a -> Sum a
Sum (Word8 -> Int
forall p. Num p => Word8 -> p
qpBytes Word8
c))) ByteString
s
    nB64 :: Int
nB64 = ((ByteString -> Int
B.length ByteString
s Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
3) Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
4