git.iko.soy/project-m36
on master help sign in
WIP updateWhere implemented
5165b43AgentM
Database/Persist/ProjectM36.hs+82
compare with master
unifiedsplit
@@ -25,6 +25,9 @@ import Data.Aeson.Types (modifyFailure)
25import Control.Monad.Reader (runReaderT)
25import Control.Monad.Reader (runReaderT)
26import Web.PathPieces (PathPiece (..))
26import Web.PathPieces (PathPiece (..))
27import qualified Database.Persist.Sql as Sql
27import qualified Database.Persist.Sql as Sql
28+import Control.Monad.Trans.Either
29+import Database.Persist.Class
30+import qualified Database.Persist.Types as DPT
28
31
29type ProjectM36Backend = C.Connection
32type ProjectM36Backend = C.Connection
30
33
@@ -223,6 +226,12 @@ recordTypeFromKey _ = error "dummyFromKey"
223dummyFromUnique :: Unique v -> Maybe v
226dummyFromUnique :: Unique v -> Maybe v
224dummyFromUnique _ = Nothing
227dummyFromUnique _ = Nothing
225
228
229+dummyFromFilter :: Filter v -> Maybe v
230+dummyFromFilter _ = Nothing
231+
232+dummyFromUpdate :: DPT.Update v -> Maybe v
233+dummyFromUpdate _ = Nothing
234+
226keyToUUID:: (PersistEntity record) => Key record -> U.UUID
235keyToUUID:: (PersistEntity record) => Key record -> U.UUID
227keyToUUID key = case keyToValues key of
236keyToUUID key = case keyToValues key of
228 ([PersistText uuidText]) -> case U.fromString (T.unpack uuidText) of
237 ([PersistText uuidText]) -> case U.fromString (T.unpack uuidText) of
@@ -374,3 +383,76 @@ instance PersistUnique C.Connection where
374 Just tuple -> do
383 Just tuple -> do
375 newEnt <- Trans.liftIO $ fromPersistValuesThrow entDef tuple
384 newEnt <- Trans.liftIO $ fromPersistValuesThrow entDef tuple
376 return $ Just newEnt
385 return $ Just newEnt
386+ deleteBy unique = do
387+ conn <- ask
388+ let predicate = persistUniqueToRestrictionPredicate unique
389+ relVarName = unDBName $ entityDB entDef
390+ entDef = entityDef $ dummyFromUnique unique
391+ throwRelErr err = Trans.liftIO $ throwIO (PersistError (T.pack $ show err))
392+ case predicate of
393+ Left err -> throwRelErr err
394+ Right predicate' -> do
395+ let deleteExpr = Delete relVarName predicate'
396+ maybeErr <- Trans.liftIO $ C.executeDatabaseContextExpr conn deleteExpr
397+ case maybeErr of
398+ Just err -> throwRelErr err
399+ Nothing -> return ()
400+
401+multiFilterAsRestrictionPredicate :: (PersistEntity val, PersistEntityBackend val ~ C.Connection) => Bool -> [Filter val] -> Either RelationalError RestrictionPredicateExpr
402+multiFilterAsRestrictionPredicate _ [] = Right $ TruePredicate
403+multiFilterAsRestrictionPredicate andOr (x:xs) = do
404+ let pred = if andOr then AndPredicate else OrPredicate
405+ filtHead <- filterAsRestrictionPredicate x
406+ filtTail <- multiFilterAsRestrictionPredicate andOr xs
407+ return $ pred filtHead filtTail
408+
409+filterValueToPersistValues :: forall a. PersistField a => Either a [a] -> [PersistValue]
410+filterValueToPersistValues v = map toPersistValue $ either return id v
411+
412+filterAsRestrictionPredicate :: (PersistEntity val, PersistEntityBackend val ~ C.Connection) => Filter val -> Either RelationalError RestrictionPredicateExpr
413+filterAsRestrictionPredicate filter = case filter of
414+ FilterAnd filters -> multiFilterAsRestrictionPredicate True filters
415+ FilterOr filters -> multiFilterAsRestrictionPredicate False filters
416+ Filter field value pfilter -> let attrName = unDBName $ fieldDB (persistFieldDef field) in
417+ case value of
418+ Left val -> case pfilter of
419+ Eq -> let entDef = entityDef $ dummyFromFilter filter
420+ atom = persistValueAtom $ toPersistValue val
421+ in case atom of
422+ Nothing -> Left $ AtomTypeNotSupported attrName
423+ Just atom' -> Right $ AttributeEqualityPredicate attrName (NakedAtomExpr atom')
424+ op -> Left $ AtomOperatorNotSupported $ T.pack (show op)
425+ Right vals -> Left $ AtomTypeNotSupported attrName
426+
427+updateToUpdateTuple :: (PersistEntity val, PersistEntityBackend val ~ C.Connection) => DPT.Update val -> Either RelationalError (AttributeName, Atom)
428+updateToUpdateTuple up@(DPT.Update field value op) = let entDef = entityDef $ dummyFromUpdate up
429+ attrName = unDBName $ fieldDB (persistFieldDef field)
430+ atom = persistValueAtom $ toPersistValue value
431+ in case op of
432+ DPT.Assign -> case atom of
433+ Nothing -> Left $ AtomTypeNotSupported attrName
434+ Just atom' -> Right $ (attrName, atom')
435+ op' -> Left $ AtomOperatorNotSupported $ T.pack (show op')
436+
437+instance PersistQuery C.Connection where
438+ updateWhere _ [] = return ()
439+ updateWhere filters updates = do
440+ conn <- ask
441+ e <- runEitherT $ do
442+ restrictionPredicate <- hoistEither $ multiFilterAsRestrictionPredicate True filters
443+ tuples <- hoistEither $ mapM updateToUpdateTuple updates
444+ let updateMap = M.fromList tuples
445+ entDef = entityDef $ dummyFromUpdate (head updates)
446+ relVarName = unDBName $ entityDB entDef
447+ updateExpr = Update relVarName updateMap restrictionPredicate
448+ maybeErr <- Trans.liftIO $ C.executeDatabaseContextExpr conn updateExpr
449+ case maybeErr of
450+ Just err -> left err
451+ Nothing -> right ()
452+ case e of
453+ Left err -> Trans.liftIO $ throwIO $ PersistError "updateWhere pooped"
454+ Right () -> return ()
455+
456+
457+
458+
project-m36.cabal+1−1
@@ -7,7 +7,7 @@ Category: Relational Algebra
7Cabal-Version: >= 1.2
7Cabal-Version: >= 1.2
8
8
9Library
9Library
10− Build-Depends: base,mtl,containers,unordered-containers,parsec,hashable,haskeline,directory,uuid,cassava ==0.4.*,text,bytestring,deepseq,deepseq-generics,vector,parallel,monad-parallel,transformers,gnuplot,binary,filepath,directory,vector-binary-instances,unix,temporary,stm,time,hashable-time,old-locale,attoparsec, persistent,persistent-template,aeson,path-pieces
10+ Build-Depends: base,mtl,containers,unordered-containers,parsec,hashable,haskeline,directory,uuid,cassava ==0.4.*,text,bytestring,deepseq,deepseq-generics,vector,parallel,monad-parallel,transformers,gnuplot,binary,filepath,directory,vector-binary-instances,unix,temporary,stm,time,hashable-time,old-locale,attoparsec,either, persistent,persistent-template,aeson,path-pieces
11--required for persistent db driver
11--required for persistent db driver
12 Exposed-Modules: ProjectM36.Error,
12 Exposed-Modules: ProjectM36.Error,
13 ProjectM36.Transaction,
13 ProjectM36.Transaction,