git.iko.soy/typeable/bloodhound
on master help sign in
Added ToJSON instances for Highlight types. Added the beginings of tests.
d28751dLiam Atkinson
Database/Bloodhound/Client.hs+17−12
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
@@ -24,18 +25,18 @@ module Database.Bloodhound.Client
24 )
25 )
25 where
26 where
26
27
27−import Data.Aeson
28+import Data.Aeson
29+import Data.ByteString.Builder
28import qualified Data.ByteString.Lazy.Char8 as L
30import qualified Data.ByteString.Lazy.Char8 as L
29−import Data.ByteString.Builder
30−import Data.List (foldl', intercalate, intersperse)
31+import Data.List (foldl', intercalate, intersperse)
31−import Data.Maybe (fromMaybe)
32+import Data.Maybe (fromMaybe)
32−import Data.Text (Text)
33+import Data.Text (Text)
33−import Network.HTTP.Client
34+import Network.HTTP.Client
34−import qualified Network.HTTP.Types.Method as NHTM
35+import qualified Network.HTTP.Types.Method as NHTM
35−import qualified Network.HTTP.Types.Status as NHTS
36+import qualified Network.HTTP.Types.Status as NHTS
36−import Prelude hiding (head, filter)
37+import Prelude hiding (filter, head)
37
38
38−import Database.Bloodhound.Types
39+import Database.Bloodhound.Types
39
40
40-- find way to avoid destructuring Servers and Indexes?
41-- find way to avoid destructuring Servers and Indexes?
41-- make get, post, put, delete helpers.
42-- make get, post, put, delete helpers.
@@ -245,10 +246,14 @@ searchByType (Server server) (IndexName indexName)
245 url = joinPath [server, indexName, mappingName, "_search"]
246 url = joinPath [server, indexName, mappingName, "_search"]
246
247
247mkSearch :: Maybe Query -> Maybe Filter -> Search
248mkSearch :: Maybe Query -> Maybe Filter -> Search
248−mkSearch query filter = Search query filter Nothing Nothing False 0 10
249+mkSearch query filter = Search query filter Nothing Nothing Nothing False 0 10
249
250
250mkAggregateSearch :: Maybe Query -> Aggregations -> Search
251mkAggregateSearch :: Maybe Query -> Aggregations -> Search
251−mkAggregateSearch query aggregations = Search query Nothing Nothing (Just aggregations) False 0 0
252+mkAggregateSearch query aggregations = Search query Nothing Nothing (Just aggregations) Nothing False 0 0
253+
254+
255+mkHighlightSearch :: Maybe Query -> Highlights -> Search
256+mkHighlightSearch query searchHighlights = Search query Nothing Nothing Nothing (Just searchHighlights) False 0 10
252
257
253pageSearch :: Int -> Int -> Search -> Search
258pageSearch :: Int -> Int -> Search -> Search
254pageSearch pageFrom pageSize search = search { from = pageFrom, size = pageSize }
259pageSearch pageFrom pageSize search = search { from = pageFrom, size = pageSize }
Database/Bloodhound/Types.hs+153−50
@@ -162,13 +162,26 @@ 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+
165 , TermsResult
177 , TermsResult
166 , DateHistogramResult
178 , DateHistogramResult
167 ) where
179 ) where
168
180
169import Control.Applicative
181import Control.Applicative
170import Data.Aeson
182import Data.Aeson
171−import Data.Aeson.Types (parseMaybe)
183+import Data.Aeson.Types (Pair (..), emptyObject,
184+ 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 (..))
@@ -500,58 +513,65 @@ 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
508−data Highlights = Hightlights { globalsettings :: Maybe HighlightSettings
522+data Highlights = Highlights { globalsettings :: Maybe HighlightSettings
509− , highlightFields :: [(FieldName, HighlightSettings)]
523+ , highlightFields :: [FieldHighlight]
510− }
524+ } deriving (Show, Eq)
511
525
512−data HighlightSettings = Plain PlainHighlightSettings
526+data FieldHighlight = FieldHighlight FieldName (Maybe HighlightSettings)
513− | Postings PostingsHighlightSettings
527+ deriving (Show, Eq)
514− | FastVector FastVectorHighlightSettings
515
528
516−data PlainHighlightSettings = PlainHighlightSettings { plainCommonSettings :: Maybe CommonHighlightSettings
529+
517− , plainNonPostSettings :: Maybe NonPostingsSettings }
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)
518
537
519 -- This requires that index_options are set to 'offset' in the mapping.
538 -- This requires that index_options are set to 'offset' in the mapping.
520−data PostingsHighlightSettings = PostingsHighlightSettings (Maybe CommonHighlightSettings)
539+data PostingsHighlight = PostingsHighlight (Maybe CommonHighlight) deriving (Show, Eq)
521
540
522-- This requires that term_vector is set to 'with_positions_offsets' in the mapping.
541-- This requires that term_vector is set to 'with_positions_offsets' in the mapping.
542+data FastVectorHighlight =
543+ FastVectorHighlight { fvCommon :: Maybe CommonHighlight
523−data FastVectorHighlightSettings = FastVectorHighlightSettings { boundaryChars :: Maybe Text
544+ , boundaryChars :: Maybe Text
524− , boundaryMaxScan :: Maybe Int
545+ , boundaryMaxScan :: Maybe Int
525− , fragmentOffset :: Maybe Int
546+ , fragmentOffset :: Maybe Int
526− , matchedFields :: [Text]
547+ , matchedFields :: [Text]
527− , fvNonPostSettings :: Maybe NonPostingsSettings
548+ , fvNonPostSettings :: Maybe NonPostings
528− , phraseLimit :: Maybe Int
549+ , phraseLimit :: Maybe Int
529− }
550+ } deriving (Show, Eq)
530−
551+
552+data CommonHighlight =
553+ CommonHighlight {
531−data CommonHighlightSettings = CommonHighlightSettings { highlightType :: Maybe HighlightType -- See below.
554+ -- highlightType :: Maybe HighlightType -- See below.
532− , forceSource :: Maybe Bool
555+ forceSource :: Maybe Bool
533− , tagSettings :: Maybe HighlightTagSettings
556+ , tag :: Maybe HighlightTag
534− , encoder :: Maybe HighlightEncoder
557+ , encoder :: Maybe HighlightEncoder
535− , noMatchSize :: Maybe Int
558+ , noMatchSize :: Maybe Int
536− , highlightQuery :: Maybe Query
559+ , highlightQuery :: Maybe Query
537− , requireFieldMatch :: Maybe Bool
560+ , requireFieldMatch :: Maybe Bool
538− }
561+ } deriving (Show, Eq)
539-- Settings that are only applicable to FastVector and Plain highlighters.
562-- Settings that are only applicable to FastVector and Plain highlighters.
563+data NonPostings =
540−data NonPostingsSettings = NonPostingsSettings { fragmentSize :: Maybe Int
564+ NonPostings { fragmentSize :: Maybe Int
541− , numberOfFragments :: Maybe Int}
565+ , numberOfFragments :: Maybe Int} deriving (Show, Eq)
542−
543−-- Used to force the type of highlighter used, if a different one is used on the mapping.
544−-- NOTE: Is there a way to ignore this, and just have it become part of the ToJSON instance
545−-- for the appropriate hightlight settings?
546−data HighlightType = PlainType
547− | PostingsType
548− | FastVectorType
549
566
550−data HighlightEncoder = DefaultEncoder | HTMLEncoder
567+data HighlightEncoder = DefaultEncoder
568+ | HTMLEncoder
569+ deriving (Show, Eq)
551
570
552-- NOTE: Should the tags use some kind of HTML type, rather than Text?
571-- NOTE: Should the tags use some kind of HTML type, rather than Text?
553−data HighlightTagSettings = TagSchema Text
572+data HighlightTag = TagSchema Text
554− | CustomTags ([Text], [Text]) -- Only uses more than the first value in the lists if fvh
573+ | CustomTags ([Text], [Text]) -- Only uses more than the first value in the lists if fvh
574+ deriving (Show, Eq)
555
575
556
576
557data Query =
577data Query =
@@ -1002,11 +1022,12 @@ data FromJSON a => SearchHits a =
1002 , hits :: [Hit a] } deriving (Eq, Show)
1022 , hits :: [Hit a] } deriving (Eq, Show)
1003
1023
1004data FromJSON a => Hit a =
1024data FromJSON a => Hit a =
1005− Hit { hitIndex :: IndexName
1025+ Hit { hitIndex :: IndexName
1006− , hitType :: MappingName
1026+ , hitType :: MappingName
1007− , hitDocId :: DocId
1027+ , hitDocId :: DocId
1008− , hitScore :: Score
1028+ , hitScore :: Score
1009− , hitSource :: a } deriving (Eq, Show)
1029+ , hitSource :: a
1030+ , hitHighlight :: Maybe Text } deriving (Eq, Show)
1010
1031
1011data ShardResult =
1032data ShardResult =
1012 ShardResult { shardTotal :: Int
1033 ShardResult { shardTotal :: Int
@@ -1803,14 +1824,95 @@ instance (FromJSON a) => FromJSON (EsResult a) where
1803
1824
1804
1825
1805instance ToJSON Search where
1826instance ToJSON Search where
1806− toJSON (Search query sFilter sort aggs sTrackSortScores sFrom sSize) =
1827+ toJSON (Search query sFilter sort aggs highlight sTrackSortScores sFrom sSize) =
1807 omitNulls [ "query" .= query
1828 omitNulls [ "query" .= query
1808 , "filter" .= sFilter
1829 , "filter" .= sFilter
1809 , "sort" .= sort
1830 , "sort" .= sort
1810 , "aggregations" .= aggs
1831 , "aggregations" .= aggs
1832+ , "highlight" .= highlight
1811 , "from" .= sFrom
1833 , "from" .= sFrom
1812 , "size" .= sSize
1834 , "size" .= sSize
1813− , "track_scores" .= sTrackSortScores ]
1835+ , "track_scores" .= sTrackSortScores]
1836+
1837+instance ToJSON FieldHighlight where
1838+ toJSON (FieldHighlight (FieldName fName) (Just fSettings)) =
1839+ object [ fName .= fSettings ]
1840+ toJSON (FieldHighlight (FieldName fName) Nothing) =
1841+ object [ fName .= emptyObject ]
1842+
1843+instance ToJSON Highlights where
1844+ toJSON (Highlights global fields) =
1845+ omitNulls (["fields" .= toJSON fields]
1846+ ++ (highlightSettingsPairs global))
1847+
1848+instance ToJSON HighlightSettings where
1849+ toJSON hs = omitNulls (highlightSettingsPairs (Just hs))
1850+
1851+highlightSettingsPairs :: Maybe HighlightSettings -> [Pair]
1852+highlightSettingsPairs Nothing = []
1853+highlightSettingsPairs (Just (Plain plh)) = plainHighPairs (Just plh)
1854+highlightSettingsPairs (Just (Postings ph)) = postHighPairs (Just ph)
1855+highlightSettingsPairs (Just (FastVector fvh)) = fastVectorHighPairs (Just fvh)
1856+
1857+
1858+plainHighPairs :: Maybe PlainHighlight -> [Pair]
1859+plainHighPairs Nothing = []
1860+plainHighPairs (Just (PlainHighlight plCom plNonPost)) =
1861+ [ "type" .= String "plain"]
1862+ ++ (commonHighlightPairs plCom)
1863+ ++ (nonPostingsToPairs plNonPost)
1864+
1865+postHighPairs :: Maybe PostingsHighlight -> [Pair]
1866+postHighPairs Nothing = []
1867+postHighPairs (Just (PostingsHighlight pCom)) =
1868+ [ "type" .= String "postings" ]
1869+ ++ (commonHighlightPairs pCom)
1870+
1871+fastVectorHighPairs :: Maybe FastVectorHighlight -> [Pair]
1872+fastVectorHighPairs Nothing = []
1873+fastVectorHighPairs (Just
1874+ (FastVectorHighlight fvCom fvBoundChars fvBoundMaxScan
1875+ fvFragOff fvMatchedFields
1876+ fvNonPostSettings fvPhraseLim)) =
1877+ [ "type" .= String "fvh"
1878+ , "boundary_chars" .= fvBoundChars
1879+ , "boundary_max_scan" .= fvBoundMaxScan
1880+ , "fragment_offset" .= fvFragOff
1881+ , "matched_fields" .= fvMatchedFields
1882+ , "phraseLimit" .= fvPhraseLim]
1883+ ++ (commonHighlightPairs fvCom)
1884+ ++ (nonPostingsToPairs fvNonPostSettings)
1885+
1886+commonHighlightPairs :: Maybe CommonHighlight -> [Pair]
1887+commonHighlightPairs Nothing = []
1888+commonHighlightPairs (Just (CommonHighlight chForceSource chTag chEncoder
1889+ chNoMatchSize chHighlightQuery
1890+ chRequireFieldMatch)) =
1891+ [ "force_source" .= chForceSource
1892+ , "encoder" .= chEncoder
1893+ , "no_match_size" .= chNoMatchSize
1894+ , "highlight_query" .= chHighlightQuery
1895+ , "require_fieldMatch" .= chRequireFieldMatch]
1896+ ++ (highlightTagToPairs chTag)
1897+
1898+
1899+nonPostingsToPairs :: Maybe NonPostings -> [Pair]
1900+nonPostingsToPairs Nothing = []
1901+nonPostingsToPairs (Just (NonPostings npFragSize npNumOfFrags)) =
1902+ [ "fragment_size" .= npFragSize
1903+ , "number_of_fragments" .= npNumOfFrags]
1904+
1905+
1906+
1907+instance ToJSON HighlightEncoder where
1908+ toJSON DefaultEncoder = String "default"
1909+ toJSON HTMLEncoder = String "html"
1910+
1911+highlightTagToPairs :: Maybe HighlightTag -> [Pair]
1912+highlightTagToPairs (Just (TagSchema _)) = [ "scheme" .= String "default"]
1913+highlightTagToPairs (Just (CustomTags (pre, post))) = [ "pre_tags" .= pre
1914+ , "post_tags" .= post]
1915+highlightTagToPairs Nothing = []
1814
1916
1815
1917
1816instance ToJSON SortSpec where
1918instance ToJSON SortSpec where
@@ -1961,11 +2063,12 @@ instance (FromJSON a) => FromJSON (SearchHits a) where
1961
2063
1962instance (FromJSON a) => FromJSON (Hit a) where
2064instance (FromJSON a) => FromJSON (Hit a) where
1963 parseJSON (Object v) = Hit <$>
2065 parseJSON (Object v) = Hit <$>
1964− v .: "_index" <*>
2066+ v .: "_index" <*>
1965− v .: "_type" <*>
2067+ v .: "_type" <*>
1966− v .: "_id" <*>
2068+ v .: "_id" <*>
1967− v .: "_score" <*>
2069+ v .: "_score" <*>
1968− v .: "_source"
2070+ v .: "_source" <*>
2071+ v .:? "highlight"
1969 parseJSON _ = empty
2072 parseJSON _ = empty
1970
2073
1971instance FromJSON ShardResult where
2074instance FromJSON ShardResult where
tests/tests.hs+30−5
@@ -3,6 +3,8 @@
3
3
4module Main where
4module Main where
5
5
6+import Debug.Trace
7+
6import Control.Applicative
8import Control.Applicative
7import Control.Monad
9import Control.Monad
8import Data.Aeson
10import Data.Aeson
@@ -68,12 +70,12 @@ mkServerVersion _ = Nothing
68
70
69getServerVersion :: Server -> IO (Maybe ServerVersion)
71getServerVersion :: Server -> IO (Maybe ServerVersion)
70getServerVersion s = liftM extractVersion (getStatus s)
72getServerVersion s = liftM extractVersion (getStatus s)
71− where
73+ where
72 version' = T.splitOn "." . number . version
74 version' = T.splitOn "." . number . version
73 toInt = read . T.unpack
75 toInt = read . T.unpack
74 parseVersion v = map toInt (version' v)
76 parseVersion v = map toInt (version' v)
75 extractVersion = join . liftM (mkServerVersion . parseVersion)
77 extractVersion = join . liftM (mkServerVersion . parseVersion)
76−
78+
77
79
78
80
79testServerBranch :: IO (Maybe ServerVersion)
81testServerBranch :: IO (Maybe ServerVersion)
@@ -164,10 +166,10 @@ searchExpectNoResults search = do
164searchExpectAggs :: Search -> IO ()
166searchExpectAggs :: Search -> IO ()
165searchExpectAggs search = do
167searchExpectAggs search = do
166 reply <- searchAll testServer search
168 reply <- searchAll testServer search
167− let isEmpty x = return (M.null x)
169+ let isEmpty x = return (M.null x)
168 let result = decode (responseBody reply) :: Maybe (SearchResult Tweet)
170 let result = decode (responseBody reply) :: Maybe (SearchResult Tweet)
169 (result >>= aggregations >>= isEmpty) `shouldBe` Just False
171 (result >>= aggregations >>= isEmpty) `shouldBe` Just False
170−
172+
171searchValidBucketAgg :: (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 ()
172searchValidBucketAgg search aggKey extractor = do
174searchValidBucketAgg search aggKey extractor = do
173 reply <- searchAll testServer search
175 reply <- searchAll testServer search
@@ -183,6 +185,15 @@ searchTermsAggHint hints = do
183 forM_ hints $ searchExpectAggs . search
185 forM_ hints $ searchExpectAggs . search
184 forM_ hints (\x -> searchValidBucketAgg (search x) "users" toTerms)
186 forM_ hints (\x -> searchValidBucketAgg (search x) "users" toTerms)
185
187
188+searchTweetHighlight :: Search -> IO (Either String (Maybe Text))
189+searchTweetHighlight search = do
190+ reply <- searchByIndex testServer testIndex search
191+ traceShowM search
192+ traceShowM reply
193+ let result = eitherDecode (responseBody reply) :: Either String (SearchResult Tweet)
194+ let myHighlight = fmap (hitHighlight . head . hits . searchHits) result
195+ return myHighlight
196+
186data BulkTest = BulkTest { name :: Text } deriving (Eq, Generic, Show)
197data BulkTest = BulkTest { name :: Text } deriving (Eq, Generic, Show)
187instance FromJSON BulkTest
198instance FromJSON BulkTest
188instance ToJSON BulkTest
199instance ToJSON BulkTest
@@ -311,7 +322,7 @@ main = hspec $ do
311 _ <- insertOther
322 _ <- insertOther
312 let sortSpec = DefaultSortSpec $ mkSort (FieldName "age") Ascending
323 let sortSpec = DefaultSortSpec $ mkSort (FieldName "age") Ascending
313 let search = Search Nothing
324 let search = Search Nothing
314− (Just IdentityFilter) (Just [sortSpec]) Nothing
325+ (Just IdentityFilter) (Just [sortSpec]) Nothing Nothing
315 False 0 10
326 False 0 10
316 reply <- searchByIndex testServer testIndex search
327 reply <- searchByIndex testServer testIndex search
317 let result = eitherDecode (responseBody reply) :: Either String (SearchResult Tweet)
328 let result = eitherDecode (responseBody reply) :: Either String (SearchResult Tweet)
@@ -484,6 +495,20 @@ main = hspec $ do
484 forM_ intervals expect
495 forM_ intervals expect
485 forM_ intervals valid
496 forM_ intervals valid
486
497
498+ describe "Highlights API" $ do
499+
500+ it "returns highlight from query" $ do
501+ _ <- insertData
502+ _ <- insertOther
503+ let query = QueryMatchQuery $ mkMatchQuery (FieldName "_all") (QueryString "haskell")
504+ let highlight = Highlights Nothing [FieldHighlight (FieldName "message") Nothing]
505+
506+ traceShowM (encode highlight)
507+ let search = mkHighlightSearch (Just query) highlight
508+ traceShowM (encode search)
509+ myHighlight <- searchTweetHighlight search
510+ myHighlight `shouldBe` Right (Just "")
511+
487 describe "ToJSON RegexpFlags" $ do
512 describe "ToJSON RegexpFlags" $ do
488 it "generates the correct JSON for AllRegexpFlags" $
513 it "generates the correct JSON for AllRegexpFlags" $
489 toJSON AllRegexpFlags `shouldBe` String "ALL"
514 toJSON AllRegexpFlags `shouldBe` String "ALL"