Compare commits

...

13 commits

Author SHA1 Message Date
63bba3a6d3
Merge patch for Mongo 6 2023-08-07 13:18:39 -05:00
0afaf89e1d
Merge branch 'runCommand-compat' of https://github.com/fumieval/mongodb into zgo-patch 2023-08-07 13:18:07 -05:00
22537d87ee
Merge branch 'external' into zgo-patch 2023-07-27 12:47:02 -05:00
cd3977c731
Adjust deps 2023-07-27 12:01:22 -05:00
4a9a1cb63f
Merge branch 'scram-sha-256' of https://github.com/fumieval/mongodb into external 2023-07-27 10:44:45 -05:00
Victor Denisov
35ee53abed Add changelog entry 2023-06-25 14:00:20 -07:00
Victor Denisov
4a46964d4c
Fix issue on collections with '.'
Merge pull request #147 from pierreMizrahi/master
2023-06-25 13:47:58 -07:00
Pierre Mizrahi
51358d13c4 mongo 6: fix issue on collections with '.'
Collection names are allowed to have a '.' in their name, db
names aren't (see
https://www.mongodb.com/docs/manual/reference/limits/#naming-restrictions)

This codes changes the logic to extract the collection
name form a FullConnecton string by stripping until the first
dot, and provides a test case.
2023-05-29 11:48:05 +02:00
Fumiaki Kinoshita
46643fd8ad Make runCommand compatible with MongoDB 6.0 2023-05-02 16:56:38 +09:00
Fumiaki Kinoshita
90afe88784 Support SCRAM-SHA-256 2023-04-18 11:16:23 +09:00
Pierre Mizrahi
995087e9a0 repair single document upserts when using OP_MSG
780df80cfc introduces support for the
OP_MSG protocol. Unfortunately, the upsert and multi options of the
update command still use flagBits to communicate the options, whereas
they must be provided directly into the command document,
alongside the "q" and "v" fields.

This commit:
 - introduces a test for a single-document upsert that, if isolated,
   succeeds against the reference MongoDB 3.6 container, but fails
   against an official 6.0 image.
 - provides a patch that sets the appropriate options.

The test is not perfect as the upsert operation is inherently racy and
this difficult to test. A comfortable threadDelay has been inserted as
a workaround to accomodate for medium workloads.
2023-02-13 14:05:56 +01:00
Victor Denisov
fb0d140aa4 Get rid of MonadFail constraints in MongoDB.Query
PR #141
2023-02-04 21:50:34 -08:00
Victor Denisov
6f1d842641 Add missing dependencies to benchmarks 2023-02-04 21:49:53 -08:00
6 changed files with 188 additions and 78 deletions

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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]@

View file

@ -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

View file

@ -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"]