persistent 2.5 → 2.6
raw patch · 8 files changed
+107/−23 lines, 8 filesdep ~http-api-data
Dependency ranges changed: http-api-data
Files
- ChangeLog.md +4/−0
- Database/Persist/Class/PersistUnique.hs +16/−0
- Database/Persist/Quasi.hs +4/−2
- Database/Persist/Sql/Orphan/PersistQuery.hs +21/−18
- Database/Persist/Sql/Orphan/PersistUnique.hs +47/−1
- Database/Persist/Sql/Types/Internal.hs +1/−0
- Database/Persist/Types/Base.hs +13/−1
- persistent.cabal +1/−1
ChangeLog.md view
@@ -1,3 +1,7 @@+## 2.6++* Add `connUpsertSql` type for providing backend-specific upsert sql support.+ ## 2.5 * read/write typeclass split
Database/Persist/Class/PersistUnique.hs view
@@ -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
Database/Persist/Quasi.hs view
@@ -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
Database/Persist/Sql/Orphan/PersistQuery.hs view
@@ -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- ] + ]
Database/Persist/Sql/Orphan/PersistUnique.hs view
@@ -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"
Database/Persist/Sql/Types/Internal.hs view
@@ -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
Database/Persist/Types/Base.hs view
@@ -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]
persistent.cabal view
@@ -1,5 +1,5 @@ name: persistent-version: 2.5+version: 2.6 license: MIT license-file: LICENSE author: Michael Snoyman <michael@snoyman.com>