packages feed

mongoDB 2.0.3 → 2.0.4

raw patch · 6 files changed

+125/−31 lines, 6 filesdep +hspecdep +mongoDBdep +old-localedep ~basedep ~mtl

Dependencies added: hspec, mongoDB, old-locale, time

Dependency ranges changed: base, mtl

Files

+ Database/MongoDB/Internal/Connection.hs view
@@ -0,0 +1,76 @@++-- | This module defines a connection interface. It could be a regular+-- network connection, TLS connection, a mock or anything else.++module Database.MongoDB.Internal.Connection (+    Connection(..),+    readExactly,+    writeLazy,+    fromHandle,+) where++import Prelude hiding (read)+import Data.Monoid+import Data.IORef+import Data.ByteString (ByteString)+import qualified Data.ByteString as ByteString+import qualified Data.ByteString.Lazy as Lazy (ByteString)+import qualified Data.ByteString.Lazy as Lazy.ByteString+import Control.Monad+import System.IO+import System.IO.Error (mkIOError, eofErrorType)++-- | Abstract connection interface+--+-- `read` should return `ByteString.null` on EOF+data Connection = Connection {+    read :: IO ByteString,+    unread :: ByteString -> IO (),+    write :: ByteString -> IO (),+    flush :: IO (),+    close :: IO ()}++readExactly :: Connection -> Int -> IO Lazy.ByteString+-- ^ Read specified number of bytes+--+-- If EOF is reached before N bytes then raise EOF exception.+readExactly conn count = go mempty count+  where+  go acc n = do+    -- read until get enough bytes+    chunk <- read conn+    when (ByteString.null chunk) $+      ioError eof+    let len = ByteString.length chunk+    if len >= n+      then do+        let (res, rest) = ByteString.splitAt n chunk+        unless (ByteString.null rest) $+          unread conn rest+        return (acc <> Lazy.ByteString.fromStrict res)+      else go (acc <> Lazy.ByteString.fromStrict chunk) (n - len)+  eof = mkIOError eofErrorType "Database.MongoDB.Internal.Connection"+                  Nothing Nothing++writeLazy :: Connection -> Lazy.ByteString -> IO ()+writeLazy conn = mapM_ (write conn) . Lazy.ByteString.toChunks++fromHandle :: Handle -> IO Connection+-- ^ Make connection form handle+fromHandle handle = do+  restRef <- newIORef mempty+  return Connection+    { read = do+        rest <- readIORef restRef+        writeIORef restRef mempty+        if ByteString.null rest+          -- 32k corresponds to the default chunk size+          -- used in bytestring package+          then ByteString.hGetSome handle (32 * 1024)+          else return rest+    , unread = \rest ->+        modifyIORef restRef (rest <>)+    , write = ByteString.hPut handle+    , flush = hFlush handle+    , close = hClose handle+    }
Database/MongoDB/Internal/Protocol.hs view
@@ -11,7 +11,7 @@ module Database.MongoDB.Internal.Protocol (     FullCollection,     -- * Pipe-    Pipe, newPipe, send, call,+    Pipe, newPipe, newPipeWith, send, call,     -- ** Notice     Notice(..), InsertOption(..), UpdateOption(..), DeleteOption(..), CursorId,     -- ** Request@@ -30,7 +30,7 @@ import Data.Bits (bit, testBit) import Data.Int (Int32, Int64) import Data.IORef (IORef, newIORef, atomicModifyIORef)-import System.IO (Handle, hClose, hFlush)+import System.IO (Handle) import System.IO.Unsafe (unsafePerformIO)  import qualified Data.ByteString.Lazy as L@@ -45,11 +45,14 @@ import qualified Data.Text as T import qualified Data.Text.Encoding as TE -import Database.MongoDB.Internal.Util (whenJust, hGetN, bitOr, byteStringHex)+import Database.MongoDB.Internal.Util (whenJust, bitOr, byteStringHex) import System.IO.Pipeline (Pipeline, newPipeline, IOStream(..))  import qualified System.IO.Pipeline as P +import Database.MongoDB.Internal.Connection (Connection)+import qualified Database.MongoDB.Internal.Connection as Connection+ -- * Pipe  type Pipe = Pipeline Response Message@@ -57,8 +60,14 @@  newPipe :: Handle -> IO Pipe -- ^ Create pipe over handle-newPipe handle = newPipeline $ IOStream (writeMessage handle) (readMessage handle) (hClose handle)+newPipe handle = Connection.fromHandle handle >>= newPipeWith +newPipeWith :: Connection -> IO Pipe+-- ^ Create pipe over connection+newPipeWith conn = newPipeline $ IOStream (writeMessage conn)+                                          (readMessage conn)+                                          (Connection.close conn)+ send :: Pipe -> [Notice] -> IO () -- ^ Send notices as a contiguous batch to server with no reply. Throw IOError if connection fails. send pipe notices = P.send pipe (notices, Nothing)@@ -79,16 +88,16 @@ -- ^ A write notice(s) with getLastError request, or just query request. -- Note, that requestId will be out of order because request ids will be generated for notices after the request id supplied was generated. This is ok because the mongo server does not care about order just uniqueness. -writeMessage :: Handle -> Message -> IO ()--- ^ Write message to socket-writeMessage handle (notices, mRequest) = do+writeMessage :: Connection -> Message -> IO ()+-- ^ Write message to connection+writeMessage conn (notices, mRequest) = do     forM_ notices $ \n -> writeReq . (Left n,) =<< genRequestId     whenJust mRequest $ writeReq . (Right *** id)-    hFlush handle+    Connection.flush conn  where     writeReq (e, requestId) = do-        L.hPut handle lenBytes-        L.hPut handle bytes+        Connection.writeLazy conn lenBytes+        Connection.writeLazy conn bytes      where         bytes = runPut $ (either putNotice putRequest e) requestId         lenBytes = encodeSize . toEnum . fromEnum $ L.length bytes@@ -97,12 +106,12 @@ type Response = (ResponseTo, Reply) -- ^ Message received from a Mongo server in response to a Request -readMessage :: Handle -> IO Response--- ^ read response from socket-readMessage handle = readResp  where+readMessage :: Connection -> IO Response+-- ^ read response from a connection+readMessage conn = readResp  where     readResp = do-        len <- fromEnum . decodeSize <$> hGetN handle 4-        runGet getReply <$> hGetN handle len+        len <- fromEnum . decodeSize <$> Connection.readExactly conn 4+        runGet getReply <$> Connection.readExactly conn len     decodeSize = subtract 4 . runGet getInt32  type FullCollection = Text
Database/MongoDB/Internal/Util.hs view
@@ -8,18 +8,15 @@ module Database.MongoDB.Internal.Util where  import Control.Applicative ((<$>))-import Control.Exception (assert, handle, throwIO, Exception)+import Control.Exception (handle, throwIO, Exception) import Control.Monad (liftM, liftM2) import Data.Bits (Bits, (.|.)) import Data.Word (Word8) import Network (PortID(..)) import Numeric (showHex)-import System.IO (Handle)-import System.IO.Error (mkIOError, eofErrorType) import System.Random (newStdGen) import System.Random.Shuffle (shuffle') -import qualified Data.ByteString.Lazy as L import qualified Data.ByteString as S  import Control.Monad.Error (MonadError(..), Error(..))@@ -107,15 +104,6 @@     Int32 n -> n == 1     Int64 n -> n == 1     _ -> error $ "expected " ++ show k ++ " to be Num or Bool in " ++ show doc--hGetN :: Handle -> Int -> IO L.ByteString--- ^ Read N bytes from hande, blocking until all N bytes are read. If EOF is reached before N bytes then raise EOF exception.-hGetN h n = assert (n >= 0) $ do-    bytes <- L.hGet h n-    let x = fromEnum $ L.length bytes-    if x >= n then return bytes-        else if x == 0 then ioError (mkIOError eofErrorType "hGetN" (Just h) Nothing)-            else L.append bytes <$> hGetN h (n - x)  byteStringHex :: S.ByteString -> String -- ^ Hexadecimal string representation of a byte string. Each byte yields two hexadecimal characters.
System/IO/Pipeline.hs view
@@ -3,7 +3,7 @@ A pipeline closes itself when a read or write causes an error, so you can detect a broken pipeline by checking isClosed.  It also closes itself when garbage collected, or you can close it explicitly. -}  {-# LANGUAGE RecordWildCards, NamedFieldPuns, ScopedTypeVariables #-}-{-# LANGUAGE CPP #-}+{-# LANGUAGE CPP, FlexibleContexts #-}  #if (__GLASGOW_HASKELL__ >= 706) {-# LANGUAGE RecursiveDo #-}
mongoDB.cabal view
@@ -1,5 +1,5 @@ Name:           mongoDB-Version:        2.0.3+Version:        2.0.4 Synopsis:       Driver (client) for MongoDB, a free, scalable, fast, document                 DBMS Description:    This package lets you connect to MongoDB servers and@@ -14,13 +14,14 @@ Copyright:      Copyright (c) 2010-2012 10gen Inc. License:        OtherLicense License-file:   LICENSE-Cabal-version:  >= 1.6+Cabal-version:  >= 1.10 Build-type:     Simple Stability:      alpha  Library   GHC-options:      -Wall   GHC-prof-options: -auto-all+  default-language: Haskell2010    Build-depends:      array -any                     , base <5@@ -43,6 +44,7 @@   Exposed-modules:  Database.MongoDB                     Database.MongoDB.Admin                     Database.MongoDB.Connection+                    Database.MongoDB.Internal.Connection                     Database.MongoDB.Internal.Protocol                     Database.MongoDB.Internal.Util                     Database.MongoDB.Query@@ -51,3 +53,21 @@ Source-repository head     Type:     git     Location: https://github.com/mongodb-haskell/mongodb++test-suite test+  hs-source-dirs: test+  main-is: Spec.hs+  ghc-options:       -Wall+  type: exitcode-stdio-1.0+  build-depends:   mongoDB+                 , base+                 , mtl+                 , hspec >= 2+                 -- Keep supporting the old-locale and time < 1.5 packages for+                 -- now. It's too difficult to support old versions of GHC and+                 -- the new version of time.+                 , old-locale+                 , time++  default-language: Haskell2010+  default-extensions: OverloadedStrings
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}