diff --git a/Database/Bloodhound.hs b/Database/Bloodhound.hs deleted file mode 100644 --- a/Database/Bloodhound.hs +++ /dev/null @@ -1,7 +0,0 @@ -module Database.Bloodhound - ( module Database.Bloodhound.Client - , module Database.Bloodhound.Types - ) where - -import Database.Bloodhound.Client -import Database.Bloodhound.Types diff --git a/Database/Bloodhound/Client.hs b/Database/Bloodhound/Client.hs deleted file mode 100644 --- a/Database/Bloodhound/Client.hs +++ /dev/null @@ -1,250 +0,0 @@ -module Database.Bloodhound.Client - ( createIndex - , deleteIndex - , indexExists - , openIndex - , closeIndex - , putMapping - , deleteMapping - , indexDocument - , getDocument - , documentExists - , deleteDocument - , searchAll - , searchByIndex - , searchByType - , refreshIndex - , mkSearch - , bulk - , pageSearch - , mkShardCount - , mkReplicaCount - , getStatus - ) - where - -import Data.Aeson -import qualified Data.ByteString.Lazy.Char8 as L -import Data.ByteString.Builder -import Data.List (foldl', intercalate, intersperse) -import Data.Maybe (fromMaybe) -import Data.Text (Text) -import Network.HTTP.Client -import qualified Network.HTTP.Types.Method as NHTM -import qualified Network.HTTP.Types.Status as NHTS -import Prelude hiding (head, filter) - -import Database.Bloodhound.Types - --- find way to avoid destructuring Servers and Indexes? --- make get, post, put, delete helpers. --- make dispatch take URL last for better variance and --- utilization of partial application - -mkShardCount :: Int -> Maybe ShardCount -mkShardCount n - | n < 1 = Nothing - | n > 1000 = Nothing -- seriously, what the fuck? - | otherwise = Just (ShardCount n) - -mkReplicaCount :: Int -> Maybe ReplicaCount -mkReplicaCount n - | n < 1 = Nothing - | n > 1000 = Nothing -- ... - | otherwise = Just (ReplicaCount n) - -emptyBody :: L.ByteString -emptyBody = L.pack "" - -dispatch :: Method -> String -> Maybe L.ByteString - -> IO Reply -dispatch dMethod url body = do - initReq <- parseUrl url - let reqBody = RequestBodyLBS $ fromMaybe emptyBody body - let req = initReq { method = dMethod - , requestBody = reqBody - , checkStatus = \_ _ _ -> Nothing} - withManager defaultManagerSettings $ httpLbs req - -joinPath :: [String] -> String -joinPath = intercalate "/" - --- Shortcut functions for HTTP methods -delete :: String -> IO Reply -delete = flip (dispatch NHTM.methodDelete) Nothing -get :: String -> IO Reply -get = flip (dispatch NHTM.methodGet) Nothing -head :: String -> IO Reply -head = flip (dispatch NHTM.methodHead) Nothing -put :: String -> Maybe L.ByteString -> IO Reply -put = dispatch NHTM.methodPost -post :: String -> Maybe L.ByteString -> IO Reply -post = dispatch NHTM.methodPost - --- indexDocument s ix name doc = put (root s ix name doc) (Just encode doc) --- http://hackage.haskell.org/package/http-client-lens-0.1.0/docs/Network-HTTP-Client-Lens.html --- https://github.com/supki/libjenkins/blob/master/src/Jenkins/Rest/Internal.hs - -getStatus :: Server -> IO (Maybe Status) -getStatus (Server server) = do - request <- parseUrl $ joinPath [server] - response <- withManager defaultManagerSettings $ httpLbs request - return $ decode (responseBody response) - -createIndex :: Server -> IndexSettings -> IndexName -> IO Reply -createIndex (Server server) indexSettings (IndexName indexName) = - put url body - where url = joinPath [server, indexName] - body = Just $ encode indexSettings - -deleteIndex :: Server -> IndexName -> IO Reply -deleteIndex (Server server) (IndexName indexName) = - delete $ joinPath [server, indexName] - -respIsTwoHunna :: Reply -> Bool -respIsTwoHunna resp = NHTS.statusCode (responseStatus resp) == 200 - -existentialQuery :: String -> IO (Reply, Bool) -existentialQuery url = do - reply <- head url - return (reply, respIsTwoHunna reply) - -indexExists :: Server -> IndexName -> IO Bool -indexExists (Server server) (IndexName indexName) = do - (_, exists) <- existentialQuery url - return exists - where url = joinPath [server, indexName] - -refreshIndex :: Server -> IndexName -> IO Reply -refreshIndex (Server server) (IndexName indexName) = - post url Nothing - where url = joinPath [server, indexName, "_refresh"] - -stringifyOCIndex :: OpenCloseIndex -> String -stringifyOCIndex oci = case oci of - OpenIndex -> "_open" - CloseIndex -> "_close" - -openOrCloseIndexes :: OpenCloseIndex -> Server -> IndexName -> IO Reply -openOrCloseIndexes oci (Server server) (IndexName indexName) = - post url Nothing - where ociString = stringifyOCIndex oci - url = joinPath [server, indexName, ociString] - -openIndex :: Server -> IndexName -> IO Reply -openIndex = openOrCloseIndexes OpenIndex - -closeIndex :: Server -> IndexName -> IO Reply -closeIndex = openOrCloseIndexes CloseIndex - -{-| putMapping is an HTTP PUT and has upsert semantics. Mappings are schemas - for documents in indexes. --} -putMapping :: ToJSON a => Server -> IndexName - -> MappingName -> a -> IO Reply -putMapping (Server server) (IndexName indexName) (MappingName mappingName) mapping = - put url body - where url = joinPath [server, indexName, mappingName, "_mapping"] - body = Just $ encode mapping - -deleteMapping :: Server -> IndexName -> MappingName -> IO Reply -deleteMapping (Server server) (IndexName indexName) - (MappingName mappingName) = - delete $ joinPath [server, indexName, mappingName, "_mapping"] - -indexDocument :: ToJSON doc => Server -> IndexName -> MappingName - -> doc -> DocId -> IO Reply -indexDocument (Server server) (IndexName indexName) - (MappingName mappingName) document (DocId docId) = - put url body - where url = joinPath [server, indexName, mappingName, docId] - body = Just (encode document) - -deleteDocument :: Server -> IndexName -> MappingName - -> DocId -> IO Reply -deleteDocument (Server server) (IndexName indexName) - (MappingName mappingName) (DocId docId) = - delete $ joinPath [server, indexName, mappingName, docId] - -bulk :: Server -> [BulkOperation] -> IO Reply -bulk (Server server) bulkOps = post url body where - url = joinPath [server, "_bulk"] - body = Just $ collapseStream bulkOps - -collapseStream :: [BulkOperation] -> L.ByteString -collapseStream stream = collapsed where - blobs = intersperse "\n" $ concat $ fmap getStreamChunk stream - mashedTaters = mash (mempty :: Builder) blobs - collapsed = toLazyByteString $ mappend mashedTaters (byteString "\n") - -mash :: Builder -> [L.ByteString] -> Builder -mash = foldl' (\b x -> mappend b (lazyByteString x)) - -mkMetadataValue :: Text -> String -> String -> String -> Value -mkMetadataValue operation indexName mappingName docId = - object [operation .= - object [ "_index" .= indexName - , "_type" .= mappingName - , "_id" .= docId]] - -getStreamChunk :: BulkOperation -> [L.ByteString] -getStreamChunk (BulkIndex (IndexName indexName) - (MappingName mappingName) - (DocId docId) value) = blob where - metadata = mkMetadataValue "index" indexName mappingName docId - blob = [encode metadata, encode value] - -getStreamChunk (BulkCreate (IndexName indexName) - (MappingName mappingName) - (DocId docId) value) = blob where - metadata = mkMetadataValue "create" indexName mappingName docId - blob = [encode metadata, encode value] - -getStreamChunk (BulkDelete (IndexName indexName) - (MappingName mappingName) - (DocId docId)) = blob where - metadata = mkMetadataValue "delete" indexName mappingName docId - blob = [encode metadata] - -getStreamChunk (BulkUpdate (IndexName indexName) - (MappingName mappingName) - (DocId docId) value) = blob where - metadata = mkMetadataValue "update" indexName mappingName docId - doc = object ["doc" .= value] - blob = [encode metadata, encode doc] - -getDocument :: Server -> IndexName -> MappingName - -> DocId -> IO Reply -getDocument (Server server) (IndexName indexName) - (MappingName mappingName) (DocId docId) = - get $ joinPath [server, indexName, mappingName, docId] - -documentExists :: Server -> IndexName -> MappingName - -> DocId -> IO Bool -documentExists (Server server) (IndexName indexName) - (MappingName mappingName) (DocId docId) = do - (_, exists) <- existentialQuery url - return exists where - url = joinPath [server, indexName, mappingName, docId] - -dispatchSearch :: String -> Search -> IO Reply -dispatchSearch url search = post url (Just (encode search)) - -searchAll :: Server -> Search -> IO Reply -searchAll (Server server) = dispatchSearch url where - url = joinPath [server, "_search"] - -searchByIndex :: Server -> IndexName -> Search -> IO Reply -searchByIndex (Server server) (IndexName indexName) = dispatchSearch url where - url = joinPath [server, indexName, "_search"] - -searchByType :: Server -> IndexName -> MappingName -> Search -> IO Reply -searchByType (Server server) (IndexName indexName) - (MappingName mappingName) = dispatchSearch url where - url = joinPath [server, indexName, mappingName, "_search"] - -mkSearch :: Maybe Query -> Maybe Filter -> Search -mkSearch query filter = Search query filter Nothing False 0 10 - -pageSearch :: Int -> Int -> Search -> Search -pageSearch pageFrom pageSize search = search { from = pageFrom, size = pageSize } diff --git a/Database/Bloodhound/Types.hs b/Database/Bloodhound/Types.hs deleted file mode 100644 --- a/Database/Bloodhound/Types.hs +++ /dev/null @@ -1,1704 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE RecordWildCards #-} - -{-| Data types for describing actions and data structures performed to interact - with Elasticsearch. The two main buckets your queries against Elasticsearch - will fall into are 'Query's and 'Filter's. 'Filter's are more like - traditional database constraints and often have preferable performance - properties. 'Query's support human-written textual queries, such as fuzzy - queries. --} - -module Database.Bloodhound.Types - ( defaultCache - , defaultIndexSettings - , halfRangeToKV - , mkSort - , rangeToKV - , showText - , unpackId - , mkMatchQuery - , mkMultiMatchQuery - , mkBoolQuery - , mkRangeQuery - , mkQueryStringQuery - , Version(..) - , Status(..) - , Existence(..) - , NullValue(..) - , IndexSettings(..) - , Server(..) - , Reply - , EsResult(..) - , Query(..) - , Search(..) - , SearchResult(..) - , SearchHits(..) - , ShardResult(..) - , Hit(..) - , Filter(..) - , Seminearring(..) - , BoolMatch(..) - , Term(..) - , GeoPoint(..) - , GeoBoundingBoxConstraint(..) - , GeoBoundingBox(..) - , GeoFilterType(..) - , Distance(..) - , DistanceUnit(..) - , DistanceType(..) - , DistanceRange(..) - , OptimizeBbox(..) - , LatLon(..) - , Range(..) - , HalfRange(..) - , RangeExecution(..) - , LessThan(..) - , LessThanEq(..) - , GreaterThan(..) - , GreaterThanEq(..) - , Regexp(..) - , RegexpFlags(..) - , RegexpFlag(..) - , FieldName(..) - , IndexName(..) - , MappingName(..) - , DocId(..) - , CacheName(..) - , CacheKey(..) - , BulkOperation(..) - , ReplicaCount(..) - , ShardCount(..) - , Sort - , SortMode(..) - , SortOrder(..) - , SortSpec(..) - , DefaultSort(..) - , Missing(..) - , OpenCloseIndex(..) - , Method - , Boost(..) - , MatchQuery(..) - , MultiMatchQuery(..) - , BoolQuery(..) - , BoostingQuery(..) - , CommonTermsQuery(..) - , DisMaxQuery(..) - , FilteredQuery(..) - , FuzzyLikeThisQuery(..) - , FuzzyLikeFieldQuery(..) - , FuzzyQuery(..) - , HasChildQuery(..) - , HasParentQuery(..) - , IndicesQuery(..) - , MoreLikeThisQuery(..) - , MoreLikeThisFieldQuery(..) - , NestedQuery(..) - , PrefixQuery(..) - , QueryStringQuery(..) - , SimpleQueryStringQuery(..) - , RangeQuery(..) - , RegexpQuery(..) - , QueryString(..) - , BooleanOperator(..) - , ZeroTermsQuery(..) - , CutoffFrequency(..) - , Analyzer(..) - , MaxExpansions(..) - , Lenient(..) - , MatchQueryType(..) - , MultiMatchQueryType(..) - , Tiebreaker(..) - , MinimumMatch(..) - , DisableCoord(..) - , CommonMinimumMatch(..) - , MinimumMatchHighLow(..) - , PrefixLength(..) - , Fuzziness(..) - , IgnoreTermFrequency(..) - , MaxQueryTerms(..) - , ScoreType(..) - , TypeName(..) - , BoostTerms(..) - , MaxWordLength(..) - , MinWordLength(..) - , MaxDocFrequency(..) - , MinDocFrequency(..) - , PhraseSlop(..) - , StopWord(..) - , QueryPath(..) - , MinimumTermFrequency(..) - , PercentMatch(..) - , FieldDefinition(..) - , MappingField(..) - , Mapping(..) - , AllowLeadingWildcard(..) - , LowercaseExpanded(..) - , GeneratePhraseQueries(..) - , Locale(..) - , AnalyzeWildcard(..) - , EnablePositionIncrements(..) - , SimpleQueryFlag(..) - , FieldOrFields(..) - , Monoid(..) - , ToJSON(..) - ) where - -import Control.Applicative -import Data.Aeson -import qualified Data.ByteString.Lazy.Char8 as L -import Data.List (nub) -import Data.List.NonEmpty (NonEmpty(..)) -import Data.Monoid -import Data.Text (Text) -import qualified Data.Text as T -import Data.Time.Clock (UTCTime) -import GHC.Generics (Generic) -import Network.HTTP.Client -import qualified Network.HTTP.Types.Method as NHTM - -import Database.Bloodhound.Types.Class - - -{-| 'Version' is embedded in 'Status' -} -data Version = Version { number :: Text - , build_hash :: Text - , build_timestamp :: UTCTime - , build_snapshot :: Bool - , lucene_version :: Text } deriving (Eq, Show, Generic) - -{-| '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. - - --} - -data Status = Status { ok :: Bool - , status :: Int - , name :: Text - , version :: Version - , tagline :: Text } deriving (Eq, Show) - -{-| 'IndexSettings' is used to configure the shards and replicas when you create - an Elasticsearch Index. - - --} - -data IndexSettings = - IndexSettings { indexShards :: ShardCount - , indexReplicas :: ReplicaCount } deriving (Eq, Show) - -{-| 'defaultIndexSettings' is an 'IndexSettings' with 3 shards and 2 replicas. -} -defaultIndexSettings :: IndexSettings -defaultIndexSettings = IndexSettings (ShardCount 3) (ReplicaCount 2) - -{-| 'Reply' and 'Method' are type synonyms from 'Network.HTTP.Types.Method.Method' -} -type Reply = Network.HTTP.Client.Response L.ByteString -type Method = NHTM.Method - -{-| 'OpenCloseIndex' is a sum type for opening and closing indices. - - --} -data OpenCloseIndex = OpenIndex | CloseIndex deriving (Eq, Show) - -data FieldType = GeoPointType - | GeoShapeType - | FloatType - | IntegerType - | LongType - | ShortType - | ByteType deriving (Eq, Show) - -data FieldDefinition = - FieldDefinition { fieldType :: FieldType } deriving (Eq, Show) - -data MappingField = - MappingField { mappingFieldName :: FieldName - , fieldDefinition :: FieldDefinition } deriving (Eq, Show) - -{-| Support for type reification of 'Mapping's is currently incomplete, for - now the mapping API verbiage expects a 'ToJSON'able blob. - - Indexes have mappings, mappings are schemas for the documents contained in the - index. I'd recommend having only one mapping per index, always having a mapping, - and keeping different kinds of documents separated if possible. --} -data Mapping = Mapping { typeName :: TypeName - , mappingFields :: [MappingField] } deriving (Eq, Show) - -{-| 'BulkOperation' is a sum type for expressing the four kinds of bulk - operation index, create, delete, and update. 'BulkIndex' behaves like an - "upsert", 'BulkCreate' will fail if a document already exists at the DocId. - - --} -data BulkOperation = - BulkIndex IndexName MappingName DocId Value - | BulkCreate IndexName MappingName DocId Value - | BulkDelete IndexName MappingName DocId - | BulkUpdate IndexName MappingName DocId Value deriving (Eq, Show) - -{-| 'EsResult' describes the standard wrapper JSON document that you see in - successful Elasticsearch responses. --} -data EsResult a = EsResult { _index :: Text - , _type :: Text - , _id :: Text - , _version :: Int - , found :: Maybe Bool - , _source :: a } deriving (Eq, Show) - -{-| '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) - -{-| '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) - -{-| '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) - -{-| 'mkSort' defaults everything but the 'FieldName' and the 'SortOrder' so - that you can concisely describe the usual kind of 'SortSpec's you want. --} -mkSort :: FieldName -> SortOrder -> DefaultSort -mkSort fieldName sOrder = DefaultSort fieldName sOrder False Nothing Nothing Nothing - -{-| 'Cache' is for telling ES whether it should cache a 'Filter' not. - 'Query's cannot be cached. --} -type Cache = Bool -- caching on/off -defaultCache :: Cache -defaultCache = False - -{-| 'PrefixValue' is used in 'PrefixQuery' as the main query component. --} -type PrefixValue = Text - -{-| '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) - -{-| 'ShardCount' is part of 'IndexSettings' --} -newtype ShardCount = ShardCount Int deriving (Eq, Show, Generic) - -{-| 'ReplicaCount' is part of 'IndexSettings' --} -newtype ReplicaCount = ReplicaCount Int deriving (Eq, Show, Generic) - -{-| 'Server' is used with the client functions to point at the ES instance --} -newtype Server = Server String deriving (Eq, Show) - -{-| 'IndexName' is used to describe which index to query/create/delete --} -newtype IndexName = IndexName String deriving (Eq, Generic, Show) - -{-| 'MappingName' is part of mappings which are how ES describes and schematizes - the data in the indices. --} -newtype MappingName = MappingName String deriving (Eq, Generic, Show) - -{-| '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 String deriving (Eq, Generic, Show) - -{-| 'QueryString' is used to wrap query text bodies, be they human written or not. --} -newtype QueryString = QueryString Text deriving (Eq, Generic, Show) - -{-| '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, Show) - -{-| 'CacheName' is used in 'RegexpFilter' for describing the - 'CacheKey' keyed caching behavior. --} -newtype CacheName = CacheName Text deriving (Eq, Show) - -{-| 'CacheKey' is used in 'RegexpFilter' to key regex caching. --} -newtype CacheKey = - CacheKey Text deriving (Eq, Show) -newtype Existence = - Existence Bool deriving (Eq, Show) -newtype NullValue = - NullValue Bool deriving (Eq, Show) -newtype CutoffFrequency = - CutoffFrequency Double deriving (Eq, Show, Generic) -newtype Analyzer = - Analyzer Text deriving (Eq, Show, Generic) -newtype MaxExpansions = - MaxExpansions Int deriving (Eq, Show, Generic) - -{-| '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, Generic) -newtype Tiebreaker = - Tiebreaker Double deriving (Eq, Show, Generic) -newtype Boost = - Boost Double deriving (Eq, Show, Generic) -newtype BoostTerms = - BoostTerms Double deriving (Eq, Show, Generic) - -{-| '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, Generic) -newtype MinimumMatchText = - MinimumMatchText Text deriving (Eq, Show) -newtype DisableCoord = - DisableCoord Bool deriving (Eq, Show, Generic) -newtype IgnoreTermFrequency = - IgnoreTermFrequency Bool deriving (Eq, Show, Generic) -newtype MinimumTermFrequency = - MinimumTermFrequency Int deriving (Eq, Show, Generic) -newtype MaxQueryTerms = - MaxQueryTerms Int deriving (Eq, Show, Generic) -newtype Fuzziness = - Fuzziness Double deriving (Eq, Show, Generic) - -{-| 'PrefixLength' is the prefix length used in queries, defaults to 0. -} -newtype PrefixLength = - PrefixLength Int deriving (Eq, Show, Generic) -newtype TypeName = - TypeName Text deriving (Eq, Show, Generic) -newtype PercentMatch = - PercentMatch Double deriving (Eq, Show, Generic) -newtype StopWord = - StopWord Text deriving (Eq, Show, Generic) -newtype QueryPath = - QueryPath Text deriving (Eq, Show, Generic) - -{-| 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, Generic) -newtype LowercaseExpanded = - LowercaseExpanded Bool deriving (Eq, Show, Generic) -newtype EnablePositionIncrements = - EnablePositionIncrements Bool deriving (Eq, Show, Generic) - -{-| 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, Generic) - -{-| 'GeneratePhraseQueries' defaults to false. --} -newtype GeneratePhraseQueries = - GeneratePhraseQueries Bool deriving (Eq, Show, Generic) - -{-| 'Locale' is used for string conversions - defaults to ROOT. --} -newtype Locale = Locale Text deriving (Eq, Show, Generic) -newtype MaxWordLength = MaxWordLength Int deriving (Eq, Show, Generic) -newtype MinWordLength = MinWordLength Int deriving (Eq, Show, Generic) - -{-| 'PhraseSlop' sets the default slop for phrases, 0 means exact - phrase matches. Default is 0. --} -newtype PhraseSlop = PhraseSlop Int deriving (Eq, Show, Generic) -newtype MinDocFrequency = MinDocFrequency Int deriving (Eq, Show, Generic) -newtype MaxDocFrequency = MaxDocFrequency Int deriving (Eq, Show, Generic) - -{-| 'unpackId' is a silly convenience function that gets used once. --} -unpackId :: DocId -> String -unpackId (DocId docId) = docId - -type TrackSortScores = Bool -type From = Int -type Size = Int - -data Search = Search { queryBody :: Maybe Query - , filterBody :: Maybe Filter - , sortBody :: Maybe Sort - -- default False - , trackSortScores :: TrackSortScores - , from :: From - , size :: Size } deriving (Eq, Show) - -data Query = - TermQuery Term (Maybe Boost) - | TermsQuery [Term] MinimumMatch - | 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 - deriving (Eq, Show) - -data RegexpQuery = - RegexpQuery { regexpQueryField :: FieldName - , regexpQuery :: Regexp - , regexpQueryFlags :: RegexpFlags - , regexpQueryBoost :: Maybe Boost - } deriving (Eq, Show) - -data RangeQuery = - RangeQuery { rangeQueryField :: FieldName - , rangeQueryRange :: Either HalfRange Range - , rangeQueryBoost :: Boost } deriving (Eq, Show) - -mkRangeQuery :: FieldName -> Either HalfRange Range -> 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 [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 [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 [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 [FieldName] - -- default 0.3 (30%) - , moreLikeThisPercentMatch :: Maybe PercentMatch - , moreLikeThisMinimumTermFreq :: Maybe MinimumTermFrequency - , moreLikeThisMaxQueryTerms :: Maybe MaxQueryTerms - , moreLikeThisStopWords :: Maybe [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 } 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 - -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 :: Maybe Query - , boolQueryMustNotMatch :: Maybe Query - , boolQueryShouldMatch :: Maybe [Query] - , boolQueryMinimumShouldMatch :: Maybe MinimumMatch - , boolQueryBoost :: Maybe Boost - , boolQueryDisableCoord :: Maybe DisableCoord - } deriving (Eq, Show) - -mkBoolQuery :: Maybe Query -> Maybe Query -> Maybe [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 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 - | RangeFilter FieldName (Either HalfRange Range) RangeExecution Cache - | RegexpFilter FieldName Regexp RegexpFlags CacheName Cache CacheKey - | TermFilter Term Cache - deriving (Eq, Show) - -data ZeroTermsQuery = ZeroTermsNone - | ZeroTermsAll deriving (Eq, Show) - --- lt, lte | gt, gte -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) - -data HalfRange = HalfRangeLt LessThan - | HalfRangeLte LessThanEq - | HalfRangeGt GreaterThan - | HalfRangeGte GreaterThanEq deriving (Eq, Show) - -data Range = RangeLtGt LessThan GreaterThan - | RangeLtGte LessThan GreaterThanEq - | RangeLteGt LessThanEq GreaterThan - | RangeLteGte LessThanEq GreaterThanEq deriving (Eq, Show) - -data RangeExecution = RangeExecutionIndex - | RangeExecutionFielddata deriving (Eq, Show) - -newtype Regexp = Regexp Text deriving (Eq, Show) - -data RegexpFlags = AllRegexpFlags - | NoRegexpFlags - | SomeRegexpFlags (NonEmpty RegexpFlag) deriving (Eq, Show) - -data RegexpFlag = AnyString - | Automaton - | Complement - | Empty - | Intersection - | Interval deriving (Eq, Show) - -halfRangeToKV :: HalfRange -> (Text, Double) -halfRangeToKV (HalfRangeLt (LessThan n)) = ("lt", n) -halfRangeToKV (HalfRangeLte (LessThanEq n)) = ("lte", n) -halfRangeToKV (HalfRangeGt (GreaterThan n)) = ("gt", n) -halfRangeToKV (HalfRangeGte (GreaterThanEq n)) = ("gte", n) - -rangeToKV :: Range -> (Text, Double, Text, Double) -rangeToKV (RangeLtGt (LessThan m) (GreaterThan n)) = ("lt", m, "gt", n) -rangeToKV (RangeLtGte (LessThan m) (GreaterThanEq n)) = ("lt", m, "gte", n) -rangeToKV (RangeLteGt (LessThanEq m) (GreaterThan n)) = ("lte", m, "gt", n) -rangeToKV (RangeLteGte (LessThanEq m) (GreaterThanEq n)) = ("lte", m, "gte", n) - --- phew. Coulda used Agda style case breaking there but, you know, whatever. :) - -data Term = Term { termField :: Text - , termValue :: Text } deriving (Eq, Show) - -data BoolMatch = MustMatch Term Cache - | MustNotMatch Term Cache - | ShouldMatch [Term] Cache deriving (Eq, Show) - --- "memory" or "indexed" -data GeoFilterType = GeoFilterMemory - | GeoFilterIndexed deriving (Eq, Show) - -data LatLon = LatLon { lat :: Double - , lon :: Double } deriving (Eq, Show) - -data GeoBoundingBox = - GeoBoundingBox { topLeft :: LatLon - , bottomRight :: LatLon } deriving (Eq, Show) - -data GeoBoundingBoxConstraint = - GeoBoundingBoxConstraint { geoBBField :: FieldName - , constraintBox :: GeoBoundingBox - , bbConstraintcache :: Cache - , geoType :: GeoFilterType - } deriving (Eq, Show) - -data GeoPoint = - GeoPoint { geoField :: FieldName - , latLon :: LatLon} deriving (Eq, Show) - -data DistanceUnit = Miles - | Yards - | Feet - | Inches - | Kilometers - | Meters - | Centimeters - | Millimeters - | NauticalMiles deriving (Eq, Show) - -data DistanceType = Arc - | SloppyArc -- doesn't exist <1.0 - | Plane 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) - -data FromJSON a => SearchResult a = - SearchResult { took :: Int - , timedOut :: Bool - , shards :: ShardResult - , searchHits :: SearchHits a } deriving (Eq, Show) - -type Score = Double - -data FromJSON a => SearchHits a = - SearchHits { hitsTotal :: Int - , maxScore :: Score - , hits :: [Hit a] } deriving (Eq, Show) - -data FromJSON a => Hit a = - Hit { hitIndex :: IndexName - , hitType :: MappingName - , hitDocId :: DocId - , hitScore :: Score - , hitSource :: a } deriving (Eq, Show) - -data ShardResult = - ShardResult { shardTotal :: Int - , shardsSuccessful :: Int - , shardsFailed :: Int } deriving (Eq, Show, Generic) - -showText :: Show a => a -> Text -showText = T.pack . show - - -instance Monoid Filter where - mempty = IdentityFilter - mappend a b = AndFilter [a, b] defaultCache - -instance Seminearring Filter where - a <||> b = OrFilter [a, b] defaultCache - -instance ToJSON Filter where - toJSON (AndFilter filters cache) = - object ["and" .= - object [ "filters" .= fmap toJSON filters - , "_cache" .= cache]] - - toJSON (OrFilter filters cache) = - object ["or" .= fmap toJSON filters - , "_cache" .= cache] - - toJSON (NotFilter notFilter cache) = - object ["not" .= - object ["filter" .= toJSON 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" .= toJSON boolMatch] - - toJSON (GeoBoundingBoxFilter bbConstraint) = - object ["geo_bounding_box" .= toJSON bbConstraint] - - toJSON (GeoDistanceFilter (GeoPoint (FieldName distanceGeoField) geoDistLatLon) - distance distanceType optimizeBbox cache) = - object ["geo_distance" .= - object ["distance" .= toJSON distance - , "distance_type" .= toJSON distanceType - , "optimize_bbox" .= optimizeBbox - , distanceGeoField .= toJSON geoDistLatLon - , "_cache" .= cache]] - - toJSON (GeoDistanceRangeFilter (GeoPoint (FieldName gddrField) drLatLon) - (DistanceRange geoDistRangeDistFrom drDistanceTo)) = - object ["geo_distance_range" .= - object ["from" .= toJSON geoDistRangeDistFrom - , "to" .= toJSON drDistanceTo - , gddrField .= toJSON 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 (T.pack . unpackId) values]] - - toJSON (LimitFilter limit) = - object ["limit" .= object ["value" .= limit]] - - toJSON (MissingFilter (FieldName fieldName) (Existence existence) (NullValue nullValue)) = - object ["missing" .= - object ["field" .= fieldName - , "existence" .= existence - , "null_value" .= nullValue]] - - toJSON (PrefixFilter (FieldName fieldName) fieldValue cache) = - object ["prefix" .= - object [fieldName .= fieldValue - , "_cache" .= cache]] - - toJSON (RangeFilter (FieldName fieldName) (Left halfRange) rangeExecution cache) = - object ["range" .= - object [fieldName .= - object [key .= val] - , "execution" .= toJSON rangeExecution - , "_cache" .= cache]] - where - (key, val) = halfRangeToKV halfRange - - toJSON (RangeFilter (FieldName fieldName) (Right range) rangeExecution cache) = - object ["range" .= - object [fieldName .= - object [lessKey .= lessVal - , greaterKey .= greaterVal] - , "execution" .= toJSON rangeExecution - , "_cache" .= cache]] - where - (lessKey, lessVal, greaterKey, greaterVal) = rangeToKV range - - toJSON (RegexpFilter (FieldName fieldName) - (Regexp regexText) flags (CacheName cacheName) cache (CacheKey cacheKey)) = - object ["regexp" .= - object [fieldName .= - object ["value" .= regexText - , "flags" .= toJSON flags] - , "_name" .= cacheName - , "_cache" .= cache - , "_cache_key" .= cacheKey]] - -instance ToJSON GeoPoint where - toJSON (GeoPoint (FieldName geoPointField) geoPointLatLon) = - object [ geoPointField .= toJSON geoPointLatLon ] - - -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 terms termsQueryMinimumMatch) = - object [ "terms" .= object conjoined ] - where conjoined = - [ "tags" .= fmap toJSON terms - , "minimum_should_match" .= toJSON termsQueryMinimumMatch ] - - toJSON (IdsQuery idsQueryMappingName docIds) = - object [ "ids" .= object conjoined ] - where conjoined = [ "type" .= toJSON idsQueryMappingName - , "values" .= fmap toJSON docIds ] - - toJSON (QueryQueryStringQuery qQueryStringQuery) = - object [ "query_string" .= toJSON qQueryStringQuery ] - - toJSON (QueryMatchQuery matchQuery) = - object [ "match" .= toJSON matchQuery ] - - toJSON (QueryMultiMatchQuery multiMatchQuery) = - object [ "multi_match" .= toJSON multiMatchQuery ] - - toJSON (QueryBoolQuery boolQuery) = - object [ "bool" .= toJSON boolQuery ] - - toJSON (QueryBoostingQuery boostingQuery) = - object [ "boosting" .= toJSON boostingQuery ] - - toJSON (QueryCommonTermsQuery commonTermsQuery) = - object [ "common" .= toJSON commonTermsQuery ] - - toJSON (ConstantScoreFilter csFilter boost) = - object [ "constant_score" .= toJSON csFilter - , "boost" .= toJSON boost] - - toJSON (ConstantScoreQuery query boost) = - object [ "constant_score" .= toJSON query - , "boost" .= toJSON boost] - - toJSON (QueryDisMaxQuery disMaxQuery) = - object [ "dis_max" .= toJSON disMaxQuery ] - - toJSON (QueryFilteredQuery qFilteredQuery) = - object [ "filtered" .= toJSON qFilteredQuery ] - - toJSON (QueryFuzzyLikeThisQuery fuzzyQuery) = - object [ "fuzzy_like_this" .= toJSON fuzzyQuery ] - - toJSON (QueryFuzzyLikeFieldQuery fuzzyFieldQuery) = - object [ "fuzzy_like_this_field" .= toJSON fuzzyFieldQuery ] - - toJSON (QueryFuzzyQuery fuzzyQuery) = - object [ "fuzzy" .= toJSON fuzzyQuery ] - - toJSON (QueryHasChildQuery childQuery) = - object [ "has_child" .= toJSON childQuery ] - - toJSON (QueryHasParentQuery parentQuery) = - object [ "has_parent" .= toJSON parentQuery ] - - toJSON (QueryIndicesQuery qIndicesQuery) = - object [ "indices" .= toJSON qIndicesQuery ] - - toJSON (MatchAllQuery boost) = - object [ "match_all" .= omitNulls [ "boost" .= boost ] ] - - toJSON (QueryMoreLikeThisQuery query) = - object [ "more_like_this" .= toJSON query ] - - toJSON (QueryMoreLikeThisFieldQuery query) = - object [ "more_like_this_field" .= toJSON query ] - - toJSON (QueryNestedQuery query) = - object [ "nested" .= toJSON query ] - - toJSON (QueryPrefixQuery query) = - object [ "prefix" .= toJSON query ] - - toJSON (QueryRangeQuery query) = - object [ "range" .= toJSON query ] - - toJSON (QueryRegexpQuery query) = - object [ "regexp" .= toJSON query ] - - toJSON (QuerySimpleQueryStringQuery query) = - object [ "simple_query_string" .= toJSON query ] - - -omitNulls :: [(Text, Value)] -> Value -omitNulls = object . filter notNull where - notNull (_, Null) = False - notNull _ = True - - -instance ToJSON SimpleQueryStringQuery where - toJSON SimpleQueryStringQuery {..} = - omitNulls (base ++ maybeAdd) - where base = [ "query" .= toJSON simpleQueryStringQuery ] - maybeAdd = [ "fields" .= simpleQueryStringField - , "default_operator" .= simpleQueryStringOperator - , "analyzer" .= simpleQueryStringAnalyzer - , "flags" .= simpleQueryStringFlags - , "lowercase_expanded_terms" .= simpleQueryStringLowercaseExpanded - , "locale" .= simpleQueryStringLocale ] - - -instance ToJSON FieldOrFields where - toJSON (FofField fieldName) = - toJSON fieldName - toJSON (FofFields fieldNames) = - toJSON fieldNames - -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 ToJSON RegexpQuery where - toJSON (RegexpQuery (FieldName rqQueryField) - (Regexp regexpQueryQuery) rqQueryFlags - rqQueryBoost) = - object [ rqQueryField .= omitNulls base ] - where base = [ "value" .= regexpQueryQuery - , "flags" .= toJSON rqQueryFlags - , "boost" .= rqQueryBoost ] - - -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" .= toJSON 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 ToJSON RangeQuery where - toJSON (RangeQuery (FieldName fieldName) (Right range) boost) = - object [ fieldName .= conjoined ] - where conjoined = [ "boost" .= toJSON boost - , lessKey .= lessVal - , greaterKey .= greaterVal ] - (lessKey, lessVal, greaterKey, greaterVal) = rangeToKV range - - toJSON (RangeQuery (FieldName fieldName) (Left halfRange) boost) = - object [ fieldName .= conjoined ] - where conjoined = [ "boost" .= toJSON boost - , key .= val ] - (key, val) = halfRangeToKV halfRange - - -instance ToJSON PrefixQuery where - toJSON (PrefixQuery (FieldName fieldName) queryValue boost) = - object [ fieldName .= omitNulls base ] - where base = [ "value" .= toJSON queryValue - , "boost" .= boost ] - - -instance ToJSON NestedQuery where - toJSON (NestedQuery nqPath nqScoreType nqQuery) = - object [ "path" .= toJSON nqPath - , "score_mode" .= toJSON nqScoreType - , "query" .= toJSON nqQuery ] - - -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" .= toJSON 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 ToJSON MoreLikeThisQuery where - toJSON (MoreLikeThisQuery text fields percent - mtf mqt stopwords mindf maxdf - minwl maxwl boostTerms boost analyzer) = - omitNulls base - where base = [ "like_text" .= toJSON 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 ToJSON IndicesQuery where - toJSON (IndicesQuery indices query noMatch) = - omitNulls [ "indices" .= toJSON indices - , "no_match_query" .= toJSON noMatch - , "query" .= toJSON query ] - - -instance ToJSON HasParentQuery where - toJSON (HasParentQuery queryType query scoreType) = - omitNulls [ "parent_type" .= toJSON queryType - , "score_type" .= toJSON scoreType - , "query" .= toJSON query ] - - -instance ToJSON HasChildQuery where - toJSON (HasChildQuery queryType query scoreType) = - omitNulls [ "query" .= toJSON query - , "score_type" .= toJSON scoreType - , "type" .= toJSON queryType ] - - -instance ToJSON FuzzyQuery where - toJSON (FuzzyQuery (FieldName fieldName) queryText - prefixLength maxEx fuzziness boost) = - object [ fieldName .= omitNulls base ] - where base = [ "value" .= toJSON queryText - , "fuzziness" .= toJSON fuzziness - , "prefix_length" .= toJSON prefixLength - , "boost" .= toJSON boost - , "max_expansions" .= toJSON maxEx ] - - -instance ToJSON FuzzyLikeFieldQuery where - toJSON (FuzzyLikeFieldQuery (FieldName fieldName) - fieldText maxTerms ignoreFreq fuzziness prefixLength - boost analyzer) = - object [ fieldName .= - omitNulls [ "like_text" .= toJSON fieldText - , "max_query_terms" .= toJSON maxTerms - , "ignore_tf" .= toJSON ignoreFreq - , "fuzziness" .= toJSON fuzziness - , "prefix_length" .= toJSON prefixLength - , "analyzer" .= toJSON analyzer - , "boost" .= toJSON boost ]] - - -instance ToJSON FuzzyLikeThisQuery where - toJSON (FuzzyLikeThisQuery fields text maxTerms - ignoreFreq fuzziness prefixLength boost analyzer) = - omitNulls base - where base = [ "fields" .= toJSON fields - , "like_text" .= toJSON text - , "max_query_terms" .= toJSON maxTerms - , "ignore_tf" .= toJSON ignoreFreq - , "fuzziness" .= toJSON fuzziness - , "prefix_length" .= toJSON prefixLength - , "analyzer" .= toJSON analyzer - , "boost" .= toJSON boost ] - - -instance ToJSON FilteredQuery where - toJSON (FilteredQuery query fFilter) = - object [ "query" .= toJSON query - , "filter" .= toJSON fFilter ] - - -instance ToJSON DisMaxQuery where - toJSON (DisMaxQuery queries tiebreaker boost) = - omitNulls base - where base = [ "queries" .= toJSON queries - , "boost" .= toJSON boost - , "tie_breaker" .= toJSON tiebreaker ] - - -instance ToJSON CommonTermsQuery where - toJSON (CommonTermsQuery (FieldName fieldName) - (QueryString query) cf lfo hfo msm - boost analyzer disableCoord) = - object [fieldName .= omitNulls base ] - where base = [ "query" .= toJSON query - , "cutoff_frequency" .= toJSON cf - , "low_freq_operator" .= toJSON lfo - , "minimum_should_match" .= toJSON msm - , "boost" .= toJSON boost - , "analyzer" .= toJSON analyzer - , "disable_coord" .= toJSON disableCoord - , "high_freq_operator" .= toJSON hfo ] - - -instance ToJSON CommonMinimumMatch where - toJSON (CommonMinimumMatch mm) = toJSON mm - toJSON (CommonMinimumMatchHighLow (MinimumMatchHighLow lowF highF)) = - object [ "low_freq" .= toJSON lowF - , "high_freq" .= toJSON highF ] - -instance ToJSON BoostingQuery where - toJSON (BoostingQuery bqPositiveQuery bqNegativeQuery bqNegativeBoost) = - object [ "positive" .= toJSON bqPositiveQuery - , "negative" .= toJSON bqNegativeQuery - , "negative_boost" .= toJSON bqNegativeBoost ] - - -instance ToJSON BoolQuery where - toJSON (BoolQuery mustM notM shouldM bqMin boost disableCoord) = - omitNulls base - where base = [ "must" .= toJSON mustM - , "must_not" .= toJSON notM - , "should" .= toJSON shouldM - , "minimum_should_match" .= toJSON bqMin - , "boost" .= toJSON boost - , "disable_coord" .= toJSON disableCoord ] - - -instance ToJSON MatchQuery where - toJSON (MatchQuery (FieldName fieldName) - (QueryString mqQueryString) booleanOperator - zeroTermsQuery cutoffFrequency matchQueryType - analyzer maxExpansions lenient) = - object [ fieldName .= omitNulls base ] - where base = [ "query" .= mqQueryString - , "operator" .= toJSON booleanOperator - , "zero_terms_query" .= toJSON zeroTermsQuery - , "cutoff_frequency" .= toJSON cutoffFrequency - , "type" .= toJSON matchQueryType - , "analyzer" .= toJSON analyzer - , "max_expansions" .= toJSON maxExpansions - , "lenient" .= toJSON lenient ] - - -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" .= toJSON boolOp - , "zero_terms_query" .= toJSON ztQ - , "tiebreaker" .= toJSON tb - , "type" .= toJSON mmqt - , "cutoff_frequency" .= toJSON cf - , "analyzer" .= toJSON analyzer - , "max_expansions" .= toJSON maxEx - , "lenient" .= toJSON lenient ] - - -instance ToJSON MultiMatchQueryType where - toJSON MultiMatchBestFields = "best_fields" - toJSON MultiMatchMostFields = "most_fields" - toJSON MultiMatchCrossFields = "cross_fields" - toJSON MultiMatchPhrase = "phrase" - toJSON MultiMatchPhrasePrefix = "phrase_prefix" - -instance ToJSON BooleanOperator where - toJSON And = String "and" - toJSON Or = String "or" - -instance ToJSON ZeroTermsQuery where - toJSON ZeroTermsNone = String "none" - toJSON ZeroTermsAll = String "all" - -instance ToJSON MatchQueryType where - toJSON MatchPhrase = "phrase" - toJSON MatchPhrasePrefix = "phrase_prefix" - -instance ToJSON FieldName where - toJSON (FieldName fieldName) = String fieldName - -instance ToJSON ReplicaCount -instance ToJSON ShardCount -instance ToJSON CutoffFrequency -instance ToJSON Analyzer -instance ToJSON MaxExpansions -instance ToJSON Lenient -instance ToJSON Boost -instance ToJSON Version -instance ToJSON Tiebreaker -instance ToJSON MinimumMatch -instance ToJSON DisableCoord -instance ToJSON PrefixLength -instance ToJSON Fuzziness -instance ToJSON IgnoreTermFrequency -instance ToJSON MaxQueryTerms -instance ToJSON TypeName -instance ToJSON IndexName -instance ToJSON BoostTerms -instance ToJSON MaxWordLength -instance ToJSON MinWordLength -instance ToJSON MaxDocFrequency -instance ToJSON MinDocFrequency -instance ToJSON PhraseSlop -instance ToJSON StopWord -instance ToJSON QueryPath -instance ToJSON MinimumTermFrequency -instance ToJSON PercentMatch -instance ToJSON MappingName -instance ToJSON DocId -instance ToJSON QueryString -instance ToJSON AllowLeadingWildcard -instance ToJSON LowercaseExpanded -instance ToJSON AnalyzeWildcard -instance ToJSON GeneratePhraseQueries -instance ToJSON Locale -instance ToJSON EnablePositionIncrements -instance FromJSON Version -instance FromJSON IndexName -instance FromJSON MappingName -instance FromJSON DocId - - -instance FromJSON Status where - parseJSON (Object v) = Status <$> - v .: "ok" <*> - v .: "status" <*> - v .: "name" <*> - v .: "version" <*> - v .: "tagline" - parseJSON _ = empty - - -instance ToJSON IndexSettings where - toJSON (IndexSettings s r) = object ["settings" .= object ["shards" .= s, "replicas" .= r]] - - -instance (FromJSON a) => FromJSON (EsResult a) where - parseJSON (Object v) = EsResult <$> - v .: "_index" <*> - v .: "_type" <*> - v .: "_id" <*> - v .: "_version" <*> - v .:? "found" <*> - v .: "_source" - parseJSON _ = empty - - -instance ToJSON Search where - toJSON (Search query sFilter sort sTrackSortScores sFrom sSize) = - omitNulls [ "query" .= query - , "filter" .= sFilter - , "sort" .= sort - , "from" .= sFrom - , "size" .= sSize - , "track_scores" .= sTrackSortScores ] - - -instance ToJSON SortSpec where - toJSON (DefaultSortSpec - (DefaultSort (FieldName dsSortFieldName) dsSortOrder dsIgnoreUnmapped - dsSortMode dsMissingSort dsNestedFilter)) = - object [dsSortFieldName .= omitNulls base] where - base = [ "order" .= toJSON dsSortOrder - , "ignore_unmapped" .= dsIgnoreUnmapped - , "mode" .= dsSortMode - , "missing" .= dsMissingSort - , "nested_filter" .= dsNestedFilter ] - - toJSON (GeoDistanceSortSpec gdsSortOrder (GeoPoint (FieldName field) gdsLatLon) units) = - object [ "unit" .= toJSON units - , field .= toJSON gdsLatLon - , "order" .= toJSON gdsSortOrder ] - - -instance ToJSON SortOrder where - toJSON Ascending = String "asc" - toJSON Descending = String "desc" - - -instance ToJSON SortMode where - toJSON SortMin = String "min" - toJSON SortMax = String "max" - toJSON SortSum = String "sum" - toJSON SortAvg = String "avg" - - -instance ToJSON Missing where - toJSON LastMissing = String "_last" - toJSON FirstMissing = String "_first" - toJSON (CustomMissing txt) = String txt - - -instance ToJSON ScoreType where - toJSON ScoreTypeMax = "max" - toJSON ScoreTypeAvg = "avg" - toJSON ScoreTypeSum = "sum" - toJSON ScoreTypeNone = "none" - - -instance ToJSON Distance where - toJSON (Distance dCoefficient dUnit) = - String boltedTogether where - coefText = showText dCoefficient - (String unitText) = toJSON dUnit - boltedTogether = mappend coefText unitText - - -instance ToJSON DistanceUnit where - toJSON Miles = String "mi" - toJSON Yards = String "yd" - toJSON Feet = String "ft" - toJSON Inches = String "in" - toJSON Kilometers = String "km" - toJSON Meters = String "m" - toJSON Centimeters = String "cm" - toJSON Millimeters = String "mm" - toJSON NauticalMiles = String "nmi" - - -instance ToJSON DistanceType where - toJSON Arc = String "arc" - toJSON SloppyArc = String "sloppy_arc" - toJSON Plane = String "plane" - - -instance ToJSON OptimizeBbox where - toJSON NoOptimizeBbox = String "none" - toJSON (OptimizeGeoFilterType gft) = toJSON gft - - -instance ToJSON GeoBoundingBoxConstraint where - toJSON (GeoBoundingBoxConstraint - (FieldName gbbcGeoBBField) gbbcConstraintBox cache type') = - object [gbbcGeoBBField .= toJSON gbbcConstraintBox - , "_cache" .= cache - , "type" .= type'] - - -instance ToJSON GeoFilterType where - toJSON GeoFilterMemory = String "memory" - toJSON GeoFilterIndexed = String "indexed" - - -instance ToJSON GeoBoundingBox where - toJSON (GeoBoundingBox gbbTopLeft gbbBottomRight) = - object ["top_left" .= toJSON gbbTopLeft - , "bottom_right" .= toJSON gbbBottomRight] - - -instance ToJSON LatLon where - toJSON (LatLon lLat lLon) = - object ["lat" .= lLat - , "lon" .= lLon] - - --- index for smaller ranges, fielddata for longer ranges -instance ToJSON RangeExecution where - toJSON RangeExecutionIndex = "index" - toJSON RangeExecutionFielddata = "fielddata" - - -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 ToJSON Term where - toJSON (Term field value) = object ["term" .= object - [field .= value]] - - -instance ToJSON BoolMatch where - toJSON (MustMatch term cache) = object ["must" .= toJSON term, - "_cache" .= cache] - toJSON (MustNotMatch term cache) = object ["must_not" .= toJSON term, - "_cache" .= cache] - toJSON (ShouldMatch terms cache) = object ["should" .= fmap toJSON terms, - "_cache" .= cache] - - -instance (FromJSON a) => FromJSON (SearchResult a) where - parseJSON (Object v) = SearchResult <$> - v .: "took" <*> - v .: "timed_out" <*> - v .: "_shards" <*> - v .: "hits" - parseJSON _ = empty - -instance (FromJSON a) => FromJSON (SearchHits a) where - parseJSON (Object v) = SearchHits <$> - v .: "total" <*> - v .: "max_score" <*> - v .: "hits" - parseJSON _ = empty - -instance (FromJSON a) => FromJSON (Hit a) where - parseJSON (Object v) = Hit <$> - v .: "_index" <*> - v .: "_type" <*> - v .: "_id" <*> - v .: "_score" <*> - v .: "_source" - parseJSON _ = empty - -instance FromJSON ShardResult where - parseJSON (Object v) = ShardResult <$> - v .: "total" <*> - v .: "successful" <*> - v .: "failed" - parseJSON _ = empty diff --git a/Database/Bloodhound/Types/Class.hs b/Database/Bloodhound/Types/Class.hs deleted file mode 100644 --- a/Database/Bloodhound/Types/Class.hs +++ /dev/null @@ -1,14 +0,0 @@ -module Database.Bloodhound.Types.Class - ( Seminearring(..) ) - where - -import Data.Monoid - -class Monoid a => Seminearring a where - -- 0, +, * - (<||>) :: a -> a -> a - (<&&>) :: a -> a -> a - (<&&>) = mappend - -infixr 5 <||> -infixr 5 <&&> diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,202 +1,12 @@ - - Apache License - Version 2.0, January 2004 - http://www.apache.org/licenses/ - - TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION - - 1. Definitions. - - "License" shall mean the terms and conditions for use, reproduction, - and distribution as defined by Sections 1 through 9 of this document. - - "Licensor" shall mean the copyright owner or entity authorized by - the copyright owner that is granting the License. - - "Legal Entity" shall mean the union of the acting entity and all - other entities that control, are controlled by, or are under common - control with that entity. For the purposes of this definition, - "control" means (i) the power, direct or indirect, to cause the - direction or management of such entity, whether by contract or - otherwise, or (ii) ownership of fifty percent (50%) or more of the - outstanding shares, or (iii) beneficial ownership of such entity. - - "You" (or "Your") shall mean an individual or Legal Entity - exercising permissions granted by this License. - - "Source" form shall mean the preferred form for making modifications, - including but not limited to software source code, documentation - source, and configuration files. - - "Object" form shall mean any form resulting from mechanical - transformation or translation of a Source form, including but - not limited to compiled object code, generated documentation, - and conversions to other media types. - - "Work" shall mean the work of authorship, whether in Source or - Object form, made available under the License, as indicated by a - copyright notice that is included in or attached to the work - (an example is provided in the Appendix below). - - "Derivative Works" shall mean any work, whether in Source or Object - form, that is based on (or derived from) the Work and for which the - editorial revisions, annotations, elaborations, or other modifications - represent, as a whole, an original work of authorship. For the purposes - of this License, Derivative Works shall not include works that remain - separable from, or merely link (or bind by name) to the interfaces of, - the Work and Derivative Works thereof. - - "Contribution" shall mean any work of authorship, including - the original version of the Work and any modifications or additions - to that Work or Derivative Works thereof, that is intentionally - submitted to Licensor for inclusion in the Work by the copyright owner - or by an individual or Legal Entity authorized to submit on behalf of - the copyright owner. For the purposes of this definition, "submitted" - means any form of electronic, verbal, or written communication sent - to the Licensor or its representatives, including but not limited to - communication on electronic mailing lists, source code control systems, - and issue tracking systems that are managed by, or on behalf of, the - Licensor for the purpose of discussing and improving the Work, but - excluding communication that is conspicuously marked or otherwise - designated in writing by the copyright owner as "Not a Contribution." - - "Contributor" shall mean Licensor and any individual or Legal Entity - on behalf of whom a Contribution has been received by Licensor and - subsequently incorporated within the Work. - - 2. Grant of Copyright License. Subject to the terms and conditions of - this License, each Contributor hereby grants to You a perpetual, - worldwide, non-exclusive, no-charge, royalty-free, irrevocable - copyright license to reproduce, prepare Derivative Works of, - publicly display, publicly perform, sublicense, and distribute the - Work and such Derivative Works in Source or Object form. - - 3. Grant of Patent License. Subject to the terms and conditions of - this License, each Contributor hereby grants to You a perpetual, - worldwide, non-exclusive, no-charge, royalty-free, irrevocable - (except as stated in this section) patent license to make, have made, - use, offer to sell, sell, import, and otherwise transfer the Work, - where such license applies only to those patent claims licensable - by such Contributor that are necessarily infringed by their - Contribution(s) alone or by combination of their Contribution(s) - with the Work to which such Contribution(s) was submitted. If You - institute patent litigation against any entity (including a - cross-claim or counterclaim in a lawsuit) alleging that the Work - or a Contribution incorporated within the Work constitutes direct - or contributory patent infringement, then any patent licenses - granted to You under this License for that Work shall terminate - as of the date such litigation is filed. - - 4. Redistribution. You may reproduce and distribute copies of the - Work or Derivative Works thereof in any medium, with or without - modifications, and in Source or Object form, provided that You - meet the following conditions: - - (a) You must give any other recipients of the Work or - Derivative Works a copy of this License; and - - (b) You must cause any modified files to carry prominent notices - stating that You changed the files; and - - (c) You must retain, in the Source form of any Derivative Works - that You distribute, all copyright, patent, trademark, and - attribution notices from the Source form of the Work, - excluding those notices that do not pertain to any part of - the Derivative Works; and - - (d) If the Work includes a "NOTICE" text file as part of its - distribution, then any Derivative Works that You distribute must - include a readable copy of the attribution notices contained - within such NOTICE file, excluding those notices that do not - pertain to any part of the Derivative Works, in at least one - of the following places: within a NOTICE text file distributed - as part of the Derivative Works; within the Source form or - documentation, if provided along with the Derivative Works; or, - within a display generated by the Derivative Works, if and - wherever such third-party notices normally appear. The contents - of the NOTICE file are for informational purposes only and - do not modify the License. You may add Your own attribution - notices within Derivative Works that You distribute, alongside - or as an addendum to the NOTICE text from the Work, provided - that such additional attribution notices cannot be construed - as modifying the License. - - You may add Your own copyright statement to Your modifications and - may provide additional or different license terms and conditions - for use, reproduction, or distribution of Your modifications, or - for any such Derivative Works as a whole, provided Your use, - reproduction, and distribution of the Work otherwise complies with - the conditions stated in this License. - - 5. Submission of Contributions. Unless You explicitly state otherwise, - any Contribution intentionally submitted for inclusion in the Work - by You to the Licensor shall be under the terms and conditions of - this License, without any additional terms or conditions. - Notwithstanding the above, nothing herein shall supersede or modify - the terms of any separate license agreement you may have executed - with Licensor regarding such Contributions. - - 6. Trademarks. This License does not grant permission to use the trade - names, trademarks, service marks, or product names of the Licensor, - except as required for reasonable and customary use in describing the - origin of the Work and reproducing the content of the NOTICE file. - - 7. Disclaimer of Warranty. Unless required by applicable law or - agreed to in writing, Licensor provides the Work (and each - Contributor provides its Contributions) on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or - implied, including, without limitation, any warranties or conditions - of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A - PARTICULAR PURPOSE. You are solely responsible for determining the - appropriateness of using or redistributing the Work and assume any - risks associated with Your exercise of permissions under this License. - - 8. Limitation of Liability. In no event and under no legal theory, - whether in tort (including negligence), contract, or otherwise, - unless required by applicable law (such as deliberate and grossly - negligent acts) or agreed to in writing, shall any Contributor be - liable to You for damages, including any direct, indirect, special, - incidental, or consequential damages of any character arising as a - result of this License or out of the use or inability to use the - Work (including but not limited to damages for loss of goodwill, - work stoppage, computer failure or malfunction, or any and all - other commercial damages or losses), even if such Contributor - has been advised of the possibility of such damages. - - 9. Accepting Warranty or Additional Liability. While redistributing - the Work or Derivative Works thereof, You may choose to offer, - and charge a fee for, acceptance of support, warranty, indemnity, - or other liability obligations and/or rights consistent with this - License. However, in accepting such obligations, You may act only - on Your own behalf and on Your sole responsibility, not on behalf - of any other Contributor, and only if You agree to indemnify, - defend, and hold each Contributor harmless for any liability - incurred by, or claims asserted against, such Contributor by reason - of your accepting any such warranty or additional liability. - - END OF TERMS AND CONDITIONS - - APPENDIX: How to apply the Apache License to your work. +Copyright (c) 2014, Chris Allen +All rights reserved. - To apply the Apache License to your work, attach the following - boilerplate notice, with the fields enclosed by brackets "[]" - replaced with your own identifying information. (Don't include - the brackets!) The text should be enclosed in the appropriate - comment syntax for the file format. We also recommend that a - file or class name and description of purpose be included on the - same "printed page" as the copyright notice for easier - identification within third-party archives. +Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: - Copyright [yyyy] [name of copyright owner] +1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at +2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. - http://www.apache.org/licenses/LICENSE-2.0 +3. Neither the name of the copyright holder nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/bloodhound.cabal b/bloodhound.cabal --- a/bloodhound.cabal +++ b/bloodhound.cabal @@ -1,9 +1,9 @@ name: bloodhound -version: 0.3.0.0 +version: 0.4.0.0 synopsis: ElasticSearch client library for Haskell description: ElasticSearch made awesome for Haskell hackers homepage: https://github.com/bitemyapp/bloodhound -license: Apache-2.0 +license: BSD3 license-file: LICENSE author: Chris Allen maintainer: cma@bitemyapp.com @@ -23,15 +23,18 @@ Database.Bloodhound.Client Database.Bloodhound.Types Database.Bloodhound.Types.Class - build-depends: base >= 4.3 && <5, - bytestring >= 0.10.2, - aeson >= 0.7, - conduit >= 1.0, - http-client >= 0.3, - semigroups >= 0.15, - time >= 1.4, - text >= 0.11, - http-types >= 0.8 + hs-source-dirs: src + build-depends: base >= 4.3 && <5, + bytestring >= 0.10.2 && <0.11, + containers >= 0.5.0.0 && <0.6, + aeson >= 0.7 && <0.9, + conduit >= 1.0 && <1.3, + http-client >= 0.3 && <0.5, + semigroups >= 0.15 && <0.16, + time >= 1.4 && <1.6, + text >= 0.11 && <1.3, + http-types >= 0.8 && <0.9, + vector >= 0.10.11 && <0.11 default-language: Haskell2010 test-suite tests @@ -44,10 +47,13 @@ bloodhound, http-client, http-types, - hspec >= 1.8, - text >= 0.11, - time >= 1.4, - aeson >= 0.7, - semigroups >= 0.15, - QuickCheck + containers, + hspec >= 1.8 && <2.1, + text, + time, + aeson, + semigroups, + QuickCheck, + vector, + unordered-containers >= 0.2.5.0 && <0.3 default-language: Haskell2010 diff --git a/src/Database/Bloodhound.hs b/src/Database/Bloodhound.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound.hs @@ -0,0 +1,7 @@ +module Database.Bloodhound + ( module Database.Bloodhound.Client + , module Database.Bloodhound.Types + ) where + +import Database.Bloodhound.Client +import Database.Bloodhound.Types diff --git a/src/Database/Bloodhound/Client.hs b/src/Database/Bloodhound/Client.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Client.hs @@ -0,0 +1,262 @@ +module Database.Bloodhound.Client + ( createIndex + , deleteIndex + , indexExists + , openIndex + , closeIndex + , putMapping + , deleteMapping + , indexDocument + , getDocument + , documentExists + , deleteDocument + , searchAll + , searchByIndex + , searchByType + , refreshIndex + , mkSearch + , mkAggregateSearch + , mkHighlightSearch + , bulk + , pageSearch + , mkShardCount + , mkReplicaCount + , getStatus + , encodeBulkOperations + , encodeBulkOperation + ) + where + +import Data.Aeson +import Data.ByteString.Builder +import qualified Data.ByteString.Lazy.Char8 as L +import Data.List (intercalate) +import Data.Maybe (fromMaybe) +import Data.Text (Text) +import qualified Data.Vector as V +import Network.HTTP.Client +import qualified Network.HTTP.Types.Method as NHTM +import qualified Network.HTTP.Types.Status as NHTS +import Prelude hiding (filter, head) + +import Database.Bloodhound.Types + +-- find way to avoid destructuring Servers and Indexes? +-- make get, post, put, delete helpers. +-- make dispatch take URL last for better variance and +-- utilization of partial application + +mkShardCount :: Int -> Maybe ShardCount +mkShardCount n + | n < 1 = Nothing + | n > 1000 = Nothing -- seriously, what the fuck? + | otherwise = Just (ShardCount n) + +mkReplicaCount :: Int -> Maybe ReplicaCount +mkReplicaCount n + | n < 1 = Nothing + | n > 1000 = Nothing -- ... + | otherwise = Just (ReplicaCount n) + +emptyBody :: L.ByteString +emptyBody = L.pack "" + +dispatch :: Method -> String -> Maybe L.ByteString + -> IO Reply +dispatch dMethod url body = do + initReq <- parseUrl url + let reqBody = RequestBodyLBS $ fromMaybe emptyBody body + let req = initReq { method = dMethod + , requestBody = reqBody + , checkStatus = \_ _ _ -> Nothing} + withManager defaultManagerSettings $ httpLbs req + +joinPath :: [String] -> String +joinPath = intercalate "/" + +-- Shortcut functions for HTTP methods +delete :: String -> IO Reply +delete = flip (dispatch NHTM.methodDelete) Nothing +get :: String -> IO Reply +get = flip (dispatch NHTM.methodGet) Nothing +head :: String -> IO Reply +head = flip (dispatch NHTM.methodHead) Nothing +put :: String -> Maybe L.ByteString -> IO Reply +put = dispatch NHTM.methodPost +post :: String -> Maybe L.ByteString -> IO Reply +post = dispatch NHTM.methodPost + +-- indexDocument s ix name doc = put (root s ix name doc) (Just encode doc) +-- http://hackage.haskell.org/package/http-client-lens-0.1.0/docs/Network-HTTP-Client-Lens.html +-- https://github.com/supki/libjenkins/blob/master/src/Jenkins/Rest/Internal.hs + +getStatus :: Server -> IO (Maybe Status) +getStatus (Server server) = do + request <- parseUrl $ joinPath [server] + response <- withManager defaultManagerSettings $ httpLbs request + return $ decode (responseBody response) + +createIndex :: Server -> IndexSettings -> IndexName -> IO Reply +createIndex (Server server) indexSettings (IndexName indexName) = + put url body + where url = joinPath [server, indexName] + body = Just $ encode indexSettings + +deleteIndex :: Server -> IndexName -> IO Reply +deleteIndex (Server server) (IndexName indexName) = + delete $ joinPath [server, indexName] + +respIsTwoHunna :: Reply -> Bool +respIsTwoHunna resp = NHTS.statusCode (responseStatus resp) == 200 + +existentialQuery :: String -> IO (Reply, Bool) +existentialQuery url = do + reply <- head url + return (reply, respIsTwoHunna reply) + +indexExists :: Server -> IndexName -> IO Bool +indexExists (Server server) (IndexName indexName) = do + (_, exists) <- existentialQuery url + return exists + where url = joinPath [server, indexName] + +refreshIndex :: Server -> IndexName -> IO Reply +refreshIndex (Server server) (IndexName indexName) = + post url Nothing + where url = joinPath [server, indexName, "_refresh"] + +stringifyOCIndex :: OpenCloseIndex -> String +stringifyOCIndex oci = case oci of + OpenIndex -> "_open" + CloseIndex -> "_close" + +openOrCloseIndexes :: OpenCloseIndex -> Server -> IndexName -> IO Reply +openOrCloseIndexes oci (Server server) (IndexName indexName) = + post url Nothing + where ociString = stringifyOCIndex oci + url = joinPath [server, indexName, ociString] + +openIndex :: Server -> IndexName -> IO Reply +openIndex = openOrCloseIndexes OpenIndex + +closeIndex :: Server -> IndexName -> IO Reply +closeIndex = openOrCloseIndexes CloseIndex + +{-| putMapping is an HTTP PUT and has upsert semantics. Mappings are schemas + for documents in indexes. +-} +putMapping :: ToJSON a => Server -> IndexName + -> MappingName -> a -> IO Reply +putMapping (Server server) (IndexName indexName) (MappingName mappingName) mapping = + put url body + where url = joinPath [server, indexName, mappingName, "_mapping"] + body = Just $ encode mapping + +deleteMapping :: Server -> IndexName -> MappingName -> IO Reply +deleteMapping (Server server) (IndexName indexName) + (MappingName mappingName) = + delete $ joinPath [server, indexName, mappingName, "_mapping"] + +indexDocument :: ToJSON doc => Server -> IndexName -> MappingName + -> doc -> DocId -> IO Reply +indexDocument (Server server) (IndexName indexName) + (MappingName mappingName) document (DocId docId) = + put url body + where url = joinPath [server, indexName, mappingName, docId] + body = Just (encode document) + +deleteDocument :: Server -> IndexName -> MappingName + -> DocId -> IO Reply +deleteDocument (Server server) (IndexName indexName) + (MappingName mappingName) (DocId docId) = + delete $ joinPath [server, indexName, mappingName, docId] + +bulk :: Server -> V.Vector BulkOperation -> IO Reply +bulk (Server server) bulkOps = post url body where + url = joinPath [server, "_bulk"] + body = Just $ encodeBulkOperations bulkOps + +encodeBulkOperations :: V.Vector BulkOperation -> L.ByteString +encodeBulkOperations stream = collapsed where + blobs = fmap encodeBulkOperation stream + mashedTaters = mash (mempty :: Builder) blobs + collapsed = toLazyByteString $ mappend mashedTaters (byteString "\n") + +mash :: Builder -> V.Vector L.ByteString -> Builder +mash = V.foldl' (\b x -> b `mappend` "\n" `mappend` (lazyByteString x)) + +mkBulkStreamValue :: Text -> String -> String -> String -> Value +mkBulkStreamValue operation indexName mappingName docId = + object [operation .= + object [ "_index" .= indexName + , "_type" .= mappingName + , "_id" .= docId]] + +encodeBulkOperation :: BulkOperation -> L.ByteString +encodeBulkOperation (BulkIndex (IndexName indexName) + (MappingName mappingName) + (DocId docId) value) = blob + where metadata = mkBulkStreamValue "index" indexName mappingName docId + blob = encode metadata `mappend` "\n" `mappend` encode value + +encodeBulkOperation (BulkCreate (IndexName indexName) + (MappingName mappingName) + (DocId docId) value) = blob + where metadata = mkBulkStreamValue "create" indexName mappingName docId + blob = encode metadata `mappend` "\n" `mappend` encode value + +encodeBulkOperation (BulkDelete (IndexName indexName) + (MappingName mappingName) + (DocId docId)) = blob + where metadata = mkBulkStreamValue "delete" indexName mappingName docId + blob = encode metadata + +encodeBulkOperation (BulkUpdate (IndexName indexName) + (MappingName mappingName) + (DocId docId) value) = blob + where metadata = mkBulkStreamValue "update" indexName mappingName docId + doc = object ["doc" .= value] + blob = encode metadata `mappend` "\n" `mappend` encode doc + + +getDocument :: Server -> IndexName -> MappingName + -> DocId -> IO Reply +getDocument (Server server) (IndexName indexName) + (MappingName mappingName) (DocId docId) = + get $ joinPath [server, indexName, mappingName, docId] + +documentExists :: Server -> IndexName -> MappingName + -> DocId -> IO Bool +documentExists (Server server) (IndexName indexName) + (MappingName mappingName) (DocId docId) = do + (_, exists) <- existentialQuery url + return exists where + url = joinPath [server, indexName, mappingName, docId] + +dispatchSearch :: String -> Search -> IO Reply +dispatchSearch url search = post url (Just (encode search)) + +searchAll :: Server -> Search -> IO Reply +searchAll (Server server) = dispatchSearch url where + url = joinPath [server, "_search"] + +searchByIndex :: Server -> IndexName -> Search -> IO Reply +searchByIndex (Server server) (IndexName indexName) = dispatchSearch url where + url = joinPath [server, indexName, "_search"] + +searchByType :: Server -> IndexName -> MappingName -> Search -> IO Reply +searchByType (Server server) (IndexName indexName) + (MappingName mappingName) = dispatchSearch url where + url = joinPath [server, indexName, mappingName, "_search"] + +mkSearch :: Maybe Query -> Maybe Filter -> Search +mkSearch query filter = Search query filter Nothing Nothing Nothing False 0 10 + +mkAggregateSearch :: Maybe Query -> Aggregations -> Search +mkAggregateSearch query mkSearchAggs = Search query Nothing Nothing (Just mkSearchAggs) Nothing False 0 0 + +mkHighlightSearch :: Maybe Query -> Highlights -> Search +mkHighlightSearch query searchHighlights = Search query Nothing Nothing Nothing (Just searchHighlights) False 0 10 + +pageSearch :: Int -> Int -> Search -> Search +pageSearch pageFrom pageSize search = search { from = pageFrom, size = pageSize } diff --git a/src/Database/Bloodhound/Types.hs b/src/Database/Bloodhound/Types.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Types.hs @@ -0,0 +1,2084 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE RecordWildCards #-} + +{-| Data types for describing actions and data structures performed to interact + with Elasticsearch. The two main buckets your queries against Elasticsearch + will fall into are 'Query's and 'Filter's. 'Filter's are more like + traditional database constraints and often have preferable performance + properties. 'Query's support human-written textual queries, such as fuzzy + queries. +-} + +module Database.Bloodhound.Types + ( defaultCache + , defaultIndexSettings + , halfRangeToKV + , mkSort + , rangeToKV + , showText + , unpackId + , mkMatchQuery + , mkMultiMatchQuery + , mkBoolQuery + , mkRangeQuery + , mkQueryStringQuery + , mkAggregations + , mkTermsAggregation + , mkTermsScriptAggregation + , mkDateHistogram + , toTerms + , toDateHistogram + , omitNulls + , Version(..) + , Status(..) + , Existence(..) + , NullValue(..) + , IndexSettings(..) + , Server(..) + , Reply + , EsResult(..) + , Query(..) + , Search(..) + , SearchResult(..) + , SearchHits(..) + , ShardResult(..) + , Hit(..) + , Filter(..) + , Seminearring(..) + , BoolMatch(..) + , Term(..) + , GeoPoint(..) + , GeoBoundingBoxConstraint(..) + , GeoBoundingBox(..) + , GeoFilterType(..) + , Distance(..) + , DistanceUnit(..) + , DistanceType(..) + , DistanceRange(..) + , OptimizeBbox(..) + , LatLon(..) + , Range(..) + , HalfRange(..) + , RangeExecution(..) + , LessThan(..) + , LessThanEq(..) + , GreaterThan(..) + , GreaterThanEq(..) + , Regexp(..) + , RegexpFlags(..) + , RegexpFlag(..) + , FieldName(..) + , IndexName(..) + , MappingName(..) + , DocId(..) + , CacheName(..) + , CacheKey(..) + , BulkOperation(..) + , ReplicaCount(..) + , ShardCount(..) + , Sort + , SortMode(..) + , SortOrder(..) + , SortSpec(..) + , DefaultSort(..) + , Missing(..) + , OpenCloseIndex(..) + , Method + , Boost(..) + , MatchQuery(..) + , MultiMatchQuery(..) + , BoolQuery(..) + , BoostingQuery(..) + , CommonTermsQuery(..) + , DisMaxQuery(..) + , FilteredQuery(..) + , FuzzyLikeThisQuery(..) + , FuzzyLikeFieldQuery(..) + , FuzzyQuery(..) + , HasChildQuery(..) + , HasParentQuery(..) + , IndicesQuery(..) + , MoreLikeThisQuery(..) + , MoreLikeThisFieldQuery(..) + , NestedQuery(..) + , PrefixQuery(..) + , QueryStringQuery(..) + , SimpleQueryStringQuery(..) + , RangeQuery(..) + , RegexpQuery(..) + , QueryString(..) + , BooleanOperator(..) + , ZeroTermsQuery(..) + , CutoffFrequency(..) + , Analyzer(..) + , MaxExpansions(..) + , Lenient(..) + , MatchQueryType(..) + , MultiMatchQueryType(..) + , Tiebreaker(..) + , MinimumMatch(..) + , DisableCoord(..) + , CommonMinimumMatch(..) + , MinimumMatchHighLow(..) + , PrefixLength(..) + , Fuzziness(..) + , IgnoreTermFrequency(..) + , MaxQueryTerms(..) + , ScoreType(..) + , TypeName(..) + , BoostTerms(..) + , MaxWordLength(..) + , MinWordLength(..) + , MaxDocFrequency(..) + , MinDocFrequency(..) + , PhraseSlop(..) + , StopWord(..) + , QueryPath(..) + , MinimumTermFrequency(..) + , PercentMatch(..) + , FieldDefinition(..) + , MappingField(..) + , Mapping(..) + , AllowLeadingWildcard(..) + , LowercaseExpanded(..) + , GeneratePhraseQueries(..) + , Locale(..) + , AnalyzeWildcard(..) + , EnablePositionIncrements(..) + , SimpleQueryFlag(..) + , FieldOrFields(..) + , Monoid(..) + , ToJSON(..) + , Interval(..) + , TimeInterval(..) + , ExecutionHint(..) + , CollectionMode(..) + , TermOrder(..) + , TermInclusion(..) + , Aggregation(..) + , Aggregations + , AggregationResults + , Bucket(..) + , BucketAggregation(..) + , TermsAggregation(..) + , DateHistogramAggregation(..) + + , Highlights(..) + , FieldHighlight(..) + , HighlightSettings(..) + , PlainHighlight(..) + , PostingsHighlight(..) + , FastVectorHighlight(..) + , CommonHighlight(..) + , NonPostings(..) + , HighlightEncoder(..) + , HighlightTag(..) + , HitHighlight + + , TermsResult(..) + , DateHistogramResult(..) + ) where + +import Control.Applicative +import Data.Aeson +import Data.Aeson.Types (Pair, emptyObject, parseMaybe) +import qualified Data.ByteString.Lazy.Char8 as L +import Data.List (nub) +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.Map.Strict as M +import Data.Monoid +import Data.Text (Text) +import qualified Data.Text as T +import Data.Time.Clock (UTCTime) +import qualified Data.Vector as V +import GHC.Generics (Generic) +import Network.HTTP.Client +import qualified Network.HTTP.Types.Method as NHTM + +import Database.Bloodhound.Types.Class + + +{-| 'Version' is embedded in 'Status' -} +data Version = Version { number :: Text + , build_hash :: Text + , build_timestamp :: UTCTime + , build_snapshot :: Bool + , lucene_version :: Text } deriving (Eq, Show, Generic) + +{-| '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. + + +-} + +data Status = Status { ok :: Maybe Bool + , status :: Int + , name :: Text + , version :: Version + , tagline :: Text } deriving (Eq, Show) + +{-| 'IndexSettings' is used to configure the shards and replicas when you create + an Elasticsearch Index. + + +-} + +data IndexSettings = + IndexSettings { indexShards :: ShardCount + , indexReplicas :: ReplicaCount } deriving (Eq, Show) + +{-| 'defaultIndexSettings' is an 'IndexSettings' with 3 shards and 2 replicas. -} +defaultIndexSettings :: IndexSettings +defaultIndexSettings = IndexSettings (ShardCount 3) (ReplicaCount 2) + +{-| 'Reply' and 'Method' are type synonyms from 'Network.HTTP.Types.Method.Method' -} +type Reply = Network.HTTP.Client.Response L.ByteString +type Method = NHTM.Method + +{-| 'OpenCloseIndex' is a sum type for opening and closing indices. + + +-} +data OpenCloseIndex = OpenIndex | CloseIndex deriving (Eq, Show) + +data FieldType = GeoPointType + | GeoShapeType + | FloatType + | IntegerType + | LongType + | ShortType + | ByteType deriving (Eq, Show) + +data FieldDefinition = + FieldDefinition { fieldType :: FieldType } deriving (Eq, Show) + +data MappingField = + MappingField { mappingFieldName :: FieldName + , fieldDefinition :: FieldDefinition } deriving (Eq, Show) + +{-| Support for type reification of 'Mapping's is currently incomplete, for + now the mapping API verbiage expects a 'ToJSON'able blob. + + Indexes have mappings, mappings are schemas for the documents contained in the + index. I'd recommend having only one mapping per index, always having a mapping, + and keeping different kinds of documents separated if possible. +-} +data Mapping = Mapping { typeName :: TypeName + , mappingFields :: [MappingField] } deriving (Eq, Show) + +{-| 'BulkOperation' is a sum type for expressing the four kinds of bulk + operation index, create, delete, and update. 'BulkIndex' behaves like an + "upsert", 'BulkCreate' will fail if a document already exists at the DocId. + + +-} +data BulkOperation = + BulkIndex IndexName MappingName DocId Value + | BulkCreate IndexName MappingName DocId Value + | BulkDelete IndexName MappingName DocId + | BulkUpdate IndexName MappingName DocId Value deriving (Eq, Show) + +{-| 'EsResult' describes the standard wrapper JSON document that you see in + successful Elasticsearch responses. +-} +data EsResult a = EsResult { _index :: Text + , _type :: Text + , _id :: Text + , _version :: Int + , found :: Maybe Bool + , _source :: a } deriving (Eq, Show) + +{-| '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) + +{-| '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) + +{-| '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) + +{-| 'mkSort' defaults everything but the 'FieldName' and the 'SortOrder' so + that you can concisely describe the usual kind of 'SortSpec's you want. +-} +mkSort :: FieldName -> SortOrder -> DefaultSort +mkSort fieldName sOrder = DefaultSort fieldName sOrder False Nothing Nothing Nothing + +{-| 'Cache' is for telling ES whether it should cache a 'Filter' not. + 'Query's cannot be cached. +-} +type Cache = Bool -- caching on/off +defaultCache :: Cache +defaultCache = False + +{-| 'PrefixValue' is used in 'PrefixQuery' as the main query component. +-} +type PrefixValue = Text + +{-| '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) + +{-| 'ShardCount' is part of 'IndexSettings' +-} +newtype ShardCount = ShardCount Int deriving (Eq, Show, Generic) + +{-| 'ReplicaCount' is part of 'IndexSettings' +-} +newtype ReplicaCount = ReplicaCount Int deriving (Eq, Show, Generic) + +{-| 'Server' is used with the client functions to point at the ES instance +-} +newtype Server = Server String deriving (Eq, Show) + +{-| 'IndexName' is used to describe which index to query/create/delete +-} +newtype IndexName = IndexName String deriving (Eq, Generic, Show) + +{-| 'MappingName' is part of mappings which are how ES describes and schematizes + the data in the indices. +-} +newtype MappingName = MappingName String deriving (Eq, Generic, Show) + +{-| '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 String deriving (Eq, Generic, Show) + +{-| 'QueryString' is used to wrap query text bodies, be they human written or not. +-} +newtype QueryString = QueryString Text deriving (Eq, Generic, Show) + +{-| '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, Show) + +{-| 'CacheName' is used in 'RegexpFilter' for describing the + 'CacheKey' keyed caching behavior. +-} +newtype CacheName = CacheName Text deriving (Eq, Show) + +{-| 'CacheKey' is used in 'RegexpFilter' to key regex caching. +-} +newtype CacheKey = + CacheKey Text deriving (Eq, Show) +newtype Existence = + Existence Bool deriving (Eq, Show) +newtype NullValue = + NullValue Bool deriving (Eq, Show) +newtype CutoffFrequency = + CutoffFrequency Double deriving (Eq, Show, Generic) +newtype Analyzer = + Analyzer Text deriving (Eq, Show, Generic) +newtype MaxExpansions = + MaxExpansions Int deriving (Eq, Show, Generic) + +{-| '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, Generic) +newtype Tiebreaker = + Tiebreaker Double deriving (Eq, Show, Generic) +newtype Boost = + Boost Double deriving (Eq, Show, Generic) +newtype BoostTerms = + BoostTerms Double deriving (Eq, Show, Generic) + +{-| '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, Generic) +newtype MinimumMatchText = + MinimumMatchText Text deriving (Eq, Show) +newtype DisableCoord = + DisableCoord Bool deriving (Eq, Show, Generic) +newtype IgnoreTermFrequency = + IgnoreTermFrequency Bool deriving (Eq, Show, Generic) +newtype MinimumTermFrequency = + MinimumTermFrequency Int deriving (Eq, Show, Generic) +newtype MaxQueryTerms = + MaxQueryTerms Int deriving (Eq, Show, Generic) +newtype Fuzziness = + Fuzziness Double deriving (Eq, Show, Generic) + +{-| 'PrefixLength' is the prefix length used in queries, defaults to 0. -} +newtype PrefixLength = + PrefixLength Int deriving (Eq, Show, Generic) +newtype TypeName = + TypeName Text deriving (Eq, Show, Generic) +newtype PercentMatch = + PercentMatch Double deriving (Eq, Show, Generic) +newtype StopWord = + StopWord Text deriving (Eq, Show, Generic) +newtype QueryPath = + QueryPath Text deriving (Eq, Show, Generic) + +{-| 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, Generic) +newtype LowercaseExpanded = + LowercaseExpanded Bool deriving (Eq, Show, Generic) +newtype EnablePositionIncrements = + EnablePositionIncrements Bool deriving (Eq, Show, Generic) + +{-| 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, Generic) + +{-| 'GeneratePhraseQueries' defaults to false. +-} +newtype GeneratePhraseQueries = + GeneratePhraseQueries Bool deriving (Eq, Show, Generic) + +{-| 'Locale' is used for string conversions - defaults to ROOT. +-} +newtype Locale = Locale Text deriving (Eq, Show, Generic) +newtype MaxWordLength = MaxWordLength Int deriving (Eq, Show, Generic) +newtype MinWordLength = MinWordLength Int deriving (Eq, Show, Generic) + +{-| 'PhraseSlop' sets the default slop for phrases, 0 means exact + phrase matches. Default is 0. +-} +newtype PhraseSlop = PhraseSlop Int deriving (Eq, Show, Generic) +newtype MinDocFrequency = MinDocFrequency Int deriving (Eq, Show, Generic) +newtype MaxDocFrequency = MaxDocFrequency Int deriving (Eq, Show, Generic) + +{-| 'unpackId' is a silly convenience function that gets used once. +-} +unpackId :: DocId -> String +unpackId (DocId docId) = docId + +type TrackSortScores = Bool +type From = Int +type Size = Int + +data Search = Search { queryBody :: Maybe Query + , filterBody :: Maybe Filter + , sortBody :: Maybe Sort + , aggBody :: Maybe Aggregations + , highlight :: Maybe Highlights + -- default False + , trackSortScores :: TrackSortScores + , from :: From + , size :: Size } deriving (Eq, Show) + +data Highlights = Highlights { globalsettings :: Maybe HighlightSettings + , highlightFields :: [FieldHighlight] + } deriving (Show, Eq) + +data FieldHighlight = FieldHighlight FieldName (Maybe HighlightSettings) + deriving (Show, Eq) + + +data HighlightSettings = Plain PlainHighlight + | Postings PostingsHighlight + | FastVector FastVectorHighlight + deriving (Show, Eq) +data PlainHighlight = + PlainHighlight { plainCommon :: Maybe CommonHighlight + , plainNonPost :: Maybe NonPostings } deriving (Show, Eq) + + -- This requires that index_options are set to 'offset' in the mapping. +data PostingsHighlight = PostingsHighlight (Maybe CommonHighlight) deriving (Show, Eq) + +-- This requires that term_vector is set to 'with_positions_offsets' in the mapping. +data FastVectorHighlight = + FastVectorHighlight { fvCommon :: Maybe CommonHighlight + , fvNonPostSettings :: Maybe NonPostings + , boundaryChars :: Maybe Text + , boundaryMaxScan :: Maybe Int + , fragmentOffset :: Maybe Int + , matchedFields :: [Text] + , phraseLimit :: Maybe Int + } deriving (Show, Eq) + +data CommonHighlight = + CommonHighlight { order :: Maybe Text + , forceSource :: Maybe Bool + , tag :: Maybe HighlightTag + , encoder :: Maybe HighlightEncoder + , noMatchSize :: Maybe Int + , highlightQuery :: Maybe Query + , requireFieldMatch :: Maybe Bool + } deriving (Show, Eq) + +-- Settings that are only applicable to FastVector and Plain highlighters. +data NonPostings = + NonPostings { fragmentSize :: Maybe Int + , numberOfFragments :: Maybe Int} deriving (Show, Eq) + +data HighlightEncoder = DefaultEncoder + | HTMLEncoder + deriving (Show, Eq) + +-- NOTE: Should the tags use some kind of HTML type, rather than Text? +data HighlightTag = TagSchema Text + | CustomTags ([Text], [Text]) -- Only uses more than the first value in the lists if fvh + deriving (Show, Eq) + + +data Query = + TermQuery Term (Maybe Boost) + | TermsQuery [Term] MinimumMatch + | 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 + deriving (Eq, Show) + +data RegexpQuery = + RegexpQuery { regexpQueryField :: FieldName + , regexpQuery :: Regexp + , regexpQueryFlags :: RegexpFlags + , regexpQueryBoost :: Maybe Boost + } deriving (Eq, Show) + +data RangeQuery = + RangeQuery { rangeQueryField :: FieldName + , rangeQueryRange :: Either HalfRange Range + , rangeQueryBoost :: Boost } deriving (Eq, Show) + +mkRangeQuery :: FieldName -> Either HalfRange Range -> 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 [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 [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 [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 [FieldName] + -- default 0.3 (30%) + , moreLikeThisPercentMatch :: Maybe PercentMatch + , moreLikeThisMinimumTermFreq :: Maybe MinimumTermFrequency + , moreLikeThisMaxQueryTerms :: Maybe MaxQueryTerms + , moreLikeThisStopWords :: Maybe [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 } 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 + +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 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 + | RangeFilter FieldName (Either HalfRange Range) RangeExecution Cache + | RegexpFilter FieldName Regexp RegexpFlags CacheName Cache CacheKey + | TermFilter Term Cache + deriving (Eq, Show) + +data ZeroTermsQuery = ZeroTermsNone + | ZeroTermsAll deriving (Eq, Show) + +-- lt, lte | gt, gte +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) + +data HalfRange = HalfRangeLt LessThan + | HalfRangeLte LessThanEq + | HalfRangeGt GreaterThan + | HalfRangeGte GreaterThanEq deriving (Eq, Show) + +data Range = RangeLtGt LessThan GreaterThan + | RangeLtGte LessThan GreaterThanEq + | RangeLteGt LessThanEq GreaterThan + | RangeLteGte LessThanEq GreaterThanEq deriving (Eq, Show) + +data RangeExecution = RangeExecutionIndex + | RangeExecutionFielddata deriving (Eq, Show) + +newtype Regexp = Regexp Text deriving (Eq, Show) + +data RegexpFlags = AllRegexpFlags + | NoRegexpFlags + | SomeRegexpFlags (NonEmpty RegexpFlag) deriving (Eq, Show) + +data RegexpFlag = AnyString + | Automaton + | Complement + | Empty + | Intersection + | Interval deriving (Eq, Show) + +halfRangeToKV :: HalfRange -> (Text, Double) +halfRangeToKV (HalfRangeLt (LessThan n)) = ("lt", n) +halfRangeToKV (HalfRangeLte (LessThanEq n)) = ("lte", n) +halfRangeToKV (HalfRangeGt (GreaterThan n)) = ("gt", n) +halfRangeToKV (HalfRangeGte (GreaterThanEq n)) = ("gte", n) + +rangeToKV :: Range -> (Text, Double, Text, Double) +rangeToKV (RangeLtGt (LessThan m) (GreaterThan n)) = ("lt", m, "gt", n) +rangeToKV (RangeLtGte (LessThan m) (GreaterThanEq n)) = ("lt", m, "gte", n) +rangeToKV (RangeLteGt (LessThanEq m) (GreaterThan n)) = ("lte", m, "gt", n) +rangeToKV (RangeLteGte (LessThanEq m) (GreaterThanEq n)) = ("lte", m, "gte", n) + +-- phew. Coulda used Agda style case breaking there but, you know, whatever. :) + +data Term = Term { termField :: Text + , termValue :: Text } deriving (Eq, Show) + +data BoolMatch = MustMatch Term Cache + | MustNotMatch Term Cache + | ShouldMatch [Term] Cache deriving (Eq, Show) + +-- "memory" or "indexed" +data GeoFilterType = GeoFilterMemory + | GeoFilterIndexed deriving (Eq, Show) + +data LatLon = LatLon { lat :: Double + , lon :: Double } deriving (Eq, Show) + +data GeoBoundingBox = + GeoBoundingBox { topLeft :: LatLon + , bottomRight :: LatLon } deriving (Eq, Show) + +data GeoBoundingBoxConstraint = + GeoBoundingBoxConstraint { geoBBField :: FieldName + , constraintBox :: GeoBoundingBox + , bbConstraintcache :: Cache + , geoType :: GeoFilterType + } deriving (Eq, Show) + +data GeoPoint = + GeoPoint { geoField :: FieldName + , latLon :: LatLon} deriving (Eq, Show) + +data DistanceUnit = Miles + | Yards + | Feet + | Inches + | Kilometers + | Meters + | Centimeters + | Millimeters + | NauticalMiles deriving (Eq, Show) + +data DistanceType = Arc + | SloppyArc -- doesn't exist <1.0 + | Plane 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) + +data (FromJSON a) => SearchResult a = + SearchResult { took :: Int + , timedOut :: Bool + , shards :: ShardResult + , searchHits :: SearchHits a + , aggregations :: Maybe AggregationResults } deriving (Eq, Show) + +type Score = Double + +data (FromJSON a) => SearchHits a = + SearchHits { hitsTotal :: Int + , maxScore :: Score + , hits :: [Hit a] } deriving (Eq, Show) + +data (FromJSON a) => Hit a = + Hit { hitIndex :: IndexName + , hitType :: MappingName + , hitDocId :: DocId + , hitScore :: Score + , hitSource :: a + , hitHighlight :: Maybe HitHighlight } deriving (Eq, Show) + +data ShardResult = + ShardResult { shardTotal :: Int + , shardsSuccessful :: Int + , shardsFailed :: Int } deriving (Eq, Show, Generic) + +type HitHighlight = M.Map Text [Text] + +showText :: Show a => a -> Text +showText = T.pack . show + +type Aggregations = M.Map Text Aggregation + +emptyAggregations :: Aggregations +emptyAggregations = M.empty + +mkAggregations :: Text -> Aggregation -> Aggregations +mkAggregations name aggregation = M.insert name aggregation emptyAggregations + +data TermOrder = TermOrder{ termSortField :: Text + , termSortOrder :: SortOrder } deriving (Eq, Show) + +data TermInclusion = TermInclusion Text + | TermPattern Text Text deriving (Eq, Show) + +data CollectionMode = BreadthFirst + | DepthFirst deriving (Eq, Show) + +data ExecutionHint = Ordinals + | GlobalOrdinals + | GlobalOrdinalsHash + | GlobalOrdinalsLowCardinality + | Map deriving (Eq, Show) + +data TimeInterval = Weeks + | Days + | Hours + | Minutes + | Seconds deriving (Eq) + +data Interval = Year + | Quarter + | Month + | Week + | Day + | Hour + | Minute + | Second + | FractionalInterval Float TimeInterval deriving (Eq, Show) + +data Aggregation = TermsAgg TermsAggregation + | DateHistogramAgg DateHistogramAggregation deriving (Eq, Show) + + +data TermsAggregation = TermsAggregation { term :: Either Text Text + , termInclude :: Maybe TermInclusion + , termExclude :: Maybe TermInclusion + , termOrder :: Maybe TermOrder + , termMinDocCount :: Maybe Int + , termSize :: Maybe Int + , termShardSize :: Maybe Int + , termCollectMode :: Maybe CollectionMode + , termExecutionHint :: Maybe ExecutionHint + , termAggs :: Maybe Aggregations + } deriving (Eq, Show) + +data DateHistogramAggregation = DateHistogramAggregation { dateField :: FieldName + , dateInterval :: Interval + , dateFormat :: Maybe Text + , datePreZone :: Maybe Text + , datePostZone :: Maybe Text + , datePreOffset :: Maybe Text + , datePostOffset :: Maybe Text + , dateAggs :: Maybe Aggregations + } deriving (Eq, Show) + + +mkTermsAggregation :: Text -> TermsAggregation +mkTermsAggregation t = TermsAggregation (Left t) Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing + +mkTermsScriptAggregation :: Text -> TermsAggregation +mkTermsScriptAggregation t = TermsAggregation (Right t) Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing + +mkDateHistogram :: FieldName -> Interval -> DateHistogramAggregation +mkDateHistogram t i = DateHistogramAggregation t i Nothing Nothing Nothing Nothing Nothing Nothing + +instance ToJSON TermOrder where + toJSON (TermOrder termSortField termSortOrder) = object [termSortField .= termSortOrder] + +instance ToJSON TermInclusion where + toJSON (TermInclusion x) = toJSON x + toJSON (TermPattern pattern flags) = omitNulls [ "pattern" .= pattern, + "flags" .= flags] + +instance ToJSON CollectionMode where + toJSON BreadthFirst = "breadth_first" + toJSON DepthFirst = "depth_first" + +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" + +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" + toJSON (FractionalInterval fraction interval) = toJSON $ show fraction ++ show interval + +instance Show TimeInterval where + show Weeks = "w" + show Days = "d" + show Hours = "h" + show Minutes = "m" + show Seconds = "s" + +instance ToJSON Aggregation where + toJSON (TermsAgg (TermsAggregation term include exclude order minDocCount size shardSize collectMode executionHint termAggs)) = + omitNulls ["terms" .= omitNulls [ toJSON' term, + "include" .= toJSON include, + "exclude" .= toJSON exclude, + "order" .= toJSON order, + "min_doc_count" .= toJSON minDocCount, + "size" .= toJSON size, + "shard_size" .= toJSON shardSize, + "collect_mode" .= toJSON collectMode, + "execution_hint" .= toJSON executionHint + ], + "aggs" .= toJSON termAggs ] + where + toJSON' x = case x of { Left y -> "field" .= toJSON y; Right y -> "script" .= toJSON y } + + toJSON (DateHistogramAgg (DateHistogramAggregation field interval format preZone postZone preOffset postOffset dateHistoAggs)) = + omitNulls ["date_histogram" .= omitNulls [ "field" .= toJSON field, + "interval" .= toJSON interval, + "format" .= toJSON format, + "pre_zone" .= toJSON preZone, + "post_zone" .= toJSON postZone, + "pre_offset" .= toJSON preOffset, + "post_offset" .= toJSON postOffset + ], + "aggs" .= toJSON dateHistoAggs ] + +type AggregationResults = M.Map Text Value + +class BucketAggregation a where + key :: a -> Text + docCount :: a -> Int + aggs :: a -> Maybe AggregationResults + + +data (FromJSON a, BucketAggregation a) => Bucket a = Bucket { buckets :: [a]} deriving (Show) + +data TermsResult = TermsResult { termKey :: Text + , termsDocCount :: Int + , termsAggs :: Maybe AggregationResults } deriving (Show) + +data DateHistogramResult = DateHistogramResult { dateKey :: Int + , dateKeyStr :: Maybe Text + , dateDocCount :: Int + , dateHistogramAggs :: Maybe AggregationResults } deriving (Show) + +toTerms :: Text -> AggregationResults -> Maybe (Bucket TermsResult) +toTerms t a = M.lookup t a >>= deserialize + where deserialize = parseMaybe parseJSON + +toDateHistogram :: Text -> AggregationResults -> Maybe (Bucket DateHistogramResult) +toDateHistogram t a = M.lookup t a >>= deserialize + where deserialize = parseMaybe parseJSON + +instance BucketAggregation TermsResult where + key = termKey + docCount = termsDocCount + aggs = termsAggs + +instance BucketAggregation DateHistogramResult where + key = showText . dateKey + docCount = dateDocCount + aggs = dateHistogramAggs + +instance (FromJSON a, BucketAggregation a) => FromJSON (Bucket a) where + parseJSON (Object v) = Bucket <$> + v .: "buckets" + parseJSON _ = mempty + +instance FromJSON TermsResult where + parseJSON (Object v) = TermsResult <$> + v .: "key" <*> + v .: "doc_count" <*> + v .:? "aggregations" + parseJSON _ = mempty + +instance FromJSON DateHistogramResult where + parseJSON (Object v) = DateHistogramResult <$> + v .: "key" <*> + v .:? "key_as_string" <*> + v .: "doc_count" <*> + v .:? "aggregations" + parseJSON _ = mempty + +instance Monoid Filter where + mempty = IdentityFilter + mappend a b = AndFilter [a, b] defaultCache + +instance Seminearring Filter where + a <||> b = OrFilter [a, b] defaultCache + +instance ToJSON Filter where + toJSON (AndFilter filters cache) = + object ["and" .= + object [ "filters" .= fmap toJSON filters + , "_cache" .= cache]] + + toJSON (OrFilter filters cache) = + object ["or" .= fmap toJSON filters + , "_cache" .= cache] + + toJSON (NotFilter notFilter cache) = + object ["not" .= + object ["filter" .= toJSON 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" .= toJSON boolMatch] + + toJSON (GeoBoundingBoxFilter bbConstraint) = + object ["geo_bounding_box" .= toJSON bbConstraint] + + toJSON (GeoDistanceFilter (GeoPoint (FieldName distanceGeoField) geoDistLatLon) + distance distanceType optimizeBbox cache) = + object ["geo_distance" .= + object ["distance" .= toJSON distance + , "distance_type" .= toJSON distanceType + , "optimize_bbox" .= optimizeBbox + , distanceGeoField .= toJSON geoDistLatLon + , "_cache" .= cache]] + + toJSON (GeoDistanceRangeFilter (GeoPoint (FieldName gddrField) drLatLon) + (DistanceRange geoDistRangeDistFrom drDistanceTo)) = + object ["geo_distance_range" .= + object ["from" .= toJSON geoDistRangeDistFrom + , "to" .= toJSON drDistanceTo + , gddrField .= toJSON 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 (T.pack . unpackId) values]] + + toJSON (LimitFilter limit) = + object ["limit" .= object ["value" .= limit]] + + toJSON (MissingFilter (FieldName fieldName) (Existence existence) (NullValue nullValue)) = + object ["missing" .= + object ["field" .= fieldName + , "existence" .= existence + , "null_value" .= nullValue]] + + toJSON (PrefixFilter (FieldName fieldName) fieldValue cache) = + object ["prefix" .= + object [fieldName .= fieldValue + , "_cache" .= cache]] + + toJSON (RangeFilter (FieldName fieldName) (Left halfRange) rangeExecution cache) = + object ["range" .= + object [fieldName .= + object [rqFKey .= rqFVal] + , "execution" .= toJSON rangeExecution + , "_cache" .= cache]] + where + (rqFKey, rqFVal) = halfRangeToKV halfRange + + toJSON (RangeFilter (FieldName fieldName) (Right range) rangeExecution cache) = + object ["range" .= + object [fieldName .= + object [lessKey .= lessVal + , greaterKey .= greaterVal] + , "execution" .= toJSON rangeExecution + , "_cache" .= cache]] + where + (lessKey, lessVal, greaterKey, greaterVal) = rangeToKV range + + toJSON (RegexpFilter (FieldName fieldName) + (Regexp regexText) flags (CacheName cacheName) cache (CacheKey cacheKey)) = + object ["regexp" .= + object [fieldName .= + object ["value" .= regexText + , "flags" .= toJSON flags] + , "_name" .= cacheName + , "_cache" .= cache + , "_cache_key" .= cacheKey]] + +instance ToJSON GeoPoint where + toJSON (GeoPoint (FieldName geoPointField) geoPointLatLon) = + object [ geoPointField .= toJSON geoPointLatLon ] + + +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 terms termsQueryMinimumMatch) = + object [ "terms" .= object conjoined ] + where conjoined = + [ "tags" .= fmap toJSON terms + , "minimum_should_match" .= toJSON termsQueryMinimumMatch ] + + toJSON (IdsQuery idsQueryMappingName docIds) = + object [ "ids" .= object conjoined ] + where conjoined = [ "type" .= toJSON idsQueryMappingName + , "values" .= fmap toJSON docIds ] + + toJSON (QueryQueryStringQuery qQueryStringQuery) = + object [ "query_string" .= toJSON qQueryStringQuery ] + + toJSON (QueryMatchQuery matchQuery) = + object [ "match" .= toJSON matchQuery ] + + toJSON (QueryMultiMatchQuery multiMatchQuery) = + toJSON multiMatchQuery + + toJSON (QueryBoolQuery boolQuery) = + object [ "bool" .= toJSON boolQuery ] + + toJSON (QueryBoostingQuery boostingQuery) = + object [ "boosting" .= toJSON boostingQuery ] + + toJSON (QueryCommonTermsQuery commonTermsQuery) = + object [ "common" .= toJSON commonTermsQuery ] + + toJSON (ConstantScoreFilter csFilter boost) = + object [ "constant_score" .= toJSON csFilter + , "boost" .= toJSON boost] + + toJSON (ConstantScoreQuery query boost) = + object [ "constant_score" .= toJSON query + , "boost" .= toJSON boost] + + toJSON (QueryDisMaxQuery disMaxQuery) = + object [ "dis_max" .= toJSON disMaxQuery ] + + toJSON (QueryFilteredQuery qFilteredQuery) = + object [ "filtered" .= toJSON qFilteredQuery ] + + toJSON (QueryFuzzyLikeThisQuery fuzzyQuery) = + object [ "fuzzy_like_this" .= toJSON fuzzyQuery ] + + toJSON (QueryFuzzyLikeFieldQuery fuzzyFieldQuery) = + object [ "fuzzy_like_this_field" .= toJSON fuzzyFieldQuery ] + + toJSON (QueryFuzzyQuery fuzzyQuery) = + object [ "fuzzy" .= toJSON fuzzyQuery ] + + toJSON (QueryHasChildQuery childQuery) = + object [ "has_child" .= toJSON childQuery ] + + toJSON (QueryHasParentQuery parentQuery) = + object [ "has_parent" .= toJSON parentQuery ] + + toJSON (QueryIndicesQuery qIndicesQuery) = + object [ "indices" .= toJSON qIndicesQuery ] + + toJSON (MatchAllQuery boost) = + object [ "match_all" .= omitNulls [ "boost" .= boost ] ] + + toJSON (QueryMoreLikeThisQuery query) = + object [ "more_like_this" .= toJSON query ] + + toJSON (QueryMoreLikeThisFieldQuery query) = + object [ "more_like_this_field" .= toJSON query ] + + toJSON (QueryNestedQuery query) = + object [ "nested" .= toJSON query ] + + toJSON (QueryPrefixQuery query) = + object [ "prefix" .= toJSON query ] + + toJSON (QueryRangeQuery query) = + object [ "range" .= toJSON query ] + + toJSON (QueryRegexpQuery query) = + object [ "regexp" .= toJSON query ] + + toJSON (QuerySimpleQueryStringQuery query) = + object [ "simple_query_string" .= toJSON query ] + + +omitNulls :: [(Text, Value)] -> Value +omitNulls = object . filter notNull where + notNull (_, Null) = False + notNull (_, (Array a)) = (not . V.null) a + notNull _ = True + + +instance ToJSON SimpleQueryStringQuery where + toJSON SimpleQueryStringQuery {..} = + omitNulls (base ++ maybeAdd) + where base = [ "query" .= toJSON simpleQueryStringQuery ] + maybeAdd = [ "fields" .= simpleQueryStringField + , "default_operator" .= simpleQueryStringOperator + , "analyzer" .= simpleQueryStringAnalyzer + , "flags" .= simpleQueryStringFlags + , "lowercase_expanded_terms" .= simpleQueryStringLowercaseExpanded + , "locale" .= simpleQueryStringLocale ] + + +instance ToJSON FieldOrFields where + toJSON (FofField fieldName) = + toJSON fieldName + toJSON (FofFields fieldNames) = + toJSON fieldNames + +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 ToJSON RegexpQuery where + toJSON (RegexpQuery (FieldName rqQueryField) + (Regexp regexpQueryQuery) rqQueryFlags + rqQueryBoost) = + object [ rqQueryField .= omitNulls base ] + where base = [ "value" .= regexpQueryQuery + , "flags" .= toJSON rqQueryFlags + , "boost" .= rqQueryBoost ] + + +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" .= toJSON 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 ToJSON RangeQuery where + toJSON (RangeQuery (FieldName fieldName) (Right range) boost) = + object [ fieldName .= conjoined ] + where conjoined = [ "boost" .= toJSON boost + , lessKey .= lessVal + , greaterKey .= greaterVal ] + (lessKey, lessVal, greaterKey, greaterVal) = rangeToKV range + + toJSON (RangeQuery (FieldName fieldName) (Left halfRange) boost) = + object [ fieldName .= conjoined ] + where conjoined = [ "boost" .= toJSON boost + , rqKey .= rqVal ] + (rqKey, rqVal) = halfRangeToKV halfRange + + +instance ToJSON PrefixQuery where + toJSON (PrefixQuery (FieldName fieldName) queryValue boost) = + object [ fieldName .= omitNulls base ] + where base = [ "value" .= toJSON queryValue + , "boost" .= boost ] + + +instance ToJSON NestedQuery where + toJSON (NestedQuery nqPath nqScoreType nqQuery) = + object [ "path" .= toJSON nqPath + , "score_mode" .= toJSON nqScoreType + , "query" .= toJSON nqQuery ] + + +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" .= toJSON 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 ToJSON MoreLikeThisQuery where + toJSON (MoreLikeThisQuery text fields percent + mtf mqt stopwords mindf maxdf + minwl maxwl boostTerms boost analyzer) = + omitNulls base + where base = [ "like_text" .= toJSON 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 ToJSON IndicesQuery where + toJSON (IndicesQuery indices query noMatch) = + omitNulls [ "indices" .= toJSON indices + , "no_match_query" .= toJSON noMatch + , "query" .= toJSON query ] + + +instance ToJSON HasParentQuery where + toJSON (HasParentQuery queryType query scoreType) = + omitNulls [ "parent_type" .= toJSON queryType + , "score_type" .= toJSON scoreType + , "query" .= toJSON query ] + + +instance ToJSON HasChildQuery where + toJSON (HasChildQuery queryType query scoreType) = + omitNulls [ "query" .= toJSON query + , "score_type" .= toJSON scoreType + , "type" .= toJSON queryType ] + + +instance ToJSON FuzzyQuery where + toJSON (FuzzyQuery (FieldName fieldName) queryText + prefixLength maxEx fuzziness boost) = + object [ fieldName .= omitNulls base ] + where base = [ "value" .= toJSON queryText + , "fuzziness" .= toJSON fuzziness + , "prefix_length" .= toJSON prefixLength + , "boost" .= toJSON boost + , "max_expansions" .= toJSON maxEx ] + + +instance ToJSON FuzzyLikeFieldQuery where + toJSON (FuzzyLikeFieldQuery (FieldName fieldName) + fieldText maxTerms ignoreFreq fuzziness prefixLength + boost analyzer) = + object [ fieldName .= + omitNulls [ "like_text" .= toJSON fieldText + , "max_query_terms" .= toJSON maxTerms + , "ignore_tf" .= toJSON ignoreFreq + , "fuzziness" .= toJSON fuzziness + , "prefix_length" .= toJSON prefixLength + , "analyzer" .= toJSON analyzer + , "boost" .= toJSON boost ]] + + +instance ToJSON FuzzyLikeThisQuery where + toJSON (FuzzyLikeThisQuery fields text maxTerms + ignoreFreq fuzziness prefixLength boost analyzer) = + omitNulls base + where base = [ "fields" .= toJSON fields + , "like_text" .= toJSON text + , "max_query_terms" .= toJSON maxTerms + , "ignore_tf" .= toJSON ignoreFreq + , "fuzziness" .= toJSON fuzziness + , "prefix_length" .= toJSON prefixLength + , "analyzer" .= toJSON analyzer + , "boost" .= toJSON boost ] + + +instance ToJSON FilteredQuery where + toJSON (FilteredQuery query fFilter) = + object [ "query" .= toJSON query + , "filter" .= toJSON fFilter ] + + +instance ToJSON DisMaxQuery where + toJSON (DisMaxQuery queries tiebreaker boost) = + omitNulls base + where base = [ "queries" .= toJSON queries + , "boost" .= toJSON boost + , "tie_breaker" .= toJSON tiebreaker ] + + +instance ToJSON CommonTermsQuery where + toJSON (CommonTermsQuery (FieldName fieldName) + (QueryString query) cf lfo hfo msm + boost analyzer disableCoord) = + object [fieldName .= omitNulls base ] + where base = [ "query" .= toJSON query + , "cutoff_frequency" .= toJSON cf + , "low_freq_operator" .= toJSON lfo + , "minimum_should_match" .= toJSON msm + , "boost" .= toJSON boost + , "analyzer" .= toJSON analyzer + , "disable_coord" .= toJSON disableCoord + , "high_freq_operator" .= toJSON hfo ] + + +instance ToJSON CommonMinimumMatch where + toJSON (CommonMinimumMatch mm) = toJSON mm + toJSON (CommonMinimumMatchHighLow (MinimumMatchHighLow lowF highF)) = + object [ "low_freq" .= toJSON lowF + , "high_freq" .= toJSON highF ] + +instance ToJSON BoostingQuery where + toJSON (BoostingQuery bqPositiveQuery bqNegativeQuery bqNegativeBoost) = + object [ "positive" .= toJSON bqPositiveQuery + , "negative" .= toJSON bqNegativeQuery + , "negative_boost" .= toJSON bqNegativeBoost ] + + +instance ToJSON BoolQuery where + toJSON (BoolQuery mustM notM shouldM bqMin boost disableCoord) = + omitNulls base + where base = [ "must" .= toJSON mustM + , "must_not" .= toJSON notM + , "should" .= toJSON shouldM + , "minimum_should_match" .= toJSON bqMin + , "boost" .= toJSON boost + , "disable_coord" .= toJSON disableCoord ] + + +instance ToJSON MatchQuery where + toJSON (MatchQuery (FieldName fieldName) + (QueryString mqQueryString) booleanOperator + zeroTermsQuery cutoffFrequency matchQueryType + analyzer maxExpansions lenient) = + object [ fieldName .= omitNulls base ] + where base = [ "query" .= mqQueryString + , "operator" .= toJSON booleanOperator + , "zero_terms_query" .= toJSON zeroTermsQuery + , "cutoff_frequency" .= toJSON cutoffFrequency + , "type" .= toJSON matchQueryType + , "analyzer" .= toJSON analyzer + , "max_expansions" .= toJSON maxExpansions + , "lenient" .= toJSON lenient ] + + +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" .= toJSON boolOp + , "zero_terms_query" .= toJSON ztQ + , "tiebreaker" .= toJSON tb + , "type" .= toJSON mmqt + , "cutoff_frequency" .= toJSON cf + , "analyzer" .= toJSON analyzer + , "max_expansions" .= toJSON maxEx + , "lenient" .= toJSON lenient ] + + +instance ToJSON MultiMatchQueryType where + toJSON MultiMatchBestFields = "best_fields" + toJSON MultiMatchMostFields = "most_fields" + toJSON MultiMatchCrossFields = "cross_fields" + toJSON MultiMatchPhrase = "phrase" + toJSON MultiMatchPhrasePrefix = "phrase_prefix" + +instance ToJSON BooleanOperator where + toJSON And = String "and" + toJSON Or = String "or" + +instance ToJSON ZeroTermsQuery where + toJSON ZeroTermsNone = String "none" + toJSON ZeroTermsAll = String "all" + +instance ToJSON MatchQueryType where + toJSON MatchPhrase = "phrase" + toJSON MatchPhrasePrefix = "phrase_prefix" + +instance ToJSON FieldName where + toJSON (FieldName fieldName) = String fieldName + +instance ToJSON ReplicaCount +instance ToJSON ShardCount +instance ToJSON CutoffFrequency +instance ToJSON Analyzer +instance ToJSON MaxExpansions +instance ToJSON Lenient +instance ToJSON Boost +instance ToJSON Version +instance ToJSON Tiebreaker +instance ToJSON MinimumMatch +instance ToJSON DisableCoord +instance ToJSON PrefixLength +instance ToJSON Fuzziness +instance ToJSON IgnoreTermFrequency +instance ToJSON MaxQueryTerms +instance ToJSON TypeName +instance ToJSON IndexName +instance ToJSON BoostTerms +instance ToJSON MaxWordLength +instance ToJSON MinWordLength +instance ToJSON MaxDocFrequency +instance ToJSON MinDocFrequency +instance ToJSON PhraseSlop +instance ToJSON StopWord +instance ToJSON QueryPath +instance ToJSON MinimumTermFrequency +instance ToJSON PercentMatch +instance ToJSON MappingName +instance ToJSON DocId +instance ToJSON QueryString +instance ToJSON AllowLeadingWildcard +instance ToJSON LowercaseExpanded +instance ToJSON AnalyzeWildcard +instance ToJSON GeneratePhraseQueries +instance ToJSON Locale +instance ToJSON EnablePositionIncrements +instance FromJSON Version +instance FromJSON IndexName +instance FromJSON MappingName +instance FromJSON DocId + + +instance FromJSON Status where + parseJSON (Object v) = Status <$> + v .:? "ok" <*> + v .: "status" <*> + v .: "name" <*> + v .: "version" <*> + v .: "tagline" + parseJSON _ = empty + + +instance ToJSON IndexSettings where + toJSON (IndexSettings s r) = object ["settings" .= object ["shards" .= s, "replicas" .= r]] + + +instance (FromJSON a) => FromJSON (EsResult a) where + parseJSON (Object v) = EsResult <$> + v .: "_index" <*> + v .: "_type" <*> + v .: "_id" <*> + v .: "_version" <*> + v .:? "found" <*> + v .: "_source" + parseJSON _ = empty + + +instance ToJSON Search where + toJSON (Search query sFilter sort searchAggs highlight sTrackSortScores sFrom sSize) = + omitNulls [ "query" .= query + , "filter" .= sFilter + , "sort" .= sort + , "aggregations" .= searchAggs + , "highlight" .= highlight + , "from" .= sFrom + , "size" .= sSize + , "track_scores" .= sTrackSortScores] + + +instance ToJSON FieldHighlight where + toJSON (FieldHighlight (FieldName fName) (Just fSettings)) = + object [ fName .= fSettings ] + toJSON (FieldHighlight (FieldName fName) Nothing) = + object [ fName .= emptyObject ] + +instance ToJSON Highlights where + toJSON (Highlights global fields) = + omitNulls (("fields" .= toJSON fields) + : highlightSettingsPairs global) + +instance ToJSON HighlightSettings where + toJSON hs = omitNulls (highlightSettingsPairs (Just hs)) + +highlightSettingsPairs :: Maybe HighlightSettings -> [Pair] +highlightSettingsPairs Nothing = [] +highlightSettingsPairs (Just (Plain plh)) = plainHighPairs (Just plh) +highlightSettingsPairs (Just (Postings ph)) = postHighPairs (Just ph) +highlightSettingsPairs (Just (FastVector fvh)) = fastVectorHighPairs (Just fvh) + + +plainHighPairs :: Maybe PlainHighlight -> [Pair] +plainHighPairs Nothing = [] +plainHighPairs (Just (PlainHighlight plCom plNonPost)) = + [ "type" .= String "plain"] + ++ commonHighlightPairs plCom + ++ nonPostingsToPairs plNonPost + +postHighPairs :: Maybe PostingsHighlight -> [Pair] +postHighPairs Nothing = [] +postHighPairs (Just (PostingsHighlight pCom)) = + ("type" .= String "postings") + : commonHighlightPairs pCom + +fastVectorHighPairs :: Maybe FastVectorHighlight -> [Pair] +fastVectorHighPairs Nothing = [] +fastVectorHighPairs (Just + (FastVectorHighlight fvCom fvNonPostSettings fvBoundChars + fvBoundMaxScan fvFragOff fvMatchedFields + fvPhraseLim)) = + [ "type" .= String "fvh" + , "boundary_chars" .= fvBoundChars + , "boundary_max_scan" .= fvBoundMaxScan + , "fragment_offset" .= fvFragOff + , "matched_fields" .= fvMatchedFields + , "phraseLimit" .= fvPhraseLim] + ++ commonHighlightPairs fvCom + ++ nonPostingsToPairs fvNonPostSettings + +commonHighlightPairs :: Maybe CommonHighlight -> [Pair] +commonHighlightPairs Nothing = [] +commonHighlightPairs (Just (CommonHighlight chScore chForceSource chTag chEncoder + chNoMatchSize chHighlightQuery + chRequireFieldMatch)) = + [ "order" .= chScore + , "force_source" .= chForceSource + , "encoder" .= chEncoder + , "no_match_size" .= chNoMatchSize + , "highlight_query" .= chHighlightQuery + , "require_fieldMatch" .= chRequireFieldMatch] + ++ highlightTagToPairs chTag + + +nonPostingsToPairs :: Maybe NonPostings -> [Pair] +nonPostingsToPairs Nothing = [] +nonPostingsToPairs (Just (NonPostings npFragSize npNumOfFrags)) = + [ "fragment_size" .= npFragSize + , "number_of_fragments" .= npNumOfFrags] + + + +instance ToJSON HighlightEncoder where + toJSON DefaultEncoder = String "default" + toJSON HTMLEncoder = String "html" + +highlightTagToPairs :: Maybe HighlightTag -> [Pair] +highlightTagToPairs (Just (TagSchema _)) = [ "scheme" .= String "default"] +highlightTagToPairs (Just (CustomTags (pre, post))) = [ "pre_tags" .= pre + , "post_tags" .= post] +highlightTagToPairs Nothing = [] + +instance ToJSON SortSpec where + toJSON (DefaultSortSpec + (DefaultSort (FieldName dsSortFieldName) dsSortOrder dsIgnoreUnmapped + dsSortMode dsMissingSort dsNestedFilter)) = + object [dsSortFieldName .= omitNulls base] where + base = [ "order" .= toJSON dsSortOrder + , "ignore_unmapped" .= dsIgnoreUnmapped + , "mode" .= dsSortMode + , "missing" .= dsMissingSort + , "nested_filter" .= dsNestedFilter ] + + toJSON (GeoDistanceSortSpec gdsSortOrder (GeoPoint (FieldName field) gdsLatLon) units) = + object [ "unit" .= toJSON units + , field .= toJSON gdsLatLon + , "order" .= toJSON gdsSortOrder ] + + +instance ToJSON SortOrder where + toJSON Ascending = String "asc" + toJSON Descending = String "desc" + + +instance ToJSON SortMode where + toJSON SortMin = String "min" + toJSON SortMax = String "max" + toJSON SortSum = String "sum" + toJSON SortAvg = String "avg" + + +instance ToJSON Missing where + toJSON LastMissing = String "_last" + toJSON FirstMissing = String "_first" + toJSON (CustomMissing txt) = String txt + + +instance ToJSON ScoreType where + toJSON ScoreTypeMax = "max" + toJSON ScoreTypeAvg = "avg" + toJSON ScoreTypeSum = "sum" + toJSON ScoreTypeNone = "none" + + +instance ToJSON Distance where + toJSON (Distance dCoefficient dUnit) = + String boltedTogether where + coefText = showText dCoefficient + (String unitText) = toJSON dUnit + boltedTogether = mappend coefText unitText + + +instance ToJSON DistanceUnit where + toJSON Miles = String "mi" + toJSON Yards = String "yd" + toJSON Feet = String "ft" + toJSON Inches = String "in" + toJSON Kilometers = String "km" + toJSON Meters = String "m" + toJSON Centimeters = String "cm" + toJSON Millimeters = String "mm" + toJSON NauticalMiles = String "nmi" + + +instance ToJSON DistanceType where + toJSON Arc = String "arc" + toJSON SloppyArc = String "sloppy_arc" + toJSON Plane = String "plane" + + +instance ToJSON OptimizeBbox where + toJSON NoOptimizeBbox = String "none" + toJSON (OptimizeGeoFilterType gft) = toJSON gft + + +instance ToJSON GeoBoundingBoxConstraint where + toJSON (GeoBoundingBoxConstraint + (FieldName gbbcGeoBBField) gbbcConstraintBox cache type') = + object [gbbcGeoBBField .= toJSON gbbcConstraintBox + , "_cache" .= cache + , "type" .= type'] + + +instance ToJSON GeoFilterType where + toJSON GeoFilterMemory = String "memory" + toJSON GeoFilterIndexed = String "indexed" + + +instance ToJSON GeoBoundingBox where + toJSON (GeoBoundingBox gbbTopLeft gbbBottomRight) = + object ["top_left" .= toJSON gbbTopLeft + , "bottom_right" .= toJSON gbbBottomRight] + + +instance ToJSON LatLon where + toJSON (LatLon lLat lLon) = + object ["lat" .= lLat + , "lon" .= lLon] + + +-- index for smaller ranges, fielddata for longer ranges +instance ToJSON RangeExecution where + toJSON RangeExecutionIndex = "index" + toJSON RangeExecutionFielddata = "fielddata" + + +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 ToJSON Term where + toJSON (Term field value) = object ["term" .= object + [field .= value]] + + +instance ToJSON BoolMatch where + toJSON (MustMatch term cache) = object ["must" .= toJSON term, + "_cache" .= cache] + toJSON (MustNotMatch term cache) = object ["must_not" .= toJSON term, + "_cache" .= cache] + toJSON (ShouldMatch terms cache) = object ["should" .= fmap toJSON terms, + "_cache" .= cache] + + +instance (FromJSON a) => FromJSON (SearchResult a) where + parseJSON (Object v) = SearchResult <$> + v .: "took" <*> + v .: "timed_out" <*> + v .: "_shards" <*> + v .: "hits" <*> + v .:? "aggregations" + parseJSON _ = empty + +instance (FromJSON a) => FromJSON (SearchHits a) where + parseJSON (Object v) = SearchHits <$> + v .: "total" <*> + v .: "max_score" <*> + v .: "hits" + parseJSON _ = empty + +instance (FromJSON a) => FromJSON (Hit a) where + parseJSON (Object v) = Hit <$> + v .: "_index" <*> + v .: "_type" <*> + v .: "_id" <*> + v .: "_score" <*> + v .: "_source" <*> + v .:? "highlight" + parseJSON _ = empty + +instance FromJSON ShardResult where + parseJSON (Object v) = ShardResult <$> + v .: "total" <*> + v .: "successful" <*> + v .: "failed" + parseJSON _ = empty diff --git a/src/Database/Bloodhound/Types/Class.hs b/src/Database/Bloodhound/Types/Class.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Types/Class.hs @@ -0,0 +1,14 @@ +module Database.Bloodhound.Types.Class + ( Seminearring(..) ) + where + +import Data.Monoid + +class Monoid a => Seminearring a where + -- 0, +, * + (<||>) :: a -> a -> a + (<&&>) :: a -> a -> a + (<&&>) = mappend + +infixr 5 <||> +infixr 5 <&&> diff --git a/tests/tests.hs b/tests/tests.hs --- a/tests/tests.hs +++ b/tests/tests.hs @@ -1,25 +1,30 @@ -{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE ScopedTypeVariables #-} module Main where -import Control.Applicative -import Database.Bloodhound -import Data.Aeson -import Data.List (nub) -import Data.List.NonEmpty (NonEmpty(..)) -import Data.Time.Calendar (Day(..)) -import Data.Time.Clock (secondsToDiffTime, UTCTime(..)) -import Data.Text (Text) -import qualified Data.Text as T -import GHC.Generics (Generic) -import Network.HTTP.Client +import Control.Applicative +import Control.Monad +import Data.Aeson +import Data.HashMap.Strict (fromList) +import Data.List (nub) +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.Map.Strict as M +import Data.Text (Text) +import qualified Data.Text as T +import Data.Time.Calendar (Day (..)) +import Data.Time.Clock (UTCTime (..), secondsToDiffTime) +import qualified Data.Vector as V +import Database.Bloodhound +import GHC.Generics (Generic) +import Network.HTTP.Client import qualified Network.HTTP.Types.Status as NHTS -import Prelude hiding (filter, putStrLn) -import Test.Hspec -import Test.Hspec.QuickCheck (prop) -import Test.QuickCheck +import Prelude hiding (filter, putStrLn) +import Test.Hspec +import Test.Hspec.QuickCheck (prop) +import Test.QuickCheck + testServer :: Server testServer = Server "http://localhost:9200" testIndex :: IndexName @@ -37,6 +42,57 @@ deleteExampleIndex :: IO Reply deleteExampleIndex = deleteIndex testServer testIndex +data ServerVersion = ServerVersion Int Int Int deriving (Show, Eq, Ord) + +es14 :: ServerVersion +es14 = ServerVersion 1 4 0 + +es13 :: ServerVersion +es13 = ServerVersion 1 3 0 + +es12 :: ServerVersion +es12 = ServerVersion 1 2 0 + +es11 :: ServerVersion +es11 = ServerVersion 1 1 0 + +es10 :: ServerVersion +es10 = ServerVersion 1 0 0 + +serverBranch :: ServerVersion -> ServerVersion +serverBranch (ServerVersion majorVer minorVer patchVer) = + ServerVersion majorVer minorVer patchVer + +mkServerVersion :: [Int] -> Maybe ServerVersion +mkServerVersion [majorVer, minorVer, patchVer] = + Just (ServerVersion majorVer minorVer patchVer) +mkServerVersion _ = Nothing + +getServerVersion :: Server -> IO (Maybe ServerVersion) +getServerVersion s = liftM extractVersion (getStatus s) + where + version' = T.splitOn "." . number . version + toInt = read . T.unpack + parseVersion v = map toInt (version' v) + extractVersion = join . liftM (mkServerVersion . parseVersion) + + + +testServerBranch :: IO (Maybe ServerVersion) +testServerBranch = getServerVersion testServer >>= \v -> return $ liftM serverBranch v + +atleast :: ServerVersion -> IO Bool +atleast v = testServerBranch >>= \x -> return $ x >= Just (serverBranch v) + +atmost :: ServerVersion -> IO Bool +atmost v = testServerBranch >>= \x -> return $ x <= Just (serverBranch v) + +is :: ServerVersion -> IO Bool +is v = testServerBranch >>= \x -> return $ x == Just (serverBranch v) + +when' :: Monad m => m Bool -> m () -> m () +when' b f = b >>= \x -> when x f + data Location = Location { lat :: Double , lon :: Double } deriving (Eq, Generic, Show) @@ -107,6 +163,35 @@ let emptyHits = fmap (hits . searchHits) result emptyHits `shouldBe` Right [] +searchExpectAggs :: Search -> IO () +searchExpectAggs search = do + reply <- searchAll testServer search + let isEmpty x = return (M.null x) + let result = decode (responseBody reply) :: Maybe (SearchResult Tweet) + (result >>= aggregations >>= isEmpty) `shouldBe` Just False + +searchValidBucketAgg :: (BucketAggregation a, FromJSON a, Show a) => Search -> Text -> (Text -> AggregationResults -> Maybe (Bucket a)) -> IO () +searchValidBucketAgg search aggKey extractor = do + reply <- searchAll testServer search + let bucketDocs = docCount . head . buckets + let result = decode (responseBody reply) :: Maybe (SearchResult Tweet) + let count = result >>= aggregations >>= extractor aggKey >>= \x -> return (bucketDocs x) + count `shouldBe` Just 1 + +searchTermsAggHint :: [ExecutionHint] -> IO () +searchTermsAggHint hints = do + let terms hint = TermsAgg $ (mkTermsAggregation "user") { termExecutionHint = Just hint } + let search hint = mkAggregateSearch Nothing $ mkAggregations "users" $ terms hint + forM_ hints $ searchExpectAggs . search + forM_ hints (\x -> searchValidBucketAgg (search x) "users" toTerms) + +searchTweetHighlight :: Search -> IO (Either String (Maybe HitHighlight)) +searchTweetHighlight search = do + reply <- searchByIndex testServer testIndex search + let result = eitherDecode (responseBody reply) :: Either String (SearchResult Tweet) + let myHighlight = fmap (hitHighlight . head . hits . searchHits) result + return myHighlight + data BulkTest = BulkTest { name :: Text } deriving (Eq, Generic, Show) instance FromJSON BulkTest instance ToJSON BulkTest @@ -160,10 +245,10 @@ let firstTest = BulkTest "blah" let secondTest = BulkTest "bloo" let firstDoc = BulkIndex testIndex - testMapping (DocId "2") (object ["name" .= String "blah"]) + testMapping (DocId "2") (toJSON firstTest) let secondDoc = BulkCreate testIndex - testMapping (DocId "3") (object ["name" .= String "bloo"]) - let stream = [firstDoc, secondDoc] + testMapping (DocId "3") (toJSON secondTest) + let stream = V.fromList [firstDoc, secondDoc] _ <- bulk testServer stream _ <- refreshIndex testServer testIndex fDoc <- getDocument testServer testIndex testMapping (DocId "2") @@ -203,7 +288,7 @@ let innerQuery = QueryMatchQuery $ mkMatchQuery (FieldName "user") (QueryString "bitemyapp") let query = QueryBoolQuery $ - mkBoolQuery (Just innerQuery) Nothing Nothing + mkBoolQuery [innerQuery] [] [] let search = mkSearch (Just query) Nothing myTweet <- searchTweet search myTweet `shouldBe` Right exampleTweet @@ -235,7 +320,7 @@ _ <- insertOther let sortSpec = DefaultSortSpec $ mkSort (FieldName "age") Ascending let search = Search Nothing - (Just IdentityFilter) (Just [sortSpec]) + (Just IdentityFilter) (Just [sortSpec]) Nothing Nothing False 0 10 reply <- searchByIndex testServer testIndex search let result = eitherDecode (responseBody reply) :: Either String (SearchResult Tweet) @@ -362,7 +447,76 @@ let search = mkSearch Nothing (Just filter) searchExpectNoResults search + describe "Aggregation API" $ do + it "returns term aggregation results" $ do + _ <- insertData + let terms = TermsAgg $ mkTermsAggregation "user" + let search = mkAggregateSearch Nothing $ mkAggregations "users" terms + searchExpectAggs search + searchValidBucketAgg search "users" toTerms + it "can give collection hint parameters to term aggregations" $ when' (atleast es13) $ do + _ <- insertData + let terms = TermsAgg $ (mkTermsAggregation "user") { termCollectMode = Just BreadthFirst } + let search = mkAggregateSearch Nothing $ mkAggregations "users" terms + searchExpectAggs search + searchValidBucketAgg search "users" toTerms + + it "can give execution hint paramters to term aggregations" $ when' (atmost es11) $ do + _ <- insertData + searchTermsAggHint [Map, Ordinals] + + it "can give execution hint paramters to term aggregations" $ when' (is es12) $ do + _ <- insertData + searchTermsAggHint [GlobalOrdinals, GlobalOrdinalsHash, GlobalOrdinalsLowCardinality, Map, Ordinals] + + it "can give execution hint paramters to term aggregations" $ when' (atleast es12) $ do + _ <- insertData + searchTermsAggHint [GlobalOrdinals, GlobalOrdinalsHash, GlobalOrdinalsLowCardinality, Map] + + it "returns date histogram aggregation results" $ do + _ <- insertData + let histogram = DateHistogramAgg $ mkDateHistogram (FieldName "postDate") Minute + let search = mkAggregateSearch Nothing (mkAggregations "byDate" histogram) + searchExpectAggs search + searchValidBucketAgg search "byDate" toDateHistogram + + it "returns date histogram using fractional date" $ do + _ <- insertData + let periods = [Year, Quarter, Month, Week, Day, Hour, Minute, Second] + let fractionals = map (FractionalInterval 1.5) [Weeks, Days, Hours, Minutes, Seconds] + let intervals = periods ++ fractionals + let histogram = mkDateHistogram (FieldName "postDate") + let search interval = mkAggregateSearch Nothing $ mkAggregations "byDate" $ DateHistogramAgg (histogram interval) + let expect interval = searchExpectAggs (search interval) + let valid interval = searchValidBucketAgg (search interval) "byDate" toDateHistogram + forM_ intervals expect + forM_ intervals valid + + describe "Highlights API" $ do + + it "returns highlight from query when there should be one" $ do + _ <- insertData + _ <- insertOther + let query = QueryMatchQuery $ mkMatchQuery (FieldName "_all") (QueryString "haskell") + let highlight = Highlights Nothing [FieldHighlight (FieldName "message") Nothing] + + let search = mkHighlightSearch (Just query) highlight + myHighlight <- searchTweetHighlight search + myHighlight `shouldBe` Right (Just (M.fromList [("message",["Use haskell!"])])) + + it "doesn't return highlight from a query when it shouldn't" $ do + _ <- insertData + _ <- insertOther + let query = QueryMatchQuery $ mkMatchQuery (FieldName "_all") (QueryString "haskell") + let highlight = Highlights Nothing [FieldHighlight (FieldName "user") Nothing] + + let search = mkHighlightSearch (Just query) highlight + myHighlight <- searchTweetHighlight search + myHighlight `shouldBe` Right Nothing + + + describe "ToJSON RegexpFlags" $ do it "generates the correct JSON for AllRegexpFlags" $ toJSON AllRegexpFlags `shouldBe` String "ALL" @@ -382,3 +536,24 @@ let String str = toJSON flags flagStrs = T.splitOn "|" str in noDuplicates flagStrs + + describe "omitNulls" $ do + it "checks that omitNulls drops list elements when it should" $ + let dropped = omitNulls $ [ "test1" .= (toJSON ([] :: [Int])) + , "test2" .= (toJSON ("some value" :: Text))] + in dropped `shouldBe` Object (fromList [("test2", String "some value")]) + + it "checks that omitNulls doesn't drop list elements when it shouldn't" $ + let notDropped = omitNulls $ [ "test1" .= (toJSON ([1] :: [Int])) + , "test2" .= (toJSON ("some value" :: Text))] + in notDropped `shouldBe` Object (fromList [ ("test1", Array (V.fromList [Number 1.0])) + , ("test2", String "some value")]) + it "checks that omitNulls drops non list elements when it should" $ + let dropped = omitNulls $ [ "test1" .= (toJSON Null) + , "test2" .= (toJSON ("some value" :: Text))] + in dropped `shouldBe` Object (fromList [("test2", String "some value")]) + it "checks that omitNulls doesn't drop non list elements when it shouldn't" $ + let notDropped = omitNulls $ [ "test1" .= (toJSON (1 :: Int)) + , "test2" .= (toJSON ("some value" :: Text))] + in notDropped `shouldBe` Object (fromList [ ("test1", Number 1.0) + , ("test2", String "some value")])