{-# LANGUAGE MultiParamTypeClasses #-}
module Database.Schema.Migrations.Store
( MigrationStore(..)
, MapValidationError(..)
, StoreData(..)
, MigrationMap
, loadMigrations
, storeMigrations
, storeLookup
, depGraphFromMapping
, validateMigrationMap
, validateSingleMigration
, leafMigrations
)
where
import Data.Text ( Text )
import Data.Maybe ( isJust )
import Control.Monad ( mzero )
import Control.Applicative ( (<$>) )
import qualified Data.Map as Map
import Data.Graph.Inductive.Graph ( labNodes, indeg )
import Database.Schema.Migrations.Migration
( Migration(..)
)
import Database.Schema.Migrations.Dependencies
( DependencyGraph(..)
, mkDepGraph
, depsOf
)
type MigrationMap = Map.Map Text Migration
data StoreData = StoreData { StoreData -> MigrationMap
storeDataMapping :: MigrationMap
, StoreData -> DependencyGraph Migration
storeDataGraph :: DependencyGraph Migration
}
data MigrationStore =
MigrationStore { MigrationStore -> Text -> IO (Either String Migration)
loadMigration :: Text -> IO (Either String Migration)
, MigrationStore -> Migration -> IO ()
saveMigration :: Migration -> IO ()
, MigrationStore -> IO [Text]
getMigrations :: IO [Text]
, MigrationStore -> Text -> IO String
fullMigrationName :: Text -> IO FilePath
}
data MapValidationError = DependencyReferenceError Text Text
| DependencyGraphError String
| InvalidMigration String
deriving (MapValidationError -> MapValidationError -> Bool
(MapValidationError -> MapValidationError -> Bool)
-> (MapValidationError -> MapValidationError -> Bool)
-> Eq MapValidationError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: MapValidationError -> MapValidationError -> Bool
$c/= :: MapValidationError -> MapValidationError -> Bool
== :: MapValidationError -> MapValidationError -> Bool
$c== :: MapValidationError -> MapValidationError -> Bool
Eq)
instance Show MapValidationError where
show :: MapValidationError -> String
show (DependencyReferenceError Text
from Text
to) =
String
"Migration " String -> ShowS
forall a. [a] -> [a] -> [a]
++ (Text -> String
forall a. Show a => a -> String
show Text
from) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" references nonexistent dependency " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> String
forall a. Show a => a -> String
show Text
to
show (DependencyGraphError String
msg) =
String
"There was an error constructing the dependency graph: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
msg
show (InvalidMigration String
msg) =
String
"There was an error loading a migration: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
msg
storeMigrations :: StoreData -> [Migration]
storeMigrations :: StoreData -> [Migration]
storeMigrations StoreData
storeData =
MigrationMap -> [Migration]
forall k a. Map k a -> [a]
Map.elems (MigrationMap -> [Migration]) -> MigrationMap -> [Migration]
forall a b. (a -> b) -> a -> b
$ StoreData -> MigrationMap
storeDataMapping StoreData
storeData
storeLookup :: StoreData -> Text -> Maybe Migration
storeLookup :: StoreData -> Text -> Maybe Migration
storeLookup StoreData
storeData Text
migrationName =
Text -> MigrationMap -> Maybe Migration
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
migrationName (MigrationMap -> Maybe Migration)
-> MigrationMap -> Maybe Migration
forall a b. (a -> b) -> a -> b
$ StoreData -> MigrationMap
storeDataMapping StoreData
storeData
loadMigrations :: MigrationStore -> IO (Either [MapValidationError] StoreData)
loadMigrations :: MigrationStore -> IO (Either [MapValidationError] StoreData)
loadMigrations MigrationStore
store = do
[Text]
migrations <- MigrationStore -> IO [Text]
getMigrations MigrationStore
store
[Either String Migration]
loadedWithErrors <- (Text -> IO (Either String Migration))
-> [Text] -> IO [Either String Migration]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\Text
name -> MigrationStore -> Text -> IO (Either String Migration)
loadMigration MigrationStore
store Text
name) [Text]
migrations
let mMap :: MigrationMap
mMap = [(Text, Migration)] -> MigrationMap
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Text, Migration)] -> MigrationMap)
-> [(Text, Migration)] -> MigrationMap
forall a b. (a -> b) -> a -> b
$ [ (Migration -> Text
mId Migration
e, Migration
e) | Migration
e <- [Migration]
loaded ]
validationErrors :: [MapValidationError]
validationErrors = MigrationMap -> [MapValidationError]
validateMigrationMap MigrationMap
mMap
([Migration]
loaded, [String]
loadErrors) = [Either String Migration]
-> ([Migration], [String]) -> ([Migration], [String])
forall a a. [Either a a] -> ([a], [a]) -> ([a], [a])
sortResults [Either String Migration]
loadedWithErrors ([], [])
allErrors :: [MapValidationError]
allErrors = [MapValidationError]
validationErrors [MapValidationError]
-> [MapValidationError] -> [MapValidationError]
forall a. [a] -> [a] -> [a]
++ (String -> MapValidationError
InvalidMigration (String -> MapValidationError) -> [String] -> [MapValidationError]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String]
loadErrors)
sortResults :: [Either a a] -> ([a], [a]) -> ([a], [a])
sortResults [] ([a], [a])
v = ([a], [a])
v
sortResults (Left a
e:[Either a a]
rest) ([a]
ms, [a]
es) = [Either a a] -> ([a], [a]) -> ([a], [a])
sortResults [Either a a]
rest ([a]
ms, a
ea -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
es)
sortResults (Right a
m:[Either a a]
rest) ([a]
ms, [a]
es) = [Either a a] -> ([a], [a]) -> ([a], [a])
sortResults [Either a a]
rest (a
ma -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
ms, [a]
es)
case [MapValidationError] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [MapValidationError]
allErrors of
Bool
False -> Either [MapValidationError] StoreData
-> IO (Either [MapValidationError] StoreData)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either [MapValidationError] StoreData
-> IO (Either [MapValidationError] StoreData))
-> Either [MapValidationError] StoreData
-> IO (Either [MapValidationError] StoreData)
forall a b. (a -> b) -> a -> b
$ [MapValidationError] -> Either [MapValidationError] StoreData
forall a b. a -> Either a b
Left [MapValidationError]
allErrors
Bool
True -> do
case MigrationMap -> Either String (DependencyGraph Migration)
depGraphFromMapping MigrationMap
mMap of
Left String
e -> Either [MapValidationError] StoreData
-> IO (Either [MapValidationError] StoreData)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either [MapValidationError] StoreData
-> IO (Either [MapValidationError] StoreData))
-> Either [MapValidationError] StoreData
-> IO (Either [MapValidationError] StoreData)
forall a b. (a -> b) -> a -> b
$ [MapValidationError] -> Either [MapValidationError] StoreData
forall a b. a -> Either a b
Left [String -> MapValidationError
DependencyGraphError String
e]
Right DependencyGraph Migration
gr -> Either [MapValidationError] StoreData
-> IO (Either [MapValidationError] StoreData)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either [MapValidationError] StoreData
-> IO (Either [MapValidationError] StoreData))
-> Either [MapValidationError] StoreData
-> IO (Either [MapValidationError] StoreData)
forall a b. (a -> b) -> a -> b
$ StoreData -> Either [MapValidationError] StoreData
forall a b. b -> Either a b
Right StoreData :: MigrationMap -> DependencyGraph Migration -> StoreData
StoreData { storeDataMapping :: MigrationMap
storeDataMapping = MigrationMap
mMap
, storeDataGraph :: DependencyGraph Migration
storeDataGraph = DependencyGraph Migration
gr
}
validateMigrationMap :: MigrationMap -> [MapValidationError]
validateMigrationMap :: MigrationMap -> [MapValidationError]
validateMigrationMap MigrationMap
mMap = do
MigrationMap -> Migration -> [MapValidationError]
validateSingleMigration MigrationMap
mMap (Migration -> [MapValidationError])
-> [Migration] -> [MapValidationError]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (Text, Migration) -> Migration
forall a b. (a, b) -> b
snd ((Text, Migration) -> Migration)
-> [(Text, Migration)] -> [Migration]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MigrationMap -> [(Text, Migration)]
forall k a. Map k a -> [(k, a)]
Map.toList MigrationMap
mMap
validateSingleMigration :: MigrationMap -> Migration -> [MapValidationError]
validateSingleMigration :: MigrationMap -> Migration -> [MapValidationError]
validateSingleMigration MigrationMap
mMap Migration
m = do
Text
depId <- Migration -> [Text]
forall a. Dependable a => a -> [Text]
depsOf Migration
m
if Maybe Migration -> Bool
forall a. Maybe a -> Bool
isJust (Maybe Migration -> Bool) -> Maybe Migration -> Bool
forall a b. (a -> b) -> a -> b
$ Text -> MigrationMap -> Maybe Migration
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
depId MigrationMap
mMap then
[MapValidationError]
forall (m :: * -> *) a. MonadPlus m => m a
mzero else
MapValidationError -> [MapValidationError]
forall (m :: * -> *) a. Monad m => a -> m a
return (MapValidationError -> [MapValidationError])
-> MapValidationError -> [MapValidationError]
forall a b. (a -> b) -> a -> b
$ Text -> Text -> MapValidationError
DependencyReferenceError (Migration -> Text
mId Migration
m) Text
depId
depGraphFromMapping :: MigrationMap -> Either String (DependencyGraph Migration)
depGraphFromMapping :: MigrationMap -> Either String (DependencyGraph Migration)
depGraphFromMapping MigrationMap
mapping = [Migration] -> Either String (DependencyGraph Migration)
forall a. Dependable a => [a] -> Either String (DependencyGraph a)
mkDepGraph ([Migration] -> Either String (DependencyGraph Migration))
-> [Migration] -> Either String (DependencyGraph Migration)
forall a b. (a -> b) -> a -> b
$ MigrationMap -> [Migration]
forall k a. Map k a -> [a]
Map.elems MigrationMap
mapping
leafMigrations :: StoreData -> [Text]
leafMigrations :: StoreData -> [Text]
leafMigrations StoreData
s = [Text
l | (Int
n, Text
l) <- Gr Text Text -> [(Int, Text)]
forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> [LNode a]
labNodes Gr Text Text
g, Gr Text Text -> Int -> Int
forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> Int -> Int
indeg Gr Text Text
g Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0]
where g :: Gr Text Text
g = DependencyGraph Migration -> Gr Text Text
forall a. DependencyGraph a -> Gr Text Text
depGraph (DependencyGraph Migration -> Gr Text Text)
-> DependencyGraph Migration -> Gr Text Text
forall a b. (a -> b) -> a -> b
$ StoreData -> DependencyGraph Migration
storeDataGraph StoreData
s