Test the migrations
This commit is contained in:
parent
f26fea5fd2
commit
98341a8c9f
40
buuka.cabal
40
buuka.cabal
@ -15,12 +15,28 @@ maintainer: mats.rauhala@iki.fi
|
||||
category: Web
|
||||
extra-source-files: CHANGELOG.md
|
||||
|
||||
library
|
||||
exposed-modules: MyLib
|
||||
-- other-modules:
|
||||
-- other-extensions:
|
||||
common common-stanza
|
||||
build-depends: base ^>=4.13.0.0
|
||||
, aeson
|
||||
default-extensions: OverloadedStrings
|
||||
, ScopedTypeVariables
|
||||
, DerivingVia
|
||||
, DeriveAnyClass
|
||||
, GeneralizedNewtypeDeriving
|
||||
, DeriveFunctor
|
||||
, DeriveTraversable
|
||||
, DeriveFoldable
|
||||
, StandaloneDeriving
|
||||
, DerivingStrategies
|
||||
, DeriveGeneric
|
||||
default-language: Haskell2010
|
||||
ghc-options: -Wall -threaded
|
||||
|
||||
library
|
||||
import: common-stanza
|
||||
exposed-modules: MyLib
|
||||
, Database.Migrations
|
||||
-- other-modules:
|
||||
build-depends: aeson
|
||||
, yaml
|
||||
, mtl
|
||||
, transformers
|
||||
@ -28,24 +44,26 @@ library
|
||||
, conduit
|
||||
, conduit-extra
|
||||
hs-source-dirs: src
|
||||
default-language: Haskell2010
|
||||
|
||||
executable buuka
|
||||
import: common-stanza
|
||||
main-is: Main.hs
|
||||
-- other-modules:
|
||||
-- other-extensions:
|
||||
build-depends: base ^>=4.13.0.0, buuka
|
||||
build-depends: buuka
|
||||
, optparse-applicative
|
||||
hs-source-dirs: app
|
||||
default-language: Haskell2010
|
||||
|
||||
test-suite buuka-test
|
||||
default-language: Haskell2010
|
||||
import: common-stanza
|
||||
other-modules: Test.Database.Migrations
|
||||
type: exitcode-stdio-1.0
|
||||
hs-source-dirs: test
|
||||
main-is: MyLibTest.hs
|
||||
build-depends: base ^>=4.13.0.0
|
||||
, buuka
|
||||
build-depends: buuka
|
||||
, hedgehog
|
||||
, hedgehog-corpus
|
||||
, tasty-hedgehog
|
||||
, tasty
|
||||
, text
|
||||
, aeson
|
||||
|
10
default.nix
10
default.nix
@ -1,6 +1,6 @@
|
||||
{ mkDerivation, aeson, base, conduit, conduit-extra, hedgehog, mtl
|
||||
, optparse-applicative, stdenv, tasty, tasty-hedgehog, transformers
|
||||
, unliftio-core, yaml
|
||||
{ mkDerivation, aeson, base, conduit, conduit-extra, hedgehog
|
||||
, hedgehog-corpus, mtl, optparse-applicative, stdenv, tasty
|
||||
, tasty-hedgehog, text, transformers, unliftio-core, yaml
|
||||
}:
|
||||
mkDerivation {
|
||||
pname = "buuka";
|
||||
@ -13,6 +13,8 @@ mkDerivation {
|
||||
yaml
|
||||
];
|
||||
executableHaskellDepends = [ base optparse-applicative ];
|
||||
testHaskellDepends = [ base hedgehog tasty tasty-hedgehog ];
|
||||
testHaskellDepends = [
|
||||
aeson base hedgehog hedgehog-corpus tasty tasty-hedgehog text
|
||||
];
|
||||
license = stdenv.lib.licenses.bsd3;
|
||||
}
|
||||
|
@ -12,6 +12,6 @@ mkShell {
|
||||
stylish-haskell
|
||||
cabal2nix
|
||||
haskellPackages.cabal-install
|
||||
(haskellPackages.ghcWithPackages (_: buuka.buildInputs ++ buuka.propagatedBuildInputs))
|
||||
(haskellPackages.ghcWithHoogle (_: buuka.buildInputs ++ buuka.propagatedBuildInputs))
|
||||
];
|
||||
}
|
||||
|
74
src/Database/Migrations.hs
Normal file
74
src/Database/Migrations.hs
Normal file
@ -0,0 +1,74 @@
|
||||
{-# LANGUAGE ConstraintKinds #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-|
|
||||
Module : Database.Migrations
|
||||
Description : Semiautomatic migrations for json values
|
||||
Copyright : (c) Mats Rauhala, 2020
|
||||
License : BSD-3-Clause
|
||||
Maintainer : mats.rauhala@iki.fi
|
||||
Stability : experimental
|
||||
Portability : POSIX
|
||||
|
||||
The idea is taken from the safecopy module.
|
||||
-}
|
||||
module Database.Migrations where
|
||||
|
||||
import Data.Aeson
|
||||
|
||||
import Data.Proxy
|
||||
import GHC.Generics
|
||||
(Generic)
|
||||
import GHC.TypeLits
|
||||
|
||||
data Versioned
|
||||
= Versioned { version :: !Integer, content :: !Value }
|
||||
deriving stock (Show, Generic, Eq)
|
||||
deriving anyclass (ToJSON, FromJSON)
|
||||
|
||||
data Kind a where
|
||||
Base :: Kind a
|
||||
Extends :: (SafeJSON (MigrateFrom a), KnownNat (Version (MigrateFrom a)), Migrate a) => Proxy (MigrateFrom a) -> Kind a
|
||||
|
||||
class FromJSON a => SafeJSON a where
|
||||
type Version a :: Nat
|
||||
|
||||
kind :: Kind a
|
||||
kind = Base
|
||||
|
||||
data Extending (a :: Nat) x
|
||||
|
||||
class Migrate a where
|
||||
type MigrateFrom a :: *
|
||||
migrate :: MigrateFrom a -> Maybe a
|
||||
|
||||
type Migratable a = (SafeJSON a, KnownNat (Version a))
|
||||
|
||||
-- | Convert any json value into a versioned version
|
||||
toVersioned :: forall a. (ToJSON a, KnownNat (Version a), SafeJSON a) => a -> Versioned
|
||||
toVersioned x =
|
||||
Versioned{ version = natVal @(Version a) Proxy
|
||||
, content = toJSON x
|
||||
}
|
||||
|
||||
-- | Convert a json value into result type 'a' doing migrations if required
|
||||
fromVersioned :: forall a. Migratable a => Versioned -> Result a
|
||||
fromVersioned = worker (kind @a)
|
||||
where
|
||||
kindFromProxy :: SafeJSON x => Proxy x -> Kind x
|
||||
kindFromProxy _ = kind
|
||||
worker :: forall b. Migratable b => Kind b -> Versioned -> Result b
|
||||
worker thisKind Versioned{..}
|
||||
-- The versions match
|
||||
| version == natVal @(Version b) Proxy = fromJSON content
|
||||
-- Migrations required
|
||||
| otherwise =
|
||||
case thisKind of
|
||||
Base -> Error "Version not found"
|
||||
Extends x -> do
|
||||
previous <- worker (kindFromProxy x) (Versioned version content)
|
||||
maybe (Error "Migration not found") Success $ migrate previous
|
@ -1,4 +1,13 @@
|
||||
module Main (main) where
|
||||
|
||||
import Test.Tasty
|
||||
|
||||
import qualified Test.Database.Migrations as Database.Migrations
|
||||
|
||||
tests :: TestTree
|
||||
tests = testGroup "buuka"
|
||||
[ Database.Migrations.tests
|
||||
]
|
||||
|
||||
main :: IO ()
|
||||
main = putStrLn "Test suite not yet implemented."
|
||||
main = defaultMain tests
|
||||
|
86
test/Test/Database/Migrations.hs
Normal file
86
test/Test/Database/Migrations.hs
Normal file
@ -0,0 +1,86 @@
|
||||
{-# 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
|
||||
]
|
Loading…
Reference in New Issue
Block a user