diff --git a/dbmigrations.cabal b/dbmigrations.cabal index 6e5e96b..af340f8 100644 --- a/dbmigrations.cabal +++ b/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 diff --git a/package.yaml b/package.yaml index 1f5aa58..765ed9e 100644 --- a/package.yaml +++ b/package.yaml @@ -3,7 +3,7 @@ version: 3.0.0 synopsis: An implementation of relational database "migrations" description: Please see author: "Jonathan Daugherty " -maintainer: "Pat Brisbin " +maintainer: "Pat Brisbin , Kris Nuttycombe " category: Database github: haskell-github-trust/dbmigrations license: BSD3 diff --git a/src/Database/Schema/Migrations/Filesystem.hs b/src/Database/Schema/Migrations/Filesystem.hs index 71b3656..9e7ea9c 100644 --- a/src/Database/Schema/Migrations/Filesystem.hs +++ b/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] diff --git a/tests/FilesystemParseSpec.hs b/tests/FilesystemParseSpec.hs index d022940..bb77ac1 100644 --- a/tests/FilesystemParseSpec.hs +++ b/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" diff --git a/tests/FilesystemSpec.hs b/tests/FilesystemSpec.hs index 206bacc..b50c6f8 100644 --- a/tests/FilesystemSpec.hs +++ b/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" diff --git a/tests/migration_parsing/valid_full_fractional_ts.txt b/tests/migration_parsing/valid_full_fractional_ts.txt new file mode 100644 index 0000000..82e65ae --- /dev/null +++ b/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;