diff --git a/Database/Persist/GenericSql.hs b/Database/Persist/GenericSql.hs --- a/Database/Persist/GenericSql.hs +++ b/Database/Persist/GenericSql.hs @@ -252,116 +252,6 @@ dummyFromKey :: KeyBackend R.SqlBackend v -> v dummyFromKey _ = error "dummyFromKey" -{- FIXME -<<<<<<< HEAD - -type Sql = Text - --- Bool indicates if the Sql is safe -type CautiousMigration = [(Bool, Sql)] -allSql :: CautiousMigration -> [Sql] -allSql = map snd -unsafeSql :: CautiousMigration -> [Sql] -unsafeSql = allSql . filter fst -safeSql :: CautiousMigration -> [Sql] -safeSql = allSql . filter (not . fst) - -type Migration m = WriterT [Text] (WriterT CautiousMigration m) () - -parseMigration :: Monad m => Migration m -> m (Either [Text] CautiousMigration) -parseMigration = - liftM go . runWriterT . execWriterT - where - go ([], sql) = Right sql - go (errs, _) = Left errs - --- like parseMigration, but call error or return the CautiousMigration -parseMigration' :: Monad m => Migration m -> m (CautiousMigration) -parseMigration' m = do - x <- parseMigration m - case x of - Left errs -> error $ unpack $ unlines errs - Right sql -> return sql - -printMigration :: (MBCIO m, MonadIO m) => Migration (SqlPersist m) -> SqlPersist m () -printMigration m = do - mig <- parseMigration' m - mapM_ (liftIO . Data.Text.IO.putStrLn . flip snoc ';') (allSql mig) - -getMigration :: (MBCIO m, MonadIO m) => Migration (SqlPersist m) -> SqlPersist m [Sql] -getMigration m = do - mig <- parseMigration' m - return $ allSql mig - -runMigration :: (MonadIO m, MBCIO m) - => Migration (SqlPersist m) - -> SqlPersist m () -runMigration m = runMigration' m False >> return () - --- | Same as 'runMigration', but returns a list of the SQL commands executed --- instead of printing them to stderr. -runMigrationSilent :: (MBCIO m, MonadIO m) - => Migration (SqlPersist m) - -> SqlPersist m [Text] -runMigrationSilent m = runMigration' m True - -runMigration' - :: (MBCIO m, MonadIO m) - => Migration (SqlPersist m) - -> Bool -- ^ is silent? - -> SqlPersist m [Text] -runMigration' m silent = do - mig <- parseMigration' m - case unsafeSql mig of - [] -> mapM (executeMigrate silent) $ safeSql mig - errs -> error $ unpack $ concat - [ "\n\nDatabase migration: manual intervention required.\n" - , "The following actions are considered unsafe:\n\n" - , unlines $ map (\s -> " " ++ s ++ ";") $ errs - ] - -runMigrationUnsafe :: (MBCIO m, MonadIO m) - => Migration (SqlPersist m) - -> SqlPersist m () -runMigrationUnsafe m = do - mig <- parseMigration' m - mapM_ (executeMigrate False) $ allSql mig - -executeMigrate :: MonadIO m => Bool -> Text -> SqlPersist m Text -executeMigrate silent s = do - unless silent $ liftIO $ hPutStrLn stderr $ "Migrating: " ++ s - execute' s [] - return s - -migrate :: (MonadIO m, MBCIO m, PersistEntity val) - => [EntityDef] - -> val - -> Migration (SqlPersist m) -migrate allDefs val = do - conn <- lift $ lift $ SqlPersist ask - let getter = R.getStmt' conn - res <- liftIO $ migrateSql conn allDefs getter val - either tell (lift . tell) res - -updatePersistValue :: Update v -> PersistValue -updatePersistValue (Update _ v _) = toPersistValue v - --- | Perform a database commit. -commit :: MonadIO m => SqlPersist m () -commit = do - conn <- SqlPersist ask - let getter = R.getStmt' conn - liftIO $ commitC conn getter >> begin conn getter - --- | Perform a database rollback. -rollback :: MonadIO m => SqlPersist m () -rollback = do - conn <- SqlPersist ask - let getter = R.getStmt' conn - liftIO $ rollbackC conn getter >> begin conn getter -======= --} - dummyFromUnique :: Unique v -> v dummyFromUnique _ = error "dummyFromUnique" diff --git a/Database/Persist/GenericSql/Migration.hs b/Database/Persist/GenericSql/Migration.hs --- a/Database/Persist/GenericSql/Migration.hs +++ b/Database/Persist/GenericSql/Migration.hs @@ -36,6 +36,9 @@ import qualified Data.Text.IO import System.IO import Control.Monad.Logger (MonadLogger) +import System.IO.Silently (hSilence) +import System.IO (stderr) +import Control.Monad.Trans.Control (liftBaseOp_) execute' :: (MonadIO m, MonadLogger m) => Text -> [PersistValue] -> SqlPersist m () execute' = R.execute @@ -88,7 +91,7 @@ runMigrationSilent :: (MBCIO m, MonadIO m, MonadLogger m) => Migration (SqlPersist m) -> SqlPersist m [Text] -runMigrationSilent m = runMigration' m True +runMigrationSilent m = liftBaseOp_ (hSilence [stderr]) $ runMigration' m True runMigration' :: (MBCIO m, MonadIO m, MonadLogger m) diff --git a/Database/Persist/TH/Library.hs b/Database/Persist/TH/Library.hs --- a/Database/Persist/TH/Library.hs +++ b/Database/Persist/TH/Library.hs @@ -1,5 +1,4 @@ {-# LANGUAGE CPP #-} -#include "cabal_macros.h" module Database.Persist.TH.Library ( apE ) where diff --git a/persistent.cabal b/persistent.cabal --- a/persistent.cabal +++ b/persistent.cabal @@ -1,5 +1,5 @@ name: persistent -version: 1.1.0 +version: 1.1.0.1 license: MIT license-file: LICENSE author: Michael Snoyman @@ -11,17 +11,11 @@ cabal-version: >= 1.8 build-type: Simple homepage: http://www.yesodweb.com/book/persistent -extra-source-files: - test/main.hs flag nooverlap default: False description: test out our assumption that OverlappingInstances is just for String -flag blaze_html_0_5 - description: use blaze-html 0.5 and blaze-markup 0.5 - default: True - library if flag(nooverlap) cpp-options: -DNO_OVERLAP @@ -32,22 +26,23 @@ , time >= 1.1.4 , text >= 0.8 , containers >= 0.2 - , conduit >= 0.5.5 && < 0.6 - , resourcet >= 0.4 && < 0.5 - , monad-control >= 0.3 && < 0.4 + , conduit >= 0.5.5 + , resourcet >= 0.4 + , monad-control >= 0.3 , lifted-base >= 0.1 - , pool-conduit >= 0.1.1 && < 0.2 - , path-pieces >= 0.1 && < 0.2 - , aeson >= 0.5 && < 0.7 - , monad-logger >= 0.2.3 && < 0.3 + , pool-conduit >= 0.1.1 + , path-pieces >= 0.1 + , aeson >= 0.5 + , monad-logger >= 0.2.3 , transformers-base , base64-bytestring , unordered-containers , vector , attoparsec , template-haskell - , blaze-html >= 0.5 && < 0.6 - , blaze-markup >= 0.5.1 && < 0.6 + , blaze-html >= 0.5 + , blaze-markup >= 0.5.1 + , silently exposed-modules: Database.Persist Database.Persist.EntityDef