[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:45:59 UTC 2010
The following commit has been merged in the master branch:
commit 26bca54bb96c4b02159de71b35aadb31c9f4f53d
Author: John Goerzen <jgoerzen at complete.org>
Date: Mon Oct 25 21:20:46 2004 +0100
Merged in upstreams for washngo, hsemail
Keywords:
Patches applied:
* jgoerzen at complete.org--tmp/hsemail--missingh--2004.0--base-0
tag of jgoerzen at complete.org--upstreams/hsemail--head--2004.0--patch-1
* jgoerzen at complete.org--tmp/hsemail--missingh--2004.0--patch-1
Removed files we don't need
* jgoerzen at complete.org--tmp/hsemail--missingh--2004.0--patch-2
Moved files
* jgoerzen at complete.org--tmp/washngo--missingh--2.0--base-0
tag of jgoerzen at complete.org--upstreams/washngo--head--2.0--patch-1
* jgoerzen at complete.org--tmp/washngo--missingh--2.0--patch-1
Removed files
* jgoerzen at complete.org--tmp/washngo--missingh--2.0--patch-2
Removed more files
* jgoerzen at complete.org--upstreams/hsemail--head--2004.0--base-0
Initial import
* jgoerzen at complete.org--upstreams/hsemail--head--2004.0--patch-1
Imported hsemail-2004-10-24
* jgoerzen at complete.org--upstreams/washngo--head--2.0--base-0
Initial setup
* jgoerzen at complete.org--upstreams/washngo--head--2.0--patch-1
Imported WashNGo-2.0.5
(jgoerzen at complete.org--projects/missingh--head--0.5--patch-3)
diff --git a/ChangeLog b/ChangeLog
index 593a395..0c8478d 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -2,6 +2,133 @@
# arch-tag: automatic-ChangeLog--jgoerzen at complete.org--projects/missingh--head--0.5
#
+2004-10-25 15:20:46 GMT John Goerzen <jgoerzen at complete.org> patch-3
+
+ Summary:
+ Merged in upstreams for washngo, hsemail
+ Revision:
+ missingh--head--0.5--patch-3
+
+ Patches applied:
+
+ * jgoerzen at complete.org--tmp/hsemail--missingh--2004.0--base-0
+ tag of jgoerzen at complete.org--upstreams/hsemail--head--2004.0--patch-1
+
+ * jgoerzen at complete.org--tmp/hsemail--missingh--2004.0--patch-1
+ Removed files we don't need
+
+ * jgoerzen at complete.org--tmp/hsemail--missingh--2004.0--patch-2
+ Moved files
+
+ * jgoerzen at complete.org--tmp/washngo--missingh--2.0--base-0
+ tag of jgoerzen at complete.org--upstreams/washngo--head--2.0--patch-1
+
+ * jgoerzen at complete.org--tmp/washngo--missingh--2.0--patch-1
+ Removed files
+
+ * jgoerzen at complete.org--tmp/washngo--missingh--2.0--patch-2
+ Removed more files
+
+ * jgoerzen at complete.org--upstreams/hsemail--head--2004.0--base-0
+ Initial import
+
+ * jgoerzen at complete.org--upstreams/hsemail--head--2004.0--patch-1
+ Imported hsemail-2004-10-24
+
+ * jgoerzen at complete.org--upstreams/washngo--head--2.0--base-0
+ Initial setup
+
+ * jgoerzen at complete.org--upstreams/washngo--head--2.0--patch-1
+ Imported WashNGo-2.0.5
+
+
+ new files:
+ libsrc/MissingH/Hsemail/.arch-ids/=id
+ libsrc/MissingH/Hsemail/.arch-ids/README.id
+ libsrc/MissingH/Hsemail/.arch-ids/Rfc2234.hs.id
+ libsrc/MissingH/Hsemail/.arch-ids/Rfc2821.hs.id
+ libsrc/MissingH/Hsemail/.arch-ids/Rfc2822.hs.id
+ libsrc/MissingH/Hsemail/README
+ libsrc/MissingH/Hsemail/Rfc2234.hs
+ libsrc/MissingH/Hsemail/Rfc2821.hs
+ libsrc/MissingH/Hsemail/Rfc2822.hs
+ libsrc/MissingH/Wash/.arch-ids/=id
+ libsrc/MissingH/Wash/Mail/.arch-ids/=id
+ libsrc/MissingH/Wash/Mail/.arch-ids/Email.hs.id
+ libsrc/MissingH/Wash/Mail/.arch-ids/EmailConfig.hs.id
+ libsrc/MissingH/Wash/Mail/.arch-ids/HeaderField.hs.id
+ libsrc/MissingH/Wash/Mail/.arch-ids/LICENSE.id
+ libsrc/MissingH/Wash/Mail/.arch-ids/MIME.hs.id
+ libsrc/MissingH/Wash/Mail/.arch-ids/MailParser.hs.id
+ libsrc/MissingH/Wash/Mail/.arch-ids/Message.hs.id
+ libsrc/MissingH/Wash/Mail/Email.hs
+ libsrc/MissingH/Wash/Mail/EmailConfig.hs
+ libsrc/MissingH/Wash/Mail/HeaderField.hs
+ libsrc/MissingH/Wash/Mail/LICENSE
+ libsrc/MissingH/Wash/Mail/MIME.hs
+ libsrc/MissingH/Wash/Mail/MailParser.hs
+ libsrc/MissingH/Wash/Mail/Message.hs
+ libsrc/MissingH/Wash/Utility/.arch-ids/=id
+ libsrc/MissingH/Wash/Utility/.arch-ids/Auxiliary.hs.id
+ libsrc/MissingH/Wash/Utility/.arch-ids/Base32.hs.id
+ libsrc/MissingH/Wash/Utility/.arch-ids/Base64.hs.id
+ libsrc/MissingH/Wash/Utility/.arch-ids/FileNames.hs.id
+ libsrc/MissingH/Wash/Utility/.arch-ids/Hex.hs.id
+ libsrc/MissingH/Wash/Utility/.arch-ids/ISO8601.hs.id
+ libsrc/MissingH/Wash/Utility/.arch-ids/IntToString.hs.id
+ libsrc/MissingH/Wash/Utility/.arch-ids/JavaScript.hs.id
+ libsrc/MissingH/Wash/Utility/.arch-ids/LICENSE.id
+ libsrc/MissingH/Wash/Utility/.arch-ids/Locking.hs.id
+ libsrc/MissingH/Wash/Utility/.arch-ids/QuotedPrintable.hs.id
+ libsrc/MissingH/Wash/Utility/.arch-ids/RFC2047.hs.id
+ libsrc/MissingH/Wash/Utility/.arch-ids/RFC2279.hs.id
+ libsrc/MissingH/Wash/Utility/.arch-ids/RFC2397.hs.id
+ libsrc/MissingH/Wash/Utility/.arch-ids/Shell.hs.id
+ libsrc/MissingH/Wash/Utility/.arch-ids/SimpleParser.hs.id
+ libsrc/MissingH/Wash/Utility/.arch-ids/URLCoding.hs.id
+ libsrc/MissingH/Wash/Utility/.arch-ids/Unique.hs.id
+ libsrc/MissingH/Wash/Utility/Auxiliary.hs
+ libsrc/MissingH/Wash/Utility/Base32.hs
+ libsrc/MissingH/Wash/Utility/Base64.hs
+ libsrc/MissingH/Wash/Utility/FileNames.hs
+ libsrc/MissingH/Wash/Utility/Hex.hs
+ libsrc/MissingH/Wash/Utility/ISO8601.hs
+ libsrc/MissingH/Wash/Utility/IntToString.hs
+ libsrc/MissingH/Wash/Utility/JavaScript.hs
+ libsrc/MissingH/Wash/Utility/LICENSE
+ libsrc/MissingH/Wash/Utility/Locking.hs
+ libsrc/MissingH/Wash/Utility/QuotedPrintable.hs
+ libsrc/MissingH/Wash/Utility/RFC2047.hs
+ libsrc/MissingH/Wash/Utility/RFC2279.hs
+ libsrc/MissingH/Wash/Utility/RFC2397.hs
+ libsrc/MissingH/Wash/Utility/Shell.hs
+ libsrc/MissingH/Wash/Utility/SimpleParser.hs
+ libsrc/MissingH/Wash/Utility/URLCoding.hs
+ libsrc/MissingH/Wash/Utility/Unique.hs
+
+ modified files:
+ ChangeLog
+
+ new directories:
+ libsrc/MissingH/Hsemail libsrc/MissingH/Hsemail/.arch-ids
+ libsrc/MissingH/Wash libsrc/MissingH/Wash/.arch-ids
+ libsrc/MissingH/Wash/Mail libsrc/MissingH/Wash/Mail/.arch-ids
+ libsrc/MissingH/Wash/Utility
+ libsrc/MissingH/Wash/Utility/.arch-ids
+
+ new patches:
+ jgoerzen at complete.org--tmp/hsemail--missingh--2004.0--base-0
+ jgoerzen at complete.org--tmp/hsemail--missingh--2004.0--patch-1
+ jgoerzen at complete.org--tmp/hsemail--missingh--2004.0--patch-2
+ jgoerzen at complete.org--tmp/washngo--missingh--2.0--base-0
+ jgoerzen at complete.org--tmp/washngo--missingh--2.0--patch-1
+ jgoerzen at complete.org--tmp/washngo--missingh--2.0--patch-2
+ jgoerzen at complete.org--upstreams/hsemail--head--2004.0--base-0
+ jgoerzen at complete.org--upstreams/hsemail--head--2004.0--patch-1
+ jgoerzen at complete.org--upstreams/washngo--head--2.0--base-0
+ jgoerzen at complete.org--upstreams/washngo--head--2.0--patch-1
+
+
2004-10-25 04:05:12 GMT John Goerzen <jgoerzen at complete.org> patch-2
Summary:
diff --git a/libsrc/MissingH/Hsemail/README b/libsrc/MissingH/Hsemail/README
new file mode 100644
index 0000000..113db15
--- /dev/null
+++ b/libsrc/MissingH/Hsemail/README
@@ -0,0 +1,47 @@
+Parsers for the Internet Message Standard
+=========================================
+
+:Latest Release: hsemail-2004-10-24.tar.gz_
+:Darcs: darcs_ get --partial http://cryp.to/hsemail/
+
+Synopsis
+--------
+
+ This package contains a bunch of Parsec_ combinators for
+ the syntax of Internet messages, such as e-mail, news
+ articles, namely RFC2234, RFC2821, and RFC2822.
+
+ There are two small example programs included in the
+ distribution::
+
+ $ runhugs message-test.hs <message-test.input
+ $ runhugs smtp-test.hs <smtp-test.input
+
+Documentation
+-------------
+
+ `Reference Documentation`_
+ Haddock-generated reference of all exported
+ functions.
+
+Copyleft
+--------
+
+ Copyright (c) 2004 Peter Simons <simons at cryp.to>. All
+ rights reserved. This software is released under the terms
+ of the `GNU General Public License
+ <http://www.gnu.org/licenses/gpl.html>`_.
+
+-----------------------------------------------------------------
+
+`[Homepage] <http://cryp.to/>`_
+
+.. _Parsec: http://www.cs.uu.nl/people/daan/parsec.html
+
+.. _darcs: http://abridgegame.org/darcs/
+
+.. _hsemail-2004-10-24.tar.gz: http://cryp.to/hsemail/hsemail-2004-10-24.tar.gz
+
+.. _Reference Documentation: docs/index.html
+
+.. _test.hs: test.hs
diff --git a/libsrc/MissingH/Hsemail/Rfc2234.hs b/libsrc/MissingH/Hsemail/Rfc2234.hs
new file mode 100644
index 0000000..e9e0579
--- /dev/null
+++ b/libsrc/MissingH/Hsemail/Rfc2234.hs
@@ -0,0 +1,185 @@
+{- |
+ Module : RFC2234
+ Copyright : (c) 2004-10-08 by Peter Simons
+ License : GPL2
+
+ Maintainer : simons at cryp.to
+ Stability : provisional
+ Portability : portable
+
+ This module provides parsers for the grammar defined in RFC2234,
+ \"Augmented BNF for Syntax Specifications: ABNF\",
+ <http://www.faqs.org/rfcs/rfc2234.html>.
+
+ /Please note/:
+
+ * The terminal called @char@ in the RFC is called 'chara' here to
+ avoid conflict with the function of the same name from Parsec.
+-}
+
+module Rfc2234
+ ( -- * Parser Combinators
+ caseChar, caseString, manyN, manyNtoM
+
+ -- * Primitive Parsers
+ , alpha, bit, chara, cr, lf, crlf, ctl
+ , dquote, hexdig, htab, lwsp, octet
+ , sp, vchar, wsp, digit
+
+ -- * Useful additions
+ , quoted_pair, quoted_string
+ )
+ where
+
+import Text.ParserCombinators.Parsec
+import Data.Char ( toUpper, chr, ord )
+import Control.Monad ( liftM2 )
+
+
+----- Parser Combinators ---------------------------------------------
+
+-- |Case-insensitive variant of Parsec's 'char' function.
+
+caseChar :: Char -> CharParser st Char
+caseChar c = satisfy (\x -> toUpper x == toUpper c)
+
+-- |Case-insensitive variant of Parsec's 'string' function.
+
+caseString :: String -> CharParser st ()
+caseString cs = mapM_ caseChar cs <?> cs
+
+-- |Match a parser at least @n@ times.
+
+manyN :: Int -> GenParser a b c -> GenParser a b [c]
+manyN n p
+ | n <= 0 = return []
+ | otherwise = liftM2 (++) (count n p) (many p)
+
+-- |Match a parser at least @n@ times, but no more than @m@ times.
+
+manyNtoM :: Int -> Int -> GenParser a b c -> GenParser a b [c]
+manyNtoM n m p
+ | n < 0 = return []
+ | n > m = return []
+ | n == m = count n p
+ | n == 0 = do foldr (<|>) (return []) (map (\x -> try $ count x p) (reverse [1..m]))
+ | otherwise = liftM2 (++) (count n p) (manyNtoM 0 (m-n) p)
+
+
+----- Primitive Parsers ----------------------------------------------
+
+-- |Match any character of the alphabet.
+
+alpha :: CharParser st Char
+alpha = satisfy (\c -> c `elem` (['A'..'Z'] ++ ['a'..'z']))
+ <?> "alphabetic character"
+
+-- |Match either \"1\" or \"0\".
+
+bit :: CharParser st Char
+bit = oneOf "01" <?> "bit ('0' or '1')"
+
+-- |Match any 7-bit US-ASCII character except for NUL (ASCII value 0, that is).
+
+chara :: CharParser st Char
+chara = satisfy (\c -> (c >= chr 1) && (c <= chr 127))
+ <?> "7-bit character excluding NUL"
+
+-- |Match the carriage return character @\\r at .
+
+cr :: CharParser st Char
+cr = char '\r' <?> "carriage return"
+
+-- |Match returns the linefeed character @\\n at .
+
+lf :: CharParser st Char
+lf = char '\n' <?> "linefeed"
+
+-- |Match the Internet newline @\\r\\n at .
+
+crlf :: CharParser st String
+crlf = do c <- cr
+ l <- lf
+ return [c,l]
+ <?> "carriage return followed by linefeed"
+
+-- |Match any US-ASCII control character. That is
+-- any character with a decimal value in the range of [0..31,127].
+
+ctl :: CharParser st Char
+ctl = satisfy (\c -> ord c `elem` ([0..31] ++ [127]))
+ <?> "control character"
+
+-- |Match the double quote character \"@\"@\".
+
+dquote :: CharParser st Char
+dquote = char (chr 34) <?> "double quote"
+
+-- |Match any character that is valid in a hexadecimal number;
+-- [\'0\'..\'9\'] and [\'A\'..\'F\',\'a\'..\'f\'] that is.
+
+hexdig :: CharParser st Char
+hexdig = hexDigit <?> "hexadecimal digit"
+
+-- |Match the tab (\"@\\t@\") character.
+
+htab :: CharParser st Char
+htab = char '\t' <?> "horizontal tab"
+
+-- |Match \"linear white-space\". That is any number of consecutive
+-- 'wsp', optionally followed by a 'crlf' and (at least) one more
+-- 'wsp'.
+
+lwsp :: CharParser st String
+lwsp = do r <- choice
+ [ many1 wsp
+ , try (liftM2 (++) crlf (many1 wsp))
+ ]
+ rs <- option [] lwsp
+ return (r ++ rs)
+ <?> "linear white-space"
+
+-- |Match /any/ character.
+octet :: CharParser st Char
+octet = anyChar <?> "any 8-bit character"
+
+-- |Match the space.
+
+sp :: CharParser st Char
+sp = char ' ' <?> "space"
+
+-- |Match any printable ASCII character. (The \"v\" stands for
+-- \"visible\".) That is any character in the decimal range of
+-- [33..126].
+
+vchar :: CharParser st Char
+vchar = satisfy (\c -> (c >= chr 33) && (c <= chr 126))
+ <?> "printable character"
+
+-- |Match either 'sp' or 'htab'.
+
+wsp :: CharParser st Char
+wsp = sp <|> htab <?> "white-space"
+
+-- |Match a \"quoted pair\". Any characters (excluding CR and
+-- LF) may be quoted.
+
+quoted_pair :: CharParser st String
+quoted_pair = do char '\\'
+ r <- noneOf "\r\n"
+ return ['\\',r]
+ <?> "quoted pair"
+
+-- |Match a quoted string. The specials \"@\\@\" and
+-- \"@\"@\" must be escaped inside a quoted string; CR and
+-- LF are not allowed at all.
+
+quoted_string :: CharParser st String
+quoted_string = do dquote
+ r <- many qcont
+ dquote
+ return ("\"" ++ concat r ++ "\"")
+ <?> "quoted string"
+ where
+ qtext = noneOf "\\\"\r\n"
+ qcont = (many1 qtext) <|> (quoted_pair)
diff --git a/libsrc/MissingH/Hsemail/Rfc2821.hs b/libsrc/MissingH/Hsemail/Rfc2821.hs
new file mode 100644
index 0000000..c4e3aca
--- /dev/null
+++ b/libsrc/MissingH/Hsemail/Rfc2821.hs
@@ -0,0 +1,520 @@
+{- |
+ Module : Rfc2821
+ Copyright : (c) 2004-10-24 by Peter Simons
+ License : GPL2
+
+ Maintainer : simons at cryp.to
+ Stability : provisional
+ Portability : portable
+
+ This module exports (1) parsers for the grammars
+ described in RFC2821, \"Simple Mail Transfer Protocol\",
+ <http://www.faqs.org/rfcs/rfc2821.html>; and (2) an SMTP
+ server state-machine as, well, suggested in the same
+ document.
+-}
+
+module Rfc2821
+ ( -- * Data Types for SMTP Commands
+ SmtpCmd(..), Mailbox(..), nullPath, postmaster
+
+ -- * Data Types for SMTP Replies
+ , SmtpReply(..), SmtpCode(..), SuccessCode(..)
+ , Category(..), reply
+
+ -- * Command Parsers
+ , SmtpParser, smtpCmd, smtpData, rset, quit
+ , ehlo, mail, rcpt, send, soml, saml, vrfy
+ , expn, help, noop, turn, helo
+
+ -- * Argument Parsers
+ , from_path, to_path, path, mailbox, local_part
+ , domain, a_d_l, at_domain, address_literal
+ , ipv4_literal, ipv4addr, subdomain, dot_string
+ , atom, snum, number, word
+
+ -- * SMTP Server State Machine
+ , SmtpdFSM, SessionState(..), Event(..)
+ , smtpdFSM, handleSmtpCmd
+
+ -- * Utility Functions
+ , fixCRLF
+ )
+ where
+
+import Control.Exception ( assert )
+import Control.Monad.State
+import Text.ParserCombinators.Parsec
+import Text.ParserCombinators.Parsec.Error
+import Data.List ( intersperse )
+import Rfc2234
+
+----- Smtp Parsers ---------------------------------------------------
+
+-- |A parsed SMTP command. You can use 'show' and 'read' to
+-- parse and display this data type, but you'll get nicer
+-- error messages if you use the 'smtpCmd' parser directly.
+
+data SmtpCmd
+ = Helo String
+ | Ehlo String
+ | MailFrom Mailbox -- ^ Might be 'nullPath'.
+ | RcptTo Mailbox -- ^ Might be 'postmaster'.
+ | Data
+ | Rset
+ | Send Mailbox
+ | Soml Mailbox
+ | Saml Mailbox
+ | Vrfy String
+ | Expn String
+ | Help String -- ^ Might be @[]@.
+ | Noop -- ^ Optional argument ignored.
+ | Quit
+ | Turn
+ | WrongArg String ParseError
+ -- ^ When a valid command has been recognized, but the
+ -- argument parser fails, then this type will be
+ -- returned. The 'String' contains the name of the
+ -- command (in all upper-case) and the 'ParseError'
+ -- is, obviously, the error description.
+
+instance Show SmtpCmd where
+ show (Helo str) = "HELO " ++ str
+ show (Ehlo str) = "EHLO " ++ str
+ show (MailFrom mbox) = "MAIL FROM:" ++ show mbox
+ show (RcptTo mbox) = "RCPT TO:" ++ show mbox
+ show (Data) = "DATA"
+ show (Rset) = "RSET"
+ show (Send mbox) = "SEND " ++ show mbox
+ show (Soml mbox) = "SOML " ++ show mbox
+ show (Saml mbox) = "SAML " ++ show mbox
+ show (Vrfy str) = "VRFY " ++ str
+ show (Expn str) = "EXPN " ++ str
+ show (Noop) = "NOOP"
+ show (Quit) = "QUIT"
+ show (Turn) = "TURN"
+ show (Help t)
+ | t == [] = "HELP"
+ | otherwise = "HELP " ++ t
+ show (WrongArg str _) =
+ "Syntax error in argument of " ++ str ++ "."
+
+instance Read SmtpCmd where
+ readsPrec _ = readWrapper smtpCmd
+ readList = error "reading [SmtpCmd] is not supported"
+
+-- |The most generic e-mail address has the form:
+-- @\<[\@route,...:]user\@domain\>@. This type, too,
+-- supports 'show' and 'read'. Note that a \"shown\" address
+-- is /always/ enclosed in angular brackets.
+
+data Mailbox = Mailbox [String] String String
+ deriving (Eq)
+
+instance Show Mailbox where
+ show (Mailbox [] [] []) = "<>"
+ show (Mailbox [] "postmaster" []) = "<postmaster>"
+ show (Mailbox p u d) = let
+ route = concat . (intersperse ",") . (map ((:) '@')) $ p
+ mbox = u ++ "@" ++ d
+ in if null route then "<" ++ mbox ++ ">"
+ else "<" ++ route ++ ":" ++ mbox ++ ">"
+
+instance Read Mailbox where
+ readsPrec _ = readWrapper (path <|> mailbox)
+ readList = error "reading [Mailbox] is not supported"
+
+-- |@nullPath@ @=@ @'Mailbox' [] \"\" \"\" = \"\<\>\"@
+
+nullPath :: Mailbox
+nullPath = Mailbox [] [] []
+
+-- |@postmaster@ @=@ @'Mailbox' [] \"postmaster\" \"\" = \"\<postmaster\>\"@
+
+postmaster :: Mailbox
+postmaster = Mailbox [] "postmaster" []
+
+-- |An SMTP reply is a three-digit return code plus some
+-- waste of bandwidth called \"comments\". This is what the
+-- list of strings is for; one string per line in the reply.
+-- 'show' will append an \"@\\r\\n@\" end-of-line marker to
+-- each entry in that list, so that the resulting string is
+-- ready to be sent back to the peer.
+--
+-- Here is an example:
+--
+-- > *Rfc2821> print $ Reply (Code Success MailSystem 0)
+-- > ["worked", "like", "a charm" ]
+-- > 250-worked
+-- > 250-like
+-- > 250 a charm
+--
+-- You might want to try it with an @[]@ and see what
+-- great standard messages you will get. @:-)@
+--
+-- /TODO:/ Define 'read' for those as well.
+
+data SmtpReply = Reply SmtpCode [String]
+
+data SmtpCode = Code SuccessCode Category Int
+
+data SuccessCode
+ = Unused0
+ | PreliminarySuccess
+ | Success
+ | IntermediateSuccess
+ | TransientFailure
+ | PermanentFailure
+ deriving (Enum, Bounded, Eq, Ord, Show)
+
+data Category
+ = Syntax
+ | Information
+ | Connection
+ | Unspecified3
+ | Unspecified4
+ | MailSystem
+ deriving (Enum, Bounded, Eq, Ord, Show)
+
+instance Show SmtpReply where
+ show (Reply c@(Code suc cat _) []) =
+ let msg = show suc ++ " in category " ++ show cat
+ in
+ show $ Reply c [msg]
+
+ show (Reply code msg) =
+ let prefixCon = show code ++ "-"
+ prefixEnd = show code ++ " "
+ fmt p l = p ++ l ++ "\r\n"
+ (x:xs) = reverse msg
+ msgCon = map (fmt prefixCon) xs
+ msgEnd = fmt prefixEnd x
+ msg' = reverse (msgEnd:msgCon)
+ in
+ concat msg'
+
+instance Show SmtpCode where
+ show (Code suc cat n) =
+ assert (n >= 0 && n <= 9) $
+ (show . fromEnum) suc ++ (show . fromEnum) cat ++ show n
+
+-- |Construct a 'Reply'. Fails 'assert' if invalid numbers
+-- are given.
+
+reply :: Int -> Int -> Int -> [String] -> SmtpReply
+reply suc c n msg =
+ assert (suc >= 0 && suc <= 5) $
+ assert (c >= 0 && c <= 5) $
+ assert (n >= 0 && n <= 9) $
+ Reply (Code (toEnum suc) (toEnum c) n) msg
+
+-- |The SMTP parsers defined here correspond to the commands
+-- specified in RFC2821, so I won't document them
+-- individually.
+
+type SmtpParser st = GenParser Char st SmtpCmd
+
+-- |This parser recognizes any of the SMTP commands defined
+-- below.
+
+smtpCmd :: SmtpParser st
+smtpCmd = choice
+ [ smtpData, rset, noop, quit, turn
+ , helo, mail, rcpt, send, soml, saml
+ , vrfy, expn, help, ehlo
+ ]
+
+-- |The parser name \"data\" was taken.
+smtpData :: SmtpParser st
+rset, quit, turn, helo, ehlo, mail :: SmtpParser st
+rcpt, send, soml, saml, vrfy, expn :: SmtpParser st
+help :: SmtpParser st
+
+-- |May have an optional 'word' argument, but it is ignored.
+noop :: SmtpParser st
+
+smtpData = mkCmd0 "DATA" Data
+rset = mkCmd0 "RSET" Rset
+quit = mkCmd0 "QUIT" Quit
+turn = mkCmd0 "TURN" Turn
+helo = mkCmd1 "HELO" Helo domain
+ehlo = mkCmd1 "EHLO" Ehlo domain
+mail = mkCmd1 "MAIL" MailFrom from_path
+rcpt = mkCmd1 "RCPT" RcptTo to_path
+send = mkCmd1 "SEND" Send from_path
+soml = mkCmd1 "SOML" Soml from_path
+saml = mkCmd1 "SAML" Saml from_path
+vrfy = mkCmd1 "VRFY" Vrfy word
+expn = mkCmd1 "EXPN" Expn word
+
+help = try (mkCmd0 "HELP" (Help [])) <|>
+ mkCmd1 "HELP" Help (option [] word)
+
+noop = try (mkCmd0 "NOOP" Noop) <|>
+ mkCmd1 "NOOP" (\_ -> Noop) (option [] word)
+
+from_path :: CharParser st Mailbox
+from_path = do
+ caseString "from:"
+ (try (string "<>" >> return nullPath) <|> path)
+ <?> "from-path"
+
+to_path :: CharParser st Mailbox
+to_path = do
+ caseString "to:"
+ (try (caseString "<postmaster>" >> return postmaster)
+ <|> path) <?> "to-path"
+
+path :: CharParser st Mailbox
+path = between (char '<') (char '>') (p <?> "path")
+ where
+ p = do
+ r1 <- option [] (a_d_l >>= \r -> char ':' >> return r)
+ (Mailbox _ l d) <- mailbox
+ return (Mailbox r1 l d)
+
+mailbox :: CharParser st Mailbox
+mailbox = p <?> "mailbox"
+ where
+ p = do
+ r1 <- local_part
+ char '@'
+ r2 <- domain
+ return (Mailbox [] r1 r2)
+
+local_part :: CharParser st String
+local_part = (dot_string <|> quoted_string) <?> "local-part"
+
+domain :: CharParser st String
+domain = choice
+ [ tokenList subdomain '.' <?> "domain"
+ , address_literal <?> "address literal"
+ ]
+
+a_d_l :: CharParser st [String]
+a_d_l = sepBy1 at_domain (char ',') <?> "route-list"
+
+at_domain :: CharParser st String
+at_domain = (char '@' >> domain) <?> "at-domain"
+
+-- |/TODO/: Add IPv6 address and general literals
+address_literal :: CharParser st String
+address_literal = ipv4_literal <?> "IPv4 address literal"
+
+ipv4_literal :: CharParser st String
+ipv4_literal = do
+ rs <- between (char '[') (char ']') ipv4addr
+ return ('[': reverse (']': reverse rs))
+
+ipv4addr :: CharParser st String
+ipv4addr = p <?> "IPv4 address literal"
+ where
+ p = do
+ r1 <- snum
+ r2 <- char '.' >> snum
+ r3 <- char '.' >> snum
+ r4 <- char '.' >> snum
+ return (r1 ++ "." ++ r2 ++ "." ++ r3 ++ "." ++ r4)
+
+subdomain :: CharParser st String
+subdomain = p <?> "domain name"
+ where
+ p = do
+ r <- many1 (alpha <|> digit <|> char '-')
+ if (last r == '-')
+ then fail "subdomain must not end with hyphen"
+ else return r
+
+dot_string :: CharParser st String
+dot_string = tokenList atom '.' <?> "dot_string"
+
+atom :: CharParser a String
+atom = many1 atext <?> "atom"
+ where
+ atext = alpha <|> digit <|> oneOf "!#$%&'*+-/=?^_`{|}~"
+
+snum :: CharParser st String
+snum = do
+ r <- manyNtoM 1 3 digit
+ if (read r :: Int) > 255
+ then fail "IP address parts must be 0 <= x <= 255"
+ else return r
+
+number :: CharParser st String
+number = many1 digit
+
+-- |This is a useful addition: The parser accepts an 'atom'
+-- or a 'quoted_string'.
+
+word :: CharParser st String
+word = (atom <|> (quoted_string >>= return . show))
+ <?> "word or quoted-string"
+
+-- |Helper function, which can be used to generate Parser-based
+-- instances for the 'Read' class.
+
+readWrapper :: GenParser tok () a -> [tok] -> [(a, [tok])]
+readWrapper m x = either (const []) (id) (parse m' "" x)
+ where
+ m' = do a <- m;
+ res <- getInput
+ return [(a,res)]
+
+----- Smtp FSM -------------------------------------------------------
+
+data SessionState
+ = Unknown
+ | HaveHelo
+ | HaveMailFrom
+ | HaveRcptTo
+ | HaveData
+ | HaveQuit
+ deriving (Enum, Bounded, Eq, Ord, Show)
+
+data Event
+ = Greeting -- ^ reserved for the user
+ | SayHelo String
+ | SayHeloAgain String
+ | SayEhlo String
+ | SayEhloAgain String
+ | SetMailFrom Mailbox
+ | AddRcptTo Mailbox
+ | StartData
+ | Deliver
+ -- ^ This event is reserved for the user; 'smtpdFSM'
+ -- doesn't trigger @Deliver at .
+ | NeedHeloFirst
+ | NeedMailFromFirst
+ | NeedRcptToFirst
+ | NotImplemened
+ -- ^ 'Turn', 'Send', 'Soml', 'Saml', 'Vrfy', and 'Expn'.
+ | ResetState
+ | SayOK
+ -- ^ In case of 'Noop' or when 'Rset' is used before
+ -- we even have a state.
+ | SeeksHelp String
+ -- ^ The parameter may be @[]@.
+ | Shutdown
+ | SyntaxErrorIn String
+ | Unrecognized String
+ deriving (Eq, Show)
+
+-- |Run like this: @'runState' (smtpdFSM \"noop\") HaveHelo at .
+
+type SmtpdFSM = State SessionState Event
+
+-- |Parse a line of SMTP dialogue and run 'handleSmtpCmd' to
+-- determine the 'Event'. In case of syntax errors,
+-- 'SyntaxErrorIn' or 'Unrecognized' will be triggered.
+-- Inputs must be terminated with 'crlf'. See 'fixCRLF'.
+
+smtpdFSM :: String -> SmtpdFSM
+smtpdFSM str = either
+ (\_ -> return (Unrecognized str))
+ (handleSmtpCmd)
+ (parse smtpCmd "" str)
+
+-- |For those who want to parse the 'SmtpCmd' themselves.
+-- Calling this function in 'HaveQuit' or 'HaveData' will
+-- fail an assertion. If 'assert' is disabled, it will
+-- return respectively 'Shutdown' and 'StartData' again.
+
+handleSmtpCmd :: SmtpCmd -> SmtpdFSM
+handleSmtpCmd cmd = get >>= \st -> match st cmd
+ where
+ match :: SessionState -> SmtpCmd -> SmtpdFSM
+ match HaveQuit _ = assert (False) (event Shutdown)
+ match HaveData _ = assert (False) (trans (HaveData, StartData))
+ match _ (WrongArg c _) = event (SyntaxErrorIn c)
+ match _ Quit = trans (HaveQuit, Shutdown)
+ match _ Noop = event SayOK
+ match _ Turn = event NotImplemened
+
+ match _ (Send _) = event NotImplemened
+ match _ (Soml _) = event NotImplemened
+ match _ (Saml _) = event NotImplemened
+ match _ (Vrfy _) = event NotImplemened
+ match _ (Expn _) = event NotImplemened
+ match _ (Help x) = event (SeeksHelp x)
+
+ match Unknown Rset = event SayOK
+ match HaveHelo Rset = event SayOK
+ match _ Rset = trans (HaveHelo, ResetState)
+
+ match Unknown (Helo x) = trans (HaveHelo, SayHelo x)
+ match _ (Helo x) = trans (HaveHelo, SayHeloAgain x)
+ match Unknown (Ehlo x) = trans (HaveHelo, SayEhlo x)
+ match _ (Ehlo x) = trans (HaveHelo, SayEhloAgain x)
+
+ match Unknown (MailFrom _) = event NeedHeloFirst
+ match _ (MailFrom x) = trans (HaveMailFrom, SetMailFrom x)
+
+ match Unknown (RcptTo _) = event NeedHeloFirst
+ match HaveHelo (RcptTo _) = event NeedMailFromFirst
+ match _ (RcptTo x) = trans (HaveRcptTo, AddRcptTo x)
+
+ match Unknown Data = event NeedHeloFirst
+ match HaveHelo Data = event NeedMailFromFirst
+ match HaveMailFrom Data = event NeedRcptToFirst
+ match HaveRcptTo Data = trans (HaveData, StartData)
+
+
+----- Utility --------------------------------------------------------
+
+-- |Make the string 'crlf' terminated, no matter what.
+-- \'@\\n@\' is expanded, otherwise 'crlf' is appended. Note
+-- that if the strong was incorrectly terminated before, it
+-- still is. So using this is safe, and useful when reading
+-- with 'hGetLine', for example.
+
+fixCRLF :: String -> String
+fixCRLF ('\r' :'\n':[]) = fixCRLF []
+fixCRLF ( x :'\n':[]) = x : fixCRLF []
+fixCRLF ( x : xs ) = x : fixCRLF xs
+fixCRLF [ ] = "\r\n"
+
+----- Not exported ---------------------------------------------------
+
+event :: Event -> SmtpdFSM
+event = return
+
+trans :: (SessionState, Event) -> SmtpdFSM
+trans (st,e) = put st >> event e
+
+-- Construct a parser for a command without arguments.
+-- Expects 'crlf'!
+
+mkCmd0 :: String -> a -> GenParser Char st a
+mkCmd0 str cons = (do
+ try (caseString str)
+ skipMany wsp >> crlf
+ return cons) <?> str
+
+-- Construct a parser for a command with an argument which
+-- the given parser can handle. The parsed result will be
+-- applied to the given type constructor and returned.
+-- Expects 'crlf'!
+
+mkCmd1 :: String -> (a -> SmtpCmd) -> GenParser Char st a
+ -> GenParser Char st SmtpCmd
+mkCmd1 str cons p = do
+ try (caseString str)
+ wsp
+ input <- getInput
+ st <- getState
+ let eol = skipMany wsp >> crlf
+ p' = (between (many wsp) eol p) <?> str
+ r = runParser p' st "" input
+ case r of
+ Left e -> return (WrongArg str e)
+ Right a -> return (cons a)
+
+-- @tokenList p '.'@ will parse a token of the form
+-- \"@p.p@\", or \"@p.p.p@\", and so on. Used in 'domain'
+-- and 'dot_string', for example.
+
+tokenList :: GenParser Char st String -> Char
+ -> GenParser Char st String
+tokenList p c = do
+ xs <- sepBy1 p (char c)
+ return (concat (intersperse [c] xs))
diff --git a/libsrc/MissingH/Hsemail/Rfc2822.hs b/libsrc/MissingH/Hsemail/Rfc2822.hs
new file mode 100644
index 0000000..93c43fa
--- /dev/null
+++ b/libsrc/MissingH/Hsemail/Rfc2822.hs
@@ -0,0 +1,1403 @@
+{- |
+ Module : Rfc2822
+ Copyright : (c) 2004-10-08 by Peter Simons
+ License : GPL2
+
+ Maintainer : simons at cryp.to
+ Stability : provisional
+ Portability : portable
+
+ This module provides parsers for the grammar defined in
+ RFC2822, \"Internet Message Format\",
+ <http://www.faqs.org/rfcs/rfc2822.html>.
+
+ /Please note:/ The module is a mess. I keep it around as
+ a reminder that it needs to be rewritten, mostly.
+ Nevertheless, some parsers -- like 'date_time', for
+ example -- are genuinely useful.
+-}
+
+module Rfc2822 where
+
+import Text.ParserCombinators.Parsec
+import Data.Char ( ord )
+import Data.List ( intersperse )
+import System.Time
+import Rfc2234 hiding ( quoted_pair, quoted_string )
+
+-- * Useful parser combinators
+
+-- |@unfold@ @=@ @between (optional cfws) (optional cfws)@
+
+unfold :: CharParser a b -> CharParser a b
+unfold = between (optional cfws) (optional cfws)
+
+-- |Construct a parser for a message header line from the
+-- header's name and a parser for the body.
+
+header :: String -> CharParser a b -> CharParser a b
+header n p = let nameString = caseString (n ++ ":")
+ in
+ between nameString crlf p <?> (n ++ " header line")
+
+-- |Like 'header', but allows the obsolete white-space rules.
+
+obs_header :: String -> CharParser a b -> CharParser a b
+obs_header n p = let nameString = caseString n >> many wsp >> char ':'
+ in
+ between nameString crlf p <?> ("obsolete " ++ n ++ " header line")
+
+
+-- ** Primitive Tokens (section 3.2.1)
+
+-- |Match any US-ASCII non-whitespace control character.
+
+no_ws_ctl :: CharParser a Char
+no_ws_ctl = satisfy (\c -> ord c `elem` ([1..8] ++ [11,12] ++ [14..31] ++ [127]))
+ <?> "US-ASCII non-whitespace control character"
+
+-- |Match any US-ASCII character except for @\r@, @\n at .
+
+text :: CharParser a Char
+text = satisfy (\c -> ord c `elem` ([1..9] ++ [11,12] ++ [14..127]))
+ <?> "US-ASCII character (excluding CR and LF)"
+
+-- |Match any of the RFC's \"special\" characters: @()\<\>[]:;\@,.\\\"@.
+
+specials :: CharParser a Char
+specials = oneOf "()<>[]:;@,.\\\"" <?> "one of ()<>[]:;@,.\\\""
+
+
+-- ** Quoted characters (section 3.2.2)
+
+-- |Match a \"quoted pair\". All characters matched by 'text' may be
+-- quoted. Note that the parsers returns /both/ characters, the
+-- backslash and the actual content.
+
+quoted_pair :: CharParser a String
+quoted_pair = do { char '\\'; r <- text; return ['\\',r] }
+ <?> "quoted pair"
+
+
+-- ** Folding white space and comments (section 3.2.3)
+
+-- |Match \"folding whitespace\". That is any combination of 'wsp' and
+-- 'crlf' followed by 'wsp'.
+
+fws :: CharParser a String
+fws = do r <- many1 $ choice [ blanks, linebreak]
+ return (concat r)
+ where
+ blanks = many1 wsp
+ linebreak = try $ do { r1 <- crlf; r2 <- blanks; return (r1 ++ r2) }
+
+-- |Match any non-whitespace, non-control character except for \"@(@\",
+-- \"@)@\", and \"@\\@\". This is used to describe the legal content of
+-- 'comment's.
+--
+-- /Note/: This parser accepts 8-bit characters, even though this is
+-- not legal according to the RFC. Unfortunately, 8-bit content in
+-- comments has become fairly common in the real world, so we'll just
+-- accept the fact.
+
+ctext :: CharParser a Char
+ctext = no_ws_ctl <|> satisfy (\c -> ord c `elem` ([33..39] ++ [42..91] ++ [93..126] ++ [128..255]))
+ <?> "any regular character (excluding '(', ')', and '\\')"
+
+-- |Match a \"comments\". That is any combination of 'ctext',
+-- 'quoted_pair's, and 'fws' between brackets. Comments may nest.
+
+comment :: CharParser a String
+comment = do char '('
+ r1 <- many ccontent
+ r2 <- option [] fws
+ char ')'
+ return ("(" ++ concat r1 ++ r2 ++ ")")
+ <?> "comment"
+ where
+ ccontent = try $ do r1 <- option [] fws
+ r2 <- choice [many1 ctext, quoted_pair, comment]
+ return (r1 ++ r2)
+
+-- |Match any combination of 'fws' and 'comments'.
+
+cfws :: CharParser a String
+cfws = do r <- many1 $ choice [ fws, comment ]
+ return (concat r)
+
+-- ** Atom (section 3.2.4)
+
+-- |Match any US-ASCII character except for control characters,
+-- 'specials', or space. 'atom' and 'dot_atom' are made up of this.
+
+atext :: CharParser a Char
+atext = alpha <|> digit <|> oneOf "!#$%&'*+-/=?^_`{|}~"
+ <?> "US-ASCII character (excluding controls, space, and specials)"
+
+-- |Match one or more 'atext' characters and skip any preceeding or
+-- trailing 'cfws'.
+
+atom :: CharParser a String
+atom = unfold (many1 atext <?> "atom")
+
+-- |Match 'dot_atom_text' and skip any preceeding or trailing 'cfws'.
+
+dot_atom :: CharParser a String
+dot_atom = unfold (dot_atom_text <?> "dot atom")
+
+-- |Match two or more 'atext's interspersed by dots.
+
+dot_atom_text :: CharParser a String
+dot_atom_text = do r <- sepBy1 (many1 atext) (char '.')
+ return (concat (intersperse "." r))
+ <?> "dot atom content"
+
+
+-- ** Quoted strings (section 3.2.5)
+
+-- |Match any non-whitespace, non-control US-ASCII character except
+-- for \"@\\@\" and \"@\"@\".
+
+qtext :: CharParser a Char
+qtext = no_ws_ctl <|> satisfy (\c -> ord c `elem` ([33] ++ [35..91] ++ [93..126]))
+ <?> "US-ASCII character (excluding '\\', and '\"')"
+
+-- |Match either 'qtext' or 'quoted_pair'.
+
+qcontent :: CharParser a String
+qcontent = many1 qtext <|> quoted_pair
+ <?> "quoted string content"
+
+-- |Match any number of 'qcontent' between double quotes. Any 'cfws'
+-- preceeding or following the \"atom\" is skipped automatically.
+
+quoted_string :: CharParser a String
+quoted_string = unfold (do dquote
+ r1 <- many (do r1 <- option [] fws
+ r2 <- qcontent
+ return (r1 ++ r2))
+ r2 <- option [] fws
+ dquote
+ return ("\"" ++ concat r1 ++ r2 ++ "\""))
+ <?> "quoted string"
+
+
+-- * Miscellaneous tokens (section 3.2.6)
+
+-- |Match either 'atom' or 'quoted_string'.
+
+word :: CharParser a String
+word = atom <|> quoted_string <?> "word"
+
+-- |Match either one or more 'word's or an 'obs_phrase'.
+
+phrase :: CharParser a [String]
+phrase = {- many1 word <?> "phrase" <|> -} obs_phrase
+
+-- |Match any non-whitespace, non-control US-ASCII character except
+-- for \"@\\@\" and \"@\"@\".
+
+utext :: CharParser a Char
+utext = no_ws_ctl <|> satisfy (\c -> ord c `elem` [33..126])
+ <?> "regular US-ASCII character (excluding '\\', and '\"')"
+
+-- |Match any number of 'utext' tokens.
+--
+-- \"Unstructured text\" is used in free text fields such as 'subject'.
+-- Please note that any comments or whitespace that prefaces or
+-- follows the actual 'utext' is /included/ in the returned string.
+
+unstructured :: CharParser a String
+unstructured = do r1 <- many (do r1 <- option [] fws
+ r2 <- utext
+ return (r1 ++ [r2]))
+ r2 <- option [] fws
+ return (concat r1 ++ r2)
+ <?> "unstructured text"
+
+
+-- * Date and Time Specification (section 3.3)
+
+-- |Parse a date and time specification of the form
+--
+-- > Thu, 19 Dec 2002 20:35:46 +0200
+--
+-- where the weekday specification \"@Thu,@\" is optional. The parser
+-- returns a 'CalendarTime', which is set to the appropriate values.
+-- Note, though, that not all fields of 'CalendarTime' will
+-- necessarily be set correctly! Obviously, when no weekday has been
+-- provided, the parser will set this field to 'Monday' - regardless
+-- of whether the day actually is a monday or not. Similarly, the day
+-- of the year will always be returned as @0 at . The timezone name will
+-- always be empty: @\"\"@.
+--
+-- Nor will the 'date_time' parser perform /any/ consistency checking.
+-- It will accept
+--
+-- > 40 Apr 2002 13:12 +0100
+--
+-- as a perfectly valid date.
+--
+-- In order to get all fields set to meaningful values, and in order
+-- to verify the date's consistency, you will have to feed it into any
+-- of the conversion routines provided in "System.Time", such as
+-- 'toClockTime'. (When doing this, keep in mind that most functions
+-- return /local time/. This will not necessarily be the time you're
+-- expecting.)
+
+date_time :: CharParser a CalendarTime
+date_time = do wd <- option Monday (try (do wd <- day_of_week
+ char ','
+ return wd))
+ (y,m,d) <- date
+ fws
+ (td,z) <- time
+ optional cfws
+ return (CalendarTime y m d (tdHour td) (tdMin td) (tdSec td) 0 wd 0 "" z False)
+ <?> "date/time specification"
+
+-- |This parser will match a 'day_name', optionally wrapped in folding
+-- whitespace, or an 'obs_day_of_week' and return it's 'Day' value.
+
+day_of_week :: CharParser a Day
+day_of_week = try (between (optional fws) (optional fws) day_name <?> "name of a day-of-the-week")
+ <|> obs_day_of_week
+
+-- |This parser will the abbreviated weekday names (\"@Mon@\", \"@Tue@\", ...)
+-- and return the appropriate 'Day' value.
+
+day_name :: CharParser a Day
+day_name = do { caseString "Mon"; return Monday }
+ <|> do { try (caseString "Tue"); return Tuesday }
+ <|> do { caseString "Wed"; return Wednesday }
+ <|> do { caseString "Thu"; return Thursday }
+ <|> do { caseString "Fri"; return Friday }
+ <|> do { try (caseString "Sat"); return Saturday }
+ <|> do { caseString "Sun"; return Sunday }
+ <?> "name of a day-of-the-week"
+
+-- |This parser will match a date of the form \"@dd:mm:yyyy@\" and return
+-- a tripple of the form (Int,Month,Int) - corresponding to
+-- (year,month,day).
+
+date :: CharParser a (Int,Month,Int)
+date = do d <- day
+ m <- month
+ y <- year
+ return (y,m,d)
+ <?> "date specification"
+
+-- |This parser will match a four digit number and return it's integer
+-- value. No range checking is performed.
+
+year :: CharParser a Int
+year = do y <- manyN 4 digit
+ return (read y :: Int)
+ <?> "year"
+
+-- |This parser will match a 'month_name', optionally wrapped in
+-- folding whitespace, or an 'obs_month' and return it's 'Month'
+-- value.
+
+month :: CharParser a Month
+month = try (between (optional fws) (optional fws) month_name <?> "month name")
+ <|> obs_month
+
+
+-- |This parser will the abbreviated month names (\"@Jan@\", \"@Feb@\", ...)
+-- and return the appropriate 'Month' value.
+
+month_name :: CharParser a Month
+month_name = do { try (caseString "Jan"); return January }
+ <|> do { caseString "Feb"; return February }
+ <|> do { try (caseString "Mar"); return March }
+ <|> do { try (caseString "Apr"); return April }
+ <|> do { caseString "May"; return May }
+ <|> do { try (caseString "Jun"); return June }
+ <|> do { caseString "Jul"; return July }
+ <|> do { caseString "Aug"; return August }
+ <|> do { caseString "Sep"; return September }
+ <|> do { caseString "Oct"; return October }
+ <|> do { caseString "Nov"; return November }
+ <|> do { caseString "Dec"; return December }
+ <?> "month name"
+
+-- |Match either an 'obs_day', or a one or two digit number and return it.
+
+day :: CharParser a Int
+day = try (do { optional fws; r <- manyNtoM 1 2 digit; return (read r :: Int) }) <|> obs_day
+ <?> "day"
+
+-- |This parser will match a 'time_of_day' specification followed by a
+-- 'zone'. It returns the tuple (TimeDiff,Int) corresponding to the
+-- return values of either parser.
+
+time :: CharParser a (TimeDiff,Int)
+time = do t <- time_of_day
+ fws
+ z <- zone
+ return (t,z)
+ <?> "time and zone specification"
+
+-- |This parser will match a time-of-day specification of \"@hh:mm@\" or
+-- \"@hh:mm:ss@\" and return the corrsponding time as a 'TimeDiff'.
+
+time_of_day :: CharParser a TimeDiff
+time_of_day = do h <- hour
+ char ':'
+ m <- minute
+ s <- option 0 (do { char ':'; second } )
+ return (TimeDiff 0 0 0 h m s 0)
+ <?> "time specification"
+
+-- |This parser will match a two-digit number and return it's integer
+-- value. No range checking is performed.
+
+hour :: CharParser a Int
+hour = do r <- count 2 digit
+ return (read r :: Int)
+ <?> "hour"
+
+-- |This parser will match a two-digit number and return it's integer
+-- value. No range checking is performed.
+
+minute :: CharParser a Int
+minute = do r <- count 2 digit
+ return (read r :: Int)
+ <?> "minute"
+
+-- |This parser will match a two-digit number and return it's integer
+-- value. No range checking takes place.
+
+second :: CharParser a Int
+second = do r <- count 2 digit
+ return (read r :: Int)
+ <?> "second"
+
+-- |This parser will match a timezone specification of the form
+-- \"@+hhmm@\" or \"@-hhmm@\" and return the zone's offset to UTC in
+-- seconds as an integer. 'obs_zone' is matched as well.
+
+zone :: CharParser a Int
+zone = ( do char '+'
+ h <- hour
+ m <- minute
+ return (((h*60)+m)*60)
+ <|> do char '-'
+ h <- hour
+ m <- minute
+ return (-((h*60)+m)*60)
+ <?> "time zone"
+ )
+ <|> obs_zone
+
+
+-- * Address Specification (section 3.4)
+
+-- |Parse a single 'mailbox' or an address 'group' and return the
+-- address(es).
+
+address :: CharParser a [String]
+address = try (do { r <- mailbox; return [r] }) <|> group
+ <?> "address"
+
+-- |Parse a 'name_addr' or an 'addr_spec' and return the
+-- address.
+
+mailbox :: CharParser a String
+mailbox = try name_addr <|> addr_spec
+ <?> "mailbox"
+
+-- |Parse an 'angle_addr', optionally prefaced with a 'display_name',
+-- and return the address.
+
+name_addr :: CharParser a String
+name_addr = do optional display_name
+ angle_addr
+ <?> "name address"
+
+-- |Parse an 'angle_addr' or an 'obs_angle_addr' and return the address.
+
+angle_addr :: CharParser a String
+angle_addr = try (unfold (do char '<'
+ r <- addr_spec
+ char '>'
+ return r)
+ <?> "angle address"
+ )
+ <|> obs_angle_addr
+
+-- |Parse a \"group\" of addresses. That is a 'display_name', followed
+-- by a colon, optionally followed by a 'mailbox_list', followed by a
+-- semicolon. The found address(es) are returned - what may be none.
+-- Here is an example:
+--
+-- > parse group "" "my group: user1 at example.org, user2 at example.org;"
+--
+-- This input comes out as:
+--
+-- > Right ["user1 at example.org","user2 at example.org"]
+
+group :: CharParser a [String]
+group = do display_name
+ char ':'
+ r <- option [] mailbox_list
+ unfold $ char ';'
+ return r
+ <?> "address group"
+
+-- |Parse and return a 'phrase'.
+
+display_name :: CharParser a [String]
+display_name = phrase <?> "display name"
+
+-- |Parse a list of 'mailbox' addresses, every two addresses being
+-- separated by a comma, and return the list of found address(es).
+
+mailbox_list :: CharParser a [String]
+mailbox_list = sepBy mailbox (char ',') <?> "mailbox list"
+
+-- |Parse a list of 'address' addresses, every two addresses being
+-- separated by a comma, and return the list of found address(es).
+
+address_list :: CharParser a [String]
+address_list = do { r <-sepBy address (char ','); return (concat r) }
+ <?> "address list"
+
+
+-- ** Addr-spec specification (section 3.4.1)
+
+-- |Parse an \"address specification\". That is a 'local_part', followed
+-- by an \"@\@@\" character, followed by a 'domain'. Return the complete
+-- address as 'String', ignoring any whitespace or any comments.
+
+addr_spec :: CharParser a String
+addr_spec = do r1 <- local_part
+ char '@'
+ r2 <- domain
+ return (r1 ++ "@" ++ r2)
+ <?> "address specification"
+
+-- |Parse and return a \"local part\" of an 'addr_spec'. That is either
+-- a 'dot_atom' or a 'quoted_string'.
+
+local_part :: CharParser a String
+local_part = dot_atom <|> quoted_string
+ <?> "address' local part"
+
+-- |Parse and return a \"domain part\" of an 'addr_spec'. That is either
+-- a 'dot_atom' or a 'domain_literal'.
+
+domain :: CharParser a String
+domain = dot_atom <|> domain_literal
+ <?> "address' domain part"
+
+-- |Parse a \"domain literal\". That is a \"@[@\" character, followed by
+-- any amount of 'dcontent', followed by a terminating \"@]@\"
+-- character. The complete string is returned verbatim.
+
+domain_literal :: CharParser a String
+domain_literal = unfold (do char '['
+ r <- many $ do { optional fws; dcontent }
+ optional fws
+ char ']'
+ return ("[" ++ concat r ++ "]"))
+ <?> "domain literal"
+
+-- |Parse and return any characters that are legal in a
+-- 'domain_literal'. That is 'dtext' or a 'quoted_pair'.
+
+dcontent :: CharParser a String
+dcontent = many1 dtext <|> quoted_pair
+ <?> "domain literal content"
+
+-- |Parse and return any ASCII characters except \"@[@\", \"@]@\", and
+-- \"@\\@\".
+
+dtext :: CharParser a Char
+dtext = no_ws_ctl
+ <|> satisfy (\c -> ord c `elem` ([33..90] ++ [94,127]))
+ <?> "character (excluding '[', ']', and '\\')"
+
+
+-- * Overall message syntax (section 3.5)
+
+-- |This data type repesents a parsed Internet Message as defined in
+-- this RFC. It consists of an arbitrary number of header lines,
+-- represented in the 'Field' data type, and a message body, which may
+-- be empty.
+
+data Message
+ = Message [Field] String
+ deriving (Show)
+
+-- |Parse a complete message as defined by this RFC and it broken down
+-- into the separate header fields and the message body. Header lines,
+-- which contain syntax errors, will not cause the parser to abort.
+-- Rather, these headers will appear as 'OptionalField's (which are
+-- unparsed) in the resulting 'Message'. A message must be really,
+-- really badly broken for this parser to fail.
+--
+-- This behaviour was chosen because it is impossible to predict what
+-- the user of this module considers to be a fatal error;
+-- traditionally, parsers are very forgiving when it comes to Internet
+-- messages.
+--
+-- If you want to implement a really strict parser, you'll have to put
+-- the appropriate parser together yourself. You'll find that this is
+-- rather easy to do. Refer to the 'fields' parser for further details.
+
+message :: CharParser a Message
+message = do f <- fields
+ b <- option [] (do crlf
+ b <- body
+ return b)
+ return (Message f b)
+
+-- |This parser will return a message body as specified by this RFC;
+-- that is basically any number of 'text' characters, which may be
+-- divided into separate lines by 'crlf'.
+
+body :: CharParser a String
+body = do r1 <- many (try (do line <- many text
+ eol <- crlf
+ return (line ++ eol)))
+ r2 <- many text
+ return (concat r1 ++ r2)
+
+
+-- * Field definitions (section 3.6)
+
+-- |This data type represents any of the header fields defined in this
+-- RFC. Each of the various instances contains with the return value
+-- of the corresponding parser.
+
+data Field = OptionalField String String
+ | From [String]
+ | Sender String
+ | ReturnPath String
+ | ReplyTo [String]
+ | To [String]
+ | Cc [String]
+ | Bcc [String]
+ | MessageID String
+ | InReplyTo [String]
+ | References [String]
+ | Subject String
+ | Comments String
+ | Keywords [[String]]
+ | Date CalendarTime
+ | ResentDate CalendarTime
+ | ResentFrom [String]
+ | ResentSender String
+ | ResentTo [String]
+ | ResentCc [String]
+ | ResentBcc [String]
+ | ResentMessageID String
+ | ResentReplyTo [String]
+ | Received ([(String,String)], CalendarTime)
+ | ObsReceived [(String,String)]
+ deriving (Show)
+
+-- |This parser will parse an arbitrary number of header fields as
+-- defined in this RFC. For each field, an appropriate 'Field' value
+-- is created, all of them making up the 'Field' list that this parser
+-- returns.
+--
+-- If you look at the implementation of this parser, you will find
+-- that it uses Parsec's 'try' modifier around /all/ of the fields.
+-- The idea behind this is that fields, which contain syntax errors,
+-- fall back to the catch-all 'optional_field'. Thus, this parser will
+-- hardly ever return a syntax error -- what conforms with the idea
+-- that any message that can possibly be accepted /should/ be.
+
+fields :: CharParser a [Field]
+fields = many ( try (do { r <- from; return (From r) })
+ <|> try (do { r <- sender; return (Sender r) })
+ <|> try (do { r <- return_path; return (ReturnPath r) })
+ <|> try (do { r <- reply_to; return (ReplyTo r) })
+ <|> try (do { r <- to; return (To r) })
+ <|> try (do { r <- cc; return (Cc r) })
+ <|> try (do { r <- bcc; return (Bcc r) })
+ <|> try (do { r <- message_id; return (MessageID r) })
+ <|> try (do { r <- in_reply_to; return (InReplyTo r) })
+ <|> try (do { r <- references; return (References r) })
+ <|> try (do { r <- subject; return (Subject r) })
+ <|> try (do { r <- comments; return (Comments r) })
+ <|> try (do { r <- keywords; return (Keywords r) })
+ <|> try (do { r <- orig_date; return (Date r) })
+ <|> try (do { r <- resent_date; return (ResentDate r) })
+ <|> try (do { r <- resent_from; return (ResentFrom r) })
+ <|> try (do { r <- resent_sender; return (ResentSender r) })
+ <|> try (do { r <- resent_to; return (ResentTo r) })
+ <|> try (do { r <- resent_cc; return (ResentCc r) })
+ <|> try (do { r <- resent_bcc; return (ResentBcc r) })
+ <|> try (do { r <- resent_msg_id; return (ResentMessageID r) })
+ <|> try (do { r <- received; return (Received r) })
+ -- catch all
+ <|> (do { (name,cont) <- optional_field; return (OptionalField name cont) })
+ )
+
+
+-- ** The origination date field (section 3.6.1)
+
+-- |Parse a \"@Date:@\" header line and return the date it contains a
+-- 'CalendarTime'.
+
+orig_date :: CharParser a CalendarTime
+orig_date = header "Date" date_time
+
+
+-- ** Originator fields (section 3.6.2)
+
+-- |Parse a \"@From:@\" header line and return the 'mailbox_list'
+-- address(es) contained in it.
+
+from :: CharParser a [String]
+from = header "From" mailbox_list
+
+-- |Parse a \"@Sender:@\" header line and return the 'mailbox' address
+-- contained in it.
+
+sender :: CharParser a String
+sender = header "Sender" mailbox
+
+-- |Parse a \"@Reply-To:@\" header line and return the 'address_list'
+-- address(es) contained in it.
+
+reply_to :: CharParser a [String]
+reply_to = header "Reply-To" address_list
+
+
+-- ** Destination address fields (section 3.6.3)
+
+-- |Parse a \"@To:@\" header line and return the 'address_list'
+-- address(es) contained in it.
+
+to :: CharParser a [String]
+to = header "To" address_list
+
+-- |Parse a \"@Cc:@\" header line and return the 'address_list'
+-- address(es) contained in it.
+
+cc :: CharParser a [String]
+cc = header "Cc" address_list
+
+-- |Parse a \"@Bcc:@\" header line and return the 'address_list'
+-- address(es) contained in it.
+
+bcc :: CharParser a [String]
+bcc = header "Bcc" (try address_list <|> do { optional cfws; return [] })
+
+-- ** Identification fields (section 3.6.4)
+
+-- |Parse a \"@Message-Id:@\" header line and return the 'msg_id'
+-- contained in it.
+
+message_id :: CharParser a String
+message_id = header "Message-ID" msg_id
+
+-- |Parse a \"@In-Reply-To:@\" header line and return the list of
+-- 'msg_id's contained in it.
+
+in_reply_to :: CharParser a [String]
+in_reply_to = header "In-Reply-To" (many1 msg_id)
+
+-- |Parse a \"@References:@\" header line and return the list of
+-- 'msg_id's contained in it.
+
+references :: CharParser a [String]
+references = header "References" (many1 msg_id)
+
+-- |Parse a \"@message ID:@\" and return it. A message ID is almost
+-- identical to an 'angle_addr', but with stricter rules about folding
+-- and whitespace.
+
+msg_id :: CharParser a String
+msg_id = unfold (do char '<'
+ idl <- id_left
+ char '@'
+ idr <- id_right
+ char '>'
+ return ("<" ++ idl ++ "@" ++ idr ++ ">"))
+ <?> "message ID"
+
+-- |Parse a \"left ID\" part of a 'msg_id'. This is almost identical to
+-- the 'local_part' of an e-mail address, but with stricter rules
+-- about folding and whitespace.
+
+id_left :: CharParser a String
+id_left = dot_atom_text <|> no_fold_quote
+ <?> "left part of an message ID"
+
+-- |Parse a \"right ID\" part of a 'msg_id'. This is almost identical to
+-- the 'domain' of an e-mail address, but with stricter rules about
+-- folding and whitespace.
+
+id_right :: CharParser a String
+id_right = dot_atom_text <|> no_fold_literal
+ <?> "right part of an message ID"
+
+-- |Parse one or more occurences of 'qtext' or 'quoted_pair' and
+-- return the concatenated string. This makes up the 'id_left' of a
+-- 'msg_id'.
+
+no_fold_quote :: CharParser a String
+no_fold_quote = do dquote
+ r <- many (many1 qtext <|> quoted_pair)
+ dquote
+ return ("\"" ++ concat r ++ "\"")
+ <?> "non-folding quoted string"
+
+-- |Parse one or more occurences of 'dtext' or 'quoted_pair' and
+-- return the concatenated string. This makes up the 'id_right' of a
+-- 'msg_id'.
+
+no_fold_literal :: CharParser a String
+no_fold_literal = do char '['
+ r <- many (many1 dtext <|> quoted_pair)
+ char ']'
+ return ("\"" ++ concat r ++ "\"")
+ return ("[" ++ concat r ++ "]")
+ <?> "non-folding domain literal"
+
+
+-- ** Informational fields (section 3.6.5)
+
+-- |Parse a \"@Subject:@\" header line and return it's contents verbatim.
+
+subject :: CharParser a String
+subject = header "Subject" unstructured
+
+-- |Parse a \"@Comments:@\" header line and return it's contents verbatim.
+
+comments :: CharParser a String
+comments = header "Comments" unstructured
+
+-- |Parse a \"@Keywords:@\" header line and return the list of 'phrase's
+-- found. Please not that each phrase is again a list of 'atom's, as
+-- returned by the 'phrase' parser.
+
+keywords :: CharParser a [[String]]
+keywords = header "Keywords" (do r1 <- phrase
+ r2 <- many (do char ','
+ r <- phrase
+ return r)
+ return (r1:r2))
+
+
+-- ** Resent fields (section 3.6.6)
+
+-- |Parse a \"@Resent-Date:@\" header line and return the date it
+-- contains as 'CalendarTime'.
+
+resent_date :: CharParser a CalendarTime
+resent_date = header "Resent-Date" date_time
+
+-- |Parse a \"@Resent-From:@\" header line and return the 'mailbox_list'
+-- address(es) contained in it.
+
+resent_from :: CharParser a [String]
+resent_from = header "Resent-From" mailbox_list
+
+
+-- |Parse a \"@Resent-Sender:@\" header line and return the 'mailbox_list'
+-- address(es) contained in it.
+
+resent_sender :: CharParser a String
+resent_sender = header "Resent-Sender" mailbox
+
+
+-- |Parse a \"@Resent-To:@\" header line and return the 'mailbox'
+-- address contained in it.
+
+resent_to :: CharParser a [String]
+resent_to = header "Resent-To" address_list
+
+-- |Parse a \"@Resent-Cc:@\" header line and return the 'address_list'
+-- address(es) contained in it.
+
+resent_cc :: CharParser a [String]
+resent_cc = header "Resent-Cc" address_list
+
+-- |Parse a \"@Resent-Bcc:@\" header line and return the 'address_list'
+-- address(es) contained in it. (This list may be empty.)
+
+resent_bcc :: CharParser a [String]
+resent_bcc = header "Resent-Bcc" ( try address_list
+ <|> do optional cfws
+ return []
+ )
+ <?> "Resent-Bcc: header line"
+
+-- |Parse a \"@Resent-Message-ID:@\" header line and return the 'msg_id'
+-- contained in it.
+
+resent_msg_id :: CharParser a String
+resent_msg_id = header "Resent-Message-ID" msg_id
+
+
+-- ** Trace fields (section 3.6.7)
+
+return_path :: CharParser a String
+return_path = header "Return-Path:" path
+
+path :: CharParser a String
+path = unfold ( do char '<'
+ r <- choice [ try addr_spec, do { cfws; return [] } ]
+ char '>'
+ return ("<" ++ r ++ ">")
+ <|> obs_path
+ )
+ <?> "return path spec"
+
+received :: CharParser a ([(String,String)], CalendarTime)
+received = header "Received" (do r1 <- name_val_list
+ char ';'
+ r2 <- date_time
+ return (r1,r2))
+
+name_val_list :: CharParser a [(String,String)]
+name_val_list = do optional cfws
+ many1 name_val_pair
+ <?> "list of name/value pairs"
+
+name_val_pair :: CharParser a (String,String)
+name_val_pair = do r1 <- item_name
+ cfws
+ r2 <- item_value
+ return (r1,r2)
+ <?> "a name/value pair"
+
+item_name :: CharParser a String
+item_name = do r1 <- alpha
+ r2 <- many $ choice [ char '-', alpha, digit ]
+ return (r1 : r2)
+ <?> "name of a name/value pair"
+
+item_value :: CharParser a String
+item_value = choice [ try (do { r <- many1 angle_addr; return (concat r) })
+ , try addr_spec
+ , try domain
+ , msg_id
+ , try atom
+ ]
+ <?> "value of a name/value pair"
+
+-- ** Optional fields (section 3.6.8)
+
+-- |Parse an arbitrary header field and return a tuple containing the
+-- 'field_name' and 'unstructured' text of the header. The name will
+-- /not/ contain the terminating colon.
+
+optional_field :: CharParser a (String,String)
+optional_field = do n <- field_name
+ char ':'
+ b <- unstructured
+ crlf
+ return (n,b)
+ <?> "optional (unspecified) header line"
+
+-- |Parse and return an arbitrary header field name. That is one or
+-- more 'ftext' characters.
+
+field_name :: CharParser a String
+field_name = many1 ftext <?> "header line name"
+
+-- |Match and return any ASCII character except for control
+-- characters, whitespace, and \"@:@\".
+
+ftext :: CharParser a Char
+ftext = satisfy (\c -> ord c `elem` ([33..57] ++ [59..126]))
+ <?> "character (excluding controls, space, and ':')"
+
+
+-- * Miscellaneous obsolete tokens (section 4.1)
+
+-- |Match the obsolete \"quoted pair\" syntax, which - unlike
+-- 'quoted_pair' - allowed /any/ ASCII character to be specified when
+-- quoted. The parser will return both, the backslash and the actual
+-- character.
+
+obs_qp :: CharParser a String
+obs_qp = do char '\\'
+ c <- satisfy (\c -> ord c `elem` [0..127])
+ return ['\\',c]
+ <?> "any quoted US-ASCII character"
+
+-- |Match the obsolete \"text\" syntax, which - unlike 'text' - allowed
+-- \"carriage returns\" and \"linefeeds\". This is really weird; you
+-- better consult the RFC for details. The parser will return the
+-- complete string, including those special characters.
+
+obs_text :: CharParser a String
+obs_text = do r1 <- many lf
+ r2 <- many cr
+ r3 <- many (do r4 <- obs_char
+ r5 <- many lf
+ r6 <- many cr
+ return (r4 : (r5 ++ r6)))
+ return (r1 ++ r2 ++ concat r3)
+
+-- |Match and return the obsolete \"char\" syntax, which - unlike
+-- 'chara' - did not allow \"carriage return\" and \"linefeed\".
+
+obs_char :: CharParser a Char
+obs_char = satisfy (\c -> ord c `elem` ([0..9] ++ [11,12] ++ [14..127]))
+ <?> "any ASCII character except CR and LF"
+
+-- |Match and return the obsolete \"utext\" syntax, which is identical
+-- to 'obs_text'.
+
+obs_utext :: CharParser a String
+obs_utext = obs_text
+
+-- |Match the obsolete \"phrase\" syntax, which - unlike 'phrase' -
+-- allows dots between tokens.
+
+obs_phrase :: CharParser a [String]
+obs_phrase = do r1 <- word
+ r2 <- many $ choice [ word
+ , string "."
+ , do { cfws; return [] }
+ ]
+ return (r1 : (filter (/=[]) r2))
+
+-- |Match a \"phrase list\" syntax and return the list of 'String's
+-- that make up the phrase. In contrast to a 'phrase', the
+-- 'obs_phrase_list' separates the individual words by commas. This
+-- syntax is - as you will have guessed - obsolete.
+
+obs_phrase_list :: CharParser a [String]
+obs_phrase_list = do r1 <- many1 (do r <- option [] phrase
+ unfold $ char ','
+ return (filter (/=[]) r))
+ r2 <- option [] phrase
+ return (concat r1 ++ r2)
+ <|> phrase
+
+
+-- * Obsolete folding white space (section 4.2)
+
+-- |Parse and return an \"obsolete fws\" token. That is at least one
+-- 'wsp' character, followed by an arbitrary number (including zero)
+-- of 'crlf' followed by at least one more 'wsp' character.
+
+obs_fws :: CharParser a String
+obs_fws = do r1 <- many1 wsp
+ r2 <- many (do r3 <- crlf
+ r4 <- many1 wsp
+ return (r3 ++ r4))
+ return (r1 ++ concat r2)
+
+
+-- * Obsolete Date and Time (section 4.3)
+
+-- |Parse a 'day_name' but allow for the obsolete folding syntax.
+
+obs_day_of_week :: CharParser a Day
+obs_day_of_week = unfold day_name <?> "day-of-the-week name"
+
+-- |Parse a 'year' but allow for a two-digit number (obsolete) and the
+-- obsolete folding syntax.
+
+obs_year :: CharParser a Int
+obs_year = unfold (do r <- manyN 2 digit
+ return (normalize (read r :: Int)))
+ <?> "year"
+ where
+ normalize n
+ | n <= 49 = 2000 + n
+ | n <= 999 = 1900 + n
+ | otherwise = n
+
+-- |Parse a 'month_name' but allow for the obsolete folding syntax.
+
+obs_month :: CharParser a Month
+obs_month = between cfws cfws month_name <?> "month name"
+
+-- |Parse a 'day' but allow for the obsolete folding syntax.
+
+obs_day :: CharParser a Int
+obs_day = unfold day <?> "day"
+
+-- |Parse a 'hour' but allow for the obsolete folding syntax.
+
+obs_hour :: CharParser a Int
+obs_hour = unfold hour <?> "hour"
+
+-- |Parse a 'minute' but allow for the obsolete folding syntax.
+
+obs_minute :: CharParser a Int
+obs_minute = unfold minute <?> "minute"
+
+-- |Parse a 'second' but allow for the obsolete folding syntax.
+
+obs_second :: CharParser a Int
+obs_second = unfold second <?> "second"
+
+-- |Match the obsolete zone names and return the appropriate offset.
+
+obs_zone :: CharParser a Int
+obs_zone = choice [ mkZone "UT" 0
+ , mkZone "GMT" 0
+ , mkZone "EST" (-5)
+ , mkZone "EDT" (-4)
+ , mkZone "CST" (-6)
+ , mkZone "CDT" (-5)
+ , mkZone "MST" (-7)
+ , mkZone "MDT" (-6)
+ , mkZone "PST" (-8)
+ , mkZone "PDT" (-7)
+ , do { r <- oneOf ['A'..'I']; return $ (ord r - 64) * 60*60 } <?> "military zone spec"
+ , do { r <- oneOf ['K'..'M']; return $ (ord r - 65) * 60*60 } <?> "military zone spec"
+ , do { r <- oneOf ['N'..'Y']; return $ -(ord r - 77) * 60*60 } <?> "military zone spec"
+ , do { char 'Z'; return 0 } <?> "military zone spec"
+ ]
+ where mkZone n o = try $ do { string n; return (o*60*60) }
+
+
+-- * Obsolete Addressing (section 4.4)
+
+-- |This parser will match the \"obsolete angle address\" syntax. This
+-- construct used to be known as a \"route address\" in earlier RFCs.
+-- There are two differences between this construct and the
+-- 'angle_addr': For one - as usual -, the obsolete form allows for
+-- more liberal insertion of folding whitespace and comments.
+--
+-- Secondly, and more importantly, angle addresses used to allow the
+-- (optional) specification of a \"route\". The newer version does not.
+-- Such a routing address looks like this:
+--
+-- > <@example1.org, at example2.org:simons at example.org>
+--
+-- The parser will return a tuple that - in case of the above address -
+-- looks like this:
+--
+-- > (["example1.org","example2.org"],"simons at example.org")
+--
+-- The first part contains a list of hosts that constitute the route
+-- part. This list may be empty! The second part of the tuple is the
+-- actual 'addr_spec' address.
+
+obs_angle_addr :: CharParser a String
+obs_angle_addr = unfold (do char '<'
+ _ <- option [] obs_route
+ addr <- addr_spec
+ char '>'
+ return addr) -- TODO: route is lost here.
+ <?> "obsolete angle address"
+
+-- |This parser parses the \"route\" part of 'obs_angle_addr' and
+-- returns the list of 'String's that make up this route. Relies on
+-- 'obs_domain_list' for the actual parsing.
+
+obs_route :: CharParser a [String]
+obs_route = unfold (do { r <- obs_domain_list; char ':'; return r })
+ <?> "route of an obsolete angle address"
+
+-- |This parser parses a list of domain names, each of them prefaced
+-- with an \"at\". Multiple names are separated by a comma. The list of
+-- 'domain's is returned - and may be empty.
+
+obs_domain_list :: CharParser a [String]
+obs_domain_list = do char '@'
+ r1 <- domain
+ r2 <- many (do cfws <|> string ","
+ optional cfws
+ char '@'
+ r <- domain
+ return r)
+ return (r1 : r2)
+ <?> "route of an obsolete angle address"
+
+-- |Parse the obsolete syntax of a 'local_part', which allowed for
+-- more liberal insertion of folding whitespace and comments. The
+-- actual string is returned.
+
+obs_local_part :: CharParser a String
+obs_local_part = do r1 <- word
+ r2 <- many (do string "."
+ r <- word
+ return ('.' : r))
+ return (r1 ++ concat r2)
+ <?> "local part of an address"
+
+-- |Parse the obsolete syntax of a 'domain', which allowed for more
+-- liberal insertion of folding whitespace and comments. The actual
+-- string is returned.
+
+obs_domain :: CharParser a String
+obs_domain = do r1 <- atom
+ r2 <- many (do string "."
+ r <- atom
+ return ('.' : r))
+ return (r1 ++ concat r2)
+ <?> "domain part of an address"
+
+-- |This parser will match the obsolete syntax for a 'mailbox_list'.
+-- This one is quite weird: An 'obs_mbox_list' contains an arbitrary
+-- number of 'mailbox'es - including none -, which are separated by
+-- commas. But you may have multiple consecutive commas without giving
+-- a 'mailbox'. You may also have a valid 'obs_mbox_list' that
+-- contains /no/ 'mailbox' at all. On the other hand, you /must/ have
+-- at least one comma.
+--
+-- So, this input is perfectly valid:
+--
+-- > ","
+--
+-- But this one is - contrary to all intuition - not:
+--
+-- > "simons at example.org"
+--
+-- Strange, isn't it?
+
+obs_mbox_list :: CharParser a [String]
+obs_mbox_list = do r1 <- many1 (try (do r <- option [] mailbox
+ unfold $ char ','
+ return r))
+ r2 <- option [] mailbox
+ return (filter (/=[]) (r1 ++ [r2]))
+ <?> "obsolete syntax for a list of mailboxes"
+
+-- |This parser is identical to 'obs_mbox_list' but parses a list of
+-- 'address'es rather than 'mailbox'es. The main difference is that an
+-- 'address' may contain 'group's. Please note that as of now, the
+-- parser will return a simple list of addresses; the grouping
+-- information is lost.
+
+obs_addr_list :: CharParser a [String]
+obs_addr_list = do r1 <- many1 (try (do r <- option [] address
+ optional cfws
+ char ','
+ optional cfws
+ return (concat r)))
+ r2 <- option [] address
+ return (filter (/=[]) (r1 ++ r2))
+ <?> "obsolete syntax for a list of addresses"
+
+
+-- * Obsolete header fields (section 4.5)
+
+obs_fields :: GenParser Char a [Field]
+obs_fields = many ( try (do { r <- obs_from; return (From r) })
+ <|> try (do { r <- obs_sender; return (Sender r) })
+ <|> try (do { r <- obs_return; return (ReturnPath r) })
+ <|> try (do { r <- obs_reply_to; return (ReplyTo r) })
+ <|> try (do { r <- obs_to; return (To r) })
+ <|> try (do { r <- obs_cc; return (Cc r) })
+ <|> try (do { r <- obs_bcc; return (Bcc r) })
+ <|> try (do { r <- obs_message_id; return (MessageID r) })
+ <|> try (do { r <- obs_in_reply_to; return (InReplyTo r) })
+ <|> try (do { r <- obs_references; return (References r) })
+ <|> try (do { r <- obs_subject; return (Subject r) })
+ <|> try (do { r <- obs_comments; return (Comments r) })
+ <|> try (do { r <- obs_keywords; return (Keywords [r]) })
+ <|> try (do { r <- obs_orig_date; return (Date r) })
+ <|> try (do { r <- obs_resent_date; return (ResentDate r) })
+ <|> try (do { r <- obs_resent_from; return (ResentFrom r) })
+ <|> try (do { r <- obs_resent_send; return (ResentSender r) })
+ <|> try (do { r <- obs_resent_to; return (ResentTo r) })
+ <|> try (do { r <- obs_resent_cc; return (ResentCc r) })
+ <|> try (do { r <- obs_resent_bcc; return (ResentBcc r) })
+ <|> try (do { r <- obs_resent_mid; return (ResentMessageID r) })
+ <|> try (do { r <- obs_resent_rply; return (ResentReplyTo r) })
+ <|> try (do { r <- obs_received; return (ObsReceived r) })
+ -- catch all
+ <|> (do { (name,cont) <- obs_optional; return (OptionalField name cont) })
+ )
+
+
+-- ** Obsolete origination date field (section 4.5.1)
+
+-- |Parse a 'date' header line but allow for the obsolete
+-- folding syntax.
+
+obs_orig_date :: CharParser a CalendarTime
+obs_orig_date = obs_header "Date" date_time
+
+
+-- ** Obsolete originator fields (section 4.5.2)
+
+-- |Parse a 'from' header line but allow for the obsolete
+-- folding syntax.
+
+obs_from :: CharParser a [String]
+obs_from = obs_header "From" mailbox_list
+
+-- |Parse a 'sender' header line but allow for the obsolete
+-- folding syntax.
+
+obs_sender :: CharParser a String
+obs_sender = obs_header "Sender" mailbox
+
+-- |Parse a 'reply_to' header line but allow for the obsolete
+-- folding syntax.
+
+obs_reply_to :: CharParser a [String]
+obs_reply_to = obs_header "Reply-To" mailbox_list
+
+
+-- ** Obsolete destination address fields (section 4.5.3)
+
+-- |Parse a 'to' header line but allow for the obsolete
+-- folding syntax.
+
+obs_to :: CharParser a [String]
+obs_to = obs_header "To" address_list
+
+-- |Parse a 'cc' header line but allow for the obsolete
+-- folding syntax.
+
+obs_cc :: CharParser a [String]
+obs_cc = obs_header "Cc" address_list
+
+-- |Parse a 'bcc' header line but allow for the obsolete
+-- folding syntax.
+
+obs_bcc :: CharParser a [String]
+obs_bcc = header "Bcc" ( try address_list
+ <|> do { optional cfws; return [] }
+ )
+
+
+-- ** Obsolete identification fields (section 4.5.4)
+
+-- |Parse a 'message_id' header line but allow for the obsolete
+-- folding syntax.
+
+obs_message_id :: CharParser a String
+obs_message_id = obs_header "Message-ID" msg_id
+
+-- |Parse an 'in_reply_to' header line but allow for the obsolete
+-- folding and the obsolete phrase syntax.
+
+obs_in_reply_to :: CharParser a [String]
+obs_in_reply_to = obs_header "In-Reply-To" (do r <- many ( do {phrase; return [] }
+ <|> msg_id
+ )
+ return (filter (/=[]) r))
+
+-- |Parse a 'references' header line but allow for the obsolete
+-- folding and the obsolete phrase syntax.
+
+obs_references :: CharParser a [String]
+obs_references = obs_header "References" (do r <- many ( do { phrase; return [] }
+ <|> msg_id
+ )
+ return (filter (/=[]) r))
+
+-- |Parses the \"left part\" of a message ID, but allows the obsolete
+-- syntax, which is identical to a 'local_part'.
+
+obs_id_left :: CharParser a String
+obs_id_left = local_part <?> "left part of an message ID"
+
+-- |Parses the \"right part\" of a message ID, but allows the obsolete
+-- syntax, which is identical to a 'domain'.
+
+obs_id_right :: CharParser a String
+obs_id_right = domain <?> "right part of an message ID"
+
+
+
+-- ** Obsolete informational fields (section 4.5.5)
+
+-- |Parse a 'subject' header line but allow for the obsolete
+-- folding syntax.
+
+obs_subject :: CharParser a String
+obs_subject = obs_header "Subject" unstructured
+
+-- |Parse a 'comments' header line but allow for the obsolete
+-- folding syntax.
+
+obs_comments :: CharParser a String
+obs_comments = obs_header "Comments" unstructured
+
+-- |Parse a 'keywords' header line but allow for the obsolete
+-- folding syntax. Also, this parser accepts 'obs_phrase_list'.
+
+obs_keywords :: CharParser a [String]
+obs_keywords = obs_header "Keywords" obs_phrase_list
+
+
+-- ** Obsolete resent fields (section 4.5.6)
+
+-- |Parse a 'resent_from' header line but allow for the obsolete
+-- folding syntax.
+
+obs_resent_from :: CharParser a [String]
+obs_resent_from = obs_header "Resent-From" mailbox_list
+
+-- |Parse a 'resent_sender' header line but allow for the obsolete
+-- folding syntax.
+
+obs_resent_send :: CharParser a String
+obs_resent_send = obs_header "Resent-Sender" mailbox
+
+-- |Parse a 'resent_date' header line but allow for the obsolete
+-- folding syntax.
+
+obs_resent_date :: CharParser a CalendarTime
+obs_resent_date = obs_header "Resent-Date" date_time
+
+-- |Parse a 'resent_to' header line but allow for the obsolete
+-- folding syntax.
+
+obs_resent_to :: CharParser a [String]
+obs_resent_to = obs_header "Resent-To" mailbox_list
+
+-- |Parse a 'resent_cc' header line but allow for the obsolete
+-- folding syntax.
+
+obs_resent_cc :: CharParser a [String]
+obs_resent_cc = obs_header "Resent-Cc" mailbox_list
+
+-- |Parse a 'resent_bcc' header line but allow for the obsolete
+-- folding syntax.
+
+obs_resent_bcc :: CharParser a [String]
+obs_resent_bcc = obs_header "Bcc" ( try address_list
+ <|> do { optional cfws; return [] }
+ )
+
+-- |Parse a 'resent_msg_id' header line but allow for the obsolete
+-- folding syntax.
+
+obs_resent_mid :: CharParser a String
+obs_resent_mid = obs_header "Resent-Message-ID" msg_id
+
+-- |Parse a 'resent_reply_to' header line but allow for the obsolete
+-- folding syntax.
+
+obs_resent_rply :: CharParser a [String]
+obs_resent_rply = obs_header "Reply-To" address_list
+
+
+-- ** Obsolete trace fields (section 4.5.7)
+
+obs_return :: CharParser a [Char]
+obs_return = obs_header "Return-Path" path
+
+obs_received :: CharParser a [(String, String)]
+obs_received = obs_header "Received" name_val_list
+
+-- |Match 'obs_angle_addr'.
+
+obs_path :: CharParser a String
+obs_path = obs_angle_addr
+
+-- |This parser is identical to 'optional_field' but allows the more
+-- liberal line-folding syntax between the \"field_name\" and the \"field
+-- text\".
+
+obs_optional :: CharParser a (String,String)
+obs_optional = do n <- field_name
+ many wsp
+ char ':'
+ b <- unstructured
+ crlf
+ return (n,b)
+ <?> "optional (unspecified) header line"
diff --git a/libsrc/MissingH/Wash/Mail/Email.hs b/libsrc/MissingH/Wash/Mail/Email.hs
new file mode 100644
index 0000000..4cde469
--- /dev/null
+++ b/libsrc/MissingH/Wash/Mail/Email.hs
@@ -0,0 +1,110 @@
+-- © 2001, 2002 Peter Thiemann
+module Email (
+ sendmail, inventMessageId, exitcodeToSYSEXIT, SYSEXIT(..),
+ 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/Wash/Mail/EmailConfig.hs b/libsrc/MissingH/Wash/Mail/EmailConfig.hs
new file mode 100644
index 0000000..da7e3ec
--- /dev/null
+++ b/libsrc/MissingH/Wash/Mail/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/Wash/Mail/HeaderField.hs b/libsrc/MissingH/Wash/Mail/HeaderField.hs
new file mode 100644
index 0000000..12ffb60
--- /dev/null
+++ b/libsrc/MissingH/Wash/Mail/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/Wash/Mail/LICENSE b/libsrc/MissingH/Wash/Mail/LICENSE
new file mode 100644
index 0000000..b16110c
--- /dev/null
+++ b/libsrc/MissingH/Wash/Mail/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/Wash/Mail/MIME.hs b/libsrc/MissingH/Wash/Mail/MIME.hs
new file mode 100644
index 0000000..6d847cd
--- /dev/null
+++ b/libsrc/MissingH/Wash/Mail/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/Wash/Mail/MailParser.hs b/libsrc/MissingH/Wash/Mail/MailParser.hs
new file mode 100644
index 0000000..a264b36
--- /dev/null
+++ b/libsrc/MissingH/Wash/Mail/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/Wash/Mail/Message.hs b/libsrc/MissingH/Wash/Mail/Message.hs
new file mode 100644
index 0000000..08bc371
--- /dev/null
+++ b/libsrc/MissingH/Wash/Mail/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
diff --git a/libsrc/MissingH/Wash/Utility/Auxiliary.hs b/libsrc/MissingH/Wash/Utility/Auxiliary.hs
new file mode 100644
index 0000000..d6d85c7
--- /dev/null
+++ b/libsrc/MissingH/Wash/Utility/Auxiliary.hs
@@ -0,0 +1,43 @@
+module Auxiliary where
+
+import IO
+import System
+import Directory
+import FileNames
+import qualified Shell
+
+protectedGetEnv :: String -> String -> IO String
+protectedGetEnv var deflt =
+ catch (getEnv var) (const $ return deflt)
+
+readFileNonExistent :: FilePath -> String -> IO String
+readFileNonExistent fileName def =
+ do existent <- doesFileExist fileName
+ if existent then readFile fileName else return def
+
+readFileStrictly :: FilePath -> IO String
+readFileStrictly filePath =
+ do h <- openFile filePath ReadMode
+ contents <- hGetContents h
+ hClose (g contents h)
+ return contents
+ where
+ g [] h = h
+ g (_:rest) h = g rest h
+
+assertDirectoryExists :: FilePath -> IO () -> IO ()
+assertDirectoryExists dirname existsAction =
+ catch (createDirectory dirname)
+ (\ ioe ->
+ if isAlreadyExistsError ioe then existsAction
+ else if isDoesNotExistError ioe then
+ do assertDirectoryExists (dropLastComponent dirname) (return ())
+ assertDirectoryExists dirname existsAction
+ else do hPutStrLn stderr ("assertDirectoryExists " ++ show dirname)
+ ioError ioe)
+
+writeDebugFile :: String -> String -> IO ()
+writeDebugFile filename str =
+ do writeFile filename str
+ system ("chmod 666 " ++ Shell.quote filename)
+ return ()
diff --git a/libsrc/MissingH/Wash/Utility/Base32.hs b/libsrc/MissingH/Wash/Utility/Base32.hs
new file mode 100644
index 0000000..98898ee
--- /dev/null
+++ b/libsrc/MissingH/Wash/Utility/Base32.hs
@@ -0,0 +1,96 @@
+-- Base32 standard:
+-- http://www.ietf.org/rfc/rfc3548.txt
+-- Author: Niklas Deutschmann
+
+module Base32 (encode, decode) where
+
+import Bits
+import Char
+import List
+
+encode :: String -> String
+encode = encBase32
+
+decode :: String -> String
+decode = decBase32
+
+-- Partitions a list into groups of length n.
+makeGroups :: Int -> [a] -> [[a]]
+makeGroups 0 lst = error "makeGroups: Invalid group length"
+makeGroups n [] = []
+makeGroups n lst = take n lst : makeGroups n (drop n lst)
+
+-- Converts an array of characters to a large number, generalized for
+-- characters of any number of bits and any alphabet.
+-- charLength: Number of bits in a character
+-- ordFunc: Function that is used for mapping characters to numbers.
+makeBits charLength ordFunc str = foldr (+) 0 bitValues
+ where
+ bitValues = zipWith (\a b -> intVal a `shiftL` b) (reverse str) [0,charLength..]
+ intVal a = toInteger (ordFunc a)
+
+makeBitsASCII = makeBits 8 ord
+makeBitsBase32 = makeBits 5 b32Ord
+
+-- Converts an array of characters into a m-bit number, where m is
+-- is smallest multiple of n that is greater or equal to the
+-- (length of str) * chrSize.
+-- Extension of "makeBits".
+makeMultipleOfNBits bitFunc charSize n str
+ | len `mod` n == 0 = bitFunc str
+ | otherwise = (bitFunc str) `shiftL` (remBitCount len)
+ where
+ remBitCount m = (0 - (m `mod` n) + n) `mod` n
+ len = length str * charSize;
+
+makeMultipleOfNBitsASCII = makeMultipleOfNBits (makeBits 8 ord) 8
+makeMultipleOfNBitsBase32 = makeMultipleOfNBits (makeBits 5 b32Ord) 5
+
+-- The Base32 alphabet
+-- Int -> Base32 character
+b32Chr n = b32tab !! (fromEnum n)
+ where
+ b32tab = ['A'..'Z'] ++ ['2'..'7']
+
+-- Base32 character -> Int
+b32Ord c
+ | c >= 'A' && c <= 'Z' = ord(c) - 65
+ | c >= '2' && c <= '7' = ord(c) - 24
+ | otherwise = error "b32Ord: No Base character"
+
+-- Encodes one block (1-5 ASCII Characters)
+encBase32Block str
+ | len == 0 = ""
+ | len == 1 = concat (b32Map [5,0]) ++ "======"
+ | len == 2 = concat (b32Map [15,10..0]) ++ "===="
+ | len == 3 = concat (b32Map [20,15..0]) ++ "==="
+ | len == 4 = concat (b32Map [30,25..0]) ++ "="
+ | len == 5 = concat (b32Map [35,30..0])
+ | otherwise = error "encBase32Block: Invalid block length"
+ where
+ b32Map = map (\x -> [b32Chr(bitStr `shiftR` x .&. 31)])
+ bitStr = makeMultipleOfNBitsASCII 5 str
+ len = length str
+
+-- Decodes one block (2,4,5,7 or 8 Base32 character + '=' padding character)
+decBase32Block str
+ | len == 0 = ""
+ | len == 2 = concat . (shiftAndMap [0] 2) . makeBitsBase32 $ code
+ | len == 4 = concat . (shiftAndMap [8,0] 4) . makeBitsBase32 $ code
+ | len == 5 = concat . (shiftAndMap [16,8,0] 1) . makeBitsBase32 $ code
+ | len == 7 = concat . (shiftAndMap [24,16..0] 3) . makeBitsBase32 $ code
+ | len == 8 = concat . (shiftAndMap [32,24..0] 0) . makeBitsBase32 $ code
+ | otherwise = error "decBase32Block: Invalid block length"
+ where
+ shiftAndMap sf n = (asciiMap sf) . (`shiftR` n)
+ asciiMap sf c = map (\x -> [chr . fromEnum $ (c `shiftR` x .&. 255)]) sf
+ len = length code
+ code = filter (/= '=') str
+
+encBase32 :: String -> String
+encBase32 = concat . map encBase32Block . makeGroups 5
+
+decBase32 :: String -> String
+decBase32 = concat . map decBase32Block . makeGroups 8
+
+
diff --git a/libsrc/MissingH/Wash/Utility/Base64.hs b/libsrc/MissingH/Wash/Utility/Base64.hs
new file mode 100644
index 0000000..c55a4f1
--- /dev/null
+++ b/libsrc/MissingH/Wash/Utility/Base64.hs
@@ -0,0 +1,124 @@
+-- © 2002 Peter Thiemann
+-- |Implements RFC 2045 MIME coding.
+module Base64
+ (encode, encode', decode, decode'
+ ,alphabet_list
+ )
+ where
+
+import Array
+import Char
+
+--
+-- |Yields encoded input cropped to lines of less than 76 characters. Directly
+-- usable as email body.
+encode :: String -> String
+encode = encode_base64
+-- |yields continuous stream of bytes.
+encode' :: String -> String
+encode' = encode_base64'
+-- |Directly applicable to email body.
+decode :: String -> String
+decode = decode_base64
+-- |Only applicable to stream of Base64 characters.
+decode' :: String -> String
+decode' = decode_base64'
+-- |Applicable to list of lines.
+decode_lines :: [String] -> String
+decode_lines = decode_base64_lines
+
+-- --------------------------------------------------------------------
+-- |Base64 alphabet in encoding order.
+alphabet_list :: String
+alphabet_list =
+ "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"
+
+encode_base64_alphabet_index =
+ zip [0 .. (63::Int)] alphabet_list
+
+decode_base64_alphabet_index =
+ zip alphabet_list [0 .. (63::Int)]
+
+encode_base64_alphabet =
+ array (0 :: Int, 63 :: Int) encode_base64_alphabet_index
+
+decode_base64_alphabet =
+ array (' ','z') decode_base64_alphabet_index
+
+base64_character =
+ array (chr 0, chr 255) [(c, c `elem` alphabet_list || c == '=') | c <- [chr 0 .. chr 255]]
+
+encode_base64 = linebreak 76 . encode_base64'
+
+linebreak m xs = lb m xs
+ where
+ lb n [] = "\r\n"
+ lb 0 xs = '\r':'\n': lb m xs
+ lb n (x:xs) = x: lb (n-1) xs
+
+encode_base64' [] = []
+
+encode_base64' [ch] =
+ encode_base64_alphabet!b1 :
+ encode_base64_alphabet!b2 :
+ "=="
+ where (b1, b2, _, _) = encode_base64_group (ch, chr 0, chr 0)
+
+encode_base64' [ch1, ch2] =
+ encode_base64_alphabet!b1 :
+ encode_base64_alphabet!b2 :
+ encode_base64_alphabet!b3 :
+ "="
+ where (b1, b2, b3, _) = encode_base64_group (ch1, ch2, chr 0)
+
+encode_base64' (ch1: ch2: ch3: rest) =
+ encode_base64_alphabet!b1 :
+ encode_base64_alphabet!b2 :
+ encode_base64_alphabet!b3 :
+ encode_base64_alphabet!b4 :
+ encode_base64' rest
+ where (b1, b2, b3, b4) = encode_base64_group (ch1, ch2, ch3)
+
+-- 111111 112222 222233 333333
+encode_base64_group (ch1, ch2, ch3) = (b1, b2, b3, b4)
+ where o1 = ord ch1
+ o2 = ord ch2
+ o3 = ord ch3
+ b1 = o1 `div` 4
+ b2 = (o1 `mod` 4) * 16 + o2 `div` 16
+ b3 = (o2 `mod` 16) * 4 + o3 `div` 64
+ b4 = o3 `mod` 64
+
+decode_base64_group (b1, b2, b3, b4) = (ch1, ch2, ch3)
+ where ch1 = chr (b1 * 4 + b2 `div` 16)
+ ch2 = chr (b2 `mod` 16 * 16 + b3 `div` 4)
+ ch3 = chr (b3 `mod` 4 * 64 + b4)
+
+decode_base64' [] = []
+
+decode_base64' [cin1, cin2, '=', '='] = [cout1]
+ where (cout1, _, _) =
+ decode_base64_group (decode_base64_alphabet!cin1
+ ,decode_base64_alphabet!cin2
+ ,0
+ ,0)
+
+decode_base64' [cin1, cin2, cin3, '='] = [cout1, cout2]
+ where (cout1, cout2, _) =
+ decode_base64_group (decode_base64_alphabet!cin1
+ ,decode_base64_alphabet!cin2
+ ,decode_base64_alphabet!cin3
+ ,0)
+
+decode_base64' (cin1: cin2: cin3: cin4: rest) =
+ cout1: cout2: cout3: decode_base64' rest
+ where (cout1, cout2, cout3) =
+ decode_base64_group (decode_base64_alphabet!cin1
+ ,decode_base64_alphabet!cin2
+ ,decode_base64_alphabet!cin3
+ ,decode_base64_alphabet!cin4)
+
+decode_base64 = decode_base64' . filter (base64_character!)
+
+decode_base64_lines = decode_base64' . concat
+
diff --git a/libsrc/MissingH/Wash/Utility/FileNames.hs b/libsrc/MissingH/Wash/Utility/FileNames.hs
new file mode 100644
index 0000000..ea99240
--- /dev/null
+++ b/libsrc/MissingH/Wash/Utility/FileNames.hs
@@ -0,0 +1,47 @@
+module FileNames where
+
+longestSuffix :: (a -> Bool) -> [a] -> [a]
+longestSuffix p xs =
+ let f [] suffix = suffix
+ f (x : xs) suffix = f xs (if p x then xs else suffix)
+ in f xs xs
+
+
+-- |longest suffix of path that does not contain '/'
+filePart :: String -> String
+filePart =
+ longestSuffix (=='/')
+
+-- |longest suffix of path that does not contain '.'
+extName :: String -> String
+extName =
+ longestSuffix (=='.')
+
+-- |longest prefix so that the rest contains '.'; entire string if no '.' present
+baseName :: String -> String
+baseName filename =
+ let f "" = ""
+ f ('.':rest) = g rest rest
+ f (x:rest) = x:f rest
+ g "" lst = ""
+ g ('.':rest) lst = '.':f lst
+ g (x:rest) lst = g rest lst
+ in f filename
+
+-- |splits input at each '/'
+fileToPath :: String -> [String]
+fileToPath filename =
+ let f acc path "" = reverse (reverse acc: path)
+ f acc path ('/':xs) = f "" (reverse acc: path) xs
+ f acc path (x:xs) = f (x:acc) path xs
+ in f "" [] filename
+
+-- |drop the last component of a file path
+dropLastComponent :: String -> String
+dropLastComponent path =
+ let f "" = ""
+ f rpath = g rpath
+ g ('/':rest) = g rest
+ g "" = "/"
+ g rpath = dropWhile (/='/') rpath
+ in reverse (f (reverse path))
diff --git a/libsrc/MissingH/Wash/Utility/Hex.hs b/libsrc/MissingH/Wash/Utility/Hex.hs
new file mode 100644
index 0000000..d1f1609
--- /dev/null
+++ b/libsrc/MissingH/Wash/Utility/Hex.hs
@@ -0,0 +1,49 @@
+-- © 2001, 2003 Peter Thiemann
+module Hex where
+
+import Array
+import Char
+
+hexdigit :: Int -> Char
+hexdigit i = hexdigits ! i
+
+hexdigits' = "0123456789ABCDEF"
+alternative_digits = "abcdef"
+alternative_indices :: [(Int, Char)]
+alternative_indices = zip [10..15] alternative_digits
+hexdigits'_indices :: [(Int, Char)]
+hexdigits'_indices = [(i, hexdigits'!!i) | i <- [0..15]]
+
+hexdigits = array (0, 15) hexdigits'_indices
+
+fromHexdigits =
+ array (chr 0, chr 127)
+ (map (\ (x,y) -> (y, x)) (hexdigits'_indices ++ alternative_indices))
+
+isHexdigitArray =
+ array (chr 0, chr 127)
+ (map (\ c -> (c, isHexdigit c)) [chr 0 .. chr 127])
+ where
+ isHexdigit :: Char -> Bool
+ isHexdigit x =
+ (x >= '0' && x <= '9') ||
+ (x >= 'a' && x <= 'f') ||
+ (x >= 'A' && x <= 'F')
+
+isHexdigit :: Char -> Bool
+isHexdigit x =
+ x <= chr 127 && isHexdigitArray ! x
+
+showHex2 :: Int -> String
+showHex2 ox = showsHex 2 ox ""
+
+showsHex :: Int -> Int -> ShowS
+showsHex 0 x = id
+showsHex i x = let (d,m) = x `divMod` 16 in showsHex (i-1) d . showChar (hexdigits ! m)
+
+hexDigitVal :: Char -> Int
+hexDigitVal x | isHexdigit x = fromHexdigits ! x
+ | otherwise = 0
+
+allDigits = hexdigits' ++ alternative_digits
+
diff --git a/libsrc/MissingH/Wash/Utility/ISO8601.hs b/libsrc/MissingH/Wash/Utility/ISO8601.hs
new file mode 100644
index 0000000..8f4f2c7
--- /dev/null
+++ b/libsrc/MissingH/Wash/Utility/ISO8601.hs
@@ -0,0 +1,758 @@
+-- © 2002 Peter Thiemann
+module ISO8601 where
+
+import Char
+import Monad
+import Time
+
+import IOExts
+
+import IntToString
+import SimpleParser
+
+secondsToString seconds =
+ intToString 20 seconds
+
+isoDateToString isoDate =
+ let seconds = unsafePerformIO $ isoDateToSeconds isoDate
+ in secondsToString seconds
+
+isoDateAndTimeToString isoDateAndTime =
+ let seconds = unsafePerformIO $ isoDateAndTimeToSeconds isoDateAndTime
+ in secondsToString seconds
+
+applyToCalT :: (CalendarTime -> a) -> IO a
+applyToCalT g =
+ do clkT <- getClockTime
+ calT <- toCalendarTime clkT
+ return $ g calT
+
+isoDateAndTimeToSeconds :: ISODateAndTime -> IO Integer
+isoDateAndTimeToSeconds isoDateAndTime =
+ applyToCalT $ toSeconds isoDateAndTime
+
+isoTimeToSeconds :: ISOTime -> IO Integer
+isoTimeToSeconds isoTime =
+ applyToCalT $ toSeconds isoTime
+
+isoDateToSeconds :: ISODate -> IO Integer
+isoDateToSeconds isoDate =
+ applyToCalT $ toSeconds isoDate
+
+class ToSeconds iso where
+ -- |returns number of seconds since reference point
+ toSeconds :: iso -> CalendarTime -> Integer
+ toRawSeconds :: iso -> CalendarTime -> Integer
+ --
+ toRawSeconds = toSeconds
+
+instance ToSeconds ISODateAndTime where
+ toSeconds isoDateAndTime@(ISODateAndTime isoDate isoTime) calT =
+ let rawseconds = toRawSeconds isoDateAndTime calT in
+ case addLeapSeconds leapSeconds rawseconds of
+ NotLeapSecond seconds -> seconds
+ LeapSecond seconds -> seconds + leapSecondCorrection isoTime
+
+ toRawSeconds (ISODateAndTime isoDate isoTime) calT =
+ toRawSeconds isoDate calT + toRawSeconds isoTime calT
+
+-- |problem: 19720630T235960 and 19720701T000000 are both mapped to the same
+-- number, 78796800, and then addLeapSeconds adds one yielding 78796801. While
+-- this is correct for 19720701T000000, 19720630T235960 must be
+-- 78796800. Implemented solution: if the current second specification is 0 and
+-- the time to convert is the leap second, then add 1.
+leapSecondCorrection (ISOTime isoHourSpec isoMinuteSpec isoSecondSpec isoTimeZoneSpec) =
+ case isoSecondSpec of
+ Second ss -> if ss == 0 then 1 else 0
+ NoSecond -> 1
+
+instance ToSeconds ISODate where
+ toSeconds isoDate calT =
+ case addLeapSeconds leapSeconds (toRawSeconds isoDate calT) of
+ NotLeapSecond seconds -> seconds
+ LeapSecond seconds -> seconds + 1 -- we always mean 00:00:00
+
+ toRawSeconds (ISODate isoYearSpec isoDayOfYearSpec) calT =
+ let year = isoYearSpecToYear isoYearSpec calT
+ in
+ secondsPerDay * fromIntegral (yearsToDays year) +
+ isoDaysOfYearToSeconds year isoDayOfYearSpec calT
+
+isoDaysOfYearToSeconds year NoDayOfYear calT =
+ 0
+isoDaysOfYearToSeconds year (MonthDay isoMonthSpec isoDayOfMonthSpec) calT =
+ let month = isoMonthSpecToMonth isoMonthSpec calT
+ dayOfMonth = isoDayOfMonthSpecToDayOfMonth isoDayOfMonthSpec calT
+ in
+ fromIntegral(dayOfMonth - 1 + daysUptoMonth year month) * secondsPerDay
+isoDaysOfYearToSeconds year (DayOfYear ddd) calT =
+ fromIntegral ddd * secondsPerDay
+isoDaysOfYearToSeconds year (WeekAndDay (Week ww) NoDayOfWeek) calT =
+ fromIntegral (7 * (ww - 1)) * secondsPerDay
+isoDaysOfYearToSeconds year (WeekAndDay (Week ww) (DayOfWeek d)) calT =
+ let weekdayOfJan1 = yearsToWeekDay year in
+ fromIntegral (7 * (ww - 1) + d - weekdayOfJan1) * secondsPerDay
+isoDaysOfYearToSeconds year (WeekAndDay ImplicitWeek (DayOfWeek d)) calT =
+ let weekdayOfJan1 = yearsToWeekDay year
+ ww = (ctYDay calT + weekdayOfJan1 + 5) `div` 7
+ in
+ fromIntegral (7 * (ww - 1) + d - weekdayOfJan1) * secondsPerDay
+isoDaysOfYearToSeconds year (WeekAndDay _ _) calT =
+ error "Sorry, this combination of week and day does not make sense!"
+
+isoMonthSpecToMonth ImplicitMonth calT =
+ fromEnum (ctMonth calT) + 1
+isoMonthSpecToMonth (Month mm) calT =
+ mm
+
+isoDayOfMonthSpecToDayOfMonth NoDayOfMonth calT =
+ 1
+isoDayOfMonthSpecToDayOfMonth (DayOfMonth dd) calT =
+ dd
+
+daysUptoMonth year month =
+ let daysPerMonth = [31, 28 + leapDays year, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31] in
+ sum (take (month-1) daysPerMonth)
+
+isoYearSpecToYear ImplicitYear calT =
+ (ctYear calT)
+isoYearSpecToYear (ImplicitCentury yy) calT =
+ (100 * (ctYear calT `div` 100) + yy)
+isoYearSpecToYear (Century cc) calT =
+ (100 * cc)
+isoYearSpecToYear (ImplicitDecade y) calT =
+ (10 * (ctYear calT `div` 10) + y)
+isoYearSpecToYear (Year ccyy) calT =
+ ccyy
+
+leapDays year =
+ if leapYear year then 1 else 0
+
+leapYear year =
+ year `mod` 4 == 0 && (year `mod` 100 /= 0 || year `mod` 400 == 0)
+
+yearsToDays ccyy =
+ let nrOfYears = ccyy - 1970
+ leapYears = [ year | year <- [1970 .. ccyy-1] , leapYear year ]
+ nrOfLeapDays = length leapYears
+ in
+ 365 * nrOfYears + nrOfLeapDays
+
+-- |compute weekday of Jan 1
+yearsToWeekDay ccyy =
+ let nrOfDays = yearsToDays ccyy
+ jan_1_1970 = 4 -- Thursday
+ in 1 + (nrOfDays + 6) `mod` 7
+
+-- |in seconds from epoch; needs to be updated when time leaps again
+leapSeconds :: [Integer]
+leapSeconds =
+ [ -- Leap 1972 Jun 30 23:59:60 + S
+ 00000000000078796800,
+ -- Leap 1972 Dec 31 23:59:60 + S
+ 00000000000094694400 + 1,
+ -- Leap 1973 Dec 31 23:59:60 + S
+ 00000000000126230400 + 2,
+ -- Leap 1974 Dec 31 23:59:60 + S
+ 00000000000157766400 + 3,
+ -- Leap 1975 Dec 31 23:59:60 + S
+ 00000000000189302400 + 4,
+ -- Leap 1976 Dec 31 23:59:60 + S
+ 00000000000220924800 + 5,
+ -- Leap 1977 Dec 31 23:59:60 + S
+ 00000000000252460800 + 6,
+ -- Leap 1978 Dec 31 23:59:60 + S
+ 00000000000283996800 + 7,
+ -- Leap 1979 Dec 31 23:59:60 + S
+ 00000000000315532800 + 8,
+ -- Leap 1981 Jun 30 23:59:60 + S
+ 00000000000362793600 + 9,
+ -- Leap 1982 Jun 30 23:59:60 + S
+ 00000000000394329600 + 10,
+ -- Leap 1983 Jun 30 23:59:60 + S
+ 00000000000425865600 + 11,
+ -- Leap 1985 Jun 30 23:59:60 + S
+ 00000000000489024000 + 12,
+ -- Leap 1987 Dec 31 23:59:60 + S
+ 00000000000567993600 + 13,
+ -- Leap 1989 Dec 31 23:59:60 + S
+ 00000000000631152000 + 14,
+ -- Leap 1990 Dec 31 23:59:60 + S
+ 00000000000662688000 + 15,
+ -- Leap 1992 Jun 30 23:59:60 + S
+ 00000000000709948800 + 16,
+ -- Leap 1993 Jun 30 23:59:60 + S
+ 00000000000741484800 + 17,
+ -- Leap 1994 Jun 30 23:59:60 + S
+ 00000000000773020800 + 18,
+ -- Leap 1995 Dec 31 23:59:60 + S
+ 00000000000820454400 + 19,
+ -- Leap 1997 Jun 30 23:59:60 + S
+ 00000000000867715200 + 20,
+ -- Leap 1998 Dec 31 23:59:60 + S
+ 00000000000915148800 + 21
+ ]
+
+data LeapSeconds = LeapSecond Integer | NotLeapSecond Integer
+ deriving Show
+
+addLeapSeconds [] seconds = NotLeapSecond seconds
+addLeapSeconds (ls: rest) seconds =
+ if ls > seconds then NotLeapSecond seconds else
+ if ls == seconds then LeapSecond seconds else
+ addLeapSeconds rest (seconds+1)
+
+secondsPerMinute = 60
+secondsPerHour = 60 * secondsPerMinute
+secondsPerDay = 24 * secondsPerHour
+secondsPerYear = 365 * secondsPerDay
+
+instance ToSeconds ISOTime where
+ -- seconds to 0:00 UTC
+ -- may become negative to indicate previous day!
+ toSeconds (ISOTime isoHourSpec isoMinuteSpec isoSecondSpec isoTimeZoneSpec) calT =
+ toSeconds isoHourSpec calT +
+ toSeconds isoMinuteSpec calT +
+ toSeconds isoSecondSpec calT +
+ toSeconds isoTimeZoneSpec calT
+
+instance ToSeconds ISOHourSpec where
+ toSeconds ImplicitHour calT = fromIntegral (3600 * ctHour calT - ctTZ calT)
+ toSeconds (Hour hh) calT = fromIntegral (3600 * hh - ctTZ calT)
+
+instance ToSeconds ISOMinuteSpec where
+ toSeconds ImplicitMinute calT = fromIntegral (60 * ctMin calT)
+ toSeconds (Minute mm) calT = fromIntegral (60 * mm)
+ toSeconds NoMinute calT = 0
+
+instance ToSeconds ISOSecondSpec where
+ toSeconds (Second ss) calT = fromIntegral ss
+ toSeconds NoSecond calT = 0
+
+instance ToSeconds ISOTimeZoneSpec where
+ toSeconds LocalTime calT = 0
+ toSeconds UTCTime calT = fromIntegral (ctTZ calT)
+ toSeconds (PlusTime (Hour hh) isoMinuteSpec) calT =
+ fromIntegral (ctTZ calT - (3600 * hh + 60 * minutes isoMinuteSpec))
+ toSeconds (MinusTime (Hour hh) isoMinuteSpec) calT =
+ fromIntegral (ctTZ calT + (3600 * hh + 60 * minutes isoMinuteSpec))
+
+minutes ImplicitMinute = 0
+minutes (Minute mm) = mm
+minutes NoMinute = 0
+
+isoDateToClockTime :: ISODate -> ClockTime
+isoDateToClockTime isoDate =
+ let seconds = unsafePerformIO $ isoDateToSeconds isoDate
+ in secondsToClockTime seconds
+
+isoDateAndTimeToClockTime :: ISODateAndTime -> ClockTime
+isoDateAndTimeToClockTime isoDateAndTime =
+ let seconds = unsafePerformIO $ isoDateAndTimeToSeconds isoDateAndTime
+ in secondsToClockTime seconds
+
+secondsToClockTime seconds =
+ let tdiff = TimeDiff { tdYear =0,
+ tdMonth =0,
+ tdDay =0,
+ tdHour =0,
+ tdMin =0,
+ tdSec = fromIntegral seconds,
+ tdPicosec =0
+ }
+ in addToClockTime tdiff epochClkT
+
+epochClkT = toClockTime epoch
+epoch = CalendarTime { ctYear = 1970,
+ ctMonth = January,
+ ctDay = 1,
+ ctHour = 0,
+ ctMin = 0,
+ ctSec = 0,
+ ctPicosec= 0,
+ ctWDay = Thursday, -- ignored
+ ctYDay = 0, -- ignored
+ ctTZName = "UTC", -- ignored
+ ctTZ = 0,
+ ctIsDST = False -- ignored
+ }
+
+
+-- |data type for representing ISO time
+data ISODateAndTime =
+ ISODateAndTime ISODate ISOTime
+ deriving Show
+
+data ISODate =
+ ISODate ISOYearSpec ISODayOfYearSpec
+ deriving Show
+
+data ISOYearSpec
+ = ImplicitYear | ImplicitCentury Int | Century Int | ImplicitDecade Int | Year Int
+ deriving Show
+data ISODayOfYearSpec
+ = NoDayOfYear
+ | MonthDay ISOMonthSpec ISODayOfMonthSpec
+ | DayOfYear Int
+ | WeekAndDay ISOWeekSpec ISODayOfWeekSpec
+ deriving Show
+data ISOMonthSpec
+ = ImplicitMonth | Month Int
+ deriving Show
+data ISODayOfMonthSpec
+ = NoDayOfMonth | DayOfMonth Int
+ deriving Show
+data ISOWeekSpec
+ = ImplicitWeek | AnyWeek | Week Int
+ deriving Show
+data ISODayOfWeekSpec
+ = NoDayOfWeek | DayOfWeek Int
+ deriving Show
+data ISOTime
+ = ISOTime ISOHourSpec ISOMinuteSpec ISOSecondSpec ISOTimeZoneSpec
+ deriving Show
+data ISOHourSpec
+ = ImplicitHour | Hour Int
+ deriving Show
+data ISOMinuteSpec
+ = ImplicitMinute | Minute Int | NoMinute
+ deriving Show
+data ISOSecondSpec
+ = Second Int | NoSecond
+ deriving Show
+data ISOTimeZoneSpec
+ = LocalTime | UTCTime | PlusTime ISOHourSpec ISOMinuteSpec | MinusTime ISOHourSpec ISOMinuteSpec
+ deriving Show
+
+updateTZ (ISOTime isoHourSpec isoMinuteSpec isoSecondSpec _) isoTimeZoneSpec =
+ ISOTime isoHourSpec isoMinuteSpec isoSecondSpec isoTimeZoneSpec
+
+digitval = digitToInt
+
+skipHyphen = char '-' >> return ()
+skipColon = char ':' >> return ()
+skipSolidus = char '/' >> return ()
+skipMinus = char '-' >> return ()
+skipPlus = char '+' >> return ()
+skipP = oneOf "pP" >> return ()
+skipT = oneOf "tT" >> return ()
+skipW = oneOf "wW" >> return ()
+skipZ = oneOf "zZ" >> return ()
+
+parseDateFromString :: String -> Maybe ISODate
+parseDateFromString = parseFromString parseDate
+parseTimeFromString :: String -> Maybe ISOTime
+parseTimeFromString = parseFromString parseTime
+parseDateAndTimeFromString :: String -> Maybe ISODateAndTime
+parseDateAndTimeFromString = parseFromString parseDateAndTime
+
+-- |external entry point
+parseDate =
+ parseBasicOrExtended parseDateInternal
+
+parseTime =
+ parseBasicOrExtended parseTimeInternal
+
+parseDateAndTime =
+ parseBasicOrExtended parseTimeAndDateInternal
+
+parseBasicOrExtended parser =
+ parser True <|> parser False
+
+parseTimeAndDateInternal extended =
+ do isodate <- parseDateInternal extended
+ isotime <- option (ISOTime (Hour 0) NoMinute NoSecond UTCTime)
+ (skipT >> parseTimeInternal extended)
+ return $ ISODateAndTime isodate isotime
+
+-- I was pretty much fed up with the irregular format of ISO 8601. After a few
+-- tries, I decided that the simplest approach was to just list all the
+-- alternatives from the standard.
+
+-- |argument determines whether extended format is parsed
+parseDateInternal False =
+ -- 5.2.1.1, complete representation, basic format: CCYYMMDD
+ (try $ do ccyy <- parseFourDigits
+ mm <- parseTwoDigits
+ dd <- parseTwoDigits
+ return $ ISODate (Year ccyy) $ MonthDay (Month mm) (DayOfMonth dd))
+ <|>
+ -- !!! CHECK THIS !!!
+ -- 5.2.1.2.a, a specific month, basic format: CCYY-MM
+ (try $ do ccyy <- parseFourDigits
+ skipHyphen
+ mm <- parseTwoDigits
+ return $ ISODate (Year ccyy) $ MonthDay (Month mm) NoDayOfMonth)
+ <|>
+ -- 5.2.1.2.b, a specific year, basic format: CCYY
+ (try $ do ccyy <- parseFourDigits
+ return $ ISODate (Year ccyy) NoDayOfYear)
+ <|>
+ -- 5.2.1.2.c, a specific century, basic format: CC
+ (try $ do cc <- parseTwoDigits
+ return $ ISODate (Century cc) NoDayOfYear)
+ <|>
+ -- 5.2.1.3.a, truncated representation, specific date in current century, basic format: YYMMDD
+ (try $ do yy <- parseTwoDigits
+ mm <- parseTwoDigits
+ dd <- parseTwoDigits
+ return $ ISODate (ImplicitCentury yy) $ MonthDay (Month mm) (DayOfMonth dd))
+ <|>
+ -- 5.2.1.3.b, truncated representation, specific year and month in current century, basic format: -YYMM
+ (try $ do skipHyphen
+ yy <- parseTwoDigits
+ mm <- parseTwoDigits
+ return $ ISODate (ImplicitCentury yy) $ MonthDay (Month mm) NoDayOfMonth)
+ <|>
+ -- 5.2.1.3.c, truncated representation, specific year in current century, basic format: -YY
+ (try $ do skipHyphen
+ yy <- parseTwoDigits
+ return $ ISODate (ImplicitCentury yy) NoDayOfYear)
+ <|>
+ -- 5.2.1.3.d, truncated representation, specific day of a month, basic format: --MMDD
+ (try $ do skipHyphen
+ skipHyphen
+ mm <- parseTwoDigits
+ dd <- parseTwoDigits
+ return $ ISODate ImplicitYear $ MonthDay (Month mm) (DayOfMonth dd))
+ <|>
+ -- 5.2.1.3.e, truncated representation, specific month, basic format: --MM
+ (try $ do skipHyphen
+ skipHyphen
+ mm <- parseTwoDigits
+ return $ ISODate ImplicitYear $ MonthDay (Month mm) NoDayOfMonth)
+ <|>
+ -- 5.2.1.3.f, truncated representation, specific day, basic format: ---DD
+ (try $ do skipHyphen
+ skipHyphen
+ skipHyphen
+ dd <- parseTwoDigits
+ return $ ISODate ImplicitYear $ MonthDay ImplicitMonth (DayOfMonth dd))
+ <|>
+ -- 5.2.2 Ordinal date
+ -- 5.2.2.1, complete representation, basic format: CCYYDDD
+ (try $ do ccyy <- parseFourDigits
+ ddd <- parseOrdinalDay
+ return $ ISODate (Year ccyy) $ DayOfYear ddd)
+ <|>
+ -- 5.2.2.2.a, truncated representation, specific year and day in current century, basic format: YYDDD
+ (try $ do yy <- parseTwoDigits
+ ddd <- parseOrdinalDay
+ return $ ISODate (ImplicitCentury yy) $ DayOfYear ddd)
+ <|>
+ -- 5.2.2.2.b, truncated representation, specific day only, basic format: -DDD
+ (try $ do skipHyphen
+ ddd <- parseOrdinalDay
+ return $ ISODate ImplicitYear $ DayOfYear ddd)
+ <|>
+ -- 5.2.3 date by calendar week and day number
+ -- 5.2.3.1, complete representation, basic format: CCYYWwwD
+ (try $ do ccyy <- parseFourDigits
+ skipW
+ ww <- parseTwoDigits
+ checkWeeks ww
+ d <- parseWeekDay
+ return $ ISODate (Year ccyy) $ WeekAndDay (Week ww) (DayOfWeek d))
+ <|>
+ -- 5.2.3.2, reduced prec representation, basic format: CCYYWww
+ (try $ do ccyy <- parseFourDigits
+ skipW
+ ww <- parseTwoDigits
+ checkWeeks ww
+ return $ ISODate (Year ccyy) $ WeekAndDay (Week ww) NoDayOfWeek)
+ <|>
+ -- 5.2.3.3.a, truncated representation, current century, basic format: YYWwwD
+ (try $ do yy <- parseTwoDigits
+ skipW
+ ww <- parseTwoDigits
+ checkWeeks ww
+ d <- parseWeekDay
+ return $ ISODate (ImplicitCentury yy) $ WeekAndDay (Week ww) (DayOfWeek d))
+ <|>
+ -- 5.2.3.3.b, truncated representation, current century, year and week only, basic format: YYWww
+ (try $ do yy <- parseTwoDigits
+ skipW
+ ww <- parseTwoDigits
+ checkWeeks ww
+ return $ ISODate (ImplicitCentury yy) $ WeekAndDay (Week ww) NoDayOfWeek)
+ <|>
+ -- 5.2.3.3.c, truncated representation, current decade, week, and day, basic format: -YWwwD
+ (try $ do skipHyphen
+ y <- parseOneDigit
+ skipW
+ ww <- parseTwoDigits
+ checkWeeks ww
+ d <- parseWeekDay
+ return $ ISODate (ImplicitDecade y) $ WeekAndDay (Week ww) (DayOfWeek d))
+ <|>
+ -- 5.2.3.3.d, truncated representation, current year, week, and day, basic format: -WwwD
+ (try $ do skipHyphen
+ skipW
+ ww <- parseTwoDigits
+ checkWeeks ww
+ d <- parseWeekDay
+ return $ ISODate ImplicitYear $ WeekAndDay (Week ww) (DayOfWeek d))
+ <|>
+ -- 5.2.3.3.e, truncated representation, current year, week only, basic format: -Www
+ (try $ do skipHyphen
+ skipW
+ ww <- parseTwoDigits
+ checkWeeks ww
+ return $ ISODate ImplicitYear $ WeekAndDay (Week ww) NoDayOfWeek)
+ <|>
+ -- 5.2.3.3.f, truncated representation, day only of current week, basic format: -W-D
+ (try $ do skipHyphen
+ skipW
+ skipHyphen
+ d <- parseWeekDay
+ return $ ISODate ImplicitYear $ WeekAndDay ImplicitWeek (DayOfWeek d))
+ <|>
+ -- 5.2.3.3.g, truncated representation, day only of any week, basic format: ---D
+ (try $ do skipHyphen
+ skipHyphen
+ skipHyphen
+ d <- parseWeekDay
+ return $ ISODate ImplicitYear $ WeekAndDay AnyWeek (DayOfWeek d))
+
+
+-- ----------------------------------------------------------------------
+-- extended formats
+parseDateInternal True =
+ -- 5.2.1.1, complete representation, extended format CCYY-MM-DD
+ (try $ do ccyy <- parseFourDigits
+ skipHyphen
+ mm <- parseTwoDigits
+ skipHyphen
+ dd <- parseTwoDigits
+ return $ ISODate (Year ccyy) $ MonthDay (Month mm) (DayOfMonth dd))
+ <|>
+ -- 5.2.1.3.a, truncated representation, extended format: YY-MM-DD
+ (try $ do yy <- parseTwoDigits
+ skipHyphen
+ mm <- parseTwoDigits
+ skipHyphen
+ dd <- parseTwoDigits
+ return $ ISODate (ImplicitCentury yy) $ MonthDay (Month mm) (DayOfMonth dd))
+ <|>
+ -- 5.2.1.3.b, truncated representation, specific year and month in current century, extended format: -YY-MM
+ (try $ do skipHyphen
+ yy <- parseTwoDigits
+ skipHyphen
+ mm <- parseTwoDigits
+ return $ ISODate (ImplicitCentury yy) $ MonthDay (Month mm) NoDayOfMonth)
+ <|>
+ -- 5.2.1.3.d, truncated representation, specific day of a month, extended format: --MM-DD
+ (try $ do skipHyphen
+ skipHyphen
+ mm <- parseTwoDigits
+ skipHyphen
+ dd <- parseTwoDigits
+ return $ ISODate ImplicitYear $ MonthDay (Month mm) (DayOfMonth dd))
+ <|>
+ -- 5.2.2 Ordinal date
+ -- 5.2.2.1, complete representation, extended format: CCYY-DDD
+ (try $ do ccyy <- parseFourDigits
+ skipHyphen
+ ddd <- parseOrdinalDay
+ return $ ISODate (Year ccyy) $ DayOfYear ddd)
+ <|>
+ -- 5.2.2.2.a, truncated representation, specific year and day in current century, extended format: YY-DDD
+ (try $ do yy <- parseTwoDigits
+ skipHyphen
+ ddd <- parseOrdinalDay
+ return $ ISODate (ImplicitCentury yy) $ DayOfYear ddd)
+ <|>
+ -- 5.2.3 date by calendar week and day number
+ -- 5.2.3.1, complete representation, extended format: CCYY-Www-D
+ (try $ do ccyy <- parseFourDigits
+ skipHyphen
+ skipW
+ ww <- parseTwoDigits
+ checkWeeks ww
+ skipHyphen
+ d <- parseWeekDay
+ return $ ISODate (Year ccyy) $ WeekAndDay (Week ww) (DayOfWeek d))
+ <|>
+ -- 5.2.3.2, reduced prec representation, extended format: CCYY-Www
+ (try $ do ccyy <- parseFourDigits
+ skipHyphen
+ skipW
+ ww <- parseTwoDigits
+ checkWeeks ww
+ return $ ISODate (Year ccyy) $ WeekAndDay (Week ww) NoDayOfWeek)
+ <|>
+ -- 5.2.3.3.a, truncated representation, current century, extended format: YY-Www-D
+ (try $ do yy <- parseTwoDigits
+ skipHyphen
+ skipW
+ ww <- parseTwoDigits
+ checkWeeks ww
+ skipHyphen
+ d <- parseWeekDay
+ return $ ISODate (ImplicitCentury yy) $ WeekAndDay (Week ww) (DayOfWeek d))
+ <|>
+ -- 5.2.3.3.b, truncated representation, current century, year and week only, extended format: YY-Www
+ (try $ do yy <- parseTwoDigits
+ skipHyphen
+ skipW
+ ww <- parseTwoDigits
+ checkWeeks ww
+ return $ ISODate (ImplicitCentury yy) $ WeekAndDay (Week ww) NoDayOfWeek)
+ <|>
+ -- 5.2.3.3.c, truncated representation, current decade, week, and day, extended format: -Y-Www-D
+ (try $ do skipHyphen
+ y <- parseOneDigit
+ skipHyphen
+ skipW
+ ww <- parseTwoDigits
+ checkWeeks ww
+ skipHyphen
+ d <- parseWeekDay
+ return $ ISODate (ImplicitDecade y) $ WeekAndDay (Week ww) (DayOfWeek d))
+ <|>
+ -- !!! CHECK THIS
+ -- 5.2.3.3.d, truncated representation, current year, week, and day, extended format: -Www-D
+ (try $ do skipHyphen
+ skipW
+ ww <- parseTwoDigits
+ checkWeeks ww
+ skipHyphen
+ d <- parseWeekDay
+ return $ ISODate ImplicitYear $ WeekAndDay (Week ww) (DayOfWeek d))
+
+-- |time parsers
+parseTimeInternal extended =
+ do localtime <- parseLocalTimeInternal extended
+ tzsuffix <- option LocalTime $ parseTZsuffix extended
+ return $ updateTZ localtime tzsuffix
+
+parseTZsuffix extended =
+ (do skipZ
+ return UTCTime)
+ <|>
+ (do skipPlus
+ (hours, minutes) <- parseHoursMinutes extended
+ return $ PlusTime hours minutes)
+ <|>
+ (do skipMinus
+ (hours, minutes) <- parseHoursMinutes extended
+ return $ MinusTime hours minutes)
+
+parseHoursMinutes False =
+ do hh <- parseTwoDigits
+ mm <- option NoMinute $ (liftM Minute) parseTwoDigits
+ return (Hour hh, mm)
+
+parseHoursMinutes True =
+ do hh <- parseTwoDigits
+ mm <- option NoMinute $ (liftM Minute) (skipColon >> parseTwoDigits)
+ return (Hour hh, mm)
+
+parseLocalTimeInternal False =
+ -- 5.3.1.1, local time, basic format: hhmmss
+ (try $ do hh <- parseTwoDigits
+ mm <- parseTwoDigits
+ ss <- parseTwoDigits
+ checkHours hh
+ checkMinutes mm
+ checkSeconds ss
+ return $ ISOTime (Hour hh) (Minute mm) (Second ss) LocalTime)
+ <|>
+ -- 5.3.1.2, local time, reduced precision, basic format: hhmm ; hh
+ (try $ do hh <- parseTwoDigits
+ mm <- parseTwoDigits
+ checkHours hh
+ checkMinutes mm
+ return $ ISOTime (Hour hh) (Minute mm) NoSecond LocalTime)
+ <|>
+ (try $ do hh <- parseTwoDigits
+ checkHours hh
+ return $ ISOTime (Hour hh) NoMinute NoSecond LocalTime)
+ <|>
+ -- 5.3.1.4.a, local time, truncated, basic format: -mmss
+ (try $ do skipHyphen
+ mm <- parseTwoDigits
+ ss <- parseTwoDigits
+ checkMinutes mm
+ checkSeconds ss
+ return $ ISOTime ImplicitHour (Minute mm) (Second ss) LocalTime)
+ <|>
+ -- 5.3.1.4.b, local time, truncated, basic format: -mm
+ (try $ do skipHyphen
+ mm <- parseTwoDigits
+ checkMinutes mm
+ return $ ISOTime ImplicitHour (Minute mm) NoSecond LocalTime)
+ <|>
+ -- 5.3.1.4.c, local time, truncated, basic format: --ss
+ (try $ do skipHyphen
+ skipHyphen
+ ss <- parseTwoDigits
+ checkSeconds ss
+ return $ ISOTime ImplicitHour ImplicitMinute (Second ss) LocalTime)
+
+
+parseLocalTimeInternal True =
+ -- 5.3.1.1, local time, extended format: hh:mm:ss
+ (try $ do hh <- parseTwoDigits
+ skipColon
+ mm <- parseTwoDigits
+ skipColon
+ ss <- parseTwoDigits
+ checkHours hh
+ checkMinutes mm
+ checkSeconds ss
+ return $ ISOTime (Hour hh) (Minute mm) (Second ss) LocalTime)
+ <|>
+ -- 5.3.1.2, local time, reduced precision, extended format: hh:mm
+ (try $ do hh <- parseTwoDigits
+ skipColon
+ mm <- parseTwoDigits
+ checkHours hh
+ checkMinutes mm
+ return $ ISOTime (Hour hh) (Minute mm) NoSecond LocalTime)
+ <|>
+ -- 5.3.1.4.a, local time, truncated, extended format: -mm:ss
+ (try $ do skipHyphen
+ mm <- parseTwoDigits
+ skipColon
+ ss <- parseTwoDigits
+ checkMinutes mm
+ checkSeconds ss
+ return $ ISOTime ImplicitHour (Minute mm) (Second ss) LocalTime)
+
+-- make ISOTime, ISODate, ISODateAndTime instances of Read
+instance Read ISOTime where
+ readsPrec i = parserToRead parseTime
+
+instance Read ISODate where
+ readsPrec i = parserToRead parseDate
+
+instance Read ISODateAndTime where
+ readsPrec i = parserToRead parseDateAndTime
+-- auxiliary parsers
+
+checkSeconds ss = if ss > 60 then fail "more than 60 seconds" else return ()
+checkMinutes mm = if mm > 59 then fail "more than 59 minutes" else return ()
+checkHours hh = if hh > 24 then fail "more than 24 hours" else return ()
+checkDays ddd = if ddd < 1 || ddd > 366 then fail "illegal ordinal day" else return ()
+checkWeeks ww = if ww < 1 || ww > 53 then fail "illegal week nr" else return ()
+
+parseWeekDay = do d0 <- oneOf "1234567"
+ return (digitval d0)
+
+parseOneDigit = do d0 <- digit
+ return (digitval d0)
+parseTwoDigits = do d1 <- digit
+ vv <- parseOneDigit
+ return (10 * digitval d1 + vv)
+parseThreeDigits = do d2 <- digit
+ vv <- parseTwoDigits
+ let vvv = 100 * digitval d2 + vv
+ return vvv
+parseOrdinalDay = do vvv <- parseThreeDigits
+ checkDays vvv
+ return vvv
+parseFourDigits = do d3 <- digit
+ vvv <- parseThreeDigits
+ return (1000 * digitval d3 + vvv)
+
diff --git a/libsrc/MissingH/Wash/Utility/IntToString.hs b/libsrc/MissingH/Wash/Utility/IntToString.hs
new file mode 100644
index 0000000..93f8a2a
--- /dev/null
+++ b/libsrc/MissingH/Wash/Utility/IntToString.hs
@@ -0,0 +1,10 @@
+-- © 2002 Peter Thiemann
+module IntToString where
+
+import Char
+
+intToString ndigits i =
+ let g x = h $ divMod x 10
+ h (q,r) = chr (ord '0' + fromInteger r) : g q
+ in
+ reverse $ take ndigits $ g i
diff --git a/libsrc/MissingH/Wash/Utility/JavaScript.hs b/libsrc/MissingH/Wash/Utility/JavaScript.hs
new file mode 100644
index 0000000..26e54b8
--- /dev/null
+++ b/libsrc/MissingH/Wash/Utility/JavaScript.hs
@@ -0,0 +1,27 @@
+-- © 2003 Peter Thiemann
+module JavaScript where
+
+import Char
+
+import Hex
+
+jsShow :: String -> String
+jsShow xs = '\'' : g xs
+ where
+ g "" = "'"
+ g (x:xs) =
+ case x of
+ '\'' -> h x xs
+ '\"' -> h x xs
+ '<' -> h x xs
+ '>' -> h x xs
+ '&' -> h x xs
+ x | isPrint x -> x : g xs
+ | otherwise -> h x xs
+ h x xs =
+ let ox = ord x in
+ if ox < 256 then
+ '\\' : 'x' : showsHex 2 ox (g xs)
+ else
+ '\\' : 'u' : showsHex 4 ox (g xs)
+
diff --git a/libsrc/MissingH/Wash/Utility/LICENSE b/libsrc/MissingH/Wash/Utility/LICENSE
new file mode 100644
index 0000000..b16110c
--- /dev/null
+++ b/libsrc/MissingH/Wash/Utility/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/Wash/Utility/Locking.hs b/libsrc/MissingH/Wash/Utility/Locking.hs
new file mode 100644
index 0000000..569cfa8
--- /dev/null
+++ b/libsrc/MissingH/Wash/Utility/Locking.hs
@@ -0,0 +1,36 @@
+module Locking (obtainLock, releaseLock) where
+
+import Auxiliary
+import Directory
+import IO
+import System
+import Time
+
+obtainLock :: FilePath -> IO ()
+releaseLock :: FilePath -> IO ()
+
+lockPath name = name ++ ".lockdir"
+
+obtainLock name =
+ assertDirectoryExists (lockPath name)
+ (system "sleep 1" >> obtainLockLoop name)
+
+releaseLock name =
+ removeDirectory (lockPath name)
+
+obtainLockLoop name =
+ let lp = lockPath name in
+ do b <- doesDirectoryExist lp
+ if b then do -- check if lock is stale
+ mtime <- getModificationTime lp
+ ftime <- getModificationTime name
+ ctime <- getClockTime
+ let td = diffClockTimes ctime mtime
+ tf = diffClockTimes ctime ftime
+ if tdSec td > 60 && tdSec tf > 60
+ then do removeDirectory lp
+ obtainLock name
+ else do system "sleep 1"
+ obtainLockLoop name
+
+ else obtainLock name
diff --git a/libsrc/MissingH/Wash/Utility/QuotedPrintable.hs b/libsrc/MissingH/Wash/Utility/QuotedPrintable.hs
new file mode 100644
index 0000000..9a66f66
--- /dev/null
+++ b/libsrc/MissingH/Wash/Utility/QuotedPrintable.hs
@@ -0,0 +1,49 @@
+module QuotedPrintable
+ (encode, encode', decode
+ -- deprecated: encode_quoted, encode_quoted', decode_quoted
+ ) where
+
+import Char
+import Hex
+
+encode, encode', decode :: String -> String
+encode = encode_quoted
+encode' = encode_quoted'
+decode = decode_quoted
+
+
+encode_hexadecimal c = '=' : showHex2 c
+
+quoted_printable x =
+ ox >= 33 && ox <= 126 && ox /= 61
+ where ox = ord x
+
+end_of_line [] = True
+end_of_line ('\r':'\n':_) = True
+end_of_line _ = False
+
+encode_quoted' (x:xs) | x `elem` "\t " =
+ if end_of_line xs then encode_hexadecimal (ord x) ++ encode_quoted' xs
+ else x : encode_quoted' xs
+encode_quoted' (x:xs) | quoted_printable x = x : encode_quoted' xs
+encode_quoted' ('\r':'\n':xs) = '\r':'\n': encode_quoted' xs
+encode_quoted' (x:xs) = encode_hexadecimal (ord x) ++ encode_quoted' xs
+encode_quoted' [] = ""
+
+encode_quoted = softLineBreak 76 . encode_quoted'
+
+softLineBreak n [] = "\r\n"
+softLineBreak 0 xs | not (end_of_line xs) = '=':'\r':'\n': softLineBreak 76 xs
+softLineBreak n ('\r':'\n':xs) = '\r':'\n': softLineBreak 76 xs
+softLineBreak n (xs@('=':_)) | n < 4 = '=':'\r':'\n': softLineBreak 76 xs
+softLineBreak n (x:xs) = x : softLineBreak (n-1) xs
+
+decode_quoted [] = []
+decode_quoted ('=':'\r':'\n':xs) =
+ decode_quoted xs
+decode_quoted ('=':'\n':xs) =
+ decode_quoted xs
+decode_quoted ('=':upper:lower:xs) | isHexdigit upper && isHexdigit lower =
+ chr (16 * hexDigitVal upper + hexDigitVal lower) : decode_quoted xs
+decode_quoted (x:xs) =
+ x : decode_quoted xs
diff --git a/libsrc/MissingH/Wash/Utility/RFC2047.hs b/libsrc/MissingH/Wash/Utility/RFC2047.hs
new file mode 100644
index 0000000..1188514
--- /dev/null
+++ b/libsrc/MissingH/Wash/Utility/RFC2047.hs
@@ -0,0 +1,71 @@
+module RFC2047 where
+-- decoding of header fields
+import Char
+import List
+
+import qualified Base64
+import qualified QuotedPrintable
+import Hex
+import Parsec
+
+lineString =
+ do initial <- many (noneOf "\n\r=")
+ rest <- option "" (do xs <- try encoded_words <|> string "="
+ ys <- lineString
+ return (xs ++ ys))
+ return (initial ++ rest)
+
+especials = "()<>@,;:\\\"/[]?.="
+tokenchar = "!\"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_`abcdefghijklmnopqrstuvwxyz{|}~" \\ especials
+p_token = many1 (oneOf tokenchar)
+p_encoded_text = many1 $ oneOf "!\"#$%&'()*+,-./0123456789:;<=>@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_`abcdefghijklmnopqrstuvwxyz{|}~"
+allchar = "\NUL\SOH\STX\ETX\EOT\ENQ\ACK\a\b\t\n\v\f\r\SO\SI\DLE\DC1\DC2\DC3\DC4\NAK\SYN\ETB\CAN\EM\SUB\ESC\FS\GS\RS\US !\"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_`abcdefghijklmnopqrstuvwxyz{|}~\DEL"
+
+-- supress linear white space between adjacent encoded_word
+encoded_words =
+ do ew <- encoded_word
+ ws <- many space
+ option (ew++ws) (encoded_words >>= \ews -> return (ew++ews))
+
+encoded_word =
+ do string "=?"
+ charset <- p_token
+ char '?'
+ encoding <- p_token
+ char '?'
+ encoded_text <- p_encoded_text
+ string "?="
+ return $ decode charset (map toUpper encoding) encoded_text
+
+decode charset "B" encoded_text =
+ Base64.decode' encoded_text
+decode charset "Q" encoded_text =
+ decode_quoted encoded_text
+decode charset encoding encoded_text =
+ error ("Unknown encoding: " ++ encoding)
+
+decode_quoted [] = []
+decode_quoted ('=':upper:lower:xs) =
+ chr (16 * hexDigitVal upper + hexDigitVal lower) : decode_quoted xs
+decode_quoted ('_':xs) =
+ ' ' : decode_quoted xs
+decode_quoted (x:xs) =
+ x : decode_quoted xs
+
+-- --------------------------------------------------------------------
+-- RFC 2047: encoding of header fields
+
+encodeWord w =
+ "=?" ++ charset ++ "?" ++ encoding ++ "?" ++ QuotedPrintable.encode' w ++ "?="
+ where encoding = "q"
+ charset = "iso-8859-1"
+
+encodeValue v =
+ case span (not . flip elem " ()<>@.!,") v of
+ ([], []) -> []
+ (word, []) -> maybeEncode word
+ (word, x:rest) -> maybeEncode word ++ x : encodeValue rest
+
+maybeEncode word | all p word = word
+ | otherwise = encodeWord word
+ where p x = let ox = ord x in ox >= 33 && ox <= 126
diff --git a/libsrc/MissingH/Wash/Utility/RFC2279.hs b/libsrc/MissingH/Wash/Utility/RFC2279.hs
new file mode 100644
index 0000000..1377ee9
--- /dev/null
+++ b/libsrc/MissingH/Wash/Utility/RFC2279.hs
@@ -0,0 +1,110 @@
+-- © 2003 Peter Thiemann
+{-|
+ Implements UTF-8 encoding
+
+ UCS-4 range (hex.) UTF-8 octet sequence (binary)
+ 0000 0000-0000 007F 0xxxxxxx
+ 0000 0080-0000 07FF 110xxxxx 10xxxxxx
+ 0000 0800-0000 FFFF 1110xxxx 10xxxxxx 10xxxxxx
+ 0001 0000-001F FFFF 11110xxx 10xxxxxx 10xxxxxx 10xxxxxx
+ 0020 0000-03FF FFFF 111110xx 10xxxxxx 10xxxxxx 10xxxxxx 10xxxxxx
+ 0400 0000-7FFF FFFF 1111110x 10xxxxxx ... 10xxxxxx
+-}
+module RFC2279 (encode, decode) where
+
+import Char
+
+
+-- |maps Unicode string to list of octets
+encode :: String -> String
+
+-- |maps list of octets in UTF-8 encoding to Unicode string
+decode :: String -> String
+
+factors = iterate (* 0x40) 1
+f1 = factors !! 1
+f2 = factors !! 2
+f3 = factors !! 3
+f4 = factors !! 4
+f5 = factors !! 5
+
+encode [] = []
+encode (x:xs) =
+ let r0 = ord x in
+ if r0 < 0x80 then
+ x : encode xs
+ else if r0 < 0x800 then
+ let c1 = 0xC0 + r0 `div` f1
+ c2 = 0x80 + r0 `mod` f1
+ in chr c1 : chr c2 : encode xs
+ else if r0 < 0x10000 then
+ let c1 = 0xE0 + r0 `div` f2
+ r1 = r0 `mod` f2
+ c2 = 0x80 + r1 `div` f1
+ c3 = 0x80 + r1 `mod` f1
+ in chr c1 : chr c2 : chr c3 : encode xs
+ else if r0 < 0x200000 then
+ let c1 = 0xF0 + r0 `div` f3
+ r1 = r0 `mod` f3
+ c2 = 0x80 + r1 `div` f2
+ r2 = r1 `mod` f2
+ c3 = 0x80 + r2 `div` f1
+ c4 = 0x80 + r2 `mod` f1
+ in chr c1 : chr c2 : chr c3 : chr c4 : encode xs
+ else if r0 < 0x4000000 then
+ let c1 = 0xF8 + r0 `div` f4
+ r1 = r0 `mod` f4
+ c2 = 0x80 + r1 `div` f3
+ r2 = r1 `mod` f3
+ c3 = 0x80 + r2 `div` f2
+ r3 = r2 `mod` f2
+ c4 = 0x80 + r3 `div` f1
+ c5 = 0x80 + r3 `mod` f1
+ in chr c1 : chr c2 : chr c3 : chr c4 : chr c5 : encode xs
+ else
+ let c1 = 0xFC + r0 `div` f5
+ r1 = r0 `mod` f5
+ c2 = 0x80 + r1 `div` f4
+ r2 = r1 `mod` f4
+ c3 = 0x80 + r2 `div` f3
+ r3 = r2 `mod` f3
+ c4 = 0x80 + r3 `div` f2
+ r4 = r3 `mod` f2
+ c5 = 0x80 + r4 `div` f1
+ c6 = 0x80 + r4 `mod` f1
+ in chr c1 : chr c2 : chr c3 : chr c4 : chr c5 : chr c6 : encode xs
+
+
+decode [] = []
+decode (x : xs) =
+ let ordx = ord x in
+ if ordx < 0x80 then
+ x : decode xs
+ else if ordx < 0xC0 then
+ error "UTF-8 decoding out of sync"
+ else if ordx < 0xE0 then
+ decoden 1 (ordx - 0xC0) xs
+ else if ordx < 0xF0 then
+ decoden 2 (ordx - 0xE0) xs
+ else if ordx < 0xF8 then
+ decoden 3 (ordx - 0xF0) xs
+ else if ordx < 0xFC then
+ decoden 4 (ordx - 0xF8) xs
+ else if ordx < 0xFE then
+ decoden 5 (ordx - 0xFC) xs
+ else
+ error "UTF-8 decoding found illegal start octet"
+
+decoden :: Int -> Int -> String -> String
+decoden 0 v xs =
+ chr v : decode xs
+decoden n v (x : xs) =
+ let ordx = ord x
+ v' = f1 * v + ordx - 0x80
+ in
+ if ordx >= 0x80 && ordx < 0xC0 then
+ decoden (n-1) v' xs
+ else
+ error "UTF-8 decoding found illegal continuation octet"
+
+
diff --git a/libsrc/MissingH/Wash/Utility/RFC2397.hs b/libsrc/MissingH/Wash/Utility/RFC2397.hs
new file mode 100644
index 0000000..0dbd15b
--- /dev/null
+++ b/libsrc/MissingH/Wash/Utility/RFC2397.hs
@@ -0,0 +1,64 @@
+module RFC2397 where
+
+import URLCoding
+import Base64
+
+data ENC = BASE64 | URL
+ deriving Eq
+
+-- |maps (mediatype, contents) to data URL
+encode :: (String, String) -> String
+encode (mediatype, thedata) =
+ "data:" ++ mediatype ++ ";base64," ++ Base64.encode' thedata
+
+-- |maps data URL to @Just (mediatype, contents)@ or @Nothing@ in case of a
+-- syntax error.
+decode :: String -> Maybe (String, String)
+decode url =
+ let (scheme, rest) = break (==':') url in
+ case rest of
+ ':' : contents | scheme == "data" ->
+ decodeContents contents
+ _ -> Nothing
+
+decodeContents xs =
+ let (prefix, restdata) = break (==',') xs in
+ case restdata of
+ ',' : thedata ->
+ decodePrefix prefix thedata
+ _ -> Nothing
+
+decodePrefix prefix thedata =
+ let fragments = breakList (==';') prefix
+ enc = case reverse fragments of
+ ("base64":_) -> BASE64
+ _ -> URL
+ mediapart | enc == BASE64 = init fragments
+ | otherwise = fragments
+ in
+ case mediapart of
+ (xs:_) ->
+ case break (=='/') xs of
+ (_, []) ->
+ decodeData ("text/plain" : mediapart) enc thedata
+ _ ->
+ decodeData mediapart enc thedata
+ _ -> decodeData ["text/plain", "charset=US-ASCII"] enc thedata
+
+decodeData mediatype enc thedata =
+ Just ( unparse mediatype
+ , case enc of
+ URL -> URLCoding.decode thedata
+ BASE64 -> Base64.decode thedata
+ )
+
+breakList :: (x -> Bool) -> [x] -> [[x]]
+breakList p xs =
+ let (pre, post) = break p xs in
+ case post of
+ [] -> [pre]
+ y:ys -> pre : breakList p ys
+
+unparse [] = ""
+unparse [xs] = xs
+unparse (xs:xss) = xs ++ ';' : unparse xss
diff --git a/libsrc/MissingH/Wash/Utility/Shell.hs b/libsrc/MissingH/Wash/Utility/Shell.hs
new file mode 100644
index 0000000..fae193a
--- /dev/null
+++ b/libsrc/MissingH/Wash/Utility/Shell.hs
@@ -0,0 +1,20 @@
+-- © 2002 Peter Thiemann
+-- |Defines functions for shell quotation.
+module Shell where
+
+import Char
+
+-- |Shell meta characters are /! & ; \` \' \" | * ? ~ \< \> ^ ( ) [ ] true $ n r/
+metaCharacters :: String
+metaCharacters = " !&;`\'\"|*?~<>^()[]$\\%{}"
+
+-- |Quotes all shell meta characters and removes non printable ones.
+quote :: String -> String
+quote "" = ""
+quote (x:xs) | isPrint x =
+ if x `elem` metaCharacters
+ then '\\' : x : quote xs
+ else x : quote xs
+ | otherwise =
+ quote xs
+
diff --git a/libsrc/MissingH/Wash/Utility/SimpleParser.hs b/libsrc/MissingH/Wash/Utility/SimpleParser.hs
new file mode 100644
index 0000000..43890dc
--- /dev/null
+++ b/libsrc/MissingH/Wash/Utility/SimpleParser.hs
@@ -0,0 +1,60 @@
+-- © 2002 Peter Thiemann
+module SimpleParser where
+
+import Char
+
+-- very simple parser combinators: Parsec is too sophisticated!
+newtype Parser a b = Parser (a -> [(b, a)])
+unParser (Parser g) = g
+instance Monad (Parser a) where
+ return x = Parser (\ w -> [(x, w)])
+ m >>= f = let g = unParser m in
+ Parser (\ w -> [ (y, w'') | (x, w') <- g w, (y, w'') <- unParser (f x) w'])
+ fail str = Parser (\ w -> [])
+
+satisfy p = Parser (\ w -> [(x, w') | x:w' <- [w], p x])
+
+print = satisfy isPrint
+alphaNum = satisfy isAlphaNum
+alpha = satisfy isAlpha
+ascii = satisfy isAscii
+digit = satisfy isDigit
+char c = satisfy (==c)
+string s = foldr (\ x p -> do { c <- char x; cs <- p; return (c:cs); }) (return "") s
+oneOf cs = satisfy (`elem` cs)
+noneOf cs = satisfy (not . (`elem` cs))
+
+eof = Parser (\ w -> if null w then [((),[])] else [])
+try parser = parser
+p1 <|> p2 = let g1 = unParser p1
+ g2 = unParser p2
+ in Parser (\w -> g1 w ++ g2 w)
+
+option :: x -> Parser a x -> Parser a x
+option x parser = parser <|> return x
+
+many1 p =
+ do x <- p
+ xs <- many p
+ return (x : xs)
+
+many p =
+ option [] (many1 p)
+
+manyn n p =
+ if n <= 0
+ then return []
+ else do x <- p
+ xs <- manyn (n-1) p
+ return (x : xs)
+
+
+parseFromString :: Parser String x -> String -> Maybe x
+parseFromString parser str =
+ let g = unParser (parser >>= (\x -> eof >> return x)) in
+ case g str of
+ (x, ""): _ -> Just x
+ _ -> Nothing
+
+parserToRead :: Parser String x -> ReadS x
+parserToRead parser = unParser parser
diff --git a/libsrc/MissingH/Wash/Utility/URLCoding.hs b/libsrc/MissingH/Wash/Utility/URLCoding.hs
new file mode 100644
index 0000000..2b3d8d6
--- /dev/null
+++ b/libsrc/MissingH/Wash/Utility/URLCoding.hs
@@ -0,0 +1,26 @@
+-- © 2001, 2002 Peter Thiemann
+-- |Implements coding of non-alphanumeric characters in URLs and CGI-requests.
+module URLCoding (encode, decode) where
+
+import Char
+import Hex
+
+encode, decode :: String -> String
+encode = urlEncode
+decode = urlDecode
+
+urlEncode :: String -> String
+urlEncode "" = ""
+urlEncode (x:xs) | isAlphaNum x = x : urlEncode xs
+ | x == ' ' = '+' : urlEncode xs
+ | otherwise = '%' : showHex2 (ord x) ++ urlEncode xs
+
+urlDecode :: String -> String
+urlDecode "" = ""
+urlDecode ('+':xs) =
+ ' ' : urlDecode xs
+urlDecode ('%':upper:lower:xs) =
+ chr (16 * hexDigitVal upper + hexDigitVal lower) : urlDecode xs
+urlDecode (x:xs) =
+ x : urlDecode xs
+
diff --git a/libsrc/MissingH/Wash/Utility/Unique.hs b/libsrc/MissingH/Wash/Utility/Unique.hs
new file mode 100644
index 0000000..fefd85c
--- /dev/null
+++ b/libsrc/MissingH/Wash/Utility/Unique.hs
@@ -0,0 +1,67 @@
+-- © 2001 Peter Thiemann
+module Unique (inventStdKey, inventKey, inventFilePath) where
+
+import Random
+import IO
+import Directory
+import Auxiliary
+import List
+import Monad
+import Locking
+
+registryDir = "/tmp/Unique/"
+
+-- |Creates a random string of 20 letters and digits.
+inventStdKey :: IO String
+inventStdKey = inventKey 20 stdKeyChars
+
+stdKeyChars = ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9']
+
+-- |Creates a unique string from a given length and alphabet.
+inventKey :: Int -> String -> IO String
+inventKey len chars =
+ do g <- newStdGen
+ let candidate = take len $ map (chars !!) $ randomRs (0, length chars - 1) g
+ dirname = registryDir ++ candidate
+ catch (do createDirectory dirname
+ return candidate)
+ (\ ioe ->
+ if isAlreadyExistsError ioe then
+ -- might want to check here for timeout
+ inventKey len chars
+ else if isDoesNotExistError ioe then
+ do assertDirectoryExists registryDir (return ())
+ setPermissions registryDir (Permissions True True True True)
+ inventKey len chars
+ else do hPutStrLn stderr ("inventKey could not create " ++ show dirname)
+ ioError ioe)
+
+-- |Create a unique temporary file name
+inventFilePath :: IO String
+inventFilePath =
+ do key <- inventStdKey
+ return (registryDir ++ key ++ "/f")
+
+-- obsolete. registryFile is a bottleneck.
+
+registryFile = registryDir ++ "REGISTRY"
+
+inventKey' :: Int -> String -> IO String
+inventKey' len chars =
+ do g <- newStdGen
+ let candidate = take len $ map (chars !!) $ randomRs (0, length chars - 1) g
+ obtainLock registryFile
+ registry <- readRegistry
+ let passwords = lines registry
+ if candidate `elem` passwords
+ then do releaseLock registryFile
+ inventKey' len chars
+ else do appendFile registryFile (candidate ++ "\n")
+ releaseLock registryFile
+ return candidate
+
+readRegistry :: IO String
+readRegistry =
+ let registryPath = init registryDir in
+ do assertDirectoryExists registryPath (return ())
+ readFileNonExistent registryFile ""
--
haskell-testpack
More information about the Pkg-haskell-commits
mailing list