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

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

import Database.Persist.Sql.Types.Internal
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 :: 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

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

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

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