81 lines
2.3 KiB
Haskell
81 lines
2.3 KiB
Haskell
{-# 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
|
|
}
|
|
|
|
eitherFromVersioned :: forall a. Migratable a => Versioned -> Either String a
|
|
eitherFromVersioned x =
|
|
case fromVersioned x of
|
|
Success s -> Right s
|
|
Error e -> Left e
|
|
|
|
-- | 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
|