From 98341a8c9f7e77495840504daf85d21e39e97ad7 Mon Sep 17 00:00:00 2001 From: Mats Rauhala Date: Wed, 30 Dec 2020 22:09:02 +0200 Subject: [PATCH] Test the migrations --- buuka.cabal | 40 +++++++++++---- default.nix | 10 ++-- shell.nix | 2 +- src/Database/Migrations.hs | 74 +++++++++++++++++++++++++++ test/MyLibTest.hs | 11 +++- test/Test/Database/Migrations.hs | 86 ++++++++++++++++++++++++++++++++ 6 files changed, 206 insertions(+), 17 deletions(-) create mode 100644 src/Database/Migrations.hs create mode 100644 test/Test/Database/Migrations.hs diff --git a/buuka.cabal b/buuka.cabal index e76c778..75392a0 100644 --- a/buuka.cabal +++ b/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 diff --git a/default.nix b/default.nix index 4181f41..b000bc7 100644 --- a/default.nix +++ b/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; } diff --git a/shell.nix b/shell.nix index e5932e0..62eef37 100644 --- a/shell.nix +++ b/shell.nix @@ -12,6 +12,6 @@ mkShell { stylish-haskell cabal2nix haskellPackages.cabal-install - (haskellPackages.ghcWithPackages (_: buuka.buildInputs ++ buuka.propagatedBuildInputs)) + (haskellPackages.ghcWithHoogle (_: buuka.buildInputs ++ buuka.propagatedBuildInputs)) ]; } diff --git a/src/Database/Migrations.hs b/src/Database/Migrations.hs new file mode 100644 index 0000000..ea8ff20 --- /dev/null +++ b/src/Database/Migrations.hs @@ -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 diff --git a/test/MyLibTest.hs b/test/MyLibTest.hs index 3e2059e..7a30e62 100644 --- a/test/MyLibTest.hs +++ b/test/MyLibTest.hs @@ -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 diff --git a/test/Test/Database/Migrations.hs b/test/Test/Database/Migrations.hs new file mode 100644 index 0000000..548da89 --- /dev/null +++ b/test/Test/Database/Migrations.hs @@ -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 + ]