diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,3 @@ +## 2.1.1.1 + +Support for monad-control 1.0 diff --git a/Database/Persist/Sql/Orphan/PersistStore.hs b/Database/Persist/Sql/Orphan/PersistStore.hs --- a/Database/Persist/Sql/Orphan/PersistStore.hs +++ b/Database/Persist/Sql/Orphan/PersistStore.hs @@ -4,12 +4,17 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE Rank2Types #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Database.Persist.Sql.Orphan.PersistStore ( withRawQuery , BackendKey(..) , toSqlKey , fromSqlKey + , getFieldName + , getTableName + , tableDBName + , fieldDBName ) where import Database.Persist @@ -54,6 +59,48 @@ Nothing -> connEscapeName conn (fieldDB (entityId t)) <> "=?" where t = entityDef $ dummyFromKey k + +-- | get the SQL string for the table that a PeristEntity represents +-- Useful for raw SQL queries +-- +-- Your backend may provide a more convenient tableName function +-- which does not operate in a Monad +getTableName :: forall record m. + ( PersistEntity record + , PersistEntityBackend record ~ SqlBackend + , Monad m + ) => record -> ReaderT SqlBackend m Text +getTableName rec = do + conn <- ask + return $ connEscapeName conn $ tableDBName rec + +-- | useful for a backend to implement tableName by adding escaping +tableDBName :: forall record. + ( PersistEntity record + , PersistEntityBackend record ~ SqlBackend + ) => record -> DBName +tableDBName rec = entityDB $ entityDef (Just rec) + +-- | get the SQL string for the field that an EntityField represents +-- Useful for raw SQL queries +-- +-- Your backend may provide a more convenient fieldName function +-- which does not operate in a Monad +getFieldName :: forall record typ m. + ( PersistEntity record + , PersistEntityBackend record ~ SqlBackend + , Monad m + ) + => EntityField record typ -> ReaderT SqlBackend m Text +getFieldName rec = do + conn <- ask + return $ connEscapeName conn $ fieldDBName rec + +-- | useful for a backend to implement fieldName by adding escaping +fieldDBName :: forall record typ. (PersistEntity record) => EntityField record typ -> DBName +fieldDBName = fieldDB . persistFieldDef + + instance PersistStore SqlBackend where newtype BackendKey SqlBackend = SqlBackendKey { unSqlBackendKey :: Int64 } deriving (Show, Read, Eq, Ord, Num, Integral, PersistField, PersistFieldSql, PathPiece, Real, Enum, Bounded, A.ToJSON, A.FromJSON) @@ -71,7 +118,7 @@ let wher = whereStmtForKey conn k let sql = T.concat [ "UPDATE " - , connEscapeName conn $ entityDB t + , connEscapeName conn $ tableDBName $ recordTypeFromKey k , " SET " , T.intercalate "," $ map (go' . go) upds , " WHERE " @@ -80,7 +127,6 @@ rawExecute sql $ map updatePersistValue upds `mappend` keyToValues k where - t = entityDef $ dummyFromKey k go x = (fieldDB $ updateFieldDef x, updateUpdate x) insert val = do @@ -216,17 +262,19 @@ conn <- ask rawExecute (sql conn) (keyToValues k) where - t = entityDef $ dummyFromKey k wher conn = whereStmtForKey conn k sql conn = T.concat [ "DELETE FROM " - , connEscapeName conn $ entityDB t + , connEscapeName conn $ tableDBName $ recordTypeFromKey k , " WHERE " , wher conn ] -dummyFromKey :: Key v -> Maybe v -dummyFromKey _ = Nothing +dummyFromKey :: Key record -> Maybe record +dummyFromKey = Just . recordTypeFromKey + +recordTypeFromKey :: Key record -> record +recordTypeFromKey _ = error "dummyFromKey" insrepHelper :: (MonadIO m, PersistEntity val) => Text diff --git a/Database/Persist/Sql/Run.hs b/Database/Persist/Sql/Run.hs --- a/Database/Persist/Sql/Run.hs +++ b/Database/Persist/Sql/Run.hs @@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} module Database.Persist.Sql.Run where import Database.Persist.Sql.Types @@ -15,7 +16,7 @@ import Control.Exception (mask) import System.Timeout (timeout) import Control.Monad.Trans.Control (control) -import Data.IORef (readIORef) +import Data.IORef (readIORef, writeIORef, newIORef) import qualified Data.Map as Map import Control.Exception.Lifted (throwIO) import Control.Exception (mask) @@ -33,8 +34,8 @@ -- allocation does not complete within the given timeout period. -- -- Since 2.0.0 -withResourceTimeout :: - (MonadBaseControl IO m) +withResourceTimeout + :: forall a m b. (MonadBaseControl IO m) => Int -- ^ Timeout period in microseconds -> Pool a -> (a -> m b) @@ -43,7 +44,7 @@ withResourceTimeout ms pool act = control $ \runInIO -> mask $ \restore -> do mres <- timeout ms $ takeResource pool case mres of - Nothing -> runInIO $ return Nothing + Nothing -> runInIO $ return (Nothing :: Maybe b) Just (resource, local) -> do ret <- restore (runInIO (liftM Just $ act resource)) `onException` destroyResource pool local resource @@ -86,9 +87,15 @@ -- NOTE: This function is a terrible, ugly hack. It would be much better to -- just clean up monad-logger. -askLogFunc :: (MonadBaseControl IO m, MonadLogger m) => m LogFunc +-- +-- FIXME: in a future release, switch over to the new askLoggerIO function +-- added in monad-logger 0.3.10. That function was not available at the time +-- this code was written. +askLogFunc :: forall m. (MonadBaseControl IO m, MonadLogger m) => m LogFunc askLogFunc = do - runInBase <- control $ \run -> run $ return run + ref <- liftBase $ newIORef undefined + liftBaseWith $ \run -> writeIORef ref run + runInBase <- liftBase $ readIORef ref return $ \a b c d -> do _ <- runInBase (monadLoggerLog a b c d) return () diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,5 @@ +## persistent + +Type-safe, data serialization. You must use a specific backend in order to make +this useful. For more information, see [the chapter in the Yesod +book](http://www.yesodweb.com/book/persistent). diff --git a/persistent.cabal b/persistent.cabal --- a/persistent.cabal +++ b/persistent.cabal @@ -1,17 +1,18 @@ name: persistent -version: 2.1.1 +version: 2.1.1.1 license: MIT license-file: LICENSE author: Michael Snoyman maintainer: Michael Snoyman , Greg Weber synopsis: Type-safe, multi-backend data serialization. -description: Type-safe, data serialization. You must use a specific backend in order to make this useful. +description: Hackage documentation generation is not reliable. For up to date documentation, please see: . category: Database, Yesod stability: Stable cabal-version: >= 1.8 build-type: Simple homepage: http://www.yesodweb.com/book/persistent bug-reports: https://github.com/yesodweb/persistent/issues +extra-source-files: ChangeLog.md README.md flag nooverlap default: False