Skip to content
Browse files

use exceptions instead of error

  • Loading branch information...
1 parent 5f47b1d commit df6bd17911dc3343996b4faf418870b0b928c3b1 @gregwebs gregwebs committed Aug 16, 2011
View
24 persistent-mongoDB/Database/Persist/MongoDB.hs
@@ -1,5 +1,4 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeSynonymInstances #-}
@@ -23,9 +22,11 @@ module Database.Persist.MongoDB
import Database.Persist
import Database.Persist.Base
+
import qualified Control.Monad.IO.Class as Trans
+
import qualified Database.MongoDB as DB
-import Database.MongoDB.Query (Database, Failure)
+import Database.MongoDB.Query (Database)
import Control.Applicative (Applicative)
import Control.Exception (toException)
import Data.UString (u)
@@ -36,8 +37,7 @@ import Data.Maybe (mapMaybe, fromJust)
import qualified Data.Text as T
import qualified Data.Text.Encoding as E
import qualified Data.Serialize as S
-import Control.Exception (Exception, throwIO)
-import Data.Typeable (Typeable)
+import Control.Exception.Control (throwIO)
import Control.Monad.MVar (MonadMVar (..))
import Prelude hiding (catch)
import qualified System.IO.Pool as Pool
@@ -63,17 +63,11 @@ withMongoDBPool dbname hostname connectionPoolSize connectionReader = do
connectionPoolSize
connectionReader (pool, dbname)
---runMongoDBConn :: (Trans.MonadIO m) => DB.AccessMode -> DB.Database -> DB.Action m b -> ConnectionPool -> m b
runMongoDBConn :: (Trans.MonadIO m) => DB.AccessMode -> DB.Action m b -> ConnectionPool -> m b
runMongoDBConn accessMode action (pool, databaseName) = do
pipe <- Trans.liftIO $ DB.runIOE $ Pool.aResource pool
res <- DB.access pipe accessMode databaseName action
- either (Trans.liftIO . throwIO . MongoDBException) return res
-
-
-newtype MongoDBException = MongoDBException Failure
- deriving (Show, Typeable)
-instance Exception MongoDBException
+ either (throwIO . PersistMongoDBError . show) return res
value :: DB.Field -> DB.Value
value (_ DB.:= val) = val
@@ -199,7 +193,7 @@ instance (Trans.MonadIO m, Applicative m, Functor m, MonadMVar m) => PersistBack
case mdocument of
Nothing -> return Nothing
Just document -> case pairFromDocument t document of
- Left s -> error s
+ Left s -> throwIO $ PersistMarshalError s
Right (k, x) -> return $ Just (k, x)
where
t = entityDef $ dummyFromUnique uniq
@@ -225,7 +219,7 @@ instance (Trans.MonadIO m, Applicative m, Functor m, MonadMVar m) => PersistBack
Nothing -> return $ Continue k
Just document -> case pairFromDocument t document of
Left s -> return $ Error $ toException
- $ PersistMarshalException s
+ $ PersistMarshalError s
Right row -> do
step <- runIteratee $ k $ Chunks [row]
loop step curs
@@ -236,7 +230,7 @@ instance (Trans.MonadIO m, Applicative m, Functor m, MonadMVar m) => PersistBack
case doc of
Nothing -> return Nothing
Just document -> case pairFromDocument t document of
- Left s -> fail $ "pairFromDocument: could not convert. " ++ s
+ Left s -> throwIO $ PersistMarshalError s
Right row -> return $ Just row
where
t = entityDef $ dummyFromFilts filts
@@ -255,7 +249,7 @@ instance (Trans.MonadIO m, Applicative m, Functor m, MonadMVar m) => PersistBack
Just [_ DB.:= (DB.ObjId oid)] -> do
step <- runIteratee $ k $ Chunks [Key $ dbOidToKey oid]
loop step curs
- Just y -> return $ Error $ toException $ PersistMarshalException
+ Just y -> return $ Error $ toException $ PersistMarshalError
$ "Unexpected in selectKeys: " ++ show y
loop step _ = return step
View
1 persistent-mongoDB/persistent-mongoDB.cabal
@@ -26,6 +26,7 @@ library
, bson >= 0.1.2
, compact-string-fix >= 0.3.1 && < 0.4
, cereal >= 0.3.0.0
+ , monad-control >= 0.2.0 && < 0.3
exposed-modules: Database.Persist.MongoDB
ghc-options: -Wall
View
29 persistent/Database/Persist/Base.hs
@@ -57,9 +57,14 @@ import qualified Data.ByteString.Lazy as L
import Data.Enumerator hiding (consume, map)
import Data.Enumerator.List (consume)
import qualified Data.Enumerator.List as EL
-import qualified Control.Exception as E
+
+import Control.Exception.Control
+import qualified Control.Exception.Base as E
+import Control.Monad.Error.Class (Error (..))
+
import Data.Bits (bitSize)
import Control.Monad (liftM)
+import Control.Monad.IO.Control (MonadControlIO)
import qualified Data.Text.Encoding as T
import qualified Data.Text.Encoding.Error as T
@@ -74,6 +79,19 @@ snd3 (_, x, _) = x
third3 :: forall t t1 t2. (t, t1, t2) -> t2
third3 (_, _, x) = x
+data PersistException
+ = PersistError String
+ | PersistMarshalError String
+ | PersistForeignKeyError Integer
+ | PersistMongoDBError String
+ | PersistMongoDBUnsupportedOperation String
+ deriving (Show, Typeable)
+
+instance E.Exception PersistException
+instance Error PersistException where strMsg msg = PersistError msg
+
+
+
-- | A raw value which can be stored in any backend and can be marshalled to
-- and from a 'PersistField'.
data PersistValue = PersistText T.Text
@@ -341,7 +359,7 @@ instance PersistField SomePersistField where
newtype Key backend entity = Key { unKey :: PersistValue }
deriving (Show, Read, Eq, Ord, PersistField)
-class (Monad (b m), Monad m) => PersistBackend b m where
+class (Monad (b m), MonadControlIO (b m), Monad m) => PersistBackend b m where
-- | Create a new record in the database, returning the newly created
-- identifier.
@@ -464,7 +482,7 @@ selectList :: (PersistEntity val, PersistBackend b m)
selectList a b = do
res <- run $ selectEnum a b ==<< consume
case res of
- Left e -> error $ show e
+ Left e -> throwIO $ PersistError $ show e
Right x -> return x
data EntityDef = EntityDef
@@ -504,17 +522,14 @@ deleteCascadeWhere :: (DeleteCascade a b, PersistBackend b m)
deleteCascadeWhere filts = do
res <- run $ selectKeys filts $ Continue iter
case res of
- Left e -> error $ show e
+ Left e -> throwIO $ PersistError $ show e
Right () -> return ()
where
iter EOF = Iteratee $ return $ Yield () EOF
iter (Chunks keys) = Iteratee $ do
mapM_ deleteCascade keys
return $ Continue iter
-data PersistException = PersistMarshalException String
- deriving (Show, Typeable)
-instance E.Exception PersistException
data PersistUpdate = Assign | Add | Subtract | Multiply | Divide -- FIXME need something else here
deriving (Read, Show, Enum, Bounded)
View
5 persistent/Database/Persist/GenericSql.hs
@@ -46,7 +46,6 @@ import Control.Exception.Control (onException)
import Control.Exception (toException)
import Data.Text (Text, pack, unpack, snoc)
import qualified Data.Text.IO
-import Data.Int (Int64)
import Web.PathPieces (SinglePiece (..))
import qualified Data.Text.Read
@@ -168,7 +167,7 @@ instance MonadControlIO m => PersistBackend SqlPersist m where
Just vals -> do
case fromPersistValues' vals of
Left s -> return $ Error $ toException
- $ PersistMarshalException s
+ $ PersistMarshalError s
Right row -> do
step <- runIteratee $ k $ Chunks [row]
loop step pop
@@ -219,7 +218,7 @@ instance MonadControlIO m => PersistBackend SqlPersist m where
Just [PersistInt64 i] -> do
step <- runIteratee $ k $ Chunks [Key $ PersistInt64 i]
loop step pop
- Just y -> return $ Error $ toException $ PersistMarshalException
+ Just y -> return $ Error $ toException $ PersistMarshalError
$ "Unexpected in selectKeys: " ++ show y
loop step _ = return step
t = entityDef $ dummyFromFilts filts
View
29 persistent/persistent.cabal
@@ -13,18 +13,19 @@ build-type: Simple
homepage: http://www.yesodweb.com/book/persistent
library
- build-depends: base >= 4 && < 5
- , bytestring >= 0.9 && < 0.10
- , transformers >= 0.2.1 && < 0.3
- , time >= 1.1.4 && < 1.3
- , text >= 0.8 && < 0.12
- , containers >= 0.2 && < 0.5
- , parsec >= 2.1 && < 4
- , enumerator >= 0.4.9 && < 0.5
- , monad-control >= 0.2 && < 0.3
- , pool >= 0.1 && < 0.2
- , blaze-html >= 0.4 && < 0.5
- , path-pieces >= 0.0 && < 0.1
+ build-depends: base >= 4 && < 5
+ , bytestring >= 0.9 && < 0.10
+ , transformers >= 0.2.1 && < 0.3
+ , time >= 1.1.4 && < 1.3
+ , text >= 0.8 && < 0.12
+ , containers >= 0.2 && < 0.5
+ , parsec >= 2.1 && < 4
+ , enumerator >= 0.4.9 && < 0.5
+ , monad-control >= 0.2 && < 0.3
+ , pool >= 0.1 && < 0.2
+ , blaze-html >= 0.4 && < 0.5
+ , path-pieces >= 0.0 && < 0.1
+ , mtl >= 2.0 && < 2.1
exposed-modules: Database.Persist
Database.Persist.Base
Database.Persist.Quasi
@@ -57,8 +58,8 @@ test-suite test
, bson
-- these are mutually exclusive options
- cpp-options: -DWITH_POSTGRESQL
- --cpp-options: -DWITH_MONGODB
+ --cpp-options: -DWITH_POSTGRESQL
+ cpp-options: -DWITH_MONGODB
ghc-options: -Wall
extra-libraries: sqlite3
View
16 persistent/test/main.hs
@@ -13,10 +13,10 @@
import Test.HUnit hiding (Test)
import Test.Hspec.Monadic
-import Test.Hspec.HUnit
+import Test.Hspec.HUnit()
import Database.Persist
-import Database.Persist.Base (PersistUpdate (Add, Assign), PersistFilter (..), ColumnDef (ColumnDef), DeleteCascade (..))
+import Database.Persist.Base (DeleteCascade (..))
import Database.Persist.Join hiding (RunJoin)
import qualified Database.Persist.Join
@@ -44,7 +44,9 @@ import Data.Int
import Data.Word
import qualified Control.Monad.IO.Control
-import Debug.FileLocation (debug)
+import Data.Text (Text)
+
+-- import Debug.FileLocation (debug)
@@ -65,7 +67,10 @@ assertNotEqual preface expected actual =
where msg = (if null preface then "" else preface ++ "\n") ++
"expected: " ++ show expected ++ "\n to not equal: " ++ show actual
+assertEmpty :: MonadIO m => [a] -> m ()
assertEmpty xs = liftIO $ assertBool "" (null xs)
+
+assertNotEmpty :: MonadIO m => [a] -> m ()
assertNotEmpty xs = liftIO $ assertBool "" (not (null xs))
@@ -130,7 +135,7 @@ setup = do
MongoDB.dropDatabase "test" --(MongoDB.Database "test")
return ()
where
- andVersion vresult = case debug $ show vresult of
+ andVersion vresult = case show vresult of
'"':'1':'.':n:'.':minor -> let i = ((read [n]) ::Int) in i > 9 || (i == 9 && ((read $ init minor)::Int) >= 1)
'"':'2':'.':_ -> True
@@ -142,6 +147,7 @@ db actions = do
return r
#else
+sqlite_database :: Text
sqlite_database = "test/testdb.sqlite3"
runConn :: Control.Monad.IO.Control.MonadControlIO m => SqlPersist m t -> m ()
runConn f = do
@@ -510,7 +516,7 @@ specs = describe "persistent" $ do
p2 = Person "E" 1 Nothing
p3 = Person "F" 2 Nothing
pid1 <- insert p1
- _pid2 <- insert p2
+ _ <- insert p2
pid3 <- insert p3
x <- selectList [PersonId <-. [pid1, pid3]] []
liftIO $ x @?= [(pid1, p1), (pid3, p3)]

0 comments on commit df6bd17

Please sign in to comment.
Something went wrong with that request. Please try again.