initial MongoDB.hs: can insert and delete
This commit is contained in:
parent
b18d3d54b0
commit
41b9c8d139
2 changed files with 150 additions and 1 deletions
146
Database/MongoDB.hs
Normal file
146
Database/MongoDB.hs
Normal file
|
@ -0,0 +1,146 @@
|
||||||
|
module Database.MongoDB
|
||||||
|
(
|
||||||
|
connect, connectOnPort,
|
||||||
|
delete,
|
||||||
|
remove,
|
||||||
|
insert,
|
||||||
|
insertMany,
|
||||||
|
query
|
||||||
|
)
|
||||||
|
where
|
||||||
|
import Control.Monad
|
||||||
|
import Data.Binary
|
||||||
|
import Data.Binary.Put
|
||||||
|
import Data.ByteString.Char8
|
||||||
|
import qualified Data.ByteString.Lazy as L
|
||||||
|
import qualified Data.ByteString.Lazy.UTF8 as L8
|
||||||
|
import Data.Int
|
||||||
|
import Data.IORef
|
||||||
|
import qualified Data.List as List
|
||||||
|
import Database.MongoDB.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.Random
|
||||||
|
|
||||||
|
data Connection = Connection { cHandle :: Handle, cRand :: IORef [Int] }
|
||||||
|
|
||||||
|
connect :: HostName -> IO Connection
|
||||||
|
connect = flip connectOnPort $ Network.PortNumber 27017
|
||||||
|
|
||||||
|
connectOnPort :: HostName -> Network.PortID -> IO Connection
|
||||||
|
connectOnPort host port = do
|
||||||
|
h <- Network.connectTo host port
|
||||||
|
hSetBuffering h NoBuffering
|
||||||
|
r <- newStdGen
|
||||||
|
let ns = randomRs (fromIntegral (minBound :: Int32),
|
||||||
|
fromIntegral (maxBound :: Int32)) r
|
||||||
|
nsRef <- newIORef ns
|
||||||
|
return $ Connection { cHandle = h, cRand = nsRef }
|
||||||
|
|
||||||
|
data Opcode
|
||||||
|
= OP_REPLY -- 1 Reply to a client request. responseTo is set
|
||||||
|
| OP_MSG -- 1000 generic msg command followed by a string
|
||||||
|
| OP_UPDATE -- 2001 update document
|
||||||
|
| OP_INSERT -- 2002 insert new document
|
||||||
|
| OP_GET_BY_OID -- 2003 is this used?
|
||||||
|
| OP_QUERY -- 2004 query a collection
|
||||||
|
| OP_GET_MORE -- 2005 Get more data from a query. See Cursors
|
||||||
|
| OP_DELETE -- 2006 Delete documents
|
||||||
|
| OP_KILL_CURSORS -- 2007 Tell database client is done with a cursor
|
||||||
|
deriving (Show, Eq)
|
||||||
|
|
||||||
|
fromOpcode OP_REPLY = 1
|
||||||
|
fromOpcode OP_MSG = 1000
|
||||||
|
fromOpcode OP_UPDATE = 2001
|
||||||
|
fromOpcode OP_INSERT = 2002
|
||||||
|
fromOpcode OP_GET_BY_OID = 2003
|
||||||
|
fromOpcode OP_QUERY = 2004
|
||||||
|
fromOpcode OP_GET_MORE = 2005
|
||||||
|
fromOpcode OP_DELETE = 2006
|
||||||
|
fromOpcode OP_KILL_CURSORS = 2007
|
||||||
|
|
||||||
|
toOpcode 1 = OP_REPLY
|
||||||
|
toOpcode 1000 = OP_MSG
|
||||||
|
toOpcode 2001 = OP_UPDATE
|
||||||
|
toOpcode 2002 = OP_INSERT
|
||||||
|
toOpcode 2003 = OP_GET_BY_OID
|
||||||
|
toOpcode 2004 = OP_QUERY
|
||||||
|
toOpcode 2005 = OP_GET_MORE
|
||||||
|
toOpcode 2006 = OP_DELETE
|
||||||
|
toOpcode 2007 = OP_KILL_CURSORS
|
||||||
|
|
||||||
|
type Collection = String
|
||||||
|
type Selector = BSONObject
|
||||||
|
type FieldSelector = BSONObject
|
||||||
|
type RequestID = Int32
|
||||||
|
type NumToSkip = Int32
|
||||||
|
type NumToReturn = Int32
|
||||||
|
|
||||||
|
delete :: Connection -> Collection -> Selector -> IO RequestID
|
||||||
|
delete c col sel = do
|
||||||
|
let body = runPut $ do
|
||||||
|
putI32 0
|
||||||
|
putCol col
|
||||||
|
putI32 0
|
||||||
|
put sel
|
||||||
|
(reqId, msg) <- packMsg c OP_DELETE body
|
||||||
|
L.hPut (cHandle c) msg
|
||||||
|
return reqId
|
||||||
|
|
||||||
|
remove = delete
|
||||||
|
|
||||||
|
insert :: Connection -> Collection -> BSONObject -> IO RequestID
|
||||||
|
insert c col doc = do
|
||||||
|
let body = runPut $ do
|
||||||
|
putI32 0
|
||||||
|
putCol col
|
||||||
|
put doc
|
||||||
|
(reqId, msg) <- packMsg c OP_INSERT body
|
||||||
|
L.hPut (cHandle c) msg
|
||||||
|
return reqId
|
||||||
|
|
||||||
|
insertMany :: Connection -> Collection -> [BSONObject] -> IO RequestID
|
||||||
|
insertMany c col docs = do
|
||||||
|
let body = runPut $ do
|
||||||
|
putI32 0
|
||||||
|
putCol col
|
||||||
|
forM_ docs put
|
||||||
|
(reqId, msg) <- packMsg c OP_INSERT body
|
||||||
|
L.hPut (cHandle c) msg
|
||||||
|
return reqId
|
||||||
|
|
||||||
|
query :: Connection -> Collection -> NumToSkip -> NumToReturn -> Selector ->
|
||||||
|
Maybe FieldSelector -> IO RequestID
|
||||||
|
query c col skip ret sel fsel = do
|
||||||
|
let body = runPut $ do
|
||||||
|
putI32 0 -- TODO opts
|
||||||
|
putCol col
|
||||||
|
putI32 skip
|
||||||
|
putI32 ret
|
||||||
|
put sel
|
||||||
|
put fsel
|
||||||
|
(reqId, msg) <- packMsg c OP_QUERY body
|
||||||
|
L.hPut (cHandle c) msg
|
||||||
|
return reqId
|
||||||
|
|
||||||
|
|
||||||
|
putCol col = putByteString (pack 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)
|
|
@ -6,8 +6,11 @@ Build-Depends: base,
|
||||||
bytestring,
|
bytestring,
|
||||||
containers,
|
containers,
|
||||||
data-binary-ieee754,
|
data-binary-ieee754,
|
||||||
|
network,
|
||||||
|
random,
|
||||||
time,
|
time,
|
||||||
utf8-string
|
utf8-string
|
||||||
Build-Type: Simple
|
Build-Type: Simple
|
||||||
Exposed-modules: Database.MongoDB.BSON
|
Exposed-modules: Database.MongoDB,
|
||||||
|
Database.MongoDB.BSON
|
||||||
Other-modules: Database.MongoDB.Util
|
Other-modules: Database.MongoDB.Util
|
||||||
|
|
Loading…
Reference in a new issue