{-# LANGUAGE DeriveGeneric #-} module Database.Bloodhound.Types.Instances ( Monoid(..) , Seminearring(..) , ToJSON(..) ) where import Control.Applicative import Data.Aeson import Data.Maybe (catMaybes) import Data.Monoid import qualified Data.Text as T import Database.Bloodhound.Types import Database.Bloodhound.Types.Class import Data.Scientific instance Monoid Filter where mempty = IdentityFilter mappend a b = AndFilter [a, b] defaultCache instance Seminearring Filter where a <||> b = OrFilter [a, b] defaultCache instance ToJSON Filter where toJSON (AndFilter filters cache) = object ["and" .= fmap toJSON filters , "_cache" .= cache] toJSON (OrFilter filters cache) = object ["or" .= fmap toJSON filters , "_cache" .= cache] toJSON (NotFilter filter cache) = object ["not" .= object ["filter" .= toJSON filter , "_cache" .= cache]] toJSON (IdentityFilter) = object ["match_all" .= object []] toJSON (ExistsFilter (FieldName fieldName)) = object ["exists" .= object ["field" .= fieldName]] toJSON (BoolFilter boolMatch) = object ["bool" .= toJSON boolMatch] toJSON (GeoBoundingBoxFilter bbConstraint filterType) = object ["geo_bounding_box" .= toJSON bbConstraint , "type" .= toJSON filterType] toJSON (GeoDistanceFilter (GeoPoint (FieldName geoField) latLon) distance distanceType optimizeBbox cache) = object ["geo_distance" .= object ["distance" .= toJSON distance , "distance_type" .= toJSON distanceType , "optimize_bbox" .= optimizeBbox , geoField .= toJSON latLon , "_cache" .= cache]] toJSON (GeoDistanceRangeFilter (GeoPoint (FieldName geoField) latLon) (DistanceRange distanceFrom distanceTo)) = object ["geo_distance_range" .= object ["from" .= toJSON distanceFrom , "to" .= toJSON distanceTo , geoField .= toJSON latLon]] toJSON (GeoPolygonFilter (FieldName geoField) latLons) = object ["geo_polygon" .= object [geoField .= object ["points" .= fmap toJSON latLons]]] toJSON (IdsFilter (MappingName mappingName) values) = object ["ids" .= object ["type" .= mappingName , "values" .= fmap (T.pack . unpackId) values]] toJSON (LimitFilter limit) = object ["limit" .= object ["value" .= limit]] toJSON (MissingFilter (FieldName fieldName) (Existence existence) (NullValue nullValue)) = object ["missing" .= object ["field" .= fieldName , "existence" .= existence , "null_value" .= nullValue]] toJSON (PrefixFilter (FieldName fieldName) fieldValue cache) = object ["prefix" .= object [fieldName .= fieldValue , "_cache" .= cache]] toJSON (RangeFilter (FieldName fieldName) (Left halfRange) rangeExecution cache) = object ["range" .= object [fieldName .= object [key .= val] , "execution" .= toJSON rangeExecution , "_cache" .= cache]] where (key, val) = halfRangeToKV halfRange toJSON (RangeFilter (FieldName fieldName) (Right range) rangeExecution cache) = object ["range" .= object [fieldName .= object [lessKey .= lessVal , greaterKey .= greaterVal] , "execution" .= toJSON rangeExecution , "_cache" .= cache]] where (lessKey, lessVal, greaterKey, greaterVal) = rangeToKV range toJSON (RegexpFilter (FieldName fieldName) (Regexp regexText) flags (CacheName cacheName) cache (CacheKey cacheKey)) = object ["regexp" .= object [fieldName .= object ["value" .= regexText , "flags" .= toJSON flags] , "_name" .= cacheName , "_cache" .= cache , "_cache_key" .= cacheKey]] instance ToJSON GeoPoint where toJSON (GeoPoint (FieldName geoField) latLon) = object [ geoField .= toJSON latLon ] instance ToJSON Query where toJSON (TermQuery (Term termField termValue) boost) = object [ "term" .= object [termField .= object merged]] where base = [ "value" .= termValue ] boosted = maybe [] (return . ("boost" .=)) boost merged = mappend base boosted toJSON (QueryMatchQuery matchQuery) = object [ "match" .= toJSON matchQuery ] toJSON (QueryMultiMatchQuery multiMatchQuery) = object [ "multi_match" .= toJSON multiMatchQuery ] toJSON (QueryBoolQuery boolQuery) = object [ "bool" .= toJSON boolQuery ] toJSON (QueryBoostingQuery boostingQuery) = object [ "boosting" .= toJSON boostingQuery ] toJSON (QueryCommonTermsQuery commonTermsQuery) = object [ "common" .= toJSON commonTermsQuery ] toJSON (ConstantScoreFilter filter boost) = object [ "constant_score" .= toJSON filter , "boost" .= toJSON boost] toJSON (ConstantScoreQuery query boost) = object [ "constant_score" .= toJSON query , "boost" .= toJSON boost] toJSON (QueryDisMaxQuery disMaxQuery) = object [ "dis_max" .= toJSON disMaxQuery ] toJSON (QueryFilteredQuery filteredQuery) = object [ "filtered" .= toJSON filteredQuery ] toJSON (QueryFuzzyLikeThisQuery fuzzyQuery) = object [ "fuzzy_like_this" .= toJSON fuzzyQuery ] toJSON (QueryFuzzyLikeFieldQuery fuzzyFieldQuery) = object [ "fuzzy_like_this_field" .= toJSON fuzzyFieldQuery ] toJSON (QueryFuzzyQuery fuzzyQuery) = object [ "fuzzy" .= toJSON fuzzyQuery ] toJSON (QueryHasChildQuery childQuery) = object [ "has_child" .= toJSON childQuery ] toJSON (QueryHasParentQuery parentQuery) = object [ "has_parent" .= toJSON parentQuery ] toJSON (QueryIndicesQuery indicesQuery) = object [ "indices" .= toJSON indicesQuery ] toJSON (MatchAllQuery boost) = object [ "match_all" .= object maybeAdd ] where maybeAdd = catMaybes [ mField "boost" boost ] toJSON (QueryMoreLikeThisQuery query) = object [ "more_like_this" .= toJSON query ] toJSON (QueryMoreLikeThisFieldQuery query) = object [ "more_like_this_field" .= toJSON query ] toJSON (QueryNestedQuery query) = object [ "nested" .= toJSON query ] toJSON (QueryPrefixQuery query) = object [ "prefix" .= toJSON query ] mField :: (ToJSON a, Functor f) => T.Text -> f a -> f (T.Text, Value) mField field = fmap ((field .=) . toJSON) instance ToJSON PrefixQuery where toJSON (PrefixQuery (FieldName fieldName) queryValue boost) = object [ fieldName .= object conjoined ] where base = [ "value" .= toJSON queryValue ] maybeAdd = catMaybes [ mField "boost" boost ] conjoined = base ++ maybeAdd instance ToJSON NestedQuery where toJSON (NestedQuery path scoreType query) = object [ "path" .= toJSON path , "score_mode" .= toJSON scoreType , "query" .= toJSON query ] instance ToJSON MoreLikeThisFieldQuery where toJSON (MoreLikeThisFieldQuery text (FieldName fieldName) percent mtf mqt stopwords mindf maxdf minwl maxwl boostTerms boost analyzer) = object [ fieldName .= object conjoined ] where base = [ "like_text" .= toJSON text ] maybeAdd = catMaybes [ mField "percent_terms_to_match" percent , mField "min_term_freq" mtf , mField "max_query_terms" mqt , mField "stop_words" stopwords , mField "min_doc_freq" mindf , mField "max_doc_freq" maxdf , mField "min_word_length" minwl , mField "max_word_length" maxwl , mField "boost_terms" boostTerms , mField "boost" boost , mField "analyzer" analyzer ] conjoined = base ++ maybeAdd instance ToJSON MoreLikeThisQuery where toJSON (MoreLikeThisQuery text fields percent mtf mqt stopwords mindf maxdf minwl maxwl boostTerms boost analyzer) = object conjoined where base = [ "like_text" .= toJSON text ] maybeAdd = catMaybes [ mField "fields" fields , mField "percent_terms_to_match" percent , mField "min_term_freq" mtf , mField "max_query_terms" mqt , mField "stop_words" stopwords , mField "min_doc_freq" mindf , mField "max_doc_freq" maxdf , mField "min_word_length" minwl , mField "max_word_length" maxwl , mField "boost_terms" boostTerms , mField "boost" boost , mField "analyzer" analyzer ] conjoined = base ++ maybeAdd instance ToJSON IndicesQuery where toJSON (IndicesQuery indices query noMatch) = object $ [ "indices" .= toJSON indices , "query" .= toJSON query ] ++ maybeAdd where maybeAdd = catMaybes [ mField "no_match_query" noMatch ] instance ToJSON HasParentQuery where toJSON (HasParentQuery queryType query scoreType) = object $ [ "parent_type" .= toJSON queryType , "query" .= toJSON query ] ++ maybeAdd where maybeAdd = catMaybes [ mField "score_type" scoreType ] instance ToJSON HasChildQuery where toJSON (HasChildQuery queryType query scoreType) = object $ [ "query" .= toJSON query , "type" .= toJSON queryType ] ++ maybeAdd where maybeAdd = catMaybes [ mField "score_type" scoreType ] instance ToJSON FuzzyQuery where toJSON (FuzzyQuery (FieldName fieldName) queryText prefixLength maxEx fuzziness boost) = object [ fieldName .= object conjoined ] where base = [ "value" .= toJSON queryText , "fuzziness" .= toJSON fuzziness , "prefix_length" .= toJSON prefixLength , "max_expansions" .= toJSON maxEx ] maybeAdd = catMaybes [ mField "boost" boost ] conjoined = base ++ maybeAdd instance ToJSON FuzzyLikeFieldQuery where toJSON (FuzzyLikeFieldQuery (FieldName fieldName) fieldText maxTerms ignoreFreq fuzziness prefixLength boost analyzer) = object $ [ fieldName .= object [ "like_text" .= toJSON fieldText , "max_query_terms" .= toJSON maxTerms , "ignore_tf" .= toJSON ignoreFreq , "fuzziness" .= toJSON fuzziness , "prefix_length" .= toJSON prefixLength , "boost" .= toJSON boost ]] ++ maybeAdd where maybeAdd = catMaybes [ mField "analyzer" analyzer ] instance ToJSON FuzzyLikeThisQuery where toJSON (FuzzyLikeThisQuery fields text maxTerms ignoreFreq fuzziness prefixLength boost analyzer) = object conjoined where base = [ "fields" .= toJSON fields , "like_text" .= toJSON text , "max_query_terms" .= toJSON maxTerms , "ignore_tf" .= toJSON ignoreFreq , "fuzziness" .= toJSON fuzziness , "prefix_length" .= toJSON prefixLength , "boost" .= toJSON boost ] maybeAdd = catMaybes [ mField "analyzer" analyzer ] conjoined = base ++ maybeAdd instance ToJSON FilteredQuery where toJSON (FilteredQuery query filter) = object [ "query" .= toJSON query , "filter" .= toJSON filter ] instance ToJSON DisMaxQuery where toJSON (DisMaxQuery queries tiebreaker boost) = object conjoined where maybeAdd = catMaybes [mField "boost" boost] base = [ "queries" .= toJSON queries , "tie_breaker" .= toJSON tiebreaker ] conjoined = base ++ maybeAdd instance ToJSON CommonTermsQuery where toJSON (CommonTermsQuery (FieldName fieldName) (QueryString query) cf lfo hfo msm boost analyzer disableCoord) = object [fieldName .= object conjoined] where base = [ "query" .= query , "cutoff_frequency" .= toJSON cf , "low_freq_operator" .= toJSON lfo , "high_freq_operator" .= toJSON hfo ] extension = catMaybes [ mField "minimum_should_match" msm , mField "boost" boost , mField "analyzer" analyzer , mField "disable_coord" disableCoord ] conjoined = base ++ extension instance ToJSON CommonMinimumMatch where toJSON (CommonMinimumMatch mm) = toJSON mm toJSON (CommonMinimumMatchHighLow (MinimumMatchHighLow lowF highF)) = object [ "low_freq" .= toJSON lowF , "high_freq" .= toJSON highF ] instance ToJSON BoostingQuery where toJSON (BoostingQuery positiveQuery negativeQuery negativeBoost) = object [ "positive" .= toJSON positiveQuery , "negative" .= toJSON negativeQuery , "negative_boost" .= toJSON negativeBoost ] instance ToJSON BoolQuery where toJSON (BoolQuery mustM notM shouldM min boost disableCoord) = object filtered where filtered = catMaybes [ mField "must" mustM , mField "must_not" notM , mField "should" shouldM , mField "minimum_should_match" min , mField "boost" boost , mField "disable_coord" disableCoord ] instance ToJSON MatchQuery where toJSON (MatchQuery (FieldName fieldName) (QueryString queryString) booleanOperator zeroTermsQuery cutoffFrequency matchQueryType analyzer maxExpansions lenient) = object [ fieldName .= object conjoined ] where conjoined = [ "query" .= queryString , "operator" .= toJSON booleanOperator , "zero_terms_query" .= toJSON zeroTermsQuery] ++ maybeAdd maybeAdd = catMaybes [ mField "cutoff_frequency" cutoffFrequency , mField "type" matchQueryType , mField "analyzer" analyzer , mField "max_expansions" maxExpansions , mField "lenient" lenient ] instance ToJSON MultiMatchQuery where toJSON (MultiMatchQuery fields (QueryString query) boolOp ztQ tb mmqt cf analyzer maxEx lenient) = object ["multi_match" .= object conjoined] where baseQuery = [ "fields" .= fmap toJSON fields , "query" .= query , "operator" .= toJSON boolOp , "zero_terms_query" .= toJSON ztQ ] maybeAdd = catMaybes [ mField "tiebreaker" tb , mField "type" mmqt , mField "cutoff_frequency" cf , mField "analyzer" analyzer , mField "max_expansions" maxEx , mField "lenient" lenient ] conjoined = baseQuery ++ maybeAdd instance ToJSON MultiMatchQueryType where toJSON MultiMatchBestFields = "best_fields" toJSON MultiMatchMostFields = "most_fields" toJSON MultiMatchCrossFields = "cross_fields" toJSON MultiMatchPhrase = "phrase" toJSON MultiMatchPhrasePrefix = "phrase_prefix" instance ToJSON BooleanOperator where toJSON And = String "and" toJSON Or = String "or" instance ToJSON ZeroTermsQuery where toJSON ZeroTermsNone = String "none" toJSON ZeroTermsAll = String "all" instance ToJSON MatchQueryType where toJSON MatchPhrase = "phrase" toJSON MatchPhrasePrefix = "phrase_prefix" instance ToJSON FieldName where toJSON (FieldName fieldName) = String fieldName instance ToJSON ReplicaCount instance ToJSON ShardCount instance ToJSON CutoffFrequency instance ToJSON Analyzer instance ToJSON MaxExpansions instance ToJSON Lenient instance ToJSON Boost instance ToJSON Version instance ToJSON Tiebreaker instance ToJSON MinimumMatch instance ToJSON DisableCoord instance ToJSON PrefixLength instance ToJSON Fuzziness instance ToJSON IgnoreTermFrequency instance ToJSON MaxQueryTerms instance ToJSON TypeName instance ToJSON IndexName instance ToJSON BoostTerms instance ToJSON MaxWordLength instance ToJSON MinWordLength instance ToJSON MaxDocFrequency instance ToJSON MinDocFrequency instance ToJSON PhraseSlop instance ToJSON StopWord instance ToJSON QueryPath instance ToJSON MinimumTermFrequency instance ToJSON PercentMatch instance FromJSON Version instance FromJSON IndexName instance FromJSON MappingName instance FromJSON DocId instance (FromJSON a) => FromJSON (Status a) where parseJSON (Object v) = Status <$> v .: "ok" <*> v .: "status" <*> v .: "name" <*> v .: "version" <*> v .: "tagline" parseJSON _ = empty instance ToJSON IndexSettings where toJSON (IndexSettings s r) = object ["settings" .= object ["shards" .= s, "replicas" .= r]] instance (FromJSON a) => FromJSON (EsResult a) where parseJSON (Object v) = EsResult <$> v .: "_index" <*> v .: "_type" <*> v .: "_id" <*> v .: "_version" <*> v .:? "found" <*> v .: "_source" parseJSON _ = empty instance ToJSON Search where toJSON (Search query filter sort trackSortScores from size) = object merged where lQuery = maybeJson "query" query lFilter = maybeJson "filter" filter lSort = maybeJsonF "sort" sort merged = mconcat [[ "from" .= from , "size" .= size , "track_scores" .= trackSortScores] , lQuery , lFilter , lSort] instance ToJSON SortSpec where toJSON (DefaultSortSpec (DefaultSort (FieldName sortFieldName) sortOrder ignoreUnmapped sortMode missingSort nestedFilter)) = object [sortFieldName .= object merged] where base = ["order" .= toJSON sortOrder , "ignore_unmapped" .= ignoreUnmapped] lSortMode = maybeJson "mode" sortMode lMissingSort = maybeJson "missing" missingSort lNestedFilter = maybeJson "nested_filter" nestedFilter merged = mconcat [base, lSortMode, lMissingSort, lNestedFilter] toJSON (GeoDistanceSortSpec sortOrder (GeoPoint (FieldName field) latLon) units) = object [ "unit" .= toJSON units , field .= toJSON latLon , "order" .= toJSON sortOrder ] instance ToJSON SortOrder where toJSON Ascending = String "asc" toJSON Descending = String "desc" instance ToJSON SortMode where toJSON SortMin = String "min" toJSON SortMax = String "max" toJSON SortSum = String "sum" toJSON SortAvg = String "avg" instance ToJSON Missing where toJSON LastMissing = String "_last" toJSON FirstMissing = String "_first" toJSON (CustomMissing txt) = String txt instance ToJSON ScoreType where toJSON ScoreTypeMax = "max" toJSON ScoreTypeAvg = "avg" toJSON ScoreTypeSum = "sum" toJSON ScoreTypeNone = "none" instance ToJSON Distance where toJSON (Distance coefficient unit) = String boltedTogether where coefText = showText coefficient (String unitText) = (toJSON unit) boltedTogether = mappend coefText unitText instance ToJSON DistanceUnit where toJSON Miles = String "mi" toJSON Yards = String "yd" toJSON Feet = String "ft" toJSON Inches = String "in" toJSON Kilometers = String "km" toJSON Meters = String "m" toJSON Centimeters = String "cm" toJSON Millimeters = String "mm" toJSON NauticalMiles = String "nmi" instance ToJSON DistanceType where toJSON Arc = String "arc" toJSON SloppyArc = String "sloppy_arc" toJSON Plane = String "plane" instance ToJSON OptimizeBbox where toJSON NoOptimizeBbox = String "none" toJSON (OptimizeGeoFilterType gft) = toJSON gft instance ToJSON GeoBoundingBoxConstraint where toJSON (GeoBoundingBoxConstraint (FieldName geoBBField) constraintBox cache) = object [geoBBField .= toJSON constraintBox , "_cache" .= cache] instance ToJSON GeoFilterType where toJSON GeoFilterMemory = String "memory" toJSON GeoFilterIndexed = String "indexed" instance ToJSON GeoBoundingBox where toJSON (GeoBoundingBox topLeft bottomRight) = object ["top_left" .= toJSON topLeft , "bottom_right" .= toJSON bottomRight] instance ToJSON LatLon where toJSON (LatLon lat lon) = object ["lat" .= lat , "lon" .= lon] -- index for smaller ranges, fielddata for longer ranges instance ToJSON RangeExecution where toJSON RangeExecutionIndex = "index" toJSON RangeExecutionFielddata = "fielddata" instance ToJSON RegexpFlags where toJSON (RegexpFlags txt) = String txt instance ToJSON Term where toJSON (Term field value) = object ["term" .= object [field .= value]] instance ToJSON BoolMatch where toJSON (MustMatch term cache) = object ["must" .= toJSON term, "_cache" .= cache] toJSON (MustNotMatch term cache) = object ["must_not" .= toJSON term, "_cache" .= cache] toJSON (ShouldMatch terms cache) = object ["should" .= fmap toJSON terms, "_cache" .= cache] instance (FromJSON a) => FromJSON (SearchResult a) where parseJSON (Object v) = SearchResult <$> v .: "took" <*> v .: "timed_out" <*> v .: "_shards" <*> v .: "hits" parseJSON _ = empty instance (FromJSON a) => FromJSON (SearchHits a) where parseJSON (Object v) = SearchHits <$> v .: "total" <*> v .: "max_score" <*> v .: "hits" parseJSON _ = empty instance (FromJSON a) => FromJSON (Hit a) where parseJSON (Object v) = Hit <$> v .: "_index" <*> v .: "_type" <*> v .: "_id" <*> v .: "_score" <*> v .: "_source" parseJSON _ = empty instance FromJSON ShardResult where parseJSON (Object v) = ShardResult <$> v .: "total" <*> v .: "successful" <*> v .: "failed" parseJSON _ = empty