{-# 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 (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
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' = forall a e (p :: * -> * -> *) (f :: * -> *).
(HasTransferEncoding a, AsTransferEncodingError e, Profunctor p,
Contravariant f) =>
Optic' p f a (Either e (TransferDecoded a))
transferDecoded
transferEncode :: TransferDecoded a -> a
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)
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)
]
chooseTransferEncoding :: B.ByteString -> (TransferEncodingName, TransferEncoding)
chooseTransferEncoding :: ByteString -> (TransferEncodingName, TransferEncoding)
chooseTransferEncoding ByteString
s
| 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
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