From 127c1212d7704392363e3614f339627bf514cfcf Mon Sep 17 00:00:00 2001
From: Gregor Kleen <aethoago@141.li>
Date: Wed, 15 Feb 2017 19:04:57 +0100
Subject: Timezones

---
 lib/Postdelay/Scan.hs           |  5 ++---
 lib/Postdelay/TimeSpec.hs       | 49 ++++++++++++++++++++++++++++++++---------
 lib/Postdelay/TimeSpec/Units.hs |  4 +---
 lib/Postdelay/TimeSpec/Utils.hs |  3 +++
 4 files changed, 45 insertions(+), 16 deletions(-)

(limited to 'lib/Postdelay')

diff --git a/lib/Postdelay/Scan.hs b/lib/Postdelay/Scan.hs
index 888a237..0a265b4 100644
--- a/lib/Postdelay/Scan.hs
+++ b/lib/Postdelay/Scan.hs
@@ -68,10 +68,9 @@ extractDelay (Message headers _) = do
     zoneHeaders = runListT $ do
       (OptionalField field content) <- ListT $ return headers
       guard $ CI.mk field == "X-Timezone"
-      Right r <- runParserT (spaceConsumer *> lexeme pTimeZone <* eof) field content
-      return r
+      either throwM return =<< runParserT (spaceConsumer *> lexeme timeZone <* eof) field content
     parseDelay :: Field -> m (Endo LocalTime)
-    parseDelay (OptionalField field content) = either throwM return =<< runParserT (spaceConsumer *> lexeme pTimeSpec <* eof) field content
+    parseDelay (OptionalField field content) = either throwM return =<< runParserT (spaceConsumer *> lexeme timeSpec <* eof) field content
 
 localT :: Either TimeZone TZ -> Iso' UTCTime LocalTime
 localT (Left tz) = iso (utcToLocalTime tz) (localTimeToUTC tz)
diff --git a/lib/Postdelay/TimeSpec.hs b/lib/Postdelay/TimeSpec.hs
index 03baf85..fbbce6b 100644
--- a/lib/Postdelay/TimeSpec.hs
+++ b/lib/Postdelay/TimeSpec.hs
@@ -1,8 +1,8 @@
 {-# LANGUAGE FlexibleContexts, ScopedTypeVariables, ViewPatterns, ConstraintKinds, TupleSections, RecordWildCards, TypeFamilies #-}
 
 module Postdelay.TimeSpec
-  ( pTimeSpec
-  , pTimeZone
+  ( timeSpec
+  , timeZone
   
   , spaceConsumer, lexeme
   ) where
@@ -15,6 +15,8 @@ import Text.Megaparsec
 import Control.Monad.IO.Class
 import Control.Applicative
 import Control.Lens hiding ((#))
+import Control.Exception (IOException)
+import Control.Monad.Catch
 
 import Data.Bool
 import Data.Semigroup hiding (option)
@@ -30,22 +32,49 @@ import Data.Time.Zones
 seconds' :: Timeable t => Lens' t Time
 seconds' = seconds . iso (% Second) (# Second)
 
+utcOffset :: Iso' TimeZone Time
+utcOffset = iso ((% Minute) . fromIntegral . timeZoneMinutes) (minutesToTimeZone . round . (# Minute))
 
-pTimeSpec :: StringParser s m => m (Endo LocalTime)
-pTimeSpec = label "Relative time specification" $
-            choice [ pOffsets False
+
+timeSpec :: StringParser s m => m (Endo LocalTime)
+timeSpec = label "Relative time specification" $
+            choice [ offsets False
                    ]
 
-pOffsets :: forall s m. StringParser s m
+offsets :: forall s m. StringParser s m
          => Bool -- ^ Require sign on first offset?
          -> m (Endo LocalTime)
-pOffsets (bool optSigned signed -> reqSgn) = fmap fold $ (:) <$> offset reqSgn <*> many (offset optSigned)
+offsets (bool optSigned signed -> reqSgn) = fmap fold $ (:) <$> offset reqSgn <*> many (offset optSigned)
   where
     asOffset :: Time -> Endo LocalTime
     asOffset by = Endo $ flexDT.seconds' %~ (^+^ by)
     offset :: (m Time -> m Time) -> m (Endo LocalTime)
     offset sgn = asOffset <$> lexeme (sgn timeLength) <?> "Time offset"
 
-pTimeZone :: (StringParser s m, MonadIO m) => m (Either TimeZone TZ)
-pTimeZone = label "Timezone" $
-            empty
+timeZone :: (StringParser s m, MonadIO m) => m (Either TimeZone TZ)
+timeZone = label "Timezone" $ (Left <$> numericTimezone) <|> (Right <$> namedTimezone)
+
+numericTimezone :: StringParser s m => m TimeZone
+numericTimezone = review utcOffset <$> (sign <*> ((^+^) <$> hour <*> minute)) <?> "Numeric timezone"
+  where
+    hour = (% Hour) <$> twoDigit
+    minute = (% Minute) <$> twoDigit
+    twoDigit = (\n1 n2 -> fromDigit n1 * 10 + fromDigit n2) <$> digitChar <*> digitChar
+
+namedTimezone :: (StringParser s m, MonadIO m) => m TZ
+namedTimezone = do
+  n <- ident
+  tz <- liftIO $ do
+    let
+      fbHandler :: IO a -> (IOException -> IO a)
+      fbHandler fb _ = fb
+    foldl (\fb a -> a `catch` fbHandler fb) (return Nothing)
+      [ Just <$> loadSystemTZ n
+      , Just <$> loadTZFromDB n
+      ]
+  case tz of
+    Nothing   -> fail $ "Could not resolve timezone: " ++ show n
+    (Just tz) -> return tz
+  where
+    asciiAlphaNum = oneOf $ ['0'..'9'] ++ ['a'..'z'] ++ ['A'..'Z']
+    ident = (++) <$> some asciiAlphaNum <*> option [] ((:) <$> oneOf "_-/.+" <*> ident) <?> "Named timezone identifier"
diff --git a/lib/Postdelay/TimeSpec/Units.hs b/lib/Postdelay/TimeSpec/Units.hs
index 0062460..a094ea3 100644
--- a/lib/Postdelay/TimeSpec/Units.hs
+++ b/lib/Postdelay/TimeSpec/Units.hs
@@ -62,10 +62,8 @@ rational :: forall s m n. (StringParser s m, Fractional n, Num n) => m n
 rational = combine <$> some digitChar <*> option [] (char '.' *> many digitChar) <?> "Decimal number"
   where
     combine :: [Char] -> [Char] -> n
-    combine (map asN -> whole) (map asN -> fractional)
+    combine (map fromDigit -> whole) (map fromDigit -> fractional)
       = foldl' (\i l -> i * 10 + l) 0 whole + (foldr' (\h t -> h + t / 10) 0 fractional) / 10
-    asN :: Char -> n
-    asN c = fromIntegral $ fromEnum c - fromEnum '0'
 
 timeUnit :: StringParser s m => m Time
 timeUnit = label "Unit of time" . choice $
diff --git a/lib/Postdelay/TimeSpec/Utils.hs b/lib/Postdelay/TimeSpec/Utils.hs
index 85ac299..83a271d 100644
--- a/lib/Postdelay/TimeSpec/Utils.hs
+++ b/lib/Postdelay/TimeSpec/Utils.hs
@@ -35,3 +35,6 @@ sign :: (StringParser s m, AdditiveGroup n) => m (n -> n)
 sign = label "sign" $ choice [ char '+' $> id
                              , char '-' $> negateV
                              ]
+
+fromDigit :: Num n => Char -> n
+fromDigit c = fromIntegral $ fromEnum c - fromEnum '0'
-- 
cgit v1.2.3