module EmbedTest (specs,
#ifndef WITH_NOSQL
embedMigrate
#endif
) where
import Init
import Control.Exception (Exception, throw)
import Data.Typeable (Typeable)
import qualified Data.Text as T
import qualified Data.Set as S
import qualified Data.Map as M
#if WITH_NOSQL
#ifdef WITH_MONGODB
import Database.Persist.MongoDB
import Database.MongoDB (genObjectId)
import Database.MongoDB (Value(String))
#endif
import EntityEmbedTest
import System.Process (readProcess)
#endif
import Data.List.NonEmpty hiding (insert, length)
data TestException = TestException
deriving (Show, Typeable, Eq)
instance Exception TestException
instance PersistFieldSql a => PersistFieldSql (NonEmpty a) where
sqlType _ = SqlString
instance PersistField a => PersistField (NonEmpty a) where
toPersistValue = toPersistValue . toList
fromPersistValue pv = case fromPersistValue pv of
Left e -> Left e
Right [] -> Left "PersistField: NonEmpty found unexpected Empty List"
Right (l:ls) -> Right (l:|ls)
#if WITH_NOSQL
mkPersist persistSettings [persistUpperCase|
# ifdef WITH_MONGODB
HasObjectId
oid ObjectId
name Text
deriving Show Eq Read Ord
HasArrayWithObjectIds
name Text
arrayWithObjectIds [HasObjectId]
deriving Show Eq Read Ord
HasArrayWithEntities
hasEntity (Entity ARecord)
arrayWithEntities [AnEntity]
deriving Show Eq Read Ord
# endif
#else
share [mkPersist sqlSettings, mkMigrate "embedMigrate"] [persistUpperCase|
#endif
OnlyName
name Text
deriving Show Eq Read Ord
HasEmbed
name Text
embed OnlyName
deriving Show Eq Read Ord
HasEmbeds
name Text
embed OnlyName
double HasEmbed
deriving Show Eq Read Ord
HasListEmbed
name Text
list [HasEmbed]
deriving Show Eq Read Ord
HasSetEmbed
name Text
set (S.Set HasEmbed)
deriving Show Eq Read Ord
HasMap
name Text
map (M.Map T.Text T.Text)
deriving Show Eq Read Ord
HasList
list [HasListId]
deriving Show Eq Read Ord
EmbedsHasMap
name Text Maybe
embed HasMap
deriving Show Eq Read Ord
InList
one Int
two Int
deriving Show Eq
ListEmbed
nested [InList]
one Int
two Int
deriving Show Eq
User
ident Text
password Text Maybe
profile Profile
deriving Show Eq Read Ord
Profile
firstName Text
lastName Text
contact Contact Maybe
deriving Show Eq Read Ord
Contact
phone Int
email T.Text
deriving Show Eq Read Ord
Account
userIds (NonEmpty (Key User))
name Text Maybe
customDomains [Text]
deriving Show Eq Read Ord
HasNestedList
list [IntList]
deriving Show Eq
IntList
ints [Int]
deriving Show Eq
MapIdValue
map (M.Map T.Text (Key OnlyName))
deriving Show Eq Read Ord
SelfList
reference [SelfList]
SelfMaybe
reference SelfMaybe Maybe
|]
#ifdef WITH_NOSQL
cleanDB :: (PersistQuery backend, PersistEntityBackend HasMap ~ backend, MonadIO m) => ReaderT backend m ()
cleanDB = do
deleteWhere ([] :: [Filter HasEmbed])
deleteWhere ([] :: [Filter HasEmbeds])
deleteWhere ([] :: [Filter HasListEmbed])
deleteWhere ([] :: [Filter HasSetEmbed])
deleteWhere ([] :: [Filter User])
deleteWhere ([] :: [Filter HasMap])
deleteWhere ([] :: [Filter HasList])
deleteWhere ([] :: [Filter EmbedsHasMap])
deleteWhere ([] :: [Filter ListEmbed])
deleteWhere ([] :: [Filter ARecord])
deleteWhere ([] :: [Filter Account])
deleteWhere ([] :: [Filter HasNestedList])
db :: Action IO () -> Assertion
db = db' cleanDB
#endif
unlessM :: MonadIO m => IO Bool -> m () -> m ()
unlessM predicate body = do
b <- liftIO predicate
unless b body
specs :: Spec
specs = describe "embedded entities" $ do
it "simple entities" $ db $ do
let container = HasEmbeds "container" (OnlyName "2")
(HasEmbed "embed" (OnlyName "1"))
contK <- insert container
Just res <- selectFirst [HasEmbedsName ==. "container"] []
res @== Entity contK container
it "query for equality of embeded entity" $ db $ do
let container = HasEmbed "container" (OnlyName "2")
contK <- insert container
Just res <- selectFirst [HasEmbedEmbed ==. OnlyName "2"] []
res @== Entity contK container
it "Set" $ db $ do
let container = HasSetEmbed "set" $ S.fromList
[ HasEmbed "embed" (OnlyName "1")
, HasEmbed "embed" (OnlyName "2")
]
contK <- insert container
Just res <- selectFirst [HasSetEmbedName ==. "set"] []
res @== Entity contK container
it "Set empty" $ db $ do
let container = HasSetEmbed "set empty" $ S.fromList []
contK <- insert container
Just res <- selectFirst [HasSetEmbedName ==. "set empty"] []
res @== Entity contK container
it "exception" $ flip shouldThrow (== TestException) $ db $ do
let container = HasSetEmbed "set" $ S.fromList
[ HasEmbed "embed" (OnlyName "1")
, HasEmbed "embed" (OnlyName "2")
]
contK <- insert container
Just res <- selectFirst [HasSetEmbedName ==. throw TestException] []
res @== Entity contK container
it "ListEmbed" $ db $ do
let container = HasListEmbed "list"
[ HasEmbed "embed" (OnlyName "1")
, HasEmbed "embed" (OnlyName "2")
]
contK <- insert container
Just res <- selectFirst [HasListEmbedName ==. "list"] []
res @== Entity contK container
it "ListEmbed empty" $ db $ do
let container = HasListEmbed "list empty" []
contK <- insert container
Just res <- selectFirst [HasListEmbedName ==. "list empty"] []
res @== Entity contK container
it "List empty" $ db $ do
let container = HasList []
contK <- insert container
Just res <- selectFirst [] []
res @== Entity contK container
it "NonEmpty List wrapper" $ db $ do
let con = Contact 123456 "foo@bar.com"
let prof = Profile "fstN" "lstN" (Just con)
uid <- insert $ User "foo" (Just "pswd") prof
let container = Account (uid:|[]) (Just "Account") []
contK <- insert container
Just res <- selectFirst [AccountUserIds ==. (uid:|[])] []
res @== Entity contK container
it "Map" $ db $ do
let container = HasMap "2 items" $ M.fromList [
("k1","v1")
, ("k2","v2")
]
contK <- insert container
Just res <- selectFirst [HasMapName ==. "2 items"] []
res @== Entity contK container
it "Map empty" $ db $ do
let container = HasMap "empty" $ M.fromList []
contK <- insert container
Just res <- selectFirst [HasMapName ==. "empty"] []
res @== Entity contK container
it "Embeds a Map" $ db $ do
let container = EmbedsHasMap (Just "non-empty map") $ HasMap "2 items" $ M.fromList [
("k1","v1")
, ("k2","v2")
]
contK <- insert container
Just res <- selectFirst [EmbedsHasMapName ==. Just "non-empty map"] []
res @== Entity contK container
it "Embeds a Map empty" $ db $ do
let container = EmbedsHasMap (Just "empty map") $ HasMap "empty" $ M.fromList []
contK <- insert container
Just res <- selectFirst [EmbedsHasMapName ==. (Just "empty map")] []
res @== Entity contK container
it "Embeds a Map with ids as values" $ db $ do
onId <- insert $ OnlyName "nombre"
onId2 <- insert $ OnlyName "nombre2"
let midValue = MapIdValue $ M.fromList [("foo", onId),("bar",onId2)]
mK <- insert midValue
Just mv <- get mK
mv @== midValue
#ifdef WITH_NOSQL
#ifdef WITH_MONGODB
it "List" $ db $ do
k1 <- insert $ HasList []
k2 <- insert $ HasList [k1]
let container = HasList [k1, k2]
contK <- insert container
Just res <- selectFirst [HasListList `anyEq` k2] []
res @== Entity contK container
it "can embed an Entity" $ db $ do
let foo = ARecord "foo"
bar = ARecord "bar"
_ <- insertMany [foo, bar]
arecords <- selectList ([ARecordName ==. "foo"] ||. [ARecordName ==. "bar"]) []
length arecords @== 2
kfoo <- insert foo
let hasEnts = HasArrayWithEntities (Entity kfoo foo) arecords
kEnts <- insert hasEnts
Just retrievedHasEnts <- get kEnts
retrievedHasEnts @== hasEnts
it "can embed objects with ObjectIds" $ db $ do
oid <- liftIO $ genObjectId
let hoid = HasObjectId oid "oid"
hasArr = HasArrayWithObjectIds "array" [hoid]
k <- insert hasArr
Just v <- get k
v @== hasArr
describe "mongoDB filters" $ do
it "mongo single nesting filters" $ db $ do
let usr = User "foo" (Just "pswd") prof
prof = Profile "fstN" "lstN" (Just con)
con = Contact 123456 "foo@bar.com"
uId <- insert usr
Just r1 <- selectFirst [UserProfile &->. ProfileFirstName `nestEq` "fstN"] []
r1 @== (Entity uId usr)
Just r2 <- selectFirst [UserProfile &~>. ProfileContact ?&->. ContactEmail `nestEq` "foo@bar.com", UserIdent ==. "foo"] []
r2 @== (Entity uId usr)
it "mongo embedded array filters" $ db $ do
let container = HasListEmbed "list" [
(HasEmbed "embed" (OnlyName "1"))
, (HasEmbed "embed" (OnlyName "2"))
]
contK <- insert container
let contEnt = Entity contK container
Just meq <- selectFirst [HasListEmbedList `anyEq` HasEmbed "embed" (OnlyName "1")] []
meq @== contEnt
Just neq1 <- selectFirst [HasListEmbedList ->. HasEmbedName `nestEq` "embed"] []
neq1 @== contEnt
Just nne1 <- selectFirst [HasListEmbedList ->. HasEmbedName `nestNe` "notEmbed"] []
nne1 @== contEnt
Just neq2 <- selectFirst [HasListEmbedList ~>. HasEmbedEmbed &->. OnlyNameName `nestEq` "1"] []
neq2 @== contEnt
Just nbq1 <- selectFirst [HasListEmbedList ->. HasEmbedName `nestBsonEq` String "embed"] []
nbq1 @== contEnt
Just nbq2 <- selectFirst [HasListEmbedList ~>. HasEmbedEmbed &->. OnlyNameName `nestBsonEq` String "1"] []
nbq2 @== contEnt
it "regexp match" $ db $ do
let container = HasListEmbed "list" [
(HasEmbed "embed" (OnlyName "abcd"))
, (HasEmbed "embed" (OnlyName "efgh"))
]
contK <- insert container
let mkReg t = (t, "ims")
Just res <- selectFirst [HasListEmbedName =~. mkReg "ist"] []
res @== (Entity contK container)
it "nested anyEq" $ db $ do
let top = HasNestedList [IntList [1,2]]
k <- insert top
Nothing <- selectFirst [HasNestedListList ->. IntListInts `nestEq` ([]::[Int])] []
Nothing <- selectFirst [HasNestedListList ->. IntListInts `nestAnyEq` 3] []
Just res <- selectFirst [HasNestedListList ->. IntListInts `nestAnyEq` 2] []
res @== (Entity k top)
describe "mongoDB updates" $ do
it "mongo single nesting updates" $ db $ do
let usr = User "foo" (Just "pswd") prof
prof = Profile "fstN" "lstN" (Just con)
con = Contact 123456 "foo@bar.com"
uid <- insert usr
let newName = "fstN2"
usr1 <- updateGet uid [UserProfile &->. ProfileFirstName `nestSet` newName]
(profileFirstName $ userProfile usr1) @== newName
let newEmail = "foo@example.com"
let newIdent = "bar"
usr2 <- updateGet uid [UserProfile &~>. ProfileContact ?&->. ContactEmail `nestSet` newEmail, UserIdent =. newIdent]
(userIdent usr2) @== newIdent
(fmap contactEmail . profileContact . userProfile $ usr2) @== Just newEmail
it "mongo embedded array updates" $ db $ do
let container = HasListEmbed "list" [
(HasEmbed "embed" (OnlyName "1"))
, (HasEmbed "embed" (OnlyName "2"))
]
contk <- insert container
let contEnt = Entity contk container
pushed <- updateGet contk [HasListEmbedList `push` HasEmbed "embed" (OnlyName "3")]
(Prelude.map (onlyNameName . hasEmbedEmbed) $ hasListEmbedList pushed) @== ["1","2","3"]
addedToSet <- updateGet contk [HasListEmbedList `addToSet` HasEmbed "embed" (OnlyName "3")]
(Prelude.map (onlyNameName . hasEmbedEmbed) $ hasListEmbedList addedToSet) @== ["1","2","3"]
pulled <- updateGet contk [HasListEmbedList `pull` HasEmbed "embed" (OnlyName "3")]
(Prelude.map (onlyNameName . hasEmbedEmbed) $ hasListEmbedList pulled) @== ["1","2"]
addedToSet2 <- updateGet contk [HasListEmbedList `addToSet` HasEmbed "embed" (OnlyName "3")]
(Prelude.map (onlyNameName . hasEmbedEmbed) $ hasListEmbedList addedToSet2) @== ["1","2","3"]
allPulled <- updateGet contk [eachOp pull HasListEmbedList
[ HasEmbed "embed" (OnlyName "3")
, HasEmbed "embed" (OnlyName "2")
] ]
(Prelude.map (onlyNameName . hasEmbedEmbed) $ hasListEmbedList allPulled) @== ["1"]
allPushed <- updateGet contk [eachOp push HasListEmbedList
[ HasEmbed "embed" (OnlyName "4")
, HasEmbed "embed" (OnlyName "5")
] ]
(Prelude.map (onlyNameName . hasEmbedEmbed) $ hasListEmbedList allPushed) @== ["1","4","5"]
it "re-orders json inserted from another source" $ db $ do
let cname = T.unpack $ collectionName (error "ListEmbed" :: ListEmbed)
liftIO $ putStrLn =<< readProcess "mongoimport" ["-d", T.unpack dbName, "-c", cname] "{ \"nested\": [{ \"one\": 1, \"two\": 2 }, { \"two\": 2, \"one\": 1}], \"two\": 2, \"one\": 1, \"_id\" : { \"$oid\" : \"50184f5a92d7ae0000001e89\" } }"
lists <- selectList [] []
fmap entityVal lists @== [ListEmbed [InList 1 2, InList 1 2] 1 2]
#endif
#endif