From 72b1f3a10b24ec4d46d60da8395730f1b3316aab Mon Sep 17 00:00:00 2001 From: patrick brisbin Date: Tue, 3 Jan 2023 13:21:29 -0500 Subject: [PATCH 1/6] Decode directly to Migration type This patch defines a `MigrationYaml` record that represents the shape of a migration's Yaml file directly, then decodes to it. This obviates the manual "parsing" from a decoded `Object`. It also produces better error messages. The tests don't pass because we have actually been using Show/Read for the `UTCTime` fields instead of a JSON representation. I'll have to introduce a new type to account for that without breaking compatibility. --- dbmigrations.cabal | 2 +- src/Database/Schema/Migrations/Filesystem.hs | 129 +++++++------------ 2 files changed, 45 insertions(+), 86 deletions(-) diff --git a/dbmigrations.cabal b/dbmigrations.cabal index d14bd99..4d961ce 100644 --- a/dbmigrations.cabal +++ b/dbmigrations.cabal @@ -86,7 +86,7 @@ Library configurator >= 0.2, split >= 0.2.2, HUnit >= 1.2, - aeson < 2, + aeson, unordered-containers Hs-Source-Dirs: src diff --git a/src/Database/Schema/Migrations/Filesystem.hs b/src/Database/Schema/Migrations/Filesystem.hs index 4d4e64d..e6df932 100644 --- a/src/Database/Schema/Migrations/Filesystem.hs +++ b/src/Database/Schema/Migrations/Filesystem.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DeriveDataTypeable, ScopedTypeVariables, OverloadedStrings #-} +{-# LANGUAGE DeriveDataTypeable, DeriveGeneric, ScopedTypeVariables, OverloadedStrings #-} -- |This module provides a type for interacting with a -- filesystem-backed 'MigrationStore'. module Database.Schema.Migrations.Filesystem @@ -27,19 +27,15 @@ import Control.Applicative ( (<$>) ) import Control.Monad ( filterM ) import Control.Exception ( Exception(..), throw, catch ) -import Data.Aeson as J (Object, Value(String, Null)) +import Data.Aeson import Data.HashMap.Strict as M (toList) -import Data.Yaml +import qualified Data.Yaml as Yaml +import GHC.Generics (Generic) -import Database.Schema.Migrations.Migration - ( Migration(..) - , emptyMigration - ) +import Database.Schema.Migrations.Migration (Migration(..)) import Database.Schema.Migrations.Filesystem.Serialize import Database.Schema.Migrations.Store -type FieldProcessor = Text -> Migration -> Maybe Migration - data FilesystemStoreSettings = FSStore { storePath :: FilePath } data FilesystemStoreError = FilesystemStoreError String @@ -106,79 +102,42 @@ migrationFromPath path = do readMigrationFile = do ymlExists <- doesFileExist (addNewMigrationExtension path) if ymlExists - then decodeFileThrow (addNewMigrationExtension path) `catch` (\(e::ParseException) -> throwFS $ show e) - else decodeFileThrow (addMigrationExtension path filenameExtensionTxt) `catch` (\(e::ParseException) -> throwFS $ show e) - - process name = do - yaml <- readMigrationFile - - -- Convert yaml structure into basic key/value map - let fields = getFields yaml - missing = missingFields fields - - case length missing of - 0 -> do - let newM = emptyMigration name - case migrationFromFields newM fields of - Nothing -> throwFS $ "Error in " ++ (show path) ++ ": unrecognized field found" - Just m -> return m - _ -> throwFS $ "Error in " ++ (show path) ++ ": missing required field(s): " ++ (show missing) - -getFields :: J.Object -> [(Text, Text)] -getFields mp = map toPair $ M.toList mp - where - toPair :: (Text, Value) -> (Text, Text) - toPair (k, J.String v) = (cs k, cs v) - toPair (k, J.Null) = (cs k, cs ("" :: String)) - toPair (k, v) = throwFS $ "Error in YAML input; expected string key and string value, got " ++ (show (k, v)) -getFields _ = throwFS "Error in YAML input; expected mapping" - -missingFields :: [(Text, Text)] -> [Text] -missingFields fs = - [ k | k <- requiredFields, not (k `elem` inputStrings) ] - where - inputStrings = map fst fs - --- |Given a migration and a list of parsed migration fields, update --- the migration from the field values for recognized fields. -migrationFromFields :: Migration -> [(Text, Text)] -> Maybe Migration -migrationFromFields m [] = Just m -migrationFromFields m ((name, value):rest) = do - processor <- lookup name fieldProcessors - newM <- processor value m - migrationFromFields newM rest - -requiredFields :: [Text] -requiredFields = [ "Apply" - , "Depends" - ] - -fieldProcessors :: [(Text, FieldProcessor)] -fieldProcessors = [ ("Created", setTimestamp ) - , ("Description", setDescription ) - , ("Apply", setApply ) - , ("Revert", setRevert ) - , ("Depends", setDepends ) - ] - -setTimestamp :: FieldProcessor -setTimestamp value m = do - ts <- case readTimestamp value of - [(t, _)] -> return t - _ -> fail "expected one valid parse" - return $ m { mTimestamp = Just ts } - -readTimestamp :: Text -> [(UTCTime, String)] -readTimestamp = reads . cs - -setDescription :: FieldProcessor -setDescription desc m = Just $ m { mDesc = Just desc } - -setApply :: FieldProcessor -setApply apply m = Just $ m { mApply = apply } - -setRevert :: FieldProcessor -setRevert revert m = Just $ m { mRevert = Just revert } - -setDepends :: FieldProcessor -setDepends depString m = Just $ m { mDeps = T.words depString } + then Yaml.decodeFileThrow (addNewMigrationExtension path) `catch` (\(e::Yaml.ParseException) -> throwFS $ show e) + else Yaml.decodeFileThrow (addMigrationExtension path filenameExtensionTxt) `catch` (\(e::Yaml.ParseException) -> throwFS $ show e) + + process name = migrationYamlToMigration name <$> readMigrationFile + +-- | TODO: re-use this for the generation side too +data MigrationYaml = MigrationYaml + { myCreated :: Maybe UTCTime + , myDescription :: Maybe Text + , myApply :: Text + , myRevert :: Maybe Text + , myDepends :: Text + -- ^ White-space separated names + } + deriving Generic + +instance FromJSON MigrationYaml where + parseJSON = genericParseJSON jsonOptions + +instance ToJSON MigrationYaml where + toJSON = genericToJSON jsonOptions + toEncoding = genericToEncoding jsonOptions + +jsonOptions :: Options +jsonOptions = defaultOptions + { fieldLabelModifier = drop 2 -- remove "my" prefix + , omitNothingFields = True + , rejectUnknownFields = True + } + +migrationYamlToMigration :: Text -> MigrationYaml -> Migration +migrationYamlToMigration theId my = Migration + { mTimestamp = myCreated my + , mId = theId + , mDesc = myDescription my + , mApply = myApply my + , mRevert = myRevert my + , mDeps = T.words $ myDepends my + } From 966792329e8e0f68dfc45e0a45c474a2a20222f3 Mon Sep 17 00:00:00 2001 From: patrick brisbin Date: Tue, 3 Jan 2023 13:37:38 -0500 Subject: [PATCH 2/6] Use custom UTCTime type to retain Show/Read format There's no functional need for this, using the JSON representation would've been readable enough, but there are going to be tons of migration files in the wild with these simplified values. We could write encoding at JSON and a decoder that accepts either, but I'm not sure it's worth it vs just using a completely custom newtype. --- src/Database/Schema/Migrations/Filesystem.hs | 26 +++++++++++++++++--- 1 file changed, 22 insertions(+), 4 deletions(-) diff --git a/src/Database/Schema/Migrations/Filesystem.hs b/src/Database/Schema/Migrations/Filesystem.hs index e6df932..b6c6238 100644 --- a/src/Database/Schema/Migrations/Filesystem.hs +++ b/src/Database/Schema/Migrations/Filesystem.hs @@ -20,10 +20,10 @@ import Data.String.Conversions ( cs, (<>) ) import Data.Typeable ( Typeable ) import Data.Time.Clock ( UTCTime ) -import Data.Time () -- for UTCTime Show instance +import Data.Time ( defaultTimeLocale, formatTime, parseTimeM ) import qualified Data.Map as Map -import Control.Applicative ( (<$>) ) +import Control.Applicative ( (<$>), (<|>) ) import Control.Monad ( filterM ) import Control.Exception ( Exception(..), throw, catch ) @@ -109,7 +109,7 @@ migrationFromPath path = do -- | TODO: re-use this for the generation side too data MigrationYaml = MigrationYaml - { myCreated :: Maybe UTCTime + { myCreated :: Maybe UTCTimeYaml , myDescription :: Maybe Text , myApply :: Text , myRevert :: Maybe Text @@ -134,10 +134,28 @@ jsonOptions = defaultOptions migrationYamlToMigration :: Text -> MigrationYaml -> Migration migrationYamlToMigration theId my = Migration - { mTimestamp = myCreated my + { mTimestamp = unUTCTimeYaml <$> myCreated my , mId = theId , mDesc = myDescription my , mApply = myApply my , mRevert = myRevert my , mDeps = T.words $ myDepends my } + +newtype UTCTimeYaml = UTCTimeYaml + { unUTCTimeYaml :: UTCTime + } + +instance FromJSON UTCTimeYaml where + parseJSON = withText "UTCTime" + $ maybe (fail "Unable to parse UTCTime") (pure . UTCTimeYaml) + . parseTimeM True defaultTimeLocale utcTimeYamlFormat + . cs + +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 UTC" From 25127fc805d040c9ff38f4cdf1f798adca684c12 Mon Sep 17 00:00:00 2001 From: patrick brisbin Date: Tue, 3 Jan 2023 13:39:00 -0500 Subject: [PATCH 3/6] Depends were never actually required It was listed in that `requiredFields` array, but was being defaulted to the empty string elsewhere. There is a test that confirms its optional, which makes sense anyway. --- src/Database/Schema/Migrations/Filesystem.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Database/Schema/Migrations/Filesystem.hs b/src/Database/Schema/Migrations/Filesystem.hs index b6c6238..2f1ac1d 100644 --- a/src/Database/Schema/Migrations/Filesystem.hs +++ b/src/Database/Schema/Migrations/Filesystem.hs @@ -113,7 +113,7 @@ data MigrationYaml = MigrationYaml , myDescription :: Maybe Text , myApply :: Text , myRevert :: Maybe Text - , myDepends :: Text + , myDepends :: Maybe Text -- ^ White-space separated names } deriving Generic @@ -139,7 +139,7 @@ migrationYamlToMigration theId my = Migration , mDesc = myDescription my , mApply = myApply my , mRevert = myRevert my - , mDeps = T.words $ myDepends my + , mDeps = maybe [] T.words $ myDepends my } newtype UTCTimeYaml = UTCTimeYaml From aee4a0ec40d2a08e2a74b4b3e8b68e4d4657f022 Mon Sep 17 00:00:00 2001 From: patrick brisbin Date: Tue, 3 Jan 2023 13:52:08 -0500 Subject: [PATCH 4/6] Preserve even weirder Depends behavior It seems the `Depends` _key_ is indeed required, but a `Null` as the _value_ is acceptable (and defaulted to no dependencies). I don't know if we need to preserve this too, but the tests fail if we don't. It was super fun to see one test assert it was optional and fail, only to have the test that asserts it as required then fail (: --- src/Database/Schema/Migrations/Filesystem.hs | 26 +++++++++++++++++--- 1 file changed, 22 insertions(+), 4 deletions(-) diff --git a/src/Database/Schema/Migrations/Filesystem.hs b/src/Database/Schema/Migrations/Filesystem.hs index 2f1ac1d..851feb9 100644 --- a/src/Database/Schema/Migrations/Filesystem.hs +++ b/src/Database/Schema/Migrations/Filesystem.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DeriveDataTypeable, DeriveGeneric, ScopedTypeVariables, OverloadedStrings #-} +{-# LANGUAGE DeriveDataTypeable, DeriveGeneric, LambdaCase, ScopedTypeVariables, OverloadedStrings #-} -- |This module provides a type for interacting with a -- filesystem-backed 'MigrationStore'. module Database.Schema.Migrations.Filesystem @@ -28,6 +28,7 @@ import Control.Monad ( filterM ) import Control.Exception ( Exception(..), throw, catch ) import Data.Aeson +import Data.Aeson.Types (typeMismatch) import Data.HashMap.Strict as M (toList) import qualified Data.Yaml as Yaml import GHC.Generics (Generic) @@ -113,8 +114,7 @@ data MigrationYaml = MigrationYaml , myDescription :: Maybe Text , myApply :: Text , myRevert :: Maybe Text - , myDepends :: Maybe Text - -- ^ White-space separated names + , myDepends :: DependsYaml } deriving Generic @@ -139,7 +139,7 @@ migrationYamlToMigration theId my = Migration , mDesc = myDescription my , mApply = myApply my , mRevert = myRevert my - , mDeps = maybe [] T.words $ myDepends my + , mDeps = unDependsYaml $ myDepends my } newtype UTCTimeYaml = UTCTimeYaml @@ -159,3 +159,21 @@ instance ToJSON UTCTimeYaml where -- Keeps things as the old Show/Read-based format, e.g "2009-04-15 10:02:06 UTC" utcTimeYamlFormat :: String utcTimeYamlFormat = "%F %T UTC" + +newtype DependsYaml = DependsYaml + { unDependsYaml :: [Text] + } + +instance FromJSON DependsYaml where + parseJSON = \case + Null -> pure $ DependsYaml [] + String t -> pure $ DependsYaml $ T.words t + x -> typeMismatch "Null or whitespace-separated String" x + +instance ToJSON DependsYaml where + toJSON (DependsYaml ts) = case ts of + [] -> toJSON Null + _ -> toJSON $ T.unwords ts + toEncoding (DependsYaml ts) = case ts of + [] -> toEncoding Null + _ -> toEncoding $ T.unwords ts From a535d514e0f60d33abc44ce2ab52b82121d1c435 Mon Sep 17 00:00:00 2001 From: patrick brisbin Date: Tue, 3 Jan 2023 14:01:19 -0500 Subject: [PATCH 5/6] Clean up unused imports --- src/Database/Schema/Migrations/Filesystem.hs | 2 -- 1 file changed, 2 deletions(-) diff --git a/src/Database/Schema/Migrations/Filesystem.hs b/src/Database/Schema/Migrations/Filesystem.hs index 851feb9..574bf66 100644 --- a/src/Database/Schema/Migrations/Filesystem.hs +++ b/src/Database/Schema/Migrations/Filesystem.hs @@ -23,13 +23,11 @@ import Data.Time.Clock ( UTCTime ) import Data.Time ( defaultTimeLocale, formatTime, parseTimeM ) import qualified Data.Map as Map -import Control.Applicative ( (<$>), (<|>) ) import Control.Monad ( filterM ) import Control.Exception ( Exception(..), throw, catch ) import Data.Aeson import Data.Aeson.Types (typeMismatch) -import Data.HashMap.Strict as M (toList) import qualified Data.Yaml as Yaml import GHC.Generics (Generic) From 5dd8aed7d820105d2101142db1baca0bce69e337 Mon Sep 17 00:00:00 2001 From: Pat Brisbin Date: Tue, 3 Jan 2023 14:02:33 -0500 Subject: [PATCH 6/6] Update src/Database/Schema/Migrations/Filesystem.hs --- src/Database/Schema/Migrations/Filesystem.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Database/Schema/Migrations/Filesystem.hs b/src/Database/Schema/Migrations/Filesystem.hs index 574bf66..9ccb63e 100644 --- a/src/Database/Schema/Migrations/Filesystem.hs +++ b/src/Database/Schema/Migrations/Filesystem.hs @@ -159,8 +159,8 @@ utcTimeYamlFormat :: String utcTimeYamlFormat = "%F %T UTC" newtype DependsYaml = DependsYaml - { unDependsYaml :: [Text] - } + { unDependsYaml :: [Text] + } instance FromJSON DependsYaml where parseJSON = \case