Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Jump to bottom

Removal of many partial functions related to head. #157

Open
wants to merge 2 commits into
base: master
Choose a base branch
from
Open

Removal of many partial functions related to head. #157

Changes from all commits
Commits
Show all changes
2 commits
Select commit Hold shift + click to select a range
2bc140e
Removal of many partial functions related to head. When there is no e…
jcmartin Oct 26, 2024
4cdcc90
Remove unused imports in Query.
jcmartin Oct 26, 2024
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
72 changes: 46 additions & 26 deletions Database/MongoDB/Query.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -133,9 +133,8 @@ import Database.MongoDB.Internal.Protocol
pwKey,
FlagBit (..)
)
import Control.Monad.Trans.Except
import qualified Database.MongoDB.Internal.Protocol as P
import Database.MongoDB.Internal.Util (liftIOE, loop, true1, (<.>), splitDot)
import Database.MongoDB.Internal.Util (liftIOE, loop, true1, (<.>))
import System.Mem.Weak (Weak)
import Text.Read (readMaybe)
import Prelude hiding (lookup)
Expand All @@ -155,8 +154,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
Expand Down Expand Up @@ -273,14 +272,19 @@ 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 =
if majorVersion >= (3 :: Int)
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
Expand Down Expand Up @@ -494,7 +498,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
Expand Down Expand Up @@ -565,11 +572,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)
Expand All @@ -587,7 +597,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.

Expand All @@ -609,20 +619,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
Expand All @@ -638,20 +648,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
Expand All @@ -669,7 +679,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

Expand Down Expand Up @@ -988,7 +998,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
Expand Down Expand Up @@ -1473,7 +1483,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)
Expand Down Expand Up @@ -1574,13 +1586,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
Expand Down