Compare commits
13 commits
Author | SHA1 | Date | |
---|---|---|---|
63bba3a6d3 | |||
0afaf89e1d | |||
22537d87ee | |||
cd3977c731 | |||
4a9a1cb63f | |||
|
35ee53abed | ||
|
4a46964d4c | ||
|
51358d13c4 | ||
|
46643fd8ad | ||
|
90afe88784 | ||
|
995087e9a0 | ||
|
fb0d140aa4 | ||
|
6f1d842641 |
6 changed files with 188 additions and 78 deletions
|
@ -4,6 +4,11 @@ This project adheres to [Package Versioning Policy](https://wiki.haskell.org/Pac
|
||||||
|
|
||||||
* Get rid of `MonadFail` constraints in `Database.MongoDB.Query`
|
* Get rid of `MonadFail` constraints in `Database.MongoDB.Query`
|
||||||
|
|
||||||
|
## [] - 2023-??-??
|
||||||
|
|
||||||
|
### Fixed
|
||||||
|
- Collections with dot in the name
|
||||||
|
|
||||||
## [2.7.1.2] - 2022-10-26
|
## [2.7.1.2] - 2022-10-26
|
||||||
|
|
||||||
### Added
|
### Added
|
||||||
|
|
|
@ -494,6 +494,9 @@ data FlagBit =
|
||||||
| ExhaustAllowed -- ^ The client is prepared for multiple replies to this request using the moreToCome bit.
|
| ExhaustAllowed -- ^ The client is prepared for multiple replies to this request using the moreToCome bit.
|
||||||
deriving (Show, Eq, Enum)
|
deriving (Show, Eq, Enum)
|
||||||
|
|
||||||
|
uOptDoc :: UpdateOption -> Document
|
||||||
|
uOptDoc Upsert = ["upsert" =: True]
|
||||||
|
uOptDoc MultiUpdate = ["multi" =: True]
|
||||||
|
|
||||||
{-
|
{-
|
||||||
OP_MSG header == 16 byte
|
OP_MSG header == 16 byte
|
||||||
|
@ -528,7 +531,7 @@ putOpMsg cmd requestId flagBit params = do
|
||||||
putCString "documents" -- identifier
|
putCString "documents" -- identifier
|
||||||
mapM_ putDocument iDocuments -- payload
|
mapM_ putDocument iDocuments -- payload
|
||||||
Update{..} -> do
|
Update{..} -> do
|
||||||
let doc = ["q" =: uSelector, "u" =: uUpdater]
|
let doc = ["q" =: uSelector, "u" =: uUpdater] <> concatMap uOptDoc uOptions
|
||||||
(sec0, sec1Size) =
|
(sec0, sec1Size) =
|
||||||
prepSectionInfo
|
prepSectionInfo
|
||||||
uFullCollection
|
uFullCollection
|
||||||
|
@ -578,6 +581,10 @@ putOpMsg cmd requestId flagBit params = do
|
||||||
putInt32 (bit $ bitOpMsg $ ExhaustAllowed)
|
putInt32 (bit $ bitOpMsg $ ExhaustAllowed)
|
||||||
putInt8 0
|
putInt8 0
|
||||||
putDocument pre
|
putDocument pre
|
||||||
|
Message{..} -> do
|
||||||
|
putInt32 biT
|
||||||
|
putInt8 0
|
||||||
|
putDocument $ merge [ "$db" =: mDatabase ] mParams
|
||||||
Kc k -> case k of
|
Kc k -> case k of
|
||||||
KillC{..} -> do
|
KillC{..} -> do
|
||||||
let n = T.splitOn "." kFullCollection
|
let n = T.splitOn "." kFullCollection
|
||||||
|
@ -653,7 +660,11 @@ data Request =
|
||||||
} | GetMore {
|
} | GetMore {
|
||||||
gFullCollection :: FullCollection,
|
gFullCollection :: FullCollection,
|
||||||
gBatchSize :: Int32,
|
gBatchSize :: Int32,
|
||||||
gCursorId :: CursorId}
|
gCursorId :: CursorId
|
||||||
|
} | Message {
|
||||||
|
mDatabase :: Text,
|
||||||
|
mParams :: Document
|
||||||
|
}
|
||||||
deriving (Show, Eq)
|
deriving (Show, Eq)
|
||||||
|
|
||||||
data QueryOption =
|
data QueryOption =
|
||||||
|
@ -673,6 +684,7 @@ data QueryOption =
|
||||||
qOpcode :: Request -> Opcode
|
qOpcode :: Request -> Opcode
|
||||||
qOpcode Query{} = 2004
|
qOpcode Query{} = 2004
|
||||||
qOpcode GetMore{} = 2005
|
qOpcode GetMore{} = 2005
|
||||||
|
qOpcode Message{} = 2013
|
||||||
|
|
||||||
opMsgOpcode :: Opcode
|
opMsgOpcode :: Opcode
|
||||||
opMsgOpcode = 2013
|
opMsgOpcode = 2013
|
||||||
|
@ -693,6 +705,10 @@ putRequest request requestId = do
|
||||||
putCString gFullCollection
|
putCString gFullCollection
|
||||||
putInt32 gBatchSize
|
putInt32 gBatchSize
|
||||||
putInt64 gCursorId
|
putInt64 gCursorId
|
||||||
|
Message{..} -> do
|
||||||
|
putInt32 0
|
||||||
|
putInt8 0
|
||||||
|
putDocument $ merge [ "$db" =: mDatabase ] mParams
|
||||||
|
|
||||||
qBit :: QueryOption -> Int32
|
qBit :: QueryOption -> Int32
|
||||||
qBit TailableCursor = bit 1
|
qBit TailableCursor = bit 1
|
||||||
|
|
|
@ -92,6 +92,9 @@ bitOr = foldl (.|.) 0
|
||||||
-- ^ Concat first and second together with period in between. Eg. @\"hello\" \<.\> \"world\" = \"hello.world\"@
|
-- ^ Concat first and second together with period in between. Eg. @\"hello\" \<.\> \"world\" = \"hello.world\"@
|
||||||
a <.> b = T.append a (T.cons '.' b)
|
a <.> b = T.append a (T.cons '.' b)
|
||||||
|
|
||||||
|
splitDot :: Text -> (Text, Text)
|
||||||
|
splitDot t = let (pre, post) = T.break (== '.') t in (pre, T.drop 1 post)
|
||||||
|
|
||||||
true1 :: Label -> Document -> Bool
|
true1 :: Label -> Document -> Bool
|
||||||
-- ^ Is field's value a 1 or True (MongoDB use both Int and Bools for truth values). Error if field not in document or field not a Num or Bool.
|
-- ^ Is field's value a 1 or True (MongoDB use both Int and Bools for truth values). Error if field not in document or field not a Num or Bool.
|
||||||
true1 k doc = case valueAt k doc of
|
true1 k doc = case valueAt k doc of
|
||||||
|
|
|
@ -11,7 +11,7 @@ module Database.MongoDB.Query (
|
||||||
-- * Database
|
-- * Database
|
||||||
Database, allDatabases, useDb, thisDatabase,
|
Database, allDatabases, useDb, thisDatabase,
|
||||||
-- ** Authentication
|
-- ** Authentication
|
||||||
Username, Password, auth, authMongoCR, authSCRAMSHA1,
|
Username, Password, auth, authMongoCR, authSCRAMSHA1, authSCRAMSHA256,
|
||||||
-- * Collection
|
-- * Collection
|
||||||
Collection, allCollections,
|
Collection, allCollections,
|
||||||
-- ** Selection
|
-- ** Selection
|
||||||
|
@ -61,8 +61,10 @@ import Control.Monad
|
||||||
)
|
)
|
||||||
import Control.Monad.Reader (MonadReader, ReaderT, ask, asks, local, runReaderT)
|
import Control.Monad.Reader (MonadReader, ReaderT, ask, asks, local, runReaderT)
|
||||||
import Control.Monad.Trans (MonadIO, liftIO, lift)
|
import Control.Monad.Trans (MonadIO, liftIO, lift)
|
||||||
|
import Control.Monad.Trans.Except
|
||||||
import qualified Crypto.Hash.MD5 as MD5
|
import qualified Crypto.Hash.MD5 as MD5
|
||||||
import qualified Crypto.Hash.SHA1 as SHA1
|
import qualified Crypto.Hash.SHA1 as SHA1
|
||||||
|
import qualified Crypto.Hash.SHA256 as SHA256
|
||||||
import qualified Crypto.MAC.HMAC as HMAC
|
import qualified Crypto.MAC.HMAC as HMAC
|
||||||
import qualified Crypto.Nonce as Nonce
|
import qualified Crypto.Nonce as Nonce
|
||||||
import Data.Binary.Put (runPut)
|
import Data.Binary.Put (runPut)
|
||||||
|
@ -133,7 +135,7 @@ import Database.MongoDB.Internal.Protocol
|
||||||
)
|
)
|
||||||
import Control.Monad.Trans.Except
|
import Control.Monad.Trans.Except
|
||||||
import qualified Database.MongoDB.Internal.Protocol as P
|
import qualified Database.MongoDB.Internal.Protocol as P
|
||||||
import Database.MongoDB.Internal.Util (liftIOE, loop, true1, (<.>))
|
import Database.MongoDB.Internal.Util (liftIOE, loop, true1, (<.>), splitDot)
|
||||||
import System.Mem.Weak (Weak)
|
import System.Mem.Weak (Weak)
|
||||||
import Text.Read (readMaybe)
|
import Text.Read (readMaybe)
|
||||||
import Prelude hiding (lookup)
|
import Prelude hiding (lookup)
|
||||||
|
@ -285,62 +287,93 @@ authMongoCR 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]
|
||||||
|
|
||||||
|
data HashAlgorithm = SHA1 | SHA256 deriving Show
|
||||||
|
|
||||||
|
hash :: HashAlgorithm -> B.ByteString -> B.ByteString
|
||||||
|
hash SHA1 = SHA1.hash
|
||||||
|
hash SHA256 = SHA256.hash
|
||||||
|
|
||||||
authSCRAMSHA1 :: MonadIO m => Username -> Password -> Action m Bool
|
authSCRAMSHA1 :: MonadIO m => Username -> Password -> Action m Bool
|
||||||
|
authSCRAMSHA1 = authSCRAMWith SHA1
|
||||||
|
|
||||||
|
authSCRAMSHA256 :: MonadIO m => Username -> Password -> Action m Bool
|
||||||
|
authSCRAMSHA256 = authSCRAMWith SHA256
|
||||||
|
|
||||||
|
toAuthResult :: Functor m => ExceptT String (Action m) () -> Action m Bool
|
||||||
|
toAuthResult = fmap (either (const False) (const True)) . runExceptT
|
||||||
|
|
||||||
|
-- | It should technically perform SASLprep, but the implementation is currently id
|
||||||
|
saslprep :: Text -> Text
|
||||||
|
saslprep = id
|
||||||
|
|
||||||
|
authSCRAMWith :: MonadIO m => HashAlgorithm -> Username -> Password -> Action m Bool
|
||||||
-- ^ Authenticate with the current database, using the SCRAM-SHA-1 authentication mechanism (default in MongoDB server >= 3.0)
|
-- ^ Authenticate with the current database, using the SCRAM-SHA-1 authentication mechanism (default in MongoDB server >= 3.0)
|
||||||
authSCRAMSHA1 un pw = do
|
authSCRAMWith algo un pw = toAuthResult $ do
|
||||||
let hmac = HMAC.hmac SHA1.hash 64
|
let hmac = HMAC.hmac (hash algo) 64
|
||||||
nonce <- liftIO (Nonce.withGenerator Nonce.nonce128 <&> B64.encode)
|
nonce <- liftIO (Nonce.withGenerator Nonce.nonce128 <&> B64.encode)
|
||||||
let firstBare = B.concat [B.pack $ "n=" ++ T.unpack un ++ ",r=", nonce]
|
let firstBare = B.concat [B.pack $ "n=" ++ T.unpack un ++ ",r=", nonce]
|
||||||
let client1 = ["saslStart" =: (1 :: Int), "mechanism" =: ("SCRAM-SHA-1" :: String), "payload" =: (B.unpack . B64.encode $ B.concat [B.pack "n,,", firstBare]), "autoAuthorize" =: (1 :: Int)]
|
let client1 =
|
||||||
server1 <- runCommand client1
|
[ "saslStart" =: (1 :: Int)
|
||||||
|
, "mechanism" =: case algo of
|
||||||
|
SHA1 -> "SCRAM-SHA-1" :: String
|
||||||
|
SHA256 -> "SCRAM-SHA-256"
|
||||||
|
, "payload" =: (B.unpack . B64.encode $ B.concat [B.pack "n,,", firstBare])
|
||||||
|
, "autoAuthorize" =: (1 :: Int)
|
||||||
|
]
|
||||||
|
server1 <- lift $ runCommand client1
|
||||||
|
|
||||||
shortcircuit (true1 "ok" server1) $ do
|
shortcircuit (true1 "ok" server1) (show server1)
|
||||||
let serverPayload1 = B64.decodeLenient . B.pack . at "payload" $ server1
|
let serverPayload1 = B64.decodeLenient . B.pack . at "payload" $ server1
|
||||||
let serverData1 = parseSCRAM serverPayload1
|
let serverData1 = parseSCRAM serverPayload1
|
||||||
let iterations = read . B.unpack $ Map.findWithDefault "1" "i" serverData1
|
let iterations = read . B.unpack $ Map.findWithDefault "1" "i" serverData1
|
||||||
let salt = B64.decodeLenient $ Map.findWithDefault "" "s" serverData1
|
let salt = B64.decodeLenient $ Map.findWithDefault "" "s" serverData1
|
||||||
let snonce = Map.findWithDefault "" "r" serverData1
|
let snonce = Map.findWithDefault "" "r" serverData1
|
||||||
|
|
||||||
shortcircuit (B.isInfixOf nonce snonce) $ do
|
shortcircuit (B.isInfixOf nonce snonce) "nonce"
|
||||||
let withoutProof = B.concat [B.pack "c=biws,r=", snonce]
|
let withoutProof = B.concat [B.pack "c=biws,r=", snonce]
|
||||||
let digestS = B.pack $ T.unpack un ++ ":mongo:" ++ T.unpack pw
|
let digest = case algo of
|
||||||
let digest = B16.encode $ MD5.hash digestS
|
SHA1 -> B16.encode $ MD5.hash $ B.pack $ T.unpack un ++ ":mongo:" ++ T.unpack pw
|
||||||
let saltedPass = scramHI digest salt iterations
|
SHA256 -> B.pack $ T.unpack $ saslprep pw
|
||||||
let clientKey = hmac saltedPass (B.pack "Client Key")
|
let saltedPass = scramHI algo digest salt iterations
|
||||||
let storedKey = SHA1.hash clientKey
|
let clientKey = hmac saltedPass (B.pack "Client Key")
|
||||||
let authMsg = B.concat [firstBare, B.pack ",", serverPayload1, B.pack ",", withoutProof]
|
let storedKey = hash algo clientKey
|
||||||
let clientSig = hmac storedKey authMsg
|
let authMsg = B.concat [firstBare, B.pack ",", serverPayload1, B.pack ",", withoutProof]
|
||||||
let pval = B64.encode . BS.pack $ BS.zipWith xor clientKey clientSig
|
let clientSig = hmac storedKey authMsg
|
||||||
let clientFinal = B.concat [withoutProof, B.pack ",p=", pval]
|
let pval = B64.encode . BS.pack $ BS.zipWith xor clientKey clientSig
|
||||||
let serverKey = hmac saltedPass (B.pack "Server Key")
|
let clientFinal = B.concat [withoutProof, B.pack ",p=", pval]
|
||||||
let serverSig = B64.encode $ hmac serverKey authMsg
|
|
||||||
let client2 = ["saslContinue" =: (1 :: Int), "conversationId" =: (at "conversationId" server1 :: Int), "payload" =: B.unpack (B64.encode clientFinal)]
|
|
||||||
server2 <- runCommand client2
|
|
||||||
|
|
||||||
shortcircuit (true1 "ok" server2) $ do
|
let client2 =
|
||||||
let serverPayload2 = B64.decodeLenient . B.pack $ at "payload" server2
|
[ "saslContinue" =: (1 :: Int)
|
||||||
let serverData2 = parseSCRAM serverPayload2
|
, "conversationId" =: (at "conversationId" server1 :: Int)
|
||||||
let serverSigComp = Map.findWithDefault "" "v" serverData2
|
, "payload" =: B.unpack (B64.encode clientFinal)
|
||||||
|
]
|
||||||
|
server2 <- lift $ runCommand client2
|
||||||
|
shortcircuit (true1 "ok" server2) (show server2)
|
||||||
|
|
||||||
shortcircuit (serverSig == serverSigComp) $ do
|
let serverKey = hmac saltedPass (B.pack "Server Key")
|
||||||
let done = true1 "done" server2
|
let serverSig = B64.encode $ hmac serverKey authMsg
|
||||||
if done
|
let serverPayload2 = B64.decodeLenient . B.pack $ at "payload" server2
|
||||||
then return True
|
let serverData2 = parseSCRAM serverPayload2
|
||||||
else do
|
let serverSigComp = Map.findWithDefault "" "v" serverData2
|
||||||
let client2Step2 = [ "saslContinue" =: (1 :: Int)
|
|
||||||
, "conversationId" =: (at "conversationId" server1 :: Int)
|
shortcircuit (serverSig == serverSigComp) "server signature does not match"
|
||||||
, "payload" =: String ""]
|
if true1 "done" server2
|
||||||
server3 <- runCommand client2Step2
|
then return ()
|
||||||
shortcircuit (true1 "ok" server3) $ do
|
else do
|
||||||
return True
|
let client2Step2 = [ "saslContinue" =: (1 :: Int)
|
||||||
|
, "conversationId" =: (at "conversationId" server1 :: Int)
|
||||||
|
, "payload" =: String ""]
|
||||||
|
server3 <- lift $ runCommand client2Step2
|
||||||
|
shortcircuit (true1 "ok" server3) "server3"
|
||||||
|
|
||||||
|
shortcircuit :: Monad m => Bool -> String -> ExceptT String m ()
|
||||||
|
shortcircuit True _ = pure ()
|
||||||
|
shortcircuit False reason = throwE (show reason)
|
||||||
|
|
||||||
|
scramHI :: HashAlgorithm -> B.ByteString -> B.ByteString -> Int -> B.ByteString
|
||||||
|
scramHI algo digest salt iters = snd $ foldl com (u1, u1) [1..(iters-1)]
|
||||||
where
|
where
|
||||||
shortcircuit True f = f
|
hmacd = HMAC.hmac (hash algo) 64 digest
|
||||||
shortcircuit False _ = return False
|
|
||||||
|
|
||||||
scramHI :: B.ByteString -> B.ByteString -> Int -> B.ByteString
|
|
||||||
scramHI digest salt iters = snd $ foldl com (u1, u1) [1..(iters-1)]
|
|
||||||
where
|
|
||||||
hmacd = HMAC.hmac SHA1.hash 64 digest
|
|
||||||
u1 = hmacd (B.concat [salt, BS.pack [0, 0, 0, 1]])
|
u1 = hmacd (B.concat [salt, BS.pack [0, 0, 0, 1]])
|
||||||
com (u,uc) _ = let u' = hmacd u in (u', BS.pack $ BS.zipWith xor uc u')
|
com (u,uc) _ = let u' = hmacd u in (u', BS.pack $ BS.zipWith xor uc u')
|
||||||
|
|
||||||
|
@ -1272,9 +1305,9 @@ find q@Query{selection, batchSize} = do
|
||||||
qr <- queryRequestOpMsg False q
|
qr <- queryRequestOpMsg False q
|
||||||
let newQr =
|
let newQr =
|
||||||
case fst qr of
|
case fst qr of
|
||||||
Req qry ->
|
Req P.Query{..} ->
|
||||||
let coll = last $ T.splitOn "." (qFullCollection qry)
|
let coll = last $ T.splitOn "." qFullCollection
|
||||||
in (Req $ qry {qSelector = merge (qSelector qry) [ "find" =: coll ]}, snd qr)
|
in (Req $ P.Query {qSelector = merge qSelector [ "find" =: coll ], ..}, snd qr)
|
||||||
-- queryRequestOpMsg only returns Cmd types constructed via Req
|
-- queryRequestOpMsg only returns Cmd types constructed via Req
|
||||||
_ -> error "impossible"
|
_ -> error "impossible"
|
||||||
dBatch <- liftIO $ requestOpMsg pipe newQr []
|
dBatch <- liftIO $ requestOpMsg pipe newQr []
|
||||||
|
@ -1312,6 +1345,9 @@ findCommand q@Query{..} = do
|
||||||
| predicate a = Just (f a)
|
| predicate a = Just (f a)
|
||||||
| otherwise = Nothing
|
| otherwise = Nothing
|
||||||
|
|
||||||
|
isHandshake :: Document -> Bool
|
||||||
|
isHandshake = (== ["isMaster" =: (1 :: Int32)])
|
||||||
|
|
||||||
findOne :: (MonadIO m) => Query -> Action m (Maybe Document)
|
findOne :: (MonadIO m) => Query -> Action m (Maybe Document)
|
||||||
-- ^ Fetch first document satisfying query or @Nothing@ if none satisfy it
|
-- ^ Fetch first document satisfying query or @Nothing@ if none satisfy it
|
||||||
findOne q = do
|
findOne q = do
|
||||||
|
@ -1321,8 +1357,7 @@ findOne q = do
|
||||||
rq <- liftIO $ request pipe [] qr
|
rq <- liftIO $ request pipe [] qr
|
||||||
Batch _ _ docs <- liftDB $ fulfill rq
|
Batch _ _ docs <- liftDB $ fulfill rq
|
||||||
return (listToMaybe docs)
|
return (listToMaybe docs)
|
||||||
isHandshake = (== ["isMaster" =: (1 :: Int32)]) $ selector $ selection q :: Bool
|
if isHandshake (selector $ selection q)
|
||||||
if isHandshake
|
|
||||||
then legacyQuery
|
then legacyQuery
|
||||||
else do
|
else do
|
||||||
let sd = P.serverData pipe
|
let sd = P.serverData pipe
|
||||||
|
@ -1332,14 +1367,14 @@ findOne q = do
|
||||||
qr <- queryRequestOpMsg False q {limit = 1}
|
qr <- queryRequestOpMsg False q {limit = 1}
|
||||||
let newQr =
|
let newQr =
|
||||||
case fst qr of
|
case fst qr of
|
||||||
Req qry ->
|
Req P.Query{..} ->
|
||||||
let coll = last $ T.splitOn "." (qFullCollection qry)
|
let coll = last $ T.splitOn "." qFullCollection
|
||||||
-- We have to understand whether findOne is called as
|
-- We have to understand whether findOne is called as
|
||||||
-- command directly. This is necessary since findOne is used via
|
-- command directly. This is necessary since findOne is used via
|
||||||
-- runCommand as a vehicle to execute any type of commands and notices.
|
-- runCommand as a vehicle to execute any type of commands and notices.
|
||||||
labels = catMaybes $ map (\f -> look f $ qSelector qry) (noticeCommands ++ adminCommands) :: [Value]
|
labels = catMaybes $ map (\f -> look f qSelector) (noticeCommands ++ adminCommands) :: [Value]
|
||||||
in if null labels
|
in if null labels
|
||||||
then (Req $ qry {qSelector = merge (qSelector qry) [ "find" =: coll ]}, snd qr)
|
then (Req P.Query {qSelector = merge qSelector [ "find" =: coll ], ..}, snd qr)
|
||||||
else qr
|
else qr
|
||||||
_ -> error "impossible"
|
_ -> error "impossible"
|
||||||
rq <- liftIO $ requestOpMsg pipe newQr []
|
rq <- liftIO $ requestOpMsg pipe newQr []
|
||||||
|
@ -1526,7 +1561,7 @@ requestOpMsg pipe (Req r, remainingLimit) params = do
|
||||||
promise <- liftIOE ConnectionFailure $ P.callOpMsg pipe r Nothing params
|
promise <- liftIOE ConnectionFailure $ P.callOpMsg pipe r Nothing params
|
||||||
let protectedPromise = liftIOE ConnectionFailure promise
|
let protectedPromise = liftIOE ConnectionFailure promise
|
||||||
return $ fromReply remainingLimit =<< protectedPromise
|
return $ fromReply remainingLimit =<< protectedPromise
|
||||||
requestOpMsg _ (Nc _, _) _ = error "requestOpMsg: Only messages of type Query are supported"
|
requestOpMsg _ _ _ = error "requestOpMsg: Only messages of type Query are supported"
|
||||||
|
|
||||||
fromReply :: Maybe Limit -> Reply -> DelayedBatch
|
fromReply :: Maybe Limit -> Reply -> DelayedBatch
|
||||||
-- ^ Convert Reply to Batch or Failure
|
-- ^ Convert Reply to Batch or Failure
|
||||||
|
@ -1844,9 +1879,29 @@ 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 :: (MonadIO m) => Command -> Action m Document
|
runCommand :: (MonadIO m) => Command -> Action m Document
|
||||||
-- ^ Run command against the database and return its result
|
runCommand params = do
|
||||||
runCommand c = fromMaybe err <$> findOne (query c "$cmd") where
|
pipe <- asks mongoPipe
|
||||||
err = error $ "Nothing returned for command: " ++ show c
|
if isHandshake params || maxWireVersion (P.serverData pipe) < 17
|
||||||
|
then runCommandLegacy pipe params
|
||||||
|
else runCommand' pipe params
|
||||||
|
|
||||||
|
runCommandLegacy :: MonadIO m => Pipe -> Selector -> ReaderT MongoContext m Document
|
||||||
|
runCommandLegacy pipe params = do
|
||||||
|
qr <- queryRequest False (query params "$cmd") {limit = 1}
|
||||||
|
rq <- liftIO $ request pipe [] qr
|
||||||
|
Batch _ _ docs <- liftDB $ fulfill rq
|
||||||
|
case docs of
|
||||||
|
[doc] -> pure doc
|
||||||
|
_ -> error $ "Nothing returned for command: " <> show params
|
||||||
|
|
||||||
|
runCommand' :: MonadIO m => Pipe -> Selector -> ReaderT MongoContext m Document
|
||||||
|
runCommand' pipe params = do
|
||||||
|
ctx <- ask
|
||||||
|
rq <- liftIO $ requestOpMsg pipe ( Req (P.Message (mongoDatabase ctx) params), Just 1) []
|
||||||
|
Batch _ _ docs <- liftDB $ fulfill rq
|
||||||
|
case docs of
|
||||||
|
[doc] -> pure doc
|
||||||
|
_ -> error $ "Nothing returned for command: " <> show params
|
||||||
|
|
||||||
runCommand1 :: (MonadIO m) => Text -> Action m Document
|
runCommand1 :: (MonadIO m) => Text -> Action m Document
|
||||||
-- ^ @runCommand1 foo = runCommand [foo =: 1]@
|
-- ^ @runCommand1 foo = runCommand [foo =: 1]@
|
||||||
|
|
|
@ -60,15 +60,17 @@ Library
|
||||||
, fail
|
, fail
|
||||||
, dns
|
, dns
|
||||||
, http-types
|
, http-types
|
||||||
|
, network >= 3.0
|
||||||
if flag(_old-network)
|
|
||||||
-- "Network.BSD" is only available in network < 2.9
|
|
||||||
build-depends: network < 2.9
|
|
||||||
else
|
|
||||||
-- "Network.BSD" has been moved into its own package `network-bsd`
|
|
||||||
build-depends: network >= 3.0
|
|
||||||
, network-bsd >= 2.7 && < 2.9
|
, network-bsd >= 2.7 && < 2.9
|
||||||
|
|
||||||
|
--if flag(_old-network)
|
||||||
|
---- "Network.BSD" is only available in network < 2.9
|
||||||
|
--build-depends: network < 2.9
|
||||||
|
--else
|
||||||
|
---- "Network.BSD" has been moved into its own package `network-bsd`
|
||||||
|
--build-depends: network >= 3.0
|
||||||
|
--, network-bsd >= 2.7 && < 2.9
|
||||||
|
|
||||||
Exposed-modules: Database.MongoDB
|
Exposed-modules: Database.MongoDB
|
||||||
Database.MongoDB.Admin
|
Database.MongoDB.Admin
|
||||||
Database.MongoDB.Connection
|
Database.MongoDB.Connection
|
||||||
|
@ -115,6 +117,8 @@ Benchmark bench
|
||||||
, base16-bytestring
|
, base16-bytestring
|
||||||
, binary -any
|
, binary -any
|
||||||
, bson >= 0.3 && < 0.5
|
, bson >= 0.3 && < 0.5
|
||||||
|
, conduit
|
||||||
|
, conduit-extra
|
||||||
, data-default-class -any
|
, data-default-class -any
|
||||||
, text
|
, text
|
||||||
, bytestring -any
|
, bytestring -any
|
||||||
|
@ -128,6 +132,7 @@ Benchmark bench
|
||||||
, random-shuffle -any
|
, random-shuffle -any
|
||||||
, monad-control >= 0.3.1
|
, monad-control >= 0.3.1
|
||||||
, lifted-base >= 0.1.0.3
|
, lifted-base >= 0.1.0.3
|
||||||
|
, transformers
|
||||||
, transformers-base >= 0.4.1
|
, transformers-base >= 0.4.1
|
||||||
, hashtables >= 1.1.2.0
|
, hashtables >= 1.1.2.0
|
||||||
, fail
|
, fail
|
||||||
|
@ -135,14 +140,16 @@ Benchmark bench
|
||||||
, http-types
|
, http-types
|
||||||
, criterion
|
, criterion
|
||||||
, tls >= 1.3.0
|
, tls >= 1.3.0
|
||||||
|
, network >= 3.0
|
||||||
if flag(_old-network)
|
|
||||||
-- "Network.BSD" is only available in network < 2.9
|
|
||||||
build-depends: network < 2.9
|
|
||||||
else
|
|
||||||
-- "Network.BSD" has been moved into its own package `network-bsd`
|
|
||||||
build-depends: network >= 3.0
|
|
||||||
, network-bsd >= 2.7 && < 2.9
|
, network-bsd >= 2.7 && < 2.9
|
||||||
|
|
||||||
|
--if flag(_old-network)
|
||||||
|
---- "Network.BSD" is only available in network < 2.9
|
||||||
|
--build-depends: network < 2.9
|
||||||
|
--else
|
||||||
|
---- "Network.BSD" has been moved into its own package `network-bsd`
|
||||||
|
--build-depends: network >= 3.0
|
||||||
|
--, network-bsd >= 2.7 && < 2.9
|
||||||
|
|
||||||
default-language: Haskell2010
|
default-language: Haskell2010
|
||||||
default-extensions: OverloadedStrings
|
default-extensions: OverloadedStrings
|
||||||
|
|
|
@ -4,6 +4,7 @@
|
||||||
module QuerySpec (spec) where
|
module QuerySpec (spec) where
|
||||||
import Data.String (IsString(..))
|
import Data.String (IsString(..))
|
||||||
import TestImport
|
import TestImport
|
||||||
|
import Control.Concurrent (threadDelay)
|
||||||
import Control.Exception
|
import Control.Exception
|
||||||
import Control.Monad (forM_, when)
|
import Control.Monad (forM_, when)
|
||||||
import System.Environment (getEnv)
|
import System.Environment (getEnv)
|
||||||
|
@ -75,6 +76,14 @@ spec = around withCleanDatabase $ do
|
||||||
db thisDatabase `shouldReturn` testDBName
|
db thisDatabase `shouldReturn` testDBName
|
||||||
db (useDb anotherDBName thisDatabase) `shouldReturn` anotherDBName
|
db (useDb anotherDBName thisDatabase) `shouldReturn` anotherDBName
|
||||||
|
|
||||||
|
describe "collectionWithDot" $ do
|
||||||
|
it "uses a collection with dots in the name" $ do
|
||||||
|
let coll = "collection.with.dot"
|
||||||
|
_id <- db $ insert coll ["name" =: "jack", "color" =: "blue"]
|
||||||
|
Just doc <- db $ findOne (select ["name" =: "jack"] coll)
|
||||||
|
doc !? "color" `shouldBe` (Just "blue")
|
||||||
|
|
||||||
|
|
||||||
describe "insert" $ do
|
describe "insert" $ do
|
||||||
it "inserts a document to the collection and returns its _id" $ do
|
it "inserts a document to the collection and returns its _id" $ do
|
||||||
_id <- db $ insert "team" ["name" =: "Yankees", "league" =: "American"]
|
_id <- db $ insert "team" ["name" =: "Yankees", "league" =: "American"]
|
||||||
|
@ -87,6 +96,21 @@ spec = around withCleanDatabase $ do
|
||||||
db (count $ select ["name" =: "Yankees", "league" =: "American"] "team") `shouldReturn` 1
|
db (count $ select ["name" =: "Yankees", "league" =: "American"] "team") `shouldReturn` 1
|
||||||
_id `shouldBe` ()
|
_id `shouldBe` ()
|
||||||
|
|
||||||
|
describe "upsert" $ do
|
||||||
|
it "upserts a document twice with the same spec" $ do
|
||||||
|
let q = select ["name" =: "jack"] "users"
|
||||||
|
db $ upsert q ["color" =: "blue", "name" =: "jack"]
|
||||||
|
-- since there is no way to ask for a ack, we must wait for "a sufficient time"
|
||||||
|
-- for the write to be visible
|
||||||
|
threadDelay 10000
|
||||||
|
db (rest =<< find (select [] "users")) >>= print
|
||||||
|
db (count $ select ["name" =: "jack"] "users") `shouldReturn` 1
|
||||||
|
db $ upsert q ["color" =: "red", "name" =: "jack"]
|
||||||
|
threadDelay 10000
|
||||||
|
db (count $ select ["name" =: "jack"] "users") `shouldReturn` 1
|
||||||
|
Just doc <- db $ findOne (select ["name" =: "jack"] "users")
|
||||||
|
doc !? "color" `shouldBe` Just "red"
|
||||||
|
|
||||||
describe "insertMany" $ do
|
describe "insertMany" $ do
|
||||||
it "inserts documents to the collection and returns their _ids" $ do
|
it "inserts documents to the collection and returns their _ids" $ do
|
||||||
(_id1:_id2:_) <- db $ insertMany "team" [ ["name" =: "Yankees", "league" =: "American"]
|
(_id1:_id2:_) <- db $ insertMany "team" [ ["name" =: "Yankees", "league" =: "American"]
|
||||||
|
|
Loading…
Reference in a new issue