Add fetchInternalDate; fix RFC 3501 zone rendering in date-time output

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

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

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
            ]