From 917fa0eb577cee0a5c6e23878376ed225f7e5bcd Mon Sep 17 00:00:00 2001 From: Taylor Fausak Date: Fri, 4 Oct 2019 12:10:24 -0400 Subject: [PATCH] Use MonadFail instead of Monad --- Database/MongoDB/Admin.hs | 3 ++- Database/MongoDB/Connection.hs | 6 ++++-- Database/MongoDB/GridFS.hs | 7 ++++--- Database/MongoDB/Query.hs | 20 +++++++++++--------- mongoDB.cabal | 1 + 5 files changed, 22 insertions(+), 15 deletions(-) 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 5a5e110..4a8f91f 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_) +import Control.Monad.Fail(MonadFail) import System.IO.Unsafe (unsafePerformIO) import System.Timeout (timeout) 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 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. -- TODO: handle Service and UnixSocket port 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 -- ^ 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