{-# 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
(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
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' = 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
transferEncode :: TransferDecoded a -> a
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)
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)
]
chooseTransferEncoding :: B.ByteString -> (TransferEncodingName, TransferEncoding)
chooseTransferEncoding :: ByteString -> (TransferEncodingName, TransferEncoding)
chooseTransferEncoding ByteString
s
| 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
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