From 99788cc992341d2cc1557657cd282b9d52ebcaf8 Mon Sep 17 00:00:00 2001 From: Michael Xavier Date: Tue, 20 Mar 2018 15:47:25 -0700 Subject: [PATCH] WIP v1 savepoint I'm trying out the technique of loading a corresponding V5 module into GHCi, :browse-ing the exports, explicitly setting those for the V1 and then pulling definitions out of the old V1 types module. Working well so far. --- src/Bloodhound/Import.hs | 94 +- .../V1/Bloodhound/Internal/Aggregation.hs | 101 +- src/Database/V1/Bloodhound/Internal/Client.hs | 149 +- .../V1/Bloodhound/Internal/Newtypes.hs | 161 ++ src/Database/V1/Bloodhound/Internal/Query.hs | 1683 +++++++++++++++++ src/Database/V1/Bloodhound/Internal/Sort.hs | 79 + .../V1/Bloodhound/Internal/StringlyTyped.hs | 25 + .../V1/Bloodhound/Internal/Suggest.hs | 252 +++ src/Database/V1/Bloodhound/Types.hs | 2 - src/Database/V5/Bloodhound/Internal/Query.hs | 3 - 10 files changed, 2462 insertions(+), 87 deletions(-) create mode 100644 src/Database/V1/Bloodhound/Internal/Newtypes.hs create mode 100644 src/Database/V1/Bloodhound/Internal/Query.hs create mode 100644 src/Database/V1/Bloodhound/Internal/Sort.hs create mode 100644 src/Database/V1/Bloodhound/Internal/Suggest.hs diff --git a/src/Bloodhound/Import.hs b/src/Bloodhound/Import.hs index bd3b1bc..b8f1afc 100644 --- a/src/Bloodhound/Import.hs +++ b/src/Bloodhound/Import.hs @@ -7,65 +7,44 @@ module Bloodhound.Import , parseReadText , readMay , showText + , deleteSeveral ) where -import Control.Applicative as X (Alternative(..), optional) -import Control.Exception as X (Exception) -import Control.Monad as X ( MonadPlus(..) - , (<=<) - , forM - ) -import Control.Monad.Fix as X (MonadFix) -import Control.Monad.IO.Class as X (MonadIO(..)) -import Control.Monad.Catch as X ( MonadCatch - , MonadMask - , MonadThrow - ) -import Control.Monad.Except as X (MonadError) -import Control.Monad.Reader as X ( MonadReader (..) - , MonadTrans (..) - , ReaderT (..) - ) -import Control.Monad.State as X (MonadState) -import Control.Monad.Writer as X (MonadWriter) -import Data.Aeson as X -import Data.Aeson.Types as X ( Pair - , Parser - , emptyObject - , parseEither - , parseMaybe - , typeMismatch - ) -import Data.Bifunctor as X (first) -import Data.Char as X (isNumber) -import Data.Hashable as X (Hashable) -import Data.List as X ( foldl' - , intercalate - , nub - ) -import Data.List.NonEmpty as X ( NonEmpty (..) - , toList - ) -import Data.Maybe as X ( catMaybes - , fromMaybe - , isNothing - , maybeToList - ) -import Data.Scientific as X (Scientific) -import Data.Semigroup as X (Semigroup(..)) -import Data.Text as X (Text) -import Data.Time.Calendar as X ( Day(..) - , showGregorian - ) -import Data.Time.Clock as X ( NominalDiffTime - , UTCTime - ) -import Data.Time.Clock.POSIX as X +import Control.Applicative as X (Alternative (..), optional) +import Control.Exception as X (Exception) +import Control.Monad as X (MonadPlus (..), forM, (<=<)) +import Control.Monad.Catch as X (MonadCatch, MonadMask, + MonadThrow) +import Control.Monad.Except as X (MonadError) +import Control.Monad.Fix as X (MonadFix) +import Control.Monad.IO.Class as X (MonadIO (..)) +import Control.Monad.Reader as X (MonadReader (..), + MonadTrans (..), ReaderT (..)) +import Control.Monad.State as X (MonadState) +import Control.Monad.Writer as X (MonadWriter) +import Data.Aeson as X +import Data.Aeson.Types as X (Pair, Parser, emptyObject, + parseEither, parseMaybe, + typeMismatch) +import Data.Bifunctor as X (first) +import Data.Char as X (isNumber) +import Data.Hashable as X (Hashable) +import qualified Data.HashMap.Strict as HM +import Data.List as X (foldl', intercalate, nub) +import Data.List.NonEmpty as X (NonEmpty (..), toList) +import Data.Maybe as X (catMaybes, fromMaybe, + isNothing, maybeToList) +import Data.Scientific as X (Scientific) +import Data.Semigroup as X (Semigroup (..)) +import Data.Text as X (Text) +import Data.Time.Calendar as X (Day (..), showGregorian) +import Data.Time.Clock as X (NominalDiffTime, UTCTime) +import Data.Time.Clock.POSIX as X -import qualified Data.ByteString.Lazy as BL -import qualified Data.Text as T -import qualified Data.Traversable as DT -import qualified Data.Vector as V +import qualified Data.ByteString.Lazy as BL +import qualified Data.Text as T +import qualified Data.Traversable as DT +import qualified Data.Vector as V import qualified Network.HTTP.Types.Method as NHTM type LByteString = BL.ByteString @@ -92,3 +71,6 @@ omitNulls = object . filter notNull where parseNEJSON :: (FromJSON a) => [Value] -> Parser (NonEmpty a) parseNEJSON [] = fail "Expected non-empty list" parseNEJSON (x:xs) = DT.mapM parseJSON (x :| xs) + +deleteSeveral :: (Eq k, Hashable k) => [k] -> HM.HashMap k v -> HM.HashMap k v +deleteSeveral ks hm = foldr HM.delete hm ks diff --git a/src/Database/V1/Bloodhound/Internal/Aggregation.hs b/src/Database/V1/Bloodhound/Internal/Aggregation.hs index 17649b2..2e0694c 100644 --- a/src/Database/V1/Bloodhound/Internal/Aggregation.hs +++ b/src/Database/V1/Bloodhound/Internal/Aggregation.hs @@ -1,9 +1,17 @@ +{-# LANGUAGE RecordWildCards #-} + module Database.V1.Bloodhound.Internal.Aggregation where import Bloodhound.Import +import qualified Data.HashMap.Strict as HM +import qualified Data.Map.Strict as M import Data.Text -import qualified Data.Text as T +import qualified Data.Text as T + +import Database.V1.Bloodhound.Internal.Newtypes +import Database.V1.Bloodhound.Internal.Query +import Database.V1.Bloodhound.Internal.Sort type Aggregations = M.Map Text Aggregation @@ -22,7 +30,7 @@ data Aggregation = TermsAgg TermsAggregation | DateRangeAgg DateRangeAggregation | MissingAgg MissingAggregation | TopHitsAgg TopHitsAggregation - deriving (Eq, Read, Show, Generic, Typeable) + deriving (Eq, Show) instance ToJSON Aggregation where @@ -84,7 +92,7 @@ data TopHitsAggregation = TopHitsAggregation data MissingAggregation = MissingAggregation { maField :: Text - } deriving (Eq, Read, Show, Generic, Typeable) + } deriving (Eq, Show) data TermsAggregation = TermsAggregation { term :: Either Text Text , termInclude :: Maybe TermInclusion @@ -96,11 +104,11 @@ data TermsAggregation = TermsAggregation { term :: Either Text Text , termCollectMode :: Maybe CollectionMode , termExecutionHint :: Maybe ExecutionHint , termAggs :: Maybe Aggregations - } deriving (Eq, Read, Show, Generic, Typeable) + } deriving (Eq, Show) data CardinalityAggregation = CardinalityAggregation { cardinalityField :: FieldName, precisionThreshold :: Maybe Int - } deriving (Eq, Read, Show, Generic, Typeable) + } deriving (Eq, Show) data DateHistogramAggregation = DateHistogramAggregation { dateField :: FieldName , dateInterval :: Interval @@ -111,25 +119,25 @@ data DateHistogramAggregation = DateHistogramAggregation { dateField :: Fie , datePreOffset :: Maybe Text , datePostOffset :: Maybe Text , dateAggs :: Maybe Aggregations - } deriving (Eq, Read, Show, Generic, Typeable) + } deriving (Eq, Show) data DateRangeAggregation = DateRangeAggregation { draField :: FieldName , draFormat :: Maybe Text , draRanges :: NonEmpty DateRangeAggRange - } deriving (Eq, Read, Show, Generic, Typeable) + } deriving (Eq, Show) data DateRangeAggRange = DateRangeFrom DateMathExpr | DateRangeTo DateMathExpr - | DateRangeFromAndTo DateMathExpr DateMathExpr deriving (Eq, Read, Show, Generic, Typeable) + | DateRangeFromAndTo DateMathExpr DateMathExpr deriving (Eq, Show) -- | See for more information. data ValueCountAggregation = FieldValueCount FieldName - | ScriptValueCount Script deriving (Eq, Read, Show, Generic, Typeable) + | ScriptValueCount Script deriving (Eq, Show) -- | Single-bucket filter aggregations. See for more information. data FilterAggregation = FilterAggregation { faFilter :: Filter - , faAggs :: Maybe Aggregations} deriving (Eq, Read, Show, Generic, Typeable) + , faAggs :: Maybe Aggregations} deriving (Eq, Show) mkTermsAggregation :: Text -> TermsAggregation mkTermsAggregation t = TermsAggregation (Left t) Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing @@ -143,3 +151,76 @@ mkDateHistogram t i = DateHistogramAggregation t i Nothing Nothing Nothing Nothi mkCardinalityAggregation :: FieldName -> CardinalityAggregation mkCardinalityAggregation t = CardinalityAggregation t Nothing +data TermInclusion = TermInclusion Text + | TermPattern Text Text deriving (Eq, Show) + +instance ToJSON TermInclusion where + toJSON (TermInclusion x) = toJSON x + toJSON (TermPattern pattern flags) = + omitNulls [ "pattern" .= pattern + , "flags" .= flags] + +data TermOrder = TermOrder + { termSortField :: Text + , termSortOrder :: SortOrder } deriving (Eq, Show) + +instance ToJSON TermOrder where + toJSON (TermOrder termSortField termSortOrder) = + object [termSortField .= termSortOrder] + + +data ExecutionHint = Ordinals + | GlobalOrdinals + | GlobalOrdinalsHash + | GlobalOrdinalsLowCardinality + | Map deriving (Eq, Show) + +instance ToJSON ExecutionHint where + toJSON Ordinals = "ordinals" + toJSON GlobalOrdinals = "global_ordinals" + toJSON GlobalOrdinalsHash = "global_ordinals_hash" + toJSON GlobalOrdinalsLowCardinality = "global_ordinals_low_cardinality" + toJSON Map = "map" + + +-- | See for more information. +data DateMathExpr = + DateMathExpr DateMathAnchor [DateMathModifier] + deriving (Eq, Show) + +instance ToJSON DateMathExpr where + toJSON (DateMathExpr a mods) = String (fmtA a <> mconcat (fmtMod <$> mods)) + where fmtA DMNow = "now" + fmtA (DMDate date) = (T.pack $ showGregorian date) <> "||" + fmtMod (AddTime n u) = "+" <> showText n <> fmtU u + fmtMod (SubtractTime n u) = "-" <> showText n <> fmtU u + fmtMod (RoundDownTo u) = "/" <> fmtU u + fmtU DMYear = "y" + fmtU DMMonth = "M" + fmtU DMWeek = "w" + fmtU DMDay = "d" + fmtU DMHour = "h" + fmtU DMMinute = "m" + fmtU DMSecond = "s" + +-- | Starting point for a date range. This along with the 'DateMathModifiers' gets you the date ES will start from. +data DateMathAnchor = + DMNow + | DMDate Day + deriving (Eq, Show) + +data DateMathModifier = + AddTime Int DateMathUnit + | SubtractTime Int DateMathUnit + | RoundDownTo DateMathUnit + deriving (Eq, Show) + +data DateMathUnit = + DMYear + | DMMonth + | DMWeek + | DMDay + | DMHour + | DMMinute + | DMSecond + deriving (Eq, Show) diff --git a/src/Database/V1/Bloodhound/Internal/Client.hs b/src/Database/V1/Bloodhound/Internal/Client.hs index a73bdd6..8138ca2 100644 --- a/src/Database/V1/Bloodhound/Internal/Client.hs +++ b/src/Database/V1/Bloodhound/Internal/Client.hs @@ -1,13 +1,21 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE UndecidableInstances #-} + module Database.V1.Bloodhound.Internal.Client where +import Bloodhound.Import -import Control.Applicative as A -import Control.Monad.Reader -import Data.Aeson -import Data.Text (Text) -import Data.Typeable (Typeable) -import GHC.Generics (Generic) +import Control.Applicative as A +import Data.Text (Text) +import qualified Data.Version as Vers import Network.HTTP.Client +import Text.Read (Read (..)) +import qualified Text.Read as TR + +import Database.V1.Bloodhound.Internal.Newtypes {-| Common environment for Elasticsearch calls. Connections will be @@ -24,7 +32,7 @@ instance (Functor m, Applicative m, MonadIO m) => MonadBH (ReaderT BHEnv m) wher {-| 'Server' is used with the client functions to point at the ES instance -} -newtype Server = Server Text deriving (Eq, Show, Generic, Typeable, FromJSON) +newtype Server = Server Text deriving (Eq, Show, FromJSON) {-| All API calls to Elasticsearch operate within MonadBH @@ -89,11 +97,11 @@ data Version = Version { number :: VersionNumber , build_hash :: BuildHash , build_timestamp :: UTCTime , build_snapshot :: Bool - , lucene_version :: VersionNumber } deriving (Eq, Read, Show, Generic, Typeable) + , lucene_version :: VersionNumber } deriving (Eq, Show) -- | Traditional software versioning number newtype VersionNumber = VersionNumber { versionNumber :: Vers.Version - } deriving (Eq, Read, Show, Generic, Typeable, Ord) + } deriving (Eq, Show, Ord) {-| 'Status' is a data type for describing the JSON body returned by Elasticsearch when you query its status. This was deprecated in 1.2.0. @@ -105,7 +113,7 @@ data Status = Status { ok :: Maybe Bool , status :: Int , name :: Text , version :: Version - , tagline :: Text } deriving (Eq, Read, Show, Generic) + , tagline :: Text } deriving (Eq, Show) {-| 'IndexSettings' is used to configure the shards and replicas when you create an Elasticsearch Index. @@ -115,7 +123,7 @@ data Status = Status { ok :: Maybe Bool data IndexSettings = IndexSettings { indexShards :: ShardCount - , indexReplicas :: ReplicaCount } deriving (Eq, Read, Show, Generic, Typeable) + , indexReplicas :: ReplicaCount } deriving (Eq, Show) {-| 'defaultIndexSettings' is an 'IndexSettings' with 3 shards and 2 replicas. -} defaultIndexSettings :: IndexSettings @@ -133,7 +141,7 @@ data IndexOptimizationSettings = -- ^ Should the optimize process only expunge segments with deletes in them? If the purpose of the optimization is to free disk space, this should be set to True. , flushAfterOptimize :: Bool -- ^ Should a flush be performed after the optimize. - } deriving (Eq, Show, Generic, Typeable) + } deriving (Eq, Show) {-| 'defaultIndexOptimizationSettings' implements the default settings that @@ -195,7 +203,7 @@ data UpdatableIndexSetting = NumberOfReplicas ReplicaCount | IndexCompoundFormat CompoundFormat | IndexCompoundOnFlush Bool | WarmerEnabled Bool - deriving (Eq, Show, Generic, Typeable) + deriving (Eq, Show) data AllocationPolicy = AllocAll -- ^ Allows shard allocation for all shards. @@ -205,12 +213,12 @@ data AllocationPolicy = AllocAll -- ^ Allows shard allocation only for primary shards for new indices. | AllocNone -- ^ No shard allocation is allowed - deriving (Eq, Read, Show, Generic, Typeable) + deriving (Eq, Show) data ReplicaBounds = ReplicasBounded Int Int | ReplicasLowerBounded Int | ReplicasUnbounded - deriving (Eq, Read, Show, Generic, Typeable) + deriving (Eq, Show) -- | A measure of bytes used for various configurations. You may want -- to use smart constructors like 'gigabytes' for larger values. @@ -223,7 +231,7 @@ data ReplicaBounds = ReplicasBounded Int Int -- -- >>> kilobytes 9 -- Bytes 9000 -newtype Bytes = Bytes Int deriving (Eq, Read, Show, Generic, Typeable, Ord, ToJSON, FromJSON) +newtype Bytes = Bytes Int deriving (Eq, Show, Ord, ToJSON, FromJSON) gigabytes :: Int -> Bytes gigabytes n = megabytes (1000 * n) @@ -235,3 +243,112 @@ megabytes n = kilobytes (1000 * n) kilobytes :: Int -> Bytes kilobytes n = Bytes (1000 * n) + + +data Interval = Year + | Quarter + | Month + | Week + | Day + | Hour + | Minute + | Second deriving (Eq, Show) + +instance ToJSON Interval where + toJSON Year = "year" + toJSON Quarter = "quarter" + toJSON Month = "month" + toJSON Week = "week" + toJSON Day = "day" + toJSON Hour = "hour" + toJSON Minute = "minute" + toJSON Second = "second" + +parseStringInterval :: (Monad m) => String -> m NominalDiffTime +parseStringInterval s = case span isNumber s of + ("", _) -> fail "Invalid interval" + (nS, unitS) -> case (readMay nS, readMay unitS) of + (Just n, Just unit) -> return (fromInteger (n * unitNDT unit)) + (Nothing, _) -> fail "Invalid interval number" + (_, Nothing) -> fail "Invalid interval unit" + where + unitNDT Seconds = 1 + unitNDT Minutes = 60 + unitNDT Hours = 60 * 60 + unitNDT Days = 24 * 60 * 60 + unitNDT Weeks = 7 * 24 * 60 * 60 + +data TimeInterval = Weeks + | Days + | Hours + | Minutes + | Seconds deriving Eq + +instance Show TimeInterval where + show Weeks = "w" + show Days = "d" + show Hours = "h" + show Minutes = "m" + show Seconds = "s" + +instance Read TimeInterval where + readPrec = f =<< TR.get + where + f 'w' = return Weeks + f 'd' = return Days + f 'h' = return Hours + f 'm' = return Minutes + f 's' = return Seconds + f _ = fail "TimeInterval expected one of w, d, h, m, s" + +-- | Typically a 7 character hex string. +newtype BuildHash = BuildHash { buildHash :: Text } + deriving (Eq, Ord, Show, FromJSON, ToJSON) + +data NodeAttrFilter = NodeAttrFilter + { nodeAttrFilterName :: NodeAttrName + , nodeAttrFilterValues :: NonEmpty Text } + deriving (Eq, Ord, Show) + +newtype NodeAttrName = NodeAttrName Text deriving (Eq, Ord, Show) + +data InitialShardCount = QuorumShards + | QuorumMinus1Shards + | FullShards + | FullMinus1Shards + | ExplicitShards Int + deriving (Eq, Show) + +instance FromJSON InitialShardCount where + parseJSON v = withText "InitialShardCount" parseText v + <|> ExplicitShards <$> parseJSON v + where parseText "quorum" = pure QuorumShards + parseText "quorum-1" = pure QuorumMinus1Shards + parseText "full" = pure FullShards + parseText "full-1" = pure FullMinus1Shards + parseText _ = mzero + +instance ToJSON InitialShardCount where + toJSON QuorumShards = String "quorum" + toJSON QuorumMinus1Shards = String "quorum-1" + toJSON FullShards = String "full" + toJSON FullMinus1Shards = String "full-1" + toJSON (ExplicitShards x) = toJSON x + +data FSType = FSSimple + | FSBuffered deriving (Eq, Show) + +instance ToJSON FSType where + toJSON FSSimple = "simple" + toJSON FSBuffered = "buffered" + +instance FromJSON FSType where + parseJSON = withText "FSType" parse + where parse "simple" = pure FSSimple + parse "buffered" = pure FSBuffered + parse t = fail ("Invalid FSType: " <> show t) + +data CompoundFormat = CompoundFileFormat Bool + | MergeSegmentVsTotalIndex Double + -- ^ percentage between 0 and 1 where 0 is false, 1 is true + deriving (Eq, Show) diff --git a/src/Database/V1/Bloodhound/Internal/Newtypes.hs b/src/Database/V1/Bloodhound/Internal/Newtypes.hs new file mode 100644 index 0000000..0c1af11 --- /dev/null +++ b/src/Database/V1/Bloodhound/Internal/Newtypes.hs @@ -0,0 +1,161 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} + +module Database.V1.Bloodhound.Internal.Newtypes where + + +import Bloodhound.Import + + +newtype From = From Int deriving (Eq, Show, ToJSON) +newtype Size = Size Int deriving (Eq, Show, ToJSON, FromJSON) + + +{-| 'FieldName' is used all over the place wherever a specific field within + a document needs to be specified, usually in 'Query's or 'Filter's. +-} +newtype FieldName = + FieldName Text + deriving (Eq, Read, Show, ToJSON, FromJSON) + +newtype Boost = + Boost Double + deriving (Eq, Show, ToJSON, FromJSON) + +newtype BoostTerms = + BoostTerms Double + deriving (Eq, Show, ToJSON, FromJSON) + +{-| 'ReplicaCount' is part of 'IndexSettings' -} +newtype ReplicaCount = + ReplicaCount Int + deriving (Eq, Show, ToJSON) + +{-| 'ShardCount' is part of 'IndexSettings' -} +newtype ShardCount = + ShardCount Int + deriving (Eq, Show, ToJSON) + + +{-| 'TemplateName' is used to describe which template to query/create/delete +-} +newtype TemplateName = TemplateName Text deriving (Eq, Show, ToJSON, FromJSON) + +{-| 'TemplatePattern' represents a pattern which is matched against index names +-} +newtype TemplatePattern = TemplatePattern Text deriving (Eq, Show, ToJSON, FromJSON) + +{-| 'MappingName' is part of mappings which are how ES describes and schematizes + the data in the indices. +-} +newtype MappingName = MappingName Text deriving (Eq, Show, ToJSON, FromJSON) + +{-| 'DocId' is a generic wrapper value for expressing unique Document IDs. + Can be set by the user or created by ES itself. Often used in client + functions for poking at specific documents. +-} +newtype DocId = DocId Text deriving (Eq, Show, ToJSON, FromJSON) + +{-| 'QueryString' is used to wrap query text bodies, be they human written or not. +-} +newtype QueryString = QueryString Text deriving (Eq, Show, ToJSON, FromJSON) + +{-| 'Script' is often used in place of 'FieldName' to specify more +complex ways of extracting a value from a document. +-} +newtype Script = Script { scriptText :: Text } deriving (Eq, Show) + +{-| 'CacheName' is used in 'RegexpFilter' for describing the + 'CacheKey' keyed caching behavior. +-} +newtype CacheName = CacheName Text deriving (Eq, Show, ToJSON, FromJSON) + +{-| 'CacheKey' is used in 'RegexpFilter' to key regex caching. +-} +newtype CacheKey = + CacheKey Text deriving (Eq, Show, ToJSON, FromJSON) +newtype Existence = + Existence Bool deriving (Eq, Show, ToJSON, FromJSON) +newtype NullValue = + NullValue Bool deriving (Eq, Show, ToJSON, FromJSON) +newtype CutoffFrequency = + CutoffFrequency Double deriving (Eq, Show, ToJSON, FromJSON) +newtype Analyzer = + Analyzer Text deriving (Eq, Show, ToJSON, FromJSON) +newtype MaxExpansions = + MaxExpansions Int deriving (Eq, Show, ToJSON, FromJSON) + +{-| 'Lenient', if set to true, will cause format based failures to be + ignored. I don't know what the bloody default is, Elasticsearch + documentation didn't say what it was. Let me know if you figure it out. +-} +newtype Lenient = + Lenient Bool deriving (Eq, Show, ToJSON, FromJSON) +newtype Tiebreaker = + Tiebreaker Double deriving (Eq, Show, ToJSON, FromJSON) + +{-| 'MinimumMatch' controls how many should clauses in the bool query should + match. Can be an absolute value (2) or a percentage (30%) or a + combination of both. +-} +newtype MinimumMatch = + MinimumMatch Int deriving (Eq, Show, ToJSON, FromJSON) +newtype DisableCoord = + DisableCoord Bool deriving (Eq, Show, ToJSON, FromJSON) +newtype IgnoreTermFrequency = + IgnoreTermFrequency Bool deriving (Eq, Show, ToJSON, FromJSON) +newtype MinimumTermFrequency = + MinimumTermFrequency Int deriving (Eq, Show, ToJSON, FromJSON) +newtype MaxQueryTerms = + MaxQueryTerms Int deriving (Eq, Show, ToJSON, FromJSON) +newtype Fuzziness = + Fuzziness Double deriving (Eq, Show, ToJSON, FromJSON) + +{-| 'PrefixLength' is the prefix length used in queries, defaults to 0. -} +newtype PrefixLength = + PrefixLength Int deriving (Eq, Show, ToJSON, FromJSON) +newtype TypeName = + TypeName Text deriving (Eq, Show, ToJSON, FromJSON) +newtype PercentMatch = + PercentMatch Double deriving (Eq, Show, ToJSON, FromJSON) +newtype StopWord = + StopWord Text deriving (Eq, Show, ToJSON, FromJSON) +newtype QueryPath = + QueryPath Text deriving (Eq, Show, ToJSON, FromJSON) + +{-| Allowing a wildcard at the beginning of a word (eg "*ing") is particularly + heavy, because all terms in the index need to be examined, just in case + they match. Leading wildcards can be disabled by setting + 'AllowLeadingWildcard' to false. -} +newtype AllowLeadingWildcard = + AllowLeadingWildcard Bool deriving (Eq, Show, ToJSON, FromJSON) +newtype LowercaseExpanded = + LowercaseExpanded Bool deriving (Eq, Show, ToJSON, FromJSON) +newtype EnablePositionIncrements = + EnablePositionIncrements Bool deriving (Eq, Show, ToJSON, FromJSON) + +{-| By default, wildcard terms in a query are not analyzed. + Setting 'AnalyzeWildcard' to true enables best-effort analysis. +-} +newtype AnalyzeWildcard = AnalyzeWildcard Bool deriving (Eq, Show, ToJSON, FromJSON) + +{-| 'GeneratePhraseQueries' defaults to false. +-} +newtype GeneratePhraseQueries = + GeneratePhraseQueries Bool deriving (Eq, Show, ToJSON, FromJSON) + +{-| 'Locale' is used for string conversions - defaults to ROOT. +-} +newtype Locale = Locale Text deriving (Eq, Show, ToJSON, FromJSON) +newtype MaxWordLength = MaxWordLength Int deriving (Eq, Show, ToJSON, FromJSON) +newtype MinWordLength = MinWordLength Int deriving (Eq, Show, ToJSON, FromJSON) + +{-| 'PhraseSlop' sets the default slop for phrases, 0 means exact + phrase matches. Default is 0. +-} +newtype PhraseSlop = PhraseSlop Int deriving (Eq, Show, ToJSON, FromJSON) +newtype MinDocFrequency = MinDocFrequency Int deriving (Eq, Show, ToJSON, FromJSON) +newtype MaxDocFrequency = MaxDocFrequency Int deriving (Eq, Show, ToJSON, FromJSON) + +-- | Newtype wrapper to parse ES's concerning tendency to in some APIs return a floating point number of milliseconds since epoch ಠ_ಠ +newtype POSIXMS = POSIXMS { posixMS :: UTCTime } diff --git a/src/Database/V1/Bloodhound/Internal/Query.hs b/src/Database/V1/Bloodhound/Internal/Query.hs new file mode 100644 index 0000000..75e1051 --- /dev/null +++ b/src/Database/V1/Bloodhound/Internal/Query.hs @@ -0,0 +1,1683 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Database.V1.Bloodhound.Internal.Query + ( module X + , module Database.V1.Bloodhound.Internal.Query + ) where + + +import Bloodhound.Import + +import qualified Data.HashMap.Strict as HM +import qualified Data.Text as T + +import Database.Bloodhound.Common.Script as X +import Database.V5.Bloodhound.Internal.Newtypes + + +data GeoPoint = + GeoPoint { geoField :: FieldName + , latLon :: LatLon} deriving (Eq, Show) + +instance ToJSON GeoPoint where + toJSON (GeoPoint (FieldName geoPointField) geoPointLatLon) = + object [ geoPointField .= geoPointLatLon ] + + +data LatLon = LatLon { lat :: Double + , lon :: Double } deriving (Eq, Show) + +instance ToJSON LatLon where + toJSON (LatLon lLat lLon) = + object ["lat" .= lLat + , "lon" .= lLon] + +instance FromJSON LatLon where + parseJSON = withObject "LatLon" parse + where parse o = LatLon <$> o .: "lat" + <*> o .: "lon" + +data DistanceUnit = Miles + | Yards + | Feet + | Inches + | Kilometers + | Meters + | Centimeters + | Millimeters + | NauticalMiles deriving (Eq, Show) + +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 FromJSON DistanceUnit where + parseJSON = withText "DistanceUnit" parse + where parse "mi" = pure Miles + parse "yd" = pure Yards + parse "ft" = pure Feet + parse "in" = pure Inches + parse "km" = pure Kilometers + parse "m" = pure Meters + parse "cm" = pure Centimeters + parse "mm" = pure Millimeters + parse "nmi" = pure NauticalMiles + parse u = fail ("Unrecognized DistanceUnit: " <> show u) + +{-| 'Cache' is for telling ES whether it should cache a 'Filter' not. + 'Query's cannot be cached. +-} +type Cache = Bool -- caching on/off + + +data Filter = AndFilter [Filter] Cache + | OrFilter [Filter] Cache + | NotFilter Filter Cache + | IdentityFilter + | BoolFilter BoolMatch + | ExistsFilter FieldName -- always cached + | GeoBoundingBoxFilter GeoBoundingBoxConstraint + | GeoDistanceFilter GeoPoint Distance DistanceType OptimizeBbox Cache + | GeoDistanceRangeFilter GeoPoint DistanceRange + | GeoPolygonFilter FieldName [LatLon] + | IdsFilter MappingName [DocId] + | LimitFilter Int + | MissingFilter FieldName Existence NullValue + | PrefixFilter FieldName PrefixValue Cache + | QueryFilter Query Cache + | RangeFilter FieldName RangeValue RangeExecution Cache + | RegexpFilter FieldName Regexp RegexpFlags CacheName Cache CacheKey + | TermFilter Term Cache + deriving (Eq, Show) + + +data BoolMatch = MustMatch Term Cache + | MustNotMatch Term Cache + | ShouldMatch [Term] Cache deriving (Eq, Show) + +data Term = Term { termField :: Text + , termValue :: Text } deriving (Eq, Show) + + +data OptimizeBbox = OptimizeGeoFilterType GeoFilterType + | NoOptimizeBbox deriving (Eq, Show) + + +data Distance = + Distance { coefficient :: Double + , unit :: DistanceUnit } deriving (Eq, Show) + +data DistanceRange = + DistanceRange { distanceFrom :: Distance + , distanceTo :: Distance } deriving (Eq, Show) + +-- "memory" or "indexed" +data GeoFilterType = GeoFilterMemory + | GeoFilterIndexed deriving (Eq, Show) + +data GeoBoundingBoxConstraint = + GeoBoundingBoxConstraint { geoBBField :: FieldName + , constraintBox :: GeoBoundingBox + , bbConstraintcache :: Cache + , geoType :: GeoFilterType + } deriving (Eq, Show) + + +data DistanceType = Arc + | SloppyArc -- doesn't exist <1.0 + | Plane deriving (Eq, Show) + +data GeoBoundingBox = + GeoBoundingBox { topLeft :: LatLon + , bottomRight :: LatLon } deriving (Eq, Show) + +{-| 'PrefixValue' is used in 'PrefixQuery' as the main query component. +-} +type PrefixValue = Text + + +data RangeValue = RangeDateLte LessThanEqD + | RangeDateLt LessThanD + | RangeDateGte GreaterThanEqD + | RangeDateGt GreaterThanD + | RangeDateGtLt GreaterThanD LessThanD + | RangeDateGteLte GreaterThanEqD LessThanEqD + | RangeDateGteLt GreaterThanEqD LessThanD + | RangeDateGtLte GreaterThanD LessThanEqD + | RangeDoubleLte LessThanEq + | RangeDoubleLt LessThan + | RangeDoubleGte GreaterThanEq + | RangeDoubleGt GreaterThan + | RangeDoubleGtLt GreaterThan LessThan + | RangeDoubleGteLte GreaterThanEq LessThanEq + | RangeDoubleGteLt GreaterThanEq LessThan + | RangeDoubleGtLte GreaterThan LessThanEq + deriving (Eq, Show) + + +newtype LessThan = LessThan Double deriving (Eq, Show) +newtype LessThanEq = LessThanEq Double deriving (Eq, Show) +newtype GreaterThan = GreaterThan Double deriving (Eq, Show) +newtype GreaterThanEq = GreaterThanEq Double deriving (Eq, Show) + +newtype LessThanD = LessThanD UTCTime deriving (Eq, Show) +newtype LessThanEqD = LessThanEqD UTCTime deriving (Eq, Show) +newtype GreaterThanD = GreaterThanD UTCTime deriving (Eq, Show) +newtype GreaterThanEqD = GreaterThanEqD UTCTime deriving (Eq, Show) + + +data Query = + TermQuery Term (Maybe Boost) + | TermsQuery Text (NonEmpty Text) + | QueryMatchQuery MatchQuery + | QueryMultiMatchQuery MultiMatchQuery + | QueryBoolQuery BoolQuery + | QueryBoostingQuery BoostingQuery + | QueryCommonTermsQuery CommonTermsQuery + | ConstantScoreFilter Filter Boost + | ConstantScoreQuery Query Boost + | QueryDisMaxQuery DisMaxQuery + | QueryFilteredQuery FilteredQuery + | QueryFuzzyLikeThisQuery FuzzyLikeThisQuery + | QueryFuzzyLikeFieldQuery FuzzyLikeFieldQuery + | QueryFuzzyQuery FuzzyQuery + | QueryHasChildQuery HasChildQuery + | QueryHasParentQuery HasParentQuery + | IdsQuery MappingName [DocId] + | QueryIndicesQuery IndicesQuery + | MatchAllQuery (Maybe Boost) + | QueryMoreLikeThisQuery MoreLikeThisQuery + | QueryMoreLikeThisFieldQuery MoreLikeThisFieldQuery + | QueryNestedQuery NestedQuery + | QueryPrefixQuery PrefixQuery + | QueryQueryStringQuery QueryStringQuery + | QuerySimpleQueryStringQuery SimpleQueryStringQuery + | QueryRangeQuery RangeQuery + | QueryRegexpQuery RegexpQuery + | QueryTemplateQueryInline TemplateQueryInline + deriving (Eq, Show) + +data RegexpQuery = + RegexpQuery { regexpQueryField :: FieldName + , regexpQuery :: Regexp + , regexpQueryFlags :: RegexpFlags + , regexpQueryBoost :: Maybe Boost + } deriving (Eq, Show) + +data RangeQuery = + RangeQuery { rangeQueryField :: FieldName + , rangeQueryRange :: RangeValue + , rangeQueryBoost :: Boost } deriving (Eq, Show) + +mkRangeQuery :: FieldName -> RangeValue -> RangeQuery +mkRangeQuery f r = RangeQuery f r (Boost 1.0) + +data SimpleQueryStringQuery = + SimpleQueryStringQuery + { simpleQueryStringQuery :: QueryString + , simpleQueryStringField :: Maybe FieldOrFields + , simpleQueryStringOperator :: Maybe BooleanOperator + , simpleQueryStringAnalyzer :: Maybe Analyzer + , simpleQueryStringFlags :: Maybe (NonEmpty SimpleQueryFlag) + , simpleQueryStringLowercaseExpanded :: Maybe LowercaseExpanded + , simpleQueryStringLocale :: Maybe Locale + } deriving (Eq, Show) + +data SimpleQueryFlag = + SimpleQueryAll + | SimpleQueryNone + | SimpleQueryAnd + | SimpleQueryOr + | SimpleQueryPrefix + | SimpleQueryPhrase + | SimpleQueryPrecedence + | SimpleQueryEscape + | SimpleQueryWhitespace + | SimpleQueryFuzzy + | SimpleQueryNear + | SimpleQuerySlop deriving (Eq, Show) + +-- use_dis_max and tie_breaker when fields are plural? +data QueryStringQuery = + QueryStringQuery + { queryStringQuery :: QueryString + , queryStringDefaultField :: Maybe FieldName + , queryStringOperator :: Maybe BooleanOperator + , queryStringAnalyzer :: Maybe Analyzer + , queryStringAllowLeadingWildcard :: Maybe AllowLeadingWildcard + , queryStringLowercaseExpanded :: Maybe LowercaseExpanded + , queryStringEnablePositionIncrements :: Maybe EnablePositionIncrements + , queryStringFuzzyMaxExpansions :: Maybe MaxExpansions + , queryStringFuzziness :: Maybe Fuzziness + , queryStringFuzzyPrefixLength :: Maybe PrefixLength + , queryStringPhraseSlop :: Maybe PhraseSlop + , queryStringBoost :: Maybe Boost + , queryStringAnalyzeWildcard :: Maybe AnalyzeWildcard + , queryStringGeneratePhraseQueries :: Maybe GeneratePhraseQueries + , queryStringMinimumShouldMatch :: Maybe MinimumMatch + , queryStringLenient :: Maybe Lenient + , queryStringLocale :: Maybe Locale + } deriving (Eq, Show) + +mkQueryStringQuery :: QueryString -> QueryStringQuery +mkQueryStringQuery qs = + QueryStringQuery qs Nothing Nothing + Nothing Nothing Nothing Nothing + Nothing Nothing Nothing Nothing + Nothing Nothing Nothing Nothing + Nothing Nothing + +data FieldOrFields = FofField FieldName + | FofFields (NonEmpty FieldName) deriving (Eq, Show) + +data PrefixQuery = + PrefixQuery + { prefixQueryField :: FieldName + , prefixQueryPrefixValue :: Text + , prefixQueryBoost :: Maybe Boost } deriving (Eq, Show) + +data NestedQuery = + NestedQuery + { nestedQueryPath :: QueryPath + , nestedQueryScoreType :: ScoreType + , nestedQuery :: Query } deriving (Eq, Show) + +data MoreLikeThisFieldQuery = + MoreLikeThisFieldQuery + { moreLikeThisFieldText :: Text + , moreLikeThisFieldFields :: FieldName + -- default 0.3 (30%) + , moreLikeThisFieldPercentMatch :: Maybe PercentMatch + , moreLikeThisFieldMinimumTermFreq :: Maybe MinimumTermFrequency + , moreLikeThisFieldMaxQueryTerms :: Maybe MaxQueryTerms + , moreLikeThisFieldStopWords :: Maybe (NonEmpty StopWord) + , moreLikeThisFieldMinDocFrequency :: Maybe MinDocFrequency + , moreLikeThisFieldMaxDocFrequency :: Maybe MaxDocFrequency + , moreLikeThisFieldMinWordLength :: Maybe MinWordLength + , moreLikeThisFieldMaxWordLength :: Maybe MaxWordLength + , moreLikeThisFieldBoostTerms :: Maybe BoostTerms + , moreLikeThisFieldBoost :: Maybe Boost + , moreLikeThisFieldAnalyzer :: Maybe Analyzer + } deriving (Eq, Show) + +data MoreLikeThisQuery = + MoreLikeThisQuery + { moreLikeThisText :: Text + , moreLikeThisFields :: Maybe (NonEmpty FieldName) + -- default 0.3 (30%) + , moreLikeThisPercentMatch :: Maybe PercentMatch + , moreLikeThisMinimumTermFreq :: Maybe MinimumTermFrequency + , moreLikeThisMaxQueryTerms :: Maybe MaxQueryTerms + , moreLikeThisStopWords :: Maybe (NonEmpty StopWord) + , moreLikeThisMinDocFrequency :: Maybe MinDocFrequency + , moreLikeThisMaxDocFrequency :: Maybe MaxDocFrequency + , moreLikeThisMinWordLength :: Maybe MinWordLength + , moreLikeThisMaxWordLength :: Maybe MaxWordLength + , moreLikeThisBoostTerms :: Maybe BoostTerms + , moreLikeThisBoost :: Maybe Boost + , moreLikeThisAnalyzer :: Maybe Analyzer + } deriving (Eq, Show) + +data IndicesQuery = + IndicesQuery + { indicesQueryIndices :: [IndexName] + , indicesQuery :: Query + -- default "all" + , indicesQueryNoMatch :: Maybe Query } deriving (Eq, Show) + +data HasParentQuery = + HasParentQuery + { hasParentQueryType :: TypeName + , hasParentQuery :: Query + , hasParentQueryScoreType :: Maybe ScoreType } deriving (Eq, Show) + +data HasChildQuery = + HasChildQuery + { hasChildQueryType :: TypeName + , hasChildQuery :: Query + , hasChildQueryScoreType :: Maybe ScoreType } deriving (Eq, Show) + +data ScoreType = + ScoreTypeMax + | ScoreTypeSum + | ScoreTypeAvg + | ScoreTypeNone deriving (Eq, Show) + +data FuzzyQuery = + FuzzyQuery { fuzzyQueryField :: FieldName + , fuzzyQueryValue :: Text + , fuzzyQueryPrefixLength :: PrefixLength + , fuzzyQueryMaxExpansions :: MaxExpansions + , fuzzyQueryFuzziness :: Fuzziness + , fuzzyQueryBoost :: Maybe Boost + } deriving (Eq, Show) + +data FuzzyLikeFieldQuery = + FuzzyLikeFieldQuery + { fuzzyLikeField :: FieldName + -- anaphora is good for the soul. + , fuzzyLikeFieldText :: Text + , fuzzyLikeFieldMaxQueryTerms :: MaxQueryTerms + , fuzzyLikeFieldIgnoreTermFrequency :: IgnoreTermFrequency + , fuzzyLikeFieldFuzziness :: Fuzziness + , fuzzyLikeFieldPrefixLength :: PrefixLength + , fuzzyLikeFieldBoost :: Boost + , fuzzyLikeFieldAnalyzer :: Maybe Analyzer + } deriving (Eq, Show) + +data FuzzyLikeThisQuery = + FuzzyLikeThisQuery + { fuzzyLikeFields :: [FieldName] + , fuzzyLikeText :: Text + , fuzzyLikeMaxQueryTerms :: MaxQueryTerms + , fuzzyLikeIgnoreTermFrequency :: IgnoreTermFrequency + , fuzzyLikeFuzziness :: Fuzziness + , fuzzyLikePrefixLength :: PrefixLength + , fuzzyLikeBoost :: Boost + , fuzzyLikeAnalyzer :: Maybe Analyzer + } deriving (Eq, Show) + +data FilteredQuery = + FilteredQuery + { filteredQuery :: Query + , filteredFilter :: Filter } deriving (Eq, Show) + +data DisMaxQuery = + DisMaxQuery { disMaxQueries :: [Query] + -- default 0.0 + , disMaxTiebreaker :: Tiebreaker + , disMaxBoost :: Maybe Boost + } deriving (Eq, Show) + +data MatchQuery = + MatchQuery { matchQueryField :: FieldName + , matchQueryQueryString :: QueryString + , matchQueryOperator :: BooleanOperator + , matchQueryZeroTerms :: ZeroTermsQuery + , matchQueryCutoffFrequency :: Maybe CutoffFrequency + , matchQueryMatchType :: Maybe MatchQueryType + , matchQueryAnalyzer :: Maybe Analyzer + , matchQueryMaxExpansions :: Maybe MaxExpansions + , matchQueryLenient :: Maybe Lenient + , matchQueryBoost :: Maybe Boost } deriving (Eq, Show) + +{-| 'mkMatchQuery' is a convenience function that defaults the less common parameters, + enabling you to provide only the 'FieldName' and 'QueryString' to make a 'MatchQuery' +-} +mkMatchQuery :: FieldName -> QueryString -> MatchQuery +mkMatchQuery field query = MatchQuery field query Or ZeroTermsNone Nothing Nothing Nothing Nothing Nothing Nothing + +data MatchQueryType = + MatchPhrase + | MatchPhrasePrefix deriving (Eq, Show) + +data MultiMatchQuery = + MultiMatchQuery { multiMatchQueryFields :: [FieldName] + , multiMatchQueryString :: QueryString + , multiMatchQueryOperator :: BooleanOperator + , multiMatchQueryZeroTerms :: ZeroTermsQuery + , multiMatchQueryTiebreaker :: Maybe Tiebreaker + , multiMatchQueryType :: Maybe MultiMatchQueryType + , multiMatchQueryCutoffFrequency :: Maybe CutoffFrequency + , multiMatchQueryAnalyzer :: Maybe Analyzer + , multiMatchQueryMaxExpansions :: Maybe MaxExpansions + , multiMatchQueryLenient :: Maybe Lenient } deriving (Eq, Show) + +{-| 'mkMultiMatchQuery' is a convenience function that defaults the less common parameters, + enabling you to provide only the list of 'FieldName's and 'QueryString' to + make a 'MultiMatchQuery'. +-} + +mkMultiMatchQuery :: [FieldName] -> QueryString -> MultiMatchQuery +mkMultiMatchQuery matchFields query = + MultiMatchQuery matchFields query + Or ZeroTermsNone Nothing Nothing Nothing Nothing Nothing Nothing + +data MultiMatchQueryType = + MultiMatchBestFields + | MultiMatchMostFields + | MultiMatchCrossFields + | MultiMatchPhrase + | MultiMatchPhrasePrefix deriving (Eq, Show) + +data BoolQuery = + BoolQuery { boolQueryMustMatch :: [Query] + , boolQueryMustNotMatch :: [Query] + , boolQueryShouldMatch :: [Query] + , boolQueryMinimumShouldMatch :: Maybe MinimumMatch + , boolQueryBoost :: Maybe Boost + , boolQueryDisableCoord :: Maybe DisableCoord + } deriving (Eq, Show) + +mkBoolQuery :: [Query] -> [Query] -> [Query] -> BoolQuery +mkBoolQuery must mustNot should = + BoolQuery must mustNot should Nothing Nothing Nothing + +data BoostingQuery = + BoostingQuery { positiveQuery :: Query + , negativeQuery :: Query + , negativeBoost :: Boost } deriving (Eq, Show) + +data CommonTermsQuery = + CommonTermsQuery { commonField :: FieldName + , commonQuery :: QueryString + , commonCutoffFrequency :: CutoffFrequency + , commonLowFreqOperator :: BooleanOperator + , commonHighFreqOperator :: BooleanOperator + , commonMinimumShouldMatch :: Maybe CommonMinimumMatch + , commonBoost :: Maybe Boost + , commonAnalyzer :: Maybe Analyzer + , commonDisableCoord :: Maybe DisableCoord + } deriving (Eq, Show) + +data CommonMinimumMatch = + CommonMinimumMatchHighLow MinimumMatchHighLow + | CommonMinimumMatch MinimumMatch + deriving (Eq, Show) + +data MinimumMatchHighLow = + MinimumMatchHighLow { lowFreq :: MinimumMatch + , highFreq :: MinimumMatch } deriving (Eq, Show) + + +data TemplateQueryInline = + TemplateQueryInline { inline :: Query + , params :: TemplateQueryKeyValuePairs + } + deriving (Eq, Show) + +instance ToJSON TemplateQueryInline where + toJSON TemplateQueryInline{..} = object [ "query" .= inline + , "params" .= params + ] + +instance FromJSON TemplateQueryInline where + parseJSON = withObject "TemplateQueryInline" parse + where parse o = TemplateQueryInline + <$> o .: "query" + <*> o .: "params" + +{-| 'BooleanOperator' is the usual And/Or operators with an ES compatible + JSON encoding baked in. Used all over the place. +-} +data BooleanOperator = And | Or deriving (Eq, Show) + +type TemplateQueryKey = Text +type TemplateQueryValue = Text + +newtype TemplateQueryKeyValuePairs = TemplateQueryKeyValuePairs (HM.HashMap TemplateQueryKey TemplateQueryValue) + deriving (Eq, Show) + +instance ToJSON TemplateQueryKeyValuePairs where + toJSON (TemplateQueryKeyValuePairs x) = Object $ HM.map toJSON x + +instance FromJSON TemplateQueryKeyValuePairs where + parseJSON (Object o) = pure . TemplateQueryKeyValuePairs $ HM.mapMaybe getValue o + where getValue (String x) = Just x + getValue _ = Nothing + parseJSON _ = fail "error parsing TemplateQueryKeyValuePairs" + +newtype Regexp = Regexp Text deriving (Eq, Show, FromJSON) + +data RegexpFlags = AllRegexpFlags + | NoRegexpFlags + | SomeRegexpFlags (NonEmpty RegexpFlag) deriving (Eq, Show) + +data RegexpFlag = AnyString + | Automaton + | Complement + | Empty + | Intersection + | Interval deriving (Eq, Show) + +data RangeExecution = RangeExecutionIndex + | RangeExecutionFielddata deriving (Eq, Show) + +data ZeroTermsQuery = ZeroTermsNone + | ZeroTermsAll deriving (Eq, Show) + +instance ToJSON Query where + toJSON (TermQuery (Term termQueryField termQueryValue) boost) = + object [ "term" .= + object [termQueryField .= object merged]] + where + base = [ "value" .= termQueryValue ] + boosted = maybe [] (return . ("boost" .=)) boost + merged = mappend base boosted + + toJSON (TermsQuery fieldName terms) = + object [ "terms" .= object conjoined ] + where conjoined = [fieldName .= terms] + + toJSON (IdsQuery idsQueryMappingName docIds) = + object [ "ids" .= object conjoined ] + where conjoined = [ "type" .= idsQueryMappingName + , "values" .= fmap toJSON docIds ] + + toJSON (QueryQueryStringQuery qQueryStringQuery) = + object [ "query_string" .= qQueryStringQuery ] + + toJSON (QueryMatchQuery matchQuery) = + object [ "match" .= matchQuery ] + + toJSON (QueryMultiMatchQuery multiMatchQuery) = + toJSON multiMatchQuery + + toJSON (QueryBoolQuery boolQuery) = + object [ "bool" .= boolQuery ] + + toJSON (QueryBoostingQuery boostingQuery) = + object [ "boosting" .= boostingQuery ] + + toJSON (QueryCommonTermsQuery commonTermsQuery) = + object [ "common" .= commonTermsQuery ] + + toJSON (ConstantScoreFilter csFilter boost) = + object ["constant_score" .= object ["filter" .= csFilter + , "boost" .= boost]] + + toJSON (ConstantScoreQuery query boost) = + object ["constant_score" .= object ["query" .= query + , "boost" .= boost]] + + toJSON (QueryDisMaxQuery disMaxQuery) = + object [ "dis_max" .= disMaxQuery ] + + toJSON (QueryFilteredQuery qFilteredQuery) = + object [ "filtered" .= qFilteredQuery ] + + toJSON (QueryFuzzyLikeThisQuery fuzzyQuery) = + object [ "fuzzy_like_this" .= fuzzyQuery ] + + toJSON (QueryFuzzyLikeFieldQuery fuzzyFieldQuery) = + object [ "fuzzy_like_this_field" .= fuzzyFieldQuery ] + + toJSON (QueryFuzzyQuery fuzzyQuery) = + object [ "fuzzy" .= fuzzyQuery ] + + toJSON (QueryHasChildQuery childQuery) = + object [ "has_child" .= childQuery ] + + toJSON (QueryHasParentQuery parentQuery) = + object [ "has_parent" .= parentQuery ] + + toJSON (QueryIndicesQuery qIndicesQuery) = + object [ "indices" .= qIndicesQuery ] + + toJSON (MatchAllQuery boost) = + object [ "match_all" .= omitNulls [ "boost" .= boost ] ] + + toJSON (QueryMoreLikeThisQuery query) = + object [ "more_like_this" .= query ] + + toJSON (QueryMoreLikeThisFieldQuery query) = + object [ "more_like_this_field" .= query ] + + toJSON (QueryNestedQuery query) = + object [ "nested" .= query ] + + toJSON (QueryPrefixQuery query) = + object [ "prefix" .= query ] + + toJSON (QueryRangeQuery query) = + object [ "range" .= query ] + + toJSON (QueryRegexpQuery query) = + object [ "regexp" .= query ] + + toJSON (QuerySimpleQueryStringQuery query) = + object [ "simple_query_string" .= query ] + + toJSON (QueryTemplateQueryInline templateQuery) = + object [ "template" .= templateQuery ] + +instance FromJSON Query where + parseJSON v = withObject "Query" parse v + where parse o = termQuery `taggedWith` "term" + <|> termsQuery `taggedWith` "terms" + <|> idsQuery `taggedWith` "ids" + <|> queryQueryStringQuery `taggedWith` "query_string" + <|> queryMatchQuery `taggedWith` "match" + <|> queryMultiMatchQuery + <|> queryBoolQuery `taggedWith` "bool" + <|> queryBoostingQuery `taggedWith` "boosting" + <|> queryCommonTermsQuery `taggedWith` "common" + <|> constantScoreFilter `taggedWith` "constant_score" + <|> constantScoreQuery `taggedWith` "constant_score" + <|> queryDisMaxQuery `taggedWith` "dis_max" + <|> queryFilteredQuery `taggedWith` "filtered" + <|> queryFuzzyLikeThisQuery `taggedWith` "fuzzy_like_this" + <|> queryFuzzyLikeFieldQuery `taggedWith` "fuzzy_like_this_field" + <|> queryFuzzyQuery `taggedWith` "fuzzy" + <|> queryHasChildQuery `taggedWith` "has_child" + <|> queryHasParentQuery `taggedWith` "has_parent" + <|> queryIndicesQuery `taggedWith` "indices" + <|> matchAllQuery `taggedWith` "match_all" + <|> queryMoreLikeThisQuery `taggedWith` "more_like_this" + <|> queryMoreLikeThisFieldQuery `taggedWith` "more_like_this_field" + <|> queryNestedQuery `taggedWith` "nested" + <|> queryPrefixQuery `taggedWith` "prefix" + <|> queryRangeQuery `taggedWith` "range" + <|> queryRegexpQuery `taggedWith` "regexp" + <|> querySimpleQueryStringQuery `taggedWith` "simple_query_string" + <|> queryTemplateQueryInline `taggedWith` "template" + where taggedWith parser k = parser =<< o .: k + termQuery = fieldTagged $ \(FieldName fn) o -> + TermQuery <$> (Term fn <$> o .: "value") <*> o .:? "boost" + termsQuery o = case HM.toList o of + [(fn, vs)] -> do vals <- parseJSON vs + case vals of + x:xs -> return (TermsQuery fn (x :| xs)) + _ -> fail "Expected non empty list of values" + _ -> fail "Expected object with 1 field-named key" + idsQuery o = IdsQuery <$> o .: "type" + <*> o .: "values" + queryQueryStringQuery = pure . QueryQueryStringQuery + queryMatchQuery = pure . QueryMatchQuery + queryMultiMatchQuery = QueryMultiMatchQuery <$> parseJSON v + queryBoolQuery = pure . QueryBoolQuery + queryBoostingQuery = pure . QueryBoostingQuery + queryCommonTermsQuery = pure . QueryCommonTermsQuery + constantScoreFilter o = case HM.lookup "filter" o of + Just x -> ConstantScoreFilter <$> parseJSON x + <*> o .: "boost" + _ -> fail "Does not appear to be a ConstantScoreFilter" + constantScoreQuery o = case HM.lookup "query" o of + Just x -> ConstantScoreQuery <$> parseJSON x + <*> o .: "boost" + _ -> fail "Does not appear to be a ConstantScoreQuery" + queryDisMaxQuery = pure . QueryDisMaxQuery + queryFilteredQuery = pure . QueryFilteredQuery + queryFuzzyLikeThisQuery = pure . QueryFuzzyLikeThisQuery + queryFuzzyLikeFieldQuery = pure . QueryFuzzyLikeFieldQuery + queryFuzzyQuery = pure . QueryFuzzyQuery + queryHasChildQuery = pure . QueryHasChildQuery + queryHasParentQuery = pure . QueryHasParentQuery + queryIndicesQuery = pure . QueryIndicesQuery + matchAllQuery o = MatchAllQuery <$> o .:? "boost" + queryMoreLikeThisQuery = pure . QueryMoreLikeThisQuery + queryMoreLikeThisFieldQuery = pure . QueryMoreLikeThisFieldQuery + queryNestedQuery = pure . QueryNestedQuery + queryPrefixQuery = pure . QueryPrefixQuery + queryRangeQuery = pure . QueryRangeQuery + queryRegexpQuery = pure . QueryRegexpQuery + querySimpleQueryStringQuery = pure . QuerySimpleQueryStringQuery + queryTemplateQueryInline = pure . QueryTemplateQueryInline + +instance ToJSON SimpleQueryStringQuery where + toJSON SimpleQueryStringQuery {..} = + omitNulls (base ++ maybeAdd) + where base = [ "query" .= simpleQueryStringQuery ] + maybeAdd = [ "fields" .= simpleQueryStringField + , "default_operator" .= simpleQueryStringOperator + , "analyzer" .= simpleQueryStringAnalyzer + , "flags" .= simpleQueryStringFlags + , "lowercase_expanded_terms" .= simpleQueryStringLowercaseExpanded + , "locale" .= simpleQueryStringLocale ] + +instance FromJSON SimpleQueryStringQuery where + parseJSON = withObject "SimpleQueryStringQuery" parse + where parse o = SimpleQueryStringQuery <$> o .: "query" + <*> o .:? "fields" + <*> o .:? "default_operator" + <*> o .:? "analyzer" + <*> (parseFlags <$> o .:? "flags") + <*> o .:? "lowercase_expanded_terms" + <*> o .:? "locale" + parseFlags (Just (x:xs)) = Just (x :| xs) + parseFlags _ = Nothing + +instance ToJSON FieldOrFields where + toJSON (FofField fieldName) = + toJSON fieldName + toJSON (FofFields fieldNames) = + toJSON fieldNames + +instance FromJSON FieldOrFields where + parseJSON v = FofField <$> parseJSON v + <|> FofFields <$> (parseNEJSON =<< parseJSON v) + +instance ToJSON SimpleQueryFlag where + toJSON SimpleQueryAll = "ALL" + toJSON SimpleQueryNone = "NONE" + toJSON SimpleQueryAnd = "AND" + toJSON SimpleQueryOr = "OR" + toJSON SimpleQueryPrefix = "PREFIX" + toJSON SimpleQueryPhrase = "PHRASE" + toJSON SimpleQueryPrecedence = "PRECEDENCE" + toJSON SimpleQueryEscape = "ESCAPE" + toJSON SimpleQueryWhitespace = "WHITESPACE" + toJSON SimpleQueryFuzzy = "FUZZY" + toJSON SimpleQueryNear = "NEAR" + toJSON SimpleQuerySlop = "SLOP" + +instance FromJSON SimpleQueryFlag where + parseJSON = withText "SimpleQueryFlag" parse + where parse "ALL" = pure SimpleQueryAll + parse "NONE" = pure SimpleQueryNone + parse "AND" = pure SimpleQueryAnd + parse "OR" = pure SimpleQueryOr + parse "PREFIX" = pure SimpleQueryPrefix + parse "PHRASE" = pure SimpleQueryPhrase + parse "PRECEDENCE" = pure SimpleQueryPrecedence + parse "ESCAPE" = pure SimpleQueryEscape + parse "WHITESPACE" = pure SimpleQueryWhitespace + parse "FUZZY" = pure SimpleQueryFuzzy + parse "NEAR" = pure SimpleQueryNear + parse "SLOP" = pure SimpleQuerySlop + parse f = fail ("Unexpected SimpleQueryFlag: " <> show f) + +instance ToJSON RegexpQuery where + toJSON (RegexpQuery (FieldName rqQueryField) + (Regexp regexpQueryQuery) rqQueryFlags + rqQueryBoost) = + object [ rqQueryField .= omitNulls base ] + where base = [ "value" .= regexpQueryQuery + , "flags" .= rqQueryFlags + , "boost" .= rqQueryBoost ] + +instance FromJSON RegexpQuery where + parseJSON = withObject "RegexpQuery" parse + where parse = fieldTagged $ \fn o -> + RegexpQuery fn + <$> o .: "value" + <*> o .: "flags" + <*> o .:? "boost" + +instance ToJSON QueryStringQuery where + toJSON (QueryStringQuery qsQueryString + qsDefaultField qsOperator + qsAnalyzer qsAllowWildcard + qsLowercaseExpanded qsEnablePositionIncrements + qsFuzzyMaxExpansions qsFuzziness + qsFuzzyPrefixLength qsPhraseSlop + qsBoost qsAnalyzeWildcard + qsGeneratePhraseQueries qsMinimumShouldMatch + qsLenient qsLocale) = + omitNulls base + where + base = [ "query" .= qsQueryString + , "default_field" .= qsDefaultField + , "default_operator" .= qsOperator + , "analyzer" .= qsAnalyzer + , "allow_leading_wildcard" .= qsAllowWildcard + , "lowercase_expanded_terms" .= qsLowercaseExpanded + , "enable_position_increments" .= qsEnablePositionIncrements + , "fuzzy_max_expansions" .= qsFuzzyMaxExpansions + , "fuzziness" .= qsFuzziness + , "fuzzy_prefix_length" .= qsFuzzyPrefixLength + , "phrase_slop" .= qsPhraseSlop + , "boost" .= qsBoost + , "analyze_wildcard" .= qsAnalyzeWildcard + , "auto_generate_phrase_queries" .= qsGeneratePhraseQueries + , "minimum_should_match" .= qsMinimumShouldMatch + , "lenient" .= qsLenient + , "locale" .= qsLocale ] + +instance FromJSON QueryStringQuery where + parseJSON = withObject "QueryStringQuery" parse + where parse o = QueryStringQuery + <$> o .: "query" + <*> o .:? "default_field" + <*> o .:? "default_operator" + <*> o .:? "analyzer" + <*> o .:? "allow_leading_wildcard" + <*> o .:? "lowercase_expanded_terms" + <*> o .:? "enable_position_increments" + <*> o .:? "fuzzy_max_expansions" + <*> o .:? "fuzziness" + <*> o .:? "fuzzy_prefix_length" + <*> o .:? "phrase_slop" + <*> o .:? "boost" + <*> o .:? "analyze_wildcard" + <*> o .:? "auto_generate_phrase_queries" + <*> o .:? "minimum_should_match" + <*> o .:? "lenient" + <*> o .:? "locale" + +instance ToJSON RangeQuery where + toJSON (RangeQuery (FieldName fieldName) range boost) = + object [ fieldName .= object conjoined ] + where conjoined = [ "boost" .= boost ] ++ (rangeValueToPair range) + +instance FromJSON RangeQuery where + parseJSON = withObject "RangeQuery" parse + where parse = fieldTagged $ \fn o -> + RangeQuery fn + <$> parseJSON (Object o) + <*> o .: "boost" + +instance FromJSON RangeValue where + parseJSON = withObject "RangeValue" parse + where parse o = parseDate o + <|> parseDouble o + parseDate o = do lt <- o .:? "lt" + lte <- o .:? "lte" + gt <- o .:? "gt" + gte <- o .:? "gte" + case (lt, lte, gt, gte) of + (Just a, _, Just b, _) -> return (RangeDateGtLt (GreaterThanD b) (LessThanD a)) + (Just a, _, _, Just b)-> return (RangeDateGteLt (GreaterThanEqD b) (LessThanD a)) + (_, Just a, Just b, _)-> return (RangeDateGtLte (GreaterThanD b) (LessThanEqD a)) + (_, Just a, _, Just b)-> return (RangeDateGteLte (GreaterThanEqD b) (LessThanEqD a)) + (_, _, Just a, _)-> return (RangeDateGt (GreaterThanD a)) + (Just a, _, _, _)-> return (RangeDateLt (LessThanD a)) + (_, _, _, Just a)-> return (RangeDateGte (GreaterThanEqD a)) + (_, Just a, _, _)-> return (RangeDateLte (LessThanEqD a)) + (Nothing, Nothing, Nothing, Nothing) -> mzero + parseDouble o = do lt <- o .:? "lt" + lte <- o .:? "lte" + gt <- o .:? "gt" + gte <- o .:? "gte" + case (lt, lte, gt, gte) of + (Just a, _, Just b, _) -> return (RangeDoubleGtLt (GreaterThan b) (LessThan a)) + (Just a, _, _, Just b)-> return (RangeDoubleGteLt (GreaterThanEq b) (LessThan a)) + (_, Just a, Just b, _)-> return (RangeDoubleGtLte (GreaterThan b) (LessThanEq a)) + (_, Just a, _, Just b)-> return (RangeDoubleGteLte (GreaterThanEq b) (LessThanEq a)) + (_, _, Just a, _)-> return (RangeDoubleGt (GreaterThan a)) + (Just a, _, _, _)-> return (RangeDoubleLt (LessThan a)) + (_, _, _, Just a)-> return (RangeDoubleGte (GreaterThanEq a)) + (_, Just a, _, _)-> return (RangeDoubleLte (LessThanEq a)) + (Nothing, Nothing, Nothing, Nothing) -> mzero + +instance ToJSON PrefixQuery where + toJSON (PrefixQuery (FieldName fieldName) queryValue boost) = + object [ fieldName .= omitNulls base ] + where base = [ "value" .= queryValue + , "boost" .= boost ] + +instance FromJSON PrefixQuery where + parseJSON = withObject "PrefixQuery" parse + where parse = fieldTagged $ \fn o -> + PrefixQuery fn + <$> o .: "value" + <*> o .:? "boost" + +instance ToJSON NestedQuery where + toJSON (NestedQuery nqPath nqScoreType nqQuery) = + object [ "path" .= nqPath + , "score_mode" .= nqScoreType + , "query" .= nqQuery ] + +instance FromJSON NestedQuery where + parseJSON = withObject "NestedQuery" parse + where parse o = NestedQuery + <$> o .: "path" + <*> o .: "score_mode" + <*> o .: "query" + +instance ToJSON MoreLikeThisFieldQuery where + toJSON (MoreLikeThisFieldQuery text (FieldName fieldName) + percent mtf mqt stopwords mindf maxdf + minwl maxwl boostTerms boost analyzer) = + object [ fieldName .= omitNulls base ] + where base = [ "like_text" .= text + , "percent_terms_to_match" .= percent + , "min_term_freq" .= mtf + , "max_query_terms" .= mqt + , "stop_words" .= stopwords + , "min_doc_freq" .= mindf + , "max_doc_freq" .= maxdf + , "min_word_length" .= minwl + , "max_word_length" .= maxwl + , "boost_terms" .= boostTerms + , "boost" .= boost + , "analyzer" .= analyzer ] + +instance FromJSON MoreLikeThisFieldQuery where + parseJSON = withObject "MoreLikeThisFieldQuery" parse + where parse = fieldTagged $ \fn o -> + MoreLikeThisFieldQuery + <$> o .: "like_text" + <*> pure fn + <*> o .:? "percent_terms_to_match" + <*> o .:? "min_term_freq" + <*> o .:? "max_query_terms" + -- <*> (optionalNE =<< o .:? "stop_words") + <*> o .:? "stop_words" + <*> o .:? "min_doc_freq" + <*> o .:? "max_doc_freq" + <*> o .:? "min_word_length" + <*> o .:? "max_word_length" + <*> o .:? "boost_terms" + <*> o .:? "boost" + <*> o .:? "analyzer" + -- optionalNE = maybe (pure Nothing) (fmap Just . parseNEJSON) + +instance ToJSON MoreLikeThisQuery where + toJSON (MoreLikeThisQuery text fields percent + mtf mqt stopwords mindf maxdf + minwl maxwl boostTerms boost analyzer) = + omitNulls base + where base = [ "like_text" .= text + , "fields" .= fields + , "percent_terms_to_match" .= percent + , "min_term_freq" .= mtf + , "max_query_terms" .= mqt + , "stop_words" .= stopwords + , "min_doc_freq" .= mindf + , "max_doc_freq" .= maxdf + , "min_word_length" .= minwl + , "max_word_length" .= maxwl + , "boost_terms" .= boostTerms + , "boost" .= boost + , "analyzer" .= analyzer ] + +instance FromJSON MoreLikeThisQuery where + parseJSON = withObject "MoreLikeThisQuery" parse + where parse o = MoreLikeThisQuery + <$> o .: "like_text" + -- <*> (optionalNE =<< o .:? "fields") + <*> o .:? "fields" + <*> o .:? "percent_terms_to_match" + <*> o .:? "min_term_freq" + <*> o .:? "max_query_terms" + -- <*> (optionalNE =<< o .:? "stop_words") + <*> o .:? "stop_words" + <*> o .:? "min_doc_freq" + <*> o .:? "max_doc_freq" + <*> o .:? "min_word_length" + <*> o .:? "max_word_length" + <*> o .:? "boost_terms" + <*> o .:? "boost" + <*> o .:? "analyzer" + -- optionalNE = maybe (pure Nothing) (fmap Just . parseNEJSON) + +instance ToJSON IndicesQuery where + toJSON (IndicesQuery indices query noMatch) = + omitNulls [ "indices" .= indices + , "no_match_query" .= noMatch + , "query" .= query ] + +instance FromJSON IndicesQuery where + parseJSON = withObject "IndicesQuery" parse + where parse o = IndicesQuery + <$> o .:? "indices" .!= [] + <*> o .: "query" + <*> o .:? "no_match_query" + +instance ToJSON HasParentQuery where + toJSON (HasParentQuery queryType query scoreType) = + omitNulls [ "parent_type" .= queryType + , "score_type" .= scoreType + , "query" .= query ] + +instance FromJSON HasParentQuery where + parseJSON = withObject "HasParentQuery" parse + where parse o = HasParentQuery + <$> o .: "parent_type" + <*> o .: "query" + <*> o .:? "score_type" + +instance ToJSON HasChildQuery where + toJSON (HasChildQuery queryType query scoreType) = + omitNulls [ "query" .= query + , "score_type" .= scoreType + , "type" .= queryType ] + +instance FromJSON HasChildQuery where + parseJSON = withObject "HasChildQuery" parse + where parse o = HasChildQuery + <$> o .: "type" + <*> o .: "query" + <*> o .:? "score_type" + +instance ToJSON FuzzyQuery where + toJSON (FuzzyQuery (FieldName fieldName) queryText + prefixLength maxEx fuzziness boost) = + object [ fieldName .= omitNulls base ] + where base = [ "value" .= queryText + , "fuzziness" .= fuzziness + , "prefix_length" .= prefixLength + , "boost" .= boost + , "max_expansions" .= maxEx ] + +instance FromJSON FuzzyQuery where + parseJSON = withObject "FuzzyQuery" parse + where parse = fieldTagged $ \fn o -> + FuzzyQuery fn + <$> o .: "value" + <*> o .: "prefix_length" + <*> o .: "max_expansions" + <*> o .: "fuzziness" + <*> o .:? "boost" + +instance ToJSON FuzzyLikeFieldQuery where + toJSON (FuzzyLikeFieldQuery (FieldName fieldName) + fieldText maxTerms ignoreFreq fuzziness prefixLength + boost analyzer) = + object [ fieldName .= + omitNulls [ "like_text" .= fieldText + , "max_query_terms" .= maxTerms + , "ignore_tf" .= ignoreFreq + , "fuzziness" .= fuzziness + , "prefix_length" .= prefixLength + , "analyzer" .= analyzer + , "boost" .= boost ]] + +instance FromJSON FuzzyLikeFieldQuery where + parseJSON = withObject "FuzzyLikeFieldQuery" parse + where parse = fieldTagged $ \fn o -> + FuzzyLikeFieldQuery fn + <$> o .: "like_text" + <*> o .: "max_query_terms" + <*> o .: "ignore_tf" + <*> o .: "fuzziness" + <*> o .: "prefix_length" + <*> o .: "boost" + <*> o .:? "analyzer" + +instance ToJSON FuzzyLikeThisQuery where + toJSON (FuzzyLikeThisQuery fields text maxTerms + ignoreFreq fuzziness prefixLength boost analyzer) = + omitNulls base + where base = [ "fields" .= fields + , "like_text" .= text + , "max_query_terms" .= maxTerms + , "ignore_tf" .= ignoreFreq + , "fuzziness" .= fuzziness + , "prefix_length" .= prefixLength + , "analyzer" .= analyzer + , "boost" .= boost ] + +instance FromJSON FuzzyLikeThisQuery where + parseJSON = withObject "FuzzyLikeThisQuery" parse + where parse o = FuzzyLikeThisQuery + <$> o .:? "fields" .!= [] + <*> o .: "like_text" + <*> o .: "max_query_terms" + <*> o .: "ignore_tf" + <*> o .: "fuzziness" + <*> o .: "prefix_length" + <*> o .: "boost" + <*> o .:? "analyzer" + +instance ToJSON FilteredQuery where + toJSON (FilteredQuery query fFilter) = + object [ "query" .= query + , "filter" .= fFilter ] + +instance FromJSON FilteredQuery where + parseJSON = withObject "FilteredQuery" parse + where parse o = FilteredQuery + <$> o .: "query" + <*> o .: "filter" + +instance ToJSON DisMaxQuery where + toJSON (DisMaxQuery queries tiebreaker boost) = + omitNulls base + where base = [ "queries" .= queries + , "boost" .= boost + , "tie_breaker" .= tiebreaker ] + +instance FromJSON DisMaxQuery where + parseJSON = withObject "DisMaxQuery" parse + where parse o = DisMaxQuery + <$> o .:? "queries" .!= [] + <*> o .: "tie_breaker" + <*> o .:? "boost" + +instance ToJSON CommonTermsQuery where + toJSON (CommonTermsQuery (FieldName fieldName) + (QueryString query) cf lfo hfo msm + boost analyzer disableCoord) = + object [fieldName .= omitNulls base ] + where base = [ "query" .= query + , "cutoff_frequency" .= cf + , "low_freq_operator" .= lfo + , "minimum_should_match" .= msm + , "boost" .= boost + , "analyzer" .= analyzer + , "disable_coord" .= disableCoord + , "high_freq_operator" .= hfo ] + +instance FromJSON CommonTermsQuery where + parseJSON = withObject "CommonTermsQuery" parse + where parse = fieldTagged $ \fn o -> + CommonTermsQuery fn + <$> o .: "query" + <*> o .: "cutoff_frequency" + <*> o .: "low_freq_operator" + <*> o .: "high_freq_operator" + <*> o .:? "minimum_should_match" + <*> o .:? "boost" + <*> o .:? "analyzer" + <*> o .:? "disable_coord" + +instance ToJSON CommonMinimumMatch where + toJSON (CommonMinimumMatch mm) = toJSON mm + toJSON (CommonMinimumMatchHighLow (MinimumMatchHighLow lowF highF)) = + object [ "low_freq" .= lowF + , "high_freq" .= highF ] + +instance FromJSON CommonMinimumMatch where + parseJSON v = parseMinimum v + <|> parseMinimumHighLow v + where parseMinimum = fmap CommonMinimumMatch . parseJSON + parseMinimumHighLow = fmap CommonMinimumMatchHighLow . withObject "CommonMinimumMatchHighLow" (\o -> + MinimumMatchHighLow + <$> o .: "low_freq" + <*> o .: "high_freq") + + +instance ToJSON BoostingQuery where + toJSON (BoostingQuery bqPositiveQuery bqNegativeQuery bqNegativeBoost) = + object [ "positive" .= bqPositiveQuery + , "negative" .= bqNegativeQuery + , "negative_boost" .= bqNegativeBoost ] + +instance FromJSON BoostingQuery where + parseJSON = withObject "BoostingQuery" parse + where parse o = BoostingQuery + <$> o .: "positive" + <*> o .: "negative" + <*> o .: "negative_boost" + +instance ToJSON BoolQuery where + toJSON (BoolQuery mustM notM shouldM bqMin boost disableCoord) = + omitNulls base + where base = [ "must" .= mustM + , "must_not" .= notM + , "should" .= shouldM + , "minimum_should_match" .= bqMin + , "boost" .= boost + , "disable_coord" .= disableCoord ] + +instance FromJSON BoolQuery where + parseJSON = withObject "BoolQuery" parse + where parse o = BoolQuery + <$> o .:? "must" .!= [] + <*> o .:? "must_not" .!= [] + <*> o .:? "should" .!= [] + <*> o .:? "minimum_should_match" + <*> o .:? "boost" + <*> o .:? "disable_coord" + +instance ToJSON MatchQuery where + toJSON (MatchQuery (FieldName fieldName) + (QueryString mqQueryString) booleanOperator + zeroTermsQuery cutoffFrequency matchQueryType + analyzer maxExpansions lenient boost) = + object [ fieldName .= omitNulls base ] + where base = [ "query" .= mqQueryString + , "operator" .= booleanOperator + , "zero_terms_query" .= zeroTermsQuery + , "cutoff_frequency" .= cutoffFrequency + , "type" .= matchQueryType + , "analyzer" .= analyzer + , "max_expansions" .= maxExpansions + , "lenient" .= lenient + , "boost" .= boost ] + +instance FromJSON MatchQuery where + parseJSON = withObject "MatchQuery" parse + where parse = fieldTagged $ \fn o -> + MatchQuery fn + <$> o .: "query" + <*> o .: "operator" + <*> o .: "zero_terms_query" + <*> o .:? "cutoff_frequency" + <*> o .:? "type" + <*> o .:? "analyzer" + <*> o .:? "max_expansions" + <*> o .:? "lenient" + <*> o .:? "boost" + +instance ToJSON MultiMatchQuery where + toJSON (MultiMatchQuery fields (QueryString query) boolOp + ztQ tb mmqt cf analyzer maxEx lenient) = + object ["multi_match" .= omitNulls base] + where base = [ "fields" .= fmap toJSON fields + , "query" .= query + , "operator" .= boolOp + , "zero_terms_query" .= ztQ + , "tie_breaker" .= tb + , "type" .= mmqt + , "cutoff_frequency" .= cf + , "analyzer" .= analyzer + , "max_expansions" .= maxEx + , "lenient" .= lenient ] + +instance FromJSON MultiMatchQuery where + parseJSON = withObject "MultiMatchQuery" parse + where parse raw = do o <- raw .: "multi_match" + MultiMatchQuery + <$> o .:? "fields" .!= [] + <*> o .: "query" + <*> o .: "operator" + <*> o .: "zero_terms_query" + <*> o .:? "tie_breaker" + <*> o .:? "type" + <*> o .:? "cutoff_frequency" + <*> o .:? "analyzer" + <*> o .:? "max_expansions" + <*> o .:? "lenient" + +instance ToJSON Filter where + toJSON (AndFilter filters cache) = + object ["and" .= + object [ "filters" .= fmap toJSON filters + , "_cache" .= cache]] + + toJSON (OrFilter filters cache) = + object ["or" .= + object [ "filters" .= fmap toJSON filters + , "_cache" .= cache]] + + toJSON (NotFilter notFilter cache) = + object ["not" .= + object ["filter" .= notFilter + , "_cache" .= cache]] + + toJSON (IdentityFilter) = + object ["match_all" .= object []] + + toJSON (TermFilter (Term termFilterField termFilterValue) cache) = + object ["term" .= object base] + where base = [termFilterField .= termFilterValue, + "_cache" .= cache] + + toJSON (ExistsFilter (FieldName fieldName)) = + object ["exists" .= object + ["field" .= fieldName]] + + toJSON (BoolFilter boolMatch) = + object ["bool" .= boolMatch] + + toJSON (GeoBoundingBoxFilter bbConstraint) = + object ["geo_bounding_box" .= bbConstraint] + + toJSON (GeoDistanceFilter (GeoPoint (FieldName distanceGeoField) geoDistLatLon) + distance distanceType optimizeBbox cache) = + object ["geo_distance" .= + object ["distance" .= distance + , "distance_type" .= distanceType + , "optimize_bbox" .= optimizeBbox + , distanceGeoField .= geoDistLatLon + , "_cache" .= cache]] + + toJSON (GeoDistanceRangeFilter (GeoPoint (FieldName gddrField) drLatLon) + (DistanceRange geoDistRangeDistFrom drDistanceTo)) = + object ["geo_distance_range" .= + object ["from" .= geoDistRangeDistFrom + , "to" .= drDistanceTo + , gddrField .= drLatLon]] + + toJSON (GeoPolygonFilter (FieldName geoPolygonFilterField) latLons) = + object ["geo_polygon" .= + object [geoPolygonFilterField .= + object ["points" .= fmap toJSON latLons]]] + + toJSON (IdsFilter (MappingName mappingName) values) = + object ["ids" .= + object ["type" .= mappingName + , "values" .= fmap 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 (QueryFilter query False) = + object ["query" .= toJSON query ] + toJSON (QueryFilter query True) = + object ["fquery" .= + object [ "query" .= toJSON query + , "_cache" .= True ]] + + toJSON (RangeFilter (FieldName fieldName) rangeValue rangeExecution cache) = + object ["range" .= + object [ fieldName .= object (rangeValueToPair rangeValue) + , "execution" .= rangeExecution + , "_cache" .= cache]] + + toJSON (RegexpFilter (FieldName fieldName) + (Regexp regexText) flags (CacheName cacheName) cache (CacheKey cacheKey)) = + object ["regexp" .= + object [fieldName .= + object ["value" .= regexText + , "flags" .= flags] + , "_name" .= cacheName + , "_cache" .= cache + , "_cache_key" .= cacheKey]] + +instance FromJSON Filter where + parseJSON = withObject "Filter" parse + where parse o = andFilter `taggedWith` "and" + <|> orFilter `taggedWith` "or" + <|> notFilter `taggedWith` "not" + <|> identityFilter `taggedWith` "match_all" + <|> boolFilter `taggedWith` "bool" + <|> existsFilter `taggedWith` "exists" + <|> geoBoundingBoxFilter `taggedWith` "geo_bounding_box" + <|> geoDistanceFilter `taggedWith` "geo_distance" + <|> geoDistanceRangeFilter `taggedWith` "geo_distance_range" + <|> geoPolygonFilter `taggedWith` "geo_polygon" + <|> idsFilter `taggedWith` "ids" + <|> limitFilter `taggedWith` "limit" + <|> missingFilter `taggedWith` "missing" + <|> prefixFilter `taggedWith` "prefix" + <|> queryFilter `taggedWith` "query" + <|> fqueryFilter `taggedWith` "fquery" + <|> rangeFilter `taggedWith` "range" + <|> regexpFilter `taggedWith` "regexp" + <|> termFilter `taggedWith` "term" + where taggedWith parser k = parser =<< o .: k + andFilter o = AndFilter <$> o .: "filters" + <*> o .:? "_cache" .!= defaultCache + orFilter o = OrFilter <$> o .: "filters" + <*> o .:? "_cache" .!= defaultCache + notFilter o = NotFilter <$> o .: "filter" + <*> o .: "_cache" .!= defaultCache + identityFilter :: Object -> Parser Filter + identityFilter m + | HM.null m = pure IdentityFilter + | otherwise = fail ("Identityfilter expected empty object but got " <> show m) + boolFilter = pure . BoolFilter + existsFilter o = ExistsFilter <$> o .: "field" + geoBoundingBoxFilter = pure . GeoBoundingBoxFilter + geoDistanceFilter o = do + case HM.toList (deleteSeveral ["distance", "distance_type", "optimize_bbox", "_cache"] o) of + [(fn, v)] -> do + gp <- GeoPoint (FieldName fn) <$> parseJSON v + GeoDistanceFilter gp <$> o .: "distance" + <*> o .: "distance_type" + <*> o .: "optimize_bbox" + <*> o .:? "_cache" .!= defaultCache + _ -> fail "Could not find GeoDistanceFilter field name" + geoDistanceRangeFilter o = do + case HM.toList (deleteSeveral ["from", "to"] o) of + [(fn, v)] -> do + gp <- GeoPoint (FieldName fn) <$> parseJSON v + rng <- DistanceRange <$> o .: "from" <*> o .: "to" + return (GeoDistanceRangeFilter gp rng) + _ -> fail "Could not find GeoDistanceRangeFilter field name" + geoPolygonFilter = fieldTagged $ \fn o -> GeoPolygonFilter fn <$> o .: "points" + idsFilter o = IdsFilter <$> o .: "type" + <*> o .: "values" + limitFilter o = LimitFilter <$> o .: "value" + missingFilter o = MissingFilter <$> o .: "field" + <*> o .: "existence" + <*> o .: "null_value" + prefixFilter o = case HM.toList (HM.delete "_cache" o) of + [(fn, String v)] -> PrefixFilter (FieldName fn) v <$> o .:? "_cache" .!= defaultCache + _ -> fail "Could not parse PrefixFilter" + + queryFilter q = pure (QueryFilter q False) + fqueryFilter o = QueryFilter <$> o .: "query" <*> pure True + rangeFilter o = case HM.toList (deleteSeveral ["execution", "_cache"] o) of + [(fn, v)] -> RangeFilter (FieldName fn) + <$> parseJSON v + <*> o .: "execution" + <*> o .:? "_cache" .!= defaultCache + _ -> fail "Could not find field name for RangeFilter" + regexpFilter o = case HM.toList (deleteSeveral ["_name", "_cache", "_cache_key"] o) of + [(fn, Object o')] -> RegexpFilter (FieldName fn) + <$> o' .: "value" + <*> o' .: "flags" + <*> o .: "_name" + <*> o .:? "_cache" .!= defaultCache + <*> o .: "_cache_key" + _ -> fail "Could not find field name for RegexpFilter" + termFilter o = case HM.toList (HM.delete "_cache" o) of + [(termField, String termVal)] -> TermFilter (Term termField termVal) + <$> o .:? "_cache" .!= defaultCache + _ -> fail "Could not find term field for TermFilter" + +instance ToJSON BooleanOperator where + toJSON And = String "and" + toJSON Or = String "or" + +instance FromJSON BooleanOperator where + parseJSON = withText "BooleanOperator" parse + where parse "and" = pure And + parse "or" = pure Or + parse o = fail ("Unexpected BooleanOperator: " <> show o) + +instance ToJSON ZeroTermsQuery where + toJSON ZeroTermsNone = String "none" + toJSON ZeroTermsAll = String "all" + +instance FromJSON ZeroTermsQuery where + parseJSON = withText "ZeroTermsQuery" parse + where parse "none" = pure ZeroTermsNone + parse "all" = pure ZeroTermsAll + parse q = fail ("Unexpected ZeroTermsQuery: " <> show q) + +fieldTagged :: Monad m => (FieldName -> Object -> m a) -> Object -> m a +fieldTagged f o = case HM.toList o of + [(k, Object o')] -> f (FieldName k) o' + _ -> fail "Expected object with 1 field-named key" + +instance ToJSON RangeExecution where + toJSON RangeExecutionIndex = "index" + toJSON RangeExecutionFielddata = "fielddata" + + +instance FromJSON RangeExecution where + parseJSON = withText "RangeExecution" parse + where parse "index" = pure RangeExecutionIndex + parse "fielddata" = pure RangeExecutionFielddata + parse t = error ("Unrecognized RangeExecution " <> show t) + +instance ToJSON RegexpFlags where + toJSON AllRegexpFlags = String "ALL" + toJSON NoRegexpFlags = String "NONE" + toJSON (SomeRegexpFlags (h :| fs)) = String $ T.intercalate "|" flagStrs + where flagStrs = map flagStr . nub $ h:fs + flagStr AnyString = "ANYSTRING" + flagStr Automaton = "AUTOMATON" + flagStr Complement = "COMPLEMENT" + flagStr Empty = "EMPTY" + flagStr Intersection = "INTERSECTION" + flagStr Interval = "INTERVAL" + +instance FromJSON RegexpFlags where + parseJSON = withText "RegexpFlags" parse + where parse "ALL" = pure AllRegexpFlags + parse "NONE" = pure NoRegexpFlags + parse t = SomeRegexpFlags <$> parseNEJSON (String <$> T.splitOn "|" t) + +instance FromJSON RegexpFlag where + parseJSON = withText "RegexpFlag" parse + where parse "ANYSTRING" = pure AnyString + parse "AUTOMATON" = pure Automaton + parse "COMPLEMENT" = pure Complement + parse "EMPTY" = pure Empty + parse "INTERSECTION" = pure Intersection + parse "INTERVAL" = pure Interval + parse f = fail ("Unknown RegexpFlag: " <> show f) + +rangeValueToPair :: RangeValue -> [Pair] +rangeValueToPair rv = case rv of + RangeDateLte (LessThanEqD t) -> ["lte" .= t] + RangeDateGte (GreaterThanEqD t) -> ["gte" .= t] + RangeDateLt (LessThanD t) -> ["lt" .= t] + RangeDateGt (GreaterThanD t) -> ["gt" .= t] + RangeDateGteLte (GreaterThanEqD l) (LessThanEqD g) -> ["gte" .= l, "lte" .= g] + RangeDateGtLte (GreaterThanD l) (LessThanEqD g) -> ["gt" .= l, "lte" .= g] + RangeDateGteLt (GreaterThanEqD l) (LessThanD g) -> ["gte" .= l, "lt" .= g] + RangeDateGtLt (GreaterThanD l) (LessThanD g) -> ["gt" .= l, "lt" .= g] + RangeDoubleLte (LessThanEq t) -> ["lte" .= t] + RangeDoubleGte (GreaterThanEq t) -> ["gte" .= t] + RangeDoubleLt (LessThan t) -> ["lt" .= t] + RangeDoubleGt (GreaterThan t) -> ["gt" .= t] + RangeDoubleGteLte (GreaterThanEq l) (LessThanEq g) -> ["gte" .= l, "lte" .= g] + RangeDoubleGtLte (GreaterThan l) (LessThanEq g) -> ["gt" .= l, "lte" .= g] + RangeDoubleGteLt (GreaterThanEq l) (LessThan g) -> ["gte" .= l, "lt" .= g] + RangeDoubleGtLt (GreaterThan l) (LessThan g) -> ["gt" .= l, "lt" .= g] + +instance ToJSON ScoreType where + toJSON ScoreTypeMax = "max" + toJSON ScoreTypeAvg = "avg" + toJSON ScoreTypeSum = "sum" + toJSON ScoreTypeNone = "none" + +instance FromJSON ScoreType where + parseJSON = withText "ScoreType" parse + where parse "max" = pure ScoreTypeMax + parse "avg" = pure ScoreTypeAvg + parse "sum" = pure ScoreTypeSum + parse "none" = pure ScoreTypeNone + parse t = fail ("Unexpected ScoreType: " <> show t) + +instance ToJSON MatchQueryType where + toJSON MatchPhrase = "phrase" + toJSON MatchPhrasePrefix = "phrase_prefix" + +instance FromJSON MatchQueryType where + parseJSON = withText "MatchQueryType" parse + where parse "phrase" = pure MatchPhrase + parse "phrase_prefix" = pure MatchPhrasePrefix + parse t = fail ("Unexpected MatchQueryType: " <> show t) + +instance ToJSON MultiMatchQueryType where + toJSON MultiMatchBestFields = "best_fields" + toJSON MultiMatchMostFields = "most_fields" + toJSON MultiMatchCrossFields = "cross_fields" + toJSON MultiMatchPhrase = "phrase" + toJSON MultiMatchPhrasePrefix = "phrase_prefix" + +instance FromJSON MultiMatchQueryType where + parseJSON = withText "MultiMatchPhrasePrefix" parse + where parse "best_fields" = pure MultiMatchBestFields + parse "most_fields" = pure MultiMatchMostFields + parse "cross_fields" = pure MultiMatchCrossFields + parse "phrase" = pure MultiMatchPhrase + parse "phrase_prefix" = pure MultiMatchPhrasePrefix + parse t = fail ("Unexpected MultiMatchPhrasePrefix: " <> show t) + +defaultCache :: Cache +defaultCache = False + +instance ToJSON BoolMatch where + toJSON (MustMatch term cache) = object ["must" .= term, + "_cache" .= cache] + toJSON (MustNotMatch term cache) = object ["must_not" .= term, + "_cache" .= cache] + toJSON (ShouldMatch terms cache) = object ["should" .= fmap toJSON terms, + "_cache" .= cache] + +instance FromJSON BoolMatch where + parseJSON = withObject "BoolMatch" parse + where parse o = mustMatch `taggedWith` "must" + <|> mustNotMatch `taggedWith` "must_not" + <|> shouldMatch `taggedWith` "should" + where taggedWith parser k = parser =<< o .: k + mustMatch t = MustMatch t <$> o .:? "_cache" .!= defaultCache + mustNotMatch t = MustNotMatch t <$> o .:? "_cache" .!= defaultCache + shouldMatch t = ShouldMatch t <$> o .:? "_cache" .!= defaultCache + +instance ToJSON GeoBoundingBoxConstraint where + toJSON (GeoBoundingBoxConstraint + (FieldName gbbcGeoBBField) gbbcConstraintBox cache type') = + object [gbbcGeoBBField .= gbbcConstraintBox + , "_cache" .= cache + , "type" .= type'] + +instance FromJSON GeoBoundingBoxConstraint where + parseJSON = withObject "GeoBoundingBoxConstraint" parse + where parse o = case HM.toList (deleteSeveral ["type", "_cache"] o) of + [(fn, v)] -> GeoBoundingBoxConstraint (FieldName fn) + <$> parseJSON v + <*> o .:? "_cache" .!= defaultCache + <*> o .: "type" + _ -> fail "Could not find field name for GeoBoundingBoxConstraint" + +instance ToJSON Distance where + toJSON (Distance dCoefficient dUnit) = + String boltedTogether where + coefText = showText dCoefficient + (String unitText) = toJSON dUnit + boltedTogether = mappend coefText unitText + +instance FromJSON Distance where + parseJSON = withText "Distance" parse + where parse t = Distance <$> parseCoeff nT + <*> parseJSON (String unitT) + where (nT, unitT) = T.span validForNumber t + -- may be a better way to do this + validForNumber '-' = True + validForNumber '.' = True + validForNumber 'e' = True + validForNumber c = isNumber c + parseCoeff "" = fail "Empty string cannot be parsed as number" + parseCoeff s = return (read (T.unpack s)) + +instance ToJSON DistanceType where + toJSON Arc = String "arc" + toJSON SloppyArc = String "sloppy_arc" + toJSON Plane = String "plane" + +instance FromJSON DistanceType where + parseJSON = withText "DistanceType" parse + where parse "arc" = pure Arc + parse "sloppy_arc" = pure SloppyArc + parse "plane" = pure Plane + parse t = fail ("Unrecognized DistanceType: " <> show t) + +instance ToJSON OptimizeBbox where + toJSON NoOptimizeBbox = String "none" + toJSON (OptimizeGeoFilterType gft) = toJSON gft + +instance FromJSON OptimizeBbox where + parseJSON v = withText "NoOptimizeBbox" parseNoOptimize v + <|> parseOptimize v + where parseNoOptimize "none" = pure NoOptimizeBbox + parseNoOptimize _ = mzero + parseOptimize = fmap OptimizeGeoFilterType . parseJSON + +instance ToJSON Term where + toJSON (Term field value) = object ["term" .= object + [field .= value]] + +instance FromJSON Term where + parseJSON = withObject "Term" parse + where parse o = do termObj <- o .: "term" + case HM.toList termObj of + [(fn, v)] -> Term fn <$> parseJSON v + _ -> fail "Expected object with 1 field-named key" + +instance ToJSON GeoBoundingBox where + toJSON (GeoBoundingBox gbbTopLeft gbbBottomRight) = + object ["top_left" .= gbbTopLeft + , "bottom_right" .= gbbBottomRight] + +instance FromJSON GeoBoundingBox where + parseJSON = withObject "GeoBoundingBox" parse + where parse o = GeoBoundingBox + <$> o .: "top_left" + <*> o .: "bottom_right" + +instance ToJSON GeoFilterType where + toJSON GeoFilterMemory = String "memory" + toJSON GeoFilterIndexed = String "indexed" + +instance FromJSON GeoFilterType where + parseJSON = withText "GeoFilterType" parse + where parse "memory" = pure GeoFilterMemory + parse "indexed" = pure GeoFilterIndexed + parse t = fail ("Unrecognized GeoFilterType: " <> show t) + +{-| 'unpackId' is a silly convenience function that gets used once. +-} +unpackId :: DocId -> Text +unpackId (DocId docId) = docId diff --git a/src/Database/V1/Bloodhound/Internal/Sort.hs b/src/Database/V1/Bloodhound/Internal/Sort.hs new file mode 100644 index 0000000..c10f32c --- /dev/null +++ b/src/Database/V1/Bloodhound/Internal/Sort.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Database.V1.Bloodhound.Internal.Sort where + + +import Bloodhound.Import + +import Database.V1.Bloodhound.Internal.Newtypes +import Database.V1.Bloodhound.Internal.Query + + +{-| 'Sort' is a synonym for a list of 'SortSpec's. Sort behavior is order + dependent with later sorts acting as tie-breakers for earlier sorts. +-} +type Sort = [SortSpec] + + +{-| The two main kinds of 'SortSpec' are 'DefaultSortSpec' and + 'GeoDistanceSortSpec'. The latter takes a 'SortOrder', 'GeoPoint', and + 'DistanceUnit' to express "nearness" to a single geographical point as a + sort specification. + + +-} +data SortSpec = DefaultSortSpec DefaultSort + | GeoDistanceSortSpec SortOrder GeoPoint DistanceUnit deriving (Eq, Show) + +{-| 'DefaultSort' is usually the kind of 'SortSpec' you'll want. There's a + 'mkSort' convenience function for when you want to specify only the most + common parameters. + + +-} +data DefaultSort = + DefaultSort { sortFieldName :: FieldName + , sortOrder :: SortOrder + -- default False + , ignoreUnmapped :: Bool + , sortMode :: Maybe SortMode + , missingSort :: Maybe Missing + , nestedFilter :: Maybe Filter } deriving (Eq, Show) + +{-| 'SortOrder' is 'Ascending' or 'Descending', as you might expect. These get + encoded into "asc" or "desc" when turned into JSON. + + +-} +data SortOrder = Ascending + | Descending deriving (Eq, Show) + + +{-| 'SortMode' prescribes how to handle sorting array/multi-valued fields. + +http://www.elasticsearch.org/guide/en/elasticsearch/reference/current/search-request-sort.html#_sort_mode_option +-} +data SortMode = SortMin + | SortMax + | SortSum + | SortAvg deriving (Eq, Show) + +instance ToJSON SortMode where + toJSON SortMin = String "min" + toJSON SortMax = String "max" + toJSON SortSum = String "sum" + toJSON SortAvg = String "avg" + +{-| 'Missing' prescribes how to handle missing fields. A missing field can be + sorted last, first, or using a custom value as a substitute. + + +-} +data Missing = LastMissing + | FirstMissing + | CustomMissing Text deriving (Eq, Show) + +instance ToJSON Missing where + toJSON LastMissing = String "_last" + toJSON FirstMissing = String "_first" + toJSON (CustomMissing txt) = String txt diff --git a/src/Database/V1/Bloodhound/Internal/StringlyTyped.hs b/src/Database/V1/Bloodhound/Internal/StringlyTyped.hs index b111067..366ecef 100644 --- a/src/Database/V1/Bloodhound/Internal/StringlyTyped.hs +++ b/src/Database/V1/Bloodhound/Internal/StringlyTyped.hs @@ -1 +1,26 @@ +{-# LANGUAGE OverloadedStrings #-} + module Database.V1.Bloodhound.Internal.StringlyTyped where + +import Bloodhound.Import + +import qualified Data.Text as T + +newtype StringlyTypedDouble = StringlyTypedDouble { unStringlyTypedDouble :: Double } + + +instance FromJSON StringlyTypedDouble where + parseJSON = fmap StringlyTypedDouble . parseJSON . unStringlyTypeJSON + + +-- | For some reason in several settings APIs, all leaf values get returned +-- as strings. This function attepmts to recover from this for all +-- non-recursive JSON types. If nothing can be done, the value is left alone. +unStringlyTypeJSON :: Value -> Value +unStringlyTypeJSON (String "true") = Bool True +unStringlyTypeJSON (String "false") = Bool False +unStringlyTypeJSON (String "null") = Null +unStringlyTypeJSON v@(String t) = case readMay (T.unpack t) of + Just n -> Number n + Nothing -> v +unStringlyTypeJSON v = v diff --git a/src/Database/V1/Bloodhound/Internal/Suggest.hs b/src/Database/V1/Bloodhound/Internal/Suggest.hs new file mode 100644 index 0000000..c58e8b8 --- /dev/null +++ b/src/Database/V1/Bloodhound/Internal/Suggest.hs @@ -0,0 +1,252 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Database.V1.Bloodhound.Internal.Suggest where + + +import Bloodhound.Import + +import qualified Data.HashMap.Strict as HM + +import Database.V5.Bloodhound.Internal.Newtypes +import Database.V5.Bloodhound.Internal.Query + +data Suggest = Suggest { suggestText :: Text + , suggestName :: Text + , suggestType :: SuggestType + } + deriving (Show, Eq) + +instance ToJSON Suggest where + toJSON Suggest{..} = object [ "text" .= suggestText + , suggestName .= suggestType + ] + +instance FromJSON Suggest where + parseJSON (Object o) = do + suggestText' <- o .: "text" + let dropTextList = HM.toList $ HM.filterWithKey (\x _ -> x /= "text") o + suggestName' <- case dropTextList of + [(x, _)] -> return x + _ -> fail "error parsing Suggest field name" + suggestType' <- o .: suggestName' + return $ Suggest suggestText' suggestName' suggestType' + parseJSON x = typeMismatch "Suggest" x + +data SuggestType = SuggestTypePhraseSuggester PhraseSuggester + deriving (Show, Eq) + +instance ToJSON SuggestType where + toJSON (SuggestTypePhraseSuggester x) = object ["phrase" .= x] + +instance FromJSON SuggestType where + parseJSON = withObject "SuggestType" parse + where parse o = phraseSuggester `taggedWith` "phrase" + where taggedWith parser k = parser =<< o .: k + phraseSuggester = pure . SuggestTypePhraseSuggester + +data PhraseSuggester = + PhraseSuggester { phraseSuggesterField :: FieldName + , phraseSuggesterGramSize :: Maybe Int + , phraseSuggesterRealWordErrorLikelihood :: Maybe Int + , phraseSuggesterConfidence :: Maybe Int + , phraseSuggesterMaxErrors :: Maybe Int + , phraseSuggesterSeparator :: Maybe Text + , phraseSuggesterSize :: Maybe Size + , phraseSuggesterAnalyzer :: Maybe Analyzer + , phraseSuggesterShardSize :: Maybe Int + , phraseSuggesterHighlight :: Maybe PhraseSuggesterHighlighter + , phraseSuggesterCollate :: Maybe PhraseSuggesterCollate + , phraseSuggesterCandidateGenerators :: [DirectGenerators] + } + deriving (Show, Eq) + +instance ToJSON PhraseSuggester where + toJSON PhraseSuggester{..} = omitNulls [ "field" .= phraseSuggesterField + , "gram_size" .= phraseSuggesterGramSize + , "real_word_error_likelihood" .= phraseSuggesterRealWordErrorLikelihood + , "confidence" .= phraseSuggesterConfidence + , "max_errors" .= phraseSuggesterMaxErrors + , "separator" .= phraseSuggesterSeparator + , "size" .= phraseSuggesterSize + , "analyzer" .= phraseSuggesterAnalyzer + , "shard_size" .= phraseSuggesterShardSize + , "highlight" .= phraseSuggesterHighlight + , "collate" .= phraseSuggesterCollate + , "direct_generator" .= phraseSuggesterCandidateGenerators + ] + +instance FromJSON PhraseSuggester where + parseJSON = withObject "PhraseSuggester" parse + where parse o = PhraseSuggester + <$> o .: "field" + <*> o .:? "gram_size" + <*> o .:? "real_word_error_likelihood" + <*> o .:? "confidence" + <*> o .:? "max_errors" + <*> o .:? "separator" + <*> o .:? "size" + <*> o .:? "analyzer" + <*> o .:? "shard_size" + <*> o .:? "highlight" + <*> o .:? "collate" + <*> o .:? "direct_generator" .!= [] + +mkPhraseSuggester :: FieldName -> PhraseSuggester +mkPhraseSuggester fName = + PhraseSuggester fName Nothing Nothing Nothing Nothing Nothing Nothing + Nothing Nothing Nothing Nothing [] + +data PhraseSuggesterHighlighter = + PhraseSuggesterHighlighter { phraseSuggesterHighlighterPreTag :: Text + , phraseSuggesterHighlighterPostTag :: Text + } + deriving (Show, Eq) + +instance ToJSON PhraseSuggesterHighlighter where + toJSON PhraseSuggesterHighlighter{..} = + object [ "pre_tag" .= phraseSuggesterHighlighterPreTag + , "post_tag" .= phraseSuggesterHighlighterPostTag + ] + +instance FromJSON PhraseSuggesterHighlighter where + parseJSON = withObject "PhraseSuggesterHighlighter" parse + where parse o = PhraseSuggesterHighlighter + <$> o .: "pre_tag" + <*> o .: "post_tag" + +data PhraseSuggesterCollate = + PhraseSuggesterCollate { phraseSuggesterCollateTemplateQuery :: TemplateQueryInline + , phraseSuggesterCollatePrune :: Bool + } + deriving (Show, Eq) + +instance ToJSON PhraseSuggesterCollate where + toJSON PhraseSuggesterCollate{..} = object [ "query" .= object + [ "inline" .= (inline phraseSuggesterCollateTemplateQuery) + ] + , "params" .= (params phraseSuggesterCollateTemplateQuery) + , "prune" .= phraseSuggesterCollatePrune + ] + +instance FromJSON PhraseSuggesterCollate where + parseJSON (Object o) = do + query' <- o .: "query" + inline' <- query' .: "inline" + params' <- o .: "params" + prune' <- o .:? "prune" .!= False + return $ PhraseSuggesterCollate (TemplateQueryInline inline' params') prune' + parseJSON x = typeMismatch "PhraseSuggesterCollate" x + +data DirectGenerators = DirectGenerators + { directGeneratorsField :: FieldName + , directGeneratorsSize :: Maybe Int + , directGeneratorSuggestMode :: DirectGeneratorSuggestModeTypes + , directGeneratorMaxEdits :: Maybe Double + , directGeneratorPrefixLength :: Maybe Int + , directGeneratorMinWordLength :: Maybe Int + , directGeneratorMaxInspections :: Maybe Int + , directGeneratorMinDocFreq :: Maybe Double + , directGeneratorMaxTermFreq :: Maybe Double + , directGeneratorPreFilter :: Maybe Text + , directGeneratorPostFilter :: Maybe Text + } + deriving (Show, Eq) + + +instance ToJSON DirectGenerators where + toJSON DirectGenerators{..} = omitNulls [ "field" .= directGeneratorsField + , "size" .= directGeneratorsSize + , "suggest_mode" .= directGeneratorSuggestMode + , "max_edits" .= directGeneratorMaxEdits + , "prefix_length" .= directGeneratorPrefixLength + , "min_word_length" .= directGeneratorMinWordLength + , "max_inspections" .= directGeneratorMaxInspections + , "min_doc_freq" .= directGeneratorMinDocFreq + , "max_term_freq" .= directGeneratorMaxTermFreq + , "pre_filter" .= directGeneratorPreFilter + , "post_filter" .= directGeneratorPostFilter + ] + +instance FromJSON DirectGenerators where + parseJSON = withObject "DirectGenerators" parse + where parse o = DirectGenerators + <$> o .: "field" + <*> o .:? "size" + <*> o .: "suggest_mode" + <*> o .:? "max_edits" + <*> o .:? "prefix_length" + <*> o .:? "min_word_length" + <*> o .:? "max_inspections" + <*> o .:? "min_doc_freq" + <*> o .:? "max_term_freq" + <*> o .:? "pre_filter" + <*> o .:? "post_filter" + +mkDirectGenerators :: FieldName -> DirectGenerators +mkDirectGenerators fn = DirectGenerators fn Nothing DirectGeneratorSuggestModeMissing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing + +data DirectGeneratorSuggestModeTypes = DirectGeneratorSuggestModeMissing + | DirectGeneratorSuggestModePopular + | DirectGeneratorSuggestModeAlways + deriving (Show, Eq) + +instance ToJSON DirectGeneratorSuggestModeTypes where + toJSON DirectGeneratorSuggestModeMissing = "missing" + toJSON DirectGeneratorSuggestModePopular = "popular" + toJSON DirectGeneratorSuggestModeAlways = "always" + +instance FromJSON DirectGeneratorSuggestModeTypes where + parseJSON = withText "DirectGeneratorSuggestModeTypes" parse + where parse "missing" = pure DirectGeneratorSuggestModeMissing + parse "popular" = pure DirectGeneratorSuggestModePopular + parse "always" = pure DirectGeneratorSuggestModeAlways + parse f = fail ("Unexpected DirectGeneratorSuggestModeTypes: " <> show f) + +data SuggestOptions = + SuggestOptions { suggestOptionsText :: Text + , suggestOptionsScore :: Double + , suggestOptionsFreq :: Maybe Int + , suggestOptionsHighlighted :: Maybe Text + } + deriving (Eq, Read, Show) + +instance FromJSON SuggestOptions where + parseJSON = withObject "SuggestOptions" parse + where parse o = SuggestOptions + <$> o .: "text" + <*> o .: "score" + <*> o .:? "freq" + <*> o .:? "highlighted" + +data SuggestResponse = + SuggestResponse { suggestResponseText :: Text + , suggestResponseOffset :: Int + , suggestResponseLength :: Int + , suggestResponseOptions :: [SuggestOptions] + } + deriving (Eq, Read, Show) + +instance FromJSON SuggestResponse where + parseJSON = withObject "SuggestResponse" parse + where parse o = SuggestResponse + <$> o .: "text" + <*> o .: "offset" + <*> o .: "length" + <*> o .: "options" + +data NamedSuggestionResponse = + NamedSuggestionResponse { nsrName :: Text + , nsrResponses :: [SuggestResponse] + } + deriving (Eq, Read, Show) + +instance FromJSON NamedSuggestionResponse where + parseJSON (Object o) = do + suggestionName' <- case HM.toList o of + [(x, _)] -> return x + _ -> fail "error parsing NamedSuggestionResponse name" + suggestionResponses' <- o .: suggestionName' + return $ NamedSuggestionResponse suggestionName' suggestionResponses' + + parseJSON x = typeMismatch "NamedSuggestionResponse" x diff --git a/src/Database/V1/Bloodhound/Types.hs b/src/Database/V1/Bloodhound/Types.hs index 728adde..d69c96a 100644 --- a/src/Database/V1/Bloodhound/Types.hs +++ b/src/Database/V1/Bloodhound/Types.hs @@ -422,8 +422,6 @@ import qualified Text.Read as TR import Database.V1.Bloodhound.Internal.Client import Database.V1.Bloodhound.Types.Class -import Database.V1.Bloodhound.Types.Internal - diff --git a/src/Database/V5/Bloodhound/Internal/Query.hs b/src/Database/V5/Bloodhound/Internal/Query.hs index d5c2a40..69b7814 100644 --- a/src/Database/V5/Bloodhound/Internal/Query.hs +++ b/src/Database/V5/Bloodhound/Internal/Query.hs @@ -1595,6 +1595,3 @@ fieldTagged :: Monad m => (FieldName -> Object -> m a) -> Object -> m a fieldTagged f o = case HM.toList o of [(k, Object o')] -> f (FieldName k) o' _ -> fail "Expected object with 1 field-named key" - -deleteSeveral :: (Eq k, Hashable k) => [k] -> HM.HashMap k v -> HM.HashMap k v -deleteSeveral ks hm = foldr HM.delete hm ks