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

Lift MonadBaseControl restriction

Browse source 
Merge pull request #76 from VictorDenisov/remove_monad_base_control
This commit is contained in:
Victor Denisov 2017-05-13 23:27:16 -07:00 committed by GitHub
commit a0416aefba
5 changed files with 53 additions and 45 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

1
CHANGELOG.md
View file

@ -6,6 +6,7 @@ This project adheres to [Package Versioning Policy](https://wiki.haskell.org/Pac
### Changed ### Changed
- Description of access function - Description of access function
- Lift MonadBaseControl restriction
## [2.2.0] - 2017-04-08 ## [2.2.0] - 2017-04-08

9
Database/MongoDB/Admin.hs
View file

@ -42,7 +42,6 @@ import qualified Data.HashTable.IO as H
import qualified Data.Set as Set import qualified Data.Set as Set
import Control.Monad.Trans (MonadIO, liftIO) import Control.Monad.Trans (MonadIO, liftIO)
import Control.Monad.Trans.Control (MonadBaseControl)
import Data.Bson (Document, Field(..), at, (=:), (=?), exclude, merge) import Data.Bson (Document, Field(..), at, (=:), (=?), exclude, merge)
import Data.Text (Text) import Data.Text (Text)
@ -138,7 +137,7 @@ dropIndex coll idxName = do
resetIndexCache resetIndexCache
runCommand ["deleteIndexes" =: coll, "index" =: idxName] runCommand ["deleteIndexes" =: coll, "index" =: idxName]
getIndexes :: (MonadIO m, MonadBaseControl IO m, Functor m) => Collection -> Action m [Document] getIndexes :: MonadIO m => Collection -> Action m [Document]
-- ^ Get all indexes on this collection -- ^ Get all indexes on this collection
getIndexes coll = do getIndexes coll = do
db <- thisDatabase db <- thisDatabase
@ -191,9 +190,9 @@ resetIndexCache = do
-- ** User -- ** User
allUsers :: (MonadIO m, MonadBaseControl IO m, Functor m) => Action m [Document] allUsers :: MonadIO m => Action m [Document]
-- ^ Fetch all users of this database -- ^ Fetch all users of this database
allUsers = map (exclude ["_id"]) <$> (rest =<< find allUsers = map (exclude ["_id"]) `liftM` (rest =<< find
(select [] "system.users") {sort = ["user" =: (1 :: Int)], project = ["user" =: (1 :: Int), "readOnly" =: (1 :: Int)]}) (select [] "system.users") {sort = ["user" =: (1 :: Int)], project = ["user" =: (1 :: Int), "readOnly" =: (1 :: Int)]})
addUser :: (MonadIO m) addUser :: (MonadIO m)
@ -260,7 +259,7 @@ storageSize c = at "storageSize" `liftM` collectionStats c
totalIndexSize :: (MonadIO m) => Collection -> Action m Int totalIndexSize :: (MonadIO m) => Collection -> Action m Int
totalIndexSize c = at "totalIndexSize" `liftM` collectionStats c totalIndexSize c = at "totalIndexSize" `liftM` collectionStats c
totalSize :: (MonadIO m, MonadBaseControl IO m) => Collection -> Action m Int totalSize :: MonadIO m => Collection -> Action m Int
totalSize coll = do totalSize coll = do
x <- storageSize coll x <- storageSize coll
xs <- mapM isize =<< getIndexes coll xs <- mapM isize =<< getIndexes coll

3
Database/MongoDB/GridFS.hs
View file

@ -28,7 +28,6 @@ import Control.Concurrent(forkIO)
import Control.Monad(when) import Control.Monad(when)
import Control.Monad.IO.Class import Control.Monad.IO.Class
import Control.Monad.Trans(MonadTrans, lift) import Control.Monad.Trans(MonadTrans, lift)
import Control.Monad.Trans.Control(MonadBaseControl)
import Control.Monad.Trans.Resource(MonadResource(..)) import Control.Monad.Trans.Resource(MonadResource(..))
import Data.Conduit import Data.Conduit
import Data.Digest.Pure.MD5 import Data.Digest.Pure.MD5
@ -76,7 +75,7 @@ getChunk (File bucket doc) i = do
Just (Binary b) -> return (Just b) Just (Binary b) -> return (Just b)
_ -> return Nothing _ -> return Nothing
findFile :: (MonadIO m, MonadBaseControl IO m) => Bucket -> Selector -> Action m [File] findFile :: MonadIO m => Bucket -> Selector -> Action m [File]
-- ^ Find files in the bucket -- ^ Find files in the bucket
findFile bucket sel = do findFile bucket sel = do
cursor <- find $ select sel $ files bucket cursor <- find $ select sel $ files bucket

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

@ -65,9 +65,9 @@ shuffle :: [a] -> IO [a]
-- ^ Randomly shuffle items in list -- ^ Randomly shuffle items in list
shuffle list = shuffle' list (length list) <$> newStdGen shuffle list = shuffle' list (length list) <$> newStdGen
loop :: (Functor m, Monad m) => m (Maybe a) -> m [a] loop :: Monad m => m (Maybe a) -> m [a]
-- ^ Repeatedy execute action, collecting results, until it returns Nothing -- ^ Repeatedy execute action, collecting results, until it returns Nothing
loop act = act >>= maybe (return []) (\a -> (a :) <$> loop act) loop act = act >>= maybe (return []) (\a -> (a :) `liftM` loop act)
untilSuccess :: (MonadError e m, Error e) => (a -> m b) -> [a] -> m b untilSuccess :: (MonadError e m, Error e) => (a -> m b) -> [a] -> m b
-- ^ Apply action to elements one at a time until one succeeds. Throw last error if all fail. Throw 'strMsg' error if list is empty. -- ^ Apply action to elements one at a time until one succeeds. Throw last error if all fail. Throw 'strMsg' error if list is empty.

81
Database/MongoDB/Query.hs
View file

@ -56,22 +56,22 @@ import Data.Word (Word32)
import Data.Monoid (mappend) import Data.Monoid (mappend)
#endif #endif
import Data.Typeable (Typeable) import Data.Typeable (Typeable)
import System.Mem.Weak (Weak)
import qualified Control.Concurrent.MVar as MV
#if MIN_VERSION_base(4,6,0) #if MIN_VERSION_base(4,6,0)
import Control.Concurrent.MVar.Lifted (MVar, newMVar, mkWeakMVar, import Control.Concurrent.MVar.Lifted (MVar,
readMVar, modifyMVar) readMVar)
#else #else
import Control.Concurrent.MVar.Lifted (MVar, newMVar, addMVarFinalizer, import Control.Concurrent.MVar.Lifted (MVar, addMVarFinalizer,
readMVar, modifyMVar) readMVar)
#endif #endif
import Control.Applicative ((<$>)) import Control.Applicative ((<$>))
import Control.Exception (SomeException, catch) import Control.Exception (SomeException, catch)
import Control.Monad (when) import Control.Monad (when)
import Control.Monad.Base (MonadBase)
import Control.Monad.Error (Error(..)) import Control.Monad.Error (Error(..))
import Control.Monad.Reader (MonadReader, ReaderT, runReaderT, ask, asks, local) import Control.Monad.Reader (MonadReader, ReaderT, runReaderT, ask, asks, local)
import Control.Monad.Trans (MonadIO, liftIO) import Control.Monad.Trans (MonadIO, liftIO)
import Control.Monad.Trans.Control (MonadBaseControl(..))
import Data.Binary.Put (runPut) import Data.Binary.Put (runPut)
import Data.Bson (Document, Field(..), Label, Val, Value(String, Doc, Bool), import Data.Bson (Document, Field(..), Label, Val, Value(String, Doc, Bool),
Javascript, at, valueAt, lookup, look, genObjectId, (=:), Javascript, at, valueAt, lookup, look, genObjectId, (=:),
@ -106,10 +106,6 @@ import qualified Data.Map as Map
import Text.Read (readMaybe) import Text.Read (readMaybe)
import Data.Maybe (fromMaybe) import Data.Maybe (fromMaybe)
#if !MIN_VERSION_base(4,6,0)
--mkWeakMVar = addMVarFinalizer
#endif
-- * Monad -- * Monad
type Action = ReaderT MongoContext type Action = ReaderT MongoContext
@ -314,7 +310,7 @@ retrieveServerData = do
type Collection = Text type Collection = Text
-- ^ Collection name (not prefixed with database) -- ^ Collection name (not prefixed with database)
allCollections :: (MonadIO m, MonadBaseControl IO m) => Action m [Collection] allCollections :: MonadIO m => Action m [Collection]
-- ^ List all collections in this database -- ^ List all collections in this database
allCollections = do allCollections = do
p <- asks mongoPipe p <- asks mongoPipe
@ -825,7 +821,7 @@ query :: Selector -> Collection -> Query
-- ^ Selects documents in collection that match selector. It uses no query options, projects all fields, does not skip any documents, does not limit result size, uses default batch size, does not sort, does not hint, and does not snapshot. -- ^ Selects documents in collection that match selector. It uses no query options, projects all fields, does not skip any documents, does not limit result size, uses default batch size, does not sort, does not hint, and does not snapshot.
query sel col = Query [] (Select sel col) [] 0 0 [] False 0 [] query sel col = Query [] (Select sel col) [] 0 0 [] False 0 []
find :: (MonadIO m, MonadBaseControl IO m) => Query -> Action m Cursor find :: MonadIO m => Query -> Action m Cursor
-- ^ Fetch documents satisfying query -- ^ Fetch documents satisfying query
find q@Query{selection, batchSize} = do find q@Query{selection, batchSize} = do
db <- thisDatabase db <- thisDatabase
@ -840,7 +836,7 @@ findOne q = do
pipe <- asks mongoPipe pipe <- asks mongoPipe
qr <- queryRequest False q {limit = 1} qr <- queryRequest False q {limit = 1}
rq <- liftIO $ request pipe [] qr rq <- liftIO $ request pipe [] qr
Batch _ _ docs <- fulfill rq Batch _ _ docs <- liftDB $ fulfill rq
return (listToMaybe docs) return (listToMaybe docs)
fetch :: (MonadIO m) => Query -> Action m Document fetch :: (MonadIO m) => Query -> Action m Document
@ -929,7 +925,7 @@ explain q = do -- same as findOne but with explain set to true
pipe <- asks mongoPipe pipe <- asks mongoPipe
qr <- queryRequest True q {limit = 1} qr <- queryRequest True q {limit = 1}
r <- liftIO $ request pipe [] qr r <- liftIO $ request pipe [] qr
Batch _ _ docs <- fulfill r Batch _ _ docs <- liftDB $ fulfill r
return $ if null docs then error ("no explain: " ++ show q) else head docs return $ if null docs then error ("no explain: " ++ show q) else head docs
count :: (MonadIO m) => Query -> Action m Int count :: (MonadIO m) => Query -> Action m Int
@ -998,7 +994,7 @@ fromReply limit Reply{..} = do
CursorNotFound -> throwIO $ CursorNotFoundFailure rCursorId CursorNotFound -> throwIO $ CursorNotFoundFailure rCursorId
QueryError -> throwIO $ QueryFailure (at "code" $ head rDocuments) (at "$err" $ head rDocuments) QueryError -> throwIO $ QueryFailure (at "code" $ head rDocuments) (at "$err" $ head rDocuments)
fulfill :: (MonadIO m) => DelayedBatch -> Action m Batch fulfill :: DelayedBatch -> Action IO Batch
-- ^ Demand and wait for result, raise failure if exception -- ^ Demand and wait for result, raise failure if exception
fulfill = liftIO fulfill = liftIO
@ -1007,22 +1003,19 @@ fulfill = liftIO
data Cursor = Cursor FullCollection BatchSize (MVar DelayedBatch) data Cursor = Cursor FullCollection BatchSize (MVar DelayedBatch)
-- ^ Iterator over results of a query. Use 'next' to iterate or 'rest' to get all results. A cursor is closed when it is explicitly closed, all results have been read from it, garbage collected, or not used for over 10 minutes (unless 'NoCursorTimeout' option was specified in 'Query'). Reading from a closed cursor raises a 'CursorNotFoundFailure'. Note, a cursor is not closed when the pipe is closed, so you can open another pipe to the same server and continue using the cursor. -- ^ Iterator over results of a query. Use 'next' to iterate or 'rest' to get all results. A cursor is closed when it is explicitly closed, all results have been read from it, garbage collected, or not used for over 10 minutes (unless 'NoCursorTimeout' option was specified in 'Query'). Reading from a closed cursor raises a 'CursorNotFoundFailure'. Note, a cursor is not closed when the pipe is closed, so you can open another pipe to the same server and continue using the cursor.
newCursor :: (MonadIO m, MonadBaseControl IO m) => Database -> Collection -> BatchSize -> DelayedBatch -> Action m Cursor newCursor :: MonadIO m => Database -> Collection -> BatchSize -> DelayedBatch -> Action m Cursor
-- ^ Create new cursor. If you don't read all results then close it. Cursor will be closed automatically when all results are read from it or when eventually garbage collected. -- ^ Create new cursor. If you don't read all results then close it. Cursor will be closed automatically when all results are read from it or when eventually garbage collected.
newCursor db col batchSize dBatch = do newCursor db col batchSize dBatch = do
var <- newMVar dBatch var <- liftIO $ MV.newMVar dBatch
let cursor = Cursor (db <.> col) batchSize var let cursor = Cursor (db <.> col) batchSize var
_ <- mkWeakMVar var (closeCursor cursor) _ <- liftDB $ mkWeakMVar var (closeCursor cursor)
return cursor return cursor
#if !MIN_VERSION_base(4,6,0)
where mkWeakMVar = addMVarFinalizer
#endif
nextBatch :: (MonadIO m, MonadBaseControl IO m) => Cursor -> Action m [Document] nextBatch :: MonadIO m => Cursor -> Action m [Document]
-- ^ Return next batch of documents in query result, which will be empty if finished. -- ^ Return next batch of documents in query result, which will be empty if finished.
nextBatch (Cursor fcol batchSize var) = modifyMVar var $ \dBatch -> do nextBatch (Cursor fcol batchSize var) = liftDB $ modifyMVar var $ \dBatch -> do
-- Pre-fetch next batch promise from server and return current batch. -- Pre-fetch next batch promise from server and return current batch.
Batch mLimit cid docs <- fulfill' fcol batchSize dBatch Batch mLimit cid docs <- liftDB $ fulfill' fcol batchSize dBatch
let newLimit = do let newLimit = do
limit <- mLimit limit <- mLimit
return $ limit - (min limit $ fromIntegral $ length docs) return $ limit - (min limit $ fromIntegral $ length docs)
@ -1037,7 +1030,7 @@ nextBatch (Cursor fcol batchSize var) = modifyMVar var $ \dBatch -> do
return (emptyBatch, resultDocs) return (emptyBatch, resultDocs)
(_, _) -> (, resultDocs) <$> getNextBatch (_, _) -> (, resultDocs) <$> getNextBatch
fulfill' :: (MonadIO m) => FullCollection -> BatchSize -> DelayedBatch -> Action m Batch fulfill' :: FullCollection -> BatchSize -> DelayedBatch -> Action IO Batch
-- Discard pre-fetched batch if empty with nonzero cid. -- Discard pre-fetched batch if empty with nonzero cid.
fulfill' fcol batchSize dBatch = do fulfill' fcol batchSize dBatch = do
b@(Batch limit cid docs) <- fulfill dBatch b@(Batch limit cid docs) <- fulfill dBatch
@ -1051,13 +1044,13 @@ nextBatch' fcol batchSize limit cid = do
liftIO $ request pipe [] (GetMore fcol batchSize' cid, remLimit) liftIO $ request pipe [] (GetMore fcol batchSize' cid, remLimit)
where (batchSize', remLimit) = batchSizeRemainingLimit batchSize limit where (batchSize', remLimit) = batchSizeRemainingLimit batchSize limit
next :: (MonadIO m, MonadBaseControl IO m) => Cursor -> Action m (Maybe Document) next :: MonadIO m => Cursor -> Action m (Maybe Document)
-- ^ Return next document in query result, or Nothing if finished. -- ^ Return next document in query result, or Nothing if finished.
next (Cursor fcol batchSize var) = modifyMVar var nextState where next (Cursor fcol batchSize var) = liftDB $ modifyMVar var nextState where
-- Pre-fetch next batch promise from server when last one in current batch is returned. -- Pre-fetch next batch promise from server when last one in current batch is returned.
-- nextState:: DelayedBatch -> Action m (DelayedBatch, Maybe Document) -- nextState:: DelayedBatch -> Action m (DelayedBatch, Maybe Document)
nextState dBatch = do nextState dBatch = do
Batch mLimit cid docs <- fulfill' fcol batchSize dBatch Batch mLimit cid docs <- liftDB $ fulfill' fcol batchSize dBatch
if mLimit == (Just 0) if mLimit == (Just 0)
then return (return $ Batch (Just 0) 0 [], Nothing) then return (return $ Batch (Just 0) 0 [], Nothing)
else else
@ -1075,27 +1068,29 @@ next (Cursor fcol batchSize var) = modifyMVar var nextState where
return (dBatch', Just doc) return (dBatch', Just doc)
[] -> if cid == 0 [] -> if cid == 0
then return (return $ Batch (Just 0) 0 [], Nothing) -- finished then return (return $ Batch (Just 0) 0 [], Nothing) -- finished
else fmap (,Nothing) $ nextBatch' fcol batchSize mLimit cid else do
nb <- nextBatch' fcol batchSize mLimit cid
return (nb, Nothing)
nextN :: (MonadIO m, MonadBaseControl IO m) => Int -> Cursor -> Action m [Document] nextN :: MonadIO m => Int -> Cursor -> Action m [Document]
-- ^ Return next N documents or less if end is reached -- ^ Return next N documents or less if end is reached
nextN n c = catMaybes `liftM` replicateM n (next c) nextN n c = catMaybes `liftM` replicateM n (next c)
rest :: (MonadIO m, MonadBaseControl IO m) => Cursor -> Action m [Document] rest :: MonadIO m => Cursor -> Action m [Document]
-- ^ Return remaining documents in query result -- ^ Return remaining documents in query result
rest c = loop (next c) rest c = loop (next c)
closeCursor :: (MonadIO m, MonadBaseControl IO m) => Cursor -> Action m () closeCursor :: MonadIO m => Cursor -> Action m ()
closeCursor (Cursor _ _ var) = modifyMVar var $ \dBatch -> do closeCursor (Cursor _ _ var) = liftDB $ modifyMVar var $ \dBatch -> do
Batch _ cid _ <- fulfill dBatch Batch _ cid _ <- fulfill dBatch
unless (cid == 0) $ do unless (cid == 0) $ do
pipe <- asks mongoPipe pipe <- asks mongoPipe
liftIOE ConnectionFailure $ P.send pipe [KillCursors [cid]] liftIOE ConnectionFailure $ P.send pipe [KillCursors [cid]]
return $ (return $ Batch (Just 0) 0 [], ()) return $ (return $ Batch (Just 0) 0 [], ())
isCursorClosed :: (MonadIO m, MonadBase IO m) => Cursor -> Action m Bool isCursorClosed :: MonadIO m => Cursor -> Action m Bool
isCursorClosed (Cursor _ _ var) = do isCursorClosed (Cursor _ _ var) = do
Batch _ cid docs <- fulfill =<< readMVar var Batch _ cid docs <- liftDB $ fulfill =<< readMVar var
return (cid == 0 && null docs) return (cid == 0 && null docs)
-- ** Aggregate -- ** Aggregate
@ -1208,7 +1203,7 @@ mapReduce :: Collection -> MapFun -> ReduceFun -> MapReduce
-- ^ MapReduce on collection with given map and reduce functions. Remaining attributes are set to their defaults, which are stated in their comments. -- ^ MapReduce on collection with given map and reduce functions. Remaining attributes are set to their defaults, which are stated in their comments.
mapReduce col map' red = MapReduce col map' red [] [] 0 Inline Nothing [] False mapReduce col map' red = MapReduce col map' red [] [] 0 Inline Nothing [] False
runMR :: (MonadIO m, MonadBaseControl IO m) => MapReduce -> Action m Cursor runMR :: MonadIO m => MapReduce -> Action m Cursor
-- ^ Run MapReduce and return cursor of results. Error if map/reduce fails (because of bad Javascript) -- ^ Run MapReduce and return cursor of results. Error if map/reduce fails (because of bad Javascript)
runMR mr = do runMR mr = do
res <- runMR' mr res <- runMR' mr
@ -1242,6 +1237,20 @@ eval :: (MonadIO m, Val v) => Javascript -> Action m v
-- ^ Run code on server -- ^ Run code on server
eval code = at "retval" `liftM` runCommand ["$eval" =: code] eval code = at "retval" `liftM` runCommand ["$eval" =: code]
modifyMVar :: MVar a -> (a -> Action IO (a, b)) -> Action IO b
modifyMVar v f = do
ctx <- ask
liftIO $ MV.modifyMVar v (\x -> runReaderT (f x) ctx)
mkWeakMVar :: MVar a -> Action IO () -> Action IO (Weak (MVar a))
mkWeakMVar m closing = do
ctx <- ask
#if MIN_VERSION_base(4,6,0)
liftIO $ MV.mkWeakMVar m $ runReaderT closing ctx
#else
liftIO $ MV.addMVarFinalizer m $ runReaderT closing ctx
#endif
{- Authors: Tony Hannan <tony@10gen.com> {- Authors: Tony Hannan <tony@10gen.com>
Copyright 2011 10gen Inc. Copyright 2011 10gen Inc.