Test the migrations

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