mongoDB 2.7.1.2 → 2.7.1.3
raw patch · 8 files changed
+276/−112 lines, 8 filesdep ~base
Dependency ranges changed: base
Files
- CHANGELOG.md +8/−0
- Database/MongoDB/Internal/Protocol.hs +18/−2
- Database/MongoDB/Internal/Util.hs +3/−0
- Database/MongoDB/Query.hs +147/−87
- mongoDB.cabal +4/−1
- test/Main.hs +9/−11
- test/QuerySpec.hs +47/−6
- test/TestImport.hs +40/−5
CHANGELOG.md view
@@ -2,6 +2,14 @@ All notable changes to this project will be documented in this file. This project adheres to [Package Versioning Policy](https://wiki.haskell.org/Package_versioning_policy). +* Get rid of `MonadFail` constraints in `Database.MongoDB.Query`++## [2.7.1.3] - 2024-02-04++### Fixed+- Collections with dot in the name+- Upper limit for batch size in Query.splitAtLimit+ ## [2.7.1.2] - 2022-10-26 ### Added
Database/MongoDB/Internal/Protocol.hs view
@@ -494,6 +494,9 @@ | ExhaustAllowed -- ^ The client is prepared for multiple replies to this request using the moreToCome bit. deriving (Show, Eq, Enum) +uOptDoc :: UpdateOption -> Document+uOptDoc Upsert = ["upsert" =: True]+uOptDoc MultiUpdate = ["multi" =: True] {- OP_MSG header == 16 byte@@ -528,7 +531,7 @@ putCString "documents" -- identifier mapM_ putDocument iDocuments -- payload Update{..} -> do- let doc = ["q" =: uSelector, "u" =: uUpdater]+ let doc = ["q" =: uSelector, "u" =: uUpdater] <> concatMap uOptDoc uOptions (sec0, sec1Size) = prepSectionInfo uFullCollection@@ -578,6 +581,10 @@ putInt32 (bit $ bitOpMsg $ ExhaustAllowed) putInt8 0 putDocument pre+ Message{..} -> do+ putInt32 biT+ putInt8 0+ putDocument $ merge [ "$db" =: mDatabase ] mParams Kc k -> case k of KillC{..} -> do let n = T.splitOn "." kFullCollection@@ -653,7 +660,11 @@ } | GetMore { gFullCollection :: FullCollection, gBatchSize :: Int32,- gCursorId :: CursorId}+ gCursorId :: CursorId+ } | Message {+ mDatabase :: Text,+ mParams :: Document+ } deriving (Show, Eq) data QueryOption =@@ -673,6 +684,7 @@ qOpcode :: Request -> Opcode qOpcode Query{} = 2004 qOpcode GetMore{} = 2005+qOpcode Message{} = 2013 opMsgOpcode :: Opcode opMsgOpcode = 2013@@ -693,6 +705,10 @@ putCString gFullCollection putInt32 gBatchSize putInt64 gCursorId+ Message{..} -> do+ putInt32 0+ putInt8 0+ putDocument $ merge [ "$db" =: mDatabase ] mParams qBit :: QueryOption -> Int32 qBit TailableCursor = bit 1
Database/MongoDB/Internal/Util.hs view
@@ -92,6 +92,9 @@ -- ^ Concat first and second together with period in between. Eg. @\"hello\" \<.\> \"world\" = \"hello.world\"@ a <.> b = T.append a (T.cons '.' b) +splitDot :: Text -> (Text, Text)+splitDot t = let (pre, post) = T.break (== '.') t in (pre, T.drop 1 post) + true1 :: Label -> Document -> Bool -- ^ Is field's value a 1 or True (MongoDB use both Int and Bools for truth values). Error if field not in document or field not a Num or Bool. true1 k doc = case valueAt k doc of
Database/MongoDB/Query.hs view
@@ -11,7 +11,7 @@ -- * Database Database, allDatabases, useDb, thisDatabase, -- ** Authentication- Username, Password, auth, authMongoCR, authSCRAMSHA1,+ Username, Password, auth, authMongoCR, authSCRAMSHA1, authSCRAMSHA256, -- * Collection Collection, allCollections, -- ** Selection@@ -60,9 +60,11 @@ when, ) import Control.Monad.Reader (MonadReader, ReaderT, ask, asks, local, runReaderT)-import Control.Monad.Trans (MonadIO, liftIO)+import Control.Monad.Trans (MonadIO, liftIO, lift)+import Control.Monad.Trans.Except import qualified Crypto.Hash.MD5 as MD5 import qualified Crypto.Hash.SHA1 as SHA1+import qualified Crypto.Hash.SHA256 as SHA256 import qualified Crypto.MAC.HMAC as HMAC import qualified Crypto.Nonce as Nonce import Data.Binary.Put (runPut)@@ -131,8 +133,9 @@ pwKey, FlagBit (..) )+import Control.Monad.Trans.Except import qualified Database.MongoDB.Internal.Protocol as P-import Database.MongoDB.Internal.Util (liftIOE, loop, true1, (<.>))+import Database.MongoDB.Internal.Util (liftIOE, loop, true1, (<.>), splitDot) import System.Mem.Weak (Weak) import Text.Read (readMaybe) import Prelude hiding (lookup)@@ -284,62 +287,93 @@ n <- at "nonce" <$> runCommand ["getnonce" =: (1 :: Int)] true1 "ok" <$> runCommand ["authenticate" =: (1 :: Int), "user" =: usr, "nonce" =: n, "key" =: pwKey n usr pss] +data HashAlgorithm = SHA1 | SHA256 deriving Show++hash :: HashAlgorithm -> B.ByteString -> B.ByteString+hash SHA1 = SHA1.hash+hash SHA256 = SHA256.hash+ authSCRAMSHA1 :: MonadIO m => Username -> Password -> Action m Bool+authSCRAMSHA1 = authSCRAMWith SHA1++authSCRAMSHA256 :: MonadIO m => Username -> Password -> Action m Bool+authSCRAMSHA256 = authSCRAMWith SHA256++toAuthResult :: Functor m => ExceptT String (Action m) () -> Action m Bool+toAuthResult = fmap (either (const False) (const True)) . runExceptT++-- | It should technically perform SASLprep, but the implementation is currently id+saslprep :: Text -> Text+saslprep = id++authSCRAMWith :: MonadIO m => HashAlgorithm -> Username -> Password -> Action m Bool -- ^ Authenticate with the current database, using the SCRAM-SHA-1 authentication mechanism (default in MongoDB server >= 3.0)-authSCRAMSHA1 un pw = do- let hmac = HMAC.hmac SHA1.hash 64+authSCRAMWith algo un pw = toAuthResult $ do+ let hmac = HMAC.hmac (hash algo) 64 nonce <- liftIO (Nonce.withGenerator Nonce.nonce128 <&> B64.encode) let firstBare = B.concat [B.pack $ "n=" ++ T.unpack un ++ ",r=", nonce]- let client1 = ["saslStart" =: (1 :: Int), "mechanism" =: ("SCRAM-SHA-1" :: String), "payload" =: (B.unpack . B64.encode $ B.concat [B.pack "n,,", firstBare]), "autoAuthorize" =: (1 :: Int)]- server1 <- runCommand client1+ let client1 =+ [ "saslStart" =: (1 :: Int)+ , "mechanism" =: case algo of+ SHA1 -> "SCRAM-SHA-1" :: String+ SHA256 -> "SCRAM-SHA-256"+ , "payload" =: (B.unpack . B64.encode $ B.concat [B.pack "n,,", firstBare])+ , "autoAuthorize" =: (1 :: Int)+ ]+ server1 <- lift $ runCommand client1 - shortcircuit (true1 "ok" server1) $ do- let serverPayload1 = B64.decodeLenient . B.pack . at "payload" $ server1- let serverData1 = parseSCRAM serverPayload1- let iterations = read . B.unpack $ Map.findWithDefault "1" "i" serverData1- let salt = B64.decodeLenient $ Map.findWithDefault "" "s" serverData1- let snonce = Map.findWithDefault "" "r" serverData1+ shortcircuit (true1 "ok" server1) (show server1)+ let serverPayload1 = B64.decodeLenient . B.pack . at "payload" $ server1+ let serverData1 = parseSCRAM serverPayload1+ let iterations = read . B.unpack $ Map.findWithDefault "1" "i" serverData1+ let salt = B64.decodeLenient $ Map.findWithDefault "" "s" serverData1+ let snonce = Map.findWithDefault "" "r" serverData1 - shortcircuit (B.isInfixOf nonce snonce) $ do- let withoutProof = B.concat [B.pack "c=biws,r=", snonce]- let digestS = B.pack $ T.unpack un ++ ":mongo:" ++ T.unpack pw- let digest = B16.encode $ MD5.hash digestS- let saltedPass = scramHI digest salt iterations- let clientKey = hmac saltedPass (B.pack "Client Key")- let storedKey = SHA1.hash clientKey- let authMsg = B.concat [firstBare, B.pack ",", serverPayload1, B.pack ",", withoutProof]- let clientSig = hmac storedKey authMsg- let pval = B64.encode . BS.pack $ BS.zipWith xor clientKey clientSig- let clientFinal = B.concat [withoutProof, B.pack ",p=", pval]- let serverKey = hmac saltedPass (B.pack "Server Key")- let serverSig = B64.encode $ hmac serverKey authMsg- let client2 = ["saslContinue" =: (1 :: Int), "conversationId" =: (at "conversationId" server1 :: Int), "payload" =: B.unpack (B64.encode clientFinal)]- server2 <- runCommand client2+ shortcircuit (B.isInfixOf nonce snonce) "nonce"+ let withoutProof = B.concat [B.pack "c=biws,r=", snonce]+ let digest = case algo of+ SHA1 -> B16.encode $ MD5.hash $ B.pack $ T.unpack un ++ ":mongo:" ++ T.unpack pw+ SHA256 -> B.pack $ T.unpack $ saslprep pw+ let saltedPass = scramHI algo digest salt iterations+ let clientKey = hmac saltedPass (B.pack "Client Key")+ let storedKey = hash algo clientKey+ let authMsg = B.concat [firstBare, B.pack ",", serverPayload1, B.pack ",", withoutProof]+ let clientSig = hmac storedKey authMsg+ let pval = B64.encode . BS.pack $ BS.zipWith xor clientKey clientSig+ let clientFinal = B.concat [withoutProof, B.pack ",p=", pval] - shortcircuit (true1 "ok" server2) $ do- let serverPayload2 = B64.decodeLenient . B.pack $ at "payload" server2- let serverData2 = parseSCRAM serverPayload2- let serverSigComp = Map.findWithDefault "" "v" serverData2+ let client2 =+ [ "saslContinue" =: (1 :: Int)+ , "conversationId" =: (at "conversationId" server1 :: Int)+ , "payload" =: B.unpack (B64.encode clientFinal)+ ]+ server2 <- lift $ runCommand client2+ shortcircuit (true1 "ok" server2) (show server2) - shortcircuit (serverSig == serverSigComp) $ do- let done = true1 "done" server2- if done- then return True- else do- let client2Step2 = [ "saslContinue" =: (1 :: Int)- , "conversationId" =: (at "conversationId" server1 :: Int)- , "payload" =: String ""]- server3 <- runCommand client2Step2- shortcircuit (true1 "ok" server3) $ do- return True- where- shortcircuit True f = f- shortcircuit False _ = return False+ let serverKey = hmac saltedPass (B.pack "Server Key")+ let serverSig = B64.encode $ hmac serverKey authMsg+ let serverPayload2 = B64.decodeLenient . B.pack $ at "payload" server2+ let serverData2 = parseSCRAM serverPayload2+ let serverSigComp = Map.findWithDefault "" "v" serverData2 -scramHI :: B.ByteString -> B.ByteString -> Int -> B.ByteString-scramHI digest salt iters = snd $ foldl com (u1, u1) [1..(iters-1)]+ shortcircuit (serverSig == serverSigComp) "server signature does not match"+ if true1 "done" server2+ then return ()+ else do+ let client2Step2 = [ "saslContinue" =: (1 :: Int)+ , "conversationId" =: (at "conversationId" server1 :: Int)+ , "payload" =: String ""]+ server3 <- lift $ runCommand client2Step2+ shortcircuit (true1 "ok" server3) "server3"++shortcircuit :: Monad m => Bool -> String -> ExceptT String m ()+shortcircuit True _ = pure ()+shortcircuit False reason = throwE (show reason)++scramHI :: HashAlgorithm -> B.ByteString -> B.ByteString -> Int -> B.ByteString+scramHI algo digest salt iters = snd $ foldl com (u1, u1) [1..(iters-1)] where- hmacd = HMAC.hmac SHA1.hash 64 digest+ hmacd = HMAC.hmac (hash algo) 64 digest u1 = hmacd (B.concat [salt, BS.pack [0, 0, 0, 1]]) com (u,uc) _ = let u' = hmacd u in (u', BS.pack $ BS.zipWith xor uc u') @@ -624,19 +658,20 @@ where go :: Int -> Int -> [Document] -> [Document] -> (Either Failure [Document], [Document]) go _ _ res [] = (Right $ reverse res, [])- go curSize curCount [] (x:xs) |- (curSize + sizeOfDocument x + 2 + curCount) > maxSize =- (Left $ WriteFailure 0 0 "One document is too big for the message", xs)- go curSize curCount res (x:xs) =- if ((curSize + sizeOfDocument x + 2 + curCount) > maxSize)- -- we have ^ 2 brackets and curCount commas in- -- the document that we need to take into- -- account- || ((curCount + 1) > maxCount)- then- (Right $ reverse res, x:xs)- else- go (curSize + sizeOfDocument x) (curCount + 1) (x:res) xs+ go curSize curCount res (x : xs) =+ let size = sizeOfDocument x + 8+ in {- 8 bytes =+ 1 byte: element type.+ 6 bytes: key name. |key| <= log (maxWriteBatchSize = 100000)+ 1 byte: \x00.+ See https://bsonspec.org/spec.html+ -}+ 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)+ else (Right $ reverse res, x : xs)+ else go (curSize + size) (curCount + 1) (x : res) xs chop :: ([a] -> (b, [a])) -> [a] -> [b] chop _ [] = []@@ -1271,15 +1306,15 @@ qr <- queryRequestOpMsg False q let newQr = case fst qr of- Req qry ->- let coll = last $ T.splitOn "." (qFullCollection qry)- in (Req $ qry {qSelector = merge (qSelector qry) [ "find" =: coll ]}, snd qr)+ Req P.Query{..} ->+ let coll = last $ T.splitOn "." qFullCollection+ in (Req $ P.Query {qSelector = merge qSelector [ "find" =: coll ], ..}, snd qr) -- queryRequestOpMsg only returns Cmd types constructed via Req _ -> error "impossible" dBatch <- liftIO $ requestOpMsg pipe newQr [] newCursor db (coll selection) batchSize dBatch -findCommand :: (MonadIO m, MonadFail m) => Query -> Action m Cursor+findCommand :: (MonadIO m) => Query -> Action m Cursor -- ^ Fetch documents satisfying query using the command "find" findCommand q@Query{..} = do pipe <- asks mongoPipe@@ -1311,6 +1346,9 @@ | predicate a = Just (f a) | otherwise = Nothing +isHandshake :: Document -> Bool+isHandshake = (== ["isMaster" =: (1 :: Int32)])+ findOne :: (MonadIO m) => Query -> Action m (Maybe Document) -- ^ Fetch first document satisfying query or @Nothing@ if none satisfy it findOne q = do@@ -1320,8 +1358,7 @@ rq <- liftIO $ request pipe [] qr Batch _ _ docs <- liftDB $ fulfill rq return (listToMaybe docs)- isHandshake = (== ["isMaster" =: (1 :: Int32)]) $ selector $ selection q :: Bool- if isHandshake+ if isHandshake (selector $ selection q) then legacyQuery else do let sd = P.serverData pipe@@ -1331,14 +1368,14 @@ qr <- queryRequestOpMsg False q {limit = 1} let newQr = case fst qr of- Req qry ->- let coll = last $ T.splitOn "." (qFullCollection qry)+ Req P.Query{..} ->+ let coll = last $ T.splitOn "." qFullCollection -- We have to understand whether findOne is called as -- command directly. This is necessary since findOne is used via -- runCommand as a vehicle to execute any type of commands and notices.- labels = catMaybes $ map (\f -> look f $ qSelector qry) (noticeCommands ++ adminCommands) :: [Value]+ labels = catMaybes $ map (\f -> look f qSelector) (noticeCommands ++ adminCommands) :: [Value] in if null labels- then (Req $ qry {qSelector = merge (qSelector qry) [ "find" =: coll ]}, snd qr)+ then (Req P.Query {qSelector = merge qSelector [ "find" =: coll ], ..}, snd qr) else qr _ -> error "impossible" rq <- liftIO $ requestOpMsg pipe newQr []@@ -1371,7 +1408,7 @@ -- Return a single updated document (@new@ option is set to @True@). -- -- See 'findAndModifyOpts' for more options.-findAndModify :: (MonadIO m, MonadFail m)+findAndModify :: (MonadIO m) => Query -> Document -- ^ updates -> Action m (Either String Document)@@ -1386,7 +1423,7 @@ -- | Run the @findAndModify@ command -- (allows more options than 'findAndModify')-findAndModifyOpts :: (MonadIO m, MonadFail m)+findAndModifyOpts :: (MonadIO m) => Query -> FindAndModifyOpts -> Action m (Either String (Maybe Document))@@ -1525,7 +1562,7 @@ promise <- liftIOE ConnectionFailure $ P.callOpMsg pipe r Nothing params let protectedPromise = liftIOE ConnectionFailure promise return $ fromReply remainingLimit =<< protectedPromise-requestOpMsg _ (Nc _, _) _ = error "requestOpMsg: Only messages of type Query are supported"+requestOpMsg _ _ _ = error "requestOpMsg: Only messages of type Query are supported" fromReply :: Maybe Limit -> Reply -> DelayedBatch -- ^ Convert Reply to Batch or Failure@@ -1666,7 +1703,7 @@ type Pipeline = [Document] -- ^ The Aggregate Pipeline -aggregate :: (MonadIO m, MonadFail m) => Collection -> Pipeline -> Action m [Document]+aggregate :: (MonadIO m) => Collection -> Pipeline -> Action m [Document] -- ^ Runs an aggregate and unpacks the result. See <http://docs.mongodb.org/manual/core/aggregation/> for details. aggregate aColl agg = do aggregateCursor aColl agg def >>= rest@@ -1689,7 +1726,7 @@ , "allowDiskUse" =: allowDiskUse ] -aggregateCursor :: (MonadIO m, MonadFail m) => Collection -> Pipeline -> AggregateConfig -> Action m Cursor+aggregateCursor :: (MonadIO m) => Collection -> Pipeline -> AggregateConfig -> Action m Cursor -- ^ Runs an aggregate and unpacks the result. See <http://docs.mongodb.org/manual/core/aggregation/> for details. aggregateCursor aColl agg cfg = do pipe <- asks mongoPipe@@ -1708,18 +1745,21 @@ >>= either (liftIO . throwIO . AggregateFailure) return getCursorFromResponse- :: (MonadIO m, MonadFail m)+ :: (MonadIO m) => Collection -> Document -> Action m (Either String Cursor) getCursorFromResponse aColl response- | true1 "ok" response = do- cursor <- lookup "cursor" response- firstBatch <- lookup "firstBatch" cursor- cursorId <- lookup "id" cursor- db <- thisDatabase- Right <$> newCursor db aColl 0 (return $ Batch Nothing cursorId firstBatch)+ | true1 "ok" response = runExceptT $ do+ cursor <- lookup "cursor" response ?? "cursor is missing"+ firstBatch <- lookup "firstBatch" cursor ?? "firstBatch is missing"+ cursorId <- lookup "id" cursor ?? "id is missing"+ db <- lift thisDatabase+ lift $ newCursor db aColl 0 (return $ Batch Nothing cursorId firstBatch) | otherwise = return $ Left $ at "errmsg" response+ where+ Nothing ?? e = throwE e+ Just a ?? _ = pure a -- ** Group @@ -1840,9 +1880,29 @@ -- ^ A command is a special query or action against the database. See <http://www.mongodb.org/display/DOCS/Commands> for details. runCommand :: (MonadIO m) => Command -> Action m Document--- ^ Run command against the database and return its result-runCommand c = fromMaybe err <$> findOne (query c "$cmd") where- err = error $ "Nothing returned for command: " ++ show c+runCommand params = do+ pipe <- asks mongoPipe+ if isHandshake params || maxWireVersion (P.serverData pipe) < 17+ then runCommandLegacy pipe params+ else runCommand' pipe params++runCommandLegacy :: MonadIO m => Pipe -> Selector -> ReaderT MongoContext m Document+runCommandLegacy pipe params = do+ qr <- queryRequest False (query params "$cmd") {limit = 1}+ rq <- liftIO $ request pipe [] qr+ Batch _ _ docs <- liftDB $ fulfill rq+ case docs of+ [doc] -> pure doc+ _ -> error $ "Nothing returned for command: " <> show params++runCommand' :: MonadIO m => Pipe -> Selector -> ReaderT MongoContext m Document+runCommand' pipe params = do+ ctx <- ask+ rq <- liftIO $ requestOpMsg pipe ( Req (P.Message (mongoDatabase ctx) params), Just 1) []+ Batch _ _ docs <- liftDB $ fulfill rq+ case docs of+ [doc] -> pure doc+ _ -> error $ "Nothing returned for command: " <> show params runCommand1 :: (MonadIO m) => Text -> Action m Document -- ^ @runCommand1 foo = runCommand [foo =: 1]@
mongoDB.cabal view
@@ -1,5 +1,5 @@ Name: mongoDB-Version: 2.7.1.2+Version: 2.7.1.3 Synopsis: Driver (client) for MongoDB, a free, scalable, fast, document DBMS Description: This package lets you connect to MongoDB servers and@@ -115,6 +115,8 @@ , base16-bytestring , binary -any , bson >= 0.3 && < 0.5+ , conduit+ , conduit-extra , data-default-class -any , text , bytestring -any@@ -128,6 +130,7 @@ , random-shuffle -any , monad-control >= 0.3.1 , lifted-base >= 0.1.0.3+ , transformers , transformers-base >= 0.4.1 , hashtables >= 1.1.2.0 , fail
test/Main.hs view
@@ -1,19 +1,17 @@ module Main where -import Database.MongoDB.Admin (serverVersion)-import Database.MongoDB.Connection (connect, host)-import Database.MongoDB.Query (access, slaveOk)-import Data.Text (unpack)+import Control.Exception (assert)+import Control.Monad (when)+import Data.Maybe (isJust)+import qualified Spec+import System.Environment (getEnv, lookupEnv) import Test.Hspec.Runner-import System.Environment (getEnv)-import System.IO.Error (catchIOError) import TestImport-import qualified Spec main :: IO () main = do- mongodbHost <- getEnv mongodbHostEnvVariable `catchIOError` (\_ -> return "localhost")- p <- connect $ host mongodbHost- version <- access p slaveOk "admin" serverVersion- putStrLn $ "Running tests with mongodb version: " ++ (unpack version)+ version <- getEnv "MONGO_VERSION"+ when (version == "mongo_atlas") $ do+ connection_string <- lookupEnv "CONNECTION_STRING"+ pure $ assert (isJust connection_string) () hspecWith defaultConfig Spec.spec
test/QuerySpec.hs view
@@ -4,9 +4,10 @@ module QuerySpec (spec) where import Data.String (IsString(..)) import TestImport+import Control.Concurrent (threadDelay) import Control.Exception import Control.Monad (forM_, when)-import System.Environment (getEnv)+import System.Environment (getEnv, lookupEnv) import System.IO.Error (catchIOError) import qualified Data.List as L @@ -16,12 +17,26 @@ testDBName = "mongodb-haskell-test" db :: Action IO a -> IO a-db action = do+db action = bracket start end inbetween+ where+ start = lookupEnv "CONNECTION_STRING" >>= getPipe+ end (_, pipe) = close pipe+ inbetween (testuser, pipe) = do+ logged_in <-+ access pipe master "admin" $ do+ auth (u_name testuser) (u_passwd testuser)+ assert logged_in $ pure ()+ access pipe master testDBName action+ getPipe Nothing = do+ let user = TestUser "testadmin" "123" mongodbHost <- getEnv mongodbHostEnvVariable `catchIOError` (\_ -> return "localhost") pipe <- connect (host mongodbHost)- result <- access pipe master testDBName action- close pipe- return result+ pure (user, pipe)+ getPipe (Just cs) = do+ let creds = extractMongoAtlasCredentials . T.pack $ cs+ user = TestUser "testadmin" (atlas_password creds)+ pipe <- connectAtlas creds+ pure (user, pipe) getWireVersion :: IO Int getWireVersion = db $ do@@ -67,6 +82,8 @@ hugeDocument :: Document hugeDocument = (flip map) [1..1000000] $ \i -> (fromString $ "team" ++ (show i)) =: ("team " ++ (show i) ++ " name") +data TestUser = TestUser {u_name :: T.Text, u_passwd :: T.Text}+ spec :: Spec spec = around withCleanDatabase $ do describe "useDb" $ do@@ -75,6 +92,16 @@ db thisDatabase `shouldReturn` testDBName db (useDb anotherDBName thisDatabase) `shouldReturn` anotherDBName + describe "collectionWithDot" $ do+ it "uses a collection with dots in the name" $ do+ -- Dots in collection names are disallowed from Mongo 6 on+ mongo_version <- getEnv "MONGO_VERSION"+ when (mongo_version `elem` ["mongo:5.0", "mongo:4.0"]) $ do+ let collec = "collection.with.dot"+ _id <- db $ insert collec ["name" =: "jack", "color" =: "blue"]+ Just doc <- db $ findOne (select ["name" =: "jack"] collec)+ doc !? "color" `shouldBe` Just "blue"+ describe "insert" $ do it "inserts a document to the collection and returns its _id" $ do _id <- db $ insert "team" ["name" =: "Yankees", "league" =: "American"]@@ -87,6 +114,21 @@ db (count $ select ["name" =: "Yankees", "league" =: "American"] "team") `shouldReturn` 1 _id `shouldBe` () + describe "upsert" $ do+ it "upserts a document twice with the same spec" $ do+ let q = select ["name" =: "jack"] "users"+ db $ upsert q ["color" =: "blue", "name" =: "jack"]+ -- since there is no way to ask for a ack, we must wait for "a sufficient time"+ -- for the write to be visible+ threadDelay 10000+ db (rest =<< find (select [] "users")) >>= print+ db (count $ select ["name" =: "jack"] "users") `shouldReturn` 1+ db $ upsert q ["color" =: "red", "name" =: "jack"]+ threadDelay 10000+ db (count $ select ["name" =: "jack"] "users") `shouldReturn` 1+ Just doc <- db $ findOne (select ["name" =: "jack"] "users")+ doc !? "color" `shouldBe` Just "red"+ describe "insertMany" $ do it "inserts documents to the collection and returns their _ids" $ do (_id1:_id2:_) <- db $ insertMany "team" [ ["name" =: "Yankees", "league" =: "American"]@@ -473,4 +515,3 @@ , sort = [ "_id" =: 1 ] } result `shouldBe` [["_id" =: "jane"], ["_id" =: "jill"], ["_id" =: "joe"]]-
test/TestImport.hs view
@@ -1,15 +1,18 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-} module TestImport ( module TestImport,- module Export+ module Export, ) where -import Test.Hspec as Export hiding (Selector)-import Database.MongoDB as Export-import Control.Monad.Trans as Export (MonadIO, liftIO) +import Control.Exception (SomeException (SomeException), try)+import Control.Monad.Trans as Export (MonadIO, liftIO)+import qualified Data.Text as T import Data.Time (ParseTime, UTCTime) import qualified Data.Time as Time+import Database.MongoDB as Export+import Test.Hspec as Export hiding (Selector) -- We support the old version of time because it's easier than trying to use -- only the new version and test older GHC versions.@@ -20,7 +23,7 @@ import Data.Maybe (fromJust) #endif -parseTime :: ParseTime t => String -> String -> t+parseTime :: (ParseTime t) => String -> String -> t #if MIN_VERSION_time(1,5,0) parseTime = Time.parseTimeOrError True defaultTimeLocale #else@@ -35,3 +38,35 @@ mongodbHostEnvVariable :: String mongodbHostEnvVariable = "HASKELL_MONGODB_TEST_HOST"++data MongoAtlas = MongoAtlas+ { atlas_host :: T.Text+ , atlas_user :: T.Text+ , atlas_password :: T.Text+ }++extractMongoAtlasCredentials :: T.Text -> MongoAtlas+extractMongoAtlasCredentials cs =+ let s = T.drop 14 cs+ [u, s'] = T.splitOn ":" s+ [p, h] = T.splitOn "@" s'+ in MongoAtlas h u p++connectAtlas :: MongoAtlas -> IO Pipe+connectAtlas (MongoAtlas h _ _) = do+ repset <- openReplicaSetSRV' $ T.unpack h+ primaryOrSecondary repset >>= \case+ Just pipe -> pure pipe+ Nothing -> ioError $ error "Unable to acquire pipe from MongoDB Atlas' replicaset"+ where+ primaryOrSecondary rep =+ try (primary rep) >>= \case+ Left (SomeException err) -> do+ print $+ "Failed to acquire primary replica, reason:"+ ++ show err+ ++ ". Moving to second..."+ try (secondaryOk rep) >>= \case+ Left (SomeException _) -> pure Nothing+ Right pipe -> pure $ Just pipe+ Right pipe -> pure $ Just pipe