buuka/test/Test/Database/Migrations.hs

87 lines
2.5 KiB
Haskell
Raw Permalink Normal View History

2020-12-30 22:09:02 +02:00
{-# 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
]