Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

-n

Support "development" version block in api-tools migration changelog
  • Loading branch information...
commit 09f506fa145828685f808daf6c62deee14f2474b 1 parent 21b98e8
@adamgundry adamgundry authored
View
5 main/Data/API/MigrationTool.hs
@@ -43,9 +43,8 @@ migrate startApiFile endApiFile
(startApi, startChangelog) <- readApiFile startApiFile
(endApi, endChangelog) <- readApiFile endApiFile
inData <- readJsonFile inDataFile
- let startApiVer = changelogVersion startChangelog
- endApiVer = changelogVersion endChangelog
- case migrateDataDump (startApi, startApiVer) (endApi, endApiVer)
+ let Release startApiVer = changelogVersion startChangelog
+ case migrateDataDump (startApi, startApiVer) (endApi, DevVersion)
endChangelog customMigrations root CheckAll inData of
Left err -> do
hPutStrLn stderr (prettyMigrateFailure err)
View
65 src/Data/API/Changes.hs
@@ -15,6 +15,8 @@ module Data.API.Changes
, APIChangelog(..)
, APIWithChangelog
, APIChange(..)
+ , VersionExtra(..)
+ , showVersionExtra
, changelogStartVersion
, changelogVersion
@@ -69,6 +71,7 @@ import Data.Version
import Data.Time
import Data.List
import Language.Haskell.TH
+import Safe
-------------------------
@@ -85,7 +88,7 @@ import Language.Haskell.TH
migrateDataDump :: (Read db, Read rec, Read fld)
=> (API, Version) -- ^ Starting schema and version
- -> (API, Version) -- ^ Ending 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
@@ -117,7 +120,7 @@ type APIWithChangelog = (API, APIChangelog)
-- descending order (according to the 'Ord' 'Version' instance).
data APIChangelog =
-- | The changes from the previous version up to this version.
- ChangesUpTo Version [APIChange] APIChangelog
+ ChangesUpTo VersionExtra [APIChange] APIChangelog
-- | The initial version
| ChangesStart Version
deriving (Eq, Show)
@@ -207,32 +210,46 @@ 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 -> Version
-changelogVersion (ChangesStart v) = v
+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 -> [(Version, Version, [APIChange])]
+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 -> [(Version, Version, [APIChange])]
+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 (Version, Version) ()
+isChangelogOrdered :: APIChangelog -> Either (VersionExtra, VersionExtra) ()
isChangelogOrdered changelog =
case find (\ (v', v, _) -> v' <= v) (viewChangelog changelog) of
Nothing -> return ()
@@ -490,13 +507,13 @@ findUpdatePos tname api = Map.alter (Just . UpdateHere) tname $
-- | Errors that may be discovered when validating a changelog
data ValidateFailure
-- | the changelog must be in descending order of versions
- = ChangelogOutOfOrder { vfLaterVersion :: Version
- , vfEarlierVersion :: Version }
+ = ChangelogOutOfOrder { vfLaterVersion :: VersionExtra
+ , vfEarlierVersion :: VersionExtra }
-- | forbid migrating from one version to an earlier version
- | CannotDowngrade { vfFromVersion :: Version
- , vfToVersion :: Version }
+ | CannotDowngrade { vfFromVersion :: VersionExtra
+ , vfToVersion :: VersionExtra }
-- | an API uses types that are not declared
- | ApiInvalid { vfInvalidVersion :: Version
+ | ApiInvalid { vfInvalidVersion :: VersionExtra
, vfMissingDeclarations :: Set TypeName }
-- | changelog entry does not apply
| ChangelogEntryInvalid { vfSuccessfullyApplied :: [APITableChange]
@@ -504,8 +521,8 @@ data ValidateFailure
, vfApplyFailure :: ApplyFailure }
-- | changelog is incomplete
-- (ie all entries apply ok but result isn't the target api)
- | ChangelogIncomplete { vfChangelogVersion :: Version
- , vfTargetVersion :: Version
+ | ChangelogIncomplete { vfChangelogVersion :: VersionExtra
+ , vfTargetVersion :: VersionExtra
, vfDifferences :: Map TypeName (MergeResult NormTypeDecl NormTypeDecl) }
deriving (Eq, Show)
@@ -548,7 +565,7 @@ data TypeKind = TKRecord | TKUnion | TKEnum
-- one version to another.
validateChanges :: (Read db, Read rec, Read fld)
=> (API, Version) -- ^ Starting schema and version
- -> (API, Version) -- ^ Ending 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
@@ -561,7 +578,7 @@ validateChanges (api,ver) (api',ver') clog custom root chks = snd <$>
-- migration tags and returns the list of 'APITableChange's to apply
-- to the dataset.
validateChanges' :: (API, Version) -- ^ Starting schema and version
- -> (API, Version) -- ^ Ending 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
@@ -569,12 +586,12 @@ validateChanges' :: (API, Version) -- ^ Starting schema and version
-> Either ValidateFailure ([APITableChange], [ValidateWarning])
validateChanges' (api,ver) (api',ver') clog custom root chks = do
-- select changes by version from log
- (changes, verEnd) <- selectChanges clog ver ver'
+ (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 ver
+ apiInvariant apiStart ?!? ApiInvalid (Release ver)
apiInvariant apiTarget ?!? ApiInvalid ver'
-- check expected end api
(apiEnd, changes') <- applyAPIChangesToAPI root custom chks changes apiStart
@@ -582,8 +599,8 @@ validateChanges' (api,ver) (api',ver') clog custom root chks = do
guard (apiEnd == apiTarget) ?! ChangelogIncomplete verEnd ver' (diffMaps apiEnd apiTarget)
return (changes', [])
-selectChanges :: APIChangelog -> Version -> Version
- -> Either ValidateFailure ([APIChange], Version)
+selectChanges :: APIChangelog -> VersionExtra -> VersionExtra
+ -> Either ValidateFailure ([APIChange], VersionExtra)
selectChanges clog ver ver'
| ver' == ver = return ([], ver')
| ver' > ver = do
@@ -591,9 +608,9 @@ selectChanges clog ver ver'
let withinRange = takeWhile (\ (_, v, _) -> v <= ver') $
dropWhile (\ (_, v, _) -> v <= ver) $
viewChangelogReverse clog
- endVer = case withinRange of
- [] -> ver
- ((_, v, _):_) -> v
+ endVer = case lastMay withinRange of
+ Nothing -> ver
+ Just (_, v, _) -> v
return ([ c | (_,_, cs) <- withinRange, c <- cs ], endVer)
| otherwise = Left (CannotDowngrade ver ver')
@@ -1154,7 +1171,7 @@ instance PPLines ValidateFailure where
else []
ppLines (ChangelogIncomplete ver ver' diffs) =
("Changelog incomplete! Differences between log version ("
- ++ showVersion ver ++ ") and latest version (" ++ showVersion ver' ++ "):")
+ ++ showVersionExtra ver ++ ") and latest version (" ++ showVersionExtra ver' ++ "):")
: indent (concatMap (uncurry ppDiff) $ Map.toList diffs)
instance PPLines APITableChange where
View
12 src/Data/API/Parse.y
@@ -218,13 +218,16 @@ TypeName :: { TypeName }
APIChangelog :: { APIChangelog }
APIChangelog
- : version Version Changes ';' APIChangelog { ChangesUpTo $2 $3 $5 }
+ : version VersionExtra Changes ';' APIChangelog { ChangesUpTo $2 $3 $5 }
| version Version { ChangesStart $2 }
- | Comments ';' APIChangelog { $3 }
+ | Comments ';' APIChangelog { $3 }
Version :: { V.Version }
: strlit { parseVer $1 }
+VersionExtra :: { VersionExtra }
+ : strlit { parseVersionExtra $1 }
+
Changes :: { [APIChange] }
: RChanges { concat (reverse $1) }
@@ -340,6 +343,11 @@ parseVer x = case simpleParse x of
Just v -> v
Nothing -> error $ "Syntax error while parsing version " ++ x
+parseVersionExtra :: String -> VersionExtra
+parseVersionExtra "development" = DevVersion
+parseVersionExtra s = Release $ parseVer s
+
+
api :: QuasiQuoter
api =
QuasiQuoter
View
6 tests/Data/API/Test/Migration.hs
@@ -98,7 +98,7 @@ basicMigrationTest :: Assertion
basicMigrationTest = do
assertMatchesAPI "Start data does not match start API" startSchema startData
assertMatchesAPI "End data does not match end API" endSchema endData
- case migrateDataDump (startSchema, startVersion) (endSchema, endVersion)
+ case migrateDataDump (startSchema, startVersion) (endSchema, DevVersion)
changelog testMigration root_ CheckAll startData of
Right (v, []) | endData == v -> return ()
| otherwise -> assertFailure $ "expected:\n"
@@ -111,7 +111,7 @@ basicMigrationTest = do
applyFailureTest :: (Version, Version, ApplyFailure) -> Test.TestTree
applyFailureTest (ver, ver', expected) =
testCase (showVersion ver ++ " -> " ++ showVersion ver') $
- case migrateDataDump (startSchema, ver) (endSchema, ver')
+ case migrateDataDump (startSchema, ver) (endSchema, Release ver')
badChangelog testMigration root_ CheckAll startData of
Right _ -> assertFailure $ "Successful migration!"
Left (ValidateFailure (ChangelogEntryInvalid _ _ err))
@@ -139,7 +139,7 @@ $(generateAPITools startSchema
validMigrationProperty :: DatabaseSnapshot -> P.Result
validMigrationProperty db =
- case migrateDataDump (startSchema, startVersion) (endSchema, endVersion)
+ case migrateDataDump (startSchema, startVersion) (endSchema, DevVersion)
changelog testMigration root_ CheckStartAndEnd (JS.toJSON db) of
Right (v, []) -> case dataMatchesAPI root_ endSchema v of
Right _ -> succeeded
View
25 tests/Data/API/Test/MigrationData.hs
@@ -161,8 +161,15 @@ duplicaterecursive :: DuplicateRecursive
recur :: ? Recursive
new :: string
+new :: New
+ = basic integer
+
changes
+version "development"
+ // changes since last release
+ added New basic integer
+
version "2.6"
// add fields with implicit default values
changed record Foo
@@ -521,7 +528,7 @@ expectedApplyFailures = map toVersions $
type MigrateFailureTest = ( String
, (API, Version) -- Start version
- , (API, Version) -- End version
+ , (API, VersionExtra) -- End version
, APIChangelog
, JS.Value
, MigrateFailure -> Bool )
@@ -530,15 +537,15 @@ expectedMigrateFailures :: [MigrateFailureTest]
expectedMigrateFailures =
[ ( "Out of order"
, (startSchema, ver "0.1")
- , (endSchema, ver "0.2")
+ , (endSchema, verRelease "0.2")
, outOfOrder
, startData
- , (== ValidateFailure (ChangelogOutOfOrder (ver "0.1") (ver "0.2")))
+ , (== ValidateFailure (ChangelogOutOfOrder (verRelease "0.1") (verRelease "0.2")))
)
, ("Incomplete"
, (startSchema, ver "0.1")
- , (endSchema, ver "2.5")
+ , (endSchema, verRelease "2.5")
, incomplete
, startData
, \ err -> case err of
@@ -548,15 +555,15 @@ expectedMigrateFailures =
, ( "Downgrade"
, (startSchema, ver "0.2")
- , (startSchema, ver "0.1")
+ , (startSchema, verRelease "0.1")
, changelog
, startData
- , (== ValidateFailure (CannotDowngrade (ver "0.2") (ver "0.1")))
+ , (== ValidateFailure (CannotDowngrade (verRelease "0.2") (verRelease "0.1")))
)
, ("Bad custom migration"
, (startSchema, ver "0.1")
- , (startSchema, ver "0.2")
+ , (startSchema, verRelease "0.2")
, badCustomMigration
, startData
, \ err -> case err of
@@ -567,6 +574,7 @@ expectedMigrateFailures =
where
ver s | Just v <- simpleParse s = v
| otherwise = error $ "expectedValidateFailures: bad version " ++ show s
+ verRelease s = Release $ ver s
outOfOrder = snd [apiWithChangelog|
changes
@@ -591,9 +599,8 @@ startData, endData :: JS.Value
Just startData = JS.decode "{ \"foo\": [ {\"id\": 42, \"nest\": { \"id\": 3 }, \"en\": \"foo\", \"un\": { \"bar\": { \"id\": 43 } }, \"quux\": null } ], \"bar\": [ { \"id\": 4 } ], \"recur\": [{ \"id\": 9, \"recur\": { \"id\": 8, \"recur\": null} }] }"
Just endData = JS.decode "{ \"foo\": [ {\"id\":42, \"nest\": { \"id\": 3, \"new\": \"hello\" }, \"c\": \"foobar42\", \"en\": \"foofoo\", \"un\": { \"barbar\": { \"id\": 43 } }, \"nolist\": [], \"nomaybe\": null } ], \"boz\": [], \"bar2\": [ {\"id\": 4 } ], \"recur\": [{ \"renamed_id\": 9, \"new\": \"hello\", \"newnew\": \"hello\", \"recur\": { \"renamed_id\": 8, \"new\": \"hello\", \"newnew\": \"hello\", \"recur\": null} }], \"recur2\": [{ \"renamed_id\": 9, \"new\": \"hello\", \"recur\": { \"renamed_id\": 8, \"new\": \"hello\", \"newnew\": \"hello\", \"recur\": null} }] }"
-startVersion, endVersion :: Version
+startVersion :: Version
startVersion = changelogStartVersion changelog
-endVersion = changelogVersion changelog
root_ :: TypeName
root_ = TypeName "DatabaseSnapshot"
Please sign in to comment.
Something went wrong with that request. Please try again.