User WriteFailure instead of WriteError
This commit is contained in:
parent
c6bd17f1f4
commit
460c7e735b
2 changed files with 19 additions and 26 deletions
|
@ -78,7 +78,6 @@ import Data.Bson (Document, Field(..), Label, Val, Value(String, Doc, Bool),
|
||||||
Javascript, at, valueAt, lookup, look, genObjectId, (=:),
|
Javascript, at, valueAt, lookup, look, genObjectId, (=:),
|
||||||
(=?), (!?), Val(..), ObjectId)
|
(=?), (!?), Val(..), ObjectId)
|
||||||
import Data.Bson.Binary (putDocument)
|
import Data.Bson.Binary (putDocument)
|
||||||
import Data.IORef (newIORef, writeIORef, readIORef)
|
|
||||||
import Data.Maybe (fromJust, isJust)
|
import Data.Maybe (fromJust, isJust)
|
||||||
import Data.Text (Text)
|
import Data.Text (Text)
|
||||||
import qualified Data.Text as T
|
import qualified Data.Text as T
|
||||||
|
@ -128,7 +127,7 @@ data Failure =
|
||||||
ConnectionFailure IOError -- ^ TCP connection ('Pipeline') failed. May work if you try again on the same Mongo 'Connection' which will create a new Pipe.
|
ConnectionFailure IOError -- ^ TCP connection ('Pipeline') failed. May work if you try again on the same Mongo 'Connection' which will create a new Pipe.
|
||||||
| CursorNotFoundFailure CursorId -- ^ Cursor expired because it wasn't accessed for over 10 minutes, or this cursor came from a different server that the one you are currently connected to (perhaps a fail over happen between servers in a replica set)
|
| CursorNotFoundFailure CursorId -- ^ Cursor expired because it wasn't accessed for over 10 minutes, or this cursor came from a different server that the one you are currently connected to (perhaps a fail over happen between servers in a replica set)
|
||||||
| QueryFailure ErrorCode String -- ^ Query failed for some reason as described in the string
|
| QueryFailure ErrorCode String -- ^ Query failed for some reason as described in the string
|
||||||
| WriteFailure ErrorCode String -- ^ Error observed by getLastError after a write, error description is in string
|
| WriteFailure Int ErrorCode String -- ^ Error observed by getLastError after a write, error description is in string, index of failed document is the first argument
|
||||||
| DocNotFound Selection -- ^ 'fetch' found no document matching selection
|
| DocNotFound Selection -- ^ 'fetch' found no document matching selection
|
||||||
| AggregateFailure String -- ^ 'aggregate' returned an error
|
| AggregateFailure String -- ^ 'aggregate' returned an error
|
||||||
deriving (Show, Eq, Typeable)
|
deriving (Show, Eq, Typeable)
|
||||||
|
@ -159,7 +158,7 @@ data UpdateResult = UpdateResult
|
||||||
, nModified :: Maybe Int
|
, nModified :: Maybe Int
|
||||||
-- ^ Mongodb server before 2.6 doesn't allow to calculate this value. This field is nothing if we can't calculate the number of modified documents.
|
-- ^ Mongodb server before 2.6 doesn't allow to calculate this value. This field is nothing if we can't calculate the number of modified documents.
|
||||||
, upserted :: [Upserted]
|
, upserted :: [Upserted]
|
||||||
, writeErrors :: [WriteError]
|
, writeErrors :: [Failure]
|
||||||
, writeConcernErrors :: [WriteConcernError]
|
, writeConcernErrors :: [WriteConcernError]
|
||||||
} deriving Show
|
} deriving Show
|
||||||
|
|
||||||
|
@ -176,12 +175,6 @@ data WriteConcernError = WriteConcernError
|
||||||
, wceErrMsg :: String
|
, wceErrMsg :: String
|
||||||
} deriving Show
|
} deriving Show
|
||||||
|
|
||||||
data WriteError = WriteError
|
|
||||||
{ errIndex :: Int
|
|
||||||
, errCode :: Int
|
|
||||||
, errMsg :: String
|
|
||||||
} deriving Show
|
|
||||||
|
|
||||||
data DeleteResult = DeleteResult
|
data DeleteResult = DeleteResult
|
||||||
|
|
||||||
master :: AccessMode
|
master :: AccessMode
|
||||||
|
@ -492,7 +485,7 @@ insertBlock opts col docs = do
|
||||||
when (isJust res) $ do
|
when (isJust res) $ do
|
||||||
let jRes = fromJust res
|
let jRes = fromJust res
|
||||||
let e = lookup "err" jRes
|
let e = lookup "err" jRes
|
||||||
when (isJust e) $ liftIO $ throwIO $ WriteFailure (maybe 0 id $ lookup "code" jRes) (fromJust e)
|
when (isJust e) $ liftIO $ throwIO $ WriteFailure 0 (maybe 0 id $ lookup "code" jRes) (fromJust e) -- Add proper index in the first argument
|
||||||
return $ map (valueAt "_id") docs'
|
return $ map (valueAt "_id") docs'
|
||||||
else do
|
else do
|
||||||
mode <- asks mongoWriteMode
|
mode <- asks mongoWriteMode
|
||||||
|
@ -503,15 +496,15 @@ insertBlock opts col docs = do
|
||||||
case (look "writeErrors" doc, look "writeConcernError" doc) of
|
case (look "writeErrors" doc, look "writeConcernError" doc) of
|
||||||
(Nothing, Nothing) -> return $ map (valueAt "_id") docs'
|
(Nothing, Nothing) -> return $ map (valueAt "_id") docs'
|
||||||
(Just err, Nothing) -> do
|
(Just err, Nothing) -> do
|
||||||
liftIO $ throwIO $ WriteFailure
|
liftIO $ throwIO $ WriteFailure 0 -- Add proper index
|
||||||
(maybe 0 id $ lookup "ok" doc)
|
(maybe 0 id $ lookup "ok" doc)
|
||||||
(show err)
|
(show err)
|
||||||
(Nothing, Just err) -> do
|
(Nothing, Just err) -> do
|
||||||
liftIO $ throwIO $ WriteFailure
|
liftIO $ throwIO $ WriteFailure 0 -- Add proper index
|
||||||
(maybe 0 id $ lookup "ok" doc)
|
(maybe 0 id $ lookup "ok" doc)
|
||||||
(show err)
|
(show err)
|
||||||
(Just err, Just writeConcernErr) -> do -- TODO writeConcernError is not a failure
|
(Just err, Just writeConcernErr) -> do -- TODO writeConcernError is not a failure
|
||||||
liftIO $ throwIO $ WriteFailure
|
liftIO $ throwIO $ WriteFailure 0 -- Add proper index
|
||||||
(maybe 0 id $ lookup "ok" doc)
|
(maybe 0 id $ lookup "ok" doc)
|
||||||
(show err ++ show writeConcernErr)
|
(show err ++ show writeConcernErr)
|
||||||
|
|
||||||
|
@ -526,7 +519,7 @@ splitAtLimit ordered maxSize maxCount list = chop (go 0 0 []) list
|
||||||
then
|
then
|
||||||
go curSize curCount [] xs -- Skip this document and insert the other documents.
|
go curSize curCount [] xs -- Skip this document and insert the other documents.
|
||||||
else
|
else
|
||||||
throw $ WriteFailure 0 "One document is too big for the message"
|
throw $ WriteFailure 0 0 "One document is too big for the message" -- TODO add proper index in the first argument
|
||||||
go curSize curCount res (x:xs) =
|
go curSize curCount res (x:xs) =
|
||||||
if ( ((curSize + (sizeOfDocument x) + 2 + curCount) > maxSize)
|
if ( ((curSize + (sizeOfDocument x) + 2 + curCount) > maxSize)
|
||||||
-- we have ^ 2 brackets and curCount commas in
|
-- we have ^ 2 brackets and curCount commas in
|
||||||
|
@ -590,7 +583,7 @@ update :: (MonadIO m)
|
||||||
update opts (Select sel col) up = do
|
update opts (Select sel col) up = do
|
||||||
res <- update' True col [(sel, up, opts)]
|
res <- update' True col [(sel, up, opts)]
|
||||||
if not $ null $ writeErrors res
|
if not $ null $ writeErrors res
|
||||||
then liftIO $ throwIO $ WriteFailure 0 (show $ head $ writeErrors res)
|
then liftIO $ throwIO $ WriteFailure 0 0 (show $ head $ writeErrors res)
|
||||||
else return ()
|
else return ()
|
||||||
|
|
||||||
updateCommandDocument :: Collection -> Bool -> [Document] -> Document -> Document
|
updateCommandDocument :: Collection -> Bool -> [Document] -> Document -> Document
|
||||||
|
@ -655,8 +648,8 @@ update' ordered col updateDocs = do
|
||||||
blocks <- liftIO $ interruptibleFor ordered (zip lSums chunks) $ \b -> liftIO $ do
|
blocks <- liftIO $ interruptibleFor ordered (zip lSums chunks) $ \b -> liftIO $ do
|
||||||
ur <- runReaderT (updateBlock ordered col b) ctx
|
ur <- runReaderT (updateBlock ordered col b) ctx
|
||||||
return ur
|
return ur
|
||||||
`catch` \(e :: SomeException) -> do
|
`catch` \(e :: Failure) -> do
|
||||||
return $ UpdateResult True 0 Nothing [] [] [] -- TODO probably should be revised
|
return $ UpdateResult True 0 Nothing [] [e] [] -- TODO probably should be revised
|
||||||
let failedTotal = or $ map failed blocks
|
let failedTotal = or $ map failed blocks
|
||||||
let updatedTotal = sum $ map nMatched blocks
|
let updatedTotal = sum $ map nMatched blocks
|
||||||
let modifiedTotal =
|
let modifiedTotal =
|
||||||
|
@ -740,9 +733,9 @@ updateBlockLegacy ordered col (prevCount, docs) = do
|
||||||
then do
|
then do
|
||||||
return $ UpdateResult True 0 Nothing [] [] [WriteConcernError c errV]
|
return $ UpdateResult True 0 Nothing [] [] [WriteConcernError c errV]
|
||||||
else do
|
else do
|
||||||
return $ UpdateResult True 0 Nothing [] [WriteError i c errV] []
|
return $ UpdateResult True 0 Nothing [] [WriteFailure i c errV] []
|
||||||
`catch` \(e :: SomeException) -> do
|
`catch` \(e :: Failure) -> do
|
||||||
return $ UpdateResult True 0 Nothing [] [WriteError i 0 (show e)] []
|
return $ UpdateResult True 0 Nothing [] [e] []
|
||||||
return $ foldl1' mergeUpdateResults results
|
return $ foldl1' mergeUpdateResults results
|
||||||
|
|
||||||
mergeUpdateResults :: UpdateResult -> UpdateResult -> UpdateResult
|
mergeUpdateResults :: UpdateResult -> UpdateResult -> UpdateResult
|
||||||
|
@ -765,8 +758,8 @@ docToUpserted doc = Upserted ind uid
|
||||||
ind = at "index" doc
|
ind = at "index" doc
|
||||||
uid = at "_id" doc
|
uid = at "_id" doc
|
||||||
|
|
||||||
docToWriteError :: Document -> WriteError
|
docToWriteError :: Document -> Failure
|
||||||
docToWriteError doc = WriteError ind code msg
|
docToWriteError doc = WriteFailure ind code msg
|
||||||
where
|
where
|
||||||
ind = at "index" doc
|
ind = at "index" doc
|
||||||
code = at "code" doc
|
code = at "code" doc
|
||||||
|
@ -877,7 +870,7 @@ deleteBlock ordered col docs = do
|
||||||
return $ Just e
|
return $ Just e
|
||||||
let onlyErrors = catMaybes errors
|
let onlyErrors = catMaybes errors
|
||||||
if not $ null onlyErrors
|
if not $ null onlyErrors
|
||||||
then liftIO $ throwIO $ WriteFailure 0 (show onlyErrors)
|
then liftIO $ throwIO $ WriteFailure 0 0 (show onlyErrors) -- TODO add normal index (first argument)
|
||||||
else return ()
|
else return ()
|
||||||
else do
|
else do
|
||||||
mode <- asks mongoWriteMode
|
mode <- asks mongoWriteMode
|
||||||
|
@ -888,15 +881,15 @@ deleteBlock ordered col docs = do
|
||||||
case (look "writeErrors" doc, look "writeConcernError" doc) of
|
case (look "writeErrors" doc, look "writeConcernError" doc) of
|
||||||
(Nothing, Nothing) -> return ()
|
(Nothing, Nothing) -> return ()
|
||||||
(Just err, Nothing) -> do
|
(Just err, Nothing) -> do
|
||||||
liftIO $ throwIO $ WriteFailure
|
liftIO $ throwIO $ WriteFailure 0 -- TODO add normal index
|
||||||
(maybe 0 id $ lookup "ok" doc)
|
(maybe 0 id $ lookup "ok" doc)
|
||||||
(show err)
|
(show err)
|
||||||
(Nothing, Just err) -> do
|
(Nothing, Just err) -> do
|
||||||
liftIO $ throwIO $ WriteFailure
|
liftIO $ throwIO $ WriteFailure 0 -- TODO add normal index
|
||||||
(maybe 0 id $ lookup "ok" doc)
|
(maybe 0 id $ lookup "ok" doc)
|
||||||
(show err)
|
(show err)
|
||||||
(Just err, Just writeConcernErr) -> do
|
(Just err, Just writeConcernErr) -> do
|
||||||
liftIO $ throwIO $ WriteFailure
|
liftIO $ throwIO $ WriteFailure 0 -- TODO add normal index
|
||||||
(maybe 0 id $ lookup "ok" doc)
|
(maybe 0 id $ lookup "ok" doc)
|
||||||
(show err ++ show writeConcernErr)
|
(show err ++ show writeConcernErr)
|
||||||
|
|
||||||
|
|
0
Setup.lhs
Executable file → Normal file
0
Setup.lhs
Executable file → Normal file
Loading…
Reference in a new issue