diff --git a/Database/Persist/MongoDB.hs b/Database/Persist/MongoDB.hs --- a/Database/Persist/MongoDB.hs +++ b/Database/Persist/MongoDB.hs @@ -7,6 +7,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} -- FIXME {-# OPTIONS_GHC -fno-warn-orphans #-} module Database.Persist.MongoDB ( @@ -57,14 +58,13 @@ import qualified Data.Serialize as Serialize import qualified System.IO.Pool as Pool import Web.PathPieces (PathPiece (..)) -import Data.Conduit (ResourceIO) import qualified Data.Conduit as C -import Control.Monad.Trans.Resource (ResourceThrow (..)) import Control.Monad.Trans.Class (lift) import Control.Monad.IO.Class (liftIO) import Data.Aeson (Value (Object), (.:), (.:?), (.!=)) import Control.Monad (mzero) import Control.Monad.Trans.Control (MonadBaseControl) +import Control.Monad.Trans.Resource (MonadThrow (..)) #ifdef DEBUG import FileLocation (debug) @@ -142,13 +142,12 @@ updateToMongoField (Update field v up) = opName DB.:= DB.Doc [( (u $ T.unpack $ unDBName $ fieldDB $ persistFieldDef field) DB.:= opValue)] where - opValue = DB.val . snd $ opNameValue - opName = fst opNameValue - opNameValue = + (opName, opValue) = case (up, toPersistValue v) of - (Assign,a) -> (u"$set", a) - (Add, a) -> (u"$inc", a) - (Subtract, PersistInt64 i) -> (u "$inc", PersistInt64 (-i)) + (Assign, PersistNull) -> (u"$unset", DB.Int64 1) + (Assign,a) -> (u"$set", DB.val a) + (Add, a) -> (u"$inc", DB.val a) + (Subtract, PersistInt64 i) -> (u "$inc", DB.Int64 (-i)) (Subtract, _) -> error "expected PersistInt64 for a subtraction" (Multiply, _) -> throw $ PersistMongoDBUnsupported "multiply not supported" (Divide, _) -> throw $ PersistMongoDBUnsupported "divide not supported" @@ -172,11 +171,16 @@ pairFromPersistValues _ = Left "error in fromPersistValues'" insertFields :: forall val. (PersistEntity val) => EntityDef -> val -> [DB.Field] -insertFields t record = zipWith (DB.:=) (toLabels) (toValues) +insertFields t record = zipFilter (entityFields t) (toPersistFields record) where - toLabels = map (u . T.unpack . unDBName . fieldDB) $ entityFields t - toValues = map (DB.val . toPersistValue) (toPersistFields record) + zipFilter [] _ = [] + zipFilter _ [] = [] + zipFilter (e:efields) (p:pfields) = let pv = toPersistValue p in + if pv == PersistNull then zipFilter efields pfields + else (toLabel e DB.:= DB.val pv):zipFilter efields pfields + toLabel = u . T.unpack . unDBName . fieldDB + saveWithKey :: forall m ent record. (Applicative m, Functor m, MonadBaseControl IO m, PersistEntity ent, PersistEntity record) => (DB.Collection -> DB.Document -> DB.Action m () ) -> Key DB.Action ent -> record -> DB.Action m () @@ -185,7 +189,7 @@ where t = entityDef record -instance (Applicative m, Functor m, ResourceIO m) => PersistStore DB.Action m where +instance (Applicative m, Functor m, Trans.MonadIO m, MonadBaseControl IO m) => PersistStore DB.Action m where insert record = do (DB.ObjId oid) <- DB.insert (u $ T.unpack $ unDBName $ entityDB t) (insertFields t record) return $ oidToKey oid @@ -219,10 +223,10 @@ where t = entityDef $ dummyFromKey k -instance ResourceThrow m => ResourceThrow (DB.Action m) where - resourceThrow = lift . resourceThrow +instance MonadThrow m => MonadThrow (DB.Action m) where + monadThrow = lift . monadThrow -instance (Applicative m, Functor m, ResourceIO m) => PersistUnique DB.Action m where +instance (Applicative m, Functor m, Trans.MonadIO m, MonadBaseControl IO m) => PersistUnique DB.Action m where getBy uniq = do mdocument <- DB.findOne $ (DB.select (uniqSelector uniq) (u $ T.unpack $ unDBName $ entityDB t)) @@ -245,7 +249,7 @@ persistKeyToMongoId :: PersistEntity val => Key DB.Action val -> DB.Field persistKeyToMongoId k = u"_id" DB.:= (DB.ObjId $ keyToOid k) -instance (Applicative m, Functor m, ResourceIO m) => PersistQuery DB.Action m where +instance (Applicative m, Functor m, Trans.MonadIO m, MonadBaseControl IO m) => PersistQuery DB.Action m where update _ [] = return () update k upds = DB.modify @@ -278,22 +282,21 @@ query = DB.select (filtersToSelector filts) (u $ T.unpack $ unDBName $ entityDB t) t = entityDef $ dummyFromFilts filts - selectSource filts opts = C.Source - { C.sourcePull = do + selectSource filts opts = C.PipeM + (do cursor <- lift $ DB.find $ makeQuery filts opts - pull cursor - , C.sourceClose = return () - } + return $ mkSrc cursor) + (return ()) where - mkSrc cursor = C.Source (pull cursor) (return ()) + mkSrc cursor = C.PipeM (pull cursor) (return ()) pull cursor = lift $ do mdoc <- DB.next cursor case mdoc of - Nothing -> return C.Closed + Nothing -> return $ C.Done Nothing () Just doc -> case pairFromDocument t doc of Left s -> liftIO $ throwIO $ PersistMarshalError $ T.pack s - Right row -> return $ C.Open (mkSrc cursor) row + Right row -> return $ C.HaveOutput (mkSrc cursor) (return ()) row t = entityDef $ dummyFromFilts filts selectFirst filts opts = do @@ -306,19 +309,18 @@ where t = entityDef $ dummyFromFilts filts - selectKeys filts = C.Source - { C.sourcePull = do + selectKeys filts = C.PipeM + (do cursor <- lift $ DB.find query - pull cursor - , C.sourceClose = return () - } + return $ mkSrc cursor) + (return ()) where - mkSrc cursor = C.Source (pull cursor) (return ()) + mkSrc cursor = C.PipeM (pull cursor) (return ()) pull cursor = lift $ do mdoc <- DB.next cursor case mdoc of - Nothing -> return C.Closed - Just [_ DB.:= DB.ObjId oid] -> return $ C.Open (mkSrc cursor) $ oidToKey oid + Nothing -> return $ C.Done Nothing () + Just [_ DB.:= DB.ObjId oid] -> return $ C.HaveOutput (mkSrc cursor) (return ()) $ oidToKey oid Just y -> liftIO $ throwIO $ PersistMarshalError $ T.pack $ "Unexpected in selectKeys: " ++ show y query = (DB.select (filtersToSelector filts) (u $ T.unpack $ unDBName $ entityDB t)) { DB.project = [u"_id" DB.=: (1 :: Int)] @@ -407,6 +409,8 @@ -- * do an alist lookup for each column -- * but once we found an item in the alist use a new alist without that item for future lookups -- * so for the last query there is only one item left + -- + -- TODO: the above should be re-thought now that we are no longer inserting null: searching for a null column will look at every returned field before giving up reorder :: [PersistValue] reorder = match castColumns castDoc [] where @@ -424,8 +428,10 @@ where matchOne (f:fs) tried = if c == fst f then (f, tried ++ fs) else matchOne fs (f:tried) - matchOne fs tried = throw $ PersistError $ T.pack $ "reorder error: field doesn't match" ++ (show c) ++ (show fs) ++ (show tried) - -- match [] fs values = throw $ PersistError $ "reorder error: extra mongo fields" ++ (show fs) + -- a Nothing will not be inserted into the document as a null + -- so if we don't find our column it is a + -- this keeps the document size down + matchOne [] tried = ((c, PersistNull), tried) mapFromDoc :: DB.Document -> [(T.Text, PersistValue)] mapFromDoc = Prelude.map (\f -> ( ( csToText (DB.label f)), (fromJust . DB.cast') (DB.value f) ) ) @@ -462,7 +468,7 @@ val (PersistNull) = DB.Null val (PersistList l) = DB.Array $ map DB.val l val (PersistMap m) = DB.Doc $ map (\(k, v)-> (DB.=:) (textToCS k) v) m - val (PersistByteString x) = DB.String $ CS.fromByteString_ x + val (PersistByteString x) = DB.Bin (DB.Binary x) val x@(PersistObjectId _) = DB.ObjId $ persistObjectIdToDbOid x val (PersistDay _) = throw $ PersistMongoDBUnsupported "only PersistUTCTime currently implemented" val (PersistTimeOfDay _) = throw $ PersistMongoDBUnsupported "only PersistUTCTime currently implemented" diff --git a/persistent-mongoDB.cabal b/persistent-mongoDB.cabal --- a/persistent-mongoDB.cabal +++ b/persistent-mongoDB.cabal @@ -1,5 +1,5 @@ name: persistent-mongoDB -version: 0.8.0 +version: 0.9.0 license: BSD3 license-file: LICENSE author: Greg Weber @@ -14,12 +14,13 @@ library build-depends: base >= 4 && < 5 - , persistent >= 0.8 && < 0.9 + , persistent >= 0.9 && < 0.10 , text >= 0.8 && < 1 - , transformers >= 0.2.1 && < 0.3 + , transformers >= 0.2.1 && < 0.4 , containers >= 0.2 && < 0.5 , bytestring >= 0.9 && < 0.10 - , conduit >= 0.2 + , conduit >= 0.4 && < 0.5 + , resourcet >= 0.3 && < 0.4 , mongoDB >= 1.2 && < 1.3 , bson >= 0.1.6 , network >= 2.2.1.7 && < 3