{-# 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.Foldable (toList)
import Data.Function (on)
import Data.List (nubBy)
import qualified Data.Text as T

import Database.Persist
import Database.Persist.Class.PersistUnique
       (defaultPutMany, defaultUpsertBy, persistUniqueKeyValues)

import Database.Persist.Sql.Orphan.PersistStore (withRawQuery)
import Database.Persist.Sql.Raw
import Database.Persist.Sql.Types.Internal
import Database.Persist.Sql.Util
       ( dbColumns
       , mkUpdateText'
       , parseEntityValues
       , parseExistsResult
       , updatePersistValue
       )

instance PersistUniqueWrite SqlBackend where
    upsertBy :: forall record (m :: * -> *).
(MonadIO m, PersistRecordBackend record SqlBackend,
 SafeToInsert record) =>
Unique record
-> record
-> [Update record]
-> ReaderT SqlBackend m (Entity record)
upsertBy Unique record
uniqueKey record
record [Update record]
updates = do
      SqlBackend
conn <- 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 = 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
                            [] -> forall record backend (m :: * -> *).
(PersistEntityBackend record ~ BaseBackend backend,
 PersistEntity record, MonadIO m, PersistStoreWrite backend,
 PersistUniqueRead backend, SafeToInsert record) =>
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
"," forall a b. (a -> b) -> a -> b
$ 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 (forall record.
PersistEntity record =>
Unique record -> NonEmpty (FieldNameHS, FieldNameDB)
persistUniqueToFieldNames Unique record
uniqueKey) Text
upds
                                    vals :: [PersistValue]
vals = forall a b. (a -> b) -> [a] -> [b]
map forall a. PersistField a => a -> PersistValue
toPersistValue (forall record. PersistEntity record => record -> [PersistValue]
toPersistFields record
record)
                                        forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map forall v. Update v -> PersistValue
updatePersistValue [Update record]
updates
                                        forall a. [a] -> [a] -> [a]
++ forall {record}.
PersistEntity record =>
Unique record -> [PersistValue]
unqs Unique record
uniqueKey

                                [Entity record]
x <- forall a (m :: * -> *) backend.
(RawSql a, MonadIO m, BackendCompatible SqlBackend backend) =>
Text -> [PersistValue] -> ReaderT backend m [a]
rawSql Text
sql [PersistValue]
vals
                                forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. [a] -> a
head [Entity record]
x
        Maybe
  (EntityDef -> NonEmpty (FieldNameHS, FieldNameDB) -> Text -> Text)
Nothing -> forall record backend (m :: * -> *).
(PersistEntityBackend record ~ BaseBackend backend,
 PersistEntity record, MonadIO m, PersistStoreWrite backend,
 PersistUniqueRead backend, SafeToInsert record) =>
Unique record
-> record -> [Update record] -> ReaderT backend m (Entity record)
defaultUpsertBy Unique record
uniqueKey record
record [Update record]
updates
        where
          t :: EntityDef
t = forall record (proxy :: * -> *).
PersistEntity record =>
proxy record -> EntityDef
entityDef forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just record
record
          unqs :: Unique record -> [PersistValue]
unqs Unique record
uniqueKey' = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall {record}.
PersistEntity record =>
Unique record -> [PersistValue]
persistUniqueToValues [Unique record
uniqueKey']

    deleteBy :: forall record (m :: * -> *).
(MonadIO m, PersistRecordBackend record SqlBackend) =>
Unique record -> ReaderT SqlBackend m ()
deleteBy Unique record
uniq = do
        SqlBackend
conn <- forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
        let sql' :: Text
sql' = SqlBackend -> Text
sql SqlBackend
conn
            vals :: [PersistValue]
vals = forall {record}.
PersistEntity record =>
Unique record -> [PersistValue]
persistUniqueToValues Unique record
uniq
        forall (m :: * -> *) backend.
(MonadIO m, BackendCompatible SqlBackend backend) =>
Text -> [PersistValue] -> ReaderT backend m ()
rawExecute Text
sql' [PersistValue]
vals
      where
        t :: EntityDef
t = forall record (proxy :: * -> *).
PersistEntity record =>
proxy record -> EntityDef
entityDef forall a b. (a -> b) -> a -> b
$ forall v. Unique v -> Maybe v
dummyFromUnique Unique record
uniq
        go :: Unique record -> [FieldNameDB]
go = forall (t :: * -> *) a. Foldable t => t a -> [a]
toList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall record.
PersistEntity record =>
Unique record -> NonEmpty (FieldNameHS, FieldNameDB)
persistUniqueToFieldNames
        go' :: SqlBackend -> FieldNameDB -> Text
go' SqlBackend
conn FieldNameDB
x = SqlBackend -> FieldNameDB -> Text
connEscapeFieldName SqlBackend
conn FieldNameDB
x 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 " forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (SqlBackend -> FieldNameDB -> Text
go' SqlBackend
conn) forall a b. (a -> b) -> a -> b
$ Unique record -> [FieldNameDB]
go Unique record
uniq]

    putMany :: forall record (m :: * -> *).
(MonadIO m, PersistRecordBackend record SqlBackend,
 SafeToInsert record) =>
[record] -> ReaderT SqlBackend m ()
putMany [] = forall (m :: * -> *) a. Monad m => a -> m a
return ()
    putMany [record]
rsD = do
        let uKeys :: [Unique record]
uKeys = forall record. PersistEntity record => record -> [Unique record]
persistUniqueKeys forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> a
head forall a b. (a -> b) -> a -> b
$ [record]
rsD
        case [Unique record]
uKeys of
            [] -> forall backend record (m :: * -> *).
(PersistStoreWrite backend, MonadIO m,
 PersistRecordBackend record backend, SafeToInsert record) =>
[record] -> ReaderT backend m ()
insertMany_ [record]
rsD
            [Unique record]
_ -> ReaderT SqlBackend m ()
go
        where
          go :: ReaderT SqlBackend m ()
go = do
            let rs :: [record]
rs = forall a. (a -> a -> Bool) -> [a] -> [a]
nubBy (forall a. Eq a => a -> a -> Bool
(==) forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` forall record. PersistEntity record => record -> [PersistValue]
persistUniqueKeyValues) (forall a. [a] -> [a]
reverse [record]
rsD)
            let ent :: EntityDef
ent = forall record (proxy :: * -> *).
PersistEntity record =>
proxy record -> EntityDef
entityDef [record]
rs
            let nr :: Int
nr  = forall (t :: * -> *) a. Foldable t => t a -> Int
length [record]
rs
            let toVals :: record -> [PersistValue]
toVals record
r = forall a b. (a -> b) -> [a] -> [b]
map forall a. PersistField a => a -> PersistValue
toPersistValue forall a b. (a -> b) -> a -> b
$ forall record. PersistEntity record => record -> [PersistValue]
toPersistFields record
r
            SqlBackend
conn <- 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) -> forall (m :: * -> *) backend.
(MonadIO m, BackendCompatible SqlBackend backend) =>
Text -> [PersistValue] -> ReaderT backend m ()
rawExecute (EntityDef -> Int -> Text
mkSql EntityDef
ent Int
nr) (forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall record. PersistEntity record => record -> [PersistValue]
toVals [record]
rs)
                Maybe (EntityDef -> Int -> Text)
Nothing -> forall record backend (m :: * -> *).
(PersistEntityBackend record ~ BaseBackend backend,
 PersistEntity record, MonadIO m, PersistStoreWrite backend,
 PersistUniqueRead backend, SafeToInsert record) =>
[record] -> ReaderT backend m ()
defaultPutMany [record]
rs

instance PersistUniqueWrite SqlWriteBackend where
    deleteBy :: forall record (m :: * -> *).
(MonadIO m, PersistRecordBackend record SqlWriteBackend) =>
Unique record -> ReaderT SqlWriteBackend m ()
deleteBy Unique record
uniq = forall backend (m :: * -> *) a.
HasPersistBackend backend =>
ReaderT (BaseBackend backend) m a -> ReaderT backend m a
withBaseBackend forall a b. (a -> b) -> a -> b
$ forall backend record (m :: * -> *).
(PersistUniqueWrite backend, MonadIO m,
 PersistRecordBackend record backend) =>
Unique record -> ReaderT backend m ()
deleteBy Unique record
uniq
    upsert :: forall record (m :: * -> *).
(MonadIO m, PersistRecordBackend record SqlWriteBackend,
 OnlyOneUniqueKey record, SafeToInsert record) =>
record
-> [Update record] -> ReaderT SqlWriteBackend m (Entity record)
upsert record
rs [Update record]
us = forall backend (m :: * -> *) a.
HasPersistBackend backend =>
ReaderT (BaseBackend backend) m a -> ReaderT backend m a
withBaseBackend forall a b. (a -> b) -> a -> b
$ forall backend record (m :: * -> *).
(PersistUniqueWrite backend, MonadIO m,
 PersistRecordBackend record backend, OnlyOneUniqueKey record,
 SafeToInsert record) =>
record -> [Update record] -> ReaderT backend m (Entity record)
upsert record
rs [Update record]
us
    putMany :: forall record (m :: * -> *).
(MonadIO m, PersistRecordBackend record SqlWriteBackend,
 SafeToInsert record) =>
[record] -> ReaderT SqlWriteBackend m ()
putMany [record]
rs = forall backend (m :: * -> *) a.
HasPersistBackend backend =>
ReaderT (BaseBackend backend) m a -> ReaderT backend m a
withBaseBackend forall a b. (a -> b) -> a -> b
$ forall backend record (m :: * -> *).
(PersistUniqueWrite backend, MonadIO m,
 PersistRecordBackend record backend, SafeToInsert record) =>
[record] -> ReaderT backend m ()
putMany [record]
rs

instance PersistUniqueRead SqlBackend where
    getBy :: forall record (m :: * -> *).
(MonadIO m, PersistRecordBackend record SqlBackend) =>
Unique record -> ReaderT SqlBackend m (Maybe (Entity record))
getBy Unique record
uniq = do
        SqlBackend
conn <- 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
"," forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> [a]
toList forall a b. (a -> b) -> a -> b
$ SqlBackend -> EntityDef -> NonEmpty 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 = forall {record}.
PersistEntity record =>
Unique record -> [PersistValue]
persistUniqueToValues Unique record
uniq
        forall (m :: * -> *) a.
MonadIO m =>
Text
-> [PersistValue]
-> ConduitM [PersistValue] Void IO a
-> ReaderT SqlBackend m a
withRawQuery Text
sql [PersistValue]
uvals forall a b. (a -> b) -> a -> b
$
            do Maybe [PersistValue]
row <- forall (m :: * -> *) a o. Monad m => ConduitT a o m (Maybe a)
CL.head
               case Maybe [PersistValue]
row of
                   Maybe [PersistValue]
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
                   Just [] -> forall a. HasCallStack => [Char] -> a
error [Char]
"getBy: empty row"
                   Just [PersistValue]
vals ->
                       case forall record.
PersistEntity record =>
EntityDef -> [PersistValue] -> Either Text (Entity record)
parseEntityValues EntityDef
t [PersistValue]
vals of
                           Left Text
err ->
                               forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall e a. Exception e => e -> IO a
throwIO forall a b. (a -> b) -> a -> b
$ Text -> PersistException
PersistMarshalError Text
err
                           Right Entity record
r -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just Entity record
r
      where
        sqlClause :: SqlBackend -> Text
sqlClause SqlBackend
conn =
            Text -> [Text] -> Text
T.intercalate Text
" AND " forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (SqlBackend -> FieldNameDB -> Text
go SqlBackend
conn) 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 forall a. Monoid a => a -> a -> a
`mappend` Text
"=?"
        t :: EntityDef
t = forall record (proxy :: * -> *).
PersistEntity record =>
proxy record -> EntityDef
entityDef forall a b. (a -> b) -> a -> b
$ forall v. Unique v -> Maybe v
dummyFromUnique Unique record
uniq
        toFieldNames' :: Unique record -> [FieldNameDB]
toFieldNames' = forall (t :: * -> *) a. Foldable t => t a -> [a]
toList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall record.
PersistEntity record =>
Unique record -> NonEmpty (FieldNameHS, FieldNameDB)
persistUniqueToFieldNames

    existsBy :: forall record (m :: * -> *).
(MonadIO m, PersistRecordBackend record SqlBackend) =>
Unique record -> ReaderT SqlBackend m Bool
existsBy Unique record
uniq = do
        SqlBackend
conn <- forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
        let sql :: Text
sql =
                [Text] -> Text
T.concat
                    [ Text
"SELECT EXISTS(SELECT 1 FROM "
                    , SqlBackend -> EntityDef -> Text
connEscapeTableName SqlBackend
conn EntityDef
t
                    , Text
" WHERE "
                    , SqlBackend -> Text
sqlClause SqlBackend
conn
                    , Text
")"
                    ]
            uvals :: [PersistValue]
uvals = forall {record}.
PersistEntity record =>
Unique record -> [PersistValue]
persistUniqueToValues Unique record
uniq
        forall (m :: * -> *) a.
MonadIO m =>
Text
-> [PersistValue]
-> ConduitM [PersistValue] Void IO a
-> ReaderT SqlBackend m a
withRawQuery Text
sql [PersistValue]
uvals forall a b. (a -> b) -> a -> b
$ do
            Maybe [PersistValue]
mm <- forall (m :: * -> *) a o. Monad m => ConduitT a o m (Maybe a)
CL.head
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Maybe [PersistValue] -> Text -> [Char] -> Bool
parseExistsResult Maybe [PersistValue]
mm Text
sql [Char]
"PersistUnique.existsBy"
      where
        sqlClause :: SqlBackend -> Text
sqlClause SqlBackend
conn =
            Text -> [Text] -> Text
T.intercalate Text
" AND " forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (SqlBackend -> FieldNameDB -> Text
go SqlBackend
conn) 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 forall a. Monoid a => a -> a -> a
`mappend` Text
"=?"
        t :: EntityDef
t = forall record (proxy :: * -> *).
PersistEntity record =>
proxy record -> EntityDef
entityDef forall a b. (a -> b) -> a -> b
$ forall v. Unique v -> Maybe v
dummyFromUnique Unique record
uniq
        toFieldNames' :: Unique record -> [FieldNameDB]
toFieldNames' = forall (t :: * -> *) a. Foldable t => t a -> [a]
toList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall record.
PersistEntity record =>
Unique record -> NonEmpty (FieldNameHS, FieldNameDB)
persistUniqueToFieldNames

instance PersistUniqueRead SqlReadBackend where
    getBy :: forall record (m :: * -> *).
(MonadIO m, PersistRecordBackend record SqlReadBackend) =>
Unique record -> ReaderT SqlReadBackend m (Maybe (Entity record))
getBy Unique record
uniq = forall backend (m :: * -> *) a.
HasPersistBackend backend =>
ReaderT (BaseBackend backend) m a -> ReaderT backend m a
withBaseBackend forall a b. (a -> b) -> a -> b
$ forall backend record (m :: * -> *).
(PersistUniqueRead backend, MonadIO m,
 PersistRecordBackend record backend) =>
Unique record -> ReaderT backend m (Maybe (Entity record))
getBy Unique record
uniq
    existsBy :: forall record (m :: * -> *).
(MonadIO m, PersistRecordBackend record SqlReadBackend) =>
Unique record -> ReaderT SqlReadBackend m Bool
existsBy Unique record
uniq = forall backend (m :: * -> *) a.
HasPersistBackend backend =>
ReaderT (BaseBackend backend) m a -> ReaderT backend m a
withBaseBackend forall a b. (a -> b) -> a -> b
$ forall backend record (m :: * -> *).
(PersistUniqueRead backend, MonadIO m,
 PersistRecordBackend record backend) =>
Unique record -> ReaderT backend m Bool
existsBy Unique record
uniq

instance PersistUniqueRead SqlWriteBackend where
    getBy :: forall record (m :: * -> *).
(MonadIO m, PersistRecordBackend record SqlWriteBackend) =>
Unique record -> ReaderT SqlWriteBackend m (Maybe (Entity record))
getBy Unique record
uniq = forall backend (m :: * -> *) a.
HasPersistBackend backend =>
ReaderT (BaseBackend backend) m a -> ReaderT backend m a
withBaseBackend forall a b. (a -> b) -> a -> b
$ forall backend record (m :: * -> *).
(PersistUniqueRead backend, MonadIO m,
 PersistRecordBackend record backend) =>
Unique record -> ReaderT backend m (Maybe (Entity record))
getBy Unique record
uniq
    existsBy :: forall record (m :: * -> *).
(MonadIO m, PersistRecordBackend record SqlWriteBackend) =>
Unique record -> ReaderT SqlWriteBackend m Bool
existsBy Unique record
uniq = forall backend (m :: * -> *) a.
HasPersistBackend backend =>
ReaderT (BaseBackend backend) m a -> ReaderT backend m a
withBaseBackend forall a b. (a -> b) -> a -> b
$ forall backend record (m :: * -> *).
(PersistUniqueRead backend, MonadIO m,
 PersistRecordBackend record backend) =>
Unique record -> ReaderT backend m Bool
existsBy Unique record
uniq

dummyFromUnique :: Unique v -> Maybe v
dummyFromUnique :: forall v. Unique v -> Maybe v
dummyFromUnique Unique v
_ = forall a. Maybe a
Nothing