Vergara_Tech/mongodb
2
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity

Use text instead of compact-string-fix

Browse source
This commit is contained in:
Fedor Gogolev 2012-05-08 19:13:25 +04:00
parent 3f3cd028da
commit 17f528e835
6 changed files with 48 additions and 41 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

31
Database/MongoDB/Admin.hs
View file

@ -31,9 +31,10 @@ import Database.MongoDB.Internal.Protocol (pwHash, pwKey)
import Database.MongoDB.Connection (Host, showHostPort) import Database.MongoDB.Connection (Host, showHostPort)
import Database.MongoDB.Query import Database.MongoDB.Query
import Data.Bson import Data.Bson
import Data.UString (pack, append, intercalate)
import Control.Monad.Reader import Control.Monad.Reader
import qualified Data.HashTable as T import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.HashTable as H
import Data.IORef import Data.IORef
import qualified Data.Set as S import qualified Data.Set as S
import System.IO.Unsafe (unsafePerformIO) import System.IO.Unsafe (unsafePerformIO)
@ -68,7 +69,7 @@ dropCollection coll = do
resetIndexCache resetIndexCache
r <- runCommand ["drop" =: coll] r <- runCommand ["drop" =: coll]
if true1 "ok" r then return True else do if true1 "ok" r then return True else do
if at "errmsg" r == ("ns not found" :: UString) then return False else if at "errmsg" r == ("ns not found" :: Text) then return False else
fail $ "dropCollection failed: " ++ show r fail $ "dropCollection failed: " ++ show r
validateCollection :: (MonadIO' m) => Collection -> Action m Document validateCollection :: (MonadIO' m) => Collection -> Action m Document
@ -77,7 +78,7 @@ validateCollection coll = runCommand ["validate" =: coll]
-- ** Index -- ** Index
type IndexName = UString type IndexName = Text
data Index = Index { data Index = Index {
iColl :: Collection, iColl :: Collection,
@ -100,8 +101,8 @@ index :: Collection -> Order -> Index
index coll keys = Index coll keys (genName keys) False False index coll keys = Index coll keys (genName keys) False False
genName :: Order -> IndexName genName :: Order -> IndexName
genName keys = intercalate "_" (map f keys) where genName keys = T.intercalate "_" (map f keys) where
f (k := v) = k `append` "_" `append` pack (show v) f (k := v) = k `T.append` "_" `T.append` T.pack (show v)
ensureIndex :: (MonadIO' m) => Index -> Action m () ensureIndex :: (MonadIO' m) => Index -> Action m ()
-- ^ Create index if we did not already create one. May be called repeatedly with practically no performance hit, because we remember if we already called this for the same index (although this memory gets wiped out every 15 minutes, in case another client drops the index and we want to create it again). -- ^ Create index if we did not already create one. May be called repeatedly with practically no performance hit, because we remember if we already called this for the same index (although this memory gets wiped out every 15 minutes, in case another client drops the index and we want to create it again).
@ -132,11 +133,11 @@ dropIndexes :: (MonadIO' m) => Collection -> Action m Document
-- ^ Drop all indexes on this collection -- ^ Drop all indexes on this collection
dropIndexes coll = do dropIndexes coll = do
resetIndexCache resetIndexCache
runCommand ["deleteIndexes" =: coll, "index" =: ("*" :: UString)] runCommand ["deleteIndexes" =: coll, "index" =: ("*" :: Text)]
-- *** Index cache -- *** Index cache
type DbIndexCache = T.HashTable Database IndexCache type DbIndexCache = H.HashTable Database IndexCache
-- ^ Cache the indexes we create so repeatedly calling ensureIndex only hits database the first time. Clear cache every once in a while so if someone else deletes index we will recreate it on ensureIndex. -- ^ Cache the indexes we create so repeatedly calling ensureIndex only hits database the first time. Clear cache every once in a while so if someone else deletes index we will recreate it on ensureIndex.
type IndexCache = IORef (S.Set (Collection, IndexName)) type IndexCache = IORef (S.Set (Collection, IndexName))
@ -144,27 +145,27 @@ type IndexCache = IORef (S.Set (Collection, IndexName))
dbIndexCache :: DbIndexCache dbIndexCache :: DbIndexCache
-- ^ initialize cache and fork thread that clears it every 15 minutes -- ^ initialize cache and fork thread that clears it every 15 minutes
dbIndexCache = unsafePerformIO $ do dbIndexCache = unsafePerformIO $ do
table <- T.new (==) (T.hashString . unpack) table <- H.new (==) (H.hashString . T.unpack)
_ <- forkIO . forever $ threadDelay 900000000 >> clearDbIndexCache _ <- forkIO . forever $ threadDelay 900000000 >> clearDbIndexCache
return table return table
{-# NOINLINE dbIndexCache #-} {-# NOINLINE dbIndexCache #-}
clearDbIndexCache :: IO () clearDbIndexCache :: IO ()
clearDbIndexCache = do clearDbIndexCache = do
keys <- map fst <$> T.toList dbIndexCache keys <- map fst <$> H.toList dbIndexCache
mapM_ (T.delete dbIndexCache) keys mapM_ (H.delete dbIndexCache) keys
fetchIndexCache :: (MonadIO m) => Action m IndexCache fetchIndexCache :: (MonadIO m) => Action m IndexCache
-- ^ Get index cache for current database -- ^ Get index cache for current database
fetchIndexCache = do fetchIndexCache = do
db <- thisDatabase db <- thisDatabase
liftIO $ do liftIO $ do
mc <- T.lookup dbIndexCache db mc <- H.lookup dbIndexCache db
maybe (newIdxCache db) return mc maybe (newIdxCache db) return mc
where where
newIdxCache db = do newIdxCache db = do
idx <- newIORef S.empty idx <- newIORef S.empty
T.insert dbIndexCache db idx H.insert dbIndexCache db idx
return idx return idx
resetIndexCache :: (MonadIO m) => Action m () resetIndexCache :: (MonadIO m) => Action m ()
@ -223,7 +224,7 @@ repairDatabase db = useDb db $ runCommand ["repairDatabase" =: (1 :: Int)]
serverBuildInfo :: (MonadIO' m) => Action m Document serverBuildInfo :: (MonadIO' m) => Action m Document
serverBuildInfo = useDb admin $ runCommand ["buildinfo" =: (1 :: Int)] serverBuildInfo = useDb admin $ runCommand ["buildinfo" =: (1 :: Int)]
serverVersion :: (MonadIO' m) => Action m UString serverVersion :: (MonadIO' m) => Action m Text
serverVersion = at "version" <$> serverBuildInfo serverVersion = at "version" <$> serverBuildInfo
-- * Diagnostics -- * Diagnostics
@ -248,7 +249,7 @@ totalSize coll = do
xs <- mapM isize =<< getIndexes coll xs <- mapM isize =<< getIndexes coll
return (foldl (+) x xs) return (foldl (+) x xs)
where where
isize idx = at "storageSize" <$> collectionStats (coll `append` ".$" `append` at "name" idx) isize idx = at "storageSize" <$> collectionStats (coll `T.append` ".$" `T.append` at "name" idx)
-- ** Profiling -- ** Profiling

13
Database/MongoDB/Connection.hs
View file

@ -26,7 +26,8 @@ import Control.Monad.Error (ErrorT(..), lift, throwError)
import Control.Concurrent.MVar.Lifted import Control.Concurrent.MVar.Lifted
import Control.Monad (forM_) import Control.Monad (forM_)
import Control.Applicative ((<$>)) import Control.Applicative ((<$>))
import Data.UString (UString, unpack) import Data.Text (Text)
import qualified Data.Text as T
import Data.Bson as D (Document, lookup, at, (=:)) import Data.Bson as D (Document, lookup, at, (=:))
import Database.MongoDB.Query (access, slaveOk, Failure(ConnectionFailure), Command, runCommand) import Database.MongoDB.Query (access, slaveOk, Failure(ConnectionFailure), Command, runCommand)
import Database.MongoDB.Internal.Util (untilSuccess, liftIOE, runIOE, updateAssocs, shuffle, mergesortM) import Database.MongoDB.Internal.Util (untilSuccess, liftIOE, runIOE, updateAssocs, shuffle, mergesortM)
@ -105,12 +106,12 @@ connect' timeoutSecs (Host hostname port) = do
-- * Replica Set -- * Replica Set
type ReplicaSetName = UString type ReplicaSetName = Text
-- | Maintains a connection (created on demand) to each server in the named replica set -- | Maintains a connection (created on demand) to each server in the named replica set
data ReplicaSet = ReplicaSet ReplicaSetName (MVar [(Host, Maybe Pipe)]) Secs data ReplicaSet = ReplicaSet ReplicaSetName (MVar [(Host, Maybe Pipe)]) Secs
replSetName :: ReplicaSet -> UString replSetName :: ReplicaSet -> Text
-- ^ name of connected replica set -- ^ name of connected replica set
replSetName (ReplicaSet rsName _ _) = rsName replSetName (ReplicaSet rsName _ _) = rsName
@ -136,7 +137,7 @@ primary rs@(ReplicaSet rsName _ _) = do
mHost <- statedPrimary <$> updateMembers rs mHost <- statedPrimary <$> updateMembers rs
case mHost of case mHost of
Just host' -> connection rs Nothing host' Just host' -> connection rs Nothing host'
Nothing -> throwError $ userError $ "replica set " ++ unpack rsName ++ " has no primary" Nothing -> throwError $ userError $ "replica set " ++ T.unpack rsName ++ " has no primary"
secondaryOk :: ReplicaSet -> IOE Pipe secondaryOk :: ReplicaSet -> IOE Pipe
-- ^ Return connection to a random secondary, or primary if no secondaries available. -- ^ Return connection to a random secondary, or primary if no secondaries available.
@ -186,8 +187,8 @@ fetchReplicaInfo rs@(ReplicaSet rsName _ _) (host', mPipe) = do
pipe <- connection rs mPipe host' pipe <- connection rs mPipe host'
info <- adminCommand ["isMaster" =: (1 :: Int)] pipe info <- adminCommand ["isMaster" =: (1 :: Int)] pipe
case D.lookup "setName" info of case D.lookup "setName" info of
Nothing -> throwError $ userError $ show host' ++ " not a member of any replica set, including " ++ unpack rsName ++ ": " ++ show info Nothing -> throwError $ userError $ show host' ++ " not a member of any replica set, including " ++ T.unpack rsName ++ ": " ++ show info
Just setName | setName /= rsName -> throwError $ userError $ show host' ++ " not a member of replica set " ++ unpack rsName ++ ": " ++ show info Just setName | setName /= rsName -> throwError $ userError $ show host' ++ " not a member of replica set " ++ T.unpack rsName ++ ": " ++ show info
Just _ -> return (host', info) Just _ -> return (host', info)
connection :: ReplicaSet -> Maybe Pipe -> Host -> IOE Pipe connection :: ReplicaSet -> Maybe Pipe -> Host -> IOE Pipe

22
Database/MongoDB/Internal/Protocol.hs
View file

@ -25,7 +25,7 @@ import Data.ByteString.Lazy as B (length, hPut)
import System.IO.Pipeline (IOE, Pipeline, newPipeline, IOStream(..)) import System.IO.Pipeline (IOE, Pipeline, newPipeline, IOStream(..))
import qualified System.IO.Pipeline as P (send, call) import qualified System.IO.Pipeline as P (send, call)
import System.IO (Handle, hClose) import System.IO (Handle, hClose)
import Data.Bson (Document, UString) import Data.Bson (Document)
import Data.Bson.Binary import Data.Bson.Binary
import Data.Binary.Put import Data.Binary.Put
import Data.Binary.Get import Data.Binary.Get
@ -33,8 +33,10 @@ import Data.Int
import Data.Bits import Data.Bits
import Data.IORef import Data.IORef
import System.IO.Unsafe (unsafePerformIO) import System.IO.Unsafe (unsafePerformIO)
import Data.Text (Text)
import qualified Crypto.Hash.MD5 as MD5 (hash) import qualified Crypto.Hash.MD5 as MD5 (hash)
import Data.UString as U (pack, append, toByteString) import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import Control.Exception as E (try) import Control.Exception as E (try)
import Control.Monad.Error import Control.Monad.Error
import System.IO (hFlush) import System.IO (hFlush)
@ -95,7 +97,7 @@ readMessage handle = ErrorT $ E.try readResp where
runGet getReply <$> hGetN handle len runGet getReply <$> hGetN handle len
decodeSize = subtract 4 . runGet getInt32 decodeSize = subtract 4 . runGet getInt32
type FullCollection = UString type FullCollection = Text
-- ^ Database name and collection name with period (.) in between. Eg. \"myDb.myCollection\" -- ^ Database name and collection name with period (.) in between. Eg. \"myDb.myCollection\"
-- ** Header -- ** Header
@ -319,15 +321,15 @@ rBit AwaitCapable = 3
-- * Authentication -- * Authentication
type Username = UString type Username = Text
type Password = UString type Password = Text
type Nonce = UString type Nonce = Text
pwHash :: Username -> Password -> UString pwHash :: Username -> Password -> Text
pwHash u p = pack . byteStringHex . MD5.hash . toByteString $ u `U.append` ":mongo:" `U.append` p pwHash u p = T.pack . byteStringHex . MD5.hash . TE.encodeUtf8 $ u `T.append` ":mongo:" `T.append` p
pwKey :: Nonce -> Username -> Password -> UString pwKey :: Nonce -> Username -> Password -> Text
pwKey n u p = pack . byteStringHex . MD5.hash . toByteString . U.append n . U.append u $ pwHash u p pwKey n u p = T.pack . byteStringHex . MD5.hash . TE.encodeUtf8 . T.append n . T.append u $ pwHash u p
{- Authors: Tony Hannan <tony@10gen.com> {- Authors: Tony Hannan <tony@10gen.com>

7
Database/MongoDB/Internal/Util.hs
View file

@ -8,7 +8,6 @@ module Database.MongoDB.Internal.Util where
import Control.Applicative (Applicative(..), (<$>)) import Control.Applicative (Applicative(..), (<$>))
import Network (PortID(..)) import Network (PortID(..))
import Data.UString as U (cons, append)
import Data.Bits (Bits, (.|.)) import Data.Bits (Bits, (.|.))
import Data.Bson import Data.Bson
import Data.ByteString.Lazy as S (ByteString, length, append, hGet) import Data.ByteString.Lazy as S (ByteString, length, append, hGet)
@ -17,7 +16,9 @@ import System.IO.Error (mkIOError, eofErrorType)
import Control.Exception (assert) import Control.Exception (assert)
import Control.Monad.Error import Control.Monad.Error
import Control.Arrow (left) import Control.Arrow (left)
import Data.Text (Text)
import qualified Data.ByteString as BS (ByteString, unpack) import qualified Data.ByteString as BS (ByteString, unpack)
import qualified Data.Text as T
import Data.Word (Word8) import Data.Word (Word8)
import Numeric (showHex) import Numeric (showHex)
import System.Random.Shuffle (shuffle') import System.Random.Shuffle (shuffle')
@ -96,9 +97,9 @@ bitOr :: (Bits a) => [a] -> a
-- ^ bit-or all numbers together -- ^ bit-or all numbers together
bitOr = foldl (.|.) 0 bitOr = foldl (.|.) 0
(<.>) :: UString -> UString -> UString (<.>) :: Text -> Text -> Text
-- ^ 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 = U.append a (cons '.' b) a <.> b = T.append a (T.cons '.' b)
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.

13
Database/MongoDB/Query.hs
View file

@ -39,7 +39,8 @@ module Database.MongoDB.Query (
) where ) where
import Prelude as X hiding (lookup) import Prelude as X hiding (lookup)
import Data.UString as U (UString, dropWhile, any, tail) import Data.Text (Text)
import qualified Data.Text as T
import Data.Bson (Document, at, valueAt, lookup, look, Field(..), (=:), (=?), Label, Value(String,Doc), Javascript, genObjectId) import Data.Bson (Document, at, valueAt, lookup, look, Field(..), (=:), (=?), Label, Value(String,Doc), Javascript, genObjectId)
import Database.MongoDB.Internal.Protocol (Pipe, Notice(..), Request(GetMore, qOptions, qFullCollection, qSkip, qBatchSize, qSelector, qProjector), Reply(..), QueryOption(..), ResponseFlag(..), InsertOption(..), UpdateOption(..), DeleteOption(..), CursorId, FullCollection, Username, Password, pwKey) import Database.MongoDB.Internal.Protocol (Pipe, Notice(..), Request(GetMore, qOptions, qFullCollection, qSkip, qBatchSize, qSelector, qProjector), Reply(..), QueryOption(..), ResponseFlag(..), InsertOption(..), UpdateOption(..), DeleteOption(..), CursorId, FullCollection, Username, Password, pwKey)
import qualified Database.MongoDB.Internal.Protocol as P (send, call, Request(Query)) import qualified Database.MongoDB.Internal.Protocol as P (send, call, Request(Query))
@ -184,7 +185,7 @@ instance (MonadDB m, Monoid w) => MonadDB (RWST r w s m) where
-- * Database -- * Database
type Database = UString type Database = Text
allDatabases :: (MonadIO' m) => Action m [Database] allDatabases :: (MonadIO' m) => Action m [Database]
-- ^ List all databases residing on server -- ^ List all databases residing on server
@ -208,7 +209,7 @@ auth usr pss = do
-- * Collection -- * Collection
type Collection = UString type Collection = Text
-- ^ Collection name (not prefixed with database) -- ^ Collection name (not prefixed with database)
allCollections :: (MonadIO m, MonadBaseControl IO m, Functor m) => Action m [Collection] allCollections :: (MonadIO m, MonadBaseControl IO m, Functor m) => Action m [Collection]
@ -218,8 +219,8 @@ allCollections = do
docs <- rest =<< find (query [] "system.namespaces") {sort = ["name" =: (1 :: Int)]} docs <- rest =<< find (query [] "system.namespaces") {sort = ["name" =: (1 :: Int)]}
return . filter (not . isSpecial db) . map dropDbPrefix $ map (at "name") docs return . filter (not . isSpecial db) . map dropDbPrefix $ map (at "name") docs
where where
dropDbPrefix = U.tail . U.dropWhile (/= '.') dropDbPrefix = T.tail . T.dropWhile (/= '.')
isSpecial db col = U.any (== '$') col && db <.> col /= "local.oplog.$main" isSpecial db col = T.any (== '$') col && db <.> col /= "local.oplog.$main"
-- * Selection -- * Selection
@ -670,7 +671,7 @@ runCommand :: (MonadIO' m) => Command -> Action m Document
runCommand c = maybe err id <$> findOne (query c "$cmd") where runCommand c = maybe err id <$> findOne (query c "$cmd") where
err = error $ "Nothing returned for command: " ++ show c err = error $ "Nothing returned for command: " ++ show c
runCommand1 :: (MonadIO' m) => UString -> Action m Document runCommand1 :: (MonadIO' m) => Text -> Action m Document
-- ^ @runCommand1 foo = runCommand [foo =: 1]@ -- ^ @runCommand1 foo = runCommand [foo =: 1]@
runCommand1 c = runCommand [c =: (1 :: Int)] runCommand1 c = runCommand [c =: (1 :: Int)]

3
mongoDB.cabal
View file

@ -10,7 +10,8 @@ build-depends:
array -any, array -any,
base <5, base <5,
binary -any, binary -any,
bson -any, bson-text -any,
text,
bytestring -any, bytestring -any,
containers -any, containers -any,
mtl >= 2, mtl >= 2,