Test the migrations

buuka.cabal

@@ -15,12 +15,28 @@ maintainer:          mats.rauhala@iki.fi
 category:            Web
 extra-source-files:  CHANGELOG.md
 
-library
+common common-stanza
-  exposed-modules:     MyLib
-  -- other-modules:
-  -- other-extensions:
   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
+  build-depends:       buuka
-                     , buuka
                      , hedgehog
+                     , hedgehog-corpus
                      , tasty-hedgehog
                      , tasty
+                     , text
+                     , aeson

default.nix

@@ -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 {
   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;
 }

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))
   ];
 }

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

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

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