module Data.API.Changes
( migrateDataDump
, validateChanges
, dataMatchesAPI
, DataChecks(..)
, APIChangelog(..)
, APIWithChangelog
, APIChange(..)
, VersionExtra(..)
, showVersionExtra
, changelogStartVersion
, changelogVersion
, CustomMigrations(..)
, mkRecordMigration
, mkRecordMigrationSchema
, noDataChanges
, noSchemaChanges
, generateMigrationKinds
, MigrationTag
, NormAPI
, NormTypeDecl(..)
, NormRecordType
, NormUnionType
, NormEnumType
, apiNormalForm
, declNF
, 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
migrateDataDump :: (Read db, Read rec, Read fld)
=> (API, Version)
-> (API, VersionExtra)
-> APIChangelog
-> CustomMigrations db rec fld
-> TypeName
-> DataChecks
-> JS.Value
-> 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
type APIWithChangelog = (API, APIChangelog)
data APIChangelog =
ChangesUpTo VersionExtra [APIChange] APIChangelog
| ChangesStart Version
deriving (Eq, Show)
data APIChange
= ChAddType TypeName NormTypeDecl
| ChDeleteType TypeName
| ChRenameType TypeName TypeName
| ChAddField TypeName FieldName APIType (Maybe DefaultValue)
| ChDeleteField TypeName FieldName
| ChRenameField TypeName FieldName FieldName
| ChChangeField TypeName FieldName APIType MigrationTag
| ChAddUnionAlt TypeName FieldName APIType
| ChDeleteUnionAlt TypeName FieldName
| ChRenameUnionAlt TypeName FieldName FieldName
| ChAddEnumVal TypeName FieldName
| ChDeleteEnumVal TypeName FieldName
| ChRenameEnumVal TypeName FieldName FieldName
| ChCustomType TypeName MigrationTag
| ChCustomAll MigrationTag
deriving (Eq, Show)
type MigrationTag = String
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)
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
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
noDataChanges :: a -> Either ValueError a
noDataChanges = return
noSchemaChanges :: a -> Either ApplyFailure (Maybe a)
noSchemaChanges _ = Right Nothing
data DataChecks = NoChecks
| CheckStartAndEnd
| CheckCustom
| CheckAll
deriving (Eq, Ord)
validateAfter :: DataChecks -> APIChange -> Bool
validateAfter chks (ChChangeField{}) = chks >= CheckCustom
validateAfter chks (ChCustomType{}) = chks >= CheckCustom
validateAfter chks (ChCustomAll{}) = chks >= CheckCustom
validateAfter chks _ = chks >= CheckAll
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
changelogStartVersion :: APIChangelog -> Version
changelogStartVersion (ChangesStart v) = v
changelogStartVersion (ChangesUpTo _ _ clog) = changelogStartVersion clog
changelogVersion :: APIChangelog -> VersionExtra
changelogVersion (ChangesStart v) = Release v
changelogVersion (ChangesUpTo v _ _) = v
viewChangelogReverse :: APIChangelog -> [(VersionExtra, VersionExtra, [APIChange])]
viewChangelogReverse clog =
reverse [ (v,v',reverse cs) | (v',v,cs) <- viewChangelog clog ]
viewChangelog :: APIChangelog -> [(VersionExtra, VersionExtra, [APIChange])]
viewChangelog (ChangesStart _) = []
viewChangelog (ChangesUpTo v' cs older) = (v', v, cs) : viewChangelog older
where v = changelogVersion older
isChangelogOrdered :: APIChangelog -> Either (VersionExtra, VersionExtra) ()
isChangelogOrdered changelog =
case find (\ (v', v, _) -> v' <= v) (viewChangelog changelog) of
Nothing -> return ()
Just (v', v, _) -> Left (v', v)
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
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)
data UpdateDeclPos
= UpdateHere (Maybe UpdateDeclPos)
| UpdateRecord (Map FieldName (Maybe UpdateTypePos))
| UpdateUnion (Map FieldName (Maybe UpdateTypePos))
| UpdateType UpdateTypePos
deriving (Eq, Show)
data UpdateTypePos
= UpdateList UpdateTypePos
| UpdateMaybe UpdateTypePos
| UpdateNamed TypeName
deriving (Eq, Show)
data APITableChange
= APIChange APIChange (Map TypeName UpdateDeclPos)
| ValidateData NormAPI
deriving (Eq, Show)
findUpdatePos :: TypeName -> NormAPI -> Map TypeName UpdateDeclPos
findUpdatePos tname api = Map.alter (Just . UpdateHere) tname $
Map.fromSet findDecl deps
where
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
data ValidateFailure
= ChangelogOutOfOrder { vfLaterVersion :: VersionExtra
, vfEarlierVersion :: VersionExtra }
| CannotDowngrade { vfFromVersion :: VersionExtra
, vfToVersion :: VersionExtra }
| ApiInvalid { vfInvalidVersion :: VersionExtra
, vfMissingDeclarations :: Set TypeName }
| ChangelogEntryInvalid { vfSuccessfullyApplied :: [APITableChange]
, vfFailedToApply :: APIChange
, vfApplyFailure :: ApplyFailure }
| ChangelogIncomplete { vfChangelogVersion :: VersionExtra
, vfTargetVersion :: VersionExtra
, vfDifferences :: Map TypeName (MergeResult NormTypeDecl NormTypeDecl) }
deriving (Eq, Show)
data ValidateWarning = ValidateWarning
deriving Show
data ApplyFailure
= TypeExists { afExistingType :: TypeName }
| TypeDoesNotExist { afMissingType :: TypeName }
| TypeWrongKind { afTypeName :: TypeName
, afExpectedKind :: TypeKind }
| TypeInUse { afTypeName :: TypeName }
| TypeMalformed { afType :: APIType
, afMissingTypes :: Set TypeName }
| DeclMalformed { afTypeName :: TypeName
, afDecl :: NormTypeDecl
, afMissingTypes :: Set TypeName }
| FieldExists { afTypeName :: TypeName
, afTypeKind :: TypeKind
, afExistingField :: FieldName }
| FieldDoesNotExist { afTypeName :: TypeName
, afTypeKind :: TypeKind
, afMissingField :: FieldName }
| FieldBadDefaultValue { afTypeName :: TypeName
, afFieldName :: FieldName
, afFieldType :: APIType
, afBadDefault :: DefaultValue }
| DefaultMissing { afTypeName :: TypeName
, afFieldName :: FieldName }
| TableChangeError { afCustomMessage :: String }
deriving (Eq, Show)
data TypeKind = TKRecord | TKUnion | TKEnum
deriving (Eq, Show)
validateChanges :: (Read db, Read rec, Read fld)
=> (API, Version)
-> (API, VersionExtra)
-> APIChangelog
-> CustomMigrations db rec fld
-> TypeName
-> DataChecks
-> Either ValidateFailure [ValidateWarning]
validateChanges (api,ver) (api',ver') clog custom root chks = snd <$>
validateChanges' (api,ver) (api',ver') clog (readCustomMigrations custom) root chks
validateChanges' :: (API, Version)
-> (API, VersionExtra)
-> APIChangelog
-> CustomMigrationsTagged
-> TypeName
-> DataChecks
-> Either ValidateFailure ([APITableChange], [ValidateWarning])
validateChanges' (api,ver) (api',ver') clog custom root chks = do
(changes, verEnd) <- selectChanges clog (Release ver) ver'
let apiStart = apiNormalForm api
apiTarget = apiNormalForm api'
apiInvariant apiStart ?!? ApiInvalid (Release ver)
apiInvariant apiTarget ?!? ApiInvalid ver'
(apiEnd, changes') <- applyAPIChangesToAPI root custom chks changes apiStart
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')
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
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'')
applyAPIChangeToAPI :: TypeName -> CustomMigrationsTagged -> APIChange -> NormAPI
-> Either ApplyFailure (NormAPI, Map TypeName UpdateDeclPos)
applyAPIChangeToAPI _ _ (ChAddType tname tdecl) api = do
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
guard (tname `typeDeclaredInApi` api) ?! TypeDoesNotExist tname
guard (not (tname `typeUsedInApi` api)) ?! TypeInUse tname
return (Map.delete tname api, Map.empty)
applyAPIChangeToAPI _ _ (ChRenameType tname tname') api = do
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
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
applyChangesToDatabase :: TypeName -> CustomMigrationsTagged
-> JS.Value -> [APITableChange]
-> Either (ValueError, Position) JS.Value
applyChangesToDatabase root custom = foldM (applyChangeToDatabase root custom)
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
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
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
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
data ValueError
= JSONError JSONError
| CustomMigrationError String JS.Value
| InvalidAPI ApplyFailure
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
defaultValueForType :: APIType -> Maybe DefaultValue
defaultValueForType (TyList _) = Just DefValList
defaultValueForType (TyMaybe _) = Just DefValMaybe
defaultValueForType _ = Nothing
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
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
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)
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"
ppATypeKind :: TypeKind -> String
ppATypeKind TKRecord = "a record"
ppATypeKind TKUnion = "a union"
ppATypeKind TKEnum = "an enum"
ppMemberWord :: TypeKind -> String
ppMemberWord TKRecord = "field"
ppMemberWord TKUnion = "alternative"
ppMemberWord TKEnum = "value"
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)
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)
cons s xs | not (Set.null xs) = map (\ x -> NormalC (mkName x) []) (Set.toList xs)
| otherwise = [NormalC (mkName $ "No" ++ s) []]
derivs = [''Read, ''Show]