module Database.Schema.Migrations.Store
( MigrationStore(..)
, MapValidationError(..)
, StoreData(..)
, MigrationMap
, loadMigrations
, storeMigrations
, storeLookup
, depGraphFromMapping
, validateMigrationMap
, validateSingleMigration
, leafMigrations
)
where
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 String Migration
data StoreData = StoreData { storeDataMapping :: MigrationMap
, storeDataGraph :: DependencyGraph Migration
}
data MigrationStore =
MigrationStore { loadMigration :: String -> IO (Either String Migration)
, saveMigration :: Migration -> IO ()
, getMigrations :: IO [String]
, fullMigrationName :: String -> IO String
}
data MapValidationError = DependencyReferenceError String String
| DependencyGraphError String
| InvalidMigration String
deriving (Eq)
instance Show MapValidationError where
show (DependencyReferenceError from to) =
"Migration " ++ (show from) ++ " references nonexistent dependency " ++ show to
show (DependencyGraphError msg) =
"There was an error constructing the dependency graph: " ++ msg
show (InvalidMigration msg) =
"There was an error loading a migration: " ++ msg
storeMigrations :: StoreData -> [Migration]
storeMigrations storeData =
Map.elems $ storeDataMapping storeData
storeLookup :: StoreData -> String -> Maybe Migration
storeLookup storeData migrationName =
Map.lookup migrationName $ storeDataMapping storeData
loadMigrations :: MigrationStore -> IO (Either [MapValidationError] StoreData)
loadMigrations store = do
migrations <- getMigrations store
loadedWithErrors <- mapM (\name -> loadMigration store name) migrations
let mMap = Map.fromList $ [ (mId e, e) | e <- loaded ]
validationErrors = validateMigrationMap mMap
(loaded, loadErrors) = sortResults loadedWithErrors ([], [])
allErrors = validationErrors ++ (InvalidMigration <$> loadErrors)
sortResults [] v = v
sortResults (Left e:rest) (ms, es) = sortResults rest (ms, e:es)
sortResults (Right m:rest) (ms, es) = sortResults rest (m:ms, es)
case null allErrors of
False -> return $ Left allErrors
True -> do
case depGraphFromMapping mMap of
Left e -> return $ Left [DependencyGraphError e]
Right gr -> return $ Right StoreData { storeDataMapping = mMap
, storeDataGraph = gr
}
validateMigrationMap :: MigrationMap -> [MapValidationError]
validateMigrationMap mMap = do
validateSingleMigration mMap =<< snd <$> Map.toList mMap
validateSingleMigration :: MigrationMap -> Migration -> [MapValidationError]
validateSingleMigration mMap m = do
depId <- depsOf m
if isJust $ Map.lookup depId mMap then
mzero else
return $ DependencyReferenceError (mId m) depId
depGraphFromMapping :: MigrationMap -> Either String (DependencyGraph Migration)
depGraphFromMapping mapping = mkDepGraph $ Map.elems mapping
leafMigrations :: StoreData -> [String]
leafMigrations s = [l | (n, l) <- labNodes g, indeg g n == 0]
where g = depGraph $ storeDataGraph s