Use MonadFail instead of Monad
This commit is contained in:
parent
76d5f84f8a
commit
917fa0eb57
5 changed files with 22 additions and 15 deletions
|
@ -33,6 +33,7 @@ import Control.Applicative ((<$>))
|
||||||
#endif
|
#endif
|
||||||
import Control.Concurrent (forkIO, threadDelay)
|
import Control.Concurrent (forkIO, threadDelay)
|
||||||
import Control.Monad (forever, unless, liftM)
|
import Control.Monad (forever, unless, liftM)
|
||||||
|
import Control.Monad.Fail(MonadFail)
|
||||||
import Data.IORef (IORef, newIORef, readIORef, writeIORef)
|
import Data.IORef (IORef, newIORef, readIORef, writeIORef)
|
||||||
import Data.Maybe (maybeToList)
|
import Data.Maybe (maybeToList)
|
||||||
import Data.Set (Set)
|
import Data.Set (Set)
|
||||||
|
@ -76,7 +77,7 @@ renameCollection from to = do
|
||||||
db <- thisDatabase
|
db <- thisDatabase
|
||||||
useDb admin $ runCommand ["renameCollection" =: db <.> from, "to" =: db <.> to, "dropTarget" =: True]
|
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).
|
-- ^ 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
|
dropCollection coll = do
|
||||||
resetIndexCache
|
resetIndexCache
|
||||||
|
|
|
@ -24,12 +24,14 @@ module Database.MongoDB.Connection (
|
||||||
import Prelude hiding (lookup)
|
import Prelude hiding (lookup)
|
||||||
import Data.IORef (IORef, newIORef, readIORef)
|
import Data.IORef (IORef, newIORef, readIORef)
|
||||||
import Data.List (intersect, partition, (\\), delete)
|
import Data.List (intersect, partition, (\\), delete)
|
||||||
|
import Data.Maybe (fromJust)
|
||||||
|
|
||||||
#if !MIN_VERSION_base(4,8,0)
|
#if !MIN_VERSION_base(4,8,0)
|
||||||
import Control.Applicative ((<$>))
|
import Control.Applicative ((<$>))
|
||||||
#endif
|
#endif
|
||||||
|
|
||||||
import Control.Monad (forM_)
|
import Control.Monad (forM_)
|
||||||
|
import Control.Monad.Fail(MonadFail)
|
||||||
import System.IO.Unsafe (unsafePerformIO)
|
import System.IO.Unsafe (unsafePerformIO)
|
||||||
import System.Timeout (timeout)
|
import System.Timeout (timeout)
|
||||||
import Text.ParserCombinators.Parsec (parse, many1, letter, digit, char, eof,
|
import Text.ParserCombinators.Parsec (parse, many1, letter, digit, char, eof,
|
||||||
|
@ -81,7 +83,7 @@ showHostPort (Host hostname port) = hostname ++ ":" ++ portname where
|
||||||
portname = case port of
|
portname = case port of
|
||||||
PortNumber p -> show p
|
PortNumber p -> show p
|
||||||
|
|
||||||
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.
|
-- ^ 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 and UnixSocket port
|
-- TODO: handle Service and UnixSocket port
|
||||||
readHostPortM = either (fail . show) return . parse parser "readHostPort" where
|
readHostPortM = either (fail . show) return . parse parser "readHostPort" where
|
||||||
|
@ -97,7 +99,7 @@ readHostPortM = either (fail . show) return . parse parser "readHostPort" where
|
||||||
|
|
||||||
readHostPort :: String -> Host
|
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.
|
-- ^ 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
|
type Secs = Double
|
||||||
|
|
||||||
|
|
|
@ -26,6 +26,7 @@ module Database.MongoDB.GridFS
|
||||||
import Control.Applicative((<$>))
|
import Control.Applicative((<$>))
|
||||||
|
|
||||||
import Control.Monad(when)
|
import Control.Monad(when)
|
||||||
|
import Control.Monad.Fail(MonadFail)
|
||||||
import Control.Monad.IO.Class
|
import Control.Monad.IO.Class
|
||||||
import Control.Monad.Trans(lift)
|
import Control.Monad.Trans(lift)
|
||||||
|
|
||||||
|
@ -69,7 +70,7 @@ openBucket name = do
|
||||||
|
|
||||||
data File = File {bucket :: Bucket, document :: Document}
|
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
|
-- ^ Get a chunk of a file
|
||||||
getChunk (File bucket doc) i = do
|
getChunk (File bucket doc) i = do
|
||||||
files_id <- B.look "_id" doc
|
files_id <- B.look "_id" doc
|
||||||
|
@ -98,7 +99,7 @@ fetchFile bucket sel = do
|
||||||
doc <- fetch $ select sel $ files bucket
|
doc <- fetch $ select sel $ files bucket
|
||||||
return $ File bucket doc
|
return $ File bucket doc
|
||||||
|
|
||||||
deleteFile :: (MonadIO m) => File -> Action m ()
|
deleteFile :: (MonadIO m, MonadFail m) => File -> Action m ()
|
||||||
-- ^ Delete files in the bucket
|
-- ^ Delete files in the bucket
|
||||||
deleteFile (File bucket doc) = do
|
deleteFile (File bucket doc) = do
|
||||||
files_id <- B.look "_id" doc
|
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
|
putChunk bucket files_id i chunk = do
|
||||||
insert_ (chunks bucket) ["files_id" =: files_id, "n" =: i, "data" =: Binary (L.toStrict chunk)]
|
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
|
-- ^ A producer for the contents of a file
|
||||||
sourceFile file = yieldChunk 0 where
|
sourceFile file = yieldChunk 0 where
|
||||||
yieldChunk i = do
|
yieldChunk i = do
|
||||||
|
|
|
@ -49,6 +49,7 @@ module Database.MongoDB.Query (
|
||||||
import Prelude hiding (lookup)
|
import Prelude hiding (lookup)
|
||||||
import Control.Exception (Exception, throwIO)
|
import Control.Exception (Exception, throwIO)
|
||||||
import Control.Monad (unless, replicateM, liftM, liftM2)
|
import Control.Monad (unless, replicateM, liftM, liftM2)
|
||||||
|
import Control.Monad.Fail(MonadFail)
|
||||||
import Data.Default.Class (Default(..))
|
import Data.Default.Class (Default(..))
|
||||||
import Data.Int (Int32, Int64)
|
import Data.Int (Int32, Int64)
|
||||||
import Data.Either (lefts, rights)
|
import Data.Either (lefts, rights)
|
||||||
|
@ -1065,7 +1066,7 @@ defFamUpdateOpts ups = FamUpdate
|
||||||
-- Returns a single updated document (new option is set to true).
|
-- Returns a single updated document (new option is set to true).
|
||||||
--
|
--
|
||||||
-- see 'findAndModifyOpts' if you want to use findAndModify in a differnt way
|
-- see 'findAndModifyOpts' if you want to use findAndModify in a differnt way
|
||||||
findAndModify :: MonadIO m
|
findAndModify :: (MonadIO m, MonadFail m)
|
||||||
=> Query
|
=> Query
|
||||||
-> Document -- ^ updates
|
-> Document -- ^ updates
|
||||||
-> Action m (Either String Document)
|
-> Action m (Either String Document)
|
||||||
|
@ -1080,7 +1081,7 @@ findAndModify q ups = do
|
||||||
|
|
||||||
-- | runs the findAndModify command,
|
-- | runs the findAndModify command,
|
||||||
-- allows more options than 'findAndModify'
|
-- allows more options than 'findAndModify'
|
||||||
findAndModifyOpts :: MonadIO m
|
findAndModifyOpts :: (MonadIO m, MonadFail m)
|
||||||
=> Query
|
=> Query
|
||||||
->FindAndModifyOpts
|
->FindAndModifyOpts
|
||||||
-> Action m (Either String (Maybe Document))
|
-> Action m (Either String (Maybe Document))
|
||||||
|
@ -1105,8 +1106,8 @@ findAndModifyOpts (Query {
|
||||||
return $ case lookupErr result of
|
return $ case lookupErr result of
|
||||||
Just e -> leftErr e
|
Just e -> leftErr e
|
||||||
Nothing -> case lookup "value" result of
|
Nothing -> case lookup "value" result of
|
||||||
Left err -> leftErr $ "no document found: " `mappend` err
|
Nothing -> leftErr "no document found"
|
||||||
Right mdoc -> case mdoc of
|
Just mdoc -> case mdoc of
|
||||||
Just doc@(_:_) -> Right (Just doc)
|
Just doc@(_:_) -> Right (Just doc)
|
||||||
Just [] -> case famOpts of
|
Just [] -> case famOpts of
|
||||||
FamUpdate { famUpsert = True, famNew = False } -> Right Nothing
|
FamUpdate { famUpsert = True, famNew = False } -> Right Nothing
|
||||||
|
@ -1118,9 +1119,10 @@ findAndModifyOpts (Query {
|
||||||
`mappend` "\nerror: " `mappend` err
|
`mappend` "\nerror: " `mappend` err
|
||||||
|
|
||||||
-- return Nothing means ok, Just is the error message
|
-- return Nothing means ok, Just is the error message
|
||||||
lookupErr result = case lookup "lastErrorObject" result of
|
lookupErr :: Document -> Maybe String
|
||||||
Right errObject -> lookup "err" errObject
|
lookupErr result = do
|
||||||
Left err -> Just err
|
errObject <- lookup "lastErrorObject" result
|
||||||
|
lookup "err" errObject
|
||||||
|
|
||||||
explain :: (MonadIO m) => Query -> Action m Document
|
explain :: (MonadIO m) => Query -> Action m Document
|
||||||
-- ^ Return performance stats of query execution
|
-- ^ Return performance stats of query execution
|
||||||
|
@ -1301,7 +1303,7 @@ isCursorClosed (Cursor _ _ var) = do
|
||||||
type Pipeline = [Document]
|
type Pipeline = [Document]
|
||||||
-- ^ The Aggregate Pipeline
|
-- ^ 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 <http://docs.mongodb.org/manual/core/aggregation/> for details.
|
-- ^ Runs an aggregate and unpacks the result. See <http://docs.mongodb.org/manual/core/aggregation/> for details.
|
||||||
aggregate aColl agg = do
|
aggregate aColl agg = do
|
||||||
aggregateCursor aColl agg def >>= rest
|
aggregateCursor aColl agg def >>= rest
|
||||||
|
@ -1312,7 +1314,7 @@ data AggregateConfig = AggregateConfig {}
|
||||||
instance Default AggregateConfig where
|
instance Default AggregateConfig where
|
||||||
def = AggregateConfig {}
|
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 <http://docs.mongodb.org/manual/core/aggregation/> for details.
|
-- ^ Runs an aggregate and unpacks the result. See <http://docs.mongodb.org/manual/core/aggregation/> for details.
|
||||||
aggregateCursor aColl agg _ = do
|
aggregateCursor aColl agg _ = do
|
||||||
response <- runCommand ["aggregate" =: aColl, "pipeline" =: agg, "cursor" =: ([] :: Document)]
|
response <- runCommand ["aggregate" =: aColl, "pipeline" =: agg, "cursor" =: ([] :: Document)]
|
||||||
|
|
|
@ -57,6 +57,7 @@ Library
|
||||||
, base16-bytestring >= 0.1.1.6
|
, base16-bytestring >= 0.1.1.6
|
||||||
, base64-bytestring >= 1.0.0.1
|
, base64-bytestring >= 1.0.0.1
|
||||||
, nonce >= 1.0.5
|
, nonce >= 1.0.5
|
||||||
|
, fail
|
||||||
|
|
||||||
if flag(_old-network)
|
if flag(_old-network)
|
||||||
-- "Network.BSD" is only available in network < 2.9
|
-- "Network.BSD" is only available in network < 2.9
|
||||||
|
|
Loading…
Reference in a new issue