-
Notifications
You must be signed in to change notification settings - Fork 2
Expand file tree
/
Copy pathChanges.hs
More file actions
912 lines (774 loc) · 42.7 KB
/
Changes.hs
File metadata and controls
912 lines (774 loc) · 42.7 KB
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
{-# LANGUAGE TemplateHaskell #-}
-- | This module deals with validating API changelogs and migrating
-- JSON data between different versions of a schema.
module Data.API.Changes
( migrateDataDump
, migrateDataDump'
-- * Validating changelogs
, validateChanges
, dataMatchesAPI
, DataChecks(..)
-- * Changelog representation
, APIChangelog(..)
, APIWithChangelog
, APIChange(..)
, VersionExtra(..)
, showVersionExtra
, changelogStartVersion
, changelogVersion
-- * Custom migrations
, CustomMigrations(..)
, mkRecordMigration
, mkRecordMigration'
, mkRecordMigrationSchema
, noDataChanges
, noSchemaChanges
, generateMigrationKinds
, MigrationTag
-- * API normal forms
, NormAPI
, NormTypeDecl(..)
, NormRecordType
, NormUnionType
, NormEnumType
, apiNormalForm
, declNF
-- * Migration errors
, MigrateFailure(..)
, MigrateWarning
, ValidateFailure(..)
, ValidateWarning
, ApplyFailure(..)
, TypeKind(..)
, MergeResult(..)
, ValueError(..)
, prettyMigrateFailure
, prettyValidateFailure
, prettyValueError
, prettyValueErrorPosition
) where
import Data.API.Changes.Types
import Data.API.Error
import Data.API.JSON
import Data.API.JSON.Compat
import Data.API.NormalForm
import Data.API.TH.Compat
import Data.API.Types
import Data.API.Utils
import Data.API.Value as Value
import Data.Binary.Serialise.CBOR.Extra
import Control.Applicative
import Control.Monad (guard, foldM, void)
import qualified Data.Aeson as JS
import Data.List
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Maybe
import Data.Set (Set)
import qualified Data.Set as Set
import qualified Data.Vector as V
import qualified Data.Text as T
import Data.Time
import Data.Version
import Language.Haskell.TH
import Safe
-------------------------
-- Top level: do it all
--
-- | Migrate a dataset from one version of an API schema to another.
-- The data must be described by a named type, the name of which is
-- assumed not to change.
--
-- The @db@, @rec@ and @fld@ types must be enumerations of all the
-- custom migration tags in the changelog, as generated by
-- 'generateMigrationKind'.
migrateDataDump :: (Read db, Read rec, 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
-> TypeName -- ^ Name of the dataset's type
-> DataChecks -- ^ How thoroughly to validate changes
-> JS.Value -- ^ Dataset to be migrated
-> Either MigrateFailure (JS.Value, [MigrateWarning])
migrateDataDump startApi endApi changelog custom root chks db = do
let custom' = readCustomMigrations custom
(changes, warnings) <- validateChanges' startApi endApi changelog custom' root chks
?!? ValidateFailure
db' <- applyChangesToDatabase root custom' db changes ?!? uncurry ValueError
return (db', warnings)
migrateDataDump' :: (Read db, Read rec, 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
-> TypeName -- ^ Name of the dataset's type
-> DataChecks -- ^ How thoroughly to validate changes
-> Value.Value -- ^ Dataset to be migrated
-> Either MigrateFailure (Value.Value, [MigrateWarning])
migrateDataDump' startApi endApi changelog custom root chks db = do
let custom' = readCustomMigrations custom
(changes, warnings) <- validateChanges' startApi endApi changelog custom' root chks
?!? ValidateFailure
db' <- applyChangesToDatabase' root custom' db changes ?!? uncurry ValueError
return (db', warnings)
-- | Custom migrations used in the changelog must be implemented in
-- Haskell, and supplied in this record. There are three 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
--
-- * Single field migrations, which may change only the type of the
-- field (with the new type specified in the changelog).
--
-- 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
{ 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)
, fieldMigration :: fld -> v -> Either ValueError v }
type CustomMigrationsTagged o v = CustomMigrations o v 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)
-- | Lift a custom record migration to work on arbitrary values
mkRecordMigration :: (JS.Object -> Either ValueError JS.Object)
-> (JS.Value -> Either ValueError JS.Value)
mkRecordMigration f (JS.Object o) = JS.Object <$> f o
mkRecordMigration _ v = Left $ JSONError $ expectedObject v
mkRecordMigration' :: (Record -> Either ValueError Record)
-> (Value -> Either ValueError Value)
mkRecordMigration' f (Record xs) = Record <$> f xs
mkRecordMigration' _ v = Left $ JSONError $ expectedObject (JS.toJSON v)
-- | Lift a schema change on record types to work on arbitrary type declarations
mkRecordMigrationSchema :: TypeName
-> (NormRecordType -> Either ApplyFailure (Maybe NormRecordType))
-> (NormTypeDecl -> Either ApplyFailure (Maybe NormTypeDecl))
mkRecordMigrationSchema tname f tinfo = do
recinfo <- expectRecordType tinfo ?! TypeWrongKind tname TKRecord
fmap NRecordType <$> f recinfo
-- | Use for 'databaseMigration', 'typeMigration' or 'fieldMigration'
-- to indicate that changes to the data are not required
noDataChanges :: a -> Either ValueError a
noDataChanges = return
-- | Use for 'databaseMigrationSchema' or 'typeMigrationSchema' to
-- indicate that the schema should not be changed
noSchemaChanges :: a -> Either ApplyFailure (Maybe a)
noSchemaChanges _ = Right Nothing
-- | When to validate the data against the schema (each level implies
-- the preceding levels):
data DataChecks = NoChecks -- ^ Not at all
| CheckStartAndEnd -- ^ At start and end of the migration
| CheckCustom -- ^ After custom migrations
| CheckAll -- ^ After every change
deriving (Eq, Ord)
-- | Whether to validate the dataset after this change
validateAfter :: DataChecks -> APIChange -> Bool
validateAfter chks (ChChangeField{}) = chks >= CheckCustom
validateAfter chks (ChChangeUnionAlt{}) = chks >= CheckCustom
validateAfter chks (ChCustomType{}) = chks >= CheckCustom
validateAfter chks (ChCustomAll{}) = chks >= CheckCustom
validateAfter chks _ = chks >= CheckAll
--------------------
-- Changelog utils
--
-- | The earliest version in the changelog
changelogStartVersion :: APIChangelog -> Version
changelogStartVersion (ChangesStart v) = v
changelogStartVersion (ChangesUpTo _ _ clog) = changelogStartVersion clog
-- | The latest version in the changelog
changelogVersion :: APIChangelog -> VersionExtra
changelogVersion (ChangesStart v) = Release v
changelogVersion (ChangesUpTo v _ _) = v
-- | Changelog in order starting from oldest version up to newest.
-- Entries are @(from, to, changes-oldest-first)@.
viewChangelogReverse :: APIChangelog -> [(VersionExtra, VersionExtra, [APIChange])]
viewChangelogReverse clog =
reverse [ (v,v',reverse cs) | (v',v,cs) <- viewChangelog clog ]
-- | Changelog in order as written, with latest version at the beginning, going
-- back to older versions. Entries are @(to, from, changes-latest-first)@.
viewChangelog :: APIChangelog -> [(VersionExtra, VersionExtra, [APIChange])]
viewChangelog (ChangesStart _) = []
viewChangelog (ChangesUpTo v' cs older) = (v', v, cs) : viewChangelog older
where v = changelogVersion older
-- | Is the changelog in the correct order? If not, return a pair of
-- out-of-order versions.
isChangelogOrdered :: APIChangelog -> Either (VersionExtra, VersionExtra) ()
isChangelogOrdered changelog =
case find (\ (v', v, _) -> v' <= v) (viewChangelog changelog) of
Nothing -> return ()
Just (v', v, _) -> Left (v', v)
-- | 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)
changelogTags (ChangesUpTo _ cs older) =
unions3 (map changeTags cs) `union3` 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
-- | 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 (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)
--------------------------------
-- Representing update positions
--
-- | Given a type to be modified, find the positions in which each
-- type in the API must be updated
findUpdatePos :: TypeName -> NormAPI -> Map TypeName UpdateDeclPos
findUpdatePos tname api = Map.alter (Just . UpdateHere) tname $
Map.fromSet findDecl deps
where
-- The set of types that depend on the type being updated
deps :: Set TypeName
deps = transitiveReverseDeps api (Set.singleton tname)
findDecl :: TypeName -> UpdateDeclPos
findDecl tname' = findDecl' $
fromMaybe (error "findUpdatePos: missing type") $
Map.lookup tname' api
findDecl' :: NormTypeDecl -> UpdateDeclPos
findDecl' (NRecordType flds) = UpdateRecord $ fmap findType flds
findDecl' (NUnionType alts) = UpdateUnion $ fmap findType alts
findDecl' (NEnumType _) = error "findDecl': unexpected enum"
findDecl' (NTypeSynonym ty) = UpdateType $ fromMaybe (error "findDecl': missing") $
findType ty
findDecl' (NNewtype _) = error "findDecl': unexpected newtype"
findType :: APIType -> Maybe UpdateTypePos
findType (TyList ty) = UpdateList <$> findType ty
findType (TyMaybe ty) = UpdateMaybe <$> findType ty
findType (TyName tname')
| tname' == tname || tname' `Set.member` deps = Just $ UpdateNamed tname'
| otherwise = Nothing
findType (TyBasic _) = Nothing
findType TyJSON = Nothing
---------------------------
-- Validating API changes
--
-- | Check that a changelog adequately describes how to migrate from
-- one version to another.
validateChanges :: (Read db, Read rec, 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
-> TypeName -- ^ Name of the dataset's type
-> DataChecks -- ^ How thoroughly to validate changes
-> Either ValidateFailure [ValidateWarning]
validateChanges (api,ver) (api',ver') clog custom root chks = snd <$>
validateChanges' (api,ver) (api',ver') clog (readCustomMigrations custom) root chks
-- | Internal version of 'validateChanges', which works on unsafe
-- migration tags and returns the list of 'APITableChange's to apply
-- to the dataset.
validateChanges' :: (API, Version) -- ^ Starting schema and version
-> (API, VersionExtra) -- ^ Ending schema and version
-> APIChangelog -- ^ Changelog to be validated
-> CustomMigrationsTagged o v -- ^ Custom migration functions
-> TypeName -- ^ Name of the dataset's type
-> DataChecks -- ^ How thoroughly to validate changes
-> Either ValidateFailure ([APITableChange], [ValidateWarning])
validateChanges' (api,ver) (api',ver') clog custom root chks = do
-- select changes by version from log
(changes, verEnd) <- selectChanges clog (Release ver) ver'
-- take norm of start and end api,
let apiStart = apiNormalForm api
apiTarget = apiNormalForm api'
-- check start and end APIs are well formed.
apiInvariant apiStart ?!? ApiInvalid (Release ver)
apiInvariant apiTarget ?!? ApiInvalid ver'
-- check expected end api
(apiEnd, changes') <- applyAPIChangesToAPI root custom chks changes apiStart
-- check expected end api
guard (apiEnd == apiTarget) ?! ChangelogIncomplete verEnd ver' (diffMaps apiEnd apiTarget)
return (changes', [])
selectChanges :: APIChangelog -> VersionExtra -> VersionExtra
-> Either ValidateFailure ([APIChange], VersionExtra)
selectChanges clog ver ver'
| ver' == ver = return ([], ver')
| ver' > ver = do
isChangelogOrdered clog ?!? uncurry ChangelogOutOfOrder
let withinRange = takeWhile (\ (_, v, _) -> v <= ver') $
dropWhile (\ (_, v, _) -> v <= ver) $
viewChangelogReverse clog
endVer = case lastMay withinRange of
Nothing -> ver
Just (_, v, _) -> v
return ([ c | (_,_, cs) <- withinRange, c <- cs ], endVer)
| otherwise = Left (CannotDowngrade ver ver')
-- | Apply a list of changes to an API, returning the updated API and
-- a list of the changes with appropriate TableChanges interspersed.
-- On failure, return the list of successfully applied changes, the
-- change that failed and the reason for the failure.
applyAPIChangesToAPI :: TypeName -> CustomMigrationsTagged o v -> DataChecks
-> [APIChange] -> NormAPI
-> Either ValidateFailure (NormAPI, [APITableChange])
applyAPIChangesToAPI root custom chks changes api = do
(api', changes') <- foldM (doChangeAPI root custom chks) (api, []) changes
let changes'' | chks >= CheckStartAndEnd = addV api $ reverse $ addV api' changes'
| otherwise = reverse changes'
return (api', changes'')
where
addV _ cs@(ValidateData _ : _) = cs
addV a cs = ValidateData a : cs
-- | Apply the API change
doChangeAPI :: TypeName -> CustomMigrationsTagged o v -> DataChecks
-> (NormAPI, [APITableChange]) -> APIChange
-> Either ValidateFailure (NormAPI, [APITableChange])
doChangeAPI root custom chks (api, changes) change = do
(api', pos) <- applyAPIChangeToAPI root custom change api
?!? ChangelogEntryInvalid changes change
let changes' = APIChange api change pos : changes
changes'' | validateAfter chks change = ValidateData api' : changes'
| otherwise = changes'
return (api', changes'')
-- Checks and and performs an API change. If it works then we get back the new
-- overall api. This is used for two purposes, (1) validating that we can apply
-- each change in that context, and that we end up with the API we expect
-- and (2) getting the intermediate APIs during data migration, because we need
-- the schema of the intermediate data as part of applying the migration.
applyAPIChangeToAPI :: TypeName -> CustomMigrationsTagged o v -> APIChange -> NormAPI
-> Either ApplyFailure (NormAPI, Map TypeName UpdateDeclPos)
applyAPIChangeToAPI _ _ (ChAddType tname tdecl) api = do
-- to add a new type, that type must not yet exist
guard (not (tname `typeDeclaredInApi` api)) ?! TypeExists tname
declIsValid tdecl api ?!? DeclMalformed tname tdecl
return (Map.insert tname tdecl api, Map.empty)
applyAPIChangeToAPI _ _ (ChDeleteType tname) api = do
-- to delete a type, that type must exist
guard (tname `typeDeclaredInApi` api) ?! TypeDoesNotExist tname
-- it must also not be used anywhere else in the API
guard (not (tname `typeUsedInApi` api)) ?! TypeInUse tname
return (Map.delete tname api, Map.empty)
applyAPIChangeToAPI _ _ (ChRenameType tname tname') api = do
-- to rename a type, the original type name must exist
-- and the new one must not yet exist
tinfo <- lookupType tname api
guard (not (tname' `typeDeclaredInApi` api)) ?! TypeExists tname'
return ( (renameTypeUses tname tname'
. Map.insert tname' tinfo . Map.delete tname) api
, Map.empty )
applyAPIChangeToAPI _ custom (ChCustomType tname tag) api = do
-- to make some change to values of a type, the type name must exist
tinfo <- lookupType tname api
mb_tinfo' <- typeMigrationSchema custom tag tinfo
let api' = case mb_tinfo' of
Just tinfo' -> Map.insert tname tinfo' api
Nothing -> api
return (api', findUpdatePos tname api)
applyAPIChangeToAPI root _ (ChAddField tname fname ftype mb_defval) api = do
tinfo <- lookupType tname api
recinfo <- expectRecordType tinfo ?! TypeWrongKind tname TKRecord
guard (not (Map.member fname recinfo)) ?! FieldExists tname TKRecord fname
typeIsValid ftype api ?!? TypeMalformed ftype
case mb_defval <|> defaultValueForType ftype of
Just defval -> guard (compatibleDefaultValue api ftype defval)
?! FieldBadDefaultValue tname fname ftype defval
Nothing -> guard (not (typeUsedInTransitiveDep root tname api))
?! DefaultMissing tname fname
let tinfo' = NRecordType (Map.insert fname ftype recinfo)
return (Map.insert tname tinfo' api, findUpdatePos tname api)
applyAPIChangeToAPI _ _ (ChDeleteField tname fname) api = do
tinfo <- lookupType tname api
recinfo <- expectRecordType tinfo ?! TypeWrongKind tname TKRecord
guard (Map.member fname recinfo) ?! FieldDoesNotExist tname TKRecord fname
let tinfo' = NRecordType (Map.delete fname recinfo)
return (Map.insert tname tinfo' api, findUpdatePos tname api)
applyAPIChangeToAPI _ _ (ChRenameField tname fname fname') api = do
tinfo <- lookupType tname api
recinfo <- expectRecordType tinfo ?! TypeWrongKind tname TKRecord
ftype <- Map.lookup fname recinfo ?! FieldDoesNotExist tname TKRecord fname
guard (not (Map.member fname' recinfo)) ?! FieldExists tname TKRecord fname'
let tinfo' = (NRecordType . Map.insert fname' ftype
. Map.delete fname) recinfo
return (Map.insert tname tinfo' api, findUpdatePos tname api)
applyAPIChangeToAPI _ _ (ChChangeField tname fname ftype _) api = do
tinfo <- lookupType tname api
recinfo <- expectRecordType tinfo ?! TypeWrongKind tname TKRecord
guard (Map.member fname recinfo) ?! FieldDoesNotExist tname TKRecord fname
let tinfo' = (NRecordType . Map.insert fname ftype) recinfo
return (Map.insert tname tinfo' api, findUpdatePos tname api)
applyAPIChangeToAPI _ _ (ChAddUnionAlt tname fname ftype) api = do
tinfo <- lookupType tname api
unioninfo <- expectUnionType tinfo ?! TypeWrongKind tname TKUnion
guard (not (Map.member fname unioninfo)) ?! FieldExists tname TKUnion fname
typeIsValid ftype api ?!? TypeMalformed ftype
let tinfo' = NUnionType (Map.insert fname ftype unioninfo)
return (Map.insert tname tinfo' api, Map.empty)
applyAPIChangeToAPI root _ (ChDeleteUnionAlt tname fname) api = do
tinfo <- lookupType tname api
unioninfo <- expectUnionType tinfo ?! TypeWrongKind tname TKUnion
guard (not (typeUsedInTransitiveDep root tname api)) ?! TypeInUse tname
guard (Map.member fname unioninfo) ?! FieldDoesNotExist tname TKUnion fname
let tinfo' = NUnionType (Map.delete fname unioninfo)
return (Map.insert tname tinfo' api, Map.empty)
applyAPIChangeToAPI _ _ (ChRenameUnionAlt tname fname fname') api = do
tinfo <- lookupType tname api
unioninfo <- expectUnionType tinfo ?! TypeWrongKind tname TKUnion
ftype <- Map.lookup fname unioninfo ?! FieldDoesNotExist tname TKUnion fname
guard (not (Map.member fname' unioninfo)) ?! FieldExists tname TKUnion fname'
let tinfo' = (NUnionType . Map.insert fname' ftype
. 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
guard (not (Set.member fname enuminfo)) ?! FieldExists tname TKEnum fname
let tinfo' = NEnumType (Set.insert fname enuminfo)
return (Map.insert tname tinfo' api, Map.empty)
applyAPIChangeToAPI root _ (ChDeleteEnumVal tname fname) api = do
tinfo <- lookupType tname api
enuminfo <- expectEnumType tinfo ?! TypeWrongKind tname TKEnum
guard (not (typeUsedInTransitiveDep root tname api)) ?! TypeInUse tname
guard (Set.member fname enuminfo) ?! FieldDoesNotExist tname TKEnum fname
let tinfo' = NEnumType (Set.delete fname enuminfo)
return (Map.insert tname tinfo' api, Map.empty)
applyAPIChangeToAPI _ _ (ChRenameEnumVal tname fname fname') api = do
tinfo <- lookupType tname api
enuminfo <- expectEnumType tinfo ?! TypeWrongKind tname TKEnum
guard (Set.member fname enuminfo) ?! FieldDoesNotExist tname TKEnum fname
guard (not (Set.member fname' enuminfo)) ?! FieldExists tname TKEnum fname'
let tinfo' = (NEnumType . Set.insert fname'
. Set.delete fname) enuminfo
return (Map.insert tname tinfo' api, findUpdatePos tname api)
applyAPIChangeToAPI root custom (ChCustomAll tag) api = do
mb_api' <- databaseMigrationSchema custom tag api
return ( fromMaybe api mb_api'
, Map.singleton root (UpdateHere Nothing))
expectRecordType :: NormTypeDecl -> Maybe (Map FieldName APIType)
expectRecordType (NRecordType rinfo) = Just rinfo
expectRecordType _ = Nothing
expectUnionType :: NormTypeDecl -> Maybe (Map FieldName APIType)
expectUnionType (NUnionType rinfo) = Just rinfo
expectUnionType _ = Nothing
expectEnumType :: NormTypeDecl -> Maybe (Set FieldName)
expectEnumType (NEnumType rinfo) = Just rinfo
expectEnumType _ = Nothing
-----------------------------------
-- Performing data transformation
--
-- | This is the low level one that just does the changes.
--
-- We assume the changes have already been validated, and that the data
-- matches the API.
--
applyChangesToDatabase :: TypeName -> CustomMigrationsTagged JS.Object JS.Value
-> JS.Value -> [APITableChange]
-> Either (ValueError, Position) JS.Value
applyChangesToDatabase root custom = foldM (applyChangeToDatabase root custom)
-- just apply each of the individual changes in sequence to the whole dataset
applyChangeToDatabase :: TypeName -> CustomMigrationsTagged JS.Object JS.Value
-> JS.Value -> APITableChange
-> Either (ValueError, Position) JS.Value
applyChangeToDatabase root custom v (APIChange _ c upds) =
updateTypeAt upds (applyChangeToData c custom) (UpdateNamed root) v []
applyChangeToDatabase root _ v (ValidateData api) = do
dataMatchesNormAPI root api v
return v
-- | Apply an update at the given position in a declaration's value
updateDeclAt :: Map TypeName UpdateDeclPos
-> (JS.Value -> Position -> Either (ValueError, Position) JS.Value)
-> UpdateDeclPos
-> JS.Value -> Position -> Either (ValueError, Position) JS.Value
updateDeclAt _ alter (UpdateHere Nothing) v p = alter v p
updateDeclAt upds alter (UpdateHere (Just upd)) v p = flip alter p =<< updateDeclAt upds alter upd v p
updateDeclAt upds alter (UpdateRecord upd_flds) v p = withObjectMatchingFields upd_flds
(maybe (pure . pure) (updateTypeAt upds alter)) v p
updateDeclAt upds alter (UpdateUnion upd_alts) v p = withObjectMatchingUnion upd_alts
(maybe (pure . pure) (updateTypeAt upds alter)) v p
updateDeclAt upds alter (UpdateType upd) v p = updateTypeAt upds alter upd v p
-- | Apply an upate at the given position in a type's value
updateTypeAt :: Map TypeName UpdateDeclPos
-> (JS.Value -> Position -> Either (ValueError, Position) JS.Value)
-> UpdateTypePos
-> JS.Value -> Position -> Either (ValueError, Position) JS.Value
updateTypeAt upds alter (UpdateList upd) v p = withArrayElems (updateTypeAt upds alter upd) v p
updateTypeAt upds alter (UpdateMaybe upd) v p = withMaybe (updateTypeAt upds alter upd) v p
updateTypeAt upds alter (UpdateNamed tname) v p = case Map.lookup tname upds of
Just upd -> updateDeclAt upds alter upd v p
Nothing -> pure v
-- | This actually applies the change to the data value, assuming it
-- is already in the correct place
applyChangeToData :: APIChange -> CustomMigrationsTagged JS.Object JS.Value
-> JS.Value -> Position -> Either (ValueError, Position) JS.Value
applyChangeToData (ChAddField tname fname ftype mb_defval) _ =
case mb_defval <|> defaultValueForType ftype of
Just defval -> let newFieldValue = defaultValueAsJsValue defval
in withObject (\ v _ -> pure $ insertKey (_FieldName fname) newFieldValue v)
Nothing -> \ _ p -> Left (InvalidAPI (DefaultMissing tname fname), p)
applyChangeToData (ChDeleteField _ fname) _ =
withObject (\ v _ -> pure $ deleteKey (_FieldName fname) v)
applyChangeToData (ChRenameField _ fname fname') _ =
withObject $ \rec p -> case lookupKey (_FieldName fname) rec of
Just field -> rename field rec
Nothing -> Left (JSONError MissingField, inField fname : p)
where
rename x = pure . insertKey (_FieldName fname') x . deleteKey (_FieldName fname)
applyChangeToData (ChChangeField _ fname _ftype tag) custom =
withObjectField (_FieldName fname) (liftMigration $ fieldMigration custom tag)
applyChangeToData (ChRenameUnionAlt _ fname fname') _ = withObject $ \un p ->
case matchSingletonObject un of
Just (k, r) | k == _FieldName fname -> return $ singletonObject (_FieldName fname') r
| 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
applyChangeToData (ChCustomType _ tag) custom = liftMigration $ typeMigration custom tag
applyChangeToData (ChCustomAll tag) custom = withObject (liftMigration $ databaseMigration custom tag)
applyChangeToData (ChAddType _ _) _ = pure . pure
applyChangeToData (ChDeleteType _) _ = pure . pure
applyChangeToData (ChRenameType _ _) _ = pure . pure
applyChangeToData (ChAddUnionAlt _ _ _) _ = pure . pure
applyChangeToData (ChDeleteUnionAlt _ _) _ = pure . pure
applyChangeToData (ChAddEnumVal _ _) _ = pure . pure
applyChangeToData (ChDeleteEnumVal _ _) _ = pure . pure
liftMigration :: (a -> Either ValueError b)
-> (a -> Position -> Either (ValueError, Position) b)
liftMigration f v p = f v ?!? flip (,) p
---------------------------------------------------------------------
-- Performing data transformation (new generic value representation)
--
applyChangesToDatabase' :: TypeName -> CustomMigrationsTagged Record Value
-> Value.Value -> [APITableChange]
-> Either (ValueError, Position) Value.Value
applyChangesToDatabase' root custom = foldM (applyChangeToDatabase' root custom)
-- just apply each of the individual changes in sequence to the whole dataset
applyChangeToDatabase' :: TypeName -> CustomMigrationsTagged Record Value
-> Value.Value -> APITableChange
-> Either (ValueError, Position) Value.Value
applyChangeToDatabase' root custom v (APIChange api c upds) =
updateTypeAt' upds (applyChangeToData' api c custom) (UpdateNamed root) v []
applyChangeToDatabase' root _ v (ValidateData api) = do
matchesNormAPI api (TyName root) v []
return v
-- | Apply an update at the given position in a declaration's value
updateDeclAt' :: Map TypeName UpdateDeclPos
-> (Value.Value -> Position -> Either (ValueError, Position) Value.Value)
-> UpdateDeclPos
-> Value.Value -> Position -> Either (ValueError, Position) Value.Value
updateDeclAt' _ alter (UpdateHere Nothing) v p = alter v p
updateDeclAt' upds alter (UpdateHere (Just upd)) v p = flip alter p =<< updateDeclAt' upds alter upd v p
updateDeclAt' upds alter (UpdateRecord upd_flds) v p = do
xs <- expectRecord v p
Record <$!> mapM update xs
where
update x@(Field fn v') = case Map.lookup fn upd_flds of
Just Nothing -> pure x
Just (Just utp) -> Field fn <$!> updateTypeAt' upds alter utp v' (inField fn : p)
Nothing -> Left (JSONError UnexpectedField, inField fn : p)
updateDeclAt' upds alter (UpdateUnion upd_alts) v p = do
(fn, v') <- expectUnion v p
case Map.lookup fn upd_alts of
Just Nothing -> pure v
Just (Just utp) -> Union fn <$!> updateTypeAt' upds alter utp v' (inField fn : p)
Nothing -> Left (JSONError UnexpectedField, inField fn : p)
updateDeclAt' upds alter (UpdateType upd) v p = updateTypeAt' upds alter upd v p
-- | Apply an update at the given position in a type's value
updateTypeAt' :: Map TypeName UpdateDeclPos
-> (Value.Value -> Position -> Either (ValueError, Position) Value.Value)
-> UpdateTypePos
-> Value.Value -> Position -> Either (ValueError, Position) Value.Value
updateTypeAt' upds alter (UpdateList upd) v p = do
xs <- expectList v p
List <$!> mapM (\ (i, v') -> updateTypeAt' upds alter upd v' (InElem i : p)) (zip [0..] xs)
updateTypeAt' upds alter (UpdateMaybe upd) v p = do
mb <- expectMaybe v p
case mb of
Nothing -> pure v
Just v' -> Maybe . Just <$!> updateTypeAt' upds alter upd v' p
updateTypeAt' upds alter (UpdateNamed tname) v p = case Map.lookup tname upds of
Just upd -> updateDeclAt' upds alter upd v p
Nothing -> pure v
-- | This actually applies the change to the data value, assuming it
-- is already in the correct place
applyChangeToData' :: NormAPI -> APIChange -> CustomMigrationsTagged Record Value
-> Value.Value -> Position -> Either (ValueError, Position) Value.Value
applyChangeToData' api (ChAddField tname fname ftype mb_defval) _ v p =
case mb_defval <|> defaultValueForType ftype of
Just defval -> case fromDefaultValue api ftype defval of
Just v' -> Record . insertField fname v' <$!> expectRecord v p
Nothing -> Left (InvalidAPI (FieldBadDefaultValue tname fname ftype defval), p)
Nothing -> Left (InvalidAPI (DefaultMissing tname fname), p)
applyChangeToData' _ (ChDeleteField _ fname) _ v p =
Record . deleteField fname <$!> expectRecord v p
applyChangeToData' _ (ChRenameField _ fname fname') _ v p =
Record . renameField fname fname' <$!> expectRecord v p
applyChangeToData' _ (ChChangeField _ fname _ftype tag) custom v p = do
xs <- expectRecord v p
case findField fname xs of
Just (ys, v', zs) -> do v'' <- liftMigration (fieldMigration custom tag) v' (inField fname:p)
pure (Record (joinRecords ys fname v'' zs))
Nothing -> Left (JSONError MissingField, inField fname : p)
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
applyChangeToData' _ (ChCustomType _ tag) custom v p = liftMigration (typeMigration custom tag) v p
applyChangeToData' _ (ChCustomAll tag) custom v p = do
xs <- expectRecord v p
Record <$!> liftMigration (databaseMigration custom tag) xs p
applyChangeToData' _ (ChAddType _ _) _ v _ = pure v
applyChangeToData' _ (ChDeleteType _) _ v _ = pure v
applyChangeToData' _ (ChRenameType _ _) _ v _ = pure v
applyChangeToData' _ (ChAddUnionAlt _ _ _) _ v _ = pure v
applyChangeToData' _ (ChDeleteUnionAlt _ _) _ v _ = pure v
applyChangeToData' _ (ChAddEnumVal _ _) _ v _ = pure v
applyChangeToData' _ (ChDeleteEnumVal _ _) _ v _ = pure v
-------------------------------------
-- Utils for manipulating JS.Values
--
withObject :: (JS.Object -> Position -> Either (ValueError, Position) JS.Object)
-> JS.Value -> Position -> Either (ValueError, Position) JS.Value
withObject alter (JS.Object obj) p = JS.Object <$> alter obj p
withObject _ v p = Left (JSONError $ expectedObject v, p)
withObjectField :: T.Text -> (JS.Value -> Position -> Either (ValueError, Position) JS.Value)
-> JS.Value -> Position -> Either (ValueError, Position) JS.Value
withObjectField field alter (JS.Object obj) p =
case lookupKey field obj of
Nothing -> Left (JSONError MissingField, InField field : p)
Just fvalue -> JS.Object <$> (insertKey field
<$> (alter fvalue (InField field : p))
<*> pure obj)
withObjectField _ _ v p = Left (JSONError $ expectedObject v, p)
withObjectMatchingFields :: Map FieldName a
-> (a -> JS.Value -> Position -> Either (ValueError, Position) JS.Value)
-> JS.Value -> Position -> Either (ValueError, Position) JS.Value
withObjectMatchingFields m f (JS.Object obj) p = do
zs <- matchMaps (Map.mapKeys _FieldName m) (objectToMap obj) ?!? toErr
obj' <- Map.traverseWithKey (\ k (ty, val) -> (f ty val (InField k : p))) zs
return $ JS.Object $ mapToObject obj'
where
toErr (k, Left _) = (JSONError MissingField, InField k : p)
toErr (k, Right _) = (JSONError UnexpectedField, InField k : p)
withObjectMatchingFields _ _ v p = Left (JSONError $ expectedObject v, p)
withObjectMatchingUnion :: Map FieldName a
-> (a -> JS.Value -> Position -> Either (ValueError, Position) JS.Value)
-> JS.Value -> Position -> Either (ValueError, Position) JS.Value
withObjectMatchingUnion m f (JS.Object obj) p
| Just (k, r) <- matchSingletonObject obj
= do x <- Map.lookup (FieldName k) m ?! (JSONError UnexpectedField, InField k : p)
r' <- f x r (InField k : p)
return $ JS.Object $ singletonObject k r'
withObjectMatchingUnion _ _ _ p = Left (JSONError $ SyntaxError "Not singleton", p)
withArrayElems :: (JS.Value -> Position -> Either (ValueError, Position) JS.Value)
-> JS.Value -> Position -> Either (ValueError, Position) JS.Value
withArrayElems alter (JS.Array arr) p = JS.Array <$> V.mapM alterAt (V.indexed arr)
where
alterAt (i, v) = alter v (InElem i : p)
withArrayElems _ v p = Left (JSONError $ expectedArray v, p)
withMaybe :: (JS.Value -> Position -> Either (ValueError, Position) JS.Value)
-> JS.Value -> Position -> Either (ValueError, Position) JS.Value
withMaybe _ JS.Null _ = return JS.Null
withMaybe f v p = f v p
withString :: (T.Text -> Position -> Either (ValueError, Position) T.Text)
-> JS.Value -> Position -> Either (ValueError, Position) JS.Value
withString alter (JS.String s) p = JS.String <$> alter s p
withString _ v p = Left (JSONError $ expectedString v, p)
compatibleDefaultValue :: NormAPI -> APIType -> DefaultValue -> Bool
compatibleDefaultValue api ty dv = isJust (fromDefaultValue api ty dv)
-- | Check if there is a "default" default value for a field of the
-- given type: list and maybe have @[]@ and @nothing@ respectively.
-- Note that type synonyms do not preserve defaults, since we do not
-- have access to the entire API.
defaultValueForType :: APIType -> Maybe DefaultValue
defaultValueForType (TyList _) = Just DefValList
defaultValueForType (TyMaybe _) = Just DefValMaybe
defaultValueForType _ = Nothing
-------------------------------------------
-- Validation that a dataset matches an API
--
-- | Check that a dataset matches an API, which is necessary for
-- succesful migration. The name of the dataset's type must be
-- specified.
dataMatchesAPI :: TypeName -> API -> JS.Value -> Either (ValueError, Position) ()
dataMatchesAPI root = dataMatchesNormAPI root . apiNormalForm
dataMatchesNormAPI :: TypeName -> NormAPI -> JS.Value -> Either (ValueError, Position) ()
dataMatchesNormAPI root api db = void $ valueMatches (TyName root) db []
where
declMatches :: NormTypeDecl -> JS.Value -> Position -> Either (ValueError, Position) JS.Value
declMatches (NRecordType flds) = withObjectMatchingFields flds valueMatches
declMatches (NUnionType alts) = withObjectMatchingUnion alts valueMatches
declMatches (NEnumType vals) = withString $ \ s p ->
if FieldName s `Set.member` vals
then return s
else Left (JSONError UnexpectedField, InField s : p)
declMatches (NTypeSynonym t) = valueMatches t
declMatches (NNewtype bt) = valueMatchesBasic bt
valueMatches :: APIType -> JS.Value -> Position -> Either (ValueError, Position) JS.Value
valueMatches (TyList t) = withArrayElems (valueMatches t)
valueMatches (TyMaybe t) = withMaybe (valueMatches t)
valueMatches (TyName tname) = \ v p -> do
d <- lookupType tname api ?!? (\ f -> (InvalidAPI f, p))
declMatches d v p
valueMatches (TyBasic bt) = valueMatchesBasic bt
valueMatches TyJSON = \ v _ -> return v
valueMatchesBasic :: BasicType -> JS.Value -> Position -> Either (ValueError, Position) JS.Value
valueMatchesBasic BTstring = expectDecodes (fromJSONWithErrs :: Decode T.Text)
valueMatchesBasic BTbinary = expectDecodes (fromJSONWithErrs :: Decode Binary)
valueMatchesBasic BTbool = expectDecodes (fromJSONWithErrs :: Decode Bool)
valueMatchesBasic BTint = expectDecodes (fromJSONWithErrs :: Decode Int)
valueMatchesBasic BTutc = expectDecodes (fromJSONWithErrs :: Decode UTCTime)
expectDecodes :: Decode t -> JS.Value -> Position -> Either (ValueError, Position) JS.Value
expectDecodes f v p = case f v of
Right _ -> return v
Left ((je, _):_) -> Left (JSONError je, p)
Left [] -> Left (JSONError $ SyntaxError "expectDecodes", p)
type Decode t = JS.Value -> Either [(JSONError, Position)] t
-------------------------------------
-- Template Haskell
--
-- | 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
guardNoDups (all_tags `Set.intersection` rec_tags)
guardNoDups (all_tags `Set.intersection` fld_tags)
guardNoDups (rec_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 fld_nm) [] (cons fld_nm fld_tags) derivs ]
where
(all_tags, rec_tags, fld_tags) = changelogTags changes
guardNoDups xs
| Set.null xs = return ()
| otherwise = fail $ "generateMigrationKinds: duplicate custom migrations in changelog: "
++ show (Set.toList xs)
-- List of constructors must not be empty, otherwise GHC can't
-- derive Read/Show instances (see GHC Trac #7401)
cons s xs | not (Set.null xs) = map (\ x -> NormalC (mkName x) []) (Set.toList xs)
| otherwise = [NormalC (mkName $ "No" ++ s) []]
derivs = [''Read, ''Show]