From 2bc140eca77aab413a36ec9d449a06a05898b9cc Mon Sep 17 00:00:00 2001 From: jcmartin Date: Sat, 26 Oct 2024 12:47:02 -0700 Subject: [PATCH] Removal of many partial functions related to head. When there is no error code, use Nothing not zero. --- Database/MongoDB/Query.hs | 69 +++++++++++++++++++++++++-------------- 1 file changed, 45 insertions(+), 24 deletions(-) diff --git a/Database/MongoDB/Query.hs b/Database/MongoDB/Query.hs index b83e316..47a84a8 100644 --- a/Database/MongoDB/Query.hs +++ b/Database/MongoDB/Query.hs @@ -155,8 +155,8 @@ access mongoPipe mongoAccessMode mongoDatabase action = runReaderT action MongoC 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. | 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 - | WriteFailure Int ErrorCode String -- ^ Error observed by getLastError after a write, error description is in string, index of failed document is the first argument + | QueryFailure (Maybe ErrorCode) String -- ^ Query failed for some reason as described in the string + | WriteFailure Int (Maybe ErrorCode) String -- ^ Error observed by getLastError after a write, error description is in string, index of failed document is the first argument | WriteConcernFailure Int String -- ^ Write concern error. It's reported only by insert, update, delete commands. Not by wire protocol. | DocNotFound Selection -- ^ 'fetch' found no document matching selection | AggregateFailure String -- ^ 'aggregate' returned an error @@ -273,7 +273,7 @@ auth :: MonadIO m => Username -> Password -> Action m Bool -- ^ Authenticate with the current database (if server is running in secure mode). Return whether authentication was successful or not. Reauthentication is required for every new pipe. SCRAM-SHA-1 will be used for server versions 3.0+, MONGO-CR for lower versions. auth un pw = do let serverVersion = fmap (at "version") $ useDb "admin" $ runCommand ["buildinfo" =: (1 :: Int)] - mmv <- readMaybe . T.unpack . head . T.splitOn "." <$> serverVersion + mmv <- takeMajorVersion <$> serverVersion maybe (return False) performAuth mmv where performAuth majorVersion = @@ -281,6 +281,11 @@ auth un pw = do then authSCRAMSHA1 un pw else authMongoCR un pw +takeMajorVersion :: Text -> Maybe Int +takeMajorVersion t = case T.splitOn "." t of + [] -> fail $ "Expected a version number with a period. Received: " <> show t + (x:_) -> readMaybe $ T.unpack x + authMongoCR :: (MonadIO m) => Username -> Password -> Action m Bool -- ^ Authenticate with the current database, using the MongoDB-CR authentication mechanism (default in MongoDB server < 3.0) authMongoCR usr pss = do @@ -494,7 +499,10 @@ insert col doc = do res <- insertBlock [] col (0, [doc']) case res of Left failure -> liftIO $ throwIO failure - Right r -> return $ head r + Right r -> case r of + [] -> error "Insertion did not return an _id value" + (h:_) -> return h + insert_ :: (MonadIO m) => Collection -> Document -> Action m () -- ^ Same as 'insert' except don't return _id @@ -565,11 +573,14 @@ insert' opts col docs = do chunkResults <- interruptibleFor ordered (zip lSums chunks) $ insertBlock opts col let lchunks = lefts preChunks - when (not $ null lchunks) $ do - liftIO $ throwIO $ head lchunks + case lchunks of + [] -> return () + (h:_) -> liftIO $ throwIO h let lresults = lefts chunkResults - when (not $ null lresults) $ liftIO $ throwIO $ head lresults + case lresults of + [] -> return () + (h:_) -> liftIO $ throwIO h return $ concat $ rights chunkResults insertBlock :: (MonadIO m) @@ -587,7 +598,7 @@ insertBlock opts col (prevCount, docs) = do let errorMessage = do jRes <- res em <- lookup "err" jRes - return $ WriteFailure prevCount (fromMaybe 0 $ lookup "code" jRes) em + return $ WriteFailure prevCount (lookup "code" jRes) em -- In older versions of ^^ the protocol we can't really say which document failed. -- So we just report the accumulated number of documents in the previous blocks. @@ -609,20 +620,20 @@ insertBlock opts col (prevCount, docs) = do (Nothing, Just err) -> do return $ Left $ WriteFailure prevCount - (fromMaybe 0 $ lookup "ok" doc) + (lookup "ok" doc) (show err) (Just (Array errs), Just writeConcernErr) -> do let writeErrors = map (anyToWriteError prevCount) errs let errorsWithFailureIndex = map (addFailureIndex prevCount) writeErrors return $ Left $ CompoundFailure $ WriteFailure prevCount - (fromMaybe 0 $ lookup "ok" doc) + (lookup "ok" doc) (show writeConcernErr) : errorsWithFailureIndex (Just unknownValue, Nothing) -> do return $ Left $ ProtocolFailure prevCount $ "Expected array of errors. Received: " ++ show unknownValue (Just unknownValue, Just writeConcernErr) -> do return $ Left $ CompoundFailure [ ProtocolFailure prevCount $ "Expected array of errors. Received: " ++ show unknownValue - , WriteFailure prevCount (fromMaybe 0 $ lookup "ok" doc) $ show writeConcernErr] + , WriteFailure prevCount (lookup "ok" doc) $ show writeConcernErr] else do mode <- asks mongoWriteMode let writeConcern = case mode of @@ -638,20 +649,20 @@ insertBlock opts col (prevCount, docs) = do (Nothing, Just err) -> do return $ Left $ WriteFailure prevCount - (fromMaybe 0 $ lookup "ok" doc) + (lookup "ok" doc) (show err) (Just (Array errs), Just writeConcernErr) -> do let writeErrors = map (anyToWriteError prevCount) errs let errorsWithFailureIndex = map (addFailureIndex prevCount) writeErrors return $ Left $ CompoundFailure $ WriteFailure prevCount - (fromMaybe 0 $ lookup "ok" doc) + (lookup "ok" doc) (show writeConcernErr) : errorsWithFailureIndex (Just unknownValue, Nothing) -> do return $ Left $ ProtocolFailure prevCount $ "Expected array of errors. Received: " ++ show unknownValue (Just unknownValue, Just writeConcernErr) -> do return $ Left $ CompoundFailure [ ProtocolFailure prevCount $ "Expected array of errors. Received: " ++ show unknownValue - , WriteFailure prevCount (fromMaybe 0 $ lookup "ok" doc) $ show writeConcernErr] + , WriteFailure prevCount (lookup "ok" doc) $ show writeConcernErr] splitAtLimit :: Int -> Int -> [Document] -> [Either Failure [Document]] splitAtLimit maxSize maxCount list = chop (go 0 0 []) list @@ -669,7 +680,7 @@ splitAtLimit maxSize maxCount list = chop (go 0 0 []) list if (curSize + size > maxSize) || (curCount + 1 > maxCount) then if curCount == 0 - then (Left $ WriteFailure 0 0 "One document is too big for the message", xs) + then (Left $ WriteFailure 0 Nothing "One document is too big for the message", xs) else (Right $ reverse res, x : xs) else go (curSize + size) (curCount + 1) (x : res) xs @@ -988,7 +999,7 @@ docToWriteError :: Document -> Failure docToWriteError doc = WriteFailure ind code msg where ind = at "index" doc - code = at "code" doc + code = lookup "code" doc msg = at "errmsg" doc -- ** Delete @@ -1473,7 +1484,9 @@ explain q = do -- same as findOne but with explain set to true qr <- queryRequest True q {limit = 1} r <- liftIO $ request pipe [] qr Batch _ _ docs <- liftDB $ fulfill r - return $ if null docs then error ("no explain: " ++ show q) else head docs + case docs of + [] -> error ("no explain: " ++ show q) + (h:_) -> return h count :: (MonadIO m) => Query -> Action m Int -- ^ Fetch number of documents satisfying query (including effect of skip and/or limit if present) @@ -1574,13 +1587,21 @@ fromReply limit Reply{..} = do checkResponseFlag flag = case flag of AwaitCapable -> return () CursorNotFound -> throwIO $ CursorNotFoundFailure rCursorId - QueryError -> throwIO $ QueryFailure (at "code" $ head rDocuments) (at "$err" $ head rDocuments) -fromReply limit ReplyOpMsg{..} = do - let section = head sections - cur = maybe Nothing cast $ look "cursor" section - case cur of - Nothing -> return (Batch limit 0 sections) - Just doc -> + QueryError -> + let code = case rDocuments of + [] -> fail "Documents are empty" + (h:_) -> lookup "code" h + errString = case rDocuments of + [] -> "No documents in response" + (h:_) -> case lookup "$err" h of + Nothing -> "$err is missing in documents." + Just err -> err + in throwIO $ QueryFailure code errString +fromReply limit ReplyOpMsg{..} = case sections of + [] -> return (Batch limit 0 sections) + (section:_) -> case maybe Nothing cast $ look "cursor" section of + Nothing -> return (Batch limit 0 sections) + Just doc -> case look "firstBatch" doc of Just ar -> do let docs = fromJust $ cast ar