Merge pull request #72 from centromere/parent-support

Added parent support to documentExists

src/Database/Bloodhound/Client.hs

@@ -68,7 +68,8 @@ import           Data.ByteString.Lazy.Builder
 import qualified Data.ByteString.Lazy.Char8   as L
 import           Data.Default.Class
 import           Data.Ix
-import           Data.Maybe                   (fromMaybe)
+import qualified Data.List                    as LS (filter)
+import           Data.Maybe                   (fromMaybe, isJust)
 import           Data.Monoid
 import           Data.Text                    (Text)
 import qualified Data.Text                    as T
@@ -499,14 +500,16 @@ getDocument (IndexName indexName)
 -- | 'documentExists' enables you to check if a document exists. Returns 'Bool'
 --   in IO
 --
--- >>> exists <- runBH' $ documentExists testIndex testMapping (DocId "1")
+-- >>> exists <- runBH' $ documentExists testIndex testMapping Nothing (DocId "1")
 documentExists :: MonadBH m => IndexName -> MappingName
-                  -> DocId -> m Bool
-documentExists (IndexName indexName)
-  (MappingName mappingName) (DocId docId) = do
+               -> Maybe DocumentParent -> DocId -> m Bool
+documentExists (IndexName indexName) (MappingName mappingName)
+               parent (DocId docId) = do
   (_, exists) <- existentialQuery =<< url
   return exists
-  where url = joinPath [indexName, mappingName, docId]
+  where url = addQuery params <$> joinPath [indexName, mappingName, docId]
+        parentParam = fmap (\(DocumentParent (DocId p)) -> p) parent
+        params = LS.filter (\(_, v) -> isJust v) [("parent", parentParam)]
 
 dispatchSearch :: MonadBH m => Text -> Search -> m Reply
 dispatchSearch url search = post url' (Just (encode search))

tests/tests.hs

@@ -116,6 +116,20 @@ instance FromJSON Tweet
 instance ToJSON   Location
 instance FromJSON Location
 
+data ParentMapping = ParentMapping deriving (Eq, Show)
+
+instance ToJSON ParentMapping where
+  toJSON ParentMapping =
+    object ["parent" .= Null ]
+
+data ChildMapping = ChildMapping deriving (Eq, Show)
+
+instance ToJSON ChildMapping where
+  toJSON ChildMapping =
+    object ["child" .=
+      object ["_parent" .= object ["type" .= ("parent" :: Text)]]
+    ]
+
 data TweetMapping = TweetMapping deriving (Eq, Show)
 
 instance ToJSON TweetMapping where
@@ -330,6 +344,18 @@ main = hspec $ do
       res' <- insertData' cfg
       liftIO $ isVersionConflict res' `shouldBe` True
 
+    it "indexes two documents in a parent/child relationship and checks that the child exists" $ withTestEnv $ do
+      resetIndex
+      _ <- putMapping testIndex (MappingName "parent") ParentMapping
+      _ <- putMapping testIndex (MappingName "child") ChildMapping
+      _ <- indexDocument testIndex (MappingName "parent") defaultIndexDocumentSettings exampleTweet (DocId "1")
+      let parent = (Just . DocumentParent . DocId) "1"
+          ids = IndexDocumentSettings NoVersionControl parent
+      _ <- indexDocument testIndex (MappingName "child") ids otherTweet (DocId "2")
+      _ <- refreshIndex testIndex
+      exists <- documentExists testIndex (MappingName "child") parent (DocId "2")
+      liftIO $ exists `shouldBe` True
+
   describe "template API" $ do
     it "can create a template" $ withTestEnv $ do
       let idxTpl = IndexTemplate (TemplatePattern "tweet-*") (Just (IndexSettings (ShardCount 1) (ReplicaCount 1))) [toJSON TweetMapping]