Vergara_Tech/mongodb
2
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity

Replace hard tabs with spaces

Browse source
This commit is contained in:
Michael Snoyman 2013-12-26 16:57:33 +02:00
parent b128bc7a09
commit 756c9181cb
7 changed files with 575 additions and 575 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

8
Database/MongoDB.hs
View file

@ -40,10 +40,10 @@ Simple example below. Use with language extensions /OvererloadedStrings/ & /Exte
-} -}
module Database.MongoDB ( module Database.MongoDB (
module Data.Bson, module Data.Bson,
module Database.MongoDB.Connection, module Database.MongoDB.Connection,
module Database.MongoDB.Query, module Database.MongoDB.Query,
module Database.MongoDB.Admin module Database.MongoDB.Admin
) where ) where
import Data.Bson import Data.Bson

160
Database/MongoDB/Admin.hs
View file

@ -3,28 +3,28 @@
{-# LANGUAGE FlexibleContexts, OverloadedStrings, RecordWildCards #-} {-# LANGUAGE FlexibleContexts, OverloadedStrings, RecordWildCards #-}
module Database.MongoDB.Admin ( module Database.MongoDB.Admin (
-- * Admin -- * Admin
-- ** Collection -- ** Collection
CollectionOption(..), createCollection, renameCollection, dropCollection, CollectionOption(..), createCollection, renameCollection, dropCollection,
validateCollection, validateCollection,
-- ** Index -- ** Index
Index(..), IndexName, index, ensureIndex, createIndex, dropIndex, Index(..), IndexName, index, ensureIndex, createIndex, dropIndex,
getIndexes, dropIndexes, getIndexes, dropIndexes,
-- ** User -- ** User
allUsers, addUser, removeUser, allUsers, addUser, removeUser,
-- ** Database -- ** Database
admin, cloneDatabase, copyDatabase, dropDatabase, repairDatabase, admin, cloneDatabase, copyDatabase, dropDatabase, repairDatabase,
-- ** Server -- ** Server
serverBuildInfo, serverVersion, serverBuildInfo, serverVersion,
-- * Diagnotics -- * Diagnotics
-- ** Collection -- ** Collection
collectionStats, dataSize, storageSize, totalIndexSize, totalSize, collectionStats, dataSize, storageSize, totalIndexSize, totalSize,
-- ** Profiling -- ** Profiling
ProfilingLevel(..), getProfilingLevel, MilliSec, setProfilingLevel, ProfilingLevel(..), getProfilingLevel, MilliSec, setProfilingLevel,
-- ** Database -- ** Database
dbStats, OpNum, currentOp, killOp, dbStats, OpNum, currentOp, killOp,
-- ** Server -- ** Server
serverStatus serverStatus
) where ) where
import Prelude hiding (lookup) import Prelude hiding (lookup)
@ -71,17 +71,17 @@ createCollection opts col = runCommand $ ["create" =: col] ++ map coptElem opts
renameCollection :: (MonadIO' m) => Collection -> Collection -> Action m Document renameCollection :: (MonadIO' m) => Collection -> Collection -> Action m Document
-- ^ Rename first collection to second collection -- ^ Rename first collection to second collection
renameCollection from to = do renameCollection from to = do
db <- thisDatabase db <- thisDatabase
useDb admin $ runCommand ["renameCollection" =: db <.> from, "to" =: db <.> to, "dropTarget" =: True] useDb admin $ runCommand ["renameCollection" =: db <.> from, "to" =: db <.> to, "dropTarget" =: True]
dropCollection :: (MonadIO' m) => Collection -> Action 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). -- ^ 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 dropCollection coll = do
resetIndexCache resetIndexCache
r <- runCommand ["drop" =: coll] r <- runCommand ["drop" =: coll]
if true1 "ok" r then return True else do if true1 "ok" r then return True else do
if at "errmsg" r == ("ns not found" :: Text) then return False else if at "errmsg" r == ("ns not found" :: Text) then return False else
fail $ "dropCollection failed: " ++ show r fail $ "dropCollection failed: " ++ show r
validateCollection :: (MonadIO' m) => Collection -> Action m Document validateCollection :: (MonadIO' m) => Collection -> Action m Document
-- ^ This operation takes a while -- ^ This operation takes a while
@ -92,20 +92,20 @@ validateCollection coll = runCommand ["validate" =: coll]
type IndexName = Text type IndexName = Text
data Index = Index { data Index = Index {
iColl :: Collection, iColl :: Collection,
iKey :: Order, iKey :: Order,
iName :: IndexName, iName :: IndexName,
iUnique :: Bool, iUnique :: Bool,
iDropDups :: Bool iDropDups :: Bool
} deriving (Show, Eq) } deriving (Show, Eq)
idxDocument :: Index -> Database -> Document idxDocument :: Index -> Database -> Document
idxDocument Index{..} db = [ idxDocument Index{..} db = [
"ns" =: db <.> iColl, "ns" =: db <.> iColl,
"key" =: iKey, "key" =: iKey,
"name" =: iName, "name" =: iName,
"unique" =: iUnique, "unique" =: iUnique,
"dropDups" =: iDropDups ] "dropDups" =: iDropDups ]
index :: Collection -> Order -> Index index :: Collection -> Order -> Index
-- ^ Spec of index of ordered keys on collection. Name is generated from keys. Unique and dropDups are False. -- ^ Spec of index of ordered keys on collection. Name is generated from keys. Unique and dropDups are False.
@ -113,16 +113,16 @@ index coll keys = Index coll keys (genName keys) False False
genName :: Order -> IndexName genName :: Order -> IndexName
genName keys = T.intercalate "_" (map f keys) where genName keys = T.intercalate "_" (map f keys) where
f (k := v) = k `T.append` "_" `T.append` T.pack (show v) f (k := v) = k `T.append` "_" `T.append` T.pack (show v)
ensureIndex :: (MonadIO' m) => Index -> Action 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). -- ^ 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 ensureIndex idx = let k = (iColl idx, iName idx) in do
icache <- fetchIndexCache icache <- fetchIndexCache
set <- liftIO (readIORef icache) set <- liftIO (readIORef icache)
unless (Set.member k set) $ do unless (Set.member k set) $ do
accessMode master (createIndex idx) accessMode master (createIndex idx)
liftIO $ writeIORef icache (Set.insert k set) liftIO $ writeIORef icache (Set.insert k set)
createIndex :: (MonadIO' m) => Index -> Action m () createIndex :: (MonadIO' m) => Index -> Action m ()
-- ^ Create index on the server. This call goes to the server every time. -- ^ Create index on the server. This call goes to the server every time.
@ -131,20 +131,20 @@ createIndex idx = insert_ "system.indexes" . idxDocument idx =<< thisDatabase
dropIndex :: (MonadIO' m) => Collection -> IndexName -> Action m Document dropIndex :: (MonadIO' m) => Collection -> IndexName -> Action m Document
-- ^ Remove the index -- ^ Remove the index
dropIndex coll idxName = do dropIndex coll idxName = do
resetIndexCache resetIndexCache
runCommand ["deleteIndexes" =: coll, "index" =: idxName] runCommand ["deleteIndexes" =: coll, "index" =: idxName]
getIndexes :: (MonadIO m, MonadBaseControl IO m, Functor m) => Collection -> Action m [Document] getIndexes :: (MonadIO m, MonadBaseControl IO m, Functor m) => Collection -> Action m [Document]
-- ^ Get all indexes on this collection -- ^ Get all indexes on this collection
getIndexes coll = do getIndexes coll = do
db <- thisDatabase db <- thisDatabase
rest =<< find (select ["ns" =: db <.> coll] "system.indexes") rest =<< find (select ["ns" =: db <.> coll] "system.indexes")
dropIndexes :: (MonadIO' m) => Collection -> Action m Document dropIndexes :: (MonadIO' m) => Collection -> Action m Document
-- ^ Drop all indexes on this collection -- ^ Drop all indexes on this collection
dropIndexes coll = do dropIndexes coll = do
resetIndexCache resetIndexCache
runCommand ["deleteIndexes" =: coll, "index" =: ("*" :: Text)] runCommand ["deleteIndexes" =: coll, "index" =: ("*" :: Text)]
-- *** Index cache -- *** Index cache
@ -156,48 +156,48 @@ type IndexCache = IORef (Set (Collection, IndexName))
dbIndexCache :: DbIndexCache dbIndexCache :: DbIndexCache
-- ^ initialize cache and fork thread that clears it every 15 minutes -- ^ initialize cache and fork thread that clears it every 15 minutes
dbIndexCache = unsafePerformIO $ do dbIndexCache = unsafePerformIO $ do
table <- H.new table <- H.new
_ <- forkIO . forever $ threadDelay 900000000 >> clearDbIndexCache _ <- forkIO . forever $ threadDelay 900000000 >> clearDbIndexCache
return table return table
{-# NOINLINE dbIndexCache #-} {-# NOINLINE dbIndexCache #-}
clearDbIndexCache :: IO () clearDbIndexCache :: IO ()
clearDbIndexCache = do clearDbIndexCache = do
keys <- map fst <$> H.toList dbIndexCache keys <- map fst <$> H.toList dbIndexCache
mapM_ (H.delete dbIndexCache) keys mapM_ (H.delete dbIndexCache) keys
fetchIndexCache :: (MonadIO m) => Action m IndexCache fetchIndexCache :: (MonadIO m) => Action m IndexCache
-- ^ Get index cache for current database -- ^ Get index cache for current database
fetchIndexCache = do fetchIndexCache = do
db <- thisDatabase db <- thisDatabase
liftIO $ do liftIO $ do
mc <- H.lookup dbIndexCache db mc <- H.lookup dbIndexCache db
maybe (newIdxCache db) return mc maybe (newIdxCache db) return mc
where where
newIdxCache db = do newIdxCache db = do
idx <- newIORef Set.empty idx <- newIORef Set.empty
H.insert dbIndexCache db idx H.insert dbIndexCache db idx
return idx return idx
resetIndexCache :: (MonadIO m) => Action m () resetIndexCache :: (MonadIO m) => Action m ()
-- ^ reset index cache for current database -- ^ reset index cache for current database
resetIndexCache = do resetIndexCache = do
icache <- fetchIndexCache icache <- fetchIndexCache
liftIO (writeIORef icache Set.empty) liftIO (writeIORef icache Set.empty)
-- ** User -- ** User
allUsers :: (MonadIO m, MonadBaseControl IO m, Functor m) => Action m [Document] allUsers :: (MonadIO m, MonadBaseControl IO m, Functor m) => Action m [Document]
-- ^ Fetch all users of this database -- ^ Fetch all users of this database
allUsers = map (exclude ["_id"]) <$> (rest =<< find allUsers = map (exclude ["_id"]) <$> (rest =<< find
(select [] "system.users") {sort = ["user" =: (1 :: Int)], project = ["user" =: (1 :: Int), "readOnly" =: (1 :: Int)]}) (select [] "system.users") {sort = ["user" =: (1 :: Int)], project = ["user" =: (1 :: Int), "readOnly" =: (1 :: Int)]})
addUser :: (MonadIO' m) => Bool -> Username -> Password -> Action 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 -- ^ 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 addUser readOnly user pass = do
mu <- findOne (select ["user" =: user] "system.users") mu <- findOne (select ["user" =: user] "system.users")
let usr = merge ["readOnly" =: readOnly, "pwd" =: pwHash user pass] (maybe ["user" =: user] id mu) let usr = merge ["readOnly" =: readOnly, "pwd" =: pwHash user pass] (maybe ["user" =: user] id mu)
save "system.users" usr save "system.users" usr
removeUser :: (MonadIO m) => Username -> Action m () removeUser :: (MonadIO m) => Username -> Action m ()
removeUser user = delete (select ["user" =: user] "system.users") removeUser user = delete (select ["user" =: user] "system.users")
@ -215,12 +215,12 @@ cloneDatabase db fromHost = useDb db $ runCommand ["clone" =: showHostPort fromH
copyDatabase :: (MonadIO' m) => Database -> Host -> Maybe (Username, Password) -> Database -> Action 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. -- ^ 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 fromDb fromHost mup toDb = do copyDatabase fromDb fromHost mup toDb = do
let c = ["copydb" =: (1 :: Int), "fromhost" =: showHostPort fromHost, "fromdb" =: fromDb, "todb" =: toDb] let c = ["copydb" =: (1 :: Int), "fromhost" =: showHostPort fromHost, "fromdb" =: fromDb, "todb" =: toDb]
useDb admin $ case mup of useDb admin $ case mup of
Nothing -> runCommand c Nothing -> runCommand c
Just (usr, pss) -> do Just (usr, pss) -> do
n <- at "nonce" <$> runCommand ["copydbgetnonce" =: (1 :: Int), "fromhost" =: showHostPort fromHost] n <- at "nonce" <$> runCommand ["copydbgetnonce" =: (1 :: Int), "fromhost" =: showHostPort fromHost]
runCommand $ c ++ ["username" =: usr, "nonce" =: n, "key" =: pwKey n usr pss] runCommand $ c ++ ["username" =: usr, "nonce" =: n, "key" =: pwKey n usr pss]
dropDatabase :: (MonadIO' m) => Database -> Action m Document dropDatabase :: (MonadIO' m) => Database -> Action m Document
-- ^ Delete the given database! -- ^ Delete the given database!
@ -256,11 +256,11 @@ totalIndexSize c = at "totalIndexSize" <$> collectionStats c
totalSize :: (MonadIO m, MonadBaseControl IO m, MonadIO' m) => Collection -> Action m Int totalSize :: (MonadIO m, MonadBaseControl IO m, MonadIO' m) => Collection -> Action m Int
totalSize coll = do totalSize coll = do
x <- storageSize coll x <- storageSize coll
xs <- mapM isize =<< getIndexes coll xs <- mapM isize =<< getIndexes coll
return (foldl (+) x xs) return (foldl (+) x xs)
where where
isize idx = at "storageSize" <$> collectionStats (coll `T.append` ".$" `T.append` at "name" idx) isize idx = at "storageSize" <$> collectionStats (coll `T.append` ".$" `T.append` at "name" idx)
-- ** Profiling -- ** Profiling
@ -273,7 +273,7 @@ type MilliSec = Int
setProfilingLevel :: (MonadIO' m) => ProfilingLevel -> Maybe MilliSec -> Action m () setProfilingLevel :: (MonadIO' m) => ProfilingLevel -> Maybe MilliSec -> Action m ()
setProfilingLevel p mSlowMs = setProfilingLevel p mSlowMs =
runCommand (["profile" =: fromEnum p] ++ ("slowms" =? mSlowMs)) >> return () runCommand (["profile" =: fromEnum p] ++ ("slowms" =? mSlowMs)) >> return ()
-- ** Database -- ** Database

124
Database/MongoDB/Connection.hs
View file

@ -3,16 +3,16 @@
{-# LANGUAGE CPP, OverloadedStrings, ScopedTypeVariables, TupleSections #-} {-# LANGUAGE CPP, OverloadedStrings, ScopedTypeVariables, TupleSections #-}
module Database.MongoDB.Connection ( module Database.MongoDB.Connection (
-- * Util -- * Util
Secs, IOE, runIOE, Secs, IOE, runIOE,
-- * Connection -- * Connection
Pipe, close, isClosed, Pipe, close, isClosed,
-- * Server -- * Server
Host(..), PortID(..), defaultPort, host, showHostPort, readHostPort, Host(..), PortID(..), defaultPort, host, showHostPort, readHostPort,
readHostPortM, globalConnectTimeout, connect, connect', readHostPortM, globalConnectTimeout, connect, connect',
-- * Replica Set -- * Replica Set
ReplicaSetName, openReplicaSet, openReplicaSet', ReplicaSetName, openReplicaSet, openReplicaSet',
ReplicaSet, primary, secondaryOk, routedHost, closeReplicaSet, replSetName ReplicaSet, primary, secondaryOk, routedHost, closeReplicaSet, replSetName
) where ) where
import Prelude hiding (lookup) import Prelude hiding (lookup)
@ -49,10 +49,10 @@ import System.IO.Pipeline (IOE, close, isClosed)
adminCommand :: Command -> Pipe -> IOE Document adminCommand :: Command -> Pipe -> IOE Document
-- ^ Run command against admin database on server connected to pipe. Fail if connection fails. -- ^ Run command against admin database on server connected to pipe. Fail if connection fails.
adminCommand cmd pipe = adminCommand cmd pipe =
liftIOE failureToIOError . ErrorT $ access pipe slaveOk "admin" $ runCommand cmd liftIOE failureToIOError . ErrorT $ access pipe slaveOk "admin" $ runCommand cmd
where where
failureToIOError (ConnectionFailure e) = e failureToIOError (ConnectionFailure e) = e
failureToIOError e = userError $ show e failureToIOError e = userError $ show e
-- * Host -- * Host
@ -70,26 +70,26 @@ showHostPort :: Host -> String
-- ^ Display host as \"host:port\" -- ^ Display host as \"host:port\"
-- TODO: Distinguish Service and UnixSocket port -- TODO: Distinguish Service and UnixSocket port
showHostPort (Host hostname port) = hostname ++ ":" ++ portname where showHostPort (Host hostname port) = hostname ++ ":" ++ portname where
portname = case port of portname = case port of
Service s -> s Service s -> s
PortNumber p -> show p PortNumber p -> show p
#if !defined(mingw32_HOST_OS) && !defined(cygwin32_HOST_OS) && !defined(_WIN32) #if !defined(mingw32_HOST_OS) && !defined(cygwin32_HOST_OS) && !defined(_WIN32)
UnixSocket s -> s UnixSocket s -> s
#endif #endif
readHostPortM :: (Monad m) => String -> m Host readHostPortM :: (Monad m) => String -> m Host
-- ^ Read string \"hostname:port\" as @Host hosthame (PortNumber port)@ or \"hostname\" as @host hostname@ (default port). Fail if string does not match either syntax. -- ^ Read string \"hostname:port\" as @Host hosthame (PortNumber port)@ or \"hostname\" as @host hostname@ (default port). Fail if string does not match either syntax.
-- TODO: handle Service and UnixSocket port -- TODO: handle Service and UnixSocket port
readHostPortM = either (fail . show) return . parse parser "readHostPort" where readHostPortM = either (fail . show) return . parse parser "readHostPort" where
hostname = many1 (letter <|> digit <|> char '-' <|> char '.') hostname = many1 (letter <|> digit <|> char '-' <|> char '.')
parser = do parser = do
spaces spaces
h <- hostname h <- hostname
try (spaces >> eof >> return (host h)) <|> do try (spaces >> eof >> return (host h)) <|> do
_ <- char ':' _ <- char ':'
port :: Int <- read <$> many1 digit port :: Int <- read <$> many1 digit
spaces >> eof spaces >> eof
return $ Host h (PortNumber $ fromIntegral port) return $ Host h (PortNumber $ fromIntegral port)
readHostPort :: String -> Host readHostPort :: String -> Host
-- ^ Read string \"hostname:port\" as @Host hostname (PortNumber port)@ or \"hostname\" as @host hostname@ (default port). Error if string does not match either syntax. -- ^ Read string \"hostname:port\" as @Host hostname (PortNumber port)@ or \"hostname\" as @host hostname@ (default port). Error if string does not match either syntax.
@ -109,10 +109,10 @@ connect h = lift (readIORef globalConnectTimeout) >>= flip connect' h
connect' :: Secs -> Host -> IOE Pipe connect' :: Secs -> Host -> IOE Pipe
-- ^ Connect to Host returning pipelined TCP connection. Throw IOError if connection refused or no response within given number of seconds. -- ^ Connect to Host returning pipelined TCP connection. Throw IOError if connection refused or no response within given number of seconds.
connect' timeoutSecs (Host hostname port) = do connect' timeoutSecs (Host hostname port) = do
handle <- ErrorT . E.try $ do handle <- ErrorT . E.try $ do
mh <- timeout (round $ timeoutSecs * 1000000) (connectTo hostname port) mh <- timeout (round $ timeoutSecs * 1000000) (connectTo hostname port)
maybe (ioError $ userError "connect timed out") return mh maybe (ioError $ userError "connect timed out") return mh
lift $ newPipe handle lift $ newPipe handle
-- * Replica Set -- * Replica Set
@ -132,10 +132,10 @@ openReplicaSet rsSeed = lift (readIORef globalConnectTimeout) >>= flip openRepli
openReplicaSet' :: Secs -> (ReplicaSetName, [Host]) -> IOE ReplicaSet openReplicaSet' :: Secs -> (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. Supplied seconds timeout is used for connect attempts to members. -- ^ Open connections (on demand) to servers in replica set. Supplied hosts is seed list. At least one of them must be a live member of the named replica set, otherwise fail. Supplied seconds timeout is used for connect attempts to members.
openReplicaSet' timeoutSecs (rsName, seedList) = do openReplicaSet' timeoutSecs (rsName, seedList) = do
vMembers <- newMVar (map (, Nothing) seedList) vMembers <- newMVar (map (, Nothing) seedList)
let rs = ReplicaSet rsName vMembers timeoutSecs let rs = ReplicaSet rsName vMembers timeoutSecs
_ <- updateMembers rs _ <- updateMembers rs
return rs return rs
closeReplicaSet :: ReplicaSet -> IO () closeReplicaSet :: ReplicaSet -> IO ()
-- ^ Close all connections to replica set -- ^ Close all connections to replica set
@ -144,18 +144,18 @@ closeReplicaSet (ReplicaSet _ vMembers _) = withMVar vMembers $ mapM_ (maybe (re
primary :: ReplicaSet -> IOE Pipe primary :: ReplicaSet -> IOE Pipe
-- ^ Return connection to current primary of replica set. Fail if no primary available. -- ^ Return connection to current primary of replica set. Fail if no primary available.
primary rs@(ReplicaSet rsName _ _) = do primary rs@(ReplicaSet rsName _ _) = do
mHost <- statedPrimary <$> updateMembers rs mHost <- statedPrimary <$> updateMembers rs
case mHost of case mHost of
Just host' -> connection rs Nothing host' Just host' -> connection rs Nothing host'
Nothing -> throwError $ userError $ "replica set " ++ T.unpack rsName ++ " has no primary" Nothing -> throwError $ userError $ "replica set " ++ T.unpack rsName ++ " has no primary"
secondaryOk :: ReplicaSet -> IOE Pipe secondaryOk :: ReplicaSet -> IOE Pipe
-- ^ Return connection to a random secondary, or primary if no secondaries available. -- ^ Return connection to a random secondary, or primary if no secondaries available.
secondaryOk rs = do secondaryOk rs = do
info <- updateMembers rs info <- updateMembers rs
hosts <- lift $ shuffle (possibleHosts info) hosts <- lift $ shuffle (possibleHosts info)
let hosts' = maybe hosts (\p -> delete p hosts ++ [p]) (statedPrimary info) let hosts' = maybe hosts (\p -> delete p hosts ++ [p]) (statedPrimary info)
untilSuccess (connection rs Nothing) hosts' untilSuccess (connection rs Nothing) hosts'
routedHost :: ((Host, Bool) -> (Host, Bool) -> IOE Ordering) -> ReplicaSet -> IOE Pipe 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. -- ^ 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.
@ -180,37 +180,37 @@ possibleHosts (_, info) = map readHostPort $ at "hosts" info
updateMembers :: ReplicaSet -> IOE ReplicaInfo updateMembers :: ReplicaSet -> IOE ReplicaInfo
-- ^ Fetch replica info from any server and update members accordingly -- ^ Fetch replica info from any server and update members accordingly
updateMembers rs@(ReplicaSet _ vMembers _) = do updateMembers rs@(ReplicaSet _ vMembers _) = do
(host', info) <- untilSuccess (fetchReplicaInfo rs) =<< readMVar vMembers (host', info) <- untilSuccess (fetchReplicaInfo rs) =<< readMVar vMembers
modifyMVar vMembers $ \members -> do modifyMVar vMembers $ \members -> do
let ((members', old), new) = intersection (map readHostPort $ at "hosts" info) members let ((members', old), new) = intersection (map readHostPort $ at "hosts" info) members
lift $ forM_ old $ \(_, mPipe) -> maybe (return ()) close mPipe lift $ forM_ old $ \(_, mPipe) -> maybe (return ()) close mPipe
return (members' ++ map (, Nothing) new, (host', info)) return (members' ++ map (, Nothing) new, (host', info))
where where
intersection :: (Eq k) => [k] -> [(k, v)] -> (([(k, v)], [(k, v)]), [k]) intersection :: (Eq k) => [k] -> [(k, v)] -> (([(k, v)], [(k, v)]), [k])
intersection keys assocs = (partition (flip elem inKeys . fst) assocs, keys \\ inKeys) where intersection keys assocs = (partition (flip elem inKeys . fst) assocs, keys \\ inKeys) where
assocKeys = map fst assocs assocKeys = map fst assocs
inKeys = intersect keys assocKeys inKeys = intersect keys assocKeys
fetchReplicaInfo :: ReplicaSet -> (Host, Maybe Pipe) -> IOE ReplicaInfo 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. -- 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 fetchReplicaInfo rs@(ReplicaSet rsName _ _) (host', mPipe) = do
pipe <- connection rs mPipe host' pipe <- connection rs mPipe host'
info <- adminCommand ["isMaster" =: (1 :: Int)] pipe info <- adminCommand ["isMaster" =: (1 :: Int)] pipe
case B.lookup "setName" info of case B.lookup "setName" info of
Nothing -> throwError $ userError $ show host' ++ " not a member of any replica set, including " ++ T.unpack rsName ++ ": " ++ show info 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 setName | setName /= rsName -> throwError $ userError $ show host' ++ " not a member of replica set " ++ T.unpack rsName ++ ": " ++ show info
Just _ -> return (host', info) Just _ -> return (host', info)
connection :: ReplicaSet -> Maybe Pipe -> Host -> IOE Pipe 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. -- ^ 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 timeoutSecs) mPipe host' = connection (ReplicaSet _ vMembers timeoutSecs) mPipe host' =
maybe conn (\p -> lift (isClosed p) >>= \bad -> if bad then conn else return p) mPipe maybe conn (\p -> lift (isClosed p) >>= \bad -> if bad then conn else return p) mPipe
where where
conn = modifyMVar vMembers $ \members -> do conn = modifyMVar vMembers $ \members -> do
let new = connect' timeoutSecs host' >>= \pipe -> return (updateAssocs host' (Just pipe) members, pipe) let new = connect' timeoutSecs host' >>= \pipe -> return (updateAssocs host' (Just pipe) members, pipe)
case List.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) Just (Just pipe) -> lift (isClosed pipe) >>= \bad -> if bad then new else return (members, pipe)
_ -> new _ -> new
{- Authors: Tony Hannan <tony@10gen.com> {- Authors: Tony Hannan <tony@10gen.com>

264
Database/MongoDB/Internal/Protocol.hs
View file

@ -9,17 +9,17 @@
{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, UndecidableInstances #-} {-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, UndecidableInstances #-}
module Database.MongoDB.Internal.Protocol ( module Database.MongoDB.Internal.Protocol (
FullCollection, FullCollection,
-- * Pipe -- * Pipe
Pipe, newPipe, send, call, Pipe, newPipe, send, call,
-- ** Notice -- ** Notice
Notice(..), InsertOption(..), UpdateOption(..), DeleteOption(..), CursorId, Notice(..), InsertOption(..), UpdateOption(..), DeleteOption(..), CursorId,
-- ** Request -- ** Request
Request(..), QueryOption(..), Request(..), QueryOption(..),
-- ** Reply -- ** Reply
Reply(..), ResponseFlag(..), Reply(..), ResponseFlag(..),
-- * Authentication -- * Authentication
Username, Password, Nonce, pwHash, pwKey Username, Password, Nonce, pwHash, pwKey
) where ) where
import Control.Applicative ((<$>)) import Control.Applicative ((<$>))
@ -68,12 +68,12 @@ send pipe notices = P.send pipe (notices, Nothing)
call :: Pipe -> [Notice] -> Request -> IOE (IOE Reply) call :: Pipe -> [Notice] -> Request -> IOE (IOE 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 and resulting promise will throw IOError if connection fails. -- ^ Send notices and request as a contiguous batch to server and return reply promise, which will block when invoked until reply arrives. This call and resulting promise will throw IOError if connection fails.
call pipe notices request = do call pipe notices request = do
requestId <- genRequestId requestId <- genRequestId
promise <- P.call pipe (notices, Just (request, requestId)) promise <- P.call pipe (notices, Just (request, requestId))
return $ check requestId <$> promise return $ check requestId <$> promise
where where
check requestId (responseTo, reply) = if requestId == responseTo then reply else check requestId (responseTo, reply) = if requestId == responseTo then reply else
error $ "expected response id (" ++ show responseTo ++ ") to match request id (" ++ show requestId ++ ")" error $ "expected response id (" ++ show responseTo ++ ") to match request id (" ++ show requestId ++ ")"
-- * Message -- * Message
@ -84,17 +84,17 @@ type Message = ([Notice], Maybe (Request, RequestId))
writeMessage :: Handle -> Message -> IOE () writeMessage :: Handle -> Message -> IOE ()
-- ^ Write message to socket -- ^ Write message to socket
writeMessage handle (notices, mRequest) = ErrorT . try $ do writeMessage handle (notices, mRequest) = ErrorT . try $ do
forM_ notices $ \n -> writeReq . (Left n,) =<< genRequestId forM_ notices $ \n -> writeReq . (Left n,) =<< genRequestId
whenJust mRequest $ writeReq . (Right *** id) whenJust mRequest $ writeReq . (Right *** id)
hFlush handle hFlush handle
where where
writeReq (e, requestId) = do writeReq (e, requestId) = do
L.hPut handle lenBytes L.hPut handle lenBytes
L.hPut handle bytes L.hPut handle bytes
where where
bytes = runPut $ (either putNotice putRequest e) requestId bytes = runPut $ (either putNotice putRequest e) requestId
lenBytes = encodeSize . toEnum . fromEnum $ L.length bytes lenBytes = encodeSize . toEnum . fromEnum $ L.length bytes
encodeSize = runPut . putInt32 . (+ 4) encodeSize = runPut . putInt32 . (+ 4)
type Response = (ResponseTo, Reply) type Response = (ResponseTo, Reply)
-- ^ Message received from a Mongo server in response to a Request -- ^ Message received from a Mongo server in response to a Request
@ -102,10 +102,10 @@ type Response = (ResponseTo, Reply)
readMessage :: Handle -> IOE Response readMessage :: Handle -> IOE Response
-- ^ read response from socket -- ^ read response from socket
readMessage handle = ErrorT $ try readResp where readMessage handle = ErrorT $ try readResp where
readResp = do readResp = do
len <- fromEnum . decodeSize <$> hGetN handle 4 len <- fromEnum . decodeSize <$> hGetN handle 4
runGet getReply <$> hGetN handle len runGet getReply <$> hGetN handle len
decodeSize = subtract 4 . runGet getInt32 decodeSize = subtract 4 . runGet getInt32
type FullCollection = Text type FullCollection = Text
-- ^ Database name and collection name with period (.) in between. Eg. \"myDb.myCollection\" -- ^ Database name and collection name with period (.) in between. Eg. \"myDb.myCollection\"
@ -122,58 +122,58 @@ type ResponseTo = RequestId
genRequestId :: (MonadIO m) => m RequestId genRequestId :: (MonadIO m) => m RequestId
-- ^ Generate fresh request id -- ^ Generate fresh request id
genRequestId = liftIO $ atomicModifyIORef counter $ \n -> (n + 1, n) where genRequestId = liftIO $ atomicModifyIORef counter $ \n -> (n + 1, n) where
counter :: IORef RequestId counter :: IORef RequestId
counter = unsafePerformIO (newIORef 0) counter = unsafePerformIO (newIORef 0)
{-# NOINLINE counter #-} {-# NOINLINE counter #-}
-- *** Binary format -- *** Binary format
putHeader :: Opcode -> RequestId -> Put putHeader :: Opcode -> RequestId -> Put
-- ^ Note, does not write message length (first int32), assumes caller will write it -- ^ Note, does not write message length (first int32), assumes caller will write it
putHeader opcode requestId = do putHeader opcode requestId = do
putInt32 requestId putInt32 requestId
putInt32 0 putInt32 0
putInt32 opcode putInt32 opcode
getHeader :: Get (Opcode, ResponseTo) getHeader :: Get (Opcode, ResponseTo)
-- ^ Note, does not read message length (first int32), assumes it was already read -- ^ Note, does not read message length (first int32), assumes it was already read
getHeader = do getHeader = do
_requestId <- getInt32 _requestId <- getInt32
responseTo <- getInt32 responseTo <- getInt32
opcode <- getInt32 opcode <- getInt32
return (opcode, responseTo) return (opcode, responseTo)
-- ** Notice -- ** Notice
-- | A notice is a message that is sent with no reply -- | A notice is a message that is sent with no reply
data Notice = data Notice =
Insert { Insert {
iFullCollection :: FullCollection, iFullCollection :: FullCollection,
iOptions :: [InsertOption], iOptions :: [InsertOption],
iDocuments :: [Document]} iDocuments :: [Document]}
| Update { | Update {
uFullCollection :: FullCollection, uFullCollection :: FullCollection,
uOptions :: [UpdateOption], uOptions :: [UpdateOption],
uSelector :: Document, uSelector :: Document,
uUpdater :: Document} uUpdater :: Document}
| Delete { | Delete {
dFullCollection :: FullCollection, dFullCollection :: FullCollection,
dOptions :: [DeleteOption], dOptions :: [DeleteOption],
dSelector :: Document} dSelector :: Document}
| KillCursors { | KillCursors {
kCursorIds :: [CursorId]} kCursorIds :: [CursorId]}
deriving (Show, Eq) deriving (Show, Eq)
data InsertOption = KeepGoing -- ^ If set, the database will not stop processing a bulk insert if one fails (eg due to duplicate IDs). This makes bulk insert behave similarly to a series of single inserts, except lastError will be set if any insert fails, not just the last one. (new in 1.9.1) data InsertOption = KeepGoing -- ^ If set, the database will not stop processing a bulk insert if one fails (eg due to duplicate IDs). This makes bulk insert behave similarly to a series of single inserts, except lastError will be set if any insert fails, not just the last one. (new in 1.9.1)
deriving (Show, Eq) deriving (Show, Eq)
data UpdateOption = data UpdateOption =
Upsert -- ^ If set, the database will insert the supplied object into the collection if no matching document is found Upsert -- ^ If set, the database will insert the supplied object into the collection if no matching document is found
| MultiUpdate -- ^ If set, the database will update all matching objects in the collection. Otherwise only updates first matching doc | MultiUpdate -- ^ If set, the database will update all matching objects in the collection. Otherwise only updates first matching doc
deriving (Show, Eq) deriving (Show, Eq)
data DeleteOption = SingleRemove -- ^ If set, the database will remove only the first matching document in the collection. Otherwise all matching documents will be removed data DeleteOption = SingleRemove -- ^ If set, the database will remove only the first matching document in the collection. Otherwise all matching documents will be removed
deriving (Show, Eq) deriving (Show, Eq)
type CursorId = Int64 type CursorId = Int64
@ -187,27 +187,27 @@ nOpcode KillCursors{} = 2007
putNotice :: Notice -> RequestId -> Put putNotice :: Notice -> RequestId -> Put
putNotice notice requestId = do putNotice notice requestId = do
putHeader (nOpcode notice) requestId putHeader (nOpcode notice) requestId
case notice of case notice of
Insert{..} -> do Insert{..} -> do
putInt32 (iBits iOptions) putInt32 (iBits iOptions)
putCString iFullCollection putCString iFullCollection
mapM_ putDocument iDocuments mapM_ putDocument iDocuments
Update{..} -> do Update{..} -> do
putInt32 0 putInt32 0
putCString uFullCollection putCString uFullCollection
putInt32 (uBits uOptions) putInt32 (uBits uOptions)
putDocument uSelector putDocument uSelector
putDocument uUpdater putDocument uUpdater
Delete{..} -> do Delete{..} -> do
putInt32 0 putInt32 0
putCString dFullCollection putCString dFullCollection
putInt32 (dBits dOptions) putInt32 (dBits dOptions)
putDocument dSelector putDocument dSelector
KillCursors{..} -> do KillCursors{..} -> do
putInt32 0 putInt32 0
putInt32 $ toEnum (length kCursorIds) putInt32 $ toEnum (length kCursorIds)
mapM_ putInt64 kCursorIds mapM_ putInt64 kCursorIds
iBit :: InsertOption -> Int32 iBit :: InsertOption -> Int32
iBit KeepGoing = bit 0 iBit KeepGoing = bit 0
@ -232,28 +232,28 @@ dBits = bitOr . map dBit
-- | A request is a message that is sent with a 'Reply' expected in return -- | A request is a message that is sent with a 'Reply' expected in return
data Request = data Request =
Query { Query {
qOptions :: [QueryOption], qOptions :: [QueryOption],
qFullCollection :: FullCollection, qFullCollection :: FullCollection,
qSkip :: Int32, -- ^ Number of initial matching documents to skip qSkip :: Int32, -- ^ Number of initial matching documents to skip
qBatchSize :: Int32, -- ^ The number of document to return in each batch response from the server. 0 means use Mongo default. Negative means close cursor after first batch and use absolute value as batch size. qBatchSize :: Int32, -- ^ The number of document to return in each batch response from the server. 0 means use Mongo default. Negative means close cursor after first batch and use absolute value as batch size.
qSelector :: Document, -- ^ \[\] = return all documents in collection qSelector :: Document, -- ^ \[\] = return all documents in collection
qProjector :: Document -- ^ \[\] = return whole document qProjector :: Document -- ^ \[\] = return whole document
} | GetMore { } | GetMore {
gFullCollection :: FullCollection, gFullCollection :: FullCollection,
gBatchSize :: Int32, gBatchSize :: Int32,
gCursorId :: CursorId} gCursorId :: CursorId}
deriving (Show, Eq) deriving (Show, Eq)
data QueryOption = 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. 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.
| SlaveOK -- ^ Allow query of replica slave. Normally these return an error except for namespace "local". | SlaveOK -- ^ Allow query of replica slave. Normally these return an error except for namespace "local".
| NoCursorTimeout -- ^ The server normally times out idle cursors after 10 minutes to prevent a memory leak in case a client forgets to close a cursor. Set this option to allow a cursor to live forever until it is closed. | NoCursorTimeout -- ^ The server normally times out idle cursors after 10 minutes to prevent a memory leak in case a client forgets to close a cursor. Set this option to allow a cursor to live forever until it is closed.
| 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. | 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.
-- | Exhaust -- ^ Stream the data down full blast in multiple "more" packages, on the assumption that the client will fully read all data queried. Faster when you are pulling a lot of data and know you want to pull it all down. Note: the client is not allowed to not read all the data unless it closes the connection. -- | Exhaust -- ^ Stream the data down full blast in multiple "more" packages, on the assumption that the client will fully read all data queried. Faster when you are pulling a lot of data and know you want to pull it all down. Note: the client is not allowed to not read all the data unless it closes the connection.
-- Exhaust commented out because not compatible with current `Pipeline` implementation -- Exhaust commented out because not compatible with current `Pipeline` implementation
| Partial -- ^ Get partial results from a _mongos_ if some shards are down, instead of throwing an error. | Partial -- ^ Get partial results from a _mongos_ if some shards are down, instead of throwing an error.
deriving (Show, Eq) deriving (Show, Eq)
-- *** Binary format -- *** Binary format
@ -263,20 +263,20 @@ qOpcode GetMore{} = 2005
putRequest :: Request -> RequestId -> Put putRequest :: Request -> RequestId -> Put
putRequest request requestId = do putRequest request requestId = do
putHeader (qOpcode request) requestId putHeader (qOpcode request) requestId
case request of case request of
Query{..} -> do Query{..} -> do
putInt32 (qBits qOptions) putInt32 (qBits qOptions)
putCString qFullCollection putCString qFullCollection
putInt32 qSkip putInt32 qSkip
putInt32 qBatchSize putInt32 qBatchSize
putDocument qSelector putDocument qSelector
unless (null qProjector) (putDocument qProjector) unless (null qProjector) (putDocument qProjector)
GetMore{..} -> do GetMore{..} -> do
putInt32 0 putInt32 0
putCString gFullCollection putCString gFullCollection
putInt32 gBatchSize putInt32 gBatchSize
putInt64 gCursorId putInt64 gCursorId
qBit :: QueryOption -> Int32 qBit :: QueryOption -> Int32
qBit TailableCursor = bit 1 qBit TailableCursor = bit 1
@ -293,17 +293,17 @@ qBits = bitOr . map qBit
-- | A reply is a message received in response to a 'Request' -- | A reply is a message received in response to a 'Request'
data Reply = Reply { data Reply = Reply {
rResponseFlags :: [ResponseFlag], rResponseFlags :: [ResponseFlag],
rCursorId :: CursorId, -- ^ 0 = cursor finished rCursorId :: CursorId, -- ^ 0 = cursor finished
rStartingFrom :: Int32, rStartingFrom :: Int32,
rDocuments :: [Document] rDocuments :: [Document]
} deriving (Show, Eq) } deriving (Show, Eq)
data ResponseFlag = data ResponseFlag =
CursorNotFound -- ^ Set when getMore is called but the cursor id is not valid at the server. Returned with zero results. CursorNotFound -- ^ Set when getMore is called but the cursor id is not valid at the server. Returned with zero results.
| QueryError -- ^ Query error. Returned with one document containing an "$err" field holding the error message. | QueryError -- ^ Query error. Returned with one document containing an "$err" field holding the error message.
| AwaitCapable -- ^ For backward compatability: Set when the server supports the AwaitData query option. if it doesn't, a replica slave client should sleep a little between getMore's | AwaitCapable -- ^ For backward compatability: Set when the server supports the AwaitData query option. if it doesn't, a replica slave client should sleep a little between getMore's
deriving (Show, Eq, Enum) deriving (Show, Eq, Enum)
-- * Binary format -- * Binary format
@ -312,14 +312,14 @@ replyOpcode = 1
getReply :: Get (ResponseTo, Reply) getReply :: Get (ResponseTo, Reply)
getReply = do getReply = do
(opcode, responseTo) <- getHeader (opcode, responseTo) <- getHeader
unless (opcode == replyOpcode) $ fail $ "expected reply opcode (1) but got " ++ show opcode unless (opcode == replyOpcode) $ fail $ "expected reply opcode (1) but got " ++ show opcode
rResponseFlags <- rFlags <$> getInt32 rResponseFlags <- rFlags <$> getInt32
rCursorId <- getInt64 rCursorId <- getInt64
rStartingFrom <- getInt32 rStartingFrom <- getInt32
numDocs <- fromIntegral <$> getInt32 numDocs <- fromIntegral <$> getInt32
rDocuments <- replicateM numDocs getDocument rDocuments <- replicateM numDocs getDocument
return (responseTo, Reply{..}) return (responseTo, Reply{..})
rFlags :: Int32 -> [ResponseFlag] rFlags :: Int32 -> [ResponseFlag]
rFlags bits = filter (testBit bits . rBit) [CursorNotFound ..] rFlags bits = filter (testBit bits . rBit) [CursorNotFound ..]

22
Database/MongoDB/Internal/Util.hs
View file

@ -98,7 +98,7 @@ runIOE (ErrorT action) = action >>= either ioError return
updateAssocs :: (Eq k) => k -> v -> [(k, v)] -> [(k, v)] updateAssocs :: (Eq k) => k -> v -> [(k, v)] -> [(k, v)]
-- ^ Change or insert value of key in association list -- ^ Change or insert value of key in association list
updateAssocs key valu assocs = case back of [] -> (key, valu) : front; _ : back' -> front ++ (key, valu) : back' updateAssocs key valu assocs = case back of [] -> (key, valu) : front; _ : back' -> front ++ (key, valu) : back'
where (front, back) = break ((key ==) . fst) assocs where (front, back) = break ((key ==) . fst) assocs
bitOr :: (Num a, Bits a) => [a] -> a bitOr :: (Num a, Bits a) => [a] -> a
-- ^ bit-or all numbers together -- ^ bit-or all numbers together
@ -111,20 +111,20 @@ a <.> b = T.append a (T.cons '.' b)
true1 :: Label -> Document -> Bool 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. -- ^ 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.
true1 k doc = case valueAt k doc of true1 k doc = case valueAt k doc of
Bool b -> b Bool b -> b
Float n -> n == 1 Float n -> n == 1
Int32 n -> n == 1 Int32 n -> n == 1
Int64 n -> n == 1 Int64 n -> n == 1
_ -> error $ "expected " ++ show k ++ " to be Num or Bool in " ++ show doc _ -> error $ "expected " ++ show k ++ " to be Num or Bool in " ++ show doc
hGetN :: Handle -> Int -> IO L.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. -- ^ 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 hGetN h n = assert (n >= 0) $ do
bytes <- L.hGet h n bytes <- L.hGet h n
let x = fromEnum $ L.length bytes let x = fromEnum $ L.length bytes
if x >= n then return bytes if x >= n then return bytes
else if x == 0 then ioError (mkIOError eofErrorType "hGetN" (Just h) Nothing) else if x == 0 then ioError (mkIOError eofErrorType "hGetN" (Just h) Nothing)
else L.append bytes <$> hGetN h (n - x) else L.append bytes <$> hGetN h (n - x)
byteStringHex :: S.ByteString -> String byteStringHex :: S.ByteString -> String
-- ^ Hexadecimal string representation of a byte string. Each byte yields two hexadecimal characters. -- ^ Hexadecimal string representation of a byte string. Each byte yields two hexadecimal characters.

482
Database/MongoDB/Query.hs
View file

@ -3,43 +3,43 @@
{-# LANGUAGE OverloadedStrings, RecordWildCards, NamedFieldPuns, TupleSections, FlexibleContexts, FlexibleInstances, UndecidableInstances, MultiParamTypeClasses, GeneralizedNewtypeDeriving, StandaloneDeriving, TypeSynonymInstances, TypeFamilies, CPP #-} {-# LANGUAGE OverloadedStrings, RecordWildCards, NamedFieldPuns, TupleSections, FlexibleContexts, FlexibleInstances, UndecidableInstances, MultiParamTypeClasses, GeneralizedNewtypeDeriving, StandaloneDeriving, TypeSynonymInstances, TypeFamilies, CPP #-}
module Database.MongoDB.Query ( module Database.MongoDB.Query (
-- * Monad -- * Monad
Action, access, Failure(..), ErrorCode, Action, access, Failure(..), ErrorCode,
AccessMode(..), GetLastError, master, slaveOk, accessMode, AccessMode(..), GetLastError, master, slaveOk, accessMode,
MonadDB(..), MonadDB(..),
-- * Database -- * Database
Database, allDatabases, useDb, thisDatabase, Database, allDatabases, useDb, thisDatabase,
-- ** Authentication -- ** Authentication
Username, Password, auth, Username, Password, auth,
-- * Collection -- * Collection
Collection, allCollections, Collection, allCollections,
-- ** Selection -- ** Selection
Selection(..), Selector, whereJS, Selection(..), Selector, whereJS,
Select(select), Select(select),
-- * Write -- * Write
-- ** Insert -- ** Insert
insert, insert_, insertMany, insertMany_, insertAll, insertAll_, insert, insert_, insertMany, insertMany_, insertAll, insertAll_,
-- ** Update -- ** Update
save, replace, repsert, Modifier, modify, save, replace, repsert, Modifier, modify,
-- ** Delete -- ** Delete
delete, deleteOne, delete, deleteOne,
-- * Read -- * Read
-- ** Query -- ** Query
Query(..), QueryOption(NoCursorTimeout, TailableCursor, AwaitData, Partial), Query(..), QueryOption(NoCursorTimeout, TailableCursor, AwaitData, Partial),
Projector, Limit, Order, BatchSize, Projector, Limit, Order, BatchSize,
explain, find, findOne, fetch, findAndModify, count, distinct, explain, find, findOne, fetch, findAndModify, count, distinct,
-- *** Cursor -- *** Cursor
Cursor, nextBatch, next, nextN, rest, closeCursor, isCursorClosed, Cursor, nextBatch, next, nextN, rest, closeCursor, isCursorClosed,
-- ** Aggregate -- ** Aggregate
Pipeline, aggregate, Pipeline, aggregate,
-- ** Group -- ** Group
Group(..), GroupKey(..), group, Group(..), GroupKey(..), group,
-- ** MapReduce -- ** MapReduce
MapReduce(..), MapFun, ReduceFun, FinalizeFun, MROut(..), MRMerge(..), MapReduce(..), MapFun, ReduceFun, FinalizeFun, MROut(..), MRMerge(..),
MRResult, mapReduce, runMR, runMR', MRResult, mapReduce, runMR, runMR',
-- * Command -- * Command
Command, runCommand, runCommand1, Command, runCommand, runCommand1,
eval, eval,
) where ) where
import Prelude hiding (lookup) import Prelude hiding (lookup)
@ -93,7 +93,7 @@ import qualified Database.MongoDB.Internal.Protocol as P
-- * Monad -- * Monad
newtype Action m a = Action {unAction :: ErrorT Failure (ReaderT Context m) a} newtype Action m a = Action {unAction :: ErrorT Failure (ReaderT Context m) a}
deriving (Functor, Applicative, Monad, MonadIO, MonadError Failure) deriving (Functor, Applicative, Monad, MonadIO, MonadError Failure)
-- ^ A monad on top of m (which must be a MonadIO) that may access the database and may fail with a DB 'Failure' -- ^ A monad on top of m (which must be a MonadIO) that may access the database and may fail with a DB 'Failure'
instance MonadBase b m => MonadBase b (Action m) where instance MonadBase b m => MonadBase b (Action m) where
@ -121,13 +121,13 @@ access myPipe myAccessMode myDatabase (Action action) = runReaderT (runErrorT ac
-- | A connection failure, or a read or write exception like cursor expired or inserting a duplicate key. -- | 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. -- 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 = data Failure =
ConnectionFailure IOError -- ^ TCP connection ('Pipeline') failed. May 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) | 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 ErrorCode String -- ^ Query failed for some reason as described in the string | QueryFailure ErrorCode 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 | WriteFailure ErrorCode String -- ^ Error observed by getLastError after a write, error description is in string
| DocNotFound Selection -- ^ 'fetch' found no document matching selection | DocNotFound Selection -- ^ 'fetch' found no document matching selection
| AggregateFailure String -- ^ 'aggregate' returned an error | AggregateFailure String -- ^ 'aggregate' returned an error
deriving (Show, Eq) deriving (Show, Eq)
type ErrorCode = Int type ErrorCode = Int
-- ^ Error code from getLastError or query failure -- ^ Error code from getLastError or query failure
@ -137,9 +137,9 @@ instance Error Failure where strMsg = error
-- | Type of reads and writes to perform -- | Type of reads and writes to perform
data AccessMode = data AccessMode =
ReadStaleOk -- ^ Read-only action, reading stale data from a slave is OK. ReadStaleOk -- ^ Read-only action, reading stale data from a slave is OK.
| UnconfirmedWrites -- ^ Read-write action, slave not OK, every write is fire & forget. | 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. | ConfirmWrites GetLastError -- ^ Read-write action, slave not OK, every write is confirmed with getLastError.
deriving Show deriving Show
type GetLastError = Document type GetLastError = Document
@ -168,9 +168,9 @@ writeMode (ConfirmWrites z) = Confirm z
-- | Values needed when executing a db operation -- | Values needed when executing a db operation
data Context = Context { data Context = Context {
myPipe :: Pipe, -- ^ operations read/write to this pipelined TCP connection to a MongoDB server myPipe :: Pipe, -- ^ operations read/write to this pipelined TCP connection to a MongoDB server
myAccessMode :: AccessMode, -- ^ read/write operation will use this access mode myAccessMode :: AccessMode, -- ^ read/write operation will use this access mode
myDatabase :: Database } -- ^ operations query/update this database myDatabase :: Database } -- ^ operations query/update this database
myReadMode :: Context -> ReadMode myReadMode :: Context -> ReadMode
myReadMode = readMode . myAccessMode myReadMode = readMode . myAccessMode
@ -181,40 +181,40 @@ myWriteMode = writeMode . myAccessMode
send :: (MonadIO m) => [Notice] -> Action m () send :: (MonadIO m) => [Notice] -> Action m ()
-- ^ Send notices as a contiguous batch to server with no reply. Throw 'ConnectionFailure' if pipe fails. -- ^ Send notices as a contiguous batch to server with no reply. Throw 'ConnectionFailure' if pipe fails.
send ns = Action $ do send ns = Action $ do
pipe <- asks myPipe pipe <- asks myPipe
liftIOE ConnectionFailure $ P.send pipe ns liftIOE ConnectionFailure $ P.send pipe ns
call :: (MonadIO m) => [Notice] -> Request -> Action m (ErrorT Failure IO Reply) 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. -- ^ 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 = Action $ do call ns r = Action $ do
pipe <- asks myPipe pipe <- asks myPipe
promise <- liftIOE ConnectionFailure $ P.call pipe ns r promise <- liftIOE ConnectionFailure $ P.call pipe ns r
return (liftIOE ConnectionFailure promise) return (liftIOE ConnectionFailure promise)
-- | If you stack a monad on top of 'Action' then make it an instance of this class and use 'liftDB' to execute a DB Action within it. Instances already exist for the basic mtl transformers. -- | If you stack a monad on top of 'Action' then make it an instance of this class and use 'liftDB' to execute a DB Action within it. Instances already exist for the basic mtl transformers.
class (Monad m, MonadBaseControl IO (BaseMonad m), Applicative (BaseMonad m), Functor (BaseMonad m)) => MonadDB m where class (Monad m, MonadBaseControl IO (BaseMonad m), Applicative (BaseMonad m), Functor (BaseMonad m)) => MonadDB m where
type BaseMonad m :: * -> * type BaseMonad m :: * -> *
liftDB :: Action (BaseMonad m) a -> m a liftDB :: Action (BaseMonad m) a -> m a
instance (MonadBaseControl IO m, Applicative m, Functor m) => MonadDB (Action m) where instance (MonadBaseControl IO m, Applicative m, Functor m) => MonadDB (Action m) where
type BaseMonad (Action m) = m type BaseMonad (Action m) = m
liftDB = id liftDB = id
instance (MonadDB m, Error e) => MonadDB (ErrorT e m) where instance (MonadDB m, Error e) => MonadDB (ErrorT e m) where
type BaseMonad (ErrorT e m) = BaseMonad m type BaseMonad (ErrorT e m) = BaseMonad m
liftDB = lift . liftDB liftDB = lift . liftDB
instance (MonadDB m) => MonadDB (ReaderT r m) where instance (MonadDB m) => MonadDB (ReaderT r m) where
type BaseMonad (ReaderT r m) = BaseMonad m type BaseMonad (ReaderT r m) = BaseMonad m
liftDB = lift . liftDB liftDB = lift . liftDB
instance (MonadDB m) => MonadDB (StateT s m) where instance (MonadDB m) => MonadDB (StateT s m) where
type BaseMonad (StateT s m) = BaseMonad m type BaseMonad (StateT s m) = BaseMonad m
liftDB = lift . liftDB liftDB = lift . liftDB
instance (MonadDB m, Monoid w) => MonadDB (WriterT w m) where instance (MonadDB m, Monoid w) => MonadDB (WriterT w m) where
type BaseMonad (WriterT w m) = BaseMonad m type BaseMonad (WriterT w m) = BaseMonad m
liftDB = lift . liftDB liftDB = lift . liftDB
instance (MonadDB m, Monoid w) => MonadDB (RWST r w s m) where instance (MonadDB m, Monoid w) => MonadDB (RWST r w s m) where
type BaseMonad (RWST r w s m) = BaseMonad m type BaseMonad (RWST r w s m) = BaseMonad m
liftDB = lift . liftDB liftDB = lift . liftDB
-- * Database -- * Database
@ -237,8 +237,8 @@ useDb db (Action act) = Action $ local (\ctx -> ctx {myDatabase = db}) act
auth :: (MonadIO' m) => Username -> Password -> Action m Bool 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. -- ^ 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 auth usr pss = do
n <- at "nonce" <$> runCommand ["getnonce" =: (1 :: Int)] n <- at "nonce" <$> runCommand ["getnonce" =: (1 :: Int)]
true1 "ok" <$> runCommand ["authenticate" =: (1 :: Int), "user" =: usr, "nonce" =: n, "key" =: pwKey n usr pss] true1 "ok" <$> runCommand ["authenticate" =: (1 :: Int), "user" =: usr, "nonce" =: n, "key" =: pwKey n usr pss]
-- * Collection -- * Collection
@ -248,12 +248,12 @@ type Collection = Text
allCollections :: (MonadIO m, MonadBaseControl IO m, Functor m) => Action m [Collection] allCollections :: (MonadIO m, MonadBaseControl IO m, Functor m) => Action m [Collection]
-- ^ List all collections in this database -- ^ List all collections in this database
allCollections = do allCollections = do
db <- thisDatabase db <- thisDatabase
docs <- rest =<< find (query [] "system.namespaces") {sort = ["name" =: (1 :: Int)]} docs <- rest =<< find (query [] "system.namespaces") {sort = ["name" =: (1 :: Int)]}
return . filter (not . isSpecial db) . map dropDbPrefix $ map (at "name") docs return . filter (not . isSpecial db) . map dropDbPrefix $ map (at "name") docs
where where
dropDbPrefix = T.tail . T.dropWhile (/= '.') dropDbPrefix = T.tail . T.dropWhile (/= '.')
isSpecial db col = T.any (== '$') col && db <.> col /= "local.oplog.$main" isSpecial db col = T.any (== '$') col && db <.> col /= "local.oplog.$main"
-- * Selection -- * Selection
@ -268,32 +268,32 @@ whereJS :: Selector -> Javascript -> Selector
whereJS sel js = ("$where" =: js) : sel whereJS sel js = ("$where" =: js) : sel
class Select aQueryOrSelection where class Select aQueryOrSelection where
select :: Selector -> Collection -> aQueryOrSelection select :: Selector -> Collection -> aQueryOrSelection
-- ^ 'Query' or 'Selection' that selects documents in collection that match selector. The choice of type depends on use, for example, in @find (select sel col)@ it is a Query, and in @delete (select sel col)@ it is a Selection. -- ^ 'Query' or 'Selection' that selects documents in collection that match selector. The choice of type depends on use, for example, in @find (select sel col)@ it is a Query, and in @delete (select sel col)@ it is a Selection.
instance Select Selection where instance Select Selection where
select = Select select = Select
instance Select Query where instance Select Query where
select = query select = query
-- * Write -- * Write
data WriteMode = data WriteMode =
NoConfirm -- ^ Submit writes without receiving acknowledgments. Fast. Assumes writes succeed even though they may not. NoConfirm -- ^ Submit writes without receiving acknowledgments. Fast. Assumes writes succeed even though they may not.
| Confirm GetLastError -- ^ Receive an acknowledgment after every write, and raise exception if one says the write failed. This is acomplished by sending the getLastError command, with given 'GetLastError' parameters, after every write. | Confirm GetLastError -- ^ Receive an acknowledgment after every write, and raise exception if one says the write failed. This is acomplished by sending the getLastError command, with given 'GetLastError' parameters, after every write.
deriving (Show, Eq) deriving (Show, Eq)
write :: (MonadIO m) => Notice -> Action 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. -- ^ Send write to server, and if write-mode is 'Safe' then include getLastError request and raise 'WriteFailure' if it reports an error.
write notice = Action (asks myWriteMode) >>= \mode -> case mode of write notice = Action (asks myWriteMode) >>= \mode -> case mode of
NoConfirm -> send [notice] NoConfirm -> send [notice]
Confirm params -> do Confirm params -> do
let q = query (("getlasterror" =: (1 :: Int)) : params) "$cmd" let q = query (("getlasterror" =: (1 :: Int)) : params) "$cmd"
Batch _ _ [doc] <- fulfill =<< request [notice] =<< queryRequest False q {limit = 1} Batch _ _ [doc] <- fulfill =<< request [notice] =<< queryRequest False q {limit = 1}
case lookup "err" doc of case lookup "err" doc of
Nothing -> return () Nothing -> return ()
Just err -> throwError $ WriteFailure (maybe 0 id $ lookup "code" doc) err Just err -> throwError $ WriteFailure (maybe 0 id $ lookup "code" doc) err
-- ** Insert -- ** Insert
@ -324,24 +324,24 @@ insertAll_ col docs = insertAll col docs >> return ()
insert' :: (MonadIO m) => [InsertOption] -> Collection -> [Document] -> Action m [Value] insert' :: (MonadIO m) => [InsertOption] -> Collection -> [Document] -> Action m [Value]
-- ^ Insert documents into collection and return their \"_id\" values, which are created automatically if not supplied -- ^ Insert documents into collection and return their \"_id\" values, which are created automatically if not supplied
insert' opts col docs = do insert' opts col docs = do
db <- thisDatabase db <- thisDatabase
docs' <- liftIO $ mapM assignId docs docs' <- liftIO $ mapM assignId docs
write (Insert (db <.> col) opts docs') write (Insert (db <.> col) opts docs')
return $ map (valueAt "_id") docs' return $ map (valueAt "_id") docs'
assignId :: Document -> IO Document assignId :: Document -> IO Document
-- ^ Assign a unique value to _id field if missing -- ^ Assign a unique value to _id field if missing
assignId doc = if any (("_id" ==) . label) doc assignId doc = if any (("_id" ==) . label) doc
then return doc then return doc
else (\oid -> ("_id" =: oid) : doc) <$> genObjectId else (\oid -> ("_id" =: oid) : doc) <$> genObjectId
-- ** Update -- ** Update
save :: (MonadIO' m) => Collection -> Document -> Action 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 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 save col doc = case look "_id" doc of
Nothing -> insert_ col doc Nothing -> insert_ col doc
Just i -> repsert (Select ["_id" := i] col) doc Just i -> repsert (Select ["_id" := i] col) doc
replace :: (MonadIO m) => Selection -> Document -> Action m () replace :: (MonadIO m) => Selection -> Document -> Action m ()
-- ^ Replace first document in selection with given document -- ^ Replace first document in selection with given document
@ -361,8 +361,8 @@ modify = update [MultiUpdate]
update :: (MonadIO m) => [UpdateOption] -> Selection -> Document -> Action 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 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 update opts (Select sel col) up = do
db <- thisDatabase db <- thisDatabase
write (Update (db <.> col) opts sel up) write (Update (db <.> col) opts sel up)
-- ** Delete -- ** Delete
@ -377,15 +377,15 @@ deleteOne = delete' [SingleRemove]
delete' :: (MonadIO m) => [DeleteOption] -> Selection -> Action 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 all documents in selection unless 'SingleRemove' option is given then only delete first document in selection
delete' opts (Select sel col) = do delete' opts (Select sel col) = do
db <- thisDatabase db <- thisDatabase
write (Delete (db <.> col) opts sel) write (Delete (db <.> col) opts sel)
-- * Read -- * Read
data ReadMode = data ReadMode =
Fresh -- ^ read from master only Fresh -- ^ read from master only
| StaleOk -- ^ read from slave ok | StaleOk -- ^ read from slave ok
deriving (Show, Eq) deriving (Show, Eq)
readModeOption :: ReadMode -> [QueryOption] readModeOption :: ReadMode -> [QueryOption]
readModeOption Fresh = [] readModeOption Fresh = []
@ -395,16 +395,16 @@ readModeOption StaleOk = [SlaveOK]
-- | Use 'select' to create a basic query with defaults, then modify if desired. For example, @(select sel col) {limit = 10}@ -- | Use 'select' to create a basic query with defaults, then modify if desired. For example, @(select sel col) {limit = 10}@
data Query = Query { data Query = Query {
options :: [QueryOption], -- ^ Default = [] options :: [QueryOption], -- ^ Default = []
selection :: Selection, selection :: Selection,
project :: Projector, -- ^ \[\] = all fields. Default = [] project :: Projector, -- ^ \[\] = all fields. Default = []
skip :: Word32, -- ^ Number of initial matching documents to skip. Default = 0 skip :: Word32, -- ^ Number of initial matching documents to skip. Default = 0
limit :: Limit, -- ^ Maximum number of documents to return, 0 = no limit. Default = 0 limit :: Limit, -- ^ Maximum number of documents to return, 0 = no limit. Default = 0
sort :: Order, -- ^ Sort results by this order, [] = no sort. Default = [] sort :: Order, -- ^ Sort results by this order, [] = no sort. Default = []
snapshot :: Bool, -- ^ If true assures no duplicates are returned, or objects missed, which were present at both the start and end of the query's execution (even if the object were updated). If an object is new during the query, or deleted during the query, it may or may not be returned, even with snapshot mode. Note that short query responses (less than 1MB) are always effectively snapshotted. Default = False snapshot :: Bool, -- ^ If true assures no duplicates are returned, or objects missed, which were present at both the start and end of the query's execution (even if the object were updated). If an object is new during the query, or deleted during the query, it may or may not be returned, even with snapshot mode. Note that short query responses (less than 1MB) are always effectively snapshotted. Default = False
batchSize :: BatchSize, -- ^ The number of document to return in each batch response from the server. 0 means use Mongo default. Default = 0 batchSize :: BatchSize, -- ^ The number of document to return in each batch response from the server. 0 means use Mongo default. Default = 0
hint :: Order -- ^ Force MongoDB to use this index, [] = no hint. Default = [] hint :: Order -- ^ Force MongoDB to use this index, [] = no hint. Default = []
} deriving (Show, Eq) } deriving (Show, Eq)
type Projector = Document 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@. -- ^ 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@.
@ -425,15 +425,15 @@ query sel col = Query [] (Select sel col) [] 0 0 [] False 0 []
find :: (MonadIO m, MonadBaseControl IO m) => Query -> Action m Cursor find :: (MonadIO m, MonadBaseControl IO m) => Query -> Action m Cursor
-- ^ Fetch documents satisfying query -- ^ Fetch documents satisfying query
find q@Query{selection, batchSize} = do find q@Query{selection, batchSize} = do
db <- thisDatabase db <- thisDatabase
dBatch <- request [] =<< queryRequest False q dBatch <- request [] =<< queryRequest False q
newCursor db (coll selection) batchSize dBatch newCursor db (coll selection) batchSize dBatch
findOne :: (MonadIO m) => Query -> Action m (Maybe Document) findOne :: (MonadIO m) => Query -> Action m (Maybe Document)
-- ^ Fetch first document satisfying query or Nothing if none satisfy it -- ^ Fetch first document satisfying query or Nothing if none satisfy it
findOne q = do findOne q = do
Batch _ _ docs <- fulfill =<< request [] =<< queryRequest False q {limit = 1} Batch _ _ docs <- fulfill =<< request [] =<< queryRequest False q {limit = 1}
return (listToMaybe docs) return (listToMaybe docs)
fetch :: (MonadIO m) => Query -> Action m Document fetch :: (MonadIO m) => Query -> Action m Document
-- ^ Same as 'findOne' except throw 'DocNotFound' if none match -- ^ Same as 'findOne' except throw 'DocNotFound' if none match
@ -481,14 +481,14 @@ findAndModify (Query {
explain :: (MonadIO m) => Query -> Action m Document explain :: (MonadIO m) => Query -> Action m Document
-- ^ Return performance stats of query execution -- ^ Return performance stats of query execution
explain q = do -- same as findOne but with explain set to true explain q = do -- same as findOne but with explain set to true
Batch _ _ docs <- fulfill =<< request [] =<< queryRequest True q {limit = 1} Batch _ _ docs <- fulfill =<< request [] =<< queryRequest True q {limit = 1}
return $ if null docs then error ("no explain: " ++ show q) else head docs return $ if null docs then error ("no explain: " ++ show q) else head docs
count :: (MonadIO' m) => Query -> Action m Int count :: (MonadIO' m) => Query -> Action m Int
-- ^ Fetch number of documents satisfying query (including effect of skip and/or limit if present) -- ^ 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 Query{selection = Select sel col, skip, limit} = at "n" <$> runCommand
(["count" =: col, "query" =: sel, "skip" =: (fromIntegral skip :: Int32)] (["count" =: col, "query" =: sel, "skip" =: (fromIntegral skip :: Int32)]
++ ("limit" =? if limit == 0 then Nothing else Just (fromIntegral limit :: Int32))) ++ ("limit" =? if limit == 0 then Nothing else Just (fromIntegral limit :: Int32)))
distinct :: (MonadIO' m) => Label -> Selection -> Action m [Value] distinct :: (MonadIO' m) => Label -> Selection -> Action m [Value]
-- ^ Fetch distinct values of field in selected documents -- ^ Fetch distinct values of field in selected documents
@ -497,31 +497,31 @@ distinct k (Select sel col) = at "values" <$> runCommand ["distinct" =: col, "ke
queryRequest :: (Monad m) => Bool -> Query -> Action m (Request, Limit) queryRequest :: (Monad m) => Bool -> Query -> Action m (Request, Limit)
-- ^ Translate Query to Protocol.Query. If first arg is true then add special $explain attribute. -- ^ Translate Query to Protocol.Query. If first arg is true then add special $explain attribute.
queryRequest isExplain Query{..} = do queryRequest isExplain Query{..} = do
ctx <- Action ask ctx <- Action ask
return $ queryRequest' (myReadMode ctx) (myDatabase ctx) return $ queryRequest' (myReadMode ctx) (myDatabase ctx)
where where
queryRequest' rm db = (P.Query{..}, remainingLimit) where queryRequest' rm db = (P.Query{..}, remainingLimit) where
qOptions = readModeOption rm ++ options qOptions = readModeOption rm ++ options
qFullCollection = db <.> coll selection qFullCollection = db <.> coll selection
qSkip = fromIntegral skip qSkip = fromIntegral skip
(qBatchSize, remainingLimit) = batchSizeRemainingLimit batchSize limit (qBatchSize, remainingLimit) = batchSizeRemainingLimit batchSize limit
qProjector = project qProjector = project
mOrder = if null sort then Nothing else Just ("$orderby" =: sort) mOrder = if null sort then Nothing else Just ("$orderby" =: sort)
mSnapshot = if snapshot then Just ("$snapshot" =: True) else Nothing mSnapshot = if snapshot then Just ("$snapshot" =: True) else Nothing
mHint = if null hint then Nothing else Just ("$hint" =: hint) mHint = if null hint then Nothing else Just ("$hint" =: hint)
mExplain = if isExplain then Just ("$explain" =: True) else Nothing mExplain = if isExplain then Just ("$explain" =: True) else Nothing
special = catMaybes [mOrder, mSnapshot, mHint, mExplain] special = catMaybes [mOrder, mSnapshot, mHint, mExplain]
qSelector = if null special then s else ("$query" =: s) : special where s = selector selection qSelector = if null special then s else ("$query" =: s) : special where s = selector selection
batchSizeRemainingLimit :: BatchSize -> Limit -> (Int32, Limit) batchSizeRemainingLimit :: BatchSize -> Limit -> (Int32, Limit)
-- ^ Given batchSize and limit return P.qBatchSize and remaining limit -- ^ Given batchSize and limit return P.qBatchSize and remaining limit
batchSizeRemainingLimit batchSize limit = if limit == 0 batchSizeRemainingLimit batchSize limit = if limit == 0
then (fromIntegral batchSize', 0) -- no limit then (fromIntegral batchSize', 0) -- no limit
else if 0 < batchSize' && batchSize' < limit else if 0 < batchSize' && batchSize' < limit
then (fromIntegral batchSize', limit - batchSize') then (fromIntegral batchSize', limit - batchSize')
else (- fromIntegral limit, 1) else (- fromIntegral limit, 1)
where batchSize' = if batchSize == 1 then 2 else batchSize where batchSize' = if batchSize == 1 then 2 else batchSize
-- batchSize 1 is broken because server converts 1 to -1 meaning limit 1 -- batchSize 1 is broken because server converts 1 to -1 meaning limit 1
type DelayedBatch = ErrorT Failure IO Batch type DelayedBatch = ErrorT Failure IO Batch
-- ^ A promised batch which may fail -- ^ A promised batch which may fail
@ -532,20 +532,20 @@ data Batch = Batch Limit CursorId [Document]
request :: (MonadIO m) => [Notice] -> (Request, Limit) -> Action m DelayedBatch request :: (MonadIO m) => [Notice] -> (Request, Limit) -> Action m DelayedBatch
-- ^ Send notices and request and return promised batch -- ^ Send notices and request and return promised batch
request ns (req, remainingLimit) = do request ns (req, remainingLimit) = do
promise <- call ns req promise <- call ns req
return $ fromReply remainingLimit =<< promise return $ fromReply remainingLimit =<< promise
fromReply :: Limit -> Reply -> DelayedBatch fromReply :: Limit -> Reply -> DelayedBatch
-- ^ Convert Reply to Batch or Failure -- ^ Convert Reply to Batch or Failure
fromReply limit Reply{..} = do fromReply limit Reply{..} = do
mapM_ checkResponseFlag rResponseFlags mapM_ checkResponseFlag rResponseFlags
return (Batch limit rCursorId rDocuments) return (Batch limit rCursorId rDocuments)
where where
-- If response flag indicates failure then throw it, otherwise do nothing -- If response flag indicates failure then throw it, otherwise do nothing
checkResponseFlag flag = case flag of checkResponseFlag flag = case flag of
AwaitCapable -> return () AwaitCapable -> return ()
CursorNotFound -> throwError $ CursorNotFoundFailure rCursorId CursorNotFound -> throwError $ CursorNotFoundFailure rCursorId
QueryError -> throwError $ QueryFailure (at "code" $ head rDocuments) (at "$err" $ head rDocuments) QueryError -> throwError $ QueryFailure (at "code" $ head rDocuments) (at "$err" $ head rDocuments)
fulfill :: (MonadIO m) => DelayedBatch -> Action m Batch fulfill :: (MonadIO m) => DelayedBatch -> Action m Batch
-- ^ Demand and wait for result, raise failure if exception -- ^ Demand and wait for result, raise failure if exception
@ -559,10 +559,10 @@ data Cursor = Cursor FullCollection BatchSize (MVar DelayedBatch)
newCursor :: (MonadIO m, MonadBaseControl IO m) => Database -> Collection -> BatchSize -> DelayedBatch -> Action m Cursor newCursor :: (MonadIO m, MonadBaseControl IO 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. -- ^ 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 db col batchSize dBatch = do newCursor db col batchSize dBatch = do
var <- newMVar dBatch var <- newMVar dBatch
let cursor = Cursor (db <.> col) batchSize var let cursor = Cursor (db <.> col) batchSize var
_ <- mkWeakMVar var (closeCursor cursor) _ <- mkWeakMVar var (closeCursor cursor)
return cursor return cursor
#if !MIN_VERSION_base(4,6,0) #if !MIN_VERSION_base(4,6,0)
where mkWeakMVar = addMVarFinalizer where mkWeakMVar = addMVarFinalizer
#endif #endif
@ -570,39 +570,39 @@ newCursor db col batchSize dBatch = do
nextBatch :: (MonadIO m, MonadBaseControl IO m) => Cursor -> Action m [Document] nextBatch :: (MonadIO m, MonadBaseControl IO m) => Cursor -> Action m [Document]
-- ^ Return next batch of documents in query result, which will be empty if finished. -- ^ Return next batch of documents in query result, which will be empty if finished.
nextBatch (Cursor fcol batchSize var) = modifyMVar var $ \dBatch -> do nextBatch (Cursor fcol batchSize var) = modifyMVar var $ \dBatch -> do
-- Pre-fetch next batch promise from server and return current batch. -- Pre-fetch next batch promise from server and return current batch.
Batch limit cid docs <- fulfill' fcol batchSize dBatch Batch limit cid docs <- fulfill' fcol batchSize dBatch
dBatch' <- if cid /= 0 then nextBatch' fcol batchSize limit cid else return $ return (Batch 0 0 []) dBatch' <- if cid /= 0 then nextBatch' fcol batchSize limit cid else return $ return (Batch 0 0 [])
return (dBatch', docs) return (dBatch', docs)
fulfill' :: (MonadIO m) => FullCollection -> BatchSize -> DelayedBatch -> Action m Batch fulfill' :: (MonadIO m) => FullCollection -> BatchSize -> DelayedBatch -> Action m Batch
-- Discard pre-fetched batch if empty with nonzero cid. -- Discard pre-fetched batch if empty with nonzero cid.
fulfill' fcol batchSize dBatch = do fulfill' fcol batchSize dBatch = do
b@(Batch limit cid docs) <- fulfill dBatch b@(Batch limit cid docs) <- fulfill dBatch
if cid /= 0 && null docs if cid /= 0 && null docs
then nextBatch' fcol batchSize limit cid >>= fulfill then nextBatch' fcol batchSize limit cid >>= fulfill
else return b else return b
nextBatch' :: (MonadIO m) => FullCollection -> BatchSize -> Limit -> CursorId -> Action m DelayedBatch nextBatch' :: (MonadIO m) => FullCollection -> BatchSize -> Limit -> CursorId -> Action m DelayedBatch
nextBatch' fcol batchSize limit cid = request [] (GetMore fcol batchSize' cid, remLimit) nextBatch' fcol batchSize limit cid = request [] (GetMore fcol batchSize' cid, remLimit)
where (batchSize', remLimit) = batchSizeRemainingLimit batchSize limit where (batchSize', remLimit) = batchSizeRemainingLimit batchSize limit
next :: (MonadIO m, MonadBaseControl IO m) => Cursor -> Action m (Maybe Document) next :: (MonadIO m, MonadBaseControl IO m) => Cursor -> Action m (Maybe Document)
-- ^ Return next document in query result, or Nothing if finished. -- ^ Return next document in query result, or Nothing if finished.
next (Cursor fcol batchSize 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. -- Pre-fetch next batch promise from server when last one in current batch is returned.
-- nextState:: DelayedBatch -> Action m (DelayedBatch, Maybe Document) -- nextState:: DelayedBatch -> Action m (DelayedBatch, Maybe Document)
nextState dBatch = do nextState dBatch = do
Batch limit cid docs <- fulfill' fcol batchSize dBatch Batch limit cid docs <- fulfill' fcol batchSize dBatch
case docs of case docs of
doc : docs' -> do doc : docs' -> do
dBatch' <- if null docs' && cid /= 0 dBatch' <- if null docs' && cid /= 0
then nextBatch' fcol batchSize limit cid then nextBatch' fcol batchSize limit cid
else return $ return (Batch limit cid docs') else return $ return (Batch limit cid docs')
return (dBatch', Just doc) return (dBatch', Just doc)
[] -> if cid == 0 [] -> if cid == 0
then return (return $ Batch 0 0 [], Nothing) -- finished then return (return $ Batch 0 0 [], Nothing) -- finished
else fmap (,Nothing) $ nextBatch' fcol batchSize limit cid else fmap (,Nothing) $ nextBatch' fcol batchSize limit cid
nextN :: (MonadIO m, MonadBaseControl IO m, Functor m) => Int -> Cursor -> Action m [Document] nextN :: (MonadIO m, MonadBaseControl IO m, Functor m) => Int -> Cursor -> Action m [Document]
-- ^ Return next N documents or less if end is reached -- ^ Return next N documents or less if end is reached
@ -614,14 +614,14 @@ rest c = loop (next c)
closeCursor :: (MonadIO m, MonadBaseControl IO m) => Cursor -> Action m () closeCursor :: (MonadIO m, MonadBaseControl IO m) => Cursor -> Action m ()
closeCursor (Cursor _ _ var) = modifyMVar var $ \dBatch -> do closeCursor (Cursor _ _ var) = modifyMVar var $ \dBatch -> do
Batch _ cid _ <- fulfill dBatch Batch _ cid _ <- fulfill dBatch
unless (cid == 0) $ send [KillCursors [cid]] unless (cid == 0) $ send [KillCursors [cid]]
return $ (return $ Batch 0 0 [], ()) return $ (return $ Batch 0 0 [], ())
isCursorClosed :: (MonadIO m, MonadBase IO m) => Cursor -> Action m Bool isCursorClosed :: (MonadIO m, MonadBase IO m) => Cursor -> Action m Bool
isCursorClosed (Cursor _ _ var) = do isCursorClosed (Cursor _ _ var) = do
Batch _ cid docs <- fulfill =<< readMVar var Batch _ cid docs <- fulfill =<< readMVar var
return (cid == 0 && null docs) return (cid == 0 && null docs)
-- ** Aggregate -- ** Aggregate
@ -631,22 +631,22 @@ type Pipeline = [Document]
aggregate :: MonadIO' m => Collection -> Pipeline -> Action m [Document] aggregate :: MonadIO' m => Collection -> Pipeline -> Action m [Document]
-- ^ Runs an aggregate and unpacks the result. See <http://docs.mongodb.org/manual/core/aggregation/> for details. -- ^ Runs an aggregate and unpacks the result. See <http://docs.mongodb.org/manual/core/aggregation/> for details.
aggregate aColl agg = do aggregate aColl agg = do
response <- runCommand ["aggregate" =: aColl, "pipeline" =: agg] response <- runCommand ["aggregate" =: aColl, "pipeline" =: agg]
case true1 "ok" response of case true1 "ok" response of
True -> lookup "result" response True -> lookup "result" response
False -> throwError $ AggregateFailure $ at "errmsg" response False -> throwError $ AggregateFailure $ at "errmsg" response
-- ** Group -- ** Group
-- | Groups documents in collection by key then reduces (aggregates) each group -- | Groups documents in collection by key then reduces (aggregates) each group
data Group = Group { data Group = Group {
gColl :: Collection, gColl :: Collection,
gKey :: GroupKey, -- ^ Fields to group by gKey :: GroupKey, -- ^ Fields to group by
gReduce :: Javascript, -- ^ @(doc, agg) -> ()@. The reduce function reduces (aggregates) the objects iterated. Typical operations of a reduce function include summing and counting. It takes two arguments, the current document being iterated over and the aggregation value, and updates the aggregate value. gReduce :: Javascript, -- ^ @(doc, agg) -> ()@. The reduce function reduces (aggregates) the objects iterated. Typical operations of a reduce function include summing and counting. It takes two arguments, the current document being iterated over and the aggregation value, and updates the aggregate value.
gInitial :: Document, -- ^ @agg@. Initial aggregation value supplied to reduce gInitial :: Document, -- ^ @agg@. Initial aggregation value supplied to reduce
gCond :: Selector, -- ^ Condition that must be true for a row to be considered. [] means always true. gCond :: Selector, -- ^ Condition that must be true for a row to be considered. [] means always true.
gFinalize :: Maybe Javascript -- ^ @agg -> () | result@. An optional function to be run on each item in the result set just before the item is returned. Can either modify the item (e.g., add an average field given a count and a total) or return a replacement object (returning a new object with just _id and average fields). gFinalize :: Maybe Javascript -- ^ @agg -> () | result@. An optional function to be run on each item in the result set just before the item is returned. Can either modify the item (e.g., add an average field given a count and a total) or return a replacement object (returning a new object with just _id and average fields).
} deriving (Show, Eq) } deriving (Show, Eq)
data GroupKey = Key [Label] | KeyF Javascript deriving (Show, Eq) data GroupKey = Key [Label] | KeyF Javascript deriving (Show, Eq)
-- ^ Fields to group by, or function (@doc -> key@) returning a "key object" to be used as the grouping key. Use KeyF instead of Key to specify a key that is not an existing member of the object (or, to access embedded members). -- ^ Fields to group by, or function (@doc -> key@) returning a "key object" to be used as the grouping key. Use KeyF instead of Key to specify a key that is not an existing member of the object (or, to access embedded members).
@ -654,12 +654,12 @@ data GroupKey = Key [Label] | KeyF Javascript deriving (Show, Eq)
groupDocument :: Group -> Document groupDocument :: Group -> Document
-- ^ Translate Group data into expected document form -- ^ Translate Group data into expected document form
groupDocument Group{..} = groupDocument Group{..} =
("finalize" =? gFinalize) ++ [ ("finalize" =? gFinalize) ++ [
"ns" =: gColl, "ns" =: gColl,
case gKey of Key k -> "key" =: map (=: True) k; KeyF f -> "$keyf" =: f, case gKey of Key k -> "key" =: map (=: True) k; KeyF f -> "$keyf" =: f,
"$reduce" =: gReduce, "$reduce" =: gReduce,
"initial" =: gInitial, "initial" =: gInitial,
"cond" =: gCond ] "cond" =: gCond ]
group :: (MonadIO' m) => Group -> Action m [Document] group :: (MonadIO' m) => Group -> Action m [Document]
-- ^ Execute group query and return resulting aggregate value for each distinct key -- ^ Execute group query and return resulting aggregate value for each distinct key
@ -670,17 +670,17 @@ group g = at "retval" <$> runCommand ["group" =: groupDocument g]
-- | Maps every document in collection to a list of (key, value) pairs, then for each unique key reduces all its associated values to a single result. There are additional parameters that may be set to tweak this basic operation. -- | Maps every document in collection to a list of (key, value) pairs, then for each unique key reduces all its associated values to a single result. There are additional parameters that may be set to tweak this basic operation.
-- This implements the latest version of map-reduce that requires MongoDB 1.7.4 or greater. To map-reduce against an older server use runCommand directly as described in http://www.mongodb.org/display/DOCS/MapReduce. -- This implements the latest version of map-reduce that requires MongoDB 1.7.4 or greater. To map-reduce against an older server use runCommand directly as described in http://www.mongodb.org/display/DOCS/MapReduce.
data MapReduce = MapReduce { data MapReduce = MapReduce {
rColl :: Collection, rColl :: Collection,
rMap :: MapFun, rMap :: MapFun,
rReduce :: ReduceFun, rReduce :: ReduceFun,
rSelect :: Selector, -- ^ Operate on only those documents selected. Default is [] meaning all documents. rSelect :: Selector, -- ^ Operate on only those documents selected. Default is [] meaning all documents.
rSort :: Order, -- ^ Default is [] meaning no sort rSort :: Order, -- ^ Default is [] meaning no sort
rLimit :: Limit, -- ^ Default is 0 meaning no limit rLimit :: Limit, -- ^ Default is 0 meaning no limit
rOut :: MROut, -- ^ Output to a collection with a certain merge policy. Default is no collection ('Inline'). Note, you don't want this default if your result set is large. rOut :: MROut, -- ^ Output to a collection with a certain merge policy. Default is no collection ('Inline'). Note, you don't want this default if your result set is large.
rFinalize :: Maybe FinalizeFun, -- ^ Function to apply to all the results when finished. Default is Nothing. rFinalize :: Maybe FinalizeFun, -- ^ Function to apply to all the results when finished. Default is Nothing.
rScope :: Document, -- ^ Variables (environment) that can be accessed from map/reduce/finalize. Default is []. rScope :: Document, -- ^ Variables (environment) that can be accessed from map/reduce/finalize. Default is [].
rVerbose :: Bool -- ^ Provide statistics on job execution time. Default is False. rVerbose :: Bool -- ^ Provide statistics on job execution time. Default is False.
} deriving (Show, Eq) } deriving (Show, Eq)
type MapFun = Javascript type MapFun = Javascript
-- ^ @() -> void@. The map function references the variable @this@ to inspect the current object under consideration. The function must call @emit(key,value)@ at least once, but may be invoked any number of times, as may be appropriate. -- ^ @() -> void@. The map function references the variable @this@ to inspect the current object under consideration. The function must call @emit(key,value)@ at least once, but may be invoked any number of times, as may be appropriate.
@ -692,15 +692,15 @@ type FinalizeFun = Javascript
-- ^ @(key, value) -> final_value@. A finalize function may be run after reduction. Such a function is optional and is not necessary for many map/reduce cases. The finalize function takes a key and a value, and returns a finalized value. -- ^ @(key, value) -> final_value@. A finalize function may be run after reduction. Such a function is optional and is not necessary for many map/reduce cases. The finalize function takes a key and a value, and returns a finalized value.
data MROut = data MROut =
Inline -- ^ Return results directly instead of writing them to an output collection. Results must fit within 16MB limit of a single document Inline -- ^ Return results directly instead of writing them to an output collection. Results must fit within 16MB limit of a single document
| Output MRMerge Collection (Maybe Database) -- ^ Write results to given collection, in other database if specified. Follow merge policy when entry already exists | Output MRMerge Collection (Maybe Database) -- ^ Write results to given collection, in other database if specified. Follow merge policy when entry already exists
deriving (Show, Eq) deriving (Show, Eq)
data MRMerge = data MRMerge =
Replace -- ^ Clear all old data and replace it with new data Replace -- ^ Clear all old data and replace it with new data
| Merge -- ^ Leave old data but overwrite entries with the same key with new data | Merge -- ^ Leave old data but overwrite entries with the same key with new data
| Reduce -- ^ Leave old data but combine entries with the same key via MR's reduce function | Reduce -- ^ Leave old data but combine entries with the same key via MR's reduce function
deriving (Show, Eq) deriving (Show, Eq)
type MRResult = Document type MRResult = Document
-- ^ Result of running a MapReduce has some stats besides the output. See http://www.mongodb.org/display/DOCS/MapReduce#MapReduce-Resultobject -- ^ Result of running a MapReduce has some stats besides the output. See http://www.mongodb.org/display/DOCS/MapReduce#MapReduce-Resultobject
@ -708,26 +708,26 @@ type MRResult = Document
mrDocument :: MapReduce -> Document mrDocument :: MapReduce -> Document
-- ^ Translate MapReduce data into expected document form -- ^ Translate MapReduce data into expected document form
mrDocument MapReduce{..} = mrDocument MapReduce{..} =
("mapreduce" =: rColl) : ("mapreduce" =: rColl) :
("out" =: mrOutDoc rOut) : ("out" =: mrOutDoc rOut) :
("finalize" =? rFinalize) ++ [ ("finalize" =? rFinalize) ++ [
"map" =: rMap, "map" =: rMap,
"reduce" =: rReduce, "reduce" =: rReduce,
"query" =: rSelect, "query" =: rSelect,
"sort" =: rSort, "sort" =: rSort,
"limit" =: (fromIntegral rLimit :: Int), "limit" =: (fromIntegral rLimit :: Int),
"scope" =: rScope, "scope" =: rScope,
"verbose" =: rVerbose ] "verbose" =: rVerbose ]
mrOutDoc :: MROut -> Document mrOutDoc :: MROut -> Document
-- ^ Translate MROut into expected document form -- ^ Translate MROut into expected document form
mrOutDoc Inline = ["inline" =: (1 :: Int)] mrOutDoc Inline = ["inline" =: (1 :: Int)]
mrOutDoc (Output mrMerge coll mDB) = (mergeName mrMerge =: coll) : mdb mDB where mrOutDoc (Output mrMerge coll mDB) = (mergeName mrMerge =: coll) : mdb mDB where
mergeName Replace = "replace" mergeName Replace = "replace"
mergeName Merge = "merge" mergeName Merge = "merge"
mergeName Reduce = "reduce" mergeName Reduce = "reduce"
mdb Nothing = [] mdb Nothing = []
mdb (Just db) = ["db" =: db] mdb (Just db) = ["db" =: db]
mapReduce :: Collection -> MapFun -> ReduceFun -> MapReduce 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 on collection with given map and reduce functions. Remaining attributes are set to their defaults, which are stated in their comments.
@ -736,18 +736,18 @@ mapReduce col map' red = MapReduce col map' red [] [] 0 Inline Nothing [] False
runMR :: (MonadIO m, MonadBaseControl IO m, Applicative m) => MapReduce -> Action m Cursor runMR :: (MonadIO m, MonadBaseControl IO m, Applicative m) => MapReduce -> Action m Cursor
-- ^ Run MapReduce and return cursor of results. Error if map/reduce fails (because of bad Javascript) -- ^ Run MapReduce and return cursor of results. Error if map/reduce fails (because of bad Javascript)
runMR mr = do runMR mr = do
res <- runMR' mr res <- runMR' mr
case look "result" res of case look "result" res of
Just (String coll) -> find $ query [] coll Just (String coll) -> find $ query [] coll
Just (Doc doc) -> useDb (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 Just x -> error $ "unexpected map-reduce result field: " ++ show x
Nothing -> newCursor "" "" 0 $ return $ Batch 0 0 (at "results" res) Nothing -> newCursor "" "" 0 $ return $ Batch 0 0 (at "results" res)
runMR' :: (MonadIO' m) => MapReduce -> Action 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). -- ^ 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 runMR' mr = do
doc <- runCommand (mrDocument mr) doc <- runCommand (mrDocument mr)
return $ if true1 "ok" doc then doc else error $ "mapReduce error:\n" ++ show doc ++ "\nin:\n" ++ show mr return $ if true1 "ok" doc then doc else error $ "mapReduce error:\n" ++ show doc ++ "\nin:\n" ++ show mr
-- * Command -- * Command
@ -757,7 +757,7 @@ type Command = Document
runCommand :: (MonadIO' m) => Command -> Action m Document runCommand :: (MonadIO' m) => Command -> Action m Document
-- ^ Run command against the database and return its result -- ^ Run command against the database and return its result
runCommand c = maybe err id <$> findOne (query c "$cmd") where runCommand c = maybe err id <$> findOne (query c "$cmd") where
err = error $ "Nothing returned for command: " ++ show c err = error $ "Nothing returned for command: " ++ show c
runCommand1 :: (MonadIO' m) => Text -> Action m Document runCommand1 :: (MonadIO' m) => Text -> Action m Document
-- ^ @runCommand1 foo = runCommand [foo =: 1]@ -- ^ @runCommand1 foo = runCommand [foo =: 1]@

90
System/IO/Pipeline.hs
View file

@ -12,11 +12,11 @@ A pipeline closes itself when a read or write causes an error, so you can detect
#endif #endif
module System.IO.Pipeline ( module System.IO.Pipeline (
IOE, IOE,
-- * IOStream -- * IOStream
IOStream(..), IOStream(..),
-- * Pipeline -- * Pipeline
Pipeline, newPipeline, send, call, close, isClosed Pipeline, newPipeline, send, call, close, isClosed
) where ) where
import Prelude hiding (length) import Prelude hiding (length)
@ -43,9 +43,9 @@ mkWeakMVar = addMVarFinalizer
onException :: (Monad m) => ErrorT e m a -> m () -> ErrorT e m a 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 -- ^ If first action throws an exception then run second action then re-throw
onException (ErrorT action) releaser = ErrorT $ do onException (ErrorT action) releaser = ErrorT $ do
e <- action e <- action
either (const releaser) (const $ return ()) e either (const releaser) (const $ return ()) e
return e return e
type IOE = ErrorT IOError IO type IOE = ErrorT IOError IO
-- ^ IO monad with explicit error -- ^ IO monad with explicit error
@ -54,59 +54,59 @@ type IOE = ErrorT IOError IO
-- | An IO sink and source where value of type @o@ are sent and values of type @i@ are received. -- | An IO sink and source where value of type @o@ are sent and values of type @i@ are received.
data IOStream i o = IOStream { data IOStream i o = IOStream {
writeStream :: o -> IOE (), writeStream :: o -> IOE (),
readStream :: IOE i, readStream :: IOE i,
closeStream :: IO () } closeStream :: IO () }
-- * Pipeline -- * Pipeline
-- | Thread-safe and pipelined connection -- | Thread-safe and pipelined connection
data Pipeline i o = Pipeline { data Pipeline i o = Pipeline {
vStream :: MVar (IOStream i o), -- ^ Mutex on handle, so only one thread at a time can write to it 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. 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 listenThread :: ThreadId
} }
-- | 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. -- | 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 :: IOStream i o -> IO (Pipeline i o)
newPipeline stream = do newPipeline stream = do
vStream <- newMVar stream vStream <- newMVar stream
responseQueue <- newChan responseQueue <- newChan
rec rec
let pipe = Pipeline{..} let pipe = Pipeline{..}
listenThread <- forkIO (listen pipe) listenThread <- forkIO (listen pipe)
_ <- mkWeakMVar vStream $ do _ <- mkWeakMVar vStream $ do
killThread listenThread killThread listenThread
closeStream stream closeStream stream
return pipe return pipe
close :: Pipeline i o -> IO () close :: Pipeline i o -> IO ()
-- ^ Close pipe and underlying connection -- ^ Close pipe and underlying connection
close Pipeline{..} = do close Pipeline{..} = do
killThread listenThread killThread listenThread
closeStream =<< readMVar vStream closeStream =<< readMVar vStream
isClosed :: Pipeline i o -> IO Bool isClosed :: Pipeline i o -> IO Bool
isClosed Pipeline{listenThread} = do isClosed Pipeline{listenThread} = do
status <- threadStatus listenThread status <- threadStatus listenThread
return $ case status of return $ case status of
ThreadRunning -> False ThreadRunning -> False
ThreadFinished -> True ThreadFinished -> True
ThreadBlocked _ -> False ThreadBlocked _ -> False
ThreadDied -> True ThreadDied -> True
--isPipeClosed Pipeline{..} = isClosed =<< readMVar vHandle -- isClosed hangs while listen loop is waiting on read --isPipeClosed Pipeline{..} = isClosed =<< readMVar vHandle -- isClosed hangs while listen loop is waiting on read
listen :: Pipeline i o -> IO () listen :: Pipeline i o -> IO ()
-- ^ Listen for responses and supply them to waiting threads in order -- ^ Listen for responses and supply them to waiting threads in order
listen Pipeline{..} = do listen Pipeline{..} = do
stream <- readMVar vStream stream <- readMVar vStream
forever $ do forever $ do
e <- runErrorT $ readStream stream e <- runErrorT $ readStream stream
var <- readChan responseQueue var <- readChan responseQueue
putMVar var e putMVar var e
case e of case e of
Left err -> closeStream stream >> ioError err -- close and stop looping Left err -> closeStream stream >> ioError err -- close and stop looping
Right _ -> return () Right _ -> return ()
send :: Pipeline i o -> o -> 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). -- ^ Send message to destination; the destination must not response (otherwise future 'call's will get these responses instead of their own).
@ -117,11 +117,11 @@ 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). -- ^ 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. -- Throw IOError and closes pipeline if send fails, likewise for promised response.
call p@Pipeline{..} message = withMVar vStream doCall `onException` close p where call p@Pipeline{..} message = withMVar vStream doCall `onException` close p where
doCall stream = do doCall stream = do
writeStream stream message writeStream stream message
var <- newEmptyMVar var <- newEmptyMVar
liftIO $ writeChan responseQueue var liftIO $ writeChan responseQueue var
return $ ErrorT (readMVar var) -- return promise return $ ErrorT (readMVar var) -- return promise
{- Authors: Tony Hannan <tony@10gen.com> {- Authors: Tony Hannan <tony@10gen.com>