diff --git a/api-tools.cabal b/api-tools.cabal --- a/api-tools.cabal +++ b/api-tools.cabal @@ -1,5 +1,5 @@ Name: api-tools -Version: 0.3 +Version: 0.4 Synopsis: DSL for generating API boilerplate and docs Description: api-tools provides a compact DSL for describing an API. It uses Template Haskell to generate the @@ -25,7 +25,7 @@ Source-Repository this Type: git Location: git://github.com/iconnect/api-tools.git - Tag: 0.3 + Tag: 0.4 Library Hs-Source-Dirs: src @@ -65,28 +65,29 @@ Data.API.TH Build-depends: - Cabal >= 1.9.2 , - QuickCheck >= 2.5.1, - aeson >= 0.6.2 && < 0.7, - aeson-pretty <= 0.7 , - array >= 0.4, - attoparsec >= 0.10.4, - base == 4.*, - base64-bytestring == 1.0.*, - bytestring >= 0.9 && < 0.11, - case-insensitive >= 1.0, - containers >= 0.5, - lens >= 3.8.7, - old-locale >= 1.0.0.4, - regex-compat-tdfa >= 0.95.1, - safe >= 0.3.3, - safecopy >= 0.8.1, - time >= 1.4, - template-haskell >= 2.7, - text >= 0.11.3, - unordered-containers >= 0.2.3.0 , - vector >= 0.10.0.1 + Cabal >= 1.4 && < 2 , + QuickCheck >= 2.5.1 && < 2.8 , + aeson >= 0.6.2 && < 0.7 , + aeson-pretty >= 0.1 && < 0.8 , + array >= 0.4 && < 0.5 , + attoparsec >= 0.10.4 && < 0.12 , + base >= 4 && < 5 , + base64-bytestring >= 1.0 && < 1.1 , + bytestring >= 0.9 && < 0.11 , + case-insensitive >= 1.0 && < 1.3 , + containers >= 0.5 && < 0.6 , + lens >= 3.8.7 && < 4 , + old-locale >= 1.0.0.4 && < 1.1 , + regex-compat-tdfa >= 0.95.1 && < 0.96 , + safe >= 0.3.3 && < 0.4 , + safecopy >= 0.8.1 && < 0.9 , + time >= 1.4 && < 1.5 , + template-haskell >= 2.7 && < 2.9 , + text >= 0.11.3 && < 1.2 , + unordered-containers >= 0.2.3.0 && < 0.3 , + vector >= 0.10.0.1 && < 0.11 + Build-tools: alex, happy @@ -105,27 +106,26 @@ Build-depends: api-tools, - Cabal >= 1.9.2 , - QuickCheck >= 2.5.1, - aeson >= 0.6.2 && < 0.7, - aeson-pretty <= 0.7 , - array >= 0.4, - attoparsec >= 0.10.4, - base == 4.*, - base64-bytestring == 1.0.*, - bytestring >= 0.9 && < 0.11, - case-insensitive >= 1.0, - containers >= 0.5, - lens >= 3.8.7, - old-locale >= 1.0.0.4, - regex-compat-tdfa >= 0.95.1, - safe >= 0.3.3, - safecopy >= 0.8.1, - time >= 1.4, - template-haskell >= 2.7, - text >= 0.11.3, - unordered-containers >= 0.2.3.0 , - vector >= 0.10.0.1 + QuickCheck >= 2.5.1 && < 2.8 , + aeson >= 0.6.2 && < 0.7 , + aeson-pretty >= 0.1 && < 0.8 , + array >= 0.4 && < 0.5 , + attoparsec >= 0.10.4 && < 0.12 , + base >= 4 && < 5 , + base64-bytestring >= 1.0 && < 1.1 , + bytestring >= 0.9 && < 0.11 , + case-insensitive >= 1.0 && < 1.3 , + containers >= 0.5 && < 0.6 , + lens >= 3.8.7 && < 4 , + old-locale >= 1.0.0.4 && < 1.1 , + regex-compat-tdfa >= 0.95.1 && < 0.96 , + safe >= 0.3.3 && < 0.4 , + safecopy >= 0.8.1 && < 0.9 , + time >= 1.4 && < 1.5 , + template-haskell >= 2.7 && < 2.9 , + text >= 0.11.3 && < 1.2 , + unordered-containers >= 0.2.3.0 && < 0.3 , + vector >= 0.10.0.1 && < 0.11 GHC-Options: -main-is Data.API.MigrationTool @@ -151,30 +151,30 @@ Build-depends: api-tools, - Cabal >= 1.9.2 , - QuickCheck >= 2.5.1, - aeson >= 0.6.2 && < 0.7, - aeson-pretty <= 0.7 , - array >= 0.4, - attoparsec >= 0.10.4, - base == 4.*, - base64-bytestring == 1.0.*, - bytestring >= 0.9 && < 0.11, - case-insensitive >= 1.0, - containers >= 0.5, - lens >= 3.8.7, - old-locale >= 1.0.0.4, - regex-compat-tdfa >= 0.95.1, - safe >= 0.3.3, - safecopy >= 0.8.1, - tasty >= 0.3 , - tasty-hunit >= 0.2 , - tasty-quickcheck >= 0.3 , - time >= 1.4, - template-haskell >= 2.7, - text >= 0.11.3, - unordered-containers >= 0.2.3.0 , - vector >= 0.10.0.1 + Cabal >= 1.4 && < 2 , + QuickCheck >= 2.5.1 && < 2.8 , + aeson >= 0.6.2 && < 0.7 , + aeson-pretty >= 0.1 && < 0.8 , + array >= 0.4 && < 0.5 , + attoparsec >= 0.10.4 && < 0.12 , + base >= 4 && < 5 , + base64-bytestring >= 1.0 && < 1.1 , + bytestring >= 0.9 && < 0.11 , + case-insensitive >= 1.0 && < 1.3 , + containers >= 0.5 && < 0.6 , + lens >= 3.8.7 && < 4 , + old-locale >= 1.0.0.4 && < 1.1 , + regex-compat-tdfa >= 0.95.1 && < 0.96 , + safe >= 0.3.3 && < 0.4 , + safecopy >= 0.8.1 && < 0.9 , + tasty >= 0.3 && < 0.9 , + tasty-hunit >= 0.2 && < 0.9 , + tasty-quickcheck >= 0.3 && < 0.9 , + time >= 1.4 && < 1.5 , + template-haskell >= 2.7 && < 2.9 , + text >= 0.11.3 && < 1.2 , + unordered-containers >= 0.2.3.0 && < 0.3 , + vector >= 0.10.0.1 && < 0.11 GHC-Options: -main-is Data.API.Test.Main diff --git a/dist/build/Data/API/Parse.hs b/dist/build/Data/API/Parse.hs --- a/dist/build/Data/API/Parse.hs +++ b/dist/build/Data/API/Parse.hs @@ -26,7 +26,7 @@ import qualified Data.Array as Happy_Data_Array import qualified GHC.Exts as Happy_GHC_Exts --- parser produced by Happy Version 1.19.0 +-- parser produced by Happy Version 1.19.2 newtype HappyAbsSyn = HappyAbsSyn HappyAny #if __GLASGOW_HASKELL__ >= 607 @@ -1056,7 +1056,7 @@ = case happyOut32 happy_x_3 of { happy_var_3 -> case happyOut47 happy_x_4 of { happy_var_4 -> happyIn38 - ([ChCustomRecord happy_var_3 happy_var_4] + ([ChCustomType happy_var_3 happy_var_4] ) `HappyStk` happyRest}} happyReduce_77 = happySpecReduce_2 33# happyReduction_77 @@ -1479,6 +1479,49 @@ {-# LINE 1 "templates/GenericTemplate.hs" #-} {-# LINE 1 "templates/GenericTemplate.hs" #-} {-# LINE 1 "" #-} +{-# LINE 8 "" #-} +# 1 "/usr/include/stdc-predef.h" 1 3 4 + +# 17 "/usr/include/stdc-predef.h" 3 4 + + + + + + + + + + + + + + +# 1 "/usr/include/x86_64-linux-gnu/bits/predefs.h" 1 3 4 + +# 18 "/usr/include/x86_64-linux-gnu/bits/predefs.h" 3 4 + + + + + + + + + + + + +# 31 "/usr/include/stdc-predef.h" 2 3 4 + + + + + + + + +{-# LINE 8 "" #-} {-# LINE 1 "templates/GenericTemplate.hs" #-} -- Id: GenericTemplate.hs,v 1.26 2005/01/14 14:47:22 simonmar Exp @@ -1488,6 +1531,7 @@ +-- Do not remove this comment. Required to fix CPP parsing when using GCC and a clang-compiled alex. #if __GLASGOW_HASKELL__ > 706 #define LT(n,m) ((Happy_GHC_Exts.tagToEnum# (n Happy_GHC_Exts.<# m)) :: Bool) #define GTE(n,m) ((Happy_GHC_Exts.tagToEnum# (n Happy_GHC_Exts.>=# m)) :: Bool) @@ -1497,7 +1541,7 @@ #define GTE(n,m) (n Happy_GHC_Exts.>=# m) #define EQ(n,m) (n Happy_GHC_Exts.==# m) #endif -{-# LINE 45 "templates/GenericTemplate.hs" #-} +{-# LINE 46 "templates/GenericTemplate.hs" #-} data Happy_IntList = HappyCons Happy_GHC_Exts.Int# Happy_IntList @@ -1506,11 +1550,11 @@ -{-# LINE 66 "templates/GenericTemplate.hs" #-} +{-# LINE 67 "templates/GenericTemplate.hs" #-} -{-# LINE 76 "templates/GenericTemplate.hs" #-} +{-# LINE 77 "templates/GenericTemplate.hs" #-} -{-# LINE 85 "templates/GenericTemplate.hs" #-} +{-# LINE 86 "templates/GenericTemplate.hs" #-} infixr 9 `HappyStk` data HappyStk a = HappyStk a (HappyStk a) @@ -1527,9 +1571,9 @@ -- parse (a %partial parser). We must ignore the saved token on the top of -- the stack in this case. happyAccept 0# tk st sts (_ `HappyStk` ans `HappyStk` _) = - happyReturn1 ans + happyReturn1 ans happyAccept j tk st sts (HappyStk ans _) = - (happyTcHack j (happyTcHack st)) (happyReturn1 ans) + (happyTcHack j (happyTcHack st)) (happyReturn1 ans) ----------------------------------------------------------------------------- -- Arrays only: do the next action @@ -1537,35 +1581,35 @@ happyDoAction i tk st - = {- nothing -} + = {- nothing -} - case action of - 0# -> {- nothing -} - happyFail i tk st - -1# -> {- nothing -} - happyAccept i tk st - n | LT(n,(0# :: Happy_GHC_Exts.Int#)) -> {- nothing -} + case action of + 0# -> {- nothing -} + happyFail i tk st + -1# -> {- nothing -} + happyAccept i tk st + n | LT(n,(0# :: Happy_GHC_Exts.Int#)) -> {- nothing -} - (happyReduceArr Happy_Data_Array.! rule) i tk st - where rule = (Happy_GHC_Exts.I# ((Happy_GHC_Exts.negateInt# ((n Happy_GHC_Exts.+# (1# :: Happy_GHC_Exts.Int#)))))) - n -> {- nothing -} + (happyReduceArr Happy_Data_Array.! rule) i tk st + where rule = (Happy_GHC_Exts.I# ((Happy_GHC_Exts.negateInt# ((n Happy_GHC_Exts.+# (1# :: Happy_GHC_Exts.Int#)))))) + n -> {- nothing -} - happyShift new_state i tk st + happyShift new_state i tk st where new_state = (n Happy_GHC_Exts.-# (1# :: Happy_GHC_Exts.Int#)) where off = indexShortOffAddr happyActOffsets st off_i = (off Happy_GHC_Exts.+# i) - check = if GTE(off_i,(0# :: Happy_GHC_Exts.Int#)) + check = if GTE(off_i,(0# :: Happy_GHC_Exts.Int#)) then EQ(indexShortOffAddr happyCheck off_i, i) - else False + else False action | check = indexShortOffAddr happyTable off_i | otherwise = indexShortOffAddr happyDefActions st indexShortOffAddr (HappyA# arr) off = - Happy_GHC_Exts.narrow16Int# i + Happy_GHC_Exts.narrow16Int# i where i = Happy_GHC_Exts.word2Int# (Happy_GHC_Exts.or# (Happy_GHC_Exts.uncheckedShiftL# high 8#) low) high = Happy_GHC_Exts.int2Word# (Happy_GHC_Exts.ord# (Happy_GHC_Exts.indexCharOffAddr# arr (off' Happy_GHC_Exts.+# 1#))) @@ -1584,7 +1628,7 @@ ----------------------------------------------------------------------------- -- HappyState data type (not arrays) -{-# LINE 169 "templates/GenericTemplate.hs" #-} +{-# LINE 170 "templates/GenericTemplate.hs" #-} ----------------------------------------------------------------------------- -- Shifting a token @@ -1626,9 +1670,9 @@ = happyFail 0# tk st sts stk happyReduce k nt fn j tk st sts stk = case happyDrop (k Happy_GHC_Exts.-# (1# :: Happy_GHC_Exts.Int#)) sts of - sts1@((HappyCons (st1@(action)) (_))) -> - let r = fn stk in -- it doesn't hurt to always seq here... - happyDoSeq r (happyGoto nt j tk st1 sts1 r) + sts1@((HappyCons (st1@(action)) (_))) -> + let r = fn stk in -- it doesn't hurt to always seq here... + happyDoSeq r (happyGoto nt j tk st1 sts1 r) happyMonadReduce k nt fn 0# tk st sts stk = happyFail 0# tk st sts stk @@ -1680,7 +1724,7 @@ -- parse error if we are in recovery and we fail again happyFail 0# tk old_st _ stk@(x `HappyStk` _) = let i = (case Happy_GHC_Exts.unsafeCoerce# x of { (Happy_GHC_Exts.I# (i)) -> i }) in --- trace "failing" $ +-- trace "failing" $ happyError_ i tk {- We don't need state discarding for our restricted implementation of @@ -1689,16 +1733,16 @@ -- discard a state happyFail 0# tk old_st (HappyCons ((action)) (sts)) - (saved_tok `HappyStk` _ `HappyStk` stk) = --- trace ("discarding state, depth " ++ show (length stk)) $ - happyDoAction 0# tk action sts ((saved_tok`HappyStk`stk)) + (saved_tok `HappyStk` _ `HappyStk` stk) = +-- trace ("discarding state, depth " ++ show (length stk)) $ + happyDoAction 0# tk action sts ((saved_tok`HappyStk`stk)) -} -- Enter error recovery: generate an error token, -- save the old token and carry on. happyFail i tk (action) sts stk = -- trace "entering error recovery" $ - happyDoAction 0# tk action sts ( (Happy_GHC_Exts.unsafeCoerce# (Happy_GHC_Exts.I# (i))) `HappyStk` stk) + happyDoAction 0# tk action sts ( (Happy_GHC_Exts.unsafeCoerce# (Happy_GHC_Exts.I# (i))) `HappyStk` stk) -- Internal happy errors: @@ -1716,9 +1760,9 @@ ----------------------------------------------------------------------------- -- Seq-ing. If the --strict flag is given, then Happy emits --- happySeq = happyDoSeq +-- happySeq = happyDoSeq -- otherwise it emits --- happySeq = happyDontSeq +-- happySeq = happyDontSeq happyDoSeq, happyDontSeq :: a -> b -> b happyDoSeq a b = a `seq` b diff --git a/dist/build/Data/API/Scan.hs b/dist/build/Data/API/Scan.hs --- a/dist/build/Data/API/Scan.hs +++ b/dist/build/Data/API/Scan.hs @@ -38,6 +38,54 @@ {-# LINE 1 "templates/wrappers.hs" #-} {-# LINE 1 "templates/wrappers.hs" #-} {-# LINE 1 "" #-} + + + + + + +# 1 "/usr/include/stdc-predef.h" 1 3 4 + +# 17 "/usr/include/stdc-predef.h" 3 4 + + + + + + + + + + + + + + +# 1 "/usr/include/x86_64-linux-gnu/bits/predefs.h" 1 3 4 + +# 18 "/usr/include/x86_64-linux-gnu/bits/predefs.h" 3 4 + + + + + + + + + + + + +# 31 "/usr/include/stdc-predef.h" 2 3 4 + + + + + + + + +{-# LINE 6 "" #-} {-# LINE 1 "templates/wrappers.hs" #-} -- ----------------------------------------------------------------------------- -- Alex wrapper code. @@ -98,11 +146,11 @@ in p' `seq` Just (b, (p', c, bs, s)) -{-# LINE 89 "templates/wrappers.hs" #-} +{-# LINE 92 "templates/wrappers.hs" #-} -{-# LINE 103 "templates/wrappers.hs" #-} +{-# LINE 106 "templates/wrappers.hs" #-} -{-# LINE 118 "templates/wrappers.hs" #-} +{-# LINE 121 "templates/wrappers.hs" #-} -- ----------------------------------------------------------------------------- -- Token positions @@ -130,27 +178,27 @@ -- ----------------------------------------------------------------------------- -- Default monad -{-# LINE 239 "templates/wrappers.hs" #-} +{-# LINE 242 "templates/wrappers.hs" #-} -- ----------------------------------------------------------------------------- -- Monad (with ByteString input) -{-# LINE 328 "templates/wrappers.hs" #-} +{-# LINE 333 "templates/wrappers.hs" #-} -- ----------------------------------------------------------------------------- -- Basic wrapper -{-# LINE 355 "templates/wrappers.hs" #-} +{-# LINE 360 "templates/wrappers.hs" #-} -- ----------------------------------------------------------------------------- -- Basic wrapper, ByteString version -{-# LINE 373 "templates/wrappers.hs" #-} +{-# LINE 378 "templates/wrappers.hs" #-} -{-# LINE 386 "templates/wrappers.hs" #-} +{-# LINE 392 "templates/wrappers.hs" #-} -- ----------------------------------------------------------------------------- @@ -173,7 +221,7 @@ -- ----------------------------------------------------------------------------- -- Posn wrapper, ByteString version -{-# LINE 418 "templates/wrappers.hs" #-} +{-# LINE 424 "templates/wrappers.hs" #-} -- ----------------------------------------------------------------------------- @@ -357,6 +405,55 @@ {-# LINE 1 "templates/GenericTemplate.hs" #-} {-# LINE 1 "templates/GenericTemplate.hs" #-} {-# LINE 1 "" #-} + + + + + + + +# 1 "/usr/include/stdc-predef.h" 1 3 4 + +# 17 "/usr/include/stdc-predef.h" 3 4 + + + + + + + + + + + + + + +# 1 "/usr/include/x86_64-linux-gnu/bits/predefs.h" 1 3 4 + +# 18 "/usr/include/x86_64-linux-gnu/bits/predefs.h" 3 4 + + + + + + + + + + + + +# 31 "/usr/include/stdc-predef.h" 2 3 4 + + + + + + + + +{-# LINE 7 "" #-} {-# LINE 1 "templates/GenericTemplate.hs" #-} -- ----------------------------------------------------------------------------- -- ALEX TEMPLATE @@ -373,6 +470,7 @@ +-- Do not remove this comment. Required to fix CPP parsing when using GCC and a clang-compiled alex. #if __GLASGOW_HASKELL__ > 706 #define GTE(n,m) (tagToEnum# (n >=# m)) #define EQ(n,m) (tagToEnum# (n ==# m)) @@ -380,11 +478,11 @@ #define GTE(n,m) (n >=# m) #define EQ(n,m) (n ==# m) #endif -{-# LINE 50 "templates/GenericTemplate.hs" #-} +{-# LINE 51 "templates/GenericTemplate.hs" #-} data AlexAddr = AlexA# Addr# - +-- Do not remove this comment. Required to fix CPP parsing when using GCC and a clang-compiled alex. #if __GLASGOW_HASKELL__ < 503 uncheckedShiftL# = shiftL# #endif @@ -427,6 +525,7 @@ + #if __GLASGOW_HASKELL__ < 503 quickIndex arr i = arr ! i #else @@ -515,7 +614,7 @@ check_accs (AlexAccNone) = last_acc check_accs (AlexAcc a ) = AlexLastAcc a input (I# (len)) check_accs (AlexAccSkip) = AlexLastSkip input (I# (len)) -{-# LINE 196 "templates/GenericTemplate.hs" #-} +{-# LINE 198 "templates/GenericTemplate.hs" #-} data AlexLastAcc a = AlexNone @@ -531,7 +630,7 @@ = AlexAccNone | AlexAcc a | AlexAccSkip -{-# LINE 240 "templates/GenericTemplate.hs" #-} +{-# LINE 242 "templates/GenericTemplate.hs" #-} -- used by wrappers iUnbox (I# (i)) = i diff --git a/main/Data/API/MigrationTool.hs b/main/Data/API/MigrationTool.hs --- a/main/Data/API/MigrationTool.hs +++ b/main/Data/API/MigrationTool.hs @@ -74,12 +74,11 @@ deriving (Read, Show) customMigrations :: CustomMigrations ChangeTag ChangeTag ChangeTag -customMigrations = CustomMigrations nope (\ _ _ -> Nothing) - nope (\ _ _ -> Nothing) - nofld +customMigrations = CustomMigrations (nope JS.Object) (const noSchemaChanges) + (nope id) (const noSchemaChanges) + (nope id) where - nope _ v = Left (CustomMigrationError "No custom migrations defined" (JS.Object v)) - nofld _ v = Left (CustomMigrationError "No field custom migrations defined" v) + nope toVal _ v = Left (CustomMigrationError "No custom migrations defined" (toVal v)) compareJSON :: FilePath -> FilePath -> IO () compareJSON file1 file2 = do diff --git a/src/Data/API/Changes.hs b/src/Data/API/Changes.hs --- a/src/Data/API/Changes.hs +++ b/src/Data/API/Changes.hs @@ -22,6 +22,10 @@ -- * Custom migrations , CustomMigrations(..) + , mkRecordMigration + , mkRecordMigrationSchema + , noDataChanges + , noSchemaChanges , generateMigrationKinds , MigrationTag @@ -148,8 +152,8 @@ | ChDeleteEnumVal TypeName FieldName | ChRenameEnumVal TypeName FieldName FieldName - -- Custom value (not type) changes - | ChCustomRecord TypeName MigrationTag + -- Custom migrations + | ChCustomType TypeName MigrationTag | ChCustomAll MigrationTag deriving (Eq, Show) @@ -163,34 +167,57 @@ -- * Whole-database migrations, which may arbitrarily change the API -- schema and the data to match; -- --- * Record migrations, which may change the schema of a single --- record; and +-- * 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 record migrations, if the schema is unchanged, the +-- For database and type migrations, if the schema is unchanged, the -- corresponding function should return 'Nothing'. -- --- The @db@, @rec@ and @fld@ parameters should be instantiated with +-- 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 rec fld = CustomMigrations +data CustomMigrations db ty fld = CustomMigrations { databaseMigration :: db -> JS.Object -> Either ValueError JS.Object - , databaseMigrationSchema :: db -> NormAPI -> Maybe NormAPI - , recordMigration :: rec -> JS.Object -> Either ValueError JS.Object - , recordMigrationSchema :: rec -> NormRecordType -> Maybe NormRecordType + , 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 rec, Read fld) - => CustomMigrations db rec fld -> CustomMigrationsTagged +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 @@ -202,7 +229,7 @@ -- | Whether to validate the dataset after this change validateAfter :: DataChecks -> APIChange -> Bool validateAfter chks (ChChangeField{}) = chks >= CheckCustom -validateAfter chks (ChCustomRecord{}) = chks >= CheckCustom +validateAfter chks (ChCustomType{}) = chks >= CheckCustom validateAfter chks (ChCustomAll{}) = chks >= CheckCustom validateAfter chks _ = chks >= CheckAll @@ -271,7 +298,7 @@ -- | 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 (ChCustomRecord _ t) = (Set.empty, Set.singleton t, Set.empty) +changeTags (ChCustomType _ t) = (Set.empty, Set.singleton t, Set.empty) changeTags (ChCustomAll t) = (Set.singleton t, Set.empty, Set.empty) changeTags _ = (Set.empty, Set.empty, Set.empty) @@ -508,13 +535,13 @@ . Map.insert tname' tinfo . Map.delete tname) api , Map.empty ) -applyAPIChangeToAPI _ custom (ChCustomRecord tname tag) api = do +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 - recinfo <- expectRecordType tinfo ?! TypeWrongKind tname TKRecord - let api' = case recordMigrationSchema custom tag recinfo of - Just recinfo' -> Map.insert tname (NRecordType recinfo') api - Nothing -> api + 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 @@ -602,8 +629,9 @@ . Set.delete fname) enuminfo return (Map.insert tname tinfo' api, findUpdatePos tname api) -applyAPIChangeToAPI root custom (ChCustomAll tag) api = - return ( fromMaybe api (databaseMigrationSchema custom tag api) +applyAPIChangeToAPI root custom (ChCustomAll tag) api = do + mb_api' <- databaseMigrationSchema custom tag api + return ( fromMaybe api mb_api' , Map.singleton root (UpdateHere Nothing)) @@ -709,7 +737,7 @@ if s == fieldKey fname then return (fieldKey fname') else return s -applyChangeToData (ChCustomRecord _ tag) custom = withObject (liftMigration $ recordMigration custom tag) +applyChangeToData (ChCustomType _ tag) custom = liftMigration $ typeMigration custom tag applyChangeToData (ChCustomAll tag) custom = withObject (liftMigration $ databaseMigration custom tag) applyChangeToData (ChAddType _ _) _ = pure . pure @@ -970,7 +998,7 @@ , " alternative removed " ++ pp f] ppLines (ChRenameEnumVal t f f') = [ "changed enum " ++ pp t , " alternative renamed " ++ pp f ++ " to " ++ pp f'] - ppLines (ChCustomRecord t c) = ["changed record " ++ pp t ++ " migration " ++ pp c] + ppLines (ChCustomType t c) = ["migration record " ++ pp t ++ " " ++ pp c] ppLines (ChCustomAll c) = ["migration " ++ pp c] instance PPLines MigrateFailure where diff --git a/src/Data/API/JSON.hs b/src/Data/API/JSON.hs --- a/src/Data/API/JSON.hs +++ b/src/Data/API/JSON.hs @@ -21,14 +21,19 @@ -- * Parser with multiple error support , ParserWithErrs + , ParseFlags(useDefaults, enforceReadOnlyFields) + , defaultParseFlags , runParserWithErrsTop -- * FromJSON class with multiple error support , FromJSONWithErrs(..) , fromJSONWithErrs + , fromJSONWithErrs' , decodeWithErrs + , decodeWithErrs' -- * ParserWithErrs combinators + , withParseFlags , failWith , expectedArray , expectedBool @@ -47,8 +52,10 @@ , withUTCRange , withVersion , withField + , withDefaultField , (.:.) , (.::) + , withUnion ) where import Data.API.Types @@ -179,13 +186,13 @@ -- -- * @pf \`ap\` ps@ returns errors from @pf@ only newtype ParserWithErrs a = ParserWithErrs { - runParserWithErrs :: Position -> Either [(JSONError, Position)] a } + runParserWithErrs :: ParseFlags -> Position -> Either [(JSONError, Position)] a } deriving Functor instance Applicative ParserWithErrs where - pure x = ParserWithErrs $ const $ Right x - pf <*> ps = ParserWithErrs $ \ z -> - case (runParserWithErrs pf z, runParserWithErrs ps z) of + pure x = ParserWithErrs $ \ _ _ -> Right x + pf <*> ps = ParserWithErrs $ \ q z -> + case (runParserWithErrs pf q z, runParserWithErrs ps q z) of (Right f, Right s) -> Right $ f s (Left es, Right _) -> Left es (Right _, Left es) -> Left es @@ -193,22 +200,40 @@ instance Alternative ParserWithErrs where empty = failWith $ SyntaxError "No alternative" - px <|> py = ParserWithErrs $ \ z -> case runParserWithErrs px z of + px <|> py = ParserWithErrs $ \ q z -> case runParserWithErrs px q z of Right v -> Right v - Left _ -> runParserWithErrs py z + Left _ -> runParserWithErrs py q z instance Monad ParserWithErrs where return = pure - px >>= f = ParserWithErrs $ \ z -> - case runParserWithErrs px z of - Right x -> runParserWithErrs (f x) z + px >>= f = ParserWithErrs $ \ q z -> + case runParserWithErrs px q z of + Right x -> runParserWithErrs (f x) q z Left es -> Left es fail = failWith . SyntaxError -runParserWithErrsTop :: ParserWithErrs a -> Either [(JSONError, Position)] a -runParserWithErrsTop p = runParserWithErrs p [] +-- | Options to modify the behaviour of the JSON parser +data ParseFlags = ParseFlags + { useDefaults :: Bool + -- ^ If true, default values from the schema will be used when a + -- field is missing from the JSON data + , enforceReadOnlyFields :: Bool + -- ^ If true, fields in the schema marked read-only will be + -- overwritten with default values + } +-- | Use this as a basis for overriding individual fields of the +-- 'ParseFlags' record, in case more flags are added in the future. +defaultParseFlags :: ParseFlags +defaultParseFlags = ParseFlags { useDefaults = False + , enforceReadOnlyFields = False + } + +runParserWithErrsTop :: ParseFlags -> ParserWithErrs a -> Either [(JSONError, Position)] a +runParserWithErrsTop q p = runParserWithErrs p q [] + + -------------------------------------------------- -- FromJSON class with multiple error support -- @@ -246,6 +271,7 @@ parseJSONWithErrs (JS.Array a) = traverse help $ zip (V.toList a) [0..] where help (x, i) = stepInside (InElem i) $ parseJSONWithErrs x + parseJSONWithErrs JS.Null = pure [] parseJSONWithErrs v = failWith $ expectedArray v instance FromJSONWithErrs Int where @@ -275,30 +301,45 @@ -- implementation of 'parseJSONWithErrs' as it will not pass on the -- current position. fromJSONWithErrs :: FromJSONWithErrs a => JS.Value -> Either [(JSONError, Position)] a -fromJSONWithErrs = runParserWithErrsTop . parseJSONWithErrs +fromJSONWithErrs = fromJSONWithErrs' defaultParseFlags +-- | Run the JSON parser on a value to produce a result or a list of +-- errors with their positions. This version allows the 'ParseFlags' +-- to be specified. +fromJSONWithErrs' :: FromJSONWithErrs a => ParseFlags -> JS.Value -> Either [(JSONError, Position)] a +fromJSONWithErrs' q = runParserWithErrsTop q . parseJSONWithErrs + + -- | Decode a 'ByteString' and run the JSON parser decodeWithErrs :: FromJSONWithErrs a => BL.ByteString -> Either [(JSONError, Position)] a -decodeWithErrs x = case JS.eitherDecode x of +decodeWithErrs = decodeWithErrs' defaultParseFlags + +-- | Decode a 'ByteString' and run the JSON parser, allowing the +-- 'ParseFlags' to be specified +decodeWithErrs' :: FromJSONWithErrs a => ParseFlags -> BL.ByteString -> Either [(JSONError, Position)] a +decodeWithErrs' q x = case JS.eitherDecode x of Left e -> Left [(SyntaxError e, [])] - Right v -> fromJSONWithErrs v + Right v -> fromJSONWithErrs' q v --------------------------------- -- ParserWithErrs combinators -- +withParseFlags :: (ParseFlags -> ParserWithErrs a) -> ParserWithErrs a +withParseFlags k = ParserWithErrs $ \ q -> runParserWithErrs (k q) q + failWith :: JSONError -> ParserWithErrs a -failWith e = ParserWithErrs $ \ z -> Left [(e, z)] +failWith e = ParserWithErrs $ \ _ z -> Left [(e, z)] stepInside :: Step -> ParserWithErrs a -> ParserWithErrs a -stepInside s p = ParserWithErrs $ \ z -> runParserWithErrs p (s:z) +stepInside s p = ParserWithErrs $ \ q z -> runParserWithErrs p q (s:z) -- | If this parser returns any errors at the current position, modify -- them using the supplied function. modifyTopError :: (JSONError -> JSONError) -> ParserWithErrs a -> ParserWithErrs a -modifyTopError f p = ParserWithErrs $ \ z -> case runParserWithErrs p z of +modifyTopError f p = ParserWithErrs $ \ q z -> case runParserWithErrs p q z of Left es -> Left $ map (modifyIfAt z) es r -> r where @@ -389,9 +430,24 @@ withField k f m = stepInside (InField k) $ modifyTopError treatAsMissing $ f v where v = fromMaybe JS.Null $ HMap.lookup k m - treatAsMissing (Expected _ _ JS.Null) = MissingField - treatAsMissing e = e +treatAsMissing :: JSONError -> JSONError +treatAsMissing (Expected _ _ JS.Null) = MissingField +treatAsMissing e = e + +-- | Look up the value of a field, which may be read-only or use a +-- default value (depending on the 'ParseFlags'). +withDefaultField :: Bool -> Maybe JS.Value -> T.Text -> (JS.Value -> ParserWithErrs a) + -> JS.Object -> ParserWithErrs a +withDefaultField readOnly mb_defVal k f m = + stepInside (InField k) $ modifyTopError treatAsMissing $ withParseFlags foo + where + foo q | readOnly && enforceReadOnlyFields q = f defVal + | useDefaults q = f $ fromMaybe defVal $ HMap.lookup k m + | otherwise = f $ fromMaybe JS.Null $ HMap.lookup k m + + defVal = fromMaybe JS.Null mb_defVal + -- | Look up the value of a field, failing on missing fields withStrictField :: T.Text -> (JS.Value -> ParserWithErrs a) -> JS.Object -> ParserWithErrs a @@ -406,6 +462,20 @@ -- | Parse the value of a field, failing on missing fields (.::) :: FromJSONWithErrs a => JS.Object -> T.Text -> ParserWithErrs a m .:: k = withStrictField k parseJSONWithErrs m + + +-- | Match an inhabitant of a disjoint union, which should be an +-- object with a single field, and call the continuation corresponding +-- to the field name. +withUnion :: [(T.Text, JS.Value -> ParserWithErrs a)] -> JS.Value -> ParserWithErrs a +withUnion xs (JS.Object hs) = + case HMap.toList hs of + [(k, v)] -> case lookup k xs of + Just c -> stepInside (InField k) $ c v + Nothing -> failWith $ MissingAlt $ map (T.unpack . fst) xs + [] -> failWith $ MissingAlt $ map (T.unpack . fst) xs + _:_:_ -> failWith UnexpectedField +withUnion _ val = failWith $ Expected ExpObject "Union" val deriveJSON defaultOptions ''JSONError diff --git a/src/Data/API/Parse.y b/src/Data/API/Parse.y --- a/src/Data/API/Parse.y +++ b/src/Data/API/Parse.y @@ -242,7 +242,7 @@ | changed record TypeName RFieldChanges { map (fldChangeToAPIChange $3) (reverse $4) } | changed union TypeName RUnionChanges { map (unionChangeToAPIChange $3) (reverse $4) } | changed enum TypeName REnumChanges { map (enumChangeToAPIChange $3) (reverse $4) } - | migration record TypeName MigrationTag { [ChCustomRecord $3 $4] } + | migration record TypeName MigrationTag { [ChCustomType $3 $4] } | migration MigrationTag { [ChCustomAll $2] } | comment { [] } diff --git a/src/Data/API/Tools/JSON.hs b/src/Data/API/Tools/JSON.hs --- a/src/Data/API/Tools/JSON.hs +++ b/src/Data/API/Tools/JSON.hs @@ -16,6 +16,7 @@ import Data.Aeson hiding (withText, withBool) import Control.Applicative +import qualified Data.HashMap.Strict as HMap import qualified Data.Map as Map import Data.Monoid import qualified Data.Text as T @@ -112,6 +113,7 @@ v .: "Input" <*> v .: "Output" <*> v .: "PipelineId" + parseJSONWithErrs Null = parseJSONWithErrs (Object HMap.empty) parseJSONWithErrs v = failWith $ expectedObject val -} @@ -119,12 +121,17 @@ gen_sr_fm = mkTool $ \ ts (an, sr) -> do x <- newName "x" optionalInstanceD ts ''FromJSONWithErrs [nodeRepT an] - [funD 'parseJSONWithErrs [cl an sr x, cl' x]] + [funD 'parseJSONWithErrs [cl an sr x, clNull, cl' x]] where cl an sr x = clause [conP 'Object [varP x]] (normalB bdy) [] - where bdy = applicativeE (nodeConE an) [ [e| $(varE x) .:. $(fieldNameE fn) |] - | (fn, _) <- srFields sr ] + where + bdy = applicativeE (nodeConE an) $ map project (srFields sr) + project (fn, ft) = [e| withDefaultField ro (fmap defaultValueAsJsValue mb_dv) $(fieldNameE fn) parseJSONWithErrs $(varE x) |] + where ro = ftReadOnly ft + mb_dv = ftDefault ft + clNull = clause [conP 'Null []] (normalB [e| parseJSONWithErrs (Object HMap.empty) |]) [] + cl' x = clause [varP x] (normalB (bdy' x)) [] bdy' x = [e| failWith (expectedObject $(varE x)) |] @@ -148,34 +155,18 @@ {- instance FromJSONWithErrs Foo where - parseJSONWithErrs (Object v) = alternatives (failWith $ MissingAlt ["x", "y"]) - [ Bar <$> v .:: "x" - , Baz <$> v .:: "y" - ] - parseJSONWithErrs val = failWith $ expectedObject val + parseJSONWithErrs = withUnion [ ("x", fmap Bar . parseJSONWithErrs) + , ("y", fmap Baz . parseJSONWithErrs) ] -} gen_su_fm :: Tool (APINode, SpecUnion) -gen_su_fm = mkTool $ \ ts (an, su) -> do - x <- newName "x" +gen_su_fm = mkTool $ \ ts (an, su) -> optionalInstanceD ts ''FromJSONWithErrs [nodeRepT an] - [funD 'parseJSONWithErrs (cls an su x)] + [simpleD 'parseJSONWithErrs (bdy an su)] where - cls an su x = [cl, cl'] - where - cl = clause [conP 'Object [varP x]] (normalB bdy) [] - bdy = [e| alternatives (failWith $ MissingAlt $ss) $alts |] - - alt fn = [e| fmap $(nodeAltConE an fn) ($(varE x) .:: $(fieldNameE fn)) |] - - alts = listE $ map alt fns - ss = listE $ map fieldNameE fns - - fns = map fst $ suFields su - - cl' = clause [varP x] (normalB bdy') [] - bdy' = [e| failWith (expectedObject $(varE x)) |] + bdy an su = varE 'withUnion `appE` listE (map (alt an) (suFields su)) + alt an (fn, _) = [e| ( $(fieldNameE fn) , fmap $(nodeAltConE an fn) . parseJSONWithErrs ) |] {- diff --git a/src/Data/API/Tutorial.hs b/src/Data/API/Tutorial.hs --- a/src/Data/API/Tutorial.hs +++ b/src/Data/API/Tutorial.hs @@ -211,12 +211,12 @@ the primitive changes, /custom/ migrations can be used to migrate data between versions. -Custom migrations can be applied to the whole dataset, a single record +Custom migrations can be applied to the whole dataset, a single type or an individual record field, thus: > version "0.42" > migration MigrateWholeDataset -> migration record Widget MigrateWidgetRecord +> migration record Widget MigrateWidgetType > changed record Widget where > field changed foo :: String migration MigrateFooField @@ -226,12 +226,12 @@ which describes how to transform the data (and 'API', if appropriate) for each custom migration. For example, -> $(generateMigrationKinds myChangelog "DatabaseMigration" "RecordMigration" "FieldMigration") +> $(generateMigrationKinds myChangelog "DatabaseMigration" "TypeMigration" "FieldMigration") with the changelog fragment above would give > data DatabaseMigration = MigrateWholeDatabase | ... -> data RecordMigration = MigrateWidgetRecord | ... +> data TypeMigration = MigrateWidgetType | ... > data FieldMigration = MigrateFooField | ... Calls to 'migrateDataDump' should include a suitable @@ -246,9 +246,9 @@ > ... A field migration may change the type of the field by listing the new -type in the changelog. Whole-database and individual-record -migrations may describe the changes they make to the schema in the -'databaseMigrationSchema' and 'recordMigrationSchema' fields of the +type in the changelog. Whole-database and individual-type migrations +may describe the changes they make to the schema in the +'databaseMigrationSchema' and 'typeMigrationSchema' fields of the 'CustomMigrations' record. In order to check that custom migrations result in data that matches diff --git a/src/Data/API/Types.hs b/src/Data/API/Types.hs --- a/src/Data/API/Types.hs +++ b/src/Data/API/Types.hs @@ -39,6 +39,7 @@ import Data.Aeson import Data.Aeson.Types import Data.Aeson.TH +import Data.Maybe import qualified Data.Text as T import qualified Data.Text.Encoding as T import qualified Data.ByteString.Char8 as B @@ -144,9 +145,12 @@ instance Lift UTCRange where lift (UTCRange lo hi) = [e| UTCRange $(liftMaybeUTCTime lo) $(liftMaybeUTCTime hi) |] +liftUTC :: UTCTime -> ExpQ +liftUTC u = [e| fromMaybe (error "liftUTC") (parseUTC_ $(stringE (mkUTC_ u))) |] + liftMaybeUTCTime :: Maybe UTCTime -> ExpQ liftMaybeUTCTime Nothing = [e| Nothing |] -liftMaybeUTCTime (Just u) = [e| parseUTC_ $(stringE (mkUTC_ u)) |] +liftMaybeUTCTime (Just u) = [e| Just $(liftUTC u) |] data RegEx = @@ -219,6 +223,10 @@ | TyJSON -- ^ a generic JSON value deriving (Eq, Show) +-- | It is sometimes helpful to write a type name directly as a string +instance IsString APIType where + fromString = TyName . fromString + -- | the basic JSON types (N.B., no floating point numbers, yet) data BasicType = BTstring -- ^ a JSON UTF-8 string @@ -237,6 +245,14 @@ | DefValInt Int | DefValUtc UTCTime deriving (Eq, Show) + +instance Lift DefaultValue where + lift DefValList = [e| DefValList |] + lift DefValMaybe = [e| DefValMaybe |] + lift (DefValString s) = [e| DefValString (T.pack $(lift (T.unpack s))) |] + lift (DefValBool b) = [e| DefValBool b |] + lift (DefValInt i) = [e| DefValInt i |] + lift (DefValUtc u) = [e| DefValUtc $(liftUTC u) |] -- | Convert a default value to an Aeson 'Value'. This differs from -- 'toJSON' as it will not round-trip with 'fromJSON': UTC default diff --git a/tests/Data/API/Test/Gen.hs b/tests/Data/API/Test/Gen.hs --- a/tests/Data/API/Test/Gen.hs +++ b/tests/Data/API/Test/Gen.hs @@ -12,7 +12,7 @@ import Data.API.Tools.Example import Control.Applicative import Language.Haskell.TH -import Test.QuickCheck +import Test.QuickCheck ( Arbitrary(..) ) $(generate DSL.example) $(generateAPITools DSL.example diff --git a/tests/Data/API/Test/JSON.hs b/tests/Data/API/Test/JSON.hs --- a/tests/Data/API/Test/JSON.hs +++ b/tests/Data/API/Test/JSON.hs @@ -18,7 +18,7 @@ import Test.Tasty import Test.Tasty.HUnit -import Test.Tasty.QuickCheck +import qualified Test.Tasty.QuickCheck as QC $(generate startSchema) @@ -51,12 +51,14 @@ -- | Test that the correct errors are generated for bad JSON data errorDecoding :: [TestTree] -errorDecoding = [ help "not enough bytes" "" (proxy :: Int) - [(SyntaxError "not enough bytes", [])] +errorDecoding = [ help "not enough input" "" (proxy :: Int) + [(SyntaxError "not enough input", [])] , help "object for int" "{}" (proxy :: Int) [(Expected ExpInt "Int" (JS.Object HMap.empty), [])] , help "missing alt" "{}" (proxy :: AUnion) [(MissingAlt ["bar"], [])] + , help "error inside alt" "{\"bar\": {}}" (proxy :: AUnion) + [(MissingField, [InField "id", InField "bar"])] , help "unexpected value" "[\"no\"]" (proxy :: [AnEnum]) [(UnexpectedEnumVal ["bar", "foo"] "no", [InElem 0])] , help "missing field" "{}" (proxy :: Bar) @@ -77,8 +79,8 @@ [ testCase "Basic value decoding" basicValueDecoding , testGroup "Decoding invalid data" errorDecoding , testGroup "Round-trip tests" - [ testGroup "example" $ map (uncurry testProperty) exampleSimpleTests - , testGroup "example2" $ map (uncurry testProperty) example2SimpleTests - , testGroup "api" $ map (uncurry testProperty) apiAPISimpleTests + [ testGroup "example" $ map (uncurry QC.testProperty) exampleSimpleTests + , testGroup "example2" $ map (uncurry QC.testProperty) example2SimpleTests + , testGroup "api" $ map (uncurry QC.testProperty) apiAPISimpleTests ] ] diff --git a/tests/Data/API/Test/Migration.hs b/tests/Data/API/Test/Migration.hs --- a/tests/Data/API/Test/Migration.hs +++ b/tests/Data/API/Test/Migration.hs @@ -27,7 +27,7 @@ import Data.Version import Test.Tasty as Test import Test.Tasty.HUnit -import Test.Tasty.QuickCheck +import qualified Test.Tasty.QuickCheck as QC import Test.QuickCheck.Property as P @@ -43,20 +43,20 @@ recur <- HMap.lookup "recur" x ?! CustomMigrationError "missing recur" (JS.Object x) return $ HMap.insert "recur2" recur x -testDatabaseMigrationSchema :: TestDatabaseMigration -> NormAPI -> Maybe NormAPI -testDatabaseMigrationSchema DuplicateBar _ = Nothing +testDatabaseMigrationSchema :: TestDatabaseMigration -> NormAPI -> Either ApplyFailure (Maybe NormAPI) +testDatabaseMigrationSchema DuplicateBar _ = Right Nothing testDatabaseMigrationSchema DuplicateRecursive napi = let Just recur = Map.lookup (TypeName "Recursive") napi Just (NRecordType dbs) = Map.lookup root_ napi dbs' = Map.insert (FieldName "recur2") (TyMaybe (TyList (TyName "DuplicateRecursive"))) dbs - in Just $ Map.insert (TypeName "DuplicateRecursive") recur $ - Map.insert root_ (NRecordType dbs') napi + in Right $ Just $ Map.insert (TypeName "DuplicateRecursive") recur $ + Map.insert root_ (NRecordType dbs') napi -- Test of a single-record migration: copy the value in the id field -- onto the end of the c field -testRecordMigration :: TestRecordMigration -> JS.Object -> Either ValueError JS.Object -testRecordMigration CopyIDtoC x = do +testRecordMigration :: TestRecordMigration -> JS.Value -> Either ValueError JS.Value +testRecordMigration CopyIDtoC = mkRecordMigration $ \ x -> do i <- HMap.lookup "id" x ?! CustomMigrationError "missing id" (JS.Object x) b <- HMap.lookup "c" x ?! CustomMigrationError "missing b" (JS.Object x) r <- case (i, b) of @@ -64,14 +64,14 @@ -> return $ JS.String $ t `T.append` T.pack (show j) _ -> Left $ CustomMigrationError "bad data" (JS.Object x) return $ HMap.insert "c" r x -testRecordMigration DuplicateNew x = do +testRecordMigration DuplicateNew = mkRecordMigration $ \ x -> do new <- HMap.lookup "new" x ?! CustomMigrationError "missing new" (JS.Object x) return $ HMap.insert "newnew" new x -testRecordMigrationSchema :: TestRecordMigration -> NormRecordType -> Maybe NormRecordType -testRecordMigrationSchema CopyIDtoC _ = Nothing -testRecordMigrationSchema DuplicateNew r = - Just $ Map.insert (FieldName "newnew") (TyBasic BTstring) r +testRecordMigrationSchema :: TestRecordMigration -> NormTypeDecl -> Either ApplyFailure (Maybe NormTypeDecl) +testRecordMigrationSchema CopyIDtoC = noSchemaChanges +testRecordMigrationSchema DuplicateNew = mkRecordMigrationSchema "Recursive" $ \ r -> + return $ Just $ Map.insert (FieldName "newnew") (TyBasic BTstring) r -- Test of a single-field migration: change the type of the field from -- binary to string by base64-decoding the contents @@ -84,8 +84,10 @@ testMigration :: CustomMigrations TestDatabaseMigration TestRecordMigration TestFieldMigration -testMigration = CustomMigrations testDatabaseMigration testDatabaseMigrationSchema - testRecordMigration testRecordMigrationSchema +testMigration = CustomMigrations testDatabaseMigration + testDatabaseMigrationSchema + testRecordMigration + testRecordMigrationSchema testFieldMigration @@ -148,7 +150,7 @@ Right (_, ws) -> failedBecause ("migration generated warnings: " ++ show ws) Left err -> failedBecause ("migration failed: " ++ prettyMigrateFailure err) where - failedBecause e = P.MkResult (Just False) True e False False [] [] + failedBecause e = failed { reason = e } migrationTests :: TestTree @@ -156,5 +158,5 @@ [ testCase "Basic migration using sample changelog" basicMigrationTest , testGroup "Invalid changes" $ map applyFailureTest expectedApplyFailures , testGroup "Invalid migrations" $ map migrateFailureTest expectedMigrateFailures - , testProperty "Valid migrations" validMigrationProperty + , QC.testProperty "Valid migrations" validMigrationProperty ]