diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,51 +1,7 @@ -{-# OPTIONS_GHC -Wall #-} -module Main (main) where +#!/usr/bin/env runhaskell -import Data.List ( nub ) -import Data.Version ( showVersion ) -import Distribution.Package ( PackageName(PackageName), Package, PackageId, InstalledPackageId, packageVersion, packageName ) -import Distribution.PackageDescription ( PackageDescription(), TestSuite(..) ) -import Distribution.Simple ( defaultMainWithHooks, UserHooks(..), simpleUserHooks ) -import Distribution.Simple.Utils ( rewriteFile, createDirectoryIfMissingVerbose, copyFiles ) -import Distribution.Simple.BuildPaths ( autogenModulesDir ) -import Distribution.Simple.Setup ( BuildFlags(buildVerbosity), Flag(..), fromFlag, HaddockFlags(haddockDistPref)) -import Distribution.Simple.LocalBuildInfo ( withLibLBI, withTestLBI, LocalBuildInfo(), ComponentLocalBuildInfo(componentPackageDeps) ) -import Distribution.Text ( display ) -import Distribution.Verbosity ( Verbosity, normal ) -import System.FilePath ( () ) +module Main where +import Distribution.Simple main :: IO () -main = defaultMainWithHooks simpleUserHooks - { buildHook = \pkg lbi hooks flags -> do - generateBuildModule (fromFlag (buildVerbosity flags)) pkg lbi - buildHook simpleUserHooks pkg lbi hooks flags - , postHaddock = \args flags pkg lbi -> do - -- copyFiles normal (haddockOutputDir flags pkg) [("images","Hierarchy.png")] - postHaddock simpleUserHooks args flags pkg lbi - } - -haddockOutputDir :: Package p => HaddockFlags -> p -> FilePath -haddockOutputDir flags pkg = destDir where - baseDir = case haddockDistPref flags of - NoFlag -> "." - Flag x -> x - destDir = baseDir "doc" "html" display (packageName pkg) - -generateBuildModule :: Verbosity -> PackageDescription -> LocalBuildInfo -> IO () -generateBuildModule verbosity pkg lbi = do - let dir = autogenModulesDir lbi - createDirectoryIfMissingVerbose verbosity True dir - withLibLBI pkg lbi $ \_ libcfg -> do - withTestLBI pkg lbi $ \suite suitecfg -> do - rewriteFile (dir "Build_" ++ testName suite ++ ".hs") $ unlines - [ "module Build_" ++ testName suite ++ " where" - , "deps :: [String]" - , "deps = " ++ (show $ formatdeps (testDeps libcfg suitecfg)) - ] - where - formatdeps = map (formatone . snd) - formatone p = case packageName p of - PackageName n -> n ++ "-" ++ showVersion (packageVersion p) - -testDeps :: ComponentLocalBuildInfo -> ComponentLocalBuildInfo -> [(InstalledPackageId, PackageId)] -testDeps xs ys = nub $ componentPackageDeps xs ++ componentPackageDeps ys +main = defaultMain diff --git a/bloodhound.cabal b/bloodhound.cabal --- a/bloodhound.cabal +++ b/bloodhound.cabal @@ -1,5 +1,5 @@ name: bloodhound -version: 0.7.0.1 +version: 0.8.0.0 synopsis: ElasticSearch client library for Haskell description: ElasticSearch made awesome for Haskell hackers homepage: https://github.com/bitemyapp/bloodhound @@ -28,7 +28,7 @@ containers >= 0.5.0.0 && <0.6, aeson >= 0.7 && <0.10, http-client >= 0.3 && <0.5, - semigroups >= 0.15 && <0.17, + semigroups >= 0.15 && <0.18, time >= 1.4 && <1.6, text >= 0.11 && <1.3, mtl >= 1.0 && <2.3, @@ -38,7 +38,9 @@ uri-bytestring >= 0.1 && <0.2, exceptions, data-default-class, - blaze-builder + blaze-builder, + unordered-containers, + mtl-compat default-language: Haskell2010 test-suite tests @@ -65,15 +67,20 @@ default-language: Haskell2010 test-suite doctests + ghc-options: -threaded -Wall default-language: Haskell2010 type: exitcode-stdio-1.0 main-is: doctests.hs - hs-source-dirs: tests + hs-source-dirs: tests, src if impl(ghc >= 7.8) build-depends: base, directory, - doctest, + doctest >= 0.10.1, doctest-prop, filepath else buildable: False + +Source-Repository head + Type: git + Location: git://github.com/bitemyapp/bloodhound.git diff --git a/src/Database/Bloodhound/Client.hs b/src/Database/Bloodhound/Client.hs --- a/src/Database/Bloodhound/Client.hs +++ b/src/Database/Bloodhound/Client.hs @@ -1,5 +1,5 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} ------------------------------------------------------------------------------- -- | @@ -27,6 +27,9 @@ , indexExists , openIndex , closeIndex + , putTemplate + , templateExists + , deleteTemplate , putMapping , deleteMapping , indexDocument @@ -36,6 +39,7 @@ , searchAll , searchByIndex , searchByType + , scanSearch , refreshIndex , mkSearch , mkAggregateSearch @@ -88,7 +92,7 @@ -- >>> let runBH' = withBH defaultManagerSettings testServer -- >>> let testIndex = IndexName "twitter" -- >>> let testMapping = MappingName "tweet" --- >>> let defaultIndexSettings = IndexSettings (ShardCount 3) (ReplicaCount 2) +-- >>> let defaultIndexSettings = IndexSettings (ShardCount 1) (ReplicaCount 0) -- >>> data TweetMapping = TweetMapping deriving (Eq, Show) -- >>> _ <- runBH' $ deleteIndex testIndex >> deleteMapping testIndex testMapping -- >>> import GHC.Generics @@ -168,6 +172,18 @@ Server s <- bhServer <$> getBHEnv return $ joinPath' (s:ps) +appendSearchTypeParam :: Text -> SearchType -> Text +appendSearchTypeParam originalUrl st = addQuery params originalUrl + where stText = "search_type" + params + | st == SearchTypeDfsQueryThenFetch = [(stText, Just "dfs_query_then_fetch")] + | st == SearchTypeCount = [(stText, Just "count")] + | st == SearchTypeScan = [(stText, Just "scan"), ("scroll", Just "1m")] + | st == SearchTypeQueryAndFetch = [(stText, Just "query_and_fetch")] + | st == SearchTypeDfsQueryAndFetch = [(stText, Just "dfs_query_and_fetch")] + -- used to catch 'SearchTypeQueryThenFetch', which is also the default + | otherwise = [(stText, Just "query_then_fetch")] + -- | Severely dumbed down query renderer. Assumes your data doesn't -- need any encoding addQuery :: [(Text, Maybe Text)] -> Text -> Text @@ -177,17 +193,17 @@ T.decodeUtf8 $ BB.toByteString $ NHTU.renderQueryText prependQuestionMark q prependQuestionMark = True - bindM2 :: (Applicative m, Monad m) => (a -> b -> m c) -> m a -> m b -> m c bindM2 f ma mb = join (f <$> ma <*> mb) --- | Convenience function that sets up a mananager and BHEnv and runs +-- | Convenience function that sets up a manager and BHEnv and runs -- the given set of bloodhound operations. Connections will be -- pipelined automatically in accordance with the given manager -- settings in IO. If you've got your own monad transformer stack, you -- should use 'runBH' directly. withBH :: ManagerSettings -> Server -> BH IO a -> IO a -withBH ms s f = withManager ms $ \mgr -> do +withBH ms s f = do + mgr <- newManager ms let env = BHEnv { bhServer = s , bhManager = mgr } runBH env f @@ -200,7 +216,7 @@ head :: MonadBH m => Text -> m Reply head = flip (dispatch NHTM.methodHead) Nothing put :: MonadBH m => Text -> Maybe L.ByteString -> m Reply -put = dispatch NHTM.methodPost +put = dispatch NHTM.methodPut post :: MonadBH m => Text -> Maybe L.ByteString -> m Reply post = dispatch NHTM.methodPost @@ -301,6 +317,35 @@ closeIndex :: MonadBH m => IndexName -> m Reply closeIndex = openOrCloseIndexes CloseIndex +-- | 'putTemplate' creates a template given an 'IndexTemplate' and a 'TemplateName'. +-- Explained in further detail at +-- +-- +-- >>> let idxTpl = IndexTemplate (TemplatePattern "tweet-*") (Just (IndexSettings (ShardCount 1) (ReplicaCount 1))) [toJSON TweetMapping] +-- >>> resp <- runBH' $ putTemplate idxTpl (TemplateName "tweet-tpl") +putTemplate :: MonadBH m => IndexTemplate -> TemplateName -> m Reply +putTemplate indexTemplate (TemplateName templateName) = + bindM2 put url (return body) + where url = joinPath ["_template", templateName] + body = Just $ encode indexTemplate + +-- | 'templateExists' checks to see if a template exists. +-- +-- >>> exists <- runBH' $ templateExists (TemplateName "tweet-tpl") +templateExists :: MonadBH m => TemplateName -> m Bool +templateExists (TemplateName templateName) = do + (_, exists) <- existentialQuery =<< joinPath ["_template", templateName] + return exists + +-- | 'deleteTemplate' is an HTTP DELETE and deletes a template. +-- +-- >>> let idxTpl = IndexTemplate (TemplatePattern "tweet-*") (Just (IndexSettings (ShardCount 1) (ReplicaCount 1))) [toJSON TweetMapping] +-- >>> _ <- runBH' $ putTemplate idxTpl (TemplateName "tweet-tpl") +-- >>> resp <- runBH' $ deleteTemplate (TemplateName "tweet-tpl") +deleteTemplate :: MonadBH m => TemplateName -> m Reply +deleteTemplate (TemplateName templateName) = + delete =<< joinPath ["_template", templateName] + -- | 'putMapping' is an HTTP PUT and has upsert semantics. Mappings are schemas -- for documents in indexes. -- @@ -312,7 +357,9 @@ -> MappingName -> a -> m Reply putMapping (IndexName indexName) (MappingName mappingName) mapping = bindM2 put url (return body) - where url = joinPath [indexName, mappingName, "_mapping"] + where url = joinPath [indexName, "_mapping", mappingName] + -- "_mapping" and mappingName above were originally transposed + -- erroneously. The correct API call is: "/INDEX/_mapping/MAPPING_NAME" body = Just $ encode mapping -- | 'deleteMapping' is an HTTP DELETE and deletes a mapping for a given index. @@ -326,7 +373,9 @@ deleteMapping :: MonadBH m => IndexName -> MappingName -> m Reply deleteMapping (IndexName indexName) (MappingName mappingName) = - delete =<< joinPath [indexName, mappingName, "_mapping"] + -- "_mapping" and mappingName below were originally transposed + -- erroneously. The correct API call is: "/INDEX/_mapping/MAPPING_NAME" + delete =<< joinPath [indexName, "_mapping", mappingName] -- | 'indexDocument' is the primary way to save a single document in -- Elasticsearch. The document itself is simply something we can @@ -342,7 +391,7 @@ (MappingName mappingName) cfg document (DocId docId) = bindM2 put url (return body) where url = addQuery params <$> joinPath [indexName, mappingName, docId] - params = case idsVersionControl cfg of + versionCtlParams = case idsVersionControl cfg of NoVersionControl -> [] InternalVersion v -> versionParams v "internal" ExternalGT (ExternalDocVersion v) -> versionParams v "external_gt" @@ -352,6 +401,10 @@ versionParams v t = [ ("version", Just $ vt v) , ("version_type", Just t) ] + parentParams = case idsParent cfg of + Nothing -> [] + Just (DocumentParent (DocId p)) -> [ ("parent", Just p) ] + params = versionCtlParams ++ parentParams body = Just (encode document) -- | 'deleteDocument' is the primary way to delete a single document. @@ -456,7 +509,8 @@ where url = joinPath [indexName, mappingName, docId] dispatchSearch :: MonadBH m => Text -> Search -> m Reply -dispatchSearch url search = post url (Just (encode search)) +dispatchSearch url search = post url' (Just (encode search)) + where url' = appendSearchTypeParam url (searchType search) -- | 'searchAll', given a 'Search', will perform that search against all indexes -- on an Elasticsearch server. Try to avoid doing this if it can be helped. @@ -490,6 +544,42 @@ (MappingName mappingName) = bindM2 dispatchSearch url . return where url = joinPath [indexName, mappingName, "_search"] +scanSearch' :: MonadBH m => IndexName -> MappingName -> Search -> m (Maybe ScrollId) +scanSearch' (IndexName indexName) (MappingName mappingName) search = do + let url = joinPath [indexName, mappingName, "_search"] + search' = search { searchType = SearchTypeScan } + resp' <- bindM2 dispatchSearch url (return search') + let msr = decode' $ responseBody resp' :: Maybe (SearchResult ()) + msid = maybe Nothing scrollId msr + return msid + +scroll' :: (FromJSON a, MonadBH m) => Maybe ScrollId -> m ([Hit a], Maybe ScrollId) +scroll' Nothing = return ([], Nothing) +scroll' (Just sid) = do + url <- joinPath ["_search/scroll?scroll=1m"] + resp' <- post url (Just . L.fromStrict $ T.encodeUtf8 sid) + let msr = decode' $ responseBody resp' :: FromJSON a => Maybe (SearchResult a) + resp = case msr of + Just sr -> (hits $ searchHits sr, scrollId sr) + _ -> ([], Nothing) + return resp + +simpleAccumilator :: (FromJSON a, MonadBH m) => [Hit a] -> ([Hit a], Maybe ScrollId) -> m ([Hit a], Maybe ScrollId) +simpleAccumilator oldHits (newHits, Nothing) = return (oldHits ++ newHits, Nothing) +simpleAccumilator oldHits ([], _) = return (oldHits, Nothing) +simpleAccumilator oldHits (newHits, msid) = do + (newHits', msid') <- scroll' msid + simpleAccumilator (oldHits ++ newHits) (newHits', msid') + +-- | 'scanSearch' uses the 'scan&scroll' API of elastic, +-- for a given 'IndexName' and 'MappingName', +scanSearch :: (FromJSON a, MonadBH m) => IndexName -> MappingName -> Search -> m [Hit a] +scanSearch indexName mappingName search = do + msid <- scanSearch' indexName mappingName search + (hits, msid') <- scroll' msid + (totalHits, _) <- simpleAccumilator [] (hits, msid') + return totalHits + -- | 'mkSearch' is a helper function for defaulting additional fields of a 'Search' -- to Nothing in case you only care about your 'Query' and 'Filter'. Use record update -- syntax if you want to add things like aggregations or highlights while still using @@ -497,9 +587,9 @@ -- -- >>> let query = TermQuery (Term "user" "bitemyapp") Nothing -- >>> mkSearch (Just query) Nothing --- Search {queryBody = Just (TermQuery (Term {termField = "user", termValue = "bitemyapp"}) Nothing), filterBody = Nothing, sortBody = Nothing, aggBody = Nothing, highlight = Nothing, trackSortScores = False, from = From 0, size = Size 10} +-- Search {queryBody = Just (TermQuery (Term {termField = "user", termValue = "bitemyapp"}) Nothing), filterBody = Nothing, sortBody = Nothing, aggBody = Nothing, highlight = Nothing, trackSortScores = False, from = From 0, size = Size 10, searchType = SearchTypeQueryThenFetch, fields = Nothing, source = Nothing} mkSearch :: Maybe Query -> Maybe Filter -> Search -mkSearch query filter = Search query filter Nothing Nothing Nothing False (From 0) (Size 10) +mkSearch query filter = Search query filter Nothing Nothing Nothing False (From 0) (Size 10) SearchTypeQueryThenFetch Nothing Nothing -- | 'mkAggregateSearch' is a helper function that defaults everything in a 'Search' except for -- the 'Query' and the 'Aggregation'. @@ -509,7 +599,7 @@ -- TermsAgg (TermsAggregation {term = Left "user", termInclude = Nothing, termExclude = Nothing, termOrder = Nothing, termMinDocCount = Nothing, termSize = Nothing, termShardSize = Nothing, termCollectMode = Just BreadthFirst, termExecutionHint = Nothing, termAggs = Nothing}) -- >>> let myAggregation = mkAggregateSearch Nothing $ mkAggregations "users" terms mkAggregateSearch :: Maybe Query -> Aggregations -> Search -mkAggregateSearch query mkSearchAggs = Search query Nothing Nothing (Just mkSearchAggs) Nothing False (From 0) (Size 0) +mkAggregateSearch query mkSearchAggs = Search query Nothing Nothing (Just mkSearchAggs) Nothing False (From 0) (Size 0) SearchTypeQueryThenFetch Nothing Nothing -- | 'mkHighlightSearch' is a helper function that defaults everything in a 'Search' except for -- the 'Query' and the 'Aggregation'. @@ -518,7 +608,7 @@ -- >>> let testHighlight = Highlights Nothing [FieldHighlight (FieldName "message") Nothing] -- >>> let search = mkHighlightSearch (Just query) testHighlight mkHighlightSearch :: Maybe Query -> Highlights -> Search -mkHighlightSearch query searchHighlights = Search query Nothing Nothing Nothing (Just searchHighlights) False (From 0) (Size 10) +mkHighlightSearch query searchHighlights = Search query Nothing Nothing Nothing (Just searchHighlights) False (From 0) (Size 10) SearchTypeQueryThenFetch Nothing Nothing -- | 'pageSearch' is a helper function that takes a search and assigns the from -- and size fields for the search. The from parameter defines the offset @@ -528,9 +618,9 @@ -- >>> let query = QueryMatchQuery $ mkMatchQuery (FieldName "_all") (QueryString "haskell") -- >>> let search = mkSearch (Just query) Nothing -- >>> search --- Search {queryBody = Just (QueryMatchQuery (MatchQuery {matchQueryField = FieldName "_all", matchQueryQueryString = QueryString "haskell", matchQueryOperator = Or, matchQueryZeroTerms = ZeroTermsNone, matchQueryCutoffFrequency = Nothing, matchQueryMatchType = Nothing, matchQueryAnalyzer = Nothing, matchQueryMaxExpansions = Nothing, matchQueryLenient = Nothing})), filterBody = Nothing, sortBody = Nothing, aggBody = Nothing, highlight = Nothing, trackSortScores = False, from = From 0, size = Size 10} +-- Search {queryBody = Just (QueryMatchQuery (MatchQuery {matchQueryField = FieldName "_all", matchQueryQueryString = QueryString "haskell", matchQueryOperator = Or, matchQueryZeroTerms = ZeroTermsNone, matchQueryCutoffFrequency = Nothing, matchQueryMatchType = Nothing, matchQueryAnalyzer = Nothing, matchQueryMaxExpansions = Nothing, matchQueryLenient = Nothing, matchQueryBoost = Nothing})), filterBody = Nothing, sortBody = Nothing, aggBody = Nothing, highlight = Nothing, trackSortScores = False, from = From 0, size = Size 10, searchType = SearchTypeQueryThenFetch, fields = Nothing, source = Nothing} -- >>> pageSearch (From 10) (Size 100) search --- Search {queryBody = Just (QueryMatchQuery (MatchQuery {matchQueryField = FieldName "_all", matchQueryQueryString = QueryString "haskell", matchQueryOperator = Or, matchQueryZeroTerms = ZeroTermsNone, matchQueryCutoffFrequency = Nothing, matchQueryMatchType = Nothing, matchQueryAnalyzer = Nothing, matchQueryMaxExpansions = Nothing, matchQueryLenient = Nothing})), filterBody = Nothing, sortBody = Nothing, aggBody = Nothing, highlight = Nothing, trackSortScores = False, from = From 10, size = Size 100} +-- Search {queryBody = Just (QueryMatchQuery (MatchQuery {matchQueryField = FieldName "_all", matchQueryQueryString = QueryString "haskell", matchQueryOperator = Or, matchQueryZeroTerms = ZeroTermsNone, matchQueryCutoffFrequency = Nothing, matchQueryMatchType = Nothing, matchQueryAnalyzer = Nothing, matchQueryMaxExpansions = Nothing, matchQueryLenient = Nothing, matchQueryBoost = Nothing})), filterBody = Nothing, sortBody = Nothing, aggBody = Nothing, highlight = Nothing, trackSortScores = False, from = From 10, size = Size 100, searchType = SearchTypeQueryThenFetch, fields = Nothing, source = Nothing} pageSearch :: From -- ^ The result offset -> Size -- ^ The number of results to return -> Search -- ^ The current seach diff --git a/src/Database/Bloodhound/Types.hs b/src/Database/Bloodhound/Types.hs --- a/src/Database/Bloodhound/Types.hs +++ b/src/Database/Bloodhound/Types.hs @@ -47,7 +47,7 @@ , toTerms , toDateHistogram , omitNulls - , BH + , BH(..) , runBH , BHEnv(..) , MonadBH(..) @@ -56,20 +56,30 @@ , Existence(..) , NullValue(..) , IndexSettings(..) + , IndexTemplate(..) , Server(..) , Reply , EsResult(..) + , EsResultFound(..) , DocVersion , ExternalDocVersion(..) , VersionControl(..) + , DocumentParent(..) , IndexDocumentSettings(..) , Query(..) , Search(..) + , SearchType(..) , SearchResult(..) + , ScrollId , SearchHits(..) , TrackSortScores , From(..) , Size(..) + , Source(..) + , PatternOrPatterns(..) + , Include(..) + , Exclude(..) + , Pattern(..) , ShardResult(..) , Hit(..) , Filter(..) @@ -100,7 +110,10 @@ , RegexpFlags(..) , RegexpFlag(..) , FieldName(..) + , Script(..) , IndexName(..) + , TemplateName(..) + , TemplatePattern(..) , MappingName(..) , DocId(..) , CacheName(..) @@ -196,6 +209,8 @@ , Bucket(..) , BucketAggregation(..) , TermsAggregation(..) + , ValueCountAggregation(..) + , FilterAggregation(..) , DateHistogramAggregation(..) , Highlights(..) @@ -215,14 +230,16 @@ ) where import Control.Applicative -import Control.Monad.Error +import Control.Monad.Catch +import Control.Monad.Except import Control.Monad.Reader import Control.Monad.State import Control.Monad.Writer import Data.Aeson import Data.Aeson.Types (Pair, emptyObject, parseMaybe) import qualified Data.ByteString.Lazy.Char8 as L -import Data.List (nub) +import qualified Data.HashMap.Strict as HM (union) +import Data.List (foldl', nub) import Data.List.NonEmpty (NonEmpty (..), toList) import qualified Data.Map.Strict as M import Data.Maybe @@ -274,7 +291,10 @@ , MonadError e , Alternative , MonadPlus - , MonadFix) + , MonadFix + , MonadThrow + , MonadCatch + , MonadMask) instance MonadTrans BH where lift = BH . lift @@ -348,6 +368,20 @@ data FieldDefinition = FieldDefinition { fieldType :: FieldType } deriving (Eq, Show) +{-| An 'IndexTemplate' defines a template that will automatically be + applied to new indices created. The templates include both + 'IndexSettings' and mappings, and a simple 'TemplatePattern' that + controls if the template will be applied to the index created. + Specify mappings as follows: @[toJSON TweetMapping, ...]@ + + https://www.elastic.co/guide/en/elasticsearch/reference/1.7/indices-templates.html +-} +data IndexTemplate = + IndexTemplate { templatePattern :: TemplatePattern + , templateSettings :: Maybe IndexSettings + , templateMappings :: [Value] + } + data MappingField = MappingField { mappingFieldName :: FieldName , fieldDefinition :: FieldDefinition } deriving (Eq, Show) @@ -375,15 +409,22 @@ | BulkUpdate IndexName MappingName DocId Value deriving (Eq, Show) {-| 'EsResult' describes the standard wrapper JSON document that you see in - successful Elasticsearch responses. + successful Elasticsearch lookups or lookups that couldn't find the document. -} -data EsResult a = EsResult { _index :: Text - , _type :: Text - , _id :: Text - , _version :: DocVersion - , found :: Maybe Bool - , _source :: a } deriving (Eq, Show) +data EsResult a = EsResult { _index :: Text + , _type :: Text + , _id :: Text + , foundResult :: Maybe (EsResultFound a)} deriving (Eq, Show) + +{-| 'EsResultFound' contains the document and its metadata inside of an + 'EsResult' when the document was successfully found. +-} +data EsResultFound a = EsResultFound { _version :: DocVersion + , _source :: a } deriving (Eq, Show) + + + {-| 'DocVersion' is an integer version number for a document between 1 and 9.2e+18 used for <>. -} @@ -439,18 +480,24 @@ -- care, as this could result in data loss. deriving (Show, Eq, Ord) +{-| 'DocumentParent' is used to specify a parent document. +-} +newtype DocumentParent = DocumentParent DocId + deriving (Eq, Show) + {-| 'IndexDocumentSettings' are special settings supplied when indexing a document. For the best backwards compatiblity when new fields are added, you should probably prefer to start with 'defaultIndexDocumentSettings' -} -data IndexDocumentSettings = IndexDocumentSettings { - idsVersionControl :: VersionControl - } +data IndexDocumentSettings = + IndexDocumentSettings { idsVersionControl :: VersionControl + , idsParent :: Maybe DocumentParent + } deriving (Eq, Show) -{-| Reasonable default settings. Chooses no version control. +{-| Reasonable default settings. Chooses no version control and no parent. -} defaultIndexDocumentSettings :: IndexDocumentSettings -defaultIndexDocumentSettings = IndexDocumentSettings NoVersionControl +defaultIndexDocumentSettings = IndexDocumentSettings NoVersionControl Nothing {-| '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. @@ -546,6 +593,14 @@ -} newtype IndexName = IndexName Text deriving (Eq, Generic, Show) +{-| 'TemplateName' is used to describe which template to query/create/delete +-} +newtype TemplateName = TemplateName Text deriving (Eq, Show, Generic) + +{-| 'TemplatePattern' represents a pattern which is matched against index names +-} +newtype TemplatePattern = TemplatePattern Text deriving (Eq, Show, Generic) + {-| 'MappingName' is part of mappings which are how ES describes and schematizes the data in the indices. -} @@ -566,6 +621,12 @@ -} newtype FieldName = FieldName Text deriving (Eq, Show) + +{-| 'Script' is often used in place of 'FieldName' to specify more +complex ways of extracting a value from a document. +-} +newtype Script = Script { scriptText :: Text } deriving (Eq, Show) + {-| 'CacheName' is used in 'RegexpFilter' for describing the 'CacheKey' keyed caching behavior. -} @@ -681,8 +742,33 @@ -- default False , trackSortScores :: TrackSortScores , from :: From - , size :: Size } deriving (Eq, Show) + , size :: Size + , searchType :: SearchType + , fields :: Maybe [FieldName] + , source :: Maybe Source } deriving (Eq, Show) +data SearchType = SearchTypeQueryThenFetch + | SearchTypeDfsQueryThenFetch + | SearchTypeCount + | SearchTypeScan + | SearchTypeQueryAndFetch + | SearchTypeDfsQueryAndFetch + deriving (Eq, Show) + +data Source = + NoSource + | SourcePatterns PatternOrPatterns + | SourceIncludeExclude Include Exclude + deriving (Show, Eq) + +data PatternOrPatterns = PopPattern Pattern + | PopPatterns [Pattern] deriving (Eq, Show) + +data Include = Include [Pattern] deriving (Eq, Show) +data Exclude = Exclude [Pattern] deriving (Eq, Show) + +newtype Pattern = Pattern Text deriving (Eq, Show) + data Highlights = Highlights { globalsettings :: Maybe HighlightSettings , highlightFields :: [FieldHighlight] } deriving (Show, Eq) @@ -969,13 +1055,14 @@ , matchQueryMatchType :: Maybe MatchQueryType , matchQueryAnalyzer :: Maybe Analyzer , matchQueryMaxExpansions :: Maybe MaxExpansions - , matchQueryLenient :: Maybe Lenient } deriving (Eq, Show) + , matchQueryLenient :: Maybe Lenient + , matchQueryBoost :: Maybe Boost } deriving (Eq, Show) {-| 'mkMatchQuery' is a convenience function that defaults the less common parameters, enabling you to provide only the 'FieldName' and 'QueryString' to make a 'MatchQuery' -} mkMatchQuery :: FieldName -> QueryString -> MatchQuery -mkMatchQuery field query = MatchQuery field query Or ZeroTermsNone Nothing Nothing Nothing Nothing Nothing +mkMatchQuery field query = MatchQuery field query Or ZeroTermsNone Nothing Nothing Nothing Nothing Nothing Nothing data MatchQueryType = MatchPhrase @@ -1194,8 +1281,11 @@ , timedOut :: Bool , shards :: ShardResult , searchHits :: SearchHits a - , aggregations :: Maybe AggregationResults } deriving (Eq, Show) + , aggregations :: Maybe AggregationResults + , scrollId :: Maybe ScrollId } deriving (Eq, Show) +type ScrollId = Text -- Fixme: Newtype + type Score = Maybe Double data SearchHits a = @@ -1268,7 +1358,9 @@ | FractionalInterval Float TimeInterval deriving (Eq, Show) data Aggregation = TermsAgg TermsAggregation - | DateHistogramAgg DateHistogramAggregation deriving (Eq, Show) + | DateHistogramAgg DateHistogramAggregation + | ValueCountAgg ValueCountAggregation + | FilterAgg FilterAggregation deriving (Eq, Show) data TermsAggregation = TermsAggregation { term :: Either Text Text @@ -1294,7 +1386,14 @@ , dateAggs :: Maybe Aggregations } deriving (Eq, Show) +-- | See for more information. +data ValueCountAggregation = FieldValueCount FieldName + | ScriptValueCount Script deriving (Eq, Show) +-- | Single-bucket filter aggregations. See for more information. +data FilterAggregation = FilterAggregation { faFilter :: Filter + , faAggs :: Maybe Aggregations} deriving (Eq, Show) + mkTermsAggregation :: Text -> TermsAggregation mkTermsAggregation t = TermsAggregation (Left t) Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing @@ -1367,6 +1466,13 @@ "post_offset" .= postOffset ], "aggs" .= dateHistoAggs ] + toJSON (ValueCountAgg a) = object ["value_count" .= v] + where v = case a of + (FieldValueCount (FieldName n)) -> object ["field" .= n] + (ScriptValueCount (Script s)) -> object ["script" .= s] + toJSON (FilterAgg (FilterAggregation filt ags)) = + omitNulls [ "filter" .= filt + , "aggs" .= ags] type AggregationResults = M.Map Text Value @@ -1886,7 +1992,7 @@ toJSON (MatchQuery (FieldName fieldName) (QueryString mqQueryString) booleanOperator zeroTermsQuery cutoffFrequency matchQueryType - analyzer maxExpansions lenient) = + analyzer maxExpansions lenient boost) = object [ fieldName .= omitNulls base ] where base = [ "query" .= mqQueryString , "operator" .= booleanOperator @@ -1895,7 +2001,8 @@ , "type" .= matchQueryType , "analyzer" .= analyzer , "max_expansions" .= maxExpansions - , "lenient" .= lenient ] + , "lenient" .= lenient + , "boost" .= boost ] instance ToJSON MultiMatchQuery where @@ -1953,6 +2060,8 @@ instance ToJSON MaxQueryTerms instance ToJSON TypeName instance ToJSON IndexName +instance ToJSON TemplateName +instance ToJSON TemplatePattern instance ToJSON BoostTerms instance ToJSON MaxWordLength instance ToJSON MinWordLength @@ -1989,22 +2098,43 @@ instance ToJSON IndexSettings where - toJSON (IndexSettings s r) = object ["settings" .= object ["shards" .= s, "replicas" .= r]] + toJSON (IndexSettings s r) = object ["settings" .= + object ["index" .= + object ["number_of_shards" .= s, "number_of_replicas" .= r] + ] + ] +instance ToJSON IndexTemplate where + toJSON (IndexTemplate p s m) = merge + (object [ "template" .= p + , "mappings" .= foldl' merge (object []) m + ]) + (toJSON s) + where + merge (Object o1) (Object o2) = toJSON $ HM.union o1 o2 + merge o Null = o + merge _ _ = undefined instance (FromJSON a) => FromJSON (EsResult a) where - parseJSON (Object v) = EsResult <$> - v .: "_index" <*> - v .: "_type" <*> - v .: "_id" <*> - v .: "_version" <*> - v .:? "found" <*> - v .: "_source" + parseJSON jsonVal@(Object v) = do + found <- v .:? "found" .!= False + fr <- if found + then parseJSON jsonVal + else return Nothing + EsResult <$> v .: "_index" <*> + v .: "_type" <*> + v .: "_id" <*> + pure fr parseJSON _ = empty +instance (FromJSON a) => FromJSON (EsResultFound a) where + parseJSON (Object v) = EsResultFound <$> + v .: "_version" <*> + v .: "_source" + parseJSON _ = empty instance ToJSON Search where - toJSON (Search query sFilter sort searchAggs highlight sTrackSortScores sFrom sSize) = + toJSON (Search query sFilter sort searchAggs highlight sTrackSortScores sFrom sSize _ sFields sSource) = omitNulls [ "query" .= query , "filter" .= sFilter , "sort" .= sort @@ -2012,9 +2142,30 @@ , "highlight" .= highlight , "from" .= sFrom , "size" .= sSize - , "track_scores" .= sTrackSortScores] + , "track_scores" .= sTrackSortScores + , "fields" .= sFields + , "_source" .= sSource] +instance ToJSON Source where + toJSON NoSource = toJSON False + toJSON (SourcePatterns patterns) = toJSON patterns + toJSON (SourceIncludeExclude incl excl) = object [ "include" .= incl, "exclude" .= excl ] + +instance ToJSON PatternOrPatterns where + toJSON (PopPattern pattern) = toJSON pattern + toJSON (PopPatterns patterns) = toJSON patterns + +instance ToJSON Include where + toJSON (Include patterns) = toJSON patterns + +instance ToJSON Exclude where + toJSON (Exclude patterns) = toJSON patterns + +instance ToJSON Pattern where + toJSON (Pattern pattern) = toJSON pattern + + instance ToJSON FieldHighlight where toJSON (FieldHighlight (FieldName fName) (Just fSettings)) = object [ fName .= fSettings ] @@ -2232,7 +2383,8 @@ v .: "timed_out" <*> v .: "_shards" <*> v .: "hits" <*> - v .:? "aggregations" + v .:? "aggregations" <*> + v .:? "_scroll_id" parseJSON _ = empty instance (FromJSON a) => FromJSON (SearchHits a) where diff --git a/src/Database/Bloodhound/Types/Class.hs b/src/Database/Bloodhound/Types/Class.hs --- a/src/Database/Bloodhound/Types/Class.hs +++ b/src/Database/Bloodhound/Types/Class.hs @@ -1,8 +1,11 @@ +{-# LANGUAGE CPP #-} module Database.Bloodhound.Types.Class ( Seminearring(..) ) where +#if !MIN_VERSION_base(4,8,0) import Data.Monoid +#endif class Monoid a => Seminearring a where -- 0, +, * diff --git a/tests/doctests.hs b/tests/doctests.hs new file mode 100644 --- /dev/null +++ b/tests/doctests.hs @@ -0,0 +1,4 @@ +import Test.DocTest + +main :: IO () +main = doctest ["-i src", "Database.Bloodhound"] diff --git a/tests/doctests.hsc b/tests/doctests.hsc deleted file mode 100644 --- a/tests/doctests.hsc +++ /dev/null @@ -1,74 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE ForeignFunctionInterface #-} ------------------------------------------------------------------------------ --- | --- Module : Main (doctests) --- Copyright : (C) 2014 Chris Allen --- License : BSD-style (see the file LICENSE) --- Maintainer : Chris Allen --- Stability : provisional --- Portability : portable --- --- This module provides doctests for a project based on the actual versions --- of the packages it was built with. It requires a corresponding Setup.lhs --- to be added to the project ------------------------------------------------------------------------------ - -module Main where - -import Build_doctests (deps) -import Control.Applicative -import Control.Monad -import Data.List -import System.Directory -import System.FilePath -import Test.DocTest - -##if defined(mingw32_HOST_OS) -##if defined(i386_HOST_ARCH) -##define USE_CP -import Control.Applicative -import Control.Exception -import Foreign.C.Types -foreign import stdcall "windows.h SetConsoleCP" c_SetConsoleCP :: CUInt -> IO Bool -foreign import stdcall "windows.h GetConsoleCP" c_GetConsoleCP :: IO CUInt -##elif defined(x86_64_HOST_ARCH) -##define USE_CP -import Control.Applicative -import Control.Exception -import Foreign.C.Types -foreign import ccall "windows.h SetConsoleCP" c_SetConsoleCP :: CUInt -> IO Bool -foreign import ccall "windows.h GetConsoleCP" c_GetConsoleCP :: IO CUInt -##endif -##endif - --- | Run in a modified codepage where we can print UTF-8 values on Windows. -withUnicode :: IO a -> IO a -##ifdef USE_CP -withUnicode m = do - cp <- c_GetConsoleCP - (c_SetConsoleCP 65001 >> m) `finally` c_SetConsoleCP cp -##else -withUnicode m = m -##endif - -main :: IO () -main = withUnicode $ getSources >>= \sources -> doctest $ - "-isrc" - : "-idist/build/autogen" - : "-optP-include" - : "-optPdist/build/autogen/cabal_macros.h" - : "-hide-all-packages" - : map ("-package="++) deps ++ sources - -getSources :: IO [FilePath] -getSources = filter (isSuffixOf ".hs") <$> go "src" - where - go dir = do - (dirs, files) <- getFilesAndDirectories dir - (files ++) . concat <$> mapM go dirs - -getFilesAndDirectories :: FilePath -> IO ([FilePath], [FilePath]) -getFilesAndDirectories dir = do - c <- map (dir ) . filter (`notElem` ["..", "."]) <$> getDirectoryContents dir - (,) <$> filterM doesDirectoryExist c <*> filterM doesFileExist c diff --git a/tests/tests.hs b/tests/tests.hs --- a/tests/tests.hs +++ b/tests/tests.hs @@ -14,6 +14,7 @@ import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as NE import qualified Data.Map.Strict as M +import Data.Monoid import Data.Text (Text) import qualified Data.Text as T import Data.Time.Calendar (Day (..)) @@ -47,7 +48,7 @@ `shouldBe` (expected :: Int) createExampleIndex :: BH IO Reply -createExampleIndex = createIndex defaultIndexSettings testIndex +createExampleIndex = createIndex (IndexSettings (ShardCount 1) (ReplicaCount 0)) testIndex deleteExampleIndex :: BH IO Reply deleteExampleIndex = deleteIndex testIndex @@ -174,15 +175,16 @@ searchTweet :: Search -> BH IO (Either String Tweet) searchTweet search = do - reply <- searchByIndex testIndex search - let result = eitherDecode (responseBody reply) :: Either String (SearchResult Tweet) + result <- searchTweets search let myTweet = fmap (hitSource . head . hits . searchHits) result return myTweet +searchTweets :: Search -> BH IO (Either String (SearchResult Tweet)) +searchTweets search = eitherDecode . responseBody <$> searchByIndex testIndex search + searchExpectNoResults :: Search -> BH IO () searchExpectNoResults search = do - reply <- searchByIndex testIndex search - let result = eitherDecode (responseBody reply) :: Either String (SearchResult Tweet) + result <- searchTweets search let emptyHits = fmap (hits . searchHits) result liftIO $ emptyHits `shouldBe` Right [] @@ -214,11 +216,21 @@ searchTweetHighlight :: Search -> BH IO (Either String (Maybe HitHighlight)) searchTweetHighlight search = do - reply <- searchByIndex testIndex search - let result = eitherDecode (responseBody reply) :: Either String (SearchResult Tweet) + result <- searchTweets search let myHighlight = fmap (hitHighlight . head . hits . searchHits) result return myHighlight +searchExpectSource :: Source -> Either String Value -> BH IO () +searchExpectSource src expected = do + _ <- insertData + let query = QueryMatchQuery $ mkMatchQuery (FieldName "_all") (QueryString "haskell") + let search = (mkSearch (Just query) Nothing) { source = Just src } + reply <- searchAll search + let result = eitherDecode (responseBody reply) :: Either String (SearchResult Value) + let value = fmap (hitSource . head . hits . searchHits) result + liftIO $ + value `shouldBe` expected + data BulkTest = BulkTest { name :: Text } deriving (Eq, Generic, Show) instance FromJSON BulkTest instance ToJSON BulkTest @@ -278,6 +290,9 @@ hs <- arbitrary return $ SearchHits tot score hs +getSource :: EsResult a -> Maybe a +getSource = fmap _source . foundResult + main :: IO () main = hspec $ do @@ -298,8 +313,14 @@ docInserted <- getDocument testIndex testMapping (DocId "1") let newTweet = eitherDecode (responseBody docInserted) :: Either String (EsResult Tweet) - liftIO $ (fmap _source newTweet `shouldBe` Right exampleTweet) + liftIO $ (fmap getSource newTweet `shouldBe` Right (Just exampleTweet)) + it "produces a parseable result when looking up a bogus document" $ withTestEnv $ do + doc <- getDocument testIndex testMapping (DocId "bogus") + let noTweet = eitherDecode + (responseBody doc) :: Either String (EsResult Tweet) + liftIO $ fmap foundResult noTweet `shouldBe` Right Nothing + it "can use optimistic concurrency control" $ withTestEnv $ do let ev = ExternalDocVersion minBound let cfg = defaultIndexDocumentSettings { idsVersionControl = ExternalGT ev } @@ -309,6 +330,24 @@ res' <- insertData' cfg liftIO $ isVersionConflict res' `shouldBe` True + describe "template API" $ do + it "can create a template" $ withTestEnv $ do + let idxTpl = IndexTemplate (TemplatePattern "tweet-*") (Just (IndexSettings (ShardCount 1) (ReplicaCount 1))) [toJSON TweetMapping] + resp <- putTemplate idxTpl (TemplateName "tweet-tpl") + liftIO $ validateStatus resp 200 + + it "can detect if a template exists" $ withTestEnv $ do + exists <- templateExists (TemplateName "tweet-tpl") + liftIO $ exists `shouldBe` True + + it "can delete a template" $ withTestEnv $ do + resp <- deleteTemplate (TemplateName "tweet-tpl") + liftIO $ validateStatus resp 200 + + it "can detect if a template doesn't exist" $ withTestEnv $ do + exists <- templateExists (TemplateName "tweet-tpl") + liftIO $ exists `shouldBe` False + describe "bulk API" $ do it "inserts all documents we request" $ withTestEnv $ do _ <- insertData @@ -326,8 +365,8 @@ let maybeFirst = eitherDecode $ responseBody fDoc :: Either String (EsResult BulkTest) let maybeSecond = eitherDecode $ responseBody sDoc :: Either String (EsResult BulkTest) liftIO $ do - fmap _source maybeFirst `shouldBe` Right firstTest - fmap _source maybeSecond `shouldBe` Right secondTest + fmap getSource maybeFirst `shouldBe` Right (Just firstTest) + fmap getSource maybeSecond `shouldBe` Right (Just secondTest) describe "query API" $ do @@ -359,8 +398,8 @@ it "returns document for multi-match query" $ withTestEnv $ do _ <- insertData - let fields = [FieldName "user", FieldName "message"] - let query = QueryMultiMatchQuery $ mkMultiMatchQuery fields (QueryString "bitemyapp") + let flds = [FieldName "user", FieldName "message"] + let query = QueryMultiMatchQuery $ mkMultiMatchQuery flds (QueryString "bitemyapp") let search = mkSearch (Just query) Nothing myTweet <- searchTweet search liftIO $ @@ -407,9 +446,8 @@ let sortSpec = DefaultSortSpec $ mkSort (FieldName "age") Ascending let search = Search Nothing (Just IdentityFilter) (Just [sortSpec]) Nothing Nothing - False (From 0) (Size 10) - reply <- searchByIndex testIndex search - let result = eitherDecode (responseBody reply) :: Either String (SearchResult Tweet) + False (From 0) (Size 10) SearchTypeQueryThenFetch Nothing Nothing + result <- searchTweets search let myTweet = fmap (hitSource . head . hits . searchHits) result liftIO $ myTweet `shouldBe` Right otherTweet @@ -601,6 +639,32 @@ _ <- insertData searchTermsAggHint [GlobalOrdinals, GlobalOrdinalsHash, GlobalOrdinalsLowCardinality, Map] + + it "can execute value_count aggregations" $ withTestEnv $ do + _ <- insertData + _ <- insertOther + let ags = mkAggregations "user_count" (ValueCountAgg (FieldValueCount (FieldName "user"))) <> + mkAggregations "bogus_count" (ValueCountAgg (FieldValueCount (FieldName "bogus"))) + let search = mkAggregateSearch Nothing ags + let docCountPair k n = (k, object ["value" .= Number n]) + res <- searchTweets search + liftIO $ + fmap aggregations res `shouldBe` Right (Just (M.fromList [ docCountPair "user_count" 2 + , docCountPair "bogus_count" 0 + ])) + + it "can execute filter aggregations" $ withTestEnv $ do + _ <- insertData + _ <- insertOther + let ags = mkAggregations "bitemyapps" (FilterAgg (FilterAggregation (TermFilter (Term "user" "bitemyapp") defaultCache) Nothing)) <> + mkAggregations "notmyapps" (FilterAgg (FilterAggregation (TermFilter (Term "user" "notmyapp") defaultCache) Nothing)) + let search = mkAggregateSearch Nothing ags + let docCountPair k n = (k, object ["doc_count" .= Number n]) + res <- searchTweets search + liftIO $ + fmap aggregations res `shouldBe` Right (Just (M.fromList [ docCountPair "bitemyapps" 1 + , docCountPair "notmyapps" 1 + ])) -- Interaction of date serialization and date histogram aggregation is broken. -- it "returns date histogram aggregation results" $ withTestEnv $ do -- _ <- insertData @@ -645,8 +709,33 @@ liftIO $ myHighlight `shouldBe` Right Nothing + describe "Source filtering" $ do + it "doesn't include source when sources are disabled" $ withTestEnv $ do + searchExpectSource + NoSource + (Left "key \"_source\" not present") + it "includes a source" $ withTestEnv $ do + searchExpectSource + (SourcePatterns (PopPattern (Pattern "message"))) + (Right (Object (HM.fromList [("message", String "Use haskell!")]))) + + it "includes sources" $ withTestEnv $ do + searchExpectSource + (SourcePatterns (PopPatterns [Pattern "user", Pattern "message"])) + (Right (Object (HM.fromList [("user",String "bitemyapp"),("message", String "Use haskell!")]))) + + it "includes source patterns" $ withTestEnv $ do + searchExpectSource + (SourcePatterns (PopPattern (Pattern "*ge"))) + (Right (Object (HM.fromList [("age", Number 10000),("message", String "Use haskell!")]))) + + it "excludes source patterns" $ withTestEnv $ do + searchExpectSource + (SourceIncludeExclude (Include []) (Exclude [Pattern "l*", Pattern "*ge", Pattern "postDate"])) + (Right (Object (HM.fromList [("user",String "bitemyapp")]))) + describe "ToJSON RegexpFlags" $ do it "generates the correct JSON for AllRegexpFlags" $ toJSON AllRegexpFlags `shouldBe` String "ALL" @@ -709,3 +798,16 @@ enumFrom (pred maxBound :: DocVersion) `shouldBe` [pred maxBound, maxBound] enumFrom (pred maxBound :: DocVersion) `shouldBe` [pred maxBound, maxBound] enumFromThen minBound (pred maxBound :: DocVersion) `shouldBe` [minBound, pred maxBound] + + describe "scan&scroll API" $ do + it "returns documents using the scan&scroll API" $ withTestEnv $ do + _ <- insertData + _ <- insertOther + let search = (mkSearch (Just $ MatchAllQuery Nothing) Nothing) { size = (Size 1) } + regular_search <- searchTweet search + scan_search' <- scanSearch testIndex testMapping search :: BH IO [Hit Tweet] + let scan_search = map hitSource scan_search' + liftIO $ + regular_search `shouldBe` Right exampleTweet -- Check that the size restrtiction is being honored + liftIO $ + scan_search `shouldMatchList` [exampleTweet, otherTweet]