@@ -414,9 +414,6 @@ module Database.V5.Bloodhound.Types
414414
415415import Bloodhound.Import
416416
417−import qualified Data.HashMap.Strict as HM
418−import qualified Data.Map.Strict as M
419−
420417import Database.V5.Bloodhound.Types.Class
421418import Database.V5.Bloodhound.Internal.Analysis
422419import Database.V5.Bloodhound.Internal.Aggregation
@@ -425,6 +422,7 @@ import Database.V5.Bloodhound.Internal.Highlight
425422import Database.V5.Bloodhound.Internal.Newtypes
426423import Database.V5.Bloodhound.Internal.Query
427424import Database.V5.Bloodhound.Internal.Sort
425+import Database.V5.Bloodhound.Internal.Suggest
428426
429427{-| 'unpackId' is a silly convenience function that gets used once.
430428-}
@@ -484,14 +482,32 @@ data Source =
484482 | SourceIncludeExclude Include Exclude
485483 deriving (Eq, Show)
486484
485+instance ToJSON Source where
486+ toJSON NoSource = toJSON False
487+ toJSON (SourcePatterns patterns) = toJSON patterns
488+ toJSON (SourceIncludeExclude incl excl) = object [ "includes" .= incl, "excludes" .= excl ]
489+
487490data PatternOrPatterns = PopPattern Pattern
488491 | PopPatterns [Pattern] deriving (Eq, Read, Show)
489492
493+instance ToJSON PatternOrPatterns where
494+ toJSON (PopPattern pattern) = toJSON pattern
495+ toJSON (PopPatterns patterns) = toJSON patterns
496+
490497data Include = Include [Pattern] deriving (Eq, Read, Show)
491498data Exclude = Exclude [Pattern] deriving (Eq, Read, Show)
492499
500+instance ToJSON Include where
501+ toJSON (Include patterns) = toJSON patterns
502+
503+instance ToJSON Exclude where
504+ toJSON (Exclude patterns) = toJSON patterns
505+
493506newtype Pattern = Pattern Text deriving (Eq, Read, Show)
494507
508+instance ToJSON Pattern where
509+ toJSON (Pattern pattern) = toJSON pattern
510+
495511data SearchResult a =
496512 SearchResult { took :: Int
497513 , timedOut :: Bool
@@ -499,7 +515,8 @@ data SearchResult a =
499515 , searchHits :: SearchHits a
500516 , aggregations :: Maybe AggregationResults
501517 , scrollId :: Maybe ScrollId
502− -- ^ Only one Suggestion request / response per Search is supported.
518+ -- ^ Only one Suggestion request / response per
519+ -- Search is supported.
503520 , suggest :: Maybe NamedSuggestionResponse
504521 }
505522 deriving (Eq, Show)
@@ -518,514 +535,3 @@ instance (FromJSON a) => FromJSON (SearchResult a) where
518535newtype ScrollId =
519536 ScrollId Text
520537 deriving (Eq, Show, Ord, ToJSON, FromJSON)
521−
522−data SearchHits a =
523− SearchHits { hitsTotal :: Int
524− , maxScore :: Score
525− , hits :: [Hit a] } deriving (Eq, Show)
526−
527−
528−instance (FromJSON a) => FromJSON (SearchHits a) where
529− parseJSON (Object v) = SearchHits <$>
530− v .: "total" <*>
531− v .: "max_score" <*>
532− v .: "hits"
533− parseJSON _ = empty
534−
535−instance Semigroup (SearchHits a) where
536− (SearchHits ta ma ha) <> (SearchHits tb mb hb) =
537− SearchHits (ta + tb) (max ma mb) (ha <> hb)
538−
539−instance Monoid (SearchHits a) where
540− mempty = SearchHits 0 Nothing mempty
541− mappend = (<>)
542−
543−data Hit a =
544− Hit { hitIndex :: IndexName
545− , hitType :: MappingName
546− , hitDocId :: DocId
547− , hitScore :: Score
548− , hitSource :: Maybe a
549− , hitFields :: Maybe HitFields
550− , hitHighlight :: Maybe HitHighlight } deriving (Eq, Show)
551−
552−instance (FromJSON a) => FromJSON (Hit a) where
553− parseJSON (Object v) = Hit <$>
554− v .: "_index" <*>
555− v .: "_type" <*>
556− v .: "_id" <*>
557− v .: "_score" <*>
558− v .:? "_source" <*>
559− v .:? "fields" <*>
560− v .:? "highlight"
561− parseJSON _ = empty
562−
563−data MissingResult = MissingResult
564− { missingDocCount :: Int
565− } deriving (Show)
566−
567−instance FromJSON MissingResult where
568− parseJSON = withObject "MissingResult" parse
569− where parse v = MissingResult <$> v .: "doc_count"
570−
571−data TopHitResult a = TopHitResult
572− { tarHits :: (SearchHits a)
573− } deriving Show
574−
575−instance (FromJSON a) => FromJSON (TopHitResult a) where
576− parseJSON (Object v) = TopHitResult <$>
577− v .: "hits"
578− parseJSON _ = fail "Failure in FromJSON (TopHitResult a)"
579−
580−data TermsResult = TermsResult
581− { termKey :: BucketValue
582− , termsDocCount :: Int
583− , termsAggs :: Maybe AggregationResults
584− } deriving (Read, Show)
585−
586−instance FromJSON TermsResult where
587− parseJSON (Object v) = TermsResult <$>
588− v .: "key" <*>
589− v .: "doc_count" <*>
590− (pure $ getNamedSubAgg v ["key", "doc_count"])
591− parseJSON _ = mempty
592−
593−instance BucketAggregation TermsResult where
594− key = termKey
595− docCount = termsDocCount
596− aggs = termsAggs
597−
598−data DateHistogramResult = DateHistogramResult
599− { dateKey :: Int
600− , dateKeyStr :: Maybe Text
601− , dateDocCount :: Int
602− , dateHistogramAggs :: Maybe AggregationResults
603− } deriving (Show)
604−
605−instance FromJSON DateHistogramResult where
606− parseJSON (Object v) = DateHistogramResult <$>
607− v .: "key" <*>
608− v .:? "key_as_string" <*>
609− v .: "doc_count" <*>
610− (pure $ getNamedSubAgg v [ "key"
611− , "doc_count"
612− , "key_as_string"
613− ]
614− )
615− parseJSON _ = mempty
616−
617−instance BucketAggregation DateHistogramResult where
618− key = TextValue . showText . dateKey
619− docCount = dateDocCount
620− aggs = dateHistogramAggs
621−
622−data DateRangeResult = DateRangeResult
623− { dateRangeKey :: Text
624− , dateRangeFrom :: Maybe UTCTime
625− , dateRangeFromAsString :: Maybe Text
626− , dateRangeTo :: Maybe UTCTime
627− , dateRangeToAsString :: Maybe Text
628− , dateRangeDocCount :: Int
629− , dateRangeAggs :: Maybe AggregationResults
630− } deriving (Eq, Show)
631−
632−instance FromJSON DateRangeResult where
633− parseJSON = withObject "DateRangeResult" parse
634− where parse v = DateRangeResult <$>
635− v .: "key" <*>
636− (fmap posixMS <$> v .:? "from") <*>
637− v .:? "from_as_string" <*>
638− (fmap posixMS <$> v .:? "to") <*>
639− v .:? "to_as_string" <*>
640− v .: "doc_count" <*>
641− (pure $ getNamedSubAgg v [ "key"
642− , "from"
643− , "from_as_string"
644− , "to"
645− , "to_as_string"
646− , "doc_count"
647− ]
648− )
649−
650−instance BucketAggregation DateRangeResult where
651− key = TextValue . dateRangeKey
652− docCount = dateRangeDocCount
653− aggs = dateRangeAggs
654−
655−toTerms :: Text -> AggregationResults -> Maybe (Bucket TermsResult)
656−toTerms = toAggResult
657−
658−toDateHistogram :: Text -> AggregationResults -> Maybe (Bucket DateHistogramResult)
659−toDateHistogram = toAggResult
660−
661−toMissing :: Text -> AggregationResults -> Maybe MissingResult
662−toMissing = toAggResult
663−
664−toTopHits :: (FromJSON a) => Text -> AggregationResults -> Maybe (TopHitResult a)
665−toTopHits = toAggResult
666−
667−toAggResult :: (FromJSON a) => Text -> AggregationResults -> Maybe a
668−toAggResult t a = M.lookup t a >>= deserialize
669− where deserialize = parseMaybe parseJSON
670−
671−-- Try to get an AggregationResults when we don't know the
672−-- field name. We filter out the known keys to try to minimize the noise.
673−getNamedSubAgg :: Object -> [Text] -> Maybe AggregationResults
674−getNamedSubAgg o knownKeys = maggRes
675− where unknownKeys = HM.filterWithKey (\k _ -> k `notElem` knownKeys) o
676− maggRes
677− | HM.null unknownKeys = Nothing
678− | otherwise = Just . M.fromList $ HM.toList unknownKeys
679−
680−instance ToJSON Source where
681− toJSON NoSource = toJSON False
682− toJSON (SourcePatterns patterns) = toJSON patterns
683− toJSON (SourceIncludeExclude incl excl) = object [ "includes" .= incl, "excludes" .= excl ]
684−
685−instance ToJSON PatternOrPatterns where
686− toJSON (PopPattern pattern) = toJSON pattern
687− toJSON (PopPatterns patterns) = toJSON patterns
688−
689−instance ToJSON Include where
690− toJSON (Include patterns) = toJSON patterns
691−
692−instance ToJSON Exclude where
693− toJSON (Exclude patterns) = toJSON patterns
694−
695−instance ToJSON Pattern where
696− toJSON (Pattern pattern) = toJSON pattern
697−
698−
699−instance ToJSON FieldHighlight where
700− toJSON (FieldHighlight (FieldName fName) (Just fSettings)) =
701− object [ fName .= fSettings ]
702− toJSON (FieldHighlight (FieldName fName) Nothing) =
703− object [ fName .= emptyObject ]
704−
705−instance ToJSON Highlights where
706− toJSON (Highlights global fields) =
707− omitNulls (("fields" .= fields)
708− : highlightSettingsPairs global)
709−
710−instance ToJSON HighlightSettings where
711− toJSON hs = omitNulls (highlightSettingsPairs (Just hs))
712−
713−highlightSettingsPairs :: Maybe HighlightSettings -> [Pair]
714−highlightSettingsPairs Nothing = []
715−highlightSettingsPairs (Just (Plain plh)) = plainHighPairs (Just plh)
716−highlightSettingsPairs (Just (Postings ph)) = postHighPairs (Just ph)
717−highlightSettingsPairs (Just (FastVector fvh)) = fastVectorHighPairs (Just fvh)
718−
719−
720−plainHighPairs :: Maybe PlainHighlight -> [Pair]
721−plainHighPairs Nothing = []
722−plainHighPairs (Just (PlainHighlight plCom plNonPost)) =
723− [ "type" .= String "plain"]
724− ++ commonHighlightPairs plCom
725− ++ nonPostingsToPairs plNonPost
726−
727−postHighPairs :: Maybe PostingsHighlight -> [Pair]
728−postHighPairs Nothing = []
729−postHighPairs (Just (PostingsHighlight pCom)) =
730− ("type" .= String "postings")
731− : commonHighlightPairs pCom
732−
733−fastVectorHighPairs :: Maybe FastVectorHighlight -> [Pair]
734−fastVectorHighPairs Nothing = []
735−fastVectorHighPairs (Just
736− (FastVectorHighlight fvCom fvNonPostSettings fvBoundChars
737− fvBoundMaxScan fvFragOff fvMatchedFields
738− fvPhraseLim)) =
739− [ "type" .= String "fvh"
740− , "boundary_chars" .= fvBoundChars
741− , "boundary_max_scan" .= fvBoundMaxScan
742− , "fragment_offset" .= fvFragOff
743− , "matched_fields" .= fvMatchedFields
744− , "phraseLimit" .= fvPhraseLim]
745− ++ commonHighlightPairs fvCom
746− ++ nonPostingsToPairs fvNonPostSettings
747−
748−commonHighlightPairs :: Maybe CommonHighlight -> [Pair]
749−commonHighlightPairs Nothing = []
750−commonHighlightPairs (Just (CommonHighlight chScore chForceSource
751− chTag chEncoder chNoMatchSize
752− chHighlightQuery chRequireFieldMatch)) =
753− [ "order" .= chScore
754− , "force_source" .= chForceSource
755− , "encoder" .= chEncoder
756− , "no_match_size" .= chNoMatchSize
757− , "highlight_query" .= chHighlightQuery
758− , "require_fieldMatch" .= chRequireFieldMatch
759− ]
760− ++ highlightTagToPairs chTag
761−
762−
763−nonPostingsToPairs :: Maybe NonPostings -> [Pair]
764−nonPostingsToPairs Nothing = []
765−nonPostingsToPairs (Just (NonPostings npFragSize npNumOfFrags)) =
766− [ "fragment_size" .= npFragSize
767− , "number_of_fragments" .= npNumOfFrags
768− ]
769−
770−highlightTagToPairs :: Maybe HighlightTag -> [Pair]
771−highlightTagToPairs (Just (TagSchema _)) =
772− [ "scheme" .= String "default"
773− ]
774−highlightTagToPairs (Just (CustomTags (pre, post))) =
775− [ "pre_tags" .= pre
776− , "post_tags" .= post
777− ]
778−highlightTagToPairs Nothing = []
779−
780−data Suggest = Suggest
781− { suggestText :: Text
782− , suggestName :: Text
783− , suggestType :: SuggestType
784− } deriving (Eq, Show)
785−
786−instance ToJSON Suggest where
787− toJSON Suggest{..} =
788− object [ "text" .= suggestText
789− , suggestName .= suggestType
790− ]
791−
792−instance FromJSON Suggest where
793− parseJSON (Object o) = do
794− suggestText' <- o .: "text"
795− let dropTextList =
796− HM.toList
797− $ HM.filterWithKey (\x _ -> x /= "text") o
798− suggestName' <-
799− case dropTextList of
800− [(x, _)] -> return x
801− _ -> fail "error parsing Suggest field name"
802− suggestType' <- o .: suggestName'
803− return $ Suggest suggestText' suggestName' suggestType'
804− parseJSON x = typeMismatch "Suggest" x
805−
806−data SuggestType =
807− SuggestTypePhraseSuggester PhraseSuggester
808− deriving (Eq, Show)
809−
810−instance ToJSON SuggestType where
811− toJSON (SuggestTypePhraseSuggester x) =
812− object [ "phrase" .= x ]
813−
814−instance FromJSON SuggestType where
815− parseJSON = withObject "SuggestType" parse
816− where parse o = phraseSuggester `taggedWith` "phrase"
817− where taggedWith parser k = parser =<< o .: k
818− phraseSuggester = pure . SuggestTypePhraseSuggester
819−
820−data PhraseSuggester = PhraseSuggester
821− { phraseSuggesterField :: FieldName
822− , phraseSuggesterGramSize :: Maybe Int
823− , phraseSuggesterRealWordErrorLikelihood :: Maybe Int
824− , phraseSuggesterConfidence :: Maybe Int
825− , phraseSuggesterMaxErrors :: Maybe Int
826− , phraseSuggesterSeparator :: Maybe Text
827− , phraseSuggesterSize :: Maybe Size
828− , phraseSuggesterAnalyzer :: Maybe Analyzer
829− , phraseSuggesterShardSize :: Maybe Int
830− , phraseSuggesterHighlight :: Maybe PhraseSuggesterHighlighter
831− , phraseSuggesterCollate :: Maybe PhraseSuggesterCollate
832− , phraseSuggesterCandidateGenerators :: [DirectGenerators]
833− } deriving (Eq, Show)
834−
835−instance ToJSON PhraseSuggester where
836− toJSON PhraseSuggester{..} =
837− omitNulls [ "field" .= phraseSuggesterField
838− , "gram_size" .= phraseSuggesterGramSize
839− , "real_word_error_likelihood" .=
840− phraseSuggesterRealWordErrorLikelihood
841− , "confidence" .= phraseSuggesterConfidence
842− , "max_errors" .= phraseSuggesterMaxErrors
843− , "separator" .= phraseSuggesterSeparator
844− , "size" .= phraseSuggesterSize
845− , "analyzer" .= phraseSuggesterAnalyzer
846− , "shard_size" .= phraseSuggesterShardSize
847− , "highlight" .= phraseSuggesterHighlight
848− , "collate" .= phraseSuggesterCollate
849− , "direct_generator" .=
850− phraseSuggesterCandidateGenerators
851− ]
852−
853−instance FromJSON PhraseSuggester where
854− parseJSON = withObject "PhraseSuggester" parse
855− where parse o = PhraseSuggester
856− <$> o .: "field"
857− <*> o .:? "gram_size"
858− <*> o .:? "real_word_error_likelihood"
859− <*> o .:? "confidence"
860− <*> o .:? "max_errors"
861− <*> o .:? "separator"
862− <*> o .:? "size"
863− <*> o .:? "analyzer"
864− <*> o .:? "shard_size"
865− <*> o .:? "highlight"
866− <*> o .:? "collate"
867− <*> o .:? "direct_generator" .!= []
868−
869−mkPhraseSuggester :: FieldName -> PhraseSuggester
870−mkPhraseSuggester fName =
871− PhraseSuggester fName Nothing Nothing Nothing Nothing Nothing Nothing
872− Nothing Nothing Nothing Nothing []
873−
874−data PhraseSuggesterHighlighter =
875− PhraseSuggesterHighlighter { phraseSuggesterHighlighterPreTag :: Text
876− , phraseSuggesterHighlighterPostTag :: Text
877− }
878− deriving (Eq, Show)
879−
880−instance ToJSON PhraseSuggesterHighlighter where
881− toJSON PhraseSuggesterHighlighter{..} =
882− object [ "pre_tag" .= phraseSuggesterHighlighterPreTag
883− , "post_tag" .= phraseSuggesterHighlighterPostTag
884− ]
885−
886−instance FromJSON PhraseSuggesterHighlighter where
887− parseJSON = withObject "PhraseSuggesterHighlighter" parse
888− where parse o = PhraseSuggesterHighlighter
889− <$> o .: "pre_tag"
890− <*> o .: "post_tag"
891−
892−data PhraseSuggesterCollate = PhraseSuggesterCollate
893− { phraseSuggesterCollateTemplateQuery :: TemplateQueryInline
894− , phraseSuggesterCollatePrune :: Bool
895− } deriving (Eq, Show)
896−
897−instance ToJSON PhraseSuggesterCollate where
898− toJSON PhraseSuggesterCollate{..} =
899− object [ "query" .= object
900− [ "inline" .= (inline phraseSuggesterCollateTemplateQuery)
901− ]
902− , "params" .= (params phraseSuggesterCollateTemplateQuery)
903− , "prune" .= phraseSuggesterCollatePrune
904− ]
905−
906−instance FromJSON PhraseSuggesterCollate where
907− parseJSON (Object o) = do
908− query' <- o .: "query"
909− inline' <- query' .: "inline"
910− params' <- o .: "params"
911− prune' <- o .:? "prune" .!= False
912− return $ PhraseSuggesterCollate
913− (TemplateQueryInline inline' params') prune'
914− parseJSON x = typeMismatch "PhraseSuggesterCollate" x
915−
916−data SuggestOptions =
917− SuggestOptions { suggestOptionsText :: Text
918− , suggestOptionsScore :: Double
919− , suggestOptionsFreq :: Maybe Int
920− , suggestOptionsHighlighted :: Maybe Text
921− }
922− deriving (Eq, Read, Show)
923−
924−instance FromJSON SuggestOptions where
925− parseJSON = withObject "SuggestOptions" parse
926− where
927− parse o = SuggestOptions
928− <$> o .: "text"
929− <*> o .: "score"
930− <*> o .:? "freq"
931− <*> o .:? "highlighted"
932−
933−data SuggestResponse =
934− SuggestResponse { suggestResponseText :: Text
935− , suggestResponseOffset :: Int
936− , suggestResponseLength :: Int
937− , suggestResponseOptions :: [SuggestOptions]
938− }
939− deriving (Eq, Read, Show)
940−
941−instance FromJSON SuggestResponse where
942− parseJSON = withObject "SuggestResponse" parse
943− where parse o = SuggestResponse
944− <$> o .: "text"
945− <*> o .: "offset"
946− <*> o .: "length"
947− <*> o .: "options"
948−
949−data NamedSuggestionResponse = NamedSuggestionResponse
950− { nsrName :: Text
951− , nsrResponses :: [SuggestResponse]
952− } deriving (Eq, Read, Show)
953−
954−instance FromJSON NamedSuggestionResponse where
955− parseJSON (Object o) = do
956− suggestionName' <- case HM.toList o of
957− [(x, _)] -> return x
958− _ -> fail "error parsing NamedSuggestionResponse name"
959− suggestionResponses' <- o .: suggestionName'
960− return $ NamedSuggestionResponse suggestionName' suggestionResponses'
961−
962− parseJSON x = typeMismatch "NamedSuggestionResponse" x
963−
964−data DirectGeneratorSuggestModeTypes = DirectGeneratorSuggestModeMissing
965− | DirectGeneratorSuggestModePopular
966− | DirectGeneratorSuggestModeAlways
967− deriving (Eq, Show)
968−
969−instance ToJSON DirectGeneratorSuggestModeTypes where
970− toJSON DirectGeneratorSuggestModeMissing = "missing"
971− toJSON DirectGeneratorSuggestModePopular = "popular"
972− toJSON DirectGeneratorSuggestModeAlways = "always"
973−
974−instance FromJSON DirectGeneratorSuggestModeTypes where
975− parseJSON = withText "DirectGeneratorSuggestModeTypes" parse
976− where
977− parse "missing" =
978− pure DirectGeneratorSuggestModeMissing
979− parse "popular" =
980− pure DirectGeneratorSuggestModePopular
981− parse "always" =
982− pure DirectGeneratorSuggestModeAlways
983− parse f =
984− fail ("Unexpected DirectGeneratorSuggestModeTypes: " <> show f)
985−
986−data DirectGenerators = DirectGenerators
987− { directGeneratorsField :: FieldName
988− , directGeneratorsSize :: Maybe Int
989− , directGeneratorSuggestMode :: DirectGeneratorSuggestModeTypes
990− , directGeneratorMaxEdits :: Maybe Double
991− , directGeneratorPrefixLength :: Maybe Int
992− , directGeneratorMinWordLength :: Maybe Int
993− , directGeneratorMaxInspections :: Maybe Int
994− , directGeneratorMinDocFreq :: Maybe Double
995− , directGeneratorMaxTermFreq :: Maybe Double
996− , directGeneratorPreFilter :: Maybe Text
997− , directGeneratorPostFilter :: Maybe Text
998− } deriving (Eq, Show)
999−
1000−instance ToJSON DirectGenerators where
1001− toJSON DirectGenerators{..} =
1002− omitNulls [ "field" .= directGeneratorsField
1003− , "size" .= directGeneratorsSize
1004− , "suggest_mode" .= directGeneratorSuggestMode
1005− , "max_edits" .= directGeneratorMaxEdits
1006− , "prefix_length" .= directGeneratorPrefixLength
1007− , "min_word_length" .= directGeneratorMinWordLength
1008− , "max_inspections" .= directGeneratorMaxInspections
1009− , "min_doc_freq" .= directGeneratorMinDocFreq
1010− , "max_term_freq" .= directGeneratorMaxTermFreq
1011− , "pre_filter" .= directGeneratorPreFilter
1012− , "post_filter" .= directGeneratorPostFilter
1013− ]
1014−
1015−instance FromJSON DirectGenerators where
1016− parseJSON = withObject "DirectGenerators" parse
1017− where parse o = DirectGenerators
1018− <$> o .: "field"
1019− <*> o .:? "size"
1020− <*> o .: "suggest_mode"
1021− <*> o .:? "max_edits"
1022− <*> o .:? "prefix_length"
1023− <*> o .:? "min_word_length"
1024− <*> o .:? "max_inspections"
1025− <*> o .:? "min_doc_freq"
1026− <*> o .:? "max_term_freq"
1027− <*> o .:? "pre_filter"
1028− <*> o .:? "post_filter"
1029−
1030−mkDirectGenerators :: FieldName -> DirectGenerators
1031−mkDirectGenerators fn = DirectGenerators fn Nothing DirectGeneratorSuggestModeMissing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing