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..b4c6301 100644 --- a/src/Network/HaskellNet/IMAP.hs +++ b/src/Network/HaskellNet/IMAP.hs @@ -15,9 +15,12 @@ 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 + , DatetimeParseError(..), FetchInternalDateError(..) -- * other types , Flag(..), Attribute(..), MailboxStatus(..) , SearchQuery(..), FlagsQuery(..) @@ -401,6 +404,29 @@ 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 (Either FetchInternalDateError CalendarTime) +fetchInternalDate conn uid = + do lst <- fetchByByteString conn uid "INTERNALDATE" + 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 fetchHeaderFields conn uid hs = @@ -830,12 +856,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 +865,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 +877,99 @@ 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) + +-- | 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 +-- 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 DatetimeParseError 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 (DatetimeMalformed 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 (DateMalformed 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 (TimeMalformed 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 (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 (MonthUnknown s) + readFully what s = + case reads s of + [(value, "")] -> Right value + _ -> Left (NumberMalformed what 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..fdf8a70 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,65 @@ 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" + ] + 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 +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 (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 (show err) + Right t -> 2 @=? ctDay t + , "round-trips through datetimeToStringIMAP" ~: TestCase $ + case IMAP.stringToDatetimeIMAP (IMAP.datetimeToStringIMAP sampleTime { ctTZ = 7200 }) of + 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 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 @@ -527,6 +587,7 @@ testData = [ "base" ~: baseTest , "imap commands" ~: imapCommandTest , "flags" ~: flagTest , "imap fetch api" ~: imapFetchTest + , "datetime" ~: datetimeTest ]