{-# LANGUAGE MultiParamTypeClasses #-}
-- |This module provides an abstraction for a /migration store/, a
-- facility in which 'Migration's can be stored and from which they
-- can be loaded.  This module also provides functions for taking
-- 'Migration's from a store and converting them into the appropriate
-- intermediate types for use with the rest of this library.
module Database.Schema.Migrations.Store
    ( MigrationStore(..)
    , MapValidationError(..)
    , StoreData(..)
    , MigrationMap

    -- * High-level Store API
    , loadMigrations
    , storeMigrations
    , storeLookup

    -- * Miscellaneous Functions
    , 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
    )

-- |A mapping from migration name to 'Migration'.  This is exported
-- for testing purposes, but you'll want to interface with this
-- through the encapsulating 'StoreData' type.
type MigrationMap = Map.Map Text Migration

data StoreData = StoreData { StoreData -> MigrationMap
storeDataMapping :: MigrationMap
                           , StoreData -> DependencyGraph Migration
storeDataGraph :: DependencyGraph Migration
                           }

-- |The type of migration storage facilities. A MigrationStore is a
-- facility in which new migrations can be created, and from which
-- existing migrations can be loaded.
data MigrationStore =
    MigrationStore { MigrationStore -> Text -> IO (Either String Migration)
loadMigration :: Text -> IO (Either String Migration)
                   -- ^ Load a migration from the store.

                   , MigrationStore -> Migration -> IO ()
saveMigration :: Migration -> IO ()
                   -- ^ Save a migration to the store.

                   , MigrationStore -> IO [Text]
getMigrations :: IO [Text]
                   -- ^ Return a list of all available migrations'
                   -- names.

                   , MigrationStore -> Text -> IO String
fullMigrationName :: Text -> IO FilePath
                   -- ^ Return the full representation of a given
                   -- migration name; mostly for filesystem stores,
                   -- where the full representation includes the store
                   -- path.
                   }

-- |A type for types of validation errors for migration maps.
data MapValidationError = DependencyReferenceError Text Text
                          -- ^ A migration claims a dependency on a
                          -- migration that does not exist.
                        | DependencyGraphError String
                          -- ^ An error was encountered when
                          -- constructing the dependency graph for
                          -- this store.
                        | InvalidMigration String
                          -- ^ The specified migration is invalid.
                          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

-- |A convenience function for extracting the list of 'Migration's
-- extant in the specified 'StoreData'.
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

-- |A convenience function for looking up a 'Migration' by name in the
-- specified '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

-- |Load migrations from the specified 'MigrationStore', validate the
-- loaded migrations, and return errors or a 'MigrationMap' on
-- success.  Generally speaking, this will be the first thing you
-- should call once you have constructed a 'MigrationStore'.
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
      -- Construct a dependency graph and, if that succeeds, return
      -- StoreData.
      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
                                             }

-- |Validate a migration map.  Returns zero or more validation errors.
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

-- |Validate a single migration.  Looks up the migration's
-- dependencies in the specified 'MigrationMap' and returns a
-- 'MapValidationError' for each one that does not exist in the map.
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

-- |Create a 'DependencyGraph' from a 'MigrationMap'; returns Left if
-- the dependency graph cannot be constructed (e.g., due to a
-- dependency cycle) or Right on success.  Generally speaking, you
-- won't want to use this directly; use 'loadMigrations' instead.
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

-- |Finds migrations that no other migration depends on (effectively finds all
-- vertices with in-degree equal to zero).
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