git.iko.soy/typeable/bloodhound
on master help sign in
Merge pull request #19 from latkins/master
14bd89cChris Allen
Database/Bloodhound/Client.hs+18−14
compare with master
unifiedsplit
@@ -16,6 +16,7 @@ module Database.Bloodhound.Client
16 , refreshIndex
16 , refreshIndex
17 , mkSearch
17 , mkSearch
18 , mkAggregateSearch
18 , mkAggregateSearch
19+ , mkHighlightSearch
19 , bulk
20 , bulk
20 , pageSearch
21 , pageSearch
21 , mkShardCount
22 , mkShardCount
@@ -26,19 +27,19 @@ module Database.Bloodhound.Client
26 )
27 )
27 where
28 where
28
29
29−import Data.Aeson
30+import Data.Aeson
31+import Data.ByteString.Builder
30import qualified Data.ByteString.Lazy.Char8 as L
32import qualified Data.ByteString.Lazy.Char8 as L
31−import Data.ByteString.Builder
32−import Data.List (intercalate)
33+import Data.List (intercalate)
33−import Data.Maybe (fromMaybe)
34+import Data.Maybe (fromMaybe)
34−import Data.Text (Text)
35+import Data.Text (Text)
35−import qualified Data.Vector as V
36+import qualified Data.Vector as V
36−import Network.HTTP.Client
37+import Network.HTTP.Client
37−import qualified Network.HTTP.Types.Method as NHTM
38+import qualified Network.HTTP.Types.Method as NHTM
38−import qualified Network.HTTP.Types.Status as NHTS
39+import qualified Network.HTTP.Types.Status as NHTS
39−import Prelude hiding (head, filter)
40+import Prelude hiding (filter, head)
40−
41+
41−import Database.Bloodhound.Types
42+import Database.Bloodhound.Types
42
43
43-- find way to avoid destructuring Servers and Indexes?
44-- find way to avoid destructuring Servers and Indexes?
44-- make get, post, put, delete helpers.
45-- make get, post, put, delete helpers.
@@ -249,10 +250,13 @@ searchByType (Server server) (IndexName indexName)
249 url = joinPath [server, indexName, mappingName, "_search"]
250 url = joinPath [server, indexName, mappingName, "_search"]
250
251
251mkSearch :: Maybe Query -> Maybe Filter -> Search
252mkSearch :: Maybe Query -> Maybe Filter -> Search
252−mkSearch query filter = Search query filter Nothing Nothing False 0 10
253+mkSearch query filter = Search query filter Nothing Nothing Nothing False 0 10
253
254
254mkAggregateSearch :: Maybe Query -> Aggregations -> Search
255mkAggregateSearch :: Maybe Query -> Aggregations -> Search
255−mkAggregateSearch query mkSearchAggs = Search query Nothing Nothing (Just mkSearchAggs) False 0 0
256+mkAggregateSearch query mkSearchAggs = Search query Nothing Nothing (Just mkSearchAggs) Nothing False 0 0
257+
258+mkHighlightSearch :: Maybe Query -> Highlights -> Search
259+mkHighlightSearch query searchHighlights = Search query Nothing Nothing Nothing (Just searchHighlights) False 0 10
256
260
257pageSearch :: Int -> Int -> Search -> Search
261pageSearch :: Int -> Int -> Search -> Search
258pageSearch pageFrom pageSize search = search { from = pageFrom, size = pageSize }
262pageSearch pageFrom pageSize search = search { from = pageFrom, size = pageSize }
Database/Bloodhound/Types.hs+200−45
@@ -162,20 +162,33 @@ module Database.Bloodhound.Types
162 , BucketAggregation(..)
162 , BucketAggregation(..)
163 , TermsAggregation(..)
163 , TermsAggregation(..)
164 , DateHistogramAggregation(..)
164 , DateHistogramAggregation(..)
165+
166+ , Highlights(..)
167+ , FieldHighlight(..)
168+ , HighlightSettings(..)
169+ , PlainHighlight(..)
170+ , PostingsHighlight(..)
171+ , FastVectorHighlight(..)
172+ , CommonHighlight(..)
173+ , NonPostings(..)
174+ , HighlightEncoder(..)
175+ , HighlightTag(..)
176+ , HitHighlight
177+
165 , TermsResult(..)
178 , TermsResult(..)
166 , DateHistogramResult(..)
179 , DateHistogramResult(..)
167 ) where
180 ) where
168
181
169import Control.Applicative
182import Control.Applicative
170import Data.Aeson
183import Data.Aeson
171−import Data.Aeson.Types (parseMaybe)
184+import Data.Aeson.Types (Pair, emptyObject, parseMaybe)
172import qualified Data.ByteString.Lazy.Char8 as L
185import qualified Data.ByteString.Lazy.Char8 as L
173import Data.List (nub)
186import Data.List (nub)
174import Data.List.NonEmpty (NonEmpty (..))
187import Data.List.NonEmpty (NonEmpty (..))
188+import qualified Data.Map.Strict as M
175import Data.Monoid
189import Data.Monoid
176import Data.Text (Text)
190import Data.Text (Text)
177import qualified Data.Text as T
191import qualified Data.Text as T
178−import qualified Data.Map.Strict as M
179import Data.Time.Clock (UTCTime)
192import Data.Time.Clock (UTCTime)
180import qualified Data.Vector as V
193import qualified Data.Vector as V
181import GHC.Generics (Generic)
194import GHC.Generics (Generic)
@@ -496,15 +509,71 @@ type TrackSortScores = Bool
496type From = Int
509type From = Int
497type Size = Int
510type Size = Int
498
511
499−data Search = Search { queryBody :: Maybe Query
512+data Search = Search { queryBody :: Maybe Query
500− , filterBody :: Maybe Filter
513+ , filterBody :: Maybe Filter
501− , sortBody :: Maybe Sort
514+ , sortBody :: Maybe Sort
502− , aggBody :: Maybe Aggregations
515+ , aggBody :: Maybe Aggregations
516+ , highlight :: Maybe Highlights
503 -- default False
517 -- default False
504 , trackSortScores :: TrackSortScores
518 , trackSortScores :: TrackSortScores
505 , from :: From
519 , from :: From
506 , size :: Size } deriving (Eq, Show)
520 , size :: Size } deriving (Eq, Show)
507
521
522+data Highlights = Highlights { globalsettings :: Maybe HighlightSettings
523+ , highlightFields :: [FieldHighlight]
524+ } deriving (Show, Eq)
525+
526+data FieldHighlight = FieldHighlight FieldName (Maybe HighlightSettings)
527+ deriving (Show, Eq)
528+
529+
530+data HighlightSettings = Plain PlainHighlight
531+ | Postings PostingsHighlight
532+ | FastVector FastVectorHighlight
533+ deriving (Show, Eq)
534+data PlainHighlight =
535+ PlainHighlight { plainCommon :: Maybe CommonHighlight
536+ , plainNonPost :: Maybe NonPostings } deriving (Show, Eq)
537+
538+ -- This requires that index_options are set to 'offset' in the mapping.
539+data PostingsHighlight = PostingsHighlight (Maybe CommonHighlight) deriving (Show, Eq)
540+
541+-- This requires that term_vector is set to 'with_positions_offsets' in the mapping.
542+data FastVectorHighlight =
543+ FastVectorHighlight { fvCommon :: Maybe CommonHighlight
544+ , fvNonPostSettings :: Maybe NonPostings
545+ , boundaryChars :: Maybe Text
546+ , boundaryMaxScan :: Maybe Int
547+ , fragmentOffset :: Maybe Int
548+ , matchedFields :: [Text]
549+ , phraseLimit :: Maybe Int
550+ } deriving (Show, Eq)
551+
552+data CommonHighlight =
553+ CommonHighlight { order :: Maybe Text
554+ , forceSource :: Maybe Bool
555+ , tag :: Maybe HighlightTag
556+ , encoder :: Maybe HighlightEncoder
557+ , noMatchSize :: Maybe Int
558+ , highlightQuery :: Maybe Query
559+ , requireFieldMatch :: Maybe Bool
560+ } deriving (Show, Eq)
561+
562+-- Settings that are only applicable to FastVector and Plain highlighters.
563+data NonPostings =
564+ NonPostings { fragmentSize :: Maybe Int
565+ , numberOfFragments :: Maybe Int} deriving (Show, Eq)
566+
567+data HighlightEncoder = DefaultEncoder
568+ | HTMLEncoder
569+ deriving (Show, Eq)
570+
571+-- NOTE: Should the tags use some kind of HTML type, rather than Text?
572+data HighlightTag = TagSchema Text
573+ | CustomTags ([Text], [Text]) -- Only uses more than the first value in the lists if fvh
574+ deriving (Show, Eq)
575+
576+
508data Query =
577data Query =
509 TermQuery Term (Maybe Boost)
578 TermQuery Term (Maybe Boost)
510 | TermsQuery [Term] MinimumMatch
579 | TermsQuery [Term] MinimumMatch
@@ -938,7 +1007,7 @@ data DistanceRange =
938 DistanceRange { distanceFrom :: Distance
1007 DistanceRange { distanceFrom :: Distance
939 , distanceTo :: Distance } deriving (Eq, Show)
1008 , distanceTo :: Distance } deriving (Eq, Show)
940
1009
941−data FromJSON a => SearchResult a =
1010+data (FromJSON a) => SearchResult a =
942 SearchResult { took :: Int
1011 SearchResult { took :: Int
943 , timedOut :: Bool
1012 , timedOut :: Bool
944 , shards :: ShardResult
1013 , shards :: ShardResult
@@ -947,23 +1016,26 @@ data FromJSON a => SearchResult a =
947
1016
948type Score = Double
1017type Score = Double
949
1018
950−data FromJSON a => SearchHits a =
1019+data (FromJSON a) => SearchHits a =
951 SearchHits { hitsTotal :: Int
1020 SearchHits { hitsTotal :: Int
952 , maxScore :: Score
1021 , maxScore :: Score
953 , hits :: [Hit a] } deriving (Eq, Show)
1022 , hits :: [Hit a] } deriving (Eq, Show)
954
1023
955−data FromJSON a => Hit a =
1024+data (FromJSON a) => Hit a =
956− Hit { hitIndex :: IndexName
1025+ Hit { hitIndex :: IndexName
957− , hitType :: MappingName
1026+ , hitType :: MappingName
958− , hitDocId :: DocId
1027+ , hitDocId :: DocId
959− , hitScore :: Score
1028+ , hitScore :: Score
960− , hitSource :: a } deriving (Eq, Show)
1029+ , hitSource :: a
1030+ , hitHighlight :: Maybe HitHighlight } deriving (Eq, Show)
961
1031
962data ShardResult =
1032data ShardResult =
963 ShardResult { shardTotal :: Int
1033 ShardResult { shardTotal :: Int
964 , shardsSuccessful :: Int
1034 , shardsSuccessful :: Int
965 , shardsFailed :: Int } deriving (Eq, Show, Generic)
1035 , shardsFailed :: Int } deriving (Eq, Show, Generic)
966
1036
1037+type HitHighlight = M.Map Text [Text]
1038+
967showText :: Show a => a -> Text
1039showText :: Show a => a -> Text
968showText = T.pack . show
1040showText = T.pack . show
969
1041
@@ -1003,7 +1075,7 @@ data Interval = Year
1003 | Day
1075 | Day
1004 | Hour
1076 | Hour
1005 | Minute
1077 | Minute
1006− | Second
1078+ | Second
1007 | FractionalInterval Float TimeInterval deriving (Eq, Show)
1079 | FractionalInterval Float TimeInterval deriving (Eq, Show)
1008
1080
1009data Aggregation = TermsAgg TermsAggregation
1081data Aggregation = TermsAgg TermsAggregation
@@ -1022,14 +1094,14 @@ data TermsAggregation = TermsAggregation { term :: Either Text Text
1022 , termAggs :: Maybe Aggregations
1094 , termAggs :: Maybe Aggregations
1023 } deriving (Eq, Show)
1095 } deriving (Eq, Show)
1024
1096
1025−data DateHistogramAggregation = DateHistogramAggregation { dateField :: FieldName
1097+data DateHistogramAggregation = DateHistogramAggregation { dateField :: FieldName
1026− , dateInterval :: Interval
1098+ , dateInterval :: Interval
1027− , dateFormat :: Maybe Text
1099+ , dateFormat :: Maybe Text
1028− , datePreZone :: Maybe Text
1100+ , datePreZone :: Maybe Text
1029− , datePostZone :: Maybe Text
1101+ , datePostZone :: Maybe Text
1030− , datePreOffset :: Maybe Text
1102+ , datePreOffset :: Maybe Text
1031− , datePostOffset :: Maybe Text
1103+ , datePostOffset :: Maybe Text
1032− , dateAggs :: Maybe Aggregations
1104+ , dateAggs :: Maybe Aggregations
1033 } deriving (Eq, Show)
1105 } deriving (Eq, Show)
1034
1106
1035
1107
@@ -1053,7 +1125,7 @@ instance ToJSON TermInclusion where
1053instance ToJSON CollectionMode where
1125instance ToJSON CollectionMode where
1054 toJSON BreadthFirst = "breadth_first"
1126 toJSON BreadthFirst = "breadth_first"
1055 toJSON DepthFirst = "depth_first"
1127 toJSON DepthFirst = "depth_first"
1056−
1128+
1057instance ToJSON ExecutionHint where
1129instance ToJSON ExecutionHint where
1058 toJSON Ordinals = "ordinals"
1130 toJSON Ordinals = "ordinals"
1059 toJSON GlobalOrdinals = "global_ordinals"
1131 toJSON GlobalOrdinals = "global_ordinals"
@@ -1083,7 +1155,7 @@ instance ToJSON Aggregation where
1083 toJSON (TermsAgg (TermsAggregation term include exclude order minDocCount size shardSize collectMode executionHint termAggs)) =
1155 toJSON (TermsAgg (TermsAggregation term include exclude order minDocCount size shardSize collectMode executionHint termAggs)) =
1084 omitNulls ["terms" .= omitNulls [ toJSON' term,
1156 omitNulls ["terms" .= omitNulls [ toJSON' term,
1085 "include" .= toJSON include,
1157 "include" .= toJSON include,
1086− "exclude" .= toJSON exclude,
1158+ "exclude" .= toJSON exclude,
1087 "order" .= toJSON order,
1159 "order" .= toJSON order,
1088 "min_doc_count" .= toJSON minDocCount,
1160 "min_doc_count" .= toJSON minDocCount,
1089 "size" .= toJSON size,
1161 "size" .= toJSON size,
@@ -1116,10 +1188,10 @@ class BucketAggregation a where
1116
1188
1117data (FromJSON a, BucketAggregation a) => Bucket a = Bucket { buckets :: [a]} deriving (Show)
1189data (FromJSON a, BucketAggregation a) => Bucket a = Bucket { buckets :: [a]} deriving (Show)
1118
1190
1119−data TermsResult = TermsResult { termKey :: Text
1191+data TermsResult = TermsResult { termKey :: Text
1120− , termsDocCount :: Int
1192+ , termsDocCount :: Int
1121− , termsAggs :: Maybe AggregationResults } deriving (Show)
1193+ , termsAggs :: Maybe AggregationResults } deriving (Show)
1122−
1194+
1123data DateHistogramResult = DateHistogramResult { dateKey :: Int
1195data DateHistogramResult = DateHistogramResult { dateKey :: Int
1124 , dateKeyStr :: Maybe Text
1196 , dateKeyStr :: Maybe Text
1125 , dateDocCount :: Int
1197 , dateDocCount :: Int
@@ -1158,7 +1230,7 @@ instance FromJSON TermsResult where
1158instance FromJSON DateHistogramResult where
1230instance FromJSON DateHistogramResult where
1159 parseJSON (Object v) = DateHistogramResult <$>
1231 parseJSON (Object v) = DateHistogramResult <$>
1160 v .: "key" <*>
1232 v .: "key" <*>
1161− v .:? "key_as_string" <*>
1233+ v .:? "key_as_string" <*>
1162 v .: "doc_count" <*>
1234 v .: "doc_count" <*>
1163 v .:? "aggregations"
1235 v .:? "aggregations"
1164 parseJSON _ = mempty
1236 parseJSON _ = mempty
@@ -1304,7 +1376,7 @@ instance ToJSON Query where
1304 object [ "match" .= toJSON matchQuery ]
1376 object [ "match" .= toJSON matchQuery ]
1305
1377
1306 toJSON (QueryMultiMatchQuery multiMatchQuery) =
1378 toJSON (QueryMultiMatchQuery multiMatchQuery) =
1307− object [ "multi_match" .= toJSON multiMatchQuery ]
1379+ toJSON multiMatchQuery
1308
1380
1309 toJSON (QueryBoolQuery boolQuery) =
1381 toJSON (QueryBoolQuery boolQuery) =
1310 object [ "bool" .= toJSON boolQuery ]
1382 object [ "bool" .= toJSON boolQuery ]
@@ -1756,15 +1828,97 @@ instance (FromJSON a) => FromJSON (EsResult a) where
1756
1828
1757
1829
1758instance ToJSON Search where
1830instance ToJSON Search where
1759− toJSON (Search query sFilter sort searchAggs sTrackSortScores sFrom sSize) =
1831+ toJSON (Search query sFilter sort searchAggs highlight sTrackSortScores sFrom sSize) =
1760− omitNulls [ "query" .= query
1832+ omitNulls [ "query" .= query
1761− , "filter" .= sFilter
1833+ , "filter" .= sFilter
1762− , "sort" .= sort
1834+ , "sort" .= sort
1763 , "aggregations" .= searchAggs
1835 , "aggregations" .= searchAggs
1836+ , "highlight" .= highlight
1764− , "from" .= sFrom
1837+ , "from" .= sFrom
1765− , "size" .= sSize
1838+ , "size" .= sSize
1766− , "track_scores" .= sTrackSortScores ]
1839+ , "track_scores" .= sTrackSortScores]
1767−
1840+
1841+
1842+instance ToJSON FieldHighlight where
1843+ toJSON (FieldHighlight (FieldName fName) (Just fSettings)) =
1844+ object [ fName .= fSettings ]
1845+ toJSON (FieldHighlight (FieldName fName) Nothing) =
1846+ object [ fName .= emptyObject ]
1847+
1848+instance ToJSON Highlights where
1849+ toJSON (Highlights global fields) =
1850+ omitNulls (("fields" .= toJSON fields)
1851+ : highlightSettingsPairs global)
1852+
1853+instance ToJSON HighlightSettings where
1854+ toJSON hs = omitNulls (highlightSettingsPairs (Just hs))
1855+
1856+highlightSettingsPairs :: Maybe HighlightSettings -> [Pair]
1857+highlightSettingsPairs Nothing = []
1858+highlightSettingsPairs (Just (Plain plh)) = plainHighPairs (Just plh)
1859+highlightSettingsPairs (Just (Postings ph)) = postHighPairs (Just ph)
1860+highlightSettingsPairs (Just (FastVector fvh)) = fastVectorHighPairs (Just fvh)
1861+
1862+
1863+plainHighPairs :: Maybe PlainHighlight -> [Pair]
1864+plainHighPairs Nothing = []
1865+plainHighPairs (Just (PlainHighlight plCom plNonPost)) =
1866+ [ "type" .= String "plain"]
1867+ ++ commonHighlightPairs plCom
1868+ ++ nonPostingsToPairs plNonPost
1869+
1870+postHighPairs :: Maybe PostingsHighlight -> [Pair]
1871+postHighPairs Nothing = []
1872+postHighPairs (Just (PostingsHighlight pCom)) =
1873+ ("type" .= String "postings")
1874+ : commonHighlightPairs pCom
1875+
1876+fastVectorHighPairs :: Maybe FastVectorHighlight -> [Pair]
1877+fastVectorHighPairs Nothing = []
1878+fastVectorHighPairs (Just
1879+ (FastVectorHighlight fvCom fvNonPostSettings fvBoundChars
1880+ fvBoundMaxScan fvFragOff fvMatchedFields
1881+ fvPhraseLim)) =
1882+ [ "type" .= String "fvh"
1883+ , "boundary_chars" .= fvBoundChars
1884+ , "boundary_max_scan" .= fvBoundMaxScan
1885+ , "fragment_offset" .= fvFragOff
1886+ , "matched_fields" .= fvMatchedFields
1887+ , "phraseLimit" .= fvPhraseLim]
1888+ ++ commonHighlightPairs fvCom
1889+ ++ nonPostingsToPairs fvNonPostSettings
1890+
1891+commonHighlightPairs :: Maybe CommonHighlight -> [Pair]
1892+commonHighlightPairs Nothing = []
1893+commonHighlightPairs (Just (CommonHighlight chScore chForceSource chTag chEncoder
1894+ chNoMatchSize chHighlightQuery
1895+ chRequireFieldMatch)) =
1896+ [ "order" .= chScore
1897+ , "force_source" .= chForceSource
1898+ , "encoder" .= chEncoder
1899+ , "no_match_size" .= chNoMatchSize
1900+ , "highlight_query" .= chHighlightQuery
1901+ , "require_fieldMatch" .= chRequireFieldMatch]
1902+ ++ highlightTagToPairs chTag
1903+
1904+
1905+nonPostingsToPairs :: Maybe NonPostings -> [Pair]
1906+nonPostingsToPairs Nothing = []
1907+nonPostingsToPairs (Just (NonPostings npFragSize npNumOfFrags)) =
1908+ [ "fragment_size" .= npFragSize
1909+ , "number_of_fragments" .= npNumOfFrags]
1910+
1911+
1912+
1913+instance ToJSON HighlightEncoder where
1914+ toJSON DefaultEncoder = String "default"
1915+ toJSON HTMLEncoder = String "html"
1916+
1917+highlightTagToPairs :: Maybe HighlightTag -> [Pair]
1918+highlightTagToPairs (Just (TagSchema _)) = [ "scheme" .= String "default"]
1919+highlightTagToPairs (Just (CustomTags (pre, post))) = [ "pre_tags" .= pre
1920+ , "post_tags" .= post]
1921+highlightTagToPairs Nothing = []
1768
1922
1769instance ToJSON SortSpec where
1923instance ToJSON SortSpec where
1770 toJSON (DefaultSortSpec
1924 toJSON (DefaultSortSpec
@@ -1914,15 +2068,16 @@ instance (FromJSON a) => FromJSON (SearchHits a) where
1914
2068
1915instance (FromJSON a) => FromJSON (Hit a) where
2069instance (FromJSON a) => FromJSON (Hit a) where
1916 parseJSON (Object v) = Hit <$>
2070 parseJSON (Object v) = Hit <$>
1917− v .: "_index" <*>
2071+ v .: "_index" <*>
1918− v .: "_type" <*>
2072+ v .: "_type" <*>
1919− v .: "_id" <*>
2073+ v .: "_id" <*>
1920− v .: "_score" <*>
2074+ v .: "_score" <*>
1921− v .: "_source"
2075+ v .: "_source" <*>
2076+ v .:? "highlight"
1922 parseJSON _ = empty
2077 parseJSON _ = empty
1923
2078
1924instance FromJSON ShardResult where
2079instance FromJSON ShardResult where
1925− parseJSON (Object v) = ShardResult <$>
2080+ parseJSON (Object v) = ShardResult <$>
1926 v .: "total" <*>
2081 v .: "total" <*>
1927 v .: "successful" <*>
2082 v .: "successful" <*>
1928 v .: "failed"
2083 v .: "failed"
tests/tests.hs+37−5
@@ -21,6 +21,7 @@ import Network.HTTP.Client
21import qualified Network.HTTP.Types.Status as NHTS
21import qualified Network.HTTP.Types.Status as NHTS
22import Prelude hiding (filter, putStrLn)
22import Prelude hiding (filter, putStrLn)
23import Test.Hspec
23import Test.Hspec
24+
24import Test.Hspec.QuickCheck (prop)
25import Test.Hspec.QuickCheck (prop)
25import Test.QuickCheck
26import Test.QuickCheck
26
27
@@ -69,12 +70,12 @@ mkServerVersion _ = Nothing
69
70
70getServerVersion :: Server -> IO (Maybe ServerVersion)
71getServerVersion :: Server -> IO (Maybe ServerVersion)
71getServerVersion s = liftM extractVersion (getStatus s)
72getServerVersion s = liftM extractVersion (getStatus s)
72− where
73+ where
73 version' = T.splitOn "." . number . version
74 version' = T.splitOn "." . number . version
74 toInt = read . T.unpack
75 toInt = read . T.unpack
75 parseVersion v = map toInt (version' v)
76 parseVersion v = map toInt (version' v)
76 extractVersion = join . liftM (mkServerVersion . parseVersion)
77 extractVersion = join . liftM (mkServerVersion . parseVersion)
77−
78+
78
79
79
80
80testServerBranch :: IO (Maybe ServerVersion)
81testServerBranch :: IO (Maybe ServerVersion)
@@ -165,10 +166,10 @@ searchExpectNoResults search = do
165searchExpectAggs :: Search -> IO ()
166searchExpectAggs :: Search -> IO ()
166searchExpectAggs search = do
167searchExpectAggs search = do
167 reply <- searchAll testServer search
168 reply <- searchAll testServer search
168− let isEmpty x = return (M.null x)
169+ let isEmpty x = return (M.null x)
169 let result = decode (responseBody reply) :: Maybe (SearchResult Tweet)
170 let result = decode (responseBody reply) :: Maybe (SearchResult Tweet)
170 (result >>= aggregations >>= isEmpty) `shouldBe` Just False
171 (result >>= aggregations >>= isEmpty) `shouldBe` Just False
171−
172+
172searchValidBucketAgg :: (BucketAggregation a, FromJSON a, Show a) => Search -> Text -> (Text -> AggregationResults -> Maybe (Bucket a)) -> IO ()
173searchValidBucketAgg :: (BucketAggregation a, FromJSON a, Show a) => Search -> Text -> (Text -> AggregationResults -> Maybe (Bucket a)) -> IO ()
173searchValidBucketAgg search aggKey extractor = do
174searchValidBucketAgg search aggKey extractor = do
174 reply <- searchAll testServer search
175 reply <- searchAll testServer search
@@ -184,6 +185,13 @@ searchTermsAggHint hints = do
184 forM_ hints $ searchExpectAggs . search
185 forM_ hints $ searchExpectAggs . search
185 forM_ hints (\x -> searchValidBucketAgg (search x) "users" toTerms)
186 forM_ hints (\x -> searchValidBucketAgg (search x) "users" toTerms)
186
187
188+searchTweetHighlight :: Search -> IO (Either String (Maybe HitHighlight))
189+searchTweetHighlight search = do
190+ reply <- searchByIndex testServer testIndex search
191+ let result = eitherDecode (responseBody reply) :: Either String (SearchResult Tweet)
192+ let myHighlight = fmap (hitHighlight . head . hits . searchHits) result
193+ return myHighlight
194+
187data BulkTest = BulkTest { name :: Text } deriving (Eq, Generic, Show)
195data BulkTest = BulkTest { name :: Text } deriving (Eq, Generic, Show)
188instance FromJSON BulkTest
196instance FromJSON BulkTest
189instance ToJSON BulkTest
197instance ToJSON BulkTest
@@ -312,7 +320,7 @@ main = hspec $ do
312 _ <- insertOther
320 _ <- insertOther
313 let sortSpec = DefaultSortSpec $ mkSort (FieldName "age") Ascending
321 let sortSpec = DefaultSortSpec $ mkSort (FieldName "age") Ascending
314 let search = Search Nothing
322 let search = Search Nothing
315− (Just IdentityFilter) (Just [sortSpec]) Nothing
323+ (Just IdentityFilter) (Just [sortSpec]) Nothing Nothing
316 False 0 10
324 False 0 10
317 reply <- searchByIndex testServer testIndex search
325 reply <- searchByIndex testServer testIndex search
318 let result = eitherDecode (responseBody reply) :: Either String (SearchResult Tweet)
326 let result = eitherDecode (responseBody reply) :: Either String (SearchResult Tweet)
@@ -485,6 +493,30 @@ main = hspec $ do
485 forM_ intervals expect
493 forM_ intervals expect
486 forM_ intervals valid
494 forM_ intervals valid
487
495
496+ describe "Highlights API" $ do
497+
498+ it "returns highlight from query when there should be one" $ do
499+ _ <- insertData
500+ _ <- insertOther
501+ let query = QueryMatchQuery $ mkMatchQuery (FieldName "_all") (QueryString "haskell")
502+ let highlight = Highlights Nothing [FieldHighlight (FieldName "message") Nothing]
503+
504+ let search = mkHighlightSearch (Just query) highlight
505+ myHighlight <- searchTweetHighlight search
506+ myHighlight `shouldBe` Right (Just (M.fromList [("message",["Use <em>haskell</em>!"])]))
507+
508+ it "doesn't return highlight from a query when it shouldn't" $ do
509+ _ <- insertData
510+ _ <- insertOther
511+ let query = QueryMatchQuery $ mkMatchQuery (FieldName "_all") (QueryString "haskell")
512+ let highlight = Highlights Nothing [FieldHighlight (FieldName "user") Nothing]
513+
514+ let search = mkHighlightSearch (Just query) highlight
515+ myHighlight <- searchTweetHighlight search
516+ myHighlight `shouldBe` Right Nothing
517+
518+
519+
488 describe "ToJSON RegexpFlags" $ do
520 describe "ToJSON RegexpFlags" $ do
489 it "generates the correct JSON for AllRegexpFlags" $
521 it "generates the correct JSON for AllRegexpFlags" $
490 toJSON AllRegexpFlags `shouldBe` String "ALL"
522 toJSON AllRegexpFlags `shouldBe` String "ALL"