persistent-mongoDB 0.2.2 → 0.3.0

raw patch · 4 files changed

+80/−47 lines, 4 filessetup-changednew-uploaderPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• Database/Persist/MongoDB.hs +70/−43
• Setup.hs +0/−2
• Setup.lhs +7/−0
• persistent-mongoDB.cabal +3/−2

@@ -1,4 +1,8 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE PackageImports, RankNTypes #-} -- | A redis backend for persistent. module Database.Persist.MongoDB@@ -15,6 +19,7 @@ import Control.Monad.Trans.Reader import qualified Control.Monad.IO.Class as Trans import qualified Database.MongoDB as DB+import Database.MongoDB.Query (Action, Failure) import Control.Applicative (Applicative) import Control.Exception (toException) import Data.UString (u)@@ -26,37 +31,59 @@ import qualified Data.Text as T import qualified Data.Text.Encoding as E import qualified Data.Serialize as S--{--import Debug.Trace-debug :: (Show a) => a -> a-debug a = trace ("DEBUG: " ++ show a) a--}+import Control.Exception (Exception, throwIO)+import Data.Typeable (Typeable)+import Control.Monad.Context (Context (..))+import Control.Monad.Throw (Throw (..))+import Prelude hiding (catch)+import Network.Abstract (Internet (..), ANetwork (..)) -newtype MongoDBReader t m a = MongoDBReader (ReaderT ((DB.ConnPool t), HostName) m a)+newtype MongoDBReader m a = MongoDBReader { unMongoDBReader :: ReaderT DB.Database (Action m) a }     deriving (Monad, Trans.MonadIO, Functor, Applicative) -withMongoDBConn :: (Network.Abstract.NetworkIO m) => t -> HostName -> ((DB.ConnPool DB.Host, t) -> m b) -> m b+instance Monad m => Context DB.Database (MongoDBReader m) where+    context = MongoDBReader ask+    push f (MongoDBReader x) = MongoDBReader $ local f x++instance Monad m => Context DB.MasterOrSlaveOk (MongoDBReader m) where+    context = MongoDBReader context+    push f (MongoDBReader x) = MongoDBReader $ push f x++instance Monad m => Context DB.Pipe (MongoDBReader m) where+    context = MongoDBReader context+    push f (MongoDBReader x) = MongoDBReader $ push f x++instance Monad m => Context DB.WriteMode (MongoDBReader m) where+    context = MongoDBReader context+    push f (MongoDBReader x) = MongoDBReader $ push f x++instance Monad m => Throw Failure (MongoDBReader m) where+    throw = MongoDBReader . throw+    catch (MongoDBReader x) f =+        MongoDBReader $ ReaderT $ \db -> catch (runReaderT x db) (f' db)+      where+        f' db e = runReaderT (unMongoDBReader (f e)) db++withMongoDBConn :: (Trans.MonadIO m, Applicative m) => t -> HostName -> (DB.ConnPool DB.Host -> t -> m b) -> m b withMongoDBConn dbname hostname connectionReader = do-  pool <- DB.newConnPool 1 $ DB.host hostname-  connectionReader (pool, dbname)+  pool <- runReaderT (DB.newConnPool 1 $ DB.host hostname) $ ANetwork Internet+  connectionReader pool dbname -runMongoDBConn :: MongoDBReader t m a -> (DB.ConnPool t, HostName) -> m a-runMongoDBConn (MongoDBReader r) = runReaderT r  -runPool :: (DB.Service s, Trans.MonadIO m) => DB.ConnPool s -> String -     -> ReaderT DB.Database (DB.Action m) a -> m (Either DB.Failure a)-runPool pool dbname action =-  DB.access DB.safe DB.Master pool $ DB.use (DB.Database (u dbname)) action+runMongoDBConn :: (DB.Service s, Trans.MonadIO m) =>+                                    MongoDBReader m b+                                 -> DB.WriteMode+                                 -> DB.MasterOrSlaveOk+                                 -> DB.ConnPool s+                                 -> DB.Database+                                 -> m b+runMongoDBConn (MongoDBReader a) wm ms cp db = do+    res <- DB.access wm ms cp (runReaderT a db)+    either (Trans.liftIO . throwIO . MongoDBException) return res -execute :: (DB.Service s, Trans.MonadIO m) =>-     ReaderT DB.Database (DB.Action (MongoDBReader s m)) b -> MongoDBReader s m b-execute action = do-  (pool, dbname) <- MongoDBReader ask-  res <-  runPool pool dbname action-  case res of-      (Right result) -> return result -      (Left x) -> fail (show x)   -- TODO what to put here?+newtype MongoDBException = MongoDBException Failure+    deriving (Show, Typeable)+instance Exception MongoDBException  value :: DB.Field -> DB.Value value (_ DB.:= val) = val@@ -118,30 +145,30 @@     toLabels = map (u . fst3) $ entityColumns t     toValues = map (DB.val . toPersistValue) (toPersistFields record) -instance (DB.DbAccess m, DB.Service t) => PersistBackend (MongoDBReader t m) where+instance (Trans.MonadIO m, Functor m) => PersistBackend (MongoDBReader m) where     insert record = do-        (DB.ObjId oid) <- execute $ DB.insert (u $ entityName t) (insertFields t record)+        (DB.ObjId oid) <- DB.insert (u $ entityName t) (insertFields t record)         return $ toPersistKey $ dbOidToKey oid        where         t = entityDef record      replace k record = do-        execute $ DB.replace (selectByKey k t) (insertFields t record)+        DB.replace (selectByKey k t) (insertFields t record)         return ()       where         t = entityDef record      update _ [] = return ()     update k upds =-        execute $ DB.modify -                     (DB.Select [u"_id" DB.:= (DB.ObjId $ keyToDbOid k)]  (u $ entityName t)) -                     $ updateFields upds+        DB.modify +           (DB.Select [u"_id" DB.:= (DB.ObjId $ keyToDbOid k)]  (u $ entityName t)) +           $ updateFields upds       where         t = entityDef $ dummyFromKey k      updateWhere _ [] = return ()     updateWhere filts upds =-        execute $ DB.modify DB.Select {+        DB.modify DB.Select {           DB.coll = (u $ entityName t)         , DB.selector = filterToSelector filts         } $ updateFields upds@@ -149,7 +176,7 @@         t = entityDef $ dummyFromFilts filts      delete k =-        execute $ DB.deleteOne DB.Select {+        DB.deleteOne DB.Select {           DB.coll = (u $ entityName t)         , DB.selector = filterByKey k         }@@ -157,7 +184,7 @@         t = entityDef $ dummyFromKey k      deleteWhere filts = do-        execute $ DB.delete DB.Select {+        DB.delete DB.Select {           DB.coll = (u $ entityName t)         , DB.selector = filterToSelector filts         }@@ -165,7 +192,7 @@         t = entityDef $ dummyFromFilts filts      deleteBy uniq =-        execute $ DB.delete DB.Select {+        DB.delete DB.Select {           DB.coll = u $ entityName t         , DB.selector = uniqSelector uniq         }@@ -173,7 +200,7 @@         t = entityDef $ dummyFromUnique uniq      get k = do-            d <- execute $ DB.findOne (queryByKey k t)+            d <- DB.findOne (queryByKey k t)             case d of               Nothing -> return Nothing               Just doc -> do@@ -182,7 +209,7 @@             t = entityDef $ dummyFromKey k      getBy uniq = do-        mdocument <- execute $ DB.findOne $+        mdocument <- DB.findOne $           (DB.select (uniqSelector uniq) (u $ entityName t))         case mdocument of           Nothing -> return Nothing@@ -193,7 +220,7 @@         t = entityDef $ dummyFromUnique uniq      count filts = do-        i <- execute $ DB.count query+        i <- DB.count query         return $ fromIntegral i       where         query = DB.select (filterToSelector filts) (u $ entityName t)@@ -202,7 +229,7 @@     selectEnum filts ords limit offset = Iteratee . start       where         start x = do-            cursor <- execute $ DB.find query+            cursor <- DB.find query             loop x cursor          query = (DB.select (filterToSelector filts) (u $ entityName t)) {@@ -218,7 +245,7 @@                                 Desc -> -1 )          loop (Continue k) curs = do-            doc <- execute $ DB.next curs+            doc <- DB.next curs             case doc of                 Nothing -> return $ Continue k                 Just document -> case pairFromDocument t document of@@ -233,11 +260,11 @@         Iteratee . start       where         start x = do-            cursor <- execute $ DB.find query+            cursor <- DB.find query             loop x cursor          loop (Continue k) curs = do-            doc <- execute $ DB.next curs+            doc <- DB.next curs             case doc of                 Nothing -> return $ Continue k                 Just [_ DB.:= (DB.ObjId oid)] -> do@@ -305,8 +332,8 @@           where             matchOne (f:fs) tried =               if c == fst f then (f, tried ++ fs) else matchOne fs (f:tried)-            matchOne fields tried = error $ "field doesn't match" ++ (show c) ++ (show fields) ++ (show tried)-        match cs fields values = error $ "fields don't match" ++ (show cs) ++ (show fields) ++ (show values)+            matchOne fs tried = error $ "field doesn't match" ++ (show c) ++ (show fs) ++ (show tried)+        match cs fs values = error $ "fields don't match" ++ (show cs) ++ (show fs) ++ (show values)  mapFromDoc :: DB.Document -> [(T.Text, PersistValue)] mapFromDoc = Prelude.map (\f -> ( ( csToT (DB.label f)), (fromJust . DB.cast') (DB.value f) ) )

@@ -1,2 +0,0 @@-import Distribution.Simple-main = defaultMain

@@ -0,0 +1,7 @@+#!/usr/bin/env runhaskell++> module Main where+> import Distribution.Simple++> main :: IO ()+> main = defaultMain

@@ -1,10 +1,11 @@ name:            persistent-mongoDB-version:         0.2.2+version:         0.3.0 license:         BSD3 license-file:    LICENSE author:          Greg Weber <greg@gregweber.info>-maintainer:      Greg Weber <greg@gregweber.info>+maintainer:      Greg Weber <greg@gregweber.info>, Rick Richardson <rick.richardson@gmail.com> synopsis:        Backend for the persistent library using mongoDB.+description:     Backend for the persistent library using mongoDB. category:        Database stability:       Experimental cabal-version:   >= 1.6