diff --git a/Database/Bloodhound/Client.hs b/Database/Bloodhound/Client.hs index 9e10395..7191398 100644 --- a/Database/Bloodhound/Client.hs +++ b/Database/Bloodhound/Client.hs @@ -16,6 +16,7 @@ module Database.Bloodhound.Client , refreshIndex , mkSearch , mkAggregateSearch + , mkHighlightSearch , bulk , pageSearch , mkShardCount @@ -24,18 +25,18 @@ module Database.Bloodhound.Client ) where -import Data.Aeson +import Data.Aeson +import Data.ByteString.Builder import qualified Data.ByteString.Lazy.Char8 as L -import Data.ByteString.Builder -import Data.List (foldl', intercalate, intersperse) -import Data.Maybe (fromMaybe) -import Data.Text (Text) -import Network.HTTP.Client -import qualified Network.HTTP.Types.Method as NHTM -import qualified Network.HTTP.Types.Status as NHTS -import Prelude hiding (head, filter) +import Data.List (foldl', intercalate, intersperse) +import Data.Maybe (fromMaybe) +import Data.Text (Text) +import Network.HTTP.Client +import qualified Network.HTTP.Types.Method as NHTM +import qualified Network.HTTP.Types.Status as NHTS +import Prelude hiding (filter, head) -import Database.Bloodhound.Types +import Database.Bloodhound.Types -- find way to avoid destructuring Servers and Indexes? -- make get, post, put, delete helpers. @@ -245,10 +246,14 @@ searchByType (Server server) (IndexName indexName) url = joinPath [server, indexName, mappingName, "_search"] mkSearch :: Maybe Query -> Maybe Filter -> Search -mkSearch query filter = Search query filter Nothing Nothing False 0 10 +mkSearch query filter = Search query filter Nothing Nothing Nothing False 0 10 mkAggregateSearch :: Maybe Query -> Aggregations -> Search -mkAggregateSearch query aggregations = Search query Nothing Nothing (Just aggregations) False 0 0 +mkAggregateSearch query aggregations = Search query Nothing Nothing (Just aggregations) Nothing False 0 0 + + +mkHighlightSearch :: Maybe Query -> Highlights -> Search +mkHighlightSearch query searchHighlights = Search query Nothing Nothing Nothing (Just searchHighlights) False 0 10 pageSearch :: Int -> Int -> Search -> Search pageSearch pageFrom pageSize search = search { from = pageFrom, size = pageSize } diff --git a/Database/Bloodhound/Types.hs b/Database/Bloodhound/Types.hs index 7d93d65..282a6be 100644 --- a/Database/Bloodhound/Types.hs +++ b/Database/Bloodhound/Types.hs @@ -162,13 +162,26 @@ module Database.Bloodhound.Types , BucketAggregation(..) , TermsAggregation(..) , DateHistogramAggregation(..) + + , Highlights(..) + , FieldHighlight(..) + , HighlightSettings(..) + , PlainHighlight(..) + , PostingsHighlight(..) + , FastVectorHighlight(..) + , CommonHighlight(..) + , NonPostings(..) + , HighlightEncoder(..) + , HighlightTag(..) + , TermsResult , DateHistogramResult ) where import Control.Applicative import Data.Aeson -import Data.Aeson.Types (parseMaybe) +import Data.Aeson.Types (Pair (..), emptyObject, + parseMaybe) import qualified Data.ByteString.Lazy.Char8 as L import Data.List (nub) import Data.List.NonEmpty (NonEmpty (..)) @@ -500,58 +513,65 @@ data Search = Search { queryBody :: Maybe Query , filterBody :: Maybe Filter , sortBody :: Maybe Sort , aggBody :: Maybe Aggregations + , highlight :: Maybe Highlights -- default False , trackSortScores :: TrackSortScores , from :: From , size :: Size } deriving (Eq, Show) -data Highlights = Hightlights { globalsettings :: Maybe HighlightSettings - , highlightFields :: [(FieldName, HighlightSettings)] - } +data Highlights = Highlights { globalsettings :: Maybe HighlightSettings + , highlightFields :: [FieldHighlight] + } deriving (Show, Eq) -data HighlightSettings = Plain PlainHighlightSettings - | Postings PostingsHighlightSettings - | FastVector FastVectorHighlightSettings +data FieldHighlight = FieldHighlight FieldName (Maybe HighlightSettings) + deriving (Show, Eq) -data PlainHighlightSettings = PlainHighlightSettings { plainCommonSettings :: Maybe CommonHighlightSettings - , plainNonPostSettings :: Maybe NonPostingsSettings } + +data HighlightSettings = Plain PlainHighlight + | Postings PostingsHighlight + | FastVector FastVectorHighlight + deriving (Show, Eq) +data PlainHighlight = + PlainHighlight { plainCommon :: Maybe CommonHighlight + , plainNonPost :: Maybe NonPostings } deriving (Show, Eq) -- This requires that index_options are set to 'offset' in the mapping. -data PostingsHighlightSettings = PostingsHighlightSettings (Maybe CommonHighlightSettings) +data PostingsHighlight = PostingsHighlight (Maybe CommonHighlight) deriving (Show, Eq) -- This requires that term_vector is set to 'with_positions_offsets' in the mapping. -data FastVectorHighlightSettings = FastVectorHighlightSettings { boundaryChars :: Maybe Text - , boundaryMaxScan :: Maybe Int - , fragmentOffset :: Maybe Int - , matchedFields :: [Text] - , fvNonPostSettings :: Maybe NonPostingsSettings - , phraseLimit :: Maybe Int - } +data FastVectorHighlight = + FastVectorHighlight { fvCommon :: Maybe CommonHighlight + , boundaryChars :: Maybe Text + , boundaryMaxScan :: Maybe Int + , fragmentOffset :: Maybe Int + , matchedFields :: [Text] + , fvNonPostSettings :: Maybe NonPostings + , phraseLimit :: Maybe Int + } deriving (Show, Eq) -data CommonHighlightSettings = CommonHighlightSettings { highlightType :: Maybe HighlightType -- See below. - , forceSource :: Maybe Bool - , tagSettings :: Maybe HighlightTagSettings - , encoder :: Maybe HighlightEncoder - , noMatchSize :: Maybe Int - , highlightQuery :: Maybe Query - , requireFieldMatch :: Maybe Bool - } +data CommonHighlight = + CommonHighlight { + -- highlightType :: Maybe HighlightType -- See below. + forceSource :: Maybe Bool + , tag :: Maybe HighlightTag + , encoder :: Maybe HighlightEncoder + , noMatchSize :: Maybe Int + , highlightQuery :: Maybe Query + , requireFieldMatch :: Maybe Bool + } deriving (Show, Eq) -- Settings that are only applicable to FastVector and Plain highlighters. -data NonPostingsSettings = NonPostingsSettings { fragmentSize :: Maybe Int - , numberOfFragments :: Maybe Int} +data NonPostings = + NonPostings { fragmentSize :: Maybe Int + , numberOfFragments :: Maybe Int} deriving (Show, Eq) --- Used to force the type of highlighter used, if a different one is used on the mapping. --- NOTE: Is there a way to ignore this, and just have it become part of the ToJSON instance --- for the appropriate hightlight settings? -data HighlightType = PlainType - | PostingsType - | FastVectorType - -data HighlightEncoder = DefaultEncoder | HTMLEncoder +data HighlightEncoder = DefaultEncoder + | HTMLEncoder + deriving (Show, Eq) -- NOTE: Should the tags use some kind of HTML type, rather than Text? -data HighlightTagSettings = TagSchema Text - | CustomTags ([Text], [Text]) -- Only uses more than the first value in the lists if fvh +data HighlightTag = TagSchema Text + | CustomTags ([Text], [Text]) -- Only uses more than the first value in the lists if fvh + deriving (Show, Eq) data Query = @@ -1002,11 +1022,12 @@ data FromJSON a => SearchHits a = , hits :: [Hit a] } deriving (Eq, Show) data FromJSON a => Hit a = - Hit { hitIndex :: IndexName - , hitType :: MappingName - , hitDocId :: DocId - , hitScore :: Score - , hitSource :: a } deriving (Eq, Show) + Hit { hitIndex :: IndexName + , hitType :: MappingName + , hitDocId :: DocId + , hitScore :: Score + , hitSource :: a + , hitHighlight :: Maybe Text } deriving (Eq, Show) data ShardResult = ShardResult { shardTotal :: Int @@ -1803,14 +1824,95 @@ instance (FromJSON a) => FromJSON (EsResult a) where instance ToJSON Search where - toJSON (Search query sFilter sort aggs sTrackSortScores sFrom sSize) = + toJSON (Search query sFilter sort aggs highlight sTrackSortScores sFrom sSize) = omitNulls [ "query" .= query , "filter" .= sFilter , "sort" .= sort , "aggregations" .= aggs + , "highlight" .= highlight , "from" .= sFrom , "size" .= sSize - , "track_scores" .= sTrackSortScores ] + , "track_scores" .= sTrackSortScores] + +instance ToJSON FieldHighlight where + toJSON (FieldHighlight (FieldName fName) (Just fSettings)) = + object [ fName .= fSettings ] + toJSON (FieldHighlight (FieldName fName) Nothing) = + object [ fName .= emptyObject ] + +instance ToJSON Highlights where + toJSON (Highlights global fields) = + omitNulls (["fields" .= toJSON fields] + ++ (highlightSettingsPairs global)) + +instance ToJSON HighlightSettings where + toJSON hs = omitNulls (highlightSettingsPairs (Just hs)) + +highlightSettingsPairs :: Maybe HighlightSettings -> [Pair] +highlightSettingsPairs Nothing = [] +highlightSettingsPairs (Just (Plain plh)) = plainHighPairs (Just plh) +highlightSettingsPairs (Just (Postings ph)) = postHighPairs (Just ph) +highlightSettingsPairs (Just (FastVector fvh)) = fastVectorHighPairs (Just fvh) + + +plainHighPairs :: Maybe PlainHighlight -> [Pair] +plainHighPairs Nothing = [] +plainHighPairs (Just (PlainHighlight plCom plNonPost)) = + [ "type" .= String "plain"] + ++ (commonHighlightPairs plCom) + ++ (nonPostingsToPairs plNonPost) + +postHighPairs :: Maybe PostingsHighlight -> [Pair] +postHighPairs Nothing = [] +postHighPairs (Just (PostingsHighlight pCom)) = + [ "type" .= String "postings" ] + ++ (commonHighlightPairs pCom) + +fastVectorHighPairs :: Maybe FastVectorHighlight -> [Pair] +fastVectorHighPairs Nothing = [] +fastVectorHighPairs (Just + (FastVectorHighlight fvCom fvBoundChars fvBoundMaxScan + fvFragOff fvMatchedFields + fvNonPostSettings fvPhraseLim)) = + [ "type" .= String "fvh" + , "boundary_chars" .= fvBoundChars + , "boundary_max_scan" .= fvBoundMaxScan + , "fragment_offset" .= fvFragOff + , "matched_fields" .= fvMatchedFields + , "phraseLimit" .= fvPhraseLim] + ++ (commonHighlightPairs fvCom) + ++ (nonPostingsToPairs fvNonPostSettings) + +commonHighlightPairs :: Maybe CommonHighlight -> [Pair] +commonHighlightPairs Nothing = [] +commonHighlightPairs (Just (CommonHighlight chForceSource chTag chEncoder + chNoMatchSize chHighlightQuery + chRequireFieldMatch)) = + [ "force_source" .= chForceSource + , "encoder" .= chEncoder + , "no_match_size" .= chNoMatchSize + , "highlight_query" .= chHighlightQuery + , "require_fieldMatch" .= chRequireFieldMatch] + ++ (highlightTagToPairs chTag) + + +nonPostingsToPairs :: Maybe NonPostings -> [Pair] +nonPostingsToPairs Nothing = [] +nonPostingsToPairs (Just (NonPostings npFragSize npNumOfFrags)) = + [ "fragment_size" .= npFragSize + , "number_of_fragments" .= npNumOfFrags] + + + +instance ToJSON HighlightEncoder where + toJSON DefaultEncoder = String "default" + toJSON HTMLEncoder = String "html" + +highlightTagToPairs :: Maybe HighlightTag -> [Pair] +highlightTagToPairs (Just (TagSchema _)) = [ "scheme" .= String "default"] +highlightTagToPairs (Just (CustomTags (pre, post))) = [ "pre_tags" .= pre + , "post_tags" .= post] +highlightTagToPairs Nothing = [] instance ToJSON SortSpec where @@ -1961,11 +2063,12 @@ instance (FromJSON a) => FromJSON (SearchHits a) where instance (FromJSON a) => FromJSON (Hit a) where parseJSON (Object v) = Hit <$> - v .: "_index" <*> - v .: "_type" <*> - v .: "_id" <*> - v .: "_score" <*> - v .: "_source" + v .: "_index" <*> + v .: "_type" <*> + v .: "_id" <*> + v .: "_score" <*> + v .: "_source" <*> + v .:? "highlight" parseJSON _ = empty instance FromJSON ShardResult where diff --git a/tests/tests.hs b/tests/tests.hs index 95bed25..6350aa4 100644 --- a/tests/tests.hs +++ b/tests/tests.hs @@ -3,6 +3,8 @@ module Main where +import Debug.Trace + import Control.Applicative import Control.Monad import Data.Aeson @@ -68,12 +70,12 @@ mkServerVersion _ = Nothing getServerVersion :: Server -> IO (Maybe ServerVersion) getServerVersion s = liftM extractVersion (getStatus s) - where + where version' = T.splitOn "." . number . version toInt = read . T.unpack parseVersion v = map toInt (version' v) extractVersion = join . liftM (mkServerVersion . parseVersion) - + testServerBranch :: IO (Maybe ServerVersion) @@ -164,10 +166,10 @@ searchExpectNoResults search = do searchExpectAggs :: Search -> IO () searchExpectAggs search = do reply <- searchAll testServer search - let isEmpty x = return (M.null x) + let isEmpty x = return (M.null x) let result = decode (responseBody reply) :: Maybe (SearchResult Tweet) (result >>= aggregations >>= isEmpty) `shouldBe` Just False - + searchValidBucketAgg :: (BucketAggregation a, FromJSON a, Show a) => Search -> Text -> (Text -> AggregationResults -> Maybe (Bucket a)) -> IO () searchValidBucketAgg search aggKey extractor = do reply <- searchAll testServer search @@ -183,6 +185,15 @@ searchTermsAggHint hints = do forM_ hints $ searchExpectAggs . search forM_ hints (\x -> searchValidBucketAgg (search x) "users" toTerms) +searchTweetHighlight :: Search -> IO (Either String (Maybe Text)) +searchTweetHighlight search = do + reply <- searchByIndex testServer testIndex search + traceShowM search + traceShowM reply + let result = eitherDecode (responseBody reply) :: Either String (SearchResult Tweet) + let myHighlight = fmap (hitHighlight . head . hits . searchHits) result + return myHighlight + data BulkTest = BulkTest { name :: Text } deriving (Eq, Generic, Show) instance FromJSON BulkTest instance ToJSON BulkTest @@ -311,7 +322,7 @@ main = hspec $ do _ <- insertOther let sortSpec = DefaultSortSpec $ mkSort (FieldName "age") Ascending let search = Search Nothing - (Just IdentityFilter) (Just [sortSpec]) Nothing + (Just IdentityFilter) (Just [sortSpec]) Nothing Nothing False 0 10 reply <- searchByIndex testServer testIndex search let result = eitherDecode (responseBody reply) :: Either String (SearchResult Tweet) @@ -484,6 +495,20 @@ main = hspec $ do forM_ intervals expect forM_ intervals valid + describe "Highlights API" $ do + + it "returns highlight from query" $ do + _ <- insertData + _ <- insertOther + let query = QueryMatchQuery $ mkMatchQuery (FieldName "_all") (QueryString "haskell") + let highlight = Highlights Nothing [FieldHighlight (FieldName "message") Nothing] + + traceShowM (encode highlight) + let search = mkHighlightSearch (Just query) highlight + traceShowM (encode search) + myHighlight <- searchTweetHighlight search + myHighlight `shouldBe` Right (Just "") + describe "ToJSON RegexpFlags" $ do it "generates the correct JSON for AllRegexpFlags" $ toJSON AllRegexpFlags `shouldBe` String "ALL"