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

dbmigrations.cabal

@@ -1,6 +1,6 @@
 cabal-version: 1.18
 
--- This file has been generated from package.yaml by hpack version 0.36.0.
+-- This file has been generated from package.yaml by hpack version 0.38.1.
 --
 -- see: https://github.com/sol/hpack
 
@@ -30,6 +30,7 @@ extra-source-files:
     tests/migration_parsing/invalid_syntax.txt
     tests/migration_parsing/invalid_timestamp.txt
     tests/migration_parsing/valid_full.txt
+    tests/migration_parsing/valid_full_fractional_ts.txt
     tests/migration_parsing/valid_no_depends.txt
     tests/migration_parsing/valid_no_desc.txt
     tests/migration_parsing/valid_no_revert.txt

package.yaml

@@ -3,7 +3,7 @@ version: 3.0.0
 synopsis: An implementation of relational database "migrations"
 description: Please see <https://github.com/haskell-github-trust/dbmigrations#readme>
 author: "Jonathan Daugherty <cygnus@foobox.com>"
-maintainer: "Pat Brisbin <pbrisbin@gmail.com>"
+maintainer: "Pat Brisbin <pbrisbin@gmail.com>, Kris Nuttycombe <kris@nutty.land>"
 category: Database
 github: haskell-github-trust/dbmigrations
 license: BSD3

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/FilesystemSpec.hs

@@ -25,6 +25,7 @@ spec = do
                           , "invalid_syntax"
                           , "invalid_timestamp"
                           , "valid_full"
+                          , "valid_full_fractional_ts"
                           , "valid_no_depends"
                           , "valid_no_desc"
                           , "valid_no_revert"

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;