{-# LANGUAGE ExplicitForAll #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Database.Persist.Sql.Orphan.PersistUnique () where import Control.Exception (throwIO) import Control.Monad.IO.Class (liftIO) import Control.Monad.Trans.Reader (ask) import qualified Data.Conduit.List as CL import Data.Function (on) import Data.List (nubBy) import qualified Data.List.NonEmpty as NEL import Data.Monoid (mappend) import qualified Data.Text as T import Database.Persist import Database.Persist.Class.PersistUnique (defaultUpsertBy, defaultPutMany, persistUniqueKeyValues) import Database.Persist.Sql.Types import Database.Persist.Sql.Raw import Database.Persist.Sql.Orphan.PersistStore (withRawQuery) import Database.Persist.Sql.Util (dbColumns, parseEntityValues, updatePersistValue, mkUpdateText') instance PersistUniqueWrite SqlBackend where upsertBy :: Unique record -> record -> [Update record] -> ReaderT SqlBackend m (Entity record) upsertBy Unique record uniqueKey record record [Update record] updates = do SqlBackend conn <- ReaderT SqlBackend m SqlBackend forall (m :: * -> *) r. Monad m => ReaderT r m r ask let refCol :: Text -> Text refCol Text n = [Text] -> Text T.concat [SqlBackend -> EntityDef -> Text connEscapeTableName SqlBackend conn EntityDef t, Text ".", Text n] let mkUpdateText :: Update record -> Text mkUpdateText = (FieldNameDB -> Text) -> (Text -> Text) -> Update record -> Text forall record. PersistEntity record => (FieldNameDB -> Text) -> (Text -> Text) -> Update record -> Text mkUpdateText' (SqlBackend -> FieldNameDB -> Text connEscapeFieldName SqlBackend conn) Text -> Text refCol case SqlBackend -> Maybe (EntityDef -> NonEmpty (FieldNameHS, FieldNameDB) -> Text -> Text) connUpsertSql SqlBackend conn of Just EntityDef -> NonEmpty (FieldNameHS, FieldNameDB) -> Text -> Text upsertSql -> case [Update record] updates of [] -> Unique record -> record -> [Update record] -> ReaderT SqlBackend m (Entity record) forall record backend (m :: * -> *). (PersistEntityBackend record ~ BaseBackend backend, PersistEntity record, MonadIO m, PersistStoreWrite backend, PersistUniqueRead backend) => Unique record -> record -> [Update record] -> ReaderT backend m (Entity record) defaultUpsertBy Unique record uniqueKey record record [Update record] updates Update record _:[Update record] _ -> do let upds :: Text upds = Text -> [Text] -> Text T.intercalate Text "," ([Text] -> Text) -> [Text] -> Text forall a b. (a -> b) -> a -> b $ (Update record -> Text) -> [Update record] -> [Text] forall a b. (a -> b) -> [a] -> [b] map Update record -> Text mkUpdateText [Update record] updates sql :: Text sql = EntityDef -> NonEmpty (FieldNameHS, FieldNameDB) -> Text -> Text upsertSql EntityDef t ([(FieldNameHS, FieldNameDB)] -> NonEmpty (FieldNameHS, FieldNameDB) forall a. [a] -> NonEmpty a NEL.fromList ([(FieldNameHS, FieldNameDB)] -> NonEmpty (FieldNameHS, FieldNameDB)) -> [(FieldNameHS, FieldNameDB)] -> NonEmpty (FieldNameHS, FieldNameDB) forall a b. (a -> b) -> a -> b $ Unique record -> [(FieldNameHS, FieldNameDB)] forall record. PersistEntity record => Unique record -> [(FieldNameHS, FieldNameDB)] persistUniqueToFieldNames Unique record uniqueKey) Text upds vals :: [PersistValue] vals = (SomePersistField -> PersistValue) -> [SomePersistField] -> [PersistValue] forall a b. (a -> b) -> [a] -> [b] map SomePersistField -> PersistValue forall a. PersistField a => a -> PersistValue toPersistValue (record -> [SomePersistField] forall record. PersistEntity record => record -> [SomePersistField] toPersistFields record record) [PersistValue] -> [PersistValue] -> [PersistValue] forall a. [a] -> [a] -> [a] ++ (Update record -> PersistValue) -> [Update record] -> [PersistValue] forall a b. (a -> b) -> [a] -> [b] map Update record -> PersistValue forall v. Update v -> PersistValue updatePersistValue [Update record] updates [PersistValue] -> [PersistValue] -> [PersistValue] forall a. [a] -> [a] -> [a] ++ Unique record -> [PersistValue] forall record. PersistEntity record => Unique record -> [PersistValue] unqs Unique record uniqueKey [Entity record] x <- Text -> [PersistValue] -> ReaderT SqlBackend m [Entity record] forall a (m :: * -> *) backend. (RawSql a, MonadIO m, BackendCompatible SqlBackend backend) => Text -> [PersistValue] -> ReaderT backend m [a] rawSql Text sql [PersistValue] vals Entity record -> ReaderT SqlBackend m (Entity record) forall (m :: * -> *) a. Monad m => a -> m a return (Entity record -> ReaderT SqlBackend m (Entity record)) -> Entity record -> ReaderT SqlBackend m (Entity record) forall a b. (a -> b) -> a -> b $ [Entity record] -> Entity record forall a. [a] -> a head [Entity record] x Maybe (EntityDef -> NonEmpty (FieldNameHS, FieldNameDB) -> Text -> Text) Nothing -> Unique record -> record -> [Update record] -> ReaderT SqlBackend m (Entity record) forall record backend (m :: * -> *). (PersistEntityBackend record ~ BaseBackend backend, PersistEntity record, MonadIO m, PersistStoreWrite backend, PersistUniqueRead backend) => Unique record -> record -> [Update record] -> ReaderT backend m (Entity record) defaultUpsertBy Unique record uniqueKey record record [Update record] updates where t :: EntityDef t = Maybe record -> EntityDef forall record (proxy :: * -> *). PersistEntity record => proxy record -> EntityDef entityDef (Maybe record -> EntityDef) -> Maybe record -> EntityDef forall a b. (a -> b) -> a -> b $ record -> Maybe record forall a. a -> Maybe a Just record record unqs :: Unique record -> [PersistValue] unqs Unique record uniqueKey' = (Unique record -> [PersistValue]) -> [Unique record] -> [PersistValue] forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b] concatMap Unique record -> [PersistValue] forall record. PersistEntity record => Unique record -> [PersistValue] persistUniqueToValues [Unique record uniqueKey'] deleteBy :: Unique record -> ReaderT SqlBackend m () deleteBy Unique record uniq = do SqlBackend conn <- ReaderT SqlBackend m SqlBackend forall (m :: * -> *) r. Monad m => ReaderT r m r ask let sql' :: Text sql' = SqlBackend -> Text sql SqlBackend conn vals :: [PersistValue] vals = Unique record -> [PersistValue] forall record. PersistEntity record => Unique record -> [PersistValue] persistUniqueToValues Unique record uniq Text -> [PersistValue] -> ReaderT SqlBackend m () forall (m :: * -> *) backend. (MonadIO m, BackendCompatible SqlBackend backend) => Text -> [PersistValue] -> ReaderT backend m () rawExecute Text sql' [PersistValue] vals where t :: EntityDef t = Maybe record -> EntityDef forall record (proxy :: * -> *). PersistEntity record => proxy record -> EntityDef entityDef (Maybe record -> EntityDef) -> Maybe record -> EntityDef forall a b. (a -> b) -> a -> b $ Unique record -> Maybe record forall v. Unique v -> Maybe v dummyFromUnique Unique record uniq go :: Unique record -> [FieldNameDB] go = ((FieldNameHS, FieldNameDB) -> FieldNameDB) -> [(FieldNameHS, FieldNameDB)] -> [FieldNameDB] forall a b. (a -> b) -> [a] -> [b] map (FieldNameHS, FieldNameDB) -> FieldNameDB forall a b. (a, b) -> b snd ([(FieldNameHS, FieldNameDB)] -> [FieldNameDB]) -> (Unique record -> [(FieldNameHS, FieldNameDB)]) -> Unique record -> [FieldNameDB] forall b c a. (b -> c) -> (a -> b) -> a -> c . Unique record -> [(FieldNameHS, FieldNameDB)] forall record. PersistEntity record => Unique record -> [(FieldNameHS, FieldNameDB)] persistUniqueToFieldNames go' :: SqlBackend -> FieldNameDB -> Text go' SqlBackend conn FieldNameDB x = SqlBackend -> FieldNameDB -> Text connEscapeFieldName SqlBackend conn FieldNameDB x Text -> Text -> Text forall a. Monoid a => a -> a -> a `mappend` Text "=?" sql :: SqlBackend -> Text sql SqlBackend conn = [Text] -> Text T.concat [ Text "DELETE FROM " , SqlBackend -> EntityDef -> Text connEscapeTableName SqlBackend conn EntityDef t , Text " WHERE " , Text -> [Text] -> Text T.intercalate Text " AND " ([Text] -> Text) -> [Text] -> Text forall a b. (a -> b) -> a -> b $ (FieldNameDB -> Text) -> [FieldNameDB] -> [Text] forall a b. (a -> b) -> [a] -> [b] map (SqlBackend -> FieldNameDB -> Text go' SqlBackend conn) ([FieldNameDB] -> [Text]) -> [FieldNameDB] -> [Text] forall a b. (a -> b) -> a -> b $ Unique record -> [FieldNameDB] go Unique record uniq] putMany :: [record] -> ReaderT SqlBackend m () putMany [] = () -> ReaderT SqlBackend m () forall (m :: * -> *) a. Monad m => a -> m a return () putMany [record] rsD = do let uKeys :: [Unique record] uKeys = record -> [Unique record] forall record. PersistEntity record => record -> [Unique record] persistUniqueKeys (record -> [Unique record]) -> ([record] -> record) -> [record] -> [Unique record] forall b c a. (b -> c) -> (a -> b) -> a -> c . [record] -> record forall a. [a] -> a head ([record] -> [Unique record]) -> [record] -> [Unique record] forall a b. (a -> b) -> a -> b $ [record] rsD case [Unique record] uKeys of [] -> [record] -> ReaderT SqlBackend m () forall backend record (m :: * -> *). (PersistStoreWrite backend, MonadIO m, PersistRecordBackend record backend) => [record] -> ReaderT backend m () insertMany_ [record] rsD [Unique record] _ -> ReaderT SqlBackend m () go where go :: ReaderT SqlBackend m () go = do let rs :: [record] rs = (record -> record -> Bool) -> [record] -> [record] forall a. (a -> a -> Bool) -> [a] -> [a] nubBy ([PersistValue] -> [PersistValue] -> Bool forall a. Eq a => a -> a -> Bool (==) ([PersistValue] -> [PersistValue] -> Bool) -> (record -> [PersistValue]) -> record -> record -> Bool forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c `on` record -> [PersistValue] forall record. PersistEntity record => record -> [PersistValue] persistUniqueKeyValues) ([record] -> [record] forall a. [a] -> [a] reverse [record] rsD) let ent :: EntityDef ent = [record] -> EntityDef forall record (proxy :: * -> *). PersistEntity record => proxy record -> EntityDef entityDef [record] rs let nr :: Int nr = [record] -> Int forall (t :: * -> *) a. Foldable t => t a -> Int length [record] rs let toVals :: record -> [PersistValue] toVals record r = (SomePersistField -> PersistValue) -> [SomePersistField] -> [PersistValue] forall a b. (a -> b) -> [a] -> [b] map SomePersistField -> PersistValue forall a. PersistField a => a -> PersistValue toPersistValue ([SomePersistField] -> [PersistValue]) -> [SomePersistField] -> [PersistValue] forall a b. (a -> b) -> a -> b $ record -> [SomePersistField] forall record. PersistEntity record => record -> [SomePersistField] toPersistFields record r SqlBackend conn <- ReaderT SqlBackend m SqlBackend forall (m :: * -> *) r. Monad m => ReaderT r m r ask case SqlBackend -> Maybe (EntityDef -> Int -> Text) connPutManySql SqlBackend conn of (Just EntityDef -> Int -> Text mkSql) -> Text -> [PersistValue] -> ReaderT SqlBackend m () forall (m :: * -> *) backend. (MonadIO m, BackendCompatible SqlBackend backend) => Text -> [PersistValue] -> ReaderT backend m () rawExecute (EntityDef -> Int -> Text mkSql EntityDef ent Int nr) ((record -> [PersistValue]) -> [record] -> [PersistValue] forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b] concatMap record -> [PersistValue] forall record. PersistEntity record => record -> [PersistValue] toVals [record] rs) Maybe (EntityDef -> Int -> Text) Nothing -> [record] -> ReaderT SqlBackend m () forall record backend (m :: * -> *). (PersistEntityBackend record ~ BaseBackend backend, PersistEntity record, MonadIO m, PersistStoreWrite backend, PersistUniqueRead backend) => [record] -> ReaderT backend m () defaultPutMany [record] rs instance PersistUniqueWrite SqlWriteBackend where deleteBy :: Unique record -> ReaderT SqlWriteBackend m () deleteBy Unique record uniq = ReaderT (BaseBackend SqlWriteBackend) m () -> ReaderT SqlWriteBackend m () forall backend (m :: * -> *) a. HasPersistBackend backend => ReaderT (BaseBackend backend) m a -> ReaderT backend m a withBaseBackend (ReaderT (BaseBackend SqlWriteBackend) m () -> ReaderT SqlWriteBackend m ()) -> ReaderT (BaseBackend SqlWriteBackend) m () -> ReaderT SqlWriteBackend m () forall a b. (a -> b) -> a -> b $ Unique record -> ReaderT SqlBackend m () forall backend record (m :: * -> *). (PersistUniqueWrite backend, MonadIO m, PersistRecordBackend record backend) => Unique record -> ReaderT backend m () deleteBy Unique record uniq upsert :: record -> [Update record] -> ReaderT SqlWriteBackend m (Entity record) upsert record rs [Update record] us = ReaderT (BaseBackend SqlWriteBackend) m (Entity record) -> ReaderT SqlWriteBackend m (Entity record) forall backend (m :: * -> *) a. HasPersistBackend backend => ReaderT (BaseBackend backend) m a -> ReaderT backend m a withBaseBackend (ReaderT (BaseBackend SqlWriteBackend) m (Entity record) -> ReaderT SqlWriteBackend m (Entity record)) -> ReaderT (BaseBackend SqlWriteBackend) m (Entity record) -> ReaderT SqlWriteBackend m (Entity record) forall a b. (a -> b) -> a -> b $ record -> [Update record] -> ReaderT SqlBackend m (Entity record) forall backend record (m :: * -> *). (PersistUniqueWrite backend, MonadIO m, PersistRecordBackend record backend, OnlyOneUniqueKey record) => record -> [Update record] -> ReaderT backend m (Entity record) upsert record rs [Update record] us putMany :: [record] -> ReaderT SqlWriteBackend m () putMany [record] rs = ReaderT (BaseBackend SqlWriteBackend) m () -> ReaderT SqlWriteBackend m () forall backend (m :: * -> *) a. HasPersistBackend backend => ReaderT (BaseBackend backend) m a -> ReaderT backend m a withBaseBackend (ReaderT (BaseBackend SqlWriteBackend) m () -> ReaderT SqlWriteBackend m ()) -> ReaderT (BaseBackend SqlWriteBackend) m () -> ReaderT SqlWriteBackend m () forall a b. (a -> b) -> a -> b $ [record] -> ReaderT SqlBackend m () forall backend record (m :: * -> *). (PersistUniqueWrite backend, MonadIO m, PersistRecordBackend record backend) => [record] -> ReaderT backend m () putMany [record] rs instance PersistUniqueRead SqlBackend where getBy :: Unique record -> ReaderT SqlBackend m (Maybe (Entity record)) getBy Unique record uniq = do SqlBackend conn <- ReaderT SqlBackend m SqlBackend forall (m :: * -> *) r. Monad m => ReaderT r m r ask let sql :: Text sql = [Text] -> Text T.concat [ Text "SELECT " , Text -> [Text] -> Text T.intercalate Text "," ([Text] -> Text) -> [Text] -> Text forall a b. (a -> b) -> a -> b $ SqlBackend -> EntityDef -> [Text] dbColumns SqlBackend conn EntityDef t , Text " FROM " , SqlBackend -> EntityDef -> Text connEscapeTableName SqlBackend conn EntityDef t , Text " WHERE " , SqlBackend -> Text sqlClause SqlBackend conn] uvals :: [PersistValue] uvals = Unique record -> [PersistValue] forall record. PersistEntity record => Unique record -> [PersistValue] persistUniqueToValues Unique record uniq Text -> [PersistValue] -> ConduitM [PersistValue] Void IO (Maybe (Entity record)) -> ReaderT SqlBackend m (Maybe (Entity record)) forall (m :: * -> *) a. MonadIO m => Text -> [PersistValue] -> ConduitM [PersistValue] Void IO a -> ReaderT SqlBackend m a withRawQuery Text sql [PersistValue] uvals (ConduitM [PersistValue] Void IO (Maybe (Entity record)) -> ReaderT SqlBackend m (Maybe (Entity record))) -> ConduitM [PersistValue] Void IO (Maybe (Entity record)) -> ReaderT SqlBackend m (Maybe (Entity record)) forall a b. (a -> b) -> a -> b $ do Maybe [PersistValue] row <- ConduitT [PersistValue] Void IO (Maybe [PersistValue]) forall (m :: * -> *) a o. Monad m => ConduitT a o m (Maybe a) CL.head case Maybe [PersistValue] row of Maybe [PersistValue] Nothing -> Maybe (Entity record) -> ConduitM [PersistValue] Void IO (Maybe (Entity record)) forall (m :: * -> *) a. Monad m => a -> m a return Maybe (Entity record) forall a. Maybe a Nothing Just [] -> [Char] -> ConduitM [PersistValue] Void IO (Maybe (Entity record)) forall a. HasCallStack => [Char] -> a error [Char] "getBy: empty row" Just [PersistValue] vals -> case EntityDef -> [PersistValue] -> Either Text (Entity record) forall record. PersistEntity record => EntityDef -> [PersistValue] -> Either Text (Entity record) parseEntityValues EntityDef t [PersistValue] vals of Left Text err -> IO (Maybe (Entity record)) -> ConduitM [PersistValue] Void IO (Maybe (Entity record)) forall (m :: * -> *) a. MonadIO m => IO a -> m a liftIO (IO (Maybe (Entity record)) -> ConduitM [PersistValue] Void IO (Maybe (Entity record))) -> IO (Maybe (Entity record)) -> ConduitM [PersistValue] Void IO (Maybe (Entity record)) forall a b. (a -> b) -> a -> b $ PersistException -> IO (Maybe (Entity record)) forall e a. Exception e => e -> IO a throwIO (PersistException -> IO (Maybe (Entity record))) -> PersistException -> IO (Maybe (Entity record)) forall a b. (a -> b) -> a -> b $ Text -> PersistException PersistMarshalError Text err Right Entity record r -> Maybe (Entity record) -> ConduitM [PersistValue] Void IO (Maybe (Entity record)) forall (m :: * -> *) a. Monad m => a -> m a return (Maybe (Entity record) -> ConduitM [PersistValue] Void IO (Maybe (Entity record))) -> Maybe (Entity record) -> ConduitM [PersistValue] Void IO (Maybe (Entity record)) forall a b. (a -> b) -> a -> b $ Entity record -> Maybe (Entity record) forall a. a -> Maybe a Just Entity record r where sqlClause :: SqlBackend -> Text sqlClause SqlBackend conn = Text -> [Text] -> Text T.intercalate Text " AND " ([Text] -> Text) -> [Text] -> Text forall a b. (a -> b) -> a -> b $ (FieldNameDB -> Text) -> [FieldNameDB] -> [Text] forall a b. (a -> b) -> [a] -> [b] map (SqlBackend -> FieldNameDB -> Text go SqlBackend conn) ([FieldNameDB] -> [Text]) -> [FieldNameDB] -> [Text] forall a b. (a -> b) -> a -> b $ Unique record -> [FieldNameDB] toFieldNames' Unique record uniq go :: SqlBackend -> FieldNameDB -> Text go SqlBackend conn FieldNameDB x = SqlBackend -> FieldNameDB -> Text connEscapeFieldName SqlBackend conn FieldNameDB x Text -> Text -> Text forall a. Monoid a => a -> a -> a `mappend` Text "=?" t :: EntityDef t = Maybe record -> EntityDef forall record (proxy :: * -> *). PersistEntity record => proxy record -> EntityDef entityDef (Maybe record -> EntityDef) -> Maybe record -> EntityDef forall a b. (a -> b) -> a -> b $ Unique record -> Maybe record forall v. Unique v -> Maybe v dummyFromUnique Unique record uniq toFieldNames' :: Unique record -> [FieldNameDB] toFieldNames' = ((FieldNameHS, FieldNameDB) -> FieldNameDB) -> [(FieldNameHS, FieldNameDB)] -> [FieldNameDB] forall a b. (a -> b) -> [a] -> [b] map (FieldNameHS, FieldNameDB) -> FieldNameDB forall a b. (a, b) -> b snd ([(FieldNameHS, FieldNameDB)] -> [FieldNameDB]) -> (Unique record -> [(FieldNameHS, FieldNameDB)]) -> Unique record -> [FieldNameDB] forall b c a. (b -> c) -> (a -> b) -> a -> c . Unique record -> [(FieldNameHS, FieldNameDB)] forall record. PersistEntity record => Unique record -> [(FieldNameHS, FieldNameDB)] persistUniqueToFieldNames instance PersistUniqueRead SqlReadBackend where getBy :: Unique record -> ReaderT SqlReadBackend m (Maybe (Entity record)) getBy Unique record uniq = ReaderT (BaseBackend SqlReadBackend) m (Maybe (Entity record)) -> ReaderT SqlReadBackend m (Maybe (Entity record)) forall backend (m :: * -> *) a. HasPersistBackend backend => ReaderT (BaseBackend backend) m a -> ReaderT backend m a withBaseBackend (ReaderT (BaseBackend SqlReadBackend) m (Maybe (Entity record)) -> ReaderT SqlReadBackend m (Maybe (Entity record))) -> ReaderT (BaseBackend SqlReadBackend) m (Maybe (Entity record)) -> ReaderT SqlReadBackend m (Maybe (Entity record)) forall a b. (a -> b) -> a -> b $ Unique record -> ReaderT SqlBackend m (Maybe (Entity record)) forall backend record (m :: * -> *). (PersistUniqueRead backend, MonadIO m, PersistRecordBackend record backend) => Unique record -> ReaderT backend m (Maybe (Entity record)) getBy Unique record uniq instance PersistUniqueRead SqlWriteBackend where getBy :: Unique record -> ReaderT SqlWriteBackend m (Maybe (Entity record)) getBy Unique record uniq = ReaderT (BaseBackend SqlWriteBackend) m (Maybe (Entity record)) -> ReaderT SqlWriteBackend m (Maybe (Entity record)) forall backend (m :: * -> *) a. HasPersistBackend backend => ReaderT (BaseBackend backend) m a -> ReaderT backend m a withBaseBackend (ReaderT (BaseBackend SqlWriteBackend) m (Maybe (Entity record)) -> ReaderT SqlWriteBackend m (Maybe (Entity record))) -> ReaderT (BaseBackend SqlWriteBackend) m (Maybe (Entity record)) -> ReaderT SqlWriteBackend m (Maybe (Entity record)) forall a b. (a -> b) -> a -> b $ Unique record -> ReaderT SqlBackend m (Maybe (Entity record)) forall backend record (m :: * -> *). (PersistUniqueRead backend, MonadIO m, PersistRecordBackend record backend) => Unique record -> ReaderT backend m (Maybe (Entity record)) getBy Unique record uniq dummyFromUnique :: Unique v -> Maybe v dummyFromUnique :: Unique v -> Maybe v dummyFromUnique Unique v _ = Maybe v forall a. Maybe a Nothing