{-# 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
(Int -> TransferEncodingError -> ShowS)
-> (TransferEncodingError -> String)
-> ([TransferEncodingError] -> ShowS)
-> Show TransferEncodingError
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 = p TransferEncodingError (f TransferEncodingError) -> p s (f s)
forall s.
AsTransferEncodingError s =>
Prism' s TransferEncodingError
_TransferEncodingError (p TransferEncodingError (f TransferEncodingError) -> p s (f s))
-> (p TransferEncodingName (f TransferEncodingName)
    -> p TransferEncodingError (f TransferEncodingError))
-> p TransferEncodingName (f TransferEncodingName)
-> p s (f s)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. p TransferEncodingName (f TransferEncodingName)
-> p TransferEncodingError (f TransferEncodingError)
forall s.
AsTransferEncodingError s =>
Prism' s TransferEncodingName
_TransferEncodingUnsupported
  _TransferDecodeError = p TransferEncodingError (f TransferEncodingError) -> p s (f s)
forall s.
AsTransferEncodingError s =>
Prism' s TransferEncodingError
_TransferEncodingError (p TransferEncodingError (f TransferEncodingError) -> p s (f s))
-> (p TransferEncodingName (f TransferEncodingName)
    -> p TransferEncodingError (f TransferEncodingError))
-> p TransferEncodingName (f TransferEncodingName)
-> p s (f s)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. p TransferEncodingName (f TransferEncodingName)
-> p TransferEncodingError (f TransferEncodingError)
forall s.
AsTransferEncodingError s =>
Prism' s TransferEncodingName
_TransferDecodeError

instance AsTransferEncodingError TransferEncodingError where
  _TransferEncodingError :: p TransferEncodingError (f TransferEncodingError)
-> p TransferEncodingError (f TransferEncodingError)
_TransferEncodingError = p TransferEncodingError (f TransferEncodingError)
-> p TransferEncodingError (f TransferEncodingError)
forall a. a -> a
id
  _TransferEncodingUnsupported :: p TransferEncodingName (f TransferEncodingName)
-> p TransferEncodingError (f TransferEncodingError)
_TransferEncodingUnsupported = (TransferEncodingName -> TransferEncodingError)
-> (TransferEncodingError -> Maybe TransferEncodingName)
-> Prism' TransferEncodingError TransferEncodingName
forall b s a. (b -> s) -> (s -> Maybe a) -> Prism s s a b
prism' TransferEncodingName -> TransferEncodingError
TransferEncodingUnsupported ((TransferEncodingError -> Maybe TransferEncodingName)
 -> Prism' TransferEncodingError TransferEncodingName)
-> (TransferEncodingError -> Maybe TransferEncodingName)
-> Prism' TransferEncodingError TransferEncodingName
forall a b. (a -> b) -> a -> b
$ \case
      TransferEncodingUnsupported TransferEncodingName
k -> TransferEncodingName -> Maybe TransferEncodingName
forall a. a -> Maybe a
Just TransferEncodingName
k ; TransferEncodingError
_ -> Maybe TransferEncodingName
forall a. Maybe a
Nothing
  _TransferDecodeError :: p TransferEncodingName (f TransferEncodingName)
-> p TransferEncodingError (f TransferEncodingError)
_TransferDecodeError = (TransferEncodingName -> TransferEncodingError)
-> (TransferEncodingError -> Maybe TransferEncodingName)
-> Prism' TransferEncodingError TransferEncodingName
forall b s a. (b -> s) -> (s -> Maybe a) -> Prism s s a b
prism' TransferEncodingName -> TransferEncodingError
TransferDecodeError ((TransferEncodingError -> Maybe TransferEncodingName)
 -> Prism' TransferEncodingError TransferEncodingName)
-> (TransferEncodingError -> Maybe TransferEncodingName)
-> Prism' TransferEncodingError TransferEncodingName
forall a b. (a -> b) -> a -> b
$ \case
      TransferDecodeError TransferEncodingName
k -> TransferEncodingName -> Maybe TransferEncodingName
forall a. a -> Maybe a
Just TransferEncodingName
k ; TransferEncodingError
_ -> Maybe TransferEncodingName
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' = Optic' p f a (Either TransferEncodingError (TransferDecoded a))
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 :: Optic' p f a (Either e ByteString)
transferDecodedBytes = (a -> Either e ByteString) -> Optic' p f a (Either e ByteString)
forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to ((a -> Either e ByteString) -> Optic' p f a (Either e ByteString))
-> (a -> Either e ByteString) -> Optic' p f a (Either e ByteString)
forall a b. (a -> b) -> a -> b
$ \a
a -> do
  let encName :: TransferEncodingName
encName = Getting TransferEncodingName a TransferEncodingName
-> a -> TransferEncodingName
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting TransferEncodingName a TransferEncodingName
forall a. HasTransferEncoding a => Getter a TransferEncodingName
transferEncodingName a
a
  TransferEncoding
enc <- Either e TransferEncoding
-> (TransferEncoding -> Either e TransferEncoding)
-> Maybe TransferEncoding
-> Either e TransferEncoding
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (e -> Either e TransferEncoding
forall a b. a -> Either a b
Left (e -> Either e TransferEncoding) -> e -> Either e TransferEncoding
forall a b. (a -> b) -> a -> b
$ AReview e TransferEncodingName -> TransferEncodingName -> e
forall b (m :: * -> *) t. MonadReader b m => AReview t b -> m t
review AReview e TransferEncodingName
forall s.
AsTransferEncodingError s =>
Prism' s TransferEncodingName
_TransferEncodingUnsupported TransferEncodingName
encName) TransferEncoding -> Either e TransferEncoding
forall a b. b -> Either a b
Right
    (TransferEncodingName
-> [(TransferEncodingName, TransferEncoding)]
-> Maybe TransferEncoding
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup TransferEncodingName
encName [(TransferEncodingName, TransferEncoding)]
transferEncodings)
  let s :: ByteString
s = Getting ByteString a ByteString -> a -> ByteString
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting ByteString a ByteString
forall a. HasTransferEncoding a => Getter a ByteString
transferEncodedData a
a
  Either e ByteString
-> (ByteString -> Either e ByteString)
-> Maybe ByteString
-> Either e ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (e -> Either e ByteString
forall a b. a -> Either a b
Left (e -> Either e ByteString) -> e -> Either e ByteString
forall a b. (a -> b) -> a -> b
$ AReview e TransferEncodingName -> TransferEncodingName -> e
forall b (m :: * -> *) t. MonadReader b m => AReview t b -> m t
review AReview e TransferEncodingName
forall s.
AsTransferEncodingError s =>
Prism' s TransferEncodingName
_TransferDecodeError TransferEncodingName
encName) ByteString -> Either e ByteString
forall a b. b -> Either a b
Right (Getting (First ByteString) ByteString ByteString
-> ByteString -> Maybe ByteString
forall s (m :: * -> *) a.
MonadReader s m =>
Getting (First a) s a -> m (Maybe a)
preview (TransferEncoding
-> Prism ByteString ByteString ByteString ByteString
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", TransferEncoding
forall a. a -> a
id)
  , (TransferEncodingName
"8bit", TransferEncoding
forall a. a -> a
id)
  , (TransferEncodingName
"binary", TransferEncoding
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", TransferEncoding
forall a. a -> a
id)
  | Int
nQP Int -> Int -> Bool
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 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
QuotedPrintable 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