git.iko.soy/project-m36
on atom_typeclass_simple help sign in
project-m36/Database/Persist/ProjectM36.hs
555 lines 29 kB history raw
1{-# LANGUAGE RankNTypes, TypeFamilies, GeneralizedNewtypeDeriving, OverloadedStrings, FlexibleInstances, FlexibleContexts #-}
2{-# OPTIONS_GHC -fno-warn-orphans #-}
3module Database.Persist.ProjectM36 where
4import Database.Persist hiding (Assign, Update)
5import qualified Database.Persist as DP
6import ProjectM36.Base
7import ProjectM36.Tuple
8import qualified ProjectM36.Client as C
9import qualified Data.UUID as U
10import Data.UUID.V4 (nextRandom)
11import qualified Data.Vector as V
12import ProjectM36.Error
13import ProjectM36.Relation
14import qualified Control.Monad.IO.Class as Trans
15import Control.Monad.Trans.Class
16import Control.Monad.Trans.Reader (ask, ReaderT)
17import Control.Exception (throw, throwIO)
18import qualified Data.Text as T
19import ProjectM36.Atom
20import Data.Aeson (FromJSON(..), ToJSON(..), withText, withObject, (.:))
21import qualified Data.Map as M
22import Control.Monad (when)
23import Data.Maybe (isJust)
24import Data.Aeson.Types (modifyFailure)
25import Control.Monad.Reader (runReaderT)
26import Web.PathPieces (PathPiece (..))
27import qualified Database.Persist.Sql as Sql
28import Control.Monad.Trans.Either
29import qualified Database.Persist.Types as DPT
30import qualified Data.Set as S
31import qualified Data.Conduit.List as CL
32import ProjectM36.RelationalExpression (unsafeCast)
33import Data.Typeable (typeRep, typeOf, Proxy(..))
34import Data.Time.Calendar (Day)
36type ProjectM36Backend = C.Connection
38--convert a PersistEntity to a RelationTuple
39recordAsTuple :: forall record. (PersistEntity record, PersistEntityBackend record ~ C.Connection)
40 => Maybe U.UUID -> record -> Either RelationalError RelationTuple
41recordAsTuple uuid record = do -- if the uuid is passed in, set the idDBName attribute
42 let entInfo = zip entFields entValues
43 entFields = embeddedFields $ toEmbedEntityDef (entityDef $ Just record)
44 entValues = map toPersistValue $ toPersistFields record
45 attrVec <- recordAttributes entInfo record
46 atomVec <- recordAsAtoms uuid attrVec record
47 return $ RelationTuple attrVec atomVec
49recordAttributes :: forall record. (PersistEntity record, PersistEntityBackend record ~ C.Connection)
50 => [(EmbedFieldDef, PersistValue)] -> record -> Either RelationalError Attributes
51recordAttributes entInfo record = do
52 let convertAttr = uncurry fieldDefAsAttribute
53 idDBName = unDBName $ fieldDB $ entityId (entityDef $ Just record)
54 attrList <- mapM convertAttr entInfo
55 return $ V.fromList ([Attribute idDBName stringAtomType] ++ attrList)
57fieldDefAsAttribute :: EmbedFieldDef -> PersistValue -> Either RelationalError Attribute
58fieldDefAsAttribute fieldDef pVal = case persistValueAtomType pVal of
59 Nothing -> Left $ AtomTypeNotSupported attrName
60 Just fType -> Right $ Attribute attrName fType
61 where
62 attrName = unDBName $ emFieldDB fieldDef
64persistValueAtomType :: PersistValue -> Maybe AtomType
65persistValueAtomType val = do
66 atom <- persistValueAtom val
67 return $ atomTypeForAtom atom
69persistValueAtom :: PersistValue -> Maybe Atom
70persistValueAtom val = case val of
71 PersistText v -> return $ Atom v
72 PersistInt64 v -> return $ Atom ((fromIntegral v)::Int)
73 PersistBool v -> return $ Atom v
74 PersistDay v -> return $ Atom v
75 _ -> Nothing
77atomAsPersistValue :: Atom -> PersistValue
78atomAsPersistValue atom@(Atom atomv) = if typeRep (Proxy :: Proxy Int) == typeOf atomv then
79 PersistInt64 (fromIntegral ((unsafeCast atom) :: Int))
80 else if typeRep (Proxy :: Proxy T.Text) == typeOf atomv then
81 PersistText (unsafeCast atom)
82 else if typeRep (Proxy :: Proxy Bool) == typeOf atomv then
83 PersistBool (unsafeCast atom)
84 else if typeRep (Proxy :: Proxy Day) == typeOf atomv then
85 PersistDay (unsafeCast atom)
86 else
87 error "missing conversion"
89recordAsAtoms :: forall record. (PersistEntity record, PersistEntityBackend record ~ C.Connection)
90 => Maybe U.UUID -> Attributes -> record -> Either RelationalError (V.Vector Atom)
91recordAsAtoms freshUUID _ record = do
92 let pValues = map toPersistValue $ toPersistFields record
93 valAtom val = case persistValueAtom val of
94 Nothing -> Left $ AtomTypeNotSupported ""
95 Just atom -> Right atom
96 atoms <- mapM valAtom pValues
97 return $ V.fromList $ case freshUUID of
98 Nothing -> atoms
99 Just uuid -> [Atom $ T.pack (U.toString uuid)] ++ atoms
101--used by insert operations
102recordsAsRelation :: forall record. (PersistEntity record, PersistEntityBackend record ~ C.Connection) =>
103 [(Maybe U.UUID, record)] -> Either RelationalError Relation
104recordsAsRelation [] = Left EmptyTuplesError
105recordsAsRelation recordZips = do
106 tupleList <- mapM (uncurry recordAsTuple) recordZips
107 let oneTuple = head tupleList
108 mkRelation (tupleAttributes oneTuple) (RelationTupleSet tupleList)
110keyFromValuesOrDie :: (Trans.MonadIO m,
111 PersistEntity record,
112 PersistEntityBackend record ~ C.Connection
113 ) => [PersistValue] -> m (Key record)
114keyFromValuesOrDie val = case keyFromValues val of
115 Right k -> return k
116 Left _ -> Trans.liftIO $ throwIO $ PersistError "key pooped"
118insertNewRecords :: (Trans.MonadIO m,
119 PersistEntity record,
120 PersistEntityBackend record ~ C.Connection) =>
121 [U.UUID] -> [record] -> ReaderT C.Connection m [Key record]
122insertNewRecords uuids records = do
123 let recordsZip = zip (map Just uuids) records
124 insertExpr = Insert (relVarNameFromRecord $ head records)
125 case recordsAsRelation recordsZip of
126 Left err -> throw $ PersistError (T.pack $ show err)
127 Right rel -> do
128 conn <- ask
129 Trans.liftIO $ executeDatabaseContextExpr conn (insertExpr (ExistingRelation rel))
130 mapM (\uuid -> keyFromValuesOrDie [PersistText $ T.pack (U.toString uuid)]) uuids
132throwIOPersistError :: (Trans.MonadIO m) => String -> m a
133throwIOPersistError msg = Trans.liftIO $ throwIO $ PersistError (T.pack msg)
135lookupByKey :: forall record m.
136 (Trans.MonadIO m,
137 PersistEntity record,
138 PersistEntityBackend record ~ C.Connection)
139 => Key record -> ReaderT C.Connection m (Maybe (Entity record))
140lookupByKey key = do
141 (relVarName, restrictionPredicate) <- commonKeyQueryProperties key
142 let query = Restrict restrictionPredicate (RelationVariable relVarName)
143 conn <- ask
144 resultRel <- Trans.liftIO $ C.executeRelationalExpr conn query
145 case resultRel of
146 Left err -> throwIOPersistError ("executeRelationExpr error: " ++ show err)
147 Right resultRel' -> case singletonTuple resultRel' of
148 Nothing -> return Nothing --no match on key
149 Just tuple -> do
150 let entityInfo = entityDefFromKey key
151 entity <- fromPersistValuesThrow entityInfo tuple --correct, one match
152 return $ Just entity
154fromPersistValuesThrow :: (Trans.MonadIO m,
155 PersistEntity record,
156 PersistEntityBackend record ~ C.Connection) => EntityDef -> RelationTuple -> m (Entity record)
157fromPersistValuesThrow entDef tuple = do
158 let body = fromPersistValues $ map getValue (entityFields entDef)
159 getValue field = case atomForAttributeName (unDBName (fieldDB field)) tuple of
160 Right atom -> atomAsPersistValue atom
161 Left err -> throw $ PersistError ("missing field: " `T.append` (T.pack $ show err))
162 keyAtom = atomForAttributeName (unDBName (fieldDB (entityId entDef))) tuple
163 case keyAtom of
164 Left err -> throwIOPersistError ("missing key atom" ++ show err)
165 Right keyAtom' -> case keyFromValues [atomAsPersistValue keyAtom'] of
166 Left err -> throw $ PersistError ("key failure" `T.append` (T.pack $ show err))
167 Right key -> case body of
168 Left err -> throwIOPersistError (show err)
169 Right body' -> return $ Entity key body'
171commonKeyQueryProperties :: (Trans.MonadIO m, PersistEntityBackend val ~ C.Connection, PersistEntity val) => Key val -> ReaderT C.Connection m (RelVarName, RestrictionPredicateExpr)
172commonKeyQueryProperties key = do
173 let matchUUID = keyToUUID key
174 keyAttributeName = unDBName (fieldDB $ entityId entityInfo)
175 relVarName = unDBName $ entityDB entityInfo
176 matchUUIDText = T.pack $ U.toString matchUUID
177 entityInfo = entityDefFromKey key
178 restrictionPredicate = AttributeEqualityPredicate keyAttributeName (NakedAtomExpr (Atom matchUUIDText))
179 return (relVarName, restrictionPredicate)
181deleteByKey :: (Trans.MonadIO m, PersistEntityBackend val ~ C.Connection, PersistEntity val) => Key val -> ReaderT C.Connection m (Bool)
182deleteByKey key = do
183 (relVarName, restrictionPredicate) <- commonKeyQueryProperties key
184 let query = Delete relVarName restrictionPredicate
185 conn <- ask
186 maybeErr <- Trans.liftIO $ C.executeDatabaseContextExpr conn query
187 return $ isJust maybeErr
189--convert persistent update list to ProjectM36 Update map
190updatesToUpdateMap :: (Trans.MonadIO m,
191 PersistEntityBackend val ~ C.Connection,
192 PersistEntity val) =>
193 [DP.Update val] -> ReaderT C.Connection m (M.Map AttributeName Atom)
194updatesToUpdateMap updates = do
195 let convertMap upd = case updateUpdate upd of
196 DP.Assign -> let attrName = unDBName $ fieldDB $ updateFieldDef upd
197 newAttrValue = persistValueAtom (updatePersistValue upd) in
198 case newAttrValue of
199 Nothing -> Trans.liftIO $ throwIO $ PersistError "atom conversion failed"
200 Just newAttrValue' -> return (attrName, newAttrValue')
201 _ -> Trans.liftIO $ throwIO $ PersistError "update type not supported"
202 updateAtomList <- mapM convertMap updates
203 return $ M.fromList updateAtomList
205updateByKey :: (Trans.MonadIO m, PersistEntityBackend val ~ C.Connection, PersistEntity val) => Key val -> [DP.Update val] -> ReaderT C.Connection m ()
206updateByKey key updates = do
207 (relVarName, restrictionPredicate) <- commonKeyQueryProperties key
208 updateMap <- updatesToUpdateMap updates
209 let query = Update relVarName updateMap restrictionPredicate
210 conn <- ask
211 maybeErr <- Trans.liftIO $ C.executeDatabaseContextExpr conn query
212 case maybeErr of
213 Just err -> throwIOPersistError ("executeDatabaseExpr error" ++ show err)
214 Nothing -> return ()
216--set the truth unconditionally
217repsertByKey :: (Trans.MonadIO m, C.Connection ~ PersistEntityBackend val, PersistEntity val) => Key val -> val -> ReaderT C.Connection m ()
218repsertByKey key val = do
219 _ <- delete key
220 insertKey key val
222replaceByKey :: (Trans.MonadIO m, C.Connection ~ PersistEntityBackend val, PersistEntity val) => Key val -> val -> ReaderT C.Connection m ()
223replaceByKey key val = do
224 deletionSuccess <- deleteByKey key
225 when (not deletionSuccess) (Trans.liftIO $ throwIO $ PersistError "entity missing during replace")
226 insertKey key val
228entityDefFromKey :: PersistEntity record => Key record -> EntityDef
229entityDefFromKey = entityDef . Just . recordTypeFromKey
231dummyFromKey :: Key record -> Maybe record
232dummyFromKey = Just . recordTypeFromKey
234recordTypeFromKey :: Key record -> record
235recordTypeFromKey _ = error "dummyFromKey"
237dummyFromUnique :: Unique v -> Maybe v
238dummyFromUnique _ = Nothing
240dummyFromFilter :: Filter v -> Maybe v
241dummyFromFilter _ = Nothing
243dummyFromFilters :: [Filter v] -> Maybe v
244dummyFromFilters _ = Nothing
246dummyFromUpdate :: DPT.Update v -> Maybe v
247dummyFromUpdate _ = Nothing
249keyToUUID:: (PersistEntity record) => Key record -> U.UUID
250keyToUUID key = case keyToValues key of
251 ([PersistText uuidText]) -> case U.fromString (T.unpack uuidText) of
252 Nothing -> error "error reading uuid from text in key construction"
253 Just uuid -> uuid
254 _ -> error "unexpected persist value in key construction"
256instance PersistStore C.Connection where
257 newtype BackendKey C.Connection = ProjectM36Key { unPM36Key :: U.UUID }
258 deriving (Show, Read, Eq, Ord, PersistField)
260 insertMany [] = return []
261 insertMany records = do
262 freshUUIDs <- Trans.liftIO $ mapM (\_-> nextRandom) records
263 insertNewRecords freshUUIDs records
265 insert record = do
266 keys <- insertMany [record]
267 return $ head keys
269 --insertEntityMany [] = return []
270 --insertKey :: (Trans.MonadIO m, backend ~ PersistEntityBackend val, PersistEntity val) => Key val -> val -> ReaderT backend m ()
271 insertKey key record = do
272 let uuid = keyToUUID key
273 _ <- insertNewRecords [uuid] [record]
274 return ()
276 --get :: (MonadIO m, backend ~ PersistEntityBackend val, PersistEntity val) => Key val -> ReaderT backend m (Maybe val)
277 get key = do
278 ent <- lookupByKey key
279 case ent of
280 Nothing -> return Nothing
281 Just (Entity _ val) -> return $ Just val
283 repsert = repsertByKey
284 --delete followed by insert "set the record as the truth
286 delete key = deleteByKey key >> return ()
288 replace = replaceByKey
290 --update :: (MonadIO m, PersistEntity val, backend ~ PersistEntityBackend val) => Key val -> [Update val] -> ReaderT backend m ()
291 update = updateByKey
293instance FromJSON (BackendKey C.Connection) where
294 parseJSON = withText "ProjectM36Key" $ \t -> maybe (fail "Invalid UUID") (return . ProjectM36Key) (U.fromString (T.unpack t))
296instance ToJSON (BackendKey C.Connection) where
297 toJSON (ProjectM36Key uuid) = toJSON $ U.toString uuid
299--wrapped version which throws exceptions
300executeDatabaseContextExpr :: C.Connection -> DatabaseExpr -> IO ()
301executeDatabaseContextExpr conn expr = do
302 res <- C.executeDatabaseContextExpr conn expr
303 case res of
304 Nothing -> return ()
305 Just err -> throwIO (PersistError $ T.pack (show err))
307relVarNameFromRecord :: (PersistEntity record, PersistEntityBackend record ~ C.Connection)
308 => record -> RelVarName
309relVarNameFromRecord = unDBName . entityDB . entityDef . Just
311{- unfortunately copy-pasted from Database.Persist.Sql.Orphan.PersistStore -}
312updateFieldDef :: PersistEntity v => DP.Update v -> FieldDef
313updateFieldDef (DP.Update f _ _) = persistFieldDef f
314updateFieldDef (BackendUpdate {}) = error "updateFieldDef did not expect BackendUpdate"
316updatePersistValue :: DP.Update v -> PersistValue
317updatePersistValue (DP.Update _ v _) = toPersistValue v
318updatePersistValue (BackendUpdate {}) = error "updatePersistValue did not expect BackendUpdate"
320instance PersistField U.UUID where
321 toPersistValue val = PersistText $ T.pack (U.toString val)
322 fromPersistValue (PersistText uuidText) = case U.fromString $ T.unpack uuidText of
323 Nothing -> Left "uuid text read failure"
324 Just uuid -> Right uuid
325 fromPersistValue _ = Left $ T.pack "expected PersistObjectId"
327instance FromJSON C.ConnectionInfo where
328 parseJSON v = modifyFailure ("Persistent: error loading ProjectM36 conf: " ++) $
329 flip (withObject "ProjectM36Conf") v $ \o -> do
330 ctype <- parseJSON =<< ( o .: "connectionType")
331 return ctype
333instance PersistConfig C.ConnectionInfo where
334 type PersistConfigBackend C.ConnectionInfo = ReaderT C.Connection
335 type PersistConfigPool C.ConnectionInfo = C.Connection
337 loadConfig = parseJSON
338 applyEnv = return -- no environment variables are used
339 createPoolConfig conf = do
340 connErr <- C.connectProjectM36 conf
341 case connErr of
342 Left err -> throwIO $ PersistError ("Failed to create connection: " `T.append` (T.pack $ show err))
343 Right conn -> return conn
344 --runPool :: (MonadBaseControl IO m, MonadIO m) => c -> PersistConfigBackend c m a -> PersistConfigPool c -> m a
345 runPool _ r = runReaderT r
347withProjectM36Conn :: (Monad m, Trans.MonadIO m) => C.ConnectionInfo -> (C.Connection -> m a) -> m a
348withProjectM36Conn conf connReader = do
349 conn <- Trans.liftIO $ createPoolConfig conf
350 connReader conn
352runProjectM36Conn :: (Trans.MonadIO m) => ReaderT C.Connection m a -> C.Connection -> m a
353runProjectM36Conn m1 conn = runReaderT m1 conn
355instance PathPiece (BackendKey ProjectM36Backend) where
356 toPathPiece (ProjectM36Key uuid) = U.toText uuid
357 fromPathPiece txt = do
358 uuid <- U.fromText txt
359 return $ ProjectM36Key uuid
361instance Sql.PersistFieldSql U.UUID where
362 sqlType _ = Sql.SqlOther "doesn't make much sense for ProjectM36"
364instance Sql.PersistFieldSql (BackendKey C.Connection) where
365 sqlType _ = Sql.SqlOther "doesn't make much sense for ProjectM36"
367persistUniqueToRestrictionPredicate :: PersistEntity record => Unique record -> Either RelationalError RestrictionPredicateExpr
368persistUniqueToRestrictionPredicate unique = do
369 atoms <- mapM (\v -> maybe (Left $ AtomTypeNotSupported "") Right $ persistValueAtom v) $ persistUniqueToValues unique
370 let attrNames = map (unDBName . snd) $ persistUniqueToFieldNames unique
371 andify [] = TruePredicate
372 andify ((attrName, atom):xs) = AndPredicate (AttributeEqualityPredicate attrName (NakedAtomExpr atom)) $ andify xs
373 return $ andify (zip attrNames atoms)
375instance PersistUnique C.Connection where
376 getBy unique = do
377 conn <- ask
378 let predicate = persistUniqueToRestrictionPredicate unique
379 relVarName = unDBName $ entityDB entDef
380 entDef = entityDef $ dummyFromUnique unique
381 throwRelErr err = Trans.liftIO $ throwIO (PersistError (T.pack $ show err))
382 case predicate of
383 Left err -> throwRelErr err
384 Right predicate' -> do
385 let restrictExpr = Restrict predicate' (RelationVariable relVarName)
386 singletonRel <- Trans.liftIO $ C.executeRelationalExpr conn restrictExpr
387 case singletonRel of
388 Left err -> throwRelErr err
389 Right singletonRel' -> do
390 if cardinality singletonRel' == Countable 0 then
391 return Nothing
392 else if cardinality singletonRel' > Countable 1 then
393 Trans.liftIO $ throwIO (PersistError "getBy returned more than one tuple")
394 else -- exactly one tuple
395 case singletonTuple singletonRel' of
396 Nothing -> Trans.liftIO $ throwIO (PersistMarshalError "singletonTuple failure")
397 Just tuple -> do
398 newEnt <- Trans.liftIO $ fromPersistValuesThrow entDef tuple
399 return $ Just newEnt
400 deleteBy unique = do
401 conn <- ask
402 let predicate = persistUniqueToRestrictionPredicate unique
403 relVarName = unDBName $ entityDB entDef
404 entDef = entityDef $ dummyFromUnique unique
405 throwRelErr err = Trans.liftIO $ throwIO (PersistError (T.pack $ show err))
406 case predicate of
407 Left err -> throwRelErr err
408 Right predicate' -> do
409 let deleteExpr = Delete relVarName predicate'
410 maybeErr <- Trans.liftIO $ C.executeDatabaseContextExpr conn deleteExpr
411 case maybeErr of
412 Just err -> throwRelErr err
413 Nothing -> return ()
415multiFilterAsRestrictionPredicate :: (PersistEntity val, PersistEntityBackend val ~ C.Connection) => Bool -> [Filter val] -> Either RelationalError RestrictionPredicateExpr
416multiFilterAsRestrictionPredicate _ [] = Right $ TruePredicate
417multiFilterAsRestrictionPredicate andOr (x:xs) = do
418 let predicate = if andOr then AndPredicate else OrPredicate
419 filtHead <- filterAsRestrictionPredicate x
420 filtTail <- multiFilterAsRestrictionPredicate andOr xs
421 return $ predicate filtHead filtTail
423filterValueToPersistValues :: forall a. PersistField a => Either a [a] -> [PersistValue]
424filterValueToPersistValues v = map toPersistValue $ either return id v
426filterAsRestrictionPredicate :: (PersistEntity val, PersistEntityBackend val ~ C.Connection) => Filter val -> Either RelationalError RestrictionPredicateExpr
427filterAsRestrictionPredicate filterIn = case filterIn of
428 FilterAnd filters -> multiFilterAsRestrictionPredicate True filters
429 FilterOr filters -> multiFilterAsRestrictionPredicate False filters
430 BackendFilter _ -> error "BackendFilter not supported"
431 Filter field value pfilter -> let attrName = unDBName $ fieldDB (persistFieldDef field) in
432 case value of
433 Left val -> let atom = persistValueAtom $ toPersistValue val in
434 case pfilter of
435 Eq -> case atom of
436 Nothing -> Left $ AtomTypeNotSupported attrName
437 Just atom' -> Right $ AttributeEqualityPredicate attrName (NakedAtomExpr atom')
438 Ne -> case atom of
439 Nothing -> Left $ AtomTypeNotSupported attrName
440 Just atom' -> Right $ NotPredicate (AttributeEqualityPredicate attrName (NakedAtomExpr atom'))
441 op -> Left $ AtomOperatorNotSupported $ T.pack (show op)
442 Right _ -> Left $ AtomTypeNotSupported attrName
444updateToUpdateTuple :: (PersistEntity val, PersistEntityBackend val ~ C.Connection) => DPT.Update val -> Either RelationalError (AttributeName, Atom)
445updateToUpdateTuple (BackendUpdate _) = error "BackendUpdate not supported"
446updateToUpdateTuple (DPT.Update field value op) = let attrName = unDBName $ fieldDB (persistFieldDef field)
447 atom = persistValueAtom $ toPersistValue value
448 in case op of
449 DPT.Assign -> case atom of
450 Nothing -> Left $ AtomTypeNotSupported attrName
451 Just atom' -> Right $ (attrName, atom')
452 op' -> Left $ AtomOperatorNotSupported $ T.pack (show op')
454selectionFromRestriction :: (PersistEntity val, PersistEntityBackend val ~ backend, Trans.MonadIO m, backend ~ C.Connection) => [Filter val] -> ReaderT backend m (Either RelationalError RelationalExpr)
455selectionFromRestriction filters = do
456 runEitherT $ do
457 restrictionPredicate <- hoistEither $ multiFilterAsRestrictionPredicate True filters
458 let entDef = entityDef $ dummyFromFilters filters
459 relVarName = unDBName $ entityDB entDef
460 right $ Restrict restrictionPredicate (RelationVariable relVarName)
463instance PersistQuery C.Connection where
464 updateWhere _ [] = return ()
465 updateWhere filters updates = do
466 conn <- ask
467 e <- runEitherT $ do
468 restrictionPredicate <- hoistEither $ multiFilterAsRestrictionPredicate True filters
469 tuples <- hoistEither $ mapM updateToUpdateTuple updates
470 let updateMap = M.fromList tuples
471 entDef = entityDef $ dummyFromUpdate (head updates)
472 relVarName = unDBName $ entityDB entDef
473 updateExpr = Update relVarName updateMap restrictionPredicate
474 maybeErr <- Trans.liftIO $ C.executeDatabaseContextExpr conn updateExpr
475 case maybeErr of
476 Just err -> left err
477 Nothing -> right ()
478 case e of
479 Left err -> throwIOPersistError ("updateWhere failure: " ++ show err)
480 Right () -> return ()
482 deleteWhere filters = do
483 conn <- ask
484 e <- runEitherT $ do
485 restrictionPredicate <- hoistEither $ multiFilterAsRestrictionPredicate True filters
486 let entDef = entityDef $ dummyFromFilters filters
487 relVarName = unDBName $ entityDB entDef
488 deleteExpr = Delete relVarName restrictionPredicate
489 maybeErr <- Trans.liftIO $ C.executeDatabaseContextExpr conn deleteExpr
490 case maybeErr of
491 Just err -> left err
492 Nothing -> right ()
493 case e of
494 Left err -> throwIOPersistError ("deleteWhere failure: " ++ show err)
495 Right () -> return ()
497 count filters = do
498 conn <- ask
499 e <- runEitherT $ do
500 restrictionPredicate <- hoistEither $ multiFilterAsRestrictionPredicate True filters
501 let entDef = entityDef $ dummyFromFilters filters
502 relVarName = unDBName $ entityDB entDef
503 allAttrNamesList = map (unDBName . fieldDB) (entityFields entDef) ++ [unDBName (fieldDB (entityId entDef))]
504 allAttrNames = AttributeNames $ S.fromList allAttrNamesList
505 groupExpr = Group allAttrNames "persistcountrel" (Restrict restrictionPredicate (RelationVariable relVarName))
506 tupleExpr = AttributeTupleExpr "persistcount" (FunctionAtomExpr "count" [AttributeAtomExpr "persistcountrel"])
507 countExpr = Extend tupleExpr groupExpr
508 rel <- Trans.liftIO $ C.executeRelationalExpr conn countExpr
509 case rel of
510 Left err -> left err
511 Right rel' -> case singletonTuple rel' of
512 Nothing -> Trans.liftIO $ throwIO $ PersistError "failed to get count tuple"
513 Just tuple -> case atomForAttributeName "persistcount" tuple of
514 (Right c) -> return (castInt c)
515 Left err -> left err
516 case e of
517 Left err -> throwIOPersistError ("count failure: " ++ show err)
518 Right c -> return c
520 --no select options currently supported (sorting, limiting)
521 selectSourceRes _ (_:_) = Trans.liftIO $ throwIO $ PersistError "select options not yet supported"
522 selectSourceRes filters [] = do
523 conn <- ask
524 entities <- runEitherT $ do
525 restrictionExpr <- (lift $ selectionFromRestriction filters) >>= hoistEither
526 --restrictionExpr' <- hoistEither restrictionExpr
527 let entDef = entityDef $ dummyFromFilters filters
528 let tupleMapper tuple = Trans.liftIO $ fromPersistValuesThrow entDef tuple
529 rel <- Trans.liftIO $ C.executeRelationalExpr conn restrictionExpr
530 case rel of
531 Left err -> Trans.liftIO $ throwIO $ PersistError (T.pack (show err))
532 Right (Relation _ tupleSet) -> mapM tupleMapper $ asList tupleSet --refactor to use some relation accessors- here we convert a relation to a matrix, effectively (especially to support future sorting)
533 case entities of
534 Left err -> Trans.liftIO $ throwIO $ PersistError (T.pack $ show err)
535 Right entities' -> return $ return $ CL.sourceList entities'
537 selectKeysRes _ (_:_) = Trans.liftIO $ throwIO $ PersistError "select options not yet supported"
538 selectKeysRes filters [] = do
539 conn <- ask
540 keys <- runEitherT $ do
541 restrictionExpr <- (lift $ selectionFromRestriction filters) >>= hoistEither
542 let keyAttrNames = ["id"] --no support for multi-attribute keys yet
543 keyExpr = Project (AttributeNames $ S.fromList keyAttrNames) restrictionExpr
544 (Relation _ tupleSet) <- (Trans.liftIO $ C.executeRelationalExpr conn keyExpr) >>= hoistEither
545 let keyMapper :: (PersistEntity record, Trans.MonadIO m) => RelationTuple -> EitherT RelationalError (ReaderT C.Connection m) (Key record)
546 keyMapper tuple = do
547 atoms <- hoistEither (atomsForAttributeNames (V.fromList keyAttrNames) tuple)
548 case keyFromValues (map atomAsPersistValue (V.toList atoms)) of
549 Left err -> throwIOPersistError ("keyFromValues failure: " ++ show err)
550 Right key -> right key
551 mapM keyMapper $ asList tupleSet
552 case keys of
553 Left err -> throwIOPersistError ("keyFromValues failure2: " ++ show err)
554 Right keys' -> return $ return (CL.sourceList keys')