Use text instead of compact-string-fix
This commit is contained in:
parent
3f3cd028da
commit
17f528e835
6 changed files with 48 additions and 41 deletions
|
@ -31,9 +31,10 @@ import Database.MongoDB.Internal.Protocol (pwHash, pwKey)
|
|||
import Database.MongoDB.Connection (Host, showHostPort)
|
||||
import Database.MongoDB.Query
|
||||
import Data.Bson
|
||||
import Data.UString (pack, append, intercalate)
|
||||
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 qualified Data.Set as S
|
||||
import System.IO.Unsafe (unsafePerformIO)
|
||||
|
@ -68,7 +69,7 @@ dropCollection coll = do
|
|||
resetIndexCache
|
||||
r <- runCommand ["drop" =: coll]
|
||||
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
|
||||
|
||||
validateCollection :: (MonadIO' m) => Collection -> Action m Document
|
||||
|
@ -77,7 +78,7 @@ validateCollection coll = runCommand ["validate" =: coll]
|
|||
|
||||
-- ** Index
|
||||
|
||||
type IndexName = UString
|
||||
type IndexName = Text
|
||||
|
||||
data Index = Index {
|
||||
iColl :: Collection,
|
||||
|
@ -100,8 +101,8 @@ index :: Collection -> Order -> Index
|
|||
index coll keys = Index coll keys (genName keys) False False
|
||||
|
||||
genName :: Order -> IndexName
|
||||
genName keys = intercalate "_" (map f keys) where
|
||||
f (k := v) = k `append` "_" `append` pack (show v)
|
||||
genName keys = T.intercalate "_" (map f keys) where
|
||||
f (k := v) = k `T.append` "_" `T.append` T.pack (show v)
|
||||
|
||||
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).
|
||||
|
@ -132,11 +133,11 @@ dropIndexes :: (MonadIO' m) => Collection -> Action m Document
|
|||
-- ^ Drop all indexes on this collection
|
||||
dropIndexes coll = do
|
||||
resetIndexCache
|
||||
runCommand ["deleteIndexes" =: coll, "index" =: ("*" :: UString)]
|
||||
runCommand ["deleteIndexes" =: coll, "index" =: ("*" :: Text)]
|
||||
|
||||
-- *** 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.
|
||||
|
||||
type IndexCache = IORef (S.Set (Collection, IndexName))
|
||||
|
@ -144,27 +145,27 @@ type IndexCache = IORef (S.Set (Collection, IndexName))
|
|||
dbIndexCache :: DbIndexCache
|
||||
-- ^ initialize cache and fork thread that clears it every 15 minutes
|
||||
dbIndexCache = unsafePerformIO $ do
|
||||
table <- T.new (==) (T.hashString . unpack)
|
||||
table <- H.new (==) (H.hashString . T.unpack)
|
||||
_ <- forkIO . forever $ threadDelay 900000000 >> clearDbIndexCache
|
||||
return table
|
||||
{-# NOINLINE dbIndexCache #-}
|
||||
|
||||
clearDbIndexCache :: IO ()
|
||||
clearDbIndexCache = do
|
||||
keys <- map fst <$> T.toList dbIndexCache
|
||||
mapM_ (T.delete dbIndexCache) keys
|
||||
keys <- map fst <$> H.toList dbIndexCache
|
||||
mapM_ (H.delete dbIndexCache) keys
|
||||
|
||||
fetchIndexCache :: (MonadIO m) => Action m IndexCache
|
||||
-- ^ Get index cache for current database
|
||||
fetchIndexCache = do
|
||||
db <- thisDatabase
|
||||
liftIO $ do
|
||||
mc <- T.lookup dbIndexCache db
|
||||
mc <- H.lookup dbIndexCache db
|
||||
maybe (newIdxCache db) return mc
|
||||
where
|
||||
newIdxCache db = do
|
||||
idx <- newIORef S.empty
|
||||
T.insert dbIndexCache db idx
|
||||
H.insert dbIndexCache db idx
|
||||
return idx
|
||||
|
||||
resetIndexCache :: (MonadIO m) => Action m ()
|
||||
|
@ -223,7 +224,7 @@ repairDatabase db = useDb db $ runCommand ["repairDatabase" =: (1 :: Int)]
|
|||
serverBuildInfo :: (MonadIO' m) => Action m Document
|
||||
serverBuildInfo = useDb admin $ runCommand ["buildinfo" =: (1 :: Int)]
|
||||
|
||||
serverVersion :: (MonadIO' m) => Action m UString
|
||||
serverVersion :: (MonadIO' m) => Action m Text
|
||||
serverVersion = at "version" <$> serverBuildInfo
|
||||
|
||||
-- * Diagnostics
|
||||
|
@ -248,7 +249,7 @@ totalSize coll = do
|
|||
xs <- mapM isize =<< getIndexes coll
|
||||
return (foldl (+) x xs)
|
||||
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
|
||||
|
||||
|
|
|
@ -26,7 +26,8 @@ import Control.Monad.Error (ErrorT(..), lift, throwError)
|
|||
import Control.Concurrent.MVar.Lifted
|
||||
import Control.Monad (forM_)
|
||||
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 Database.MongoDB.Query (access, slaveOk, Failure(ConnectionFailure), Command, runCommand)
|
||||
import Database.MongoDB.Internal.Util (untilSuccess, liftIOE, runIOE, updateAssocs, shuffle, mergesortM)
|
||||
|
@ -105,12 +106,12 @@ connect' timeoutSecs (Host hostname port) = do
|
|||
|
||||
-- * Replica Set
|
||||
|
||||
type ReplicaSetName = UString
|
||||
type ReplicaSetName = Text
|
||||
|
||||
-- | Maintains a connection (created on demand) to each server in the named replica set
|
||||
data ReplicaSet = ReplicaSet ReplicaSetName (MVar [(Host, Maybe Pipe)]) Secs
|
||||
|
||||
replSetName :: ReplicaSet -> UString
|
||||
replSetName :: ReplicaSet -> Text
|
||||
-- ^ name of connected replica set
|
||||
replSetName (ReplicaSet rsName _ _) = rsName
|
||||
|
||||
|
@ -136,7 +137,7 @@ primary rs@(ReplicaSet rsName _ _) = do
|
|||
mHost <- statedPrimary <$> updateMembers rs
|
||||
case mHost of
|
||||
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
|
||||
-- ^ 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'
|
||||
info <- adminCommand ["isMaster" =: (1 :: Int)] pipe
|
||||
case D.lookup "setName" info of
|
||||
Nothing -> throwError $ userError $ show host' ++ " not a member of any replica set, including " ++ unpack rsName ++ ": " ++ show info
|
||||
Just setName | setName /= rsName -> throwError $ userError $ show host' ++ " not a member of replica set " ++ 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 " ++ T.unpack rsName ++ ": " ++ show info
|
||||
Just _ -> return (host', info)
|
||||
|
||||
connection :: ReplicaSet -> Maybe Pipe -> Host -> IOE Pipe
|
||||
|
|
|
@ -25,7 +25,7 @@ import Data.ByteString.Lazy as B (length, hPut)
|
|||
import System.IO.Pipeline (IOE, Pipeline, newPipeline, IOStream(..))
|
||||
import qualified System.IO.Pipeline as P (send, call)
|
||||
import System.IO (Handle, hClose)
|
||||
import Data.Bson (Document, UString)
|
||||
import Data.Bson (Document)
|
||||
import Data.Bson.Binary
|
||||
import Data.Binary.Put
|
||||
import Data.Binary.Get
|
||||
|
@ -33,8 +33,10 @@ import Data.Int
|
|||
import Data.Bits
|
||||
import Data.IORef
|
||||
import System.IO.Unsafe (unsafePerformIO)
|
||||
import Data.Text (Text)
|
||||
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.Monad.Error
|
||||
import System.IO (hFlush)
|
||||
|
@ -95,7 +97,7 @@ readMessage handle = ErrorT $ E.try readResp where
|
|||
runGet getReply <$> hGetN handle len
|
||||
decodeSize = subtract 4 . runGet getInt32
|
||||
|
||||
type FullCollection = UString
|
||||
type FullCollection = Text
|
||||
-- ^ Database name and collection name with period (.) in between. Eg. \"myDb.myCollection\"
|
||||
|
||||
-- ** Header
|
||||
|
@ -319,15 +321,15 @@ rBit AwaitCapable = 3
|
|||
|
||||
-- * Authentication
|
||||
|
||||
type Username = UString
|
||||
type Password = UString
|
||||
type Nonce = UString
|
||||
type Username = Text
|
||||
type Password = Text
|
||||
type Nonce = Text
|
||||
|
||||
pwHash :: Username -> Password -> UString
|
||||
pwHash u p = pack . byteStringHex . MD5.hash . toByteString $ u `U.append` ":mongo:" `U.append` p
|
||||
pwHash :: Username -> Password -> Text
|
||||
pwHash u p = T.pack . byteStringHex . MD5.hash . TE.encodeUtf8 $ u `T.append` ":mongo:" `T.append` p
|
||||
|
||||
pwKey :: Nonce -> Username -> Password -> UString
|
||||
pwKey n u p = pack . byteStringHex . MD5.hash . toByteString . U.append n . U.append u $ pwHash u p
|
||||
pwKey :: Nonce -> Username -> Password -> Text
|
||||
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>
|
||||
|
|
|
@ -8,7 +8,6 @@ module Database.MongoDB.Internal.Util where
|
|||
|
||||
import Control.Applicative (Applicative(..), (<$>))
|
||||
import Network (PortID(..))
|
||||
import Data.UString as U (cons, append)
|
||||
import Data.Bits (Bits, (.|.))
|
||||
import Data.Bson
|
||||
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.Monad.Error
|
||||
import Control.Arrow (left)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.ByteString as BS (ByteString, unpack)
|
||||
import qualified Data.Text as T
|
||||
import Data.Word (Word8)
|
||||
import Numeric (showHex)
|
||||
import System.Random.Shuffle (shuffle')
|
||||
|
@ -96,9 +97,9 @@ bitOr :: (Bits a) => [a] -> a
|
|||
-- ^ bit-or all numbers together
|
||||
bitOr = foldl (.|.) 0
|
||||
|
||||
(<.>) :: UString -> UString -> UString
|
||||
(<.>) :: Text -> Text -> Text
|
||||
-- ^ 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
|
||||
-- ^ 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.
|
||||
|
|
|
@ -39,7 +39,8 @@ module Database.MongoDB.Query (
|
|||
) where
|
||||
|
||||
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 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))
|
||||
|
@ -184,7 +185,7 @@ instance (MonadDB m, Monoid w) => MonadDB (RWST r w s m) where
|
|||
|
||||
-- * Database
|
||||
|
||||
type Database = UString
|
||||
type Database = Text
|
||||
|
||||
allDatabases :: (MonadIO' m) => Action m [Database]
|
||||
-- ^ List all databases residing on server
|
||||
|
@ -208,7 +209,7 @@ auth usr pss = do
|
|||
|
||||
-- * Collection
|
||||
|
||||
type Collection = UString
|
||||
type Collection = Text
|
||||
-- ^ Collection name (not prefixed with database)
|
||||
|
||||
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)]}
|
||||
return . filter (not . isSpecial db) . map dropDbPrefix $ map (at "name") docs
|
||||
where
|
||||
dropDbPrefix = U.tail . U.dropWhile (/= '.')
|
||||
isSpecial db col = U.any (== '$') col && db <.> col /= "local.oplog.$main"
|
||||
dropDbPrefix = T.tail . T.dropWhile (/= '.')
|
||||
isSpecial db col = T.any (== '$') col && db <.> col /= "local.oplog.$main"
|
||||
|
||||
-- * Selection
|
||||
|
||||
|
@ -670,7 +671,7 @@ runCommand :: (MonadIO' m) => Command -> Action m Document
|
|||
runCommand c = maybe err id <$> findOne (query c "$cmd") where
|
||||
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 c = runCommand [c =: (1 :: Int)]
|
||||
|
||||
|
|
|
@ -10,7 +10,8 @@ build-depends:
|
|||
array -any,
|
||||
base <5,
|
||||
binary -any,
|
||||
bson -any,
|
||||
bson-text -any,
|
||||
text,
|
||||
bytestring -any,
|
||||
containers -any,
|
||||
mtl >= 2,
|
||||
|
|
Loading…
Reference in a new issue