@@ -1,7 +1,8 @@
11{-# LANGUAGE RankNTypes, TypeFamilies, GeneralizedNewtypeDeriving, OverloadedStrings, FlexibleInstances, FlexibleContexts #-}
22{-# OPTIONS_GHC -fno-warn-orphans #-}
33module Database.Persist.ProjectM36 where
4−import Database.Persist
4+import Database.Persist hiding (Assign, Update)
5+import qualified Database.Persist as DP
56import ProjectM36.Base
67import ProjectM36.Tuple
78import qualified ProjectM36.Client as C
@@ -17,9 +18,12 @@ import qualified Data.Text as T
1718import ProjectM36.Atom
1819import Data.Aeson (FromJSON(..), ToJSON(..), withText)
1920import qualified Data.HashSet as HS
21+import qualified Data.Map as M
22+import Control.Monad (when)
23+import Data.Maybe (isJust)
2024
2125type ProjectM36Backend = C.Connection
22−
26+
2327--convert a PersistEntity to a RelationTuple
2428recordAsTuple :: forall record. (PersistEntity record, PersistEntityBackend record ~ C.Connection)
2529 => Maybe U.UUID -> record -> Either RelationalError RelationTuple
@@ -102,7 +106,7 @@ insertNewRecords :: (Trans.MonadIO m,
102106 [U.UUID] -> [record] -> ReaderT C.Connection m [Key record]
103107insertNewRecords uuids records = do
104108 let recordsZip = zip (map Just uuids) records
105− insertExpr = Insert (relVarName $ head records)
109+ insertExpr = Insert (relVarNameFromRecord $ head records)
106110 case recordsAsRelation recordsZip of
107111 Left err -> throw $ PersistError (T.pack $ show err)
108112 Right rel -> do
@@ -116,24 +120,18 @@ lookupByKey :: forall record m.
116120 PersistEntityBackend record ~ C.Connection)
117121 => Key record -> ReaderT C.Connection m (Maybe (Entity record))
118122lookupByKey key = do
119− case fromPersistValue $ head $ keyToValues key of
120− Left err -> Trans.liftIO $ throwIO $ PersistError "key uuid extraction failure"
121− Right matchUUID -> do
122− let matchUUIDText = T.pack $ U.toString matchUUID
123− entityInfo = entityDefFromKey key
124− keyAttributeName = unDBName (fieldDB $ entityId entityInfo)
125− relVarName = unDBName $ entityDB entityInfo
126− restrictionPredicate = AttributeEqualityPredicate keyAttributeName (NakedAtomExpr (StringAtom matchUUIDText))
127− query = Restrict restrictionPredicate (RelationVariable relVarName)
128− conn <- ask
129− resultRel <- Trans.liftIO $ C.executeRelationalExpr conn query
130− case resultRel of
131− Left err -> Trans.liftIO $ throwIO $ PersistError "executeRelationExpr error"
132− Right resultRel' -> case singletonTuple resultRel' of
133− Nothing -> return Nothing --no match on key
134− Just tuple -> do
135− entity <- fromPersistValuesThrow entityInfo tuple --correct, one match
136− return $ Just entity
123+ (relVarName, restrictionPredicate) <- commonKeyQueryProperties key
124+ let query = Restrict restrictionPredicate (RelationVariable relVarName)
125+ conn <- ask
126+ resultRel <- Trans.liftIO $ C.executeRelationalExpr conn query
127+ case resultRel of
128+ Left err -> Trans.liftIO $ throwIO $ PersistError "executeRelationExpr error"
129+ Right resultRel' -> case singletonTuple resultRel' of
130+ Nothing -> return Nothing --no match on key
131+ Just tuple -> do
132+ let entityInfo = entityDefFromKey key
133+ entity <- fromPersistValuesThrow entityInfo tuple --correct, one match
134+ return $ Just entity
137135
138136fromPersistValuesThrow :: (Trans.MonadIO m,
139137 PersistEntity record,
@@ -151,6 +149,63 @@ fromPersistValuesThrow entDef tuple = do
151149 Right key -> case body of
152150 Left err -> Trans.liftIO $ throwIO $ PersistError err
153151 Right body' -> return $ Entity key body'
152+
153+commonKeyQueryProperties :: (Trans.MonadIO m, PersistEntityBackend val ~ C.Connection, PersistEntity val) => Key val -> ReaderT C.Connection m (RelVarName, RestrictionPredicateExpr)
154+commonKeyQueryProperties key = do
155+ let matchUUID = keyToUUID key
156+ keyAttributeName = unDBName (fieldDB $ entityId entityInfo)
157+ relVarName = unDBName $ entityDB entityInfo
158+ matchUUIDText = T.pack $ U.toString matchUUID
159+ entityInfo = entityDefFromKey key
160+ restrictionPredicate = AttributeEqualityPredicate keyAttributeName (NakedAtomExpr (StringAtom matchUUIDText))
161+ return (relVarName, restrictionPredicate)
162+
163+deleteByKey :: (Trans.MonadIO m, PersistEntityBackend val ~ C.Connection, PersistEntity val) => Key val -> ReaderT C.Connection m (Bool)
164+deleteByKey key = do
165+ (relVarName, restrictionPredicate) <- commonKeyQueryProperties key
166+ let query = Delete relVarName restrictionPredicate
167+ conn <- ask
168+ maybeErr <- Trans.liftIO $ C.executeDatabaseContextExpr conn query
169+ return $ isJust maybeErr
170+
171+--convert persistent update list to ProjectM36 Update map
172+updatesToUpdateMap :: (Trans.MonadIO m,
173+ PersistEntityBackend val ~ C.Connection,
174+ PersistEntity val) =>
175+ [DP.Update val] -> ReaderT C.Connection m (M.Map AttributeName Atom)
176+updatesToUpdateMap updates = do
177+ let convertMap upd = case updateUpdate upd of
178+ DP.Assign -> let attrName = unDBName $ fieldDB $ updateFieldDef upd
179+ newAttrValue = persistValueAtom (updatePersistValue upd) in
180+ case newAttrValue of
181+ Nothing -> Trans.liftIO $ throwIO $ PersistError "atom conversion failed"
182+ Just newAttrValue' -> return (attrName, newAttrValue')
183+ _ -> Trans.liftIO $ throwIO $ PersistError "update type not supported"
184+ updateAtomList <- mapM convertMap updates
185+ return $ M.fromList updateAtomList
186+
187+updateByKey :: (Trans.MonadIO m, PersistEntityBackend val ~ C.Connection, PersistEntity val) => Key val -> [DP.Update val] -> ReaderT C.Connection m ()
188+updateByKey key updates = do
189+ (relVarName, restrictionPredicate) <- commonKeyQueryProperties key
190+ updateMap <- updatesToUpdateMap updates
191+ let query = Update relVarName updateMap restrictionPredicate
192+ conn <- ask
193+ maybeErr <- Trans.liftIO $ C.executeDatabaseContextExpr conn query
194+ case maybeErr of
195+ Just err -> Trans.liftIO $ throwIO $ PersistError "executeDatabaseExpr error"
196+ Nothing -> return ()
197+
198+--set the truth unconditionally
199+repsertByKey :: (Trans.MonadIO m, C.Connection ~ PersistEntityBackend val, PersistEntity val) => Key val -> val -> ReaderT C.Connection m ()
200+repsertByKey key val = do
201+ _ <- delete key
202+ insertKey key val
203+
204+replaceByKey :: (Trans.MonadIO m, C.Connection ~ PersistEntityBackend val, PersistEntity val) => Key val -> val -> ReaderT C.Connection m ()
205+replaceByKey key val = do
206+ deletionSuccess <- deleteByKey key
207+ when (not deletionSuccess) (Trans.liftIO $ throwIO $ PersistError "entity missing during replace")
208+ insertKey key val
154209
155210entityDefFromKey :: PersistEntity record => Key record -> EntityDef
156211entityDefFromKey = entityDef . Just . recordTypeFromKey
@@ -195,10 +250,15 @@ instance PersistStore C.Connection where
195250 Nothing -> return Nothing
196251 Just (Entity _ val) -> return $ Just val
197252
198− repsert = undefined
199− delete = undefined
200− replace = undefined
201− update = undefined
253+ repsert = repsertByKey
254+ --delete followed by insert "set the record as the truth
255+
256+ delete key = deleteByKey key >> return ()
257+
258+ replace = replaceByKey
259+
260+ --update :: (MonadIO m, PersistEntity val, backend ~ PersistEntityBackend val) => Key val -> [Update val] -> ReaderT backend m ()
261+ update = updateByKey
202262
203263instance FromJSON (BackendKey C.Connection) where
204264 parseJSON = withText "ProjectM36Key" $ \t -> maybe (fail "Invalid UUID") (return . ProjectM36Key) (U.fromString (T.unpack t))
@@ -214,9 +274,9 @@ executeDatabaseContextExpr conn expr = do
214274 Nothing -> return ()
215275 Just err -> throwIO (PersistError $ T.pack (show err))
216276
217−relVarName :: (PersistEntity record, PersistEntityBackend record ~ C.Connection)
277+relVarNameFromRecord :: (PersistEntity record, PersistEntityBackend record ~ C.Connection)
218278 => record -> RelVarName
219−relVarName = unDBName . entityDB . entityDef . Just
279+relVarNameFromRecord = unDBName . entityDB . entityDef . Just
220280
221281instance PersistField U.UUID where
222282 toPersistValue val = PersistText $ T.pack (U.toString val)
@@ -225,3 +285,11 @@ instance PersistField U.UUID where
225285 Just uuid -> Right uuid
226286 fromPersistValue _ = Left $ T.pack "expected PersistObjectId"
227287
288+{- unfortunately copy-pasted from Database.Persist.Sql.Orphan.PersistStore -}
289+updateFieldDef :: PersistEntity v => DP.Update v -> FieldDef
290+updateFieldDef (DP.Update f _ _) = persistFieldDef f
291+updateFieldDef (BackendUpdate {}) = error "updateFieldDef did not expect BackendUpdate"
292+
293+updatePersistValue :: DP.Update v -> PersistValue
294+updatePersistValue (DP.Update _ v _) = toPersistValue v
295+updatePersistValue (BackendUpdate {}) = error "updatePersistValue did not expect BackendUpdate"