Test the migrations

This commit is contained in:
Mats Rauhala 2020-12-30 22:09:02 +02:00
parent f26fea5fd2
commit 98341a8c9f
6 changed files with 206 additions and 17 deletions

View File

@ -15,12 +15,28 @@ maintainer: mats.rauhala@iki.fi
category: Web category: Web
extra-source-files: CHANGELOG.md extra-source-files: CHANGELOG.md
library common common-stanza
exposed-modules: MyLib
-- other-modules:
-- other-extensions:
build-depends: base ^>=4.13.0.0 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 , yaml
, mtl , mtl
, transformers , transformers
@ -28,24 +44,26 @@ library
, conduit , conduit
, conduit-extra , conduit-extra
hs-source-dirs: src hs-source-dirs: src
default-language: Haskell2010
executable buuka executable buuka
import: common-stanza
main-is: Main.hs main-is: Main.hs
-- other-modules: -- other-modules:
-- other-extensions: -- other-extensions:
build-depends: base ^>=4.13.0.0, buuka build-depends: buuka
, optparse-applicative , optparse-applicative
hs-source-dirs: app hs-source-dirs: app
default-language: Haskell2010
test-suite buuka-test test-suite buuka-test
default-language: Haskell2010 import: common-stanza
other-modules: Test.Database.Migrations
type: exitcode-stdio-1.0 type: exitcode-stdio-1.0
hs-source-dirs: test hs-source-dirs: test
main-is: MyLibTest.hs main-is: MyLibTest.hs
build-depends: base ^>=4.13.0.0 build-depends: buuka
, buuka
, hedgehog , hedgehog
, hedgehog-corpus
, tasty-hedgehog , tasty-hedgehog
, tasty , tasty
, text
, aeson

View File

@ -1,6 +1,6 @@
{ mkDerivation, aeson, base, conduit, conduit-extra, hedgehog, mtl { mkDerivation, aeson, base, conduit, conduit-extra, hedgehog
, optparse-applicative, stdenv, tasty, tasty-hedgehog, transformers , hedgehog-corpus, mtl, optparse-applicative, stdenv, tasty
, unliftio-core, yaml , tasty-hedgehog, text, transformers, unliftio-core, yaml
}: }:
mkDerivation { mkDerivation {
pname = "buuka"; pname = "buuka";
@ -13,6 +13,8 @@ mkDerivation {
yaml yaml
]; ];
executableHaskellDepends = [ base optparse-applicative ]; 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; license = stdenv.lib.licenses.bsd3;
} }

View File

@ -12,6 +12,6 @@ mkShell {
stylish-haskell stylish-haskell
cabal2nix cabal2nix
haskellPackages.cabal-install haskellPackages.cabal-install
(haskellPackages.ghcWithPackages (_: buuka.buildInputs ++ buuka.propagatedBuildInputs)) (haskellPackages.ghcWithHoogle (_: buuka.buildInputs ++ buuka.propagatedBuildInputs))
]; ];
} }

View 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

View File

@ -1,4 +1,13 @@
module Main (main) where 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 :: IO ()
main = putStrLn "Test suite not yet implemented." main = defaultMain tests

View 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
]