-- | Connect to a single server or a replica set of servers

{-# LANGUAGE CPP, OverloadedStrings, ScopedTypeVariables, TupleSections #-}

#if (__GLASGOW_HASKELL__ >= 706)
{-# LANGUAGE RecursiveDo #-}
#else
{-# LANGUAGE DoRec #-}
#endif

module Database.MongoDB.Connection (
    -- * Util
    Secs,
    -- * Connection
    Pipe, close, isClosed,
    -- * Server
    Host(..), PortID(..), defaultPort, host, showHostPort, readHostPort,
    readHostPortM, globalConnectTimeout, connect, connect',
    -- * Replica Set
    ReplicaSetName, openReplicaSet, openReplicaSet', openReplicaSetTLS, openReplicaSetTLS',
    openReplicaSetSRV, openReplicaSetSRV', openReplicaSetSRV'', openReplicaSetSRV''',
    ReplicaSet, primary, secondaryOk, routedHost, closeReplicaSet, replSetName
) where

import Prelude hiding (lookup)
import Data.IORef (IORef, newIORef, readIORef)
import Data.List (intersect, partition, (\\), delete)
import Data.Maybe (fromJust)

#if !MIN_VERSION_base(4,8,0)
import Control.Applicative ((<$>))
#endif

import Control.Monad (forM_, guard)
import System.IO.Unsafe (unsafePerformIO)
import System.Timeout (timeout)
import Text.ParserCombinators.Parsec (parse, many1, letter, digit, char, anyChar, eof,
                                      spaces, try, (<|>))
import qualified Data.List as List


import Control.Monad.Except (throwError)
import Control.Concurrent.MVar.Lifted (MVar, newMVar, withMVar, modifyMVar,
                                       readMVar)
import Data.Bson (Document, at, (=:))
import Data.Text (Text)

import qualified Data.Bson as B
import qualified Data.Text as T

import Database.MongoDB.Internal.Network (Host(..), HostName, PortID(..), connectTo, lookupSeedList, lookupReplicaSetName)
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 qualified Database.MongoDB.Transport.Tls as TLS (connect)

adminCommand :: Command -> Pipe -> IO Document
-- ^ Run command against admin database on server connected to pipe. Fail if connection fails.
adminCommand :: Document -> Pipe -> IO Document
adminCommand Document
cmd Pipe
pipe =
    (Failure -> IOError) -> IO Document -> IO Document
forall (m :: * -> *) e e' a.
(MonadIO m, Exception e, Exception e') =>
(e -> e') -> IO a -> m a
liftIOE Failure -> IOError
failureToIOError (IO Document -> IO Document) -> IO Document -> IO Document
forall a b. (a -> b) -> a -> b
$ Pipe -> AccessMode -> Database -> Action IO Document -> IO Document
forall (m :: * -> *) a.
MonadIO m =>
Pipe -> AccessMode -> Database -> Action m a -> m a
access Pipe
pipe AccessMode
slaveOk Database
"admin" (Action IO Document -> IO Document)
-> Action IO Document -> IO Document
forall a b. (a -> b) -> a -> b
$ Document -> Action IO Document
forall (m :: * -> *). MonadIO m => Document -> Action m Document
runCommand Document
cmd
 where
    failureToIOError :: Failure -> IOError
failureToIOError (ConnectionFailure IOError
e) = IOError
e
    failureToIOError Failure
e = [Char] -> IOError
userError ([Char] -> IOError) -> [Char] -> IOError
forall a b. (a -> b) -> a -> b
$ Failure -> [Char]
forall a. Show a => a -> [Char]
show Failure
e

defaultPort :: PortID
-- ^ Default MongoDB port = 27017
defaultPort :: PortID
defaultPort = PortNumber -> PortID
PortNumber PortNumber
27017

host :: HostName -> Host
-- ^ Host on 'defaultPort'
host :: [Char] -> Host
host [Char]
hostname = [Char] -> PortID -> Host
Host [Char]
hostname PortID
defaultPort

showHostPort :: Host -> String
-- ^ Display host as \"host:port\"
-- TODO: Distinguish Service port
showHostPort :: Host -> [Char]
showHostPort (Host [Char]
hostname (PortNumber PortNumber
port)) = [Char]
hostname [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
":" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ PortNumber -> [Char]
forall a. Show a => a -> [Char]
show PortNumber
port
#if !defined(mingw32_HOST_OS) && !defined(cygwin32_HOST_OS) && !defined(_WIN32)
showHostPort (Host [Char]
_        (UnixSocket [Char]
path)) = [Char]
"unix:" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
path
#endif

readHostPortM :: (MonadFail m) => String -> m Host
-- ^ Read string \"hostname:port\" as @Host hosthame (PortNumber port)@ or \"hostname\" as @host hostname@ (default port). Fail if string does not match either syntax.

-- TODO: handle Service port
readHostPortM :: forall (m :: * -> *). MonadFail m => [Char] -> m Host
readHostPortM = (ParseError -> m Host)
-> (Host -> m Host) -> Either ParseError Host -> m Host
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ([Char] -> m Host
forall a. [Char] -> m a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> m Host)
-> (ParseError -> [Char]) -> ParseError -> m Host
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParseError -> [Char]
forall a. Show a => a -> [Char]
show) Host -> m Host
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ParseError Host -> m Host)
-> ([Char] -> Either ParseError Host) -> [Char] -> m Host
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parsec [Char] () Host -> [Char] -> [Char] -> Either ParseError Host
forall s t a.
Stream s Identity t =>
Parsec s () a -> [Char] -> s -> Either ParseError a
parse Parsec [Char] () Host
forall {u}. ParsecT [Char] u Identity Host
parser [Char]
"readHostPort" where
    hostname :: ParsecT [Char] u Identity [Char]
hostname = ParsecT [Char] u Identity Char -> ParsecT [Char] u Identity [Char]
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 (ParsecT [Char] u Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
letter ParsecT [Char] u Identity Char
-> ParsecT [Char] u Identity Char -> ParsecT [Char] u Identity Char
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> ParsecT [Char] u Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
digit ParsecT [Char] u Identity Char
-> ParsecT [Char] u Identity Char -> ParsecT [Char] u Identity Char
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> Char -> ParsecT [Char] u Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'-' ParsecT [Char] u Identity Char
-> ParsecT [Char] u Identity Char -> ParsecT [Char] u Identity Char
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> Char -> ParsecT [Char] u Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'.' ParsecT [Char] u Identity Char
-> ParsecT [Char] u Identity Char -> ParsecT [Char] u Identity Char
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> Char -> ParsecT [Char] u Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'_')
    parser :: ParsecT [Char] u Identity Host
parser = do
        ParsecT [Char] u Identity ()
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
spaces
        [Char]
h <- ParsecT [Char] u Identity [Char]
forall {u}. ParsecT [Char] u Identity [Char]
hostname
        ParsecT [Char] u Identity Host -> ParsecT [Char] u Identity Host
forall tok st a. GenParser tok st a -> GenParser tok st a
try (ParsecT [Char] u Identity ()
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
spaces ParsecT [Char] u Identity ()
-> ParsecT [Char] u Identity () -> ParsecT [Char] u Identity ()
forall a b.
ParsecT [Char] u Identity a
-> ParsecT [Char] u Identity b -> ParsecT [Char] u Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ParsecT [Char] u Identity ()
forall s (m :: * -> *) t u.
(Stream s m t, Show t) =>
ParsecT s u m ()
eof ParsecT [Char] u Identity ()
-> ParsecT [Char] u Identity Host -> ParsecT [Char] u Identity Host
forall a b.
ParsecT [Char] u Identity a
-> ParsecT [Char] u Identity b -> ParsecT [Char] u Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Host -> ParsecT [Char] u Identity Host
forall a. a -> ParsecT [Char] u Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Char] -> Host
host [Char]
h)) ParsecT [Char] u Identity Host
-> ParsecT [Char] u Identity Host -> ParsecT [Char] u Identity Host
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> do
            Char
_ <- Char -> ParsecT [Char] u Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
':'
            ParsecT [Char] u Identity Host -> ParsecT [Char] u Identity Host
forall tok st a. GenParser tok st a -> GenParser tok st a
try (  do Int
port :: Int <- [Char] -> Int
forall a. Read a => [Char] -> a
read ([Char] -> Int)
-> ParsecT [Char] u Identity [Char]
-> ParsecT [Char] u Identity Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT [Char] u Identity Char -> ParsecT [Char] u Identity [Char]
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 ParsecT [Char] u Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
digit
                      ParsecT [Char] u Identity ()
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
spaces ParsecT [Char] u Identity ()
-> ParsecT [Char] u Identity () -> ParsecT [Char] u Identity ()
forall a b.
ParsecT [Char] u Identity a
-> ParsecT [Char] u Identity b -> ParsecT [Char] u Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ParsecT [Char] u Identity ()
forall s (m :: * -> *) t u.
(Stream s m t, Show t) =>
ParsecT s u m ()
eof
                      Host -> ParsecT [Char] u Identity Host
forall a. a -> ParsecT [Char] u Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Host -> ParsecT [Char] u Identity Host)
-> Host -> ParsecT [Char] u Identity Host
forall a b. (a -> b) -> a -> b
$ [Char] -> PortID -> Host
Host [Char]
h (PortNumber -> PortID
PortNumber (PortNumber -> PortID) -> PortNumber -> PortID
forall a b. (a -> b) -> a -> b
$ Int -> PortNumber
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
port))
#if !defined(mingw32_HOST_OS) && !defined(cygwin32_HOST_OS) && !defined(_WIN32)
              ParsecT [Char] u Identity Host
-> ParsecT [Char] u Identity Host -> ParsecT [Char] u Identity Host
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|>  do Bool -> ParsecT [Char] u Identity ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard ([Char]
h [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
"unix")
                      [Char]
p <- ParsecT [Char] u Identity Char -> ParsecT [Char] u Identity [Char]
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 ParsecT [Char] u Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
anyChar
                      ParsecT [Char] u Identity ()
forall s (m :: * -> *) t u.
(Stream s m t, Show t) =>
ParsecT s u m ()
eof
                      Host -> ParsecT [Char] u Identity Host
forall a. a -> ParsecT [Char] u Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Host -> ParsecT [Char] u Identity Host)
-> Host -> ParsecT [Char] u Identity Host
forall a b. (a -> b) -> a -> b
$ [Char] -> PortID -> Host
Host [Char]
"" ([Char] -> PortID
UnixSocket [Char]
p)
#endif

readHostPort :: String -> Host
-- ^ Read string \"hostname:port\" as @Host hostname (PortNumber port)@ or \"hostname\" as @host hostname@ (default port). Error if string does not match either syntax.
readHostPort :: [Char] -> Host
readHostPort = Maybe Host -> Host
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Host -> Host) -> ([Char] -> Maybe Host) -> [Char] -> Host
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Maybe Host
forall (m :: * -> *). MonadFail m => [Char] -> m Host
readHostPortM

type Secs = Double

globalConnectTimeout :: IORef Secs
-- ^ 'connect' (and 'openReplicaSet') fails if it can't connect within this many seconds (default is 6 seconds). Use 'connect'' (and 'openReplicaSet'') if you want to ignore this global and specify your own timeout. Note, this timeout only applies to initial connection establishment, not when reading/writing to the connection.
globalConnectTimeout :: IORef Secs
globalConnectTimeout = IO (IORef Secs) -> IORef Secs
forall a. IO a -> a
unsafePerformIO (Secs -> IO (IORef Secs)
forall a. a -> IO (IORef a)
newIORef Secs
6)
{-# NOINLINE globalConnectTimeout #-}

connect :: Host -> IO Pipe
-- ^ Connect to Host returning pipelined TCP connection. Throw 'IOError' if connection refused or no response within 'globalConnectTimeout'.
connect :: Host -> IO Pipe
connect Host
h = IORef Secs -> IO Secs
forall a. IORef a -> IO a
readIORef IORef Secs
globalConnectTimeout IO Secs -> (Secs -> IO Pipe) -> IO Pipe
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Secs -> Host -> IO Pipe) -> Host -> Secs -> IO Pipe
forall a b c. (a -> b -> c) -> b -> a -> c
flip Secs -> Host -> IO Pipe
connect' Host
h

connect' :: Secs -> Host -> IO Pipe
-- ^ Connect to Host returning pipelined TCP connection. Throw 'IOError' if connection refused or no response within given number of seconds.
connect' :: Secs -> Host -> IO Pipe
connect' Secs
timeoutSecs (Host [Char]
hostname PortID
port) = do
    Maybe Handle
mh <- Int -> IO Handle -> IO (Maybe Handle)
forall a. Int -> IO a -> IO (Maybe a)
timeout (Secs -> Int
forall b. Integral b => Secs -> b
forall a b. (RealFrac a, Integral b) => a -> b
round (Secs -> Int) -> Secs -> Int
forall a b. (a -> b) -> a -> b
$ Secs
timeoutSecs Secs -> Secs -> Secs
forall a. Num a => a -> a -> a
* Secs
1000000) ([Char] -> PortID -> IO Handle
connectTo [Char]
hostname PortID
port)
    Handle
handle <- IO Handle -> (Handle -> IO Handle) -> Maybe Handle -> IO Handle
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (IOError -> IO Handle
forall a. IOError -> IO a
ioError (IOError -> IO Handle) -> IOError -> IO Handle
forall a b. (a -> b) -> a -> b
$ [Char] -> IOError
userError [Char]
"connect timed out") Handle -> IO Handle
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Handle
mh
    rec
      Pipe
p <- ServerData -> Handle -> IO Pipe
newPipe ServerData
sd Handle
handle
      ServerData
sd <- Pipe
-> AccessMode -> Database -> Action IO ServerData -> IO ServerData
forall (m :: * -> *) a.
MonadIO m =>
Pipe -> AccessMode -> Database -> Action m a -> m a
access Pipe
p AccessMode
slaveOk Database
"admin" Action IO ServerData
forall (m :: * -> *). MonadIO m => Action m ServerData
retrieveServerData
    Pipe -> IO Pipe
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Pipe
p

-- * Replica Set

type ReplicaSetName = Text

data TransportSecurity = Secure | Unsecure

-- | Maintains a connection (created on demand) to each server in the named replica set
data ReplicaSet = ReplicaSet ReplicaSetName (MVar [(Host, Maybe Pipe)]) Secs TransportSecurity

replSetName :: ReplicaSet -> Text
-- ^ Get the name of connected replica set.
replSetName :: ReplicaSet -> Database
replSetName (ReplicaSet Database
rsName MVar [(Host, Maybe Pipe)]
_ Secs
_ TransportSecurity
_) = Database
rsName

openReplicaSet :: (ReplicaSetName, [Host]) -> IO ReplicaSet
-- ^ Open connections (on demand) to servers in replica set. Supplied hosts is seed list. At least one of them must be a live member of the named replica set, otherwise fail. 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 'openReplicaSet'' instead.
openReplicaSet :: (Database, [Host]) -> IO ReplicaSet
openReplicaSet (Database, [Host])
rsSeed = IORef Secs -> IO Secs
forall a. IORef a -> IO a
readIORef IORef Secs
globalConnectTimeout IO Secs -> (Secs -> IO ReplicaSet) -> IO ReplicaSet
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Secs -> (Database, [Host]) -> IO ReplicaSet)
-> (Database, [Host]) -> Secs -> IO ReplicaSet
forall a b c. (a -> b -> c) -> b -> a -> c
flip Secs -> (Database, [Host]) -> IO ReplicaSet
openReplicaSet' (Database, [Host])
rsSeed

openReplicaSet' :: Secs -> (ReplicaSetName, [Host]) -> IO ReplicaSet
-- ^ Open connections (on demand) to servers in replica set. Supplied hosts is seed list. At least one of them must be a live member of the named replica set, otherwise fail. Supplied seconds timeout is used for connect attempts to members.
openReplicaSet' :: Secs -> (Database, [Host]) -> IO ReplicaSet
openReplicaSet' Secs
timeoutSecs (Database
rs, [Host]
hosts) = Secs -> (Database, [Host], TransportSecurity) -> IO ReplicaSet
_openReplicaSet Secs
timeoutSecs (Database
rs, [Host]
hosts, TransportSecurity
Unsecure)

openReplicaSetTLS :: (ReplicaSetName, [Host]) -> IO ReplicaSet
-- ^ Open secure connections (on demand) to servers in the replica set. Supplied hosts is seed list. At least one of them must be a live member of the named replica set, otherwise fail. 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 'openReplicaSetTLS'' instead.
openReplicaSetTLS :: (Database, [Host]) -> IO ReplicaSet
openReplicaSetTLS  (Database, [Host])
rsSeed = IORef Secs -> IO Secs
forall a. IORef a -> IO a
readIORef IORef Secs
globalConnectTimeout IO Secs -> (Secs -> IO ReplicaSet) -> IO ReplicaSet
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Secs -> (Database, [Host]) -> IO ReplicaSet)
-> (Database, [Host]) -> Secs -> IO ReplicaSet
forall a b c. (a -> b -> c) -> b -> a -> c
flip Secs -> (Database, [Host]) -> IO ReplicaSet
openReplicaSetTLS' (Database, [Host])
rsSeed

openReplicaSetTLS' :: Secs -> (ReplicaSetName, [Host]) -> IO ReplicaSet
-- ^ Open secure connections (on demand) to servers in replica set. Supplied hosts is seed list. At least one of them must be a live member of the named replica set, otherwise fail. Supplied seconds timeout is used for connect attempts to members.
openReplicaSetTLS' :: Secs -> (Database, [Host]) -> IO ReplicaSet
openReplicaSetTLS' Secs
timeoutSecs (Database
rs, [Host]
hosts) = Secs -> (Database, [Host], TransportSecurity) -> IO ReplicaSet
_openReplicaSet Secs
timeoutSecs (Database
rs, [Host]
hosts, TransportSecurity
Secure)

_openReplicaSet :: Secs -> (ReplicaSetName, [Host], TransportSecurity) -> IO ReplicaSet
_openReplicaSet :: Secs -> (Database, [Host], TransportSecurity) -> IO ReplicaSet
_openReplicaSet Secs
timeoutSecs (Database
rsName, [Host]
seedList, TransportSecurity
transportSecurity) = do
    MVar [(Host, Maybe Pipe)]
vMembers <- [(Host, Maybe Pipe)] -> IO (MVar [(Host, Maybe Pipe)])
forall (m :: * -> *) a. MonadBase IO m => a -> m (MVar a)
newMVar ((Host -> (Host, Maybe Pipe)) -> [Host] -> [(Host, Maybe Pipe)]
forall a b. (a -> b) -> [a] -> [b]
map (, Maybe Pipe
forall a. Maybe a
Nothing) [Host]
seedList)
    let rs :: ReplicaSet
rs = Database
-> MVar [(Host, Maybe Pipe)]
-> Secs
-> TransportSecurity
-> ReplicaSet
ReplicaSet Database
rsName MVar [(Host, Maybe Pipe)]
vMembers Secs
timeoutSecs TransportSecurity
transportSecurity
    ReplicaInfo
_ <- ReplicaSet -> IO ReplicaInfo
updateMembers ReplicaSet
rs
    ReplicaSet -> IO ReplicaSet
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ReplicaSet
rs

openReplicaSetSRV :: HostName -> IO ReplicaSet
-- ^ Open /non-secure/ connections (on demand) to servers in a replica set. The seedlist and replica set name is fetched from the SRV and TXT DNS records for the given hostname. 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 'openReplicaSetSRV''' instead.
openReplicaSetSRV :: [Char] -> IO ReplicaSet
openReplicaSetSRV [Char]
hostname = do
    Secs
timeoutSecs <- IORef Secs -> IO Secs
forall a. IORef a -> IO a
readIORef IORef Secs
globalConnectTimeout
    Secs -> TransportSecurity -> [Char] -> IO ReplicaSet
_openReplicaSetSRV Secs
timeoutSecs TransportSecurity
Unsecure [Char]
hostname

openReplicaSetSRV' :: HostName -> IO ReplicaSet
-- ^ Open /secure/ connections (on demand) to servers in a replica set. The seedlist and replica set name is fetched from the SRV and TXT DNS records for the given hostname. 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 'openReplicaSetSRV'''' instead.
--
-- The preferred connection method for cloud MongoDB providers. A typical connecting sequence is shown in the example below.
--
-- ==== __Example__
-- >   do
-- >   pipe <- openReplicatSetSRV' "cluster#.xxxxx.yyyyy.zzz"
-- >   is_auth <- access pipe master "admin" $ auth user_name password
-- >   unless is_auth (throwIO $ userError "Authentication failed!")
openReplicaSetSRV' :: [Char] -> IO ReplicaSet
openReplicaSetSRV' [Char]
hostname = do
    Secs
timeoutSecs <- IORef Secs -> IO Secs
forall a. IORef a -> IO a
readIORef IORef Secs
globalConnectTimeout
    Secs -> TransportSecurity -> [Char] -> IO ReplicaSet
_openReplicaSetSRV Secs
timeoutSecs TransportSecurity
Secure [Char]
hostname

openReplicaSetSRV'' :: Secs -> HostName -> IO ReplicaSet
-- ^ Open /non-secure/ connections (on demand) to servers in a replica set. The seedlist and replica set name is fetched from the SRV and TXT DNS records for the given hostname. Supplied seconds timeout is used for connect attempts to members.
openReplicaSetSRV'' :: Secs -> [Char] -> IO ReplicaSet
openReplicaSetSRV'' Secs
timeoutSecs = Secs -> TransportSecurity -> [Char] -> IO ReplicaSet
_openReplicaSetSRV Secs
timeoutSecs TransportSecurity
Unsecure

openReplicaSetSRV''' :: Secs -> HostName -> IO ReplicaSet
-- ^ Open /secure/ connections (on demand) to servers in a replica set. The seedlist and replica set name is fetched from the SRV and TXT DNS records for the given hostname. Supplied seconds timeout is used for connect attempts to members.
openReplicaSetSRV''' :: Secs -> [Char] -> IO ReplicaSet
openReplicaSetSRV''' Secs
timeoutSecs = Secs -> TransportSecurity -> [Char] -> IO ReplicaSet
_openReplicaSetSRV Secs
timeoutSecs TransportSecurity
Secure

_openReplicaSetSRV :: Secs -> TransportSecurity -> HostName -> IO ReplicaSet
_openReplicaSetSRV :: Secs -> TransportSecurity -> [Char] -> IO ReplicaSet
_openReplicaSetSRV Secs
timeoutSecs TransportSecurity
transportSecurity [Char]
hostname = do
    Maybe Database
replicaSetName <- [Char] -> IO (Maybe Database)
lookupReplicaSetName [Char]
hostname
    [Host]
hosts <- [Char] -> IO [Host]
lookupSeedList [Char]
hostname
    case (Maybe Database
replicaSetName, [Host]
hosts) of
        (Maybe Database
Nothing, [Host]
_) -> IOError -> IO ReplicaSet
forall a. IOError -> IO a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (IOError -> IO ReplicaSet) -> IOError -> IO ReplicaSet
forall a b. (a -> b) -> a -> b
$ [Char] -> IOError
userError [Char]
"Failed to lookup replica set name"
        (Maybe Database
_, [])  -> IOError -> IO ReplicaSet
forall a. IOError -> IO a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (IOError -> IO ReplicaSet) -> IOError -> IO ReplicaSet
forall a b. (a -> b) -> a -> b
$ [Char] -> IOError
userError [Char]
"Failed to lookup replica set seedlist"
        (Just Database
rsName, [Host]
_) ->
            case TransportSecurity
transportSecurity of
                TransportSecurity
Secure -> Secs -> (Database, [Host]) -> IO ReplicaSet
openReplicaSetTLS' Secs
timeoutSecs (Database
rsName, [Host]
hosts)
                TransportSecurity
Unsecure -> Secs -> (Database, [Host]) -> IO ReplicaSet
openReplicaSet' Secs
timeoutSecs (Database
rsName, [Host]
hosts)

closeReplicaSet :: ReplicaSet -> IO ()
-- ^ Close all connections to replica set
closeReplicaSet :: ReplicaSet -> IO ()
closeReplicaSet (ReplicaSet Database
_ MVar [(Host, Maybe Pipe)]
vMembers Secs
_ TransportSecurity
_) = MVar [(Host, Maybe Pipe)]
-> ([(Host, Maybe Pipe)] -> IO ()) -> IO ()
forall (m :: * -> *) a b.
MonadBaseControl IO m =>
MVar a -> (a -> m b) -> m b
withMVar MVar [(Host, Maybe Pipe)]
vMembers (([(Host, Maybe Pipe)] -> IO ()) -> IO ())
-> ([(Host, Maybe Pipe)] -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ ((Host, Maybe Pipe) -> IO ()) -> [(Host, Maybe Pipe)] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (IO () -> (Pipe -> IO ()) -> Maybe Pipe -> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()) Pipe -> IO ()
close (Maybe Pipe -> IO ())
-> ((Host, Maybe Pipe) -> Maybe Pipe)
-> (Host, Maybe Pipe)
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Host, Maybe Pipe) -> Maybe Pipe
forall a b. (a, b) -> b
snd)

primary :: ReplicaSet -> IO Pipe
-- ^ Return connection to current primary of replica set. Fail if no primary available.
primary :: ReplicaSet -> IO Pipe
primary rs :: ReplicaSet
rs@(ReplicaSet Database
rsName MVar [(Host, Maybe Pipe)]
_ Secs
_ TransportSecurity
_) = do
    Maybe Host
mHost <- ReplicaInfo -> Maybe Host
statedPrimary (ReplicaInfo -> Maybe Host) -> IO ReplicaInfo -> IO (Maybe Host)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReplicaSet -> IO ReplicaInfo
updateMembers ReplicaSet
rs
    case Maybe Host
mHost of
        Just Host
host' -> ReplicaSet -> Maybe Pipe -> Host -> IO Pipe
connection ReplicaSet
rs Maybe Pipe
forall a. Maybe a
Nothing Host
host'
        Maybe Host
Nothing -> IOError -> IO Pipe
forall a. IOError -> IO a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (IOError -> IO Pipe) -> IOError -> IO Pipe
forall a b. (a -> b) -> a -> b
$ [Char] -> IOError
userError ([Char] -> IOError) -> [Char] -> IOError
forall a b. (a -> b) -> a -> b
$ [Char]
"replica set " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Database -> [Char]
T.unpack Database
rsName [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" has no primary"

secondaryOk :: ReplicaSet -> IO Pipe
-- ^ Return connection to a random secondary, or primary if no secondaries available.
secondaryOk :: ReplicaSet -> IO Pipe
secondaryOk ReplicaSet
rs = do
    ReplicaInfo
info <- ReplicaSet -> IO ReplicaInfo
updateMembers ReplicaSet
rs
    [Host]
hosts <- [Host] -> IO [Host]
forall a. [a] -> IO [a]
shuffle (ReplicaInfo -> [Host]
possibleHosts ReplicaInfo
info)
    let hosts' :: [Host]
hosts' = [Host] -> (Host -> [Host]) -> Maybe Host -> [Host]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Host]
hosts (\Host
p -> Host -> [Host] -> [Host]
forall a. Eq a => a -> [a] -> [a]
delete Host
p [Host]
hosts [Host] -> [Host] -> [Host]
forall a. [a] -> [a] -> [a]
++ [Host
p]) (ReplicaInfo -> Maybe Host
statedPrimary ReplicaInfo
info)
    (Host -> IO Pipe) -> [Host] -> IO Pipe
forall e (m :: * -> *) a b.
MonadError e m =>
(a -> m b) -> [a] -> m b
untilSuccess (ReplicaSet -> Maybe Pipe -> Host -> IO Pipe
connection ReplicaSet
rs Maybe Pipe
forall a. Maybe a
Nothing) [Host]
hosts'

routedHost :: ((Host, Bool) -> (Host, Bool) -> IO Ordering) -> ReplicaSet -> IO Pipe
-- ^ Return a connection to a host using a user-supplied sorting function, which sorts based on a tuple containing the host and a boolean indicating whether the host is primary.
routedHost :: ((Host, Bool) -> (Host, Bool) -> IO Ordering)
-> ReplicaSet -> IO Pipe
routedHost (Host, Bool) -> (Host, Bool) -> IO Ordering
f ReplicaSet
rs = do
  ReplicaInfo
info <- ReplicaSet -> IO ReplicaInfo
updateMembers ReplicaSet
rs
  [Host]
hosts <- [Host] -> IO [Host]
forall a. [a] -> IO [a]
shuffle (ReplicaInfo -> [Host]
possibleHosts ReplicaInfo
info)
  let addIsPrimary :: Host -> (Host, Bool)
addIsPrimary Host
h = (Host
h, Host -> Maybe Host
forall a. a -> Maybe a
Just Host
h Maybe Host -> Maybe Host -> Bool
forall a. Eq a => a -> a -> Bool
== ReplicaInfo -> Maybe Host
statedPrimary ReplicaInfo
info)
  [Host]
hosts' <- (Host -> Host -> IO Ordering) -> [Host] -> IO [Host]
forall (m :: * -> *) a.
Monad m =>
(a -> a -> m Ordering) -> [a] -> m [a]
mergesortM (\Host
a Host
b -> (Host, Bool) -> (Host, Bool) -> IO Ordering
f (Host -> (Host, Bool)
addIsPrimary Host
a) (Host -> (Host, Bool)
addIsPrimary Host
b)) [Host]
hosts
  (Host -> IO Pipe) -> [Host] -> IO Pipe
forall e (m :: * -> *) a b.
MonadError e m =>
(a -> m b) -> [a] -> m b
untilSuccess (ReplicaSet -> Maybe Pipe -> Host -> IO Pipe
connection ReplicaSet
rs Maybe Pipe
forall a. Maybe a
Nothing) [Host]
hosts'

type ReplicaInfo = (Host, Document)
-- ^ Result of isMaster command on host in replica set. Returned fields are: setName, ismaster, secondary, hosts, [primary]. primary only present when ismaster = false

statedPrimary :: ReplicaInfo -> Maybe Host
-- ^ Primary of replica set or Nothing if there isn't one
statedPrimary :: ReplicaInfo -> Maybe Host
statedPrimary (Host
host', Document
info) = if (Database -> Document -> Bool
forall v. Val v => Database -> Document -> v
at Database
"ismaster" Document
info) then Host -> Maybe Host
forall a. a -> Maybe a
Just Host
host' else [Char] -> Host
readHostPort ([Char] -> Host) -> Maybe [Char] -> Maybe Host
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Database -> Document -> Maybe [Char]
forall v (m :: * -> *).
(Val v, MonadFail m) =>
Database -> Document -> m v
B.lookup Database
"primary" Document
info

possibleHosts :: ReplicaInfo -> [Host]
-- ^ Non-arbiter, non-hidden members of replica set
possibleHosts :: ReplicaInfo -> [Host]
possibleHosts (Host
_, Document
info) = ([Char] -> Host) -> [[Char]] -> [Host]
forall a b. (a -> b) -> [a] -> [b]
map [Char] -> Host
readHostPort ([[Char]] -> [Host]) -> [[Char]] -> [Host]
forall a b. (a -> b) -> a -> b
$ Database -> Document -> [[Char]]
forall v. Val v => Database -> Document -> v
at Database
"hosts" Document
info

updateMembers :: ReplicaSet -> IO ReplicaInfo
-- ^ Fetch replica info from any server and update members accordingly
updateMembers :: ReplicaSet -> IO ReplicaInfo
updateMembers rs :: ReplicaSet
rs@(ReplicaSet Database
_ MVar [(Host, Maybe Pipe)]
vMembers Secs
_ TransportSecurity
_) = do
    (Host
host', Document
info) <- ((Host, Maybe Pipe) -> IO ReplicaInfo)
-> [(Host, Maybe Pipe)] -> IO ReplicaInfo
forall e (m :: * -> *) a b.
MonadError e m =>
(a -> m b) -> [a] -> m b
untilSuccess (ReplicaSet -> (Host, Maybe Pipe) -> IO ReplicaInfo
fetchReplicaInfo ReplicaSet
rs) ([(Host, Maybe Pipe)] -> IO ReplicaInfo)
-> IO [(Host, Maybe Pipe)] -> IO ReplicaInfo
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< MVar [(Host, Maybe Pipe)] -> IO [(Host, Maybe Pipe)]
forall (m :: * -> *) a. MonadBase IO m => MVar a -> m a
readMVar MVar [(Host, Maybe Pipe)]
vMembers
    MVar [(Host, Maybe Pipe)]
-> ([(Host, Maybe Pipe)] -> IO ([(Host, Maybe Pipe)], ReplicaInfo))
-> IO ReplicaInfo
forall (m :: * -> *) a b.
MonadBaseControl IO m =>
MVar a -> (a -> m (a, b)) -> m b
modifyMVar MVar [(Host, Maybe Pipe)]
vMembers (([(Host, Maybe Pipe)] -> IO ([(Host, Maybe Pipe)], ReplicaInfo))
 -> IO ReplicaInfo)
-> ([(Host, Maybe Pipe)] -> IO ([(Host, Maybe Pipe)], ReplicaInfo))
-> IO ReplicaInfo
forall a b. (a -> b) -> a -> b
$ \[(Host, Maybe Pipe)]
members -> do
        let (([(Host, Maybe Pipe)]
members', [(Host, Maybe Pipe)]
old), [Host]
new) = [Host]
-> [(Host, Maybe Pipe)]
-> (([(Host, Maybe Pipe)], [(Host, Maybe Pipe)]), [Host])
forall k v. Eq k => [k] -> [(k, v)] -> (([(k, v)], [(k, v)]), [k])
intersection (([Char] -> Host) -> [[Char]] -> [Host]
forall a b. (a -> b) -> [a] -> [b]
map [Char] -> Host
readHostPort ([[Char]] -> [Host]) -> [[Char]] -> [Host]
forall a b. (a -> b) -> a -> b
$ Database -> Document -> [[Char]]
forall v. Val v => Database -> Document -> v
at Database
"hosts" Document
info) [(Host, Maybe Pipe)]
members
        [(Host, Maybe Pipe)] -> ((Host, Maybe Pipe) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(Host, Maybe Pipe)]
old (((Host, Maybe Pipe) -> IO ()) -> IO ())
-> ((Host, Maybe Pipe) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(Host
_, Maybe Pipe
mPipe) -> IO () -> (Pipe -> IO ()) -> Maybe Pipe -> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()) Pipe -> IO ()
close Maybe Pipe
mPipe
        ([(Host, Maybe Pipe)], ReplicaInfo)
-> IO ([(Host, Maybe Pipe)], ReplicaInfo)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Host, Maybe Pipe)]
members' [(Host, Maybe Pipe)]
-> [(Host, Maybe Pipe)] -> [(Host, Maybe Pipe)]
forall a. [a] -> [a] -> [a]
++ (Host -> (Host, Maybe Pipe)) -> [Host] -> [(Host, Maybe Pipe)]
forall a b. (a -> b) -> [a] -> [b]
map (, Maybe Pipe
forall a. Maybe a
Nothing) [Host]
new, (Host
host', Document
info))
 where
    intersection :: (Eq k) => [k] -> [(k, v)] -> (([(k, v)], [(k, v)]), [k])
    intersection :: forall k v. Eq k => [k] -> [(k, v)] -> (([(k, v)], [(k, v)]), [k])
intersection [k]
keys [(k, v)]
assocs = (((k, v) -> Bool) -> [(k, v)] -> ([(k, v)], [(k, v)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition ((k -> [k] -> Bool) -> [k] -> k -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip k -> [k] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem [k]
inKeys (k -> Bool) -> ((k, v) -> k) -> (k, v) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (k, v) -> k
forall a b. (a, b) -> a
fst) [(k, v)]
assocs, [k]
keys [k] -> [k] -> [k]
forall a. Eq a => [a] -> [a] -> [a]
\\ [k]
inKeys) where
        assocKeys :: [k]
assocKeys = ((k, v) -> k) -> [(k, v)] -> [k]
forall a b. (a -> b) -> [a] -> [b]
map (k, v) -> k
forall a b. (a, b) -> a
fst [(k, v)]
assocs
        inKeys :: [k]
inKeys = [k] -> [k] -> [k]
forall a. Eq a => [a] -> [a] -> [a]
intersect [k]
keys [k]
assocKeys

fetchReplicaInfo :: ReplicaSet -> (Host, Maybe Pipe) -> IO ReplicaInfo
-- Connect to host and fetch replica info from host creating new connection if missing or closed (previously failed). Fail if not member of named replica set.
fetchReplicaInfo :: ReplicaSet -> (Host, Maybe Pipe) -> IO ReplicaInfo
fetchReplicaInfo rs :: ReplicaSet
rs@(ReplicaSet Database
rsName MVar [(Host, Maybe Pipe)]
_ Secs
_ TransportSecurity
_) (Host
host', Maybe Pipe
mPipe) = do
    Pipe
pipe <- ReplicaSet -> Maybe Pipe -> Host -> IO Pipe
connection ReplicaSet
rs Maybe Pipe
mPipe Host
host'
    Document
info <- Document -> Pipe -> IO Document
adminCommand [Database
"isMaster" Database -> Int -> Field
forall v. Val v => Database -> v -> Field
=: (Int
1 :: Int)] Pipe
pipe
    case Database -> Document -> Maybe Database
forall v (m :: * -> *).
(Val v, MonadFail m) =>
Database -> Document -> m v
B.lookup Database
"setName" Document
info of
        Maybe Database
Nothing -> IOError -> IO ReplicaInfo
forall a. IOError -> IO a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (IOError -> IO ReplicaInfo) -> IOError -> IO ReplicaInfo
forall a b. (a -> b) -> a -> b
$ [Char] -> IOError
userError ([Char] -> IOError) -> [Char] -> IOError
forall a b. (a -> b) -> a -> b
$ Host -> [Char]
forall a. Show a => a -> [Char]
show Host
host' [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" not a member of any replica set, including " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Database -> [Char]
T.unpack Database
rsName [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
": " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Document -> [Char]
forall a. Show a => a -> [Char]
show Document
info
        Just Database
setName | Database
setName Database -> Database -> Bool
forall a. Eq a => a -> a -> Bool
/= Database
rsName -> IOError -> IO ReplicaInfo
forall a. IOError -> IO a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (IOError -> IO ReplicaInfo) -> IOError -> IO ReplicaInfo
forall a b. (a -> b) -> a -> b
$ [Char] -> IOError
userError ([Char] -> IOError) -> [Char] -> IOError
forall a b. (a -> b) -> a -> b
$ Host -> [Char]
forall a. Show a => a -> [Char]
show Host
host' [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" not a member of replica set " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Database -> [Char]
T.unpack Database
rsName [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
": " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Document -> [Char]
forall a. Show a => a -> [Char]
show Document
info
        Just Database
_ -> ReplicaInfo -> IO ReplicaInfo
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Host
host', Document
info)

connection :: ReplicaSet -> Maybe Pipe -> Host -> IO Pipe
-- ^ Return new or existing connection to member of replica set. If pipe is already known for host it is given, but we still test if it is open.
connection :: ReplicaSet -> Maybe Pipe -> Host -> IO Pipe
connection (ReplicaSet Database
_ MVar [(Host, Maybe Pipe)]
vMembers Secs
timeoutSecs TransportSecurity
transportSecurity) Maybe Pipe
mPipe Host
host' =
    IO Pipe -> (Pipe -> IO Pipe) -> Maybe Pipe -> IO Pipe
forall b a. b -> (a -> b) -> Maybe a -> b
maybe IO Pipe
conn (\Pipe
p -> Pipe -> IO Bool
isClosed Pipe
p IO Bool -> (Bool -> IO Pipe) -> IO Pipe
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Bool
bad -> if Bool
bad then IO Pipe
conn else Pipe -> IO Pipe
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Pipe
p) Maybe Pipe
mPipe
 where
    conn :: IO Pipe
conn =  MVar [(Host, Maybe Pipe)]
-> ([(Host, Maybe Pipe)] -> IO ([(Host, Maybe Pipe)], Pipe))
-> IO Pipe
forall (m :: * -> *) a b.
MonadBaseControl IO m =>
MVar a -> (a -> m (a, b)) -> m b
modifyMVar MVar [(Host, Maybe Pipe)]
vMembers (([(Host, Maybe Pipe)] -> IO ([(Host, Maybe Pipe)], Pipe))
 -> IO Pipe)
-> ([(Host, Maybe Pipe)] -> IO ([(Host, Maybe Pipe)], Pipe))
-> IO Pipe
forall a b. (a -> b) -> a -> b
$ \[(Host, Maybe Pipe)]
members -> do
        let (Host [Char]
h PortID
p) = Host
host'
        let conn' :: IO Pipe
conn' = case TransportSecurity
transportSecurity of
                        TransportSecurity
Secure   -> [Char] -> PortID -> IO Pipe
TLS.connect [Char]
h PortID
p
                        TransportSecurity
Unsecure -> Secs -> Host -> IO Pipe
connect' Secs
timeoutSecs Host
host'
        let new :: IO ([(Host, Maybe Pipe)], Pipe)
new = IO Pipe
conn' IO Pipe
-> (Pipe -> IO ([(Host, Maybe Pipe)], Pipe))
-> IO ([(Host, Maybe Pipe)], Pipe)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Pipe
pipe -> ([(Host, Maybe Pipe)], Pipe) -> IO ([(Host, Maybe Pipe)], Pipe)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Host -> Maybe Pipe -> [(Host, Maybe Pipe)] -> [(Host, Maybe Pipe)]
forall k v. Eq k => k -> v -> [(k, v)] -> [(k, v)]
updateAssocs Host
host' (Pipe -> Maybe Pipe
forall a. a -> Maybe a
Just Pipe
pipe) [(Host, Maybe Pipe)]
members, Pipe
pipe)
        case Host -> [(Host, Maybe Pipe)] -> Maybe (Maybe Pipe)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
List.lookup Host
host' [(Host, Maybe Pipe)]
members of
            Just (Just Pipe
pipe) -> Pipe -> IO Bool
isClosed Pipe
pipe IO Bool
-> (Bool -> IO ([(Host, Maybe Pipe)], Pipe))
-> IO ([(Host, Maybe Pipe)], Pipe)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Bool
bad -> if Bool
bad then IO ([(Host, Maybe Pipe)], Pipe)
new else ([(Host, Maybe Pipe)], Pipe) -> IO ([(Host, Maybe Pipe)], Pipe)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Host, Maybe Pipe)]
members, Pipe
pipe)
            Maybe (Maybe Pipe)
_ -> IO ([(Host, Maybe Pipe)], Pipe)
new


{- Authors: Tony Hannan <tony@10gen.com>
   Copyright 2011 10gen Inc.
   Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in compliance with the License. You may obtain a copy of the License at: http://www.apache.org/licenses/LICENSE-2.0. Unless required by applicable law or agreed to in writing, software distributed under the License is distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the License for the specific language governing permissions and limitations under the License. -}