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