module Database.MongoDB
(
Connection, ConnectOpt(..),
connect, connectOnPort, conClose, disconnect, dropDatabase,
connectCluster, connectClusterOnPort,
serverInfo, serverShutdown,
databasesInfo, databaseNames,
Database, MongoDBCollectionInvalid, Password, Username,
ColCreateOpt(..),
collectionNames, createCollection, dropCollection,
renameCollection, runCommand, validateCollection,
auth, addUser, login, logout,
Collection, FieldSelector, FullCollection,
NumToSkip, NumToReturn, Selector,
QueryOpt(..),
UpdateFlag(..),
count, countMatching, delete, insert, insertMany, query, remove, update,
save,
find, findOne, quickFind, quickFind',
whereClause,
Cursor,
allDocs, allDocs', finish, nextDoc,
Key, Unique,
Direction(..),
createIndex, dropIndex, dropIndexes, indexInformation,
MapReduceOpt(..),
mapReduce, mapReduceWScopes,
runMapReduce, runMapReduceWScopes,
mapReduceResults,
)
where
import Control.Exception
import Control.Monad
import Data.Binary()
import Data.Binary.Get
import Data.Binary.Put
import Data.Bits
import Data.ByteString.Char8 (pack)
import Data.ByteString.Internal (c2w)
import qualified Data.ByteString.Lazy as L
import qualified Data.ByteString.Lazy.UTF8 as L8
import Data.Digest.OpenSSL.MD5
import Data.Int
import Data.IORef
import qualified Data.List as List
import Data.Maybe
import Data.Typeable
import Database.MongoDB.BSON as BSON
import Database.MongoDB.Util
import qualified Network
import Network.Socket hiding (connect, send, sendTo, recv, recvFrom)
import Prelude hiding (getContents)
import System.IO
import System.IO.Unsafe
import System.Random
data Connection = Connection {
cHandle :: IORef Handle,
cRand :: IORef [Int],
cOidGen :: ObjectIdGen
}
data ConnectOpt
= SlaveOK
deriving (Show, Eq)
connect :: HostName -> [ConnectOpt] -> IO Connection
connect = flip connectOnPort (Network.PortNumber 27017)
connectCluster :: [HostName] -> [ConnectOpt] -> IO Connection
connectCluster xs =
connectClusterOnPort (fmap (flip (,) $ Network.PortNumber 27017) xs)
connectClusterOnPort :: [(HostName, Network.PortID)] -> [ConnectOpt]
-> IO Connection
connectClusterOnPort [] _ = throwOpFailure "No hostnames in list"
connectClusterOnPort servers opts = newConnection servers opts
connectOnPort :: HostName -> Network.PortID -> [ConnectOpt] -> IO Connection
connectOnPort host port = newConnection [(host, port)]
newConnection :: [(HostName, Network.PortID)] -> [ConnectOpt] -> IO Connection
newConnection servers opts = do
r <- newStdGen
let ns = randomRs (fromIntegral (minBound :: Int32),
fromIntegral (maxBound :: Int32)) r
nsRef <- newIORef ns
hRef <- openHandle (head servers) >>= newIORef
oidGen <- mkObjectIdGen
let c = Connection hRef nsRef oidGen
res <- isMaster c
if fromBson (fromLookup $ List.lookup (s2L "ismaster") res) == (1::Int) ||
isJust (List.elemIndex SlaveOK opts)
then return c
else case List.lookup (s2L "remote") res of
Nothing -> throwConFailure "Couldn't find master to connect to"
Just server -> do
hRef' <- openHandle (splitHostPort $ fromBson server) >>= newIORef
return $ c {cHandle = hRef'}
openHandle :: (HostName, Network.PortID) -> IO Handle
openHandle (host, port) = do
h <- Network.connectTo host port
hSetBuffering h NoBuffering
return h
getHandle :: Connection -> IO Handle
getHandle c = readIORef $ cHandle c
cPut :: Connection -> L.ByteString -> IO ()
cPut c msg = getHandle c >>= flip L.hPut msg
conClose :: Connection -> IO ()
conClose c = readIORef (cHandle c) >>= hClose
databasesInfo :: Connection -> IO BsonDoc
databasesInfo c =
runCommand c (s2L "admin") $ toBsonDoc [("listDatabases", BsonInt32 1)]
databaseNames :: Connection -> IO [Database]
databaseNames c = do
info <- databasesInfo c
let (BsonArray dbs) = fromLookup $ List.lookup (s2L "databases") info
names = mapMaybe (List.lookup (s2L "name") . fromBson) dbs
return $ List.map fromBson (names::[BsonValue])
disconnect :: Connection -> IO ()
disconnect = conClose
dropDatabase :: Connection -> Database -> IO ()
dropDatabase c db = do
_ <- runCommand c db $ toBsonDoc [("dropDatabase", BsonInt32 1)]
return ()
isMaster :: Connection -> IO BsonDoc
isMaster c = runCommand c (s2L "admin") $ toBsonDoc [("ismaster", BsonInt32 1)]
serverInfo :: Connection -> IO BsonDoc
serverInfo c =
runCommand c (s2L "admin") $ toBsonDoc [("buildinfo", BsonInt32 1)]
serverShutdown :: Connection -> IO BsonDoc
serverShutdown c =
runCommand c (s2L "admin") $ toBsonDoc [("shutdown", BsonInt32 1)]
collectionNames :: Connection -> Database -> IO [FullCollection]
collectionNames c db = do
docs <- quickFind' c (L.append db $ s2L ".system.namespaces") empty
let names = flip List.map docs $
fromBson . fromLookup . List.lookup (s2L "name")
return $ List.filter (L.notElem $ c2w '$') names
data ColCreateOpt = CCOSize Int64
| CCOCapped Bool
| CCOMax Int64
deriving (Show, Eq)
colCreateOptToBson :: ColCreateOpt -> (String, BsonValue)
colCreateOptToBson (CCOSize sz) = ("size", toBson sz)
colCreateOptToBson (CCOCapped b) = ("capped", toBson b)
colCreateOptToBson (CCOMax m) = ("max", toBson m)
createCollection :: Connection -> FullCollection -> [ColCreateOpt] -> IO ()
createCollection c col opts = do
(db, col') <- validateCollectionName col
dbcols <- collectionNames c db
when (col `List.elem` dbcols) $
throwColInvalid $ "Collection already exists: " ++ show col
let cmd = ("create", toBson col') : List.map colCreateOptToBson opts
_ <- runCommand c db $ toBsonDoc cmd
return ()
dropCollection :: Connection -> FullCollection -> IO ()
dropCollection c col = do
let (db, col') = splitFullCol col
_ <- runCommand c db $ toBsonDoc [("drop", toBson col')]
return ()
renameCollection :: Connection -> FullCollection -> FullCollection -> IO ()
renameCollection c col newName = do
_ <- validateCollectionName col
_ <- runCommand c (s2L "admin") $ toBsonDoc [("renameCollection", toBson col),
("to", toBson newName)]
return ()
validateCollection :: Connection -> FullCollection -> IO String
validateCollection c col = do
let (db, col') = splitFullCol col
res <- runCommand c db $ toBsonDoc [("validate", toBson col')]
return $ fromBson $ fromLookup $ List.lookup (s2L "result") res
splitFullCol :: FullCollection -> (Database, Collection)
splitFullCol col = (L.takeWhile (c2w '.' /=) col,
L.tail $ L.dropWhile (c2w '.' /=) col)
splitHostPort :: String -> (HostName, Network.PortID)
splitHostPort hp = (host, port)
where host = List.takeWhile (':' /=) hp
port = case List.dropWhile (':' /=) hp of
"" -> Network.PortNumber 27017
pstr -> Network.Service $ List.tail pstr
runCommand :: Connection -> Database -> BsonDoc -> IO BsonDoc
runCommand c db cmd = do
mres <- findOne c (L.append db $ s2L ".$cmd") cmd
let res = fromLookup mres
when (BsonDouble 1.0 /= fromLookup (List.lookup (s2L "ok") res)) $
throwOpFailure $ "command \"" ++ show cmd ++ "\" failed: " ++
fromBson (fromLookup $ List.lookup (s2L "errmsg") res)
return res
data Cursor = Cursor {
curCon :: Connection,
curID :: IORef Int64,
curNumToRet :: Int32,
curCol :: FullCollection,
curDocBytes :: IORef L.ByteString,
curClosed :: IORef Bool
}
data Opcode
= OPReply
| OPMsg
| OPUpdate
| OPInsert
| OPGetByOid
| OPQuery
| OPGetMore
| OPDelete
| OPKillCursors
deriving (Show, Eq)
data MongoDBInternalError = MongoDBInternalError String
deriving (Eq, Show, Read)
mongoDBInternalError :: TyCon
mongoDBInternalError = mkTyCon "Database.MongoDB.MongoDBInternalError"
instance Typeable MongoDBInternalError where
typeOf _ = mkTyConApp mongoDBInternalError []
instance Exception MongoDBInternalError
data MongoDBCollectionInvalid = MongoDBCollectionInvalid String
deriving (Eq, Show, Read)
mongoDBCollectionInvalid :: TyCon
mongoDBCollectionInvalid = mkTyCon "Database.MongoDB.MongoDBcollectionInvalid"
instance Typeable MongoDBCollectionInvalid where
typeOf _ = mkTyConApp mongoDBCollectionInvalid []
instance Exception MongoDBCollectionInvalid
throwColInvalid :: String -> a
throwColInvalid = throw . MongoDBCollectionInvalid
data MongoDBOperationFailure = MongoDBOperationFailure String
deriving (Eq, Show, Read)
mongoDBOperationFailure :: TyCon
mongoDBOperationFailure = mkTyCon "Database.MongoDB.MongoDBoperationFailure"
instance Typeable MongoDBOperationFailure where
typeOf _ = mkTyConApp mongoDBOperationFailure []
instance Exception MongoDBOperationFailure
throwOpFailure :: String -> a
throwOpFailure = throw . MongoDBOperationFailure
data MongoDBConnectionFailure = MongoDBConnectionFailure String
deriving (Eq, Show, Read)
mongoDBConnectionFailure :: TyCon
mongoDBConnectionFailure = mkTyCon "Database.MongoDB.MongoDBconnectionFailure"
instance Typeable MongoDBConnectionFailure where
typeOf _ = mkTyConApp mongoDBConnectionFailure []
instance Exception MongoDBConnectionFailure
throwConFailure :: String -> a
throwConFailure = throw . MongoDBConnectionFailure
fromOpcode :: Opcode -> Int32
fromOpcode OPReply = 1
fromOpcode OPMsg = 1000
fromOpcode OPUpdate = 2001
fromOpcode OPInsert = 2002
fromOpcode OPGetByOid = 2003
fromOpcode OPQuery = 2004
fromOpcode OPGetMore = 2005
fromOpcode OPDelete = 2006
fromOpcode OPKillCursors = 2007
toOpcode :: Int32 -> Opcode
toOpcode 1 = OPReply
toOpcode 1000 = OPMsg
toOpcode 2001 = OPUpdate
toOpcode 2002 = OPInsert
toOpcode 2003 = OPGetByOid
toOpcode 2004 = OPQuery
toOpcode 2005 = OPGetMore
toOpcode 2006 = OPDelete
toOpcode 2007 = OPKillCursors
toOpcode n = throw $ MongoDBInternalError $ "Got unexpected Opcode: " ++ show n
type Database = L8.ByteString
type FullCollection = L8.ByteString
type Collection = L8.ByteString
type Selector = BsonDoc
type FieldSelector = [L8.ByteString]
type RequestID = Int32
type NumToSkip = Int32
type NumToReturn = Int32
type Username = String
type Password = String
type JSCode = L8.ByteString
data QueryOpt = QOTailableCursor
| QOSlaveOK
| QOOpLogReplay
| QONoCursorTimeout
deriving (Show)
fromQueryOpts :: [QueryOpt] -> Int32
fromQueryOpts opts = List.foldl (.|.) 0 $ fmap toVal opts
where toVal QOTailableCursor = 2
toVal QOSlaveOK = 4
toVal QOOpLogReplay = 8
toVal QONoCursorTimeout = 16
data UpdateFlag = UFUpsert
| UFMultiupdate
deriving (Show, Enum)
fromUpdateFlags :: [UpdateFlag] -> Int32
fromUpdateFlags flags = List.foldl (.|.) 0 $
flip fmap flags $ (1 `shiftL`) . fromEnum
count :: Connection -> FullCollection -> IO Integer
count c col = countMatching c col empty
countMatching :: Connection -> FullCollection -> Selector -> IO Integer
countMatching c col sel = do
let (db, col') = splitFullCol col
res <- runCommand c db $ toBsonDoc [("count", toBson col'),
("query", toBson sel)]
let cnt = (fromBson $ fromLookup $ List.lookup (s2L "n") res :: Double)
return $ truncate cnt
delete :: Connection -> FullCollection -> Selector -> IO RequestID
delete c col sel = do
let body = runPut $ do
putI32 0
putCol col
putI32 0
putBsonDoc sel
(reqID, msg) <- packMsg c OPDelete body
cPut c msg
return reqID
remove :: Connection -> FullCollection -> Selector -> IO RequestID
remove = delete
moveOidToFrontOrGen :: Connection -> BsonDoc -> IO BsonDoc
moveOidToFrontOrGen c doc =
case List.lookup (s2L "_id") doc of
Nothing -> do
oid <- genObjectId $ cOidGen c
return $ (s2L "_id", oid) : doc
Just oid -> do
let keyEq = (\(k1, _) (k2, _) -> k1 == k2)
delByKey = \k -> List.deleteBy keyEq (k, undefined)
return $ (s2L "_id", oid) : delByKey (s2L "_id") doc
insert :: Connection -> FullCollection -> BsonDoc -> IO BsonValue
insert c col doc = do
doc' <- moveOidToFrontOrGen c doc
let body = runPut $ do
putI32 0
putCol col
putBsonDoc doc'
(_reqID, msg) <- packMsg c OPInsert body
cPut c msg
return $ snd $ head doc'
insertMany :: Connection -> FullCollection -> [BsonDoc] -> IO [BsonValue]
insertMany c col docs = do
docs' <- mapM (moveOidToFrontOrGen c) docs
let body = runPut $ do
putI32 0
putCol col
forM_ docs' putBsonDoc
(_, msg) <- packMsg c OPInsert body
cPut c msg
return $ List.map (snd . head) docs'
find :: Connection -> FullCollection -> Selector -> IO Cursor
find c col sel = query c col [] 0 0 sel []
findOne :: Connection -> FullCollection -> Selector -> IO (Maybe BsonDoc)
findOne c col sel = query c col [] 0 (1) sel [] >>= nextDoc
quickFind :: Connection -> FullCollection -> Selector -> IO [BsonDoc]
quickFind c col sel = find c col sel >>= allDocs
quickFind' :: Connection -> FullCollection -> Selector -> IO [BsonDoc]
quickFind' c col sel = find c col sel >>= allDocs'
query :: Connection -> FullCollection -> [QueryOpt] ->
NumToSkip -> NumToReturn -> Selector -> FieldSelector -> IO Cursor
query c col opts nskip ret sel fsel = do
h <- getHandle c
let body = runPut $ do
putI32 $ fromQueryOpts opts
putCol col
putI32 nskip
putI32 ret
putBsonDoc sel
case fsel of
[] -> putNothing
_ -> putBsonDoc $ toBsonDoc $ List.zip fsel $
repeat $ BsonInt32 1
(reqID, msg) <- packMsg c OPQuery body
L.hPut h msg
hdr <- getHeader h
assert (OPReply == hOp hdr) $ return ()
assert (hRespTo hdr == reqID) $ return ()
reply <- getReply h
assert (rRespFlags reply == 0) $ return ()
docBytes <- L.hGet h (fromIntegral $ hMsgLen hdr 16 20) >>= newIORef
closed <- newIORef False
cid <- newIORef $ rCursorID reply
return Cursor {
curCon = c,
curID = cid,
curNumToRet = ret,
curCol = col,
curDocBytes = docBytes,
curClosed = closed
}
update :: Connection -> FullCollection ->
[UpdateFlag] -> Selector -> BsonDoc -> IO RequestID
update c col flags sel obj = do
let body = runPut $ do
putI32 0
putCol col
putI32 $ fromUpdateFlags flags
putBsonDoc sel
putBsonDoc obj
(reqID, msg) <- packMsg c OPUpdate body
cPut c msg
return reqID
login :: Connection -> Database -> Username -> Password -> IO BsonDoc
login c db user pass = do
doc <- runCommand c db (toBsonDoc [("getnonce", toBson (1 :: Int))])
let nonce = fromBson $ fromLookup $ List.lookup (s2L "nonce") doc :: String
digest = md5sum $ pack $ nonce ++ user ++
md5sum (pack (user ++ ":mongo:" ++ pass))
request = toBsonDoc [("authenticate", toBson (1 :: Int)),
("user", toBson user),
("nonce", toBson nonce),
("key", toBson digest)]
in runCommand c db request
auth :: Connection -> Database -> Username -> Password -> IO BsonDoc
auth = login
logout :: Connection -> Database -> IO ()
logout c db =
runCommand c db (toBsonDoc [(s2L "logout", BsonInt32 1)]) >> return ()
addUser :: Connection -> Database -> Username -> Password -> IO BsonDoc
addUser c db user pass = do
let userDoc = toBsonDoc [(s2L "user", toBson user)]
fdb = L.append db (s2L ".system.users")
doc <- findOne c fdb userDoc
let pwd = md5sum $ pack (user ++ ":mongo:" ++ pass)
doc' = (s2L "pwd", toBson pwd) :
List.deleteBy (\(k1,_) (k2,_) -> (k1 == k2))
(s2L user, undefined)
(fromMaybe userDoc doc)
_ <- save c fdb doc'
return doc'
data MapReduceOpt
= MROptQuery BsonDoc
| MROptLimit Int64
| MROptOut L8.ByteString
| MROptKeepTemp
| MROptFinalize JSCode
| MROptScope BsonDoc
| MROptVerbose
mrOptToTuple :: MapReduceOpt -> (String, BsonValue)
mrOptToTuple (MROptQuery q) = ("query", BsonDoc q)
mrOptToTuple (MROptLimit l) = ("limit", BsonInt64 l)
mrOptToTuple (MROptOut c) = ("out", BsonString c)
mrOptToTuple MROptKeepTemp = ("keeptemp", BsonBool True)
mrOptToTuple (MROptFinalize f) = ("finalize", BsonJSCode f)
mrOptToTuple (MROptScope s) = ("scope", BsonDoc s)
mrOptToTuple MROptVerbose = ("verbose", BsonBool True)
runMapReduce :: Connection -> FullCollection
-> JSCode
-> JSCode
-> [MapReduceOpt]
-> IO BsonDoc
runMapReduce c fc m r opts = do
let (db, col) = splitFullCol fc
doc = [("mapreduce", toBson col),
("map", BsonJSCode m),
("reduce", BsonJSCode r)] ++ List.map mrOptToTuple opts
runCommand c db $ toBsonDoc doc
runMapReduceWScopes :: Connection -> FullCollection
-> JSCode
-> BsonDoc
-> JSCode
-> BsonDoc
-> [MapReduceOpt]
-> IO BsonDoc
runMapReduceWScopes c fc m ms r rs opts = do
let (db, col) = splitFullCol fc
doc = [("mapreduce", toBson col),
("map", BsonJSCodeWScope m ms),
("reduce", BsonJSCodeWScope r rs)] ++ List.map mrOptToTuple opts
runCommand c db $ toBsonDoc doc
mapReduceResults :: Connection -> Database -> BsonDoc -> IO Cursor
mapReduceResults c db r = do
let col = case List.lookup (s2L "result") r of
Just bCol -> fromBson bCol
Nothing -> throwOpFailure "No 'result' in mapReduce response"
fc = L.append (L.append db $ s2L ".") col
find c fc []
mapReduce :: Connection -> FullCollection
-> JSCode
-> JSCode
-> [MapReduceOpt]
-> IO Cursor
mapReduce c fc m r opts =
runMapReduce c fc m r opts >>= mapReduceResults c (fst $ splitFullCol fc)
mapReduceWScopes :: Connection -> FullCollection
-> JSCode
-> BsonDoc
-> JSCode
-> BsonDoc
-> [MapReduceOpt]
-> IO Cursor
mapReduceWScopes c fc m ms r rs opts =
runMapReduceWScopes c fc m ms r rs opts >>=
mapReduceResults c (fst $ splitFullCol fc)
save :: Connection -> FullCollection -> BsonDoc -> IO BsonValue
save c fc doc =
case List.lookup (s2L "_id") doc of
Nothing -> insert c fc doc
Just oid -> update c fc [UFUpsert] (toBsonDoc [("_id", oid)]) doc >>
return oid
whereClause :: String -> Maybe BsonDoc -> BsonDoc
whereClause qry Nothing = toBsonDoc [("$where", BsonJSCode (s2L qry))]
whereClause qry (Just scope) =
toBsonDoc [("$where", BsonJSCodeWScope (s2L qry) scope)]
data Hdr = Hdr {
hMsgLen :: Int32,
hRespTo :: Int32,
hOp :: Opcode
} deriving (Show)
data Reply = Reply {
rRespFlags :: Int32,
rCursorID :: Int64
} deriving (Show)
getHeader :: Handle -> IO Hdr
getHeader h = do
hdrBytes <- L.hGet h 16
return $ flip runGet hdrBytes $ do
msgLen <- getI32
skip 4
respTo <- getI32
op <- getI32
return $ Hdr msgLen respTo $ toOpcode op
getReply :: Handle -> IO Reply
getReply h = do
replyBytes <- L.hGet h 20
return $ flip runGet replyBytes $ do
respFlags <- getI32
cursorID <- getI64
skip 4
skip 4
return $ Reply respFlags cursorID
nextDoc :: Cursor -> IO (Maybe BsonDoc)
nextDoc cur = do
closed <- readIORef $ curClosed cur
if closed
then return Nothing
else do
docBytes <- readIORef $ curDocBytes cur
cid <- readIORef $ curID cur
case L.length docBytes of
0 -> if cid == 0
then writeIORef (curClosed cur) True >> return Nothing
else getMore cur
_ -> do
let (doc, docBytes') = getFirstDoc docBytes
writeIORef (curDocBytes cur) docBytes'
return $ Just doc
allDocs :: Cursor -> IO [BsonDoc]
allDocs cur = unsafeInterleaveIO $ do
doc <- nextDoc cur
case doc of
Nothing -> return []
Just d -> liftM (d :) (allDocs cur)
allDocs' :: Cursor -> IO [BsonDoc]
allDocs' cur = do
doc <- nextDoc cur
case doc of
Nothing -> return []
Just d -> liftM (d :) (allDocs' cur)
getFirstDoc :: L.ByteString -> (BsonDoc, L.ByteString)
getFirstDoc docBytes = flip runGet docBytes $ do
doc <- getBsonDoc
docBytes' <- getRemainingLazyByteString
return (doc, docBytes')
getMore :: Cursor -> IO (Maybe BsonDoc)
getMore cur = do
h <- getHandle $ curCon cur
cid <- readIORef $ curID cur
let body = runPut $ do
putI32 0
putCol $ curCol cur
putI32 $ curNumToRet cur
putI64 cid
(reqID, msg) <- packMsg (curCon cur) OPGetMore body
L.hPut h msg
hdr <- getHeader h
assert (OPReply == hOp hdr) $ return ()
assert (hRespTo hdr == reqID) $ return ()
reply <- getReply h
assert (rRespFlags reply == 0) $ return ()
case rCursorID reply of
0 -> writeIORef (curID cur) 0
ncid -> assert (ncid == cid) $ return ()
docBytes <- (L.hGet h $ fromIntegral $ hMsgLen hdr 16 20)
case L.length docBytes of
0 -> writeIORef (curClosed cur) True >> return Nothing
_ -> do
let (doc, docBytes') = getFirstDoc docBytes
writeIORef (curDocBytes cur) docBytes'
return $ Just doc
finish :: Cursor -> IO ()
finish cur = do
h <- getHandle $ curCon cur
cid <- readIORef $ curID cur
unless (cid == 0) $ do
let body = runPut $ do
putI32 0
putI32 1
putI64 cid
(_reqID, msg) <- packMsg (curCon cur) OPKillCursors body
L.hPut h msg
writeIORef (curClosed cur) True
return ()
type Key = L8.ByteString
data Direction = Ascending
| Descending
deriving (Show, Eq)
fromDirection :: Direction -> Int
fromDirection Ascending = 1
fromDirection Descending = 1
type Unique = Bool
createIndex :: Connection -> FullCollection ->
[(Key, Direction)] -> Unique -> IO L8.ByteString
createIndex c col keys uniq = do
let (db, _col') = splitFullCol col
name = indexName keys
keysDoc = flip fmap keys $
\(k, d) -> (k, toBson $ fromDirection d :: BsonValue)
_ <- insert c (L.append db $ s2L ".system.indexes") $
toBsonDoc [("name", toBson name),
("ns", toBson col),
("key", toBson keysDoc),
("unique", toBson uniq)]
return name
dropIndex :: Connection -> FullCollection -> [(Key, Direction)] -> IO ()
dropIndex c col keys = do
let (db, col') = splitFullCol col
name = indexName keys
_ <- runCommand c db $ toBsonDoc [("deleteIndexes", toBson col'),
("index", toBson name)]
return ()
dropIndexes :: Connection -> FullCollection -> IO ()
dropIndexes c col = do
let (db, col') = splitFullCol col
_ <- runCommand c db $ toBsonDoc [("deleteIndexes", toBson col'),
("index", toBson "*")]
return ()
indexInformation :: Connection -> FullCollection -> IO [BsonDoc]
indexInformation c col = do
let (db, _col') = splitFullCol col
quickFind' c (L.append db $ s2L ".system.indexes") $
toBsonDoc [("ns", toBson col)]
indexName :: [(Key, Direction)] -> L8.ByteString
indexName = L.intercalate (s2L "_") . List.map partName
where partName (k, Ascending) = L.append k $ s2L "_1"
partName (k, Descending) = L.append k $ s2L "_-1"
putCol :: Collection -> Put
putCol col = putLazyByteString col >> putNull
packMsg :: Connection -> Opcode -> L.ByteString -> IO (RequestID, L.ByteString)
packMsg c op body = do
reqID <- randNum c
let msg = runPut $ do
putI32 $ fromIntegral $ L.length body + 16
putI32 reqID
putI32 0
putI32 $ fromOpcode op
putLazyByteString body
return (reqID, msg)
randNum :: Connection -> IO Int32
randNum Connection { cRand = nsRef } = atomicModifyIORef nsRef $ \ns ->
(List.tail ns,
fromIntegral $ List.head ns)
s2L :: String -> L8.ByteString
s2L = L8.fromString
validateCollectionName :: FullCollection -> IO (Database, Collection)
validateCollectionName col = do
let (db, col') = splitFullCol col
when (s2L ".." `List.elem` L.group col) $
throwColInvalid $ "Collection can't contain \"..\": " ++ show col
when (c2w '$' `L.elem` col &&
not (s2L "oplog.$mail" `L.isPrefixOf` col' ||
s2L "$cmd" `L.isPrefixOf` col')) $
throwColInvalid $ "Collection can't contain '$': " ++ show col
when (L.head col == c2w '.' || L.last col == c2w '.') $
throwColInvalid $ "Collection can't start or end with '.': " ++ show col
return (db, col')
fromLookup :: Maybe a -> a
fromLookup (Just m) = m
fromLookup Nothing = throwColInvalid "cannot find key"