d28751d · typeable/bloodhound

git.iko.soy/typeable/bloodhound

Added ToJSON instances for Highlight types. Added the beginings of tests.

commitd28751d0aa02efa0b054d61796318ceeac6a7d81 authorLiam Atkinson <liamatkinson@gmail.com> dateFri 17 Oct 2014, 14:45 (12 years ago) parentc172009

3 files changed+200−67

compare with master

unifiedsplit

Database/Bloodhound/Client.hs+17−12 Database/Bloodhound/Types.hs+153−50 tests/tests.hs+30−5

Database/Bloodhound/Client.hs+17−12

@@ -16,6 +16,7 @@ module Database.Bloodhound.Client

1616 , refreshIndex

1717 , mkSearch

1818 , mkAggregateSearch

19+ , mkHighlightSearch

1920 , bulk

2021 , pageSearch

2122 , mkShardCount

@@ -24,18 +25,18 @@ module Database.Bloodhound.Client

2425 )

2526 where

2627

27−import Data.Aeson

28+import Data.Aeson

29+import Data.ByteString.Builder

2830import qualified Data.ByteString.Lazy.Char8 as L

29−import Data.ByteString.Builder

30−import Data.List (foldl', intercalate, intersperse)

31−import Data.Maybe (fromMaybe)

32−import Data.Text (Text)

33−import Network.HTTP.Client

34−import qualified Network.HTTP.Types.Method as NHTM

35−import qualified Network.HTTP.Types.Status as NHTS

36−import Prelude hiding (head, filter)

31+import Data.List (foldl', intercalate, intersperse)

32+import Data.Maybe (fromMaybe)

33+import Data.Text (Text)

34+import Network.HTTP.Client

35+import qualified Network.HTTP.Types.Method as NHTM

36+import qualified Network.HTTP.Types.Status as NHTS

37+import Prelude hiding (filter, head)

3738

38−import Database.Bloodhound.Types

39+import Database.Bloodhound.Types

3940

4041-- find way to avoid destructuring Servers and Indexes?

4142-- make get, post, put, delete helpers.

@@ -245,10 +246,14 @@ searchByType (Server server) (IndexName indexName)

245246 url = joinPath [server, indexName, mappingName, "_search"]

246247

247248mkSearch :: 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

249250

250251mkAggregateSearch :: 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

252257

253258pageSearch :: Int -> Int -> Search -> Search

254259pageSearch pageFrom pageSize search = search { from = pageFrom, size = pageSize }

Database/Bloodhound/Types.hs+153−50

@@ -162,13 +162,26 @@ 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+

165177 , TermsResult

166178 , DateHistogramResult

167179 ) where

168180

169181import Control.Applicative

170182import Data.Aeson

171−import Data.Aeson.Types (parseMaybe)

183+import Data.Aeson.Types (Pair (..), emptyObject,

184+ parseMaybe)

172185import qualified Data.ByteString.Lazy.Char8 as L

173186import Data.List (nub)

174187import Data.List.NonEmpty (NonEmpty (..))

@@ -500,58 +513,65 @@ data Search = Search { queryBody :: Maybe Query

500513 , filterBody :: Maybe Filter

501514 , sortBody :: Maybe Sort

502515 , aggBody :: Maybe Aggregations

516+ , highlight :: Maybe Highlights

503517 -- default False

504518 , trackSortScores :: TrackSortScores

505519 , from :: From

506520 , size :: Size } deriving (Eq, Show)

507521

508−data Highlights = Hightlights { globalsettings :: Maybe HighlightSettings

509− , highlightFields :: [(FieldName, HighlightSettings)]

510− }

522+data Highlights = Highlights { globalsettings :: Maybe HighlightSettings

523+ , highlightFields :: [FieldHighlight]

524+ } deriving (Show, Eq)

511525

512−data HighlightSettings = Plain PlainHighlightSettings

513− | Postings PostingsHighlightSettings

514− | FastVector FastVectorHighlightSettings

526+data FieldHighlight = FieldHighlight FieldName (Maybe HighlightSettings)

527+ deriving (Show, Eq)

515528

516−data PlainHighlightSettings = PlainHighlightSettings { plainCommonSettings :: Maybe CommonHighlightSettings

517− , plainNonPostSettings :: Maybe NonPostingsSettings }

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)

518537

519538 -- 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)

521540

522541-- This requires that term_vector is set to 'with_positions_offsets' in the mapping.

523−data FastVectorHighlightSettings = FastVectorHighlightSettings { boundaryChars :: Maybe Text

524− , boundaryMaxScan :: Maybe Int

525− , fragmentOffset :: Maybe Int

526− , matchedFields :: [Text]

527− , fvNonPostSettings :: Maybe NonPostingsSettings

528− , phraseLimit :: Maybe Int

529− }

530−

531−data CommonHighlightSettings = CommonHighlightSettings { highlightType :: Maybe HighlightType -- See below.

532− , forceSource :: Maybe Bool

533− , tagSettings :: Maybe HighlightTagSettings

534− , encoder :: Maybe HighlightEncoder

535− , noMatchSize :: Maybe Int

536− , highlightQuery :: Maybe Query

537− , requireFieldMatch :: Maybe Bool

538− }

542+data FastVectorHighlight =

543+ FastVectorHighlight { fvCommon :: Maybe CommonHighlight

544+ , boundaryChars :: Maybe Text

545+ , boundaryMaxScan :: Maybe Int

546+ , fragmentOffset :: Maybe Int

547+ , matchedFields :: [Text]

548+ , fvNonPostSettings :: Maybe NonPostings

549+ , phraseLimit :: Maybe Int

550+ } deriving (Show, Eq)

551+

552+data CommonHighlight =

553+ CommonHighlight {

554+ -- highlightType :: Maybe HighlightType -- See below.

555+ forceSource :: Maybe Bool

556+ , tag :: Maybe HighlightTag

557+ , encoder :: Maybe HighlightEncoder

558+ , noMatchSize :: Maybe Int

559+ , highlightQuery :: Maybe Query

560+ , requireFieldMatch :: Maybe Bool

561+ } deriving (Show, Eq)

539562-- Settings that are only applicable to FastVector and Plain highlighters.

540−data NonPostingsSettings = NonPostingsSettings { fragmentSize :: Maybe Int

541− , numberOfFragments :: Maybe Int}

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

563+data NonPostings =

564+ NonPostings { fragmentSize :: Maybe Int

565+ , numberOfFragments :: Maybe Int} deriving (Show, Eq)

549566

550−data HighlightEncoder = DefaultEncoder | HTMLEncoder

567+data HighlightEncoder = DefaultEncoder

568+ | HTMLEncoder

569+ deriving (Show, Eq)

551570

552571-- NOTE: Should the tags use some kind of HTML type, rather than Text?

553−data HighlightTagSettings = TagSchema Text

554− | CustomTags ([Text], [Text]) -- Only uses more than the first value in the lists if fvh

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)

555575

556576

557577data Query =

@@ -1002,11 +1022,12 @@ data FromJSON a => SearchHits a =

10021022 , hits :: [Hit a] } deriving (Eq, Show)

10031023

10041024data FromJSON a => Hit a =

1005− Hit { hitIndex :: IndexName

1006− , hitType :: MappingName

1007− , hitDocId :: DocId

1008− , hitScore :: Score

1009− , hitSource :: a } deriving (Eq, Show)

1025+ Hit { hitIndex :: IndexName

1026+ , hitType :: MappingName

1027+ , hitDocId :: DocId

1028+ , hitScore :: Score

1029+ , hitSource :: a

1030+ , hitHighlight :: Maybe Text } deriving (Eq, Show)

10101031

10111032data ShardResult =

10121033 ShardResult { shardTotal :: Int

@@ -1803,14 +1824,95 @@ instance (FromJSON a) => FromJSON (EsResult a) where

18031824

18041825

18051826instance ToJSON Search where

1806− toJSON (Search query sFilter sort aggs sTrackSortScores sFrom sSize) =

1827+ toJSON (Search query sFilter sort aggs highlight sTrackSortScores sFrom sSize) =

18071828 omitNulls [ "query" .= query

18081829 , "filter" .= sFilter

18091830 , "sort" .= sort

18101831 , "aggregations" .= aggs

1832+ , "highlight" .= highlight

18111833 , "from" .= sFrom

18121834 , "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 = []

18141916

18151917

18161918instance ToJSON SortSpec where

@@ -1961,11 +2063,12 @@ instance (FromJSON a) => FromJSON (SearchHits a) where

19612063

19622064instance (FromJSON a) => FromJSON (Hit a) where

19632065 parseJSON (Object v) = Hit <$>

1964− v .: "_index" <*>

1965− v .: "_type" <*>

1966− v .: "_id" <*>

1967− v .: "_score" <*>

1968− v .: "_source"

2066+ v .: "_index" <*>

2067+ v .: "_type" <*>

2068+ v .: "_id" <*>

2069+ v .: "_score" <*>

2070+ v .: "_source" <*>

2071+ v .:? "highlight"

19692072 parseJSON _ = empty

19702073

19712074instance FromJSON ShardResult where

tests/tests.hs+30−5

@@ -3,6 +3,8 @@

44module Main where

6+import Debug.Trace

68import Control.Applicative

79import Control.Monad

810import Data.Aeson

@@ -68,12 +70,12 @@ mkServerVersion _ = Nothing

6870

6971getServerVersion :: Server -> IO (Maybe ServerVersion)

7072getServerVersion s = liftM extractVersion (getStatus s)

71− where

73+ where

7274 version' = T.splitOn "." . number . version

7375 toInt = read . T.unpack

7476 parseVersion v = map toInt (version' v)

7577 extractVersion = join . liftM (mkServerVersion . parseVersion)

76−

78+

7779

7880

7981testServerBranch :: IO (Maybe ServerVersion)

@@ -164,10 +166,10 @@ searchExpectNoResults search = do

164166searchExpectAggs :: Search -> IO ()

165167searchExpectAggs search = do

166168 reply <- searchAll testServer search

167− let isEmpty x = return (M.null x)

169+ let isEmpty x = return (M.null x)

168170 let result = decode (responseBody reply) :: Maybe (SearchResult Tweet)

169171 (result >>= aggregations >>= isEmpty) `shouldBe` Just False

170−

172+

171173searchValidBucketAgg :: (BucketAggregation a, FromJSON a, Show a) => Search -> Text -> (Text -> AggregationResults -> Maybe (Bucket a)) -> IO ()

172174searchValidBucketAgg search aggKey extractor = do

173175 reply <- searchAll testServer search

@@ -183,6 +185,15 @@ searchTermsAggHint hints = do

183185 forM_ hints $ searchExpectAggs . search

184186 forM_ hints (\x -> searchValidBucketAgg (search x) "users" toTerms)

185187

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+

186197data BulkTest = BulkTest { name :: Text } deriving (Eq, Generic, Show)

187198instance FromJSON BulkTest

188199instance ToJSON BulkTest

@@ -311,7 +322,7 @@ main = hspec $ do

311322 _ <- insertOther

312323 let sortSpec = DefaultSortSpec $ mkSort (FieldName "age") Ascending

313324 let search = Search Nothing

314− (Just IdentityFilter) (Just [sortSpec]) Nothing

325+ (Just IdentityFilter) (Just [sortSpec]) Nothing Nothing

315326 False 0 10

316327 reply <- searchByIndex testServer testIndex search

317328 let result = eitherDecode (responseBody reply) :: Either String (SearchResult Tweet)

@@ -484,6 +495,20 @@ main = hspec $ do

484495 forM_ intervals expect

485496 forM_ intervals valid

486497

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+

487512 describe "ToJSON RegexpFlags" $ do

488513 it "generates the correct JSON for AllRegexpFlags" $

489514 toJSON AllRegexpFlags `shouldBe` String "ALL"