diff --git a/Database/MongoDB/Admin.hs b/Database/MongoDB/Admin.hs
index 1a07eab..bf322c8 100644
--- a/Database/MongoDB/Admin.hs
+++ b/Database/MongoDB/Admin.hs
@@ -33,6 +33,7 @@ import Control.Applicative ((<$>))
#endif
import Control.Concurrent (forkIO, threadDelay)
import Control.Monad (forever, unless, liftM)
+import Control.Monad.Fail(MonadFail)
import Data.IORef (IORef, newIORef, readIORef, writeIORef)
import Data.Maybe (maybeToList)
import Data.Set (Set)
@@ -76,7 +77,7 @@ renameCollection from to = do
db <- thisDatabase
useDb admin $ runCommand ["renameCollection" =: db <.> from, "to" =: db <.> to, "dropTarget" =: True]
-dropCollection :: (MonadIO m) => Collection -> Action m Bool
+dropCollection :: (MonadIO m, MonadFail m) => Collection -> Action m Bool
-- ^ Delete the given collection! Return True if collection existed (and was deleted); return False if collection did not exist (and no action).
dropCollection coll = do
resetIndexCache
diff --git a/Database/MongoDB/Connection.hs b/Database/MongoDB/Connection.hs
index 3df0911..fbf5373 100644
--- a/Database/MongoDB/Connection.hs
+++ b/Database/MongoDB/Connection.hs
@@ -24,12 +24,14 @@ module Database.MongoDB.Connection (
import Prelude hiding (lookup)
import Data.IORef (IORef, newIORef, readIORef)
import Data.List (intersect, partition, (\\), delete)
+import Data.Maybe (fromJust)
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative ((<$>))
#endif
import Control.Monad (forM_, guard)
+import Control.Monad.Fail(MonadFail)
import System.IO.Unsafe (unsafePerformIO)
import System.Timeout (timeout)
import Text.ParserCombinators.Parsec (parse, many1, letter, digit, char, anyChar, eof,
@@ -82,7 +84,7 @@ showHostPort (Host hostname (PortNumber port)) = hostname ++ ":" ++ show port
showHostPort (Host _ (UnixSocket path)) = "unix:" ++ path
#endif
-readHostPortM :: (Monad m) => String -> m Host
+readHostPortM :: (MonadFail m) => String -> m Host
-- ^ Read string \"hostname:port\" as @Host hosthame (PortNumber port)@ or \"hostname\" as @host hostname@ (default port). Fail if string does not match either syntax.
-- TODO: handle Service port
readHostPortM = either (fail . show) return . parse parser "readHostPort" where
@@ -104,7 +106,7 @@ readHostPortM = either (fail . show) return . parse parser "readHostPort" where
readHostPort :: String -> Host
-- ^ Read string \"hostname:port\" as @Host hostname (PortNumber port)@ or \"hostname\" as @host hostname@ (default port). Error if string does not match either syntax.
-readHostPort = runIdentity . readHostPortM
+readHostPort = fromJust . readHostPortM
type Secs = Double
diff --git a/Database/MongoDB/GridFS.hs b/Database/MongoDB/GridFS.hs
index aeb6ea2..5515ace 100644
--- a/Database/MongoDB/GridFS.hs
+++ b/Database/MongoDB/GridFS.hs
@@ -26,6 +26,7 @@ module Database.MongoDB.GridFS
import Control.Applicative((<$>))
import Control.Monad(when)
+import Control.Monad.Fail(MonadFail)
import Control.Monad.IO.Class
import Control.Monad.Trans(lift)
@@ -69,7 +70,7 @@ openBucket name = do
data File = File {bucket :: Bucket, document :: Document}
-getChunk :: (Monad m, MonadIO m) => File -> Int -> Action m (Maybe S.ByteString)
+getChunk :: (MonadFail m, MonadIO m) => File -> Int -> Action m (Maybe S.ByteString)
-- ^ Get a chunk of a file
getChunk (File bucket doc) i = do
files_id <- B.look "_id" doc
@@ -98,7 +99,7 @@ fetchFile bucket sel = do
doc <- fetch $ select sel $ files bucket
return $ File bucket doc
-deleteFile :: (MonadIO m) => File -> Action m ()
+deleteFile :: (MonadIO m, MonadFail m) => File -> Action m ()
-- ^ Delete files in the bucket
deleteFile (File bucket doc) = do
files_id <- B.look "_id" doc
@@ -110,7 +111,7 @@ putChunk :: (Monad m, MonadIO m) => Bucket -> ObjectId -> Int -> L.ByteString ->
putChunk bucket files_id i chunk = do
insert_ (chunks bucket) ["files_id" =: files_id, "n" =: i, "data" =: Binary (L.toStrict chunk)]
-sourceFile :: (Monad m, MonadIO m) => File -> Producer (Action m) S.ByteString
+sourceFile :: (MonadFail m, MonadIO m) => File -> Producer (Action m) S.ByteString
-- ^ A producer for the contents of a file
sourceFile file = yieldChunk 0 where
yieldChunk i = do
diff --git a/Database/MongoDB/Query.hs b/Database/MongoDB/Query.hs
index d0bcc86..7b9bf51 100644
--- a/Database/MongoDB/Query.hs
+++ b/Database/MongoDB/Query.hs
@@ -49,6 +49,7 @@ module Database.MongoDB.Query (
import Prelude hiding (lookup)
import Control.Exception (Exception, throwIO)
import Control.Monad (unless, replicateM, liftM, liftM2)
+import Control.Monad.Fail(MonadFail)
import Data.Default.Class (Default(..))
import Data.Int (Int32, Int64)
import Data.Either (lefts, rights)
@@ -1065,7 +1066,7 @@ defFamUpdateOpts ups = FamUpdate
-- Returns a single updated document (new option is set to true).
--
-- see 'findAndModifyOpts' if you want to use findAndModify in a differnt way
-findAndModify :: MonadIO m
+findAndModify :: (MonadIO m, MonadFail m)
=> Query
-> Document -- ^ updates
-> Action m (Either String Document)
@@ -1080,7 +1081,7 @@ findAndModify q ups = do
-- | runs the findAndModify command,
-- allows more options than 'findAndModify'
-findAndModifyOpts :: MonadIO m
+findAndModifyOpts :: (MonadIO m, MonadFail m)
=> Query
->FindAndModifyOpts
-> Action m (Either String (Maybe Document))
@@ -1105,8 +1106,8 @@ findAndModifyOpts (Query {
return $ case lookupErr result of
Just e -> leftErr e
Nothing -> case lookup "value" result of
- Left err -> leftErr $ "no document found: " `mappend` err
- Right mdoc -> case mdoc of
+ Nothing -> leftErr "no document found"
+ Just mdoc -> case mdoc of
Just doc@(_:_) -> Right (Just doc)
Just [] -> case famOpts of
FamUpdate { famUpsert = True, famNew = False } -> Right Nothing
@@ -1118,9 +1119,10 @@ findAndModifyOpts (Query {
`mappend` "\nerror: " `mappend` err
-- return Nothing means ok, Just is the error message
- lookupErr result = case lookup "lastErrorObject" result of
- Right errObject -> lookup "err" errObject
- Left err -> Just err
+ lookupErr :: Document -> Maybe String
+ lookupErr result = do
+ errObject <- lookup "lastErrorObject" result
+ lookup "err" errObject
explain :: (MonadIO m) => Query -> Action m Document
-- ^ Return performance stats of query execution
@@ -1301,7 +1303,7 @@ isCursorClosed (Cursor _ _ var) = do
type Pipeline = [Document]
-- ^ The Aggregate Pipeline
-aggregate :: MonadIO m => Collection -> Pipeline -> Action m [Document]
+aggregate :: (MonadIO m, MonadFail m) => Collection -> Pipeline -> Action m [Document]
-- ^ Runs an aggregate and unpacks the result. See for details.
aggregate aColl agg = do
aggregateCursor aColl agg def >>= rest
@@ -1312,7 +1314,7 @@ data AggregateConfig = AggregateConfig {}
instance Default AggregateConfig where
def = AggregateConfig {}
-aggregateCursor :: MonadIO m => Collection -> Pipeline -> AggregateConfig -> Action m Cursor
+aggregateCursor :: (MonadIO m, MonadFail m) => Collection -> Pipeline -> AggregateConfig -> Action m Cursor
-- ^ Runs an aggregate and unpacks the result. See for details.
aggregateCursor aColl agg _ = do
response <- runCommand ["aggregate" =: aColl, "pipeline" =: agg, "cursor" =: ([] :: Document)]
diff --git a/mongoDB.cabal b/mongoDB.cabal
index 6160aeb..a301f66 100644
--- a/mongoDB.cabal
+++ b/mongoDB.cabal
@@ -57,6 +57,7 @@ Library
, base16-bytestring >= 0.1.1.6
, base64-bytestring >= 1.0.0.1
, nonce >= 1.0.5
+ , fail
if flag(_old-network)
-- "Network.BSD" is only available in network < 2.9