[Pkg-haskell-commits] [SCM] haskell-testpack branch, master, updated. debian/1.0.2-1-4-gb0d6b36
John Goerzen
jgoerzen at complete.org
Fri Apr 23 14:44:51 UTC 2010
The following commit has been merged in the master branch:
commit 88f08ec9b0042e0e06ea3a6063a4cffb9210ef96
Author: John Goerzen <jgoerzen at complete.org>
Date: Wed Oct 20 08:21:37 2004 +0100
Imported main Wash stuff
Keywords:
(jgoerzen at complete.org--projects/missingh--head--1.0--patch-79)
diff --git a/ChangeLog b/ChangeLog
index d0c2619..2424cfa 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -2,6 +2,69 @@
# arch-tag: automatic-ChangeLog--jgoerzen at complete.org--projects/missingh--head--1.0
#
+2004-10-20 02:21:37 GMT John Goerzen <jgoerzen at complete.org> patch-79
+
+ Summary:
+ Imported main Wash stuff
+ Revision:
+ missingh--head--1.0--patch-79
+
+
+ new files:
+ 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/Makefile.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/SHA1.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/.arch-ids/sha1lib.c.id
+ libsrc/MissingH/Wash/Utility/.arch-ids/sha1lib.h.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/Makefile
+ 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/SHA1.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
+ libsrc/MissingH/Wash/Utility/sha1lib.c
+ libsrc/MissingH/Wash/Utility/sha1lib.h
+
+ modified files:
+ ChangeLog libsrc/MissingH/Wash/Mail/Email.hs
+
+ new directories:
+ libsrc/MissingH/Wash/Utility
+ libsrc/MissingH/Wash/Utility/.arch-ids
+
+
2004-10-20 02:19:56 GMT John Goerzen <jgoerzen at complete.org> patch-78
Summary:
diff --git a/libsrc/MissingH/Wash/Mail/Email.hs b/libsrc/MissingH/Wash/Mail/Email.hs
index ba44403..4cde469 100644
--- a/libsrc/MissingH/Wash/Mail/Email.hs
+++ b/libsrc/MissingH/Wash/Mail/Email.hs
@@ -1,6 +1,6 @@
-- © 2001, 2002 Peter Thiemann
-module MissingH.WASHMail.Email (
- sendmail, inventMessageId, exitcodeToSYSEXIT,
+module Email (
+ sendmail, inventMessageId, exitcodeToSYSEXIT, SYSEXIT(..),
module MIME, module HeaderField) where
-- from standard library
@@ -12,9 +12,9 @@ import Auxiliary
import Unique
-- from package
-import MissingH.WASHMail.EmailConfig
-import MissingH.WASHMail.HeaderField
-import MissihgH.WASHMail.MIME
+import EmailConfig
+import HeaderField
+import MIME
-- |from sysexit.h
data SYSEXIT =
diff --git a/libsrc/MissingH/Wash/Utility/Auxiliary.hs b/libsrc/MissingH/Wash/Utility/Auxiliary.hs
new file mode 100644
index 0000000..d6d85c7
--- /dev/null
+++ b/libsrc/MissingH/Wash/Utility/Auxiliary.hs
@@ -0,0 +1,43 @@
+module Auxiliary where
+
+import IO
+import System
+import Directory
+import FileNames
+import qualified Shell
+
+protectedGetEnv :: String -> String -> IO String
+protectedGetEnv var deflt =
+ catch (getEnv var) (const $ return deflt)
+
+readFileNonExistent :: FilePath -> String -> IO String
+readFileNonExistent fileName def =
+ do existent <- doesFileExist fileName
+ if existent then readFile fileName else return def
+
+readFileStrictly :: FilePath -> IO String
+readFileStrictly filePath =
+ do h <- openFile filePath ReadMode
+ contents <- hGetContents h
+ hClose (g contents h)
+ return contents
+ where
+ g [] h = h
+ g (_:rest) h = g rest h
+
+assertDirectoryExists :: FilePath -> IO () -> IO ()
+assertDirectoryExists dirname existsAction =
+ catch (createDirectory dirname)
+ (\ ioe ->
+ if isAlreadyExistsError ioe then existsAction
+ else if isDoesNotExistError ioe then
+ do assertDirectoryExists (dropLastComponent dirname) (return ())
+ assertDirectoryExists dirname existsAction
+ else do hPutStrLn stderr ("assertDirectoryExists " ++ show dirname)
+ ioError ioe)
+
+writeDebugFile :: String -> String -> IO ()
+writeDebugFile filename str =
+ do writeFile filename str
+ system ("chmod 666 " ++ Shell.quote filename)
+ return ()
diff --git a/libsrc/MissingH/Wash/Utility/Base32.hs b/libsrc/MissingH/Wash/Utility/Base32.hs
new file mode 100644
index 0000000..98898ee
--- /dev/null
+++ b/libsrc/MissingH/Wash/Utility/Base32.hs
@@ -0,0 +1,96 @@
+-- Base32 standard:
+-- http://www.ietf.org/rfc/rfc3548.txt
+-- Author: Niklas Deutschmann
+
+module Base32 (encode, decode) where
+
+import Bits
+import Char
+import List
+
+encode :: String -> String
+encode = encBase32
+
+decode :: String -> String
+decode = decBase32
+
+-- Partitions a list into groups of length n.
+makeGroups :: Int -> [a] -> [[a]]
+makeGroups 0 lst = error "makeGroups: Invalid group length"
+makeGroups n [] = []
+makeGroups n lst = take n lst : makeGroups n (drop n lst)
+
+-- Converts an array of characters to a large number, generalized for
+-- characters of any number of bits and any alphabet.
+-- charLength: Number of bits in a character
+-- ordFunc: Function that is used for mapping characters to numbers.
+makeBits charLength ordFunc str = foldr (+) 0 bitValues
+ where
+ bitValues = zipWith (\a b -> intVal a `shiftL` b) (reverse str) [0,charLength..]
+ intVal a = toInteger (ordFunc a)
+
+makeBitsASCII = makeBits 8 ord
+makeBitsBase32 = makeBits 5 b32Ord
+
+-- Converts an array of characters into a m-bit number, where m is
+-- is smallest multiple of n that is greater or equal to the
+-- (length of str) * chrSize.
+-- Extension of "makeBits".
+makeMultipleOfNBits bitFunc charSize n str
+ | len `mod` n == 0 = bitFunc str
+ | otherwise = (bitFunc str) `shiftL` (remBitCount len)
+ where
+ remBitCount m = (0 - (m `mod` n) + n) `mod` n
+ len = length str * charSize;
+
+makeMultipleOfNBitsASCII = makeMultipleOfNBits (makeBits 8 ord) 8
+makeMultipleOfNBitsBase32 = makeMultipleOfNBits (makeBits 5 b32Ord) 5
+
+-- The Base32 alphabet
+-- Int -> Base32 character
+b32Chr n = b32tab !! (fromEnum n)
+ where
+ b32tab = ['A'..'Z'] ++ ['2'..'7']
+
+-- Base32 character -> Int
+b32Ord c
+ | c >= 'A' && c <= 'Z' = ord(c) - 65
+ | c >= '2' && c <= '7' = ord(c) - 24
+ | otherwise = error "b32Ord: No Base character"
+
+-- Encodes one block (1-5 ASCII Characters)
+encBase32Block str
+ | len == 0 = ""
+ | len == 1 = concat (b32Map [5,0]) ++ "======"
+ | len == 2 = concat (b32Map [15,10..0]) ++ "===="
+ | len == 3 = concat (b32Map [20,15..0]) ++ "==="
+ | len == 4 = concat (b32Map [30,25..0]) ++ "="
+ | len == 5 = concat (b32Map [35,30..0])
+ | otherwise = error "encBase32Block: Invalid block length"
+ where
+ b32Map = map (\x -> [b32Chr(bitStr `shiftR` x .&. 31)])
+ bitStr = makeMultipleOfNBitsASCII 5 str
+ len = length str
+
+-- Decodes one block (2,4,5,7 or 8 Base32 character + '=' padding character)
+decBase32Block str
+ | len == 0 = ""
+ | len == 2 = concat . (shiftAndMap [0] 2) . makeBitsBase32 $ code
+ | len == 4 = concat . (shiftAndMap [8,0] 4) . makeBitsBase32 $ code
+ | len == 5 = concat . (shiftAndMap [16,8,0] 1) . makeBitsBase32 $ code
+ | len == 7 = concat . (shiftAndMap [24,16..0] 3) . makeBitsBase32 $ code
+ | len == 8 = concat . (shiftAndMap [32,24..0] 0) . makeBitsBase32 $ code
+ | otherwise = error "decBase32Block: Invalid block length"
+ where
+ shiftAndMap sf n = (asciiMap sf) . (`shiftR` n)
+ asciiMap sf c = map (\x -> [chr . fromEnum $ (c `shiftR` x .&. 255)]) sf
+ len = length code
+ code = filter (/= '=') str
+
+encBase32 :: String -> String
+encBase32 = concat . map encBase32Block . makeGroups 5
+
+decBase32 :: String -> String
+decBase32 = concat . map decBase32Block . makeGroups 8
+
+
diff --git a/libsrc/MissingH/Wash/Utility/Base64.hs b/libsrc/MissingH/Wash/Utility/Base64.hs
new file mode 100644
index 0000000..c55a4f1
--- /dev/null
+++ b/libsrc/MissingH/Wash/Utility/Base64.hs
@@ -0,0 +1,124 @@
+-- © 2002 Peter Thiemann
+-- |Implements RFC 2045 MIME coding.
+module Base64
+ (encode, encode', decode, decode'
+ ,alphabet_list
+ )
+ where
+
+import Array
+import Char
+
+--
+-- |Yields encoded input cropped to lines of less than 76 characters. Directly
+-- usable as email body.
+encode :: String -> String
+encode = encode_base64
+-- |yields continuous stream of bytes.
+encode' :: String -> String
+encode' = encode_base64'
+-- |Directly applicable to email body.
+decode :: String -> String
+decode = decode_base64
+-- |Only applicable to stream of Base64 characters.
+decode' :: String -> String
+decode' = decode_base64'
+-- |Applicable to list of lines.
+decode_lines :: [String] -> String
+decode_lines = decode_base64_lines
+
+-- --------------------------------------------------------------------
+-- |Base64 alphabet in encoding order.
+alphabet_list :: String
+alphabet_list =
+ "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"
+
+encode_base64_alphabet_index =
+ zip [0 .. (63::Int)] alphabet_list
+
+decode_base64_alphabet_index =
+ zip alphabet_list [0 .. (63::Int)]
+
+encode_base64_alphabet =
+ array (0 :: Int, 63 :: Int) encode_base64_alphabet_index
+
+decode_base64_alphabet =
+ array (' ','z') decode_base64_alphabet_index
+
+base64_character =
+ array (chr 0, chr 255) [(c, c `elem` alphabet_list || c == '=') | c <- [chr 0 .. chr 255]]
+
+encode_base64 = linebreak 76 . encode_base64'
+
+linebreak m xs = lb m xs
+ where
+ lb n [] = "\r\n"
+ lb 0 xs = '\r':'\n': lb m xs
+ lb n (x:xs) = x: lb (n-1) xs
+
+encode_base64' [] = []
+
+encode_base64' [ch] =
+ encode_base64_alphabet!b1 :
+ encode_base64_alphabet!b2 :
+ "=="
+ where (b1, b2, _, _) = encode_base64_group (ch, chr 0, chr 0)
+
+encode_base64' [ch1, ch2] =
+ encode_base64_alphabet!b1 :
+ encode_base64_alphabet!b2 :
+ encode_base64_alphabet!b3 :
+ "="
+ where (b1, b2, b3, _) = encode_base64_group (ch1, ch2, chr 0)
+
+encode_base64' (ch1: ch2: ch3: rest) =
+ encode_base64_alphabet!b1 :
+ encode_base64_alphabet!b2 :
+ encode_base64_alphabet!b3 :
+ encode_base64_alphabet!b4 :
+ encode_base64' rest
+ where (b1, b2, b3, b4) = encode_base64_group (ch1, ch2, ch3)
+
+-- 111111 112222 222233 333333
+encode_base64_group (ch1, ch2, ch3) = (b1, b2, b3, b4)
+ where o1 = ord ch1
+ o2 = ord ch2
+ o3 = ord ch3
+ b1 = o1 `div` 4
+ b2 = (o1 `mod` 4) * 16 + o2 `div` 16
+ b3 = (o2 `mod` 16) * 4 + o3 `div` 64
+ b4 = o3 `mod` 64
+
+decode_base64_group (b1, b2, b3, b4) = (ch1, ch2, ch3)
+ where ch1 = chr (b1 * 4 + b2 `div` 16)
+ ch2 = chr (b2 `mod` 16 * 16 + b3 `div` 4)
+ ch3 = chr (b3 `mod` 4 * 64 + b4)
+
+decode_base64' [] = []
+
+decode_base64' [cin1, cin2, '=', '='] = [cout1]
+ where (cout1, _, _) =
+ decode_base64_group (decode_base64_alphabet!cin1
+ ,decode_base64_alphabet!cin2
+ ,0
+ ,0)
+
+decode_base64' [cin1, cin2, cin3, '='] = [cout1, cout2]
+ where (cout1, cout2, _) =
+ decode_base64_group (decode_base64_alphabet!cin1
+ ,decode_base64_alphabet!cin2
+ ,decode_base64_alphabet!cin3
+ ,0)
+
+decode_base64' (cin1: cin2: cin3: cin4: rest) =
+ cout1: cout2: cout3: decode_base64' rest
+ where (cout1, cout2, cout3) =
+ decode_base64_group (decode_base64_alphabet!cin1
+ ,decode_base64_alphabet!cin2
+ ,decode_base64_alphabet!cin3
+ ,decode_base64_alphabet!cin4)
+
+decode_base64 = decode_base64' . filter (base64_character!)
+
+decode_base64_lines = decode_base64' . concat
+
diff --git a/libsrc/MissingH/Wash/Utility/FileNames.hs b/libsrc/MissingH/Wash/Utility/FileNames.hs
new file mode 100644
index 0000000..ea99240
--- /dev/null
+++ b/libsrc/MissingH/Wash/Utility/FileNames.hs
@@ -0,0 +1,47 @@
+module FileNames where
+
+longestSuffix :: (a -> Bool) -> [a] -> [a]
+longestSuffix p xs =
+ let f [] suffix = suffix
+ f (x : xs) suffix = f xs (if p x then xs else suffix)
+ in f xs xs
+
+
+-- |longest suffix of path that does not contain '/'
+filePart :: String -> String
+filePart =
+ longestSuffix (=='/')
+
+-- |longest suffix of path that does not contain '.'
+extName :: String -> String
+extName =
+ longestSuffix (=='.')
+
+-- |longest prefix so that the rest contains '.'; entire string if no '.' present
+baseName :: String -> String
+baseName filename =
+ let f "" = ""
+ f ('.':rest) = g rest rest
+ f (x:rest) = x:f rest
+ g "" lst = ""
+ g ('.':rest) lst = '.':f lst
+ g (x:rest) lst = g rest lst
+ in f filename
+
+-- |splits input at each '/'
+fileToPath :: String -> [String]
+fileToPath filename =
+ let f acc path "" = reverse (reverse acc: path)
+ f acc path ('/':xs) = f "" (reverse acc: path) xs
+ f acc path (x:xs) = f (x:acc) path xs
+ in f "" [] filename
+
+-- |drop the last component of a file path
+dropLastComponent :: String -> String
+dropLastComponent path =
+ let f "" = ""
+ f rpath = g rpath
+ g ('/':rest) = g rest
+ g "" = "/"
+ g rpath = dropWhile (/='/') rpath
+ in reverse (f (reverse path))
diff --git a/libsrc/MissingH/Wash/Utility/Hex.hs b/libsrc/MissingH/Wash/Utility/Hex.hs
new file mode 100644
index 0000000..d1f1609
--- /dev/null
+++ b/libsrc/MissingH/Wash/Utility/Hex.hs
@@ -0,0 +1,49 @@
+-- © 2001, 2003 Peter Thiemann
+module Hex where
+
+import Array
+import Char
+
+hexdigit :: Int -> Char
+hexdigit i = hexdigits ! i
+
+hexdigits' = "0123456789ABCDEF"
+alternative_digits = "abcdef"
+alternative_indices :: [(Int, Char)]
+alternative_indices = zip [10..15] alternative_digits
+hexdigits'_indices :: [(Int, Char)]
+hexdigits'_indices = [(i, hexdigits'!!i) | i <- [0..15]]
+
+hexdigits = array (0, 15) hexdigits'_indices
+
+fromHexdigits =
+ array (chr 0, chr 127)
+ (map (\ (x,y) -> (y, x)) (hexdigits'_indices ++ alternative_indices))
+
+isHexdigitArray =
+ array (chr 0, chr 127)
+ (map (\ c -> (c, isHexdigit c)) [chr 0 .. chr 127])
+ where
+ isHexdigit :: Char -> Bool
+ isHexdigit x =
+ (x >= '0' && x <= '9') ||
+ (x >= 'a' && x <= 'f') ||
+ (x >= 'A' && x <= 'F')
+
+isHexdigit :: Char -> Bool
+isHexdigit x =
+ x <= chr 127 && isHexdigitArray ! x
+
+showHex2 :: Int -> String
+showHex2 ox = showsHex 2 ox ""
+
+showsHex :: Int -> Int -> ShowS
+showsHex 0 x = id
+showsHex i x = let (d,m) = x `divMod` 16 in showsHex (i-1) d . showChar (hexdigits ! m)
+
+hexDigitVal :: Char -> Int
+hexDigitVal x | isHexdigit x = fromHexdigits ! x
+ | otherwise = 0
+
+allDigits = hexdigits' ++ alternative_digits
+
diff --git a/libsrc/MissingH/Wash/Utility/ISO8601.hs b/libsrc/MissingH/Wash/Utility/ISO8601.hs
new file mode 100644
index 0000000..8f4f2c7
--- /dev/null
+++ b/libsrc/MissingH/Wash/Utility/ISO8601.hs
@@ -0,0 +1,758 @@
+-- © 2002 Peter Thiemann
+module ISO8601 where
+
+import Char
+import Monad
+import Time
+
+import IOExts
+
+import IntToString
+import SimpleParser
+
+secondsToString seconds =
+ intToString 20 seconds
+
+isoDateToString isoDate =
+ let seconds = unsafePerformIO $ isoDateToSeconds isoDate
+ in secondsToString seconds
+
+isoDateAndTimeToString isoDateAndTime =
+ let seconds = unsafePerformIO $ isoDateAndTimeToSeconds isoDateAndTime
+ in secondsToString seconds
+
+applyToCalT :: (CalendarTime -> a) -> IO a
+applyToCalT g =
+ do clkT <- getClockTime
+ calT <- toCalendarTime clkT
+ return $ g calT
+
+isoDateAndTimeToSeconds :: ISODateAndTime -> IO Integer
+isoDateAndTimeToSeconds isoDateAndTime =
+ applyToCalT $ toSeconds isoDateAndTime
+
+isoTimeToSeconds :: ISOTime -> IO Integer
+isoTimeToSeconds isoTime =
+ applyToCalT $ toSeconds isoTime
+
+isoDateToSeconds :: ISODate -> IO Integer
+isoDateToSeconds isoDate =
+ applyToCalT $ toSeconds isoDate
+
+class ToSeconds iso where
+ -- |returns number of seconds since reference point
+ toSeconds :: iso -> CalendarTime -> Integer
+ toRawSeconds :: iso -> CalendarTime -> Integer
+ --
+ toRawSeconds = toSeconds
+
+instance ToSeconds ISODateAndTime where
+ toSeconds isoDateAndTime@(ISODateAndTime isoDate isoTime) calT =
+ let rawseconds = toRawSeconds isoDateAndTime calT in
+ case addLeapSeconds leapSeconds rawseconds of
+ NotLeapSecond seconds -> seconds
+ LeapSecond seconds -> seconds + leapSecondCorrection isoTime
+
+ toRawSeconds (ISODateAndTime isoDate isoTime) calT =
+ toRawSeconds isoDate calT + toRawSeconds isoTime calT
+
+-- |problem: 19720630T235960 and 19720701T000000 are both mapped to the same
+-- number, 78796800, and then addLeapSeconds adds one yielding 78796801. While
+-- this is correct for 19720701T000000, 19720630T235960 must be
+-- 78796800. Implemented solution: if the current second specification is 0 and
+-- the time to convert is the leap second, then add 1.
+leapSecondCorrection (ISOTime isoHourSpec isoMinuteSpec isoSecondSpec isoTimeZoneSpec) =
+ case isoSecondSpec of
+ Second ss -> if ss == 0 then 1 else 0
+ NoSecond -> 1
+
+instance ToSeconds ISODate where
+ toSeconds isoDate calT =
+ case addLeapSeconds leapSeconds (toRawSeconds isoDate calT) of
+ NotLeapSecond seconds -> seconds
+ LeapSecond seconds -> seconds + 1 -- we always mean 00:00:00
+
+ toRawSeconds (ISODate isoYearSpec isoDayOfYearSpec) calT =
+ let year = isoYearSpecToYear isoYearSpec calT
+ in
+ secondsPerDay * fromIntegral (yearsToDays year) +
+ isoDaysOfYearToSeconds year isoDayOfYearSpec calT
+
+isoDaysOfYearToSeconds year NoDayOfYear calT =
+ 0
+isoDaysOfYearToSeconds year (MonthDay isoMonthSpec isoDayOfMonthSpec) calT =
+ let month = isoMonthSpecToMonth isoMonthSpec calT
+ dayOfMonth = isoDayOfMonthSpecToDayOfMonth isoDayOfMonthSpec calT
+ in
+ fromIntegral(dayOfMonth - 1 + daysUptoMonth year month) * secondsPerDay
+isoDaysOfYearToSeconds year (DayOfYear ddd) calT =
+ fromIntegral ddd * secondsPerDay
+isoDaysOfYearToSeconds year (WeekAndDay (Week ww) NoDayOfWeek) calT =
+ fromIntegral (7 * (ww - 1)) * secondsPerDay
+isoDaysOfYearToSeconds year (WeekAndDay (Week ww) (DayOfWeek d)) calT =
+ let weekdayOfJan1 = yearsToWeekDay year in
+ fromIntegral (7 * (ww - 1) + d - weekdayOfJan1) * secondsPerDay
+isoDaysOfYearToSeconds year (WeekAndDay ImplicitWeek (DayOfWeek d)) calT =
+ let weekdayOfJan1 = yearsToWeekDay year
+ ww = (ctYDay calT + weekdayOfJan1 + 5) `div` 7
+ in
+ fromIntegral (7 * (ww - 1) + d - weekdayOfJan1) * secondsPerDay
+isoDaysOfYearToSeconds year (WeekAndDay _ _) calT =
+ error "Sorry, this combination of week and day does not make sense!"
+
+isoMonthSpecToMonth ImplicitMonth calT =
+ fromEnum (ctMonth calT) + 1
+isoMonthSpecToMonth (Month mm) calT =
+ mm
+
+isoDayOfMonthSpecToDayOfMonth NoDayOfMonth calT =
+ 1
+isoDayOfMonthSpecToDayOfMonth (DayOfMonth dd) calT =
+ dd
+
+daysUptoMonth year month =
+ let daysPerMonth = [31, 28 + leapDays year, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31] in
+ sum (take (month-1) daysPerMonth)
+
+isoYearSpecToYear ImplicitYear calT =
+ (ctYear calT)
+isoYearSpecToYear (ImplicitCentury yy) calT =
+ (100 * (ctYear calT `div` 100) + yy)
+isoYearSpecToYear (Century cc) calT =
+ (100 * cc)
+isoYearSpecToYear (ImplicitDecade y) calT =
+ (10 * (ctYear calT `div` 10) + y)
+isoYearSpecToYear (Year ccyy) calT =
+ ccyy
+
+leapDays year =
+ if leapYear year then 1 else 0
+
+leapYear year =
+ year `mod` 4 == 0 && (year `mod` 100 /= 0 || year `mod` 400 == 0)
+
+yearsToDays ccyy =
+ let nrOfYears = ccyy - 1970
+ leapYears = [ year | year <- [1970 .. ccyy-1] , leapYear year ]
+ nrOfLeapDays = length leapYears
+ in
+ 365 * nrOfYears + nrOfLeapDays
+
+-- |compute weekday of Jan 1
+yearsToWeekDay ccyy =
+ let nrOfDays = yearsToDays ccyy
+ jan_1_1970 = 4 -- Thursday
+ in 1 + (nrOfDays + 6) `mod` 7
+
+-- |in seconds from epoch; needs to be updated when time leaps again
+leapSeconds :: [Integer]
+leapSeconds =
+ [ -- Leap 1972 Jun 30 23:59:60 + S
+ 00000000000078796800,
+ -- Leap 1972 Dec 31 23:59:60 + S
+ 00000000000094694400 + 1,
+ -- Leap 1973 Dec 31 23:59:60 + S
+ 00000000000126230400 + 2,
+ -- Leap 1974 Dec 31 23:59:60 + S
+ 00000000000157766400 + 3,
+ -- Leap 1975 Dec 31 23:59:60 + S
+ 00000000000189302400 + 4,
+ -- Leap 1976 Dec 31 23:59:60 + S
+ 00000000000220924800 + 5,
+ -- Leap 1977 Dec 31 23:59:60 + S
+ 00000000000252460800 + 6,
+ -- Leap 1978 Dec 31 23:59:60 + S
+ 00000000000283996800 + 7,
+ -- Leap 1979 Dec 31 23:59:60 + S
+ 00000000000315532800 + 8,
+ -- Leap 1981 Jun 30 23:59:60 + S
+ 00000000000362793600 + 9,
+ -- Leap 1982 Jun 30 23:59:60 + S
+ 00000000000394329600 + 10,
+ -- Leap 1983 Jun 30 23:59:60 + S
+ 00000000000425865600 + 11,
+ -- Leap 1985 Jun 30 23:59:60 + S
+ 00000000000489024000 + 12,
+ -- Leap 1987 Dec 31 23:59:60 + S
+ 00000000000567993600 + 13,
+ -- Leap 1989 Dec 31 23:59:60 + S
+ 00000000000631152000 + 14,
+ -- Leap 1990 Dec 31 23:59:60 + S
+ 00000000000662688000 + 15,
+ -- Leap 1992 Jun 30 23:59:60 + S
+ 00000000000709948800 + 16,
+ -- Leap 1993 Jun 30 23:59:60 + S
+ 00000000000741484800 + 17,
+ -- Leap 1994 Jun 30 23:59:60 + S
+ 00000000000773020800 + 18,
+ -- Leap 1995 Dec 31 23:59:60 + S
+ 00000000000820454400 + 19,
+ -- Leap 1997 Jun 30 23:59:60 + S
+ 00000000000867715200 + 20,
+ -- Leap 1998 Dec 31 23:59:60 + S
+ 00000000000915148800 + 21
+ ]
+
+data LeapSeconds = LeapSecond Integer | NotLeapSecond Integer
+ deriving Show
+
+addLeapSeconds [] seconds = NotLeapSecond seconds
+addLeapSeconds (ls: rest) seconds =
+ if ls > seconds then NotLeapSecond seconds else
+ if ls == seconds then LeapSecond seconds else
+ addLeapSeconds rest (seconds+1)
+
+secondsPerMinute = 60
+secondsPerHour = 60 * secondsPerMinute
+secondsPerDay = 24 * secondsPerHour
+secondsPerYear = 365 * secondsPerDay
+
+instance ToSeconds ISOTime where
+ -- seconds to 0:00 UTC
+ -- may become negative to indicate previous day!
+ toSeconds (ISOTime isoHourSpec isoMinuteSpec isoSecondSpec isoTimeZoneSpec) calT =
+ toSeconds isoHourSpec calT +
+ toSeconds isoMinuteSpec calT +
+ toSeconds isoSecondSpec calT +
+ toSeconds isoTimeZoneSpec calT
+
+instance ToSeconds ISOHourSpec where
+ toSeconds ImplicitHour calT = fromIntegral (3600 * ctHour calT - ctTZ calT)
+ toSeconds (Hour hh) calT = fromIntegral (3600 * hh - ctTZ calT)
+
+instance ToSeconds ISOMinuteSpec where
+ toSeconds ImplicitMinute calT = fromIntegral (60 * ctMin calT)
+ toSeconds (Minute mm) calT = fromIntegral (60 * mm)
+ toSeconds NoMinute calT = 0
+
+instance ToSeconds ISOSecondSpec where
+ toSeconds (Second ss) calT = fromIntegral ss
+ toSeconds NoSecond calT = 0
+
+instance ToSeconds ISOTimeZoneSpec where
+ toSeconds LocalTime calT = 0
+ toSeconds UTCTime calT = fromIntegral (ctTZ calT)
+ toSeconds (PlusTime (Hour hh) isoMinuteSpec) calT =
+ fromIntegral (ctTZ calT - (3600 * hh + 60 * minutes isoMinuteSpec))
+ toSeconds (MinusTime (Hour hh) isoMinuteSpec) calT =
+ fromIntegral (ctTZ calT + (3600 * hh + 60 * minutes isoMinuteSpec))
+
+minutes ImplicitMinute = 0
+minutes (Minute mm) = mm
+minutes NoMinute = 0
+
+isoDateToClockTime :: ISODate -> ClockTime
+isoDateToClockTime isoDate =
+ let seconds = unsafePerformIO $ isoDateToSeconds isoDate
+ in secondsToClockTime seconds
+
+isoDateAndTimeToClockTime :: ISODateAndTime -> ClockTime
+isoDateAndTimeToClockTime isoDateAndTime =
+ let seconds = unsafePerformIO $ isoDateAndTimeToSeconds isoDateAndTime
+ in secondsToClockTime seconds
+
+secondsToClockTime seconds =
+ let tdiff = TimeDiff { tdYear =0,
+ tdMonth =0,
+ tdDay =0,
+ tdHour =0,
+ tdMin =0,
+ tdSec = fromIntegral seconds,
+ tdPicosec =0
+ }
+ in addToClockTime tdiff epochClkT
+
+epochClkT = toClockTime epoch
+epoch = CalendarTime { ctYear = 1970,
+ ctMonth = January,
+ ctDay = 1,
+ ctHour = 0,
+ ctMin = 0,
+ ctSec = 0,
+ ctPicosec= 0,
+ ctWDay = Thursday, -- ignored
+ ctYDay = 0, -- ignored
+ ctTZName = "UTC", -- ignored
+ ctTZ = 0,
+ ctIsDST = False -- ignored
+ }
+
+
+-- |data type for representing ISO time
+data ISODateAndTime =
+ ISODateAndTime ISODate ISOTime
+ deriving Show
+
+data ISODate =
+ ISODate ISOYearSpec ISODayOfYearSpec
+ deriving Show
+
+data ISOYearSpec
+ = ImplicitYear | ImplicitCentury Int | Century Int | ImplicitDecade Int | Year Int
+ deriving Show
+data ISODayOfYearSpec
+ = NoDayOfYear
+ | MonthDay ISOMonthSpec ISODayOfMonthSpec
+ | DayOfYear Int
+ | WeekAndDay ISOWeekSpec ISODayOfWeekSpec
+ deriving Show
+data ISOMonthSpec
+ = ImplicitMonth | Month Int
+ deriving Show
+data ISODayOfMonthSpec
+ = NoDayOfMonth | DayOfMonth Int
+ deriving Show
+data ISOWeekSpec
+ = ImplicitWeek | AnyWeek | Week Int
+ deriving Show
+data ISODayOfWeekSpec
+ = NoDayOfWeek | DayOfWeek Int
+ deriving Show
+data ISOTime
+ = ISOTime ISOHourSpec ISOMinuteSpec ISOSecondSpec ISOTimeZoneSpec
+ deriving Show
+data ISOHourSpec
+ = ImplicitHour | Hour Int
+ deriving Show
+data ISOMinuteSpec
+ = ImplicitMinute | Minute Int | NoMinute
+ deriving Show
+data ISOSecondSpec
+ = Second Int | NoSecond
+ deriving Show
+data ISOTimeZoneSpec
+ = LocalTime | UTCTime | PlusTime ISOHourSpec ISOMinuteSpec | MinusTime ISOHourSpec ISOMinuteSpec
+ deriving Show
+
+updateTZ (ISOTime isoHourSpec isoMinuteSpec isoSecondSpec _) isoTimeZoneSpec =
+ ISOTime isoHourSpec isoMinuteSpec isoSecondSpec isoTimeZoneSpec
+
+digitval = digitToInt
+
+skipHyphen = char '-' >> return ()
+skipColon = char ':' >> return ()
+skipSolidus = char '/' >> return ()
+skipMinus = char '-' >> return ()
+skipPlus = char '+' >> return ()
+skipP = oneOf "pP" >> return ()
+skipT = oneOf "tT" >> return ()
+skipW = oneOf "wW" >> return ()
+skipZ = oneOf "zZ" >> return ()
+
+parseDateFromString :: String -> Maybe ISODate
+parseDateFromString = parseFromString parseDate
+parseTimeFromString :: String -> Maybe ISOTime
+parseTimeFromString = parseFromString parseTime
+parseDateAndTimeFromString :: String -> Maybe ISODateAndTime
+parseDateAndTimeFromString = parseFromString parseDateAndTime
+
+-- |external entry point
+parseDate =
+ parseBasicOrExtended parseDateInternal
+
+parseTime =
+ parseBasicOrExtended parseTimeInternal
+
+parseDateAndTime =
+ parseBasicOrExtended parseTimeAndDateInternal
+
+parseBasicOrExtended parser =
+ parser True <|> parser False
+
+parseTimeAndDateInternal extended =
+ do isodate <- parseDateInternal extended
+ isotime <- option (ISOTime (Hour 0) NoMinute NoSecond UTCTime)
+ (skipT >> parseTimeInternal extended)
+ return $ ISODateAndTime isodate isotime
+
+-- I was pretty much fed up with the irregular format of ISO 8601. After a few
+-- tries, I decided that the simplest approach was to just list all the
+-- alternatives from the standard.
+
+-- |argument determines whether extended format is parsed
+parseDateInternal False =
+ -- 5.2.1.1, complete representation, basic format: CCYYMMDD
+ (try $ do ccyy <- parseFourDigits
+ mm <- parseTwoDigits
+ dd <- parseTwoDigits
+ return $ ISODate (Year ccyy) $ MonthDay (Month mm) (DayOfMonth dd))
+ <|>
+ -- !!! CHECK THIS !!!
+ -- 5.2.1.2.a, a specific month, basic format: CCYY-MM
+ (try $ do ccyy <- parseFourDigits
+ skipHyphen
+ mm <- parseTwoDigits
+ return $ ISODate (Year ccyy) $ MonthDay (Month mm) NoDayOfMonth)
+ <|>
+ -- 5.2.1.2.b, a specific year, basic format: CCYY
+ (try $ do ccyy <- parseFourDigits
+ return $ ISODate (Year ccyy) NoDayOfYear)
+ <|>
+ -- 5.2.1.2.c, a specific century, basic format: CC
+ (try $ do cc <- parseTwoDigits
+ return $ ISODate (Century cc) NoDayOfYear)
+ <|>
+ -- 5.2.1.3.a, truncated representation, specific date in current century, basic format: YYMMDD
+ (try $ do yy <- parseTwoDigits
+ mm <- parseTwoDigits
+ dd <- parseTwoDigits
+ return $ ISODate (ImplicitCentury yy) $ MonthDay (Month mm) (DayOfMonth dd))
+ <|>
+ -- 5.2.1.3.b, truncated representation, specific year and month in current century, basic format: -YYMM
+ (try $ do skipHyphen
+ yy <- parseTwoDigits
+ mm <- parseTwoDigits
+ return $ ISODate (ImplicitCentury yy) $ MonthDay (Month mm) NoDayOfMonth)
+ <|>
+ -- 5.2.1.3.c, truncated representation, specific year in current century, basic format: -YY
+ (try $ do skipHyphen
+ yy <- parseTwoDigits
+ return $ ISODate (ImplicitCentury yy) NoDayOfYear)
+ <|>
+ -- 5.2.1.3.d, truncated representation, specific day of a month, basic format: --MMDD
+ (try $ do skipHyphen
+ skipHyphen
+ mm <- parseTwoDigits
+ dd <- parseTwoDigits
+ return $ ISODate ImplicitYear $ MonthDay (Month mm) (DayOfMonth dd))
+ <|>
+ -- 5.2.1.3.e, truncated representation, specific month, basic format: --MM
+ (try $ do skipHyphen
+ skipHyphen
+ mm <- parseTwoDigits
+ return $ ISODate ImplicitYear $ MonthDay (Month mm) NoDayOfMonth)
+ <|>
+ -- 5.2.1.3.f, truncated representation, specific day, basic format: ---DD
+ (try $ do skipHyphen
+ skipHyphen
+ skipHyphen
+ dd <- parseTwoDigits
+ return $ ISODate ImplicitYear $ MonthDay ImplicitMonth (DayOfMonth dd))
+ <|>
+ -- 5.2.2 Ordinal date
+ -- 5.2.2.1, complete representation, basic format: CCYYDDD
+ (try $ do ccyy <- parseFourDigits
+ ddd <- parseOrdinalDay
+ return $ ISODate (Year ccyy) $ DayOfYear ddd)
+ <|>
+ -- 5.2.2.2.a, truncated representation, specific year and day in current century, basic format: YYDDD
+ (try $ do yy <- parseTwoDigits
+ ddd <- parseOrdinalDay
+ return $ ISODate (ImplicitCentury yy) $ DayOfYear ddd)
+ <|>
+ -- 5.2.2.2.b, truncated representation, specific day only, basic format: -DDD
+ (try $ do skipHyphen
+ ddd <- parseOrdinalDay
+ return $ ISODate ImplicitYear $ DayOfYear ddd)
+ <|>
+ -- 5.2.3 date by calendar week and day number
+ -- 5.2.3.1, complete representation, basic format: CCYYWwwD
+ (try $ do ccyy <- parseFourDigits
+ skipW
+ ww <- parseTwoDigits
+ checkWeeks ww
+ d <- parseWeekDay
+ return $ ISODate (Year ccyy) $ WeekAndDay (Week ww) (DayOfWeek d))
+ <|>
+ -- 5.2.3.2, reduced prec representation, basic format: CCYYWww
+ (try $ do ccyy <- parseFourDigits
+ skipW
+ ww <- parseTwoDigits
+ checkWeeks ww
+ return $ ISODate (Year ccyy) $ WeekAndDay (Week ww) NoDayOfWeek)
+ <|>
+ -- 5.2.3.3.a, truncated representation, current century, basic format: YYWwwD
+ (try $ do yy <- parseTwoDigits
+ skipW
+ ww <- parseTwoDigits
+ checkWeeks ww
+ d <- parseWeekDay
+ return $ ISODate (ImplicitCentury yy) $ WeekAndDay (Week ww) (DayOfWeek d))
+ <|>
+ -- 5.2.3.3.b, truncated representation, current century, year and week only, basic format: YYWww
+ (try $ do yy <- parseTwoDigits
+ skipW
+ ww <- parseTwoDigits
+ checkWeeks ww
+ return $ ISODate (ImplicitCentury yy) $ WeekAndDay (Week ww) NoDayOfWeek)
+ <|>
+ -- 5.2.3.3.c, truncated representation, current decade, week, and day, basic format: -YWwwD
+ (try $ do skipHyphen
+ y <- parseOneDigit
+ skipW
+ ww <- parseTwoDigits
+ checkWeeks ww
+ d <- parseWeekDay
+ return $ ISODate (ImplicitDecade y) $ WeekAndDay (Week ww) (DayOfWeek d))
+ <|>
+ -- 5.2.3.3.d, truncated representation, current year, week, and day, basic format: -WwwD
+ (try $ do skipHyphen
+ skipW
+ ww <- parseTwoDigits
+ checkWeeks ww
+ d <- parseWeekDay
+ return $ ISODate ImplicitYear $ WeekAndDay (Week ww) (DayOfWeek d))
+ <|>
+ -- 5.2.3.3.e, truncated representation, current year, week only, basic format: -Www
+ (try $ do skipHyphen
+ skipW
+ ww <- parseTwoDigits
+ checkWeeks ww
+ return $ ISODate ImplicitYear $ WeekAndDay (Week ww) NoDayOfWeek)
+ <|>
+ -- 5.2.3.3.f, truncated representation, day only of current week, basic format: -W-D
+ (try $ do skipHyphen
+ skipW
+ skipHyphen
+ d <- parseWeekDay
+ return $ ISODate ImplicitYear $ WeekAndDay ImplicitWeek (DayOfWeek d))
+ <|>
+ -- 5.2.3.3.g, truncated representation, day only of any week, basic format: ---D
+ (try $ do skipHyphen
+ skipHyphen
+ skipHyphen
+ d <- parseWeekDay
+ return $ ISODate ImplicitYear $ WeekAndDay AnyWeek (DayOfWeek d))
+
+
+-- ----------------------------------------------------------------------
+-- extended formats
+parseDateInternal True =
+ -- 5.2.1.1, complete representation, extended format CCYY-MM-DD
+ (try $ do ccyy <- parseFourDigits
+ skipHyphen
+ mm <- parseTwoDigits
+ skipHyphen
+ dd <- parseTwoDigits
+ return $ ISODate (Year ccyy) $ MonthDay (Month mm) (DayOfMonth dd))
+ <|>
+ -- 5.2.1.3.a, truncated representation, extended format: YY-MM-DD
+ (try $ do yy <- parseTwoDigits
+ skipHyphen
+ mm <- parseTwoDigits
+ skipHyphen
+ dd <- parseTwoDigits
+ return $ ISODate (ImplicitCentury yy) $ MonthDay (Month mm) (DayOfMonth dd))
+ <|>
+ -- 5.2.1.3.b, truncated representation, specific year and month in current century, extended format: -YY-MM
+ (try $ do skipHyphen
+ yy <- parseTwoDigits
+ skipHyphen
+ mm <- parseTwoDigits
+ return $ ISODate (ImplicitCentury yy) $ MonthDay (Month mm) NoDayOfMonth)
+ <|>
+ -- 5.2.1.3.d, truncated representation, specific day of a month, extended format: --MM-DD
+ (try $ do skipHyphen
+ skipHyphen
+ mm <- parseTwoDigits
+ skipHyphen
+ dd <- parseTwoDigits
+ return $ ISODate ImplicitYear $ MonthDay (Month mm) (DayOfMonth dd))
+ <|>
+ -- 5.2.2 Ordinal date
+ -- 5.2.2.1, complete representation, extended format: CCYY-DDD
+ (try $ do ccyy <- parseFourDigits
+ skipHyphen
+ ddd <- parseOrdinalDay
+ return $ ISODate (Year ccyy) $ DayOfYear ddd)
+ <|>
+ -- 5.2.2.2.a, truncated representation, specific year and day in current century, extended format: YY-DDD
+ (try $ do yy <- parseTwoDigits
+ skipHyphen
+ ddd <- parseOrdinalDay
+ return $ ISODate (ImplicitCentury yy) $ DayOfYear ddd)
+ <|>
+ -- 5.2.3 date by calendar week and day number
+ -- 5.2.3.1, complete representation, extended format: CCYY-Www-D
+ (try $ do ccyy <- parseFourDigits
+ skipHyphen
+ skipW
+ ww <- parseTwoDigits
+ checkWeeks ww
+ skipHyphen
+ d <- parseWeekDay
+ return $ ISODate (Year ccyy) $ WeekAndDay (Week ww) (DayOfWeek d))
+ <|>
+ -- 5.2.3.2, reduced prec representation, extended format: CCYY-Www
+ (try $ do ccyy <- parseFourDigits
+ skipHyphen
+ skipW
+ ww <- parseTwoDigits
+ checkWeeks ww
+ return $ ISODate (Year ccyy) $ WeekAndDay (Week ww) NoDayOfWeek)
+ <|>
+ -- 5.2.3.3.a, truncated representation, current century, extended format: YY-Www-D
+ (try $ do yy <- parseTwoDigits
+ skipHyphen
+ skipW
+ ww <- parseTwoDigits
+ checkWeeks ww
+ skipHyphen
+ d <- parseWeekDay
+ return $ ISODate (ImplicitCentury yy) $ WeekAndDay (Week ww) (DayOfWeek d))
+ <|>
+ -- 5.2.3.3.b, truncated representation, current century, year and week only, extended format: YY-Www
+ (try $ do yy <- parseTwoDigits
+ skipHyphen
+ skipW
+ ww <- parseTwoDigits
+ checkWeeks ww
+ return $ ISODate (ImplicitCentury yy) $ WeekAndDay (Week ww) NoDayOfWeek)
+ <|>
+ -- 5.2.3.3.c, truncated representation, current decade, week, and day, extended format: -Y-Www-D
+ (try $ do skipHyphen
+ y <- parseOneDigit
+ skipHyphen
+ skipW
+ ww <- parseTwoDigits
+ checkWeeks ww
+ skipHyphen
+ d <- parseWeekDay
+ return $ ISODate (ImplicitDecade y) $ WeekAndDay (Week ww) (DayOfWeek d))
+ <|>
+ -- !!! CHECK THIS
+ -- 5.2.3.3.d, truncated representation, current year, week, and day, extended format: -Www-D
+ (try $ do skipHyphen
+ skipW
+ ww <- parseTwoDigits
+ checkWeeks ww
+ skipHyphen
+ d <- parseWeekDay
+ return $ ISODate ImplicitYear $ WeekAndDay (Week ww) (DayOfWeek d))
+
+-- |time parsers
+parseTimeInternal extended =
+ do localtime <- parseLocalTimeInternal extended
+ tzsuffix <- option LocalTime $ parseTZsuffix extended
+ return $ updateTZ localtime tzsuffix
+
+parseTZsuffix extended =
+ (do skipZ
+ return UTCTime)
+ <|>
+ (do skipPlus
+ (hours, minutes) <- parseHoursMinutes extended
+ return $ PlusTime hours minutes)
+ <|>
+ (do skipMinus
+ (hours, minutes) <- parseHoursMinutes extended
+ return $ MinusTime hours minutes)
+
+parseHoursMinutes False =
+ do hh <- parseTwoDigits
+ mm <- option NoMinute $ (liftM Minute) parseTwoDigits
+ return (Hour hh, mm)
+
+parseHoursMinutes True =
+ do hh <- parseTwoDigits
+ mm <- option NoMinute $ (liftM Minute) (skipColon >> parseTwoDigits)
+ return (Hour hh, mm)
+
+parseLocalTimeInternal False =
+ -- 5.3.1.1, local time, basic format: hhmmss
+ (try $ do hh <- parseTwoDigits
+ mm <- parseTwoDigits
+ ss <- parseTwoDigits
+ checkHours hh
+ checkMinutes mm
+ checkSeconds ss
+ return $ ISOTime (Hour hh) (Minute mm) (Second ss) LocalTime)
+ <|>
+ -- 5.3.1.2, local time, reduced precision, basic format: hhmm ; hh
+ (try $ do hh <- parseTwoDigits
+ mm <- parseTwoDigits
+ checkHours hh
+ checkMinutes mm
+ return $ ISOTime (Hour hh) (Minute mm) NoSecond LocalTime)
+ <|>
+ (try $ do hh <- parseTwoDigits
+ checkHours hh
+ return $ ISOTime (Hour hh) NoMinute NoSecond LocalTime)
+ <|>
+ -- 5.3.1.4.a, local time, truncated, basic format: -mmss
+ (try $ do skipHyphen
+ mm <- parseTwoDigits
+ ss <- parseTwoDigits
+ checkMinutes mm
+ checkSeconds ss
+ return $ ISOTime ImplicitHour (Minute mm) (Second ss) LocalTime)
+ <|>
+ -- 5.3.1.4.b, local time, truncated, basic format: -mm
+ (try $ do skipHyphen
+ mm <- parseTwoDigits
+ checkMinutes mm
+ return $ ISOTime ImplicitHour (Minute mm) NoSecond LocalTime)
+ <|>
+ -- 5.3.1.4.c, local time, truncated, basic format: --ss
+ (try $ do skipHyphen
+ skipHyphen
+ ss <- parseTwoDigits
+ checkSeconds ss
+ return $ ISOTime ImplicitHour ImplicitMinute (Second ss) LocalTime)
+
+
+parseLocalTimeInternal True =
+ -- 5.3.1.1, local time, extended format: hh:mm:ss
+ (try $ do hh <- parseTwoDigits
+ skipColon
+ mm <- parseTwoDigits
+ skipColon
+ ss <- parseTwoDigits
+ checkHours hh
+ checkMinutes mm
+ checkSeconds ss
+ return $ ISOTime (Hour hh) (Minute mm) (Second ss) LocalTime)
+ <|>
+ -- 5.3.1.2, local time, reduced precision, extended format: hh:mm
+ (try $ do hh <- parseTwoDigits
+ skipColon
+ mm <- parseTwoDigits
+ checkHours hh
+ checkMinutes mm
+ return $ ISOTime (Hour hh) (Minute mm) NoSecond LocalTime)
+ <|>
+ -- 5.3.1.4.a, local time, truncated, extended format: -mm:ss
+ (try $ do skipHyphen
+ mm <- parseTwoDigits
+ skipColon
+ ss <- parseTwoDigits
+ checkMinutes mm
+ checkSeconds ss
+ return $ ISOTime ImplicitHour (Minute mm) (Second ss) LocalTime)
+
+-- make ISOTime, ISODate, ISODateAndTime instances of Read
+instance Read ISOTime where
+ readsPrec i = parserToRead parseTime
+
+instance Read ISODate where
+ readsPrec i = parserToRead parseDate
+
+instance Read ISODateAndTime where
+ readsPrec i = parserToRead parseDateAndTime
+-- auxiliary parsers
+
+checkSeconds ss = if ss > 60 then fail "more than 60 seconds" else return ()
+checkMinutes mm = if mm > 59 then fail "more than 59 minutes" else return ()
+checkHours hh = if hh > 24 then fail "more than 24 hours" else return ()
+checkDays ddd = if ddd < 1 || ddd > 366 then fail "illegal ordinal day" else return ()
+checkWeeks ww = if ww < 1 || ww > 53 then fail "illegal week nr" else return ()
+
+parseWeekDay = do d0 <- oneOf "1234567"
+ return (digitval d0)
+
+parseOneDigit = do d0 <- digit
+ return (digitval d0)
+parseTwoDigits = do d1 <- digit
+ vv <- parseOneDigit
+ return (10 * digitval d1 + vv)
+parseThreeDigits = do d2 <- digit
+ vv <- parseTwoDigits
+ let vvv = 100 * digitval d2 + vv
+ return vvv
+parseOrdinalDay = do vvv <- parseThreeDigits
+ checkDays vvv
+ return vvv
+parseFourDigits = do d3 <- digit
+ vvv <- parseThreeDigits
+ return (1000 * digitval d3 + vvv)
+
diff --git a/libsrc/MissingH/Wash/Utility/IntToString.hs b/libsrc/MissingH/Wash/Utility/IntToString.hs
new file mode 100644
index 0000000..93f8a2a
--- /dev/null
+++ b/libsrc/MissingH/Wash/Utility/IntToString.hs
@@ -0,0 +1,10 @@
+-- © 2002 Peter Thiemann
+module IntToString where
+
+import Char
+
+intToString ndigits i =
+ let g x = h $ divMod x 10
+ h (q,r) = chr (ord '0' + fromInteger r) : g q
+ in
+ reverse $ take ndigits $ g i
diff --git a/libsrc/MissingH/Wash/Utility/JavaScript.hs b/libsrc/MissingH/Wash/Utility/JavaScript.hs
new file mode 100644
index 0000000..26e54b8
--- /dev/null
+++ b/libsrc/MissingH/Wash/Utility/JavaScript.hs
@@ -0,0 +1,27 @@
+-- © 2003 Peter Thiemann
+module JavaScript where
+
+import Char
+
+import Hex
+
+jsShow :: String -> String
+jsShow xs = '\'' : g xs
+ where
+ g "" = "'"
+ g (x:xs) =
+ case x of
+ '\'' -> h x xs
+ '\"' -> h x xs
+ '<' -> h x xs
+ '>' -> h x xs
+ '&' -> h x xs
+ x | isPrint x -> x : g xs
+ | otherwise -> h x xs
+ h x xs =
+ let ox = ord x in
+ if ox < 256 then
+ '\\' : 'x' : showsHex 2 ox (g xs)
+ else
+ '\\' : 'u' : showsHex 4 ox (g xs)
+
diff --git a/libsrc/MissingH/Wash/Mail/LICENSE b/libsrc/MissingH/Wash/Utility/LICENSE
similarity index 100%
copy from libsrc/MissingH/Wash/Mail/LICENSE
copy to libsrc/MissingH/Wash/Utility/LICENSE
diff --git a/libsrc/MissingH/Wash/Utility/Locking.hs b/libsrc/MissingH/Wash/Utility/Locking.hs
new file mode 100644
index 0000000..569cfa8
--- /dev/null
+++ b/libsrc/MissingH/Wash/Utility/Locking.hs
@@ -0,0 +1,36 @@
+module Locking (obtainLock, releaseLock) where
+
+import Auxiliary
+import Directory
+import IO
+import System
+import Time
+
+obtainLock :: FilePath -> IO ()
+releaseLock :: FilePath -> IO ()
+
+lockPath name = name ++ ".lockdir"
+
+obtainLock name =
+ assertDirectoryExists (lockPath name)
+ (system "sleep 1" >> obtainLockLoop name)
+
+releaseLock name =
+ removeDirectory (lockPath name)
+
+obtainLockLoop name =
+ let lp = lockPath name in
+ do b <- doesDirectoryExist lp
+ if b then do -- check if lock is stale
+ mtime <- getModificationTime lp
+ ftime <- getModificationTime name
+ ctime <- getClockTime
+ let td = diffClockTimes ctime mtime
+ tf = diffClockTimes ctime ftime
+ if tdSec td > 60 && tdSec tf > 60
+ then do removeDirectory lp
+ obtainLock name
+ else do system "sleep 1"
+ obtainLockLoop name
+
+ else obtainLock name
diff --git a/libsrc/MissingH/Wash/Utility/Makefile b/libsrc/MissingH/Wash/Utility/Makefile
new file mode 100644
index 0000000..89abd4f
--- /dev/null
+++ b/libsrc/MissingH/Wash/Utility/Makefile
@@ -0,0 +1,141 @@
+#
+# Makefile for WASH/Utility (Haskell98)
+# copyright 2001-2003 by Peter Thiemann
+#
+
+PACKAGE=Utility
+VERSION=0.3.11
+
+include $(TOP)/mk/config.mk
+include $(TOP)/mk/common.mk
+
+FILES= Makefile LICENSE Utility.pkg $(HS_SOURCES) $(C_SOURCES) $(H_SOURCES)
+HS_SOURCES=\
+ Auxiliary.hs \
+ Base32.hs \
+ Base64.hs \
+ FileNames.hs \
+ Hex.hs \
+ ISO8601.hs \
+ IntToString.hs \
+ JavaScript.hs \
+ Locking.hs \
+ QuotedPrintable.hs \
+ RFC2047.hs \
+ RFC2279.hs \
+ RFC2397.hs \
+ SHA1.hs \
+ SimpleParser.hs \
+ Shell.hs \
+ URLCoding.hs \
+ Unique.hs \
+
+C_SOURCES= sha1lib.c
+H_SOURCES= sha1lib.h
+
+FULLNAME=$(PACKAGE)-$(VERSION)
+BINDISTNAME=$(PACKAGE)-bin-$(VERSION).tgz
+DISTNAME=$(FULLNAME).tgz
+# where the WASH homepage resides
+WWWDIR=$(HOME)/public/www/haskell/WASH
+TMPDIR=/tmp
+
+######################################################################
+# goals
+
+all: libUtility.a
+
+libUtility.a: libUtility.a($(HS_SOURCES:.hs=.o) $(C_SOURCES:.c=.o))
+ $(RANLIB) $@
+
+dist: documentation
+ $(RM) -rf $(TMPDIR)/$(FULLNAME)
+ $(MKDIR) -p $(TMPDIR)/$(FULLNAME)/$(DOCSUBDIR)
+ $(CP) $(FILES) $(TMPDIR)/$(FULLNAME)
+ $(CP) -rp $(DOCSUBDIR) $(TMPDIR)/$(FULLNAME)
+ $(TAR) cfCvz $(DISTNAME) $(TMPDIR) $(FULLNAME)
+
+install-distribution: dist
+ $(INSTALL) $(DISTNAME) $(WWWDIR)
+
+install: libUtility.a
+ $(INSTALL) -d $(PACKAGELIBDIR)
+ $(INSTALL) -d $(PACKAGEIMPORTDIR)
+ $(INSTALL) -c -m 644 $(HS_SOURCES:.hs=.hi) $(PACKAGEIMPORTDIR)
+ $(INSTALL) -c -m 644 libUtility.a $(PACKAGELIBDIR)
+ $(RANLIB) $(PACKAGELIBDIR)/libUtility.a
+ifeq ($(ENABLE_REG_PACKAGE),yes)
+ $(GENPKG) $(PACKAGE) --import_dirs $(PACKAGEIMPORTDIR) --library_dirs $(PACKAGELIBDIR) --hs_libraries $(PACKAGE) --package_deps text | $(GHCPKG) $(GHCPKGFLAGS) --update-package --auto-ghci-libs
+endif
+
+######################################################################
+# special dependencies
+
+sha1lib.o: sha1lib.h
+SHA1.o: sha1lib.h
+
+######################################################################
+# generic stuff
+
+HC_SPEC_FLAGS= -package-name $(PACKAGE)
+HCINCLUDES= -package text
+HCLOADFLAGS=
+
+OPT= -O2 -ffi
+
+HCFLAGS= $(OPT) $(HC_SPEC_FLAGS) $(HCINCLUDES) $(HCEXTRAFLAGS)
+
+HS_FILES= $(HS_SOURCES)
+
+DOCSUBDIR= doc
+
+documentation: $(DOCSUBDIR)
+
+$(DOCSUBDIR): $(HS_SOURCES)
+ $(RM) -rf $(DOCSUBDIR)
+ $(MKDIR) $(DOCSUBDIR)
+ $(HADDOCK) -o $(DOCSUBDIR) -h $(HS_SOURCES)
+
+clean:
+ $(RM) -f *.a *.o *.hi
+
+veryclean:: clean
+
+depend::
+ $(HC) -M $(HCFLAGS) $(HS_FILES)
+
+# DO NOT DELETE: Beginning of Haskell dependencies
+Auxiliary.o : Auxiliary.hs
+Auxiliary.o : ./Shell.hi
+Auxiliary.o : ./FileNames.hi
+Base32.o : Base32.hs
+Base64.o : Base64.hs
+FileNames.o : FileNames.hs
+Hex.o : Hex.hs
+ISO8601.o : ISO8601.hs
+ISO8601.o : ./SimpleParser.hi
+ISO8601.o : ./IntToString.hi
+IntToString.o : IntToString.hs
+JavaScript.o : JavaScript.hs
+JavaScript.o : Hex.hi
+Locking.o : Locking.hs
+Locking.o : Auxiliary.hi
+QuotedPrintable.o : QuotedPrintable.hs
+QuotedPrintable.o : Hex.hi
+RFC2047.o : RFC2047.hs
+RFC2047.o : Hex.hi
+RFC2047.o : QuotedPrintable.hi
+RFC2047.o : Base64.hi
+RFC2279.o : RFC2279.hs
+RFC2397.o : RFC2397.hs
+RFC2397.o : Base64.hi
+RFC2397.o : ./URLCoding.hi
+SHA1.o : SHA1.hs
+SimpleParser.o : SimpleParser.hs
+Shell.o : Shell.hs
+URLCoding.o : URLCoding.hs
+URLCoding.o : Hex.hi
+Unique.o : Unique.hs
+Unique.o : Locking.hi
+Unique.o : Auxiliary.hi
+# DO NOT DELETE: End of Haskell dependencies
diff --git a/libsrc/MissingH/Wash/Utility/QuotedPrintable.hs b/libsrc/MissingH/Wash/Utility/QuotedPrintable.hs
new file mode 100644
index 0000000..9a66f66
--- /dev/null
+++ b/libsrc/MissingH/Wash/Utility/QuotedPrintable.hs
@@ -0,0 +1,49 @@
+module QuotedPrintable
+ (encode, encode', decode
+ -- deprecated: encode_quoted, encode_quoted', decode_quoted
+ ) where
+
+import Char
+import Hex
+
+encode, encode', decode :: String -> String
+encode = encode_quoted
+encode' = encode_quoted'
+decode = decode_quoted
+
+
+encode_hexadecimal c = '=' : showHex2 c
+
+quoted_printable x =
+ ox >= 33 && ox <= 126 && ox /= 61
+ where ox = ord x
+
+end_of_line [] = True
+end_of_line ('\r':'\n':_) = True
+end_of_line _ = False
+
+encode_quoted' (x:xs) | x `elem` "\t " =
+ if end_of_line xs then encode_hexadecimal (ord x) ++ encode_quoted' xs
+ else x : encode_quoted' xs
+encode_quoted' (x:xs) | quoted_printable x = x : encode_quoted' xs
+encode_quoted' ('\r':'\n':xs) = '\r':'\n': encode_quoted' xs
+encode_quoted' (x:xs) = encode_hexadecimal (ord x) ++ encode_quoted' xs
+encode_quoted' [] = ""
+
+encode_quoted = softLineBreak 76 . encode_quoted'
+
+softLineBreak n [] = "\r\n"
+softLineBreak 0 xs | not (end_of_line xs) = '=':'\r':'\n': softLineBreak 76 xs
+softLineBreak n ('\r':'\n':xs) = '\r':'\n': softLineBreak 76 xs
+softLineBreak n (xs@('=':_)) | n < 4 = '=':'\r':'\n': softLineBreak 76 xs
+softLineBreak n (x:xs) = x : softLineBreak (n-1) xs
+
+decode_quoted [] = []
+decode_quoted ('=':'\r':'\n':xs) =
+ decode_quoted xs
+decode_quoted ('=':'\n':xs) =
+ decode_quoted xs
+decode_quoted ('=':upper:lower:xs) | isHexdigit upper && isHexdigit lower =
+ chr (16 * hexDigitVal upper + hexDigitVal lower) : decode_quoted xs
+decode_quoted (x:xs) =
+ x : decode_quoted xs
diff --git a/libsrc/MissingH/Wash/Utility/RFC2047.hs b/libsrc/MissingH/Wash/Utility/RFC2047.hs
new file mode 100644
index 0000000..1188514
--- /dev/null
+++ b/libsrc/MissingH/Wash/Utility/RFC2047.hs
@@ -0,0 +1,71 @@
+module RFC2047 where
+-- decoding of header fields
+import Char
+import List
+
+import qualified Base64
+import qualified QuotedPrintable
+import Hex
+import Parsec
+
+lineString =
+ do initial <- many (noneOf "\n\r=")
+ rest <- option "" (do xs <- try encoded_words <|> string "="
+ ys <- lineString
+ return (xs ++ ys))
+ return (initial ++ rest)
+
+especials = "()<>@,;:\\\"/[]?.="
+tokenchar = "!\"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_`abcdefghijklmnopqrstuvwxyz{|}~" \\ especials
+p_token = many1 (oneOf tokenchar)
+p_encoded_text = many1 $ oneOf "!\"#$%&'()*+,-./0123456789:;<=>@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_`abcdefghijklmnopqrstuvwxyz{|}~"
+allchar = "\NUL\SOH\STX\ETX\EOT\ENQ\ACK\a\b\t\n\v\f\r\SO\SI\DLE\DC1\DC2\DC3\DC4\NAK\SYN\ETB\CAN\EM\SUB\ESC\FS\GS\RS\US !\"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_`abcdefghijklmnopqrstuvwxyz{|}~\DEL"
+
+-- supress linear white space between adjacent encoded_word
+encoded_words =
+ do ew <- encoded_word
+ ws <- many space
+ option (ew++ws) (encoded_words >>= \ews -> return (ew++ews))
+
+encoded_word =
+ do string "=?"
+ charset <- p_token
+ char '?'
+ encoding <- p_token
+ char '?'
+ encoded_text <- p_encoded_text
+ string "?="
+ return $ decode charset (map toUpper encoding) encoded_text
+
+decode charset "B" encoded_text =
+ Base64.decode' encoded_text
+decode charset "Q" encoded_text =
+ decode_quoted encoded_text
+decode charset encoding encoded_text =
+ error ("Unknown encoding: " ++ encoding)
+
+decode_quoted [] = []
+decode_quoted ('=':upper:lower:xs) =
+ chr (16 * hexDigitVal upper + hexDigitVal lower) : decode_quoted xs
+decode_quoted ('_':xs) =
+ ' ' : decode_quoted xs
+decode_quoted (x:xs) =
+ x : decode_quoted xs
+
+-- --------------------------------------------------------------------
+-- RFC 2047: encoding of header fields
+
+encodeWord w =
+ "=?" ++ charset ++ "?" ++ encoding ++ "?" ++ QuotedPrintable.encode' w ++ "?="
+ where encoding = "q"
+ charset = "iso-8859-1"
+
+encodeValue v =
+ case span (not . flip elem " ()<>@.!,") v of
+ ([], []) -> []
+ (word, []) -> maybeEncode word
+ (word, x:rest) -> maybeEncode word ++ x : encodeValue rest
+
+maybeEncode word | all p word = word
+ | otherwise = encodeWord word
+ where p x = let ox = ord x in ox >= 33 && ox <= 126
diff --git a/libsrc/MissingH/Wash/Utility/RFC2279.hs b/libsrc/MissingH/Wash/Utility/RFC2279.hs
new file mode 100644
index 0000000..1377ee9
--- /dev/null
+++ b/libsrc/MissingH/Wash/Utility/RFC2279.hs
@@ -0,0 +1,110 @@
+-- © 2003 Peter Thiemann
+{-|
+ Implements UTF-8 encoding
+
+ UCS-4 range (hex.) UTF-8 octet sequence (binary)
+ 0000 0000-0000 007F 0xxxxxxx
+ 0000 0080-0000 07FF 110xxxxx 10xxxxxx
+ 0000 0800-0000 FFFF 1110xxxx 10xxxxxx 10xxxxxx
+ 0001 0000-001F FFFF 11110xxx 10xxxxxx 10xxxxxx 10xxxxxx
+ 0020 0000-03FF FFFF 111110xx 10xxxxxx 10xxxxxx 10xxxxxx 10xxxxxx
+ 0400 0000-7FFF FFFF 1111110x 10xxxxxx ... 10xxxxxx
+-}
+module RFC2279 (encode, decode) where
+
+import Char
+
+
+-- |maps Unicode string to list of octets
+encode :: String -> String
+
+-- |maps list of octets in UTF-8 encoding to Unicode string
+decode :: String -> String
+
+factors = iterate (* 0x40) 1
+f1 = factors !! 1
+f2 = factors !! 2
+f3 = factors !! 3
+f4 = factors !! 4
+f5 = factors !! 5
+
+encode [] = []
+encode (x:xs) =
+ let r0 = ord x in
+ if r0 < 0x80 then
+ x : encode xs
+ else if r0 < 0x800 then
+ let c1 = 0xC0 + r0 `div` f1
+ c2 = 0x80 + r0 `mod` f1
+ in chr c1 : chr c2 : encode xs
+ else if r0 < 0x10000 then
+ let c1 = 0xE0 + r0 `div` f2
+ r1 = r0 `mod` f2
+ c2 = 0x80 + r1 `div` f1
+ c3 = 0x80 + r1 `mod` f1
+ in chr c1 : chr c2 : chr c3 : encode xs
+ else if r0 < 0x200000 then
+ let c1 = 0xF0 + r0 `div` f3
+ r1 = r0 `mod` f3
+ c2 = 0x80 + r1 `div` f2
+ r2 = r1 `mod` f2
+ c3 = 0x80 + r2 `div` f1
+ c4 = 0x80 + r2 `mod` f1
+ in chr c1 : chr c2 : chr c3 : chr c4 : encode xs
+ else if r0 < 0x4000000 then
+ let c1 = 0xF8 + r0 `div` f4
+ r1 = r0 `mod` f4
+ c2 = 0x80 + r1 `div` f3
+ r2 = r1 `mod` f3
+ c3 = 0x80 + r2 `div` f2
+ r3 = r2 `mod` f2
+ c4 = 0x80 + r3 `div` f1
+ c5 = 0x80 + r3 `mod` f1
+ in chr c1 : chr c2 : chr c3 : chr c4 : chr c5 : encode xs
+ else
+ let c1 = 0xFC + r0 `div` f5
+ r1 = r0 `mod` f5
+ c2 = 0x80 + r1 `div` f4
+ r2 = r1 `mod` f4
+ c3 = 0x80 + r2 `div` f3
+ r3 = r2 `mod` f3
+ c4 = 0x80 + r3 `div` f2
+ r4 = r3 `mod` f2
+ c5 = 0x80 + r4 `div` f1
+ c6 = 0x80 + r4 `mod` f1
+ in chr c1 : chr c2 : chr c3 : chr c4 : chr c5 : chr c6 : encode xs
+
+
+decode [] = []
+decode (x : xs) =
+ let ordx = ord x in
+ if ordx < 0x80 then
+ x : decode xs
+ else if ordx < 0xC0 then
+ error "UTF-8 decoding out of sync"
+ else if ordx < 0xE0 then
+ decoden 1 (ordx - 0xC0) xs
+ else if ordx < 0xF0 then
+ decoden 2 (ordx - 0xE0) xs
+ else if ordx < 0xF8 then
+ decoden 3 (ordx - 0xF0) xs
+ else if ordx < 0xFC then
+ decoden 4 (ordx - 0xF8) xs
+ else if ordx < 0xFE then
+ decoden 5 (ordx - 0xFC) xs
+ else
+ error "UTF-8 decoding found illegal start octet"
+
+decoden :: Int -> Int -> String -> String
+decoden 0 v xs =
+ chr v : decode xs
+decoden n v (x : xs) =
+ let ordx = ord x
+ v' = f1 * v + ordx - 0x80
+ in
+ if ordx >= 0x80 && ordx < 0xC0 then
+ decoden (n-1) v' xs
+ else
+ error "UTF-8 decoding found illegal continuation octet"
+
+
diff --git a/libsrc/MissingH/Wash/Utility/RFC2397.hs b/libsrc/MissingH/Wash/Utility/RFC2397.hs
new file mode 100644
index 0000000..0dbd15b
--- /dev/null
+++ b/libsrc/MissingH/Wash/Utility/RFC2397.hs
@@ -0,0 +1,64 @@
+module RFC2397 where
+
+import URLCoding
+import Base64
+
+data ENC = BASE64 | URL
+ deriving Eq
+
+-- |maps (mediatype, contents) to data URL
+encode :: (String, String) -> String
+encode (mediatype, thedata) =
+ "data:" ++ mediatype ++ ";base64," ++ Base64.encode' thedata
+
+-- |maps data URL to @Just (mediatype, contents)@ or @Nothing@ in case of a
+-- syntax error.
+decode :: String -> Maybe (String, String)
+decode url =
+ let (scheme, rest) = break (==':') url in
+ case rest of
+ ':' : contents | scheme == "data" ->
+ decodeContents contents
+ _ -> Nothing
+
+decodeContents xs =
+ let (prefix, restdata) = break (==',') xs in
+ case restdata of
+ ',' : thedata ->
+ decodePrefix prefix thedata
+ _ -> Nothing
+
+decodePrefix prefix thedata =
+ let fragments = breakList (==';') prefix
+ enc = case reverse fragments of
+ ("base64":_) -> BASE64
+ _ -> URL
+ mediapart | enc == BASE64 = init fragments
+ | otherwise = fragments
+ in
+ case mediapart of
+ (xs:_) ->
+ case break (=='/') xs of
+ (_, []) ->
+ decodeData ("text/plain" : mediapart) enc thedata
+ _ ->
+ decodeData mediapart enc thedata
+ _ -> decodeData ["text/plain", "charset=US-ASCII"] enc thedata
+
+decodeData mediatype enc thedata =
+ Just ( unparse mediatype
+ , case enc of
+ URL -> URLCoding.decode thedata
+ BASE64 -> Base64.decode thedata
+ )
+
+breakList :: (x -> Bool) -> [x] -> [[x]]
+breakList p xs =
+ let (pre, post) = break p xs in
+ case post of
+ [] -> [pre]
+ y:ys -> pre : breakList p ys
+
+unparse [] = ""
+unparse [xs] = xs
+unparse (xs:xss) = xs ++ ';' : unparse xss
diff --git a/libsrc/MissingH/Wash/Utility/SHA1.hs b/libsrc/MissingH/Wash/Utility/SHA1.hs
new file mode 100644
index 0000000..3dd1ccb
--- /dev/null
+++ b/libsrc/MissingH/Wash/Utility/SHA1.hs
@@ -0,0 +1,50 @@
+-- SHA1 hash function.
+
+-- SHA1:
+-- http://sea-to-sky.net/~sreid/sha1.c
+
+module SHA1 where
+
+import Int
+import Ptr
+import MarshalAlloc
+import CString
+import CTypes
+import IOExts
+import Storable (pokeByteOff)
+import Bits
+import Char
+
+type SHA1_CTX = ()
+type SHA1_DIGEST = Ptr CChar
+
+foreign import ccall "sha1lib.h SHA1Init"
+ sha1_init :: Ptr SHA1_CTX -> IO ()
+foreign import ccall "sha1lib.h SHA1Update"
+ sha1_update :: Ptr SHA1_CTX -> Ptr CChar -> Int32 -> IO ()
+foreign import ccall "sha1lib.h SHA1Final"
+ sha1_final :: SHA1_DIGEST -> Ptr SHA1_CTX -> IO ()
+
+sha1 :: String -> String
+sha1 str =
+ unsafePerformIO $
+ do sha1_context <- mallocBytes (64 + 5*4 + 2*4)
+ sha1_digest <- mallocBytes 20
+ sha1_init sha1_context
+ let loop s =
+ -- Process 16KB block in every round.
+ case splitAt 16384 s of
+ (xs, ys) ->
+ do cs <- newCString xs
+ sha1_update sha1_context cs (fromIntegral (length xs))
+ case ys of
+ [] -> return ()
+ _ -> loop ys
+ loop str
+ sha1_final sha1_digest sha1_context
+ peekCStringLen (sha1_digest, 20)
+
+
+
+
+
diff --git a/libsrc/MissingH/Wash/Utility/Shell.hs b/libsrc/MissingH/Wash/Utility/Shell.hs
new file mode 100644
index 0000000..fae193a
--- /dev/null
+++ b/libsrc/MissingH/Wash/Utility/Shell.hs
@@ -0,0 +1,20 @@
+-- © 2002 Peter Thiemann
+-- |Defines functions for shell quotation.
+module Shell where
+
+import Char
+
+-- |Shell meta characters are /! & ; \` \' \" | * ? ~ \< \> ^ ( ) [ ] true $ n r/
+metaCharacters :: String
+metaCharacters = " !&;`\'\"|*?~<>^()[]$\\%{}"
+
+-- |Quotes all shell meta characters and removes non printable ones.
+quote :: String -> String
+quote "" = ""
+quote (x:xs) | isPrint x =
+ if x `elem` metaCharacters
+ then '\\' : x : quote xs
+ else x : quote xs
+ | otherwise =
+ quote xs
+
diff --git a/libsrc/MissingH/Wash/Utility/SimpleParser.hs b/libsrc/MissingH/Wash/Utility/SimpleParser.hs
new file mode 100644
index 0000000..43890dc
--- /dev/null
+++ b/libsrc/MissingH/Wash/Utility/SimpleParser.hs
@@ -0,0 +1,60 @@
+-- © 2002 Peter Thiemann
+module SimpleParser where
+
+import Char
+
+-- very simple parser combinators: Parsec is too sophisticated!
+newtype Parser a b = Parser (a -> [(b, a)])
+unParser (Parser g) = g
+instance Monad (Parser a) where
+ return x = Parser (\ w -> [(x, w)])
+ m >>= f = let g = unParser m in
+ Parser (\ w -> [ (y, w'') | (x, w') <- g w, (y, w'') <- unParser (f x) w'])
+ fail str = Parser (\ w -> [])
+
+satisfy p = Parser (\ w -> [(x, w') | x:w' <- [w], p x])
+
+print = satisfy isPrint
+alphaNum = satisfy isAlphaNum
+alpha = satisfy isAlpha
+ascii = satisfy isAscii
+digit = satisfy isDigit
+char c = satisfy (==c)
+string s = foldr (\ x p -> do { c <- char x; cs <- p; return (c:cs); }) (return "") s
+oneOf cs = satisfy (`elem` cs)
+noneOf cs = satisfy (not . (`elem` cs))
+
+eof = Parser (\ w -> if null w then [((),[])] else [])
+try parser = parser
+p1 <|> p2 = let g1 = unParser p1
+ g2 = unParser p2
+ in Parser (\w -> g1 w ++ g2 w)
+
+option :: x -> Parser a x -> Parser a x
+option x parser = parser <|> return x
+
+many1 p =
+ do x <- p
+ xs <- many p
+ return (x : xs)
+
+many p =
+ option [] (many1 p)
+
+manyn n p =
+ if n <= 0
+ then return []
+ else do x <- p
+ xs <- manyn (n-1) p
+ return (x : xs)
+
+
+parseFromString :: Parser String x -> String -> Maybe x
+parseFromString parser str =
+ let g = unParser (parser >>= (\x -> eof >> return x)) in
+ case g str of
+ (x, ""): _ -> Just x
+ _ -> Nothing
+
+parserToRead :: Parser String x -> ReadS x
+parserToRead parser = unParser parser
diff --git a/libsrc/MissingH/Wash/Utility/URLCoding.hs b/libsrc/MissingH/Wash/Utility/URLCoding.hs
new file mode 100644
index 0000000..2b3d8d6
--- /dev/null
+++ b/libsrc/MissingH/Wash/Utility/URLCoding.hs
@@ -0,0 +1,26 @@
+-- © 2001, 2002 Peter Thiemann
+-- |Implements coding of non-alphanumeric characters in URLs and CGI-requests.
+module URLCoding (encode, decode) where
+
+import Char
+import Hex
+
+encode, decode :: String -> String
+encode = urlEncode
+decode = urlDecode
+
+urlEncode :: String -> String
+urlEncode "" = ""
+urlEncode (x:xs) | isAlphaNum x = x : urlEncode xs
+ | x == ' ' = '+' : urlEncode xs
+ | otherwise = '%' : showHex2 (ord x) ++ urlEncode xs
+
+urlDecode :: String -> String
+urlDecode "" = ""
+urlDecode ('+':xs) =
+ ' ' : urlDecode xs
+urlDecode ('%':upper:lower:xs) =
+ chr (16 * hexDigitVal upper + hexDigitVal lower) : urlDecode xs
+urlDecode (x:xs) =
+ x : urlDecode xs
+
diff --git a/libsrc/MissingH/Wash/Utility/Unique.hs b/libsrc/MissingH/Wash/Utility/Unique.hs
new file mode 100644
index 0000000..fefd85c
--- /dev/null
+++ b/libsrc/MissingH/Wash/Utility/Unique.hs
@@ -0,0 +1,67 @@
+-- © 2001 Peter Thiemann
+module Unique (inventStdKey, inventKey, inventFilePath) where
+
+import Random
+import IO
+import Directory
+import Auxiliary
+import List
+import Monad
+import Locking
+
+registryDir = "/tmp/Unique/"
+
+-- |Creates a random string of 20 letters and digits.
+inventStdKey :: IO String
+inventStdKey = inventKey 20 stdKeyChars
+
+stdKeyChars = ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9']
+
+-- |Creates a unique string from a given length and alphabet.
+inventKey :: Int -> String -> IO String
+inventKey len chars =
+ do g <- newStdGen
+ let candidate = take len $ map (chars !!) $ randomRs (0, length chars - 1) g
+ dirname = registryDir ++ candidate
+ catch (do createDirectory dirname
+ return candidate)
+ (\ ioe ->
+ if isAlreadyExistsError ioe then
+ -- might want to check here for timeout
+ inventKey len chars
+ else if isDoesNotExistError ioe then
+ do assertDirectoryExists registryDir (return ())
+ setPermissions registryDir (Permissions True True True True)
+ inventKey len chars
+ else do hPutStrLn stderr ("inventKey could not create " ++ show dirname)
+ ioError ioe)
+
+-- |Create a unique temporary file name
+inventFilePath :: IO String
+inventFilePath =
+ do key <- inventStdKey
+ return (registryDir ++ key ++ "/f")
+
+-- obsolete. registryFile is a bottleneck.
+
+registryFile = registryDir ++ "REGISTRY"
+
+inventKey' :: Int -> String -> IO String
+inventKey' len chars =
+ do g <- newStdGen
+ let candidate = take len $ map (chars !!) $ randomRs (0, length chars - 1) g
+ obtainLock registryFile
+ registry <- readRegistry
+ let passwords = lines registry
+ if candidate `elem` passwords
+ then do releaseLock registryFile
+ inventKey' len chars
+ else do appendFile registryFile (candidate ++ "\n")
+ releaseLock registryFile
+ return candidate
+
+readRegistry :: IO String
+readRegistry =
+ let registryPath = init registryDir in
+ do assertDirectoryExists registryPath (return ())
+ readFileNonExistent registryFile ""
diff --git a/libsrc/MissingH/Wash/Utility/sha1lib.c b/libsrc/MissingH/Wash/Utility/sha1lib.c
new file mode 100644
index 0000000..6701777
--- /dev/null
+++ b/libsrc/MissingH/Wash/Utility/sha1lib.c
@@ -0,0 +1,248 @@
+/*
+SHA-1 in C
+By Steve Reid <sreid at sea-to-sky.net>
+100% Public Domain
+
+-----------------
+Modified 7/98
+By James H. Brown <jbrown at burgoyne.com>
+Still 100% Public Domain
+
+-----------------
+Library version 8/03
+by Niklas Deutschmann <nickel.de at gmx.de>
+Still 100% Public domain!
+
+Corrected a problem which generated improper hash values on 16 bit machines
+Routine SHA1Update changed from
+ void SHA1Update(SHA1_CTX* context, unsigned char* data, unsigned int len)
+to
+ void SHA1Update(SHA1_CTX* context, unsigned char* data, unsigned long len)
+
+The 'len' parameter was declared an int which works fine on 32 bit machines.
+However, on 16 bit machines an int is too small for the shifts being done
+against it. This caused the hash function to generate incorrect values if len was
+greater than 8191 (8K - 1) due to the 'len << 3' on line 3 of SHA1Update().
+
+Since the file IO in main() reads 16K at a time, any file 8K or larger would
+be guaranteed to generate the wrong hash (e.g. Test Vector #3, a million
+"a"s).
+
+I also changed the declaration of variables i & j in SHA1Update to
+unsigned long from unsigned int for the same reason.
+
+These changes should make no difference to any 32 bit implementations since
+an int and a long are the same size in those environments.
+
+--
+I also corrected a few compiler warnings generated by Borland C.
+1. Added #include <process.h> for exit() prototype
+2. Removed unused variable 'j' in SHA1Final
+3. Changed exit(0) to return(0) at end of main.
+
+ALL changes I made can be located by searching for comments containing 'JHB'
+-----------------
+Modified 8/98
+By Steve Reid <sreid at sea-to-sky.net>
+Still 100% public domain
+
+1- Removed #include <process.h> and used return() instead of exit()
+2- Fixed overwriting of finalcount in SHA1Final() (discovered by Chris Hall)
+3- Changed email address from steve at edmweb.com to sreid at sea-to-sky.net
+
+-----------------
+Modified 4/01
+By Saul Kravitz <Saul.Kravitz at celera.com>
+Still 100% PD
+Modified to run on Compaq Alpha hardware.
+
+
+*/
+
+/*
+Test Vectors (from FIPS PUB 180-1)
+"abc"
+ A9993E36 4706816A BA3E2571 7850C26C 9CD0D89D
+"abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq"
+ 84983E44 1C3BD26E BAAE4AA1 F95129E5 E54670F1
+A million repetitions of "a"
+ 34AA973C D4C4DAA4 F61EEB2B DBAD2731 6534016F
+*/
+
+/* #define SHA1HANDSOFF */
+
+#include <stdio.h>
+#include <string.h>
+
+#include "sha1lib.h"
+
+/* #include <process.h> */ /* prototype for exit() - JHB */
+/* Using return() instead of exit() - SWR */
+
+void SHA1Transform(uint32 state[5], unsigned char buffer[64]);
+
+#define rol(value, bits) (((value) << (bits)) | ((value) >> (32 - (bits))))
+
+/* blk0() and blk() perform the initial expand. */
+/* I got the idea of expanding during the round function from SSLeay */
+#ifdef LITTLE_ENDIAN
+#define blk0(i) (block->l[i] = (rol(block->l[i],24)&0xFF00FF00) \
+ |(rol(block->l[i],8)&0x00FF00FF))
+#else
+#define blk0(i) block->l[i]
+#endif
+#define blk(i) (block->l[i&15] = rol(block->l[(i+13)&15]^block->l[(i+8)&15] \
+ ^block->l[(i+2)&15]^block->l[i&15],1))
+
+/* (R0+R1), R2, R3, R4 are the different operations used in SHA1 */
+#define R0(v,w,x,y,z,i) z+=((w&(x^y))^y)+blk0(i)+0x5A827999+rol(v,5);w=rol(w,30);
+#define R1(v,w,x,y,z,i) z+=((w&(x^y))^y)+blk(i)+0x5A827999+rol(v,5);w=rol(w,30);
+#define R2(v,w,x,y,z,i) z+=(w^x^y)+blk(i)+0x6ED9EBA1+rol(v,5);w=rol(w,30);
+#define R3(v,w,x,y,z,i) z+=(((w|x)&y)|(w&x))+blk(i)+0x8F1BBCDC+rol(v,5);w=rol(w,30);
+#define R4(v,w,x,y,z,i) z+=(w^x^y)+blk(i)+0xCA62C1D6+rol(v,5);w=rol(w,30);
+
+
+#ifdef VERBOSE /* SAK */
+void SHAPrintContext(SHA1_CTX *context, char *msg){
+ printf("%s (%d,%d) %x %x %x %x %x\n",
+ msg,
+ context->count[0], context->count[1],
+ context->state[0],
+ context->state[1],
+ context->state[2],
+ context->state[3],
+ context->state[4]);
+}
+#endif
+
+/* Hash a single 512-bit block. This is the core of the algorithm. */
+void SHA1Transform(uint32 state[5], unsigned char buffer[64])
+{
+ uint32 a, b, c, d, e;
+ typedef union {
+ unsigned char c[64];
+ uint32 l[16];
+ } CHAR64LONG16;
+ CHAR64LONG16* block;
+#ifdef SHA1HANDSOFF
+ static unsigned char workspace[64];
+ block = (CHAR64LONG16*)workspace;
+ memcpy(block, buffer, 64);
+#else
+ block = (CHAR64LONG16*)buffer;
+#endif
+ /* Copy context->state[] to working vars */
+ a = state[0];
+ b = state[1];
+ c = state[2];
+ d = state[3];
+ e = state[4];
+ /* 4 rounds of 20 operations each. Loop unrolled. */
+ R0(a,b,c,d,e, 0); R0(e,a,b,c,d, 1); R0(d,e,a,b,c, 2); R0(c,d,e,a,b, 3);
+ R0(b,c,d,e,a, 4); R0(a,b,c,d,e, 5); R0(e,a,b,c,d, 6); R0(d,e,a,b,c, 7);
+ R0(c,d,e,a,b, 8); R0(b,c,d,e,a, 9); R0(a,b,c,d,e,10); R0(e,a,b,c,d,11);
+ R0(d,e,a,b,c,12); R0(c,d,e,a,b,13); R0(b,c,d,e,a,14); R0(a,b,c,d,e,15);
+ R1(e,a,b,c,d,16); R1(d,e,a,b,c,17); R1(c,d,e,a,b,18); R1(b,c,d,e,a,19);
+ R2(a,b,c,d,e,20); R2(e,a,b,c,d,21); R2(d,e,a,b,c,22); R2(c,d,e,a,b,23);
+ R2(b,c,d,e,a,24); R2(a,b,c,d,e,25); R2(e,a,b,c,d,26); R2(d,e,a,b,c,27);
+ R2(c,d,e,a,b,28); R2(b,c,d,e,a,29); R2(a,b,c,d,e,30); R2(e,a,b,c,d,31);
+ R2(d,e,a,b,c,32); R2(c,d,e,a,b,33); R2(b,c,d,e,a,34); R2(a,b,c,d,e,35);
+ R2(e,a,b,c,d,36); R2(d,e,a,b,c,37); R2(c,d,e,a,b,38); R2(b,c,d,e,a,39);
+ R3(a,b,c,d,e,40); R3(e,a,b,c,d,41); R3(d,e,a,b,c,42); R3(c,d,e,a,b,43);
+ R3(b,c,d,e,a,44); R3(a,b,c,d,e,45); R3(e,a,b,c,d,46); R3(d,e,a,b,c,47);
+ R3(c,d,e,a,b,48); R3(b,c,d,e,a,49); R3(a,b,c,d,e,50); R3(e,a,b,c,d,51);
+ R3(d,e,a,b,c,52); R3(c,d,e,a,b,53); R3(b,c,d,e,a,54); R3(a,b,c,d,e,55);
+ R3(e,a,b,c,d,56); R3(d,e,a,b,c,57); R3(c,d,e,a,b,58); R3(b,c,d,e,a,59);
+ R4(a,b,c,d,e,60); R4(e,a,b,c,d,61); R4(d,e,a,b,c,62); R4(c,d,e,a,b,63);
+ R4(b,c,d,e,a,64); R4(a,b,c,d,e,65); R4(e,a,b,c,d,66); R4(d,e,a,b,c,67);
+ R4(c,d,e,a,b,68); R4(b,c,d,e,a,69); R4(a,b,c,d,e,70); R4(e,a,b,c,d,71);
+ R4(d,e,a,b,c,72); R4(c,d,e,a,b,73); R4(b,c,d,e,a,74); R4(a,b,c,d,e,75);
+ R4(e,a,b,c,d,76); R4(d,e,a,b,c,77); R4(c,d,e,a,b,78); R4(b,c,d,e,a,79);
+ /* Add the working vars back into context.state[] */
+ state[0] += a;
+ state[1] += b;
+ state[2] += c;
+ state[3] += d;
+ state[4] += e;
+ /* Wipe variables */
+ a = b = c = d = e = 0;
+}
+
+
+/* SHA1Init - Initialize new context */
+
+void SHA1Init(SHA1_CTX* context)
+{
+ /* SHA1 initialization constants */
+ context->state[0] = 0x67452301;
+ context->state[1] = 0xEFCDAB89;
+ context->state[2] = 0x98BADCFE;
+ context->state[3] = 0x10325476;
+ context->state[4] = 0xC3D2E1F0;
+ context->count[0] = context->count[1] = 0;
+}
+
+
+/* Run your data through this. */
+
+void SHA1Update(SHA1_CTX* context, unsigned char* data, uint32 len) /* JHB */
+{
+ uint32 i, j; /* JHB */
+
+#ifdef VERBOSE
+ SHAPrintContext(context, "before");
+#endif
+ j = (context->count[0] >> 3) & 63;
+ if ((context->count[0] += len << 3) < (len << 3)) context->count[1]++;
+ context->count[1] += (len >> 29);
+ if ((j + len) > 63) {
+ memcpy(&context->buffer[j], data, (i = 64-j));
+ SHA1Transform(context->state, context->buffer);
+ for ( ; i + 63 < len; i += 64) {
+ SHA1Transform(context->state, &data[i]);
+ }
+ j = 0;
+ }
+ else i = 0;
+ memcpy(&context->buffer[j], &data[i], len - i);
+#ifdef VERBOSE
+ SHAPrintContext(context, "after ");
+#endif
+}
+
+
+/* Add padding and return the message digest. */
+
+void SHA1Final(unsigned char digest[20], SHA1_CTX* context) {
+ uint32 i; /* JHB */
+ unsigned char finalcount[8];
+
+ for (i = 0; i < 8; i++) {
+ finalcount[i] = (unsigned char)((context->count[(i >= 4 ? 0 : 1)]
+ >> ((3-(i & 3)) * 8) ) & 255); /* Endian independent */
+ }
+ SHA1Update(context, (unsigned char *)"\200", 1);
+ while ((context->count[0] & 504) != 448) {
+ SHA1Update(context, (unsigned char *)"\0", 1);
+ }
+ SHA1Update(context, finalcount, 8); /* Should cause a SHA1Transform()
+ */
+ for (i = 0; i < 20; i++) {
+ digest[i] = (unsigned char)
+ ((context->state[i>>2] >> ((3-(i & 3)) * 8) ) & 255);
+ }
+ /* Wipe variables */
+ i = 0; /* JHB */
+ memset(context->buffer, 0, 64);
+ memset(context->state, 0, 20);
+ memset(context->count, 0, 8);
+ memset(finalcount, 0, 8); /* SWR */
+#ifdef SHA1HANDSOFF /* make SHA1Transform overwrite it's own static vars */
+ SHA1Transform(context->state, context->buffer);
+#endif
+}
+
+/*************************************************************/
+
+
+
diff --git a/libsrc/MissingH/Wash/Utility/sha1lib.h b/libsrc/MissingH/Wash/Utility/sha1lib.h
new file mode 100644
index 0000000..33ac4c5
--- /dev/null
+++ b/libsrc/MissingH/Wash/Utility/sha1lib.h
@@ -0,0 +1,28 @@
+#ifndef _SHA1LIB_H_
+#define _SHA1LIB_H_
+
+#ifndef i386 /* For ALPHA (SAK) */
+#define LITTLE_ENDIAN
+typedef long int int64;
+typedef unsigned long int uint64;
+typedef int int32;
+typedef unsigned int uint32;
+#else /*i386*/
+#define LITTLE_ENDIAN
+typedef long long int int64;
+typedef unsigned long long int uint64;
+typedef long int int32;
+typedef unsigned long int uint32;
+#endif /*i386*/
+
+typedef struct {
+ uint32 state[5];
+ uint32 count[2];
+ unsigned char buffer[64];
+} SHA1_CTX;
+
+void SHA1Init(SHA1_CTX* context);
+void SHA1Update(SHA1_CTX* context, unsigned char* data, uint32 len); /* JHB */
+void SHA1Final(unsigned char digest[20], SHA1_CTX* context);
+
+#endif
--
haskell-testpack
More information about the Pkg-haskell-commits
mailing list