diff --git a/Database/Bloodhound.hs b/Database/Bloodhound.hs new file mode 100644 --- /dev/null +++ b/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/Database/Bloodhound/Client.hs b/Database/Bloodhound/Client.hs new file mode 100644 --- /dev/null +++ b/Database/Bloodhound/Client.hs @@ -0,0 +1,234 @@ +module Database.Bloodhound.Client + ( createIndex + , deleteIndex + , createMapping + , deleteMapping + , indexDocument + , getDocument + , documentExists + , deleteDocument + , searchAll + , searchByIndex + , searchByType + , refreshIndex + , mkSearch + , bulk + ) + 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.Conduit +import qualified Network.HTTP.Types.Method as NHTM +import qualified Network.HTTP.Types.Status as NHTS +import Prelude hiding (head) + +import Database.Bloodhound.Types +import Database.Bloodhound.Types.Class +import Database.Bloodhound.Types.Instances + +-- 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) + +responseIsError :: Reply -> Bool +responseIsError resp = NHTS.statusCode (responseStatus resp) > 299 + +emptyBody = L.pack "" + +dispatch :: Method -> String -> Maybe L.ByteString + -> IO Reply +dispatch method url body = do + initReq <- parseUrl url + let reqBody = RequestBodyLBS $ fromMaybe emptyBody body + let req = initReq { method = method + , requestBody = reqBody + , checkStatus = \_ _ _ -> Nothing} + withManager $ httpLbs req + +joinPath :: [String] -> String +joinPath = intercalate "/" + +delete = flip (dispatch NHTM.methodDelete) $ Nothing +get = flip (dispatch NHTM.methodGet) $ Nothing +head = flip (dispatch NHTM.methodHead) $ Nothing +put = dispatch NHTM.methodPost +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 Version)) +getStatus (Server server) = do + request <- parseUrl $ joinPath [server] + response <- withManager $ 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 url = do + reply <- head url + return (reply, respIsTwoHunna reply) + +indexExists :: Server -> IndexName -> IO Bool +indexExists (Server server) (IndexName indexName) = do + (reply, 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 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 + +createMapping :: ToJSON a => Server -> IndexName + -> MappingName -> a -> IO Reply +createMapping (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 "\n" + +mash :: Builder -> [L.ByteString] -> Builder +mash builder xs = foldl' (\b x -> mappend b (lazyByteString x)) builder xs + +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 + (reply, 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) search = dispatchSearch url search where + url = joinPath [server, "_search"] + +searchByIndex :: Server -> IndexName -> Search -> IO Reply +searchByIndex (Server server) (IndexName indexName) search = dispatchSearch url search where + url = joinPath [server, indexName, "_search"] + +searchByType :: Server -> IndexName -> MappingName -> Search -> IO Reply +searchByType (Server server) (IndexName indexName) + (MappingName mappingName) search = dispatchSearch url search 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 from size search = search { from = from, size = size } diff --git a/Database/Bloodhound/Types.hs b/Database/Bloodhound/Types.hs new file mode 100644 --- /dev/null +++ b/Database/Bloodhound/Types.hs @@ -0,0 +1,698 @@ +{-# LANGUAGE DeriveGeneric #-} + +module Database.Bloodhound.Types + ( defaultCache + , defaultIndexSettings + , halfRangeToKV + , maybeJson + , maybeJsonF + , mkSort + , rangeToKV + , showText + , unpackId + , mkMatchQuery + , mkMultiMatchQuery + , mkBoolQuery + , 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(..) + , 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(..) + ) where + +import Data.Aeson +import qualified Data.ByteString.Lazy.Char8 as L +import Data.Text (Text) +import qualified Data.Text as T +import Data.Time.Clock (UTCTime) +import Database.Bloodhound.Types.Class +import GHC.Generics (Generic) +import Network.HTTP.Conduit +import qualified Network.HTTP.Types.Method as NHTM + +data Version = Version { number :: Text + , build_hash :: Text + , build_timestamp :: UTCTime + , build_snapshot :: Bool + , lucene_version :: Text } deriving (Show, Generic) + +data Status a = Status { ok :: Bool + , status :: Int + , name :: Text + , version :: a + , tagline :: Text } deriving (Eq, Show) + +data IndexSettings = + IndexSettings { indexShards :: ShardCount + , indexReplicas :: ReplicaCount } deriving (Eq, Show) + +defaultIndexSettings = IndexSettings (ShardCount 3) (ReplicaCount 2) + +data Strategy = RoundRobinStrat | RandomStrat | HeadStrat deriving (Eq, Show) + + +type Reply = Network.HTTP.Conduit.Response L.ByteString +type Method = NHTM.Method + +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) + +data Mapping = Mapping { typeName :: TypeName + , fields :: [MappingField] } deriving (Eq, Show) + +data BulkOperation = + BulkIndex IndexName MappingName DocId Value + | BulkCreate IndexName MappingName DocId Value + | BulkDelete IndexName MappingName DocId + | BulkUpdate IndexName MappingName DocId Value deriving (Eq, Show) + +data EsResult a = EsResult { _index :: Text + , _type :: Text + , _id :: Text + , _version :: Int + , found :: Maybe Bool + , _source :: a } deriving (Eq, Show) + +type Sort = [SortSpec] + +data SortSpec = DefaultSortSpec DefaultSort + | GeoDistanceSortSpec SortOrder GeoPoint DistanceUnit deriving (Eq, Show) + +data DefaultSort = + DefaultSort { sortFieldName :: FieldName + , sortOrder :: SortOrder + -- default False + , ignoreUnmapped :: Bool + , sortMode :: Maybe SortMode + , missingSort :: Maybe Missing + , nestedFilter :: Maybe Filter } deriving (Eq, Show) + +data SortOrder = Ascending + | Descending deriving (Eq, Show) + +data Missing = LastMissing + | FirstMissing + | CustomMissing Text deriving (Eq, Show) + +data SortMode = SortMin + | SortMax + | SortSum + | SortAvg deriving (Eq, Show) + +mkSort :: FieldName -> SortOrder -> DefaultSort +mkSort fieldName sortOrder = DefaultSort fieldName sortOrder False Nothing Nothing Nothing + +type Cache = Bool -- caching on/off +defaultCache = False + +type PrefixValue = Text + +data BooleanOperator = And | Or deriving (Eq, Show) + +newtype ShardCount = ShardCount Int deriving (Eq, Show, Generic) +newtype ReplicaCount = ReplicaCount Int deriving (Eq, Show, Generic) +newtype Server = Server String deriving (Eq, Show) +newtype IndexName = IndexName String deriving (Eq, Generic, Show) +newtype MappingName = MappingName String deriving (Eq, Generic, Show) +newtype DocId = DocId String deriving (Eq, Generic, Show) +newtype QueryString = QueryString Text deriving (Eq, Show) +newtype FieldName = FieldName Text deriving (Eq, Show) +newtype CacheName = CacheName Text deriving (Eq, Show) +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) +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) +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) +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) +newtype AllowLeadingWildcard = AllowLeadingWildcard Bool deriving (Eq, Show) +newtype LowercaseExpanded = LowercaseExpanded Bool deriving (Eq, Show) +newtype EnablePositionIncrements = EnablePositionIncrements Bool deriving (Eq, Show) +newtype AnalyzeWildcard = AnalyzeWildcard Bool deriving (Eq, Show) +newtype GeneratePhraseQueries = GeneratePhraseQueries Bool deriving (Eq, Show) +newtype Locale = Locale Text deriving (Eq, Show) +newtype MaxWordLength = MaxWordLength Int deriving (Eq, Show, Generic) +newtype MinWordLength = MinWordLength Int deriving (Eq, Show, Generic) +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 :: 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 + , regexpQueryCacheName :: CacheName + , regexpQueryCache :: Cache + , regexpQueryCacheKey :: CacheKey } deriving (Eq, Show) + +data RangeQuery = + RangeQuery { rangeQueryField :: FieldName + , rangeQueryRange :: Either HalfRange Range + , rangeQueryBoost :: Boost } deriving (Eq, Show) + +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 FieldOrFields + , 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) + +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 :: 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 :: [FieldName] -> QueryString -> MultiMatchQuery +mkMultiMatchQuery fields query = + MultiMatchQuery fields 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 GeoFilterType + | 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 + 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) +newtype RegexpFlags = RegexpFlags Text 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 + } 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) + +maybeJson :: ToJSON a => Text -> Maybe a -> [(Text, Value)] +maybeJson field (Just value) = [field .= toJSON value] +maybeJson _ _ = [] + +-- maybeJsonF :: (ToJSON (f Value), ToJSON a, Functor f) => +-- Text -> Maybe (f a) -> [(Text, Value)] +maybeJsonF field (Just value) = [field .= fmap toJSON value] +maybeJsonF _ _ = [] + +showText :: Show a => a -> Text +showText = T.pack . show diff --git a/Database/Bloodhound/Types/Class.hs b/Database/Bloodhound/Types/Class.hs new file mode 100644 --- /dev/null +++ b/Database/Bloodhound/Types/Class.hs @@ -0,0 +1,15 @@ +module Database.Bloodhound.Types.Class + ( Seminearring(..) ) + where + +import Data.Aeson +import Data.Monoid + +class Monoid a => Seminearring a where + -- 0, +, * + (<||>) :: a -> a -> a + (<&&>) :: a -> a -> a + (<&&>) = mappend + +infixr 5 <||> +infixr 5 <&&> diff --git a/Database/Bloodhound/Types/Instances.hs b/Database/Bloodhound/Types/Instances.hs new file mode 100644 --- /dev/null +++ b/Database/Bloodhound/Types/Instances.hs @@ -0,0 +1,657 @@ +{-# LANGUAGE DeriveGeneric #-} + +module Database.Bloodhound.Types.Instances + ( Monoid(..) + , Seminearring(..) + , ToJSON(..) + ) where + +import Control.Applicative +import Data.Aeson +import Data.Maybe (catMaybes) +import Data.Monoid +import qualified Data.Text as T +import Database.Bloodhound.Types +import Database.Bloodhound.Types.Class +import Data.Scientific + +instance Monoid Filter where + mempty = IdentityFilter + mappend a b = AndFilter [a, b] defaultCache + +instance Seminearring Filter where + a <||> b = OrFilter [a, b] defaultCache + +instance ToJSON Filter where + toJSON (AndFilter filters cache) = + object ["and" .= fmap toJSON filters + , "_cache" .= cache] + + toJSON (OrFilter filters cache) = + object ["or" .= fmap toJSON filters + , "_cache" .= cache] + + toJSON (NotFilter filter cache) = + object ["not" .= + object ["filter" .= toJSON filter + , "_cache" .= cache]] + + toJSON (IdentityFilter) = + object ["match_all" .= object []] + + toJSON (ExistsFilter (FieldName fieldName)) = + object ["exists" .= object + ["field" .= fieldName]] + + toJSON (BoolFilter boolMatch) = + object ["bool" .= toJSON boolMatch] + + toJSON (GeoBoundingBoxFilter bbConstraint filterType) = + object ["geo_bounding_box" .= toJSON bbConstraint + , "type" .= toJSON filterType] + + toJSON (GeoDistanceFilter (GeoPoint (FieldName geoField) latLon) + distance distanceType optimizeBbox cache) = + object ["geo_distance" .= + object ["distance" .= toJSON distance + , "distance_type" .= toJSON distanceType + , "optimize_bbox" .= optimizeBbox + , geoField .= toJSON latLon + , "_cache" .= cache]] + + toJSON (GeoDistanceRangeFilter (GeoPoint (FieldName geoField) latLon) + (DistanceRange distanceFrom distanceTo)) = + object ["geo_distance_range" .= + object ["from" .= toJSON distanceFrom + , "to" .= toJSON distanceTo + , geoField .= toJSON latLon]] + + toJSON (GeoPolygonFilter (FieldName geoField) latLons) = + object ["geo_polygon" .= + object [geoField .= + object ["points" .= fmap toJSON latLons]]] + + toJSON (IdsFilter (MappingName mappingName) values) = + object ["ids" .= + object ["type" .= mappingName + , "values" .= fmap (T.pack . unpackId) values]] + + toJSON (LimitFilter limit) = + object ["limit" .= object ["value" .= limit]] + + toJSON (MissingFilter (FieldName fieldName) (Existence existence) (NullValue nullValue)) = + object ["missing" .= + object ["field" .= fieldName + , "existence" .= existence + , "null_value" .= nullValue]] + + toJSON (PrefixFilter (FieldName fieldName) fieldValue cache) = + object ["prefix" .= + object [fieldName .= fieldValue + , "_cache" .= cache]] + + toJSON (RangeFilter (FieldName fieldName) (Left halfRange) rangeExecution cache) = + object ["range" .= + object [fieldName .= + object [key .= val] + , "execution" .= toJSON rangeExecution + , "_cache" .= cache]] + where + (key, val) = halfRangeToKV halfRange + + toJSON (RangeFilter (FieldName fieldName) (Right range) rangeExecution cache) = + object ["range" .= + object [fieldName .= + object [lessKey .= lessVal + , greaterKey .= greaterVal] + , "execution" .= toJSON rangeExecution + , "_cache" .= cache]] + where + (lessKey, lessVal, greaterKey, greaterVal) = rangeToKV range + + toJSON (RegexpFilter (FieldName fieldName) + (Regexp regexText) flags (CacheName cacheName) cache (CacheKey cacheKey)) = + object ["regexp" .= + object [fieldName .= + object ["value" .= regexText + , "flags" .= toJSON flags] + , "_name" .= cacheName + , "_cache" .= cache + , "_cache_key" .= cacheKey]] + +instance ToJSON GeoPoint where + toJSON (GeoPoint (FieldName geoField) latLon) = + object [ geoField .= toJSON latLon ] + + +instance ToJSON Query where + toJSON (TermQuery (Term termField termValue) boost) = + object [ "term" .= + object [termField .= object merged]] + where + base = [ "value" .= termValue ] + boosted = maybe [] (return . ("boost" .=)) boost + merged = mappend base boosted + + toJSON (QueryMatchQuery matchQuery) = + object [ "match" .= toJSON matchQuery ] + + toJSON (QueryMultiMatchQuery multiMatchQuery) = + object [ "multi_match" .= toJSON multiMatchQuery ] + + toJSON (QueryBoolQuery boolQuery) = + object [ "bool" .= toJSON boolQuery ] + + toJSON (QueryBoostingQuery boostingQuery) = + object [ "boosting" .= toJSON boostingQuery ] + + toJSON (QueryCommonTermsQuery commonTermsQuery) = + object [ "common" .= toJSON commonTermsQuery ] + + toJSON (ConstantScoreFilter filter boost) = + object [ "constant_score" .= toJSON filter + , "boost" .= toJSON boost] + + toJSON (ConstantScoreQuery query boost) = + object [ "constant_score" .= toJSON query + , "boost" .= toJSON boost] + + toJSON (QueryDisMaxQuery disMaxQuery) = + object [ "dis_max" .= toJSON disMaxQuery ] + + toJSON (QueryFilteredQuery filteredQuery) = + object [ "filtered" .= toJSON filteredQuery ] + + toJSON (QueryFuzzyLikeThisQuery fuzzyQuery) = + object [ "fuzzy_like_this" .= toJSON fuzzyQuery ] + + toJSON (QueryFuzzyLikeFieldQuery fuzzyFieldQuery) = + object [ "fuzzy_like_this_field" .= toJSON fuzzyFieldQuery ] + + toJSON (QueryFuzzyQuery fuzzyQuery) = + object [ "fuzzy" .= toJSON fuzzyQuery ] + + toJSON (QueryHasChildQuery childQuery) = + object [ "has_child" .= toJSON childQuery ] + + toJSON (QueryHasParentQuery parentQuery) = + object [ "has_parent" .= toJSON parentQuery ] + + toJSON (QueryIndicesQuery indicesQuery) = + object [ "indices" .= toJSON indicesQuery ] + + toJSON (MatchAllQuery boost) = + object [ "match_all" .= object maybeAdd ] + where maybeAdd = catMaybes [ mField "boost" boost ] + + toJSON (QueryMoreLikeThisQuery query) = + object [ "more_like_this" .= toJSON query ] + + toJSON (QueryMoreLikeThisFieldQuery query) = + object [ "more_like_this_field" .= toJSON query ] + + toJSON (QueryNestedQuery query) = + object [ "nested" .= toJSON query ] + + toJSON (QueryPrefixQuery query) = + object [ "prefix" .= toJSON query ] + + +mField :: (ToJSON a, Functor f) => T.Text -> f a -> f (T.Text, Value) +mField field = fmap ((field .=) . toJSON) + + +instance ToJSON PrefixQuery where + toJSON (PrefixQuery (FieldName fieldName) queryValue boost) = + object [ fieldName .= object conjoined ] + where base = [ "value" .= toJSON queryValue ] + maybeAdd = catMaybes [ mField "boost" boost ] + conjoined = base ++ maybeAdd + + +instance ToJSON NestedQuery where + toJSON (NestedQuery path scoreType query) = + object [ "path" .= toJSON path + , "score_mode" .= toJSON scoreType + , "query" .= toJSON query ] + + +instance ToJSON MoreLikeThisFieldQuery where + toJSON (MoreLikeThisFieldQuery text (FieldName fieldName) + percent mtf mqt stopwords mindf maxdf + minwl maxwl boostTerms boost analyzer) = + object [ fieldName .= object conjoined ] + where base = [ "like_text" .= toJSON text ] + maybeAdd = catMaybes [ mField "percent_terms_to_match" percent + , mField "min_term_freq" mtf + , mField "max_query_terms" mqt + , mField "stop_words" stopwords + , mField "min_doc_freq" mindf + , mField "max_doc_freq" maxdf + , mField "min_word_length" minwl + , mField "max_word_length" maxwl + , mField "boost_terms" boostTerms + , mField "boost" boost + , mField "analyzer" analyzer ] + conjoined = base ++ maybeAdd + + +instance ToJSON MoreLikeThisQuery where + toJSON (MoreLikeThisQuery text fields percent + mtf mqt stopwords mindf maxdf + minwl maxwl boostTerms boost analyzer) = + object conjoined + where base = [ "like_text" .= toJSON text ] + maybeAdd = catMaybes [ mField "fields" fields + , mField "percent_terms_to_match" percent + , mField "min_term_freq" mtf + , mField "max_query_terms" mqt + , mField "stop_words" stopwords + , mField "min_doc_freq" mindf + , mField "max_doc_freq" maxdf + , mField "min_word_length" minwl + , mField "max_word_length" maxwl + , mField "boost_terms" boostTerms + , mField "boost" boost + , mField "analyzer" analyzer ] + conjoined = base ++ maybeAdd + + +instance ToJSON IndicesQuery where + toJSON (IndicesQuery indices query noMatch) = + object $ [ "indices" .= toJSON indices + , "query" .= toJSON query ] ++ maybeAdd + where maybeAdd = catMaybes [ mField "no_match_query" noMatch ] + + +instance ToJSON HasParentQuery where + toJSON (HasParentQuery queryType query scoreType) = + object $ [ "parent_type" .= toJSON queryType + , "query" .= toJSON query ] ++ maybeAdd + where maybeAdd = catMaybes [ mField "score_type" scoreType ] + + +instance ToJSON HasChildQuery where + toJSON (HasChildQuery queryType query scoreType) = + object $ [ "query" .= toJSON query + , "type" .= toJSON queryType ] ++ maybeAdd + where maybeAdd = catMaybes [ mField "score_type" scoreType ] + + +instance ToJSON FuzzyQuery where + toJSON (FuzzyQuery (FieldName fieldName) queryText + prefixLength maxEx fuzziness boost) = + object [ fieldName .= object conjoined ] + where base = [ "value" .= toJSON queryText + , "fuzziness" .= toJSON fuzziness + , "prefix_length" .= toJSON prefixLength + , "max_expansions" .= toJSON maxEx ] + maybeAdd = catMaybes [ mField "boost" boost ] + conjoined = base ++ maybeAdd + + +instance ToJSON FuzzyLikeFieldQuery where + toJSON (FuzzyLikeFieldQuery (FieldName fieldName) + fieldText maxTerms ignoreFreq fuzziness prefixLength + boost analyzer) = + object $ [ fieldName .= + object [ "like_text" .= toJSON fieldText + , "max_query_terms" .= toJSON maxTerms + , "ignore_tf" .= toJSON ignoreFreq + , "fuzziness" .= toJSON fuzziness + , "prefix_length" .= toJSON prefixLength + , "boost" .= toJSON boost ]] ++ maybeAdd + where maybeAdd = catMaybes [ mField "analyzer" analyzer ] + + +instance ToJSON FuzzyLikeThisQuery where + toJSON (FuzzyLikeThisQuery fields text maxTerms + ignoreFreq fuzziness prefixLength boost analyzer) = + object conjoined + where base = [ "fields" .= toJSON fields + , "like_text" .= toJSON text + , "max_query_terms" .= toJSON maxTerms + , "ignore_tf" .= toJSON ignoreFreq + , "fuzziness" .= toJSON fuzziness + , "prefix_length" .= toJSON prefixLength + , "boost" .= toJSON boost ] + maybeAdd = catMaybes [ mField "analyzer" analyzer ] + conjoined = base ++ maybeAdd + + +instance ToJSON FilteredQuery where + toJSON (FilteredQuery query filter) = + object [ "query" .= toJSON query + , "filter" .= toJSON filter ] + + +instance ToJSON DisMaxQuery where + toJSON (DisMaxQuery queries tiebreaker boost) = + object conjoined + where maybeAdd = catMaybes [mField "boost" boost] + base = [ "queries" .= toJSON queries + , "tie_breaker" .= toJSON tiebreaker ] + conjoined = base ++ maybeAdd + + +instance ToJSON CommonTermsQuery where + toJSON (CommonTermsQuery (FieldName fieldName) + (QueryString query) cf lfo hfo msm + boost analyzer disableCoord) = + object [fieldName .= object conjoined] + where base = [ "query" .= query + , "cutoff_frequency" .= toJSON cf + , "low_freq_operator" .= toJSON lfo + , "high_freq_operator" .= toJSON hfo ] + extension = catMaybes + [ mField "minimum_should_match" msm + , mField "boost" boost + , mField "analyzer" analyzer + , mField "disable_coord" disableCoord ] + conjoined = base ++ extension + + +instance ToJSON CommonMinimumMatch where + toJSON (CommonMinimumMatch mm) = toJSON mm + toJSON (CommonMinimumMatchHighLow (MinimumMatchHighLow lowF highF)) = + object [ "low_freq" .= toJSON lowF + , "high_freq" .= toJSON highF ] + +instance ToJSON BoostingQuery where + toJSON (BoostingQuery positiveQuery negativeQuery negativeBoost) = + object [ "positive" .= toJSON positiveQuery + , "negative" .= toJSON negativeQuery + , "negative_boost" .= toJSON negativeBoost ] + + +instance ToJSON BoolQuery where + toJSON (BoolQuery mustM notM shouldM min boost disableCoord) = + object filtered + where filtered = catMaybes + [ mField "must" mustM + , mField "must_not" notM + , mField "should" shouldM + , mField "minimum_should_match" min + , mField "boost" boost + , mField "disable_coord" disableCoord ] + + +instance ToJSON MatchQuery where + toJSON (MatchQuery (FieldName fieldName) + (QueryString queryString) booleanOperator + zeroTermsQuery cutoffFrequency matchQueryType + analyzer maxExpansions lenient) = + object [ fieldName .= object conjoined ] + where conjoined = [ "query" .= queryString + , "operator" .= toJSON booleanOperator + , "zero_terms_query" .= toJSON zeroTermsQuery] + ++ maybeAdd + maybeAdd = catMaybes [ mField "cutoff_frequency" cutoffFrequency + , mField "type" matchQueryType + , mField "analyzer" analyzer + , mField "max_expansions" maxExpansions + , mField "lenient" lenient ] + + +instance ToJSON MultiMatchQuery where + toJSON (MultiMatchQuery fields (QueryString query) boolOp + ztQ tb mmqt cf analyzer maxEx lenient) = + object ["multi_match" .= object conjoined] + where baseQuery = [ "fields" .= fmap toJSON fields + , "query" .= query + , "operator" .= toJSON boolOp + , "zero_terms_query" .= toJSON ztQ ] + maybeAdd = catMaybes [ mField "tiebreaker" tb + , mField "type" mmqt + , mField "cutoff_frequency" cf + , mField "analyzer" analyzer + , mField "max_expansions" maxEx + , mField "lenient" lenient ] + conjoined = baseQuery ++ maybeAdd + + +instance ToJSON MultiMatchQueryType where + toJSON MultiMatchBestFields = "best_fields" + toJSON MultiMatchMostFields = "most_fields" + toJSON MultiMatchCrossFields = "cross_fields" + toJSON MultiMatchPhrase = "phrase" + toJSON MultiMatchPhrasePrefix = "phrase_prefix" + +instance ToJSON BooleanOperator where + toJSON And = String "and" + toJSON Or = String "or" + +instance ToJSON ZeroTermsQuery where + toJSON ZeroTermsNone = String "none" + toJSON ZeroTermsAll = String "all" + +instance ToJSON MatchQueryType where + toJSON MatchPhrase = "phrase" + toJSON MatchPhrasePrefix = "phrase_prefix" + +instance ToJSON FieldName where + toJSON (FieldName fieldName) = String fieldName + +instance ToJSON ReplicaCount +instance ToJSON ShardCount +instance ToJSON CutoffFrequency +instance ToJSON Analyzer +instance ToJSON MaxExpansions +instance ToJSON Lenient +instance ToJSON Boost +instance ToJSON Version +instance ToJSON Tiebreaker +instance ToJSON MinimumMatch +instance ToJSON DisableCoord +instance ToJSON PrefixLength +instance ToJSON Fuzziness +instance ToJSON IgnoreTermFrequency +instance ToJSON MaxQueryTerms +instance ToJSON TypeName +instance ToJSON IndexName +instance ToJSON BoostTerms +instance ToJSON MaxWordLength +instance ToJSON MinWordLength +instance ToJSON MaxDocFrequency +instance ToJSON MinDocFrequency +instance ToJSON PhraseSlop +instance ToJSON StopWord +instance ToJSON QueryPath +instance ToJSON MinimumTermFrequency +instance ToJSON PercentMatch +instance FromJSON Version +instance FromJSON IndexName +instance FromJSON MappingName +instance FromJSON DocId + + +instance (FromJSON a) => FromJSON (Status a) where + parseJSON (Object v) = Status <$> + v .: "ok" <*> + v .: "status" <*> + v .: "name" <*> + v .: "version" <*> + v .: "tagline" + parseJSON _ = empty + + +instance ToJSON IndexSettings where + toJSON (IndexSettings s r) = object ["settings" .= object ["shards" .= s, "replicas" .= r]] + + +instance (FromJSON a) => FromJSON (EsResult a) where + parseJSON (Object v) = EsResult <$> + v .: "_index" <*> + v .: "_type" <*> + v .: "_id" <*> + v .: "_version" <*> + v .:? "found" <*> + v .: "_source" + parseJSON _ = empty + + +instance ToJSON Search where + toJSON (Search query filter sort trackSortScores from size) = + object merged where + lQuery = maybeJson "query" query + lFilter = maybeJson "filter" filter + lSort = maybeJsonF "sort" sort + merged = mconcat [[ "from" .= from + , "size" .= size + , "track_scores" .= trackSortScores] + , lQuery + , lFilter + , lSort] + + +instance ToJSON SortSpec where + toJSON (DefaultSortSpec + (DefaultSort (FieldName sortFieldName) sortOrder ignoreUnmapped + sortMode missingSort nestedFilter)) = + object [sortFieldName .= object merged] where + base = ["order" .= toJSON sortOrder + , "ignore_unmapped" .= ignoreUnmapped] + lSortMode = maybeJson "mode" sortMode + lMissingSort = maybeJson "missing" missingSort + lNestedFilter = maybeJson "nested_filter" nestedFilter + merged = mconcat [base, lSortMode, lMissingSort, lNestedFilter] + + toJSON (GeoDistanceSortSpec sortOrder (GeoPoint (FieldName field) latLon) units) = + object [ "unit" .= toJSON units + , field .= toJSON latLon + , "order" .= toJSON sortOrder ] + + +instance ToJSON SortOrder where + toJSON Ascending = String "asc" + toJSON Descending = String "desc" + + +instance ToJSON SortMode where + toJSON SortMin = String "min" + toJSON SortMax = String "max" + toJSON SortSum = String "sum" + toJSON SortAvg = String "avg" + + +instance ToJSON Missing where + toJSON LastMissing = String "_last" + toJSON FirstMissing = String "_first" + toJSON (CustomMissing txt) = String txt + + +instance ToJSON ScoreType where + toJSON ScoreTypeMax = "max" + toJSON ScoreTypeAvg = "avg" + toJSON ScoreTypeSum = "sum" + toJSON ScoreTypeNone = "none" + + +instance ToJSON Distance where + toJSON (Distance coefficient unit) = + String boltedTogether where + coefText = showText coefficient + (String unitText) = (toJSON unit) + boltedTogether = mappend coefText unitText + + +instance ToJSON DistanceUnit where + toJSON Miles = String "mi" + toJSON Yards = String "yd" + toJSON Feet = String "ft" + toJSON Inches = String "in" + toJSON Kilometers = String "km" + toJSON Meters = String "m" + toJSON Centimeters = String "cm" + toJSON Millimeters = String "mm" + toJSON NauticalMiles = String "nmi" + + +instance ToJSON DistanceType where + toJSON Arc = String "arc" + toJSON SloppyArc = String "sloppy_arc" + toJSON Plane = String "plane" + + +instance ToJSON OptimizeBbox where + toJSON NoOptimizeBbox = String "none" + toJSON (OptimizeGeoFilterType gft) = toJSON gft + + +instance ToJSON GeoBoundingBoxConstraint where + toJSON (GeoBoundingBoxConstraint (FieldName geoBBField) constraintBox cache) = + object [geoBBField .= toJSON constraintBox + , "_cache" .= cache] + + +instance ToJSON GeoFilterType where + toJSON GeoFilterMemory = String "memory" + toJSON GeoFilterIndexed = String "indexed" + + +instance ToJSON GeoBoundingBox where + toJSON (GeoBoundingBox topLeft bottomRight) = + object ["top_left" .= toJSON topLeft + , "bottom_right" .= toJSON bottomRight] + + +instance ToJSON LatLon where + toJSON (LatLon lat lon) = + object ["lat" .= lat + , "lon" .= lon] + + +-- index for smaller ranges, fielddata for longer ranges +instance ToJSON RangeExecution where + toJSON RangeExecutionIndex = "index" + toJSON RangeExecutionFielddata = "fielddata" + + +instance ToJSON RegexpFlags where + toJSON (RegexpFlags txt) = String txt + + +instance ToJSON Term where + toJSON (Term field value) = object ["term" .= object + [field .= value]] + + +instance ToJSON BoolMatch where + toJSON (MustMatch term cache) = object ["must" .= toJSON term, + "_cache" .= cache] + toJSON (MustNotMatch term cache) = object ["must_not" .= toJSON term, + "_cache" .= cache] + toJSON (ShouldMatch terms cache) = object ["should" .= fmap toJSON terms, + "_cache" .= cache] + + +instance (FromJSON a) => FromJSON (SearchResult a) where + parseJSON (Object v) = SearchResult <$> + v .: "took" <*> + v .: "timed_out" <*> + v .: "_shards" <*> + v .: "hits" + parseJSON _ = empty + +instance (FromJSON a) => FromJSON (SearchHits a) where + parseJSON (Object v) = SearchHits <$> + v .: "total" <*> + v .: "max_score" <*> + v .: "hits" + parseJSON _ = empty + +instance (FromJSON a) => FromJSON (Hit a) where + parseJSON (Object v) = Hit <$> + v .: "_index" <*> + v .: "_type" <*> + v .: "_id" <*> + v .: "_score" <*> + v .: "_source" + parseJSON _ = empty + +instance FromJSON ShardResult where + parseJSON (Object v) = ShardResult <$> + v .: "total" <*> + v .: "successful" <*> + v .: "failed" + parseJSON _ = empty diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,202 @@ + + 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. + + 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. + + Copyright [yyyy] [name of copyright owner] + + 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 + + http://www.apache.org/licenses/LICENSE-2.0 + + 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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/bloodhound.cabal b/bloodhound.cabal new file mode 100644 --- /dev/null +++ b/bloodhound.cabal @@ -0,0 +1,69 @@ +-- Initial bloodhound.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/ + +name: bloodhound +version: 0.1.0.0 +synopsis: ElasticSearch client library for Haskell +description: ElasticSearch made awesome for Haskell hackers +homepage: github.com/bitemyapp/bloodhound +license: Apache-2.0 +license-file: LICENSE +author: Chris Allen +maintainer: cma@bitemyapp.com +copyright: 2014, Chris Allen +category: Database, Search +build-type: Simple +cabal-version: >=1.10 + +library + ghc-options: -Wall + default-extensions: OverloadedStrings + exposed-modules: Database.Bloodhound + Database.Bloodhound.Client + Database.Bloodhound.Types + Database.Bloodhound.Types.Class + Database.Bloodhound.Types.Instances + build-depends: base >=4.3 && <5, + bytestring >= 0.10, + transformers >= 0.3, + free >= 4.5, + lens >= 4, + aeson >= 0.7, + aeson-pretty >= 0.7, + conduit >= 1.0, + http-conduit >= 2.0, + io-streams >= 1.1, + http-streams >= 0.7, + HTTP >= 4000.2, + time >= 1.4, + text >= 0.11, + http-types >= 0.8, + blaze-builder >= 0.3, + failure >= 0.2, + semigroups >= 0.12, + containers , + scientific + default-language: Haskell2010 + +test-suite tests + ghc-options: -Wall + default-extensions: OverloadedStrings + type: exitcode-stdio-1.0 + main-is: tests.hs + -- ghc-options: -w -threaded -rtsopts -with-rtsopts=-N + hs-source-dirs: tests + build-depends: base, + bloodhound, + http-conduit, + http-types, + bytestring >= 0.10, + hspec >= 1.8, + QuickCheck >= 2.5, + derive >= 2.5, + text >= 0.11, + time >= 1.4, + aeson >= 0.7, + aeson-pretty >= 0.7, + random >= 1.0, + quickcheck-instances >= 0.3 + default-language: Haskell2010 diff --git a/tests/tests.hs b/tests/tests.hs new file mode 100644 --- /dev/null +++ b/tests/tests.hs @@ -0,0 +1,330 @@ +{-# LANGUAGE DeriveGeneric #-} + +module Main where + +import Database.Bloodhound +import Data.Aeson +-- import Data.Aeson.Encode.Pretty +-- import Data.ByteString.Lazy.Char8 (putStrLn) +import Data.Time.Calendar (Day(..)) +import Data.Time.Clock (secondsToDiffTime, UTCTime(..)) +import Data.Text (Text) +import GHC.Generics (Generic) +import Network.HTTP.Conduit +import qualified Network.HTTP.Types.Status as NHTS +import Prelude hiding (filter, putStrLn) +import Test.Hspec + +testServer :: Server +testServer = Server "http://localhost:9200" +testIndex :: IndexName +testIndex = IndexName "twitter" +testMapping :: MappingName +testMapping = MappingName "tweet" + +validateStatus :: Response body -> Int -> Expectation +validateStatus resp expected = + (NHTS.statusCode $ responseStatus resp) + `shouldBe` (expected :: Int) + +createExampleIndex :: IO Reply +createExampleIndex = createIndex testServer defaultIndexSettings testIndex +deleteExampleIndex :: IO Reply +deleteExampleIndex = deleteIndex testServer testIndex + +data Location = Location { lat :: Double + , lon :: Double } deriving (Eq, Generic, Show) + +data Tweet = Tweet { user :: Text + , postDate :: UTCTime + , message :: Text + , age :: Int + , location :: Location } + deriving (Eq, Generic, Show) + +instance ToJSON Tweet +instance FromJSON Tweet +instance ToJSON Location +instance FromJSON Location + +data TweetMapping = TweetMapping deriving (Eq, Show) + +instance ToJSON TweetMapping where + toJSON TweetMapping = + object ["tweet" .= + object ["properties" .= + object ["location" .= object ["type" .= ("geo_point" :: Text)]]]] + +exampleTweet :: Tweet +exampleTweet = Tweet { user = "bitemyapp" + , postDate = UTCTime + (ModifiedJulianDay 55000) + (secondsToDiffTime 10) + , message = "Use haskell!" + , age = 10000 + , location = Location 40.12 (-71.34) } + +otherTweet :: Tweet +otherTweet = Tweet { user = "notmyapp" + , postDate = UTCTime + (ModifiedJulianDay 55000) + (secondsToDiffTime 11) + , message = "Use haskell!" + , age = 1000 + , location = Location 40.12 (-71.34) } + +insertData :: IO () +insertData = do + _ <- deleteExampleIndex + _ <- createExampleIndex + _ <- createMapping testServer testIndex testMapping TweetMapping + _ <- indexDocument testServer testIndex testMapping exampleTweet (DocId "1") + _ <- refreshIndex testServer testIndex + return () + +insertOther :: IO () +insertOther = do + _ <- indexDocument testServer testIndex testMapping otherTweet (DocId "2") + _ <- refreshIndex testServer testIndex + return () + +searchTweet :: Search -> IO (Either String Tweet) +searchTweet search = do + reply <- searchByIndex testServer testIndex search + let result = eitherDecode (responseBody reply) :: Either String (SearchResult Tweet) + let myTweet = fmap (hitSource . head . hits . searchHits) result + return myTweet + +searchExpectNoResults :: Search -> IO () +searchExpectNoResults search = do + reply <- searchByIndex testServer testIndex search + let result = eitherDecode (responseBody reply) :: Either String (SearchResult Tweet) + let emptyHits = fmap (hits . searchHits) result + emptyHits `shouldBe` Right [] + +data BulkTest = BulkTest { name :: Text } deriving (Eq, Generic, Show) +instance FromJSON BulkTest +instance ToJSON BulkTest + +main :: IO () +main = hspec $ do + + describe "index create/delete API" $ do + it "creates and then deletes the requested index" $ do + -- priming state. + _ <- deleteExampleIndex + resp <- createExampleIndex + deleteResp <- deleteExampleIndex + validateStatus resp 200 + validateStatus deleteResp 200 + + + describe "document API" $ do + it "indexes, gets, and then deletes the generated document" $ do + _ <- insertData + docInserted <- getDocument testServer testIndex testMapping (DocId "1") + let newTweet = eitherDecode + (responseBody docInserted) :: Either String (EsResult Tweet) + fmap _source newTweet `shouldBe` Right exampleTweet + + + describe "bulk API" $ do + it "inserts all documents we request" $ do + _ <- insertData + let firstTest = BulkTest "blah" + let secondTest = BulkTest "bloo" + let firstDoc = BulkIndex (IndexName "twitter") + (MappingName "tweet") (DocId "2") (object ["name" .= String "blah"]) + let secondDoc = BulkCreate (IndexName "twitter") + (MappingName "tweet") (DocId "3") (object ["name" .= String "bloo"]) + let stream = [firstDoc, secondDoc] + _ <- bulk testServer stream + _ <- refreshIndex testServer testIndex + fDoc <- getDocument testServer testIndex testMapping (DocId "2") + sDoc <- getDocument testServer testIndex testMapping (DocId "3") + let maybeFirst = eitherDecode $ responseBody fDoc :: Either String (EsResult BulkTest) + let maybeSecond = eitherDecode $ responseBody sDoc :: Either String (EsResult BulkTest) + fmap _source maybeFirst `shouldBe` Right firstTest + fmap _source maybeSecond `shouldBe` Right secondTest + + + describe "query API" $ do + it "returns document for term query and identity filter" $ do + _ <- insertData + let query = TermQuery (Term "user" "bitemyapp") Nothing + let filter = IdentityFilter <&&> IdentityFilter + let search = mkSearch (Just query) (Just filter) + myTweet <- searchTweet search + myTweet `shouldBe` Right exampleTweet + + it "returns document for match query" $ do + _ <- insertData + let query = QueryMatchQuery $ mkMatchQuery (FieldName "user") (QueryString "bitemyapp") + let search = mkSearch (Just query) Nothing + myTweet <- searchTweet search + myTweet `shouldBe` Right exampleTweet + + it "returns document for multi-match query" $ do + _ <- insertData + let fields = [FieldName "user", FieldName "message"] + let query = QueryMultiMatchQuery $ mkMultiMatchQuery fields (QueryString "bitemyapp") + let search = mkSearch (Just query) Nothing + myTweet <- searchTweet search + myTweet `shouldBe` Right exampleTweet + + it "returns document for bool query" $ do + _ <- insertData + let innerQuery = QueryMatchQuery $ + mkMatchQuery (FieldName "user") (QueryString "bitemyapp") + let query = QueryBoolQuery $ + mkBoolQuery (Just innerQuery) Nothing Nothing + let search = mkSearch (Just query) Nothing + myTweet <- searchTweet search + myTweet `shouldBe` Right exampleTweet + + it "returns document for boosting query" $ do + _ <- insertData + let posQuery = QueryMatchQuery $ mkMatchQuery (FieldName "user") (QueryString "bitemyapp") + let negQuery = QueryMatchQuery $ mkMatchQuery (FieldName "user") (QueryString "notmyapp") + let query = QueryBoostingQuery $ BoostingQuery posQuery negQuery (Boost 0.2) + let search = mkSearch (Just query) Nothing + myTweet <- searchTweet search + myTweet `shouldBe` Right exampleTweet + + it "returns document for common terms query" $ do + _ <- insertData + let query = QueryCommonTermsQuery $ + CommonTermsQuery (FieldName "user") + (QueryString "bitemyapp") + (CutoffFrequency 0.0001) + Or Or Nothing Nothing Nothing Nothing + let search = mkSearch (Just query) Nothing + myTweet <- searchTweet search + myTweet `shouldBe` Right exampleTweet + + + describe "sorting" $ do + it "returns documents in the right order" $ do + _ <- insertData + _ <- insertOther + let sortSpec = DefaultSortSpec $ mkSort (FieldName "age") Ascending + let search = Search Nothing + (Just IdentityFilter) (Just [sortSpec]) + False 0 10 + reply <- searchByIndex testServer testIndex search + let result = eitherDecode (responseBody reply) :: Either String (SearchResult Tweet) + let myTweet = fmap (hitSource . head . hits . searchHits) result + myTweet `shouldBe` Right otherTweet + + + describe "filtering API" $ do + it "returns document for composed boolmatch and identity" $ do + _ <- insertData + let queryFilter = BoolFilter (MustMatch (Term "user" "bitemyapp") False) + <&&> IdentityFilter + let search = mkSearch Nothing (Just queryFilter) + myTweet <- searchTweet search + myTweet `shouldBe` Right exampleTweet + + it "returns document for existential filter" $ do + _ <- insertData + let search = mkSearch Nothing (Just (ExistsFilter (FieldName "user"))) + myTweet <- searchTweet search + myTweet `shouldBe` Right exampleTweet + + it "returns document for geo boundingbox filter" $ do + _ <- insertData + let box = GeoBoundingBox (LatLon 40.73 (-74.1)) (LatLon 40.10 (-71.12)) + let bbConstraint = GeoBoundingBoxConstraint (FieldName "tweet.location") box False + let geoFilter = GeoBoundingBoxFilter bbConstraint GeoFilterMemory + let search = mkSearch Nothing (Just geoFilter) + myTweet <- searchTweet search + myTweet `shouldBe` Right exampleTweet + + it "doesn't return document for nonsensical boundingbox filter" $ do + _ <- insertData + let box = GeoBoundingBox (LatLon 0.73 (-4.1)) (LatLon 0.10 (-1.12)) + let bbConstraint = GeoBoundingBoxConstraint (FieldName "tweet.location") box False + let geoFilter = GeoBoundingBoxFilter bbConstraint GeoFilterMemory + let search = mkSearch Nothing (Just geoFilter) + searchExpectNoResults search + + it "returns document for geo distance filter" $ do + _ <- insertData + let geoPoint = GeoPoint (FieldName "tweet.location") (LatLon 40.12 (-71.34)) + let distance = Distance 10.0 Miles + let optimizeBbox = OptimizeGeoFilterType GeoFilterMemory + let geoFilter = GeoDistanceFilter geoPoint distance SloppyArc optimizeBbox False + let search = mkSearch Nothing (Just geoFilter) + myTweet <- searchTweet search + myTweet `shouldBe` Right exampleTweet + + it "returns document for geo distance range filter" $ do + _ <- insertData + let geoPoint = GeoPoint (FieldName "tweet.location") (LatLon 40.12 (-71.34)) + let distanceRange = DistanceRange (Distance 0.0 Miles) (Distance 10.0 Miles) + let geoFilter = GeoDistanceRangeFilter geoPoint distanceRange + let search = mkSearch Nothing (Just geoFilter) + myTweet <- searchTweet search + myTweet `shouldBe` Right exampleTweet + + it "doesn't return document for wild geo distance range filter" $ do + _ <- insertData + let geoPoint = GeoPoint (FieldName "tweet.location") (LatLon 40.12 (-71.34)) + let distanceRange = DistanceRange (Distance 100.0 Miles) (Distance 1000.0 Miles) + let geoFilter = GeoDistanceRangeFilter geoPoint distanceRange + let search = mkSearch Nothing (Just geoFilter) + searchExpectNoResults search + + it "returns document for geo polygon filter" $ do + _ <- insertData + let points = [LatLon 40.0 (-70.00), + LatLon 40.0 (-72.00), + LatLon 41.0 (-70.00), + LatLon 41.0 (-72.00)] + let geoFilter = GeoPolygonFilter (FieldName "tweet.location") points + let search = mkSearch Nothing (Just geoFilter) + myTweet <- searchTweet search + myTweet `shouldBe` Right exampleTweet + + it "doesn't return document for bad geo polygon filter" $ do + _ <- insertData + let points = [LatLon 40.0 (-70.00), + LatLon 40.0 (-71.00), + LatLon 41.0 (-70.00), + LatLon 41.0 (-71.00)] + let geoFilter = GeoPolygonFilter (FieldName "tweet.location") points + let search = mkSearch Nothing (Just geoFilter) + searchExpectNoResults search + + it "returns document for ids filter" $ do + _ <- insertData + let filter = IdsFilter (MappingName "tweet") [DocId "1"] + let search = mkSearch Nothing (Just filter) + myTweet <- searchTweet search + myTweet `shouldBe` Right exampleTweet + + it "returns document for range filter" $ do + _ <- insertData + let filter = RangeFilter (FieldName "age") + (Right (RangeLtGt (LessThan 100000.0) (GreaterThan 1000.0))) + RangeExecutionIndex False + let search = mkSearch Nothing (Just filter) + myTweet <- searchTweet search + myTweet `shouldBe` Right exampleTweet + + it "returns document for regexp filter" $ do + _ <- insertData + let filter = RegexpFilter (FieldName "user") (Regexp "bite.*app") + (RegexpFlags "ALL") (CacheName "test") False (CacheKey "key") + let search = mkSearch Nothing (Just filter) + myTweet <- searchTweet search + myTweet `shouldBe` Right exampleTweet + + it "doesn't return document for non-matching regexp filter" $ do + _ <- insertData + let filter = RegexpFilter (FieldName "user") + (Regexp "boy") (RegexpFlags "ALL") + (CacheName "test") False (CacheKey "key") + let search = mkSearch Nothing (Just filter) + searchExpectNoResults search