diff --git a/Database/Persist/MongoDB.hs b/Database/Persist/MongoDB.hs --- a/Database/Persist/MongoDB.hs +++ b/Database/Persist/MongoDB.hs @@ -1,89 +1,92 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE PackageImports, RankNTypes #-} --- | A redis backend for persistent. +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} module Database.Persist.MongoDB - ( MongoDBReader - , withMongoDBConn + ( withMongoDBConn + , withMongoDBPool , runMongoDBConn , HostName - , PersistValue(..) + , u + , DB.Action + -- , DB.MasterOrSlaveOk(..) + , DB.AccessMode(..) + , DB.master + , DB.slaveOk + , (DB.=:) + , ConnectionPool , module Database.Persist ) where import Database.Persist import Database.Persist.Base -import Control.Monad.Trans.Reader + import qualified Control.Monad.IO.Class as Trans +import Control.Exception (throw, toException, throwIO) + import qualified Database.MongoDB as DB -import Database.MongoDB.Query (Action, Failure) +import Database.MongoDB.Query (Database) import Control.Applicative (Applicative) -import Control.Exception (toException) import Data.UString (u) import qualified Data.CompactString.UTF8 as CS -import Data.Enumerator hiding (map, length) +import Data.Enumerator hiding (map, length, concatMap, head, replicate) import Network.Socket (HostName) -import qualified Network.Abstract(NetworkIO) 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.Monad.Context (Context (..)) -import Control.Monad.Throw (Throw (..)) -import Prelude hiding (catch) -import Network.Abstract (Internet (..), ANetwork (..)) +import qualified Data.Serialize as Serialize +import qualified System.IO.Pool as Pool +import Web.PathPieces (SinglePiece (..)) +import Control.Monad.IO.Control (MonadControlIO) -newtype MongoDBReader m a = MongoDBReader { unMongoDBReader :: ReaderT DB.Database (Action m) a } - deriving (Monad, Trans.MonadIO, Functor, Applicative) +#ifdef DEBUG +import FileLocation (debug) +#else +{- +debug :: forall a. a -> a +debug = id +debugMsg :: forall t a. t -> a -> a +debugMsg _ = id +-} +#endif -instance Monad m => Context DB.Database (MongoDBReader m) where - context = MongoDBReader ask - push f (MongoDBReader x) = MongoDBReader $ local f x +type ConnectionPool = (Pool.Pool IOError DB.Pipe, Database) -instance Monad m => Context DB.MasterOrSlaveOk (MongoDBReader m) where - context = MongoDBReader context - push f (MongoDBReader x) = MongoDBReader $ push f x +instance SinglePiece (Key DB.Action entity) where + toSinglePiece (Key pOid@(PersistObjectId _)) = -- T.pack $ show $ Serialize.encode bsonId + let oid@(DB.Oid _ _) = persistObjectIdToDbOid pOid + in T.pack $ show oid + toSinglePiece k = throw $ PersistInvalidField $ "Invalid Key (expected PersistObjectId): " ++ show k -instance Monad m => Context DB.Pipe (MongoDBReader m) where - context = MongoDBReader context - push f (MongoDBReader x) = MongoDBReader $ push f x + fromSinglePiece str = + case (reads $ (T.unpack str))::[(DB.ObjectId,String)] of + (parsed,_):[] -> Just $ Key $ PersistObjectId $ Serialize.encode parsed + _ -> Nothing -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 <- runReaderT (DB.newConnPool 1 $ DB.host hostname) $ ANetwork Internet - connectionReader pool dbname - +withMongoDBConn :: (Trans.MonadIO m, Applicative m) => + Database -> HostName -> (ConnectionPool -> m b) -> m b +withMongoDBConn dbname hostname = withMongoDBPool dbname hostname 1 -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 +withMongoDBPool :: (Trans.MonadIO m, Applicative m) => + Database -> HostName -> Int -> (ConnectionPool -> m b) -> m b +withMongoDBPool dbname hostname connectionPoolSize connectionReader = do + --pool <- runReaderT (DB.newConnPool connectionPoolSize $ DB.host hostname) $ ANetwork Internet + pool <- Trans.liftIO $ Pool.newPool Pool.Factory { Pool.newResource = DB.connect (DB.host hostname) + , Pool.killResource = DB.close + , Pool.isExpired = DB.isClosed + } + connectionPoolSize + connectionReader (pool, dbname) -newtype MongoDBException = MongoDBException Failure - deriving (Show, Typeable) -instance Exception MongoDBException +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 . PersistMongoDBError . show) return res value :: DB.Field -> DB.Value value (_ DB.:= val) = val @@ -93,62 +96,57 @@ Left e -> error e Right v -> v -fst3 :: forall t t1 t2. (t, t1, t2) -> t -fst3 (x, _, _) = x - -filterByKey :: (PersistEntity val) => Key val -> DB.Document +filterByKey :: (PersistEntity val) => Key DB.Action val -> DB.Document filterByKey k = [u"_id" DB.=: keyToDbOid k] -queryByKey :: (PersistEntity val) => Key val -> EntityDef -> DB.Query +queryByKey :: (PersistEntity val) => Key DB.Action val -> EntityDef -> DB.Query queryByKey k entity = (DB.select (filterByKey k) (u $ entityName entity)) -selectByKey :: (PersistEntity val) => Key val -> EntityDef -> DB.Selection +selectByKey :: (PersistEntity val) => Key DB.Action val -> EntityDef -> DB.Selection selectByKey k entity = (DB.select (filterByKey k) (u $ entityName entity)) updateFields :: (PersistEntity val) => [Update val] -> [DB.Field] -updateFields upds = map updateField upds +updateFields upds = map updateToMongoField upds -updateField :: (PersistEntity val) => Update val -> DB.Field -updateField upd = opName DB.:= DB.Doc [( (u $ persistUpdateToFieldName upd) DB.:= opValue)] +updateToMongoField :: (PersistEntity val) => Update val -> DB.Field +updateToMongoField upd@(Update _ v up) = opName DB.:= DB.Doc [( (u $ updateFieldName upd) DB.:= opValue)] where - opValue = (DB.val $ transform $ persistUpdateToValue upd) - transform (PersistInt64 i) = PersistInt64 $ - case persistUpdateToUpdate upd of - Subtract -> -i - _ -> i - transform x = x - opName = case persistUpdateToUpdate upd of - Update -> u "$set" - Add -> u "$inc" - Subtract -> u "$inc" - Multiply -> error "multiply not supported yet" - Divide -> error "divide not supported yet" + opValue = DB.val . snd $ opNameValue + opName = fst opNameValue + opNameValue = + case (up, toPersistValue v) of + (Assign,a) -> (u "$set", a) + (Add, a) -> (u "$inc", a) + (Subtract, PersistInt64 i) -> (u "$inc", PersistInt64 (-i)) + (Subtract, _) -> error "expected PersistInt64 for a subtraction" + (Multiply, _) -> throw $ PersistMongoDBUnsupported "multiply not supported" + (Divide, _) -> throw $ PersistMongoDBUnsupported "divide not supported" -uniqSelector :: forall val. (PersistEntity val) => Unique val -> [DB.Field] +uniqSelector :: forall val. (PersistEntity val) => Unique val DB.Action -> [DB.Field] uniqSelector uniq = zipWith (DB.:=) (map u (persistUniqueToFieldNames uniq)) (map DB.val (persistUniqueToValues uniq)) -pairFromDocument :: forall val val1. (PersistEntity val, PersistEntity val1) => EntityDef -> [DB.Field] -> Either String (Key val, val1) +pairFromDocument :: forall val val1. (PersistEntity val, PersistEntity val1) => EntityDef -> [DB.Field] -> Either String (Key DB.Action val, val1) pairFromDocument ent document = pairFromPersistValues document where pairFromPersistValues (x:xs) = case wrapFromPersistValues ent xs of Left e -> Left e - Right xs' -> Right ((toPersistKey . fromJust . DB.cast' . value) x, xs') + Right xs' -> Right ((Key . dbOidToKey . fromJust . DB.cast' . value) x, xs') pairFromPersistValues _ = Left "error in fromPersistValues'" insertFields :: forall val. (PersistEntity val) => EntityDef -> val -> [DB.Field] insertFields t record = zipWith (DB.:=) (toLabels) (toValues) where - toLabels = map (u . fst3) $ entityColumns t + toLabels = map (u . columnName) $ entityColumns t toValues = map (DB.val . toPersistValue) (toPersistFields record) -instance (Trans.MonadIO m, Functor m) => PersistBackend (MongoDBReader m) where +instance (Applicative m, Functor m, MonadControlIO m) => PersistBackend DB.Action m where insert record = do (DB.ObjId oid) <- DB.insert (u $ entityName t) (insertFields t record) - return $ toPersistKey $ dbOidToKey oid + return $ Key $ dbOidToKey oid where t = entityDef record @@ -170,7 +168,7 @@ updateWhere filts upds = DB.modify DB.Select { DB.coll = (u $ entityName t) - , DB.selector = filterToSelector filts + , DB.selector = filtersToSelector filts } $ updateFields upds where t = entityDef $ dummyFromFilts filts @@ -186,7 +184,7 @@ deleteWhere filts = do DB.delete DB.Select { DB.coll = (u $ entityName t) - , DB.selector = filterToSelector filts + , DB.selector = filtersToSelector filts } where t = entityDef $ dummyFromFilts filts @@ -214,7 +212,7 @@ case mdocument of Nothing -> return Nothing Just document -> case pairFromDocument t document of - Left s -> error s + Left s -> Trans.liftIO . throwIO $ PersistMarshalError s Right (k, x) -> return $ Just (k, x) where t = entityDef $ dummyFromUnique uniq @@ -223,26 +221,16 @@ i <- DB.count query return $ fromIntegral i where - query = DB.select (filterToSelector filts) (u $ entityName t) + query = DB.select (filtersToSelector filts) (u $ entityName t) t = entityDef $ dummyFromFilts filts - selectEnum filts ords limit offset = Iteratee . start + selectEnum filts opts = Iteratee . start where start x = do - cursor <- DB.find query + cursor <- DB.find $ makeQuery filts opts loop x cursor - query = (DB.select (filterToSelector filts) (u $ entityName t)) { - DB.limit = fromIntegral limit - , DB.skip = fromIntegral offset - , DB.sort = if null ords then [] else map orderClause ords - } - t = entityDef $ dummyFromFilts filts - orderClause o = (u(persistOrderToFieldName o)) - DB.=: (case persistOrderToOrder o of - Asc -> 1 :: Int - Desc -> -1 ) loop (Continue k) curs = do doc <- DB.next curs @@ -250,12 +238,22 @@ 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 loop step _ = return step + selectFirst filts opts = do + doc <- DB.findOne $ makeQuery filts opts + case doc of + Nothing -> return Nothing + Just document -> case pairFromDocument t document of + Left s -> Trans.liftIO . throwIO $ PersistMarshalError s + Right row -> return $ Just row + where + t = entityDef $ dummyFromFilts filts + selectKeys filts = Iteratee . start where @@ -268,33 +266,65 @@ case doc of Nothing -> return $ Continue k Just [_ DB.:= (DB.ObjId oid)] -> do - step <- runIteratee $ k $ Chunks [toPersistKey $ dbOidToKey oid] + 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 - query = (DB.select (filterToSelector filts) (u $ entityName t)) { + query = (DB.select (filtersToSelector filts) (u $ entityName t)) { DB.project = [u"_id" DB.=: (1 :: Int)] } t = entityDef $ dummyFromFilts filts -filterToSelector :: PersistEntity val => [Filter val] -> DB.Document -filterToSelector filts = map filterField filts +orderClause :: PersistEntity val => SelectOpt val -> DB.Field +orderClause o = case o of + Asc f -> fieldName f DB.=: ( 1 :: Int) + Desc f -> fieldName f DB.=: (-1 :: Int) + _ -> error "orderClause: expected Asc or Desc" -filterField :: PersistEntity val => Filter val -> DB.Field -filterField f = case filt of - Eq -> name DB.:= filterValue - _ -> name DB.=: [u(showFilter filt) DB.:= filterValue] + +makeQuery :: PersistEntity val => [Filter val] -> [SelectOpt val] -> DB.Query +makeQuery filts opts = + (DB.select (filtersToSelector filts) (u $ entityName t)) { + DB.limit = fromIntegral limit + , DB.skip = fromIntegral offset + , DB.sort = orders + } where - name = case (persistFilterToFieldName f) of - "id" -> u "_id" - other -> u other - filt = persistFilterToFilter f - filterValue = case persistFilterToValue f of - Left v -> DB.val v - Right vs -> DB.Array (map DB.val vs) + t = entityDef $ dummyFromFilts filts + limit = fst3 $ limitOffsetOrder opts + offset = snd3 $ limitOffsetOrder opts + orders = map orderClause $ third3 $ limitOffsetOrder opts +filtersToSelector :: PersistEntity val => [Filter val] -> DB.Document +filtersToSelector filts = +#ifdef DEBUG + debug $ +#endif + if null filts then [] else concatMap filterToDocument filts + +multiFilter :: forall val. PersistEntity val => String -> [Filter val] -> [DB.Field] +multiFilter multi fs = [u multi DB.:= DB.Array (map (DB.Doc . filterToDocument) fs)] + +filterToDocument :: PersistEntity val => Filter val -> DB.Document +filterToDocument f = + case f of + Filter field v filt -> return $ case filt of + Eq -> fieldName field DB.:= toValue v + _ -> fieldName field DB.=: [u(showFilter filt) DB.:= toValue v] + FilterOr fs -> multiFilter "$or" fs + -- I didn't even know about the $and operator. + -- It is unecessary in 99% of cases. + -- However it makes query construction easier in special cases + FilterAnd fs -> multiFilter "$and" fs + where + toValue :: forall a. PersistField a => Either a [a] -> DB.Value + toValue val = + case val of + Left v -> DB.val $ toPersistValue v + Right vs -> DB.val $ map toPersistValue vs + showFilter Ne = "$ne" showFilter Gt = "$gt" showFilter Lt = "$lt" @@ -302,13 +332,19 @@ showFilter Le = "$lte" showFilter In = "$in" showFilter NotIn = "$nin" - showFilter Eq = error "" + showFilter Eq = error "EQ filter not expected" + showFilter (BackendSpecificFilter bsf) = throw $ PersistMongoDBError $ "did not expect BackendSpecificFilter " ++ bsf +fieldName :: forall v typ. (PersistEntity v) => EntityField v typ -> CS.CompactString +fieldName = u . idfix . columnName . persistColumnDef + where idfix f = if f == "id" then "_id" else f + + wrapFromPersistValues :: (PersistEntity val) => EntityDef -> [DB.Field] -> Either String val wrapFromPersistValues e doc = fromPersistValues reorder where castDoc = mapFromDoc doc - castColumns = map (T.pack . fst3) $ (entityColumns e) + castColumns = map (T.pack . columnName) $ (entityColumns e) -- we have an alist of fields that need to be the same order as entityColumns -- -- this naive lookup is O(n^2) @@ -332,8 +368,8 @@ where matchOne (f:fs) tried = if c == fst f then (f, tried ++ fs) else matchOne fs (f:tried) - 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) + matchOne fs tried = throw $ PersistError $ "reorder error: field doesn't match" ++ (show c) ++ (show fs) ++ (show tried) + match cs fs values = throw $ PersistError $ "reorder 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) ) ) @@ -345,16 +381,16 @@ tToCS = CS.fromByteString_ . E.encodeUtf8 dbOidToKey :: DB.ObjectId -> PersistValue -dbOidToKey = PersistForeignKey . S.encode +dbOidToKey = PersistObjectId . Serialize.encode -foreignKeyToDbOid :: PersistValue -> DB.ObjectId -foreignKeyToDbOid (PersistForeignKey k) = case S.decode k of - Left s -> error s +persistObjectIdToDbOid :: PersistValue -> DB.ObjectId +persistObjectIdToDbOid (PersistObjectId k) = case Serialize.decode k of + Left msg -> throw $ PersistError $ "error decoding " ++ (show k) ++ ": " ++ msg Right o -> o -foreignKeyToDbOid _ = error "expected PersistForeignKey" +persistObjectIdToDbOid _ = throw $ PersistInvalidField "expected PersistObjectId" -keyToDbOid :: (PersistEntity val) => Key val -> DB.ObjectId -keyToDbOid = foreignKeyToDbOid . fromPersistKey +keyToDbOid :: (PersistEntity val) => Key DB.Action val -> DB.ObjectId +keyToDbOid (Key k) = persistObjectIdToDbOid k instance DB.Val PersistValue where val (PersistInt64 x) = DB.Int64 x @@ -366,9 +402,9 @@ val (PersistList l) = DB.Array $ map DB.val l val (PersistMap m) = DB.Doc $ map (\(k, v)-> (DB.=:) (tToCS k) v) m val (PersistByteString x) = DB.String $ CS.fromByteString_ x - val x@(PersistForeignKey _) = DB.ObjId $ foreignKeyToDbOid x - val (PersistDay _) = error "only PersistUTCTime currently implemented" - val (PersistTimeOfDay _) = error "only PersistUTCTime currently implemented" + val x@(PersistObjectId _) = DB.ObjId $ persistObjectIdToDbOid x + val (PersistDay _) = throw $ PersistMongoDBUnsupported "only PersistUTCTime currently implemented" + val (PersistTimeOfDay _) = throw $ PersistMongoDBUnsupported "only PersistUTCTime currently implemented" cast' (DB.Float x) = Just (PersistDouble x) cast' (DB.Int32 x) = Just $ PersistInt64 $ fromIntegral x cast' (DB.Int64 x) = Just $ PersistInt64 x @@ -384,23 +420,23 @@ cast' (DB.RegEx (DB.Regex us1 us2)) = Just $ PersistByteString $ CS.toByteString $ CS.append us1 us2 cast' (DB.Doc doc) = Just $ PersistMap $ mapFromDoc doc cast' (DB.Array xs) = Just $ PersistList $ mapMaybe DB.cast' xs - cast' (DB.ObjId x) = Just $ dbOidToKey x - cast' (DB.JavaScr _) = error "cast operation not supported for javascript" - cast' (DB.Sym _) = error "cast operation not supported for sym" - cast' (DB.Stamp _) = error "cast operation not supported for stamp" - cast' (DB.MinMax _) = error "cast operation not supported for minmax" + cast' (DB.ObjId x) = Just $ dbOidToKey x + cast' (DB.JavaScr _) = throw $ PersistMongoDBUnsupported "cast operation not supported for javascript" + cast' (DB.Sym _) = throw $ PersistMongoDBUnsupported "cast operation not supported for sym" + cast' (DB.Stamp _) = throw $ PersistMongoDBUnsupported "cast operation not supported for stamp" + cast' (DB.MinMax _) = throw $ PersistMongoDBUnsupported "cast operation not supported for minmax" -instance S.Serialize DB.ObjectId where - put (DB.Oid w1 w2) = do S.put w1 - S.put w2 +instance Serialize.Serialize DB.ObjectId where + put (DB.Oid w1 w2) = do Serialize.put w1 + Serialize.put w2 - get = do w1 <- S.get - w2 <- S.get + get = do w1 <- Serialize.get + w2 <- Serialize.get return (DB.Oid w1 w2) -dummyFromKey :: Key v -> v +dummyFromKey :: Key DB.Action v -> v dummyFromKey _ = error "dummyFromKey" -dummyFromUnique :: Unique v -> v +dummyFromUnique :: Unique v DB.Action -> v dummyFromUnique _ = error "dummyFromUnique" dummyFromFilts :: [Filter v] -> v dummyFromFilts _ = error "dummyFromFilts" diff --git a/persistent-mongoDB.cabal b/persistent-mongoDB.cabal --- a/persistent-mongoDB.cabal +++ b/persistent-mongoDB.cabal @@ -1,36 +1,37 @@ name: persistent-mongoDB -version: 0.3.0 +version: 0.6.1 license: BSD3 license-file: LICENSE author: Greg Weber -maintainer: Greg Weber , Rick Richardson +maintainer: Greg Weber synopsis: Backend for the persistent library using mongoDB. -description: Backend for the persistent library using mongoDB. category: Database stability: Experimental cabal-version: >= 1.6 build-type: Simple -homepage: http://docs.yesodweb.com/persistent/ +homepage: http://www.yesodweb.com/book/persistent +description: Backend for the persistent library using mongoDB. library - build-depends: base >= 4 && < 5 - , persistent >= 0.5.0 - , neither - , template-haskell >= 2.4 && < 2.6 - , text >= 0.8 && < 0.12 - , transformers >= 0.2.1 && < 0.3 - , containers >= 0.2 && < 0.5 - , bytestring >= 0.9 && < 0.10 - , enumerator >= 0.4 && < 0.5 - , mongoDB >= 0.9.2.1 && < 1.0 - , network >= 2.2.1.7 - , bson >= 0.1.2 - , compact-string-fix >= 0.3.1 && < 0.4 - , cereal >= 0.3.0.0 + build-depends: base >= 4 && < 5 + , persistent >= 0.6.0 && < 0.7.0 + , template-haskell >= 2.4 && < 2.7 + , text >= 0.8 && < 0.12 + , transformers >= 0.2.1 && < 0.3 + , containers >= 0.2 && < 0.5 + , bytestring >= 0.9 && < 0.10 + , enumerator >= 0.4 && < 0.5 + , mongoDB >= 1.1 && < 1.2 + , bson >= 0.1.5 + , network >= 2.2.1.7 + , compact-string-fix >= 0.3.1 && < 0.4 + , cereal >= 0.3.0.0 + , path-pieces >= 0.0 && < 0.1 + , monad-control >= 0.2 && < 0.3 exposed-modules: Database.Persist.MongoDB ghc-options: -Wall source-repository head type: git - location: git://github.com/snoyberg/persistent.git + location: git://github.com/yesodweb/persistent.git