Restore parsing of fractional seconds in the Created field.

The old show/read format always included fractional seconds in the
`Created` field; this fixes a bug that was introduced in
9667923 This commit restored parsing
fractional seconds, and modified parsing to allow either format.

Author: nuttycom

src/Database/Schema/Migrations/Filesystem.hs

@@ -11,7 +11,7 @@ where
 import Prelude
 
 import Control.Exception (Exception (..), catch, throw)
-import Control.Monad (filterM)
+import Control.Monad (filterM, msum)
 import Data.Aeson
 import Data.Aeson.Types (typeMismatch)
 import Data.ByteString.Char8 qualified as BSC
@@ -147,18 +147,28 @@ newtype UTCTimeYaml = UTCTimeYaml
 
 instance FromJSON UTCTimeYaml where
   parseJSON =
-    withText "UTCTime" $
-      maybe (fail "Unable to parse UTCTime") (pure . UTCTimeYaml)
-        . parseTimeM True defaultTimeLocale utcTimeYamlFormat
-        . cs
+    withText "UTCTime" $ \t ->
+      let s = cs t
+       in case msum [parseTimeM True defaultTimeLocale fmt s | fmt <- utcTimeParseFormats] of
+            Nothing -> fail "Unable to parse UTCTime"
+            Just utc -> pure $ UTCTimeYaml utc
 
 instance ToJSON UTCTimeYaml where
-  toJSON = toJSON . formatTime defaultTimeLocale utcTimeYamlFormat . unUTCTimeYaml
-  toEncoding = toEncoding . formatTime defaultTimeLocale utcTimeYamlFormat . unUTCTimeYaml
-
--- Keeps things as the old Show/Read-based format, e.g "2009-04-15 10:02:06 UTC"
-utcTimeYamlFormat :: String
-utcTimeYamlFormat = "%F %T%Q UTC"
+  toJSON = toJSON . formatTime defaultTimeLocale utcTimeWriteFormat . unUTCTimeYaml
+  toEncoding = toEncoding . formatTime defaultTimeLocale utcTimeWriteFormat . unUTCTimeYaml
+
+-- | Canonical output format: the old Show/Read-based format,
+-- e.g "2009-04-15 10:02:06.123456 UTC"
+utcTimeWriteFormat :: String
+utcTimeWriteFormat = "%F %T%Q UTC"
+
+-- | Accepted input formats, tried in order. Lenient parsing accepts
+-- timestamps with or without fractional seconds.
+utcTimeParseFormats :: [String]
+utcTimeParseFormats =
+  [ "%F %T%Q UTC" -- "2009-04-15 10:02:06.123456 UTC" (with fractional seconds)
+  , "%F %T UTC" -- "2009-04-15 10:02:06 UTC" (without fractional seconds)
+  ]
 
 newtype DependsYaml = DependsYaml
   { unDependsYaml :: [Text]

tests/FilesystemParseSpec.hs

@@ -34,6 +34,10 @@ spec = do
     it "fully valid" $ do
       migrationFromFile' "valid_full" `shouldReturn` Right validFull
 
+    it "fully valid with fractional seconds in timestamp" $ do
+      migrationFromFile' "valid_full_fractional_ts"
+        `shouldReturn` Right (validFullFractionalTs {mId = "valid_full_fractional_ts"})
+
     it "comments" $ do
       migrationFromFile' "valid_with_comments"
         `shouldReturn` Right (validFull {mId = "valid_with_comments"})
@@ -154,3 +158,17 @@ ts = read tsStr
 
 tsStr :: String
 tsStr = "2009-04-15 10:02:06 UTC"
+
+validFullFractionalTs :: Migration
+validFullFractionalTs =
+  Migration
+    { mTimestamp = Just tsFractional
+    , mId = "valid_full_fractional_ts"
+    , mDesc = Just "A valid full migration with fractional seconds."
+    , mDeps = ["another_migration"]
+    , mApply = "CREATE TABLE test ( a int );"
+    , mRevert = Just "DROP TABLE test;"
+    }
+
+tsFractional :: UTCTime
+tsFractional = read "2009-04-15 10:02:06.123456 UTC"

tests/migration_parsing/valid_full_fractional_ts.txt

@@ -0,0 +1,10 @@
+Description: A valid full migration with fractional seconds.
+Created: 2009-04-15 10:02:06.123456 UTC
+Depends: another_migration
+Apply:
+
+  CREATE TABLE test (
+    a int
+  );
+
+Revert: DROP TABLE test;