Timezones

1 files changed, 39 insertions, 10 deletions

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"