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
|
{-# LANGUAGE CPP #-}
{-# LANGUAGE TypeFamilies, FlexibleContexts #-}
module Database.Persist.Class.PersistStore
( PersistStore (..)
, getJust
, belongsTo
, belongsToJust
) where
import qualified Prelude
import Prelude hiding ((++), show)
import qualified Data.Text as T
import Control.Monad.Trans.Error (Error (..))
import Control.Monad.Trans.Class (lift)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Data.Monoid (Monoid)
import Control.Exception.Lifted (throwIO)
import Data.Conduit.Internal (Pipe, ConduitM)
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.PersistEntity
import Database.Persist.Types
class MonadIO m => PersistStore m where
type PersistMonadBackend m
-- | Get a record by identifier, if available.
get :: (PersistMonadBackend m ~ PersistEntityBackend val, PersistEntity val)
=> Key val -> m (Maybe val)
-- | Create a new record in the database, returning an automatically created
-- key (in SQL an auto-increment id).
insert :: (PersistMonadBackend m ~ PersistEntityBackend val, PersistEntity val)
=> val -> m (Key val)
-- | Same as 'insert', but doesn't return a @Key@.
insert_ :: (PersistMonadBackend m ~ PersistEntityBackend val, PersistEntity val)
=> val -> m ()
insert_ val = insert val >> return ()
-- | Create multiple records in the database.
-- SQL backends currently use the slow default implementation of
-- @mapM insert@
insertMany :: (PersistMonadBackend m ~ PersistEntityBackend val, PersistEntity val)
=> [val] -> m [Key val]
insertMany = mapM insert
-- | Create a new record in the database using the given key.
insertKey :: (PersistMonadBackend m ~ PersistEntityBackend val, PersistEntity val)
=> Key val -> val -> m ()
-- | Put the record in the database with the given key.
-- Unlike 'replace', if a record with the given key does not
-- exist then a new record will be inserted.
repsert :: (PersistMonadBackend m ~ PersistEntityBackend val, PersistEntity val)
=> Key val -> val -> m ()
-- | Replace the record in the database with the given
-- key. Note that the result is undefined if such record does
-- not exist, so you must use 'insertKey or 'repsert' in
-- these cases.
replace :: (PersistMonadBackend m ~ PersistEntityBackend val, PersistEntity val)
=> Key val -> val -> m ()
-- | Delete a specific record by identifier. Does nothing if record does
-- not exist.
delete :: (PersistMonadBackend m ~ PersistEntityBackend val, PersistEntity val)
=> Key val -> m ()
-- | Same as get, but for a non-null (not Maybe) foreign key
-- Unsafe unless your database is enforcing that the foreign key is valid
getJust :: (PersistStore m, PersistEntity val, Show (Key val), PersistMonadBackend m ~ PersistEntityBackend val) => Key val -> m val
getJust key = get key >>= maybe
(liftIO $ throwIO $ PersistForeignConstraintUnmet $ T.pack $ Prelude.show key)
return
-- | curry this to make a convenience function that loads an associated model
-- > foreign = belongsTo foeignId
belongsTo ::
(PersistStore m
, PersistEntity ent1
, PersistEntity ent2
, PersistMonadBackend m ~ PersistEntityBackend ent2
) => (ent1 -> Maybe (Key ent2)) -> ent1 -> m (Maybe ent2)
belongsTo foreignKeyField model = case foreignKeyField model of
Nothing -> return Nothing
Just f -> get f
-- | same as belongsTo, but uses @getJust@ and therefore is similarly unsafe
belongsToJust ::
(PersistStore m
, PersistEntity ent1
, PersistEntity ent2
, PersistMonadBackend m ~ PersistEntityBackend ent2)
=> (ent1 -> Key ent2) -> ent1 -> m ent2
belongsToJust getForeignKey model = getJust $ getForeignKey model
#define DEF(T) { type PersistMonadBackend (T m) = PersistMonadBackend m; insert = lift . insert; insertKey k = lift . insertKey k; repsert k = lift . repsert k; replace k = lift . replace k; delete = lift . delete; get = lift . get }
#define GO(T) instance (PersistStore m) => PersistStore (T m) where DEF(T)
#define GOX(X, T) instance (X, PersistStore m) => PersistStore (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)
GO(ConduitM i o)
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
|
