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

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

{- |

MIME content transfer encodings.

-}
module Data.MIME.TransferEncoding
  (
    HasTransferEncoding(..)
  , TransferEncodingName
  , transferDecodedBytes
  , transferEncodings
  , TransferEncodingError(..)
  , AsTransferEncodingError(..)
  , TransferEncoding
  , chooseTransferEncoding
  ) where

import Data.Monoid (Sum(Sum), Any(Any))

import Control.Lens
import qualified Data.ByteString as B
import Data.ByteString.Lens (bytes)
import qualified Data.CaseInsensitive as CI

import Data.MIME.Base64
import Data.MIME.QuotedPrintable

type TransferEncodingName = CI.CI B.ByteString
type TransferEncoding = APrism' B.ByteString B.ByteString

data TransferEncodingError
  = TransferEncodingUnsupported TransferEncodingName
  | TransferDecodeError TransferEncodingName
  deriving (Int -> TransferEncodingError -> ShowS
[TransferEncodingError] -> ShowS
TransferEncodingError -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TransferEncodingError] -> ShowS
$cshowList :: [TransferEncodingError] -> ShowS
show :: TransferEncodingError -> String
$cshow :: TransferEncodingError -> String
showsPrec :: Int -> TransferEncodingError -> ShowS
$cshowsPrec :: Int -> TransferEncodingError -> ShowS
Show)

class AsTransferEncodingError s where
  _TransferEncodingError :: Prism' s TransferEncodingError
  _TransferEncodingUnsupported :: Prism' s TransferEncodingName
  _TransferDecodeError :: Prism' s TransferEncodingName

  _TransferEncodingUnsupported = forall s.
AsTransferEncodingError s =>
Prism' s TransferEncodingError
_TransferEncodingError forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s.
AsTransferEncodingError s =>
Prism' s TransferEncodingName
_TransferEncodingUnsupported
  _TransferDecodeError = forall s.
AsTransferEncodingError s =>
Prism' s TransferEncodingError
_TransferEncodingError forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s.
AsTransferEncodingError s =>
Prism' s TransferEncodingName
_TransferDecodeError

instance AsTransferEncodingError TransferEncodingError where
  _TransferEncodingError :: Prism' TransferEncodingError TransferEncodingError
_TransferEncodingError = forall a. a -> a
id
  _TransferEncodingUnsupported :: Prism' TransferEncodingError TransferEncodingName
_TransferEncodingUnsupported = forall b s a. (b -> s) -> (s -> Maybe a) -> Prism s s a b
prism' TransferEncodingName -> TransferEncodingError
TransferEncodingUnsupported forall a b. (a -> b) -> a -> b
$ \case
      TransferEncodingUnsupported TransferEncodingName
k -> forall a. a -> Maybe a
Just TransferEncodingName
k ; TransferEncodingError
_ -> forall a. Maybe a
Nothing
  _TransferDecodeError :: Prism' TransferEncodingError TransferEncodingName
_TransferDecodeError = forall b s a. (b -> s) -> (s -> Maybe a) -> Prism s s a b
prism' TransferEncodingName -> TransferEncodingError
TransferDecodeError forall a b. (a -> b) -> a -> b
$ \case
      TransferDecodeError TransferEncodingName
k -> forall a. a -> Maybe a
Just TransferEncodingName
k ; TransferEncodingError
_ -> forall a. Maybe a
Nothing


-- | Data types that can have /transfer encoding/.
class HasTransferEncoding a where
  type TransferDecoded a

  -- | Get the declared or default transfer encoding name.
  transferEncodingName :: Getter a TransferEncodingName

  -- | Return the encoded data in the structure.
  transferEncodedData :: Getter a B.ByteString

  -- | Perform content transfer decoding.
  transferDecoded
    :: (AsTransferEncodingError e, Profunctor p, Contravariant f)
    => Optic' p f a (Either e (TransferDecoded a))

  -- | Perform content transfer decoding (monomorphic error type).
  transferDecoded'
    :: (Profunctor p, Contravariant f)
    => Optic' p f a (Either TransferEncodingError (TransferDecoded a))
  transferDecoded' = forall a e (p :: * -> * -> *) (f :: * -> *).
(HasTransferEncoding a, AsTransferEncodingError e, Profunctor p,
 Contravariant f) =>
Optic' p f a (Either e (TransferDecoded a))
transferDecoded

  -- | Encode the data
  transferEncode :: TransferDecoded a -> a

-- | Decode the object according to the declared content transfer encoding.
transferDecodedBytes
  :: (HasTransferEncoding a, AsTransferEncodingError e, Profunctor p, Contravariant f)
  => Optic' p f a (Either e B.ByteString)
transferDecodedBytes :: forall a e (p :: * -> * -> *) (f :: * -> *).
(HasTransferEncoding a, AsTransferEncodingError e, Profunctor p,
 Contravariant f) =>
Optic' p f a (Either e ByteString)
transferDecodedBytes = forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to forall a b. (a -> b) -> a -> b
$ \a
a -> do
  let encName :: TransferEncodingName
encName = forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a. HasTransferEncoding a => Getter a TransferEncodingName
transferEncodingName a
a
  TransferEncoding
enc <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ forall b (m :: * -> *) t. MonadReader b m => AReview t b -> m t
review forall s.
AsTransferEncodingError s =>
Prism' s TransferEncodingName
_TransferEncodingUnsupported TransferEncodingName
encName) forall a b. b -> Either a b
Right
    (forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup TransferEncodingName
encName [(TransferEncodingName, TransferEncoding)]
transferEncodings)
  let s :: ByteString
s = forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a. HasTransferEncoding a => Getter a ByteString
transferEncodedData a
a
  forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ forall b (m :: * -> *) t. MonadReader b m => AReview t b -> m t
review forall s.
AsTransferEncodingError s =>
Prism' s TransferEncodingName
_TransferDecodeError TransferEncodingName
encName) forall a b. b -> Either a b
Right (forall s (m :: * -> *) a.
MonadReader s m =>
Getting (First a) s a -> m (Maybe a)
preview (forall s t a b. APrism s t a b -> Prism s t a b
clonePrism TransferEncoding
enc) ByteString
s)

-- Message instance:
    --v = fromMaybe "7bit" $ preview (header "content-transfer-encoding") h
-- | Get the Content-Transfer-Encoding for an entity.
-- Defaults to @7bit@ (RFC 2045 §6.1) if the header is
-- not present.  Fails on /unrecognised/ values.
--

transferEncodings :: [(CI.CI B.ByteString, TransferEncoding)]
transferEncodings :: [(TransferEncodingName, TransferEncoding)]
transferEncodings =
  [ (TransferEncodingName
"7bit", forall a. a -> a
id)
  , (TransferEncodingName
"8bit", forall a. a -> a
id)
  , (TransferEncodingName
"binary", forall a. a -> a
id)
  , (TransferEncodingName
"quoted-printable", TransferEncoding
contentTransferEncodingQuotedPrintable)
  , (TransferEncodingName
"base64", TransferEncoding
contentTransferEncodingBase64)
  , (TransferEncodingName
"q", TransferEncoding
q)
  , (TransferEncodingName
"b", TransferEncoding
b)
  ]

-- | Inspect the data and choose a transfer encoding to use: @7bit@
-- if the data can be transmitted as-is, otherwise whichever of
-- @quoted-printable@ or @base64@ should result in smaller output.
--
chooseTransferEncoding :: B.ByteString -> (TransferEncodingName, TransferEncoding)
chooseTransferEncoding :: ByteString -> (TransferEncodingName, TransferEncoding)
chooseTransferEncoding ByteString
s
  -- TODO: does not handle max line length of 998
  | Bool -> Bool
not Bool
doEnc = (TransferEncodingName
"7bit", forall a. a -> a
id)
  | Int
nQP forall a. Ord a => a -> a -> Bool
< Int
nB64 = (TransferEncodingName
"quoted-printable", TransferEncoding
contentTransferEncodingQuotedPrintable)
  | Bool
otherwise = (TransferEncodingName
"base64", TransferEncoding
contentTransferEncodingBase64)
  where
    -- https://tools.ietf.org/html/rfc5322#section-3.5 'text'
    needEnc :: a -> Bool
needEnc a
c = a
c forall a. Ord a => a -> a -> Bool
> a
127 Bool -> Bool -> Bool
|| a
c forall a. Eq a => a -> a -> Bool
== a
0
    qpBytes :: Word8 -> a
qpBytes Word8
c
      | QuotedPrintableMode -> Word8 -> Bool
encodingRequiredNonEOL QuotedPrintableMode
QuotedPrintable Word8
c = a
3
      | Bool
otherwise = a
1
    (Any Bool
doEnc, Sum Int
nQP) = forall r s a. Getting r s a -> (a -> r) -> s -> r
foldMapOf forall t. IsByteString t => IndexedTraversal' Int t Word8
bytes (\Word8
c -> (Bool -> Any
Any (forall {a}. (Ord a, Num a) => a -> Bool
needEnc Word8
c), forall a. a -> Sum a
Sum (forall {a}. Num a => Word8 -> a
qpBytes Word8
c))) ByteString
s
    nB64 :: Int
nB64 = ((ByteString -> Int
B.length ByteString
s forall a. Num a => a -> a -> a
+ Int
2) forall a. Integral a => a -> a -> a
`div` Int
3) forall a. Num a => a -> a -> a
* Int
4