git.iko.soy/typeable/bloodhound
on master help sign in
Added map to deal with highlight response
e26032bLiam Atkinson
Database/Bloodhound/Types.hs+24−21
compare with master
unifiedsplit
@@ -173,6 +173,7 @@ module Database.Bloodhound.Types
173 , NonPostings(..)
173 , NonPostings(..)
174 , HighlightEncoder(..)
174 , HighlightEncoder(..)
175 , HighlightTag(..)
175 , HighlightTag(..)
176+ , HitHighlight
176
177
177 , TermsResult
178 , TermsResult
178 , DateHistogramResult
179 , DateHistogramResult
@@ -551,7 +552,6 @@ data FastVectorHighlight =
551
552
552data CommonHighlight =
553data CommonHighlight =
553 CommonHighlight {
554 CommonHighlight {
554− -- highlightType :: Maybe HighlightType -- See below.
555 forceSource :: Maybe Bool
555 forceSource :: Maybe Bool
556 , tag :: Maybe HighlightTag
556 , tag :: Maybe HighlightTag
557 , encoder :: Maybe HighlightEncoder
557 , encoder :: Maybe HighlightEncoder
@@ -559,6 +559,7 @@ data CommonHighlight =
559 , highlightQuery :: Maybe Query
559 , highlightQuery :: Maybe Query
560 , requireFieldMatch :: Maybe Bool
560 , requireFieldMatch :: Maybe Bool
561 } deriving (Show, Eq)
561 } deriving (Show, Eq)
562+
562-- Settings that are only applicable to FastVector and Plain highlighters.
563-- Settings that are only applicable to FastVector and Plain highlighters.
563data NonPostings =
564data NonPostings =
564 NonPostings { fragmentSize :: Maybe Int
565 NonPostings { fragmentSize :: Maybe Int
@@ -1007,7 +1008,7 @@ data DistanceRange =
1007 DistanceRange { distanceFrom :: Distance
1008 DistanceRange { distanceFrom :: Distance
1008 , distanceTo :: Distance } deriving (Eq, Show)
1009 , distanceTo :: Distance } deriving (Eq, Show)
1009
1010
1010−data FromJSON a => SearchResult a =
1011+data (FromJSON a) => SearchResult a =
1011 SearchResult { took :: Int
1012 SearchResult { took :: Int
1012 , timedOut :: Bool
1013 , timedOut :: Bool
1013 , shards :: ShardResult
1014 , shards :: ShardResult
@@ -1016,24 +1017,26 @@ data FromJSON a => SearchResult a =
1016
1017
1017type Score = Double
1018type Score = Double
1018
1019
1019−data FromJSON a => SearchHits a =
1020+data (FromJSON a) => SearchHits a =
1020 SearchHits { hitsTotal :: Int
1021 SearchHits { hitsTotal :: Int
1021 , maxScore :: Score
1022 , maxScore :: Score
1022 , hits :: [Hit a] } deriving (Eq, Show)
1023 , hits :: [Hit a] } deriving (Eq, Show)
1023
1024
1024−data FromJSON a => Hit a =
1025+data (FromJSON a) => Hit a =
1025 Hit { hitIndex :: IndexName
1026 Hit { hitIndex :: IndexName
1026 , hitType :: MappingName
1027 , hitType :: MappingName
1027 , hitDocId :: DocId
1028 , hitDocId :: DocId
1028 , hitScore :: Score
1029 , hitScore :: Score
1029 , hitSource :: a
1030 , hitSource :: a
1030− , hitHighlight :: Maybe Text } deriving (Eq, Show)
1031+ , hitHighlight :: Maybe HitHighlight } deriving (Eq, Show)
1031
1032
1032data ShardResult =
1033data ShardResult =
1033 ShardResult { shardTotal :: Int
1034 ShardResult { shardTotal :: Int
1034 , shardsSuccessful :: Int
1035 , shardsSuccessful :: Int
1035 , shardsFailed :: Int } deriving (Eq, Show, Generic)
1036 , shardsFailed :: Int } deriving (Eq, Show, Generic)
1036
1037
1038+type HitHighlight = M.Map Text [Text]
1039+
1037showText :: Show a => a -> Text
1040showText :: Show a => a -> Text
1038showText = T.pack . show
1041showText = T.pack . show
1039
1042
@@ -1825,13 +1828,13 @@ instance (FromJSON a) => FromJSON (EsResult a) where
1825
1828
1826instance ToJSON Search where
1829instance ToJSON Search where
1827 toJSON (Search query sFilter sort aggs highlight sTrackSortScores sFrom sSize) =
1830 toJSON (Search query sFilter sort aggs highlight sTrackSortScores sFrom sSize) =
1828− omitNulls [ "query" .= query
1831+ omitNulls [ "query" .= query
1829− , "filter" .= sFilter
1832+ , "filter" .= sFilter
1830− , "sort" .= sort
1833+ , "sort" .= sort
1831 , "aggregations" .= aggs
1834 , "aggregations" .= aggs
1832− , "highlight" .= highlight
1835+ , "highlight" .= highlight
1833− , "from" .= sFrom
1836+ , "from" .= sFrom
1834− , "size" .= sSize
1837+ , "size" .= sSize
1835 , "track_scores" .= sTrackSortScores]
1838 , "track_scores" .= sTrackSortScores]
1836
1839
1837instance ToJSON FieldHighlight where
1840instance ToJSON FieldHighlight where
@@ -1842,8 +1845,8 @@ instance ToJSON FieldHighlight where
1842
1845
1843instance ToJSON Highlights where
1846instance ToJSON Highlights where
1844 toJSON (Highlights global fields) =
1847 toJSON (Highlights global fields) =
1845− omitNulls (["fields" .= toJSON fields]
1848+ omitNulls (("fields" .= toJSON fields)
1846− ++ (highlightSettingsPairs global))
1849+ : highlightSettingsPairs global)
1847
1850
1848instance ToJSON HighlightSettings where
1851instance ToJSON HighlightSettings where
1849 toJSON hs = omitNulls (highlightSettingsPairs (Just hs))
1852 toJSON hs = omitNulls (highlightSettingsPairs (Just hs))
@@ -1859,14 +1862,14 @@ plainHighPairs :: Maybe PlainHighlight -> [Pair]
1859plainHighPairs Nothing = []
1862plainHighPairs Nothing = []
1860plainHighPairs (Just (PlainHighlight plCom plNonPost)) =
1863plainHighPairs (Just (PlainHighlight plCom plNonPost)) =
1861 [ "type" .= String "plain"]
1864 [ "type" .= String "plain"]
1862− ++ (commonHighlightPairs plCom)
1865+ ++ commonHighlightPairs plCom
1863− ++ (nonPostingsToPairs plNonPost)
1866+ ++ nonPostingsToPairs plNonPost
1864
1867
1865postHighPairs :: Maybe PostingsHighlight -> [Pair]
1868postHighPairs :: Maybe PostingsHighlight -> [Pair]
1866postHighPairs Nothing = []
1869postHighPairs Nothing = []
1867postHighPairs (Just (PostingsHighlight pCom)) =
1870postHighPairs (Just (PostingsHighlight pCom)) =
1868− [ "type" .= String "postings" ]
1871+ ("type" .= String "postings")
1869− ++ (commonHighlightPairs pCom)
1872+ : commonHighlightPairs pCom
1870
1873
1871fastVectorHighPairs :: Maybe FastVectorHighlight -> [Pair]
1874fastVectorHighPairs :: Maybe FastVectorHighlight -> [Pair]
1872fastVectorHighPairs Nothing = []
1875fastVectorHighPairs Nothing = []
@@ -1880,8 +1883,8 @@ fastVectorHighPairs (Just
1880 , "fragment_offset" .= fvFragOff
1883 , "fragment_offset" .= fvFragOff
1881 , "matched_fields" .= fvMatchedFields
1884 , "matched_fields" .= fvMatchedFields
1882 , "phraseLimit" .= fvPhraseLim]
1885 , "phraseLimit" .= fvPhraseLim]
1883− ++ (commonHighlightPairs fvCom)
1886+ ++ commonHighlightPairs fvCom
1884− ++ (nonPostingsToPairs fvNonPostSettings)
1887+ ++ nonPostingsToPairs fvNonPostSettings
1885
1888
1886commonHighlightPairs :: Maybe CommonHighlight -> [Pair]
1889commonHighlightPairs :: Maybe CommonHighlight -> [Pair]
1887commonHighlightPairs Nothing = []
1890commonHighlightPairs Nothing = []
@@ -1893,7 +1896,7 @@ commonHighlightPairs (Just (CommonHighlight chForceSource chTag chEncoder
1893 , "no_match_size" .= chNoMatchSize
1896 , "no_match_size" .= chNoMatchSize
1894 , "highlight_query" .= chHighlightQuery
1897 , "highlight_query" .= chHighlightQuery
1895 , "require_fieldMatch" .= chRequireFieldMatch]
1898 , "require_fieldMatch" .= chRequireFieldMatch]
1896− ++ (highlightTagToPairs chTag)
1899+ ++ highlightTagToPairs chTag
1897
1900
1898
1901
1899nonPostingsToPairs :: Maybe NonPostings -> [Pair]
1902nonPostingsToPairs :: Maybe NonPostings -> [Pair]
@@ -2072,7 +2075,7 @@ instance (FromJSON a) => FromJSON (Hit a) where
2072 parseJSON _ = empty
2075 parseJSON _ = empty
2073
2076
2074instance FromJSON ShardResult where
2077instance FromJSON ShardResult where
2075− parseJSON (Object v) = ShardResult <$>
2078+ parseJSON (Object v) = ShardResult <$>
2076 v .: "total" <*>
2079 v .: "total" <*>
2077 v .: "successful" <*>
2080 v .: "successful" <*>
2078 v .: "failed"
2081 v .: "failed"
tests/tests.hs+15−9
@@ -3,8 +3,6 @@
3
3
4module Main where
4module Main where
5
5
6−import Debug.Trace
7−
8import Control.Applicative
6import Control.Applicative
9import Control.Monad
7import Control.Monad
10import Data.Aeson
8import Data.Aeson
@@ -185,11 +183,9 @@ searchTermsAggHint hints = do
185 forM_ hints $ searchExpectAggs . search
183 forM_ hints $ searchExpectAggs . search
186 forM_ hints (\x -> searchValidBucketAgg (search x) "users" toTerms)
184 forM_ hints (\x -> searchValidBucketAgg (search x) "users" toTerms)
187
185
188−searchTweetHighlight :: Search -> IO (Either String (Maybe Text))
186+searchTweetHighlight :: Search -> IO (Either String (Maybe HitHighlight))
189searchTweetHighlight search = do
187searchTweetHighlight search = do
190 reply <- searchByIndex testServer testIndex search
188 reply <- searchByIndex testServer testIndex search
191− traceShowM search
192− traceShowM reply
193 let result = eitherDecode (responseBody reply) :: Either String (SearchResult Tweet)
189 let result = eitherDecode (responseBody reply) :: Either String (SearchResult Tweet)
194 let myHighlight = fmap (hitHighlight . head . hits . searchHits) result
190 let myHighlight = fmap (hitHighlight . head . hits . searchHits) result
195 return myHighlight
191 return myHighlight
@@ -497,17 +493,27 @@ main = hspec $ do
497
493
498 describe "Highlights API" $ do
494 describe "Highlights API" $ do
499
495
500− it "returns highlight from query" $ do
496+ it "returns highlight from query when there should be one" $ do
501 _ <- insertData
497 _ <- insertData
502 _ <- insertOther
498 _ <- insertOther
503 let query = QueryMatchQuery $ mkMatchQuery (FieldName "_all") (QueryString "haskell")
499 let query = QueryMatchQuery $ mkMatchQuery (FieldName "_all") (QueryString "haskell")
504 let highlight = Highlights Nothing [FieldHighlight (FieldName "message") Nothing]
500 let highlight = Highlights Nothing [FieldHighlight (FieldName "message") Nothing]
505
501
506− traceShowM (encode highlight)
507 let search = mkHighlightSearch (Just query) highlight
502 let search = mkHighlightSearch (Just query) highlight
508− traceShowM (encode search)
509 myHighlight <- searchTweetHighlight search
503 myHighlight <- searchTweetHighlight search
510− myHighlight `shouldBe` Right (Just "")
504+ myHighlight `shouldBe` Right (Just (M.fromList [("message",["Use <em>haskell</em>!"])]))
505+
506+ it "doesn't return highlight from a query when it shouldn't" $ do
507+ _ <- insertData
508+ _ <- insertOther
509+ let query = QueryMatchQuery $ mkMatchQuery (FieldName "_all") (QueryString "haskell")
510+ let highlight = Highlights Nothing [FieldHighlight (FieldName "user") Nothing]
511+
512+ let search = mkHighlightSearch (Just query) highlight
513+ myHighlight <- searchTweetHighlight search
514+ myHighlight `shouldBe` Right Nothing
515+
516+
511
517
512 describe "ToJSON RegexpFlags" $ do
518 describe "ToJSON RegexpFlags" $ do
513 it "generates the correct JSON for AllRegexpFlags" $
519 it "generates the correct JSON for AllRegexpFlags" $