persistent 0.8.0.2 → 0.9.0
raw patch · 10 files changed
+86/−164 lines, 10 filesdep +resourcetdep ~conduitdep ~pool-conduitdep ~transformers
Dependencies added: resourcet
Dependency ranges changed: conduit, pool-conduit, transformers
Files
- Database/Persist/GenericSql.hs +5/−13
- Database/Persist/GenericSql/Internal.hs +3/−2
- Database/Persist/GenericSql/Raw.hs +41/−39
- Database/Persist/Quasi.hs +1/−3
- Database/Persist/Query/GenericSql.hs +14/−16
- Database/Persist/Query/Internal.hs +4/−3
- Database/Persist/Query/Join/Sql.hs +3/−1
- Database/Persist/Store.hs +10/−6
- persistent.cabal +5/−4
- test/main.hs +0/−77
Database/Persist/GenericSql.hs view
@@ -51,16 +51,8 @@ import Database.Persist.GenericSql.Migration import qualified Database.Persist.GenericSql.Raw as R import Database.Persist.GenericSql.Raw (SqlPersist (..))-#if MIN_VERSION_monad_control(0, 3, 0) import Control.Monad.Trans.Control (MonadBaseControl, control) import qualified Control.Exception as E-#define MBCIO MonadBaseControl IO-#else-import Control.Monad.IO.Control (MonadControlIO)-import Control.Exception.Control (onException)--#define MBCIO MonadControlIO-#endif import Control.Exception (throw) import Data.Text (Text, pack, unpack, concat) import qualified Data.Text as T@@ -86,10 +78,10 @@ -- | Get a connection from the pool, run the given action, and then return the -- connection to the pool.-runSqlPool :: (MBCIO m, MonadIO m) => SqlPersist m a -> Pool Connection -> m a+runSqlPool :: (MonadBaseControl IO m, MonadIO m) => SqlPersist m a -> Pool Connection -> m a runSqlPool r pconn = withResource pconn $ runSqlConn r -runSqlConn :: (MBCIO m, MonadIO m) => SqlPersist m a -> Connection -> m a+runSqlConn :: (MonadBaseControl IO m, MonadIO m) => SqlPersist m a -> Connection -> m a runSqlConn (SqlPersist r) conn = do let getter = R.getStmt' conn liftIO $ begin conn getter@@ -99,7 +91,7 @@ liftIO $ commitC conn getter return x -instance C.ResourceIO m => PersistStore SqlPersist m where+instance (MonadBaseControl IO m, MonadIO m, C.MonadThrow m, C.MonadUnsafeIO m) => PersistStore SqlPersist m where insert val = do conn <- SqlPersist ask let esql = insertSql conn (entityDB t) (map fieldDB $ entityFields t)@@ -199,7 +191,7 @@ ] vals = k : map toPersistValue (toPersistFields val) -instance C.ResourceIO m => PersistUnique SqlPersist m where+instance (MonadBaseControl IO m, C.MonadUnsafeIO m, MonadIO m, C.MonadThrow m) => PersistUnique SqlPersist m where deleteBy uniq = do conn <- SqlPersist ask execute' (sql conn) $ persistUniqueToValues uniq@@ -463,7 +455,7 @@ -- However, most common problems are mitigated by using the -- entity selection placeholder @??@, and you shouldn't see any -- error at all if you're not using 'Single'.-rawSql :: (RawSql a, C.ResourceIO m) =>+rawSql :: (RawSql a, C.MonadUnsafeIO m, C.MonadThrow m, MonadIO m, MonadBaseControl IO m) => Text -- ^ SQL statement, possibly with placeholders. -> [PersistValue] -- ^ Values to fill the placeholders. -> SqlPersist m [a]
Database/Persist/GenericSql/Internal.hs view
@@ -22,6 +22,7 @@ import Data.Conduit.Pool import Database.Persist.Store import Control.Exception.Lifted (bracket)+import Control.Monad.Trans.Control (MonadBaseControl) import Database.Persist.Util (nullable) import Data.Text (Text) import qualified Data.Text as T@@ -50,7 +51,7 @@ { finalize :: IO () , reset :: IO () , execute :: [PersistValue] -> IO ()- , withStmt :: forall m. C.ResourceIO m+ , withStmt :: forall m. C.MonadResource m => [PersistValue] -> C.Source m [PersistValue] }@@ -70,7 +71,7 @@ -> m (Pool Connection) createSqlPool mkConn = liftIO . createPool mkConn close' 1 20 -withSqlConn :: C.ResourceIO m+withSqlConn :: (MonadIO m, MonadBaseControl IO m) => IO Connection -> (Connection -> m a) -> m a withSqlConn open = bracket (liftIO open) (liftIO . close')
Database/Persist/GenericSql/Raw.hs view
@@ -24,33 +24,23 @@ import Control.Applicative (Applicative) import Control.Monad.Trans.Class (MonadTrans (..)) import Control.Monad.Base (MonadBase (liftBase))-#if MIN_VERSION_monad_control(0, 3, 0) import Control.Monad.Trans.Control (MonadBaseControl (..), ComposeSt, defaultLiftBaseWith, defaultRestoreM, MonadTransControl (..)) import Control.Monad (liftM) #define MBCIO MonadBaseControl IO-#else-import Control.Monad.IO.Control (MonadControlIO)-#define MBCIO MonadControlIO-#endif import Data.Text (Text) import Control.Monad (MonadPlus)-import Control.Monad.Trans.Resource (ResourceThrow (..), ResourceIO)+import Control.Monad.Trans.Resource (MonadThrow (..), MonadResource (..)) import qualified Data.Conduit as C newtype SqlPersist m a = SqlPersist { unSqlPersist :: ReaderT Connection m a }- deriving (Monad, MonadIO, MonadTrans, Functor, Applicative, MonadPlus-#if !MIN_VERSION_monad_control(0, 3, 0)- , MonadControlIO-#endif- )+ deriving (Monad, MonadIO, MonadTrans, Functor, Applicative, MonadPlus) -instance ResourceThrow m => ResourceThrow (SqlPersist m) where- resourceThrow = lift . resourceThrow+instance MonadThrow m => MonadThrow (SqlPersist m) where+ monadThrow = lift . monadThrow instance MonadBase b m => MonadBase b (SqlPersist m) where liftBase = lift . liftBase -#if MIN_VERSION_monad_control(0, 3, 0) instance MonadBaseControl b m => MonadBaseControl b (SqlPersist m) where newtype StM (SqlPersist m) a = StMSP {unStMSP :: ComposeSt SqlPersist m a} liftBaseWith = defaultLiftBaseWith StMSP@@ -59,42 +49,54 @@ newtype StT SqlPersist a = StReader {unStReader :: a} liftWith f = SqlPersist $ ReaderT $ \r -> f $ \t -> liftM StReader $ runReaderT (unSqlPersist t) r restoreT = SqlPersist . ReaderT . const . liftM unStReader-#endif -withStmt :: ResourceIO m+instance MonadResource m => MonadResource (SqlPersist m) where+ register = lift . register+ release = lift . release+ allocate a = lift . allocate a+ resourceMask = lift . resourceMask++class MonadIO m => MonadSqlPersist m where+ askSqlConn :: m Connection++instance MonadIO m => MonadSqlPersist (SqlPersist m) where+ askSqlConn = SqlPersist ask+instance MonadSqlPersist m => MonadSqlPersist (C.ResourceT m) where+ askSqlConn = lift askSqlConn+-- FIXME add a bunch of MonadSqlPersist instances for all transformers++withStmt :: (MonadSqlPersist m, MonadResource m) => Text -> [PersistValue]- -> C.Source (SqlPersist m) [PersistValue]-withStmt sql vals = C.Source- { C.sourcePull = do- stmt <- lift $ getStmt sql- let src = I.withStmt stmt vals- pull stmt src- , C.sourceClose = return ()- }+ -> C.Source m [PersistValue]+withStmt sql vals = C.PipeM+ (do+ stmt <- getStmt sql+ reset' <- register $ I.reset stmt+ return $ pull reset' $ I.withStmt stmt vals)+ (return ()) where- pull stmt src = do- res <- C.sourcePull src- case res of- C.Closed -> do- liftIO $ I.reset stmt- return C.Closed- C.Open src' val -> return $ C.Open- (C.Source (pull stmt src') (close' stmt src'))- val- close' stmt src = do- liftIO $ I.reset stmt- C.sourceClose src+ pull reset' (C.Done _ ()) = C.PipeM (do+ release reset'+ return $ C.Done Nothing ()) (release reset')+ pull reset' (C.HaveOutput src close' x) = C.HaveOutput+ (pull reset' src)+ (release reset' >> close')+ x+ pull reset' (C.PipeM msrc close') = C.PipeM+ (pull reset' `liftM` msrc)+ (release reset' >> close')+ pull reset' (C.NeedInput _ c) = pull reset' c -execute :: MonadIO m => Text -> [PersistValue] -> SqlPersist m ()+execute :: MonadSqlPersist m => Text -> [PersistValue] -> m () execute sql vals = do stmt <- getStmt sql liftIO $ I.execute stmt vals liftIO $ reset stmt -getStmt :: MonadIO m => Text -> SqlPersist m Statement+getStmt :: MonadSqlPersist m => Text -> m Statement getStmt sql = do- conn <- SqlPersist ask+ conn <- askSqlConn liftIO $ getStmt' conn sql getStmt' :: Connection -> Text -> IO Statement
Database/Persist/Quasi.hs view
@@ -198,9 +198,7 @@ Nothing -> idName ts Just s -> s uniqs = mapMaybe (takeUniqs ps cols) attribs- derives = case mapMaybe takeDerives attribs of- [] -> ["Show", "Read", "Eq"]- x -> concat x+ derives = concat $ mapMaybe takeDerives attribs cols :: [FieldDef] cols = mapMaybe (takeCols ps) attribs
Database/Persist/Query/GenericSql.hs view
@@ -31,9 +31,11 @@ import Control.Monad.IO.Class import Control.Monad.Trans.Class import Control.Monad.Trans.Reader+import Control.Monad.Trans.Control (MonadBaseControl) import qualified Data.Conduit as C import qualified Data.Conduit.List as CL+import Control.Monad.Trans.Resource (transResourceT) import Control.Exception (throwIO) import qualified Data.Text as T@@ -41,7 +43,7 @@ import Data.Monoid (Monoid, mappend, mconcat) -- orphaned instance for convenience of modularity-instance C.ResourceIO m => PersistQuery SqlPersist m where+instance (C.MonadThrow m, MonadIO m, C.MonadUnsafeIO m, MonadBaseControl IO m) => PersistQuery SqlPersist m where update _ [] = return () update k upds = do conn <- SqlPersist ask@@ -80,13 +82,11 @@ where t = entityDef $ dummyFromFilts filts - selectSource filts opts = C.Source- { C.sourcePull = do+ selectSource filts opts = C.PipeM+ (do conn <- lift $ SqlPersist ask- let src = R.withStmt (sql conn) (getFiltsValues conn filts) C.$= CL.mapM parse- C.sourcePull src- , C.sourceClose = return ()- }+ return $ R.withStmt (sql conn) (getFiltsValues conn filts) C.$= CL.mapM parse)+ (return ()) where (limit, offset, orders) = limitOffsetOrder opts @@ -129,13 +129,11 @@ , off ] - selectKeys filts = C.Source- { C.sourcePull = do+ selectKeys filts = C.PipeM+ (do conn <- lift $ SqlPersist ask- let src = R.withStmt (sql conn) (getFiltsValues conn filts) C.$= CL.mapM parse- C.sourcePull src- , C.sourceClose = return ()- }+ return $ R.withStmt (sql conn) (getFiltsValues conn filts) C.$= CL.mapM parse)+ (return ()) where parse [PersistInt64 i] = return $ Key $ PersistInt64 i parse y = liftIO $ throwIO $ PersistMarshalError $ "Unexpected in selectKeys: " ++ show y@@ -329,13 +327,13 @@ -- the environment inside a 'SqlPersist' monad, provide an explicit -- 'Connection'. This can allow you to use the returned 'Source' in an -- arbitrary monad.-selectSourceConn :: (C.ResourceIO m, PersistEntity val, SqlPersist ~ PersistEntityBackend val)+selectSourceConn :: (PersistEntity val, SqlPersist ~ PersistEntityBackend val, C.MonadThrow m, C.MonadUnsafeIO m, MonadIO m, MonadBaseControl IO m) => Connection -> [Filter val] -> [SelectOpt val]- -> C.Source m (Entity val)+ -> C.Source (C.ResourceT m) (Entity val) selectSourceConn conn fs opts =- C.transSource (flip runSqlConn conn) (selectSource fs opts)+ C.transPipe (transResourceT $ flip runSqlConn conn) (selectSource fs opts) dummyFromFilts :: [Filter v] -> v dummyFromFilts _ = error "dummyFromFilts"
Database/Persist/Query/Internal.hs view
@@ -18,6 +18,7 @@ import Database.Persist.Store import Database.Persist.EntityDef+import Control.Monad.Trans.Class (lift) import qualified Data.Conduit as C import qualified Data.Conduit.List as CL@@ -39,7 +40,7 @@ :: (PersistEntity val, PersistEntityBackend val ~ b) => [Filter val] -> [SelectOpt val]- -> C.Source (b m) (Entity val)+ -> C.Source (C.ResourceT (b m)) (Entity val) -- | get just the first record for the criterion selectFirst :: (PersistEntity val, PersistEntityBackend val ~ b)@@ -53,7 +54,7 @@ -- | Get the 'Key's of all records matching the given criterion. selectKeys :: PersistEntity val => [Filter val]- -> C.Source (b m) (Key b val)+ -> C.Source (C.ResourceT (b m)) (Key b val) -- | The total number of records fulfilling the given criterion. count :: PersistEntity val => [Filter val] -> b m Int@@ -106,4 +107,4 @@ deleteCascadeWhere :: (DeleteCascade a b m, PersistQuery b m) => [Filter a] -> b m () deleteCascadeWhere filts = do- C.runResourceT $ selectKeys filts C.$$ CL.mapM_ deleteCascade+ C.runResourceT $ selectKeys filts C.$$ CL.mapM_ (lift . deleteCascade)
Database/Persist/Query/Join/Sql.hs view
@@ -28,6 +28,8 @@ import qualified Data.Text as T import qualified Data.Conduit as C import qualified Data.Conduit.List as CL+import Control.Monad.IO.Class (MonadIO)+import Control.Monad.Trans.Control (MonadBaseControl) fromPersistValuesId :: PersistEntity v => [PersistValue] -> Either Text (Entity v) fromPersistValuesId [] = Left "fromPersistValuesId: No values provided"@@ -38,7 +40,7 @@ fromPersistValuesId _ = Left "fromPersistValuesId: invalid ID" class RunJoin a where- runJoin :: C.ResourceIO m => a -> SqlPersist m (J.Result a)+ runJoin :: (C.MonadThrow m, C.MonadUnsafeIO m, MonadIO m, MonadBaseControl IO m) => a -> SqlPersist m (J.Result a) instance (PersistEntity one, PersistEntity many, Eq (Key SqlPersist one)) => RunJoin (SelectOneMany SqlPersist one many) where
Database/Persist/Store.hs view
@@ -65,7 +65,6 @@ import qualified Data.Text as T import qualified Data.Text.Lazy as TL import qualified Data.ByteString.Lazy as L-import qualified Control.Monad.IO.Class as Trans import qualified Control.Exception as E import Control.Monad.Trans.Error (Error (..))@@ -79,7 +78,6 @@ import qualified Data.Text.Encoding.Error as T import Web.PathPieces (PathPiece (..)) import qualified Data.Text.Read-import qualified Data.Conduit as C import Data.Aeson (Value) import Data.Aeson.Types (Parser)@@ -99,6 +97,10 @@ import Data.Text.Lazy (toStrict) import Data.Text.Lazy.Builder (toLazyText) +import Control.Monad.Trans.Control (MonadBaseControl)+import Control.Monad.Base (liftBase)+import Control.Monad.IO.Class (MonadIO)+ data PersistException = PersistError T.Text -- ^ Generic Exception | PersistMarshalError T.Text@@ -503,7 +505,7 @@ , entityVal :: entity } deriving (Eq, Ord, Show, Read) -class (C.ResourceIO m, C.ResourceIO (b m)) => PersistStore b m where+class (MonadBaseControl IO m, MonadBaseControl IO (b m)) => PersistStore b m where -- | Create a new record in the database, returning an automatically created -- key (in SQL an auto-increment id).@@ -543,7 +545,7 @@ insertUnique :: (b ~ PersistEntityBackend val, PersistEntity val) => val -> b m (Maybe (Key b val)) insertUnique datum = do isUnique <- checkUnique datum- if isUnique then Just <$> insert datum else return Nothing+ if isUnique then Just `liftM` insert datum else return Nothing @@ -599,7 +601,7 @@ -- Unsafe unless your database is enforcing that the foreign key is valid getJust :: (PersistStore b m, PersistEntity val, Show (Key b val)) => Key b val -> b m val getJust key = get key >>= maybe- (Trans.liftIO $ E.throwIO $ PersistForeignConstraintUnmet $ show key)+ (liftBase $ E.throwIO $ PersistForeignConstraintUnmet $ show key) return @@ -650,7 +652,9 @@ createPoolConfig :: c -> IO (PersistConfigPool c) -- | Run a database action by taking a connection from the pool.- runPool :: C.ResourceIO m => c -> PersistConfigBackend c m a+ runPool :: (MonadBaseControl IO m, MonadIO m)+ => c+ -> PersistConfigBackend c m a -> PersistConfigPool c -> m a
persistent.cabal view
@@ -1,5 +1,5 @@ name: persistent-version: 0.8.0.2+version: 0.9.0 license: BSD3 license-file: LICENSE author: Michael Snoyman <michael@snoyman.com>@@ -22,14 +22,15 @@ build-depends: base >= 4 && < 5 , bytestring >= 0.9 && < 0.10- , transformers >= 0.2.1 && < 0.3+ , transformers >= 0.2.1 && < 0.4 , time >= 1.1.4 , text >= 0.8 && < 1 , containers >= 0.2 && < 0.5- , conduit >= 0.2 && < 0.3+ , conduit >= 0.4 && < 0.5+ , resourcet >= 0.3 && < 0.4 , monad-control >= 0.3 && < 0.4 , lifted-base >= 0.1 && < 0.2- , pool-conduit >= 0.0 && < 0.1+ , pool-conduit >= 0.1 && < 0.2 , blaze-html >= 0.4 && < 0.5 , path-pieces >= 0.1 && < 0.2 , mtl >= 2.0 && < 2.1
− test/main.hs
@@ -1,77 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-import Test.Hspec.Monadic-import Test.Hspec.HUnit ()-import Test.HUnit--import Database.Persist.Quasi-import Database.Persist.EntityDef--main :: IO ()-main = hspecX $ do- describe "tokenization" $ do- it "handles normal words" $- tokenize " foo bar baz" @?=- [ Spaces 1- , Token "foo"- , Spaces 3- , Token "bar"- , Spaces 2- , Token "baz"- ]- it "handles quotes" $- tokenize " \"foo bar\" \"baz\"" @?=- [ Spaces 2- , Token "foo bar"- , Spaces 2- , Token "baz"- ]- it "handles unnested parantheses" $- tokenize " (foo bar) (baz)" @?=- [ Spaces 2- , Token "foo bar"- , Spaces 2- , Token "baz"- ]- it "handles nested parantheses" $- tokenize " (foo (bar)) (baz)" @?=- [ Spaces 2- , Token "foo (bar)"- , Spaces 2- , Token "baz"- ]- it "escaping " $- tokenize " (foo \\(bar) \"baz\\\"\"" @?=- [ Spaces 2- , Token "foo (bar"- , Spaces 2- , Token "baz\""- ]- describe "parseFieldType" $ do- it "simple types" $- parseFieldType "FooBar" @?= Just (FTTypeCon Nothing "FooBar")- it "module types" $- parseFieldType "Data.Map.FooBar" @?= Just (FTTypeCon (Just "Data.Map") "FooBar")- it "application" $- parseFieldType "Foo Bar" @?= Just (- FTTypeCon Nothing "Foo" `FTApp` FTTypeCon Nothing "Bar")- it "application multiple" $- parseFieldType "Foo Bar Baz" @?= Just (- (FTTypeCon Nothing "Foo" `FTApp` FTTypeCon Nothing "Bar")- `FTApp` FTTypeCon Nothing "Baz"- )- it "parens" $ do- let foo = FTTypeCon Nothing "Foo"- bar = FTTypeCon Nothing "Bar"- baz = FTTypeCon Nothing "Baz"- parseFieldType "Foo (Bar Baz)" @?= Just (- foo `FTApp` (bar `FTApp` baz))- it "lists" $ do- let foo = FTTypeCon Nothing "Foo"- bar = FTTypeCon Nothing "Bar"- bars = FTList bar- baz = FTTypeCon Nothing "Baz"- parseFieldType "Foo [Bar] Baz" @?= Just (- foo `FTApp` bars `FTApp` baz)- describe "stripId" $ do- it "works" $- (parseFieldType "FooId" >>= stripId) @?= Just "Foo"