diff --git a/Database/MongoDB/Admin.hs b/Database/MongoDB/Admin.hs --- a/Database/MongoDB/Admin.hs +++ b/Database/MongoDB/Admin.hs @@ -5,9 +5,11 @@ module Database.MongoDB.Admin ( -- * Admin -- ** Collection - CollectionOption(..), createCollection, renameCollection, dropCollection, validateCollection, + CollectionOption(..), createCollection, renameCollection, dropCollection, + validateCollection, -- ** Index - Index(..), IndexName, index, ensureIndex, createIndex, dropIndex, getIndexes, dropIndexes, + Index(..), IndexName, index, ensureIndex, createIndex, dropIndex, + getIndexes, dropIndexes, -- ** User allUsers, addUser, removeUser, -- ** Database @@ -27,20 +29,30 @@ import Prelude hiding (lookup) import Control.Applicative ((<$>)) -import Database.MongoDB.Internal.Protocol (pwHash, pwKey) -import Database.MongoDB.Connection (Host, showHostPort) -import Database.MongoDB.Query -import Data.Bson -import Data.UString (pack, append, intercalate) -import Control.Monad.Reader -import qualified Data.HashTable as T -import Data.IORef -import qualified Data.Set as S -import System.IO.Unsafe (unsafePerformIO) import Control.Concurrent (forkIO, threadDelay) -import Database.MongoDB.Internal.Util (MonadIO', (<.>), true1) +import Control.Monad (forever, unless) +import Data.IORef (IORef, newIORef, readIORef, writeIORef) +import Data.Set (Set) +import System.IO.Unsafe (unsafePerformIO) + +import qualified Data.HashTable as H +import qualified Data.Set as Set + +import Control.Monad.Trans (MonadIO, liftIO) import Control.Monad.Trans.Control (MonadBaseControl) +import Data.Bson (Document, Field(..), at, (=:), (=?), exclude, merge) +import Data.Text (Text) +import qualified Data.Text as T + +import Database.MongoDB.Connection (Host, showHostPort) +import Database.MongoDB.Internal.Protocol (pwHash, pwKey) +import Database.MongoDB.Internal.Util (MonadIO', (<.>), true1) +import Database.MongoDB.Query (Action, Database, Collection, Username, Password, + Order, Query(..), accessMode, master, runCommand, + useDb, thisDatabase, rest, select, find, findOne, + insert_, save, delete) + -- * Admin -- ** Collection @@ -68,7 +80,7 @@ resetIndexCache r <- runCommand ["drop" =: coll] if true1 "ok" r then return True else do - if at "errmsg" r == ("ns not found" :: UString) then return False else + if at "errmsg" r == ("ns not found" :: Text) then return False else fail $ "dropCollection failed: " ++ show r validateCollection :: (MonadIO' m) => Collection -> Action m Document @@ -77,7 +89,7 @@ -- ** Index -type IndexName = UString +type IndexName = Text data Index = Index { iColl :: Collection, @@ -100,17 +112,17 @@ index coll keys = Index coll keys (genName keys) False False genName :: Order -> IndexName -genName keys = intercalate "_" (map f keys) where - f (k := v) = k `append` "_" `append` pack (show v) +genName keys = T.intercalate "_" (map f keys) where + f (k := v) = k `T.append` "_" `T.append` T.pack (show v) 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 set <- liftIO (readIORef icache) - unless (S.member k set) $ do + unless (Set.member k set) $ do accessMode master (createIndex idx) - liftIO $ writeIORef icache (S.insert k set) + liftIO $ writeIORef icache (Set.insert k set) createIndex :: (MonadIO' m) => Index -> Action m () -- ^ Create index on the server. This call goes to the server every time. @@ -132,46 +144,46 @@ -- ^ Drop all indexes on this collection dropIndexes coll = do resetIndexCache - runCommand ["deleteIndexes" =: coll, "index" =: ("*" :: UString)] + runCommand ["deleteIndexes" =: coll, "index" =: ("*" :: Text)] -- *** Index cache -type DbIndexCache = T.HashTable Database IndexCache +type DbIndexCache = H.HashTable Database IndexCache -- ^ Cache the indexes we create so repeatedly calling ensureIndex only hits database the first time. Clear cache every once in a while so if someone else deletes index we will recreate it on ensureIndex. -type IndexCache = IORef (S.Set (Collection, IndexName)) +type IndexCache = IORef (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) + table <- H.new (==) (H.hashString . T.unpack) _ <- forkIO . forever $ threadDelay 900000000 >> clearDbIndexCache return table {-# NOINLINE dbIndexCache #-} clearDbIndexCache :: IO () clearDbIndexCache = do - keys <- map fst <$> T.toList dbIndexCache - mapM_ (T.delete dbIndexCache) keys + keys <- map fst <$> H.toList dbIndexCache + mapM_ (H.delete dbIndexCache) keys fetchIndexCache :: (MonadIO m) => Action m IndexCache -- ^ Get index cache for current database fetchIndexCache = do db <- thisDatabase liftIO $ do - mc <- T.lookup dbIndexCache db + mc <- H.lookup dbIndexCache db maybe (newIdxCache db) return mc where newIdxCache db = do - idx <- newIORef S.empty - T.insert dbIndexCache db idx + idx <- newIORef Set.empty + H.insert dbIndexCache db idx return idx resetIndexCache :: (MonadIO m) => Action m () -- ^ reset index cache for current database resetIndexCache = do icache <- fetchIndexCache - liftIO (writeIORef icache S.empty) + liftIO (writeIORef icache Set.empty) -- ** User @@ -223,7 +235,7 @@ serverBuildInfo :: (MonadIO' m) => Action m Document serverBuildInfo = useDb admin $ runCommand ["buildinfo" =: (1 :: Int)] -serverVersion :: (MonadIO' m) => Action m UString +serverVersion :: (MonadIO' m) => Action m Text serverVersion = at "version" <$> serverBuildInfo -- * Diagnostics @@ -248,7 +260,7 @@ xs <- mapM isize =<< getIndexes coll return (foldl (+) x xs) where - isize idx = at "storageSize" <$> collectionStats (coll `append` ".$" `append` at "name" idx) + isize idx = at "storageSize" <$> collectionStats (coll `T.append` ".$" `T.append` at "name" idx) -- ** Profiling diff --git a/Database/MongoDB/Connection.hs b/Database/MongoDB/Connection.hs --- a/Database/MongoDB/Connection.hs +++ b/Database/MongoDB/Connection.hs @@ -8,33 +8,44 @@ -- * Connection Pipe, close, isClosed, -- * Server - Host(..), PortID(..), defaultPort, host, showHostPort, readHostPort, readHostPortM, - globalConnectTimeout, connect, connect', + Host(..), PortID(..), defaultPort, host, showHostPort, readHostPort, + readHostPortM, globalConnectTimeout, connect, connect', -- * Replica Set ReplicaSetName, openReplicaSet, openReplicaSet', - ReplicaSet, primary, secondaryOk, closeReplicaSet, replSetName + ReplicaSet, primary, secondaryOk, routedHost, closeReplicaSet, replSetName ) where import Prelude hiding (lookup) -import Database.MongoDB.Internal.Protocol (Pipe, newPipe) -import System.IO.Pipeline (IOE, close, isClosed) -import Control.Exception as E (try) +import Data.IORef (IORef, newIORef, readIORef) +import Data.List (intersect, partition, (\\), delete) +import Control.Applicative ((<$>)) +import Control.Monad (forM_) import Network (HostName, PortID(..), connectTo) -import Text.ParserCombinators.Parsec as T (parse, many1, letter, digit, char, eof, spaces, try, (<|>)) +import System.IO.Unsafe (unsafePerformIO) +import System.Timeout (timeout) +import Text.ParserCombinators.Parsec (parse, many1, letter, digit, char, eof, + spaces, try, (<|>)) +import qualified Control.Exception as E +import qualified Data.List as List + + import Control.Monad.Identity (runIdentity) import Control.Monad.Error (ErrorT(..), lift, throwError) -import Control.Concurrent.MVar.Lifted -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, slaveOk, Failure(ConnectionFailure), Command, runCommand) -import Database.MongoDB.Internal.Util (untilSuccess, liftIOE, runIOE, updateAssocs, shuffle) -import Data.List as L (lookup, intersect, partition, (\\), delete) -import Data.IORef (IORef, newIORef, readIORef) -import System.Timeout (timeout) -import System.IO.Unsafe (unsafePerformIO) +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.Protocol (Pipe, newPipe) +import Database.MongoDB.Internal.Util (untilSuccess, liftIOE, runIOE, + updateAssocs, shuffle, mergesortM) +import Database.MongoDB.Query (Command, Failure(ConnectionFailure), access, + slaveOk, runCommand) +import System.IO.Pipeline (IOE, close, isClosed) + adminCommand :: Command -> Pipe -> IOE Document -- ^ Run command against admin database on server connected to pipe. Fail if connection fails. adminCommand cmd pipe = @@ -74,7 +85,7 @@ parser = do spaces h <- hostname - T.try (spaces >> eof >> return (host h)) <|> do + try (spaces >> eof >> return (host h)) <|> do _ <- char ':' port :: Int <- read <$> many1 digit spaces >> eof @@ -105,12 +116,12 @@ -- * Replica Set -type ReplicaSetName = UString +type ReplicaSetName = Text -- | Maintains a connection (created on demand) to each server in the named replica set data ReplicaSet = ReplicaSet ReplicaSetName (MVar [(Host, Maybe Pipe)]) Secs -replSetName :: ReplicaSet -> UString +replSetName :: ReplicaSet -> Text -- ^ name of connected replica set replSetName (ReplicaSet rsName _ _) = rsName @@ -136,7 +147,7 @@ mHost <- statedPrimary <$> updateMembers rs case mHost of Just host' -> connection rs Nothing host' - Nothing -> throwError $ userError $ "replica set " ++ unpack rsName ++ " has no primary" + Nothing -> throwError $ userError $ "replica set " ++ T.unpack rsName ++ " has no primary" secondaryOk :: ReplicaSet -> IOE Pipe -- ^ Return connection to a random secondary, or primary if no secondaries available. @@ -146,12 +157,21 @@ let hosts' = maybe hosts (\p -> delete p hosts ++ [p]) (statedPrimary info) untilSuccess (connection rs Nothing) hosts' +routedHost :: ((Host, Bool) -> (Host, Bool) -> IOE Ordering) -> ReplicaSet -> IOE 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 f rs = do + info <- updateMembers rs + hosts <- lift $ shuffle (possibleHosts info) + let addIsPrimary h = (h, if Just h == statedPrimary info then True else False) + hosts' <- mergesortM (\a b -> f (addIsPrimary a) (addIsPrimary b)) hosts + untilSuccess (connection rs Nothing) 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 (host', info) = if (at "ismaster" info) then Just host' else readHostPort <$> D.lookup "primary" info +statedPrimary (host', info) = if (at "ismaster" info) then Just host' else readHostPort <$> B.lookup "primary" info possibleHosts :: ReplicaInfo -> [Host] -- ^ Non-arbiter, non-hidden members of replica set @@ -176,9 +196,9 @@ 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 + case B.lookup "setName" info of + Nothing -> throwError $ userError $ show host' ++ " not a member of any replica set, including " ++ T.unpack rsName ++ ": " ++ show info + Just setName | setName /= rsName -> throwError $ userError $ show host' ++ " not a member of replica set " ++ T.unpack rsName ++ ": " ++ show info Just _ -> return (host', info) connection :: ReplicaSet -> Maybe Pipe -> Host -> IOE Pipe @@ -188,7 +208,7 @@ where conn = modifyMVar vMembers $ \members -> do let new = connect' timeoutSecs host' >>= \pipe -> return (updateAssocs host' (Just pipe) members, pipe) - case L.lookup host' members of + case List.lookup host' members of Just (Just pipe) -> lift (isClosed pipe) >>= \bad -> if bad then new else return (members, pipe) _ -> new diff --git a/Database/MongoDB/Internal/Protocol.hs b/Database/MongoDB/Internal/Protocol.hs --- a/Database/MongoDB/Internal/Protocol.hs +++ b/Database/MongoDB/Internal/Protocol.hs @@ -1,8 +1,12 @@ -{-| Low-level messaging between this client and the MongoDB server, see Mongo Wire Protocol (). - -This module is not intended for direct use. Use the high-level interface at "Database.MongoDB.Query" and "Database.MongoDB.Connection" instead. -} +-- | Low-level messaging between this client and the MongoDB server, see Mongo +-- Wire Protocol (). +-- +-- This module is not intended for direct use. Use the high-level interface at +-- "Database.MongoDB.Query" and "Database.MongoDB.Connection" instead. -{-# LANGUAGE RecordWildCards, StandaloneDeriving, OverloadedStrings, FlexibleContexts, TupleSections, TypeSynonymInstances, MultiParamTypeClasses, FlexibleInstances, UndecidableInstances #-} +{-# LANGUAGE RecordWildCards, StandaloneDeriving, OverloadedStrings #-} +{-# LANGUAGE FlexibleContexts, TupleSections, TypeSynonymInstances #-} +{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, UndecidableInstances #-} module Database.MongoDB.Internal.Protocol ( FullCollection, @@ -18,28 +22,36 @@ Username, Password, Nonce, pwHash, pwKey ) where -import Prelude as X import Control.Applicative ((<$>)) import Control.Arrow ((***)) -import Data.ByteString.Lazy as B (length, hPut) -import System.IO.Pipeline (IOE, Pipeline, newPipeline, IOStream(..)) -import qualified System.IO.Pipeline as P (send, call) -import System.IO (Handle, hClose) -import Data.Bson (Document, UString) -import Data.Bson.Binary -import Data.Binary.Put -import Data.Binary.Get -import Data.Int -import Data.Bits -import Data.IORef +import Control.Exception (try) +import Control.Monad (forM_, replicateM, unless) +import Data.Binary.Get (Get, runGet) +import Data.Binary.Put (Put, runPut) +import Data.Bits (bit, testBit) +import Data.Int (Int32, Int64) +import Data.IORef (IORef, newIORef, atomicModifyIORef) +import System.IO (Handle, hClose, hFlush) import System.IO.Unsafe (unsafePerformIO) -import qualified Crypto.Hash.MD5 as MD5 (hash) -import Data.UString as U (pack, append, toByteString) -import Control.Exception as E (try) -import Control.Monad.Error -import System.IO (hFlush) + +import qualified Data.ByteString.Lazy as L + +import Control.Monad.Error (ErrorT(..)) +import Control.Monad.Trans (MonadIO, liftIO) +import Data.Bson (Document) +import Data.Bson.Binary (getDocument, putDocument, getInt32, putInt32, getInt64, + putInt64, putCString) +import Data.Text (Text) + +import qualified Crypto.Hash.MD5 as MD5 +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE + import Database.MongoDB.Internal.Util (whenJust, hGetN, bitOr, byteStringHex) +import System.IO.Pipeline (IOE, Pipeline, newPipeline, IOStream(..)) +import qualified System.IO.Pipeline as P + -- * Pipe type Pipe = Pipeline Response Message @@ -71,17 +83,17 @@ writeMessage :: Handle -> Message -> IOE () -- ^ Write message to socket -writeMessage handle (notices, mRequest) = ErrorT . E.try $ do +writeMessage handle (notices, mRequest) = ErrorT . 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 + L.hPut handle lenBytes + L.hPut handle bytes where bytes = runPut $ (either putNotice putRequest e) requestId - lenBytes = encodeSize . toEnum . fromEnum $ B.length bytes + lenBytes = encodeSize . toEnum . fromEnum $ L.length bytes encodeSize = runPut . putInt32 . (+ 4) type Response = (ResponseTo, Reply) @@ -89,13 +101,13 @@ readMessage :: Handle -> IOE Response -- ^ read response from socket -readMessage handle = ErrorT $ E.try readResp where +readMessage handle = ErrorT $ try readResp where readResp = do len <- fromEnum . decodeSize <$> hGetN handle 4 runGet getReply <$> hGetN handle len decodeSize = subtract 4 . runGet getInt32 -type FullCollection = UString +type FullCollection = Text -- ^ Database name and collection name with period (.) in between. Eg. \"myDb.myCollection\" -- ** Header @@ -194,7 +206,7 @@ putDocument dSelector KillCursors{..} -> do putInt32 0 - putInt32 $ toEnum (X.length kCursorIds) + putInt32 $ toEnum (length kCursorIds) mapM_ putInt64 kCursorIds iBit :: InsertOption -> Int32 @@ -319,15 +331,15 @@ -- * Authentication -type Username = UString -type Password = UString -type Nonce = UString +type Username = Text +type Password = Text +type Nonce = Text -pwHash :: Username -> Password -> UString -pwHash u p = pack . byteStringHex . MD5.hash . toByteString $ u `U.append` ":mongo:" `U.append` p +pwHash :: Username -> Password -> Text +pwHash u p = T.pack . byteStringHex . MD5.hash . TE.encodeUtf8 $ u `T.append` ":mongo:" `T.append` p -pwKey :: Nonce -> Username -> Password -> UString -pwKey n u p = pack . byteStringHex . MD5.hash . toByteString . U.append n . U.append u $ pwHash u p +pwKey :: Nonce -> Username -> Password -> Text +pwKey n u p = T.pack . byteStringHex . MD5.hash . TE.encodeUtf8 . T.append n . T.append u $ pwHash u p {- Authors: Tony Hannan diff --git a/Database/MongoDB/Internal/Util.hs b/Database/MongoDB/Internal/Util.hs --- a/Database/MongoDB/Internal/Util.hs +++ b/Database/MongoDB/Internal/Util.hs @@ -1,27 +1,34 @@ -- | Miscellaneous general functions and Show, Eq, and Ord instances for PortID {-# LANGUAGE FlexibleInstances, UndecidableInstances, StandaloneDeriving #-} +-- PortID instances +{-# OPTIONS_GHC -fno-warn-orphans #-} module Database.MongoDB.Internal.Util where import Control.Applicative (Applicative(..), (<$>)) -import Network (PortID(..)) -import Data.UString as U (cons, append) -import Data.Bits (Bits, (.|.)) -import Data.Bson -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 Control.Exception (assert) +import Control.Monad (liftM, liftM2) +import Data.Bits (Bits, (.|.)) import Data.Word (Word8) +import Network (PortID(..)) import Numeric (showHex) -import System.Random.Shuffle (shuffle') +import System.IO (Handle) +import System.IO.Error (mkIOError, eofErrorType) import System.Random (newStdGen) -import Data.List as L (length) +import System.Random.Shuffle (shuffle') +import qualified Data.ByteString.Lazy as L +import qualified Data.ByteString as S + +import Control.Monad.Error (MonadError(..), ErrorT(..), Error(..)) +import Control.Monad.Trans (MonadIO, liftIO) +import Data.Bson +import Data.Text (Text) + +import qualified Data.Text as T + deriving instance Show PortID deriving instance Eq PortID deriving instance Ord PortID @@ -30,9 +37,36 @@ class (MonadIO m, Applicative m, Functor m) => MonadIO' m instance (MonadIO m, Applicative m, Functor m) => MonadIO' m +-- | A monadic sort implementation derived from the non-monadic one in ghc's Prelude +mergesortM :: Monad m => (a -> a -> m Ordering) -> [a] -> m [a] +mergesortM cmp = mergesortM' cmp . map wrap + +mergesortM' :: Monad m => (a -> a -> m Ordering) -> [[a]] -> m [a] +mergesortM' _ [] = return [] +mergesortM' _ [xs] = return xs +mergesortM' cmp xss = mergesortM' cmp =<< (merge_pairsM cmp xss) + +merge_pairsM :: Monad m => (a -> a -> m Ordering) -> [[a]] -> m [[a]] +merge_pairsM _ [] = return [] +merge_pairsM _ [xs] = return [xs] +merge_pairsM cmp (xs:ys:xss) = liftM2 (:) (mergeM cmp xs ys) (merge_pairsM cmp xss) + +mergeM :: Monad m => (a -> a -> m Ordering) -> [a] -> [a] -> m [a] +mergeM _ [] ys = return ys +mergeM _ xs [] = return xs +mergeM cmp (x:xs) (y:ys) + = do + c <- x `cmp` y + case c of + GT -> liftM (y:) (mergeM cmp (x:xs) ys) + _ -> liftM (x:) (mergeM cmp xs (y:ys)) + +wrap :: a -> [a] +wrap x = [x] + shuffle :: [a] -> IO [a] -- ^ Randomly shuffle items in list -shuffle list = shuffle' list (L.length list) <$> newStdGen +shuffle list = shuffle' list (length list) <$> newStdGen loop :: (Functor m, Monad m) => m (Maybe a) -> m [a] -- ^ Repeatedy execute action, collecting results, until it returns Nothing @@ -67,9 +101,9 @@ -- ^ bit-or all numbers together bitOr = foldl (.|.) 0 -(<.>) :: UString -> UString -> UString +(<.>) :: Text -> Text -> Text -- ^ Concat first and second together with period in between. Eg. @\"hello\" \<.\> \"world\" = \"hello.world\"@ -a <.> b = U.append a (cons '.' b) +a <.> b = T.append a (T.cons '.' b) true1 :: Label -> Document -> Bool -- ^ Is field's value a 1 or True (MongoDB use both Int and Bools for truth values). Error if field not in document or field not a Num or Bool. @@ -80,18 +114,18 @@ Int64 n -> n == 1 _ -> error $ "expected " ++ show k ++ " to be Num or Bool in " ++ show doc -hGetN :: Handle -> Int -> IO ByteString +hGetN :: Handle -> Int -> IO L.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 $ S.length bytes + bytes <- L.hGet h n + let x = fromEnum $ L.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) + else L.append bytes <$> hGetN h (n - x) -byteStringHex :: BS.ByteString -> String +byteStringHex :: S.ByteString -> String -- ^ Hexadecimal string representation of a byte string. Each byte yields two hexadecimal characters. -byteStringHex = concatMap byteHex . BS.unpack +byteStringHex = concatMap byteHex . S.unpack byteHex :: Word8 -> String -- ^ Two char hexadecimal representation of byte diff --git a/Database/MongoDB/Query.hs b/Database/MongoDB/Query.hs --- a/Database/MongoDB/Query.hs +++ b/Database/MongoDB/Query.hs @@ -25,38 +25,58 @@ delete, deleteOne, -- * Read -- ** Query - Query(..), QueryOption(NoCursorTimeout, TailableCursor, AwaitData, Partial), Projector, Limit, Order, BatchSize, + Query(..), QueryOption(NoCursorTimeout, TailableCursor, AwaitData, Partial), + Projector, Limit, Order, BatchSize, explain, find, findOne, fetch, count, distinct, -- *** Cursor Cursor, nextBatch, next, nextN, rest, closeCursor, isCursorClosed, -- ** Group Group(..), GroupKey(..), group, -- ** MapReduce - MapReduce(..), MapFun, ReduceFun, FinalizeFun, MROut(..), MRMerge(..), MRResult, mapReduce, runMR, runMR', + MapReduce(..), MapFun, ReduceFun, FinalizeFun, MROut(..), MRMerge(..), + MRResult, mapReduce, runMR, runMR', -- * Command Command, runCommand, runCommand1, eval, ) where -import Prelude as X hiding (lookup) -import Data.UString as U (UString, dropWhile, any, tail) -import Data.Bson (Document, at, valueAt, lookup, look, Field(..), (=:), (=?), Label, Value(String,Doc), Javascript, genObjectId) -import Database.MongoDB.Internal.Protocol (Pipe, Notice(..), Request(GetMore, qOptions, qFullCollection, qSkip, qBatchSize, qSelector, qProjector), Reply(..), QueryOption(..), ResponseFlag(..), InsertOption(..), 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.Concurrent.MVar.Lifted -import Control.Monad.Error -import Control.Monad.Reader -import Control.Monad.State (StateT) -import Control.Monad.Writer (WriterT, Monoid) -import Control.Monad.RWS (RWST) -import Control.Monad.Base (MonadBase(liftBase)) -import Control.Monad.Trans.Control (ComposeSt, MonadBaseControl(..), MonadTransControl(..), StM, StT, defaultLiftBaseWith, defaultRestoreM) +import Prelude hiding (lookup) import Control.Applicative (Applicative, (<$>)) -import Data.Maybe (listToMaybe, catMaybes) +import Control.Monad (unless, replicateM, liftM) import Data.Int (Int32) +import Data.Maybe (listToMaybe, catMaybes) import Data.Word (Word32) +import Control.Concurrent.MVar.Lifted (MVar, newMVar, addMVarFinalizer, + readMVar, modifyMVar) +import Control.Monad.Base (MonadBase(liftBase)) +import Control.Monad.Error (ErrorT, Error(..), MonadError, runErrorT, + throwError) +import Control.Monad.Reader (ReaderT, runReaderT, ask, asks, local) +import Control.Monad.RWS (RWST) +import Control.Monad.State (StateT) +import Control.Monad.Trans (MonadIO, MonadTrans, lift, liftIO) +import Control.Monad.Trans.Control (ComposeSt, MonadBaseControl(..), + MonadTransControl(..), StM, StT, + defaultLiftBaseWith, defaultRestoreM) +import Control.Monad.Writer (WriterT, Monoid) +import Data.Bson (Document, Field(..), Label, Value(String,Doc), Javascript, + at, valueAt, lookup, look, genObjectId, (=:), (=?)) +import Data.Text (Text) +import qualified Data.Text as T + +import Database.MongoDB.Internal.Protocol (Reply(..), QueryOption(..), + ResponseFlag(..), InsertOption(..), + UpdateOption(..), DeleteOption(..), + CursorId, FullCollection, Username, + Password, Pipe, Notice(..), + Request(GetMore, qOptions, qSkip, + qFullCollection, qBatchSize, + qSelector, qProjector), + pwKey) +import Database.MongoDB.Internal.Util (MonadIO', loop, liftIOE, true1, (<.>)) +import qualified Database.MongoDB.Internal.Protocol as P + -- * Monad newtype Action m a = Action {unAction :: ErrorT Failure (ReaderT Context m) a} @@ -106,6 +126,7 @@ ReadStaleOk -- ^ Read-only action, reading stale data from a slave is OK. | UnconfirmedWrites -- ^ Read-write action, slave not OK, every write is fire & forget. | ConfirmWrites GetLastError -- ^ Read-write action, slave not OK, every write is confirmed with getLastError. + deriving Show type GetLastError = Document -- ^ Parameters for getLastError command. For example @[\"w\" =: 2]@ tells the server to wait for the write to reach at least two servers in replica set before acknowledging. See for more options. @@ -183,7 +204,7 @@ -- * Database -type Database = UString +type Database = Text allDatabases :: (MonadIO' m) => Action m [Database] -- ^ List all databases residing on server @@ -207,7 +228,7 @@ -- * Collection -type Collection = UString +type Collection = Text -- ^ Collection name (not prefixed with database) allCollections :: (MonadIO m, MonadBaseControl IO m, Functor m) => Action m [Collection] @@ -217,8 +238,8 @@ docs <- rest =<< find (query [] "system.namespaces") {sort = ["name" =: (1 :: Int)]} return . filter (not . isSpecial db) . map dropDbPrefix $ map (at "name") docs where - dropDbPrefix = U.tail . U.dropWhile (/= '.') - isSpecial db col = U.any (== '$') col && db <.> col /= "local.oplog.$main" + dropDbPrefix = T.tail . T.dropWhile (/= '.') + isSpecial db col = T.any (== '$') col && db <.> col /= "local.oplog.$main" -- * Selection @@ -296,7 +317,7 @@ assignId :: Document -> IO Document -- ^ Assign a unique value to _id field if missing -assignId doc = if X.any (("_id" ==) . label) doc +assignId doc = if any (("_id" ==) . label) doc then return doc else (\oid -> ("_id" =: oid) : doc) <$> genObjectId @@ -669,7 +690,7 @@ runCommand c = maybe err id <$> findOne (query c "$cmd") where err = error $ "Nothing returned for command: " ++ show c -runCommand1 :: (MonadIO' m) => UString -> Action m Document +runCommand1 :: (MonadIO' m) => Text -> Action m Document -- ^ @runCommand1 foo = runCommand [foo =: 1]@ runCommand1 c = runCommand [c =: (1 :: Int)] diff --git a/System/IO/Pipeline.hs b/System/IO/Pipeline.hs --- a/System/IO/Pipeline.hs +++ b/System/IO/Pipeline.hs @@ -13,11 +13,15 @@ ) where import Prelude hiding (length) -import GHC.Conc (ThreadStatus(..), threadStatus) import Control.Concurrent (ThreadId, forkIO, killThread) -import Control.Concurrent.Chan -import Control.Concurrent.MVar.Lifted -import Control.Monad.Error +import Control.Concurrent.Chan (Chan, newChan, readChan, writeChan) +import Control.Monad (forever) +import GHC.Conc (ThreadStatus(..), threadStatus) + +import Control.Monad.Trans (liftIO) +import Control.Concurrent.MVar.Lifted (MVar, newEmptyMVar, newMVar, withMVar, + putMVar, readMVar, addMVarFinalizer) +import Control.Monad.Error (ErrorT(ErrorT), runErrorT) 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 diff --git a/System/IO/Pool.hs b/System/IO/Pool.hs --- a/System/IO/Pool.hs +++ b/System/IO/Pool.hs @@ -5,12 +5,15 @@ module System.IO.Pool where import Control.Applicative ((<$>)) -import Control.Concurrent.MVar.Lifted -import Data.Array.IO +import Control.Exception (assert) +import Data.Array.IO (IOArray, readArray, writeArray, newArray, newListArray, + getElems, getBounds, rangeSize, range) import Data.Maybe (catMaybes) -import Control.Monad.Error import System.Random (randomRIO) -import Control.Exception (assert) + +import Control.Concurrent.MVar.Lifted (MVar, newMVar, withMVar, modifyMVar_) +import Control.Monad.Error (ErrorT, Error) +import Control.Monad.Trans (liftIO) -- | Creator, destroyer, and checker of resources of type r. Creator may throw error or type e. data Factory e r = Factory { diff --git a/mongoDB.cabal b/mongoDB.cabal --- a/mongoDB.cabal +++ b/mongoDB.cabal @@ -1,68 +1,48 @@ -name: mongoDB -version: 1.2.0 -build-type: Simple -license: OtherLicense -license-file: LICENSE -copyright: Copyright (c) 2010-2012 10gen Inc. -author: Tony Hannan -maintainer: Tony Hannan -build-depends: - array -any, - base <5, - binary -any, - bson -any, - bytestring -any, - containers -any, - mtl >= 2, - cryptohash -any, - network -any, - parsec -any, - random -any, - random-shuffle -any, - monad-control >= 0.3.1, - lifted-base >= 0.1.0.3, - transformers-base >= 0.4.1 -stability: alpha -homepage: http://github.com/TonyGen/mongoDB-haskell -package-url: -bug-reports: -synopsis: Driver (client) for MongoDB, a free, scalable, fast, document DBMS -description: This package lets you connect to MongoDB servers and update/query their data. Please see the example in Database.MongoDB and the tutorial from the homepage. For information about MongoDB itself, see www.mongodb.org. -category: Database -tested-with: -data-files: -data-dir: "" -extra-source-files: -extra-tmp-files: -exposed-modules: - Database.MongoDB - Database.MongoDB.Admin - Database.MongoDB.Connection - Database.MongoDB.Internal.Protocol - Database.MongoDB.Internal.Util - Database.MongoDB.Query - System.IO.Pipeline - System.IO.Pool -exposed: True -buildable: True -build-tools: -cpp-options: -cc-options: -ld-options: -pkgconfig-depends: -frameworks: -c-sources: -extensions: -extra-libraries: -extra-lib-dirs: -includes: -install-includes: -include-dirs: -hs-source-dirs: . -other-modules: -ghc-prof-options: -auto-all -ghc-shared-options: -ghc-options: -Wall -hugs-options: -nhc98-options: -jhc-options: +Name: mongoDB +Version: 1.3.0 +Synopsis: Driver (client) for MongoDB, a free, scalable, fast, document + DBMS +Description: This package lets you connect to MongoDB servers and + update/query their data. Please see the example in + Database.MongoDB and the tutorial from the homepage. For + information about MongoDB itself, see www.mongodb.org. +Category: Database +Homepage: http://github.com/selectel/mongodb-haskell +Author: Tony Hannan +Maintainer: Fedor Gogolev +Copyright: Copyright (c) 2010-2012 10gen Inc. +License: OtherLicense +License-file: LICENSE +Cabal-version: >= 1.2 +Build-type: Simple +Stability: alpha + +Library + GHC-options: -Wall + GHC-prof-options: -auto-all + + Build-depends: array -any + , base <5 + , binary -any + , bson >= 0.2.0 && < 0.3.0 + , text + , bytestring -any + , containers -any + , mtl >= 2 + , cryptohash -any + , network -any + , parsec -any + , random -any + , random-shuffle -any + , monad-control >= 0.3.1 + , lifted-base >= 0.1.0.3 + , transformers-base >= 0.4.1 + + Exposed-modules: Database.MongoDB + Database.MongoDB.Admin + Database.MongoDB.Connection + Database.MongoDB.Internal.Protocol + Database.MongoDB.Internal.Util + Database.MongoDB.Query + System.IO.Pipeline + System.IO.Pool