persistent 0.2.4.1 → 0.3.0
raw patch · 8 files changed
+112/−108 lines, 8 filesdep +neitherdep −MonadCatchIO-transformersdep −utf8-stringdep ~text
Dependencies added: neither
Dependencies removed: MonadCatchIO-transformers, utf8-string
Dependency ranges changed: text
Files
- Database/Persist.hs +0/−1
- Database/Persist/Base.hs +14/−29
- Database/Persist/GenericSql.hs +15/−20
- Database/Persist/GenericSql/Internal.hs +4/−10
- Database/Persist/GenericSql/Raw.hs +15/−4
- Database/Persist/Pool.hs +31/−39
- Database/Persist/TH.hs +29/−0
- persistent.cabal +4/−5
Database/Persist.hs view
@@ -6,7 +6,6 @@ , persist , selectList , insertBy- , insertBy' , checkUnique ) where
Database/Persist/Base.hs view
@@ -24,7 +24,6 @@ , SomePersistField (..) , selectList , insertBy- , insertBy' , checkUnique , DeleteCascade (..) , deleteCascadeWhere@@ -34,7 +33,6 @@ import Language.Haskell.TH.Syntax import Data.Time (Day, TimeOfDay, UTCTime) import Data.ByteString.Char8 (ByteString, unpack)-import qualified Data.ByteString.UTF8 as BSU import Control.Applicative import Data.Typeable (Typeable) import Data.Int (Int8, Int16, Int32, Int64)@@ -48,6 +46,9 @@ import Data.Bits (bitSize) import Control.Monad (liftM) +import qualified Data.Text.Encoding as T+import qualified Data.Text.Encoding.Error as T+ -- | A raw value which can be stored in any backend and can be marshalled to -- and from a 'PersistField'. data PersistValue = PersistString String@@ -86,7 +87,8 @@ instance PersistField String where toPersistValue = PersistString fromPersistValue (PersistString s) = Right s- fromPersistValue (PersistByteString bs) = Right $ BSU.toString bs+ fromPersistValue (PersistByteString bs) =+ Right $ T.unpack $ T.decodeUtf8With T.lenientDecode bs fromPersistValue (PersistInt64 i) = Right $ show i fromPersistValue (PersistDouble d) = Right $ show d fromPersistValue (PersistDay d) = Right $ show d@@ -99,12 +101,14 @@ instance PersistField ByteString where toPersistValue = PersistByteString fromPersistValue (PersistByteString bs) = Right bs- fromPersistValue x = BSU.fromString <$> fromPersistValue x+ fromPersistValue x = T.encodeUtf8 . T.pack <$> fromPersistValue x sqlType _ = SqlBlob instance PersistField T.Text where toPersistValue = PersistString . T.unpack- fromPersistValue = fmap T.pack . fromPersistValue+ fromPersistValue (PersistByteString bs) =+ Right $ T.decodeUtf8With T.lenientDecode bs+ fromPersistValue v = fmap T.pack $ fromPersistValue v sqlType _ = SqlString instance PersistField Html where@@ -326,31 +330,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- where- go [] = do- key <- insert val- return (key, val)- go (x:xs) = do- y <- getBy x- 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)+-- | Insert a value, checking for conflicts with any unique constraints. 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 =+insertBy val = go $ persistUniqueKeys val where go [] = Right `liftM` insert val
Database/Persist/GenericSql.hs view
@@ -10,7 +10,6 @@ , Statement , runSqlConn , runSqlPool- , runSqlPoolF , Migration , parseMigration , parseMigration'@@ -34,29 +33,25 @@ import Database.Persist.GenericSql.Internal import qualified Database.Persist.GenericSql.Raw as R import Database.Persist.GenericSql.Raw (SqlPersist (..))-import "MonadCatchIO-transformers" Control.Monad.CatchIO import Control.Monad (liftM, unless)-import Data.Enumerator (Step (..), Stream (..), Iteratee (..))+import Data.Enumerator hiding (map, length) import Language.Haskell.TH.Syntax hiding (lift)+import Control.Monad.Invert (MonadInvertIO, onException)+import Control.Exception (toException) type ConnectionPool = Pool Connection -withStmt' :: MonadCatchIO m => String -> [PersistValue]+withStmt' :: MonadInvertIO m => String -> [PersistValue] -> (RowPopper (SqlPersist m) -> SqlPersist m a) -> SqlPersist m a withStmt' = R.withStmt execute' :: MonadIO m => String -> [PersistValue] -> SqlPersist m () execute' = R.execute -runSqlPool :: MonadCatchIO m => SqlPersist m a -> Pool Connection -> m a+runSqlPool :: MonadInvertIO m => SqlPersist m a -> Pool Connection -> m a runSqlPool r pconn = withPool' pconn $ runSqlConn r -runSqlPoolF :: MonadCatchIO m- => (m (Maybe b) -> m () -> m (Maybe b))- -> SqlPersist m b -> Pool Connection -> m b-runSqlPoolF finally' r pconn = withPoolF' finally' pconn $ runSqlConn r--runSqlConn :: MonadCatchIO m => SqlPersist m a -> Connection -> m a+runSqlConn :: MonadInvertIO m => SqlPersist m a -> Connection -> m a runSqlConn (SqlPersist r) conn = do let getter = R.getStmt' conn liftIO $ begin conn getter@@ -66,7 +61,7 @@ liftIO $ commit conn getter return x -instance MonadCatchIO m => PersistBackend (SqlPersist m) where+instance MonadInvertIO m => PersistBackend (SqlPersist m) where insert val = do conn <- SqlPersist ask let esql = insertSql conn (rawTableName t) (map fst3 $ tableColumns t)@@ -447,29 +442,29 @@ Left errs -> error $ unlines errs Right sql -> return sql -printMigration :: MonadCatchIO m => Migration (SqlPersist m) -> SqlPersist m ()+printMigration :: MonadInvertIO m => Migration (SqlPersist m) -> SqlPersist m () printMigration m = do mig <- parseMigration' m mapM_ (liftIO . putStrLn) (allSql mig) -getMigration :: MonadCatchIO m => Migration (SqlPersist m) -> SqlPersist m [Sql]+getMigration :: MonadInvertIO m => Migration (SqlPersist m) -> SqlPersist m [Sql] getMigration m = do mig <- parseMigration' m return $ allSql mig -runMigration :: MonadCatchIO m+runMigration :: MonadInvertIO 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 :: MonadCatchIO m+runMigrationSilent :: MonadInvertIO m => Migration (SqlPersist m) -> SqlPersist m [String] runMigrationSilent m = runMigration' m True -runMigration' :: MonadCatchIO m+runMigration' :: MonadInvertIO m => Migration (SqlPersist m) -> Bool -- ^ is silent? -> SqlPersist m [String]@@ -483,7 +478,7 @@ , unlines $ map (" " ++) $ errs ] -runMigrationUnsafe :: MonadCatchIO m+runMigrationUnsafe :: MonadInvertIO m => Migration (SqlPersist m) -> SqlPersist m () runMigrationUnsafe m = do@@ -496,7 +491,7 @@ execute' s [] return s -migrate :: (MonadCatchIO m, PersistEntity val)+migrate :: (MonadInvertIO m, PersistEntity val) => val -> Migration (SqlPersist m) migrate val = do@@ -526,7 +521,7 @@ ] where typ = ForallT [PlainTV $ mkName "m"]- [ ClassP ''MonadCatchIO [VarT $ mkName "m"]+ [ ClassP ''MonadInvertIO [VarT $ mkName "m"] ] $ ConT ''Migration `AppT` (ConT ''SqlPersist `AppT` VarT (mkName "m")) body =
Database/Persist/GenericSql/Internal.hs view
@@ -6,7 +6,6 @@ , Statement (..) , withSqlConn , withSqlPool- , withSqlPoolF , RowPopper , mkColumns , Column (..)@@ -18,7 +17,6 @@ , RawName (..) ) where -import "MonadCatchIO-transformers" Control.Monad.CatchIO import qualified Data.Map as Map import Data.IORef import Control.Monad.IO.Class@@ -26,6 +24,7 @@ import Database.Persist.Base import Data.Maybe (fromJust) import Control.Arrow+import Control.Monad.Invert (MonadInvertIO, bracket) type RowPopper m = m (Maybe [PersistValue]) @@ -47,20 +46,15 @@ { finalize :: IO () , reset :: IO () , execute :: [PersistValue] -> IO ()- , withStmt :: forall a m. MonadCatchIO m+ , withStmt :: forall a m. MonadInvertIO m => [PersistValue] -> (RowPopper m -> m a) -> m a } -withSqlPool :: MonadCatchIO m+withSqlPool :: MonadInvertIO m => IO Connection -> Int -> (Pool Connection -> m a) -> m a withSqlPool mkConn = createPool mkConn close' -withSqlPoolF :: MonadIO m- => (m a -> m () -> m a)- -> IO Connection -> Int -> (Pool Connection -> m a) -> m a-withSqlPoolF finally' mkConn = createPoolF finally' mkConn close'--withSqlConn :: MonadCatchIO m => IO Connection -> (Connection -> m a) -> m a+withSqlConn :: MonadInvertIO m => IO Connection -> (Connection -> m a) -> m a withSqlConn open = bracket (liftIO open) (liftIO . close') close' :: Connection -> IO ()
Database/Persist/GenericSql/Raw.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE PackageImports #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE TypeFamilies #-} module Database.Persist.GenericSql.Raw ( withStmt , execute@@ -17,12 +18,22 @@ import qualified Data.Map as Map import Control.Applicative (Applicative) import Control.Monad.Trans.Class (MonadTrans (..))-import "MonadCatchIO-transformers" Control.Monad.CatchIO+import Control.Monad.Invert (MonadInvertIO (..))+import Control.Monad (liftM) -newtype SqlPersist m a = SqlPersist (ReaderT Connection m a)- deriving (Monad, MonadIO, MonadCatchIO, MonadTrans, Functor, Applicative)+newtype SqlPersist m a = SqlPersist { unSqlPersist :: ReaderT Connection m a }+ deriving (Monad, MonadIO, MonadTrans, Functor, Applicative) -withStmt :: MonadCatchIO m => String -> [PersistValue]+instance MonadInvertIO m => MonadInvertIO (SqlPersist m) where+ newtype InvertedIO (SqlPersist m) a =+ InvSqlPersistIO+ { runInvSqlPersistIO :: InvertedIO (ReaderT Connection m) a+ }+ type InvertedArg (SqlPersist m) = (Connection, InvertedArg m)+ invertIO = liftM (fmap InvSqlPersistIO) . invertIO . unSqlPersist+ revertIO f = SqlPersist $ revertIO $ liftM runInvSqlPersistIO . f++withStmt :: MonadInvertIO m => String -> [PersistValue] -> (RowPopper (SqlPersist m) -> SqlPersist m a) -> SqlPersist m a withStmt sql vals pop = do stmt <- getStmt sql
Database/Persist/Pool.hs view
@@ -1,22 +1,22 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE PackageImports #-} module Database.Persist.Pool- ( createPool+ ( -- * Using pools+ createPool , withPool , withPool' , Pool- , withPoolF'- , withPoolF- , createPoolF+ -- * Diagnostics+ , PoolStats (..)+ , poolStats ) where import Control.Concurrent.STM (atomically) import Control.Concurrent.STM.TVar (TVar, newTVarIO, readTVar, writeTVar)-import Control.Exception (throwIO)+import Control.Exception (throwIO, Exception) import Data.Typeable-import "MonadCatchIO-transformers" Control.Monad.CatchIO hiding (finally)-import qualified "MonadCatchIO-transformers" Control.Monad.CatchIO as C+import qualified Control.Monad.Invert as I import Control.Monad.IO.Class import Control.Monad @@ -31,16 +31,22 @@ , poolMake :: IO a } -createPool :: MonadCatchIO m- => IO a -> (a -> IO ()) -> Int -> (Pool a -> m b) -> m b-createPool = createPoolF C.finally+data PoolStats = PoolStats+ { poolStatsMax :: Int+ , poolStatsAvailable :: Int+ , poolStatsCreated :: Int+ } -createPoolF :: MonadIO m- => (m b -> m () -> m b)- -> IO a -> (a -> IO ()) -> Int -> (Pool a -> m b) -> m b-createPoolF finally mk fr mx f = do+poolStats :: Pool a -> IO PoolStats+poolStats (Pool m td _) = do+ d <- atomically $ readTVar td+ return $ PoolStats m (length $ poolAvail d) (poolCreated d)++createPool :: (MonadIO m, I.MonadInvertIO m)+ => IO a -> (a -> IO ()) -> Int -> (Pool a -> m b) -> m b+createPool mk fr mx f = do pd <- liftIO $ newTVarIO $ PoolData [] 0- finally (f $ Pool mx pd mk) $ liftIO $ do+ I.finally (f $ Pool mx pd mk) $ liftIO $ do PoolData ress _ <- atomically $ readTVar pd mapM_ fr ress @@ -48,29 +54,16 @@ deriving (Show, Typeable) instance Exception PoolExhaustedException -withPool' :: MonadCatchIO m => Pool a -> (a -> m b) -> m b+withPool' :: (MonadIO m, I.MonadInvertIO m) => Pool a -> (a -> m b) -> m b withPool' p f = do x <- withPool p f case x of Nothing -> liftIO $ throwIO PoolExhaustedException Just x' -> return x' -withPoolF' :: MonadCatchIO m- => (m (Maybe b) -> m () -> m (Maybe b))- -> Pool a -> (a -> m b) -> m b-withPoolF' finally p f = do- x <- withPoolF finally p f- case x of- Nothing -> liftIO $ throwIO PoolExhaustedException- Just x' -> return x'--withPool :: MonadCatchIO m => Pool a -> (a -> m b) -> m (Maybe b)-withPool = withPoolF C.finally--withPoolF :: MonadCatchIO m- => (m (Maybe b) -> m () -> m (Maybe b))- -> Pool a -> (a -> m b) -> m (Maybe b)-withPoolF finally p f = block $ do+withPool :: (MonadIO m, I.MonadInvertIO m)+ => Pool a -> (a -> m b) -> m (Maybe b)+withPool p f = I.block $ do eres <- liftIO $ atomically $ do pd <- readTVar $ poolData p let (pd', eres) =@@ -83,13 +76,12 @@ Left pc -> if pc >= poolMax p then return Nothing- else do- x <- liftIO $ poolMake p- finally- (liftM Just $ unblock $ f x)- (insertResource 1 x)- Right res -> finally- (liftM Just $ unblock $ f res)+ else I.bracket+ (liftIO $ poolMake p)+ (insertResource 1)+ (liftM Just . I.unblock . f)+ Right res -> I.finally+ (liftM Just $ I.unblock $ f res) (insertResource 0 res) where insertResource i x = liftIO $ atomically $ do
Database/Persist/TH.hs view
@@ -7,6 +7,7 @@ , share2 , mkSave , mkDeleteCascade+ , derivePersistField ) where import Database.Persist.Base@@ -435,3 +436,31 @@ go' xs front col = let Just col' = lookup col xs in front `AppE` VarE col'++-- | Automatically creates a valid 'PersistField' instance for any datatype+-- that has valid 'Show' and 'Read' instances. Can be very convenient for+-- 'Enum' types.+derivePersistField :: String -> Q [Dec]+derivePersistField s = do+ ss <- [|SqlString|]+ tpv <- [|PersistString . show|]+ fpv <- [|\dt v ->+ case fromPersistValue v of+ Left e -> Left e+ Right s ->+ case reads s of+ (x, _):_ -> Right x+ [] -> Left $ "Invalid " ++ dt ++ ": " ++ s|]+ return+ [ InstanceD [] (ConT ''PersistField `AppT` ConT (mkName s))+ [ FunD (mkName "sqlType")+ [ Clause [WildP] (NormalB ss) []+ ]+ , FunD (mkName "toPersistValue")+ [ Clause [] (NormalB tpv) []+ ]+ , FunD (mkName "fromPersistValue")+ [ Clause [] (NormalB $ fpv `AppE` LitE (StringL s)) []+ ]+ ]+ ]
persistent.cabal view
@@ -1,5 +1,5 @@ name: persistent-version: 0.2.4.1+version: 0.3.0 license: BSD3 license-file: LICENSE author: Michael Snoyman <michael@snoyman.com>@@ -16,17 +16,16 @@ build-depends: base >= 4 && < 5, template-haskell >= 2.4 && < 2.6, bytestring >= 0.9.1 && < 0.10,- MonadCatchIO-transformers >= 0.2.2 && < 0.3, transformers >= 0.2.1 && < 0.3, time >= 1.1.4 && < 1.3,- utf8-string >= 0.3.4 && < 0.4,- text >= 0.7.1 && < 0.12,+ text >= 0.7.1 && < 0.11, hamlet >= 0.5 && < 0.6, web-routes-quasi >= 0.6.0 && < 0.7, containers >= 0.2 && < 0.5, parsec >= 2.1 && < 4, enumerator >= 0.4 && < 0.5,- stm >= 2.1 && < 2.2+ stm >= 2.1 && < 2.2,+ neither >= 0.1 && < 0.2 exposed-modules: Database.Persist Database.Persist.Base Database.Persist.TH