mime-string 0.4 → 0.5
raw patch · 27 files changed
+1938/−1928 lines, 27 filesdep +old-localedep +randomdep ~basesetup-changednew-uploader
Dependencies added: old-locale, random
Dependency ranges changed: base
Files
- ChangeLog.md +9/−0
- Codec/Binary/EncodingQ/String.hs +0/−49
- Codec/MIME/String.hs +0/−21
- Codec/MIME/String/ContentDisposition.hs +0/−115
- Codec/MIME/String/Date.hs +0/−241
- Codec/MIME/String/EncodedWord.hs +0/−8
- Codec/MIME/String/Flatten.hs +0/−144
- Codec/MIME/String/Headers.hs +0/−634
- Codec/MIME/String/Internal/ABNF.hs +0/−173
- Codec/MIME/String/Internal/Utils.hs +0/−58
- Codec/MIME/String/Parse.hs +0/−318
- Codec/MIME/String/QuotedPrintable.hs +0/−60
- Codec/MIME/String/Types.hs +0/−82
- Setup.hs +0/−6
- mime-string.cabal +27/−19
- src/Codec/Binary/EncodingQ/String.hs +49/−0
- src/Codec/MIME/String.hs +21/−0
- src/Codec/MIME/String/ContentDisposition.hs +116/−0
- src/Codec/MIME/String/Date.hs +242/−0
- src/Codec/MIME/String/EncodedWord.hs +8/−0
- src/Codec/MIME/String/Flatten.hs +144/−0
- src/Codec/MIME/String/Headers.hs +635/−0
- src/Codec/MIME/String/Internal/ABNF.hs +173/−0
- src/Codec/MIME/String/Internal/Utils.hs +58/−0
- src/Codec/MIME/String/Parse.hs +314/−0
- src/Codec/MIME/String/QuotedPrintable.hs +60/−0
- src/Codec/MIME/String/Types.hs +82/−0
+ ChangeLog.md view
@@ -0,0 +1,9 @@+# Revision history for mime-string++## 0.5.0.0 -- 2017-10-07++* fix building with GHC 8.2++## 0.4.0.0 -- 2008-12-07++* previous version
− Codec/Binary/EncodingQ/String.hs
@@ -1,49 +0,0 @@---- XXX Write tests---- Defined in RFC 2047--- We assume we have US-ASCII characters.--module Codec.Binary.EncodingQ.String ( encode, decode) where--import Codec.MIME.String.Internal.Utils-import Data.Bits-import Data.Char---- len is the maximum length the encoded text in a single block is--- allowed to be-encode :: Int -> String -> [String]-encode _ "" = []-encode len xs = enc len 0 id id xs---- The Int is the number of characters on this line so far--- 76 is the maximum we can have no one line, and 3 is the most--- generated for 1 input char (but we also need space for a trailing--- '=' for a soft line break).--enc :: Int -> Int -- Length stuff- -> ([String] -> [String]) -> (String -> String) -- accumulators- -> String -- input- -> [String]-enc _ _ acc_list acc_string "" = acc_list [acc_string ""]-enc len so_far acc_list acc_string (c:cs)- = if so_far' > len- then enc len new_len (acc_list . (acc_string "" :)) id cs- else enc len new_len acc_list (acc_string . (encoded ++)) cs- where encoded = if isAsciiPrint c && (c /= ' ') && (c /= '?')- then [c]- else ['=', x1, x2]- new_len = length encoded- so_far' = so_far + new_len- o = ord c- x1 = toUpper $ intToDigit (o `shiftR` 4)- x2 = toUpper $ intToDigit (o .&. 0xF)--decode :: String -> String-decode ('=':c1:c2:cs)- | isAsciiHexDigit c1 && isAsciiHexDigit c2- = chr ((digitToInt c1 `shiftL` 4) + digitToInt c2):decode cs-decode ('_':cs) = ' ':decode cs-decode (c:cs) = c:decode cs-decode "" = ""-
− Codec/MIME/String.hs
@@ -1,21 +0,0 @@--module Codec.MIME.String (- module Codec.MIME.String.ContentDisposition,- module Codec.MIME.String.Date,- module Codec.MIME.String.EncodedWord,- module Codec.MIME.String.Flatten,- module Codec.MIME.String.Headers,- module Codec.MIME.String.Parse,- module Codec.MIME.String.QuotedPrintable,- module Codec.MIME.String.Types,- ) where--import Codec.MIME.String.ContentDisposition-import Codec.MIME.String.Date-import Codec.MIME.String.EncodedWord-import Codec.MIME.String.Flatten-import Codec.MIME.String.Headers-import Codec.MIME.String.Parse-import Codec.MIME.String.QuotedPrintable-import Codec.MIME.String.Types-
− Codec/MIME/String/ContentDisposition.hs
@@ -1,115 +0,0 @@---- We assume we have US-ASCII characters--module Codec.MIME.String.ContentDisposition- (- ContentDisposition(ContentDisposition),- DispositionType(Inline, Attachment),- DispositionParameter(..),- get_content_disposition,- ) where--import Codec.MIME.String.Internal.Utils-import Codec.MIME.String.Internal.ABNF- (- Parser, parse, nested_parse,- (<$>), (<$), (<*>), (<*), (<|>),- pEOI, pPred, pChar, pMany, pAtLeast,- )-import Codec.MIME.String.Date (FullDate, p_date_time)-import Codec.MIME.String.Headers- (- Parameter, p_parameter,- cws, p_ci_string, p_extension_token, p_value, p_quoted_string,- )--data ContentDisposition = ContentDisposition DispositionType- [DispositionParameter]- deriving (Show, Read)--data DispositionType = Inline | Attachment- deriving (Show, Read)--data DispositionParameter = Filename String- | CreationDate FullDate- | ModificationDate FullDate- | ReadDate FullDate- | Size Integer- | DispositionParameter Parameter- deriving (Show, Read)--get_content_disposition :: String -> Maybe ContentDisposition-get_content_disposition xs- = case parse ph_content_disposition xs of- Left cd -> Just cd- Right _ -> Nothing--ph_content_disposition :: Parser Char ContentDisposition-ph_content_disposition = ContentDisposition- <$ cws- <*> p_disposition_type- <*> pMany ( id- <$ cws- <* pChar ';'- <* cws- <*> p_disposition_parm)- <* cws- <* pEOI--p_disposition_type :: Parser Char DispositionType-p_disposition_type = Inline <$ p_ci_string "inline"- <|> Attachment <$ p_ci_string "attachment"- <|> Attachment <$ p_extension_token--p_disposition_parm :: Parser Char DispositionParameter-p_disposition_parm = p_filename_parm- <|> p_creation_date_parm- <|> p_modification_date_parm- <|> p_read_date_parm- <|> p_size_parm- <|> DispositionParameter <$> p_parameter--p_filename_parm :: Parser Char DispositionParameter-p_filename_parm = Filename- <$ p_ci_string "filename"- <* cws- <* pChar '='- <* cws- <*> p_value--p_creation_date_parm :: Parser Char DispositionParameter-p_creation_date_parm = CreationDate- <$ p_ci_string "creation-date"- <* cws- <* pChar '='- <* cws- <*> p_quoted_date_time--p_modification_date_parm :: Parser Char DispositionParameter-p_modification_date_parm = ModificationDate- <$ p_ci_string "modification-date"- <* cws- <* pChar '='- <* cws- <*> p_quoted_date_time--p_read_date_parm :: Parser Char DispositionParameter-p_read_date_parm = ReadDate- <$ p_ci_string "read-date"- <* cws- <* pChar '='- <* cws- <*> p_quoted_date_time--p_size_parm :: Parser Char DispositionParameter-p_size_parm = (Size . read)- <$ p_ci_string "size"- <* cws- <* pChar '='- <* cws- <*> pAtLeast 1 (pPred isAsciiDigit)--p_quoted_date_time :: Parser Char FullDate-p_quoted_date_time = nested_parse p_quoted_string- (id <$> p_date_time <* pEOI)-
− Codec/MIME/String/Date.hs
@@ -1,241 +0,0 @@--module Codec.MIME.String.Date- (FullDate(FullDate), DOW(..), Date(Date), Day, Month(..), Year,- Time(Time), Zone, TimeOfDay(TimeOfDay), Hour, Minute, Second,- show_full_date, show_mbox_full_date, get_date, p_date_time,- get_current_date, epochDate,- )- where--import Codec.MIME.String.Internal.ABNF- (- Parser, parse,- (<$>), (<$), (<*>), (<*), (<|>),- pEOI, pPred, pChar, pAtLeast, pFromTo, pExactly, pMaybe,- )-import Codec.MIME.String.Headers (cws, p_ci_string)-import Codec.MIME.String.Internal.Utils--import Control.Monad.Trans (MonadIO, liftIO)-import System.Time hiding (Month(May), Day)-import qualified System.Time as Time (Month(May))--data FullDate = FullDate (Maybe DOW) Date Time- deriving (Show, Read)--data DOW = Mon | Tue | Wed | Thu | Fri | Sat | Sun- deriving (Show, Read)--data Date = Date Day Month Year- deriving (Show, Read)-type Day = Int-data Month = Jan | Feb | Mar | Apr | May | Jun- | Jul | Aug | Sep | Oct | Nov | Dec- deriving (Show, Read)-type Year = Int--data Time = Time TimeOfDay Zone- deriving (Show, Read)-type Zone = Int-data TimeOfDay = TimeOfDay Hour Minute (Maybe Second)- deriving (Show, Read)-type Hour = Int-type Minute = Int-type Second = Int--epochDate :: FullDate-epochDate = FullDate (Just Thu) (Date 01 Jan 1970)- (Time (TimeOfDay 0 0 (Just 0)) 0)-------------------------- Showing--show_full_date :: FullDate -> String-show_full_date (FullDate m_dow date time)- = shown_dow ++ show_date date ++ " " ++ show_time time- where shown_dow = case m_dow of- Nothing -> ""- Just dow -> show dow ++ ", "--show_date :: Date -> String-show_date (Date day month year)- = show_int 2 day ++ " " ++ show month ++ " " ++ show year--show_time :: Time -> String-show_time (Time tod zone) = show_tod tod ++ " " ++ show_zone zone--show_tod :: TimeOfDay -> String-show_tod (TimeOfDay h m m_s)- = show_int 2 h ++ ":" ++ show_int 2 m ++ shown_s- where shown_s = case m_s of- Nothing -> ""- Just s -> ":" ++ show_int 2 s--show_zone :: Zone -> String-show_zone z = (if z < 0 then '-' else '+'):show_int 4 (abs z)--show_int :: Int -> Int -> String-show_int digits int = let s = show int- in replicate (digits - length s) '0' ++ s---- Showing for the "From " line in mboxes is sadly a slightly different format--show_mbox_full_date :: FullDate -> String-show_mbox_full_date (FullDate m_dow (Date day month year) (Time tod _))- = shown_dow ++ show month ++ " " ++ show_int 2 day ++ " " ++- show_tod tod ++ " " ++ show year- where shown_dow = case m_dow of- Nothing -> ""- Just dow -> show dow ++ " "-------------------------- Parsing--get_date :: String -> Maybe FullDate-get_date xs- = case parse ph_date xs of- Left f -> Just f- Right _ -> Nothing--ph_date :: Parser Char FullDate-ph_date = id- <$ cws- <*> p_date_time- <* cws- <* pEOI--p_date_time :: Parser Char FullDate-p_date_time = FullDate- <$> pMaybe ( id- <$> p_dow- <* cws- <* pChar ','- <* cws)- <*> p_date- <* cws- <*> p_time--p_dow :: Parser Char DOW-p_dow = Mon <$ p_ci_string "Mon"- <|> Tue <$ p_ci_string "Tue"- <|> Wed <$ p_ci_string "Wed"- <|> Thu <$ p_ci_string "Thu"- <|> Fri <$ p_ci_string "Fri"- <|> Sat <$ p_ci_string "Sat"- <|> Sun <$ p_ci_string "Sun"--p_date :: Parser Char Date-p_date = Date- <$> p_day- <* cws- <*> p_month- <* cws- <*> p_year---- obs-year merged in-p_year :: Parser Char Year-p_year = (\ds -> let y = read ds- in case ds of- [_, _, _] -> 2000 + y- [_, _]- | y < 50 -> 1900 + y- | otherwise -> 2000 + y- _ -> y)- <$> pAtLeast 2 (pPred isAsciiDigit)--p_month :: Parser Char Month-p_month = Jan <$ p_ci_string "Jan"- <|> Feb <$ p_ci_string "Feb"- <|> Mar <$ p_ci_string "Mar"- <|> Apr <$ p_ci_string "Apr"- <|> May <$ p_ci_string "May"- <|> Jun <$ p_ci_string "Jun"- <|> Jul <$ p_ci_string "Jul"- <|> Aug <$ p_ci_string "Aug"- <|> Sep <$ p_ci_string "Sep"- <|> Oct <$ p_ci_string "Oct"- <|> Nov <$ p_ci_string "Nov"- <|> Dec <$ p_ci_string "Dec"--p_day :: Parser Char Day-p_day = read <$> pFromTo 1 2 (pPred isAsciiDigit)--p_time :: Parser Char Time-p_time = Time- <$> p_time_of_day- <* cws- <*> p_zone--p_time_of_day :: Parser Char TimeOfDay-p_time_of_day = TimeOfDay- <$> p_hour- <* cws- <* pChar ':'- <* cws- <*> p_minute- <*> pMaybe ( id- <$ cws- <* pChar ':'- <* cws- <*> p_second)--p_hour :: Parser Char Hour-p_hour = read <$> pExactly 2 (pPred isAsciiDigit)--p_minute :: Parser Char Minute-p_minute = read <$> pExactly 2 (pPred isAsciiDigit)--p_second :: Parser Char Second-p_second = read <$> pExactly 2 (pPred isAsciiDigit)--p_zone :: Parser Char Zone-p_zone = (\f n -> f $ read n)- <$> (id <$ pChar '+' <|> negate <$ pChar '-')- <*> pExactly 4 (pPred isAsciiDigit)- <|> p_obs_zone--p_obs_zone :: Parser Char Zone-p_obs_zone = 0 <$ p_ci_string "UT"- <|> 0 <$ p_ci_string "GMT"- <|> -500 <$ p_ci_string "EST"- <|> -400 <$ p_ci_string "EDT"- <|> -600 <$ p_ci_string "CST"- <|> -500 <$ p_ci_string "CDT"- <|> -700 <$ p_ci_string "MST"- <|> -600 <$ p_ci_string "MDT"- <|> -800 <$ p_ci_string "PST"- <|> -700 <$ p_ci_string "PDT"- -- Military time zones. Strictly we shouldn't accept [jJ]- -- but no harm done.- -- 'they SHOULD all be considered equivalent to "-0000"' as- -- RFC 822 defined them incorrectly.- <|> 0 <$ pPred isAsciiAlpha--get_current_date :: MonadIO m => m FullDate-get_current_date- = do clt <- liftIO getClockTime- cat <- liftIO $ toCalendarTime clt- let fd = FullDate (Just dow) date time- get_dow Sunday = Sun- get_dow Monday = Mon- get_dow Tuesday = Tue- get_dow Wednesday = Wed- get_dow Thursday = Thu- get_dow Friday = Fri- get_dow Saturday = Sat- get_month January = Jan- get_month February = Feb- get_month March = Mar- get_month April = Apr- get_month Time.May = May- get_month June = Jun- get_month July = Jul- get_month August = Aug- get_month September = Sep- get_month October = Oct- get_month November = Nov- get_month December = Dec- dow = get_dow (ctWDay cat)- date = Date (ctDay cat) (get_month (ctMonth cat)) (ctYear cat)- time = Time tod (ctTZ cat `div` 36)- tod = TimeOfDay (ctHour cat) (ctMin cat) (Just (ctSec cat))- return fd-
− Codec/MIME/String/EncodedWord.hs
@@ -1,8 +0,0 @@--module Codec.MIME.String.EncodedWord (base64_encode) where--import Codec.Binary.Base64.String (encode)--base64_encode :: String -> String -> String-base64_encode charset xs = "=?" ++ charset ++ "?B?" ++ encode xs ++ "?="-
− Codec/MIME/String/Flatten.hs
@@ -1,144 +0,0 @@--module Codec.MIME.String.Flatten- (flatten, Attachments, Attachment)- where--import qualified Codec.Binary.Base64.String as Base64 (encode)-import qualified Codec.MIME.String.QuotedPrintable as QP (encode)-import Codec.MIME.String.Headers-import Codec.MIME.String.Internal.Utils-import Codec.MIME.String.Types--{--XXX For message IDs:-import Network.BSD (getHostName)-import System.Locale (defaultTimeLocale)-import System.Random (randomIO)-import System.Time (getClockTime, toCalendarTime, formatCalendarTime)--}--type Attachments = [Attachment]-type Attachment = (String, FilePath, Maybe ContentType)---- XXX This should be rewritten in a more compositional way!-flatten :: Headers -> String -> Maybe String -> Attachments -> IO String-flatten headers body maybeHtmlBody attachments- = do -- XXX Could add one of one isn't already found? msgid <- mk_msgid- let -- XXX This (\n) could be prettier - check llengths of bits- alternativeBoundary = "=:A"- alternativePartStart = "\n--" ++ alternativeBoundary ++ "\n"- alternativePartsEnd = "\n--" ++ alternativeBoundary ++ "--\n"- mixedBoundary = "=:M"- mixedPartStart = "\n--" ++ mixedBoundary ++ "\n"- mixedPartsEnd = "\n--" ++ mixedBoundary ++ "--\n"- common_headers = unlines (concatMap h_raw_header headers)- ++ "MIME-Version: 1.0\n"- text_content_headers = unlines [- "Content-type: text/plain; charset=utf-8",- "Content-transfer-encoding: quoted-printable",- "Content-Disposition: inline"]- html_content_headers = unlines [- "Content-type: text/html; charset=utf-8",- "Content-transfer-encoding: quoted-printable",- "Content-Disposition: inline"]- -- This is overly paranoid- safe_char c = isAsciiAlphaNum c || (c `elem` " .-_")- mime_attachment (a, fn, mct)- = let -- XXX showParam and ct should do some sanity checking- -- of the values they are passed- showParam (Parameter k v) = "; " ++ k ++ "=\"" ++ v ++ "\""- ct = case mct of- Just (ContentType x y ps) ->- "Content-type: " ++ x ++ "/" ++ y- ++ concatMap showParam ps ++ "\n"- Nothing -> "Content-type: application/octet-stream\n"- in mixedPartStart- ++ ct- ++ "Content-transfer-encoding: base64\n"- ++ "Content-Disposition: attachment; filename=\""- ++ (case reverse $ filter safe_char- $ takeWhile ('/' /=)- $ reverse fn of- [] -> "unknown"- fn' -> fn')- ++ "\"\n"- ++ "\n"- ++ Base64.encode a- msg = if single_part- then case maybeHtmlBody of- Nothing ->- common_headers- ++ text_content_headers- ++ "\n"- ++ QP.encode (my_lines body)- Just htmlBody ->- common_headers- ++ "Content-type: multipart/alternative; boundary=\""- ++ alternativeBoundary ++ "\"\n"- ++ "\n"- ++ "This is a multi-part message in MIME format.\n"- ++ alternativePartStart- ++ text_content_headers- ++ "\n"- ++ QP.encode (my_lines body)- ++ alternativePartStart- ++ html_content_headers- ++ "\n"- ++ QP.encode (my_lines htmlBody)- ++ alternativePartsEnd- else case maybeHtmlBody of- Nothing ->- common_headers- ++ "Content-type: multipart/mixed; boundary=\""- ++ mixedBoundary ++ "\"\n"- ++ "\n"- ++ "This is a multi-part message in MIME format.\n"- ++ mixedPartStart- ++ text_content_headers- ++ "\n"- ++ QP.encode (my_lines body)- ++ concatMap mime_attachment attachments- ++ mixedPartsEnd- Just htmlBody ->- common_headers- ++ "Content-type: multipart/mixed; boundary=\""- ++ mixedBoundary ++ "\"\n"- ++ "\n"- ++ "This is a multi-part message in MIME format.\n"- ++ mixedPartStart- -- Start of the body- ++ "Content-type: multipart/alternative; boundary=\""- ++ alternativeBoundary ++ "\"\n"- ++ "\n"- ++ alternativePartStart- ++ text_content_headers- ++ "\n"- ++ QP.encode (my_lines body)- ++ alternativePartStart- ++ html_content_headers- ++ "\n"- ++ QP.encode (my_lines htmlBody)- ++ alternativePartsEnd- -- End of the body- ++ concatMap mime_attachment attachments- ++ mixedPartsEnd- return msg- where single_part = null attachments---- XXX The IO calls used to use liftIOErr. We could use something similar--- but require we are called in a MonadError m?--- XXX We should possibly be including a program name-{--mk_msgid :: IO String-mk_msgid- = do hostname <- getHostName- clock_time <- getClockTime- calendar_time <- toCalendarTime clock_time- r <- randomIO- let timestamp = formatCalendarTime defaultTimeLocale- "%Y%m%d%H%M%S" calendar_time- lhs = concat $ intersperse "."- [timestamp, show (r :: Int)]- return (lhs ++ "@" ++ hostname)--}-
− Codec/MIME/String/Headers.hs
@@ -1,634 +0,0 @@---- We assume we have US-ASCII characters--module Codec.MIME.String.Headers- (- Domain(Domain, LiteralDomain),- Mailbox(Mailbox),- RoutedEmailAddress(RoutedEmailAddress, NormalEmailAddress),- EmailAddress(EmailAddress), get_addr_spec,- Address(Address, Group),- ContentType(ContentType), get_content_type,- ContentDescription(ContentDescription),- get_content_description,- ContentTransferEncoding(ContentTransferEncoding),- get_content_transfer_encoding,- ContentID(ContentID), get_content_id,- MessageID(MessageID),- MIMEVersion(MIMEVersion), get_mime_version,- Parameter(Parameter), p_parameter,- From(From), To(To), Subject(Subject),- get_from, get_to, get_subject,- get_boundary, p_extension_token, p_value, p_quoted_string,- cws, p_ci_string,- )- where--import Codec.MIME.String.Internal.ABNF- (- Parser, parse, pSucceed, pFail,- (<$>), (<$), (<*>), (<*), (<|>), (<|), (<!>),- pEOI, pPred, pChar, pMany, pAtLeast, pMaybe, pOptDef, pString,- )-import qualified Codec.Binary.Base64.String as Base64 (decode)-import qualified Codec.Binary.EncodingQ.String as EncodingQ (decode)-import Codec.MIME.String.Internal.Utils--import Codec.Text.IConv-import qualified Data.ByteString.Lazy.Char8 as BS-import Data.Char-import Data.List---------------------------- Utils--ignore :: Parser inp a -> Parser inp ()-ignore p = () <$ p--boxp :: Parser inp a -> Parser inp [a]-boxp p = box <$> p---------------------------- RFC 2234--p_CTL :: Parser Char Char-p_CTL = pPred (\c -> ord c < 32 || ord c == 127)--p_SP :: Parser Char Char-p_SP = pChar ' '--p_HTAB :: Parser Char Char-p_HTAB = pChar '\t'--p_WSP :: Parser Char Char-p_WSP = p_SP <|> p_HTAB---------------------------- RFC 2822---- Case insensitive strings, written "Foo"-p_ci_string :: String -> Parser Char String-p_ci_string s = s <$ f s- where f "" = pSucceed ()- f (c:cs) = let p = if isAsciiAlpha c- then pChar (toLower c) <| pChar (toUpper c)- else pChar c- in () <$ p <* f cs--p_NO_WS_CTL :: Parser Char Char-p_NO_WS_CTL = pPred (\c -> let o = ord c in 1 <= o && o <= 8- || o == 11- || o == 12- || 14 <= o && o <= 31- || o == 127)---- If we follow the spec precisely then we get pMany (pMany), and hence--- non-termination, so we merge the definition of p_obs_text in.-p_text :: Parser Char String-p_text = concat- <$> pMany (- p_encoded_words- <| boxp (pPred (\c -> let o = ord c in 0 <= o && o <= 9- || o == 11- || o == 12- || 14 <= o && o <= 127))- )---- We are lax about checking they have any necessary surrounding--- whitespace-p_encoded_words :: Parser Char String-p_encoded_words = (\x xs -> x ++ concat xs)- <$> p_encoded_word- <*> pMany (id <$ cws <*> p_encoded_word)---- XXX What happens if iconv doesn't understand the charset "cs"?-p_encoded_word :: Parser Char String-p_encoded_word = (\cs dec text -> BS.unpack $ convertFuzzy Transliterate cs "utf8" $ BS.pack $ dec text)- <$ pString "=?"- <*> p_charset- <* pChar '?'- <*> p_encoding- <* pChar '?'- <*> p_encoded_text- <* pString "?="---- token definition inlined as they use a different one to p_token.-p_charset :: Parser Char String-p_charset = pAtLeast 1 (pPred isAscii <!> (p_SP <|> p_CTL <|> p_especials))--p_especials :: Parser Char Char-p_especials = pPred (`elem` "()<>@,;:\\\"/[]?.=")---- This is much stricter than specified, but if it's not [qQbB] then--- we'd want to fall back to showing it as a string anyway.-p_encoding :: Parser Char (String -> String)-p_encoding = EncodingQ.decode <$ (pChar 'Q' <|> pChar 'q')- <|> Base64.decode <$ (pChar 'B' <|> pChar 'b')--p_encoded_text :: Parser Char String-p_encoded_text = pMany (pPred (\c -> isAsciiPrint c && c /= '?' && c /= ' '))--p_quoted_pair :: Parser Char String-p_quoted_pair = id <$ pChar '\\' <*> p_text <|> (boxp p_obs_qp)--p_obs_qp :: Parser Char Char-p_obs_qp = id <$ pChar '\\' <*> pPred isAscii---- Done differently as the newlines are already gone-p_FWS :: Parser Char String-p_FWS = pMany p_WSP--p_ctext :: Parser Char Char-p_ctext = p_NO_WS_CTL- <|> pPred (\c -> let o = ord c in 33 <= o && o <= 39- || 42 <= o && o <= 91- || 93 <= o && o <= 126)--p_ccontent :: Parser Char ()-p_ccontent = ignore p_ctext <|> ignore p_quoted_pair <|> p_comment--p_comment :: Parser Char ()-p_comment = ()- <$ pChar '('- <* pMany (() <$ pMany p_NO_WS_CTL <* p_ccontent)- <* pMany p_NO_WS_CTL- <* pChar ')'---- We might want to keep the result. If we do then we also need to--- handle encoded words properly.--- This isn't quite CFWS as we need to be able to accept "1.0"--- as a MIME version with cws between all the characters.--- Also, we've already removed all the newlines in the headers.-cws :: Parser Char ()-cws = ignore $ pMany (ignore (pAtLeast 1 p_WSP) <|> p_comment)--p_qtext :: Parser Char Char-p_qtext = p_NO_WS_CTL- <|> pPred (\c -> let o = ord c in o == 33- || 35 <= o && o <= 91- || 93 <= o && o <= 126)--p_qcontent :: Parser Char String-p_qcontent = boxp p_qtext- <|> p_quoted_pair--p_quoted_string :: Parser Char String-p_quoted_string = (++)- <$ cws- <* pChar '"'- <*> (concat <$> pMany ((++) <$> pOptDef "" p_FWS <*> p_qcontent))- <*> pOptDef "" p_FWS- <* pChar '"'--p_dcontent :: Parser Char String-p_dcontent = boxp p_dtext <|> p_quoted_pair--p_dtext :: Parser Char Char-p_dtext = p_NO_WS_CTL- <|> pPred (\c -> let o = ord c in 33 <= o && o <= 90- || 94 <= o && o <= 126)--data MessageID = MessageID String Domain- deriving (Show, Read)--p_msg_id :: Parser Char MessageID-p_msg_id = MessageID- <$ cws- <* pChar '<'- <*> p_id_left- <* pChar '@'- <*> p_id_right- <* pChar '>'- <* cws--p_atom :: Parser Char String-p_atom = id- <$ cws- <*> pAtLeast 1 p_atext- <* cws--p_atext :: Parser Char Char-p_atext = pPred (\c -> isAsciiAlphaNum c || c `elem` "!#$%&'+-/=?^_`{|}~")--p_dot_atom :: Parser Char String-p_dot_atom = id - <$ cws- <*> p_dot_atom_text- <* cws--p_word :: Parser Char String-p_word = p_atom <|> p_quoted_string---- This incorporates obs-phrase-p_phrase :: Parser Char [String]-p_phrase = (:)- <$> (p_encoded_words <| p_word)- <*> pMany (id <$ cws <*> (p_encoded_words <| p_word <| pString "."))- <|> boxp p_quoted_string--p_dot_atom_text :: Parser Char String-p_dot_atom_text = (\x xs -> x ++ concat xs)- <$> pAtLeast 1 p_atext- <*> pMany ((:) <$> pChar '.' <*> pAtLeast 1 p_atext)--p_id_left :: Parser Char String-p_id_left = p_dot_atom_text <|> p_no_fold_quote <|> p_obs_id_left--p_id_right :: Parser Char Domain-p_id_right = Domain <$> p_dot_atom_text- <|> p_no_fold_literal- <|> p_obs_id_right--p_obs_id_left :: Parser Char String-p_obs_id_left = p_local_part--p_local_part :: Parser Char String-p_local_part = p_dot_atom <|> p_quoted_string <|> p_obs_local_part--p_obs_local_part :: Parser Char String-p_obs_local_part = (\x xs -> x ++ concat xs)- <$> p_word- <*> pMany ((:) <$> pChar '.' <*> p_word)--p_domain :: Parser Char Domain-p_domain = Domain <$> p_dot_atom <|> p_domain_literal <|> p_obs_domain--p_domain_literal :: Parser Char Domain-p_domain_literal = (LiteralDomain . concat)- <$ cws- <* pChar '['- <*> pMany ( id- <$ p_FWS- <*> p_dcontent)- <* p_FWS- <* pChar ']'- <* cws--p_obs_domain :: Parser Char Domain-p_obs_domain = (\x xs -> Domain (x ++ concat xs))- <$> p_atom- <*> pMany ((:) <$> pChar '.' <*> p_atom)--p_obs_id_right :: Parser Char Domain-p_obs_id_right = p_domain--p_no_fold_quote :: Parser Char String-p_no_fold_quote = concat- <$ pChar '"'- <*> pMany (boxp p_qtext <|> p_quoted_pair)- <* pChar '"'--data Domain = Domain String | LiteralDomain String- deriving (Show, Read, Eq)--p_no_fold_literal :: Parser Char Domain-p_no_fold_literal = LiteralDomain . concat- <$ pChar '['- <*> pMany (boxp p_dtext <|> p_quoted_pair)- <* pChar ']'--data Subject = Subject String- deriving (Show, Read)--get_subject :: String -> Maybe Subject-get_subject xs- = case parse ph_subject xs of- Left cd -> Just cd- Right _ -> Nothing---- This is actually the RFC822 definition, as otherwise things get very--- confusing.--- Would be pMany, but p_text already does that for us-ph_subject :: Parser Char Subject-ph_subject = Subject <$> p_text <* pEOI--data From = From [Mailbox]- deriving (Show, Read, Eq)--get_from :: String -> Maybe From-get_from xs- = case parse ph_from xs of- Left f -> Just f- Right _ -> Nothing--ph_from :: Parser Char From-ph_from = From <$ cws <*> p_mailbox_list <* cws <* pEOI--data To = To [Address]- deriving (Show, Read)--data Address = Address Mailbox- | Group String [Mailbox]- deriving (Show, Read)--get_to :: String -> Maybe To-get_to xs- = case parse ph_to xs of- Left t -> Just t- Right _ -> Nothing--ph_to :: Parser Char To-ph_to = To <$ cws <*> p_address_list <* cws <* pEOI---- obs-addr-list merged in-p_address_list :: Parser Char [Address]-p_address_list = (:)- <$ pMany (() <$ pChar ',' <* cws)- <*> p_address- <*> pMany ( id- <$ pAtLeast 1 (() <$ cws <* pChar ',')- <* cws- <*> p_address)- <* pMany (() <$ cws <* pChar ',')--p_address :: Parser Char Address-p_address = Address <$> p_mailbox- <|> p_group--p_group :: Parser Char Address-p_group = Group- <$> p_display_name - <* cws- <* pChar ':'- <* cws- <*> pOptDef [] p_mailbox_list- <* cws- <* pChar ';'---- obs-mbox-list merged in-p_mailbox_list :: Parser Char [Mailbox]-p_mailbox_list = (:)- <$ pMany (() <$ pChar ',' <* cws)- <*> p_mailbox- <*> pMany ( id- <$ pAtLeast 1 (() <$ cws <* pChar ',')- <* cws- <*> p_mailbox)- <* pMany (() <$ cws <* pChar ',')--data Mailbox = Mailbox (Maybe String) RoutedEmailAddress- deriving (Show, Read, Eq)--p_mailbox :: Parser Char Mailbox-p_mailbox = p_name_addr- <|> (Mailbox Nothing . NormalEmailAddress) <$> p_addr_spec--p_name_addr :: Parser Char Mailbox-p_name_addr = Mailbox- <$> pMaybe p_display_name- <* cws- <*> p_angle_addr--data EmailAddress = EmailAddress String Domain- deriving (Show, Read, Eq)--data RoutedEmailAddress = NormalEmailAddress EmailAddress- | RoutedEmailAddress [Domain] EmailAddress- deriving (Show, Read, Eq)--p_angle_addr :: Parser Char RoutedEmailAddress-p_angle_addr = ($)- <$ pChar '<'- <* cws- -- This next makes us also satisfy obs-angle-addr- <*> pOptDef NormalEmailAddress- (RoutedEmailAddress <$> p_obs_route <* cws)- <*> p_addr_spec- <* cws- <* pChar '>'--get_addr_spec :: String -> Maybe EmailAddress-get_addr_spec xs- = case parse p_addr_spec xs of- Left e -> Just e- Right _ -> Nothing--p_addr_spec :: Parser Char EmailAddress-p_addr_spec = EmailAddress- <$> p_local_part- <* cws- <* pChar '@'- <* cws- <*> p_domain--p_display_name :: Parser Char String-p_display_name = (concat . intersperse " ") <$> p_phrase--p_obs_route :: Parser Char [Domain]-p_obs_route = id <$> p_obs_domain_list <* pChar ':'--p_obs_domain_list :: Parser Char [Domain]-p_obs_domain_list = (:)- <$ pChar '@'- <* cws- <*> p_domain- <*> pMany ( id- <$ pMaybe (() <$ cws <* pChar ',')- <* cws- <* pChar '@'- <* cws- <*> p_domain)---------------------------- RFC 2045--data MIMEVersion = MIMEVersion Integer Integer- deriving (Show, Read)--get_mime_version :: String -> Maybe MIMEVersion-get_mime_version xs = case parse ph_mime_version xs of- Left ct -> Just ct- Right _ -> Nothing--ph_mime_version :: Parser Char MIMEVersion-ph_mime_version = MIMEVersion- <$ cws- <*> (read <$> pMany (pPred isAsciiDigit))- <* cws- <* pChar '.'- <* cws- <*> (read <$> pMany (pPred isAsciiDigit))- <* cws- <* pEOI--data ContentType = ContentType String -- Case insensitive: lower-cased- String -- Case insensitive: lower-cased- [Parameter]- deriving (Show, Read)-data Parameter = Parameter String -- Case insensitive: lower-cased- String- deriving (Show, Read)--get_content_type :: String -> Maybe ContentType-get_content_type xs = case parse ph_content_type xs of- Left ct -> Just ct- Right _ -> Nothing--ph_content_type :: Parser Char ContentType-ph_content_type = ContentType- <$ cws- <*> p_type- <* cws- <* pChar '/'- <* cws- <*> p_subtype- <*> pMany (id- <$ cws- <* pChar ';'- <* cws- <*> p_parameter)- <* cws- <* pEOI----- For type and subtypes, allow anything that matches a regexp that--- subsumes the currently allowed values-p_type :: Parser Char String-p_type = pAtLeast 1 (pPred (\c -> isAsciiAlphaNum c || c `elem` "-.+"))--p_subtype :: Parser Char String-p_subtype = pAtLeast 1 (pPred (\c -> isAsciiAlphaNum c || c `elem` "-.+"))--{--p_type :: Parser Char String-p_type = p_discrete_type <|> p_composite_type--p_subtype :: Parser Char String-p_subtype = map asciiToLower <$> (p_extension_token <|> p_iana_token)--p_discrete_type :: Parser Char String-p_discrete_type = p_ci_string "text"- <|> p_ci_string "image"- <|> p_ci_string "audio"- <|> p_ci_string "video"- <|> p_ci_string "application"- <|> map asciiToLower <$> p_extension_token--p_composite_type :: Parser Char String-p_composite_type = p_ci_string "message"- <|> p_ci_string "multipart"- <|> map asciiToLower <$> p_extension_token--p_iana_token :: Parser Char String-p_iana_token = pFail--}--p_extension_token :: Parser Char String-p_extension_token = p_ietf_token <|> p_x_token--p_ietf_token :: Parser Char String-p_ietf_token = pFail--p_x_token :: Parser Char String-p_x_token = (\x t -> x:'-':t)- <$> (pChar 'X' <|> pChar 'x')- <* pChar '-'- <*> p_token--p_parameter :: Parser Char Parameter-p_parameter = Parameter- <$> p_attribute- <* cws- <* pChar '='- <* cws- <*> p_value--p_attribute :: Parser Char String-p_attribute = map asciiToLower <$> p_token--p_value :: Parser Char String-p_value = p_token <|> p_quoted_string--p_token :: Parser Char String-p_token = pAtLeast 1 (pPred isAscii <!> (p_SP <|> p_CTL <|> p_tspecials))--p_tspecials :: Parser Char Char-p_tspecials = pPred (`elem` "()<>@,;:\\\"/[]?=")---------data ContentTransferEncoding- = ContentTransferEncoding String -- Case insensitive: lower-cased- deriving (Show, Read)--get_content_transfer_encoding :: String -> Maybe ContentTransferEncoding-get_content_transfer_encoding xs- = case parse ph_content_transfer_encoding xs of- Left cte -> Just cte- Right _ -> Nothing--ph_content_transfer_encoding :: Parser Char ContentTransferEncoding-ph_content_transfer_encoding- = ContentTransferEncoding- <$ cws- <*> p_mechanism- <* cws- <* pEOI--p_mechanism :: Parser Char String-p_mechanism = p_ci_string "7bit"- <|> p_ci_string "8bit"- <|> p_ci_string "binary"- <|> p_ci_string "quoted-printable"- <|> p_ci_string "base64"- <|> map asciiToLower <$> p_ietf_token- <|> map asciiToLower <$> p_x_token--data ContentID = ContentID MessageID- deriving (Show, Read)--get_content_id :: String -> Maybe ContentID-get_content_id xs- = case parse ph_content_id xs of- Left ci -> Just ci- Right _ -> Nothing--ph_content_id :: Parser Char ContentID-ph_content_id- = ContentID- <$ cws- <*> p_msg_id- <* cws- <* pEOI--data ContentDescription = ContentDescription String- deriving (Show, Read)--get_content_description :: String -> Maybe ContentDescription-get_content_description xs- = case parse ph_content_description xs of- Left cd -> Just cd- Right _ -> Nothing--ph_content_description :: Parser Char ContentDescription-ph_content_description- = ContentDescription- <$ cws- <*> p_text -- would be pMany, but p_text already does that for us- <* cws- <* pEOI---------------------------- RFC 2046---- Not really a header as such--get_boundary :: String -> Maybe String-get_boundary xs- = case parse p_boundary xs of- Left b -> Just b- Right _ -> Nothing---- We are very flexible here-p_boundary :: Parser Char String-p_boundary = (\ss b bs -> dropFromEndWhile (' ' ==) (ss ++ [b] ++ bs))- <$> pMany (pChar ' ')- <*> p_bchars- <*> pMany p_bchars--p_bchars :: Parser Char Char-p_bchars = p_bcharsnospace <|> pChar ' '--p_bcharsnospace :: Parser Char Char-p_bcharsnospace = pPred (\c -> isAsciiAlphaNum c || c `elem` "'()+_,-./:=?")-
− Codec/MIME/String/Internal/ABNF.hs
@@ -1,173 +0,0 @@--module Codec.MIME.String.Internal.ABNF- (Parser, apply, parse,- pPred, pSucceed, pFail, pEOI, (<*>), (<|>), (<| ), (<!>), nested_parse,- pChar, pString, (<$>), (<$ ), (<* ), ( |>),- pMany, pAtLeast, pAtMost, pExactly, pFromTo, pOptDef, pMaybe- ) where--import Data.Word--newtype Parser inp res = Parser ([(inp, Pos)] -> ParseResult inp res)--data ParseResult inp res = Success res [(inp, Pos)] !Pos- | Fail !Pos--type Line = Integer-type Column = Integer-data Pos = Pos !Line !Column- | EOI- deriving (Eq, Ord)--get_pos :: [(a, Pos)] -> Pos-get_pos [] = EOI-get_pos ((_, p):_) = p--show_pos :: Pos -> String-show_pos EOI = "End of input"-show_pos (Pos l c) = "Line " ++ show l ++ ", column " ++ show c--infixl 6 <$>, <$, <*>, <*-infixr 3 <|>, <|, |>--posify :: String -> [(Char, Pos)]-posify = f 1 1- where f _ _ [] = []- f l c ('\n':xs) = ('\n', Pos l c):f (l+1) 1 xs- f l c (x :xs) = (x, Pos l c):f l (c+1) xs--apply :: Parser Char a -> String -> Either (a, String) String-apply (Parser p) xs- = case p $ posify xs of- Success res ys _ -> Left (res, map fst ys)- Fail pos -> Right ("Error: Failed at " ++ show_pos pos)--parse :: Parser Char a -> String -> Either a String-parse (Parser p) xs- = case p $ posify xs of- Success res [] _ -> Left res- Success _ ((_, pos):_) _ ->- Right ("Error: Only consumed up to " ++ show_pos pos)- Fail pos ->- Right ("Error: Failed at " ++ show_pos pos)---- Primitive combinators--pPred :: (inp -> Bool) -> Parser inp inp-pPred p = Parser- $ \inp -> case inp of- ((x, pos):inp')- | p x -> Success x inp' pos- _ -> Fail (get_pos inp)--pSucceed :: res -> Parser a res-pSucceed x = Parser $ \inp -> Success x inp (get_pos inp)--pFail :: Parser a res-pFail = Parser $ \inp -> Fail (get_pos inp)--pEOI :: Parser a ()-pEOI = Parser $ \inp -> case inp of- [] -> Success () [] EOI- _ -> Fail (get_pos inp)--(<*>) :: Parser inp (a -> b) -> Parser inp a -> Parser inp b-Parser p <*> Parser q = Parser $ \inp ->- case p inp of- Fail pos -> Fail pos- Success f inp' pos ->- case q inp' of- Fail pos' -> Fail (pos `max` pos')- Success x inp'' pos' ->- Success (f x) inp'' (pos `max` pos')--(<|>) :: Parser inp a -> Parser inp a -> Parser inp a-Parser p <|> Parser q = Parser $ \inp ->- case (p inp, q inp) of- (Fail posp, Fail posq) -> Fail (posp `max` posq)- (Fail posp, Success x inp' posq) ->- Success x inp' (posp `max` posq)- (Success x inp' posp, Fail posq) ->- Success x inp' (posp `max` posq)- (rp@(Success _ _ posp), rq@(Success _ _ posq))- -> if posp >= posq then rp else rq--(<| ) :: Parser inp a -> Parser inp a -> Parser inp a-Parser p <| Parser q = Parser $ \inp ->- case p inp of- Fail posp ->- case q inp of- Fail posq -> Fail (posp `max` posq)- Success x inp' posq ->- Success x inp' (posp `max` posq)- s -> s--(<!>) :: Parser inp a -> Parser inp b -> Parser inp a-Parser p <!> Parser q = Parser $ \inp -> case q inp of- Fail _ ->- p inp- Success _ _ pos -> Fail pos--check_fails_empty :: Parser inp a -> ()-check_fails_empty (Parser p) = case p [] of- Fail _ -> ()- _ -> error "check_fails_empty failed"--nested_parse :: Parser Char String -> Parser Char a -> Parser Char a-nested_parse (Parser p1) (Parser p2)- = Parser- $ \inp -> case p1 inp of- Fail pos -> Fail pos- Success inp' rem_inp pos ->- case p2 $ posify inp' of- Fail pos' -> Fail (pos `max` pos')- Success x [] pos' -> Success x rem_inp (pos `max` pos')- Success _ _ pos' -> Fail (pos `max` pos')---- Derived combinators--pChar :: Char -> Parser Char Char-pChar c = pPred (c ==)--pString :: String -> Parser Char String-pString "" = pSucceed ""-pString (c:cs) = (:) <$> pChar c <*> pString cs--(<$>) :: (a -> b) -> Parser inp a -> Parser inp b-x <$> q = pSucceed x <*> q--(<$ ) :: a -> Parser inp b -> Parser inp a-x <$ q = pSucceed x <* q--(<* ) :: Parser inp a -> Parser inp b -> Parser inp a-p <* q = (\x _ -> x) <$> p <*> q--( |>) :: Parser inp a -> Parser inp a -> Parser inp a-p |> q = q <| p--pMany :: Parser inp a -> Parser inp [a]-pMany p = check_fails_empty p `seq` ((:) <$> p <*> pMany p) <| pSucceed []--pAtLeast :: Word -> Parser inp a -> Parser inp [a]-pAtLeast 0 p = pMany p-pAtLeast n p = ((:) <$> p <*> pAtLeast (n-1) p)--pAtMost :: Word -> Parser inp a -> Parser inp [a]-pAtMost 0 _ = pSucceed []-pAtMost n p = ((:) <$> p <*> pAtMost (n-1) p) <| pSucceed []--pExactly :: Word -> Parser inp a -> Parser inp [a]-pExactly 0 _ = pSucceed []-pExactly n p = ((:) <$> p <*> pExactly (n-1) p)--pFromTo :: Word -> Word -> Parser inp a -> Parser inp [a]-pFromTo 0 t p = pAtMost t p-pFromTo _ 0 _ = error "Codec.MIME.String.Internal.ABNF.pFromTo: Bad arguments"-pFromTo f t p = ((:) <$> p <*> pFromTo (f-1) (t-1) p)--pOptDef :: a -> Parser inp a -> Parser inp a-pOptDef x p = p <| pSucceed x--pMaybe :: Parser inp a -> Parser inp (Maybe a)-pMaybe p = Just <$> p <| pSucceed Nothing-
− Codec/MIME/String/Internal/Utils.hs
@@ -1,58 +0,0 @@--module Codec.MIME.String.Internal.Utils where--import Data.Char--isAsciiDigit :: Char -> Bool-isAsciiDigit c = isAscii c && isDigit c--isAsciiHexDigit :: Char -> Bool-isAsciiHexDigit c = isAscii c && isHexDigit c--isAsciiPrint :: Char -> Bool-isAsciiPrint c = isAscii c && isPrint c--isAsciiAlpha :: Char -> Bool-isAsciiAlpha c = isAscii c && isAlpha c--isAsciiAlphaNum :: Char -> Bool-isAsciiAlphaNum c = isAscii c && isAlphaNum c--asciiToLower :: Char -> Char-asciiToLower c | isAscii c = toLower c- | otherwise = c--asciiToUpper :: Char -> Char-asciiToUpper c | isAscii c = toUpper c- | otherwise = c--splits :: Int -> [a] -> [[a]]-splits _ [] = []-splits n xs = case splitAt n xs of- (ys, zs) -> ys:splits n zs--box :: a -> [a]-box x = [x]--dropFromEndWhile :: (a -> Bool) -> [a] -> [a]-dropFromEndWhile p = foldr (\x xs -> if null xs && p x then [] else x:xs) []---- We are generous about what we allow as line terminators. Any of--- \r \n \r\n \n\r will satisfy us.-my_lines :: String -> [String]-my_lines xs = case get_line xs of- (ys, Nothing) -> [ys]- (ys, Just zs) -> ys:my_lines zs--get_line :: String -> (String, Maybe String)-get_line xs = case break is_cr_or_lf xs of- (ys, z1:z2:zs)- | is_cr_or_lf z2 && z1 /= z2 -> (ys, Just zs)- (ys, _:zs) -> (ys, Just zs)- (ys, "") -> (ys, Nothing)--is_cr_or_lf :: Char -> Bool-is_cr_or_lf '\r' = True-is_cr_or_lf '\n' = True-is_cr_or_lf _ = False-
− Codec/MIME/String/Parse.hs
@@ -1,318 +0,0 @@--module Codec.MIME.String.Parse where--import qualified Codec.Binary.Base64.String as Base64 (decode)-import Codec.MIME.String.ContentDisposition- (- ContentDisposition(ContentDisposition), get_content_disposition,- DispositionType(Inline, Attachment),- DispositionParameter(..),- )-import Codec.MIME.String.Date (get_date)-import Codec.MIME.String.Headers- (- ContentTransferEncoding(ContentTransferEncoding),- get_content_transfer_encoding,- ContentType(ContentType), get_content_type,- get_content_description, get_boundary,- Parameter(Parameter),- MIMEVersion(MIMEVersion), get_mime_version,- Subject(Subject),- get_subject, get_from, get_to,- )-import qualified Codec.MIME.String.QuotedPrintable as QuotedPrintable (decode)-import Codec.MIME.String.Types- (- ParseM,- Header(Header, h_raw_header, h_raw_name, h_name, h_body),- Headers,- Message(Message),- MessageInfo(..),- Multipart(Multipart),- MessageContent(NoContent, Mixed, Alternative,- Parallel, Digest, RFC822),- mkData, mkBody,- digest_content_type, ascii_text_content_type,- )-import Codec.MIME.String.Internal.Utils--import Codec.Text.IConv-import Control.Monad (liftM)-import Control.Monad.State (evalState, get, put)-import qualified Data.ByteString.Lazy.Char8 as BS-import Data.ByteString.Lazy.Char8 (ByteString)-import Data.Maybe (fromMaybe)--mkMessage :: MessageInfo -> ParseM MessageContent -> ParseM Message-mkMessage mi f_mc- = do pn <- get- put (pn + 1)- -- This is done slightly oddly so we get numbering in the natural- -- order, which in turn is important when looking for a part number- mc <- f_mc- return $ Message pn mi mc--parse :: String -> Message-parse msg = evalState (parse_message msg) 1--parse_message :: String -> ParseM Message-parse_message msg- = let (headers, m_body) = parse_headers msg- in case get_header headers "mime-version:" get_mime_version of- -- We only try and be clever if the MIME version is 1.0- Just (MIMEVersion 1 0) ->- parse_mime_message ascii_text_content_type msg- _ ->- do let m_from = get_header headers "from:" get_from- m_subject = get_header headers "subject:" (Just . Subject)- m_to = get_header headers "to:" get_to- m_date = get_header headers "date:" get_date- mi = MessageInfo {- mi_headers = headers,- mi_from = m_from,- mi_subject = m_subject,- mi_to = m_to,- mi_date = m_date,- mi_content_description = Nothing- }- mc = case m_body of- Just body ->- mkBody ascii_text_content_type "unknown"- (convertAsciiToUtf8 body)- Nothing ->- return $ NoContent ascii_text_content_type- mkMessage mi mc--convertAsciiToUtf8 :: String -> String-convertAsciiToUtf8 xs- = BS.unpack $ convertFuzzy Transliterate "US-ASCII" "utf8" $ BS.pack xs--parse_mime_message :: ContentType -> String -> ParseM Message-parse_mime_message def_content_type msg- = let (headers, m_body) = parse_headers msg- mi = make_mime_message_info headers- mc = case m_body of- Nothing ->- do let m_ct = get_header headers "content-type:"- get_content_type- content_type = fromMaybe def_content_type m_ct- return $ NoContent content_type- Just body ->- make_mime_message_content def_content_type headers body- in mkMessage mi mc--make_mime_message_info :: Headers -> MessageInfo-make_mime_message_info headers- = let m_content_description = get_header headers "content-description:"- get_content_description- m_from = get_header headers "from:" get_from- m_subject = get_header headers "subject:" get_subject- m_to = get_header headers "to:" get_to- m_date = get_header headers "date:" get_date- in MessageInfo {- mi_headers = headers,- mi_from = m_from,- mi_subject = m_subject,- mi_to = m_to,- mi_date = m_date,- mi_content_description = m_content_description- }--make_mime_message_content :: ContentType -> Headers -> String- -> ParseM MessageContent-make_mime_message_content def_content_type headers body- = -- We accept illegal combinations of content type and- -- encoding, so just decode whatever it says- case m_decoded_body of- Nothing ->- mkData (Just cte) content_type filename body- Just decoded_body ->- case content_disposition of- ContentDisposition Attachment _ ->- mkData Nothing content_type filename decoded_body- ContentDisposition Inline _ ->- case content_type of- ContentType "text" _ ps ->- let charset = fromMaybe "US-ASCII"- $ lookup_param "charset" ps- decoded_body' = BS.pack decoded_body- in case tryConvertFuzzy Transliterate charset "utf8" decoded_body' of- Just xs ->- mkBody content_type filename $ BS.unpack xs- Nothing ->- mkData Nothing content_type filename decoded_body- ContentType "multipart" st ps- | Just raw_b <- lookup_param "boundary" ps,- Just b <- get_boundary raw_b- -> do let (preamble, parts, epilogue)- = get_parts b decoded_body- ct = case st of- "digest" -> digest_content_type- _ -> ascii_text_content_type- constr = case st of- "alternative" -> Alternative- "parallel" -> Parallel- "digest" -> Digest- _ -> Mixed- ms <- mapM (parse_mime_message ct) parts- return $ constr (Multipart preamble ms epilogue)- ContentType "message" "rfc822" _ ->- liftM (RFC822 decoded_body filename)- (parse_message decoded_body)- -- Anything else is treated like an- -- application/octet-stream- _ -> mkData Nothing content_type filename decoded_body- where m_cd = get_header headers "content-disposition:"- get_content_disposition- content_disposition = fromMaybe (ContentDisposition Inline []) m_cd- m_ct = get_header headers "content-type:"- get_content_type- content_type = fromMaybe def_content_type m_ct- filename = get_filename content_disposition content_type- m_ce = get_header headers "content-transfer-encoding:"- get_content_transfer_encoding- cte@(ContentTransferEncoding content_transfer_encoding)- = fromMaybe (ContentTransferEncoding "7bit") m_ce- m_decoded_body- = if content_transfer_encoding == "base64" then- Just (Base64.decode body)- else if content_transfer_encoding == "quoted-printable" then- Just (QuotedPrintable.decode $ my_lines body)- else if content_transfer_encoding `elem`- ["7bit", "8bit", "binary"] then- -- Don't worry if 8-bit data is in 7-bit transfer-encoded data- Just body- else Nothing---- XXX This is rather hacky. We really want convertFuzzy to tell us if--- the conversion is supported itself-tryConvertFuzzy :: Fuzzy -> EncodingName -> EncodingName -> ByteString- -> Maybe ByteString-tryConvertFuzzy fuzzy from_charset to_charset decoded_body =- case convertStrictly from_charset to_charset decoded_body of- Right (UnsuportedConversion {}) -> Nothing- _ -> Just $ convertFuzzy fuzzy from_charset to_charset decoded_body--get_filename :: ContentDisposition -> ContentType -> FilePath-get_filename (ContentDisposition _ params) (ContentType _ _ params')- = loop params- where loop [] = -- Look up legacy name parameter in content type- case lookup_param "name" params' of- Nothing -> default_filename- Just f -> sanitise f- loop (Filename f:_) = sanitise f- loop (_:ps) = loop ps- sanitise f = case reverse $ takeWhile ('/' /=) $ reverse f of- "" -> default_filename- f' -> f'- default_filename = "unknown"--get_parts :: String -> String -> (String, [String], String)-get_parts boundary body- = case gps [] body of- (pre:parts, epi) -> (pre, parts, epi)- _ -> error "Parse.get_parts: Can't happen XXX"- where gps acc "" = ([from_acc acc], "")- gps acc xs- = case fmap (dropWhile isWSP) $ after dd_boundary- $ snd $ read_line_ending xs of- Just "--" -> ([from_acc acc], "")- Just ('-':'-':cs@(c:_))- | is_cr_or_lf c -> ([from_acc acc], cs)- Just "" -> ([from_acc acc], "")- Just (c1:cs)- | is_cr_or_lf c1- -> let cs' = case cs of- c2:cs''- | is_cr_or_lf c2 && c1 /= c2- -> cs''- _ -> cs- in case gps [] cs' of- (ps, ep) -> (from_acc acc:ps, ep)- _ -> case read_line_ending xs of- (le, xs') ->- case break is_cr_or_lf xs' of- (ys, zs) -> gps (ys:le:acc) zs- from_acc acc = concat $ reverse acc- read_line_ending cs = case cs of- (c1:cs1)- | is_cr_or_lf c1 ->- case cs1 of- (c2:cs2)- | is_cr_or_lf c2 && c1 /= c2 ->- ([c1, c2], cs2)- _ -> ([c1], cs1)- _ -> ("", cs)- after "" ys = Just ys- after (x:xs) (y:ys)- | x == y = after xs ys- | otherwise = Nothing- after (_:_) "" = Nothing- dd_boundary = "--" ++ boundary- isWSP ' ' = True- isWSP '\t' = True- isWSP _ = False---- Returns the value of the first parameter of the name (must be lower cased)-lookup_param :: String -> [Parameter] -> Maybe String-lookup_param _ [] = Nothing-lookup_param name (Parameter n v:ps)- | name == n = Just v- | otherwise = lookup_param name ps--get_header :: Headers -> String -> (String -> Maybe a) -> Maybe a-get_header hs name getter- = case filter ((name ==) . h_name) hs of- [h] -> getter (h_body h)- _ -> Nothing---- We skip over leading white space lines, both for resilience and--- because this is allowed for MIME part headers.-parse_headers :: String -> (Headers, Maybe String)-parse_headers msg = skip_whitespace (Just msg)- where skip_whitespace :: Maybe String -> ([Header], Maybe String)- skip_whitespace Nothing = ([], Nothing)- skip_whitespace (Just xs) = case get_line xs of- ([], m_zs) -> ([], m_zs)- (ys, m_zs) ->- case dropWhile isWhite ys of- [] -> skip_whitespace m_zs- ys' -> gather [ys'] m_zs- gather :: [String] -> Maybe String -> ([Header], Maybe String)- gather acc Nothing = ([mk_rev_header acc], Nothing)- gather acc (Just xs)- = case get_line xs of- ([], m_zs) -> ([mk_rev_header acc], m_zs)- (ys, m_zs)- | starts_with_white ys -> gather (ys:acc) m_zs- | otherwise -> let (hs, m_rest) = gather [ys] m_zs- in (mk_rev_header acc:hs, m_rest)- starts_with_white (c:_) = isWhite c- starts_with_white [] = False- isWhite ' ' = True- isWhite '\t' = True- isWhite _ = False---- Takes the lines comprising a header (in reverse order) and constructs--- the corresponding Header-mk_rev_header :: [String] -> Header-mk_rev_header = mk_header . reverse---- Takes the lines comprising a header and constructs--- the corresponding Header-mk_header :: [String] -> Header-mk_header xs = let unfolded = concat xs- (raw_name, body) = case break ends_header unfolded of- (name, ':':val) -> (name ++ ":", val)- (name, val) -> (name, val)- in Header {- h_raw_header = xs,- h_raw_name = raw_name,- h_name = map asciiToLower raw_name,- h_body = body- }- where ends_header ':' = True- ends_header ' ' = True- ends_header '\t' = True- ends_header _ = False-
− Codec/MIME/String/QuotedPrintable.hs
@@ -1,60 +0,0 @@---- Defined in RFC 2045.--- We assume we have US-ASCII characters.--- We return a string with native '\n' line endings.--module Codec.MIME.String.QuotedPrintable (encode, decode) where--import Codec.MIME.String.Internal.Utils-import Data.Bits-import Data.Char-import Data.List--encode :: [String] -> String-encode = enc 0---- The Int is the number of characters on this line so far--- 76 is the maximum we can have no one line, and 3 is the most--- generated for 1 input char (but we also need space for a trailing--- '=' for a soft line break).-enc :: Int -> [String] -> String-enc _ [] = ""-enc _ [[]] = ""-enc _ ([]:ls) = '\n':enc 0 ls-enc n ls | n > 72 = '=':'\n':enc 0 ls-enc n ((c:cs):ls)- | (33 <= o && o <= 126 && o /= 61) ||- (not (null cs) && (o == 9 || o == 32)) = c:enc (n+1) (cs:ls)- | otherwise = '=':x1:x2:enc (n+3) (cs:ls)- where o = ord c- x1 = toUpper $ intToDigit (o `shiftR` 4)- x2 = toUpper $ intToDigit (o .&. 0xF)---- decode is very forgiving, and makes some best guesses-decode :: [String] -> String-decode = dec . concat . intersperse "\n"- . removeSoftLinebreaks- . map (dropFromEndWhile is_tab_space)- where is_tab_space ' ' = True- is_tab_space '\t' = True- is_tab_space _ = False- breakLast "" = ("", "")- breakLast [x] = ("", [x])- breakLast (x:xs) = case breakLast xs of- (ys, zs) -> (x:ys, zs)- removeSoftLinebreaks [] = []- removeSoftLinebreaks (x:xs)- = case breakLast x of- (x', "=") ->- case removeSoftLinebreaks xs of- [] -> [x']- (y:ys) -> (x' ++ y):ys- _ -> x:removeSoftLinebreaks xs--dec :: String -> String-dec ('=':c1:c2:cs)- | isAsciiHexDigit c1 && isAsciiHexDigit c2- = chr ((digitToInt c1 `shiftL` 4) + digitToInt c2):dec cs-dec (c:cs) = c:dec cs-dec "" = ""-
− Codec/MIME/String/Types.hs
@@ -1,82 +0,0 @@--module Codec.MIME.String.Types- (- ParseM, PartNumber, Headers,- Header(Header, h_raw_header, h_raw_name, h_name, h_body),- Message(..), MessageInfo(..), Multipart(Multipart),- MessageContent(NoContent, Body, Data, Mixed, Alternative,- Parallel, Digest, RFC822),- mkData, mkBody,- digest_content_type, ascii_text_content_type,- )- where--import Codec.MIME.String.Date (FullDate)-import Codec.MIME.String.Headers- (- ContentType(ContentType), ContentDescription, ContentTransferEncoding,- Parameter(Parameter), From, To, Subject,- )-import Codec.MIME.String.Internal.Utils (my_lines)--import Control.Monad.State (State)--type Headers = [Header]-data Header = Header {- h_raw_header :: [String],- h_raw_name :: String,- h_name :: String,- h_body :: String- }- deriving (Show, Read)--data MessageInfo = MessageInfo {- mi_headers :: Headers,- mi_from :: Maybe From,- mi_to :: Maybe To,- mi_subject :: Maybe Subject,- mi_date :: Maybe FullDate,- mi_content_description :: Maybe ContentDescription- }- deriving (Show, Read)-data MessageContent = NoContent ContentType- | Body ContentType FilePath String -- UTF-8 text- | Data (Maybe ContentTransferEncoding)- ContentType FilePath String -- 8-bit data- | Mixed Multipart- | Alternative Multipart- | Parallel Multipart- | Digest Multipart- | RFC822 String{- unparsed message-} FilePath Message- deriving (Show, Read)--type ParseM a = State PartNumber a--mkBody :: ContentType -> FilePath -> String -> ParseM MessageContent-mkBody ct fp s = return $ Body ct fp $ unlines $ my_lines s--mkData :: Maybe ContentTransferEncoding -> ContentType -> FilePath- -> String -> ParseM MessageContent-mkData m_cte ct fp s = return $ Data m_cte ct fp s--data Multipart = Multipart String -- Preamble- [Message] -- The messages themselves- String -- Epilogue- deriving (Show, Read)--type PartNumber = Integer--data Message = Message {- m_part_number :: PartNumber,- m_message_info :: MessageInfo,- m_message_content :: MessageContent- }- deriving (Show, Read)--ascii_text_content_type :: ContentType-ascii_text_content_type- = ContentType "text" "plain" [Parameter "charset" "US-ASCII"]--digest_content_type :: ContentType-digest_content_type = ContentType "message" "rfc822" []-
Setup.hs view
@@ -1,8 +1,2 @@--module Main (main) where- import Distribution.Simple--main :: IO () main = defaultMain-
mime-string.cabal view
@@ -1,21 +1,29 @@-Name: mime-string-Version: 0.4-License: OtherLicense-License-File: COPYING-Copyright: Ian Lynagh, 2005, 2007-Author: Ian Lynagh-Maintainer: igloo@earth.li-Stability: experimental-Synopsis: MIME implementation for String's.-Build-Type: Simple-Description:+name: mime-string+version: 0.5+license: OtherLicense+license-File: COPYING+author: Ian Lynagh+maintainer: guillaumh@gmail.com+synopsis: MIME implementation for String's.+build-type: Simple+description: Implementation of the MIME RFCs 2045-2049. Rather rough around the edges at the moment.-Category: Codec-Build-Depends: base, mtl, network, iconv, base64-string, old-time, bytestring-Extensions: PatternGuards-Extra-source-files: "BSD3", "GPL-2"-Exposed-modules:+category: Codec+cabal-version: >=1.10+extra-source-files:+ BSD3+ GPL-2+ ChangeLog.md+source-repository head+ type: darcs+ location: http://hub.darcs.net/gh/mime-string++library+ hs-source-dirs: src+ build-depends: base < 5, mtl, network, iconv, base64-string, old-time, bytestring, random, old-locale+ default-extensions: PatternGuards+ exposed-modules: Codec.Binary.EncodingQ.String Codec.MIME.String Codec.MIME.String.ContentDisposition@@ -26,8 +34,8 @@ Codec.MIME.String.Parse Codec.MIME.String.Types Codec.MIME.String.QuotedPrintable-Other-Modules:+ Other-Modules: Codec.MIME.String.Internal.ABNF Codec.MIME.String.Internal.Utils-GHC-Options: -Wall-+ GHC-Options: -Wall+ default-language: Haskell2010
+ src/Codec/Binary/EncodingQ/String.hs view
@@ -0,0 +1,49 @@++-- XXX Write tests++-- Defined in RFC 2047+-- We assume we have US-ASCII characters.++module Codec.Binary.EncodingQ.String ( encode, decode) where++import Codec.MIME.String.Internal.Utils+import Data.Bits+import Data.Char++-- len is the maximum length the encoded text in a single block is+-- allowed to be+encode :: Int -> String -> [String]+encode _ "" = []+encode len xs = enc len 0 id id xs++-- The Int is the number of characters on this line so far+-- 76 is the maximum we can have no one line, and 3 is the most+-- generated for 1 input char (but we also need space for a trailing+-- '=' for a soft line break).++enc :: Int -> Int -- Length stuff+ -> ([String] -> [String]) -> (String -> String) -- accumulators+ -> String -- input+ -> [String]+enc _ _ acc_list acc_string "" = acc_list [acc_string ""]+enc len so_far acc_list acc_string (c:cs)+ = if so_far' > len+ then enc len new_len (acc_list . (acc_string "" :)) id cs+ else enc len new_len acc_list (acc_string . (encoded ++)) cs+ where encoded = if isAsciiPrint c && (c /= ' ') && (c /= '?')+ then [c]+ else ['=', x1, x2]+ new_len = length encoded+ so_far' = so_far + new_len+ o = ord c+ x1 = toUpper $ intToDigit (o `shiftR` 4)+ x2 = toUpper $ intToDigit (o .&. 0xF)++decode :: String -> String+decode ('=':c1:c2:cs)+ | isAsciiHexDigit c1 && isAsciiHexDigit c2+ = chr ((digitToInt c1 `shiftL` 4) + digitToInt c2):decode cs+decode ('_':cs) = ' ':decode cs+decode (c:cs) = c:decode cs+decode "" = ""+
+ src/Codec/MIME/String.hs view
@@ -0,0 +1,21 @@++module Codec.MIME.String (+ module Codec.MIME.String.ContentDisposition,+ module Codec.MIME.String.Date,+ module Codec.MIME.String.EncodedWord,+ module Codec.MIME.String.Flatten,+ module Codec.MIME.String.Headers,+ module Codec.MIME.String.Parse,+ module Codec.MIME.String.QuotedPrintable,+ module Codec.MIME.String.Types,+ ) where++import Codec.MIME.String.ContentDisposition+import Codec.MIME.String.Date+import Codec.MIME.String.EncodedWord+import Codec.MIME.String.Flatten+import Codec.MIME.String.Headers+import Codec.MIME.String.Parse+import Codec.MIME.String.QuotedPrintable+import Codec.MIME.String.Types+
+ src/Codec/MIME/String/ContentDisposition.hs view
@@ -0,0 +1,116 @@++-- We assume we have US-ASCII characters++module Codec.MIME.String.ContentDisposition+ (+ ContentDisposition(ContentDisposition),+ DispositionType(Inline, Attachment),+ DispositionParameter(..),+ get_content_disposition,+ ) where++import Prelude hiding ( (<*>), (<$>), (<*), (<$) )+import Codec.MIME.String.Internal.Utils+import Codec.MIME.String.Internal.ABNF+ (+ Parser, parse, nested_parse,+ (<$>), (<$), (<*>), (<*), (<|>),+ pEOI, pPred, pChar, pMany, pAtLeast,+ )+import Codec.MIME.String.Date (FullDate, p_date_time)+import Codec.MIME.String.Headers+ (+ Parameter, p_parameter,+ cws, p_ci_string, p_extension_token, p_value, p_quoted_string,+ )++data ContentDisposition = ContentDisposition DispositionType+ [DispositionParameter]+ deriving (Show, Read)++data DispositionType = Inline | Attachment+ deriving (Show, Read)++data DispositionParameter = Filename String+ | CreationDate FullDate+ | ModificationDate FullDate+ | ReadDate FullDate+ | Size Integer+ | DispositionParameter Parameter+ deriving (Show, Read)++get_content_disposition :: String -> Maybe ContentDisposition+get_content_disposition xs+ = case parse ph_content_disposition xs of+ Left cd -> Just cd+ Right _ -> Nothing++ph_content_disposition :: Parser Char ContentDisposition+ph_content_disposition = ContentDisposition+ <$ cws+ <*> p_disposition_type+ <*> pMany ( id+ <$ cws+ <* pChar ';'+ <* cws+ <*> p_disposition_parm)+ <* cws+ <* pEOI++p_disposition_type :: Parser Char DispositionType+p_disposition_type = Inline <$ p_ci_string "inline"+ <|> Attachment <$ p_ci_string "attachment"+ <|> Attachment <$ p_extension_token++p_disposition_parm :: Parser Char DispositionParameter+p_disposition_parm = p_filename_parm+ <|> p_creation_date_parm+ <|> p_modification_date_parm+ <|> p_read_date_parm+ <|> p_size_parm+ <|> DispositionParameter <$> p_parameter++p_filename_parm :: Parser Char DispositionParameter+p_filename_parm = Filename+ <$ p_ci_string "filename"+ <* cws+ <* pChar '='+ <* cws+ <*> p_value++p_creation_date_parm :: Parser Char DispositionParameter+p_creation_date_parm = CreationDate+ <$ p_ci_string "creation-date"+ <* cws+ <* pChar '='+ <* cws+ <*> p_quoted_date_time++p_modification_date_parm :: Parser Char DispositionParameter+p_modification_date_parm = ModificationDate+ <$ p_ci_string "modification-date"+ <* cws+ <* pChar '='+ <* cws+ <*> p_quoted_date_time++p_read_date_parm :: Parser Char DispositionParameter+p_read_date_parm = ReadDate+ <$ p_ci_string "read-date"+ <* cws+ <* pChar '='+ <* cws+ <*> p_quoted_date_time++p_size_parm :: Parser Char DispositionParameter+p_size_parm = (Size . read)+ <$ p_ci_string "size"+ <* cws+ <* pChar '='+ <* cws+ <*> pAtLeast 1 (pPred isAsciiDigit)++p_quoted_date_time :: Parser Char FullDate+p_quoted_date_time = nested_parse p_quoted_string+ (id <$> p_date_time <* pEOI)+
+ src/Codec/MIME/String/Date.hs view
@@ -0,0 +1,242 @@++module Codec.MIME.String.Date+ (FullDate(FullDate), DOW(..), Date(Date), Day, Month(..), Year,+ Time(Time), Zone, TimeOfDay(TimeOfDay), Hour, Minute, Second,+ show_full_date, show_mbox_full_date, get_date, p_date_time,+ get_current_date, epochDate,+ )+ where++import Prelude hiding ( (<*>), (<$>), (<*), (<$) )+import Codec.MIME.String.Internal.ABNF+ (+ Parser, parse,+ (<$>), (<$), (<*>), (<*), (<|>),+ pEOI, pPred, pChar, pAtLeast, pFromTo, pExactly, pMaybe,+ )+import Codec.MIME.String.Headers (cws, p_ci_string)+import Codec.MIME.String.Internal.Utils++import Control.Monad.Trans (MonadIO, liftIO)+import System.Time hiding (Month(May), Day)+import qualified System.Time as Time (Month(May))++data FullDate = FullDate (Maybe DOW) Date Time+ deriving (Show, Read)++data DOW = Mon | Tue | Wed | Thu | Fri | Sat | Sun+ deriving (Show, Read)++data Date = Date Day Month Year+ deriving (Show, Read)+type Day = Int+data Month = Jan | Feb | Mar | Apr | May | Jun+ | Jul | Aug | Sep | Oct | Nov | Dec+ deriving (Show, Read)+type Year = Int++data Time = Time TimeOfDay Zone+ deriving (Show, Read)+type Zone = Int+data TimeOfDay = TimeOfDay Hour Minute (Maybe Second)+ deriving (Show, Read)+type Hour = Int+type Minute = Int+type Second = Int++epochDate :: FullDate+epochDate = FullDate (Just Thu) (Date 01 Jan 1970)+ (Time (TimeOfDay 0 0 (Just 0)) 0)++------------------------ Showing++show_full_date :: FullDate -> String+show_full_date (FullDate m_dow date time)+ = shown_dow ++ show_date date ++ " " ++ show_time time+ where shown_dow = case m_dow of+ Nothing -> ""+ Just dow -> show dow ++ ", "++show_date :: Date -> String+show_date (Date day month year)+ = show_int 2 day ++ " " ++ show month ++ " " ++ show year++show_time :: Time -> String+show_time (Time tod zone) = show_tod tod ++ " " ++ show_zone zone++show_tod :: TimeOfDay -> String+show_tod (TimeOfDay h m m_s)+ = show_int 2 h ++ ":" ++ show_int 2 m ++ shown_s+ where shown_s = case m_s of+ Nothing -> ""+ Just s -> ":" ++ show_int 2 s++show_zone :: Zone -> String+show_zone z = (if z < 0 then '-' else '+'):show_int 4 (abs z)++show_int :: Int -> Int -> String+show_int digits int = let s = show int+ in replicate (digits - length s) '0' ++ s++-- Showing for the "From " line in mboxes is sadly a slightly different format++show_mbox_full_date :: FullDate -> String+show_mbox_full_date (FullDate m_dow (Date day month year) (Time tod _))+ = shown_dow ++ show month ++ " " ++ show_int 2 day ++ " " +++ show_tod tod ++ " " ++ show year+ where shown_dow = case m_dow of+ Nothing -> ""+ Just dow -> show dow ++ " "++------------------------ Parsing++get_date :: String -> Maybe FullDate+get_date xs+ = case parse ph_date xs of+ Left f -> Just f+ Right _ -> Nothing++ph_date :: Parser Char FullDate+ph_date = id+ <$ cws+ <*> p_date_time+ <* cws+ <* pEOI++p_date_time :: Parser Char FullDate+p_date_time = FullDate+ <$> pMaybe ( id+ <$> p_dow+ <* cws+ <* pChar ','+ <* cws)+ <*> p_date+ <* cws+ <*> p_time++p_dow :: Parser Char DOW+p_dow = Mon <$ p_ci_string "Mon"+ <|> Tue <$ p_ci_string "Tue"+ <|> Wed <$ p_ci_string "Wed"+ <|> Thu <$ p_ci_string "Thu"+ <|> Fri <$ p_ci_string "Fri"+ <|> Sat <$ p_ci_string "Sat"+ <|> Sun <$ p_ci_string "Sun"++p_date :: Parser Char Date+p_date = Date+ <$> p_day+ <* cws+ <*> p_month+ <* cws+ <*> p_year++-- obs-year merged in+p_year :: Parser Char Year+p_year = (\ds -> let y = read ds+ in case ds of+ [_, _, _] -> 2000 + y+ [_, _]+ | y < 50 -> 1900 + y+ | otherwise -> 2000 + y+ _ -> y)+ <$> pAtLeast 2 (pPred isAsciiDigit)++p_month :: Parser Char Month+p_month = Jan <$ p_ci_string "Jan"+ <|> Feb <$ p_ci_string "Feb"+ <|> Mar <$ p_ci_string "Mar"+ <|> Apr <$ p_ci_string "Apr"+ <|> May <$ p_ci_string "May"+ <|> Jun <$ p_ci_string "Jun"+ <|> Jul <$ p_ci_string "Jul"+ <|> Aug <$ p_ci_string "Aug"+ <|> Sep <$ p_ci_string "Sep"+ <|> Oct <$ p_ci_string "Oct"+ <|> Nov <$ p_ci_string "Nov"+ <|> Dec <$ p_ci_string "Dec"++p_day :: Parser Char Day+p_day = read <$> pFromTo 1 2 (pPred isAsciiDigit)++p_time :: Parser Char Time+p_time = Time+ <$> p_time_of_day+ <* cws+ <*> p_zone++p_time_of_day :: Parser Char TimeOfDay+p_time_of_day = TimeOfDay+ <$> p_hour+ <* cws+ <* pChar ':'+ <* cws+ <*> p_minute+ <*> pMaybe ( id+ <$ cws+ <* pChar ':'+ <* cws+ <*> p_second)++p_hour :: Parser Char Hour+p_hour = read <$> pExactly 2 (pPred isAsciiDigit)++p_minute :: Parser Char Minute+p_minute = read <$> pExactly 2 (pPred isAsciiDigit)++p_second :: Parser Char Second+p_second = read <$> pExactly 2 (pPred isAsciiDigit)++p_zone :: Parser Char Zone+p_zone = (\f n -> f $ read n)+ <$> (id <$ pChar '+' <|> negate <$ pChar '-')+ <*> pExactly 4 (pPred isAsciiDigit)+ <|> p_obs_zone++p_obs_zone :: Parser Char Zone+p_obs_zone = 0 <$ p_ci_string "UT"+ <|> 0 <$ p_ci_string "GMT"+ <|> -500 <$ p_ci_string "EST"+ <|> -400 <$ p_ci_string "EDT"+ <|> -600 <$ p_ci_string "CST"+ <|> -500 <$ p_ci_string "CDT"+ <|> -700 <$ p_ci_string "MST"+ <|> -600 <$ p_ci_string "MDT"+ <|> -800 <$ p_ci_string "PST"+ <|> -700 <$ p_ci_string "PDT"+ -- Military time zones. Strictly we shouldn't accept [jJ]+ -- but no harm done.+ -- 'they SHOULD all be considered equivalent to "-0000"' as+ -- RFC 822 defined them incorrectly.+ <|> 0 <$ pPred isAsciiAlpha++get_current_date :: MonadIO m => m FullDate+get_current_date+ = do clt <- liftIO getClockTime+ cat <- liftIO $ toCalendarTime clt+ let fd = FullDate (Just dow) date time+ get_dow Sunday = Sun+ get_dow Monday = Mon+ get_dow Tuesday = Tue+ get_dow Wednesday = Wed+ get_dow Thursday = Thu+ get_dow Friday = Fri+ get_dow Saturday = Sat+ get_month January = Jan+ get_month February = Feb+ get_month March = Mar+ get_month April = Apr+ get_month Time.May = May+ get_month June = Jun+ get_month July = Jul+ get_month August = Aug+ get_month September = Sep+ get_month October = Oct+ get_month November = Nov+ get_month December = Dec+ dow = get_dow (ctWDay cat)+ date = Date (ctDay cat) (get_month (ctMonth cat)) (ctYear cat)+ time = Time tod (ctTZ cat `div` 36)+ tod = TimeOfDay (ctHour cat) (ctMin cat) (Just (ctSec cat))+ return fd+
+ src/Codec/MIME/String/EncodedWord.hs view
@@ -0,0 +1,8 @@++module Codec.MIME.String.EncodedWord (base64_encode) where++import Codec.Binary.Base64.String (encode)++base64_encode :: String -> String -> String+base64_encode charset xs = "=?" ++ charset ++ "?B?" ++ encode xs ++ "?="+
+ src/Codec/MIME/String/Flatten.hs view
@@ -0,0 +1,144 @@++module Codec.MIME.String.Flatten+ (flatten, Attachments, Attachment)+ where++import qualified Codec.Binary.Base64.String as Base64 (encode)+import qualified Codec.MIME.String.QuotedPrintable as QP (encode)+import Codec.MIME.String.Headers+import Codec.MIME.String.Internal.Utils+import Codec.MIME.String.Types++{-+XXX For message IDs:+import Network.BSD (getHostName)+import System.Locale (defaultTimeLocale)+import System.Random (randomIO)+import System.Time (getClockTime, toCalendarTime, formatCalendarTime)+-}++type Attachments = [Attachment]+type Attachment = (String, FilePath, Maybe ContentType)++-- XXX This should be rewritten in a more compositional way!+flatten :: Headers -> String -> Maybe String -> Attachments -> IO String+flatten headers body maybeHtmlBody attachments+ = do -- XXX Could add one of one isn't already found? msgid <- mk_msgid+ let -- XXX This (\n) could be prettier - check llengths of bits+ alternativeBoundary = "=:A"+ alternativePartStart = "\n--" ++ alternativeBoundary ++ "\n"+ alternativePartsEnd = "\n--" ++ alternativeBoundary ++ "--\n"+ mixedBoundary = "=:M"+ mixedPartStart = "\n--" ++ mixedBoundary ++ "\n"+ mixedPartsEnd = "\n--" ++ mixedBoundary ++ "--\n"+ common_headers = unlines (concatMap h_raw_header headers)+ ++ "MIME-Version: 1.0\n"+ text_content_headers = unlines [+ "Content-type: text/plain; charset=utf-8",+ "Content-transfer-encoding: quoted-printable",+ "Content-Disposition: inline"]+ html_content_headers = unlines [+ "Content-type: text/html; charset=utf-8",+ "Content-transfer-encoding: quoted-printable",+ "Content-Disposition: inline"]+ -- This is overly paranoid+ safe_char c = isAsciiAlphaNum c || (c `elem` " .-_")+ mime_attachment (a, fn, mct)+ = let -- XXX showParam and ct should do some sanity checking+ -- of the values they are passed+ showParam (Parameter k v) = "; " ++ k ++ "=\"" ++ v ++ "\""+ ct = case mct of+ Just (ContentType x y ps) ->+ "Content-type: " ++ x ++ "/" ++ y+ ++ concatMap showParam ps ++ "\n"+ Nothing -> "Content-type: application/octet-stream\n"+ in mixedPartStart+ ++ ct+ ++ "Content-transfer-encoding: base64\n"+ ++ "Content-Disposition: attachment; filename=\""+ ++ (case reverse $ filter safe_char+ $ takeWhile ('/' /=)+ $ reverse fn of+ [] -> "unknown"+ fn' -> fn')+ ++ "\"\n"+ ++ "\n"+ ++ Base64.encode a+ msg = if single_part+ then case maybeHtmlBody of+ Nothing ->+ common_headers+ ++ text_content_headers+ ++ "\n"+ ++ QP.encode (my_lines body)+ Just htmlBody ->+ common_headers+ ++ "Content-type: multipart/alternative; boundary=\""+ ++ alternativeBoundary ++ "\"\n"+ ++ "\n"+ ++ "This is a multi-part message in MIME format.\n"+ ++ alternativePartStart+ ++ text_content_headers+ ++ "\n"+ ++ QP.encode (my_lines body)+ ++ alternativePartStart+ ++ html_content_headers+ ++ "\n"+ ++ QP.encode (my_lines htmlBody)+ ++ alternativePartsEnd+ else case maybeHtmlBody of+ Nothing ->+ common_headers+ ++ "Content-type: multipart/mixed; boundary=\""+ ++ mixedBoundary ++ "\"\n"+ ++ "\n"+ ++ "This is a multi-part message in MIME format.\n"+ ++ mixedPartStart+ ++ text_content_headers+ ++ "\n"+ ++ QP.encode (my_lines body)+ ++ concatMap mime_attachment attachments+ ++ mixedPartsEnd+ Just htmlBody ->+ common_headers+ ++ "Content-type: multipart/mixed; boundary=\""+ ++ mixedBoundary ++ "\"\n"+ ++ "\n"+ ++ "This is a multi-part message in MIME format.\n"+ ++ mixedPartStart+ -- Start of the body+ ++ "Content-type: multipart/alternative; boundary=\""+ ++ alternativeBoundary ++ "\"\n"+ ++ "\n"+ ++ alternativePartStart+ ++ text_content_headers+ ++ "\n"+ ++ QP.encode (my_lines body)+ ++ alternativePartStart+ ++ html_content_headers+ ++ "\n"+ ++ QP.encode (my_lines htmlBody)+ ++ alternativePartsEnd+ -- End of the body+ ++ concatMap mime_attachment attachments+ ++ mixedPartsEnd+ return msg+ where single_part = null attachments++-- XXX The IO calls used to use liftIOErr. We could use something similar+-- but require we are called in a MonadError m?+-- XXX We should possibly be including a program name+{-+mk_msgid :: IO String+mk_msgid+ = do hostname <- getHostName+ clock_time <- getClockTime+ calendar_time <- toCalendarTime clock_time+ r <- randomIO+ let timestamp = formatCalendarTime defaultTimeLocale+ "%Y%m%d%H%M%S" calendar_time+ lhs = concat $ intersperse "."+ [timestamp, show (r :: Int)]+ return (lhs ++ "@" ++ hostname)+-}+
+ src/Codec/MIME/String/Headers.hs view
@@ -0,0 +1,635 @@++-- We assume we have US-ASCII characters++module Codec.MIME.String.Headers+ (+ Domain(Domain, LiteralDomain),+ Mailbox(Mailbox),+ RoutedEmailAddress(RoutedEmailAddress, NormalEmailAddress),+ EmailAddress(EmailAddress), get_addr_spec,+ Address(Address, Group),+ ContentType(ContentType), get_content_type,+ ContentDescription(ContentDescription),+ get_content_description,+ ContentTransferEncoding(ContentTransferEncoding),+ get_content_transfer_encoding,+ ContentID(ContentID), get_content_id,+ MessageID(MessageID),+ MIMEVersion(MIMEVersion), get_mime_version,+ Parameter(Parameter), p_parameter,+ From(From), To(To), Subject(Subject),+ get_from, get_to, get_subject,+ get_boundary, p_extension_token, p_value, p_quoted_string,+ cws, p_ci_string,+ )+ where++import Prelude hiding ( (<*>), (<$>), (<*), (<$) )+import Codec.MIME.String.Internal.ABNF+ (+ Parser, parse, pSucceed, pFail,+ (<$>), (<$), (<*>), (<*), (<|>), (<|), (<!>),+ pEOI, pPred, pChar, pMany, pAtLeast, pMaybe, pOptDef, pString,+ )+import qualified Codec.Binary.Base64.String as Base64 (decode)+import qualified Codec.Binary.EncodingQ.String as EncodingQ (decode)+import Codec.MIME.String.Internal.Utils++import Codec.Text.IConv+import qualified Data.ByteString.Lazy.Char8 as BS+import Data.Char+import Data.List++-----------------------+-- Utils++ignore :: Parser inp a -> Parser inp ()+ignore p = () <$ p++boxp :: Parser inp a -> Parser inp [a]+boxp p = box <$> p++-----------------------+-- RFC 2234++p_CTL :: Parser Char Char+p_CTL = pPred (\c -> ord c < 32 || ord c == 127)++p_SP :: Parser Char Char+p_SP = pChar ' '++p_HTAB :: Parser Char Char+p_HTAB = pChar '\t'++p_WSP :: Parser Char Char+p_WSP = p_SP <|> p_HTAB++-----------------------+-- RFC 2822++-- Case insensitive strings, written "Foo"+p_ci_string :: String -> Parser Char String+p_ci_string s = s <$ f s+ where f "" = pSucceed ()+ f (c:cs) = let p = if isAsciiAlpha c+ then pChar (toLower c) <| pChar (toUpper c)+ else pChar c+ in () <$ p <* f cs++p_NO_WS_CTL :: Parser Char Char+p_NO_WS_CTL = pPred (\c -> let o = ord c in 1 <= o && o <= 8+ || o == 11+ || o == 12+ || 14 <= o && o <= 31+ || o == 127)++-- If we follow the spec precisely then we get pMany (pMany), and hence+-- non-termination, so we merge the definition of p_obs_text in.+p_text :: Parser Char String+p_text = concat+ <$> pMany (+ p_encoded_words+ <| boxp (pPred (\c -> let o = ord c in 0 <= o && o <= 9+ || o == 11+ || o == 12+ || 14 <= o && o <= 127))+ )++-- We are lax about checking they have any necessary surrounding+-- whitespace+p_encoded_words :: Parser Char String+p_encoded_words = (\x xs -> x ++ concat xs)+ <$> p_encoded_word+ <*> pMany (id <$ cws <*> p_encoded_word)++-- XXX What happens if iconv doesn't understand the charset "cs"?+p_encoded_word :: Parser Char String+p_encoded_word = (\cs dec text -> BS.unpack $ convertFuzzy Transliterate cs "utf8" $ BS.pack $ dec text)+ <$ pString "=?"+ <*> p_charset+ <* pChar '?'+ <*> p_encoding+ <* pChar '?'+ <*> p_encoded_text+ <* pString "?="++-- token definition inlined as they use a different one to p_token.+p_charset :: Parser Char String+p_charset = pAtLeast 1 (pPred isAscii <!> (p_SP <|> p_CTL <|> p_especials))++p_especials :: Parser Char Char+p_especials = pPred (`elem` "()<>@,;:\\\"/[]?.=")++-- This is much stricter than specified, but if it's not [qQbB] then+-- we'd want to fall back to showing it as a string anyway.+p_encoding :: Parser Char (String -> String)+p_encoding = EncodingQ.decode <$ (pChar 'Q' <|> pChar 'q')+ <|> Base64.decode <$ (pChar 'B' <|> pChar 'b')++p_encoded_text :: Parser Char String+p_encoded_text = pMany (pPred (\c -> isAsciiPrint c && c /= '?' && c /= ' '))++p_quoted_pair :: Parser Char String+p_quoted_pair = id <$ pChar '\\' <*> p_text <|> boxp p_obs_qp++p_obs_qp :: Parser Char Char+p_obs_qp = id <$ pChar '\\' <*> pPred isAscii++-- Done differently as the newlines are already gone+p_FWS :: Parser Char String+p_FWS = pMany p_WSP++p_ctext :: Parser Char Char+p_ctext = p_NO_WS_CTL+ <|> pPred (\c -> let o = ord c in 33 <= o && o <= 39+ || 42 <= o && o <= 91+ || 93 <= o && o <= 126)++p_ccontent :: Parser Char ()+p_ccontent = ignore p_ctext <|> ignore p_quoted_pair <|> p_comment++p_comment :: Parser Char ()+p_comment = ()+ <$ pChar '('+ <* pMany (() <$ pMany p_NO_WS_CTL <* p_ccontent)+ <* pMany p_NO_WS_CTL+ <* pChar ')'++-- We might want to keep the result. If we do then we also need to+-- handle encoded words properly.+-- This isn't quite CFWS as we need to be able to accept "1.0"+-- as a MIME version with cws between all the characters.+-- Also, we've already removed all the newlines in the headers.+cws :: Parser Char ()+cws = ignore $ pMany (ignore (pAtLeast 1 p_WSP) <|> p_comment)++p_qtext :: Parser Char Char+p_qtext = p_NO_WS_CTL+ <|> pPred (\c -> let o = ord c in o == 33+ || 35 <= o && o <= 91+ || 93 <= o && o <= 126)++p_qcontent :: Parser Char String+p_qcontent = boxp p_qtext+ <|> p_quoted_pair++p_quoted_string :: Parser Char String+p_quoted_string = (++)+ <$ cws+ <* pChar '"'+ <*> (concat <$> pMany ((++) <$> pOptDef "" p_FWS <*> p_qcontent))+ <*> pOptDef "" p_FWS+ <* pChar '"'++p_dcontent :: Parser Char String+p_dcontent = boxp p_dtext <|> p_quoted_pair++p_dtext :: Parser Char Char+p_dtext = p_NO_WS_CTL+ <|> pPred (\c -> let o = ord c in 33 <= o && o <= 90+ || 94 <= o && o <= 126)++data MessageID = MessageID String Domain+ deriving (Show, Read)++p_msg_id :: Parser Char MessageID+p_msg_id = MessageID+ <$ cws+ <* pChar '<'+ <*> p_id_left+ <* pChar '@'+ <*> p_id_right+ <* pChar '>'+ <* cws++p_atom :: Parser Char String+p_atom = id+ <$ cws+ <*> pAtLeast 1 p_atext+ <* cws++p_atext :: Parser Char Char+p_atext = pPred (\c -> isAsciiAlphaNum c || c `elem` "!#$%&'+-/=?^_`{|}~")++p_dot_atom :: Parser Char String+p_dot_atom = id + <$ cws+ <*> p_dot_atom_text+ <* cws++p_word :: Parser Char String+p_word = p_atom <|> p_quoted_string++-- This incorporates obs-phrase+p_phrase :: Parser Char [String]+p_phrase = (:)+ <$> (p_encoded_words <| p_word)+ <*> pMany (id <$ cws <*> (p_encoded_words <| p_word <| pString "."))+ <|> boxp p_quoted_string++p_dot_atom_text :: Parser Char String+p_dot_atom_text = (\x xs -> x ++ concat xs)+ <$> pAtLeast 1 p_atext+ <*> pMany ((:) <$> pChar '.' <*> pAtLeast 1 p_atext)++p_id_left :: Parser Char String+p_id_left = p_dot_atom_text <|> p_no_fold_quote <|> p_obs_id_left++p_id_right :: Parser Char Domain+p_id_right = Domain <$> p_dot_atom_text+ <|> p_no_fold_literal+ <|> p_obs_id_right++p_obs_id_left :: Parser Char String+p_obs_id_left = p_local_part++p_local_part :: Parser Char String+p_local_part = p_dot_atom <|> p_quoted_string <|> p_obs_local_part++p_obs_local_part :: Parser Char String+p_obs_local_part = (\x xs -> x ++ concat xs)+ <$> p_word+ <*> pMany ((:) <$> pChar '.' <*> p_word)++p_domain :: Parser Char Domain+p_domain = Domain <$> p_dot_atom <|> p_domain_literal <|> p_obs_domain++p_domain_literal :: Parser Char Domain+p_domain_literal = (LiteralDomain . concat)+ <$ cws+ <* pChar '['+ <*> pMany ( id+ <$ p_FWS+ <*> p_dcontent)+ <* p_FWS+ <* pChar ']'+ <* cws++p_obs_domain :: Parser Char Domain+p_obs_domain = (\x xs -> Domain (x ++ concat xs))+ <$> p_atom+ <*> pMany ((:) <$> pChar '.' <*> p_atom)++p_obs_id_right :: Parser Char Domain+p_obs_id_right = p_domain++p_no_fold_quote :: Parser Char String+p_no_fold_quote = concat+ <$ pChar '"'+ <*> pMany (boxp p_qtext <|> p_quoted_pair)+ <* pChar '"'++data Domain = Domain String | LiteralDomain String+ deriving (Show, Read, Eq)++p_no_fold_literal :: Parser Char Domain+p_no_fold_literal = LiteralDomain . concat+ <$ pChar '['+ <*> pMany (boxp p_dtext <|> p_quoted_pair)+ <* pChar ']'++newtype Subject = Subject String+ deriving (Show, Read)++get_subject :: String -> Maybe Subject+get_subject xs+ = case parse ph_subject xs of+ Left cd -> Just cd+ Right _ -> Nothing++-- This is actually the RFC822 definition, as otherwise things get very+-- confusing.+-- Would be pMany, but p_text already does that for us+ph_subject :: Parser Char Subject+ph_subject = Subject <$> p_text <* pEOI++newtype From = From [Mailbox]+ deriving (Show, Read, Eq)++get_from :: String -> Maybe From+get_from xs+ = case parse ph_from xs of+ Left f -> Just f+ Right _ -> Nothing++ph_from :: Parser Char From+ph_from = From <$ cws <*> p_mailbox_list <* cws <* pEOI++newtype To = To [Address]+ deriving (Show, Read)++data Address = Address Mailbox+ | Group String [Mailbox]+ deriving (Show, Read)++get_to :: String -> Maybe To+get_to xs+ = case parse ph_to xs of+ Left t -> Just t+ Right _ -> Nothing++ph_to :: Parser Char To+ph_to = To <$ cws <*> p_address_list <* cws <* pEOI++-- obs-addr-list merged in+p_address_list :: Parser Char [Address]+p_address_list = (:)+ <$ pMany (() <$ pChar ',' <* cws)+ <*> p_address+ <*> pMany ( id+ <$ pAtLeast 1 (() <$ cws <* pChar ',')+ <* cws+ <*> p_address)+ <* pMany (() <$ cws <* pChar ',')++p_address :: Parser Char Address+p_address = Address <$> p_mailbox+ <|> p_group++p_group :: Parser Char Address+p_group = Group+ <$> p_display_name + <* cws+ <* pChar ':'+ <* cws+ <*> pOptDef [] p_mailbox_list+ <* cws+ <* pChar ';'++-- obs-mbox-list merged in+p_mailbox_list :: Parser Char [Mailbox]+p_mailbox_list = (:)+ <$ pMany (() <$ pChar ',' <* cws)+ <*> p_mailbox+ <*> pMany ( id+ <$ pAtLeast 1 (() <$ cws <* pChar ',')+ <* cws+ <*> p_mailbox)+ <* pMany (() <$ cws <* pChar ',')++data Mailbox = Mailbox (Maybe String) RoutedEmailAddress+ deriving (Show, Read, Eq)++p_mailbox :: Parser Char Mailbox+p_mailbox = p_name_addr+ <|> (Mailbox Nothing . NormalEmailAddress) <$> p_addr_spec++p_name_addr :: Parser Char Mailbox+p_name_addr = Mailbox+ <$> pMaybe p_display_name+ <* cws+ <*> p_angle_addr++data EmailAddress = EmailAddress String Domain+ deriving (Show, Read, Eq)++data RoutedEmailAddress = NormalEmailAddress EmailAddress+ | RoutedEmailAddress [Domain] EmailAddress+ deriving (Show, Read, Eq)++p_angle_addr :: Parser Char RoutedEmailAddress+p_angle_addr = ($)+ <$ pChar '<'+ <* cws+ -- This next makes us also satisfy obs-angle-addr+ <*> pOptDef NormalEmailAddress+ (RoutedEmailAddress <$> p_obs_route <* cws)+ <*> p_addr_spec+ <* cws+ <* pChar '>'++get_addr_spec :: String -> Maybe EmailAddress+get_addr_spec xs+ = case parse p_addr_spec xs of+ Left e -> Just e+ Right _ -> Nothing++p_addr_spec :: Parser Char EmailAddress+p_addr_spec = EmailAddress+ <$> p_local_part+ <* cws+ <* pChar '@'+ <* cws+ <*> p_domain++p_display_name :: Parser Char String+p_display_name = (concat . intersperse " ") <$> p_phrase++p_obs_route :: Parser Char [Domain]+p_obs_route = id <$> p_obs_domain_list <* pChar ':'++p_obs_domain_list :: Parser Char [Domain]+p_obs_domain_list = (:)+ <$ pChar '@'+ <* cws+ <*> p_domain+ <*> pMany ( id+ <$ pMaybe (() <$ cws <* pChar ',')+ <* cws+ <* pChar '@'+ <* cws+ <*> p_domain)++-----------------------+-- RFC 2045++data MIMEVersion = MIMEVersion Integer Integer+ deriving (Show, Read)++get_mime_version :: String -> Maybe MIMEVersion+get_mime_version xs = case parse ph_mime_version xs of+ Left ct -> Just ct+ Right _ -> Nothing++ph_mime_version :: Parser Char MIMEVersion+ph_mime_version = MIMEVersion+ <$ cws+ <*> (read <$> pMany (pPred isAsciiDigit))+ <* cws+ <* pChar '.'+ <* cws+ <*> (read <$> pMany (pPred isAsciiDigit))+ <* cws+ <* pEOI++data ContentType = ContentType String -- Case insensitive: lower-cased+ String -- Case insensitive: lower-cased+ [Parameter]+ deriving (Show, Read)+data Parameter = Parameter String -- Case insensitive: lower-cased+ String+ deriving (Show, Read)++get_content_type :: String -> Maybe ContentType+get_content_type xs = case parse ph_content_type xs of+ Left ct -> Just ct+ Right _ -> Nothing++ph_content_type :: Parser Char ContentType+ph_content_type = ContentType+ <$ cws+ <*> p_type+ <* cws+ <* pChar '/'+ <* cws+ <*> p_subtype+ <*> pMany (id+ <$ cws+ <* pChar ';'+ <* cws+ <*> p_parameter)+ <* cws+ <* pEOI+++-- For type and subtypes, allow anything that matches a regexp that+-- subsumes the currently allowed values+p_type :: Parser Char String+p_type = pAtLeast 1 (pPred (\c -> isAsciiAlphaNum c || c `elem` "-.+"))++p_subtype :: Parser Char String+p_subtype = pAtLeast 1 (pPred (\c -> isAsciiAlphaNum c || c `elem` "-.+"))++{-+p_type :: Parser Char String+p_type = p_discrete_type <|> p_composite_type++p_subtype :: Parser Char String+p_subtype = map asciiToLower <$> (p_extension_token <|> p_iana_token)++p_discrete_type :: Parser Char String+p_discrete_type = p_ci_string "text"+ <|> p_ci_string "image"+ <|> p_ci_string "audio"+ <|> p_ci_string "video"+ <|> p_ci_string "application"+ <|> map asciiToLower <$> p_extension_token++p_composite_type :: Parser Char String+p_composite_type = p_ci_string "message"+ <|> p_ci_string "multipart"+ <|> map asciiToLower <$> p_extension_token++p_iana_token :: Parser Char String+p_iana_token = pFail+-}++p_extension_token :: Parser Char String+p_extension_token = p_ietf_token <|> p_x_token++p_ietf_token :: Parser Char String+p_ietf_token = pFail++p_x_token :: Parser Char String+p_x_token = (\x t -> x:'-':t)+ <$> (pChar 'X' <|> pChar 'x')+ <* pChar '-'+ <*> p_token++p_parameter :: Parser Char Parameter+p_parameter = Parameter+ <$> p_attribute+ <* cws+ <* pChar '='+ <* cws+ <*> p_value++p_attribute :: Parser Char String+p_attribute = map asciiToLower <$> p_token++p_value :: Parser Char String+p_value = p_token <|> p_quoted_string++p_token :: Parser Char String+p_token = pAtLeast 1 (pPred isAscii <!> (p_SP <|> p_CTL <|> p_tspecials))++p_tspecials :: Parser Char Char+p_tspecials = pPred (`elem` "()<>@,;:\\\"/[]?=")++-----++newtype ContentTransferEncoding+ = ContentTransferEncoding String -- Case insensitive: lower-cased+ deriving (Show, Read)++get_content_transfer_encoding :: String -> Maybe ContentTransferEncoding+get_content_transfer_encoding xs+ = case parse ph_content_transfer_encoding xs of+ Left cte -> Just cte+ Right _ -> Nothing++ph_content_transfer_encoding :: Parser Char ContentTransferEncoding+ph_content_transfer_encoding+ = ContentTransferEncoding+ <$ cws+ <*> p_mechanism+ <* cws+ <* pEOI++p_mechanism :: Parser Char String+p_mechanism = p_ci_string "7bit"+ <|> p_ci_string "8bit"+ <|> p_ci_string "binary"+ <|> p_ci_string "quoted-printable"+ <|> p_ci_string "base64"+ <|> map asciiToLower <$> p_ietf_token+ <|> map asciiToLower <$> p_x_token++newtype ContentID = ContentID MessageID+ deriving (Show, Read)++get_content_id :: String -> Maybe ContentID+get_content_id xs+ = case parse ph_content_id xs of+ Left ci -> Just ci+ Right _ -> Nothing++ph_content_id :: Parser Char ContentID+ph_content_id+ = ContentID+ <$ cws+ <*> p_msg_id+ <* cws+ <* pEOI++newtype ContentDescription = ContentDescription String+ deriving (Show, Read)++get_content_description :: String -> Maybe ContentDescription+get_content_description xs+ = case parse ph_content_description xs of+ Left cd -> Just cd+ Right _ -> Nothing++ph_content_description :: Parser Char ContentDescription+ph_content_description+ = ContentDescription+ <$ cws+ <*> p_text -- would be pMany, but p_text already does that for us+ <* cws+ <* pEOI++-----------------------+-- RFC 2046++-- Not really a header as such++get_boundary :: String -> Maybe String+get_boundary xs+ = case parse p_boundary xs of+ Left b -> Just b+ Right _ -> Nothing++-- We are very flexible here+p_boundary :: Parser Char String+p_boundary = (\ss b bs -> dropFromEndWhile (' ' ==) (ss ++ [b] ++ bs))+ <$> pMany (pChar ' ')+ <*> p_bchars+ <*> pMany p_bchars++p_bchars :: Parser Char Char+p_bchars = p_bcharsnospace <|> pChar ' '++p_bcharsnospace :: Parser Char Char+p_bcharsnospace = pPred (\c -> isAsciiAlphaNum c || c `elem` "'()+_,-./:=?")+
+ src/Codec/MIME/String/Internal/ABNF.hs view
@@ -0,0 +1,173 @@++module Codec.MIME.String.Internal.ABNF+ (Parser, apply, parse,+ pPred, pSucceed, pFail, pEOI, (<*>), (<|>), (<| ), (<!>), nested_parse,+ pChar, pString, (<$>), (<$ ), (<* ), ( |>),+ pMany, pAtLeast, pAtMost, pExactly, pFromTo, pOptDef, pMaybe+ ) where++import Prelude hiding ( (<*>), (<$>), (<*), (<$) )++newtype Parser inp res = Parser ([(inp, Pos)] -> ParseResult inp res)++data ParseResult inp res = Success res [(inp, Pos)] !Pos+ | Fail !Pos++type Line = Integer+type Column = Integer+data Pos = Pos !Line !Column+ | EOI+ deriving (Eq, Ord)++get_pos :: [(a, Pos)] -> Pos+get_pos [] = EOI+get_pos ((_, p):_) = p++show_pos :: Pos -> String+show_pos EOI = "End of input"+show_pos (Pos l c) = "Line " ++ show l ++ ", column " ++ show c++infixl 6 <$>, <$, <*>, <*+infixr 3 <|>, <|, |>++posify :: String -> [(Char, Pos)]+posify = f 1 1+ where f _ _ [] = []+ f l c ('\n':xs) = ('\n', Pos l c):f (l+1) 1 xs+ f l c (x :xs) = (x, Pos l c):f l (c+1) xs++apply :: Parser Char a -> String -> Either (a, String) String+apply (Parser p) xs+ = case p $ posify xs of+ Success res ys _ -> Left (res, map fst ys)+ Fail pos -> Right ("Error: Failed at " ++ show_pos pos)++parse :: Parser Char a -> String -> Either a String+parse (Parser p) xs+ = case p $ posify xs of+ Success res [] _ -> Left res+ Success _ ((_, pos):_) _ ->+ Right ("Error: Only consumed up to " ++ show_pos pos)+ Fail pos ->+ Right ("Error: Failed at " ++ show_pos pos)++-- Primitive combinators++pPred :: (inp -> Bool) -> Parser inp inp+pPred p = Parser+ $ \inp -> case inp of+ ((x, pos):inp')+ | p x -> Success x inp' pos+ _ -> Fail (get_pos inp)++pSucceed :: res -> Parser a res+pSucceed x = Parser $ \inp -> Success x inp (get_pos inp)++pFail :: Parser a res+pFail = Parser $ \inp -> Fail (get_pos inp)++pEOI :: Parser a ()+pEOI = Parser $ \inp -> case inp of+ [] -> Success () [] EOI+ _ -> Fail (get_pos inp)++(<*>) :: Parser inp (a -> b) -> Parser inp a -> Parser inp b+Parser p <*> Parser q = Parser $ \inp ->+ case p inp of+ Fail pos -> Fail pos+ Success f inp' pos ->+ case q inp' of+ Fail pos' -> Fail (pos `max` pos')+ Success x inp'' pos' ->+ Success (f x) inp'' (pos `max` pos')++(<|>) :: Parser inp a -> Parser inp a -> Parser inp a+Parser p <|> Parser q = Parser $ \inp ->+ case (p inp, q inp) of+ (Fail posp, Fail posq) -> Fail (posp `max` posq)+ (Fail posp, Success x inp' posq) ->+ Success x inp' (posp `max` posq)+ (Success x inp' posp, Fail posq) ->+ Success x inp' (posp `max` posq)+ (rp@(Success _ _ posp), rq@(Success _ _ posq))+ -> if posp >= posq then rp else rq++(<| ) :: Parser inp a -> Parser inp a -> Parser inp a+Parser p <| Parser q = Parser $ \inp ->+ case p inp of+ Fail posp ->+ case q inp of+ Fail posq -> Fail (posp `max` posq)+ Success x inp' posq ->+ Success x inp' (posp `max` posq)+ s -> s++(<!>) :: Parser inp a -> Parser inp b -> Parser inp a+Parser p <!> Parser q = Parser $ \inp -> case q inp of+ Fail _ ->+ p inp+ Success _ _ pos -> Fail pos++check_fails_empty :: Parser inp a -> ()+check_fails_empty (Parser p) = case p [] of+ Fail _ -> ()+ _ -> error "check_fails_empty failed"++nested_parse :: Parser Char String -> Parser Char a -> Parser Char a+nested_parse (Parser p1) (Parser p2)+ = Parser+ $ \inp -> case p1 inp of+ Fail pos -> Fail pos+ Success inp' rem_inp pos ->+ case p2 $ posify inp' of+ Fail pos' -> Fail (pos `max` pos')+ Success x [] pos' -> Success x rem_inp (pos `max` pos')+ Success _ _ pos' -> Fail (pos `max` pos')++-- Derived combinators++pChar :: Char -> Parser Char Char+pChar c = pPred (c ==)++pString :: String -> Parser Char String+pString "" = pSucceed ""+pString (c:cs) = (:) <$> pChar c <*> pString cs++(<$>) :: (a -> b) -> Parser inp a -> Parser inp b+x <$> q = pSucceed x <*> q++(<$ ) :: a -> Parser inp b -> Parser inp a+x <$ q = pSucceed x <* q++(<* ) :: Parser inp a -> Parser inp b -> Parser inp a+p <* q = (\x _ -> x) <$> p <*> q++( |>) :: Parser inp a -> Parser inp a -> Parser inp a+p |> q = q <| p++pMany :: Parser inp a -> Parser inp [a]+pMany p = check_fails_empty p `seq` ((:) <$> p <*> pMany p) <| pSucceed []++pAtLeast :: Word -> Parser inp a -> Parser inp [a]+pAtLeast 0 p = pMany p+pAtLeast n p = (:) <$> p <*> pAtLeast (n-1) p++pAtMost :: Word -> Parser inp a -> Parser inp [a]+pAtMost 0 _ = pSucceed []+pAtMost n p = ((:) <$> p <*> pAtMost (n-1) p) <| pSucceed []++pExactly :: Word -> Parser inp a -> Parser inp [a]+pExactly 0 _ = pSucceed []+pExactly n p = (:) <$> p <*> pExactly (n-1) p++pFromTo :: Word -> Word -> Parser inp a -> Parser inp [a]+pFromTo 0 t p = pAtMost t p+pFromTo _ 0 _ = error "Codec.MIME.String.Internal.ABNF.pFromTo: Bad arguments"+pFromTo f t p = (:) <$> p <*> pFromTo (f-1) (t-1) p++pOptDef :: a -> Parser inp a -> Parser inp a+pOptDef x p = p <| pSucceed x++pMaybe :: Parser inp a -> Parser inp (Maybe a)+pMaybe p = Just <$> p <| pSucceed Nothing+
+ src/Codec/MIME/String/Internal/Utils.hs view
@@ -0,0 +1,58 @@++module Codec.MIME.String.Internal.Utils where++import Data.Char++isAsciiDigit :: Char -> Bool+isAsciiDigit c = isAscii c && isDigit c++isAsciiHexDigit :: Char -> Bool+isAsciiHexDigit c = isAscii c && isHexDigit c++isAsciiPrint :: Char -> Bool+isAsciiPrint c = isAscii c && isPrint c++isAsciiAlpha :: Char -> Bool+isAsciiAlpha c = isAscii c && isAlpha c++isAsciiAlphaNum :: Char -> Bool+isAsciiAlphaNum c = isAscii c && isAlphaNum c++asciiToLower :: Char -> Char+asciiToLower c | isAscii c = toLower c+ | otherwise = c++asciiToUpper :: Char -> Char+asciiToUpper c | isAscii c = toUpper c+ | otherwise = c++splits :: Int -> [a] -> [[a]]+splits _ [] = []+splits n xs = case splitAt n xs of+ (ys, zs) -> ys:splits n zs++box :: a -> [a]+box x = [x]++dropFromEndWhile :: (a -> Bool) -> [a] -> [a]+dropFromEndWhile p = foldr (\x xs -> if null xs && p x then [] else x:xs) []++-- We are generous about what we allow as line terminators. Any of+-- \r \n \r\n \n\r will satisfy us.+my_lines :: String -> [String]+my_lines xs = case get_line xs of+ (ys, Nothing) -> [ys]+ (ys, Just zs) -> ys:my_lines zs++get_line :: String -> (String, Maybe String)+get_line xs = case break is_cr_or_lf xs of+ (ys, z1:z2:zs)+ | is_cr_or_lf z2 && z1 /= z2 -> (ys, Just zs)+ (ys, _:zs) -> (ys, Just zs)+ (ys, "") -> (ys, Nothing)++is_cr_or_lf :: Char -> Bool+is_cr_or_lf '\r' = True+is_cr_or_lf '\n' = True+is_cr_or_lf _ = False+
+ src/Codec/MIME/String/Parse.hs view
@@ -0,0 +1,314 @@++module Codec.MIME.String.Parse where++import qualified Codec.Binary.Base64.String as Base64 (decode)+import Codec.MIME.String.ContentDisposition+ (+ ContentDisposition(ContentDisposition), get_content_disposition,+ DispositionType(Inline, Attachment),+ DispositionParameter(..),+ )+import Codec.MIME.String.Date (get_date)+import Codec.MIME.String.Headers+ (+ ContentTransferEncoding(ContentTransferEncoding),+ get_content_transfer_encoding,+ ContentType(ContentType), get_content_type,+ get_content_description, get_boundary,+ Parameter(Parameter),+ MIMEVersion(MIMEVersion), get_mime_version,+ Subject(Subject),+ get_subject, get_from, get_to,+ )+import qualified Codec.MIME.String.QuotedPrintable as QuotedPrintable (decode)+import Codec.MIME.String.Types+ (+ ParseM,+ Header(Header, h_raw_header, h_raw_name, h_name, h_body),+ Headers,+ Message(Message),+ MessageInfo(..),+ Multipart(Multipart),+ MessageContent(NoContent, Mixed, Alternative,+ Parallel, Digest, RFC822),+ mkData, mkBody,+ digest_content_type, ascii_text_content_type,+ )+import Codec.MIME.String.Internal.Utils++import Codec.Text.IConv+import Control.Monad (liftM)+import Control.Monad.State (evalState, get, put)+import qualified Data.ByteString.Lazy.Char8 as BS+import Data.ByteString.Lazy.Char8 (ByteString)+import Data.Maybe (fromMaybe)++mkMessage :: MessageInfo -> ParseM MessageContent -> ParseM Message+mkMessage mi f_mc+ = do pn <- get+ put (pn + 1)+ -- This is done slightly oddly so we get numbering in the natural+ -- order, which in turn is important when looking for a part number+ mc <- f_mc+ return $ Message pn mi mc++parse :: String -> Message+parse msg = evalState (parse_message msg) 1++parse_message :: String -> ParseM Message+parse_message msg+ = let (headers, m_body) = parse_headers msg+ in case get_header headers "mime-version:" get_mime_version of+ -- We only try and be clever if the MIME version is 1.0+ Just (MIMEVersion 1 0) ->+ parse_mime_message ascii_text_content_type msg+ _ ->+ do let m_from = get_header headers "from:" get_from+ m_subject = get_header headers "subject:" (Just . Subject)+ m_to = get_header headers "to:" get_to+ m_date = get_header headers "date:" get_date+ mi = MessageInfo {+ mi_headers = headers,+ mi_from = m_from,+ mi_subject = m_subject,+ mi_to = m_to,+ mi_date = m_date,+ mi_content_description = Nothing+ }+ mc = case m_body of+ Just body ->+ mkBody ascii_text_content_type "unknown"+ (convertAsciiToUtf8 body)+ Nothing ->+ return $ NoContent ascii_text_content_type+ mkMessage mi mc++convertAsciiToUtf8 :: String -> String+convertAsciiToUtf8 xs+ = BS.unpack $ convertFuzzy Transliterate "US-ASCII" "utf8" $ BS.pack xs++parse_mime_message :: ContentType -> String -> ParseM Message+parse_mime_message def_content_type msg+ = let (headers, m_body) = parse_headers msg+ mi = make_mime_message_info headers+ mc = case m_body of+ Nothing ->+ do let m_ct = get_header headers "content-type:"+ get_content_type+ content_type = fromMaybe def_content_type m_ct+ return $ NoContent content_type+ Just body ->+ make_mime_message_content def_content_type headers body+ in mkMessage mi mc++make_mime_message_info :: Headers -> MessageInfo+make_mime_message_info headers+ = let m_content_description = get_header headers "content-description:"+ get_content_description+ m_from = get_header headers "from:" get_from+ m_subject = get_header headers "subject:" get_subject+ m_to = get_header headers "to:" get_to+ m_date = get_header headers "date:" get_date+ in MessageInfo {+ mi_headers = headers,+ mi_from = m_from,+ mi_subject = m_subject,+ mi_to = m_to,+ mi_date = m_date,+ mi_content_description = m_content_description+ }++make_mime_message_content :: ContentType -> Headers -> String+ -> ParseM MessageContent+make_mime_message_content def_content_type headers body+ = -- We accept illegal combinations of content type and+ -- encoding, so just decode whatever it says+ case m_decoded_body of+ Nothing ->+ mkData (Just cte) content_type filename body+ Just decoded_body ->+ case content_disposition of+ ContentDisposition Attachment _ ->+ mkData Nothing content_type filename decoded_body+ ContentDisposition Inline _ ->+ case content_type of+ ContentType "text" _ ps ->+ let charset = fromMaybe "US-ASCII"+ $ lookup_param "charset" ps+ decoded_body' = BS.pack decoded_body+ in case tryConvertFuzzy Transliterate charset "utf8" decoded_body' of+ Just xs ->+ mkBody content_type filename $ BS.unpack xs+ Nothing ->+ mkData Nothing content_type filename decoded_body+ ContentType "multipart" st ps+ | Just raw_b <- lookup_param "boundary" ps,+ Just b <- get_boundary raw_b+ -> do let (preamble, parts, epilogue)+ = get_parts b decoded_body+ ct = case st of+ "digest" -> digest_content_type+ _ -> ascii_text_content_type+ constr = case st of+ "alternative" -> Alternative+ "parallel" -> Parallel+ "digest" -> Digest+ _ -> Mixed+ ms <- mapM (parse_mime_message ct) parts+ return $ constr (Multipart preamble ms epilogue)+ ContentType "message" "rfc822" _ ->+ liftM (RFC822 decoded_body filename)+ (parse_message decoded_body)+ -- Anything else is treated like an+ -- application/octet-stream+ _ -> mkData Nothing content_type filename decoded_body+ where m_cd = get_header headers "content-disposition:"+ get_content_disposition+ content_disposition = fromMaybe (ContentDisposition Inline []) m_cd+ m_ct = get_header headers "content-type:"+ get_content_type+ content_type = fromMaybe def_content_type m_ct+ filename = get_filename content_disposition content_type+ m_ce = get_header headers "content-transfer-encoding:"+ get_content_transfer_encoding+ cte@(ContentTransferEncoding content_transfer_encoding)+ = fromMaybe (ContentTransferEncoding "7bit") m_ce+ m_decoded_body+ | content_transfer_encoding == "base64" = Just (Base64.decode body)+ | content_transfer_encoding == "quoted-printable" = Just (QuotedPrintable.decode $ my_lines body)+ | content_transfer_encoding `elem` ["7bit", "8bit", "binary"] = Just body+ -- Don't worry if 8-bit data is in 7-bit transfer-encoded data+ | otherwise = Nothing++-- XXX This is rather hacky. We really want convertFuzzy to tell us if+-- the conversion is supported itself+tryConvertFuzzy :: Fuzzy -> EncodingName -> EncodingName -> ByteString+ -> Maybe ByteString+tryConvertFuzzy fuzzy from_charset to_charset decoded_body =+ case convertStrictly from_charset to_charset decoded_body of+ Right (UnsuportedConversion {}) -> Nothing+ _ -> Just $ convertFuzzy fuzzy from_charset to_charset decoded_body++get_filename :: ContentDisposition -> ContentType -> FilePath+get_filename (ContentDisposition _ params) (ContentType _ _ params')+ = loop params+ where loop [] = -- Look up legacy name parameter in content type+ case lookup_param "name" params' of+ Nothing -> default_filename+ Just f -> sanitise f+ loop (Filename f:_) = sanitise f+ loop (_:ps) = loop ps+ sanitise f = case reverse $ takeWhile ('/' /=) $ reverse f of+ "" -> default_filename+ f' -> f'+ default_filename = "unknown"++get_parts :: String -> String -> (String, [String], String)+get_parts boundary body+ = case gps [] body of+ (pre:parts, epi) -> (pre, parts, epi)+ _ -> error "Parse.get_parts: Can't happen XXX"+ where gps acc "" = ([from_acc acc], "")+ gps acc xs+ = case fmap (dropWhile isWSP) $ after dd_boundary+ $ snd $ read_line_ending xs of+ Just "--" -> ([from_acc acc], "")+ Just ('-':'-':cs@(c:_))+ | is_cr_or_lf c -> ([from_acc acc], cs)+ Just "" -> ([from_acc acc], "")+ Just (c1:cs)+ | is_cr_or_lf c1+ -> let cs' = case cs of+ c2:cs''+ | is_cr_or_lf c2 && c1 /= c2+ -> cs''+ _ -> cs+ in case gps [] cs' of+ (ps, ep) -> (from_acc acc:ps, ep)+ _ -> case read_line_ending xs of+ (le, xs') ->+ case break is_cr_or_lf xs' of+ (ys, zs) -> gps (ys:le:acc) zs+ from_acc acc = concat $ reverse acc+ read_line_ending cs = case cs of+ (c1:cs1)+ | is_cr_or_lf c1 ->+ case cs1 of+ (c2:cs2)+ | is_cr_or_lf c2 && c1 /= c2 ->+ ([c1, c2], cs2)+ _ -> ([c1], cs1)+ _ -> ("", cs)+ after "" ys = Just ys+ after (x:xs) (y:ys)+ | x == y = after xs ys+ | otherwise = Nothing+ after (_:_) "" = Nothing+ dd_boundary = "--" ++ boundary+ isWSP ' ' = True+ isWSP '\t' = True+ isWSP _ = False++-- Returns the value of the first parameter of the name (must be lower cased)+lookup_param :: String -> [Parameter] -> Maybe String+lookup_param _ [] = Nothing+lookup_param name (Parameter n v:ps)+ | name == n = Just v+ | otherwise = lookup_param name ps++get_header :: Headers -> String -> (String -> Maybe a) -> Maybe a+get_header hs name getter+ = case filter ((name ==) . h_name) hs of+ [h] -> getter (h_body h)+ _ -> Nothing++-- We skip over leading white space lines, both for resilience and+-- because this is allowed for MIME part headers.+parse_headers :: String -> (Headers, Maybe String)+parse_headers msg = skip_whitespace (Just msg)+ where skip_whitespace :: Maybe String -> ([Header], Maybe String)+ skip_whitespace Nothing = ([], Nothing)+ skip_whitespace (Just xs) = case get_line xs of+ ([], m_zs) -> ([], m_zs)+ (ys, m_zs) ->+ case dropWhile isWhite ys of+ [] -> skip_whitespace m_zs+ ys' -> gather [ys'] m_zs+ gather :: [String] -> Maybe String -> ([Header], Maybe String)+ gather acc Nothing = ([mk_rev_header acc], Nothing)+ gather acc (Just xs)+ = case get_line xs of+ ([], m_zs) -> ([mk_rev_header acc], m_zs)+ (ys, m_zs)+ | starts_with_white ys -> gather (ys:acc) m_zs+ | otherwise -> let (hs, m_rest) = gather [ys] m_zs+ in (mk_rev_header acc:hs, m_rest)+ starts_with_white (c:_) = isWhite c+ starts_with_white [] = False+ isWhite ' ' = True+ isWhite '\t' = True+ isWhite _ = False++-- Takes the lines comprising a header (in reverse order) and constructs+-- the corresponding Header+mk_rev_header :: [String] -> Header+mk_rev_header = mk_header . reverse++-- Takes the lines comprising a header and constructs+-- the corresponding Header+mk_header :: [String] -> Header+mk_header xs = let unfolded = concat xs+ (raw_name, body) = case break ends_header unfolded of+ (name, ':':val) -> (name ++ ":", val)+ (name, val) -> (name, val)+ in Header {+ h_raw_header = xs,+ h_raw_name = raw_name,+ h_name = map asciiToLower raw_name,+ h_body = body+ }+ where ends_header ':' = True+ ends_header ' ' = True+ ends_header '\t' = True+ ends_header _ = False+
+ src/Codec/MIME/String/QuotedPrintable.hs view
@@ -0,0 +1,60 @@++-- Defined in RFC 2045.+-- We assume we have US-ASCII characters.+-- We return a string with native '\n' line endings.++module Codec.MIME.String.QuotedPrintable (encode, decode) where++import Codec.MIME.String.Internal.Utils+import Data.Bits+import Data.Char+import Data.List++encode :: [String] -> String+encode = enc 0++-- The Int is the number of characters on this line so far+-- 76 is the maximum we can have no one line, and 3 is the most+-- generated for 1 input char (but we also need space for a trailing+-- '=' for a soft line break).+enc :: Int -> [String] -> String+enc _ [] = ""+enc _ [[]] = ""+enc _ ([]:ls) = '\n':enc 0 ls+enc n ls | n > 72 = '=':'\n':enc 0 ls+enc n ((c:cs):ls)+ | (33 <= o && o <= 126 && o /= 61) ||+ (not (null cs) && (o == 9 || o == 32)) = c:enc (n+1) (cs:ls)+ | otherwise = '=':x1:x2:enc (n+3) (cs:ls)+ where o = ord c+ x1 = toUpper $ intToDigit (o `shiftR` 4)+ x2 = toUpper $ intToDigit (o .&. 0xF)++-- decode is very forgiving, and makes some best guesses+decode :: [String] -> String+decode = dec . intercalate "\n"+ . removeSoftLinebreaks+ . map (dropFromEndWhile is_tab_space)+ where is_tab_space ' ' = True+ is_tab_space '\t' = True+ is_tab_space _ = False+ breakLast "" = ("", "")+ breakLast [x] = ("", [x])+ breakLast (x:xs) = case breakLast xs of+ (ys, zs) -> (x:ys, zs)+ removeSoftLinebreaks [] = []+ removeSoftLinebreaks (x:xs)+ = case breakLast x of+ (x', "=") ->+ case removeSoftLinebreaks xs of+ [] -> [x']+ (y:ys) -> (x' ++ y):ys+ _ -> x:removeSoftLinebreaks xs++dec :: String -> String+dec ('=':c1:c2:cs)+ | isAsciiHexDigit c1 && isAsciiHexDigit c2+ = chr ((digitToInt c1 `shiftL` 4) + digitToInt c2):dec cs+dec (c:cs) = c:dec cs+dec "" = ""+
+ src/Codec/MIME/String/Types.hs view
@@ -0,0 +1,82 @@++module Codec.MIME.String.Types+ (+ ParseM, PartNumber, Headers,+ Header(Header, h_raw_header, h_raw_name, h_name, h_body),+ Message(..), MessageInfo(..), Multipart(Multipart),+ MessageContent(NoContent, Body, Data, Mixed, Alternative,+ Parallel, Digest, RFC822),+ mkData, mkBody,+ digest_content_type, ascii_text_content_type,+ )+ where++import Codec.MIME.String.Date (FullDate)+import Codec.MIME.String.Headers+ (+ ContentType(ContentType), ContentDescription, ContentTransferEncoding,+ Parameter(Parameter), From, To, Subject,+ )+import Codec.MIME.String.Internal.Utils (my_lines)++import Control.Monad.State (State)++type Headers = [Header]+data Header = Header {+ h_raw_header :: [String],+ h_raw_name :: String,+ h_name :: String,+ h_body :: String+ }+ deriving (Show, Read)++data MessageInfo = MessageInfo {+ mi_headers :: Headers,+ mi_from :: Maybe From,+ mi_to :: Maybe To,+ mi_subject :: Maybe Subject,+ mi_date :: Maybe FullDate,+ mi_content_description :: Maybe ContentDescription+ }+ deriving (Show, Read)+data MessageContent = NoContent ContentType+ | Body ContentType FilePath String -- UTF-8 text+ | Data (Maybe ContentTransferEncoding)+ ContentType FilePath String -- 8-bit data+ | Mixed Multipart+ | Alternative Multipart+ | Parallel Multipart+ | Digest Multipart+ | RFC822 String{- unparsed message-} FilePath Message+ deriving (Show, Read)++type ParseM a = State PartNumber a++mkBody :: ContentType -> FilePath -> String -> ParseM MessageContent+mkBody ct fp s = return $ Body ct fp $ unlines $ my_lines s++mkData :: Maybe ContentTransferEncoding -> ContentType -> FilePath+ -> String -> ParseM MessageContent+mkData m_cte ct fp s = return $ Data m_cte ct fp s++data Multipart = Multipart String -- Preamble+ [Message] -- The messages themselves+ String -- Epilogue+ deriving (Show, Read)++type PartNumber = Integer++data Message = Message {+ m_part_number :: PartNumber,+ m_message_info :: MessageInfo,+ m_message_content :: MessageContent+ }+ deriving (Show, Read)++ascii_text_content_type :: ContentType+ascii_text_content_type+ = ContentType "text" "plain" [Parameter "charset" "US-ASCII"]++digest_content_type :: ContentType+digest_content_type = ContentType "message" "rfc822" []+