typeable/bloodhound
1
0
Fork 0
mirror of https://github.com/typeable/bloodhound.git synced 2024-12-03 23:15:14 +03:00
Code Issues Projects Releases Wiki Activity

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

Browse Source
This commit is contained in:
Liam Atkinson 2014-10-17 14:45:50 +01:00
parent c172009434
commit d28751d0aa
3 changed files with 199 additions and 66 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

29
Database/Bloodhound/Client.hs
View File

@ -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 }

201
Database/Bloodhound/Types.hs
View File

@ -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

35
tests/tests.hs
View File

@ -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"