| 7 | 7 |
import qualified Data.Attoparsec.ByteString as Atto
|
| 8 | 8 |
import Data.ByteString (ByteString)
|
| 9 | 9 |
import qualified Data.ByteString as B
|
| 10 |
import qualified Data.ByteString.Char8 as B8
|
| 10 | 11 |
import qualified Data.ByteString.Lazy as BL
|
| 11 | 12 |
import qualified Data.ByteString.Builder as BB
|
| 12 | 13 |
import qualified Data.Char as Char
|
| 13 | 14 |
import qualified Data.Foldable as Fold
|
| 15 |
import Data.Monoid ((<>))
|
| 14 | 16 |
import Data.Sequence (Seq)
|
| 15 | 17 |
import qualified Data.Sequence as Seq
|
| 16 | 18 |
import Data.Time.Clock (UTCTime)
|
|
| 21 | 23 |
|
| 22 | 24 |
-- The comments here are taken directly from RFC 5322
|
| 23 | 25 |
|
| 26 |
w8 :: Char -> Word8
|
| 27 |
w8 = fromIntegral . Char.ord
|
| 28 |
|
| 29 |
char :: Char -> Parser ()
|
| 30 |
char n = void (Atto.word8 (fromIntegral (Char.ord n)))
|
| 31 |
|
| 32 |
pSeq :: Parser a -> Parser (Seq a)
|
| 33 |
pSeq p = Seq.fromList <$> Atto.many' p
|
| 34 |
|
| 35 |
pMsgId :: Parser MessageId
|
| 36 |
pMsgId = do
|
| 37 |
pCfwsMb
|
| 38 |
char '<'
|
| 39 |
left <- pDotAtom
|
| 40 |
char '@'
|
| 41 |
right <- pDotAtom <|> pDtext
|
| 42 |
char '>'
|
| 43 |
return (MessageId (left <> "@" <> right))
|
| 44 |
|
| 45 |
pMsgIdLiberal :: Parser MessageId
|
| 46 |
pMsgIdLiberal = do
|
| 47 |
pCfwsMb
|
| 48 |
char '<'
|
| 49 |
bs <- Atto.takeWhile (/= (w8 '>'))
|
| 50 |
char '>'
|
| 51 |
return (MessageId bs)
|
| 52 |
|
| 53 |
pDtext :: Parser ByteString
|
| 54 |
pDtext = do
|
| 55 |
void (Atto.word8 91)
|
| 56 |
rs <- Atto.takeWhile (\ c -> (c >= 33 && c <= 90) || (c >= 94 && c <= 128))
|
| 57 |
void (Atto.word8 93)
|
| 58 |
return rs
|
| 24 | 59 |
|
| 25 | 60 |
-- word = atom / quoted-string
|
| 26 | 61 |
-- phrase = 1*word / obs-phrase
|
|
| 114 | 149 |
pHeader = do
|
| 115 | 150 |
name <- Atto.takeWhile1 (\ c -> c /= 58 && not (isSpace c))
|
| 116 | 151 |
void $ Atto.word8 58
|
| 117 | |
case name of
|
| 118 | |
"OrigDate" -> HeaderOther "arglbargl" <$> foldingHeader
|
| 119 | |
"Subject" -> HeaderSubject <$> foldingHeader
|
| 120 | |
"Comments" -> HeaderComments <$> foldingHeader
|
| 121 | |
"Keywords" -> HeaderKeywords <$> foldingHeader
|
| 122 | |
"Sender" -> HeaderSender <$> pMailbox <* pCrlf
|
| 123 | |
"From" -> HeaderFrom <$> pMailboxList <* pCrlf
|
| 124 | |
"Reply-To" -> HeaderReplyTo <$> pAddressList <* pCrlf
|
| 125 | |
"To" -> HeaderTo <$> pAddressList <* pCrlf
|
| 126 | |
"Cc" -> HeaderCc <$> pAddressList <* pCrlf
|
| 127 | |
"Bcc" -> HeaderBcc <$> pAddressList <* pCrlf
|
| 128 | |
_ -> HeaderOther name <$> foldingHeader
|
| 152 |
case B8.map Char.toLower name of
|
| 153 |
"origdate" -> HeaderOther "arglbargl" <$> foldingHeader
|
| 154 |
"subject" -> HeaderSubject <$> foldingHeader
|
| 155 |
"comments" -> HeaderComments <$> foldingHeader
|
| 156 |
"keywords" -> HeaderKeywords <$> foldingHeader
|
| 157 |
"sender" -> HeaderSender <$> pMailbox <* pCrlf
|
| 158 |
"from" -> HeaderFrom <$> pMailboxList <* pCrlf
|
| 159 |
"reply-to" -> HeaderReplyTo <$> pAddressList <* pCrlf
|
| 160 |
"to" -> HeaderTo <$> pAddressList <* pCrlf
|
| 161 |
"cc" -> HeaderCc <$> pAddressList <* pCrlf
|
| 162 |
"bcc" -> HeaderBcc <$> pAddressList <* pCrlf
|
| 163 |
"message-id" -> HeaderMessageId <$> pMsgId <* pCrlf
|
| 164 |
"in-reply-to" -> HeaderInReplyTo <$> pSeq pMsgIdLiberal <* pCrlf
|
| 165 |
"references" -> HeaderReferences <$> pSeq pMsgIdLiberal <* pCrlf
|
| 166 |
_ -> HeaderOther name <$> foldingHeader
|
| 129 | 167 |
|
| 130 | 168 |
pDateTime :: Parser UTCTime
|
| 131 | 169 |
pDateTime = undefined
|