module EZCouch.WriteAction where
import Prelude ()
import ClassyPrelude.Conduit
import Control.Monad.Trans.Resource
import EZCouch.Ids
import EZCouch.Action
import EZCouch.Types
import EZCouch.Doc
import EZCouch.Parsing
import qualified EZCouch.Encoding as Encoding
import qualified Database.CouchDB.Conduit.View.Query as CC
import Data.Aeson as Aeson
data WriteOperation a
= Create Text a
| Update Text Text a
| Delete Text Text
writeOperationsAction :: (MonadAction m, Doc a)
=> [WriteOperation a]
-> m [(Text, Maybe Text)]
writeOperationsAction ops =
postAction path qps body >>=
runParser (rowsParser2 >=> mapM idRevParser . toList)
where
path = ["_bulk_docs"]
qps = []
body = writeOperationsBody ops
writeOperationsBody ops = Aeson.encode $ Aeson.object [("docs", Aeson.Array $ fromList $ fmap operationJSON ops)]
operationJSON (Create id a)
= Encoding.insertPairs [("_id", toJSON id)] $ toJSON a
operationJSON (Update id rev a)
= Encoding.insertPairs [("_id", toJSON id), ("_rev", toJSON rev)] $ toJSON a
operationJSON (Delete id rev)
= Aeson.object [("_id", toJSON id), ("_rev", toJSON rev), ("_deleted", Aeson.Bool True)]
deleteMultiple :: (MonadAction m, Doc a) => [Persisted a] -> m ()
deleteMultiple vals = do
results <- writeOperationsAction $ map toOperation vals
let failedIds = fmap fst $ filter (isNothing . snd) results
if null failedIds
then return ()
else throwIO $ OperationException $ "Couldn't delete entities by following ids: " ++ show failedIds
where
toOperation :: Persisted a -> WriteOperation a
toOperation (Persisted id rev val) = Delete id rev
delete :: (MonadAction m, Doc a) => Persisted a -> m ()
delete = deleteMultiple . singleton
createMultipleWithIds :: (MonadAction m, Doc a)
=> [(Text, a)]
-> m [Either (Text, a) (Persisted a)]
createMultipleWithIds idsToVals
= writeOperationsAction [Create id val | (id, val) <- idsToVals]
>>= mapM convertResult
where
valById = asMap $ fromList idsToVals
convertResult (id, Nothing) = fmap Left $
(,) <$> pure id <*> lookupThrowing id valById
convertResult (id, Just rev) = fmap Right $
Persisted <$> pure id <*> pure rev <*> lookupThrowing id valById
createWithId :: (MonadAction m, Doc a)
=> Text
-> a
-> m (Persisted a)
createWithId id val = createMultipleWithIds [(id, val)]
>>= return . join . fmap (either (const Nothing) Just) . listToMaybe
>>= maybe (throwIO $ OperationException "Failed to create entity") return
createMultiple :: (MonadAction m, Doc a) => [a] -> m [Persisted a]
createMultiple = retry 10
where
generateIdToVal val = do
id <- fmap ((docType val ++ "-") ++) $ fmap fromString generateId
return (id, val)
retry attempts vals = do
idsToVals <- liftIO $ mapM generateIdToVal vals
results <- createMultipleWithIds idsToVals
let (failures, successes) = partitionEithers results
if attempts > 0 || null failures
then do
let vals' = [val | (_, val) <- failures]
let attempts' = if null successes then attempts 1 else attempts
remaining <- if null failures then return [] else retry attempts' vals'
return $ remaining ++ successes
else
throwIO $ OperationException $ "Failed to generate unique ids"
create :: (MonadAction m, Doc a) => a -> m (Persisted a)
create = return . singleton >=> createMultiple >=>
maybe (throwIO $ OperationException "Failed to create entity") return . listToMaybe
updateMultiple :: (MonadAction m, Doc a) => [Persisted a] -> m [Persisted a]
updateMultiple pVals
= writeOperationsAction [Update id rev val | Persisted id rev val <- pVals]
>>= mapM convertResult
where
valById = asMap $ fromList [(id, val) | Persisted id _ val <- pVals]
convertResult (id, Nothing) = throwIO $ OperationException $ "Couldn't update all documents"
convertResult (id, Just rev) = Persisted <$> pure id <*> pure rev <*> lookupThrowing id valById
update :: (MonadAction m, Doc a) => Persisted a -> m (Persisted a)
update = return . singleton >=> updateMultiple >=>
maybe (throwIO $ OperationException "Failed to update entity") return . listToMaybe
lookupThrowing id cache = case lookup id cache of
Just val -> return val
Nothing -> throwIO $ ParsingException $ "Unexpected id: " ++ show id