Resolve haskell#272. Allow 23:59 as maximum/minimum tz offset

albertodvp · Jun 19, 2023 · 3774a8d · 3774a8d
1 parent 9a48ced
commit 3774a8d
Show file tree

Hide file tree

Showing 2 changed files with 16 additions and 7 deletions.
diff --git a/text-iso8601/src/Data/Time/FromText.hs b/text-iso8601/src/Data/Time/FromText.hs
@@ -131,6 +131,9 @@ parseTimeOfDay = parseTimeOfDay_ kontEOF $ \_ _ _ c _ -> unexpectedChar c "end-o
 --
 -- The accepted formats are @Z@, @+HH@, @+HHMM@, or @+HH:MM@. (@+@ can be @-@).
 --
+-- Accepts @-23:59..23:59@ range, i.e. @HH < 24@ and @MM < 59@.
+-- (This is consistent with grammar, and with what Python, Clojure, joda-time do).
+--
 parseTimeZone :: Text -> Either String Local.TimeZone
 parseTimeZone = parseTimeZone_ Right
 
@@ -485,11 +488,9 @@ parseTimeZone__ x kont c t0 = case c of
 
     withResult :: (Int -> Int) -> Int -> Int -> (Local.TimeZone -> Either String b) -> Either String b
     withResult posNeg hh mm kontR =
-        let off = posNeg (hh * 60 + mm)
-        in if off < (-720) || off > 840 || mm > 59
-           then Left $ "Invalid TimeZone:" ++ show (hh, mm)
-           else kontR (Local.minutesToTimeZone off)
-
+        if hh < 24 && mm < 60
+        then kontR (Local.minutesToTimeZone (posNeg (hh * 60 + mm)))
+        else Left $ "Invalid TimeZone:" ++ show (hh, mm)
 
 {-# INLINE parseLocalTime_ #-}
 parseLocalTime_

diff --git a/text-iso8601/tests/text-iso8601-tests.hs b/text-iso8601/tests/text-iso8601-tests.hs
@@ -57,6 +57,10 @@ main = defaultMain $ testGroup "text-iso8601"
         -- ISO8601 allows various offsets, while RFC3339 only +-HH:MM
         , accepts T.parseUTCTime "1990-12-31T15:59:60-0800" -- no colon
         , accepts T.parseUTCTime "1990-12-31T15:59:60-08"   -- just hour
+
+        -- accepts +23:59
+        , accepts T.parseUTCTime "1937-01-01T12:00:00+23:59"
+        , accepts T.parseUTCTime "1937-01-01T12:00:00-23:59"
         ]
 
     , testGroup "rejected"
@@ -70,6 +74,10 @@ main = defaultMain $ testGroup "text-iso8601"
         -- RFC3339 says we MAY limit, i.e. requiring they should be uppercase.
         , rejects T.parseUTCTime "2023-06-09T02:35:33z"
         , rejects T.parseUTCTime "2023-06-09t02:35:33Z"
+
+        -- accepts +23:59, but not 24 or 60
+        , rejects T.parseUTCTime "1937-01-01T12:00:00+24:59"
+        , rejects T.parseUTCTime "1937-01-01T12:00:00-23:60"
         ]
     ]
 
@@ -91,13 +99,13 @@ roundtrip eq build parse = testProperty (show (typeRep (Proxy :: Proxy a))) $ \x
        property (liftEq eq y (Right x))
 
 rejects :: forall a. (Typeable a, Show a) => (Text -> Either String a) -> String -> TestTree
-rejects parse inp = testCase (show (typeRep (Proxy :: Proxy a)) ++ " accepts " ++ show inp) $ do
+rejects parse inp = testCase (show (typeRep (Proxy :: Proxy a)) ++ " rejects " ++ show inp) $ do
     case parse (T.pack inp) of
         Left _  -> return ()
         Right a -> assertFailure $ "Unexpectedly accepted: " ++ show a
 
 accepts :: forall a. (Typeable a, Show a) => (Text -> Either String a) -> String -> TestTree
-accepts parse inp = testCase (show (typeRep (Proxy :: Proxy a)) ++ " rejects " ++ show inp) $ do
+accepts parse inp = testCase (show (typeRep (Proxy :: Proxy a)) ++ " accepts " ++ show inp) $ do
     case parse (T.pack inp) of
         Left err -> assertFailure $ "Unexpectedly rejected: " ++ err
         Right _  -> return ()