[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 15:19:56 UTC 2010
The following commit has been merged in the master branch:
commit 897016cdc39eca64b1088dec080db0ba7e1cc162
Author: John Goerzen <jgoerzen at complete.org>
Date: Wed Dec 6 23:12:21 2006 +0100
Remove WASH code
diff --git a/src/Data/Codec/Base32.hs b/src/Data/Codec/Base32.hs
deleted file mode 100644
index 0c51499..0000000
--- a/src/Data/Codec/Base32.hs
+++ /dev/null
@@ -1,96 +0,0 @@
--- Base32 standard:
--- http://www.ietf.org/rfc/rfc3548.txt
--- Author: Niklas Deutschmann
-
-module Data.Codec.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/src/Data/Codec/Base64.hs b/src/Data/Codec/Base64.hs
deleted file mode 100644
index 7edc2ce..0000000
--- a/src/Data/Codec/Base64.hs
+++ /dev/null
@@ -1,124 +0,0 @@
--- © 2002 Peter Thiemann
--- |Implements RFC 2045 MIME coding.
-module Data.Codec.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/src/Network/Email/Message.hs b/src/Network/Email/Message.hs
deleted file mode 100644
index 3261086..0000000
--- a/src/Network/Email/Message.hs
+++ /dev/null
@@ -1,82 +0,0 @@
-module Network.Email.Message where
-
-import Network.Email.Message.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 :: Message -> Bool
-isSinglePart (Singlepart {}) = True
-isSinglePart _ = False
-
-isMultiPart :: Message -> Bool
-isMultiPart (Multipart {}) = True
-isMultiPart _ = False
-
-showHeader :: Header -> String
-showHeader (Header (n, v)) = n ++ ": " ++ v
-
-showParameters :: [(String, String)] -> String -> String
-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/src/Network/Email/Message/HeaderField.hs b/src/Network/Email/Message/HeaderField.hs
deleted file mode 100644
index 4dcacf5..0000000
--- a/src/Network/Email/Message/HeaderField.hs
+++ /dev/null
@@ -1,53 +0,0 @@
-module Network.Email.Message.HeaderField where
-
-import Network.Email.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/src/Network/Email/Message/MIME.hs b/src/Network/Email/Message/MIME.hs
deleted file mode 100644
index c7ce741..0000000
--- a/src/Network/Email/Message/MIME.hs
+++ /dev/null
@@ -1,185 +0,0 @@
--- © 2001, 2002 Peter Thiemann
-module Network.Email.Message.MIME where
--- RFC 2045
--- RFC 2046
-
-import IO
-import Random
-import Char
-
-import qualified Data.Codec.Base64 as Base64
-import qualified Network.Email.Message.QuotedPrintable as QuotedPrintable
-import Network.Email.Message.HeaderField
-import qualified Network.Email.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/src/Network/Email/Message/Parser.hs b/src/Network/Email/Message/Parser.hs
deleted file mode 100644
index 27684dc..0000000
--- a/src/Network/Email/Message/Parser.hs
+++ /dev/null
@@ -1,371 +0,0 @@
-module Network.Email.Message.Parser where
-
--- see RFC 2822
--- TODO: check against their definition of token
-import Char
-import List
-import Maybe
---
-import Text.ParserCombinators.Parsec
---
-import qualified Data.Codec.Base64 as Base64
-import qualified Network.Email.Message.QuotedPrintable as QuotedPrintable
-import qualified Network.Email.Utility.RFC2047 as RFC2047
-import Network.Email.Utility.RFC2047 (p_token)
-import Network.Email.Message
-import Network.Email.Message.HeaderField
-
-parseMessageFromFile :: FilePath -> IO (Either ParseError RawMessage)
-parseMessageFromFile fname =
- parseFromFile message fname
-
-parseMessageFromString :: String -> Either ParseError RawMessage
-parseMessageFromString str =
- parse message "MailParser" str
-
-parseDateTimeFromString :: String -> Either ParseError DateTime2822
-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 <- parseOneOrTwoDigits
- 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)
-
-parseOneOrTwoDigits =
- do d1 <- digit
- md2 <- option Nothing (digit >>= (return . Just))
- case md2 of
- Just d2 ->
- return (10 * digitToInt d1 + digitToInt d2)
- Nothing ->
- return (digitToInt d1)
diff --git a/src/Network/Email/Message/QuotedPrintable.hs b/src/Network/Email/Message/QuotedPrintable.hs
deleted file mode 100644
index d65421c..0000000
--- a/src/Network/Email/Message/QuotedPrintable.hs
+++ /dev/null
@@ -1,49 +0,0 @@
-module Network.Email.Message.QuotedPrintable
- (encode, encode', decode
- -- deprecated: encode_quoted, encode_quoted', decode_quoted
- ) where
-
-import Char
-import Network.Email.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/src/Network/Email/Utility/Auxiliary.hs b/src/Network/Email/Utility/Auxiliary.hs
deleted file mode 100644
index 114cb85..0000000
--- a/src/Network/Email/Utility/Auxiliary.hs
+++ /dev/null
@@ -1,43 +0,0 @@
-module Network.Email.Utility.Auxiliary where
-
-import IO
-import System
-import Directory
-import Network.Email.Utility.FileNames
-import qualified Network.Email.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/src/Network/Email/Utility/FileNames.hs b/src/Network/Email/Utility/FileNames.hs
deleted file mode 100644
index 8ea724d..0000000
--- a/src/Network/Email/Utility/FileNames.hs
+++ /dev/null
@@ -1,47 +0,0 @@
-module Network.Email.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/src/Network/Email/Utility/Hex.hs b/src/Network/Email/Utility/Hex.hs
deleted file mode 100644
index 654b0fa..0000000
--- a/src/Network/Email/Utility/Hex.hs
+++ /dev/null
@@ -1,49 +0,0 @@
--- © 2001, 2003 Peter Thiemann
-module Network.Email.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/src/Network/Email/Utility/IntToString.hs b/src/Network/Email/Utility/IntToString.hs
deleted file mode 100644
index ca23d1e..0000000
--- a/src/Network/Email/Utility/IntToString.hs
+++ /dev/null
@@ -1,10 +0,0 @@
--- © 2002 Peter Thiemann
-module Network.Email.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/src/Network/Email/Utility/JavaScript.hs b/src/Network/Email/Utility/JavaScript.hs
deleted file mode 100644
index cb8f64a..0000000
--- a/src/Network/Email/Utility/JavaScript.hs
+++ /dev/null
@@ -1,27 +0,0 @@
--- © 2003 Peter Thiemann
-module Network.Email.Utility.JavaScript where
-
-import Char
-
-import Network.Email.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/src/Network/Email/Utility/RFC2047.hs b/src/Network/Email/Utility/RFC2047.hs
deleted file mode 100644
index c6e133f..0000000
--- a/src/Network/Email/Utility/RFC2047.hs
+++ /dev/null
@@ -1,71 +0,0 @@
-module Network.Email.Utility.RFC2047 where
--- decoding of header fields
-import Char
-import List
-
-import qualified Data.Codec.Base64 as Base64
-import qualified Network.Email.Message.QuotedPrintable as QuotedPrintable
-import Network.Email.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/src/Network/Email/Utility/RFC2279.hs b/src/Network/Email/Utility/RFC2279.hs
deleted file mode 100644
index 935868b..0000000
--- a/src/Network/Email/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 Network.Email.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/src/Network/Email/Utility/RFC2397.hs b/src/Network/Email/Utility/RFC2397.hs
deleted file mode 100644
index 55c077d..0000000
--- a/src/Network/Email/Utility/RFC2397.hs
+++ /dev/null
@@ -1,67 +0,0 @@
-module Network.Email.Utility.RFC2397 where
-
-import Network.Email.Utility.URLCoding
-import Data.Codec.Base64
-
-import qualified Data.Codec.Base64 as Base64
-import qualified Network.Email.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/src/Network/Email/Utility/Shell.hs b/src/Network/Email/Utility/Shell.hs
deleted file mode 100644
index b05ab0a..0000000
--- a/src/Network/Email/Utility/Shell.hs
+++ /dev/null
@@ -1,20 +0,0 @@
--- © 2002 Peter Thiemann
--- |Defines functions for shell quotation.
-module Network.Email.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/src/Network/Email/Utility/SimpleParser.hs b/src/Network/Email/Utility/SimpleParser.hs
deleted file mode 100644
index 0c88000..0000000
--- a/src/Network/Email/Utility/SimpleParser.hs
+++ /dev/null
@@ -1,60 +0,0 @@
--- © 2002 Peter Thiemann
-module Network.Email.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/src/Network/Email/Utility/URLCoding.hs b/src/Network/Email/Utility/URLCoding.hs
deleted file mode 100644
index 6c33c5f..0000000
--- a/src/Network/Email/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 Network.Email.Utility.URLCoding (encode, decode) where
-
-import Char
-import Network.Email.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/src/Network/Email/Utility/Unique.hs b/src/Network/Email/Utility/Unique.hs
deleted file mode 100644
index 652323f..0000000
--- a/src/Network/Email/Utility/Unique.hs
+++ /dev/null
@@ -1,67 +0,0 @@
--- © 2001 Peter Thiemann
-module Network.Email.Utility.Unique (inventStdKey, inventKey, inventFilePath) where
-
-import Random
-import IO
-import Directory
-import Network.Email.Utility.Auxiliary
-import List
-import Monad
-import System.IO.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 ""
diff --git a/src/System/IO/Locking.hs b/src/System/IO/Locking.hs
deleted file mode 100644
index 619c5f5..0000000
--- a/src/System/IO/Locking.hs
+++ /dev/null
@@ -1,36 +0,0 @@
-module System.IO.Locking (obtainLock, releaseLock) where
-
-import Network.Email.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/src/System/Time/ISO8601.hs b/src/System/Time/ISO8601.hs
deleted file mode 100644
index 783612e..0000000
--- a/src/System/Time/ISO8601.hs
+++ /dev/null
@@ -1,758 +0,0 @@
--- © 2002 Peter Thiemann
-module System.Time.ISO8601 where
-
-import Char
-import Monad
-import Time
-
-import System.IO.Unsafe
-
-import Network.Email.Utility.IntToString
-import Network.Email.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)
-
--
haskell-testpack
More information about the Pkg-haskell-commits
mailing list