Open replica set from mongodb+srv URI

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, optionMaybe, 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 <- optionMaybe $ try $ do
+        u <- many1 (noneOf ":@")
+        _ <- char ':'
+        p <- many1 (noneOf "@")
+        _ <- char '@'
+        return (T.pack u, T.pack p)
+    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 $ "Invalid mongodb+srv URI: " ++ 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:[email protected]"
+-- >   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)