persistent 0.2.1 → 0.2.2
raw patch · 6 files changed
+80/−42 lines, 6 filesdep +stm
Dependencies added: stm
Files
- Database/Persist.hs +1/−0
- Database/Persist/Base.hs +21/−0
- Database/Persist/GenericSql.hs +22/−7
- Database/Persist/Pool.hs +22/−31
- Database/Persist/Quasi.hs +11/−2
- persistent.cabal +3/−2
Database/Persist.hs view
@@ -6,6 +6,7 @@ , persist , selectList , insertBy+ , insertBy' , checkUnique ) where
Database/Persist/Base.hs view
@@ -24,6 +24,7 @@ , SomePersistField (..) , selectList , insertBy+ , insertBy' , checkUnique , DeleteCascade (..) , deleteCascadeWhere@@ -45,6 +46,7 @@ import Data.Enumerator import qualified Control.Exception as E import Data.Bits (bitSize)+import Control.Monad (when, liftM) -- | A raw value which can be stored in any backend and can be marshalled to -- and from a 'PersistField'.@@ -324,8 +326,12 @@ -- | The total number of records fulfilling the given criterion. count :: PersistEntity val => [Filter val] -> m Int +{-# DEPRECATED insertBy "Please use insertBy' instead." #-} -- | Try to insert the given entity; if another entity exists with the same -- unique key, return that entity; otherwise, return the newly created entity.+--+-- This function is deprecated in favor of insertBy'. In the next major+-- version, this function will be replaced with that one. insertBy :: (PersistEntity val, PersistBackend m) => val -> m (Key val, val) insertBy val = go $ persistUniqueKeys val@@ -338,6 +344,21 @@ case y of Nothing -> go xs Just z -> return z++-- | This is an improved version of 'insertBy', indicating whether a new value+-- was inserted. If a duplicate exists in the database, it is returned as+-- 'Left'. Otherwise, the new 'Key' is returned as 'Right'.+insertBy' :: (PersistEntity v, PersistBackend m)+ => v -> m (Either (Key v, v) (Key v))+insertBy' val =+ go $ persistUniqueKeys val+ where+ go [] = Right `liftM` insert val+ go (x:xs) = do+ y <- getBy x+ case y of+ Nothing -> go xs+ Just z -> return $ Left z -- | Check whether there are any conflicts for unique keys with this entity and -- existing entities in the database.
Database/Persist/GenericSql.hs view
@@ -15,6 +15,7 @@ , printMigration , getMigration , runMigration+ , runMigrationSilent , runMigrationUnsafe , migrate ) where@@ -31,7 +32,7 @@ import qualified Database.Persist.GenericSql.Raw as R import Database.Persist.GenericSql.Raw (SqlPersist (..)) import "MonadCatchIO-transformers" Control.Monad.CatchIO-import Control.Monad (liftM)+import Control.Monad (liftM, unless) import Data.Enumerator hiding (map, length) type ConnectionPool = Pool Connection@@ -450,10 +451,23 @@ runMigration :: MonadCatchIO m => Migration (SqlPersist m) -> SqlPersist m ()-runMigration m = do+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 :: MonadCatchIO m+ => Migration (SqlPersist m)+ -> SqlPersist m [String]+runMigrationSilent m = runMigration' m True++runMigration' :: MonadCatchIO m+ => Migration (SqlPersist m)+ -> Bool -- ^ is silent?+ -> SqlPersist m [String]+runMigration' m silent = do mig <- parseMigration' m case unsafeSql mig of- [] -> mapM_ executeMigrate $ safeSql mig+ [] -> mapM (executeMigrate silent) $ safeSql mig errs -> error $ concat [ "\n\nDatabase migration: manual intervention required.\n" , "The following actions are considered unsafe:\n\n"@@ -465,12 +479,13 @@ -> SqlPersist m () runMigrationUnsafe m = do mig <- parseMigration' m- mapM_ executeMigrate $ allSql mig+ mapM_ (executeMigrate False) $ allSql mig -executeMigrate :: MonadIO m => String -> SqlPersist m ()-executeMigrate s = do- liftIO $ hPutStrLn stderr $ "Migrating: " ++ s+executeMigrate :: MonadIO m => Bool -> String -> SqlPersist m String+executeMigrate silent s = do+ unless silent $ liftIO $ hPutStrLn stderr $ "Migrating: " ++ s execute' s []+ return s migrate :: (MonadCatchIO m, PersistEntity val) => val
Database/Persist/Pool.hs view
@@ -7,7 +7,9 @@ , Pool ) where -import Control.Concurrent.MVar hiding (modifyMVar, modifyMVar_)+import Control.Concurrent.STM (atomically)+import Control.Concurrent.STM.TVar+ (TVar, newTVarIO, readTVar, writeTVar, readTVarIO) import Control.Exception (throwIO) import Data.Typeable import "MonadCatchIO-transformers" Control.Monad.CatchIO@@ -21,19 +23,17 @@ data Pool a = Pool { poolMax :: Int- , poolData :: MVar (PoolData a)+ , poolData :: TVar (PoolData a) , poolMake :: IO a } createPool :: MonadCatchIO m => IO a -> (a -> IO ()) -> Int -> (Pool a -> m b) -> m b createPool mk fr mx f = do- pd <- liftIO $ newMVar $ PoolData [] 0- finally (f $ Pool mx pd mk) $ do- mress <- liftIO $ tryTakeMVar pd- case mress of- Nothing -> return ()- Just (PoolData ress _) -> liftIO $ mapM_ fr ress+ pd <- liftIO $ newTVarIO $ PoolData [] 0+ finally (f $ Pool mx pd mk) $ liftIO $ do+ PoolData ress _ <- readTVarIO pd+ mapM_ fr ress data PoolExhaustedException = PoolExhaustedException deriving (Show, Typeable)@@ -48,10 +48,14 @@ withPool :: MonadCatchIO m => Pool a -> (a -> m b) -> m (Maybe b) withPool p f = block $ do- eres <- modifyMVar (poolData p) $ \pd -> do- case poolAvail pd of- (x:xs) -> return (pd { poolAvail = xs }, Right x)- [] -> return (pd, Left $ poolCreated pd)+ eres <- liftIO $ atomically $ do+ pd <- readTVar $ poolData p+ let (pd', eres) =+ case poolAvail pd of+ (x:xs) -> (pd { poolAvail = xs }, Right x)+ [] -> (pd, Left $ poolCreated pd)+ writeTVar (poolData p) pd'+ return eres case eres of Left pc -> if pc >= poolMax p@@ -64,22 +68,9 @@ (liftM Just $ unblock $ f res) (insertResource 0 res) where- insertResource i x = modifyMVar_ (poolData p) $ \pd ->- return pd { poolAvail = x : poolAvail pd- , poolCreated = i + poolCreated pd- }--modifyMVar :: MonadCatchIO m => MVar a -> (a -> m (a,b)) -> m b-modifyMVar m io =- block $ do- a <- liftIO $ takeMVar m- (a',b) <- unblock (io a) `onException` liftIO (putMVar m a)- liftIO $ putMVar m a'- return b--modifyMVar_ :: MonadCatchIO m => MVar a -> (a -> m a) -> m ()-modifyMVar_ m io =- block $ do- a <- liftIO $ takeMVar m- a' <- unblock (io a) `onException` liftIO (putMVar m a)- liftIO $ putMVar m a'+ insertResource i x = liftIO $ atomically $ do+ pd <- readTVar $ poolData p+ writeTVar (poolData p)+ pd { poolAvail = x : poolAvail pd+ , poolCreated = i + poolCreated pd+ }
Database/Persist/Quasi.hs view
@@ -16,8 +16,17 @@ } parse_ :: String -> [EntityDef]-parse_ = map parse' . nest . map words' . filter (not . null)- . map killCarriage . lines+parse_ = map parse' . nest . map words'+ . removeLeadingSpaces+ . map killCarriage+ . lines++removeLeadingSpaces :: [String] -> [String]+removeLeadingSpaces x =+ let y = filter (not . null) x+ in if all isSpace (map head y)+ then removeLeadingSpaces (map tail y)+ else y killCarriage :: String -> String killCarriage "" = ""
persistent.cabal view
@@ -1,5 +1,5 @@ name: persistent-version: 0.2.1+version: 0.2.2 license: BSD3 license-file: LICENSE author: Michael Snoyman <michael@snoyman.com>@@ -25,7 +25,8 @@ web-routes-quasi >= 0.6.0 && < 0.7, containers >= 0.2 && < 0.4, parsec >= 2.1 && < 4,- enumerator >= 0.4 && < 0.5+ enumerator >= 0.4 && < 0.5,+ stm >= 2.1 && < 2.2 exposed-modules: Database.Persist Database.Persist.Base Database.Persist.TH