diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,7 @@ +## 2.6 + +* Add `connUpsertSql` type for providing backend-specific upsert sql support. + ## 2.5 * read/write typeclass split diff --git a/Database/Persist/Class/PersistUnique.hs b/Database/Persist/Class/PersistUnique.hs --- a/Database/Persist/Class/PersistUnique.hs +++ b/Database/Persist/Class/PersistUnique.hs @@ -80,6 +80,22 @@ -- ^ the record in the database after the operation upsert record updates = do uniqueKey <- onlyUnique record + upsertBy uniqueKey record updates + + -- | Update based on a given uniqueness constraint or insert: + -- + -- * insert the new record if it does not exist; + -- * update the existing record that matches the given uniqueness contraint. + upsertBy :: (MonadIO m, PersistRecordBackend record backend) + => Unique record -- ^ uniqueness constraint to find by + -> record -- ^ new record to insert + -> [Update record] + -- ^ updates to perform if the record already exists (leaving + -- this empty is the equivalent of performing a 'repsert' on a + -- unique key) + -> ReaderT backend m (Entity record) + -- ^ the record in the database after the operation + upsertBy uniqueKey record updates = do mExists <- getBy uniqueKey k <- case mExists of Just (Entity k _) -> do diff --git a/Database/Persist/Quasi.hs b/Database/Persist/Quasi.hs --- a/Database/Persist/Quasi.hs +++ b/Database/Persist/Quasi.hs @@ -456,8 +456,10 @@ (_, attrs) = break ("!" `T.isPrefixOf`) pkcols getDef [] t = error $ "Unknown column in primary key constraint: " ++ show t getDef (d:ds) t - | nullable (fieldAttrs d) /= NotNullable = error $ "primary key column cannot be nullable: " ++ show t - | fieldHaskell d == HaskellName t = d + | fieldHaskell d == HaskellName t = + if nullable (fieldAttrs d) /= NotNullable + then error $ "primary key column cannot be nullable: " ++ show t + else d | otherwise = getDef ds t -- Unique UppercaseConstraintName list of lowercasefields diff --git a/Database/Persist/Sql/Orphan/PersistQuery.hs b/Database/Persist/Sql/Orphan/PersistQuery.hs --- a/Database/Persist/Sql/Orphan/PersistQuery.hs +++ b/Database/Persist/Sql/Orphan/PersistQuery.hs @@ -46,7 +46,7 @@ case mm of Just [PersistInt64 i] -> return $ fromIntegral i Just [PersistDouble i] ->return $ fromIntegral (truncate i :: Int64) -- gb oracle - Just [PersistByteString i] -> case readInteger i of -- gb mssql + Just [PersistByteString i] -> case readInteger i of -- gb mssql Just (ret,"") -> return $ fromIntegral ret xs -> error $ "invalid number i["++show i++"] xs[" ++ show xs ++ "]" Just xs -> error $ "count:invalid sql return xs["++show xs++"] sql["++show sql++"]" @@ -89,8 +89,8 @@ where t = entityDef $ dummyFromFilts filts cols conn = T.intercalate "," $ dbIdColumns conn t - + wher conn = if null filts then "" else filterClause False conn filts @@ -112,12 +112,12 @@ parse xs = do keyvals <- case entityPrimary t of - Nothing -> + Nothing -> case xs of [PersistInt64 x] -> return [PersistInt64 x] - [PersistDouble x] -> return [PersistInt64 (truncate x)] -- oracle returns Double + [PersistDouble x] -> return [PersistInt64 (truncate x)] -- oracle returns Double _ -> liftIO $ throwIO $ PersistMarshalError $ "Unexpected in selectKeys False: " <> T.pack (show xs) - Just pdef -> + Just pdef -> let pks = map fieldHaskell $ compositeFields pdef keyvals = map snd $ filter (\(a, _) -> let ret=isJust (find (== a) pks) in ret) $ zip (map fieldHaskell $ entityFields t) xs in return keyvals @@ -238,7 +238,7 @@ go (FilterAnd fs) = combineAND fs go (FilterOr []) = ("1=0", []) go (FilterOr fs) = combine " OR " fs - go (Filter field value pfilter) = + go (Filter field value pfilter) = let t = entityDef $ dummyFromFilts [Filter field value pfilter] in case (isIdField field, entityPrimary t, allVals) of (True, Just pdef, PersistList ys:_) -> @@ -246,21 +246,21 @@ then error $ "wrong number of entries in compositeFields vs PersistList allVals=" ++ show allVals else case (allVals, pfilter, isCompFilter pfilter) of - ([PersistList xs], Eq, _) -> + ([PersistList xs], Eq, _) -> let sqlcl=T.intercalate " and " (map (\a -> connEscapeName conn (fieldDB a) <> showSqlFilter pfilter <> "? ") (compositeFields pdef)) in (wrapSql sqlcl,xs) - ([PersistList xs], Ne, _) -> + ([PersistList xs], Ne, _) -> let sqlcl=T.intercalate " or " (map (\a -> connEscapeName conn (fieldDB a) <> showSqlFilter pfilter <> "? ") (compositeFields pdef)) in (wrapSql sqlcl,xs) - (_, In, _) -> + (_, In, _) -> let xxs = transpose (map fromPersistList allVals) sqls=map (\(a,xs) -> connEscapeName conn (fieldDB a) <> showSqlFilter pfilter <> "(" <> T.intercalate "," (replicate (length xs) " ?") <> ") ") (zip (compositeFields pdef) xxs) in (wrapSql (T.intercalate " and " (map wrapSql sqls)), concat xxs) - (_, NotIn, _) -> + (_, NotIn, _) -> let xxs = transpose (map fromPersistList allVals) sqls=map (\(a,xs) -> connEscapeName conn (fieldDB a) <> showSqlFilter pfilter <> "(" <> T.intercalate "," (replicate (length xs) " ?") <> ") ") (zip (compositeFields pdef) xxs) in (wrapSql (T.intercalate " or " (map wrapSql sqls)), concat xxs) - ([PersistList xs], _, True) -> + ([PersistList xs], _, True) -> let zs = tail (inits (compositeFields pdef)) sql1 = map (\b -> wrapSql (T.intercalate " and " (map (\(i,a) -> sql2 (i==length b) a) (zip [1..] b)))) zs sql2 islast a = connEscapeName conn (fieldDB a) <> (if islast then showSqlFilter pfilter else showSqlFilter Eq) <> "? " @@ -268,7 +268,10 @@ in (wrapSql sqlcl, concat (tail (inits xs))) (_, BackendSpecificFilter _, _) -> error "unhandled type BackendSpecificFilter for composite/non id primary keys" _ -> error $ "unhandled type/filter for composite/non id primary keys pfilter=" ++ show pfilter ++ " persistList="++show allVals - (True, Just pdef, _) -> error $ "unhandled error for composite/non id primary keys pfilter=" ++ show pfilter ++ " persistList=" ++ show allVals ++ " pdef=" ++ show pdef + (True, Just pdef, []) -> + error $ "empty list given as filter value filter=" ++ show pfilter ++ " persistList=" ++ show allVals ++ " pdef=" ++ show pdef + (True, Just pdef, _) -> + error $ "unhandled error for composite/non id primary keys filter=" ++ show pfilter ++ " persistList=" ++ show allVals ++ " pdef=" ++ show pdef _ -> case (isNull, pfilter, varCount) of (True, Eq, _) -> (name <> " IS NULL", []) @@ -314,7 +317,7 @@ , qmarks , ")" ], notNullVals) - _ -> (name <> showSqlFilter pfilter <> "?" <> orNullSuffix, allVals) + _ -> (name <> showSqlFilter pfilter <> "?" <> orNullSuffix, allVals) where isCompFilter Lt = True @@ -322,11 +325,11 @@ isCompFilter Gt = True isCompFilter Ge = True isCompFilter _ = False - + wrapSql sqlcl = "(" <> sqlcl <> ")" fromPersistList (PersistList xs) = xs fromPersistList other = error $ "expected PersistList but found " ++ show other - + filterValueToPersistValues :: forall a. PersistField a => Either a [a] -> [PersistValue] filterValueToPersistValues v = map toPersistValue $ either return id v @@ -399,8 +402,8 @@ $ connEscapeName conn $ fieldName x -- | Generates sql for limit and offset for postgres, sqlite and mysql. -decorateSQLWithLimitOffset::Text -> (Int,Int) -> Bool -> Text -> Text -decorateSQLWithLimitOffset nolimit (limit,offset) _ sql = +decorateSQLWithLimitOffset::Text -> (Int,Int) -> Bool -> Text -> Text +decorateSQLWithLimitOffset nolimit (limit,offset) _ sql = let lim = case (limit, offset) of (0, 0) -> "" @@ -413,4 +416,4 @@ [ sql , lim , off - ] + ] diff --git a/Database/Persist/Sql/Orphan/PersistUnique.hs b/Database/Persist/Sql/Orphan/PersistUnique.hs --- a/Database/Persist/Sql/Orphan/PersistUnique.hs +++ b/Database/Persist/Sql/Orphan/PersistUnique.hs @@ -13,11 +13,48 @@ import Database.Persist.Sql.Orphan.PersistStore (withRawQuery) import Database.Persist.Sql.Util (dbColumns, parseEntityValues) import qualified Data.Text as T -import Data.Monoid (mappend) +import Data.Monoid (mappend, (<>)) import qualified Data.Conduit.List as CL import Control.Monad.Trans.Reader (ask, withReaderT) +import Control.Monad (when, liftM) +defaultUpsert :: (MonadIO m, PersistEntity record, PersistUniqueWrite backend + , PersistEntityBackend record ~ BaseBackend backend) + => record -> [Update record] -> ReaderT backend m (Entity record) +defaultUpsert record updates = do + uniqueKey <- onlyUnique record + upsertBy uniqueKey record updates + instance PersistUniqueWrite SqlBackend where + + upsert record updates = do + conn <- ask + uniqueKey <- onlyUnique record + case connUpsertSql conn of + Just upsertSql -> case updates of + [] -> defaultUpsert record updates + xs -> do + let upds = T.intercalate "," $ map (go' . go) updates + sql = upsertSql t upds + vals = (map toPersistValue $ toPersistFields record) ++ (map updatePersistValue updates) ++ (unqs uniqueKey) + + go'' n Assign = n <> "=?" + go'' n Add = T.concat [n, "=", n, "+?"] + go'' n Subtract = T.concat [n, "=", n, "-?"] + go'' n Multiply = T.concat [n, "=", n, "*?"] + go'' n Divide = T.concat [n, "=", n, "/?"] + go'' _ (BackendSpecificUpdate up) = error $ T.unpack $ "BackendSpecificUpdate" `mappend` up `mappend` "not supported" + + go' (x, pu) = go'' (connEscapeName conn x) pu + go x = (fieldDB $ updateFieldDef x, updateUpdate x) + + x <- rawSql sql vals + return $ head x + Nothing -> defaultUpsert record updates + where + t = entityDef $ Just record + unqs uniqueKey = concat $ map (persistUniqueToValues) [uniqueKey] + deleteBy uniq = do conn <- ask let sql' = sql conn @@ -69,3 +106,12 @@ dummyFromUnique :: Unique v -> Maybe v dummyFromUnique _ = Nothing + + +updateFieldDef :: PersistEntity v => Update v -> FieldDef +updateFieldDef (Update f _ _) = persistFieldDef f +updateFieldDef (BackendUpdate {}) = error "updateFieldDef did not expect BackendUpdate" + +updatePersistValue :: Update v -> PersistValue +updatePersistValue (Update _ v _) = toPersistValue v +updatePersistValue (BackendUpdate {}) = error "updatePersistValue did not expect BackendUpdate" diff --git a/Database/Persist/Sql/Types/Internal.hs b/Database/Persist/Sql/Types/Internal.hs --- a/Database/Persist/Sql/Types/Internal.hs +++ b/Database/Persist/Sql/Types/Internal.hs @@ -65,6 +65,7 @@ -- | table name, column names, id name, either 1 or 2 statements to run , connInsertSql :: EntityDef -> [PersistValue] -> InsertSqlResult , connInsertManySql :: Maybe (EntityDef -> [[PersistValue]] -> InsertSqlResult) -- ^ SQL for inserting many rows and returning their primary keys, for backends that support this functioanlity. If 'Nothing', rows will be inserted one-at-a-time using 'connInsertSql'. + , connUpsertSql :: Maybe (EntityDef -> Text -> Text) , connStmtMap :: IORef (Map Text Statement) , connClose :: IO () , connMigrateSql diff --git a/Database/Persist/Types/Base.hs b/Database/Persist/Types/Base.hs --- a/Database/Persist/Types/Base.hs +++ b/Database/Persist/Types/Base.hs @@ -218,8 +218,20 @@ _ -> Nothing } +-- Type for storing the Uniqueness constraint in the Schema. +-- Assume you have the following schema with a uniqueness +-- constraint: +-- Person +-- name String +-- age Int +-- UniqueAge age +-- +-- This will be represented as: +-- UniqueDef (HaskellName (packPTH "UniqueAge")) +-- (DBName (packPTH "unique_age")) [(HaskellName (packPTH "age"), DBName (packPTH "age"))] [] +-- data UniqueDef = UniqueDef - { uniqueHaskell :: !HaskellName + { uniqueHaskell :: !HaskellName , uniqueDBName :: !DBName , uniqueFields :: ![(HaskellName, DBName)] , uniqueAttrs :: ![Attr] diff --git a/persistent.cabal b/persistent.cabal --- a/persistent.cabal +++ b/persistent.cabal @@ -1,5 +1,5 @@ name: persistent -version: 2.5 +version: 2.6 license: MIT license-file: LICENSE author: Michael Snoyman