Skip to content

Commit

Permalink
persistent-mongoDB-2.13.0.0 (#1286)
Browse files Browse the repository at this point in the history
* Fix upsert tests

* Fix mongo insert documents

* Fix shadowing

* Add notes about mongo PersistMap

* Re enable some mongodb tests

* Re enable building mongo

* Stylish haskell

* Update changelog

* Bump mongodb version

* Update mongodb maintaner
  • Loading branch information
aschmois authored Jun 21, 2021
1 parent 2aa65e2 commit 5dbd756
Show file tree
Hide file tree
Showing 8 changed files with 56 additions and 38 deletions.
2 changes: 1 addition & 1 deletion cabal.project
Original file line number Diff line number Diff line change
Expand Up @@ -2,7 +2,7 @@ packages:
persistent
persistent-sqlite
persistent-test
-- persistent-mongoDB
persistent-mongoDB
persistent-mysql
persistent-postgresql
persistent-redis
Expand Down
4 changes: 4 additions & 0 deletions persistent-mongoDB/ChangeLog.md
Original file line number Diff line number Diff line change
@@ -1,5 +1,9 @@
# Changelog for persistent-mongoDB

## 2.13.0.0

* Fix persistent 2.13 changes [#1286](https://github.com/yesodweb/persistent/pull/1286)

## 2.12.0.0

* Decomposed `HaskellName` into `ConstraintNameHS`, `EntityNameHS`, `FieldNameHS`. Decomposed `DBName` into `ConstraintNameDB`, `EntityNameDB`, `FieldNameDB` respectively. [#1174](https://github.com/yesodweb/persistent/pull/1174)
Expand Down
64 changes: 40 additions & 24 deletions persistent-mongoDB/Database/Persist/MongoDB.hs
Original file line number Diff line number Diff line change
Expand Up @@ -112,31 +112,40 @@ module Database.Persist.MongoDB
, module Database.Persist
) where

import qualified Data.List.NonEmpty as NEL
import Control.Exception (throw, throwIO)
import Control.Monad (liftM, (>=>), forM_, unless)
import Control.Monad (forM_, liftM, unless, (>=>))
import Control.Monad.IO.Class (liftIO)
import qualified Control.Monad.IO.Class as Trans
import Control.Monad.IO.Unlift (MonadUnliftIO, withRunInIO)
import Control.Monad.Trans.Reader (ask, runReaderT)
import qualified Data.List.NonEmpty as NEL

import Data.Acquire (mkAcquire)
import Data.Aeson (Value (Number), (.:), (.:?), (.!=), FromJSON(..), ToJSON(..), withText, withObject)
import Data.Aeson
( FromJSON(..)
, ToJSON(..)
, Value(Number)
, withObject
, withText
, (.!=)
, (.:)
, (.:?)
)
import Data.Aeson.Types (modifyFailure)
import Data.Bits (shiftR)
import Data.Bson (ObjectId(..))
import qualified Data.ByteString as BS
import Data.Conduit
import Data.Maybe (mapMaybe, fromJust)
import Data.Maybe (fromJust, mapMaybe)
import Data.Monoid (mappend)
import qualified Data.Pool as Pool
import qualified Data.Serialize as Serialize
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as E
import qualified Data.Traversable as Traversable
import qualified Data.Pool as Pool
import Data.Time (NominalDiffTime)
import Data.Time.Calendar (Day(..))
import qualified Data.Traversable as Traversable
#ifdef HIGH_PRECISION_DATE
import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds)
#endif
Expand All @@ -145,8 +154,14 @@ import Network.Socket (HostName)
import Numeric (readHex)
import System.Environment (lookupEnv)
import Unsafe.Coerce (unsafeCoerce)
import Web.HttpApiData
( FromHttpApiData(..)
, ToHttpApiData(..)
, parseUrlPieceMaybe
, parseUrlPieceWithPrefix
, readTextData
)
import Web.PathPieces (PathPiece(..))
import Web.HttpApiData (ToHttpApiData(..), FromHttpApiData(..), parseUrlPieceMaybe, parseUrlPieceWithPrefix, readTextData)

#ifdef DEBUG
import FileLocation (debug)
Expand All @@ -156,8 +171,8 @@ import qualified Database.MongoDB as DB
import Database.MongoDB.Query (Database)

import Database.Persist
import qualified Database.Persist.Sql as Sql
import Database.Persist.EntityDef.Internal (toEmbedEntityDef)
import qualified Database.Persist.Sql as Sql

instance HasPersistBackend DB.MongoContext where
type BaseBackend DB.MongoContext = DB.MongoContext
Expand Down Expand Up @@ -430,15 +445,18 @@ toInsertDoc record =
DB.:=
embeddedVal pv
)
$ filter (\(_, pv) -> isNull pv)
$ filter (\(_, pv) -> not $ isNull pv)
$ zip xs ys
where
isNull PersistNull = True
isNull (PersistMap m) = null m
isNull (PersistList l) = null l
isNull _ = False

-- make sure to removed nulls from embedded entities also
-- make sure to removed nulls from embedded entities also.
-- note that persistent no longer supports embedded maps
-- with fields. This means any embedded bson object will
-- insert null. But top level will not.
embeddedVal :: PersistValue -> DB.Value
embeddedVal (PersistMap m) =
DB.Doc $ fmap (\(k, v) -> k DB.:= DB.val v) $ m
Expand Down Expand Up @@ -989,25 +1007,24 @@ orderPersistValues entDef castDoc =
-- another application may use fields we don't care about
-- our own application may set extra fields with the raw driver
match [] _ values = values
match ((fieldName, medef) : columns) fields values =
match ((fName, medef) : columns) fields values =
let
((_, pv) , unused) =
matchOne fields []
in
match columns unused $
values ++ [(fieldName, nestedOrder medef pv)]
values ++ [(fName, nestedOrder medef pv)]
where
nestedOrder (Just _) (PersistMap m) =
PersistMap m
nestedOrder (Just em) (PersistList l) =
PersistList $ map (nestedOrder (Just em)) l
nestedOrder Nothing found =
found
-- support for embedding other persistent objects into a schema for
-- mongodb cannot be currently supported in persistent.
-- The order will be undetermined but that's ok because there is no
-- schema migration for mongodb anyways.
-- nestedOrder (Just _) (PersistMap m) = PersistMap m
nestedOrder (Just em) (PersistList l) = PersistList $ map (nestedOrder (Just em)) l
nestedOrder _ found = found

matchOne (field:fs) tried =
if fieldName == fst field
-- snd drops the name now that it has been used to make the match
-- persistent will add the field name later
if fName == fst field
then (field, tried ++ fs)
else matchOne fs (field:tried)
-- if field is not found, assume it was a Nothing
Expand All @@ -1016,7 +1033,7 @@ orderPersistValues entDef castDoc =
-- instead, we want to store no field at all: that takes less space.
-- Also, another ORM may be doing the same
-- Also, this adding a Maybe field means no migration required
matchOne [] tried = ((fieldName, PersistNull), tried)
matchOne [] tried = ((fName, PersistNull), tried)

assocListFromDoc :: DB.Document -> [(Text, PersistValue)]
assocListFromDoc = Prelude.map (\f -> ( (DB.label f), cast (DB.value f) ) )
Expand Down Expand Up @@ -1057,8 +1074,7 @@ instance DB.Val PersistValue where
val (PersistRational _) = throw $ PersistMongoDBUnsupported "PersistRational not implemented for the MongoDB backend"
val (PersistArray a) = DB.val $ PersistList a
val (PersistDbSpecific _) = throw $ PersistMongoDBUnsupported "PersistDbSpecific not implemented for the MongoDB backend"
val (PersistLiteral _) = throw $ PersistMongoDBUnsupported "PersistLiteral not implemented for the MongoDB backend"
val (PersistLiteralEscaped _) = throw $ PersistMongoDBUnsupported "PersistLiteralEscaped not implemented for the MongoDB backend"
val (PersistLiteral_ _ _) = throw $ PersistMongoDBUnsupported "PersistLiteral not implemented for the MongoDB backend"
cast' (DB.Float x) = Just (PersistDouble x)
cast' (DB.Int32 x) = Just $ PersistInt64 $ fromIntegral x
cast' (DB.Int64 x) = Just $ PersistInt64 x
Expand Down
4 changes: 2 additions & 2 deletions persistent-mongoDB/persistent-mongoDB.cabal
Original file line number Diff line number Diff line change
@@ -1,9 +1,9 @@
name: persistent-mongoDB
version: 2.12.0.0
version: 2.13.0.0
license: MIT
license-file: LICENSE
author: Greg Weber <[email protected]>
maintainer: Greg Weber <[email protected]>
maintainer: Andres Schmois <[email protected]>
synopsis: Backend for the persistent library using mongoDB.
category: Database
stability: Experimental
Expand Down
14 changes: 5 additions & 9 deletions persistent-mongoDB/test/main.hs
Original file line number Diff line number Diff line change
Expand Up @@ -103,8 +103,7 @@ EmptyEntity
main :: IO ()
main = do
hspec $ afterAll dropDatabase $ do
xdescribe "This test is failing for Mongo by only embedding the first thing." $ do
RenameTest.specsWith (db' RenameTest.cleanDB)
RenameTest.specsWith (db' RenameTest.cleanDB)
DataTypeTest.specsWith
dbNoCleanup
Nothing
Expand Down Expand Up @@ -135,13 +134,10 @@ main = do
dbNoCleanup
Nothing
PersistentTest.specsWith (db' PersistentTest.cleanDB)
-- TODO: The upsert tests are currently failing. Find out why and fix
-- them.
xdescribe "UpsertTest is currently failing for Mongo due to differing behavior" $ do
UpsertTest.specsWith
(db' PersistentTest.cleanDB)
UpsertTest.AssumeNullIsZero
UpsertTest.UpsertGenerateNewKey
UpsertTest.specsWith
(db' PersistentTest.cleanDB)
UpsertTest.AssumeNullIsZero
UpsertTest.UpsertGenerateNewKey
EmptyEntityTest.specsWith
(db' EmptyEntityTest.cleanDB)
Nothing
Expand Down
2 changes: 2 additions & 0 deletions persistent-test/src/PersistentTestModels.hs
Original file line number Diff line number Diff line change
Expand Up @@ -239,3 +239,5 @@ cleanDB = do
deleteWhere ([] :: [Filter (OutdoorPetGeneric backend)])
deleteWhere ([] :: [Filter (UserPTGeneric backend)])
deleteWhere ([] :: [Filter (EmailPTGeneric backend)])
deleteWhere ([] :: [Filter (UpsertGeneric backend)])
deleteWhere ([] :: [Filter (UpsertByGeneric backend)])
2 changes: 1 addition & 1 deletion stack-nightly.yaml
Original file line number Diff line number Diff line change
Expand Up @@ -3,7 +3,7 @@ packages:
- ./persistent
- ./persistent-sqlite
- ./persistent-test
# - ./persistent-mongoDB
- ./persistent-mongoDB
- ./persistent-mysql
- ./persistent-postgresql
- ./persistent-redis
Expand Down
2 changes: 1 addition & 1 deletion stack.yaml
Original file line number Diff line number Diff line change
Expand Up @@ -3,7 +3,7 @@ packages:
- ./persistent
- ./persistent-sqlite
- ./persistent-test
# - ./persistent-mongoDB
- ./persistent-mongoDB
- ./persistent-mysql
- ./persistent-postgresql
- ./persistent-redis
Expand Down

0 comments on commit 5dbd756

Please sign in to comment.