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/main/MigrationTool.hs b/main/MigrationTool.hs index 4f679b4..59b56f9 100644 --- a/main/MigrationTool.hs +++ b/main/MigrationTool.hs @@ -71,10 +71,11 @@ readApiFile file = fmap (parseAPIWithChangelog file (0,0)) (readFile file) data ChangeTag = None deriving (Read, Show) -customMigrations :: CustomMigrations JS.Object JS.Value ChangeTag ChangeTag ChangeTag +customMigrations :: CustomMigrations JS.Object JS.Value ChangeTag ChangeTag ChangeTag ChangeTag customMigrations = CustomMigrations (nope JS.Object) (const noSchemaChanges) (nope id) (const noSchemaChanges) (nope id) + (nope id) where nope toVal _ v = Left (CustomMigrationError "No custom migrations defined" (toVal v)) diff --git a/src/Data/API/Changes.hs b/src/Data/API/Changes.hs index 4d16dbd..2135979 100644 --- a/src/Data/API/Changes.hs +++ b/src/Data/API/Changes.hs @@ -94,11 +94,11 @@ import Safe -- custom migration tags in the changelog, as generated by -- 'generateMigrationKind'. -migrateDataDump :: (Read db, Read rec, Read fld) +migrateDataDump :: (Read db, Read rec, Read alt, Read fld) => (API, Version) -- ^ Starting schema and version -> (API, VersionExtra) -- ^ Ending schema and version -> APIChangelog -- ^ Log of changes, containing both versions - -> CustomMigrations JS.Object JS.Value db rec fld -- ^ Custom migration functions + -> CustomMigrations JS.Object JS.Value db rec alt fld -- ^ Custom migration functions -> TypeName -- ^ Name of the dataset's type -> DataChecks -- ^ How thoroughly to validate changes -> JS.Value -- ^ Dataset to be migrated @@ -110,11 +110,11 @@ migrateDataDump startApi endApi changelog custom root chks db = do db' <- applyChangesToDatabase root custom' db changes ?!? uncurry ValueError return (db', warnings) -migrateDataDump' :: (Read db, Read rec, Read fld) +migrateDataDump' :: (Read db, Read rec, Read alt, Read fld) => (API, Version) -- ^ Starting schema and version -> (API, VersionExtra) -- ^ Ending schema and version -> APIChangelog -- ^ Log of changes, containing both versions - -> CustomMigrations Record Value db rec fld -- ^ Custom migration functions + -> CustomMigrations Record Value db rec alt fld -- ^ Custom migration functions -> TypeName -- ^ Name of the dataset's type -> DataChecks -- ^ How thoroughly to validate changes -> Value.Value -- ^ Dataset to be migrated @@ -129,12 +129,16 @@ migrateDataDump' startApi endApi changelog custom root chks db = do -- | Custom migrations used in the changelog must be implemented in --- Haskell, and supplied in this record. There are three kinds: +-- Haskell, and supplied in this record. There are four kinds: -- -- * Whole-database migrations, which may arbitrarily change the API -- schema and the data to match; -- --- * Type migrations, which may change the schema of a single type; and +-- * Type migrations, which may change the schema of a single type; +-- +-- * Union alternative migrations, which may change the type of a +-- single alternative within a union (with the new type specified in +-- the changelog); and -- -- * Single field migrations, which may change only the type of the -- field (with the new type specified in the changelog). @@ -142,23 +146,24 @@ migrateDataDump' startApi endApi changelog custom root chks db = do -- For database and type migrations, if the schema is unchanged, the -- corresponding function should return 'Nothing'. -- --- The @db@, @ty@ and @fld@ parameters should be instantiated with --- the enumeration types generated by 'generateMigrationKinds', which --- correspond to the exact set of custom migration tags used in the --- changelog. -data CustomMigrations o v db ty fld = CustomMigrations +-- The @db@, @ty@, @alt@ and @fld@ parameters should be instantiated +-- with the enumeration types generated by 'generateMigrationKinds', +-- which correspond to the exact set of custom migration tags used in +-- the changelog. +data CustomMigrations o v db ty alt fld = CustomMigrations { databaseMigration :: db -> o -> Either ValueError o , databaseMigrationSchema :: db -> NormAPI -> Either ApplyFailure (Maybe NormAPI) , typeMigration :: ty -> v -> Either ValueError v , typeMigrationSchema :: ty -> NormTypeDecl -> Either ApplyFailure (Maybe NormTypeDecl) + , unionAltMigration :: alt -> v -> Either ValueError v , fieldMigration :: fld -> v -> Either ValueError v } -type CustomMigrationsTagged o v = CustomMigrations o v MigrationTag MigrationTag MigrationTag +type CustomMigrationsTagged o v = CustomMigrations o v MigrationTag MigrationTag MigrationTag MigrationTag -readCustomMigrations :: (Read db, Read ty, Read fld) - => CustomMigrations o v db ty fld -> CustomMigrationsTagged o v -readCustomMigrations (CustomMigrations db dbs r rs f) = - CustomMigrations (db . read) (dbs . read) (r . read) (rs . read) (f . read) +readCustomMigrations :: (Read db, Read ty, Read alt, Read fld) + => CustomMigrations o v db ty alt fld -> CustomMigrationsTagged o v +readCustomMigrations (CustomMigrations db dbs r rs a f) = + CustomMigrations (db . read) (dbs . read) (r . read) (rs . read) (a . read) (f . read) -- | Lift a custom record migration to work on arbitrary values mkRecordMigration :: (JS.Object -> Either ValueError JS.Object) @@ -200,10 +205,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 -------------------- @@ -243,22 +249,23 @@ isChangelogOrdered changelog = -- | Sets of custom migration tags in the changelog for --- whole-database, single-record and single-field migrations -changelogTags :: APIChangelog -> (Set MigrationTag, Set MigrationTag, Set MigrationTag) -changelogTags (ChangesStart _) = (Set.empty, Set.empty, Set.empty) +-- whole-database, single-type, union-alternative and single-field migrations +changelogTags :: APIChangelog -> (Set MigrationTag, Set MigrationTag, Set MigrationTag, Set MigrationTag) +changelogTags (ChangesStart _) = (Set.empty, Set.empty, Set.empty, Set.empty) changelogTags (ChangesUpTo _ cs older) = - unions3 (map changeTags cs) `union3` changelogTags older + unions4 (map changeTags cs) `union4` changelogTags older where - union3 (a, b, c) (x, y, z) = (a `Set.union` x, b `Set.union` y, c `Set.union` z) - unions3 xyzs = (Set.unions xs, Set.unions ys, Set.unions zs) - where (xs, ys, zs) = unzip3 xyzs + union4 (a, b, c, d) (x, y, z, w) = (a `Set.union` x, b `Set.union` y, c `Set.union` z, d `Set.union` w) + unions4 xyzws = (Set.unions xs, Set.unions ys, Set.unions zs, Set.unions ws) + where (xs, ys, zs, ws) = unzip4 xyzws -- | 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 :: APIChange -> (Set MigrationTag, Set MigrationTag, Set MigrationTag, Set MigrationTag) +changeTags (ChChangeField _ _ _ t) = (Set.empty, Set.empty, Set.empty, Set.singleton t) +changeTags (ChChangeUnionAlt _ _ _ t) = (Set.empty, Set.empty, Set.singleton t, Set.empty) +changeTags (ChCustomType _ t) = (Set.empty, Set.singleton t, Set.empty, Set.empty) +changeTags (ChCustomAll t) = (Set.singleton t, Set.empty, Set.empty, Set.empty) +changeTags _ = (Set.empty, Set.empty, Set.empty, Set.empty) -------------------------------- @@ -304,11 +311,11 @@ findUpdatePos tname api = Map.alter (Just . UpdateHere) tname $ -- | Check that a changelog adequately describes how to migrate from -- one version to another. -validateChanges :: (Read db, Read rec, Read fld) +validateChanges :: (Read db, Read rec, Read alt, Read fld) => (API, Version) -- ^ Starting schema and version -> (API, VersionExtra) -- ^ Ending schema and version -> APIChangelog -- ^ Changelog to be validated - -> CustomMigrations o v db rec fld -- ^ Custom migration functions + -> CustomMigrations o v db rec alt fld -- ^ Custom migration functions -> TypeName -- ^ Name of the dataset's type -> DataChecks -- ^ How thoroughly to validate changes -> Either ValidateFailure [ValidateWarning] @@ -484,6 +491,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 +622,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 (unionAltMigration 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 +740,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 (unionAltMigration 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 @@ -864,17 +892,21 @@ type Decode t = JS.Value -> Either [(JSONError, Position)] t -- | Generate enumeration datatypes corresponding to the custom -- migrations used in an API migration changelog. -generateMigrationKinds :: APIChangelog -> String -> String -> String -> Q [Dec] -generateMigrationKinds changes all_nm rec_nm fld_nm = do +generateMigrationKinds :: APIChangelog -> String -> String -> String -> String -> Q [Dec] +generateMigrationKinds changes all_nm rec_nm alt_nm fld_nm = do guardNoDups (all_tags `Set.intersection` rec_tags) + guardNoDups (all_tags `Set.intersection` alt_tags) guardNoDups (all_tags `Set.intersection` fld_tags) + guardNoDups (rec_tags `Set.intersection` alt_tags) guardNoDups (rec_tags `Set.intersection` fld_tags) + guardNoDups (alt_tags `Set.intersection` fld_tags) return [ mkDataD [] (mkName all_nm) [] (cons all_nm all_tags) derivs , mkDataD [] (mkName rec_nm) [] (cons rec_nm rec_tags) derivs + , mkDataD [] (mkName alt_nm) [] (cons alt_nm alt_tags) derivs , mkDataD [] (mkName fld_nm) [] (cons fld_nm fld_tags) derivs ] where - (all_tags, rec_tags, fld_tags) = changelogTags changes + (all_tags, rec_tags, alt_tags, fld_tags) = changelogTags changes guardNoDups xs | Set.null xs = return () 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/src/Data/API/Tutorial.hs b/src/Data/API/Tutorial.hs index bb7fc30..85c1210 100644 --- a/src/Data/API/Tutorial.hs +++ b/src/Data/API/Tutorial.hs @@ -301,13 +301,14 @@ These types should then be used to create a 'CustomMigrations' record, which describes how to transform the data (and 'API', if appropriate) for each custom migration. For example, -> $(generateMigrationKinds myChangelog "DatabaseMigration" "TypeMigration" "FieldMigration") +> $(generateMigrationKinds myChangelog "DatabaseMigration" "TypeMigration" "UnionAltMigration" "FieldMigration") with the changelog fragment above would give -> data DatabaseMigration = MigrateWholeDatabase | ... -> data TypeMigration = MigrateWidgetType | ... -> data FieldMigration = MigrateFooField | ... +> data DatabaseMigration = MigrateWholeDatabase | ... +> data TypeMigration = MigrateWidgetType | ... +> data UnionAltMigration = ... +> data FieldMigration = MigrateFooField | ... Calls to 'migrateDataDump' should include a suitable 'CustomMigrations' record, which includes functions to perform the 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/Migration.hs b/tests/Data/API/Test/Migration.hs index 0270ff1..b13bc47 100644 --- a/tests/Data/API/Test/Migration.hs +++ b/tests/Data/API/Test/Migration.hs @@ -40,7 +40,7 @@ import qualified Data.HashMap.Strict as HMap #endif -$(generateMigrationKinds changelog "TestDatabaseMigration" "TestRecordMigration" "TestFieldMigration") +$(generateMigrationKinds changelog "TestDatabaseMigration" "TestRecordMigration" "TestUnionAltMigration" "TestFieldMigration") -- Test of a whole-database migration: copy data between tables @@ -121,18 +121,20 @@ testFieldMigration' ConvertBinaryToString (Value.Bytes bs) = return (Value.Strin testFieldMigration' ConvertBinaryToString v = Left $ CustomMigrationError "bad data" (JS.toJSON v) -testMigration :: CustomMigrations JS.Object JS.Value TestDatabaseMigration TestRecordMigration TestFieldMigration +testMigration :: CustomMigrations JS.Object JS.Value TestDatabaseMigration TestRecordMigration TestUnionAltMigration TestFieldMigration testMigration = CustomMigrations testDatabaseMigration testDatabaseMigrationSchema testRecordMigration testRecordMigrationSchema + (\ _ -> noDataChanges) testFieldMigration -testMigration' :: CustomMigrations Value.Record Value.Value TestDatabaseMigration TestRecordMigration TestFieldMigration +testMigration' :: CustomMigrations Value.Record Value.Value TestDatabaseMigration TestRecordMigration TestUnionAltMigration TestFieldMigration testMigration' = CustomMigrations testDatabaseMigration' testDatabaseMigrationSchema testRecordMigration' testRecordMigrationSchema + (\ _ -> noDataChanges) testFieldMigration' diff --git a/tests/Data/API/Test/UnionMigration.hs b/tests/Data/API/Test/UnionMigration.hs new file mode 100644 index 0000000..448cf93 --- /dev/null +++ b/tests/Data/API/Test/UnionMigration.hs @@ -0,0 +1,169 @@ +{-# 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" "TypeSwapUnionAltMigration" "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 :: TypeSwapUnionAltMigration -> 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 TypeSwapUnionAltMigration TypeSwapFieldMigration +typeSwapMigration = CustomMigrations + { databaseMigration = \ _ -> noDataChanges + , databaseMigrationSchema = \ _ -> noSchemaChanges + , typeMigration = \ _ -> noDataChanges + , typeMigrationSchema = \ _ -> noSchemaChanges + , unionAltMigration = migratePersonV1ToV2 + , 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" +|]