From 6a9a533fcc589f78c1c3f1184f94ca95172c3293 Mon Sep 17 00:00:00 2001
From: "Scott R. Parish" <sparish@peak6.com>
Date: Thu, 14 Jan 2010 07:16:20 -0600
Subject: [PATCH] adding update support

---
 Database/MongoDB.hs | 21 +++++++++++++++++++++
 1 file changed, 21 insertions(+)

diff --git a/Database/MongoDB.hs b/Database/MongoDB.hs
index 911a965..4c066cc 100644
--- a/Database/MongoDB.hs
+++ b/Database/MongoDB.hs
@@ -93,6 +93,13 @@ fromQueryOpts opts = List.foldl (.|.) 0 $ fmap toVal opts
           toVal QO_OpLogReplay = 8
           toVal QO_NoCursorTimeout = 16
 
+data UpdateFlag = UF_Upsert
+                | UF_Multiupdate
+                deriving (Show, Enum)
+
+fromUpdateFlags flags = List.foldl (.|.) 0 $
+                        flip fmap flags $ (1 `shiftL`) . fromEnum
+
 delete :: Connection -> Collection -> Selector -> IO RequestID
 delete c col sel = do
   let body = runPut $ do
@@ -142,6 +149,20 @@ query c col opts skip ret sel fsel = do
   L.hPut (cHandle c) msg
   getReply c reqID
 
+update :: Connection -> Collection ->
+          [UpdateFlag] -> Selector -> BSONObject -> IO RequestID
+update c col flags sel obj = do
+  let body = runPut $ do
+               putI32 0
+               putCol col
+               putI32 $ fromUpdateFlags flags
+               put sel
+               put obj
+  (reqID, msg) <- packMsg c OP_UPDATE body
+  L.hPut (cHandle c) msg
+  return reqID
+
+
 data Hdr = Hdr {
       hMsgLen :: Int32,
       hReqID :: Int32,