2033814 · schematic · git.iko.soy

git.iko.soy/schematic

on master help sign in

Migration system fixed

2033814Denis Redozubov9 years ago

src/Data/Schematic.hs+11−33

compare with master

unifiedsplit

@@ -70,7 +70,10 @@ class Migratable (revisions :: [(Revision, Schema)]) where

70 -> J.Value

71 -> ParseResult (JsonRepr (Snd (Head revisions)))

73+instance

74+ {-# OVERLAPPING #-}

73−instance {-# OVERLAPPING #-} (TopLevel (Snd rev), SingI (Snd rev)) => Migratable '[rev] where

75+ ( TopLevel (Snd rev), SingI (Snd rev) )

76+ => Migratable '[rev] where

74 mparse _ = parseAndValidateJson

77 mparse _ = parseAndValidateJson

76instance {-# OVERLAPPABLE #-}

79instance {-# OVERLAPPABLE #-}

@@ -79,41 +82,16 @@ instance {-# OVERLAPPABLE #-}

79 , SingI (Snd (Head revisions)))

82 , SingI (Snd (Head revisions)))

80 => Migratable revisions where

83 => Migratable revisions where

81 mparse s v = case parseEither parseJSON v of

84 mparse s v = case parseEither parseJSON v of

85+ Left _ ->

82− Left _ -> migrate <$> mparse (sTail s) v

86+ migrate <$> (mparse (sTail s) v :: ParseResult (JsonRepr (Snd (Head (Tail revisions)))))

83 Right x -> Valid x

87 Right x -> Valid x

84−-- type family Migratable (revisions :: [(Revision, Schema)]) = (cs :: Constraint) where

85−-- Migratable '[rev] = (TopLevel (Snd rev), SingI (Snd rev))

86−-- Migratable revisions =

87−-- ( Migratable (Tail revisions)

88−-- , MigrateSchema (Snd (Head (Tail revisions))) (Snd (Head revisions))

89−-- , SingI (Snd (Head revisions)))

90−

91−-- mparseBySing

92−-- :: Sing schema

93−-- -> J.Value

94−-- -> ParseResult (JsonRepr (Snd (Head revisions)))

95−-- mparseBySing s v = undefined

96−

97−-- mparse

98−-- :: Migratable revisions

99−-- => Sing revisions

100−-- -> J.Value

101−-- -> ParseResult (JsonRepr (Snd (Head revisions)))

102−-- mparse s v =

103−-- let

104−-- st = sTail s

105−-- sth = sSnd $ sHead st

106−-- SCons x SNil -> parseAndValidateJson v

107−-- SCons sch _ -> case parseEither parseJSON v of

108−-- Left _ -> migrate <$> mparse (sTail s) v

109−-- Right x -> Valid x

110

111parseAndValidateVersionedJson

89parseAndValidateVersionedJson

112− :: forall proxy v. (SingI (AllVersions v), Migratable (AllVersions v))

90+ :: forall proxy v. (SingI (Reverse (AllVersions v)), Migratable (Reverse (AllVersions v)))

113 => proxy v

91 => proxy v

114 -> J.Value

92 -> J.Value

115− -> ParseResult (JsonRepr (Snd (Head (AllVersions v))))

93+ -> ParseResult (JsonRepr (Snd (Head (Reverse (AllVersions v)))))

116−parseAndValidateVersionedJson _ v = mparse (sing :: Sing (AllVersions v)) v

94+parseAndValidateVersionedJson _ v = mparse (sing :: Sing (Reverse (AllVersions v))) v

117

118decodeAndValidateJson

96decodeAndValidateJson

119 :: forall schema

97 :: forall schema

@@ -125,10 +103,10 @@ decodeAndValidateJson bs = case decode bs of

125 Just x -> parseAndValidateJson x

103 Just x -> parseAndValidateJson x

126

104

127decodeAndValidateVersionedJson

105decodeAndValidateVersionedJson

128− :: (Migratable (AllVersions versioned), SingI (AllVersions versioned))

106+ :: (Migratable (Reverse (AllVersions versioned)), SingI (Reverse (AllVersions versioned)))

129 => proxy versioned

107 => proxy versioned

130 -> BL.ByteString

108 -> BL.ByteString

131− -> ParseResult (JsonRepr (Snd (Head (AllVersions versioned))))

109+ -> ParseResult (JsonRepr (Snd (Head (Reverse (AllVersions versioned)))))

132decodeAndValidateVersionedJson vp bs = case decode bs of

110decodeAndValidateVersionedJson vp bs = case decode bs of

133 Nothing -> DecodingError "malformed json"

111 Nothing -> DecodingError "malformed json"

134 Just x -> parseAndValidateVersionedJson vp x

112 Just x -> parseAndValidateVersionedJson vp x

src/Data/Schematic/Migration.hs+1−4

@@ -92,7 +92,7 @@ type family AllVersions (vd :: Versioned) :: [(Revision, Schema)] where

92type family AllVersions' (acc :: [(Revision, Schema)]) (ms :: [Migration]) = (r :: [(Revision, Schema)]) where

93 AllVersions' acc '[] = acc

94 AllVersions' ( '(rh, sh) ': tl ) (m ': ms) =

95− AllVersions' ( ApplyMigration m sh ': tl ) ms

95+ AllVersions' ( '(rh, sh) ': ApplyMigration m sh ': tl ) ms

97type family TopVersion (rs :: [(Revision, Schema)]) :: Schema where

98 TopVersion ( '(rh, sh) ': tl) = sh

@@ -100,9 +100,6 @@ type family TopVersion (rs :: [(Revision, Schema)]) :: Schema where

100class MigrateSchema (a :: Schema) (b :: Schema) where

101 migrate :: JsonRepr a -> JsonRepr b

102

103−instance MigrateSchema a a where

104− migrate = id

105−

106data Action = AddKey Symbol Schema | Update Schema | DeleteKey Symbol

103data Action = AddKey Symbol Schema | Update Schema | DeleteKey Symbol

107

104

108data instance Sing (a :: Action) where

105data instance Sing (a :: Action) where

test/SchemaSpec.hs+25−9

@@ -8,6 +8,7 @@ import Data.Aeson

8import Data.Proxy

9import Data.Schematic

10import Data.Singletons

11+import Data.Singletons.Prelude

11import Data.Vinyl

12import Data.Vinyl

12import Test.Hspec

13import Test.Hspec

13import Test.Hspec.SmallCheck

14import Test.Hspec.SmallCheck

@@ -16,15 +17,16 @@ import Test.SmallCheck.Series.Instances

18type SchemaExample

19type SchemaExample

19− = SchemaObject

20+ = 'SchemaObject

20− '[ '("foo", SchemaArray '[AEq 1] (SchemaNumber '[NGt 10]))

21+ '[ '("foo", 'SchemaArray '[AEq 1] ('SchemaNumber '[NGt 10]))

21− , '("bar", SchemaOptional (SchemaText '[TEnum '["foo", "bar"]]))]

22+ , '("bar", 'SchemaOptional ('SchemaText '[TEnum '["foo", "bar"]]))]

23−type VS =

24+type TestMigration =

24− 'Versioned SchemaExample

25− '[ 'Migration "test_revision"

25+ 'Migration "test_revision"

26− '[ 'Diff '[ 'PKey "bar" ] ('Update ('SchemaText '[]))

26+ '[ 'Diff '[ 'PKey "bar" ] ('Update ('SchemaText '[]))

27− , 'Diff '[ 'PKey "foo" ] ('Update ('SchemaNumber '[])) ] ]

27+ , 'Diff '[ 'PKey "foo" ] ('Update ('SchemaNumber '[])) ]

28+

29+type VS = 'Versioned SchemaExample '[ TestMigration ]

29exampleTest :: JsonRepr (SchemaOptional (SchemaText '[TEq 3]))

31exampleTest :: JsonRepr (SchemaOptional (SchemaText '[TEq 3]))

30exampleTest = ReprOptional (Just (ReprText "lil"))

32exampleTest = ReprOptional (Just (ReprText "lil"))

@@ -50,6 +52,19 @@ schemaJson2 = "{\"foo\": [3], \"bar\": null}"

50schemaJsonTopVersion :: ByteString

52schemaJsonTopVersion :: ByteString

51schemaJsonTopVersion = "{ \"foo\": 42, \"bar\": \"bar\" }"

53schemaJsonTopVersion = "{ \"foo\": 42, \"bar\": \"bar\" }"

55+instance

56+ MigrateSchema

57+ ('SchemaObject

58+ '[ '("foo", 'SchemaArray '[ 'AEq 1] ('SchemaNumber '[ 'NGt 10 ])),

59+ '("bar", 'SchemaOptional ('SchemaText '[ 'TEnum '["foo", "bar"]]))])

60+ ('SchemaObject

61+ '[ '("foo", 'SchemaNumber '[]), '("bar", 'SchemaText '[])])

62+ where

63+ migrate _ = ReprObject $

64+ FieldRepr (ReprNumber 42)

65+ :& FieldRepr (ReprText "test")

66+ :& RNil

67+

53spec :: Spec

68spec :: Spec

54spec = do

69spec = do

55 -- it "show/read JsonRepr properly" $

70 -- it "show/read JsonRepr properly" $

@@ -66,8 +81,9 @@ spec = do

66 ((decodeAndValidateJson schemaJson2) :: ParseResult (JsonRepr SchemaExample))

81 ((decodeAndValidateJson schemaJson2) :: ParseResult (JsonRepr SchemaExample))

67 `shouldSatisfy` isValidationError

82 `shouldSatisfy` isValidationError

68 it "validates versioned json" $ do

83 it "validates versioned json" $ do

69− (decodeAndValidateVersionedJson (Proxy @VS) schemaJsonTopVersion)

84+ decodeAndValidateVersionedJson (Proxy @VS) schemaJson

70 `shouldSatisfy` isValid

85 `shouldSatisfy` isValid

87+

72main :: IO ()

88main :: IO ()

73main = hspec spec

89main = hspec spec