Support a X-Timezone header

1 files changed, 16 insertions, 11 deletions

diff --git a/lib/Postdelay/Scan.hs b/lib/Postdelay/Scan.hs
index fba9f35..2f0a78a 100644
--- a/lib/Postdelay/Scan.hs
+++ b/lib/Postdelay/Scan.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE OverloadedStrings, ScopedTypeVariables, FlexibleContexts, RecordWildCards, ViewPatterns #-}
+{-# LANGUAGE OverloadedStrings, ScopedTypeVariables, FlexibleContexts, RecordWildCards, ViewPatterns, TupleSections #-}
 
 module Postdelay.Scan
   ( scan
@@ -45,24 +45,29 @@ scan :: (MonadIO m, MonadError ParseError m) => String -> m (Maybe Delay)
 scan = fmap getOption . extractDelay <=< either throwError return . parse message ""
 
 extractDelay :: forall m. (MonadIO m, MonadError ParseError m) => Message -> m (Option Delay)
-extractDelay (Message headers _)
-  = let latestCtx = maximumBy (comparing baseTime) dateHeaders
-    in foldMap pure <$> mapM (flip runReaderT latestCtx . parseDelay) delayHeaders
+extractDelay (Message headers _) = do
+  zones <- zoneHeaders
+  let (baseTime, dateTz) = maximumBy (comparing fst) dateHeaders
+      tz = foldr' (flip (<>)) (Left dateTz) zones
+  foldMap pure <$> mapM (flip runReaderT TimeCtx{..} . parseDelay) delayHeaders
   where
     delayHeaders :: [Field]
     delayHeaders = do
       (OptionalField field content) <- headers
       guard $ CI.mk field == "X-Delay"
       return . OptionalField field $ decodeWords content
-    dateHeaders :: [TimeCtx]
+    dateHeaders :: [(UTCTime, TimeZone)]
     dateHeaders = do
       (Date CalendarTime{..}) <- headers
       let tz = minutesToTimeZone . round $ ctTZ % 60
-      return $ TimeCtx
-        { baseTime = localTimeToUTC tz $ LocalTime
-                     (fromGregorian (fromIntegral ctYear) (fromEnum ctMonth + 1) ctDay)
-                     (TimeOfDay ctHour ctMin $ fromIntegral ctSec + fromIntegral ctPicosec * 1e-12)
-        , tz = Left tz
-        }
+      return . (, tz) . localTimeToUTC tz $ LocalTime
+        (fromGregorian (fromIntegral ctYear) (fromEnum ctMonth + 1) ctDay)
+        (TimeOfDay ctHour ctMin $ fromIntegral ctSec + fromIntegral ctPicosec * 1e-12)
+    zoneHeaders :: m [Either TimeZone TZ]
+    zoneHeaders = runListT $ do
+      (OptionalField field content) <- ListT $ return headers
+      guard $ CI.mk field == "X-Timezone"
+      Right r <- runParserT (spaces *> pTimeZone <* spaces <* eof) () field content
+      return r
     parseDelay :: Field -> ReaderT TimeCtx m Delay
     parseDelay (OptionalField field content) = either throwError return =<< runParserT (Until <$> pTimeSpec) () field content