Skip to content

Commit a87edcf

Browse files
adinapoliadinapoli
committed
Support migrating individual alternatives in unions
1 parent 8b85714 commit a87edcf

6 files changed

Lines changed: 199 additions & 11 deletions

File tree

‎api-tools.cabal‎

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -176,6 +176,8 @@ Test-Suite test-api-tools
176176
Data.API.Test.Migration
177177
Data.API.Test.MigrationData
178178
Data.API.Test.Time
179+
Data.API.Test.UnionMigration
180+
Data.API.Test.UnionMigrationData
179181

180182
Build-depends:
181183
api-tools,

‎src/Data/API/Changes.hs‎

Lines changed: 30 additions & 8 deletions
Original file line numberDiff line numberDiff line change
@@ -200,10 +200,11 @@ data DataChecks = NoChecks -- ^ Not at all
200200

201201
-- | Whether to validate the dataset after this change
202202
validateAfter :: DataChecks -> APIChange -> Bool
203-
validateAfter chks (ChChangeField{}) = chks >= CheckCustom
204-
validateAfter chks (ChCustomType{}) = chks >= CheckCustom
205-
validateAfter chks (ChCustomAll{}) = chks >= CheckCustom
206-
validateAfter chks _ = chks >= CheckAll
203+
validateAfter chks (ChChangeField{}) = chks >= CheckCustom
204+
validateAfter chks (ChChangeUnionAlt{}) = chks >= CheckCustom
205+
validateAfter chks (ChCustomType{}) = chks >= CheckCustom
206+
validateAfter chks (ChCustomAll{}) = chks >= CheckCustom
207+
validateAfter chks _ = chks >= CheckAll
207208

208209

209210
--------------------
@@ -255,10 +256,11 @@ changelogTags (ChangesUpTo _ cs older) =
255256

256257
-- | Sets of custom migration tags in a single change
257258
changeTags :: APIChange -> (Set MigrationTag, Set MigrationTag, Set MigrationTag)
258-
changeTags (ChChangeField _ _ _ t) = (Set.empty, Set.empty, Set.singleton t)
259-
changeTags (ChCustomType _ t) = (Set.empty, Set.singleton t, Set.empty)
260-
changeTags (ChCustomAll t) = (Set.singleton t, Set.empty, Set.empty)
261-
changeTags _ = (Set.empty, Set.empty, Set.empty)
259+
changeTags (ChChangeField _ _ _ t) = (Set.empty, Set.empty, Set.singleton t)
260+
changeTags (ChChangeUnionAlt _ _ _ t) = (Set.empty, Set.empty, Set.singleton t)
261+
changeTags (ChCustomType _ t) = (Set.empty, Set.singleton t, Set.empty)
262+
changeTags (ChCustomAll t) = (Set.singleton t, Set.empty, Set.empty)
263+
changeTags _ = (Set.empty, Set.empty, Set.empty)
262264

263265

264266
--------------------------------
@@ -484,6 +486,13 @@ applyAPIChangeToAPI _ _ (ChRenameUnionAlt tname fname fname') api = do
484486
. Map.delete fname) unioninfo
485487
return (Map.insert tname tinfo' api, findUpdatePos tname api)
486488

489+
applyAPIChangeToAPI _ _custom (ChChangeUnionAlt tname fname ftype _tag) api = do
490+
tinfo <- lookupType tname api
491+
unioninfo <- expectUnionType tinfo ?! TypeWrongKind tname TKUnion
492+
guard (Map.member fname unioninfo) ?! FieldDoesNotExist tname TKUnion fname
493+
let tinfo' = (NUnionType . Map.insert fname ftype) unioninfo
494+
return (Map.insert tname tinfo' api, findUpdatePos tname api)
495+
487496
applyAPIChangeToAPI _ _ (ChAddEnumVal tname fname) api = do
488497
tinfo <- lookupType tname api
489498
enuminfo <- expectEnumType tinfo ?! TypeWrongKind tname TKEnum
@@ -607,6 +616,13 @@ applyChangeToData (ChRenameUnionAlt _ fname fname') _ = withObject $ \un p ->
607616
| otherwise -> return un
608617
Nothing -> Left (JSONError $ SyntaxError "Not singleton", p)
609618

619+
applyChangeToData (ChChangeUnionAlt _ fname _ftype tag) custom = withObject $ \un p ->
620+
case matchSingletonObject un of
621+
Just (k, r) | k == _FieldName fname -> do
622+
r' <- liftMigration (fieldMigration custom tag) r p
623+
return $ singletonObject (_FieldName fname) r'
624+
_ -> return un
625+
610626
applyChangeToData (ChRenameEnumVal _ fname fname') _ = withString $ \s _ ->
611627
if s == _FieldName fname then return (_FieldName fname')
612628
else return s
@@ -718,6 +734,12 @@ applyChangeToData' _ (ChRenameUnionAlt _ fname fname') _ v p = do
718734
(fn, v') <- expectUnion v p
719735
pure $! if fn == fname then Union fname' v' else v
720736

737+
applyChangeToData' _ (ChChangeUnionAlt _ fname _ftype tag) custom v p = do
738+
(fn, v') <- expectUnion v p
739+
if fn == fname
740+
then Union fn <$!> liftMigration (fieldMigration custom tag) v' (inField fn:p)
741+
else pure v
742+
721743
applyChangeToData' _ (ChRenameEnumVal _ fname fname') _ v p = do
722744
fn <- expectEnum v p
723745
pure $! if fn == fname then Enum fname' else v

‎src/Data/API/Changes/Types.hs‎

Lines changed: 4 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -57,6 +57,7 @@ data APIChange
5757
| ChAddUnionAlt TypeName FieldName APIType
5858
| ChDeleteUnionAlt TypeName FieldName
5959
| ChRenameUnionAlt TypeName FieldName FieldName
60+
| ChChangeUnionAlt TypeName FieldName APIType MigrationTag
6061

6162
-- Changes for enum types
6263
| ChAddEnumVal TypeName FieldName
@@ -87,6 +88,9 @@ instance PPLines APIChange where
8788
, " alternative removed " ++ pp f]
8889
ppLines (ChRenameUnionAlt t f f') = [ "changed union " ++ pp t
8990
, " alternative renamed " ++ pp f ++ " to " ++ pp f']
91+
ppLines (ChChangeUnionAlt t f ty c) = [ "changed union " ++ pp t
92+
, " alternative changed " ++ pp f ++ " :: " ++ pp ty
93+
++ " migration " ++ pp c]
9094
ppLines (ChAddEnumVal t f) = [ "changed enum " ++ pp t
9195
, " alternative added " ++ pp f]
9296
ppLines (ChDeleteEnumVal t f) = [ "changed enum " ++ pp t

‎src/Data/API/Parse.y‎

Lines changed: 6 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -280,6 +280,7 @@ UnionChange :: { [UnionChange] }
280280
: alternative added FieldName '::' Type { [UnChAdd $3 $5] }
281281
| alternative removed FieldName { [UnChDelete $3] }
282282
| alternative renamed FieldName to FieldName { [UnChRename $3 $5] }
283+
| alternative changed FieldName '::' Type migration MigrationTag { [UnChChange $3 $5 $7] }
283284
| comment { [] }
284285

285286
REnumChanges :: { [EnumChange] }
@@ -331,11 +332,13 @@ fldChangeToAPIChange t (FldChChange f ty m) = ChChangeField t f ty m
331332
data UnionChange = UnChAdd FieldName APIType
332333
| UnChDelete FieldName
333334
| UnChRename FieldName FieldName
335+
| UnChChange FieldName APIType MigrationTag
334336

335337
unionChangeToAPIChange :: TypeName -> UnionChange -> APIChange
336-
unionChangeToAPIChange t (UnChAdd f ty) = ChAddUnionAlt t f ty
337-
unionChangeToAPIChange t (UnChDelete f) = ChDeleteUnionAlt t f
338-
unionChangeToAPIChange t (UnChRename f f') = ChRenameUnionAlt t f f'
338+
unionChangeToAPIChange t (UnChAdd f ty) = ChAddUnionAlt t f ty
339+
unionChangeToAPIChange t (UnChDelete f) = ChDeleteUnionAlt t f
340+
unionChangeToAPIChange t (UnChRename f f') = ChRenameUnionAlt t f f'
341+
unionChangeToAPIChange t (UnChChange f ty m) = ChChangeUnionAlt t f ty m
339342

340343
data EnumChange = EnChAdd FieldName
341344
| EnChDelete FieldName

‎tests/Data/API/Test/UnionMigration.hs‎

Lines changed: 107 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,107 @@
1+
{-# LANGUAGE OverloadedStrings #-}
2+
{-# LANGUAGE TemplateHaskell #-}
3+
4+
-- | Standalone test for union alternative migration with field changes
5+
module Data.API.Test.UnionMigration
6+
( unionMigrationTests
7+
) where
8+
9+
import Data.API.Changes
10+
import Data.API.JSON
11+
import Data.API.JSON.Compat
12+
import Data.API.Tools
13+
import Data.API.Types
14+
import Data.API.Utils
15+
16+
import qualified Data.Aeson as JS
17+
import qualified Data.Aeson.Encode.Pretty as JS
18+
import qualified Data.ByteString.Lazy.Char8 as BL
19+
import qualified Data.Text as T
20+
import Data.Version
21+
import Test.Tasty
22+
import Test.Tasty.HUnit
23+
24+
import Data.API.Test.UnionMigrationData
25+
26+
27+
-- Generate migration enums from changelog
28+
$(generateMigrationKinds testChangelog "TestDbMigration" "TestRecordMigration" "TestFieldMigration")
29+
30+
31+
-- Custom field migration that adds a 'name' field prefixed with "id_"
32+
testFieldMigration :: TestFieldMigration -> JS.Value -> Either ValueError JS.Value
33+
testFieldMigration AddNameToTestRecord (JS.Object x) = do
34+
i <- lookupKey "id" x ?! CustomMigrationError "missing id" (JS.Object x)
35+
case i of
36+
JS.Number n -> do
37+
let name = JS.String $ "id_" `T.append` T.pack (show (floor (toRational n) :: Int))
38+
return $ JS.Object $ insertKey "name" name x
39+
_ -> Left $ CustomMigrationError "bad id" (JS.Object x)
40+
testFieldMigration AddNameToTestRecord v = Left $ CustomMigrationError "bad data" v
41+
42+
43+
-- Custom migrations record
44+
testMigration :: CustomMigrations JS.Object JS.Value TestDbMigration TestRecordMigration TestFieldMigration
45+
testMigration = CustomMigrations
46+
{ databaseMigration = \ _ -> noDataChanges
47+
, databaseMigrationSchema = \ _ -> noSchemaChanges
48+
, typeMigration = \ _ -> noDataChanges
49+
, typeMigrationSchema = \ _ -> noSchemaChanges
50+
, fieldMigration = testFieldMigration
51+
}
52+
53+
54+
-- Test data
55+
startUnionData :: JS.Value
56+
Just startUnionData = JS.decode "{ \"alt\": {\"id\": 42} }"
57+
58+
expectedUnionData :: JS.Value
59+
Just expectedUnionData = JS.decode "{ \"alt\": {\"id\": 42, \"name\": \"id_42\"} }"
60+
61+
62+
-- | The basic test case for union alternative migration
63+
unionAlternativeMigrationTest :: Assertion
64+
unionAlternativeMigrationTest = do
65+
-- Verify data matches schemas
66+
case dataMatchesAPI rootUnionName startUnionSchema startUnionData of
67+
Right () -> return ()
68+
Left err -> assertFailure $ "Start data does not match start API: "
69+
++ prettyValueErrorPosition err
70+
71+
case dataMatchesAPI rootUnionName endUnionSchema expectedUnionData of
72+
Right () -> return ()
73+
Left err -> assertFailure $ "Expected end data does not match end API: "
74+
++ prettyValueErrorPosition err
75+
76+
-- Run migration
77+
let startVer = parseVer "0"
78+
case migrateDataDump (startUnionSchema, startVer) (endUnionSchema, parseVerExtra "1.0")
79+
testChangelog testMigration rootUnionName CheckAll startUnionData of
80+
Right (v, []) | expectedUnionData == v -> return ()
81+
| otherwise -> assertFailure $ unlines
82+
[ "Expected:"
83+
, BL.unpack (JS.encodePretty expectedUnionData)
84+
, "but got:"
85+
, BL.unpack (JS.encodePretty v)
86+
]
87+
Right (_, ws) -> assertFailure $ "Unexpected warnings: " ++ show ws
88+
Left err -> assertFailure $ "Migration failed: " ++ prettyMigrateFailure err
89+
90+
91+
rootUnionName :: TypeName
92+
rootUnionName = TypeName "TestUnion"
93+
94+
parseVer :: String -> Version
95+
parseVer s = case simpleParseVersion s of
96+
Just v -> v
97+
Nothing -> error $ "Invalid version: " ++ s
98+
99+
parseVerExtra :: String -> VersionExtra
100+
parseVerExtra s = Release $ parseVer s
101+
102+
103+
-- | All union migration tests
104+
unionMigrationTests :: TestTree
105+
unionMigrationTests = testGroup "Union Alternative Migration"
106+
[ testCase "Union alternative migration with field change" unionAlternativeMigrationTest
107+
]

‎tests/Data/API/Test/UnionMigrationData.hs‎

Lines changed: 50 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,50 @@
1+
{-# LANGUAGE QuasiQuotes #-}
2+
3+
-- | Data for union alternative migration tests
4+
module Data.API.Test.UnionMigrationData
5+
( startUnionSchema
6+
, endUnionSchema
7+
, testChangelog
8+
) where
9+
10+
import Data.API.Changes
11+
import Data.API.Parse
12+
import Data.API.Types
13+
14+
15+
-- Initial schema with a union containing a record type
16+
startUnionSchema :: API
17+
startUnionSchema = [api|
18+
19+
testPrefix :: TestRecord
20+
= record
21+
id :: integer
22+
23+
testUnionPrefix :: TestUnion
24+
= union
25+
| alt :: TestRecord
26+
|]
27+
28+
29+
-- Final schema and changelog
30+
endUnionSchema :: API
31+
testChangelog :: APIChangelog
32+
(endUnionSchema, testChangelog) = [apiWithChangelog|
33+
34+
testPrefix :: TestRecord
35+
= record
36+
id :: integer
37+
name :: string
38+
39+
testUnionPrefix :: TestUnion
40+
= union
41+
| alt :: TestRecord
42+
43+
changes
44+
45+
version "1.0"
46+
changed union TestUnion
47+
alternative changed alt :: TestRecord migration AddNameToTestRecord
48+
49+
version "0"
50+
|]

0 commit comments

Comments
 (0)