@@ -25,6 +25,9 @@ import Data.Aeson.Types (modifyFailure)
2525import Control.Monad.Reader (runReaderT)
2626import Web.PathPieces (PathPiece (..))
2727import 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
2831
2932type ProjectM36Backend = C.Connection
3033
@@ -223,6 +226,12 @@ recordTypeFromKey _ = error "dummyFromKey"
223226dummyFromUnique :: Unique v -> Maybe v
224227dummyFromUnique _ = Nothing
225228
229+dummyFromFilter :: Filter v -> Maybe v
230+dummyFromFilter _ = Nothing
231+
232+dummyFromUpdate :: DPT.Update v -> Maybe v
233+dummyFromUpdate _ = Nothing
234+
226235keyToUUID:: (PersistEntity record) => Key record -> U.UUID
227236keyToUUID key = case keyToValues key of
228237 ([PersistText uuidText]) -> case U.fromString (T.unpack uuidText) of
@@ -374,3 +383,76 @@ instance PersistUnique C.Connection where
374383 Just tuple -> do
375384 newEnt <- Trans.liftIO $ fromPersistValuesThrow entDef tuple
376385 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+