diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/Database/MongoDB/Internal/Protocol.hs b/Database/MongoDB/Internal/Protocol.hs --- a/Database/MongoDB/Internal/Protocol.hs +++ b/Database/MongoDB/Internal/Protocol.hs @@ -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 diff --git a/Database/MongoDB/Internal/Util.hs b/Database/MongoDB/Internal/Util.hs --- a/Database/MongoDB/Internal/Util.hs +++ b/Database/MongoDB/Internal/Util.hs @@ -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 diff --git a/Database/MongoDB/Query.hs b/Database/MongoDB/Query.hs --- a/Database/MongoDB/Query.hs +++ b/Database/MongoDB/Query.hs @@ -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 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 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 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]@ diff --git a/mongoDB.cabal b/mongoDB.cabal --- a/mongoDB.cabal +++ b/mongoDB.cabal @@ -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 diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -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 diff --git a/test/QuerySpec.hs b/test/QuerySpec.hs --- a/test/QuerySpec.hs +++ b/test/QuerySpec.hs @@ -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"]] - diff --git a/test/TestImport.hs b/test/TestImport.hs --- a/test/TestImport.hs +++ b/test/TestImport.hs @@ -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