persistent-mongoDB 0.8.0 → 0.9.0
raw patch · 2 files changed
+46/−39 lines, 2 filesdep +resourcetdep ~conduitdep ~persistentdep ~transformers
Dependencies added: resourcet
Dependency ranges changed: conduit, persistent, transformers
Files
- Database/Persist/MongoDB.hs +41/−35
- persistent-mongoDB.cabal +5/−4
Database/Persist/MongoDB.hs view
@@ -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"
persistent-mongoDB.cabal view
@@ -1,5 +1,5 @@ name: persistent-mongoDB-version: 0.8.0+version: 0.9.0 license: BSD3 license-file: LICENSE author: Greg Weber <greg@gregweber.info>@@ -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