From a45fa188046ab652150d332f48202f0e3fa5ea82 Mon Sep 17 00:00:00 2001
From: Gregor Kleen <aethoago@141.li>
Date: Mon, 30 Jan 2017 13:33:33 +0100
Subject: Support a X-Timezone header

---
 lib/Postdelay/Scan.hs     | 27 ++++++++++++++++-----------
 lib/Postdelay/TimeSpec.hs |  7 +++++--
 2 files changed, 21 insertions(+), 13 deletions(-)

(limited to 'lib/Postdelay')

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
diff --git a/lib/Postdelay/TimeSpec.hs b/lib/Postdelay/TimeSpec.hs
index af8d801..676dabf 100644
--- a/lib/Postdelay/TimeSpec.hs
+++ b/lib/Postdelay/TimeSpec.hs
@@ -2,6 +2,7 @@
 
 module Postdelay.TimeSpec
   ( pTimeSpec
+  , pTimeZone
   , TimeCtx(..)
   ) where
 
@@ -308,7 +309,7 @@ pTimeBase = choice' [ do
     pMinute = ensure (< 60) =<< natural
     pSecond = decimal
 
-pTimeZone :: MonadTP m => ParsecT String () m (Either TimeZone TZ)
+pTimeZone :: MonadIO m => ParsecT String () m (Either TimeZone TZ)
 pTimeZone = choice' [ do
                         sgn <- choice [ id <$ char '+'
                                       , negate <$ char '-'
@@ -317,7 +318,9 @@ pTimeZone = choice' [ do
                         ms <- option 0 $ (\d u -> 10 * d + u) <$> digit <*> digit
                         return . Left . minutesToTimeZone $ hs * 60 + ms
                     , do
-                        n <- many1 $ letter <|> char '/'
+                        let
+                          ident = (++) <$> many1 alphaNum <*> option "" ((:) <$> oneOf "_-/.+" <*> ident)
+                        n <- ident
                         tz <- liftIO $ do
                           let
                             fbHandler :: IO a -> (IOException -> IO a)
-- 
cgit v1.2.3