87 lines
2.5 KiB
Haskell
87 lines
2.5 KiB
Haskell
|
{-# LANGUAGE DataKinds #-}
|
||
|
|
{-# LANGUAGE DuplicateRecordFields #-}
|
||
|
|
{-# LANGUAGE RecordWildCards #-}
|
||
|
|
{-# LANGUAGE TypeApplications #-}
|
||
|
|
{-# LANGUAGE TypeFamilies #-}
|
||
|
|
module Test.Database.Migrations where
|
||
|
|
|
||
|
|
import Hedgehog
|
||
|
|
import qualified Hedgehog.Corpus as Corpus
|
||
|
|
import qualified Hedgehog.Gen as Gen
|
||
|
|
import qualified Hedgehog.Range as Range
|
||
|
|
import Test.Tasty
|
||
|
|
import Test.Tasty.Hedgehog
|
||
|
|
|
||
|
|
import qualified Data.Text as T
|
||
|
|
|
||
|
|
import Data.Aeson
|
||
|
|
import Data.Proxy
|
||
|
|
(Proxy(..))
|
||
|
|
import GHC.Generics
|
||
|
|
(Generic)
|
||
|
|
|
||
|
|
import Database.Migrations
|
||
|
|
|
||
|
|
newtype Foo_0 = Foo_0 { name :: String }
|
||
|
|
deriving stock (Show, Eq, Generic)
|
||
|
|
deriving anyclass (ToJSON, FromJSON)
|
||
|
|
|
||
|
|
data Foo_1 = Foo_1 { name :: String, age :: Int }
|
||
|
|
deriving stock (Show, Eq, Generic)
|
||
|
|
deriving anyclass (ToJSON, FromJSON)
|
||
|
|
|
||
|
|
data Foo = Foo { name :: T.Text, age :: Int }
|
||
|
|
deriving stock (Show, Eq, Generic)
|
||
|
|
deriving anyclass (ToJSON, FromJSON)
|
||
|
|
|
||
|
|
instance SafeJSON Foo_0 where
|
||
|
|
type Version Foo_0 = 0
|
||
|
|
kind = Base
|
||
|
|
|
||
|
|
instance SafeJSON Foo_1 where
|
||
|
|
type Version Foo_1 = 1
|
||
|
|
kind = Extends Proxy
|
||
|
|
|
||
|
|
instance SafeJSON Foo where
|
||
|
|
type Version Foo = 1
|
||
|
|
kind = Extends Proxy
|
||
|
|
|
||
|
|
instance Migrate Foo_1 where
|
||
|
|
type MigrateFrom Foo_1 = Foo_0
|
||
|
|
migrate Foo_0{..} = Just Foo_1{name=name, age=0}
|
||
|
|
|
||
|
|
instance Migrate Foo where
|
||
|
|
type MigrateFrom Foo = Foo_1
|
||
|
|
migrate Foo_1{..} = Just Foo{name=T.pack name, age=age}
|
||
|
|
|
||
|
|
genFoo :: Gen Foo
|
||
|
|
genFoo = Foo <$> Gen.element Corpus.simpsons <*> Gen.integral (Range.linear 0 100)
|
||
|
|
|
||
|
|
genFoo_1 :: Gen Foo_1
|
||
|
|
genFoo_1 = Foo_1 <$> Gen.element Corpus.simpsons <*> Gen.integral (Range.linear 0 100)
|
||
|
|
|
||
|
|
genFoo_0 :: Gen Foo_0
|
||
|
|
genFoo_0 = Foo_0 <$> Gen.element Corpus.simpsons
|
||
|
|
|
||
|
|
prop_roundtrip_same_version :: Property
|
||
|
|
prop_roundtrip_same_version = property $ do
|
||
|
|
x <- forAll genFoo
|
||
|
|
tripping x toVersioned fromVersioned
|
||
|
|
|
||
|
|
prop_roundtrip_one_migration :: Property
|
||
|
|
prop_roundtrip_one_migration = property $ do
|
||
|
|
x <- forAll genFoo_1
|
||
|
|
fromVersioned (toVersioned x) === maybe (Error "No migrations") Success (migrate @Foo x)
|
||
|
|
|
||
|
|
prop_roundtrip_multiple_migration :: Property
|
||
|
|
prop_roundtrip_multiple_migration = property $ do
|
||
|
|
x <- forAll genFoo_0
|
||
|
|
fromVersioned (toVersioned x) === maybe (Error "No migrations") Success (migrate x >>= migrate @Foo)
|
||
|
|
|
||
|
|
tests :: TestTree
|
||
|
|
tests = testGroup "Database.Migrations"
|
||
|
|
[ testProperty "Roundtrip with same version" prop_roundtrip_same_version
|
||
|
|
, testProperty "Roundtrip with one migration" prop_roundtrip_one_migration
|
||
|
|
, testProperty "Roundtrip with multiple migrations" prop_roundtrip_multiple_migration
|
||
|
|
]
|