{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
module Data.RFC5322
(
Message(..)
, message
, MessageContext
, BodyHandler(..)
, body
, EqMessage(..)
, Header
, HasHeaders(..)
, header
, headerList
, Headers(..)
, Address(..)
, address
, addressList
, AddrSpec(..)
, Domain(..)
, Mailbox(..)
, mailbox
, mailboxList
, parse
, parsed
, parsePrint
, crlf
, quotedString
, field
, rfc5422DateTimeFormat
, rfc5422DateTimeFormatLax
, buildMessage
, renderMessage
, RenderMessage(..)
, renderRFC5422Date
, buildFields
, buildField
, renderAddressSpec
, renderMailbox
, renderMailboxes
, renderAddress
, renderAddresses
) where
import Control.Applicative
import Data.Foldable (fold)
import Data.List (findIndex, intersperse)
import Data.List.NonEmpty (intersperse)
import Data.Semigroup ((<>))
import Data.Word (Word8)
import GHC.Generics (Generic)
import Control.DeepSeq (NFData)
import Control.Lens
import Control.Lens.Cons.Extras (recons)
import Data.Attoparsec.ByteString as A hiding (parse, take)
import Data.Attoparsec.ByteString.Char8 (char8)
import qualified Data.Attoparsec.ByteString.Lazy as AL
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as L
import qualified Data.ByteString.Char8 as Char8
import qualified Data.ByteString.Builder as Builder
import qualified Data.ByteString.Builder.Prim as Prim
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import Data.Time.Clock (UTCTime)
import Data.Time.Format (defaultTimeLocale, formatTime)
import Data.RFC5322.Internal
( CI, ci, original
, (<<>>), foldMany, foldMany1Sep
, fromChar, isAtext, isQtext, isVchar, isWsp
, optionalCFWS, word, wsp, vchar, optionalFWS, crlf
, domainLiteral, dotAtom, localPart, quotedString
)
import Data.RFC5322.Address.Types
import Data.MIME.Charset
import Data.MIME.EncodedWord (encodedWord, decodeEncodedWord, buildEncodedWord)
import Data.MIME.TransferEncoding (transferEncode)
type Header = (CI B.ByteString, B.ByteString)
newtype Headers = Headers [Header]
deriving (Eq, Show, Generic, NFData)
instance Semigroup Headers where
Headers a <> Headers b = Headers (a <> b)
instance Monoid Headers where
mempty = Headers []
class HasHeaders a where
headers :: Lens' a Headers
instance HasHeaders Headers where
headers = id
type instance Index Headers = CI B.ByteString
type instance IxValue Headers = B.ByteString
instance Ixed Headers where
ix = header
hdriso :: Iso' Headers [(CI B.ByteString, B.ByteString)]
hdriso = iso (\(Headers xs) -> xs) Headers
instance At Headers where
at k = hdriso . l
where
l :: Lens' [(CI B.ByteString, B.ByteString)] (Maybe B.ByteString)
l f kv =
let
i = findIndex ((== k) . fst) kv
g Nothing = maybe kv (\j -> take j kv <> drop (j + 1) kv) i
g (Just v) = maybe ((k,v):kv) (\j -> set (ix j) (k,v) kv) i
in
g <$> f (lookup k kv)
header :: HasHeaders a => CI B.ByteString -> Traversal' a B.ByteString
header k = headerList . traversed . filtered ((k ==) . fst) . _2
data Message s a = Message Headers a
deriving (Show, Generic, NFData)
instance HasHeaders (Message s a) where
headers f (Message h b) = fmap (`Message` b) (f h)
instance Functor (Message s) where
fmap f (Message h a) = Message h (f a)
class EqMessage a where
eqMessage :: Message s a -> Message s a -> Bool
default eqMessage :: (Eq a) => Message s a -> Message s a -> Bool
eqMessage (Message h1 b1) (Message h2 b2) = h1 == h2 && b1 == b2
instance EqMessage a => Eq (Message s a) where
(==) = eqMessage
headerList :: HasHeaders a => Lens' a [(CI B.ByteString, B.ByteString)]
headerList = headers . coerced
body :: Lens (Message ctx a) (Message ctx' b) a b
body f (Message h b) = fmap (\b' -> Message h b') (f b)
{-# ANN body ("HLint: ignore Avoid lambda" :: String) #-}
isSpecial :: Word8 -> Bool
isSpecial = inClass "()<>[]:;@\\,.\""
special :: Parser Word8
special = satisfy isSpecial
rfc5422DateTimeFormat :: String
rfc5422DateTimeFormat = "%a, %d %b %Y %T %z"
rfc5422DateTimeFormatLax :: String
rfc5422DateTimeFormatLax = "%a, %-d %b %Y %-H:%-M:%-S %z"
renderRFC5422Date :: UTCTime -> B.ByteString
renderRFC5422Date = Char8.pack . formatTime defaultTimeLocale rfc5422DateTimeFormat
buildMailbox :: Mailbox -> Builder.Builder
buildMailbox (Mailbox n a) =
maybe a' (\n' -> buildPhrase n' <> " <" <> a' <> ">") n
where
a' = buildAddressSpec a
buildPhrase :: T.Text -> Builder.Builder
buildPhrase "" = "\"\""
buildPhrase s =
case enc s of
PhraseAtom -> T.encodeUtf8Builder s
PhraseQuotedString _ -> "\"" <> T.encodeUtf8BuilderEscaped escPrim s <> "\""
PhraseEncodedWord -> buildEncodedWord . transferEncode . charsetEncode $ s
where
enc = T.foldr (\c z -> encChar c <> z) mempty
encChar c
| isAtext c = PhraseAtom
| isQtext c = PhraseQuotedString 0
| isVchar c || c == ' ' = PhraseQuotedString 1
| otherwise = PhraseEncodedWord
escPrim = Prim.condB (\c -> isQtext c || c == 32)
(Prim.liftFixedToBounded Prim.word8)
(Prim.liftFixedToBounded $ (fromChar '\\',) Prim.>$< Prim.word8 Prim.>*< Prim.word8)
data PhraseEscapeRequirement = PhraseAtom | PhraseQuotedString Int | PhraseEncodedWord
instance Semigroup PhraseEscapeRequirement where
PhraseEncodedWord <> _ = PhraseEncodedWord
PhraseAtom <> a = a
PhraseQuotedString n <> PhraseQuotedString m = PhraseQuotedString (n + m)
a <> PhraseAtom = a
_ <> PhraseEncodedWord = PhraseEncodedWord
instance Monoid PhraseEscapeRequirement where
mempty = PhraseAtom
renderMailboxes :: [Mailbox] -> B.ByteString
renderMailboxes = L.toStrict . Builder.toLazyByteString . buildMailboxes
buildMailboxes :: [Mailbox] -> Builder.Builder
buildMailboxes = fold . Data.List.intersperse ", " . fmap buildMailbox
renderMailbox :: Mailbox -> B.ByteString
renderMailbox = L.toStrict . Builder.toLazyByteString . buildMailbox
mailbox :: CharsetLookup -> Parser Mailbox
mailbox charsets =
Mailbox <$> optional (displayName charsets) <*> angleAddr
<|> Mailbox Nothing <$> addressSpec
phrase :: CharsetLookup -> Parser T.Text
phrase charsets = foldMany1Sep " " $
fmap (decodeEncodedWord charsets) ("=?" *> encodedWord)
<|> fmap decodeLenient word
displayName :: CharsetLookup -> Parser T.Text
displayName = phrase
angleAddr :: Parser AddrSpec
angleAddr = optionalCFWS *>
char8 '<' *> addressSpec <* char8 '>'
<* optionalCFWS
buildAddressSpec :: AddrSpec -> Builder.Builder
buildAddressSpec (AddrSpec lp (DomainDotAtom b))
| " " `B.isInfixOf` lp = "\"" <> buildLP <> "\"" <> rest
| otherwise = buildLP <> rest
where
buildLP = Builder.byteString lp
rest = "@" <> foldMap Builder.byteString (Data.List.NonEmpty.intersperse "." b)
buildAddressSpec (AddrSpec lp (DomainLiteral b)) =
foldMap Builder.byteString [lp, "@", b]
renderAddressSpec :: AddrSpec -> B.ByteString
renderAddressSpec = L.toStrict . Builder.toLazyByteString . buildAddressSpec
addressSpec :: Parser AddrSpec
addressSpec = AddrSpec <$> localPart <*> (char8 '@' *> domain)
isDtext :: Word8 -> Bool
isDtext c = (c >= 33 && c <= 90) || (c >= 94 && c <= 126)
domain :: Parser Domain
domain = (DomainDotAtom <$> dotAtom)
<|> (DomainLiteral <$> domainLiteral)
mailboxList :: CharsetLookup -> Parser [Mailbox]
mailboxList charsets = mailbox charsets `sepBy` char8 ','
renderAddresses :: [Address] -> B.ByteString
renderAddresses xs = B.intercalate ", " $ renderAddress <$> xs
renderAddress :: Address -> B.ByteString
renderAddress (Single m) = renderMailbox m
renderAddress (Group name xs) = T.encodeUtf8 name <> ":" <> renderMailboxes xs <> ";"
addressList :: CharsetLookup -> Parser [Address]
addressList charsets = address charsets `sepBy` char8 ','
group :: CharsetLookup -> Parser Address
group charsets =
Group <$> (displayName charsets) <* char8 ':'
<*> mailboxList charsets <* char8 ';' <* optionalCFWS
address :: CharsetLookup -> Parser Address
address charsets =
group charsets <|> Single <$> mailbox charsets
data BodyHandler a
= RequiredBody (Parser a)
| OptionalBody (Parser a, a)
| NoBody a
message :: (Headers -> BodyHandler a) -> Parser (Message (MessageContext a) a)
message f = fields >>= \hdrs -> Message hdrs <$> case f hdrs of
RequiredBody b -> crlf *> b
OptionalBody (b, a) -> optional crlf >>= maybe (pure a) (const b)
NoBody b -> pure b
type family MessageContext a
fields :: Parser Headers
fields = Headers <$> many field
class RenderMessage a where
buildBody :: Headers -> a -> Maybe Builder.Builder
tweakHeaders :: Headers -> Headers
tweakHeaders = id
buildMessage :: forall ctx a. (RenderMessage a) => Message ctx a -> Builder.Builder
buildMessage (Message h b) =
buildFields (tweakHeaders @a h)
<> maybe mempty ("\r\n" <>) (buildBody h b)
renderMessage :: (RenderMessage a) => Message ctx a -> L.ByteString
renderMessage = Builder.toLazyByteString . buildMessage
buildFields :: Headers -> Builder.Builder
buildFields = foldMapOf (hdriso . traversed) buildField
buildField :: (CI B.ByteString, B.ByteString) -> Builder.Builder
buildField (k,v) =
let key = original k
in
Builder.byteString key
<> ": "
<> Builder.byteString (foldUnstructured (B.length key) v)
<> "\r\n"
foldUnstructured :: Int -> B.ByteString -> B.ByteString
foldUnstructured i b =
let xs = chunk (i + 2) (Char8.words b) [] []
in B.intercalate "\r\n " (filter (not . B.null) xs)
chunk :: Int -> [B.ByteString] -> [B.ByteString] -> [B.ByteString] -> [B.ByteString]
chunk _ [] xs result = result <> [Char8.unwords xs]
chunk max' (x:rest) xs result = if (max' + B.length x + 1) >= 77
then result <> [Char8.unwords xs] <> chunk (B.length x + 1) rest [x] []
else result <> chunk (max' + B.length x + 1) rest (xs <> [x]) result
isFtext :: Word8 -> Bool
isFtext c = (c >= 33 && c <= 57) || (c >= 59 && c <= 126)
field :: Parser (CI B.ByteString, B.ByteString)
field = (,)
<$> ci (takeWhile1 isFtext)
<* char8 ':' <* many wsp
<*> unstructured <* crlf
unstructured :: Parser B.ByteString
unstructured =
foldMany (optionalFWS <<>> (B.singleton <$> vchar))
<<>> A.takeWhile isWsp
parsed :: (Cons s s Word8 Word8) => Parser a -> Fold s a
parsed p = to (parse p) . folded
{-# INLINE parsed #-}
parsePrint :: Parser a -> (a -> B.ByteString) -> Prism' B.ByteString a
parsePrint fwd rev = prism' rev (AL.maybeResult . AL.parse fwd . view recons)
parse :: (Cons s s Word8 Word8) => Parser a -> s -> Either String a
parse p = AL.eitherResult . AL.parse p . view recons
{-# INLINE parse #-}