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

Simplify! Removed Context and Throw monad classes. Removed embedded pool from replica-set. Not backwards-compatible, starts new major version 1.x

Browse source
This commit is contained in:
Tony Hannan 2011-07-05 10:37:01 -04:00
parent f7ae5b7235
commit 9f48c26384
12 changed files with 491 additions and 766 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

27
Control/Monad/Context.hs
View file

@ -1,27 +0,0 @@
{- | This is just like "Control.Monad.Reader.Class" except you can access the context of any Reader in the monad stack instead of just the top one as long as the context types are different. If two or more readers in the stack have the same context type you get the context of the top one. -}
{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, OverlappingInstances #-}
module Control.Monad.Context where
import Control.Monad.Reader
import Control.Monad.Error
-- | Same as 'MonadReader' but without functional dependency so the same monad can have multiple contexts with different types
class (Monad m) => Context x m where
context :: m x
-- ^ Get the context in the Reader in the monad stack that has @x@ context type. Analogous to 'ask'.
push :: (x -> x) -> m a -> m a
-- ^ Push new context in the Reader in the monad stack that has @x@ context type. Analogous to 'local'
instance (Monad m) => Context x (ReaderT x m) where
context = ask
push = local
instance (Context x m) => Context x (ReaderT r m) where
context = lift context
push f m = ReaderT (push f . runReaderT m)
instance (Context x m, Error e) => Context x (ErrorT e m) where
context = lift context
push f = ErrorT . push f . runErrorT

50
Control/Monad/Throw.hs
View file

@ -1,50 +0,0 @@
{- | This is just like "Control.Monad.Error.Class" except you can throw/catch the error of any ErrorT in the monad stack instead of just the top one as long as the error types are different. If two or more ErrorTs in the stack have the same error type you get the error of the top one. -}
{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, OverlappingInstances, UndecidableInstances #-}
module Control.Monad.Throw where
import Prelude hiding (catch)
import Control.Monad.Reader
import Control.Monad.Error
import Control.Arrow ((+++))
import Control.Applicative ((<$>))
-- | Same as 'MonadError' but without functional dependency so the same monad can have multiple errors with different types
class (Monad m) => Throw e m where
throw :: e -> m a
-- ^ Abort action and throw give exception. Analogous to 'throwError'.
catch :: m a -> (e -> m a) -> m a
-- ^ If first action aborts with exception then execute second action. Analogous to 'catchError'
throwLeft :: (Throw e m) => m (Either e a) -> m a
-- ^ Execute action and throw exception if result is Left, otherwise return the Right result
throwLeft = throwLeft' id
throwLeft' :: (Throw e m) => (x -> e) -> m (Either x a) -> m a
-- ^ Execute action and throw transformed exception if result is Left, otherwise return Right result
throwLeft' f = (either (throw . f) return =<<)
onException :: (Throw e m) => m a -> (e -> m b) -> m a
-- ^ If first action throws an exception then run second action then re-throw
onException action releaser = catch action $ \e -> releaser e >> throw e
instance (Error e) => Throw e (Either e) where
throw = throwError
catch = catchError
instance (Error e, Monad m) => Throw e (ErrorT e m) where
throw = throwError
catch = catchError
instance (Error e, Throw e m, Error x) => Throw e (ErrorT x m) where
throw = lift . throw
catch a h = ErrorT $ catch (runErrorT a) (runErrorT . h)
instance (Throw e m) => Throw e (ReaderT x m) where
throw = lift . throw
catch a h = ReaderT $ \x -> catch (runReaderT a x) (flip runReaderT x . h)
mapError :: (Functor m) => (e -> e') -> ErrorT e m a -> ErrorT e' m a
-- ^ Convert error type
mapError f (ErrorT m) = ErrorT $ (f +++ id) <$> m

39
Control/Monad/Util.hs
View file

@ -1,39 +0,0 @@
-- | Extra monad functions and instances
{-# LANGUAGE FlexibleInstances, UndecidableInstances #-}
module Control.Monad.Util where
import Control.Applicative (Applicative(..), (<$>))
import Control.Arrow ((+++))
import Control.Monad.Reader
import Control.Monad.Error
-- | MonadIO with extra Applicative and Functor superclasses
class (MonadIO m, Applicative m, Functor m) => MonadIO' m
instance (MonadIO m, Applicative m, Functor m) => MonadIO' m
loop :: (Functor m, Monad m) => m (Maybe a) -> m [a]
-- ^ Repeatedy execute action, collecting results, until it returns Nothing
loop act = act >>= maybe (return []) (\a -> (a :) <$> loop act)
untilJust :: (Monad m) => (a -> m (Maybe b)) -> [a] -> m (Maybe b)
-- ^ Apply action to elements one at a time until one returns Just. Return Nothing if all return Nothing.
untilJust _ [] = return Nothing
untilJust f (a:as) = f a >>= maybe (untilJust f as) (return . Just)
untilSuccess :: (MonadError e m, Error e) => (a -> m b) -> [a] -> m b
-- ^ Apply action to elements one at a time until one succeeds. Throw last error if all fail. Throw 'strMsg' error if list is empty.
untilSuccess = untilSuccess' (strMsg "empty untilSuccess")
untilSuccess' :: (MonadError e m) => e -> (a -> m b) -> [a] -> m b
-- ^ Apply action to elements one at a time until one succeeds. Throw last error if all fail. Throw given error if list is empty
untilSuccess' e _ [] = throwError e
untilSuccess' _ f (x : xs) = catchError (f x) (\e -> untilSuccess' e f xs)
mapError :: (Functor m) => (e' -> e) -> ErrorT e' m a -> ErrorT e m a
-- ^ Convert error type thrown
mapError f (ErrorT m) = ErrorT $ (f +++ id) <$> m
whenJust :: (Monad m) => Maybe a -> (a -> m ()) -> m ()
whenJust mVal act = maybe (return ()) act mVal

8
Database/MongoDB.hs
View file

@ -6,15 +6,15 @@ Simple example below. Use with language extension /OvererloadedStrings/.
> {-# LANGUAGE OverloadedStrings #-} > {-# LANGUAGE OverloadedStrings #-}
> >
> import Database.MongoDB > import Database.MongoDB
> import Data.CompactString () -- Show and IsString instances of UString
> import Control.Monad.Trans (liftIO) > import Control.Monad.Trans (liftIO)
> >
> main = do > main = do
> pool <- newConnPool 1 (host "127.0.0.1") > pipe <- runIOE $ connect (host "127.0.0.1")
> e <- access safe Master pool run > e <- access pipe safe Master "baseball" run
> close pipe
> print e > print e
> >
> run = use (Database "baseball") $ do > run = do
> clearTeams > clearTeams
> insertTeams > insertTeams
> printDocs "All Teams" =<< allTeams > printDocs "All Teams" =<< allTeams

93
Database/MongoDB/Admin.hs
View file

@ -38,7 +38,8 @@ import Data.IORef
import qualified Data.Set as S import qualified Data.Set as S
import System.IO.Unsafe (unsafePerformIO) import System.IO.Unsafe (unsafePerformIO)
import Control.Concurrent (forkIO, threadDelay) import Control.Concurrent (forkIO, threadDelay)
import Database.MongoDB.Internal.Util ((<.>), true1) import Database.MongoDB.Internal.Util (MonadIO', (<.>), true1)
import Control.Monad.MVar (MonadMVar)
-- * Admin -- * Admin
@ -51,17 +52,17 @@ coptElem Capped = "capped" =: True
coptElem (MaxByteSize n) = "size" =: n coptElem (MaxByteSize n) = "size" =: n
coptElem (MaxItems n) = "max" =: n coptElem (MaxItems n) = "max" =: n
createCollection :: (DbAccess m) => [CollectionOption] -> Collection -> m Document createCollection :: (MonadIO' m) => [CollectionOption] -> Collection -> Action m Document
-- ^ Create collection with given options. You only need to call this to set options, otherwise a collection is created automatically on first use with no options. -- ^ Create collection with given options. You only need to call this to set options, otherwise a collection is created automatically on first use with no options.
createCollection opts col = runCommand $ ["create" =: col] ++ map coptElem opts createCollection opts col = runCommand $ ["create" =: col] ++ map coptElem opts
renameCollection :: (DbAccess m) => Collection -> Collection -> m Document renameCollection :: (MonadIO' m) => Collection -> Collection -> Action m Document
-- ^ Rename first collection to second collection -- ^ Rename first collection to second collection
renameCollection from to = do renameCollection from to = do
Database db <- thisDatabase db <- thisDatabase
use admin $ runCommand ["renameCollection" =: db <.> from, "to" =: db <.> to, "dropTarget" =: True] useDb admin $ runCommand ["renameCollection" =: db <.> from, "to" =: db <.> to, "dropTarget" =: True]
dropCollection :: (DbAccess m) => Collection -> m Bool dropCollection :: (MonadIO' m) => Collection -> Action m Bool
-- ^ Delete the given collection! Return True if collection existed (and was deleted); return False if collection did not exist (and no action). -- ^ 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
@ -70,7 +71,7 @@ dropCollection coll = do
if at "errmsg" r == ("ns not found" :: UString) then return False else if at "errmsg" r == ("ns not found" :: UString) then return False else
fail $ "dropCollection failed: " ++ show r fail $ "dropCollection failed: " ++ show r
validateCollection :: (DbAccess m) => Collection -> m Document validateCollection :: (MonadIO' m) => Collection -> Action m Document
-- ^ This operation takes a while -- ^ This operation takes a while
validateCollection coll = runCommand ["validate" =: coll] validateCollection coll = runCommand ["validate" =: coll]
@ -87,7 +88,7 @@ data Index = Index {
} deriving (Show, Eq) } deriving (Show, Eq)
idxDocument :: Index -> Database -> Document idxDocument :: Index -> Database -> Document
idxDocument Index{..} (Database db) = [ idxDocument Index{..} db = [
"ns" =: db <.> iColl, "ns" =: db <.> iColl,
"key" =: iKey, "key" =: iKey,
"name" =: iName, "name" =: iName,
@ -102,7 +103,7 @@ genName :: Order -> IndexName
genName keys = intercalate "_" (map f keys) where genName keys = intercalate "_" (map f keys) where
f (k := v) = k `append` "_" `append` pack (show v) f (k := v) = k `append` "_" `append` pack (show v)
ensureIndex :: (DbAccess m) => Index -> m () ensureIndex :: (MonadIO' m) => Index -> Action m ()
-- ^ Create index if we did not already create one. May be called repeatedly with practically no performance hit, because we remember if we already called this for the same index (although this memory gets wiped out every 15 minutes, in case another client drops the index and we want to create it again). -- ^ 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
@ -111,23 +112,23 @@ ensureIndex idx = let k = (iColl idx, iName idx) in do
writeMode (Safe []) (createIndex idx) writeMode (Safe []) (createIndex idx)
liftIO $ writeIORef icache (S.insert k set) liftIO $ writeIORef icache (S.insert k set)
createIndex :: (DbAccess m) => Index -> m () createIndex :: (MonadIO' m) => Index -> Action m ()
-- ^ Create index on the server. This call goes to the server every time. -- ^ Create index on the server. This call goes to the server every time.
createIndex idx = insert_ "system.indexes" . idxDocument idx =<< thisDatabase createIndex idx = insert_ "system.indexes" . idxDocument idx =<< thisDatabase
dropIndex :: (DbAccess m) => Collection -> IndexName -> m Document dropIndex :: (MonadIO' m) => Collection -> IndexName -> Action m Document
-- ^ Remove the index -- ^ Remove the index
dropIndex coll idxName = do dropIndex coll idxName = do
resetIndexCache resetIndexCache
runCommand ["deleteIndexes" =: coll, "index" =: idxName] runCommand ["deleteIndexes" =: coll, "index" =: idxName]
getIndexes :: (DbAccess m) => Collection -> m [Document] getIndexes :: (MonadMVar m, Functor m) => Collection -> Action m [Document]
-- ^ Get all indexes on this collection -- ^ Get all indexes on this collection
getIndexes coll = do getIndexes coll = do
Database db <- thisDatabase db <- thisDatabase
rest =<< find (select ["ns" =: db <.> coll] "system.indexes") rest =<< find (select ["ns" =: db <.> coll] "system.indexes")
dropIndexes :: (DbAccess m) => Collection -> m Document dropIndexes :: (MonadIO' m) => Collection -> Action m Document
-- ^ Drop all indexes on this collection -- ^ Drop all indexes on this collection
dropIndexes coll = do dropIndexes coll = do
resetIndexCache resetIndexCache
@ -143,7 +144,7 @@ type IndexCache = IORef (S.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 <- T.new (==) (T.hashString . unpack . databaseName) table <- T.new (==) (T.hashString . unpack)
_ <- forkIO . forever $ threadDelay 900000000 >> clearDbIndexCache _ <- forkIO . forever $ threadDelay 900000000 >> clearDbIndexCache
return table return table
{-# NOINLINE dbIndexCache #-} {-# NOINLINE dbIndexCache #-}
@ -153,7 +154,7 @@ clearDbIndexCache = do
keys <- map fst <$> T.toList dbIndexCache keys <- map fst <$> T.toList dbIndexCache
mapM_ (T.delete dbIndexCache) keys mapM_ (T.delete dbIndexCache) keys
fetchIndexCache :: (DbAccess m) => 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
@ -166,7 +167,7 @@ fetchIndexCache = do
T.insert dbIndexCache db idx T.insert dbIndexCache db idx
return idx return idx
resetIndexCache :: (DbAccess m) => 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
@ -174,74 +175,74 @@ resetIndexCache = do
-- ** User -- ** User
allUsers :: (DbAccess m) => m [Document] allUsers :: (MonadMVar 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 :: (DbAccess m) => Bool -> Username -> Password -> m () addUser :: (MonadIO' m) => Bool -> Username -> Password -> Action m ()
-- ^ Add user with password with read-only access if bool is True or read-write access if bool is False -- ^ 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 :: (DbAccess m) => Username -> m () removeUser :: (MonadIO m) => Username -> Action m ()
removeUser user = delete (select ["user" =: user] "system.users") removeUser user = delete (select ["user" =: user] "system.users")
-- ** Database -- ** Database
admin :: Database admin :: Database
-- ^ \"admin\" database -- ^ \"admin\" database
admin = Database "admin" admin = "admin"
cloneDatabase :: (Access m) => Database -> Host -> m Document cloneDatabase :: (MonadIO' m) => Database -> Host -> Action m Document
-- ^ Copy database from given host to the server I am connected to. Fails and returns @"ok" = 0@ if we don't have permission to read from given server (use copyDatabase in this case). -- ^ Copy database from given host to the server I am connected to. Fails and returns @"ok" = 0@ if we don't have permission to read from given server (use copyDatabase in this case).
cloneDatabase db fromHost = use db $ runCommand ["clone" =: showHostPort fromHost] cloneDatabase db fromHost = useDb db $ runCommand ["clone" =: showHostPort fromHost]
copyDatabase :: (Access m) => Database -> Host -> Maybe (Username, Password) -> Database -> m Document copyDatabase :: (MonadIO' m) => Database -> Host -> Maybe (Username, Password) -> Database -> Action m Document
-- ^ Copy database from given host to the server I am connected to. If username & password is supplied use them to read from given host. -- ^ Copy database from given host to the server I am connected to. If username & password is supplied use them to read from given host.
copyDatabase (Database fromDb) fromHost mup (Database toDb) = do copyDatabase fromDb fromHost mup toDb = do
let c = ["copydb" =: (1 :: Int), "fromhost" =: showHostPort fromHost, "fromdb" =: fromDb, "todb" =: toDb] let c = ["copydb" =: (1 :: Int), "fromhost" =: showHostPort fromHost, "fromdb" =: fromDb, "todb" =: toDb]
use admin $ case mup of useDb admin $ case mup of
Nothing -> runCommand c 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 :: (Access m) => Database -> m Document dropDatabase :: (MonadIO' m) => Database -> Action m Document
-- ^ Delete the given database! -- ^ Delete the given database!
dropDatabase db = use db $ runCommand ["dropDatabase" =: (1 :: Int)] dropDatabase db = useDb db $ runCommand ["dropDatabase" =: (1 :: Int)]
repairDatabase :: (Access m) => Database -> m Document repairDatabase :: (MonadIO' m) => Database -> Action m Document
-- ^ Attempt to fix any corrupt records. This operation takes a while. -- ^ Attempt to fix any corrupt records. This operation takes a while.
repairDatabase db = use db $ runCommand ["repairDatabase" =: (1 :: Int)] repairDatabase db = useDb db $ runCommand ["repairDatabase" =: (1 :: Int)]
-- ** Server -- ** Server
serverBuildInfo :: (Access m) => m Document serverBuildInfo :: (MonadIO' m) => Action m Document
serverBuildInfo = use admin $ runCommand ["buildinfo" =: (1 :: Int)] serverBuildInfo = useDb admin $ runCommand ["buildinfo" =: (1 :: Int)]
serverVersion :: (Access m) => m UString serverVersion :: (MonadIO' m) => Action m UString
serverVersion = at "version" <$> serverBuildInfo serverVersion = at "version" <$> serverBuildInfo
-- * Diagnostics -- * Diagnostics
-- ** Collection -- ** Collection
collectionStats :: (DbAccess m) => Collection -> m Document collectionStats :: (MonadIO' m) => Collection -> Action m Document
collectionStats coll = runCommand ["collstats" =: coll] collectionStats coll = runCommand ["collstats" =: coll]
dataSize :: (DbAccess m) => Collection -> m Int dataSize :: (MonadIO' m) => Collection -> Action m Int
dataSize c = at "size" <$> collectionStats c dataSize c = at "size" <$> collectionStats c
storageSize :: (DbAccess m) => Collection -> m Int storageSize :: (MonadIO' m) => Collection -> Action m Int
storageSize c = at "storageSize" <$> collectionStats c storageSize c = at "storageSize" <$> collectionStats c
totalIndexSize :: (DbAccess m) => Collection -> m Int totalIndexSize :: (MonadIO' m) => Collection -> Action m Int
totalIndexSize c = at "totalIndexSize" <$> collectionStats c totalIndexSize c = at "totalIndexSize" <$> collectionStats c
totalSize :: (DbAccess m) => Collection -> m Int totalSize :: (MonadMVar 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
@ -253,35 +254,35 @@ totalSize coll = do
data ProfilingLevel = Off | Slow | All deriving (Show, Enum, Eq) data ProfilingLevel = Off | Slow | All deriving (Show, Enum, Eq)
getProfilingLevel :: (DbAccess m) => m ProfilingLevel getProfilingLevel :: (MonadIO' m) => Action m ProfilingLevel
getProfilingLevel = toEnum . at "was" <$> runCommand ["profile" =: (-1 :: Int)] getProfilingLevel = toEnum . at "was" <$> runCommand ["profile" =: (-1 :: Int)]
type MilliSec = Int type MilliSec = Int
setProfilingLevel :: (DbAccess m) => ProfilingLevel -> Maybe MilliSec -> 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
dbStats :: (DbAccess m) => m Document dbStats :: (MonadIO' m) => Action m Document
dbStats = runCommand ["dbstats" =: (1 :: Int)] dbStats = runCommand ["dbstats" =: (1 :: Int)]
currentOp :: (DbAccess m) => m (Maybe Document) currentOp :: (MonadIO m) => Action m (Maybe Document)
-- ^ See currently running operation on the database, if any -- ^ See currently running operation on the database, if any
currentOp = findOne (select [] "$cmd.sys.inprog") currentOp = findOne (select [] "$cmd.sys.inprog")
type OpNum = Int type OpNum = Int
killOp :: (DbAccess m) => OpNum -> m (Maybe Document) killOp :: (MonadIO m) => OpNum -> Action m (Maybe Document)
killOp op = findOne (select ["op" =: op] "$cmd.sys.killop") killOp op = findOne (select ["op" =: op] "$cmd.sys.killop")
-- ** Server -- ** Server
serverStatus :: (Access m) => m Document serverStatus :: (MonadIO' m) => Action m Document
serverStatus = use admin $ runCommand ["serverStatus" =: (1 :: Int)] serverStatus = useDb admin $ runCommand ["serverStatus" =: (1 :: Int)]
{- Authors: Tony Hannan <tony@10gen.com> {- Authors: Tony Hannan <tony@10gen.com>
Copyright 2010 10gen Inc. Copyright 2011 10gen Inc.
Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in compliance with the License. You may obtain a copy of the License at: http://www.apache.org/licenses/LICENSE-2.0. Unless required by applicable law or agreed to in writing, software distributed under the License is distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the License for the specific language governing permissions and limitations under the License. -} Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in compliance with the License. You may obtain a copy of the License at: http://www.apache.org/licenses/LICENSE-2.0. Unless required by applicable law or agreed to in writing, software distributed under the License is distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the License for the specific language governing permissions and limitations under the License. -}

277
Database/MongoDB/Connection.hs
View file

@ -1,61 +1,42 @@
{- | A pool of TCP connections to a single server or a replica set of servers. -} -- | Connect to a single server or a replica set of servers
{-# LANGUAGE CPP, OverloadedStrings, ScopedTypeVariables, RecordWildCards, NamedFieldPuns, MultiParamTypeClasses, FlexibleContexts, TypeFamilies, DoRec, RankNTypes, FlexibleInstances #-} {-# LANGUAGE CPP, OverloadedStrings, ScopedTypeVariables, TupleSections #-}
module Database.MongoDB.Connection ( module Database.MongoDB.Connection (
-- * Pipe IOE, runIOE,
Pipe, -- * Connection
Pipe, close, isClosed,
-- * Host -- * Host
Host(..), PortID(..), host, showHostPort, readHostPort, readHostPortM, Host(..), PortID(..), host, showHostPort, readHostPort, readHostPortM, connect,
-- * Replica Set -- * Replica Set
ReplicaSet(..), Name, ReplicaSetName, openReplicaSet, ReplicaSet, primary, secondaryOk
-- * MasterOrSlaveOk
MasterOrSlaveOk(..),
-- * Connection Pool
Service(..),
connHost, replicaSet
) where ) where
import Prelude hiding (lookup) import Prelude hiding (lookup)
import Database.MongoDB.Internal.Protocol as X import Database.MongoDB.Internal.Protocol (Pipe, writeMessage, readMessage)
import qualified Network.Abstract as C import System.IO.Pipeline (IOE, IOStream(..), newPipeline, close, isClosed)
import Network.Abstract (IOE, NetworkIO, ANetwork) import System.IO.Error as E (try)
import Data.Bson ((=:), at, lookup, UString) import System.IO (hClose)
import Control.Pipeline as P import Network (HostName, PortID(..), connectTo)
import Control.Applicative ((<$>))
import Control.Exception (assert)
import Control.Monad.Error
import Control.Monad.MVar
import Network (HostName, PortID(..))
import Data.Bson (Document, look)
import Text.ParserCombinators.Parsec as T (parse, many1, letter, digit, char, eof, spaces, try, (<|>)) import Text.ParserCombinators.Parsec as T (parse, many1, letter, digit, char, eof, spaces, try, (<|>))
import Control.Monad.Identity import Control.Monad.Identity (runIdentity)
import Control.Monad.Util (MonadIO', untilSuccess) import Control.Monad.Error (ErrorT(..), lift, throwError)
import Database.MongoDB.Internal.Util () -- PortID instances import Control.Monad.MVar
import Var.Pool import Control.Monad (forM_)
import System.Random (newStdGen, randomRs) import Control.Applicative ((<$>))
import Data.List (delete, find, nub) import Data.UString (UString, unpack)
import System.IO.Unsafe (unsafePerformIO) import Data.Bson as D (Document, lookup, at, (=:))
import Database.MongoDB.Query (access, safe, MasterOrSlaveOk(SlaveOk), Failure(ConnectionFailure), Command, runCommand)
import Database.MongoDB.Internal.Util (untilSuccess, liftIOE, runIOE, updateAssocs, shuffle)
import Data.List as L (lookup, intersect, partition, (\\))
type Name = UString adminCommand :: Command -> Pipe -> IOE Document
-- ^ Run command against admin database on server connected to pipe. Fail if connection fails.
adminCommand :: Document -> Request adminCommand cmd pipe =
-- ^ Convert command to request liftIOE failureToIOError . ErrorT $ access pipe safe SlaveOk "admin" $ runCommand cmd
adminCommand cmd = Query{..} where where
qOptions = [SlaveOK] failureToIOError (ConnectionFailure e) = e
qFullCollection = "admin.$cmd" failureToIOError e = userError $ show e
qSkip = 0
qBatchSize = -1
qSelector = cmd
qProjector = []
commandReply :: String -> Reply -> Document
-- ^ Extract first document from reply. Error if query error, using given string as prefix error message.
commandReply title Reply{..} = if elem QueryError rResponseFlags
then error $ title ++ ": " ++ at "$err" (head rDocuments)
else if null rDocuments
then error ("empty reply to: " ++ title)
else head rDocuments
-- * Host -- * Host
@ -97,152 +78,86 @@ readHostPort :: String -> Host
-- ^ Read string \"hostname:port\" as @Host hostname port@ or \"hostname\" as @host hostname@ (default port). Error if string does not match either syntax. -- ^ Read string \"hostname:port\" as @Host hostname port@ or \"hostname\" as @host hostname@ (default port). Error if string does not match either syntax.
readHostPort = runIdentity . readHostPortM readHostPort = runIdentity . readHostPortM
connect :: Host -> IOE Pipe
-- ^ Connect to Host returning pipelined TCP connection. Throw IOError if problem connecting.
connect (Host hostname port) = do
handle <- ErrorT . E.try $ connectTo hostname port
lift $ newPipeline $ IOStream (writeMessage handle) (readMessage handle) (hClose handle)
-- * Replica Set -- * Replica Set
data ReplicaSet = ReplicaSet {setName :: Name, seedHosts :: [Host]} deriving (Show) type ReplicaSetName = UString
-- ^ Replica set of hosts identified by set name. At least one of the seed hosts must be an active member of the set. However, this list is not used to identify the set, just the set name.
instance Eq ReplicaSet where ReplicaSet x _ == ReplicaSet y _ = x == y -- | Maintains a connection (created on demand) to each server in the named replica set
data ReplicaSet = ReplicaSet ReplicaSetName (MVar [(Host, Maybe Pipe)])
-- ** Replica Info openReplicaSet :: (ReplicaSetName, [Host]) -> IOE ReplicaSet
-- ^ Open connections (on demand) to servers in replica set. Supplied hosts is seed list. At least one of them must be a live member of the named replica set, otherwise fail.
openReplicaSet (rsName, seedList) = do
rs <- ReplicaSet rsName <$> newMVar (map (, Nothing) seedList)
_ <- updateMembers rs
return rs
getReplicaInfo :: ConnPool Host -> IOE ReplicaInfo primary :: ReplicaSet -> IOE Pipe
-- ^ Get replica info of the connected host. Throw IOError if connection fails or host is not part of a replica set (no /hosts/ and /primary/ field). -- ^ Return connection to current primary of replica set
getReplicaInfo conn = do primary rs@(ReplicaSet rsName _) = do
pipe <- getHostPipe conn mHost <- statedPrimary <$> updateMembers rs
promise <- X.call pipe [] (adminCommand ["ismaster" =: (1 :: Int)]) case mHost of
info <- commandReply "ismaster" <$> promise Just host' -> connection rs Nothing host'
_ <- look "hosts" info Nothing -> throwError $ userError $ "replica set " ++ unpack rsName ++ " has no primary"
_ <- look "ismaster" info
return $ ReplicaInfo (connHost conn) info
data ReplicaInfo = ReplicaInfo {_infoHost :: Host, infoDoc :: Document} deriving (Show) secondaryOk :: ReplicaSet -> IOE Pipe
-- ^ Configuration info of a host in a replica set (result of /ismaster/ command). Contains all the hosts in the replica set plus its role in that set (master, slave, or arbiter) -- ^ Return connection to a random member (secondary or primary)
secondaryOk rs = do
info <- updateMembers rs
hosts <- lift $ shuffle (possibleHosts info)
untilSuccess (connection rs Nothing) hosts
{- isPrimary :: ReplicaInfo -> Bool type ReplicaInfo = (Host, Document)
-- ^ Is the replica described by this info a master/primary (not slave or arbiter)? -- ^ Result of isMaster command on host in replica set. Returned fields are: setName, ismaster, secondary, hosts, [primary]. primary only present when ismaster = false
isPrimary = true1 "ismaster"
isSecondary :: ReplicaInfo -> Bool statedPrimary :: ReplicaInfo -> Maybe Host
-- ^ Is the replica described by this info a slave/secondary (not master or arbiter) -- ^ Primary of replica set or Nothing if there isn't one
isSecondary = true1 "secondary" -} statedPrimary (host', info) = if (at "ismaster" info) then Just host' else readHostPort <$> D.lookup "primary" info
primary :: ReplicaInfo -> Maybe Host possibleHosts :: ReplicaInfo -> [Host]
-- ^ Read primary from configuration info. During failover or minor network partition there is no primary (Nothing). -- ^ Non-arbiter, non-hidden members of replica set
primary (ReplicaInfo host' info) = if at "ismaster" info then Just host' else readHostPort <$> lookup "primary" info possibleHosts (_, info) = map readHostPort $ at "hosts" info
replicas :: ReplicaInfo -> [Host] updateMembers :: ReplicaSet -> IOE ReplicaInfo
-- ^ All replicas in set according to this replica configuration info with primary at head, if there is one. -- ^ Fetch replica info from any server and update members accordingly
replicas info = maybe members (\m -> m : delete m members) master where updateMembers rs@(ReplicaSet _ vMembers) = do
members = map readHostPort $ at "hosts" (infoDoc info) (host', info) <- untilSuccess (fetchReplicaInfo rs) =<< readMVar vMembers
master = primary info modifyMVar vMembers $ \members -> do
let ((members', old), new) = intersection (map readHostPort $ at "hosts" info) members
-- * MasterOrSlaveOk lift $ forM_ old $ \(_, mPipe) -> maybe (return ()) close mPipe
return (members' ++ map (, Nothing) new, (host', info))
data MasterOrSlaveOk =
Master -- ^ connect to master only
| SlaveOk -- ^ connect to a slave, or master if no slave available
deriving (Show, Eq)
{- isMS :: MasterOrSlaveOk -> ReplicaInfo -> Bool
-- ^ Does the host (as described by its replica-info) match the master/slave type
isMS Master i = isPrimary i
isMS SlaveOk i = isSecondary i || isPrimary i -}
-- * Connection Pool
type Pool' = Pool IOError
-- | A Service is a single server ('Host') or a replica set of servers ('ReplicaSet')
class Service t where
data ConnPool t
-- ^ A pool of TCP connections ('Pipe's) to a host or a replica set of hosts
newConnPool :: (NetworkIO m) => Int -> t -> m (ConnPool t)
-- ^ Create a ConnectionPool to a host or a replica set of hosts. Actual TCP connection is not attempted until 'getPipe' request, so no IOError can be raised here. Up to N TCP connections will be established to each host.
getPipe :: MasterOrSlaveOk -> ConnPool t -> IOE Pipe
-- ^ Return a TCP connection (Pipe) to the master or a slave in the server. Master must connect to the master, SlaveOk may connect to a slave or master. To spread the load, SlaveOk requests are distributed amongst all hosts in the server. Throw IOError if failed to connect to right type of host (Master/SlaveOk).
killPipes :: ConnPool t -> IO ()
-- ^ Kill all open pipes (TCP Connections). Will cause any users of them to fail. Alternatively you can let them die on their own when they get garbage collected.
-- ** ConnectionPool Host
instance Service Host where
data ConnPool Host = HostConnPool {connHost :: Host, connPool :: Pool' Pipe}
-- ^ A pool of TCP connections ('Pipe's) to a server, handed out in round-robin style.
newConnPool poolSize' host' = liftIO . newHostConnPool poolSize' host' =<< C.network
-- ^ Create a connection pool to server (host or replica set)
getPipe _ = getHostPipe
-- ^ Return a TCP connection (Pipe). If SlaveOk, connect to a slave if available. Round-robin if multiple slaves are available. Throw IOError if failed to connect.
killPipes (HostConnPool _ pool) = killAll pool
instance Show (ConnPool Host) where
show HostConnPool{connHost} = "ConnPool " ++ show connHost
newHostConnPool :: Int -> Host -> ANetwork -> IO (ConnPool Host)
-- ^ Create a pool of N 'Pipe's (TCP connections) to server. 'getHostPipe' will return one of those pipes, round-robin style.
newHostConnPool poolSize' host' net = HostConnPool host' <$> newPool Factory{..} poolSize' where
newResource = tcpConnect net host'
killResource = P.close
isExpired = P.isClosed
getHostPipe :: ConnPool Host -> IOE Pipe
-- ^ Return next pipe (TCP connection) in connection pool, round-robin style. Throw IOError if can't connect to host.
getHostPipe (HostConnPool _ pool) = aResource pool
tcpConnect :: ANetwork -> Host -> IOE Pipe
-- ^ Create a TCP connection (Pipe) to the given host. Throw IOError if can't connect.
tcpConnect net (Host hostname port) = newPipeline =<< C.connect net (C.Server hostname port)
-- ** Connection ReplicaSet
instance Service ReplicaSet where
data ConnPool ReplicaSet = ReplicaSetConnPool {
network :: ANetwork,
repsetName :: Name,
currentMembers :: MVar [ConnPool Host] } -- master at head after a refresh
newConnPool poolSize' repset = liftIO . newSetConnPool poolSize' repset =<< C.network
getPipe = getSetPipe
killPipes ReplicaSetConnPool{..} = withMVar currentMembers (mapM_ killPipes)
instance Show (ConnPool ReplicaSet) where
show r = "ConnPool " ++ show (unsafePerformIO $ replicaSet r)
replicaSet :: (MonadIO' m) => ConnPool ReplicaSet -> m ReplicaSet
-- ^ Return replicas set name with current members as seed list
replicaSet ReplicaSetConnPool{..} = ReplicaSet repsetName . map connHost <$> readMVar currentMembers
newSetConnPool :: Int -> ReplicaSet -> ANetwork -> IO (ConnPool ReplicaSet)
-- ^ Create a connection pool to each member of the replica set.
newSetConnPool poolSize' repset net = assert (not . null $ seedHosts repset) $ do
currentMembers <- newMVar =<< mapM (\h -> newHostConnPool poolSize' h net) (seedHosts repset)
return $ ReplicaSetConnPool net (setName repset) currentMembers
getMembers :: Name -> [ConnPool Host] -> IOE [Host]
-- ^ Get members of replica set, master first. Query supplied connections until config found.
-- TODO: Verify config for request replica set name and not some other replica set. "ismaster" reply includes "setName" in result.
getMembers _repsetName connections = replicas <$> untilSuccess getReplicaInfo connections
refreshMembers :: ANetwork -> Name -> [ConnPool Host] -> IOE [ConnPool Host]
-- ^ Update current members with master at head. Reuse unchanged members. Throw IOError if can't connect to any and fetch config. Dropped connections are not closed in case they still have users; they will be closed when garbage collected.
refreshMembers net repsetName connections = do
n <- liftIO . poolSize . connPool $ head connections
mapM (liftIO . connection n) =<< getMembers repsetName connections
where where
connection n host' = maybe (newHostConnPool n host' net) return mc where intersection :: (Eq k) => [k] -> [(k, v)] -> (([(k, v)], [(k, v)]), [k])
mc = find ((host' ==) . connHost) connections intersection keys assocs = (partition (flip elem inKeys . fst) assocs, keys \\ inKeys) where
assocKeys = map fst assocs
inKeys = intersect keys assocKeys
fetchReplicaInfo :: ReplicaSet -> (Host, Maybe Pipe) -> IOE ReplicaInfo
-- Connect to host and fetch replica info from host creating new connection if missing or closed (previously failed). Fail if not member of named replica set.
fetchReplicaInfo rs@(ReplicaSet rsName _) (host', mPipe) = do
pipe <- connection rs mPipe host'
info <- adminCommand ["isMaster" =: (1 :: Int)] pipe
case D.lookup "setName" info of
Nothing -> throwError $ userError $ show host' ++ " not a member of any replica set, including " ++ unpack rsName ++ ": " ++ show info
Just setName | setName /= rsName -> throwError $ userError $ show host' ++ " not a member of replica set " ++ unpack rsName ++ ": " ++ show info
Just _ -> return (host', info)
getSetPipe :: MasterOrSlaveOk -> ConnPool ReplicaSet -> IOE Pipe connection :: ReplicaSet -> Maybe Pipe -> Host -> IOE Pipe
-- ^ Return a pipe to primary or a random secondary in replica set. Use primary for SlaveOk if and only if no secondaries. Note, refreshes members each time (makes ismaster call to primary). -- ^ 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.
getSetPipe mos ReplicaSetConnPool{..} = modifyMVar currentMembers $ \conns -> do connection (ReplicaSet _ vMembers) mPipe host' =
connections <- refreshMembers network repsetName conns -- master at head after refresh maybe conn (\p -> lift (isClosed p) >>= \bad -> if bad then conn else return p) mPipe
pipe <- case mos of where
Master -> getHostPipe (head connections) conn = modifyMVar vMembers $ \members -> do
SlaveOk -> do let new = connect host' >>= \pipe -> return (updateAssocs host' (Just pipe) members, pipe)
let n = length connections - 1 case L.lookup host' members of
is <- take (max 1 n) . nub . randomRs (min 1 n, n) <$> liftIO newStdGen Just (Just pipe) -> lift (isClosed pipe) >>= \bad -> if bad then new else return (members, pipe)
untilSuccess (getHostPipe . (connections !!)) is _ -> new
return (connections, pipe)
{- Authors: Tony Hannan <tony@10gen.com> {- Authors: Tony Hannan <tony@10gen.com>

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

@ -5,10 +5,12 @@ This module is not intended for direct use. Use the high-level interface at "Dat
{-# LANGUAGE RecordWildCards, StandaloneDeriving, OverloadedStrings, FlexibleContexts, TupleSections, TypeSynonymInstances, MultiParamTypeClasses, FlexibleInstances, UndecidableInstances #-} {-# LANGUAGE RecordWildCards, StandaloneDeriving, OverloadedStrings, FlexibleContexts, TupleSections, TypeSynonymInstances, MultiParamTypeClasses, FlexibleInstances, UndecidableInstances #-}
module Database.MongoDB.Internal.Protocol ( module Database.MongoDB.Internal.Protocol (
MasterOrSlaveOk(..),
FullCollection,
-- * Pipe -- * Pipe
Pipe, send, call, Pipe, send, call,
-- * Message -- * Message
FullCollection, writeMessage, readMessage,
-- ** Notice -- ** Notice
Notice(..), UpdateOption(..), DeleteOption(..), CursorId, Notice(..), UpdateOption(..), DeleteOption(..), CursorId,
-- ** Request -- ** Request
@ -23,7 +25,9 @@ import Prelude as X
import Control.Applicative ((<$>)) import Control.Applicative ((<$>))
import Control.Arrow ((***)) import Control.Arrow ((***))
import Data.ByteString.Lazy as B (length, hPut) import Data.ByteString.Lazy as B (length, hPut)
import qualified Control.Pipeline as P import System.IO.Pipeline (IOE, Pipeline)
import qualified System.IO.Pipeline as P (send, call)
import System.IO (Handle)
import Data.Bson (Document, UString) import Data.Bson (Document, UString)
import Data.Bson.Binary import Data.Bson.Binary
import Data.Binary.Put import Data.Binary.Put
@ -34,22 +38,21 @@ import Data.IORef
import System.IO.Unsafe (unsafePerformIO) import System.IO.Unsafe (unsafePerformIO)
import qualified Crypto.Hash.MD5 as MD5 (hash) import qualified Crypto.Hash.MD5 as MD5 (hash)
import Data.UString as U (pack, append, toByteString) import Data.UString as U (pack, append, toByteString)
import qualified Data.ByteString as BS (ByteString, unpack)
import Data.Word (Word8)
import System.IO.Error as E (try) import System.IO.Error as E (try)
import Control.Monad.Error import Control.Monad.Error
import Control.Monad.Util (whenJust)
import Network.Abstract hiding (send)
import System.IO (hFlush) import System.IO (hFlush)
import Database.MongoDB.Internal.Util (hGetN, bitOr) import Database.MongoDB.Internal.Util (whenJust, hGetN, bitOr, byteStringHex)
import Numeric (showHex)
-- Network -> Server -> (Sink, Source) -- * MasterOrSlaveOk
-- (Sink, Source) -> Pipeline
data MasterOrSlaveOk =
Master -- ^ connect to master only
| SlaveOk -- ^ connect to a slave, or master if no slave available
deriving (Show, Eq)
-- * Pipe -- * Pipe
type Pipe = P.Pipeline Message Response type Pipe = Pipeline Response Message
-- ^ Thread-safe TCP connection with pipelined requests -- ^ Thread-safe TCP connection with pipelined requests
send :: Pipe -> [Notice] -> IOE () send :: Pipe -> [Notice] -> IOE ()
@ -69,10 +72,11 @@ call pipe notices request = do
-- * Message -- * Message
type Message = ([Notice], Maybe (Request, RequestId)) type Message = ([Notice], Maybe (Request, RequestId))
-- ^ A write notice(s), write notice(s) with getLastError request, or just query request. -- ^ A write notice(s) with getLastError request, or just query request.
-- Note, that requestId will be out of order because request ids will be generated for notices after the request id supplied was generated. This is ok because the mongo server does not care about order just uniqueness. -- Note, that requestId will be out of order because request ids will be generated for notices after the request id supplied was generated. This is ok because the mongo server does not care about order just uniqueness.
instance WriteMessage Message where writeMessage :: Handle -> Message -> IOE ()
-- ^ Write message to socket
writeMessage handle (notices, mRequest) = ErrorT . E.try $ do writeMessage handle (notices, mRequest) = ErrorT . E.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)
@ -89,8 +93,9 @@ instance WriteMessage Message where
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
instance ReadMessage Response where readMessage :: Handle -> IOE Response
readMessage handle = ErrorT . E.try $ readResp where -- ^ read response from socket
readMessage handle = ErrorT $ E.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
@ -314,10 +319,7 @@ pwHash u p = pack . byteStringHex . MD5.hash . toByteString $ u `U.append` ":mon
pwKey :: Nonce -> Username -> Password -> UString pwKey :: Nonce -> Username -> Password -> UString
pwKey n u p = pack . byteStringHex . MD5.hash . toByteString . U.append n . U.append u $ pwHash u p pwKey n u p = pack . byteStringHex . MD5.hash . toByteString . U.append n . U.append u $ pwHash u p
byteStringHex :: BS.ByteString -> String
-- ^ Hexadecimal string representation of a byte string. Each byte yields two hexadecimal characters.
byteStringHex = concatMap byteHex . BS.unpack
byteHex :: Word8 -> String {- Authors: Tony Hannan <tony@10gen.com>
-- ^ Two char hexadecimal representation of byte Copyright 2011 10gen Inc.
byteHex b = (if b < 16 then ('0' :) else id) (showHex b "") Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in compliance with the License. You may obtain a copy of the License at: http://www.apache.org/licenses/LICENSE-2.0. Unless required by applicable law or agreed to in writing, software distributed under the License is distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the License for the specific language governing permissions and limitations under the License. -}

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

@ -1,11 +1,10 @@
-- | Miscellaneous general functions and Show, Eq, and Ord instances for PortID -- | Miscellaneous general functions and Show, Eq, and Ord instances for PortID
{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE FlexibleInstances, UndecidableInstances, StandaloneDeriving #-}
module Database.MongoDB.Internal.Util where module Database.MongoDB.Internal.Util where
import Prelude hiding (length) import Control.Applicative (Applicative(..), (<$>))
import Control.Applicative ((<$>))
import Network (PortID(..)) import Network (PortID(..))
import Data.UString as U (cons, append) import Data.UString as U (cons, append)
import Data.Bits (Bits, (.|.)) import Data.Bits (Bits, (.|.))
@ -14,11 +13,56 @@ import Data.ByteString.Lazy as S (ByteString, length, append, hGet)
import System.IO (Handle) import System.IO (Handle)
import System.IO.Error (mkIOError, eofErrorType) import System.IO.Error (mkIOError, eofErrorType)
import Control.Exception (assert) import Control.Exception (assert)
import Control.Monad.Error
import Control.Arrow (left)
import qualified Data.ByteString as BS (ByteString, unpack)
import Data.Word (Word8)
import Numeric (showHex)
import System.Random.Shuffle (shuffle')
import System.Random (newStdGen)
import Data.List as L (length)
deriving instance Show PortID deriving instance Show PortID
deriving instance Eq PortID deriving instance Eq PortID
deriving instance Ord PortID deriving instance Ord PortID
-- | MonadIO with extra Applicative and Functor superclasses
class (MonadIO m, Applicative m, Functor m) => MonadIO' m
instance (MonadIO m, Applicative m, Functor m) => MonadIO' m
shuffle :: [a] -> IO [a]
-- ^ Randomly shuffle items in list
shuffle list = shuffle' list (L.length list) <$> newStdGen
loop :: (Functor m, Monad m) => m (Maybe a) -> m [a]
-- ^ Repeatedy execute action, collecting results, until it returns Nothing
loop act = act >>= maybe (return []) (\a -> (a :) <$> loop act)
untilSuccess :: (MonadError e m, Error e) => (a -> m b) -> [a] -> m b
-- ^ Apply action to elements one at a time until one succeeds. Throw last error if all fail. Throw 'strMsg' error if list is empty.
untilSuccess = untilSuccess' (strMsg "empty untilSuccess")
untilSuccess' :: (MonadError e m) => e -> (a -> m b) -> [a] -> m b
-- ^ Apply action to elements one at a time until one succeeds. Throw last error if all fail. Throw given error if list is empty
untilSuccess' e _ [] = throwError e
untilSuccess' _ f (x : xs) = catchError (f x) (\e -> untilSuccess' e f xs)
whenJust :: (Monad m) => Maybe a -> (a -> m ()) -> m ()
whenJust mVal act = maybe (return ()) act mVal
liftIOE :: (MonadIO m) => (e -> e') -> ErrorT e IO a -> ErrorT e' m a
-- ^ lift IOE monad to ErrorT monad over some MonadIO m
liftIOE f = ErrorT . liftIO . fmap (left f) . runErrorT
runIOE :: ErrorT IOError IO a -> IO a
-- ^ Run action while catching explicit error and rethrowing in IO monad
runIOE (ErrorT action) = action >>= either ioError return
updateAssocs :: (Eq k) => k -> v -> [(k, v)] -> [(k, v)]
-- ^ Change or insert value of key in association list
updateAssocs key valu assocs = case back of [] -> (key, valu) : front; _ : back' -> front ++ (key, valu) : back'
where (front, back) = break ((key ==) . fst) assocs
bitOr :: (Bits a) => [a] -> a bitOr :: (Bits a) => [a] -> a
-- ^ bit-or all numbers together -- ^ bit-or all numbers together
bitOr = foldl (.|.) 0 bitOr = foldl (.|.) 0
@ -40,7 +84,15 @@ hGetN :: Handle -> Int -> IO ByteString
-- ^ Read N bytes from hande, blocking until all N bytes are read. If EOF is reached before N bytes then raise EOF exception. -- ^ 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 <- hGet h n bytes <- hGet h n
let x = fromEnum $ length bytes let x = fromEnum $ S.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 S.append bytes <$> hGetN h (n - x) else S.append bytes <$> hGetN h (n - x)
byteStringHex :: BS.ByteString -> String
-- ^ Hexadecimal string representation of a byte string. Each byte yields two hexadecimal characters.
byteStringHex = concatMap byteHex . BS.unpack
byteHex :: Word8 -> String
-- ^ Two char hexadecimal representation of byte
byteHex b = (if b < 16 then ('0' :) else id) (showHex b "")

459
Database/MongoDB/Query.hs
View file

@ -3,19 +3,18 @@
{-# LANGUAGE OverloadedStrings, RecordWildCards, NamedFieldPuns, TupleSections, FlexibleContexts, FlexibleInstances, UndecidableInstances, MultiParamTypeClasses, GeneralizedNewtypeDeriving, StandaloneDeriving, TypeSynonymInstances, RankNTypes #-} {-# LANGUAGE OverloadedStrings, RecordWildCards, NamedFieldPuns, TupleSections, FlexibleContexts, FlexibleInstances, UndecidableInstances, MultiParamTypeClasses, GeneralizedNewtypeDeriving, StandaloneDeriving, TypeSynonymInstances, RankNTypes #-}
module Database.MongoDB.Query ( module Database.MongoDB.Query (
-- * Access -- * Monad
access, Access, Action, runAction, Failure(..), Action, Failure(..), access,
-- * Database -- * Database
Database(..), allDatabases, DbAccess, use, thisDatabase, Database, allDatabases, useDb, thisDatabase,
-- ** Authentication -- ** Authentication
P.Username, P.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
-- ** WriteMode
WriteMode(..), safe, GetLastError, writeMode, WriteMode(..), safe, GetLastError, writeMode,
-- ** Insert -- ** Insert
insert, insert_, insertMany, insertMany_, insert, insert_, insertMany, insertMany_,
@ -24,7 +23,7 @@ module Database.MongoDB.Query (
-- ** Delete -- ** Delete
delete, deleteOne, delete, deleteOne,
-- * Read -- * Read
readMode, MasterOrSlaveOk(..), readMode,
-- ** Query -- ** Query
Query(..), QueryOption(..), Projector, Limit, Order, BatchSize, Query(..), QueryOption(..), Projector, Limit, Order, BatchSize,
explain, find, findOne, count, distinct, explain, find, findOne, count, distinct,
@ -40,109 +39,83 @@ module Database.MongoDB.Query (
) where ) where
import Prelude as X hiding (lookup) import Prelude as X hiding (lookup)
import Control.Applicative ((<$>), Applicative(..)) import Data.UString as U (UString, dropWhile, any, tail)
import Control.Arrow (first) import Data.Bson (Document, at, lookup, look, Field(..), (=:), (=?), Label, Value(String,Doc), Javascript, genObjectId)
import Control.Monad.Context import Database.MongoDB.Internal.Protocol (MasterOrSlaveOk(..), Pipe, Notice(..), Request(GetMore), Reply(..), QueryOption(..), ResponseFlag(..), UpdateOption(..), DeleteOption(..), CursorId, FullCollection, Username, Password, pwKey)
import Control.Monad.Reader import qualified Database.MongoDB.Internal.Protocol as P (send, call, Request(Query))
import Control.Monad.Error import Database.MongoDB.Internal.Util (MonadIO', loop, liftIOE, true1, (<.>))
import Control.Monad.Throw
import Control.Monad.MVar import Control.Monad.MVar
import qualified Database.MongoDB.Internal.Protocol as P import Control.Monad.Error
import Database.MongoDB.Internal.Protocol hiding (Query, QueryOption(..), send, call) import Control.Monad.Reader
import Database.MongoDB.Connection (MasterOrSlaveOk(..), Service(..)) import Control.Applicative (Applicative, (<$>))
import Data.Bson
import Data.Word
import Data.Int
import Data.Maybe (listToMaybe, catMaybes) import Data.Maybe (listToMaybe, catMaybes)
import Data.UString as U (dropWhile, any, tail) import Data.Int (Int32)
import Control.Monad.Util (MonadIO', loop) import Data.Word (Word32)
import Database.MongoDB.Internal.Util ((<.>), true1)
mapErrorIO :: (Throw e m, MonadIO m) => (e' -> e) -> ErrorT e' IO a -> m a -- * Monad
mapErrorIO f = throwLeft' f . liftIO . runErrorT
-- * Mongo Monad type Action m = ErrorT Failure (ReaderT Context m)
-- ^ A monad on top of m (which must be a MonadIO) with access to a 'Context' and may throw a 'Failure'
access :: (Service s, MonadIO m) => WriteMode -> MasterOrSlaveOk -> ConnPool s -> Action m a -> m (Either Failure a)
-- ^ Run action under given write and read mode against the server or replicaSet behind given connection pool. Return Left Failure if there is a connection failure or read/write error.
access w mos pool act = do
ePipe <- liftIO . runErrorT $ getPipe mos pool
either (return . Left . ConnectionFailure) (runAction act w mos) ePipe
-- | A monad with access to a 'Pipe', 'MasterOrSlaveOk', and 'WriteMode', and throws 'Failure' on read, write, or pipe failure
class (Context Pipe m, Context MasterOrSlaveOk m, Context WriteMode m, Throw Failure m, MonadIO' m) => Access m
instance (Context Pipe m, Context MasterOrSlaveOk m, Context WriteMode m, Throw Failure m, MonadIO' m) => Access m
wrapIO :: (Access m) => (WriteMode -> MasterOrSlaveOk -> Pipe -> IO (Either Failure a)) -> m a
-- ^ Lift IO with Access context and failure into Access monad
wrapIO act = do
writeMod <- context
mos <- context
pipe <- context
e <- liftIO (act writeMod mos pipe)
either throw return e
modifyMVar' :: (Access m) => MVar a -> (a -> Action IO (a, b)) -> m b
modifyMVar' var act = wrapIO $ \w m p -> modifyMVar var $ \a -> do
e <- runAction (act a) w m p
return $ either ((a,) . Left) (Right <$>) e
addMVarFinalizer' :: (Access m) => MVar a -> Action IO () -> m ()
addMVarFinalizer' var act = wrapIO $ \w m p -> do
addMVarFinalizer var $ runAction act w m p >> return () -- ignore any failure
return (Right ())
newtype Action m a = Action (ErrorT Failure (ReaderT WriteMode (ReaderT MasterOrSlaveOk (ReaderT Pipe m))) a)
deriving (Context Pipe, Context MasterOrSlaveOk, Context WriteMode, Throw Failure, MonadIO, Monad, Applicative, Functor)
-- ^ Monad with access to a 'Pipe', 'MasterOrSlaveOk', and 'WriteMode', and throws a 'Failure' on read, write or pipe failure
instance MonadTrans Action where
lift = Action . lift . lift . lift . lift
runAction :: Action m a -> WriteMode -> MasterOrSlaveOk -> Pipe -> m (Either Failure a)
-- ^ Run action with given write mode and read mode (master or slave-ok) against given pipe (TCP connection). Return Left Failure if read/write error or connection failure.
-- 'access' calls runAction. Use this directly if you want to use the same connection and not take from the pool again. However, the connection may still be used by other threads at the same time. For instance, the pool will still hand this connection out.
runAction (Action action) w mos = runReaderT (runReaderT (runReaderT (runErrorT action) w) mos)
-- | 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 ('Pipe') failed. Make work if you try again on the same Mongo 'Connection' which will create a new Pipe. ConnectionFailure IOError -- ^ TCP connection ('Pipeline') failed. May work if you try again on the same Mongo 'Connection' which will create a new Pipe.
| CursorNotFoundFailure CursorId -- ^ Cursor expired because it wasn't accessed for over 10 minutes, or this cursor came from a different server that the one you are currently connected to (perhaps a fail over happen between servers in a replica set) | CursorNotFoundFailure CursorId -- ^ Cursor expired because it wasn't accessed for over 10 minutes, or this cursor came from a different server that the one you are currently connected to (perhaps a fail over happen between servers in a replica set)
| QueryFailure String -- ^ Query failed for some reason as described in the string | QueryFailure String -- ^ Query failed for some reason as described in the string
| WriteFailure ErrorCode String -- ^ Error observed by getLastError after a write, error description is in string | WriteFailure ErrorCode String -- ^ Error observed by getLastError after a write, error description is in string
deriving (Show, Eq) deriving (Show, Eq)
type ErrorCode = Int
-- ^ Error code from getLastError
instance Error Failure where strMsg = error instance Error Failure where strMsg = error
-- ^ 'fail' is treated the same as 'error'. In other words, don't use it. -- ^ 'fail' is treated the same as 'error'. In other words, don't use it.
-- | Values needed when executing a db operation
data Context = Context {
myPipe :: Pipe, -- | operations read/write to this pipelined TCP connection to a MongoDB server
myReadMode :: MasterOrSlaveOk, -- | queries set slaveOk according to this mode
myWriteMode :: WriteMode, -- | writes will automatically issue a getlasterror when this writeMode is `Safe`
myDatabase :: Database } -- | operations query/update this database
access :: (MonadIO m) => Pipe -> WriteMode -> MasterOrSlaveOk -> Database -> Action m a -> m (Either Failure a)
-- ^ Run action under given context. Return Left on Failure.
access myPipe myWriteMode myReadMode myDatabase action = runReaderT (runErrorT action) Context{..}
send :: (MonadIO m) => [Notice] -> Action m ()
-- ^ Send notices as a contiguous batch to server with no reply. Throw 'ConnectionFailure' if pipe fails.
send ns = do
pipe <- asks myPipe
liftIOE ConnectionFailure $ P.send pipe ns
call :: (MonadIO m) => [Notice] -> Request -> Action m (ErrorT Failure IO Reply)
-- ^ Send notices and request as a contiguous batch to server and return reply promise, which will block when invoked until reply arrives. This call will throw 'ConnectionFailure' if pipe fails on send, and promise will throw 'ConnectionFailure' if pipe fails on receive.
call ns r = do
pipe <- asks myPipe
promise <- liftIOE ConnectionFailure $ P.call pipe ns r
return (liftIOE ConnectionFailure promise)
-- * Database -- * Database
newtype Database = Database {databaseName :: UString} deriving (Eq, Ord) type Database = UString
-- ^ Database name
instance Show Database where show (Database x) = unpack x allDatabases :: (MonadIO' m) => Action m [Database]
-- | 'Access' monad with a particular 'Database' in context
class (Context Database m, Access m) => DbAccess m
instance (Context Database m, Access m) => DbAccess m
allDatabases :: (Access m) => m [Database]
-- ^ List all databases residing on server -- ^ List all databases residing on server
allDatabases = map (Database . at "name") . at "databases" <$> use (Database "admin") (runCommand1 "listDatabases") allDatabases = map (at "name") . at "databases" <$> useDb "admin" (runCommand1 "listDatabases")
use :: Database -> ReaderT Database m a -> m a thisDatabase :: (Monad m) => Action m Database
-- ^ Run action against given database
use = flip runReaderT
thisDatabase :: (DbAccess m) => m Database
-- ^ Current database in use -- ^ Current database in use
thisDatabase = context thisDatabase = asks myDatabase
useDb :: (Monad m) => Database -> Action m a -> Action m a
-- ^ Run action against given database
useDb = local . \db ctx -> ctx {myDatabase = db}
-- * Authentication -- * Authentication
auth :: (DbAccess m) => Username -> Password -> m Bool auth :: (MonadIO' m) => Username -> Password -> Action m Bool
-- ^ Authenticate with the database (if server is running in secure mode). Return whether authentication was successful or not. Reauthentication is required for every new pipe. -- ^ 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]
@ -152,7 +125,7 @@ auth usr pss = do
type Collection = UString type Collection = UString
-- ^ Collection name (not prefixed with database) -- ^ Collection name (not prefixed with database)
allCollections :: (DbAccess m) => m [Collection] allCollections :: (MonadMVar m, Functor m) => Action m [Collection]
-- ^ List all collections in this database -- ^ List all collections in this database
allCollections = do allCollections = do
db <- thisDatabase db <- thisDatabase
@ -160,7 +133,7 @@ allCollections = do
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 = U.tail . U.dropWhile (/= '.') dropDbPrefix = U.tail . U.dropWhile (/= '.')
isSpecial (Database db) col = U.any (== '$') col && db <.> col /= "local.oplog.$main" isSpecial db col = U.any (== '$') col && db <.> col /= "local.oplog.$main"
-- * Selection -- * Selection
@ -186,8 +159,6 @@ instance Select Query where
-- * Write -- * Write
-- ** WriteMode
-- | Default write-mode is 'Unsafe' -- | Default write-mode is 'Unsafe'
data WriteMode = data WriteMode =
Unsafe -- ^ Submit writes without receiving acknowledgments. Fast. Assumes writes succeed even though they may not. Unsafe -- ^ Submit writes without receiving acknowledgments. Fast. Assumes writes succeed even though they may not.
@ -201,52 +172,40 @@ safe :: WriteMode
-- ^ Safe [] -- ^ Safe []
safe = Safe [] safe = Safe []
writeMode :: (Access m) => WriteMode -> m a -> m a writeMode :: (Monad m) => WriteMode -> Action m a -> Action m a
-- ^ Run action with given 'WriteMode' -- ^ Run action with given 'WriteMode'
writeMode = push . const writeMode = local . \w ctx -> ctx {myWriteMode = w}
write :: (DbAccess m) => Notice -> m () write :: (MonadIO m) => Notice -> Action m ()
-- ^ Send write to server, and if write-mode is 'Safe' then include getLastError request and raise 'WriteFailure' if it reports an error. -- ^ Send write to server, and if write-mode is 'Safe' then include getLastError request and raise 'WriteFailure' if it reports an error.
write notice = do write notice = asks myWriteMode >>= \mode -> case mode of
mode <- context
case mode of
Unsafe -> send [notice] Unsafe -> send [notice]
Safe params -> do Safe params -> do
me <- getLastError [notice] params let q = query (("getlasterror" =: (1 :: Int)) : params) "$cmd"
maybe (return ()) (throw . uncurry WriteFailure) me Batch _ _ [doc] <- fulfill =<< request [notice] =<< queryRequest False q {limit = 1}
case lookup "err" doc of
type ErrorCode = Int Nothing -> return ()
-- ^ Error code from getLastError Just err -> throwError $ WriteFailure (maybe 0 id $ lookup "code" doc) err
getLastError :: (DbAccess m) => [Notice] -> GetLastError -> m (Maybe (ErrorCode, String))
-- ^ Send notices (writes) then fetch what the last error was, Nothing means no error
getLastError writes params = do
r <- runCommand' writes $ ("getlasterror" =: (1 :: Int)) : params
return $ (at "code" r,) <$> lookup "err" r
{-resetLastError :: (DbConn m) => m ()
-- ^ Clear last error
resetLastError = runCommand1 "reseterror" >> return ()-}
-- ** Insert -- ** Insert
insert :: (DbAccess m) => Collection -> Document -> m Value insert :: (MonadIO' m) => Collection -> Document -> Action m Value
-- ^ Insert document into collection and return its \"_id\" value, which is created automatically if not supplied -- ^ Insert document into collection and return its \"_id\" value, which is created automatically if not supplied
insert col doc = head <$> insertMany col [doc] insert col doc = head <$> insertMany col [doc]
insert_ :: (DbAccess m) => Collection -> Document -> m () insert_ :: (MonadIO' m) => Collection -> Document -> Action m ()
-- ^ Same as 'insert' except don't return _id -- ^ Same as 'insert' except don't return _id
insert_ col doc = insert col doc >> return () insert_ col doc = insert col doc >> return ()
insertMany :: (DbAccess m) => Collection -> [Document] -> m [Value] insertMany :: (MonadIO m) => Collection -> [Document] -> Action m [Value]
-- ^ Insert documents into collection and return their \"_id\" values, which are created automatically if not supplied -- ^ Insert documents into collection and return their \"_id\" values, which are created automatically if not supplied
insertMany col docs = do insertMany col docs = do
Database db <- thisDatabase db <- thisDatabase
docs' <- liftIO $ mapM assignId docs docs' <- liftIO $ mapM assignId docs
write (Insert (db <.> col) docs') write (Insert (db <.> col) docs')
mapM (look "_id") docs' mapM (look "_id") docs'
insertMany_ :: (DbAccess m) => Collection -> [Document] -> m () insertMany_ :: (MonadIO m) => Collection -> [Document] -> Action m ()
-- ^ Same as 'insertMany' except don't return _ids -- ^ Same as 'insertMany' except don't return _ids
insertMany_ col docs = insertMany col docs >> return () insertMany_ col docs = insertMany col docs >> return ()
@ -258,60 +217,58 @@ assignId doc = if X.any (("_id" ==) . label) doc
-- ** Update -- ** Update
save :: (DbAccess m) => Collection -> Document -> m () save :: (MonadIO' m) => Collection -> Document -> Action m ()
-- ^ Save document to collection, meaning insert it if its new (has no \"_id\" field) or update it if its not new (has \"_id\" field) -- ^ Save 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 :: (DbAccess m) => Selection -> Document -> m () replace :: (MonadIO m) => Selection -> Document -> Action m ()
-- ^ Replace first document in selection with given document -- ^ Replace first document in selection with given document
replace = update [] replace = update []
repsert :: (DbAccess m) => Selection -> Document -> m () repsert :: (MonadIO m) => Selection -> Document -> Action m ()
-- ^ Replace first document in selection with given document, or insert document if selection is empty -- ^ Replace first document in selection with given document, or insert document if selection is empty
repsert = update [Upsert] repsert = update [Upsert]
type Modifier = Document type Modifier = Document
-- ^ Update operations on fields in a document. See <http://www.mongodb.org/display/DOCS/Updating#Updating-ModifierOperations> -- ^ Update operations on fields in a document. See <http://www.mongodb.org/display/DOCS/Updating#Updating-ModifierOperations>
modify :: (DbAccess m) => Selection -> Modifier -> m () modify :: (MonadIO m) => Selection -> Modifier -> Action m ()
-- ^ Update all documents in selection using given modifier -- ^ Update all documents in selection using given modifier
modify = update [MultiUpdate] modify = update [MultiUpdate]
update :: (DbAccess m) => [UpdateOption] -> Selection -> Document -> m () update :: (MonadIO m) => [UpdateOption] -> Selection -> Document -> Action m ()
-- ^ Update first document in selection using updater document, unless 'MultiUpdate' option is supplied then update all documents in selection. If 'Upsert' option is supplied then treat updater as document and insert it if selection is empty. -- ^ Update 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
Database db <- thisDatabase db <- thisDatabase
write (Update (db <.> col) opts sel up) write (Update (db <.> col) opts sel up)
-- ** Delete -- ** Delete
delete :: (DbAccess m) => Selection -> m () delete :: (MonadIO m) => Selection -> Action m ()
-- ^ Delete all documents in selection -- ^ Delete all documents in selection
delete = delete' [] delete = delete' []
deleteOne :: (DbAccess m) => Selection -> m () deleteOne :: (MonadIO m) => Selection -> Action m ()
-- ^ Delete first document in selection -- ^ Delete first document in selection
deleteOne = delete' [SingleRemove] deleteOne = delete' [SingleRemove]
delete' :: (DbAccess m) => [DeleteOption] -> Selection -> m () delete' :: (MonadIO m) => [DeleteOption] -> Selection -> Action m ()
-- ^ Delete all documents in selection unless 'SingleRemove' option is given then only delete first document in selection -- ^ Delete 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
Database db <- thisDatabase db <- thisDatabase
write (Delete (db <.> col) opts sel) write (Delete (db <.> col) opts sel)
-- * Read -- * Read
-- ** MasterOrSlaveOk readMode :: (Monad m) => MasterOrSlaveOk -> Action m a -> Action m a
readMode :: (Access m) => MasterOrSlaveOk -> m a -> m a
-- ^ Execute action using given read mode. Master = consistent reads, SlaveOk = eventually consistent reads. -- ^ Execute action using given read mode. Master = consistent reads, SlaveOk = eventually consistent reads.
readMode = push . const readMode = local . \r ctx -> ctx {myReadMode = r}
msOption :: MasterOrSlaveOk -> [P.QueryOption] msOption :: MasterOrSlaveOk -> [QueryOption]
msOption Master = [] msOption Master = []
msOption SlaveOk = [P.SlaveOK] msOption SlaveOk = [SlaveOK]
-- ** Query -- ** Query
@ -328,18 +285,6 @@ data Query = Query {
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)
data QueryOption =
TailableCursor -- ^ Tailable means cursor is not closed when the last data is retrieved. Rather, the cursor marks the final object's position. You can resume using the cursor later, from where it was located, if more data were received. Like any "latent cursor", the cursor may become invalid at some point – for example if the final object it references were deleted. Thus, you should be prepared to requery on CursorNotFound exception.
| NoCursorTimeout -- The server normally times out idle cursors after an inactivity period (10 minutes) to prevent excess memory use. Set this option to prevent that.
| AwaitData -- ^ Use with TailableCursor. If we are at the end of the data, block for a while rather than returning no data. After a timeout period, we do return as normal.
deriving (Show, Eq)
pOption :: QueryOption -> P.QueryOption
-- ^ Convert to protocol query option
pOption TailableCursor = P.TailableCursor
pOption NoCursorTimeout = P.NoCursorTimeout
pOption AwaitData = P.AwaitData
type Projector = Document 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@.
@ -356,20 +301,43 @@ query :: Selector -> Collection -> Query
-- ^ Selects documents in collection that match selector. It uses no query options, projects all fields, does not skip any documents, does not limit result size, uses default batch size, does not sort, does not hint, and does not snapshot. -- ^ Selects documents in collection that match selector. It uses no query options, projects all fields, does not skip any documents, does not limit result size, uses default batch size, does not sort, does not hint, and does not snapshot.
query sel col = Query [] (Select sel col) [] 0 0 [] False 0 [] query sel col = Query [] (Select sel col) [] 0 0 [] False 0 []
batchSizeRemainingLimit :: BatchSize -> Limit -> (Int32, Limit) find :: (MonadMVar m) => Query -> Action m Cursor
-- ^ Given batchSize and limit return P.qBatchSize and remaining limit -- ^ Fetch documents satisfying query
batchSizeRemainingLimit batchSize limit = if limit == 0 find q@Query{selection, batchSize} = do
then (fromIntegral batchSize', 0) -- no limit db <- thisDatabase
else if 0 < batchSize' && batchSize' < limit dBatch <- request [] =<< queryRequest False q
then (fromIntegral batchSize', limit - batchSize') newCursor db (coll selection) batchSize dBatch
else (- fromIntegral limit, 1)
where batchSize' = if batchSize == 1 then 2 else batchSize
-- batchSize 1 is broken because server converts 1 to -1 meaning limit 1
queryRequest :: Bool -> MasterOrSlaveOk -> Query -> Database -> (Request, Limit) findOne :: (MonadIO m) => Query -> Action m (Maybe Document)
-- ^ Fetch first document satisfying query or Nothing if none satisfy it
findOne q = do
Batch _ _ docs <- fulfill =<< request [] =<< queryRequest False q {limit = 1}
return (listToMaybe docs)
explain :: (MonadIO m) => Query -> Action m Document
-- ^ Return performance stats of query execution
explain q = do -- same as findOne but with explain set to true
Batch _ _ docs <- fulfill =<< request [] =<< queryRequest True q {limit = 1}
return $ if null docs then error ("no explain: " ++ show q) else head docs
count :: (MonadIO' m) => Query -> Action m Int
-- ^ Fetch number of documents satisfying query (including effect of skip and/or limit if present)
count Query{selection = Select sel col, skip, limit} = at "n" <$> runCommand
(["count" =: col, "query" =: sel, "skip" =: (fromIntegral skip :: Int32)]
++ ("limit" =? if limit == 0 then Nothing else Just (fromIntegral limit :: Int32)))
distinct :: (MonadIO' m) => Label -> Selection -> Action m [Value]
-- ^ Fetch distinct values of field in selected documents
distinct k (Select sel col) = at "values" <$> runCommand ["distinct" =: col, "key" =: k, "query" =: sel]
queryRequest :: (Monad m) => Bool -> Query -> Action m (Request, Limit)
-- ^ Translate Query to Protocol.Query. If first arg is true then add special $explain attribute. -- ^ Translate Query to Protocol.Query. If first arg is true then add special $explain attribute.
queryRequest isExplain mos Query{..} (Database db) = (P.Query{..}, remainingLimit) where queryRequest isExplain Query{..} = do
qOptions = msOption mos ++ map pOption options ctx <- ask
return $ queryRequest' (myReadMode ctx) (myDatabase ctx)
where
queryRequest' mos db = (P.Query{..}, remainingLimit) where
qOptions = msOption mos ++ 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
@ -381,122 +349,93 @@ queryRequest isExplain mos Query{..} (Database db) = (P.Query{..}, remainingLimi
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
runQuery :: (DbAccess m) => Bool -> [Notice] -> Query -> m DelayedCursorState batchSizeRemainingLimit :: BatchSize -> Limit -> (Int32, Limit)
-- ^ Send query request and return cursor state -- ^ Given batchSize and limit return P.qBatchSize and remaining limit
runQuery isExplain ns q = do batchSizeRemainingLimit batchSize limit = if limit == 0
db <- thisDatabase then (fromIntegral batchSize', 0) -- no limit
slaveOK <- context else if 0 < batchSize' && batchSize' < limit
request ns (queryRequest isExplain slaveOK q db) then (fromIntegral batchSize', limit - batchSize')
else (- fromIntegral limit, 1)
where batchSize' = if batchSize == 1 then 2 else batchSize
-- batchSize 1 is broken because server converts 1 to -1 meaning limit 1
find :: (DbAccess m) => Query -> m Cursor type DelayedBatch = ErrorT Failure IO Batch
-- ^ Fetch documents satisfying query -- ^ A promised batch which may fail
find q@Query{selection, batchSize} = do
db <- thisDatabase
dcs <- runQuery False [] q
newCursor db (coll selection) batchSize dcs
findOne' :: (DbAccess m) => [Notice] -> Query -> m (Maybe Document) data Batch = Batch Limit CursorId [Document]
-- ^ Send notices and fetch first document satisfying query or Nothing if none satisfy it -- ^ CursorId = 0 means cursor is finished. Documents is remaining documents to serve in current batch. Limit is remaining limit for next fetch.
findOne' ns q = do
CS _ _ docs <- mapErrorIO id =<< runQuery False ns q {limit = 1}
return (listToMaybe docs)
findOne :: (DbAccess m) => Query -> m (Maybe Document) request :: (MonadIO m) => [Notice] -> (Request, Limit) -> Action m DelayedBatch
-- ^ Fetch first document satisfying query or Nothing if none satisfy it -- ^ Send notices and request and return promised batch
findOne = findOne' []
explain :: (DbAccess m) => Query -> m Document
-- ^ Return performance stats of query execution
explain q = do -- same as findOne but with explain set to true
CS _ _ docs <- mapErrorIO id =<< runQuery True [] q {limit = 1}
return $ if null docs then error ("no explain: " ++ show q) else head docs
count :: (DbAccess m) => Query -> m Int
-- ^ Fetch number of documents satisfying query (including effect of skip and/or limit if present)
count Query{selection = Select sel col, skip, limit} = at "n" <$> runCommand
(["count" =: col, "query" =: sel, "skip" =: (fromIntegral skip :: Int32)]
++ ("limit" =? if limit == 0 then Nothing else Just (fromIntegral limit :: Int32)))
distinct :: (DbAccess m) => Label -> Selection -> m [Value]
-- ^ Fetch distinct values of field in selected documents
distinct k (Select sel col) = at "values" <$> runCommand ["distinct" =: col, "key" =: k, "query" =: sel]
-- *** Cursor
data Cursor = Cursor FullCollection BatchSize (MVar DelayedCursorState)
-- ^ Iterator over results of a query. Use 'next' to iterate or 'rest' to get all results. A cursor is closed when it is explicitly closed, all results have been read from it, garbage collected, or not used for over 10 minutes (unless 'NoCursorTimeout' option was specified in 'Query'). Reading from a closed cursor raises a 'CursorNotFoundFailure'. Note, a cursor is not closed when the pipe is closed, so you can open another pipe to the same server and continue using the cursor.
getCursorState :: (Access m) => Cursor -> m CursorState
-- ^ Extract current cursor status
getCursorState (Cursor _ _ var) = mapErrorIO id =<< readMVar var
type DelayedCursorState = ErrorT Failure IO CursorState
-- ^ A promised cursor state which may fail
request :: (Access m) => [Notice] -> (Request, Limit) -> m DelayedCursorState
-- ^ Send notices and request and return promised cursor state
request 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
data CursorState = CS Limit CursorId [Document] fromReply :: Limit -> Reply -> DelayedBatch
-- ^ CursorId = 0 means cursor is finished. Documents is remaining documents to serve in current batch. Limit is remaining limit for next fetch. -- ^ Convert Reply to Batch or Failure
fromReply :: (Throw Failure m) => Limit -> Reply -> m CursorState
-- ^ Convert Reply to CursorState or Failure
fromReply limit Reply{..} = do fromReply limit Reply{..} = do
mapM_ checkResponseFlag rResponseFlags mapM_ checkResponseFlag rResponseFlags
return (CS 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 -> throw (CursorNotFoundFailure rCursorId) CursorNotFound -> throwError (CursorNotFoundFailure rCursorId)
QueryError -> throw (QueryFailure $ at "$err" $ head rDocuments) QueryError -> throwError (QueryFailure $ at "$err" $ head rDocuments)
newCursor :: (Access m) => Database -> Collection -> BatchSize -> DelayedCursorState -> m Cursor fulfill :: (MonadIO m) => DelayedBatch -> ErrorT Failure m Batch
-- ^ Demand and wait for result, raise failure if exception
fulfill = liftIOE id
-- *** Cursor
data Cursor = Cursor FullCollection BatchSize (MVar DelayedBatch)
-- ^ Iterator over results of a query. Use 'next' to iterate or 'rest' to get all results. A cursor is closed when it is explicitly closed, all results have been read from it, garbage collected, or not used for over 10 minutes (unless 'NoCursorTimeout' option was specified in 'Query'). Reading from a closed cursor raises a 'CursorNotFoundFailure'. Note, a cursor is not closed when the pipe is closed, so you can open another pipe to the same server and continue using the cursor.
newCursor :: (MonadMVar m) => Database -> Collection -> BatchSize -> DelayedBatch -> Action m Cursor
-- ^ Create new cursor. If you don't read all results then close it. Cursor will be closed automatically when all results are read from it or when eventually garbage collected. -- ^ Create new cursor. If you don't read all results then close it. Cursor will be closed automatically when all results are read from it or when eventually garbage collected.
newCursor (Database db) col batch cs = do newCursor db col batchSize dBatch = do
var <- newMVar cs var <- newMVar dBatch
let cursor = Cursor (db <.> col) batch var let cursor = Cursor (db <.> col) batchSize var
addMVarFinalizer' var (closeCursor cursor) addMVarFinalizer var (closeCursor cursor)
return cursor return cursor
next :: (Access m) => Cursor -> m (Maybe Document) next :: (MonadMVar m) => Cursor -> Action m (Maybe Document)
-- ^ Return next document in query result, or Nothing if finished. -- ^ Return next document in query result, or Nothing if finished.
next (Cursor fcol batch var) = modifyMVar' var nextState where next (Cursor fcol batchSize var) = modifyMVar var nextState where
-- Pre-fetch next batch promise from server when last one in current batch is returned. -- Pre-fetch next batch promise from server when last one in current batch is returned.
nextState:: DelayedCursorState -> Action IO (DelayedCursorState, Maybe Document) -- nextState:: DelayedBatch -> Action m (DelayedBatch, Maybe Document)
nextState dcs = do nextState dBatch = do
CS limit cid docs <- mapErrorIO id dcs Batch limit cid docs <- fulfill dBatch
case docs of case docs of
doc : docs' -> do doc : docs' -> do
dcs' <- if null docs' && cid /= 0 dBatch' <- if null docs' && cid /= 0
then nextBatch limit cid then nextBatch limit cid
else return $ return (CS limit cid docs') else return $ return (Batch limit cid docs')
return (dcs', Just doc) return (dBatch', Just doc)
[] -> if cid == 0 [] -> if cid == 0
then return (return $ CS 0 0 [], Nothing) -- finished then return (return $ Batch 0 0 [], Nothing) -- finished
else error $ "server returned empty batch but says more results on server" else error $ "server returned empty batch but says more results on server"
nextBatch limit cid = request [] (GetMore fcol batchSize cid, remLimit) nextBatch limit cid = request [] (GetMore fcol batchSize' cid, remLimit)
where (batchSize, remLimit) = batchSizeRemainingLimit batch limit where (batchSize', remLimit) = batchSizeRemainingLimit batchSize limit
nextN :: (Access m) => Int -> Cursor -> m [Document] nextN :: (MonadMVar m, Functor m) => Int -> Cursor -> Action m [Document]
-- ^ Return next N documents or less if end is reached -- ^ Return next N documents or less if end is reached
nextN n c = catMaybes <$> replicateM n (next c) nextN n c = catMaybes <$> replicateM n (next c)
rest :: (Access m) => Cursor -> m [Document] rest :: (MonadMVar m, Functor m) => Cursor -> Action m [Document]
-- ^ Return remaining documents in query result -- ^ Return remaining documents in query result
rest c = loop (next c) rest c = loop (next c)
closeCursor :: (Access m) => Cursor -> m () closeCursor :: (MonadMVar m) => Cursor -> Action m ()
closeCursor (Cursor _ _ var) = modifyMVar' var kill' where closeCursor (Cursor _ _ var) = modifyMVar var $ \dBatch -> do
kill' dcs = first return <$> (kill =<< mapErrorIO id dcs) Batch _ cid _ <- fulfill dBatch
kill (CS _ cid _) = (CS 0 0 [],) <$> if cid == 0 then return () else send [KillCursors [cid]] unless (cid == 0) $ send [KillCursors [cid]]
return $ (return $ Batch 0 0 [], ())
isCursorClosed :: (Access m) => Cursor -> m Bool isCursorClosed :: (MonadIO m) => Cursor -> Action m Bool
isCursorClosed cursor = do isCursorClosed (Cursor _ _ var) = do
CS _ cid docs <- getCursorState cursor Batch _ cid docs <- fulfill =<< readMVar var
return (cid == 0 && null docs) return (cid == 0 && null docs)
-- ** Group -- ** Group
@ -524,7 +463,7 @@ groupDocument Group{..} =
"initial" =: gInitial, "initial" =: gInitial,
"cond" =: gCond ] "cond" =: gCond ]
group :: (DbAccess m) => Group -> m [Document] group :: (MonadIO' m) => Group -> Action m [Document]
-- ^ Execute group query and return resulting aggregate value for each distinct key -- ^ Execute group query and return resulting aggregate value for each distinct key
group g = at "retval" <$> runCommand ["group" =: groupDocument g] group g = at "retval" <$> runCommand ["group" =: groupDocument g]
@ -590,23 +529,23 @@ mrOutDoc (Output mrMerge coll mDB) = (mergeName mrMerge =: coll) : mdb mDB where
mergeName Merge = "merge" mergeName Merge = "merge"
mergeName Reduce = "reduce" mergeName Reduce = "reduce"
mdb Nothing = [] mdb Nothing = []
mdb (Just (Database 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.
mapReduce col map' red = MapReduce col map' red [] [] 0 Inline Nothing [] False mapReduce col map' red = MapReduce col map' red [] [] 0 Inline Nothing [] False
runMR :: (DbAccess m) => MapReduce -> m Cursor runMR :: (MonadMVar m, Applicative m) => MapReduce -> Action m Cursor
-- ^ Run MapReduce and return cursor of results. Error if map/reduce fails (because of bad Javascript) -- ^ 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) -> use (Database $ at "db" doc) $ find $ query [] (at "collection" doc) Just (Doc doc) -> useDb (at "db" doc) $ find $ query [] (at "collection" doc)
Just x -> error $ "unexpected map-reduce result field: " ++ show x Just x -> error $ "unexpected map-reduce result field: " ++ show x
Nothing -> newCursor (Database "") "" 0 $ return $ CS 0 0 (at "results" res) Nothing -> newCursor "" "" 0 $ return $ Batch 0 0 (at "results" res)
runMR' :: (DbAccess m) => MapReduce -> m MRResult runMR' :: (MonadIO' m) => MapReduce -> Action m MRResult
-- ^ Run MapReduce and return a MR result document containing stats and the results if Inlined. Error if the map/reduce failed (because of bad Javascript). -- ^ 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)
@ -617,40 +556,20 @@ runMR' mr = do
type Command = Document type Command = Document
-- ^ A command is a special query or action against the database. See <http://www.mongodb.org/display/DOCS/Commands> for details. -- ^ A command is a special query or action against the database. See <http://www.mongodb.org/display/DOCS/Commands> for details.
runCommand' :: (DbAccess m) => [Notice] -> Command -> m Document runCommand :: (MonadIO' m) => Command -> Action m Document
-- ^ Send notices then run command and return its result -- ^ Run command against the database and return its result
runCommand' ns c = maybe err id <$> findOne' ns (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
runCommand :: (DbAccess m) => Command -> m Document runCommand1 :: (MonadIO' m) => UString -> Action m Document
-- ^ Run command against the database and return its result
runCommand = runCommand' []
runCommand1 :: (DbAccess m) => UString -> m Document
-- ^ @runCommand1 foo = runCommand [foo =: 1]@ -- ^ @runCommand1 foo = runCommand [foo =: 1]@
runCommand1 c = runCommand [c =: (1 :: Int)] runCommand1 c = runCommand [c =: (1 :: Int)]
eval :: (DbAccess m) => Javascript -> m Document eval :: (MonadIO' m) => Javascript -> Action m Document
-- ^ Run code on server -- ^ Run code on server
eval code = at "retval" <$> runCommand ["$eval" =: code] eval code = at "retval" <$> runCommand ["$eval" =: code]
-- * Primitives
send :: (Context Pipe m, Throw Failure m, MonadIO m) => [Notice] -> m ()
-- ^ Send notices as a contiguous batch to server with no reply. Throw 'ConnectionFailure' if pipe fails.
send ns = do
pipe <- context
mapErrorIO ConnectionFailure (P.send pipe ns)
call :: (Context Pipe m, Throw Failure m, MonadIO m, Throw Failure n, MonadIO n) =>
[Notice] -> Request -> m (n Reply)
-- ^ Send notices and request as a contiguous batch to server and return reply promise, which will block when invoked until reply arrives. This call will throw 'ConnectionFailure' if pipe fails on send, and promise will throw 'ConnectionFailure' if pipe fails on receive.
call ns r = do
pipe <- context
promise <- mapErrorIO ConnectionFailure (P.call pipe ns r)
return (mapErrorIO ConnectionFailure promise)
{- Authors: Tony Hannan <tony@10gen.com> {- Authors: Tony Hannan <tony@10gen.com>
Copyright 2010 10gen Inc. Copyright 2011 10gen Inc.
Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in compliance with the License. You may obtain a copy of the License at: http://www.apache.org/licenses/LICENSE-2.0. Unless required by applicable law or agreed to in writing, software distributed under the License is distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the License for the specific language governing permissions and limitations under the License. -} Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in compliance with the License. You may obtain a copy of the License at: http://www.apache.org/licenses/LICENSE-2.0. Unless required by applicable law or agreed to in writing, software distributed under the License is distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the License for the specific language governing permissions and limitations under the License. -}

63
Network/Abstract.hs
View file

@ -1,63 +0,0 @@
-- | Generalize a network connection to a sink and source
{-# LANGUAGE MultiParamTypeClasses, ExistentialQuantification, FlexibleContexts, FlexibleInstances, OverlappingInstances, UndecidableInstances #-}
module Network.Abstract where
import System.IO (Handle, hClose)
import Network (HostName, PortID, connectTo)
import Control.Monad.Error
import System.IO.Error (try)
import Control.Monad.Context
import Control.Monad.Util (MonadIO')
type IOE = ErrorT IOError IO
-- ^ Be explicit about exception that may be raised.
data Server i o = Server HostName PortID
-- ^ A server receives messages of type i and returns messages of type o.
-- | Serialize message over handle
class WriteMessage i where
writeMessage :: Handle -> i -> IOE ()
-- | Deserialize message from handle
class ReadMessage o where
readMessage :: Handle -> IOE o
-- | A network controls connections to other hosts. It may want to overide to log messages or play them back.
class Network n where
connect :: (WriteMessage i, ReadMessage o) => n -> Server i o -> IOE (Connection i o)
-- ^ Connect to Server returning the send sink and receive source, throw IOError if can't connect.
data Connection i o = Connection {
send :: i -> IOE (),
receive :: IOE o,
close :: IO () }
data ANetwork = forall n. (Network n) => ANetwork n
instance Network (ANetwork) where
connect (ANetwork n) = connect n
data Internet = Internet
-- ^ Normal Network instance, i.e. no logging or replay
-- | Connect to server. Write messages and receive replies. Not thread-safe, must be wrapped in Pipeline or something.
instance Network Internet where
connect _ (Server hostname portid) = ErrorT . try $ do
handle <- connectTo hostname portid
return $ Connection (writeMessage handle) (readMessage handle) (hClose handle)
class (MonadIO' m) => NetworkIO m where
network :: m ANetwork
instance (Context ANetwork m, MonadIO' m) => NetworkIO m where
network = context
instance NetworkIO IO where
network = return (ANetwork Internet)
{- Authors: Tony Hannan <tony@10gen.com>
Copyright 2010 10gen Inc.
Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in compliance with the License. You may obtain a copy of the License at: http://www.apache.org/licenses/LICENSE-2.0. Unless required by applicable law or agreed to in writing, software distributed under the License is distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the License for the specific language governing permissions and limitations under the License. -}

80
Control/Pipeline.hs → System/IO/Pipeline.hs
View file

@ -1,53 +1,71 @@
{- | Pipelining is sending multiple requests over a socket and receiving the responses later, in the same order. This is faster than sending one request, waiting for the response, then sending the next request, and so on. This implementation returns a /promise (future)/ response for each request that when invoked waits for the response if not already arrived. Multiple threads can send on the same pipeline (and get promises back); it will pipeline each thread's request right away without waiting. {- | Pipelining is sending multiple requests over a socket and receiving the responses later, in the same order. This is faster than sending one request, waiting for the response, then sending the next request, and so on. This implementation returns a /promise (future)/ response for each request that when invoked waits for the response if not already arrived. Multiple threads can send on the same pipeline (and get promises back); it will send each thread's request right away without waiting.
A pipeline closes itself when a read or write causes an error, so you can detect a broken pipeline by checking isClosed. It also closes itself when garbage collected, or you can close it explicitly. -} A pipeline closes itself when a read or write causes an error, so you can detect a broken pipeline by checking isClosed. It also closes itself when garbage collected, or you can close it explicitly. -}
{-# LANGUAGE DoRec, RecordWildCards, NamedFieldPuns, ScopedTypeVariables #-} {-# LANGUAGE DoRec, RecordWildCards, NamedFieldPuns, ScopedTypeVariables #-}
module Control.Pipeline ( module System.IO.Pipeline (
IOE,
-- * IOStream
IOStream(..),
-- * Pipeline -- * Pipeline
Pipeline, newPipeline, send, call, close, isClosed Pipeline, newPipeline, send, call, close, isClosed
) where ) where
import Control.Monad.Throw (onException) import Prelude hiding (length)
import Control.Monad.Error
import Control.Concurrent (ThreadId, forkIO, killThread)
import GHC.Conc (ThreadStatus(..), threadStatus) import GHC.Conc (ThreadStatus(..), threadStatus)
import Control.Monad.MVar import Control.Concurrent (ThreadId, forkIO, killThread)
import Control.Concurrent.Chan import Control.Concurrent.Chan
import Network.Abstract (IOE) import Control.Monad.MVar
import qualified Network.Abstract as C import Control.Monad.Error
onException :: (Monad m) => ErrorT e m a -> m () -> ErrorT e m a
-- ^ If first action throws an exception then run second action then re-throw
onException (ErrorT action) releaser = ErrorT $ do
e <- action
either (const releaser) (const $ return ()) e
return e
type IOE = ErrorT IOError IO
-- * IOStream
-- | An IO sink and source where value of type @o@ are sent and values of type @i@ are received.
data IOStream i o = IOStream {
writeStream :: o -> IOE (),
readStream :: IOE i,
closeStream :: IO () }
-- * Pipeline -- * Pipeline
-- | Thread-safe and pipelined connection -- | Thread-safe and pipelined connection
data Pipeline i o = Pipeline { data Pipeline i o = Pipeline {
vConn :: MVar (C.Connection i o), -- ^ Mutex on handle, so only one thread at a time can write to it vStream :: MVar (IOStream i o), -- ^ Mutex on handle, so only one thread at a time can write to it
responseQueue :: Chan (MVar (Either IOError o)), -- ^ Queue of threads waiting for responses. Every time a response arrive we pop the next thread and give it the response. 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 on given connection. You should 'close' pipeline when finished, which will also close connection. If pipeline is not closed but eventually garbage collected, it will be closed along with connection. -- | 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 :: (MonadIO m) => C.Connection i o -> m (Pipeline i o) newPipeline :: IOStream i o -> IO (Pipeline i o)
newPipeline conn = liftIO $ do newPipeline stream = do
vConn <- newMVar conn vStream <- newMVar stream
responseQueue <- newChan responseQueue <- newChan
rec rec
let pipe = Pipeline{..} let pipe = Pipeline{..}
listenThread <- forkIO (listen pipe) listenThread <- forkIO (listen pipe)
addMVarFinalizer vConn $ do addMVarFinalizer vStream $ do
killThread listenThread killThread listenThread
C.close conn closeStream stream
return pipe return pipe
close :: (MonadIO m) => Pipeline i o -> m () close :: Pipeline i o -> IO ()
-- | Close pipe and underlying connection -- | Close pipe and underlying connection
close Pipeline{..} = liftIO $ do close Pipeline{..} = do
killThread listenThread killThread listenThread
C.close =<< readMVar vConn closeStream =<< readMVar vStream
isClosed :: (MonadIO m) => Pipeline i o -> m Bool isClosed :: Pipeline i o -> IO Bool
isClosed Pipeline{listenThread} = liftIO $ do isClosed Pipeline{listenThread} = do
status <- threadStatus listenThread status <- threadStatus listenThread
return $ case status of return $ case status of
ThreadRunning -> False ThreadRunning -> False
@ -59,31 +77,31 @@ isClosed Pipeline{listenThread} = liftIO $ do
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
conn <- readMVar vConn stream <- readMVar vStream
forever $ do forever $ do
e <- runErrorT $ C.receive conn e <- runErrorT $ readStream stream
var <- readChan responseQueue var <- readChan responseQueue
putMVar var e putMVar var e
case e of case e of
Left err -> C.close conn >> ioError err -- close and stop looping Left err -> closeStream stream >> ioError err -- close and stop looping
Right _ -> return () Right _ -> return ()
send :: Pipeline i o -> i -> IOE () send :: Pipeline i o -> o -> IOE ()
-- ^ Send message to destination; the destination must not response (otherwise future 'call's will get these responses instead of their own). -- ^ Send message to destination; the destination must not response (otherwise future 'call's will get these responses instead of their own).
-- Throw IOError and close pipeline if send fails -- Throw IOError and close pipeline if send fails
send p@Pipeline{..} message = withMVar vConn (flip C.send message) `onException` \(_ :: IOError) -> close p send p@Pipeline{..} message = withMVar vStream (flip writeStream message) `onException` close p
call :: Pipeline i o -> i -> IOE (IOE o) call :: Pipeline i o -> o -> IOE (IOE i)
-- ^ Send message to destination and return /promise/ of response from one message only. The destination must reply to the message (otherwise promises will have the wrong responses in them). -- ^ 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 vConn doCall `onException` \(_ :: IOError) -> close p where call p@Pipeline{..} message = withMVar vStream doCall `onException` close p where
doCall conn = do doCall stream = do
C.send conn 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>
Copyright 2010 10gen Inc. Copyright 2011 10gen Inc.
Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in compliance with the License. You may obtain a copy of the License at: http://www.apache.org/licenses/LICENSE-2.0. Unless required by applicable law or agreed to in writing, software distributed under the License is distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the License for the specific language governing permissions and limitations under the License. -} Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in compliance with the License. You may obtain a copy of the License at: http://www.apache.org/licenses/LICENSE-2.0. Unless required by applicable law or agreed to in writing, software distributed under the License is distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the License for the specific language governing permissions and limitations under the License. -}

11
mongoDB.cabal
View file

@ -1,5 +1,5 @@
name: mongoDB name: mongoDB
version: 0.10.0 version: 1.0.0
build-type: Simple build-type: Simple
license: OtherLicense license: OtherLicense
license-file: LICENSE license-file: LICENSE
@ -16,7 +16,8 @@ build-depends:
cryptohash -any, cryptohash -any,
network -any, network -any,
parsec -any, parsec -any,
random -any random -any,
random-shuffle -any
stability: alpha stability: alpha
homepage: http://github.com/TonyGen/mongoDB-haskell homepage: http://github.com/TonyGen/mongoDB-haskell
package-url: package-url:
@ -31,18 +32,14 @@ data-dir: ""
extra-source-files: extra-source-files:
extra-tmp-files: extra-tmp-files:
exposed-modules: exposed-modules:
Control.Monad.Context
Control.Monad.MVar Control.Monad.MVar
Control.Monad.Throw
Control.Monad.Util
Control.Pipeline
Database.MongoDB Database.MongoDB
Database.MongoDB.Admin Database.MongoDB.Admin
Database.MongoDB.Connection Database.MongoDB.Connection
Database.MongoDB.Internal.Protocol Database.MongoDB.Internal.Protocol
Database.MongoDB.Internal.Util Database.MongoDB.Internal.Util
Database.MongoDB.Query Database.MongoDB.Query
Network.Abstract System.IO.Pipeline
Var.Pool Var.Pool
exposed: True exposed: True
buildable: True buildable: True