{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
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 (Show)
class AsTransferEncodingError s where
_TransferEncodingError :: Prism' s TransferEncodingError
_TransferEncodingUnsupported :: Prism' s TransferEncodingName
_TransferDecodeError :: Prism' s TransferEncodingName
_TransferEncodingUnsupported = _TransferEncodingError . _TransferEncodingUnsupported
_TransferDecodeError = _TransferEncodingError . _TransferDecodeError
instance AsTransferEncodingError TransferEncodingError where
_TransferEncodingError = id
_TransferEncodingUnsupported = prism' TransferEncodingUnsupported $ \case
TransferEncodingUnsupported k -> Just k ; _ -> Nothing
_TransferDecodeError = prism' TransferDecodeError $ \case
TransferDecodeError k -> Just k ; _ -> Nothing
class HasTransferEncoding a where
type TransferDecoded a
transferEncodingName :: Getter a TransferEncodingName
transferEncodedData :: Getter a B.ByteString
transferDecoded
:: (AsTransferEncodingError e, Profunctor p, Contravariant f)
=> Optic' p f a (Either e (TransferDecoded a))
transferDecoded'
:: (Profunctor p, Contravariant f)
=> Optic' p f a (Either TransferEncodingError (TransferDecoded a))
transferDecoded' = transferDecoded
transferEncode :: TransferDecoded a -> a
transferDecodedBytes
:: (HasTransferEncoding a, AsTransferEncodingError e, Profunctor p, Contravariant f)
=> Optic' p f a (Either e B.ByteString)
transferDecodedBytes = to $ \a -> do
let encName = view transferEncodingName a
enc <- maybe (Left $ review _TransferEncodingUnsupported encName) Right
(lookup encName transferEncodings)
let s = view transferEncodedData a
maybe (Left $ review _TransferDecodeError encName) Right (preview (clonePrism enc) s)
transferEncodings :: [(CI.CI B.ByteString, TransferEncoding)]
transferEncodings =
[ ("7bit", id)
, ("8bit", id)
, ("binary", id)
, ("quoted-printable", contentTransferEncodingQuotedPrintable)
, ("base64", contentTransferEncodingBase64)
, ("q", q)
, ("b", b)
]
chooseTransferEncoding :: B.ByteString -> (TransferEncodingName, TransferEncoding)
chooseTransferEncoding s
| not doEnc = ("7bit", id)
| nQP < nB64 = ("quoted-printable", contentTransferEncodingQuotedPrintable)
| otherwise = ("base64", contentTransferEncodingBase64)
where
needEnc c = c > 127 || c == 0
qpBytes c
| encodingRequiredNonEOL QuotedPrintable c = 3
| otherwise = 1
(Any doEnc, Sum nQP) = foldMapOf bytes (\c -> (Any (needEnc c), Sum (qpBytes c))) s
nB64 = ((B.length s + 2) `div` 3) * 4