[Pkg-haskell-commits] [SCM] haskell-testpack branch, master, updated. debian/1.0.2-1-4-gb0d6b36
John Goerzen
jgoerzen at complete.org
Fri Apr 23 14:44:49 UTC 2010
The following commit has been merged in the master branch:
commit f11929cb78a3f21200ca068b8ceab44922a3045f
Author: John Goerzen <jgoerzen at complete.org>
Date: Wed Oct 20 08:15:17 2004 +0100
Added WASHMail 0.3.6 files
Keywords:
(jgoerzen at complete.org--projects/missingh--head--1.0--patch-77)
diff --git a/ChangeLog b/ChangeLog
index eb4a956..1923c74 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -2,6 +2,34 @@
# arch-tag: automatic-ChangeLog--jgoerzen at complete.org--projects/missingh--head--1.0
#
+2004-10-20 02:15:17 GMT John Goerzen <jgoerzen at complete.org> patch-77
+
+ Summary:
+ Added WASHMail 0.3.6 files
+ Revision:
+ missingh--head--1.0--patch-77
+
+
+ new files:
+ libsrc/MissingH/WASHMail/.arch-ids/Email.hs.id
+ libsrc/MissingH/WASHMail/.arch-ids/EmailConfig.hs.id
+ libsrc/MissingH/WASHMail/.arch-ids/HeaderField.hs.id
+ libsrc/MissingH/WASHMail/.arch-ids/LICENSE.id
+ libsrc/MissingH/WASHMail/.arch-ids/MIME.hs.id
+ libsrc/MissingH/WASHMail/.arch-ids/MailParser.hs.id
+ libsrc/MissingH/WASHMail/.arch-ids/Message.hs.id
+ libsrc/MissingH/WASHMail/Email.hs
+ libsrc/MissingH/WASHMail/EmailConfig.hs
+ libsrc/MissingH/WASHMail/HeaderField.hs
+ libsrc/MissingH/WASHMail/LICENSE
+ libsrc/MissingH/WASHMail/MIME.hs
+ libsrc/MissingH/WASHMail/MailParser.hs
+ libsrc/MissingH/WASHMail/Message.hs
+
+ modified files:
+ ChangeLog
+
+
2004-10-20 02:14:47 GMT John Goerzen <jgoerzen at complete.org> patch-76
Summary:
diff --git a/libsrc/MissingH/WASHMail/Email.hs b/libsrc/MissingH/WASHMail/Email.hs
new file mode 100644
index 0000000..9aa6172
--- /dev/null
+++ b/libsrc/MissingH/WASHMail/Email.hs
@@ -0,0 +1,110 @@
+-- © 2001, 2002 Peter Thiemann
+module Email (
+ sendmail, inventMessageId, exitcodeToSYSEXIT,
+ module MIME, module HeaderField) where
+
+-- from standard library
+import IO
+import System
+
+-- from utility
+import Auxiliary
+import Unique
+
+-- from package
+import EmailConfig
+import HeaderField
+import MIME
+
+-- |from sysexit.h
+data SYSEXIT =
+ EX_OK -- 0 /* successful termination */
+ | EX_USAGE -- 64 /* command line usage error */
+ | EX_DATAERR -- 65 /* data format error */
+ | EX_NOINPUT -- 66 /* cannot open input */
+ | EX_NOUSER -- 67 /* addressee unknown */
+ | EX_NOHOST -- 68 /* host name unknown */
+ | EX_UNAVAILABLE -- 69 /* service unavailable */
+ | EX_SOFTWARE -- 70 /* internal software error */
+ | EX_OSERR -- 71 /* system error (e.g., can't fork) */
+ | EX_OSFILE -- 72 /* critical OS file missing */
+ | EX_CANTCREAT -- 73 /* can't create (user) output file */
+ | EX_IOERR -- 74 /* input/output error */
+ | EX_TEMPFAIL -- 75 /* temp failure; user is invited to retry */
+ | EX_PROTOCOL -- 76 /* remote error in protocol */
+ | EX_NOPERM -- 77 /* permission denied */
+ | EX_CONFIG -- 78 /* configuration error */
+ | EX_UNKNOWN Int
+
+exitcodeToSYSEXIT :: ExitCode -> SYSEXIT
+exitcodeToSYSEXIT exitcode =
+ case exitcode of
+ ExitSuccess -> EX_OK
+ ExitFailure 64 -> EX_USAGE
+ ExitFailure 65 -> EX_DATAERR
+ ExitFailure 66 -> EX_NOINPUT
+ ExitFailure 67 -> EX_NOUSER
+ ExitFailure 68 -> EX_NOHOST
+ ExitFailure 69 -> EX_UNAVAILABLE
+ ExitFailure 70 -> EX_SOFTWARE
+ ExitFailure 71 -> EX_OSERR
+ ExitFailure 72 -> EX_OSFILE
+ ExitFailure 73 -> EX_CANTCREAT
+ ExitFailure 74 -> EX_IOERR
+ ExitFailure 75 -> EX_TEMPFAIL
+ ExitFailure 76 -> EX_PROTOCOL
+ ExitFailure 77 -> EX_NOPERM
+ ExitFailure 78 -> EX_CONFIG
+ ExitFailure sc -> EX_UNKNOWN sc
+
+instance Show SYSEXIT where
+ showsPrec i se = case se of
+ EX_OK -> showString "successful termination"
+ EX_USAGE -> showString "command line usage error"
+ EX_DATAERR -> showString "data format error"
+ EX_NOINPUT -> showString "cannot open input"
+ EX_NOUSER -> showString "addressee unknown"
+ EX_NOHOST -> showString "host name unknown"
+ EX_UNAVAILABLE -> showString "service unavailable"
+ EX_SOFTWARE -> showString "internal software error"
+ EX_OSERR -> showString "system error (e.g., can't fork)"
+ EX_OSFILE -> showString "critical OS file missing"
+ EX_CANTCREAT -> showString "can't create (user) output file"
+ EX_IOERR -> showString "input/output error"
+ EX_TEMPFAIL -> showString "temp failure; user is invited to retry"
+ EX_PROTOCOL -> showString "remote error in protocol"
+ EX_NOPERM -> showString "permission denied"
+ EX_CONFIG -> showString "configuration error"
+ EX_UNKNOWN sc -> showString "unknown return code: " . shows sc
+
+-- facilities for sending email
+
+sendmailFlags =
+ ["-i" -- ignore dots alone on a line
+ ,"-t" -- read message for recipients
+ ,"--" -- end of flag arguments
+ ] -- , "-v" for verbose mode
+
+sendmail :: Mail -> IO ExitCode
+sendmail mail =
+ do filename <- inventBoundary
+ let tempfilename = emailTmpDir ++ filename
+ tempfilename2 = emailTmpDir ++ "T" ++ filename
+ h <- openFile tempfilename WriteMode
+ hSend smtpSendControl{ sendH = h } mail
+ hClose h
+ exitcode <- system (sendmailProgram ++ pFlags sendmailFlags ++ " < " ++ tempfilename ++ " > " ++ tempfilename2)
+ system ("rm " ++ tempfilename)
+ system ("rm " ++ tempfilename2)
+ return exitcode
+
+pFlags [] = ""
+pFlags (flag:flags) = ' ' : flag ++ pFlags flags
+
+inventMessageId :: IO Header
+inventMessageId =
+ do randomKey <- inventStdKey
+ hostname <- protectedGetEnv "SERVER_NAME" "localhost"
+ let messageId = "<" ++ randomKey ++ ".Email@" ++ hostname ++ ">"
+ return (Header ("Message-Id", messageId))
+
diff --git a/libsrc/MissingH/WASHMail/EmailConfig.hs b/libsrc/MissingH/WASHMail/EmailConfig.hs
new file mode 100644
index 0000000..da7e3ec
--- /dev/null
+++ b/libsrc/MissingH/WASHMail/EmailConfig.hs
@@ -0,0 +1,13 @@
+module EmailConfig where
+
+tmpDir, varDir, emailTmpDir, sendmailProgram :: String
+
+-- |temporary storage
+tmpDir = "/tmp/"
+-- |persistent, mutable storage
+varDir = "/tmp/"
+
+-- |temporary email files
+emailTmpDir = tmpDir
+-- |path of sendmail program
+sendmailProgram = "/usr/sbin/sendmail"
diff --git a/libsrc/MissingH/WASHMail/HeaderField.hs b/libsrc/MissingH/WASHMail/HeaderField.hs
new file mode 100644
index 0000000..12ffb60
--- /dev/null
+++ b/libsrc/MissingH/WASHMail/HeaderField.hs
@@ -0,0 +1,53 @@
+module HeaderField where
+
+import RFC2047
+
+--
+newtype Header = Header (String, String)
+newtype KV = KV (String, String)
+newtype MediaType = MediaType (String, String)
+--
+
+instance Show Header where
+ show (Header (key, value)) =
+ if null value then "" else
+ key ++ ':' : ' ' : encodeValue value ++ "\r\n"
+
+instance Show KV where
+ show (KV (key, value)) =
+ key ++ '=' : value
+
+instance Show MediaType where
+ show (MediaType (ty, subty)) =
+ ty ++ '/' : subty
+
+--
+
+mimeHeader =
+ Header ("MIME-Version", "1.0")
+
+identHeader =
+ Header ("X-Mailer", "WASH/Mail 0.1")
+
+makeContentType mtype subtype parameters =
+ Header ("Content-Type", mtype ++ "/" ++ subtype ++ p parameters)
+ where p = concat . map p1
+ p1 parameter = ';' : show parameter
+
+makeContentTransferEncoding enc =
+ Header ("Content-Transfer-Encoding", enc)
+
+makeContentDisposition name =
+ Header ("Content-Disposition", name)
+
+makeX what recipients =
+ Header (what, l recipients)
+ where l [] = []
+ l [xs] = xs
+ l (xs:xss) = xs ++ ", " ++ l xss
+
+makeTO = makeX "To"
+makeCC = makeX "Cc"
+makeBCC = makeX "Bcc"
+makeSubject s = makeX "Subject" [s]
+
diff --git a/libsrc/MissingH/WASHMail/LICENSE b/libsrc/MissingH/WASHMail/LICENSE
new file mode 100644
index 0000000..b16110c
--- /dev/null
+++ b/libsrc/MissingH/WASHMail/LICENSE
@@ -0,0 +1,30 @@
+The WASH License
+
+Copyright 2001-2003, Peter Thiemann.
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are
+met:
+
+ 1. Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+ 2. Redistributions in binary form must reproduce the above
+ copyright notice, this list of conditions and the following
+ disclaimer in the documentation and/or other materials provided
+ with the distribution.
+ 3. The name of the author may not be used to endorse or promote
+ products derived from this software without specific prior
+ written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR
+IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
+DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT,
+INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
+(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
+STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING
+IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+POSSIBILITY OF SUCH DAMAGE.
diff --git a/libsrc/MissingH/WASHMail/MIME.hs b/libsrc/MissingH/WASHMail/MIME.hs
new file mode 100644
index 0000000..6d847cd
--- /dev/null
+++ b/libsrc/MissingH/WASHMail/MIME.hs
@@ -0,0 +1,184 @@
+-- © 2001, 2002 Peter Thiemann
+module MIME where
+-- RFC 2045
+-- RFC 2046
+
+import IO
+import Random
+import Char
+
+import qualified Base64
+import qualified QuotedPrintable
+import HeaderField
+import qualified RFC2279 -- UTF-8
+
+
+-- --------------------------------------------------------------------
+
+textDOC subty docLines =
+ DOC { mediatype= "text",
+ subtype= subty,
+ textLines= docLines,
+ parameters= [],
+ filename= "",
+ messageData="",
+ parts=[]
+ }
+
+binaryDOC ty subty bindata =
+ DOC { mediatype= ty,
+ subtype= subty,
+ messageData= bindata,
+ textLines= [],
+ parameters= [],
+ filename= "",
+ parts=[]
+ }
+
+multipartDOC subty subdocs =
+ DOC { mediatype= "multipart",
+ subtype= subty,
+ messageData= "",
+ textLines= [],
+ parameters= [],
+ filename= "",
+ parts= subdocs
+ }
+
+data DOC =
+ DOC {
+ mediatype :: String, -- type
+ subtype :: String, -- subtype
+ parameters :: [KV], -- parameters
+ filename :: String, -- suggested filename
+ -- depending on mediatype only one of the following is relevant:
+ messageData :: String, -- data
+ textLines :: [String], -- lines
+ parts :: [DOC] -- data
+ }
+
+recommend_cte h doc =
+ case mediatype doc of
+ "text" ->
+ case sendMode h of
+ SevenBit -> "quoted-printable"
+ EightBit -> "8bit"
+ "multipart" -> "7bit"
+ _ ->
+ case sendMode h of
+ SevenBit -> "base64"
+ EightBit -> "8bit"
+
+inventBoundary =
+ inventKey 10 (init Base64.alphabet_list)
+ where
+ inventKey len chars =
+ do g <- getStdGen
+ let candidate = take len $ map (chars !!) $ randomRs (0, length chars - 1) g
+ return ("=_" ++ candidate ++ "=_")
+ -- see RFC 2045, 6.7 for reasoning about this choice of boundary string
+
+data SendMode =
+ EightBit | SevenBit
+data SendControl =
+ SendControl {
+ sendH :: Handle,
+ sendMode :: SendMode
+ }
+
+smtpSendControl =
+ SendControl { sendH = stdout, sendMode = SevenBit }
+
+httpSendControl =
+ SendControl { sendH = stdout, sendMode = EightBit }
+
+instance Send DOC where
+ hSend h doc =
+ let cte = recommend_cte h doc in
+ do boundary <- inventBoundary
+ let extraParameter
+ | mediatype doc == "multipart" = [KV ("boundary", '\"':boundary++"\"")]
+ | mediatype doc == "text" = [KV ("charset", "utf-8")]
+ | otherwise = []
+ hSend h (makeContentType (mediatype doc)
+ (subtype doc)
+ (extraParameter ++ parameters doc))
+ hSend h (makeContentTransferEncoding cte)
+ hSend h (makeContentDisposition (filename doc))
+ hSend h CRLF
+ case mediatype doc of
+ "text" -> hSendText h doc
+ "multipart" -> hSendMultipart h boundary doc
+ _ -> hSendBinary h doc
+
+hSendText h doc =
+ case sendMode h of
+ EightBit ->
+ hPutStr hdl str
+ SevenBit ->
+ hPutStr hdl (QuotedPrintable.encode str)
+ where hdl = sendH h
+ str = RFC2279.encode $ flat (textLines doc)
+ flat [] = []
+ flat (xs:xss) = xs ++ "\r\n" ++ flat xss
+
+hSendBinary h doc =
+ case sendMode h of
+ SevenBit ->
+ hPutStr (sendH h) (Base64.encode (messageData doc))
+ EightBit ->
+ hPutStr (sendH h) (messageData doc)
+
+hSendMultipart h boundary doc =
+ do -- may send a preamble for non-MIME-able MUAs at this point
+ sendParts (parts doc)
+ where hdl = sendH h
+ sendParts [] =
+ do hPutStr hdl "--"
+ hPutStr hdl boundary
+ hPutStr hdl "--"
+ hSend h CRLF
+ sendParts (doc:docs) =
+ do hPutStr hdl "--"
+ hPutStr hdl boundary
+ hSend h CRLF
+ hSend h doc
+ sendParts docs
+
+data CRLF = CRLF
+
+instance Send CRLF where
+ hSend h CRLF = hPutStr (sendH h) "\n"
+
+data Mail =
+ Mail {
+ to :: [String],
+ subject :: String,
+ cc :: [String],
+ bcc :: [String],
+ headers :: [Header],
+ contents :: DOC
+ }
+
+simpleMail recipients subj doc =
+ Mail { to= recipients, subject= subj, cc=[], bcc=[], headers=[], contents=doc }
+
+class Send m where
+ send :: m -> IO ()
+ hSend :: SendControl -> m -> IO ()
+ send = hSend smtpSendControl
+
+instance Send Header where
+ hSend h header = hPutStr (sendH h) (show header)
+
+instance Send Mail where
+ hSend h mail =
+ do hSend h (makeTO (to mail))
+ hSend h (makeSubject (subject mail))
+ hSend h (makeCC (cc mail))
+ hSend h (makeBCC (bcc mail))
+ hSend h mimeHeader
+ hSend h identHeader
+ sequence (map (hSend h) (headers mail))
+ hSend h (contents mail)
+
diff --git a/libsrc/MissingH/WASHMail/MailParser.hs b/libsrc/MissingH/WASHMail/MailParser.hs
new file mode 100644
index 0000000..a264b36
--- /dev/null
+++ b/libsrc/MissingH/WASHMail/MailParser.hs
@@ -0,0 +1,359 @@
+module MailParser where
+
+-- see RFC 2822
+-- TODO: check against their definition of token
+import Char
+import List
+import Maybe
+--
+import Parsec
+--
+import qualified Base64
+import qualified QuotedPrintable
+import RFC2047 (p_token)
+import Message
+import HeaderField
+
+parseMessageFromFile fname =
+ parseFromFile message fname
+
+parseMessageFromString str =
+ parse message "MailParser" str
+
+parseDateTimeFromString str =
+ parse parseDateTime "DateTimeParser" (' ':str)
+
+data RawMessage =
+ RawMessage
+ { rawHeaders :: [Header]
+ , rawLines :: [String]
+ }
+ deriving Show
+
+lexeme p = do x <- p; many ws1; return x
+literalString = do char '\"'
+ str <- many (noneOf "\"\\" <|> quoted_pair)
+ char '\"'
+ return str
+
+no_ws_ctl_chars = map chr ([1..8] ++ [11,12] ++ [14..31] ++ [127])
+no_ws_ctl = oneOf no_ws_ctl_chars
+
+text_chars = map chr ([1..9] ++ [11,12] ++ [14..127])
+p_text = oneOf text_chars
+
+quoted_pair = do char '\\'
+ p_text
+
+-- RFC 2045, 5.1 says:
+-- "The type, subtype, and parameter names are not case sensitive."
+
+p_parameter =
+ do lexeme $ char ';'
+ p_name <- lexeme $ p_token
+ lexeme $ char '='
+ p_value <- literalString <|> p_token
+ return (map toLower p_name, p_value)
+
+p_contentType =
+ do many ws1
+ c_type <- p_token
+ lexeme $ char '/'
+ c_subtype <- lexeme $ p_token
+ c_parameters <- many p_parameter
+ return $ ContentType (map toLower c_type) (map toLower c_subtype) c_parameters
+
+-- RFC 2045, 6.1
+-- "these values are not case sensitive"
+
+p_contentTransferEncoding =
+ do many ws1
+ c_cte <- RFC2047.p_token
+ return $ ContentTransferEncoding (map toLower c_cte)
+
+p_contentDisposition =
+ do many ws1
+ c_cd <- RFC2047.p_token
+ c_parameters <- many p_parameter
+ return $ ContentDisposition (map toLower c_cd) c_parameters
+
+p_contentID =
+ do many ws1
+ c_cid <- RFC2047.p_token
+ return $ ContentID c_cid
+
+p_contentDescription =
+ do many ws1
+ c_desc <- many lineChar
+ return $ ContentDescription c_desc
+
+crLf = try (string "\n\r" <|> string "\r\n") <|> string "\n" <|> string "\r"
+
+fws =
+ do many1 ws1
+ option "" (do crLf
+ many1 ws1)
+ <|>
+ do crLf
+ many1 ws1
+
+ws1 = oneOf " \t"
+lineChar = noneOf "\n\r"
+headerNameChar = noneOf "\n\r:"
+
+header = do name <- many1 headerNameChar
+ char ':'
+ line <- do many ws1; lineString
+ crLf
+ extraLines <- many extraHeaderLine
+ return (Header (map toLower name, concat (line:extraLines)))
+
+extraHeaderLine = do sp <- ws1
+ line <- lineString
+ crLf
+ return (sp:line)
+
+lineString = many (noneOf "\n\r")
+
+headerBodySep = do crLf; return ()
+
+body = many (do line <- many lineChar; crLf; return line)
+
+message =
+ do hs <- many header
+ headerBodySep
+ b <- body
+ return (RawMessage hs b)
+
+lookupHeader name msg =
+ lookupInHeaders name (getHeaders msg)
+lookupRawHeader name raw =
+ lookupInHeaders name (rawHeaders raw)
+lookupInHeaders name headers = g headers
+ where g [] = Nothing
+ g (Header (name', text):_) | name == name' = Just text
+ g (_:rest) = g rest
+
+parseHeader raw name deflt parser =
+ fromMaybe deflt $
+ do str <- lookupRawHeader name raw
+ case parse parser name str of
+ Right v -> return v
+ Left _ -> Nothing
+
+digestMessage :: RawMessage -> Message
+digestMessage =
+ digestMessage' (ContentType "text" "plain" [( "charset", "us-ascii")])
+
+digestMessage' :: ContentType -> RawMessage -> Message
+digestMessage' defcty raw =
+ let cty = parseHeader raw
+ "content-type" defcty p_contentType
+ cte = parseHeader raw
+ "content-transfer-encoding" (ContentTransferEncoding "7bit") p_contentTransferEncoding
+ cdn = parseHeader raw
+ "content-disposition" (ContentDisposition "inline" []) p_contentDisposition
+ cid = parseHeader raw
+ "content-id" (ContentID "(none)") p_contentID
+ cdc = parseHeader raw
+ "content-description" (ContentDescription "(none)") p_contentDescription
+ defaultMessage =
+ Singlepart
+ { getHeaders = rawHeaders raw
+ , getLines = rawLines raw
+ , getDecoded = decode cte (unlines (rawLines raw))
+ , getContentType= cty
+ , getContentTransferEncoding= cte
+ , getContentDisposition= cdn
+ }
+ in
+ case cty of
+ ContentType "multipart" c_subtype c_parameters ->
+ case lookup "boundary" c_parameters of
+ Just boundary ->
+ let defcte
+ | c_subtype == "digest" =
+ ContentType "message" "rfc822" []
+ | otherwise =
+ ContentType "text" "plain" [("charset", "us-ascii")] in
+ Multipart
+ { getHeaders = rawHeaders raw
+ , getLines = rawLines raw
+ , getParts = map (digestMessage' defcte)
+ (splitBody boundary (rawLines raw))
+ , getContentType= cty
+ , getContentTransferEncoding= cte
+ , getContentDisposition= cdn
+ }
+ _ ->
+ defaultMessage
+ _ ->
+ defaultMessage
+
+splitBody boundary lines =
+ g False lines (showChar '\n') []
+ where
+ finish shower showers =
+ reverse (map (\shower -> parseSuccessfully message "body part" (shower ""))
+ (shower:showers))
+ g afterPreamble [] shower showers =
+ finish shower showers
+ g afterPreamble (xs : rest) shower showers =
+ if innerboundary `isPrefixOf` xs
+ then if finalboundary `isPrefixOf` xs
+ then if afterPreamble
+ then finish shower showers
+ else finish (showChar '\n') []
+ else if afterPreamble
+ then g afterPreamble rest id (shower : showers)
+ else g True rest (showChar '\n') []
+ else
+ g afterPreamble rest (shower . showString xs . showString "\n") showers
+ innerboundary = '-':'-':boundary
+ finalboundary = innerboundary ++ "--"
+
+decode (ContentTransferEncoding "quoted-printable") rawlines =
+ QuotedPrintable.decode rawlines
+decode (ContentTransferEncoding "base64") rawlines =
+ Base64.decode rawlines
+-- "7bit", "8bit", "binary", and everything else
+decode (ContentTransferEncoding _) rawlines =
+ rawlines
+
+
+parseSuccessfully p n inp =
+ case parse p n inp of
+ Left pError ->
+ error (show pError)
+ Right x ->
+ x
+
+-- |parse contents of Date field according to RFC2822
+data DateTime2822 =
+ DateTime2822 (Maybe DayOfWeek) Date2822 Time2822
+ deriving Show
+parseDateTime =
+ do mdow <- option Nothing (try $ do fws
+ dow <- parseDayOfWeek
+ char ','
+ return (Just dow))
+ date <- parseDate
+ fws
+ time <- parseTime
+ return (DateTime2822 mdow date time)
+
+type DayOfWeek = Int
+parseDayOfWeek =
+ (try (string "Mon") >> return (1 :: DayOfWeek))
+ <|> (try (string "Tue") >> return 2)
+ <|> (try (string "Wed") >> return 3)
+ <|> (try (string "Thu") >> return 4)
+ <|> (try (string "Fri") >> return 5)
+ <|> (try (string "Sat") >> return 6)
+ <|> (try (string "Sun") >> return 7)
+
+data Date2822 =
+ Date2822 Int Int Int
+ deriving Show
+parseDate =
+ do d <- parseDay
+ m <- parseMonth
+ y <- parseYear
+ return (Date2822 d m y)
+
+parseDay =
+ do fws
+ d1 <- digit
+ md2 <- option Nothing (digit >>= (return . Just))
+ case md2 of
+ Nothing ->
+ return (digitToInt d1)
+ Just d2 ->
+ return (digitToInt d2 + 10 * digitToInt d1)
+
+monthList =
+ ["Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"]
+parseMonthName =
+ foldr1 (<|>) (zipWith g monthList [1::Int ..])
+ where
+ g mname mnr = try (string mname) >> return mnr
+
+parseMonth =
+ do fws
+ m <- parseMonthName
+ fws
+ return m
+
+parseYear =
+ do y1 <- digit
+ y2 <- digit
+ my3 <- option Nothing (digit >>= (return . Just))
+ my4 <- option Nothing (digit >>= (return . Just))
+ case (my3, my4) of
+ (Just y3, Just y4) ->
+ return (1000 * digitToInt y1 + 100 * digitToInt y2
+ + 10 * digitToInt y3 + digitToInt y4)
+ -- interpretation of obs-year from RFC2822, 4.3
+ (Just y3, Nothing) ->
+ return (1900 + 100 * digitToInt y1 + 10 * digitToInt y2 + digitToInt y3)
+ (Nothing, Nothing) ->
+ let rawVal = 10 * digitToInt y1 + digitToInt y2 in
+ if rawVal < 50
+ then return (2000 + rawVal)
+ else return (1900 + rawVal)
+ _ ->
+ fail "parseYear"
+data Time2822 =
+ Time2822 TimeOfDay2822 Zone2822
+ deriving Show
+parseTime =
+ do tod <- parseTimeOfDay
+ fws
+ zone <- parseZone
+ return (Time2822 tod zone)
+
+data TimeOfDay2822 =
+ TimeOfDay2822 Int Int Int
+ deriving Show
+parseTimeOfDay =
+ do hh <- parseTwoDigits
+ char ':'
+ mm <- parseTwoDigits
+ ss <- option 0 (try $ do char ':'
+ parseTwoDigits)
+ return (TimeOfDay2822 hh mm ss)
+
+zoneInfoList =
+ [( "UT", (Zone2822 '+' 0 0))
+ ,( "GMT", (Zone2822 '+' 0 0))
+ ,( "EDT", (Zone2822 '-' 4 0))
+ ,( "EST", (Zone2822 '-' 5 0))
+ ,( "CDT", (Zone2822 '-' 5 0))
+ ,( "CST", (Zone2822 '-' 6 0))
+ ,( "MDT", (Zone2822 '-' 6 0))
+ ,( "MST", (Zone2822 '-' 7 0))
+ ,( "PDT", (Zone2822 '-' 7 0))
+ ,( "PST", (Zone2822 '-' 8 0))
+ ]
+
+parseZoneInfo =
+ foldr1 (<|>) (map g zoneInfoList)
+ where
+ g (zname, zinfo) = try (string zname) >> return zinfo
+
+data Zone2822 =
+ Zone2822 Char Int Int
+ deriving Show
+parseZone =
+ do sign <- oneOf "+-"
+ hh <- parseTwoDigits
+ mm <- parseTwoDigits
+ return (Zone2822 sign hh mm)
+ <|> parseZoneInfo
+ -- anything else should be mapped to (Zone2822 '-' 0 0)
+
+parseTwoDigits =
+ do d1 <- digit
+ d2 <- digit
+ return (10 * digitToInt d1 + digitToInt d2)
+
diff --git a/libsrc/MissingH/WASHMail/Message.hs b/libsrc/MissingH/WASHMail/Message.hs
new file mode 100644
index 0000000..08bc371
--- /dev/null
+++ b/libsrc/MissingH/WASHMail/Message.hs
@@ -0,0 +1,78 @@
+module Message where
+
+import HeaderField
+
+data Message =
+ Singlepart
+ { getHeaders :: [Header]
+ , getLines :: [String]
+ , getDecoded :: [Char]
+ , getContentType :: ContentType
+ , getContentTransferEncoding :: ContentTransferEncoding
+ , getContentDisposition :: ContentDisposition
+ }
+ | Multipart
+ { getHeaders :: [Header]
+ , getLines :: [String]
+ , getParts :: [Message]
+ , getContentType :: ContentType
+ , getContentTransferEncoding :: ContentTransferEncoding
+ , getContentDisposition :: ContentDisposition
+ }
+ deriving Show
+
+isSinglePart (Singlepart {}) = True
+isSinglePart _ = False
+
+isMultiPart (Multipart {}) = True
+isMultiPart _ = False
+
+showHeader (Header (n, v)) = n ++ ": " ++ v
+
+showParameters c_parameters =
+ foldr (\(n,v) f -> showString " ;" .
+ showString n .
+ showString "=\"" .
+ showString v .
+ showChar '\"' . f) id c_parameters
+
+data ContentType =
+ ContentType String -- type
+ String -- subtype
+ [(String, String)] -- parameters
+instance Show ContentType where
+ showsPrec i (ContentType c_type c_subtype c_parameters) =
+ showString "Content-Type: " .
+ showString c_type .
+ showChar '/' .
+ showString c_subtype .
+ showParameters c_parameters
+
+data ContentTransferEncoding =
+ ContentTransferEncoding String
+instance Show ContentTransferEncoding where
+ showsPrec i (ContentTransferEncoding cte) =
+ showString "Content-Transfer-Encoding: " .
+ showString cte
+
+data ContentDisposition =
+ ContentDisposition String [(String, String)]
+instance Show ContentDisposition where
+ showsPrec i (ContentDisposition cdn c_parameters) =
+ showString "Content-Disposition: " .
+ showString cdn .
+ showParameters c_parameters
+
+data ContentID =
+ ContentID String
+instance Show ContentID where
+ showsPrec i (ContentID cid) =
+ showString "Content-ID: " .
+ showString cid
+
+data ContentDescription =
+ ContentDescription String
+instance Show ContentDescription where
+ showsPrec i (ContentDescription txt) =
+ showString "Content-Description: " .
+ showString txt
--
haskell-testpack
More information about the Pkg-haskell-commits
mailing list