diff --git a/Control/Monad/Context.hs b/Control/Monad/Context.hs deleted file mode 100644 index c8b4055..0000000 --- a/Control/Monad/Context.hs +++ /dev/null @@ -1,27 +0,0 @@ -{- | This is just like "Control.Monad.Reader.Class" except you can access the context of any Reader in the monad stack instead of just the top one as long as the context types are different. If two or more readers in the stack have the same context type you get the context of the top one. -} - -{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, OverlappingInstances #-} - -module Control.Monad.Context where - -import Control.Monad.Reader -import Control.Monad.Error - --- | Same as 'MonadReader' but without functional dependency so the same monad can have multiple contexts with different types -class (Monad m) => Context x m where - context :: m x - -- ^ Get the context in the Reader in the monad stack that has @x@ context type. Analogous to 'ask'. - push :: (x -> x) -> m a -> m a - -- ^ Push new context in the Reader in the monad stack that has @x@ context type. Analogous to 'local' - -instance (Monad m) => Context x (ReaderT x m) where - context = ask - push = local - -instance (Context x m) => Context x (ReaderT r m) where - context = lift context - push f m = ReaderT (push f . runReaderT m) - -instance (Context x m, Error e) => Context x (ErrorT e m) where - context = lift context - push f = ErrorT . push f . runErrorT diff --git a/Control/Monad/Throw.hs b/Control/Monad/Throw.hs deleted file mode 100644 index 6d6b85e..0000000 --- a/Control/Monad/Throw.hs +++ /dev/null @@ -1,50 +0,0 @@ -{- | This is just like "Control.Monad.Error.Class" except you can throw/catch the error of any ErrorT in the monad stack instead of just the top one as long as the error types are different. If two or more ErrorTs in the stack have the same error type you get the error of the top one. -} - -{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, OverlappingInstances, UndecidableInstances #-} - -module Control.Monad.Throw where - -import Prelude hiding (catch) -import Control.Monad.Reader -import Control.Monad.Error -import Control.Arrow ((+++)) -import Control.Applicative ((<$>)) - --- | Same as 'MonadError' but without functional dependency so the same monad can have multiple errors with different types -class (Monad m) => Throw e m where - throw :: e -> m a - -- ^ Abort action and throw give exception. Analogous to 'throwError'. - catch :: m a -> (e -> m a) -> m a - -- ^ If first action aborts with exception then execute second action. Analogous to 'catchError' - -throwLeft :: (Throw e m) => m (Either e a) -> m a --- ^ Execute action and throw exception if result is Left, otherwise return the Right result -throwLeft = throwLeft' id - -throwLeft' :: (Throw e m) => (x -> e) -> m (Either x a) -> m a --- ^ Execute action and throw transformed exception if result is Left, otherwise return Right result -throwLeft' f = (either (throw . f) return =<<) - -onException :: (Throw e m) => m a -> (e -> m b) -> m a --- ^ If first action throws an exception then run second action then re-throw -onException action releaser = catch action $ \e -> releaser e >> throw e - -instance (Error e) => Throw e (Either e) where - throw = throwError - catch = catchError - -instance (Error e, Monad m) => Throw e (ErrorT e m) where - throw = throwError - catch = catchError - -instance (Error e, Throw e m, Error x) => Throw e (ErrorT x m) where - throw = lift . throw - catch a h = ErrorT $ catch (runErrorT a) (runErrorT . h) - -instance (Throw e m) => Throw e (ReaderT x m) where - throw = lift . throw - catch a h = ReaderT $ \x -> catch (runReaderT a x) (flip runReaderT x . h) - -mapError :: (Functor m) => (e -> e') -> ErrorT e m a -> ErrorT e' m a --- ^ Convert error type -mapError f (ErrorT m) = ErrorT $ (f +++ id) <$> m diff --git a/Control/Monad/Util.hs b/Control/Monad/Util.hs deleted file mode 100644 index 5a49eec..0000000 --- a/Control/Monad/Util.hs +++ /dev/null @@ -1,39 +0,0 @@ --- | Extra monad functions and instances - -{-# LANGUAGE FlexibleInstances, UndecidableInstances #-} - -module Control.Monad.Util where - -import Control.Applicative (Applicative(..), (<$>)) -import Control.Arrow ((+++)) -import Control.Monad.Reader -import Control.Monad.Error - --- | MonadIO with extra Applicative and Functor superclasses -class (MonadIO m, Applicative m, Functor m) => MonadIO' m -instance (MonadIO m, Applicative m, Functor m) => MonadIO' m - -loop :: (Functor m, Monad m) => m (Maybe a) -> m [a] --- ^ Repeatedy execute action, collecting results, until it returns Nothing -loop act = act >>= maybe (return []) (\a -> (a :) <$> loop act) - -untilJust :: (Monad m) => (a -> m (Maybe b)) -> [a] -> m (Maybe b) --- ^ Apply action to elements one at a time until one returns Just. Return Nothing if all return Nothing. -untilJust _ [] = return Nothing -untilJust f (a:as) = f a >>= maybe (untilJust f as) (return . Just) - -untilSuccess :: (MonadError e m, Error e) => (a -> m b) -> [a] -> m b --- ^ Apply action to elements one at a time until one succeeds. Throw last error if all fail. Throw 'strMsg' error if list is empty. -untilSuccess = untilSuccess' (strMsg "empty untilSuccess") - -untilSuccess' :: (MonadError e m) => e -> (a -> m b) -> [a] -> m b --- ^ Apply action to elements one at a time until one succeeds. Throw last error if all fail. Throw given error if list is empty -untilSuccess' e _ [] = throwError e -untilSuccess' _ f (x : xs) = catchError (f x) (\e -> untilSuccess' e f xs) - -mapError :: (Functor m) => (e' -> e) -> ErrorT e' m a -> ErrorT e m a --- ^ Convert error type thrown -mapError f (ErrorT m) = ErrorT $ (f +++ id) <$> m - -whenJust :: (Monad m) => Maybe a -> (a -> m ()) -> m () -whenJust mVal act = maybe (return ()) act mVal diff --git a/Database/MongoDB.hs b/Database/MongoDB.hs index 9801d3d..8d0a0e4 100644 --- a/Database/MongoDB.hs +++ b/Database/MongoDB.hs @@ -6,15 +6,15 @@ Simple example below. Use with language extension /OvererloadedStrings/. > {-# LANGUAGE OverloadedStrings #-} > > import Database.MongoDB -> import Data.CompactString () -- Show and IsString instances of UString > import Control.Monad.Trans (liftIO) > > main = do -> pool <- newConnPool 1 (host "127.0.0.1") -> e <- access safe Master pool run +> pipe <- runIOE $ connect (host "127.0.0.1") +> e <- access pipe safe Master "baseball" run +> close pipe > print e > -> run = use (Database "baseball") $ do +> run = do > clearTeams > insertTeams > printDocs "All Teams" =<< allTeams diff --git a/Database/MongoDB/Admin.hs b/Database/MongoDB/Admin.hs index 8caa031..d4f74da 100644 --- a/Database/MongoDB/Admin.hs +++ b/Database/MongoDB/Admin.hs @@ -38,7 +38,8 @@ import Data.IORef import qualified Data.Set as S import System.IO.Unsafe (unsafePerformIO) import Control.Concurrent (forkIO, threadDelay) -import Database.MongoDB.Internal.Util ((<.>), true1) +import Database.MongoDB.Internal.Util (MonadIO', (<.>), true1) +import Control.Monad.MVar (MonadMVar) -- * Admin @@ -51,17 +52,17 @@ coptElem Capped = "capped" =: True coptElem (MaxByteSize n) = "size" =: n coptElem (MaxItems n) = "max" =: n -createCollection :: (DbAccess m) => [CollectionOption] -> Collection -> m Document +createCollection :: (MonadIO' m) => [CollectionOption] -> Collection -> Action m Document -- ^ Create collection with given options. You only need to call this to set options, otherwise a collection is created automatically on first use with no options. createCollection opts col = runCommand $ ["create" =: col] ++ map coptElem opts -renameCollection :: (DbAccess m) => Collection -> Collection -> m Document +renameCollection :: (MonadIO' m) => Collection -> Collection -> Action m Document -- ^ Rename first collection to second collection renameCollection from to = do - Database db <- thisDatabase - use admin $ runCommand ["renameCollection" =: db <.> from, "to" =: db <.> to, "dropTarget" =: True] + db <- thisDatabase + useDb admin $ runCommand ["renameCollection" =: db <.> from, "to" =: db <.> to, "dropTarget" =: True] -dropCollection :: (DbAccess m) => Collection -> m Bool +dropCollection :: (MonadIO' m) => Collection -> Action m Bool -- ^ Delete the given collection! Return True if collection existed (and was deleted); return False if collection did not exist (and no action). dropCollection coll = do resetIndexCache @@ -70,7 +71,7 @@ dropCollection coll = do if at "errmsg" r == ("ns not found" :: UString) then return False else fail $ "dropCollection failed: " ++ show r -validateCollection :: (DbAccess m) => Collection -> m Document +validateCollection :: (MonadIO' m) => Collection -> Action m Document -- ^ This operation takes a while validateCollection coll = runCommand ["validate" =: coll] @@ -87,7 +88,7 @@ data Index = Index { } deriving (Show, Eq) idxDocument :: Index -> Database -> Document -idxDocument Index{..} (Database db) = [ +idxDocument Index{..} db = [ "ns" =: db <.> iColl, "key" =: iKey, "name" =: iName, @@ -102,7 +103,7 @@ genName :: Order -> IndexName genName keys = intercalate "_" (map f keys) where f (k := v) = k `append` "_" `append` pack (show v) -ensureIndex :: (DbAccess m) => Index -> m () +ensureIndex :: (MonadIO' m) => Index -> Action m () -- ^ Create index if we did not already create one. May be called repeatedly with practically no performance hit, because we remember if we already called this for the same index (although this memory gets wiped out every 15 minutes, in case another client drops the index and we want to create it again). ensureIndex idx = let k = (iColl idx, iName idx) in do icache <- fetchIndexCache @@ -111,23 +112,23 @@ ensureIndex idx = let k = (iColl idx, iName idx) in do writeMode (Safe []) (createIndex idx) liftIO $ writeIORef icache (S.insert k set) -createIndex :: (DbAccess m) => Index -> m () +createIndex :: (MonadIO' m) => Index -> Action m () -- ^ Create index on the server. This call goes to the server every time. createIndex idx = insert_ "system.indexes" . idxDocument idx =<< thisDatabase -dropIndex :: (DbAccess m) => Collection -> IndexName -> m Document +dropIndex :: (MonadIO' m) => Collection -> IndexName -> Action m Document -- ^ Remove the index dropIndex coll idxName = do resetIndexCache runCommand ["deleteIndexes" =: coll, "index" =: idxName] -getIndexes :: (DbAccess m) => Collection -> m [Document] +getIndexes :: (MonadMVar m, Functor m) => Collection -> Action m [Document] -- ^ Get all indexes on this collection getIndexes coll = do - Database db <- thisDatabase + db <- thisDatabase rest =<< find (select ["ns" =: db <.> coll] "system.indexes") -dropIndexes :: (DbAccess m) => Collection -> m Document +dropIndexes :: (MonadIO' m) => Collection -> Action m Document -- ^ Drop all indexes on this collection dropIndexes coll = do resetIndexCache @@ -143,7 +144,7 @@ type IndexCache = IORef (S.Set (Collection, IndexName)) dbIndexCache :: DbIndexCache -- ^ initialize cache and fork thread that clears it every 15 minutes dbIndexCache = unsafePerformIO $ do - table <- T.new (==) (T.hashString . unpack . databaseName) + table <- T.new (==) (T.hashString . unpack) _ <- forkIO . forever $ threadDelay 900000000 >> clearDbIndexCache return table {-# NOINLINE dbIndexCache #-} @@ -153,7 +154,7 @@ clearDbIndexCache = do keys <- map fst <$> T.toList dbIndexCache mapM_ (T.delete dbIndexCache) keys -fetchIndexCache :: (DbAccess m) => m IndexCache +fetchIndexCache :: (MonadIO m) => Action m IndexCache -- ^ Get index cache for current database fetchIndexCache = do db <- thisDatabase @@ -166,7 +167,7 @@ fetchIndexCache = do T.insert dbIndexCache db idx return idx -resetIndexCache :: (DbAccess m) => m () +resetIndexCache :: (MonadIO m) => Action m () -- ^ reset index cache for current database resetIndexCache = do icache <- fetchIndexCache @@ -174,74 +175,74 @@ resetIndexCache = do -- ** User -allUsers :: (DbAccess m) => m [Document] +allUsers :: (MonadMVar m, Functor m) => Action m [Document] -- ^ Fetch all users of this database allUsers = map (exclude ["_id"]) <$> (rest =<< find (select [] "system.users") {sort = ["user" =: (1 :: Int)], project = ["user" =: (1 :: Int), "readOnly" =: (1 :: Int)]}) -addUser :: (DbAccess m) => Bool -> Username -> Password -> m () +addUser :: (MonadIO' m) => Bool -> Username -> Password -> Action m () -- ^ Add user with password with read-only access if bool is True or read-write access if bool is False addUser readOnly user pass = do mu <- findOne (select ["user" =: user] "system.users") let usr = merge ["readOnly" =: readOnly, "pwd" =: pwHash user pass] (maybe ["user" =: user] id mu) save "system.users" usr -removeUser :: (DbAccess m) => Username -> m () +removeUser :: (MonadIO m) => Username -> Action m () removeUser user = delete (select ["user" =: user] "system.users") -- ** Database admin :: Database -- ^ \"admin\" database -admin = Database "admin" +admin = "admin" -cloneDatabase :: (Access m) => Database -> Host -> m Document +cloneDatabase :: (MonadIO' m) => Database -> Host -> Action m Document -- ^ Copy database from given host to the server I am connected to. Fails and returns @"ok" = 0@ if we don't have permission to read from given server (use copyDatabase in this case). -cloneDatabase db fromHost = use db $ runCommand ["clone" =: showHostPort fromHost] +cloneDatabase db fromHost = useDb db $ runCommand ["clone" =: showHostPort fromHost] -copyDatabase :: (Access m) => Database -> Host -> Maybe (Username, Password) -> Database -> m Document +copyDatabase :: (MonadIO' m) => Database -> Host -> Maybe (Username, Password) -> Database -> Action m Document -- ^ Copy database from given host to the server I am connected to. If username & password is supplied use them to read from given host. -copyDatabase (Database fromDb) fromHost mup (Database toDb) = do +copyDatabase fromDb fromHost mup toDb = do let c = ["copydb" =: (1 :: Int), "fromhost" =: showHostPort fromHost, "fromdb" =: fromDb, "todb" =: toDb] - use admin $ case mup of + useDb admin $ case mup of Nothing -> runCommand c Just (usr, pss) -> do n <- at "nonce" <$> runCommand ["copydbgetnonce" =: (1 :: Int), "fromhost" =: showHostPort fromHost] runCommand $ c ++ ["username" =: usr, "nonce" =: n, "key" =: pwKey n usr pss] -dropDatabase :: (Access m) => Database -> m Document +dropDatabase :: (MonadIO' m) => Database -> Action m Document -- ^ Delete the given database! -dropDatabase db = use db $ runCommand ["dropDatabase" =: (1 :: Int)] +dropDatabase db = useDb db $ runCommand ["dropDatabase" =: (1 :: Int)] -repairDatabase :: (Access m) => Database -> m Document +repairDatabase :: (MonadIO' m) => Database -> Action m Document -- ^ Attempt to fix any corrupt records. This operation takes a while. -repairDatabase db = use db $ runCommand ["repairDatabase" =: (1 :: Int)] +repairDatabase db = useDb db $ runCommand ["repairDatabase" =: (1 :: Int)] -- ** Server -serverBuildInfo :: (Access m) => m Document -serverBuildInfo = use admin $ runCommand ["buildinfo" =: (1 :: Int)] +serverBuildInfo :: (MonadIO' m) => Action m Document +serverBuildInfo = useDb admin $ runCommand ["buildinfo" =: (1 :: Int)] -serverVersion :: (Access m) => m UString +serverVersion :: (MonadIO' m) => Action m UString serverVersion = at "version" <$> serverBuildInfo -- * Diagnostics -- ** Collection -collectionStats :: (DbAccess m) => Collection -> m Document +collectionStats :: (MonadIO' m) => Collection -> Action m Document collectionStats coll = runCommand ["collstats" =: coll] -dataSize :: (DbAccess m) => Collection -> m Int +dataSize :: (MonadIO' m) => Collection -> Action m Int dataSize c = at "size" <$> collectionStats c -storageSize :: (DbAccess m) => Collection -> m Int +storageSize :: (MonadIO' m) => Collection -> Action m Int storageSize c = at "storageSize" <$> collectionStats c -totalIndexSize :: (DbAccess m) => Collection -> m Int +totalIndexSize :: (MonadIO' m) => Collection -> Action m Int totalIndexSize c = at "totalIndexSize" <$> collectionStats c -totalSize :: (DbAccess m) => Collection -> m Int +totalSize :: (MonadMVar m, MonadIO' m) => Collection -> Action m Int totalSize coll = do x <- storageSize coll xs <- mapM isize =<< getIndexes coll @@ -253,35 +254,35 @@ totalSize coll = do data ProfilingLevel = Off | Slow | All deriving (Show, Enum, Eq) -getProfilingLevel :: (DbAccess m) => m ProfilingLevel +getProfilingLevel :: (MonadIO' m) => Action m ProfilingLevel getProfilingLevel = toEnum . at "was" <$> runCommand ["profile" =: (-1 :: Int)] type MilliSec = Int -setProfilingLevel :: (DbAccess m) => ProfilingLevel -> Maybe MilliSec -> m () +setProfilingLevel :: (MonadIO' m) => ProfilingLevel -> Maybe MilliSec -> Action m () setProfilingLevel p mSlowMs = runCommand (["profile" =: fromEnum p] ++ ("slowms" =? mSlowMs)) >> return () -- ** Database -dbStats :: (DbAccess m) => m Document +dbStats :: (MonadIO' m) => Action m Document dbStats = runCommand ["dbstats" =: (1 :: Int)] -currentOp :: (DbAccess m) => m (Maybe Document) +currentOp :: (MonadIO m) => Action m (Maybe Document) -- ^ See currently running operation on the database, if any currentOp = findOne (select [] "$cmd.sys.inprog") type OpNum = Int -killOp :: (DbAccess m) => OpNum -> m (Maybe Document) +killOp :: (MonadIO m) => OpNum -> Action m (Maybe Document) killOp op = findOne (select ["op" =: op] "$cmd.sys.killop") -- ** Server -serverStatus :: (Access m) => m Document -serverStatus = use admin $ runCommand ["serverStatus" =: (1 :: Int)] +serverStatus :: (MonadIO' m) => Action m Document +serverStatus = useDb admin $ runCommand ["serverStatus" =: (1 :: Int)] {- Authors: Tony Hannan - Copyright 2010 10gen Inc. + 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. -} diff --git a/Database/MongoDB/Connection.hs b/Database/MongoDB/Connection.hs index 6631f36..becf41c 100644 --- a/Database/MongoDB/Connection.hs +++ b/Database/MongoDB/Connection.hs @@ -1,61 +1,42 @@ -{- | A pool of TCP connections to a single server or a replica set of servers. -} +-- | Connect to a single server or a replica set of servers -{-# LANGUAGE CPP, OverloadedStrings, ScopedTypeVariables, RecordWildCards, NamedFieldPuns, MultiParamTypeClasses, FlexibleContexts, TypeFamilies, DoRec, RankNTypes, FlexibleInstances #-} +{-# LANGUAGE CPP, OverloadedStrings, ScopedTypeVariables, TupleSections #-} module Database.MongoDB.Connection ( - -- * Pipe - Pipe, + IOE, runIOE, + -- * Connection + Pipe, close, isClosed, -- * Host - Host(..), PortID(..), host, showHostPort, readHostPort, readHostPortM, - -- * ReplicaSet - ReplicaSet(..), Name, - -- * MasterOrSlaveOk - MasterOrSlaveOk(..), - -- * Connection Pool - Service(..), - connHost, replicaSet + Host(..), PortID(..), host, showHostPort, readHostPort, readHostPortM, connect, + -- * Replica Set + ReplicaSetName, openReplicaSet, ReplicaSet, primary, secondaryOk ) where import Prelude hiding (lookup) -import Database.MongoDB.Internal.Protocol as X -import qualified Network.Abstract as C -import Network.Abstract (IOE, NetworkIO, ANetwork) -import Data.Bson ((=:), at, lookup, UString) -import Control.Pipeline as P -import Control.Applicative ((<$>)) -import Control.Exception (assert) -import Control.Monad.Error -import Control.Monad.MVar -import Network (HostName, PortID(..)) -import Data.Bson (Document, look) +import Database.MongoDB.Internal.Protocol (Pipe, writeMessage, readMessage) +import System.IO.Pipeline (IOE, IOStream(..), newPipeline, close, isClosed) +import System.IO.Error as E (try) +import System.IO (hClose) +import Network (HostName, PortID(..), connectTo) import Text.ParserCombinators.Parsec as T (parse, many1, letter, digit, char, eof, spaces, try, (<|>)) -import Control.Monad.Identity -import Control.Monad.Util (MonadIO', untilSuccess) -import Database.MongoDB.Internal.Util () -- PortID instances -import Var.Pool -import System.Random (newStdGen, randomRs) -import Data.List (delete, find, nub) -import System.IO.Unsafe (unsafePerformIO) +import Control.Monad.Identity (runIdentity) +import Control.Monad.Error (ErrorT(..), lift, throwError) +import Control.Monad.MVar +import Control.Monad (forM_) +import Control.Applicative ((<$>)) +import Data.UString (UString, unpack) +import Data.Bson as D (Document, lookup, at, (=:)) +import Database.MongoDB.Query (access, safe, MasterOrSlaveOk(SlaveOk), Failure(ConnectionFailure), Command, runCommand) +import Database.MongoDB.Internal.Util (untilSuccess, liftIOE, runIOE, updateAssocs, shuffle) +import Data.List as L (lookup, intersect, partition, (\\)) -type Name = UString - -adminCommand :: Document -> Request --- ^ Convert command to request -adminCommand cmd = Query{..} where - qOptions = [SlaveOK] - qFullCollection = "admin.$cmd" - qSkip = 0 - qBatchSize = -1 - qSelector = cmd - qProjector = [] - -commandReply :: String -> Reply -> Document --- ^ Extract first document from reply. Error if query error, using given string as prefix error message. -commandReply title Reply{..} = if elem QueryError rResponseFlags - then error $ title ++ ": " ++ at "$err" (head rDocuments) - else if null rDocuments - then error ("empty reply to: " ++ title) - else head rDocuments +adminCommand :: Command -> Pipe -> IOE Document +-- ^ Run command against admin database on server connected to pipe. Fail if connection fails. +adminCommand cmd pipe = + liftIOE failureToIOError . ErrorT $ access pipe safe SlaveOk "admin" $ runCommand cmd + where + failureToIOError (ConnectionFailure e) = e + failureToIOError e = userError $ show e -- * Host @@ -97,152 +78,86 @@ readHostPort :: String -> Host -- ^ Read string \"hostname:port\" as @Host hostname port@ or \"hostname\" as @host hostname@ (default port). Error if string does not match either syntax. readHostPort = runIdentity . readHostPortM +connect :: Host -> IOE Pipe +-- ^ Connect to Host returning pipelined TCP connection. Throw IOError if problem connecting. +connect (Host hostname port) = do + handle <- ErrorT . E.try $ connectTo hostname port + lift $ newPipeline $ IOStream (writeMessage handle) (readMessage handle) (hClose handle) + -- * Replica Set -data ReplicaSet = ReplicaSet {setName :: Name, seedHosts :: [Host]} deriving (Show) --- ^ Replica set of hosts identified by set name. At least one of the seed hosts must be an active member of the set. However, this list is not used to identify the set, just the set name. +type ReplicaSetName = UString -instance Eq ReplicaSet where ReplicaSet x _ == ReplicaSet y _ = x == y +-- | Maintains a connection (created on demand) to each server in the named replica set +data ReplicaSet = ReplicaSet ReplicaSetName (MVar [(Host, Maybe Pipe)]) --- ** Replica Info +openReplicaSet :: (ReplicaSetName, [Host]) -> IOE 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. +openReplicaSet (rsName, seedList) = do + rs <- ReplicaSet rsName <$> newMVar (map (, Nothing) seedList) + _ <- updateMembers rs + return rs -getReplicaInfo :: ConnPool Host -> IOE ReplicaInfo --- ^ Get replica info of the connected host. Throw IOError if connection fails or host is not part of a replica set (no /hosts/ and /primary/ field). -getReplicaInfo conn = do - pipe <- getHostPipe conn - promise <- X.call pipe [] (adminCommand ["ismaster" =: (1 :: Int)]) - info <- commandReply "ismaster" <$> promise - _ <- look "hosts" info - _ <- look "ismaster" info - return $ ReplicaInfo (connHost conn) info +primary :: ReplicaSet -> IOE Pipe +-- ^ Return connection to current primary of replica set +primary rs@(ReplicaSet rsName _) = do + mHost <- statedPrimary <$> updateMembers rs + case mHost of + Just host' -> connection rs Nothing host' + Nothing -> throwError $ userError $ "replica set " ++ unpack rsName ++ " has no primary" -data ReplicaInfo = ReplicaInfo {_infoHost :: Host, infoDoc :: Document} deriving (Show) --- ^ Configuration info of a host in a replica set (result of /ismaster/ command). Contains all the hosts in the replica set plus its role in that set (master, slave, or arbiter) +secondaryOk :: ReplicaSet -> IOE Pipe +-- ^ Return connection to a random member (secondary or primary) +secondaryOk rs = do + info <- updateMembers rs + hosts <- lift $ shuffle (possibleHosts info) + untilSuccess (connection rs Nothing) hosts -{- isPrimary :: ReplicaInfo -> Bool --- ^ Is the replica described by this info a master/primary (not slave or arbiter)? -isPrimary = true1 "ismaster" +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 -isSecondary :: ReplicaInfo -> Bool --- ^ Is the replica described by this info a slave/secondary (not master or arbiter) -isSecondary = true1 "secondary" -} +statedPrimary :: ReplicaInfo -> Maybe Host +-- ^ Primary of replica set or Nothing if there isn't one +statedPrimary (host', info) = if (at "ismaster" info) then Just host' else readHostPort <$> D.lookup "primary" info -primary :: ReplicaInfo -> Maybe Host --- ^ Read primary from configuration info. During failover or minor network partition there is no primary (Nothing). -primary (ReplicaInfo host' info) = if at "ismaster" info then Just host' else readHostPort <$> lookup "primary" info +possibleHosts :: ReplicaInfo -> [Host] +-- ^ Non-arbiter, non-hidden members of replica set +possibleHosts (_, info) = map readHostPort $ at "hosts" info -replicas :: ReplicaInfo -> [Host] --- ^ All replicas in set according to this replica configuration info with primary at head, if there is one. -replicas info = maybe members (\m -> m : delete m members) master where - members = map readHostPort $ at "hosts" (infoDoc info) - master = primary info - --- * MasterOrSlaveOk - -data MasterOrSlaveOk = - Master -- ^ connect to master only - | SlaveOk -- ^ connect to a slave, or master if no slave available - deriving (Show, Eq) - -{- isMS :: MasterOrSlaveOk -> ReplicaInfo -> Bool --- ^ Does the host (as described by its replica-info) match the master/slave type -isMS Master i = isPrimary i -isMS SlaveOk i = isSecondary i || isPrimary i -} - --- * Connection Pool - -type Pool' = Pool IOError - --- | A Service is a single server ('Host') or a replica set of servers ('ReplicaSet') -class Service t where - data ConnPool t - -- ^ A pool of TCP connections ('Pipe's) to a host or a replica set of hosts - newConnPool :: (NetworkIO m) => Int -> t -> m (ConnPool t) - -- ^ Create a ConnectionPool to a host or a replica set of hosts. Actual TCP connection is not attempted until 'getPipe' request, so no IOError can be raised here. Up to N TCP connections will be established to each host. - getPipe :: MasterOrSlaveOk -> ConnPool t -> IOE Pipe - -- ^ Return a TCP connection (Pipe) to the master or a slave in the server. Master must connect to the master, SlaveOk may connect to a slave or master. To spread the load, SlaveOk requests are distributed amongst all hosts in the server. Throw IOError if failed to connect to right type of host (Master/SlaveOk). - killPipes :: ConnPool t -> IO () - -- ^ Kill all open pipes (TCP Connections). Will cause any users of them to fail. Alternatively you can let them die on their own when they get garbage collected. - --- ** ConnectionPool Host - -instance Service Host where - data ConnPool Host = HostConnPool {connHost :: Host, connPool :: Pool' Pipe} - -- ^ A pool of TCP connections ('Pipe's) to a server, handed out in round-robin style. - newConnPool poolSize' host' = liftIO . newHostConnPool poolSize' host' =<< C.network - -- ^ Create a connection pool to server (host or replica set) - getPipe _ = getHostPipe - -- ^ Return a TCP connection (Pipe). If SlaveOk, connect to a slave if available. Round-robin if multiple slaves are available. Throw IOError if failed to connect. - killPipes (HostConnPool _ pool) = killAll pool - -instance Show (ConnPool Host) where - show HostConnPool{connHost} = "ConnPool " ++ show connHost - -newHostConnPool :: Int -> Host -> ANetwork -> IO (ConnPool Host) --- ^ Create a pool of N 'Pipe's (TCP connections) to server. 'getHostPipe' will return one of those pipes, round-robin style. -newHostConnPool poolSize' host' net = HostConnPool host' <$> newPool Factory{..} poolSize' where - newResource = tcpConnect net host' - killResource = P.close - isExpired = P.isClosed - -getHostPipe :: ConnPool Host -> IOE Pipe --- ^ Return next pipe (TCP connection) in connection pool, round-robin style. Throw IOError if can't connect to host. -getHostPipe (HostConnPool _ pool) = aResource pool - -tcpConnect :: ANetwork -> Host -> IOE Pipe --- ^ Create a TCP connection (Pipe) to the given host. Throw IOError if can't connect. -tcpConnect net (Host hostname port) = newPipeline =<< C.connect net (C.Server hostname port) - --- ** Connection ReplicaSet - -instance Service ReplicaSet where - data ConnPool ReplicaSet = ReplicaSetConnPool { - network :: ANetwork, - repsetName :: Name, - currentMembers :: MVar [ConnPool Host] } -- master at head after a refresh - newConnPool poolSize' repset = liftIO . newSetConnPool poolSize' repset =<< C.network - getPipe = getSetPipe - killPipes ReplicaSetConnPool{..} = withMVar currentMembers (mapM_ killPipes) - -instance Show (ConnPool ReplicaSet) where - show r = "ConnPool " ++ show (unsafePerformIO $ replicaSet r) - -replicaSet :: (MonadIO' m) => ConnPool ReplicaSet -> m ReplicaSet --- ^ Return replicas set name with current members as seed list -replicaSet ReplicaSetConnPool{..} = ReplicaSet repsetName . map connHost <$> readMVar currentMembers - -newSetConnPool :: Int -> ReplicaSet -> ANetwork -> IO (ConnPool ReplicaSet) --- ^ Create a connection pool to each member of the replica set. -newSetConnPool poolSize' repset net = assert (not . null $ seedHosts repset) $ do - currentMembers <- newMVar =<< mapM (\h -> newHostConnPool poolSize' h net) (seedHosts repset) - return $ ReplicaSetConnPool net (setName repset) currentMembers - -getMembers :: Name -> [ConnPool Host] -> IOE [Host] --- ^ Get members of replica set, master first. Query supplied connections until config found. --- TODO: Verify config for request replica set name and not some other replica set. "ismaster" reply includes "setName" in result. -getMembers _repsetName connections = replicas <$> untilSuccess getReplicaInfo connections - -refreshMembers :: ANetwork -> Name -> [ConnPool Host] -> IOE [ConnPool Host] --- ^ Update current members with master at head. Reuse unchanged members. Throw IOError if can't connect to any and fetch config. Dropped connections are not closed in case they still have users; they will be closed when garbage collected. -refreshMembers net repsetName connections = do - n <- liftIO . poolSize . connPool $ head connections - mapM (liftIO . connection n) =<< getMembers repsetName connections +updateMembers :: ReplicaSet -> IOE ReplicaInfo +-- ^ Fetch replica info from any server and update members accordingly +updateMembers rs@(ReplicaSet _ vMembers) = do + (host', info) <- untilSuccess (fetchReplicaInfo rs) =<< readMVar vMembers + modifyMVar vMembers $ \members -> do + let ((members', old), new) = intersection (map readHostPort $ at "hosts" info) members + lift $ forM_ old $ \(_, mPipe) -> maybe (return ()) close mPipe + return (members' ++ map (, Nothing) new, (host', info)) where - connection n host' = maybe (newHostConnPool n host' net) return mc where - mc = find ((host' ==) . connHost) connections - + intersection :: (Eq k) => [k] -> [(k, v)] -> (([(k, v)], [(k, v)]), [k]) + intersection keys assocs = (partition (flip elem inKeys . fst) assocs, keys \\ inKeys) where + assocKeys = map fst assocs + inKeys = intersect keys assocKeys -getSetPipe :: MasterOrSlaveOk -> ConnPool ReplicaSet -> IOE Pipe --- ^ Return a pipe to primary or a random secondary in replica set. Use primary for SlaveOk if and only if no secondaries. Note, refreshes members each time (makes ismaster call to primary). -getSetPipe mos ReplicaSetConnPool{..} = modifyMVar currentMembers $ \conns -> do - connections <- refreshMembers network repsetName conns -- master at head after refresh - pipe <- case mos of - Master -> getHostPipe (head connections) - SlaveOk -> do - let n = length connections - 1 - is <- take (max 1 n) . nub . randomRs (min 1 n, n) <$> liftIO newStdGen - untilSuccess (getHostPipe . (connections !!)) is - return (connections, pipe) +fetchReplicaInfo :: ReplicaSet -> (Host, Maybe Pipe) -> IOE 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 rs@(ReplicaSet rsName _) (host', mPipe) = do + pipe <- connection rs mPipe host' + info <- adminCommand ["isMaster" =: (1 :: Int)] pipe + case D.lookup "setName" info of + Nothing -> throwError $ userError $ show host' ++ " not a member of any replica set, including " ++ unpack rsName ++ ": " ++ show info + Just setName | setName /= rsName -> throwError $ userError $ show host' ++ " not a member of replica set " ++ unpack rsName ++ ": " ++ show info + Just _ -> return (host', info) + +connection :: ReplicaSet -> Maybe Pipe -> Host -> IOE 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 _ vMembers) mPipe host' = + maybe conn (\p -> lift (isClosed p) >>= \bad -> if bad then conn else return p) mPipe + where + conn = modifyMVar vMembers $ \members -> do + let new = connect host' >>= \pipe -> return (updateAssocs host' (Just pipe) members, pipe) + case L.lookup host' members of + Just (Just pipe) -> lift (isClosed pipe) >>= \bad -> if bad then new else return (members, pipe) + _ -> new {- Authors: Tony Hannan diff --git a/Database/MongoDB/Internal/Protocol.hs b/Database/MongoDB/Internal/Protocol.hs index 4ebfbd6..fdbbbae 100644 --- a/Database/MongoDB/Internal/Protocol.hs +++ b/Database/MongoDB/Internal/Protocol.hs @@ -5,10 +5,12 @@ This module is not intended for direct use. Use the high-level interface at "Dat {-# LANGUAGE RecordWildCards, StandaloneDeriving, OverloadedStrings, FlexibleContexts, TupleSections, TypeSynonymInstances, MultiParamTypeClasses, FlexibleInstances, UndecidableInstances #-} module Database.MongoDB.Internal.Protocol ( + MasterOrSlaveOk(..), + FullCollection, -- * Pipe Pipe, send, call, -- * Message - FullCollection, + writeMessage, readMessage, -- ** Notice Notice(..), UpdateOption(..), DeleteOption(..), CursorId, -- ** Request @@ -23,7 +25,9 @@ import Prelude as X import Control.Applicative ((<$>)) import Control.Arrow ((***)) import Data.ByteString.Lazy as B (length, hPut) -import qualified Control.Pipeline as P +import System.IO.Pipeline (IOE, Pipeline) +import qualified System.IO.Pipeline as P (send, call) +import System.IO (Handle) import Data.Bson (Document, UString) import Data.Bson.Binary import Data.Binary.Put @@ -34,22 +38,21 @@ import Data.IORef import System.IO.Unsafe (unsafePerformIO) import qualified Crypto.Hash.MD5 as MD5 (hash) import Data.UString as U (pack, append, toByteString) -import qualified Data.ByteString as BS (ByteString, unpack) -import Data.Word (Word8) import System.IO.Error as E (try) import Control.Monad.Error -import Control.Monad.Util (whenJust) -import Network.Abstract hiding (send) import System.IO (hFlush) -import Database.MongoDB.Internal.Util (hGetN, bitOr) -import Numeric (showHex) +import Database.MongoDB.Internal.Util (whenJust, hGetN, bitOr, byteStringHex) --- Network -> Server -> (Sink, Source) --- (Sink, Source) -> Pipeline +-- * MasterOrSlaveOk + +data MasterOrSlaveOk = + Master -- ^ connect to master only + | SlaveOk -- ^ connect to a slave, or master if no slave available + deriving (Show, Eq) -- * Pipe -type Pipe = P.Pipeline Message Response +type Pipe = Pipeline Response Message -- ^ Thread-safe TCP connection with pipelined requests send :: Pipe -> [Notice] -> IOE () @@ -69,32 +72,34 @@ call pipe notices request = do -- * Message type Message = ([Notice], Maybe (Request, RequestId)) --- ^ A write notice(s), write notice(s) with getLastError request, or just query request. +-- ^ A write notice(s) with getLastError request, or just query request. -- Note, that requestId will be out of order because request ids will be generated for notices after the request id supplied was generated. This is ok because the mongo server does not care about order just uniqueness. -instance WriteMessage Message where - writeMessage handle (notices, mRequest) = ErrorT . E.try $ do - forM_ notices $ \n -> writeReq . (Left n,) =<< genRequestId - whenJust mRequest $ writeReq . (Right *** id) - hFlush handle +writeMessage :: Handle -> Message -> IOE () +-- ^ Write message to socket +writeMessage handle (notices, mRequest) = ErrorT . E.try $ do + forM_ notices $ \n -> writeReq . (Left n,) =<< genRequestId + whenJust mRequest $ writeReq . (Right *** id) + hFlush handle + where + writeReq (e, requestId) = do + hPut handle lenBytes + hPut handle bytes where - writeReq (e, requestId) = do - hPut handle lenBytes - hPut handle bytes - where - bytes = runPut $ (either putNotice putRequest e) requestId - lenBytes = encodeSize . toEnum . fromEnum $ B.length bytes - encodeSize = runPut . putInt32 . (+ 4) + bytes = runPut $ (either putNotice putRequest e) requestId + lenBytes = encodeSize . toEnum . fromEnum $ B.length bytes + encodeSize = runPut . putInt32 . (+ 4) type Response = (ResponseTo, Reply) -- ^ Message received from a Mongo server in response to a Request -instance ReadMessage Response where - readMessage handle = ErrorT . E.try $ readResp where - readResp = do - len <- fromEnum . decodeSize <$> hGetN handle 4 - runGet getReply <$> hGetN handle len - decodeSize = subtract 4 . runGet getInt32 +readMessage :: Handle -> IOE Response +-- ^ read response from socket +readMessage handle = ErrorT $ E.try readResp where + readResp = do + len <- fromEnum . decodeSize <$> hGetN handle 4 + runGet getReply <$> hGetN handle len + decodeSize = subtract 4 . runGet getInt32 type FullCollection = UString -- ^ Database name and collection name with period (.) in between. Eg. \"myDb.myCollection\" @@ -314,10 +319,7 @@ pwHash u p = pack . byteStringHex . MD5.hash . toByteString $ u `U.append` ":mon pwKey :: Nonce -> Username -> Password -> UString pwKey n u p = pack . byteStringHex . MD5.hash . toByteString . U.append n . U.append u $ pwHash u p -byteStringHex :: BS.ByteString -> String --- ^ Hexadecimal string representation of a byte string. Each byte yields two hexadecimal characters. -byteStringHex = concatMap byteHex . BS.unpack -byteHex :: Word8 -> String --- ^ Two char hexadecimal representation of byte -byteHex b = (if b < 16 then ('0' :) else id) (showHex b "") +{- Authors: Tony Hannan + 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. -} diff --git a/Database/MongoDB/Internal/Util.hs b/Database/MongoDB/Internal/Util.hs index 4c076b4..7bf5146 100644 --- a/Database/MongoDB/Internal/Util.hs +++ b/Database/MongoDB/Internal/Util.hs @@ -1,11 +1,10 @@ -- | Miscellaneous general functions and Show, Eq, and Ord instances for PortID -{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE FlexibleInstances, UndecidableInstances, StandaloneDeriving #-} module Database.MongoDB.Internal.Util where -import Prelude hiding (length) -import Control.Applicative ((<$>)) +import Control.Applicative (Applicative(..), (<$>)) import Network (PortID(..)) import Data.UString as U (cons, append) import Data.Bits (Bits, (.|.)) @@ -14,11 +13,56 @@ import Data.ByteString.Lazy as S (ByteString, length, append, hGet) import System.IO (Handle) import System.IO.Error (mkIOError, eofErrorType) import Control.Exception (assert) +import Control.Monad.Error +import Control.Arrow (left) +import qualified Data.ByteString as BS (ByteString, unpack) +import Data.Word (Word8) +import Numeric (showHex) +import System.Random.Shuffle (shuffle') +import System.Random (newStdGen) +import Data.List as L (length) deriving instance Show PortID deriving instance Eq PortID deriving instance Ord PortID +-- | MonadIO with extra Applicative and Functor superclasses +class (MonadIO m, Applicative m, Functor m) => MonadIO' m +instance (MonadIO m, Applicative m, Functor m) => MonadIO' m + +shuffle :: [a] -> IO [a] +-- ^ Randomly shuffle items in list +shuffle list = shuffle' list (L.length list) <$> newStdGen + +loop :: (Functor m, Monad m) => m (Maybe a) -> m [a] +-- ^ Repeatedy execute action, collecting results, until it returns Nothing +loop act = act >>= maybe (return []) (\a -> (a :) <$> loop act) + +untilSuccess :: (MonadError e m, Error e) => (a -> m b) -> [a] -> m b +-- ^ Apply action to elements one at a time until one succeeds. Throw last error if all fail. Throw 'strMsg' error if list is empty. +untilSuccess = untilSuccess' (strMsg "empty untilSuccess") + +untilSuccess' :: (MonadError e m) => e -> (a -> m b) -> [a] -> m b +-- ^ Apply action to elements one at a time until one succeeds. Throw last error if all fail. Throw given error if list is empty +untilSuccess' e _ [] = throwError e +untilSuccess' _ f (x : xs) = catchError (f x) (\e -> untilSuccess' e f xs) + +whenJust :: (Monad m) => Maybe a -> (a -> m ()) -> m () +whenJust mVal act = maybe (return ()) act mVal + +liftIOE :: (MonadIO m) => (e -> e') -> ErrorT e IO a -> ErrorT e' m a +-- ^ lift IOE monad to ErrorT monad over some MonadIO m +liftIOE f = ErrorT . liftIO . fmap (left f) . runErrorT + +runIOE :: ErrorT IOError IO a -> IO a +-- ^ Run action while catching explicit error and rethrowing in IO monad +runIOE (ErrorT action) = action >>= either ioError return + +updateAssocs :: (Eq k) => k -> v -> [(k, v)] -> [(k, v)] +-- ^ Change or insert value of key in association list +updateAssocs key valu assocs = case back of [] -> (key, valu) : front; _ : back' -> front ++ (key, valu) : back' + where (front, back) = break ((key ==) . fst) assocs + bitOr :: (Bits a) => [a] -> a -- ^ bit-or all numbers together bitOr = foldl (.|.) 0 @@ -40,7 +84,15 @@ hGetN :: Handle -> Int -> IO ByteString -- ^ Read N bytes from hande, blocking until all N bytes are read. If EOF is reached before N bytes then raise EOF exception. hGetN h n = assert (n >= 0) $ do bytes <- hGet h n - let x = fromEnum $ length bytes + let x = fromEnum $ S.length bytes if x >= n then return bytes else if x == 0 then ioError (mkIOError eofErrorType "hGetN" (Just h) Nothing) else S.append bytes <$> hGetN h (n - x) + +byteStringHex :: BS.ByteString -> String +-- ^ Hexadecimal string representation of a byte string. Each byte yields two hexadecimal characters. +byteStringHex = concatMap byteHex . BS.unpack + +byteHex :: Word8 -> String +-- ^ Two char hexadecimal representation of byte +byteHex b = (if b < 16 then ('0' :) else id) (showHex b "") diff --git a/Database/MongoDB/Query.hs b/Database/MongoDB/Query.hs index e06fd8d..eb74419 100644 --- a/Database/MongoDB/Query.hs +++ b/Database/MongoDB/Query.hs @@ -3,19 +3,18 @@ {-# LANGUAGE OverloadedStrings, RecordWildCards, NamedFieldPuns, TupleSections, FlexibleContexts, FlexibleInstances, UndecidableInstances, MultiParamTypeClasses, GeneralizedNewtypeDeriving, StandaloneDeriving, TypeSynonymInstances, RankNTypes #-} module Database.MongoDB.Query ( - -- * Access - access, Access, Action, runAction, Failure(..), + -- * Monad + Action, Failure(..), access, -- * Database - Database(..), allDatabases, DbAccess, use, thisDatabase, + Database, allDatabases, useDb, thisDatabase, -- ** Authentication - P.Username, P.Password, auth, + Username, Password, auth, -- * Collection Collection, allCollections, -- ** Selection Selection(..), Selector, whereJS, Select(select), -- * Write - -- ** WriteMode WriteMode(..), safe, GetLastError, writeMode, -- ** Insert insert, insert_, insertMany, insertMany_, @@ -24,7 +23,7 @@ module Database.MongoDB.Query ( -- ** Delete delete, deleteOne, -- * Read - readMode, + MasterOrSlaveOk(..), readMode, -- ** Query Query(..), QueryOption(..), Projector, Limit, Order, BatchSize, explain, find, findOne, count, distinct, @@ -40,109 +39,83 @@ module Database.MongoDB.Query ( ) where import Prelude as X hiding (lookup) -import Control.Applicative ((<$>), Applicative(..)) -import Control.Arrow (first) -import Control.Monad.Context -import Control.Monad.Reader -import Control.Monad.Error -import Control.Monad.Throw +import Data.UString as U (UString, dropWhile, any, tail) +import Data.Bson (Document, at, lookup, look, Field(..), (=:), (=?), Label, Value(String,Doc), Javascript, genObjectId) +import Database.MongoDB.Internal.Protocol (MasterOrSlaveOk(..), Pipe, Notice(..), Request(GetMore), Reply(..), QueryOption(..), ResponseFlag(..), UpdateOption(..), DeleteOption(..), CursorId, FullCollection, Username, Password, pwKey) +import qualified Database.MongoDB.Internal.Protocol as P (send, call, Request(Query)) +import Database.MongoDB.Internal.Util (MonadIO', loop, liftIOE, true1, (<.>)) import Control.Monad.MVar -import qualified Database.MongoDB.Internal.Protocol as P -import Database.MongoDB.Internal.Protocol hiding (Query, QueryOption(..), send, call) -import Database.MongoDB.Connection (MasterOrSlaveOk(..), Service(..)) -import Data.Bson -import Data.Word -import Data.Int +import Control.Monad.Error +import Control.Monad.Reader +import Control.Applicative (Applicative, (<$>)) import Data.Maybe (listToMaybe, catMaybes) -import Data.UString as U (dropWhile, any, tail) -import Control.Monad.Util (MonadIO', loop) -import Database.MongoDB.Internal.Util ((<.>), true1) +import Data.Int (Int32) +import Data.Word (Word32) -mapErrorIO :: (Throw e m, MonadIO m) => (e' -> e) -> ErrorT e' IO a -> m a -mapErrorIO f = throwLeft' f . liftIO . runErrorT +-- * Monad --- * Mongo Monad - -access :: (Service s, MonadIO m) => WriteMode -> MasterOrSlaveOk -> ConnPool s -> Action m a -> m (Either Failure a) --- ^ Run action under given write and read mode against the server or replicaSet behind given connection pool. Return Left Failure if there is a connection failure or read/write error. -access w mos pool act = do - ePipe <- liftIO . runErrorT $ getPipe mos pool - either (return . Left . ConnectionFailure) (runAction act w mos) ePipe - --- | A monad with access to a 'Pipe', 'MasterOrSlaveOk', and 'WriteMode', and throws 'Failure' on read, write, or pipe failure -class (Context Pipe m, Context MasterOrSlaveOk m, Context WriteMode m, Throw Failure m, MonadIO' m) => Access m -instance (Context Pipe m, Context MasterOrSlaveOk m, Context WriteMode m, Throw Failure m, MonadIO' m) => Access m - -wrapIO :: (Access m) => (WriteMode -> MasterOrSlaveOk -> Pipe -> IO (Either Failure a)) -> m a --- ^ Lift IO with Access context and failure into Access monad -wrapIO act = do - writeMod <- context - mos <- context - pipe <- context - e <- liftIO (act writeMod mos pipe) - either throw return e - -modifyMVar' :: (Access m) => MVar a -> (a -> Action IO (a, b)) -> m b -modifyMVar' var act = wrapIO $ \w m p -> modifyMVar var $ \a -> do - e <- runAction (act a) w m p - return $ either ((a,) . Left) (Right <$>) e - -addMVarFinalizer' :: (Access m) => MVar a -> Action IO () -> m () -addMVarFinalizer' var act = wrapIO $ \w m p -> do - addMVarFinalizer var $ runAction act w m p >> return () -- ignore any failure - return (Right ()) - -newtype Action m a = Action (ErrorT Failure (ReaderT WriteMode (ReaderT MasterOrSlaveOk (ReaderT Pipe m))) a) - deriving (Context Pipe, Context MasterOrSlaveOk, Context WriteMode, Throw Failure, MonadIO, Monad, Applicative, Functor) --- ^ Monad with access to a 'Pipe', 'MasterOrSlaveOk', and 'WriteMode', and throws a 'Failure' on read, write or pipe failure - -instance MonadTrans Action where - lift = Action . lift . lift . lift . lift - -runAction :: Action m a -> WriteMode -> MasterOrSlaveOk -> Pipe -> m (Either Failure a) --- ^ Run action with given write mode and read mode (master or slave-ok) against given pipe (TCP connection). Return Left Failure if read/write error or connection failure. --- 'access' calls runAction. Use this directly if you want to use the same connection and not take from the pool again. However, the connection may still be used by other threads at the same time. For instance, the pool will still hand this connection out. -runAction (Action action) w mos = runReaderT (runReaderT (runReaderT (runErrorT action) w) mos) +type Action m = ErrorT Failure (ReaderT Context m) +-- ^ A monad on top of m (which must be a MonadIO) with access to a 'Context' and may throw a 'Failure' -- | A connection failure, or a read or write exception like cursor expired or inserting a duplicate key. -- Note, unexpected data from the server is not a Failure, rather it is a programming error (you should call 'error' in this case) because the client and server are incompatible and requires a programming change. data Failure = - ConnectionFailure IOError -- ^ TCP connection ('Pipe') failed. Make work if you try again on the same Mongo 'Connection' which will create a new Pipe. + ConnectionFailure IOError -- ^ TCP connection ('Pipeline') failed. May work if you try again on the same Mongo 'Connection' which will create a new Pipe. | CursorNotFoundFailure CursorId -- ^ Cursor expired because it wasn't accessed for over 10 minutes, or this cursor came from a different server that the one you are currently connected to (perhaps a fail over happen between servers in a replica set) | QueryFailure String -- ^ Query failed for some reason as described in the string | WriteFailure ErrorCode String -- ^ Error observed by getLastError after a write, error description is in string deriving (Show, Eq) +type ErrorCode = Int +-- ^ Error code from getLastError + instance Error Failure where strMsg = error -- ^ 'fail' is treated the same as 'error'. In other words, don't use it. +-- | Values needed when executing a db operation +data Context = Context { + myPipe :: Pipe, -- | operations read/write to this pipelined TCP connection to a MongoDB server + myReadMode :: MasterOrSlaveOk, -- | queries set slaveOk according to this mode + myWriteMode :: WriteMode, -- | writes will automatically issue a getlasterror when this writeMode is `Safe` + myDatabase :: Database } -- | operations query/update this database + +access :: (MonadIO m) => Pipe -> WriteMode -> MasterOrSlaveOk -> Database -> Action m a -> m (Either Failure a) +-- ^ Run action under given context. Return Left on Failure. +access myPipe myWriteMode myReadMode myDatabase action = runReaderT (runErrorT action) Context{..} + +send :: (MonadIO m) => [Notice] -> Action m () +-- ^ Send notices as a contiguous batch to server with no reply. Throw 'ConnectionFailure' if pipe fails. +send ns = do + pipe <- asks myPipe + liftIOE ConnectionFailure $ P.send pipe ns + +call :: (MonadIO m) => [Notice] -> Request -> Action m (ErrorT Failure IO Reply) +-- ^ Send notices and request as a contiguous batch to server and return reply promise, which will block when invoked until reply arrives. This call will throw 'ConnectionFailure' if pipe fails on send, and promise will throw 'ConnectionFailure' if pipe fails on receive. +call ns r = do + pipe <- asks myPipe + promise <- liftIOE ConnectionFailure $ P.call pipe ns r + return (liftIOE ConnectionFailure promise) + -- * Database -newtype Database = Database {databaseName :: UString} deriving (Eq, Ord) --- ^ Database name +type Database = UString -instance Show Database where show (Database x) = unpack x - --- | 'Access' monad with a particular 'Database' in context -class (Context Database m, Access m) => DbAccess m -instance (Context Database m, Access m) => DbAccess m - -allDatabases :: (Access m) => m [Database] +allDatabases :: (MonadIO' m) => Action m [Database] -- ^ List all databases residing on server -allDatabases = map (Database . at "name") . at "databases" <$> use (Database "admin") (runCommand1 "listDatabases") +allDatabases = map (at "name") . at "databases" <$> useDb "admin" (runCommand1 "listDatabases") -use :: Database -> ReaderT Database m a -> m a --- ^ Run action against given database -use = flip runReaderT - -thisDatabase :: (DbAccess m) => m Database +thisDatabase :: (Monad m) => Action m Database -- ^ Current database in use -thisDatabase = context +thisDatabase = asks myDatabase + +useDb :: (Monad m) => Database -> Action m a -> Action m a +-- ^ Run action against given database +useDb = local . \db ctx -> ctx {myDatabase = db} -- * Authentication -auth :: (DbAccess m) => Username -> Password -> m Bool --- ^ Authenticate with the database (if server is running in secure mode). Return whether authentication was successful or not. Reauthentication is required for every new pipe. +auth :: (MonadIO' m) => Username -> Password -> Action m Bool +-- ^ Authenticate with the current database (if server is running in secure mode). Return whether authentication was successful or not. Reauthentication is required for every new pipe. auth usr pss = do n <- at "nonce" <$> runCommand ["getnonce" =: (1 :: Int)] true1 "ok" <$> runCommand ["authenticate" =: (1 :: Int), "user" =: usr, "nonce" =: n, "key" =: pwKey n usr pss] @@ -152,7 +125,7 @@ auth usr pss = do type Collection = UString -- ^ Collection name (not prefixed with database) -allCollections :: (DbAccess m) => m [Collection] +allCollections :: (MonadMVar m, Functor m) => Action m [Collection] -- ^ List all collections in this database allCollections = do db <- thisDatabase @@ -160,7 +133,7 @@ allCollections = do return . filter (not . isSpecial db) . map dropDbPrefix $ map (at "name") docs where dropDbPrefix = U.tail . U.dropWhile (/= '.') - isSpecial (Database db) col = U.any (== '$') col && db <.> col /= "local.oplog.$main" + isSpecial db col = U.any (== '$') col && db <.> col /= "local.oplog.$main" -- * Selection @@ -186,8 +159,6 @@ instance Select Query where -- * Write --- ** WriteMode - -- | Default write-mode is 'Unsafe' data WriteMode = Unsafe -- ^ Submit writes without receiving acknowledgments. Fast. Assumes writes succeed even though they may not. @@ -201,52 +172,40 @@ safe :: WriteMode -- ^ Safe [] safe = Safe [] -writeMode :: (Access m) => WriteMode -> m a -> m a +writeMode :: (Monad m) => WriteMode -> Action m a -> Action m a -- ^ Run action with given 'WriteMode' -writeMode = push . const +writeMode = local . \w ctx -> ctx {myWriteMode = w} -write :: (DbAccess m) => Notice -> m () +write :: (MonadIO m) => Notice -> Action m () -- ^ Send write to server, and if write-mode is 'Safe' then include getLastError request and raise 'WriteFailure' if it reports an error. -write notice = do - mode <- context - case mode of - Unsafe -> send [notice] - Safe params -> do - me <- getLastError [notice] params - maybe (return ()) (throw . uncurry WriteFailure) me - -type ErrorCode = Int --- ^ Error code from getLastError - -getLastError :: (DbAccess m) => [Notice] -> GetLastError -> m (Maybe (ErrorCode, String)) --- ^ Send notices (writes) then fetch what the last error was, Nothing means no error -getLastError writes params = do - r <- runCommand' writes $ ("getlasterror" =: (1 :: Int)) : params - return $ (at "code" r,) <$> lookup "err" r - -{-resetLastError :: (DbConn m) => m () --- ^ Clear last error -resetLastError = runCommand1 "reseterror" >> return ()-} +write notice = asks myWriteMode >>= \mode -> case mode of + Unsafe -> send [notice] + Safe params -> do + let q = query (("getlasterror" =: (1 :: Int)) : params) "$cmd" + Batch _ _ [doc] <- fulfill =<< request [notice] =<< queryRequest False q {limit = 1} + case lookup "err" doc of + Nothing -> return () + Just err -> throwError $ WriteFailure (maybe 0 id $ lookup "code" doc) err -- ** Insert -insert :: (DbAccess m) => Collection -> Document -> m Value +insert :: (MonadIO' m) => Collection -> Document -> Action m Value -- ^ Insert document into collection and return its \"_id\" value, which is created automatically if not supplied insert col doc = head <$> insertMany col [doc] -insert_ :: (DbAccess m) => Collection -> Document -> m () +insert_ :: (MonadIO' m) => Collection -> Document -> Action m () -- ^ Same as 'insert' except don't return _id insert_ col doc = insert col doc >> return () -insertMany :: (DbAccess m) => Collection -> [Document] -> m [Value] +insertMany :: (MonadIO m) => Collection -> [Document] -> Action m [Value] -- ^ Insert documents into collection and return their \"_id\" values, which are created automatically if not supplied insertMany col docs = do - Database db <- thisDatabase + db <- thisDatabase docs' <- liftIO $ mapM assignId docs write (Insert (db <.> col) docs') mapM (look "_id") docs' -insertMany_ :: (DbAccess m) => Collection -> [Document] -> m () +insertMany_ :: (MonadIO m) => Collection -> [Document] -> Action m () -- ^ Same as 'insertMany' except don't return _ids insertMany_ col docs = insertMany col docs >> return () @@ -258,60 +217,58 @@ assignId doc = if X.any (("_id" ==) . label) doc -- ** Update -save :: (DbAccess m) => Collection -> Document -> m () +save :: (MonadIO' m) => Collection -> Document -> Action m () -- ^ Save document to collection, meaning insert it if its new (has no \"_id\" field) or update it if its not new (has \"_id\" field) save col doc = case look "_id" doc of Nothing -> insert_ col doc Just i -> repsert (Select ["_id" := i] col) doc -replace :: (DbAccess m) => Selection -> Document -> m () +replace :: (MonadIO m) => Selection -> Document -> Action m () -- ^ Replace first document in selection with given document replace = update [] -repsert :: (DbAccess m) => Selection -> Document -> m () +repsert :: (MonadIO m) => Selection -> Document -> Action m () -- ^ Replace first document in selection with given document, or insert document if selection is empty repsert = update [Upsert] type Modifier = Document -- ^ Update operations on fields in a document. See -modify :: (DbAccess m) => Selection -> Modifier -> m () +modify :: (MonadIO m) => Selection -> Modifier -> Action m () -- ^ Update all documents in selection using given modifier modify = update [MultiUpdate] -update :: (DbAccess m) => [UpdateOption] -> Selection -> Document -> m () +update :: (MonadIO m) => [UpdateOption] -> Selection -> Document -> Action m () -- ^ Update first document in selection using updater document, unless 'MultiUpdate' option is supplied then update all documents in selection. If 'Upsert' option is supplied then treat updater as document and insert it if selection is empty. update opts (Select sel col) up = do - Database db <- thisDatabase + db <- thisDatabase write (Update (db <.> col) opts sel up) -- ** Delete -delete :: (DbAccess m) => Selection -> m () +delete :: (MonadIO m) => Selection -> Action m () -- ^ Delete all documents in selection delete = delete' [] -deleteOne :: (DbAccess m) => Selection -> m () +deleteOne :: (MonadIO m) => Selection -> Action m () -- ^ Delete first document in selection deleteOne = delete' [SingleRemove] -delete' :: (DbAccess m) => [DeleteOption] -> Selection -> m () +delete' :: (MonadIO m) => [DeleteOption] -> Selection -> Action m () -- ^ Delete all documents in selection unless 'SingleRemove' option is given then only delete first document in selection delete' opts (Select sel col) = do - Database db <- thisDatabase + db <- thisDatabase write (Delete (db <.> col) opts sel) -- * Read --- ** MasterOrSlaveOk - -readMode :: (Access m) => MasterOrSlaveOk -> m a -> m a +readMode :: (Monad m) => MasterOrSlaveOk -> Action m a -> Action m a -- ^ Execute action using given read mode. Master = consistent reads, SlaveOk = eventually consistent reads. -readMode = push . const +readMode = local . \r ctx -> ctx {myReadMode = r} -msOption :: MasterOrSlaveOk -> [P.QueryOption] +msOption :: MasterOrSlaveOk -> [QueryOption] msOption Master = [] -msOption SlaveOk = [P.SlaveOK] +msOption SlaveOk = [SlaveOK] -- ** Query @@ -328,18 +285,6 @@ data Query = Query { hint :: Order -- ^ Force MongoDB to use this index, [] = no hint. Default = [] } deriving (Show, Eq) -data QueryOption = - TailableCursor -- ^ Tailable means cursor is not closed when the last data is retrieved. Rather, the cursor marks the final object's position. You can resume using the cursor later, from where it was located, if more data were received. Like any "latent cursor", the cursor may become invalid at some point – for example if the final object it references were deleted. Thus, you should be prepared to requery on CursorNotFound exception. - | NoCursorTimeout -- The server normally times out idle cursors after an inactivity period (10 minutes) to prevent excess memory use. Set this option to prevent that. - | AwaitData -- ^ Use with TailableCursor. If we are at the end of the data, block for a while rather than returning no data. After a timeout period, we do return as normal. - deriving (Show, Eq) - -pOption :: QueryOption -> P.QueryOption --- ^ Convert to protocol query option -pOption TailableCursor = P.TailableCursor -pOption NoCursorTimeout = P.NoCursorTimeout -pOption AwaitData = P.AwaitData - type Projector = Document -- ^ Fields to return, analogous to the select clause in SQL. @[]@ means return whole document (analogous to * in SQL). @[x =: 1, y =: 1]@ means return only @x@ and @y@ fields of each document. @[x =: 0]@ means return all fields except @x@. @@ -356,6 +301,54 @@ query :: Selector -> Collection -> Query -- ^ Selects documents in collection that match selector. It uses no query options, projects all fields, does not skip any documents, does not limit result size, uses default batch size, does not sort, does not hint, and does not snapshot. query sel col = Query [] (Select sel col) [] 0 0 [] False 0 [] +find :: (MonadMVar m) => Query -> Action m Cursor +-- ^ Fetch documents satisfying query +find q@Query{selection, batchSize} = do + db <- thisDatabase + dBatch <- request [] =<< queryRequest False q + newCursor db (coll selection) batchSize dBatch + +findOne :: (MonadIO m) => Query -> Action m (Maybe Document) +-- ^ Fetch first document satisfying query or Nothing if none satisfy it +findOne q = do + Batch _ _ docs <- fulfill =<< request [] =<< queryRequest False q {limit = 1} + return (listToMaybe docs) + +explain :: (MonadIO m) => Query -> Action m Document +-- ^ Return performance stats of query execution +explain q = do -- same as findOne but with explain set to true + Batch _ _ docs <- fulfill =<< request [] =<< queryRequest True q {limit = 1} + return $ if null docs then error ("no explain: " ++ show q) else head docs + +count :: (MonadIO' m) => Query -> Action m Int +-- ^ Fetch number of documents satisfying query (including effect of skip and/or limit if present) +count Query{selection = Select sel col, skip, limit} = at "n" <$> runCommand + (["count" =: col, "query" =: sel, "skip" =: (fromIntegral skip :: Int32)] + ++ ("limit" =? if limit == 0 then Nothing else Just (fromIntegral limit :: Int32))) + +distinct :: (MonadIO' m) => Label -> Selection -> Action m [Value] +-- ^ Fetch distinct values of field in selected documents +distinct k (Select sel col) = at "values" <$> runCommand ["distinct" =: col, "key" =: k, "query" =: sel] + +queryRequest :: (Monad m) => Bool -> Query -> Action m (Request, Limit) +-- ^ Translate Query to Protocol.Query. If first arg is true then add special $explain attribute. +queryRequest isExplain Query{..} = do + ctx <- ask + return $ queryRequest' (myReadMode ctx) (myDatabase ctx) + where + queryRequest' mos db = (P.Query{..}, remainingLimit) where + qOptions = msOption mos ++ options + qFullCollection = db <.> coll selection + qSkip = fromIntegral skip + (qBatchSize, remainingLimit) = batchSizeRemainingLimit batchSize limit + qProjector = project + mOrder = if null sort then Nothing else Just ("$orderby" =: sort) + mSnapshot = if snapshot then Just ("$snapshot" =: True) else Nothing + mHint = if null hint then Nothing else Just ("$hint" =: hint) + mExplain = if isExplain then Just ("$explain" =: True) else Nothing + special = catMaybes [mOrder, mSnapshot, mHint, mExplain] + qSelector = if null special then s else ("$query" =: s) : special where s = selector selection + batchSizeRemainingLimit :: BatchSize -> Limit -> (Int32, Limit) -- ^ Given batchSize and limit return P.qBatchSize and remaining limit batchSizeRemainingLimit batchSize limit = if limit == 0 @@ -366,137 +359,83 @@ batchSizeRemainingLimit batchSize limit = if limit == 0 where batchSize' = if batchSize == 1 then 2 else batchSize -- batchSize 1 is broken because server converts 1 to -1 meaning limit 1 -queryRequest :: Bool -> MasterOrSlaveOk -> Query -> Database -> (Request, Limit) --- ^ Translate Query to Protocol.Query. If first arg is true then add special $explain attribute. -queryRequest isExplain mos Query{..} (Database db) = (P.Query{..}, remainingLimit) where - qOptions = msOption mos ++ map pOption options - qFullCollection = db <.> coll selection - qSkip = fromIntegral skip - (qBatchSize, remainingLimit) = batchSizeRemainingLimit batchSize limit - qProjector = project - mOrder = if null sort then Nothing else Just ("$orderby" =: sort) - mSnapshot = if snapshot then Just ("$snapshot" =: True) else Nothing - mHint = if null hint then Nothing else Just ("$hint" =: hint) - mExplain = if isExplain then Just ("$explain" =: True) else Nothing - special = catMaybes [mOrder, mSnapshot, mHint, mExplain] - qSelector = if null special then s else ("$query" =: s) : special where s = selector selection +type DelayedBatch = ErrorT Failure IO Batch +-- ^ A promised batch which may fail -runQuery :: (DbAccess m) => Bool -> [Notice] -> Query -> m DelayedCursorState --- ^ Send query request and return cursor state -runQuery isExplain ns q = do - db <- thisDatabase - slaveOK <- context - request ns (queryRequest isExplain slaveOK q db) +data Batch = Batch Limit CursorId [Document] +-- ^ CursorId = 0 means cursor is finished. Documents is remaining documents to serve in current batch. Limit is remaining limit for next fetch. -find :: (DbAccess m) => Query -> m Cursor --- ^ Fetch documents satisfying query -find q@Query{selection, batchSize} = do - db <- thisDatabase - dcs <- runQuery False [] q - newCursor db (coll selection) batchSize dcs - -findOne' :: (DbAccess m) => [Notice] -> Query -> m (Maybe Document) --- ^ Send notices and fetch first document satisfying query or Nothing if none satisfy it -findOne' ns q = do - CS _ _ docs <- mapErrorIO id =<< runQuery False ns q {limit = 1} - return (listToMaybe docs) - -findOne :: (DbAccess m) => Query -> m (Maybe Document) --- ^ Fetch first document satisfying query or Nothing if none satisfy it -findOne = findOne' [] - -explain :: (DbAccess m) => Query -> m Document --- ^ Return performance stats of query execution -explain q = do -- same as findOne but with explain set to true - CS _ _ docs <- mapErrorIO id =<< runQuery True [] q {limit = 1} - return $ if null docs then error ("no explain: " ++ show q) else head docs - -count :: (DbAccess m) => Query -> m Int --- ^ Fetch number of documents satisfying query (including effect of skip and/or limit if present) -count Query{selection = Select sel col, skip, limit} = at "n" <$> runCommand - (["count" =: col, "query" =: sel, "skip" =: (fromIntegral skip :: Int32)] - ++ ("limit" =? if limit == 0 then Nothing else Just (fromIntegral limit :: Int32))) - -distinct :: (DbAccess m) => Label -> Selection -> m [Value] --- ^ Fetch distinct values of field in selected documents -distinct k (Select sel col) = at "values" <$> runCommand ["distinct" =: col, "key" =: k, "query" =: sel] - --- *** Cursor - -data Cursor = Cursor FullCollection BatchSize (MVar DelayedCursorState) --- ^ Iterator over results of a query. Use 'next' to iterate or 'rest' to get all results. A cursor is closed when it is explicitly closed, all results have been read from it, garbage collected, or not used for over 10 minutes (unless 'NoCursorTimeout' option was specified in 'Query'). Reading from a closed cursor raises a 'CursorNotFoundFailure'. Note, a cursor is not closed when the pipe is closed, so you can open another pipe to the same server and continue using the cursor. - -getCursorState :: (Access m) => Cursor -> m CursorState --- ^ Extract current cursor status -getCursorState (Cursor _ _ var) = mapErrorIO id =<< readMVar var - -type DelayedCursorState = ErrorT Failure IO CursorState --- ^ A promised cursor state which may fail - -request :: (Access m) => [Notice] -> (Request, Limit) -> m DelayedCursorState --- ^ Send notices and request and return promised cursor state +request :: (MonadIO m) => [Notice] -> (Request, Limit) -> Action m DelayedBatch +-- ^ Send notices and request and return promised batch request ns (req, remainingLimit) = do promise <- call ns req return $ fromReply remainingLimit =<< promise -data CursorState = CS Limit CursorId [Document] --- ^ CursorId = 0 means cursor is finished. Documents is remaining documents to serve in current batch. Limit is remaining limit for next fetch. - -fromReply :: (Throw Failure m) => Limit -> Reply -> m CursorState --- ^ Convert Reply to CursorState or Failure +fromReply :: Limit -> Reply -> DelayedBatch +-- ^ Convert Reply to Batch or Failure fromReply limit Reply{..} = do mapM_ checkResponseFlag rResponseFlags - return (CS limit rCursorId rDocuments) + return (Batch limit rCursorId rDocuments) where -- If response flag indicates failure then throw it, otherwise do nothing checkResponseFlag flag = case flag of AwaitCapable -> return () - CursorNotFound -> throw (CursorNotFoundFailure rCursorId) - QueryError -> throw (QueryFailure $ at "$err" $ head rDocuments) + CursorNotFound -> throwError (CursorNotFoundFailure rCursorId) + QueryError -> throwError (QueryFailure $ at "$err" $ head rDocuments) -newCursor :: (Access m) => Database -> Collection -> BatchSize -> DelayedCursorState -> m Cursor +fulfill :: (MonadIO m) => DelayedBatch -> ErrorT Failure m Batch +-- ^ Demand and wait for result, raise failure if exception +fulfill = liftIOE id + +-- *** Cursor + +data Cursor = Cursor FullCollection BatchSize (MVar DelayedBatch) +-- ^ Iterator over results of a query. Use 'next' to iterate or 'rest' to get all results. A cursor is closed when it is explicitly closed, all results have been read from it, garbage collected, or not used for over 10 minutes (unless 'NoCursorTimeout' option was specified in 'Query'). Reading from a closed cursor raises a 'CursorNotFoundFailure'. Note, a cursor is not closed when the pipe is closed, so you can open another pipe to the same server and continue using the cursor. + +newCursor :: (MonadMVar m) => Database -> Collection -> BatchSize -> DelayedBatch -> Action m Cursor -- ^ Create new cursor. If you don't read all results then close it. Cursor will be closed automatically when all results are read from it or when eventually garbage collected. -newCursor (Database db) col batch cs = do - var <- newMVar cs - let cursor = Cursor (db <.> col) batch var - addMVarFinalizer' var (closeCursor cursor) +newCursor db col batchSize dBatch = do + var <- newMVar dBatch + let cursor = Cursor (db <.> col) batchSize var + addMVarFinalizer var (closeCursor cursor) return cursor -next :: (Access m) => Cursor -> m (Maybe Document) +next :: (MonadMVar m) => Cursor -> Action m (Maybe Document) -- ^ Return next document in query result, or Nothing if finished. -next (Cursor fcol batch var) = modifyMVar' var nextState where +next (Cursor fcol batchSize var) = modifyMVar var nextState where -- Pre-fetch next batch promise from server when last one in current batch is returned. - nextState:: DelayedCursorState -> Action IO (DelayedCursorState, Maybe Document) - nextState dcs = do - CS limit cid docs <- mapErrorIO id dcs + -- nextState:: DelayedBatch -> Action m (DelayedBatch, Maybe Document) + nextState dBatch = do + Batch limit cid docs <- fulfill dBatch case docs of doc : docs' -> do - dcs' <- if null docs' && cid /= 0 + dBatch' <- if null docs' && cid /= 0 then nextBatch limit cid - else return $ return (CS limit cid docs') - return (dcs', Just doc) + else return $ return (Batch limit cid docs') + return (dBatch', Just doc) [] -> if cid == 0 - then return (return $ CS 0 0 [], Nothing) -- finished + then return (return $ Batch 0 0 [], Nothing) -- finished else error $ "server returned empty batch but says more results on server" - nextBatch limit cid = request [] (GetMore fcol batchSize cid, remLimit) - where (batchSize, remLimit) = batchSizeRemainingLimit batch limit + nextBatch limit cid = request [] (GetMore fcol batchSize' cid, remLimit) + where (batchSize', remLimit) = batchSizeRemainingLimit batchSize limit -nextN :: (Access m) => Int -> Cursor -> m [Document] +nextN :: (MonadMVar m, Functor m) => Int -> Cursor -> Action m [Document] -- ^ Return next N documents or less if end is reached nextN n c = catMaybes <$> replicateM n (next c) -rest :: (Access m) => Cursor -> m [Document] +rest :: (MonadMVar m, Functor m) => Cursor -> Action m [Document] -- ^ Return remaining documents in query result rest c = loop (next c) -closeCursor :: (Access m) => Cursor -> m () -closeCursor (Cursor _ _ var) = modifyMVar' var kill' where - kill' dcs = first return <$> (kill =<< mapErrorIO id dcs) - kill (CS _ cid _) = (CS 0 0 [],) <$> if cid == 0 then return () else send [KillCursors [cid]] +closeCursor :: (MonadMVar m) => Cursor -> Action m () +closeCursor (Cursor _ _ var) = modifyMVar var $ \dBatch -> do + Batch _ cid _ <- fulfill dBatch + unless (cid == 0) $ send [KillCursors [cid]] + return $ (return $ Batch 0 0 [], ()) -isCursorClosed :: (Access m) => Cursor -> m Bool -isCursorClosed cursor = do - CS _ cid docs <- getCursorState cursor +isCursorClosed :: (MonadIO m) => Cursor -> Action m Bool +isCursorClosed (Cursor _ _ var) = do + Batch _ cid docs <- fulfill =<< readMVar var return (cid == 0 && null docs) -- ** Group @@ -524,7 +463,7 @@ groupDocument Group{..} = "initial" =: gInitial, "cond" =: gCond ] -group :: (DbAccess m) => Group -> m [Document] +group :: (MonadIO' m) => Group -> Action m [Document] -- ^ Execute group query and return resulting aggregate value for each distinct key group g = at "retval" <$> runCommand ["group" =: groupDocument g] @@ -590,23 +529,23 @@ mrOutDoc (Output mrMerge coll mDB) = (mergeName mrMerge =: coll) : mdb mDB where mergeName Merge = "merge" mergeName Reduce = "reduce" mdb Nothing = [] - mdb (Just (Database db)) = ["db" =: db] + mdb (Just db) = ["db" =: db] mapReduce :: Collection -> MapFun -> ReduceFun -> MapReduce -- ^ MapReduce on collection with given map and reduce functions. Remaining attributes are set to their defaults, which are stated in their comments. mapReduce col map' red = MapReduce col map' red [] [] 0 Inline Nothing [] False -runMR :: (DbAccess m) => MapReduce -> m Cursor +runMR :: (MonadMVar m, Applicative m) => MapReduce -> Action m Cursor -- ^ Run MapReduce and return cursor of results. Error if map/reduce fails (because of bad Javascript) runMR mr = do res <- runMR' mr case look "result" res of Just (String coll) -> find $ query [] coll - Just (Doc doc) -> use (Database $ at "db" doc) $ find $ query [] (at "collection" doc) + Just (Doc doc) -> useDb (at "db" doc) $ find $ query [] (at "collection" doc) Just x -> error $ "unexpected map-reduce result field: " ++ show x - Nothing -> newCursor (Database "") "" 0 $ return $ CS 0 0 (at "results" res) + Nothing -> newCursor "" "" 0 $ return $ Batch 0 0 (at "results" res) -runMR' :: (DbAccess m) => MapReduce -> m MRResult +runMR' :: (MonadIO' m) => MapReduce -> Action m MRResult -- ^ Run MapReduce and return a MR result document containing stats and the results if Inlined. Error if the map/reduce failed (because of bad Javascript). runMR' mr = do doc <- runCommand (mrDocument mr) @@ -617,40 +556,20 @@ runMR' mr = do type Command = Document -- ^ A command is a special query or action against the database. See for details. -runCommand' :: (DbAccess m) => [Notice] -> Command -> m Document --- ^ Send notices then run command and return its result -runCommand' ns c = maybe err id <$> findOne' ns (query c "$cmd") where +runCommand :: (MonadIO' m) => Command -> Action m Document +-- ^ Run command against the database and return its result +runCommand c = maybe err id <$> findOne (query c "$cmd") where err = error $ "Nothing returned for command: " ++ show c -runCommand :: (DbAccess m) => Command -> m Document --- ^ Run command against the database and return its result -runCommand = runCommand' [] - -runCommand1 :: (DbAccess m) => UString -> m Document +runCommand1 :: (MonadIO' m) => UString -> Action m Document -- ^ @runCommand1 foo = runCommand [foo =: 1]@ runCommand1 c = runCommand [c =: (1 :: Int)] -eval :: (DbAccess m) => Javascript -> m Document +eval :: (MonadIO' m) => Javascript -> Action m Document -- ^ Run code on server eval code = at "retval" <$> runCommand ["$eval" =: code] --- * Primitives - -send :: (Context Pipe m, Throw Failure m, MonadIO m) => [Notice] -> m () --- ^ Send notices as a contiguous batch to server with no reply. Throw 'ConnectionFailure' if pipe fails. -send ns = do - pipe <- context - mapErrorIO ConnectionFailure (P.send pipe ns) - -call :: (Context Pipe m, Throw Failure m, MonadIO m, Throw Failure n, MonadIO n) => - [Notice] -> Request -> m (n Reply) --- ^ Send notices and request as a contiguous batch to server and return reply promise, which will block when invoked until reply arrives. This call will throw 'ConnectionFailure' if pipe fails on send, and promise will throw 'ConnectionFailure' if pipe fails on receive. -call ns r = do - pipe <- context - promise <- mapErrorIO ConnectionFailure (P.call pipe ns r) - return (mapErrorIO ConnectionFailure promise) - {- Authors: Tony Hannan - Copyright 2010 10gen Inc. + 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. -} diff --git a/Network/Abstract.hs b/Network/Abstract.hs deleted file mode 100644 index 80b79c3..0000000 --- a/Network/Abstract.hs +++ /dev/null @@ -1,63 +0,0 @@ --- | Generalize a network connection to a sink and source - -{-# LANGUAGE MultiParamTypeClasses, ExistentialQuantification, FlexibleContexts, FlexibleInstances, OverlappingInstances, UndecidableInstances #-} - -module Network.Abstract where - -import System.IO (Handle, hClose) -import Network (HostName, PortID, connectTo) -import Control.Monad.Error -import System.IO.Error (try) -import Control.Monad.Context -import Control.Monad.Util (MonadIO') - -type IOE = ErrorT IOError IO --- ^ Be explicit about exception that may be raised. - -data Server i o = Server HostName PortID --- ^ A server receives messages of type i and returns messages of type o. - --- | Serialize message over handle -class WriteMessage i where - writeMessage :: Handle -> i -> IOE () - --- | Deserialize message from handle -class ReadMessage o where - readMessage :: Handle -> IOE o - --- | A network controls connections to other hosts. It may want to overide to log messages or play them back. -class Network n where - connect :: (WriteMessage i, ReadMessage o) => n -> Server i o -> IOE (Connection i o) - -- ^ Connect to Server returning the send sink and receive source, throw IOError if can't connect. - -data Connection i o = Connection { - send :: i -> IOE (), - receive :: IOE o, - close :: IO () } - -data ANetwork = forall n. (Network n) => ANetwork n - -instance Network (ANetwork) where - connect (ANetwork n) = connect n - -data Internet = Internet --- ^ Normal Network instance, i.e. no logging or replay - --- | Connect to server. Write messages and receive replies. Not thread-safe, must be wrapped in Pipeline or something. -instance Network Internet where - connect _ (Server hostname portid) = ErrorT . try $ do - handle <- connectTo hostname portid - return $ Connection (writeMessage handle) (readMessage handle) (hClose handle) - -class (MonadIO' m) => NetworkIO m where - network :: m ANetwork - -instance (Context ANetwork m, MonadIO' m) => NetworkIO m where - network = context - -instance NetworkIO IO where - network = return (ANetwork Internet) - -{- Authors: Tony Hannan - Copyright 2010 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. -} diff --git a/Control/Pipeline.hs b/System/IO/Pipeline.hs similarity index 61% rename from Control/Pipeline.hs rename to System/IO/Pipeline.hs index 554d121..82aeab4 100644 --- a/Control/Pipeline.hs +++ b/System/IO/Pipeline.hs @@ -1,53 +1,71 @@ -{- | Pipelining is sending multiple requests over a socket and receiving the responses later, in the same order. This is faster than sending one request, waiting for the response, then sending the next request, and so on. This implementation returns a /promise (future)/ response for each request that when invoked waits for the response if not already arrived. Multiple threads can send on the same pipeline (and get promises back); it will pipeline each thread's request right away without waiting. +{- | Pipelining is sending multiple requests over a socket and receiving the responses later, in the same order. This is faster than sending one request, waiting for the response, then sending the next request, and so on. This implementation returns a /promise (future)/ response for each request that when invoked waits for the response if not already arrived. Multiple threads can send on the same pipeline (and get promises back); it will send each thread's request right away without waiting. A pipeline closes itself when a read or write causes an error, so you can detect a broken pipeline by checking isClosed. It also closes itself when garbage collected, or you can close it explicitly. -} {-# LANGUAGE DoRec, RecordWildCards, NamedFieldPuns, ScopedTypeVariables #-} -module Control.Pipeline ( +module System.IO.Pipeline ( + IOE, + -- * IOStream + IOStream(..), -- * Pipeline Pipeline, newPipeline, send, call, close, isClosed ) where -import Control.Monad.Throw (onException) -import Control.Monad.Error -import Control.Concurrent (ThreadId, forkIO, killThread) +import Prelude hiding (length) import GHC.Conc (ThreadStatus(..), threadStatus) -import Control.Monad.MVar +import Control.Concurrent (ThreadId, forkIO, killThread) import Control.Concurrent.Chan -import Network.Abstract (IOE) -import qualified Network.Abstract as C +import Control.Monad.MVar +import Control.Monad.Error + +onException :: (Monad m) => ErrorT e m a -> m () -> ErrorT e m a +-- ^ If first action throws an exception then run second action then re-throw +onException (ErrorT action) releaser = ErrorT $ do + e <- action + either (const releaser) (const $ return ()) e + return e + +type IOE = ErrorT IOError IO + +-- * IOStream + +-- | An IO sink and source where value of type @o@ are sent and values of type @i@ are received. +data IOStream i o = IOStream { + writeStream :: o -> IOE (), + readStream :: IOE i, + closeStream :: IO () } -- * Pipeline -- | Thread-safe and pipelined connection data Pipeline i o = Pipeline { - vConn :: MVar (C.Connection i o), -- ^ Mutex on handle, so only one thread at a time can write to it - responseQueue :: Chan (MVar (Either IOError o)), -- ^ Queue of threads waiting for responses. Every time a response arrive we pop the next thread and give it the response. + vStream :: MVar (IOStream i o), -- ^ Mutex on handle, so only one thread at a time can write to it + responseQueue :: Chan (MVar (Either IOError i)), -- ^ Queue of threads waiting for responses. Every time a response arrive we pop the next thread and give it the response. listenThread :: ThreadId } --- | Create new Pipeline on given connection. You should 'close' pipeline when finished, which will also close connection. If pipeline is not closed but eventually garbage collected, it will be closed along with connection. -newPipeline :: (MonadIO m) => C.Connection i o -> m (Pipeline i o) -newPipeline conn = liftIO $ do - vConn <- newMVar conn +-- | Create new Pipeline over given handle. You should 'close' pipeline when finished, which will also close handle. If pipeline is not closed but eventually garbage collected, it will be closed along with handle. +newPipeline :: IOStream i o -> IO (Pipeline i o) +newPipeline stream = do + vStream <- newMVar stream responseQueue <- newChan rec let pipe = Pipeline{..} listenThread <- forkIO (listen pipe) - addMVarFinalizer vConn $ do + addMVarFinalizer vStream $ do killThread listenThread - C.close conn + closeStream stream return pipe -close :: (MonadIO m) => Pipeline i o -> m () +close :: Pipeline i o -> IO () -- | Close pipe and underlying connection -close Pipeline{..} = liftIO $ do +close Pipeline{..} = do killThread listenThread - C.close =<< readMVar vConn + closeStream =<< readMVar vStream -isClosed :: (MonadIO m) => Pipeline i o -> m Bool -isClosed Pipeline{listenThread} = liftIO $ do +isClosed :: Pipeline i o -> IO Bool +isClosed Pipeline{listenThread} = do status <- threadStatus listenThread return $ case status of ThreadRunning -> False @@ -59,31 +77,31 @@ isClosed Pipeline{listenThread} = liftIO $ do listen :: Pipeline i o -> IO () -- ^ Listen for responses and supply them to waiting threads in order listen Pipeline{..} = do - conn <- readMVar vConn + stream <- readMVar vStream forever $ do - e <- runErrorT $ C.receive conn + e <- runErrorT $ readStream stream var <- readChan responseQueue putMVar var e case e of - Left err -> C.close conn >> ioError err -- close and stop looping + Left err -> closeStream stream >> ioError err -- close and stop looping Right _ -> return () -send :: Pipeline i o -> i -> IOE () +send :: Pipeline i o -> o -> IOE () -- ^ Send message to destination; the destination must not response (otherwise future 'call's will get these responses instead of their own). -- Throw IOError and close pipeline if send fails -send p@Pipeline{..} message = withMVar vConn (flip C.send message) `onException` \(_ :: IOError) -> close p +send p@Pipeline{..} message = withMVar vStream (flip writeStream message) `onException` close p -call :: Pipeline i o -> i -> IOE (IOE o) +call :: Pipeline i o -> o -> IOE (IOE i) -- ^ Send message to destination and return /promise/ of response from one message only. The destination must reply to the message (otherwise promises will have the wrong responses in them). -- Throw IOError and closes pipeline if send fails, likewise for promised response. -call p@Pipeline{..} message = withMVar vConn doCall `onException` \(_ :: IOError) -> close p where - doCall conn = do - C.send conn message +call p@Pipeline{..} message = withMVar vStream doCall `onException` close p where + doCall stream = do + writeStream stream message var <- newEmptyMVar liftIO $ writeChan responseQueue var return $ ErrorT (readMVar var) -- return promise {- Authors: Tony Hannan - Copyright 2010 10gen Inc. + 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. -} diff --git a/mongoDB.cabal b/mongoDB.cabal index 7e11b45..76c3499 100644 --- a/mongoDB.cabal +++ b/mongoDB.cabal @@ -1,5 +1,5 @@ name: mongoDB -version: 0.10.0 +version: 1.0.0 build-type: Simple license: OtherLicense license-file: LICENSE @@ -16,7 +16,8 @@ build-depends: cryptohash -any, network -any, parsec -any, - random -any + random -any, + random-shuffle -any stability: alpha homepage: http://github.com/TonyGen/mongoDB-haskell package-url: @@ -31,18 +32,14 @@ data-dir: "" extra-source-files: extra-tmp-files: exposed-modules: - Control.Monad.Context Control.Monad.MVar - Control.Monad.Throw - Control.Monad.Util - Control.Pipeline Database.MongoDB Database.MongoDB.Admin Database.MongoDB.Connection Database.MongoDB.Internal.Protocol Database.MongoDB.Internal.Util Database.MongoDB.Query - Network.Abstract + System.IO.Pipeline Var.Pool exposed: True buildable: True