1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
|
{-# LANGUAGE CPP #-}
{-# LANGUAGE TypeFamilies, FlexibleContexts #-}
module Database.Persist.Class.PersistUnique
( PersistUnique (..)
, getByValue
, insertBy
, replaceUnique
, checkUnique
) where
import qualified Prelude
import Prelude hiding ((++), show)
import Control.Monad (liftM)
import Control.Monad.Trans.Error (Error (..))
import Control.Monad.Trans.Class (lift)
import Data.Monoid (Monoid)
import Data.List ((\\))
import Data.Conduit.Internal (Pipe)
import Control.Monad.Logger (LoggingT)
import Control.Monad.Trans.Identity ( IdentityT)
import Control.Monad.Trans.List ( ListT )
import Control.Monad.Trans.Maybe ( MaybeT )
import Control.Monad.Trans.Error ( ErrorT )
import Control.Monad.Trans.Reader ( ReaderT )
import Control.Monad.Trans.Cont ( ContT )
import Control.Monad.Trans.State ( StateT )
import Control.Monad.Trans.Writer ( WriterT )
import Control.Monad.Trans.RWS ( RWST )
import Control.Monad.Trans.Resource ( ResourceT)
import qualified Control.Monad.Trans.RWS.Strict as Strict ( RWST )
import qualified Control.Monad.Trans.State.Strict as Strict ( StateT )
import qualified Control.Monad.Trans.Writer.Strict as Strict ( WriterT )
import Database.Persist.Class.PersistStore
import Database.Persist.Class.PersistEntity
-- | Queries against unique keys (other than the id).
--
-- Please read the general Persistent documentation to learn how to create
-- Unique keys.
-- SQL backends automatically create uniqueness constraints, but for MongoDB you must manually place a unique index on the field.
--
-- Some functions in this module (insertUnique, insertBy, and replaceUnique) first query the unique indexes to check for conflicts.
-- You could instead optimistically attempt to perform the operation (e.g. replace instead of replaceUnique). However,
--
-- * there is some fragility to trying to catch the correct exception and determing the column of failure.
--
-- * an exception will automatically abort the current SQL transaction
class PersistStore m => PersistUnique m where
-- | Get a record by unique key, if available. Returns also the identifier.
getBy :: (PersistEntityBackend val ~ PersistMonadBackend m, PersistEntity val) => Unique val -> m (Maybe (Entity val))
-- | Delete a specific record by unique key. Does nothing if no record
-- matches.
deleteBy :: (PersistEntityBackend val ~ PersistMonadBackend m, PersistEntity val) => Unique val -> m ()
-- | Like 'insert', but returns 'Nothing' when the record
-- couldn't be inserted because of a uniqueness constraint.
insertUnique :: (PersistEntityBackend val ~ PersistMonadBackend m, PersistEntity val) => val -> m (Maybe (Key val))
insertUnique datum = do
conflict <- checkUnique datum
case conflict of
Nothing -> Just `liftM` insert datum
Just _ -> return Nothing
-- | Insert a value, checking for conflicts with any unique constraints. If a
-- duplicate exists in the database, it is returned as 'Left'. Otherwise, the
-- new 'Key is returned as 'Right'.
insertBy :: (PersistEntity val, PersistUnique m, PersistEntityBackend val ~ PersistMonadBackend m)
=> val -> m (Either (Entity val) (Key val))
insertBy val = do
res <- getByValue val
case res of
Nothing -> Right `liftM` insert val
Just z -> return $ Left z
-- | A modification of 'getBy', which takes the 'PersistEntity' itself instead
-- of a 'Unique' value. Returns a value matching /one/ of the unique keys. This
-- function makes the most sense on entities with a single 'Unique'
-- constructor.
getByValue :: (PersistEntity value, PersistUnique m, PersistEntityBackend value ~ PersistMonadBackend m)
=> value -> m (Maybe (Entity value))
getByValue = checkUniques . persistUniqueKeys
where
checkUniques [] = return Nothing
checkUniques (x:xs) = do
y <- getBy x
case y of
Nothing -> checkUniques xs
Just z -> return $ Just z
-- | Attempt to replace the record of the given key with the given new record.
-- First query the unique fields to make sure the replacement maintains uniqueness constraints.
-- Return 'Nothing' if the replacement was made.
-- If uniqueness is violated, return a 'Just' with the 'Unique' violation
--
-- Since 1.2.2.0
replaceUnique :: (Eq record, Eq (Unique record), PersistEntityBackend record ~ PersistMonadBackend m, PersistEntity record, PersistStore m, PersistUnique m)
=> Key record -> record -> m (Maybe (Unique record))
replaceUnique key datumNew = getJust key >>= replaceOriginal
where
uniqueKeysNew = persistUniqueKeys datumNew
replaceOriginal original = do
conflict <- checkUniqueKeys changedKeys
case conflict of
Nothing -> replace key datumNew >> return Nothing
(Just conflictingKey) -> return $ Just conflictingKey
where
changedKeys = uniqueKeysNew \\ uniqueKeysOriginal
uniqueKeysOriginal = persistUniqueKeys original
-- | Check whether there are any conflicts for unique keys with this entity and
-- existing entities in the database.
--
-- Returns 'Nothing' if the entity would be unique, and could thus safely be inserted.
-- on a conflict returns the conflicting key
checkUnique :: (PersistEntityBackend record ~ PersistMonadBackend m, PersistEntity record, PersistUnique m)
=> record -> m (Maybe (Unique record))
checkUnique = checkUniqueKeys . persistUniqueKeys
checkUniqueKeys :: (PersistEntity record, PersistUnique m, PersistEntityBackend record ~ PersistMonadBackend m)
=> [Unique record] -> m (Maybe (Unique record))
checkUniqueKeys [] = return Nothing
checkUniqueKeys (x:xs) = do
y <- getBy x
case y of
Nothing -> checkUniqueKeys xs
Just _ -> return (Just x)
#define DEF(T) { getBy = lift . getBy; deleteBy = lift . deleteBy; insertUnique = lift . insertUnique }
#define GO(T) instance (PersistUnique m) => PersistUnique (T m) where DEF(T)
#define GOX(X, T) instance (X, PersistUnique m) => PersistUnique (T m) where DEF(T)
GO(LoggingT)
GO(IdentityT)
GO(ListT)
GO(MaybeT)
GOX(Error e, ErrorT e)
GO(ReaderT r)
GO(ContT r)
GO(StateT s)
GO(ResourceT)
GO(Pipe l i o u)
GOX(Monoid w, WriterT w)
GOX(Monoid w, RWST r w s)
GOX(Monoid w, Strict.RWST r w s)
GO(Strict.StateT s)
GOX(Monoid w, Strict.WriterT w)
#undef DEF
#undef GO
#undef GOX
|
