diff --git a/api-tools.cabal b/api-tools.cabal index 5a89593..046e2bd 100644 --- a/api-tools.cabal +++ b/api-tools.cabal @@ -176,6 +176,8 @@ Test-Suite test-api-tools Data.API.Test.Migration Data.API.Test.MigrationData Data.API.Test.Time + Data.API.Test.UnionMigration + Data.API.Test.UnionMigrationData Build-depends: api-tools, diff --git a/src/Data/API/Changes.hs b/src/Data/API/Changes.hs index 4d16dbd..f030b2c 100644 --- a/src/Data/API/Changes.hs +++ b/src/Data/API/Changes.hs @@ -200,10 +200,11 @@ data DataChecks = NoChecks -- ^ Not at all -- | Whether to validate the dataset after this change validateAfter :: DataChecks -> APIChange -> Bool -validateAfter chks (ChChangeField{}) = chks >= CheckCustom -validateAfter chks (ChCustomType{}) = chks >= CheckCustom -validateAfter chks (ChCustomAll{}) = chks >= CheckCustom -validateAfter chks _ = chks >= CheckAll +validateAfter chks (ChChangeField{}) = chks >= CheckCustom +validateAfter chks (ChChangeUnionAlt{}) = chks >= CheckCustom +validateAfter chks (ChCustomType{}) = chks >= CheckCustom +validateAfter chks (ChCustomAll{}) = chks >= CheckCustom +validateAfter chks _ = chks >= CheckAll -------------------- @@ -255,10 +256,11 @@ changelogTags (ChangesUpTo _ cs older) = -- | Sets of custom migration tags in a single change changeTags :: APIChange -> (Set MigrationTag, Set MigrationTag, Set MigrationTag) -changeTags (ChChangeField _ _ _ t) = (Set.empty, Set.empty, Set.singleton t) -changeTags (ChCustomType _ t) = (Set.empty, Set.singleton t, Set.empty) -changeTags (ChCustomAll t) = (Set.singleton t, Set.empty, Set.empty) -changeTags _ = (Set.empty, Set.empty, Set.empty) +changeTags (ChChangeField _ _ _ t) = (Set.empty, Set.empty, Set.singleton t) +changeTags (ChChangeUnionAlt _ _ _ t) = (Set.empty, Set.singleton t, Set.empty) +changeTags (ChCustomType _ t) = (Set.empty, Set.singleton t, Set.empty) +changeTags (ChCustomAll t) = (Set.singleton t, Set.empty, Set.empty) +changeTags _ = (Set.empty, Set.empty, Set.empty) -------------------------------- @@ -484,6 +486,14 @@ applyAPIChangeToAPI _ _ (ChRenameUnionAlt tname fname fname') api = do . Map.delete fname) unioninfo return (Map.insert tname tinfo' api, findUpdatePos tname api) +applyAPIChangeToAPI _ _custom (ChChangeUnionAlt tname fname ftype _tag) api = do + tinfo <- lookupType tname api + unioninfo <- expectUnionType tinfo ?! TypeWrongKind tname TKUnion + guard (Map.member fname unioninfo) ?! FieldDoesNotExist tname TKUnion fname + typeIsValid ftype api ?!? TypeMalformed ftype + let tinfo' = (NUnionType . Map.insert fname ftype) unioninfo + return (Map.insert tname tinfo' api, findUpdatePos tname api) + applyAPIChangeToAPI _ _ (ChAddEnumVal tname fname) api = do tinfo <- lookupType tname api enuminfo <- expectEnumType tinfo ?! TypeWrongKind tname TKEnum @@ -607,6 +617,13 @@ applyChangeToData (ChRenameUnionAlt _ fname fname') _ = withObject $ \un p -> | otherwise -> return un Nothing -> Left (JSONError $ SyntaxError "Not singleton", p) +applyChangeToData (ChChangeUnionAlt _ fname _ftype tag) custom = withObject $ \un p -> + case matchSingletonObject un of + Just (k, r) | k == _FieldName fname -> do + r' <- liftMigration (typeMigration custom tag) r p + return $ singletonObject (_FieldName fname) r' + _ -> return un + applyChangeToData (ChRenameEnumVal _ fname fname') _ = withString $ \s _ -> if s == _FieldName fname then return (_FieldName fname') else return s @@ -718,6 +735,12 @@ applyChangeToData' _ (ChRenameUnionAlt _ fname fname') _ v p = do (fn, v') <- expectUnion v p pure $! if fn == fname then Union fname' v' else v +applyChangeToData' _ (ChChangeUnionAlt _ fname _ftype tag) custom v p = do + (fn, v') <- expectUnion v p + if fn == fname + then Union fn <$!> liftMigration (typeMigration custom tag) v' (inField fn:p) + else pure v + applyChangeToData' _ (ChRenameEnumVal _ fname fname') _ v p = do fn <- expectEnum v p pure $! if fn == fname then Enum fname' else v diff --git a/src/Data/API/Changes/Types.hs b/src/Data/API/Changes/Types.hs index e258205..ff90068 100644 --- a/src/Data/API/Changes/Types.hs +++ b/src/Data/API/Changes/Types.hs @@ -57,6 +57,7 @@ data APIChange | ChAddUnionAlt TypeName FieldName APIType | ChDeleteUnionAlt TypeName FieldName | ChRenameUnionAlt TypeName FieldName FieldName + | ChChangeUnionAlt TypeName FieldName APIType MigrationTag -- Changes for enum types | ChAddEnumVal TypeName FieldName @@ -87,6 +88,9 @@ instance PPLines APIChange where , " alternative removed " ++ pp f] ppLines (ChRenameUnionAlt t f f') = [ "changed union " ++ pp t , " alternative renamed " ++ pp f ++ " to " ++ pp f'] + ppLines (ChChangeUnionAlt t f ty c) = [ "changed union " ++ pp t + , " alternative changed " ++ pp f ++ " :: " ++ pp ty + ++ " migration " ++ pp c] ppLines (ChAddEnumVal t f) = [ "changed enum " ++ pp t , " alternative added " ++ pp f] ppLines (ChDeleteEnumVal t f) = [ "changed enum " ++ pp t diff --git a/src/Data/API/Parse.y b/src/Data/API/Parse.y index 8b49c40..9f73a3d 100644 --- a/src/Data/API/Parse.y +++ b/src/Data/API/Parse.y @@ -280,6 +280,7 @@ UnionChange :: { [UnionChange] } : alternative added FieldName '::' Type { [UnChAdd $3 $5] } | alternative removed FieldName { [UnChDelete $3] } | alternative renamed FieldName to FieldName { [UnChRename $3 $5] } + | alternative changed FieldName '::' Type migration MigrationTag { [UnChChange $3 $5 $7] } | comment { [] } REnumChanges :: { [EnumChange] } @@ -331,11 +332,13 @@ fldChangeToAPIChange t (FldChChange f ty m) = ChChangeField t f ty m data UnionChange = UnChAdd FieldName APIType | UnChDelete FieldName | UnChRename FieldName FieldName + | UnChChange FieldName APIType MigrationTag unionChangeToAPIChange :: TypeName -> UnionChange -> APIChange -unionChangeToAPIChange t (UnChAdd f ty) = ChAddUnionAlt t f ty -unionChangeToAPIChange t (UnChDelete f) = ChDeleteUnionAlt t f -unionChangeToAPIChange t (UnChRename f f') = ChRenameUnionAlt t f f' +unionChangeToAPIChange t (UnChAdd f ty) = ChAddUnionAlt t f ty +unionChangeToAPIChange t (UnChDelete f) = ChDeleteUnionAlt t f +unionChangeToAPIChange t (UnChRename f f') = ChRenameUnionAlt t f f' +unionChangeToAPIChange t (UnChChange f ty m) = ChChangeUnionAlt t f ty m data EnumChange = EnChAdd FieldName | EnChDelete FieldName diff --git a/tests/Data/API/Test/Main.hs b/tests/Data/API/Test/Main.hs index 58d12f2..092e224 100644 --- a/tests/Data/API/Test/Main.hs +++ b/tests/Data/API/Test/Main.hs @@ -3,6 +3,7 @@ import Data.API.API.Gen import Data.API.Test.JSON import Data.API.Test.Migration import Data.API.Test.Time +import Data.API.Test.UnionMigration import Test.Tasty import Test.Tasty.QuickCheck @@ -12,6 +13,7 @@ main = defaultMain tests tests :: TestTree tests = testGroup "api-tools" [ migrationTests + , unionMigrationTests , jsonTests , timeTests , testProperty "Convert/unconvert" convertUncovertTest diff --git a/tests/Data/API/Test/UnionMigration.hs b/tests/Data/API/Test/UnionMigration.hs new file mode 100644 index 0000000..c89026d --- /dev/null +++ b/tests/Data/API/Test/UnionMigration.hs @@ -0,0 +1,168 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +-- | Tests for union alternative migration with type changes +-- +-- This module tests the 'alternative changed' changelog feature, which allows +-- changing the type of a union alternative with a custom migration function. +module Data.API.Test.UnionMigration + ( unionMigrationTests + ) where + +import Data.API.Changes +import Data.API.JSON +import Data.API.JSON.Compat +import Data.API.Types +import Data.API.Utils + +import qualified Data.Aeson as JS +import qualified Data.Aeson.Encode.Pretty as JS +import qualified Data.ByteString.Lazy.Char8 as BL +import qualified Data.Text as T +import Data.Version +import Test.Tasty +import Test.Tasty.HUnit + +import Data.API.Test.UnionMigrationData + + +-- Generate migration enums from changelog +$(generateMigrationKinds typeSwapChangelog "TypeSwapDbMigration" "TypeSwapRecordMigration" "TypeSwapFieldMigration") + + +-- ----------------------------------------------------------------------------- +-- Type Swap Migration (PersonV1 -> PersonV2) +-- ----------------------------------------------------------------------------- + +-- | Migrate PersonV1 to PersonV2 +-- +-- PersonV1: { "name": "John" } +-- PersonV2: { "fullName": "John", "age": 0 } +-- +-- This is a type migration because we're transforming the entire inner value +-- of the union alternative from one type to another. +migratePersonV1ToV2 :: TypeSwapRecordMigration -> JS.Value -> Either ValueError JS.Value +migratePersonV1ToV2 MigratePersonV1ToV2 (JS.Object obj) = do + nameVal <- lookupKey "name" obj ?! CustomMigrationError "missing 'name' field" (JS.Object obj) + case nameVal of + JS.String name -> return $ JS.Object $ + insertKey "fullName" (JS.String name) $ + singletonObject "age" (JS.Number 0) + _ -> Left $ CustomMigrationError "expected string for 'name'" (JS.Object obj) +migratePersonV1ToV2 MigratePersonV1ToV2 v = + Left $ CustomMigrationError "expected object for PersonV1" v + + +typeSwapMigration :: CustomMigrations JS.Object JS.Value TypeSwapDbMigration TypeSwapRecordMigration TypeSwapFieldMigration +typeSwapMigration = CustomMigrations + { databaseMigration = \ _ -> noDataChanges + , databaseMigrationSchema = \ _ -> noSchemaChanges + , typeMigration = migratePersonV1ToV2 + , typeMigrationSchema = \ _ -> noSchemaChanges + , fieldMigration = \ _ -> noDataChanges + } + + +-- Test data for type swap +-- +-- Start: Container with MyUnion containing PersonV1 +-- End: Container with MyUnion containing PersonV2 + +-- | Start data: { "person": { "person": { "name": "Alice" } } } +startTypeSwapData :: JS.Value +Just startTypeSwapData = JS.decode "{ \"person\": { \"person\": { \"name\": \"Alice\" } } }" + +-- | Expected end data: { "person": { "person": { "fullName": "Alice", "age": 0 } } } +expectedTypeSwapData :: JS.Value +Just expectedTypeSwapData = JS.decode "{ \"person\": { \"person\": { \"fullName\": \"Alice\", \"age\": 0 } } }" + +-- | Start data with "other" alternative (should pass through unchanged) +startOtherAltData :: JS.Value +Just startOtherAltData = JS.decode "{ \"person\": { \"other\": 42 } }" + +-- | Expected end data for "other" alternative (unchanged) +expectedOtherAltData :: JS.Value +Just expectedOtherAltData = JS.decode "{ \"person\": { \"other\": 42 } }" + + +-- | Test migrating PersonV1 to PersonV2 within a union +typeSwapMigrationTest :: Assertion +typeSwapMigrationTest = do + -- Verify start data matches start schema + case dataMatchesAPI rootName startTypeSwapSchema startTypeSwapData of + Right () -> return () + Left err -> assertFailure $ "Start data does not match start API: " + ++ prettyValueErrorPosition err + + -- Verify expected end data matches end schema + case dataMatchesAPI rootName endTypeSwapSchema expectedTypeSwapData of + Right () -> return () + Left err -> assertFailure $ "Expected end data does not match end API: " + ++ prettyValueErrorPosition err + + -- Run migration + case migrateDataDump (startTypeSwapSchema, parseVer "0") + (endTypeSwapSchema, Release (parseVer "1.0")) + typeSwapChangelog typeSwapMigration rootName CheckAll + startTypeSwapData of + Right (v, []) + | expectedTypeSwapData == v -> return () + | otherwise -> assertFailure $ unlines + [ "Type swap migration produced wrong result" + , "Expected:" + , BL.unpack (JS.encodePretty expectedTypeSwapData) + , "but got:" + , BL.unpack (JS.encodePretty v) + ] + Right (_, ws) -> assertFailure $ "Unexpected warnings: " ++ show ws + Left err -> assertFailure $ "Migration failed: " ++ prettyMigrateFailure err + + +-- | Test that non-matching alternatives pass through unchanged +otherAlternativeUnchangedTest :: Assertion +otherAlternativeUnchangedTest = do + -- Verify start data matches start schema + case dataMatchesAPI rootName startTypeSwapSchema startOtherAltData of + Right () -> return () + Left err -> assertFailure $ "Start data does not match start API: " + ++ prettyValueErrorPosition err + + -- Verify expected end data matches end schema + case dataMatchesAPI rootName endTypeSwapSchema expectedOtherAltData of + Right () -> return () + Left err -> assertFailure $ "Expected end data does not match end API: " + ++ prettyValueErrorPosition err + + -- Run migration - "other" alternative should pass through unchanged + case migrateDataDump (startTypeSwapSchema, parseVer "0") + (endTypeSwapSchema, Release (parseVer "1.0")) + typeSwapChangelog typeSwapMigration rootName CheckAll + startOtherAltData of + Right (v, []) + | expectedOtherAltData == v -> return () + | otherwise -> assertFailure $ unlines + [ "Other alternative was incorrectly modified" + , "Expected:" + , BL.unpack (JS.encodePretty expectedOtherAltData) + , "but got:" + , BL.unpack (JS.encodePretty v) + ] + Right (_, ws) -> assertFailure $ "Unexpected warnings: " ++ show ws + Left err -> assertFailure $ "Migration failed: " ++ prettyMigrateFailure err + + +rootName :: TypeName +rootName = TypeName "Container" + +parseVer :: String -> Version +parseVer s = case simpleParseVersion s of + Just v -> v + Nothing -> error $ "Invalid version: " ++ s + + +-- | All union migration tests +unionMigrationTests :: TestTree +unionMigrationTests = testGroup "Union Alternative Migration" + [ testCase "Type swap: PersonV1 -> PersonV2" typeSwapMigrationTest + , testCase "Other alternatives pass through unchanged" otherAlternativeUnchangedTest + ] diff --git a/tests/Data/API/Test/UnionMigrationData.hs b/tests/Data/API/Test/UnionMigrationData.hs new file mode 100644 index 0000000..5a509e1 --- /dev/null +++ b/tests/Data/API/Test/UnionMigrationData.hs @@ -0,0 +1,86 @@ +{-# LANGUAGE QuasiQuotes #-} + +-- | Data for union alternative migration tests +-- +-- This module tests the 'alternative changed' changelog feature, which allows +-- swapping the type of a union alternative from one type to a completely +-- different type, with a custom migration function to transform the data. +module Data.API.Test.UnionMigrationData + ( -- * Type swap scenario (PersonV1 -> PersonV2) + startTypeSwapSchema + , endTypeSwapSchema + , typeSwapChangelog + ) where + +import Data.API.Changes +import Data.API.Parse +import Data.API.Types + + +-- ----------------------------------------------------------------------------- +-- Type Swap Scenario +-- +-- This tests the primary use case: migrating a union alternative from one +-- type (PersonV1) to a completely different type (PersonV2). +-- +-- PersonV1 has: name :: string +-- PersonV2 has: fullName :: string, age :: integer +-- +-- The migration function transforms PersonV1 data to PersonV2 data. +-- ----------------------------------------------------------------------------- + +-- | Initial schema with PersonV1 +startTypeSwapSchema :: API +startTypeSwapSchema = [api| + +personV1Prefix :: PersonV1 + = record + name :: string + +containerPrefix :: Container + = record + person :: MyUnion + +myUnionPrefix :: MyUnion + = union + | person :: PersonV1 + | other :: integer +|] + + +-- | Final schema with PersonV2 and changelog +endTypeSwapSchema :: API +typeSwapChangelog :: APIChangelog +(endTypeSwapSchema, typeSwapChangelog) = [apiWithChangelog| + +personV1Prefix :: PersonV1 + = record + name :: string + +personV2Prefix :: PersonV2 + = record + fullName :: string + age :: integer + +containerPrefix :: Container + = record + person :: MyUnion + +myUnionPrefix :: MyUnion + = union + | person :: PersonV2 + | other :: integer + +changes + +version "1.0" + // Note: changes are processed bottom-up, so we must list the union change + // before adding the new type it references + changed union MyUnion + alternative changed person :: PersonV2 migration MigratePersonV1ToV2 + added PersonV2 record + fullName :: string + age :: integer + +version "0" +|]