[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 ddf5028d7eb467a5f645a0175de06d1b1e2364ea
Author: John Goerzen <jgoerzen at complete.org>
Date: Mon Oct 25 10:05:12 2004 +0100
Removed 3rd-party code imported outside arch
Keywords:
(jgoerzen at complete.org--projects/missingh--head--0.5--patch-2)
diff --git a/ChangeLog b/ChangeLog
index ca24d33..593a395 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -2,6 +2,89 @@
# arch-tag: automatic-ChangeLog--jgoerzen at complete.org--projects/missingh--head--0.5
#
+2004-10-25 04:05:12 GMT John Goerzen <jgoerzen at complete.org> patch-2
+
+ Summary:
+ Removed 3rd-party code imported outside arch
+ Revision:
+ missingh--head--0.5--patch-2
+
+
+ removed 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
+
+ removed 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
+
+
2004-10-25 04:04:09 GMT John Goerzen <jgoerzen at complete.org> patch-1
Summary:
diff --git a/libsrc/MissingH/Hsemail/README b/libsrc/MissingH/Hsemail/README
deleted file mode 100644
index 06aac01..0000000
--- a/libsrc/MissingH/Hsemail/README
+++ /dev/null
@@ -1,47 +0,0 @@
-Parsers for the Internet Message Standard
-=========================================
-
-:Latest Release: hsemail-2004-10-12.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-12.tar.gz: http://cryp.to/hsemail/hsemail-2004-10-12.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
deleted file mode 100644
index b16de04..0000000
--- a/libsrc/MissingH/Hsemail/Rfc2234.hs
+++ /dev/null
@@ -1,185 +0,0 @@
-{- |
- 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 MissingH.Hsemail.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
deleted file mode 100644
index a4cec1c..0000000
--- a/libsrc/MissingH/Hsemail/Rfc2821.hs
+++ /dev/null
@@ -1,507 +0,0 @@
-{- |
- Module : Rfc2821
- Copyright : (c) 2004-10-12 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 MissingH.Hsemail.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, element, name
- , dot_string, atom, dotnum, 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 MissingH.Hsemail.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
- ]
-
--- |\"@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 = (do
- r1 <- local_part
- char '@'
- r2 <- domain
- return (Mailbox [] r1 r2)) <?> "mailbox"
-
-local_part :: CharParser st String
-local_part = (dot_string <|> quoted_string)
- <?> "local-part"
-
-domain :: CharParser st String
-domain = tokenList element '.' <?> "domain"
-
-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"
-
-element :: CharParser st String
-element = (choice
- [ name
- , (char '#' >> number >>= \xs -> return ('#':xs))
- <?> "#-literal"
- , (between (char '[') (char ']') dotnum >>= \xs ->
- return ("[" ++ xs ++ "]")) <?> "domain-literal"
- ]) <?> "domain element"
-
-name :: CharParser st String
-name = (do
- r1 <- alpha
- r2 <- many1 (alpha <|> digit <|> char '-')
- let r = r1 : r2
- if (last r == '-')
- then fail "name must not end with hyphen"
- else return r) <?> "domain name"
-
-dot_string :: CharParser st String
-dot_string = tokenList atom '.' <?> "dot_string"
-
-atom :: CharParser a String
-atom = many1 atext <?> "atom"
- where
- atext = alpha <|> digit <|> oneOf "!#$%&'*+-/=?^_`{|}~"
-
-dotnum :: CharParser st String
-dotnum = (do
- r1 <- snum
- char '.'
- r2 <- snum
- char '.'
- r3 <- snum
- char '.'
- r4 <- snum
- return (r1 ++ "." ++ r2 ++ "." ++ r3 ++ "." ++ r4))
- <?> "IP address"
-
-snum :: CharParser st String
-snum = do
- r <- manyNtoM 1 3 hexdig
- 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
- = SayHelo String
- | SayHeloAgain String
- | SayEhlo String
- | SayEhloAgain String
- | SetMailFrom Mailbox
- | AddRcptTo Mailbox
- | StartData
- | NeedHeloFirst
- | NeedMailFromFirst
- | NeedRcptToFirst
- | NotImplemened
- | ResetState
- | SayOK
- | SeeksHelp String
- | Shutdown
- | SyntaxErrorIn String
- | Unrecognized String
- deriving (Eq, Show)
-
--- |Run like this: @'runState' (smtpdFSM \"noop\") HaveHelo at .
-
-type SmtpdFSM = State SessionState Event
-
--- |Calling this function in 'HaveQuit' will fail an
--- assertion -- or, if 'assert' is disabled, return
--- 'Shutdown' again. Inputs must be terminated with 'crlf'.
--- See 'fixCRLF'.
-
-smtpdFSM :: String -> SmtpdFSM
-smtpdFSM str = either
- (\_ -> return (Unrecognized str))
- (handleSmtpCmd)
- (parse smtpCmd "" str)
-
--- |Transform a command and a session state into an event
--- and a new session state.
-
-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
deleted file mode 100644
index f21d5a0..0000000
--- a/libsrc/MissingH/Hsemail/Rfc2822.hs
+++ /dev/null
@@ -1,1403 +0,0 @@
-{- |
- 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 MissingH.Hsemail.Rfc2822 where
-
-import Text.ParserCombinators.Parsec
-import Data.Char ( ord )
-import Data.List ( intersperse )
-import System.Time
-import MissingH.Hsemail.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
deleted file mode 100644
index 7f697ac..0000000
--- a/libsrc/MissingH/Wash/Mail/Email.hs
+++ /dev/null
@@ -1,111 +0,0 @@
--- © 2001, 2002 Peter Thiemann
-module MissingH.Wash.Mail.Email (
- sendmail, inventMessageId, exitcodeToSYSEXIT, SYSEXIT(..),
- module MissingH.Wash.Mail.MIME,
- module MissingH.Wash.Mail.HeaderField) where
-
--- from standard library
-import IO
-import System
-
--- from utility
-import MissingH.Wash.Utility.Auxiliary
-import MissingH.Wash.Utility.Unique
-
--- from package
-import MissingH.Wash.Mail.EmailConfig
-import MissingH.Wash.Mail.HeaderField
-import MissingH.Wash.Mail.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
deleted file mode 100644
index 08cbb11..0000000
--- a/libsrc/MissingH/Wash/Mail/EmailConfig.hs
+++ /dev/null
@@ -1,13 +0,0 @@
-module MissingH.Wash.Mail.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
deleted file mode 100644
index 5666869..0000000
--- a/libsrc/MissingH/Wash/Mail/HeaderField.hs
+++ /dev/null
@@ -1,53 +0,0 @@
-module MissingH.Wash.Mail.HeaderField where
-
-import MissingH.Wash.Utility.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
deleted file mode 100644
index b16110c..0000000
--- a/libsrc/MissingH/Wash/Mail/LICENSE
+++ /dev/null
@@ -1,30 +0,0 @@
-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
deleted file mode 100644
index 8554de5..0000000
--- a/libsrc/MissingH/Wash/Mail/MIME.hs
+++ /dev/null
@@ -1,185 +0,0 @@
--- © 2001, 2002 Peter Thiemann
-module MissingH.Wash.Mail.MIME where
--- RFC 2045
--- RFC 2046
-
-import IO
-import Random
-import Char
-
-import qualified MissingH.Wash.Utility.Base64 as Base64
-import qualified MissingH.Wash.Utility.QuotedPrintable as QuotedPrintable
-import MissingH.Wash.Mail.HeaderField
-import qualified MissingH.Wash.Utility.RFC2279 as 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
deleted file mode 100644
index 2f378d0..0000000
--- a/libsrc/MissingH/Wash/Mail/MailParser.hs
+++ /dev/null
@@ -1,360 +0,0 @@
-module MissingH.Wash.Mail.MailParser where
-
--- see RFC 2822
--- TODO: check against their definition of token
-import Char
-import List
-import Maybe
---
-import Text.ParserCombinators.Parsec
---
-import qualified MissingH.Wash.Utility.Base64 as Base64
-import qualified MissingH.Wash.Utility.QuotedPrintable as QuotedPrintable
-import qualified MissingH.Wash.Utility.RFC2047 as RFC2047
-import MissingH.Wash.Utility.RFC2047 (p_token)
-import MissingH.Wash.Mail.Message
-import MissingH.Wash.Mail.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
deleted file mode 100644
index ee69abd..0000000
--- a/libsrc/MissingH/Wash/Mail/Message.hs
+++ /dev/null
@@ -1,78 +0,0 @@
-module MissingH.Wash.Mail.Message where
-
-import MissingH.Wash.Mail.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
deleted file mode 100644
index 15cab7a..0000000
--- a/libsrc/MissingH/Wash/Utility/Auxiliary.hs
+++ /dev/null
@@ -1,43 +0,0 @@
-module MissingH.Wash.Utility.Auxiliary where
-
-import IO
-import System
-import Directory
-import MissingH.Wash.Utility.FileNames
-import qualified MissingH.Wash.Utility.Shell as 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
deleted file mode 100644
index dea78bf..0000000
--- a/libsrc/MissingH/Wash/Utility/Base32.hs
+++ /dev/null
@@ -1,96 +0,0 @@
--- Base32 standard:
--- http://www.ietf.org/rfc/rfc3548.txt
--- Author: Niklas Deutschmann
-
-module MissingH.Wash.Utility.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
deleted file mode 100644
index afe6326..0000000
--- a/libsrc/MissingH/Wash/Utility/Base64.hs
+++ /dev/null
@@ -1,124 +0,0 @@
--- © 2002 Peter Thiemann
--- |Implements RFC 2045 MIME coding.
-module MissingH.Wash.Utility.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
deleted file mode 100644
index 7a161db..0000000
--- a/libsrc/MissingH/Wash/Utility/FileNames.hs
+++ /dev/null
@@ -1,47 +0,0 @@
-module MissingH.Wash.Utility.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
deleted file mode 100644
index 4da2185..0000000
--- a/libsrc/MissingH/Wash/Utility/Hex.hs
+++ /dev/null
@@ -1,49 +0,0 @@
--- © 2001, 2003 Peter Thiemann
-module MissingH.Wash.Utility.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
deleted file mode 100644
index 0df774e..0000000
--- a/libsrc/MissingH/Wash/Utility/ISO8601.hs
+++ /dev/null
@@ -1,758 +0,0 @@
--- © 2002 Peter Thiemann
-module MissingH.Wash.Utility.ISO8601 where
-
-import Char
-import Monad
-import Time
-
-import System.IO.Unsafe
-
-import MissingH.Wash.Utility.IntToString
-import MissingH.Wash.Utility.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
deleted file mode 100644
index ea0f497..0000000
--- a/libsrc/MissingH/Wash/Utility/IntToString.hs
+++ /dev/null
@@ -1,10 +0,0 @@
--- © 2002 Peter Thiemann
-module MissingH.Wash.Utility.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
deleted file mode 100644
index ae9493e..0000000
--- a/libsrc/MissingH/Wash/Utility/JavaScript.hs
+++ /dev/null
@@ -1,27 +0,0 @@
--- © 2003 Peter Thiemann
-module MissingH.Wash.Utility.JavaScript where
-
-import Char
-
-import MissingH.Wash.Utility.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
deleted file mode 100644
index b16110c..0000000
--- a/libsrc/MissingH/Wash/Utility/LICENSE
+++ /dev/null
@@ -1,30 +0,0 @@
-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
deleted file mode 100644
index 46c7bf7..0000000
--- a/libsrc/MissingH/Wash/Utility/Locking.hs
+++ /dev/null
@@ -1,36 +0,0 @@
-module MissingH.Wash.Utility.Locking (obtainLock, releaseLock) where
-
-import MissingH.Wash.Utility.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
deleted file mode 100644
index 8d70333..0000000
--- a/libsrc/MissingH/Wash/Utility/QuotedPrintable.hs
+++ /dev/null
@@ -1,49 +0,0 @@
-module MissingH.Wash.Utility.QuotedPrintable
- (encode, encode', decode
- -- deprecated: encode_quoted, encode_quoted', decode_quoted
- ) where
-
-import Char
-import MissingH.Wash.Utility.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
deleted file mode 100644
index a8548b6..0000000
--- a/libsrc/MissingH/Wash/Utility/RFC2047.hs
+++ /dev/null
@@ -1,71 +0,0 @@
-module MissingH.Wash.Utility.RFC2047 where
--- decoding of header fields
-import Char
-import List
-
-import qualified MissingH.Wash.Utility.Base64 as Base64
-import qualified MissingH.Wash.Utility.QuotedPrintable as QuotedPrintable
-import MissingH.Wash.Utility.Hex
-import Text.ParserCombinators.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
deleted file mode 100644
index d0a7470..0000000
--- a/libsrc/MissingH/Wash/Utility/RFC2279.hs
+++ /dev/null
@@ -1,110 +0,0 @@
--- © 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 MissingH.Wash.Utility.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
deleted file mode 100644
index 9b881c1..0000000
--- a/libsrc/MissingH/Wash/Utility/RFC2397.hs
+++ /dev/null
@@ -1,67 +0,0 @@
-module MissingH.Wash.Utility.RFC2397 where
-
-import MissingH.Wash.Utility.URLCoding
-import MissingH.Wash.Utility.Base64
-
-import qualified MissingH.Wash.Utility.Base64 as Base64
-import qualified MissingH.Wash.Utility.URLCoding as URLCoding
-
-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
deleted file mode 100644
index b2e8c82..0000000
--- a/libsrc/MissingH/Wash/Utility/Shell.hs
+++ /dev/null
@@ -1,20 +0,0 @@
--- © 2002 Peter Thiemann
--- |Defines functions for shell quotation.
-module MissingH.Wash.Utility.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
deleted file mode 100644
index 7e78126..0000000
--- a/libsrc/MissingH/Wash/Utility/SimpleParser.hs
+++ /dev/null
@@ -1,60 +0,0 @@
--- © 2002 Peter Thiemann
-module MissingH.Wash.Utility.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
deleted file mode 100644
index 562b2f6..0000000
--- a/libsrc/MissingH/Wash/Utility/URLCoding.hs
+++ /dev/null
@@ -1,26 +0,0 @@
--- © 2001, 2002 Peter Thiemann
--- |Implements coding of non-alphanumeric characters in URLs and CGI-requests.
-module MissingH.Wash.Utility.URLCoding (encode, decode) where
-
-import Char
-import MissingH.Wash.Utility.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
deleted file mode 100644
index dfac033..0000000
--- a/libsrc/MissingH/Wash/Utility/Unique.hs
+++ /dev/null
@@ -1,67 +0,0 @@
--- © 2001 Peter Thiemann
-module MissingH.Wash.Utility.Unique (inventStdKey, inventKey, inventFilePath) where
-
-import Random
-import IO
-import Directory
-import MissingH.Wash.Utility.Auxiliary
-import List
-import Monad
-import MissingH.Wash.Utility.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