From 344efe6e6a38b94adc940849a4170a1c900c0176 Mon Sep 17 00:00:00 2001 From: Adrian Dole Date: Wed, 15 May 2024 20:09:55 -0700 Subject: [PATCH 1/3] Open replica set from mongodb+srv URI --- Database/MongoDB/Connection.hs | 53 ++++++++++++++++++++++++++++++---- 1 file changed, 48 insertions(+), 5 deletions(-) diff --git a/Database/MongoDB/Connection.hs b/Database/MongoDB/Connection.hs index 63b0786..6d05847 100644 --- a/Database/MongoDB/Connection.hs +++ b/Database/MongoDB/Connection.hs @@ -19,6 +19,7 @@ module Database.MongoDB.Connection ( -- * Replica Set ReplicaSetName, openReplicaSet, openReplicaSet', openReplicaSetTLS, openReplicaSetTLS', openReplicaSetSRV, openReplicaSetSRV', openReplicaSetSRV'', openReplicaSetSRV''', + openReplicaSetURI, openReplicaSetURI', ReplicaSet, primary, secondaryOk, routedHost, closeReplicaSet, replSetName ) where @@ -31,11 +32,12 @@ import Data.Maybe (fromJust) import Control.Applicative ((<$>)) #endif -import Control.Monad (forM_, guard) +import Control.Monad (forM_, guard, unless) import System.IO.Unsafe (unsafePerformIO) import System.Timeout (timeout) import Text.ParserCombinators.Parsec (parse, many1, letter, digit, char, anyChar, eof, - spaces, try, (<|>)) + spaces, try, (<|>), string, option, noneOf) +import Text.Parsec.Prim (Parsec) import qualified Data.List as List @@ -52,8 +54,8 @@ import Database.MongoDB.Internal.Network (Host(..), HostName, PortID(..), connec import Database.MongoDB.Internal.Protocol (Pipe, newPipe, close, isClosed) import Database.MongoDB.Internal.Util (untilSuccess, liftIOE, updateAssocs, shuffle, mergesortM) -import Database.MongoDB.Query (Command, Failure(ConnectionFailure), access, - slaveOk, runCommand, retrieveServerData) +import Database.MongoDB.Query (Command, Failure(ConnectionFailure), access, master, + slaveOk, runCommand, retrieveServerData, auth) import qualified Database.MongoDB.Transport.Tls as TLS (connect) adminCommand :: Command -> Pipe -> IO Document @@ -175,7 +177,7 @@ openReplicaSetSRV' :: HostName -> IO ReplicaSet -- -- ==== __Example__ -- > do --- > pipe <- openReplicatSetSRV' "cluster#.xxxxx.yyyyy.zzz" +-- > pipe <- openReplicaSetSRV' "cluster#.xxxxx.yyyyy.zzz" -- > is_auth <- access pipe master "admin" $ auth user_name password -- > unless is_auth (throwIO $ userError "Authentication failed!") openReplicaSetSRV' hostname = do @@ -202,6 +204,47 @@ _openReplicaSetSRV timeoutSecs transportSecurity hostname = do Secure -> openReplicaSetTLS' timeoutSecs (rsName, hosts) Unsecure -> openReplicaSet' timeoutSecs (rsName, hosts) +data MongoURI = MongoURI HostName (Maybe (Text, Text)) + +parseURI :: Parsec String () MongoURI +parseURI = do + _ <- string "mongodb+srv://" + creds <- option Nothing $ do + u <- many1 (noneOf ":@") + _ <- char ':' + p <- many1 (noneOf "@") + return $ Just (T.pack u, T.pack p) + _ <- char '@' + hostname <- many1 (noneOf "/") + return $ MongoURI hostname creds + +openReplicaSetURI' :: Secs -> String -> IO ReplicaSet +openReplicaSetURI' timeoutSecs uri = do + MongoURI hostname creds <- case parse parseURI "openReplicaSetURI" uri of + Left e -> throwError $ userError $ show e + Right x -> return x + repSet <- _openReplicaSetSRV timeoutSecs Secure hostname + _ <- case creds of + Just (user, pass) -> do + p <- primary repSet + is_auth <- access p master "admin" $ auth user pass + unless is_auth (throwError $ userError "Authentication failed!") + Nothing -> return () + return repSet + +openReplicaSetURI :: String -> IO ReplicaSet +-- ^ Open /secure/ connections (on demand) to the replica set described by the given mongodb+srv URI. Authenticate with the given username and password if provided. The value of 'globalConnectTimeout' at the time of this call is the timeout used for future member connect attempts. To use your own value call 'openReplicaSetURI'' instead. +-- +-- The preferred connection method for MongoDB Atlas. A typical connecting sequence is shown in the example below. +-- +-- ==== __Example__ +-- > do +-- > repSet <- openReplicaSetURI "mongodb+srv://username:password@cluster0.abcdefg.mongodb.net" +-- > p <- primary repSet +openReplicaSetURI uri = do + timeoutSecs <- readIORef globalConnectTimeout + openReplicaSetURI' timeoutSecs uri + closeReplicaSet :: ReplicaSet -> IO () -- ^ Close all connections to replica set closeReplicaSet (ReplicaSet _ vMembers _ _) = withMVar vMembers $ mapM_ (maybe (return ()) close . snd) From 9a24a396d84ea565732db172a1a84516ac8c571c Mon Sep 17 00:00:00 2001 From: Adrian Dole Date: Wed, 15 May 2024 20:30:01 -0700 Subject: [PATCH 2/3] Parser backtracking fix --- Database/MongoDB/Connection.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/Database/MongoDB/Connection.hs b/Database/MongoDB/Connection.hs index 6d05847..55607d9 100644 --- a/Database/MongoDB/Connection.hs +++ b/Database/MongoDB/Connection.hs @@ -36,7 +36,7 @@ import Control.Monad (forM_, guard, unless) import System.IO.Unsafe (unsafePerformIO) import System.Timeout (timeout) import Text.ParserCombinators.Parsec (parse, many1, letter, digit, char, anyChar, eof, - spaces, try, (<|>), string, option, noneOf) + spaces, try, (<|>), string, optionMaybe, noneOf) import Text.Parsec.Prim (Parsec) import qualified Data.List as List @@ -209,12 +209,12 @@ data MongoURI = MongoURI HostName (Maybe (Text, Text)) parseURI :: Parsec String () MongoURI parseURI = do _ <- string "mongodb+srv://" - creds <- option Nothing $ do + creds <- optionMaybe $ try $ do u <- many1 (noneOf ":@") _ <- char ':' p <- many1 (noneOf "@") - return $ Just (T.pack u, T.pack p) - _ <- char '@' + _ <- char '@' + return (T.pack u, T.pack p) hostname <- many1 (noneOf "/") return $ MongoURI hostname creds From 9d437a9c510ff800f842672905df0284ec79cac3 Mon Sep 17 00:00:00 2001 From: Adrian Dole Date: Wed, 15 May 2024 21:33:58 -0700 Subject: [PATCH 3/3] Better error message --- Database/MongoDB/Connection.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Database/MongoDB/Connection.hs b/Database/MongoDB/Connection.hs index 55607d9..df89506 100644 --- a/Database/MongoDB/Connection.hs +++ b/Database/MongoDB/Connection.hs @@ -221,7 +221,7 @@ parseURI = do openReplicaSetURI' :: Secs -> String -> IO ReplicaSet openReplicaSetURI' timeoutSecs uri = do MongoURI hostname creds <- case parse parseURI "openReplicaSetURI" uri of - Left e -> throwError $ userError $ show e + Left e -> throwError $ userError $ "Invalid mongodb+srv URI: " ++ show e Right x -> return x repSet <- _openReplicaSetSRV timeoutSecs Secure hostname _ <- case creds of