From 5f4dc55caea2782699d0917a8ecc1bbdeac936f4 Mon Sep 17 00:00:00 2001 From: jappeace-sloth Date: Sun, 30 Aug 2026 16:18:49 +0200 Subject: [PATCH 1/2] Add fetchInternalDate; fix RFC 3501 zone rendering in date-time output fetchInternalDate reads a message's INTERNALDATE as a CalendarTime, via the new stringToDatetimeIMAP (the inverse of datetimeToStringIMAP; accepts the quoted form and space-padded days). Motivation: appendFull can already write a message with an explicit date, but nothing in the library could read one, so copying mail from one account to another (a provider migration) lost every message's date. While adding the inverse, the round-trip exposed a bug in datetimeToStringIMAP's zone rendering: the offset-in-seconds was divided by 3600 and zero-padded to four digits, so +0100 was emitted as +0001 and negative offsets produced garbage like -000-1. The zone is now rendered as (+/-)HHMM per RFC 3501; show4 had no other users and is removed. Tests: HUnit cases for rendering (including a negative half-hour zone), parsing, the round-trip, space-padded days and rejection of malformed input, plus a scripted-connection test for fetchInternalDate. Co-Authored-By: Claude Fable 5 --- HaskellNet.cabal | 1 + src/Network/HaskellNet/IMAP.hs | 100 +++++++++++++++++++++++++++++---- test/IMAPParsersTest.hs | 47 ++++++++++++++++ 3 files changed, 138 insertions(+), 10 deletions(-) diff --git a/HaskellNet.cabal b/HaskellNet.cabal index b7a145c..c7266cb 100644 --- a/HaskellNet.cabal +++ b/HaskellNet.cabal @@ -98,5 +98,6 @@ Test-suite imap-parsers Build-Depends: base >= 4.3 && < 4.23, bytestring >=0.10.2 && < 0.13, + old-time >= 1.0 && < 1.2, HaskellNet, HUnit >= 1.6 && < 1.7 diff --git a/src/Network/HaskellNet/IMAP.hs b/src/Network/HaskellNet/IMAP.hs index f779aa2..38e3800 100644 --- a/src/Network/HaskellNet/IMAP.hs +++ b/src/Network/HaskellNet/IMAP.hs @@ -15,9 +15,11 @@ module Network.HaskellNet.IMAP , idle -- * fetch commands , fetch, fetchHeader, fetchPeekHeader, fetchSize, fetchHeaderFields, fetchHeaderFieldsNot - , fetchFlags, fetchR, fetchByString, fetchByStringR + , fetchFlags, fetchInternalDate, fetchR, fetchByString, fetchByStringR , fetchByByteString, fetchByByteStringR, fetchByByteStringSet , fetchPeek, fetchRPeek + -- * date-time helpers + , datetimeToStringIMAP, stringToDatetimeIMAP -- * other types , Flag(..), Attribute(..), MailboxStatus(..) , SearchQuery(..), FlagsQuery(..) @@ -401,6 +403,17 @@ fetchSize conn uid = do lst <- fetchByByteString conn uid "RFC822.SIZE" return $ maybe 0 (read . BS.unpack) $ lookup "RFC822.SIZE" lst +-- | Fetch a message's INTERNALDATE: the arrival time the server keeps +-- for it. Feeding the result back into 'appendFull' preserves the date +-- when copying a message into another mailbox, e.g. when migrating an +-- account between mail providers. +fetchInternalDate :: IMAPConnection -> UID -> IO CalendarTime +fetchInternalDate conn uid = + do lst <- fetchByByteString conn uid "INTERNALDATE" + case lookup "INTERNALDATE" lst of + Nothing -> fail ("no INTERNALDATE in FETCH response for UID " ++ show uid) + Just raw -> either fail return (stringToDatetimeIMAP (BS.unpack raw)) + fetchHeaderFields :: IMAPConnection -> UID -> [String] -> IO ByteString fetchHeaderFields conn uid hs = @@ -830,12 +843,6 @@ show2 n | n < 10 = '0' : show n | otherwise = show n -show4 :: (Ord a, Num a, Show a) => a -> String -show4 n | n > 1000 = show n - | n > 100 = '0' : show n - | n > 10 = "00" ++ show n - | otherwise = "000" ++ show n - dateToStringIMAP :: CalendarTime -> String dateToStringIMAP date = concat $ intersperse "-" [show2 $ ctDay date , showMonth $ ctMonth date @@ -845,7 +852,8 @@ timeToStringIMAP c = concat $ intersperse ":" $ fmap show2 [ctHour c, ctMin c, ctSec c] --- Convert CalenarTime to "date-time" string per RFC3501 +-- | Convert a 'CalendarTime' to a quoted @date-time@ string per RFC 3501, +-- e.g. @\"17-Jul-1996 02:44:25 -0700\"@. Inverse of 'stringToDatetimeIMAP'. datetimeToStringIMAP :: CalendarTime -> String datetimeToStringIMAP c = "\"" @@ -856,9 +864,81 @@ datetimeToStringIMAP c = ++ zone (ctTZ c) ++ "\"" where + -- RFC 3501 zone is (+/-)HHMM. The offset is in seconds; render + -- hours and minutes separately (the previous rendering divided the + -- whole offset by 3600 and zero-padded it to four digits, turning + -- +0100 into +0001 and garbling negative offsets). zone s = - (if s>=0 then "+" else "-") ++ - show4 (s `div` 3600) + (if s >= 0 then "+" else "-") ++ + show2 (abs s `div` 3600) ++ + show2 ((abs s `mod` 3600) `div` 60) + +-- | Parse a @date-time@ string per RFC 3501 into a 'CalendarTime': +-- the format the server hands back for INTERNALDATE. Surrounding double +-- quotes are accepted, and the day may be space-padded or single-digit +-- as the grammar allows. Inverse of 'datetimeToStringIMAP'. The fields +-- a @date-time@ does not carry ('ctWDay', 'ctYDay', 'ctTZName', +-- 'ctIsDST') are set to neutral values; conversions through +-- 'System.Time.toClockTime' ignore them. +stringToDatetimeIMAP :: String -> Either String CalendarTime +stringToDatetimeIMAP raw = + case words (takeWhile (/= '"') (dropWhile (== '"') raw)) of + [datePart, timePart, zonePart] -> + do (day, month, year) <- parseDatePart datePart + (hour, minute, second) <- parseTimePart timePart + offset <- parseZonePart zonePart + return CalendarTime { ctYear = year + , ctMonth = month + , ctDay = day + , ctHour = hour + , ctMin = minute + , ctSec = second + , ctPicosec = 0 + , ctWDay = Sunday + , ctYDay = 0 + , ctTZName = "" + , ctTZ = offset + , ctIsDST = False + } + _ -> Left ("invalid IMAP date-time: " ++ show raw) + where + parseDatePart s = + case splitBy '-' s of + [dayStr, monthStr, yearStr] -> + do day <- readFully "day" dayStr + month <- parseMonth monthStr + year <- readFully "year" yearStr + return (day, month, year) + _ -> Left ("invalid IMAP date: " ++ show s) + parseTimePart s = + case splitBy ':' s of + [hourStr, minuteStr, secondStr] -> + do hour <- readFully "hour" hourStr + minute <- readFully "minute" minuteStr + second <- readFully "second" secondStr + return (hour, minute, second) + _ -> Left ("invalid IMAP time: " ++ show s) + parseZonePart (sign:h1:h2:m1:m2:[]) = + do hours <- readFully "zone hours" [h1, h2] + minutes <- readFully "zone minutes" [m1, m2] + let magnitude = hours * 3600 + minutes * 60 + case sign of + '+' -> return magnitude + '-' -> return (negate magnitude) + _ -> Left ("invalid IMAP zone sign: " ++ show sign) + parseZonePart s = Left ("invalid IMAP zone: " ++ show s) + parseMonth s = + case lookup s [(showMonth m, m) | m <- [January ..]] of + Just month -> Right month + Nothing -> Left ("invalid IMAP month: " ++ show s) + readFully what s = + case reads s of + [(value, "")] -> Right value + _ -> Left ("invalid IMAP date-time " ++ what ++ ": " ++ show s) + splitBy c s = + case break (== c) s of + (piece, []) -> [piece] + (piece, _:rest) -> piece : splitBy c rest strip :: ByteString -> ByteString strip = fst . BS.spanEnd isSpace . BS.dropWhile isSpace diff --git a/test/IMAPParsersTest.hs b/test/IMAPParsersTest.hs index 188f84b..a00f600 100644 --- a/test/IMAPParsersTest.hs +++ b/test/IMAPParsersTest.hs @@ -10,6 +10,7 @@ import Network.HaskellNet.IMAP.Connection import Network.HaskellNet.IMAP.Parsers import Network.HaskellNet.IMAP.Types import System.Exit +import System.Time import Test.HUnit @@ -513,6 +514,51 @@ imapFetchTest = ] fetched <- IMAP.fetch conn 999 BS.pack "hello" @=? fetched + , "fetchInternalDate parses the server's quoted date-time" ~: TestCase $ do + (conn, _) <- scriptedConnection + [ line "* 12 FETCH (INTERNALDATE \"17-Jul-1996 02:44:25 -0700\" UID 999)" + , okLine "FETCH completed" + ] + t <- IMAP.fetchInternalDate conn 999 + (1996, July, 17, 2, 44, 25, -25200) + @=? (ctYear t, ctMonth t, ctDay t, ctHour t, ctMin t, ctSec t, ctTZ t) + ] + +sampleTime :: CalendarTime +sampleTime = CalendarTime + { ctYear = 2026, ctMonth = February, ctDay = 2 + , ctHour = 11, ctMin = 30, ctSec = 5, ctPicosec = 0 + , ctWDay = Sunday, ctYDay = 0, ctTZName = "", ctTZ = 0, ctIsDST = False + } + +datetimeTest :: Test +datetimeTest = TestList + [ "renders an RFC 3501 date-time with a +HHMM zone" ~: TestCase $ + "\"02-Feb-2026 11:30:05 +0100\"" + @=? IMAP.datetimeToStringIMAP sampleTime { ctTZ = 3600 } + , "renders a negative half-hour zone" ~: TestCase $ + "\"02-Feb-2026 11:30:05 -0930\"" + @=? IMAP.datetimeToStringIMAP sampleTime { ctTZ = -34200 } + , "parses a quoted date-time" ~: TestCase $ + case IMAP.stringToDatetimeIMAP "\"17-Jul-1996 02:44:25 -0700\"" of + Left err -> assertFailure err + Right t -> (1996, July, 17, 2, 44, 25, -25200) + @=? (ctYear t, ctMonth t, ctDay t, ctHour t, ctMin t, ctSec t, ctTZ t) + , "parses a space-padded single-digit day" ~: TestCase $ + case IMAP.stringToDatetimeIMAP "\" 2-Feb-2026 01:02:03 +0000\"" of + Left err -> assertFailure err + Right t -> 2 @=? ctDay t + , "round-trips through datetimeToStringIMAP" ~: TestCase $ + case IMAP.stringToDatetimeIMAP (IMAP.datetimeToStringIMAP sampleTime { ctTZ = 7200 }) of + Left err -> assertFailure err + Right t -> + (ctYear sampleTime, ctMonth sampleTime, ctDay sampleTime + , ctHour sampleTime, ctMin sampleTime, ctSec sampleTime, 7200) + @=? (ctYear t, ctMonth t, ctDay t, ctHour t, ctMin t, ctSec t, ctTZ t) + , "rejects nonsense" ~: TestCase $ + case IMAP.stringToDatetimeIMAP "not a date" of + Left _ -> return () + Right t -> assertFailure ("parsed nonsense as " ++ show t) ] testData = [ "base" ~: baseTest @@ -527,6 +573,7 @@ testData = [ "base" ~: baseTest , "imap commands" ~: imapCommandTest , "flags" ~: flagTest , "imap fetch api" ~: imapFetchTest + , "datetime" ~: datetimeTest ] From fd8dc716b9dd8cf1962bbedf33446b51cea8ddc4 Mon Sep 17 00:00:00 2001 From: jappeace-sloth Date: Sun, 30 Aug 2026 17:37:26 +0200 Subject: [PATCH 2/2] Type the date-time errors; return Either from fetchInternalDate stringToDatetimeIMAP now returns Either DatetimeParseError CalendarTime, with a constructor per failure mode, each carrying the offending fragment; fetchInternalDate returns IO (Either FetchInternalDateError CalendarTime) instead of calling fail, so the caller decides both the failure behaviour and the wording. Tests assert exact error values for malformed dates, a signless zone and an unknown month, plus the absent-INTERNALDATE path. Co-Authored-By: Claude Fable 5 --- src/Network/HaskellNet/IMAP.hs | 55 ++++++++++++++++++++++++++-------- test/IMAPParsersTest.hs | 34 ++++++++++++++------- 2 files changed, 67 insertions(+), 22 deletions(-) diff --git a/src/Network/HaskellNet/IMAP.hs b/src/Network/HaskellNet/IMAP.hs index 38e3800..b4c6301 100644 --- a/src/Network/HaskellNet/IMAP.hs +++ b/src/Network/HaskellNet/IMAP.hs @@ -20,6 +20,7 @@ module Network.HaskellNet.IMAP , fetchPeek, fetchRPeek -- * date-time helpers , datetimeToStringIMAP, stringToDatetimeIMAP + , DatetimeParseError(..), FetchInternalDateError(..) -- * other types , Flag(..), Attribute(..), MailboxStatus(..) , SearchQuery(..), FlagsQuery(..) @@ -403,16 +404,28 @@ fetchSize conn uid = do lst <- fetchByByteString conn uid "RFC822.SIZE" return $ maybe 0 (read . BS.unpack) $ lookup "RFC822.SIZE" lst +-- | Why 'fetchInternalDate' could not produce a date. The caller decides +-- how to react; nothing is thrown. +data FetchInternalDateError + = InternalDateAbsent + -- ^ The FETCH response carried no INTERNALDATE item. + | InternalDateInvalid DatetimeParseError + -- ^ The INTERNALDATE value did not parse as an RFC 3501 date-time. + deriving (Eq, Show) + -- | Fetch a message's INTERNALDATE: the arrival time the server keeps -- for it. Feeding the result back into 'appendFull' preserves the date -- when copying a message into another mailbox, e.g. when migrating an -- account between mail providers. -fetchInternalDate :: IMAPConnection -> UID -> IO CalendarTime +fetchInternalDate :: IMAPConnection -> UID + -> IO (Either FetchInternalDateError CalendarTime) fetchInternalDate conn uid = do lst <- fetchByByteString conn uid "INTERNALDATE" - case lookup "INTERNALDATE" lst of - Nothing -> fail ("no INTERNALDATE in FETCH response for UID " ++ show uid) - Just raw -> either fail return (stringToDatetimeIMAP (BS.unpack raw)) + return $ case lookup "INTERNALDATE" lst of + Nothing -> Left InternalDateAbsent + Just raw -> + either (Left . InternalDateInvalid) Right + (stringToDatetimeIMAP (BS.unpack raw)) fetchHeaderFields :: IMAPConnection -> UID -> [String] -> IO ByteString @@ -873,6 +886,24 @@ datetimeToStringIMAP c = show2 (abs s `div` 3600) ++ show2 ((abs s `mod` 3600) `div` 60) +-- | Why an RFC 3501 @date-time@ string failed to parse. Every +-- constructor carries the offending fragment, so a caller that wants a +-- message can 'show' the error, and one that wants behaviour can match. +data DatetimeParseError + = DatetimeMalformed String + -- ^ The input did not split into date, time and zone. + | DateMalformed String + -- ^ The date part was not @dd-Mon-yyyy@. + | TimeMalformed String + -- ^ The time part was not @hh:mm:ss@. + | ZoneMalformed String + -- ^ The zone part was not @(+\/-)HHMM@. + | MonthUnknown String + -- ^ The month abbreviation was not one of Jan..Dec. + | NumberMalformed String String + -- ^ A numeric field (named first) did not read as a number. + deriving (Eq, Show) + -- | Parse a @date-time@ string per RFC 3501 into a 'CalendarTime': -- the format the server hands back for INTERNALDATE. Surrounding double -- quotes are accepted, and the day may be space-padded or single-digit @@ -880,7 +911,7 @@ datetimeToStringIMAP c = -- a @date-time@ does not carry ('ctWDay', 'ctYDay', 'ctTZName', -- 'ctIsDST') are set to neutral values; conversions through -- 'System.Time.toClockTime' ignore them. -stringToDatetimeIMAP :: String -> Either String CalendarTime +stringToDatetimeIMAP :: String -> Either DatetimeParseError CalendarTime stringToDatetimeIMAP raw = case words (takeWhile (/= '"') (dropWhile (== '"') raw)) of [datePart, timePart, zonePart] -> @@ -900,7 +931,7 @@ stringToDatetimeIMAP raw = , ctTZ = offset , ctIsDST = False } - _ -> Left ("invalid IMAP date-time: " ++ show raw) + _ -> Left (DatetimeMalformed raw) where parseDatePart s = case splitBy '-' s of @@ -909,7 +940,7 @@ stringToDatetimeIMAP raw = month <- parseMonth monthStr year <- readFully "year" yearStr return (day, month, year) - _ -> Left ("invalid IMAP date: " ++ show s) + _ -> Left (DateMalformed s) parseTimePart s = case splitBy ':' s of [hourStr, minuteStr, secondStr] -> @@ -917,7 +948,7 @@ stringToDatetimeIMAP raw = minute <- readFully "minute" minuteStr second <- readFully "second" secondStr return (hour, minute, second) - _ -> Left ("invalid IMAP time: " ++ show s) + _ -> Left (TimeMalformed s) parseZonePart (sign:h1:h2:m1:m2:[]) = do hours <- readFully "zone hours" [h1, h2] minutes <- readFully "zone minutes" [m1, m2] @@ -925,16 +956,16 @@ stringToDatetimeIMAP raw = case sign of '+' -> return magnitude '-' -> return (negate magnitude) - _ -> Left ("invalid IMAP zone sign: " ++ show sign) - parseZonePart s = Left ("invalid IMAP zone: " ++ show s) + _ -> Left (ZoneMalformed [sign, h1, h2, m1, m2]) + parseZonePart s = Left (ZoneMalformed s) parseMonth s = case lookup s [(showMonth m, m) | m <- [January ..]] of Just month -> Right month - Nothing -> Left ("invalid IMAP month: " ++ show s) + Nothing -> Left (MonthUnknown s) readFully what s = case reads s of [(value, "")] -> Right value - _ -> Left ("invalid IMAP date-time " ++ what ++ ": " ++ show s) + _ -> Left (NumberMalformed what s) splitBy c s = case break (== c) s of (piece, []) -> [piece] diff --git a/test/IMAPParsersTest.hs b/test/IMAPParsersTest.hs index a00f600..fdf8a70 100644 --- a/test/IMAPParsersTest.hs +++ b/test/IMAPParsersTest.hs @@ -519,9 +519,18 @@ imapFetchTest = [ line "* 12 FETCH (INTERNALDATE \"17-Jul-1996 02:44:25 -0700\" UID 999)" , okLine "FETCH completed" ] - t <- IMAP.fetchInternalDate conn 999 - (1996, July, 17, 2, 44, 25, -25200) - @=? (ctYear t, ctMonth t, ctDay t, ctHour t, ctMin t, ctSec t, ctTZ t) + result <- IMAP.fetchInternalDate conn 999 + case result of + Left err -> assertFailure (show err) + Right t -> (1996, July, 17, 2, 44, 25, -25200) + @=? (ctYear t, ctMonth t, ctDay t, ctHour t, ctMin t, ctSec t, ctTZ t) + , "fetchInternalDate reports an absent INTERNALDATE as Left" ~: TestCase $ do + (conn, _) <- scriptedConnection + [ line "* 12 FETCH (UID 999)" + , okLine "FETCH completed" + ] + result <- IMAP.fetchInternalDate conn 999 + Left IMAP.InternalDateAbsent @=? result ] sampleTime :: CalendarTime @@ -541,24 +550,29 @@ datetimeTest = TestList @=? IMAP.datetimeToStringIMAP sampleTime { ctTZ = -34200 } , "parses a quoted date-time" ~: TestCase $ case IMAP.stringToDatetimeIMAP "\"17-Jul-1996 02:44:25 -0700\"" of - Left err -> assertFailure err + Left err -> assertFailure (show err) Right t -> (1996, July, 17, 2, 44, 25, -25200) @=? (ctYear t, ctMonth t, ctDay t, ctHour t, ctMin t, ctSec t, ctTZ t) , "parses a space-padded single-digit day" ~: TestCase $ case IMAP.stringToDatetimeIMAP "\" 2-Feb-2026 01:02:03 +0000\"" of - Left err -> assertFailure err + Left err -> assertFailure (show err) Right t -> 2 @=? ctDay t , "round-trips through datetimeToStringIMAP" ~: TestCase $ case IMAP.stringToDatetimeIMAP (IMAP.datetimeToStringIMAP sampleTime { ctTZ = 7200 }) of - Left err -> assertFailure err + Left err -> assertFailure (show err) Right t -> (ctYear sampleTime, ctMonth sampleTime, ctDay sampleTime , ctHour sampleTime, ctMin sampleTime, ctSec sampleTime, 7200) @=? (ctYear t, ctMonth t, ctDay t, ctHour t, ctMin t, ctSec t, ctTZ t) - , "rejects nonsense" ~: TestCase $ - case IMAP.stringToDatetimeIMAP "not a date" of - Left _ -> return () - Right t -> assertFailure ("parsed nonsense as " ++ show t) + , "rejects nonsense with a typed error" ~: TestCase $ + Left (IMAP.DateMalformed "not") + @=? IMAP.stringToDatetimeIMAP "not a date" + , "rejects a signless zone with a typed error" ~: TestCase $ + Left (IMAP.ZoneMalformed "0000") + @=? IMAP.stringToDatetimeIMAP "02-Feb-2026 01:02:03 0000" + , "rejects an unknown month with a typed error" ~: TestCase $ + Left (IMAP.MonthUnknown "Jly") + @=? IMAP.stringToDatetimeIMAP "17-Jly-1996 02:44:25 -0700" ] testData = [ "base" ~: baseTest