{-# OPTIONS_GHC -fno-warn-deprecations #-} {-# LANGUAGE TemplateHaskell #-} -- | This module deals with validating API changelogs and migrating -- JSON data between different versions of a schema. module Data.API.Changes ( migrateDataDump -- * Validating changelogs , validateChanges , dataMatchesAPI , DataChecks(..) -- * Changelog representation , APIChangelog(..) , APIWithChangelog , APIChange(..) , VersionExtra(..) , showVersionExtra , changelogStartVersion , changelogVersion -- * Custom migrations , CustomMigrations(..) , 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.JSON import Data.API.NormalForm import Data.API.PP import Data.API.Types import Data.API.Utils import Control.Applicative import Control.Monad import qualified Data.Aeson as JS import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Base64 as B64 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.HashMap.Strict as HMap import qualified Data.Vector as V import qualified Data.Text as T import Data.Version import Data.Time import Data.List 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 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) data MigrateFailure = ValidateFailure ValidateFailure | ValueError ValueError Position deriving (Eq, Show) type MigrateWarning = ValidateWarning ------------------ -- The key types -- type APIWithChangelog = (API, APIChangelog) -- | An API changelog, consisting of a list of versions with the -- changes from one version to the next. The versions must be in -- descending order (according to the 'Ord' 'Version' instance). data APIChangelog = -- | The changes from the previous version up to this version. ChangesUpTo VersionExtra [APIChange] APIChangelog -- | The initial version | ChangesStart Version deriving (Eq, Show) -- | A single change within a changelog data APIChange = ChAddType TypeName NormTypeDecl | ChDeleteType TypeName | ChRenameType TypeName TypeName -- Specific changes for record types | ChAddField TypeName FieldName APIType (Maybe DefaultValue) | ChDeleteField TypeName FieldName | ChRenameField TypeName FieldName FieldName | ChChangeField TypeName FieldName APIType MigrationTag -- Changes for union types | ChAddUnionAlt TypeName FieldName APIType | ChDeleteUnionAlt TypeName FieldName | ChRenameUnionAlt TypeName FieldName FieldName -- Changes for enum types | ChAddEnumVal TypeName FieldName | ChDeleteEnumVal TypeName FieldName | ChRenameEnumVal TypeName FieldName FieldName -- Custom migrations | ChCustomType TypeName MigrationTag | ChCustomAll MigrationTag deriving (Eq, Show) -- | Within the changelog, custom migrations are represented as -- strings, so we have less type-safety. type MigrationTag = String -- | 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 db ty fld = CustomMigrations { databaseMigration :: db -> JS.Object -> Either ValueError JS.Object , databaseMigrationSchema :: db -> NormAPI -> Either ApplyFailure (Maybe NormAPI) , typeMigration :: ty -> JS.Value -> Either ValueError JS.Value , typeMigrationSchema :: ty -> NormTypeDecl -> Either ApplyFailure (Maybe NormTypeDecl) , fieldMigration :: fld -> JS.Value -> Either ValueError JS.Value } type CustomMigrationsTagged = CustomMigrations MigrationTag MigrationTag MigrationTag readCustomMigrations :: (Read db, Read ty, Read fld) => CustomMigrations db ty fld -> CustomMigrationsTagged 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 -- | 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 (ChCustomType{}) = chks >= CheckCustom validateAfter chks (ChCustomAll{}) = chks >= CheckCustom validateAfter chks _ = chks >= CheckAll -------------------- -- Changelog utils -- -- | Represents either a released version (with a version number) or -- the version under development, which is newer than any release data VersionExtra = Release Version | DevVersion deriving (Eq, Ord, Show) showVersionExtra :: VersionExtra -> String showVersionExtra (Release v) = showVersion v showVersionExtra DevVersion = "development" instance PP VersionExtra where pp = showVersionExtra -- | 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 (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 -- -- | Represents the positions in a declaration to apply an update data UpdateDeclPos = UpdateHere (Maybe UpdateDeclPos) | UpdateRecord (Map FieldName (Maybe UpdateTypePos)) | UpdateUnion (Map FieldName (Maybe UpdateTypePos)) | UpdateType UpdateTypePos deriving (Eq, Show) -- | Represents the positions in a type to apply an update data UpdateTypePos = UpdateList UpdateTypePos | UpdateMaybe UpdateTypePos | UpdateNamed TypeName deriving (Eq, Show) data APITableChange -- | The pair of an APIChange and the positions in which to apply it = APIChange APIChange (Map TypeName UpdateDeclPos) -- | Request to validate the dataset against the given API | ValidateData NormAPI deriving (Eq, Show) -- | 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 -- -- | Errors that may be discovered when validating a changelog data ValidateFailure -- | the changelog must be in descending order of versions = ChangelogOutOfOrder { vfLaterVersion :: VersionExtra , vfEarlierVersion :: VersionExtra } -- | forbid migrating from one version to an earlier version | CannotDowngrade { vfFromVersion :: VersionExtra , vfToVersion :: VersionExtra } -- | an API uses types that are not declared | ApiInvalid { vfInvalidVersion :: VersionExtra , vfMissingDeclarations :: Set TypeName } -- | changelog entry does not apply | ChangelogEntryInvalid { vfSuccessfullyApplied :: [APITableChange] , vfFailedToApply :: APIChange , vfApplyFailure :: ApplyFailure } -- | changelog is incomplete -- (ie all entries apply ok but result isn't the target api) | ChangelogIncomplete { vfChangelogVersion :: VersionExtra , vfTargetVersion :: VersionExtra , vfDifferences :: Map TypeName (MergeResult NormTypeDecl NormTypeDecl) } deriving (Eq, Show) data ValidateWarning = ValidateWarning -- add warnings about bits we cannot check (opaque custom) deriving Show -- | Errors that may occur applying a single API change data ApplyFailure = TypeExists { afExistingType :: TypeName } -- ^ for adding or renaming type | TypeDoesNotExist { afMissingType :: TypeName } -- ^ for deleting or renaming a type | TypeWrongKind { afTypeName :: TypeName , afExpectedKind :: TypeKind } -- ^ e.g. it's not a record type | TypeInUse { afTypeName :: TypeName } -- ^ cannot delete/modify types that are still used | TypeMalformed { afType :: APIType , afMissingTypes :: Set TypeName } -- ^ type refers to a non-existent type | DeclMalformed { afTypeName :: TypeName , afDecl :: NormTypeDecl , afMissingTypes :: Set TypeName } -- ^ decl refers to a non-existent type | FieldExists { afTypeName :: TypeName , afTypeKind :: TypeKind , afExistingField :: FieldName } -- ^ for adding or renaming a field | FieldDoesNotExist { afTypeName :: TypeName , afTypeKind :: TypeKind , afMissingField :: FieldName } -- ^ for deleting or renaming a field | FieldBadDefaultValue { afTypeName :: TypeName , afFieldName :: FieldName , afFieldType :: APIType , afBadDefault :: DefaultValue } -- ^ for adding a field, must be a default -- value compatible with the type | DefaultMissing { afTypeName :: TypeName , afFieldName :: FieldName } -- ^ for adding a field to a table | TableChangeError { afCustomMessage :: String } -- ^ custom error in tableChange deriving (Eq, Show) data TypeKind = TKRecord | TKUnion | TKEnum | TKNewtype | TKTypeSynonym deriving (Eq, Show) -- | 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 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 -- ^ 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 -> 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 -> 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 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 -> 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 _ _ (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)) lookupType :: TypeName -> NormAPI -> Either ApplyFailure NormTypeDecl lookupType tname api = Map.lookup tname api ?! TypeDoesNotExist tname 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.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.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.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 $ HMap.insert (fieldKey fname) newFieldValue v) Nothing -> \ _ p -> Left (InvalidAPI (DefaultMissing tname fname), p) applyChangeToData (ChDeleteField _ fname) _ = withObject (\ v _ -> pure $ HMap.delete (fieldKey fname) v) applyChangeToData (ChRenameField _ fname fname') _ = withObject $ \rec p -> case HMap.lookup k_fname rec of Just field -> renameField field rec Nothing -> Left (JSONError MissingField, InField k_fname : p) where k_fname = fieldKey fname k_fname' = fieldKey fname' renameField x = pure . HMap.insert k_fname' x . HMap.delete k_fname applyChangeToData (ChChangeField _ fname _ftype tag) custom = withObjectField (fieldKey fname) (liftMigration $ fieldMigration custom tag) applyChangeToData (ChRenameUnionAlt _ fname fname') _ = withObject $ \un p -> case HMap.toList un of [(k, r)] | k == fieldKey fname -> return $ HMap.singleton (fieldKey fname') r | otherwise -> return un _ -> Left (JSONError $ SyntaxError "Not singleton", p) applyChangeToData (ChRenameEnumVal _ fname fname') _ = withString $ \s _ -> if s == fieldKey fname then return (fieldKey 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 ------------------------------------- -- Utils for manipulating JS.Values -- -- | Errors that can be discovered when migrating data values data ValueError = JSONError JSONError -- ^ Data doesn't match schema | CustomMigrationError String JS.Value -- ^ Error generated during custom migration | InvalidAPI ApplyFailure -- ^ An API change was invalid deriving (Eq, Show) 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 HMap.lookup field obj of Nothing -> Left (JSONError MissingField, InField field : p) Just fvalue -> JS.Object <$> (HMap.insert 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 fieldKey m) (hmapToMap obj) ?!? toErr obj' <- Map.traverseWithKey (\ k (ty, val) -> (f ty val (InField k : p))) zs return $ JS.Object $ mapToHMap obj' where toErr (k, Left _) = (JSONError MissingField, InField k : p) toErr (k, Right _) = (JSONError UnexpectedField, InField k : p) hmapToMap = Map.fromList . HMap.toList mapToHMap = HMap.fromList . Map.toList 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 | [(k, r)] <- HMap.toList obj = do x <- Map.lookup (fromFieldKey k) m ?! (JSONError UnexpectedField, InField k : p) r' <- f x r (InField k : p) return $ JS.Object $ HMap.singleton 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) fieldKey :: FieldName -> T.Text fieldKey (FieldName fname) = T.pack fname fromFieldKey :: T.Text -> FieldName fromFieldKey = FieldName . T.unpack compatibleDefaultValue :: NormAPI -> APIType -> DefaultValue -> Bool compatibleDefaultValue _ (TyList _) DefValList = True compatibleDefaultValue _ (TyMaybe _) DefValMaybe = True compatibleDefaultValue api (TyMaybe ty) defval = compatibleDefaultValue api ty defval compatibleDefaultValue _ (TyBasic bt) defval = compatibleBasicDefaultValue bt defval compatibleDefaultValue _ TyJSON _ = True compatibleDefaultValue env (TyName tname) defval = case Map.lookup tname env of Just (NTypeSynonym t) -> compatibleDefaultValue env t defval Just (NNewtype bt) -> compatibleBasicDefaultValue bt defval Just (NEnumType vals) -> case defval of DefValString s -> fromFieldKey s `Set.member` vals _ -> False _ -> False compatibleDefaultValue _ _ _ = False compatibleBasicDefaultValue :: BasicType -> DefaultValue -> Bool compatibleBasicDefaultValue BTstring (DefValString _) = True compatibleBasicDefaultValue BTbinary (DefValString v) = case B64.decode (B.pack (T.unpack v)) of Left _ -> False Right _ -> True compatibleBasicDefaultValue BTbool (DefValBool _) = True compatibleBasicDefaultValue BTint (DefValInt _) = True compatibleBasicDefaultValue BTutc (DefValUtc _) = True compatibleBasicDefaultValue _ _ = False -- | 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 fromFieldKey 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 ------------------------------------- -- Utils for merging and diffing maps -- data MergeResult a b = OnlyInLeft a | InBoth a b | OnlyInRight b deriving (Eq, Show) mergeMaps :: Ord k => Map k a -> Map k b -> Map k (MergeResult a b) mergeMaps m1 m2 = Map.unionWith (\(OnlyInLeft a) (OnlyInRight b) -> InBoth a b) (fmap OnlyInLeft m1) (fmap OnlyInRight m2) diffMaps :: (Eq a, Ord k) => Map k a -> Map k a -> Map k (MergeResult a a) diffMaps m1 m2 = Map.filter different $ mergeMaps m1 m2 where different (InBoth a b) = a /= b different _ = True -- Attempts to match the keys of the maps to produce a map from keys -- to pairs. matchMaps :: Ord k => Map k a -> Map k b -> Either (k, Either a b) (Map k (a, b)) matchMaps m1 m2 = Map.traverseWithKey win $ mergeMaps m1 m2 where win _ (InBoth x y) = return (x, y) win k (OnlyInLeft x) = Left (k, Left x) win k (OnlyInRight x) = Left (k, Right x) ------------------------------------- -- Pretty-printing -- prettyMigrateFailure :: MigrateFailure -> String prettyMigrateFailure = unlines . ppLines prettyValidateFailure :: ValidateFailure -> String prettyValidateFailure = unlines . ppLines prettyValueError :: ValueError -> String prettyValueError = unlines . ppLines prettyValueErrorPosition :: (ValueError, Position) -> String prettyValueErrorPosition = unlines . ppLines instance PP TypeKind where pp TKRecord = "record" pp TKUnion = "union" pp TKEnum = "enum" pp TKNewtype = "newtype" pp TKTypeSynonym = "type" ppATypeKind :: TypeKind -> String ppATypeKind TKRecord = "a record" ppATypeKind TKUnion = "a union" ppATypeKind TKEnum = "an enum" ppATypeKind TKNewtype = "a newtype" ppATypeKind TKTypeSynonym = "a type synonym" ppMemberWord :: TypeKind -> String ppMemberWord TKRecord = "field" ppMemberWord TKUnion = "alternative" ppMemberWord TKEnum = "value" ppMemberWord TKNewtype = "member" ppMemberWord TKTypeSynonym = "member" instance PPLines APIChange where ppLines (ChAddType t d) = ("added " ++ pp t ++ " ") `inFrontOf` ppLines d ppLines (ChDeleteType t) = ["removed " ++ pp t] ppLines (ChRenameType t t') = ["renamed " ++ pp t ++ " to " ++ pp t'] ppLines (ChAddField t f ty mb_v) = [ "changed record " ++ pp t , " field added " ++ pp f ++ " :: " ++ pp ty ++ maybe "" (\ v -> " default " ++ pp v) mb_v] ppLines (ChDeleteField t f) = ["changed record " ++ pp t, " field removed " ++ pp f] ppLines (ChRenameField t f f') = [ "changed record " ++ pp t , " field renamed " ++ pp f ++ " to " ++ pp f'] ppLines (ChChangeField t f ty c) = [ "changed record " ++ pp t , " field changed " ++ pp f ++ " :: " ++ pp ty ++ " migration " ++ pp c] ppLines (ChAddUnionAlt t f ty) = [ "changed union " ++ pp t , " alternative added " ++ pp f ++ " :: " ++ pp ty] ppLines (ChDeleteUnionAlt t f) = [ "changed union " ++ pp t , " alternative removed " ++ pp f] ppLines (ChRenameUnionAlt t f f') = [ "changed union " ++ pp t , " alternative renamed " ++ pp f ++ " to " ++ pp f'] ppLines (ChAddEnumVal t f) = [ "changed enum " ++ pp t , " alternative added " ++ pp f] ppLines (ChDeleteEnumVal t f) = [ "changed enum " ++ pp t , " alternative removed " ++ pp f] ppLines (ChRenameEnumVal t f f') = [ "changed enum " ++ pp t , " alternative renamed " ++ pp f ++ " to " ++ pp f'] ppLines (ChCustomType t c) = ["migration record " ++ pp t ++ " " ++ pp c] ppLines (ChCustomAll c) = ["migration " ++ pp c] instance PPLines MigrateFailure where ppLines (ValidateFailure x) = ppLines x ppLines (ValueError x ps) = ppLines x ++ map prettyStep ps instance PPLines ValidateFailure where ppLines (ChangelogOutOfOrder later earlier) = ["Changelog out of order: version " ++ pp later ++ " appears after version " ++ pp earlier] ppLines (CannotDowngrade from to) = ["Cannot downgrade from version " ++ pp from ++ " to version " ++ pp to] ppLines (ApiInvalid ver missing) = ["Missing declarations in API version " ++ pp ver ++ ": " ++ pp missing] ppLines (ChangelogEntryInvalid succs change af) = ppLines af ++ ("when applying the change" : indent (ppLines change)) ++ if not (null succs) then "after successfully applying the changes:" : indent (ppLines succs) else [] ppLines (ChangelogIncomplete ver ver' diffs) = ("Changelog incomplete! Differences between log version (" ++ showVersionExtra ver ++ ") and latest version (" ++ showVersionExtra ver' ++ "):") : indent (concatMap (uncurry ppDiff) $ Map.toList diffs) instance PPLines APITableChange where ppLines (APIChange c _) = ppLines c ppLines (ValidateData _) = [] ppDiff :: TypeName -> MergeResult NormTypeDecl NormTypeDecl -> [String] ppDiff t (OnlyInLeft _) = ["removed " ++ pp t] ppDiff t (OnlyInRight d) = ("added " ++ pp t ++ " ") `inFrontOf` ppLines d ppDiff t (InBoth (NRecordType flds) (NRecordType flds')) = ("changed record " ++ pp t) : (concatMap (uncurry (ppDiffFields "field")) $ Map.toList $ diffMaps flds flds') ppDiff t (InBoth (NUnionType alts) (NUnionType alts')) = ("changed union " ++ pp t) : (concatMap (uncurry (ppDiffFields "alternative")) $ Map.toList $ diffMaps alts alts') ppDiff t (InBoth (NEnumType vals) (NEnumType vals')) = ("changed enum " ++ pp t) : (map (\ x -> " alternative removed " ++ pp x) $ Set.toList $ vals Set.\\ vals') ++ (map (\ x -> " alternative added " ++ pp x) $ Set.toList $ vals' Set.\\ vals) ppDiff t (InBoth _ _) = ["incompatible definitions of " ++ pp t] ppDiffFields :: String -> FieldName -> MergeResult APIType APIType -> [String] ppDiffFields s f (OnlyInLeft _) = [" " ++ s ++ " removed " ++ pp f] ppDiffFields s f (OnlyInRight ty) = [" " ++ s ++ " added " ++ pp f ++ " :: " ++ pp ty] ppDiffFields s f (InBoth ty ty') = [ " incompatible types for " ++ s ++ " " ++ pp f , " changelog type: " ++ pp ty , " latest version type: " ++ pp ty' ] instance PPLines ApplyFailure where ppLines (TypeExists t) = ["Type " ++ pp t ++ " already exists"] ppLines (TypeDoesNotExist t) = ["Type " ++ pp t ++ " does not exist"] ppLines (TypeWrongKind t k) = ["Type " ++ pp t ++ " is not " ++ ppATypeKind k] ppLines (TypeInUse t) = ["Type " ++ pp t ++ " is in use, so it cannot be modified"] ppLines (TypeMalformed ty xs) = ["Type " ++ pp ty ++ " is malformed, missing declarations:" , " " ++ pp xs] ppLines (DeclMalformed t _ xs) = [ "Declaration of " ++ pp t ++ " is malformed, missing declarations:" , " " ++ pp xs] ppLines (FieldExists t k f) = ["Type " ++ pp t ++ " already has the " ++ ppMemberWord k ++ " " ++ pp f] ppLines (FieldDoesNotExist t k f) = ["Type " ++ pp t ++ " does not have the " ++ ppMemberWord k ++ " " ++ pp f] ppLines (FieldBadDefaultValue _ _ ty v) = ["Default value " ++ pp v ++ " is not compatible with the type " ++ pp ty] ppLines (DefaultMissing t f) = ["Field " ++ pp f ++ " does not have a default value, but " ++ pp t ++ " occurs in the database"] ppLines (TableChangeError s) = ["Error when detecting changed tables:", " " ++ s] instance PPLines ValueError where ppLines (JSONError e) = [prettyJSONError e] ppLines (CustomMigrationError e v) = [ "Custom migration error:", " " ++ e , "when migrating value"] ++ indent (ppLines v) ppLines (InvalidAPI af) = "Invalid API detected during value migration:" : indent (ppLines af) ------------------------------------- -- 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 [ DataD [] (mkName all_nm) [] (cons all_nm all_tags) derivs , DataD [] (mkName rec_nm) [] (cons rec_nm rec_tags) derivs , DataD [] (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]