module Database.Schema.Migrations.Filesystem
( FilesystemStore(..)
, migrationFromFile
, migrationFromPath
)
where
import Prelude hiding ( catch )
import System.Directory ( getDirectoryContents, doesFileExist )
import System.FilePath ( (</>), takeExtension, dropExtension
, takeFileName, takeBaseName )
import Control.Monad.Trans ( MonadIO, liftIO )
import Data.ByteString.Char8 ( unpack )
import Data.Typeable ( Typeable )
import Data.Time.Clock ( UTCTime )
import Data.Time ()
import qualified Data.Map as Map
import Control.Applicative ( (<$>) )
import Control.Monad ( filterM )
import Control.Exception ( IOException, Exception(..), throw, catch )
import Data.Yaml.YamlLight
import Database.Schema.Migrations.Migration
( Migration(..)
, newMigration
)
import Database.Schema.Migrations.Filesystem.Serialize
import Database.Schema.Migrations.Store
type FieldProcessor = String -> Migration -> Maybe Migration
data FilesystemStore = FSStore { storePath :: FilePath }
data FilesystemStoreError = FilesystemStoreError String
deriving (Show, Typeable)
instance Exception FilesystemStoreError
throwFS :: String -> a
throwFS = throw . FilesystemStoreError
filenameExtension :: String
filenameExtension = ".txt"
instance (MonadIO m) => MigrationStore FilesystemStore m where
fullMigrationName s name =
return $ storePath s </> name ++ filenameExtension
loadMigration s theId = do
result <- liftIO $ migrationFromFile s theId
return $ case result of
Left _ -> Nothing
Right m -> Just m
getMigrations s = do
contents <- liftIO $ getDirectoryContents $ storePath s
let migrationFilenames = [ f | f <- contents, isMigrationFilename f ]
fullPaths = [ (f, storePath s </> f) | f <- migrationFilenames ]
existing <- liftIO $ filterM (\(_, full) -> doesFileExist full) fullPaths
return [ dropExtension short | (short, _) <- existing ]
saveMigration s m = do
filename <- fullMigrationName s $ mId m
liftIO $ writeFile filename $ serializeMigration m
isMigrationFilename :: FilePath -> Bool
isMigrationFilename path = takeExtension path == filenameExtension
migrationFromFile :: FilesystemStore -> String -> IO (Either String Migration)
migrationFromFile store name =
fullMigrationName store name >>= migrationFromPath
migrationFromPath :: FilePath -> IO (Either String Migration)
migrationFromPath path = do
let name = takeBaseName $ takeFileName path
(Right <$> process name) `catch` (\(FilesystemStoreError s) -> return $ Left s)
where
process name = do
yaml <- parseYamlFile path `catch` (\(e::IOException) -> throwFS $ show e)
let fields = getFields yaml
missing = missingFields fields
case length missing of
0 -> do
newM <- newMigration ""
case migrationFromFields newM fields of
Nothing -> throwFS $ "Error in " ++ (show path) ++ ": unrecognized field found"
Just m -> return $ m { mId = name }
_ -> throwFS $ "Error in " ++ (show path) ++ ": missing required field(s): " ++ (show missing)
getFields :: YamlLight -> [(String, String)]
getFields (YMap mp) = map toPair $ Map.assocs mp
where
toPair (YStr k, YStr v) = (unpack k, unpack v)
toPair (k, v) = throwFS $ "Error in YAML input; expected string key and string value, got " ++ (show (k, v))
getFields _ = throwFS "Error in YAML input; expected mapping"
missingFields :: [(String, String)] -> [String]
missingFields fs =
[ k | k <- requiredFields, not (k `elem` inputStrings) ]
where
inputStrings = map fst fs
migrationFromFields :: Migration -> [(String, String)] -> Maybe Migration
migrationFromFields m [] = Just m
migrationFromFields m ((name, value):rest) = do
processor <- lookup name fieldProcessors
newM <- processor value m
migrationFromFields newM rest
requiredFields :: [String]
requiredFields = [ "Created"
, "Apply"
, "Depends"
]
fieldProcessors :: [(String, FieldProcessor)]
fieldProcessors = [ ("Created", setTimestamp )
, ("Description", setDescription )
, ("Apply", setApply )
, ("Revert", setRevert )
, ("Depends", setDepends )
]
setTimestamp :: FieldProcessor
setTimestamp value m = do
ts <- case readTimestamp value of
[(t, _)] -> return t
_ -> fail "expected one valid parse"
return $ m { mTimestamp = ts }
readTimestamp :: String -> [(UTCTime, String)]
readTimestamp = reads
setDescription :: FieldProcessor
setDescription desc m = Just $ m { mDesc = Just desc }
setApply :: FieldProcessor
setApply apply m = Just $ m { mApply = apply }
setRevert :: FieldProcessor
setRevert revert m = Just $ m { mRevert = Just revert }
setDepends :: FieldProcessor
setDepends depString m = Just $ m { mDeps = words depString }