@@ -162,20 +162,33 @@ module Database.Bloodhound.Types
162162 , BucketAggregation(..)
163163 , TermsAggregation(..)
164164 , 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+
165178 , TermsResult(..)
166179 , DateHistogramResult(..)
167180 ) where
168181
169182import Control.Applicative
170183import Data.Aeson
171−import Data.Aeson.Types (parseMaybe)
184+import Data.Aeson.Types (Pair, emptyObject, parseMaybe)
172185import qualified Data.ByteString.Lazy.Char8 as L
173186import Data.List (nub)
174187import Data.List.NonEmpty (NonEmpty (..))
188+import qualified Data.Map.Strict as M
175189import Data.Monoid
176190import Data.Text (Text)
177191import qualified Data.Text as T
178−import qualified Data.Map.Strict as M
179192import Data.Time.Clock (UTCTime)
180193import qualified Data.Vector as V
181194import GHC.Generics (Generic)
@@ -496,15 +509,71 @@ type TrackSortScores = Bool
496509type From = Int
497510type Size = Int
498511
499−data Search = Search { queryBody :: Maybe Query
500− , filterBody :: Maybe Filter
501− , sortBody :: Maybe Sort
502− , aggBody :: Maybe Aggregations
512+data Search = Search { queryBody :: Maybe Query
513+ , filterBody :: Maybe Filter
514+ , sortBody :: Maybe Sort
515+ , aggBody :: Maybe Aggregations
516+ , highlight :: Maybe Highlights
503517 -- default False
504518 , trackSortScores :: TrackSortScores
505519 , from :: From
506520 , size :: Size } deriving (Eq, Show)
507521
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+
508577data Query =
509578 TermQuery Term (Maybe Boost)
510579 | TermsQuery [Term] MinimumMatch
@@ -938,7 +1007,7 @@ data DistanceRange =
9381007 DistanceRange { distanceFrom :: Distance
9391008 , distanceTo :: Distance } deriving (Eq, Show)
9401009
941−data FromJSON a => SearchResult a =
1010+data (FromJSON a) => SearchResult a =
9421011 SearchResult { took :: Int
9431012 , timedOut :: Bool
9441013 , shards :: ShardResult
@@ -947,23 +1016,26 @@ data FromJSON a => SearchResult a =
9471016
9481017type Score = Double
9491018
950−data FromJSON a => SearchHits a =
1019+data (FromJSON a) => SearchHits a =
9511020 SearchHits { hitsTotal :: Int
9521021 , maxScore :: Score
9531022 , hits :: [Hit a] } deriving (Eq, Show)
9541023
955−data FromJSON a => Hit a =
956− Hit { hitIndex :: IndexName
957− , hitType :: MappingName
958− , hitDocId :: DocId
959− , hitScore :: Score
960− , hitSource :: a } deriving (Eq, Show)
1024+data (FromJSON a) => Hit a =
1025+ Hit { hitIndex :: IndexName
1026+ , hitType :: MappingName
1027+ , hitDocId :: DocId
1028+ , hitScore :: Score
1029+ , hitSource :: a
1030+ , hitHighlight :: Maybe HitHighlight } deriving (Eq, Show)
9611031
9621032data ShardResult =
9631033 ShardResult { shardTotal :: Int
9641034 , shardsSuccessful :: Int
9651035 , shardsFailed :: Int } deriving (Eq, Show, Generic)
9661036
1037+type HitHighlight = M.Map Text [Text]
1038+
9671039showText :: Show a => a -> Text
9681040showText = T.pack . show
9691041
@@ -1003,7 +1075,7 @@ data Interval = Year
10031075 | Day
10041076 | Hour
10051077 | Minute
1006− | Second
1078+ | Second
10071079 | FractionalInterval Float TimeInterval deriving (Eq, Show)
10081080
10091081data Aggregation = TermsAgg TermsAggregation
@@ -1022,14 +1094,14 @@ data TermsAggregation = TermsAggregation { term :: Either Text Text
10221094 , termAggs :: Maybe Aggregations
10231095 } deriving (Eq, Show)
10241096
1025−data DateHistogramAggregation = DateHistogramAggregation { dateField :: FieldName
1026− , dateInterval :: Interval
1027− , dateFormat :: Maybe Text
1028− , datePreZone :: Maybe Text
1029− , datePostZone :: Maybe Text
1030− , datePreOffset :: Maybe Text
1031− , datePostOffset :: Maybe Text
1032− , dateAggs :: Maybe Aggregations
1097+data DateHistogramAggregation = DateHistogramAggregation { dateField :: FieldName
1098+ , dateInterval :: Interval
1099+ , dateFormat :: Maybe Text
1100+ , datePreZone :: Maybe Text
1101+ , datePostZone :: Maybe Text
1102+ , datePreOffset :: Maybe Text
1103+ , datePostOffset :: Maybe Text
1104+ , dateAggs :: Maybe Aggregations
10331105 } deriving (Eq, Show)
10341106
10351107
@@ -1053,7 +1125,7 @@ instance ToJSON TermInclusion where
10531125instance ToJSON CollectionMode where
10541126 toJSON BreadthFirst = "breadth_first"
10551127 toJSON DepthFirst = "depth_first"
1056−
1128+
10571129instance ToJSON ExecutionHint where
10581130 toJSON Ordinals = "ordinals"
10591131 toJSON GlobalOrdinals = "global_ordinals"
@@ -1083,7 +1155,7 @@ instance ToJSON Aggregation where
10831155 toJSON (TermsAgg (TermsAggregation term include exclude order minDocCount size shardSize collectMode executionHint termAggs)) =
10841156 omitNulls ["terms" .= omitNulls [ toJSON' term,
10851157 "include" .= toJSON include,
1086− "exclude" .= toJSON exclude,
1158+ "exclude" .= toJSON exclude,
10871159 "order" .= toJSON order,
10881160 "min_doc_count" .= toJSON minDocCount,
10891161 "size" .= toJSON size,
@@ -1116,10 +1188,10 @@ class BucketAggregation a where
11161188
11171189data (FromJSON a, BucketAggregation a) => Bucket a = Bucket { buckets :: [a]} deriving (Show)
11181190
1119−data TermsResult = TermsResult { termKey :: Text
1120− , termsDocCount :: Int
1121− , termsAggs :: Maybe AggregationResults } deriving (Show)
1122−
1191+data TermsResult = TermsResult { termKey :: Text
1192+ , termsDocCount :: Int
1193+ , termsAggs :: Maybe AggregationResults } deriving (Show)
1194+
11231195data DateHistogramResult = DateHistogramResult { dateKey :: Int
11241196 , dateKeyStr :: Maybe Text
11251197 , dateDocCount :: Int
@@ -1158,7 +1230,7 @@ instance FromJSON TermsResult where
11581230instance FromJSON DateHistogramResult where
11591231 parseJSON (Object v) = DateHistogramResult <$>
11601232 v .: "key" <*>
1161− v .:? "key_as_string" <*>
1233+ v .:? "key_as_string" <*>
11621234 v .: "doc_count" <*>
11631235 v .:? "aggregations"
11641236 parseJSON _ = mempty
@@ -1304,7 +1376,7 @@ instance ToJSON Query where
13041376 object [ "match" .= toJSON matchQuery ]
13051377
13061378 toJSON (QueryMultiMatchQuery multiMatchQuery) =
1307− object [ "multi_match" .= toJSON multiMatchQuery ]
1379+ toJSON multiMatchQuery
13081380
13091381 toJSON (QueryBoolQuery boolQuery) =
13101382 object [ "bool" .= toJSON boolQuery ]
@@ -1756,15 +1828,97 @@ instance (FromJSON a) => FromJSON (EsResult a) where
17561828
17571829
17581830instance ToJSON Search where
1759− toJSON (Search query sFilter sort searchAggs sTrackSortScores sFrom sSize) =
1760− omitNulls [ "query" .= query
1761− , "filter" .= sFilter
1762− , "sort" .= sort
1831+ toJSON (Search query sFilter sort searchAggs highlight sTrackSortScores sFrom sSize) =
1832+ omitNulls [ "query" .= query
1833+ , "filter" .= sFilter
1834+ , "sort" .= sort
17631835 , "aggregations" .= searchAggs
1764− , "from" .= sFrom
1765− , "size" .= sSize
1766− , "track_scores" .= sTrackSortScores ]
1767−
1836+ , "highlight" .= highlight
1837+ , "from" .= sFrom
1838+ , "size" .= sSize
1839+ , "track_scores" .= sTrackSortScores]
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 = []
17681922
17691923instance ToJSON SortSpec where
17701924 toJSON (DefaultSortSpec
@@ -1914,15 +2068,16 @@ instance (FromJSON a) => FromJSON (SearchHits a) where
19142068
19152069instance (FromJSON a) => FromJSON (Hit a) where
19162070 parseJSON (Object v) = Hit <$>
1917− v .: "_index" <*>
1918− v .: "_type" <*>
1919− v .: "_id" <*>
1920− v .: "_score" <*>
1921− v .: "_source"
2071+ v .: "_index" <*>
2072+ v .: "_type" <*>
2073+ v .: "_id" <*>
2074+ v .: "_score" <*>
2075+ v .: "_source" <*>
2076+ v .:? "highlight"
19222077 parseJSON _ = empty
19232078
19242079instance FromJSON ShardResult where
1925− parseJSON (Object v) = ShardResult <$>
2080+ parseJSON (Object v) = ShardResult <$>
19262081 v .: "total" <*>
19272082 v .: "successful" <*>
19282083 v .: "failed"