diff --git a/bloodhound.cabal b/bloodhound.cabal --- a/bloodhound.cabal +++ b/bloodhound.cabal @@ -1,5 +1,5 @@ name: bloodhound -version: 0.5.0.1 +version: 0.6.0.0 synopsis: ElasticSearch client library for Haskell description: ElasticSearch made awesome for Haskell hackers homepage: https://github.com/bitemyapp/bloodhound @@ -16,6 +16,9 @@ type: git location: https://github.com/bitemyapp/bloodhound.git +flag DevelopmentMode + Default: False + library ghc-options: -Wall exposed-modules: Database.Bloodhound @@ -27,13 +30,17 @@ bytestring >= 0.10.0 && <0.11, containers >= 0.5.0.0 && <0.6, aeson >= 0.7 && <0.9, - conduit >= 1.0 && <1.3, http-client >= 0.3 && <0.5, semigroups >= 0.15 && <0.17, time >= 1.4 && <1.6, text >= 0.11 && <1.3, + mtl >= 1.0 && <2.3, + transformers >= 0.2 && <0.5, http-types >= 0.8 && <0.9, - vector >= 0.10.9 && <0.11 + vector >= 0.10.9 && <0.11, + uri-bytestring >= 0.1 && <0.2, + exceptions, + data-default-class default-language: Haskell2010 test-suite tests @@ -46,14 +53,16 @@ http-client, http-types, containers, - hspec >= 1.8 && <2.1, + hspec >= 1.8 && <2.2, text, time, aeson, semigroups, QuickCheck, vector, - unordered-containers >= 0.2.5.0 && <0.3 + unordered-containers >= 0.2.5.0 && <0.3, + mtl, + quickcheck-properties default-language: Haskell2010 test-suite doctests @@ -61,8 +70,11 @@ type: exitcode-stdio-1.0 main-is: doctests.hs hs-source-dirs: tests - build-depends: base, - directory, - doctest, - doctest-prop, - filepath + if impl(ghc >= 7.8) + build-depends: base, + directory, + doctest, + doctest-prop, + filepath + else + buildable: False 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,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} ------------------------------------------------------------------------------- -- | @@ -20,8 +21,8 @@ -- and typeclass instances for the functions that make use of them. -- $setup - - createIndex + withBH + , createIndex , deleteIndex , indexExists , openIndex @@ -49,17 +50,24 @@ ) where +import Control.Applicative +import Control.Monad +import Control.Monad.Catch +import Control.Monad.IO.Class import Data.Aeson import Data.ByteString.Lazy.Builder -import qualified Data.ByteString.Lazy.Char8 as L -import Data.List (intercalate) -import Data.Maybe (fromMaybe) -import Data.Text (Text) -import qualified Data.Vector as V +import qualified Data.ByteString.Lazy.Char8 as L +import Data.Default.Class +import Data.Maybe (fromMaybe) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified Data.Vector as V import Network.HTTP.Client -import qualified Network.HTTP.Types.Method as NHTM -import qualified Network.HTTP.Types.Status as NHTS -import Prelude hiding (filter, head) +import qualified Network.HTTP.Types.Method as NHTM +import qualified Network.HTTP.Types.Status as NHTS +import Prelude hiding (filter, head) +import URI.ByteString hiding (Query) import Database.Bloodhound.Types @@ -69,12 +77,12 @@ -- >>> import Database.Bloodhound -- >>> import Test.DocTest.Prop (assert) -- >>> let testServer = (Server "http://localhost:9200") +-- >>> let runBH' = withBH defaultManagerSettings testServer -- >>> let testIndex = IndexName "twitter" -- >>> let testMapping = MappingName "tweet" -- >>> let defaultIndexSettings = IndexSettings (ShardCount 3) (ReplicaCount 2) -- >>> data TweetMapping = TweetMapping deriving (Eq, Show) --- >>> _ <- deleteIndex testServer testIndex --- >>> _ <- deleteMapping testServer testIndex testMapping +-- >>> _ <- runBH' $ deleteIndex testIndex >> deleteMapping testIndex testMapping -- >>> import GHC.Generics -- >>> import Data.Time.Calendar (Day (..)) -- >>> import Data.Time.Clock (UTCTime (..), secondsToDiffTime) @@ -133,29 +141,49 @@ emptyBody :: L.ByteString emptyBody = L.pack "" -dispatch :: Method -> String -> Maybe L.ByteString - -> IO Reply +dispatch :: MonadBH m => Method -> Text -> Maybe L.ByteString + -> m Reply dispatch dMethod url body = do - initReq <- parseUrl url + initReq <- liftIO $ parseUrl' url let reqBody = RequestBodyLBS $ fromMaybe emptyBody body let req = initReq { method = dMethod , requestBody = reqBody , checkStatus = \_ _ _ -> Nothing} - withManager defaultManagerSettings $ httpLbs req + mgr <- bhManager <$> getBHEnv + liftIO $ httpLbs req mgr -joinPath :: [String] -> String -joinPath = intercalate "/" +joinPath' :: [Text] -> Text +joinPath' = T.intercalate "/" +joinPath :: MonadBH m => [Text] -> m Text +joinPath ps = do + Server s <- bhServer <$> getBHEnv + return $ joinPath' (s:ps) + +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 +-- 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 + let env = BHEnv { bhServer = s + , bhManager = mgr } + runBH env f + -- Shortcut functions for HTTP methods -delete :: String -> IO Reply +delete :: MonadBH m => Text -> m Reply delete = flip (dispatch NHTM.methodDelete) Nothing -get :: String -> IO Reply +get :: MonadBH m => Text -> m Reply get = flip (dispatch NHTM.methodGet) Nothing -head :: String -> IO Reply +head :: MonadBH m => Text -> m Reply head = flip (dispatch NHTM.methodHead) Nothing -put :: String -> Maybe L.ByteString -> IO Reply +put :: MonadBH m => Text -> Maybe L.ByteString -> m Reply put = dispatch NHTM.methodPost -post :: String -> Maybe L.ByteString -> IO Reply +post :: MonadBH m => Text -> Maybe L.ByteString -> m Reply post = dispatch NHTM.methodPost -- indexDocument s ix name doc = put (root s ix name doc) (Just encode doc) @@ -164,38 +192,41 @@ -- | 'getStatus' fetches the 'Status' of a 'Server' -- --- >>> getStatus testServer --- Just (Status {ok = Nothing, status = 200, name = "Arena", version = Version {number = "1.4.1", build_hash = "89d3241d670db65f994242c8e8383b169779e2d4", build_timestamp = 2014-11-26 15:49:29 UTC, build_snapshot = False, lucene_version = "4.10.2"}, tagline = "You Know, for Search"}) -getStatus :: Server -> IO (Maybe Status) -getStatus (Server server) = do - request <- parseUrl $ joinPath [server] - response <- withManager defaultManagerSettings $ httpLbs request +-- >>> serverStatus <- runBH' getStatus +-- >>> fmap status (serverStatus) +-- Just 200 +getStatus :: MonadBH m => m (Maybe Status) +getStatus = do + url <- joinPath [] + request <- liftIO $ parseUrl' url + mgr <- bhManager <$> getBHEnv + response <- liftIO $ httpLbs request mgr return $ decode (responseBody response) -- | 'createIndex' will create an index given a 'Server', 'IndexSettings', and an 'IndexName'. -- --- >>> response <- createIndex testServer defaultIndexSettings (IndexName "didimakeanindex") +-- >>> response <- runBH' $ createIndex defaultIndexSettings (IndexName "didimakeanindex") -- >>> respIsTwoHunna response -- True --- >>> indexExists testServer (IndexName "didimakeanindex") +-- >>> runBH' $ indexExists (IndexName "didimakeanindex") -- True -createIndex :: Server -> IndexSettings -> IndexName -> IO Reply -createIndex (Server server) indexSettings (IndexName indexName) = - put url body - where url = joinPath [server, indexName] +createIndex :: MonadBH m => IndexSettings -> IndexName -> m Reply +createIndex indexSettings (IndexName indexName) = + bindM2 put url (return body) + where url = joinPath [indexName] body = Just $ encode indexSettings -- | 'deleteIndex' will delete an index given a 'Server', and an 'IndexName'. -- --- >>> response <- createIndex testServer defaultIndexSettings (IndexName "didimakeanindex") --- >>> response <- deleteIndex testServer (IndexName "didimakeanindex") +-- >>> _ <- runBH' $ createIndex defaultIndexSettings (IndexName "didimakeanindex") +-- >>> response <- runBH' $ deleteIndex (IndexName "didimakeanindex") -- >>> respIsTwoHunna response -- True --- >>> indexExists testServer testIndex +-- >>> runBH' $ indexExists testIndex -- False -deleteIndex :: Server -> IndexName -> IO Reply -deleteIndex (Server server) (IndexName indexName) = - delete $ joinPath [server, indexName] +deleteIndex :: MonadBH m => IndexName -> m Reply +deleteIndex (IndexName indexName) = + delete =<< joinPath [indexName] statusCodeIs :: Int -> Reply -> Bool statusCodeIs n resp = NHTS.statusCode (responseStatus resp) == n @@ -203,7 +234,7 @@ respIsTwoHunna :: Reply -> Bool respIsTwoHunna = statusCodeIs 200 -existentialQuery :: String -> IO (Reply, Bool) +existentialQuery :: MonadBH m => Text -> m (Reply, Bool) existentialQuery url = do reply <- head url return (reply, respIsTwoHunna reply) @@ -211,99 +242,98 @@ -- | 'indexExists' enables you to check if an index exists. Returns 'Bool' -- in IO -- --- >>> exists <- indexExists testServer testIndex -indexExists :: Server -> IndexName -> IO Bool -indexExists (Server server) (IndexName indexName) = do - (_, exists) <- existentialQuery url +-- >>> exists <- runBH' $ indexExists testIndex +indexExists :: MonadBH m => IndexName -> m Bool +indexExists (IndexName indexName) = do + (_, exists) <- existentialQuery =<< joinPath [indexName] return exists - where url = joinPath [server, indexName] -- | 'refreshIndex' will force a refresh on an index. You must -- do this if you want to read what you wrote. -- --- >>> _ <- createIndex testServer defaultIndexSettings testIndex --- >>> _ <- refreshIndex testServer testIndex -refreshIndex :: Server -> IndexName -> IO Reply -refreshIndex (Server server) (IndexName indexName) = - post url Nothing - where url = joinPath [server, indexName, "_refresh"] +-- >>> _ <- runBH' $ createIndex defaultIndexSettings testIndex +-- >>> _ <- runBH' $ refreshIndex testIndex +refreshIndex :: MonadBH m => IndexName -> m Reply +refreshIndex (IndexName indexName) = + bindM2 post url (return Nothing) + where url = joinPath [indexName, "_refresh"] -stringifyOCIndex :: OpenCloseIndex -> String +stringifyOCIndex :: OpenCloseIndex -> Text stringifyOCIndex oci = case oci of OpenIndex -> "_open" CloseIndex -> "_close" -openOrCloseIndexes :: OpenCloseIndex -> Server -> IndexName -> IO Reply -openOrCloseIndexes oci (Server server) (IndexName indexName) = - post url Nothing +openOrCloseIndexes :: MonadBH m => OpenCloseIndex -> IndexName -> m Reply +openOrCloseIndexes oci (IndexName indexName) = + bindM2 post url (return Nothing) where ociString = stringifyOCIndex oci - url = joinPath [server, indexName, ociString] + url = joinPath [indexName, ociString] --- | 'openIndex' opens an index given a 'Server' and an 'IndexName'. Explained in further detail at +-- | 'openIndex' opens an index given a 'Server' and an 'IndexName'. Explained in further detail at -- -- --- >>> reply <- openIndex testServer testIndex -openIndex :: Server -> IndexName -> IO Reply +-- >>> reply <- runBH' $ openIndex testIndex +openIndex :: MonadBH m => IndexName -> m Reply openIndex = openOrCloseIndexes OpenIndex --- | 'closeIndex' closes an index given a 'Server' and an 'IndexName'. Explained in further detail at +-- | 'closeIndex' closes an index given a 'Server' and an 'IndexName'. Explained in further detail at -- -- --- >>> reply <- closeIndex testServer testIndex -closeIndex :: Server -> IndexName -> IO Reply +-- >>> reply <- runBH' $ closeIndex testIndex +closeIndex :: MonadBH m => IndexName -> m Reply closeIndex = openOrCloseIndexes CloseIndex -- | 'putMapping' is an HTTP PUT and has upsert semantics. Mappings are schemas -- for documents in indexes. -- --- >>> _ <- createIndex testServer defaultIndexSettings testIndex --- >>> resp <- putMapping testServer testIndex testMapping TweetMapping +-- >>> _ <- runBH' $ createIndex defaultIndexSettings testIndex +-- >>> resp <- runBH' $ putMapping testIndex testMapping TweetMapping -- >>> print resp -- Response {responseStatus = Status {statusCode = 200, statusMessage = "OK"}, responseVersion = HTTP/1.1, responseHeaders = [("Content-Type","application/json; charset=UTF-8"),("Content-Length","21")], responseBody = "{\"acknowledged\":true}", responseCookieJar = CJ {expose = []}, responseClose' = ResponseClose} -putMapping :: ToJSON a => Server -> IndexName - -> MappingName -> a -> IO Reply -putMapping (Server server) (IndexName indexName) (MappingName mappingName) mapping = - put url body - where url = joinPath [server, indexName, mappingName, "_mapping"] +putMapping :: (MonadBH m, ToJSON a) => IndexName + -> MappingName -> a -> m Reply +putMapping (IndexName indexName) (MappingName mappingName) mapping = + bindM2 put url (return body) + where url = joinPath [indexName, mappingName, "_mapping"] body = Just $ encode mapping -- | 'deleteMapping' is an HTTP DELETE and deletes a mapping for a given index. -- Mappings are schemas for documents in indexes. -- --- >>> _ <- createIndex testServer defaultIndexSettings testIndex --- >>> _ <- putMapping testServer testIndex testMapping TweetMapping --- >>> resp <- deleteMapping testServer testIndex testMapping +-- >>> _ <- runBH' $ createIndex defaultIndexSettings testIndex +-- >>> _ <- runBH' $ putMapping testIndex testMapping TweetMapping +-- >>> resp <- runBH' $ deleteMapping testIndex testMapping -- >>> print resp -- Response {responseStatus = Status {statusCode = 200, statusMessage = "OK"}, responseVersion = HTTP/1.1, responseHeaders = [("Content-Type","application/json; charset=UTF-8"),("Content-Length","21")], responseBody = "{\"acknowledged\":true}", responseCookieJar = CJ {expose = []}, responseClose' = ResponseClose} -deleteMapping :: Server -> IndexName -> MappingName -> IO Reply -deleteMapping (Server server) (IndexName indexName) +deleteMapping :: MonadBH m => IndexName -> MappingName -> m Reply +deleteMapping (IndexName indexName) (MappingName mappingName) = - delete $ joinPath [server, indexName, mappingName, "_mapping"] + delete =<< joinPath [indexName, mappingName, "_mapping"] -- | 'indexDocument' is the primary way to save a single document in -- Elasticsearch. The document itself is simply something we can -- convert into a JSON 'Value'. The 'DocId' will function as the -- primary key for the document. -- --- >>> resp <- indexDocument testServer testIndex testMapping exampleTweet (DocId "1") +-- >>> resp <- runBH' $ indexDocument testIndex testMapping exampleTweet (DocId "1") -- >>> print resp -- Response {responseStatus = Status {statusCode = 201, statusMessage = "Created"}, responseVersion = HTTP/1.1, responseHeaders = [("Content-Type","application/json; charset=UTF-8"),("Content-Length","74")], responseBody = "{\"_index\":\"twitter\",\"_type\":\"tweet\",\"_id\":\"1\",\"_version\":1,\"created\":true}", responseCookieJar = CJ {expose = []}, responseClose' = ResponseClose} -indexDocument :: ToJSON doc => Server -> IndexName -> MappingName - -> doc -> DocId -> IO Reply -indexDocument (Server server) (IndexName indexName) +indexDocument :: (ToJSON doc, MonadBH m) => IndexName -> MappingName + -> doc -> DocId -> m Reply +indexDocument (IndexName indexName) (MappingName mappingName) document (DocId docId) = - put url body - where url = joinPath [server, indexName, mappingName, docId] + bindM2 put url (return body) + where url = joinPath [indexName, mappingName, docId] body = Just (encode document) -- | 'deleteDocument' is the primary way to delete a single document. -- --- >>> _ <- deleteDocument testServer testIndex testMapping (DocId "1") -deleteDocument :: Server -> IndexName -> MappingName - -> DocId -> IO Reply -deleteDocument (Server server) (IndexName indexName) +-- >>> _ <- runBH' $ deleteDocument testIndex testMapping (DocId "1") +deleteDocument :: MonadBH m => IndexName -> MappingName + -> DocId -> m Reply +deleteDocument (IndexName indexName) (MappingName mappingName) (DocId docId) = - delete $ joinPath [server, indexName, mappingName, docId] + delete =<< joinPath [indexName, mappingName, docId] -- | 'bulk' uses -- @@ -313,12 +343,12 @@ -- server to be performed. I changed from [BulkOperation] to a Vector due to memory overhead. -- -- >>> let stream = V.fromList [BulkIndex testIndex testMapping (DocId "2") (toJSON (BulkTest "blah"))] --- >>> _ <- bulk testServer stream --- >>> _ <- refreshIndex testServer testIndex -bulk :: Server -> V.Vector BulkOperation -> IO Reply -bulk (Server server) bulkOps = post url body where - url = joinPath [server, "_bulk"] - body = Just $ encodeBulkOperations bulkOps +-- >>> _ <- runBH' $ bulk stream +-- >>> _ <- runBH' $ refreshIndex testIndex +bulk :: MonadBH m => V.Vector BulkOperation -> m Reply +bulk bulkOps = bindM2 post url (return body) + where url = joinPath ["_bulk"] + body = Just $ encodeBulkOperations bulkOps -- | 'encodeBulkOperations' is a convenience function for dumping a vector of 'BulkOperation' -- into an 'L.ByteString' @@ -335,7 +365,7 @@ mash :: Builder -> V.Vector L.ByteString -> Builder mash = V.foldl' (\b x -> b `mappend` (byteString "\n") `mappend` (lazyByteString x)) -mkBulkStreamValue :: Text -> String -> String -> String -> Value +mkBulkStreamValue :: Text -> Text -> Text -> Text -> Value mkBulkStreamValue operation indexName mappingName docId = object [operation .= object [ "_index" .= indexName @@ -378,26 +408,26 @@ -- Elasticsearch using a 'Server', 'IndexName', 'MappingName', and a 'DocId'. -- The 'DocId' is the primary key for your Elasticsearch document. -- --- >>> yourDoc <- getDocument testServer testIndex testMapping (DocId "1") -getDocument :: Server -> IndexName -> MappingName - -> DocId -> IO Reply -getDocument (Server server) (IndexName indexName) +-- >>> yourDoc <- runBH' $ getDocument testIndex testMapping (DocId "1") +getDocument :: MonadBH m => IndexName -> MappingName + -> DocId -> m Reply +getDocument (IndexName indexName) (MappingName mappingName) (DocId docId) = - get $ joinPath [server, indexName, mappingName, docId] + get =<< joinPath [indexName, mappingName, docId] -- | 'documentExists' enables you to check if a document exists. Returns 'Bool' -- in IO -- --- >>> exists <- documentExists testServer testIndex testMapping (DocId "1") -documentExists :: Server -> IndexName -> MappingName - -> DocId -> IO Bool -documentExists (Server server) (IndexName indexName) +-- >>> exists <- runBH' $ documentExists testIndex testMapping (DocId "1") +documentExists :: MonadBH m => IndexName -> MappingName + -> DocId -> m Bool +documentExists (IndexName indexName) (MappingName mappingName) (DocId docId) = do - (_, exists) <- existentialQuery url - return exists where - url = joinPath [server, indexName, mappingName, docId] + (_, exists) <- existentialQuery =<< url + return exists + where url = joinPath [indexName, mappingName, docId] -dispatchSearch :: String -> Search -> IO Reply +dispatchSearch :: MonadBH m => Text -> Search -> m Reply dispatchSearch url search = post url (Just (encode search)) -- | 'searchAll', given a 'Search', will perform that search against all indexes @@ -405,31 +435,32 @@ -- -- >>> let query = TermQuery (Term "user" "bitemyapp") Nothing -- >>> let search = mkSearch (Just query) Nothing --- >>> reply <- searchAll testServer search -searchAll :: Server -> Search -> IO Reply -searchAll (Server server) = dispatchSearch url where - url = joinPath [server, "_search"] +-- >>> reply <- runBH' $ searchAll search +searchAll :: MonadBH m => Search -> m Reply +searchAll = bindM2 dispatchSearch url . return + where url = joinPath ["_search"] -- | 'searchByIndex', given a 'Search' and an 'IndexName', will perform that search -- against all mappings within an index on an Elasticsearch server. -- -- >>> let query = TermQuery (Term "user" "bitemyapp") Nothing -- >>> let search = mkSearch (Just query) Nothing --- >>> reply <- searchByIndex testServer testIndex search -searchByIndex :: Server -> IndexName -> Search -> IO Reply -searchByIndex (Server server) (IndexName indexName) = dispatchSearch url where - url = joinPath [server, indexName, "_search"] +-- >>> reply <- runBH' $ searchByIndex testIndex search +searchByIndex :: MonadBH m => IndexName -> Search -> m Reply +searchByIndex (IndexName indexName) = bindM2 dispatchSearch url . return + where url = joinPath [indexName, "_search"] -- | 'searchByType', given a 'Search', 'IndexName', and 'MappingName', will perform that -- search against a specific mapping within an index on an Elasticsearch server. -- -- >>> let query = TermQuery (Term "user" "bitemyapp") Nothing -- >>> let search = mkSearch (Just query) Nothing --- >>> reply <- searchByType testServer testIndex testMapping search -searchByType :: Server -> IndexName -> MappingName -> Search -> IO Reply -searchByType (Server server) (IndexName indexName) - (MappingName mappingName) = dispatchSearch url where - url = joinPath [server, indexName, mappingName, "_search"] +-- >>> reply <- runBH' $ searchByType testIndex testMapping search +searchByType :: MonadBH m => IndexName -> MappingName -> Search + -> m Reply +searchByType (IndexName indexName) + (MappingName mappingName) = bindM2 dispatchSearch url . return + where url = joinPath [indexName, mappingName, "_search"] -- | '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 @@ -438,9 +469,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 = 0, 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} mkSearch :: Maybe Query -> Maybe Filter -> Search -mkSearch query filter = Search query filter Nothing Nothing Nothing False 0 10 +mkSearch query filter = Search query filter Nothing Nothing Nothing False (From 0) (Size 10) -- | 'mkAggregateSearch' is a helper function that defaults everything in a 'Search' except for -- the 'Query' and the 'Aggregation'. @@ -450,7 +481,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 0 0 +mkAggregateSearch query mkSearchAggs = Search query Nothing Nothing (Just mkSearchAggs) Nothing False (From 0) (Size 0) -- | 'mkHighlightSearch' is a helper function that defaults everything in a 'Search' except for -- the 'Query' and the 'Aggregation'. @@ -459,16 +490,49 @@ -- >>> 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 0 10 +mkHighlightSearch query searchHighlights = Search query Nothing Nothing Nothing (Just searchHighlights) False (From 0) (Size 10) --- | 'pageSearch' is a helper function that takes a search and assigns the page from and to --- fields for the search. +-- | '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 +-- from the first result you want to fetch. The size parameter allows you to +-- configure the maximum amount of hits to be returned. -- -- >>> 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 = 0, size = 10} --- >>> pageSearch 10 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 = 10, size = 100} -pageSearch :: Int -> Int -> Search -> Search -pageSearch pageFrom pageSize search = search { from = pageFrom, size = pageSize } +-- 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} +-- >>> 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} +pageSearch :: From -- ^ The result offset + -> Size -- ^ The number of results to return + -> Search -- ^ The current seach + -> Search -- ^ The paged search +pageSearch resultOffset pageSize search = search { from = resultOffset, size = pageSize } + +parseUrl' :: MonadThrow m => Text -> m Request +parseUrl' t = + case parseURI laxURIParserOptions (T.encodeUtf8 t) of + Right uri -> setURI def uri + Left e -> throwM $ InvalidUrlException (T.unpack t) ("Invalid URL: " ++ show e) + +setURI :: MonadThrow m => Request -> URI -> m Request +setURI req URI{..} = do + Authority {..} <- maybe missingUA return uriAuthority + let req' = req { secure = isSecure + , host = hostBS authorityHost + , port = thePort + , path = uriPath + } + thePort = maybe defPort portNumber authorityPort + addAuth = maybe id addAuth' authorityUserInfo + return $ setQueryString theQueryString $ addAuth req' + where + missingUA = throwM $ InvalidUrlException "N/A" "Missing URI host/port" + addAuth' UserInfo {..} = applyBasicProxyAuth uiUsername uiPassword + defPort + | isSecure = 443 + | otherwise = 80 + isSecure = case uriScheme of + Scheme "https" -> True + _ -> False + theQueryString = [(k , Just v) | (k, v) <- queryPairs uriQuery] 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 @@ -1,6 +1,11 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE UndecidableInstances #-} ------------------------------------------------------------------------------- -- | @@ -24,9 +29,7 @@ module Database.Bloodhound.Types ( defaultCache , defaultIndexSettings - , halfRangeToKV , mkSort - , rangeToKV , showText , unpackId , mkMatchQuery @@ -41,6 +44,10 @@ , toTerms , toDateHistogram , omitNulls + , BH + , runBH + , BHEnv(..) + , MonadBH(..) , Version(..) , Status(..) , Existence(..) @@ -53,6 +60,9 @@ , Search(..) , SearchResult(..) , SearchHits(..) + , TrackSortScores + , From(..) + , Size(..) , ShardResult(..) , Hit(..) , Filter(..) @@ -69,13 +79,16 @@ , DistanceRange(..) , OptimizeBbox(..) , LatLon(..) - , Range(..) - , HalfRange(..) + , RangeValue(..) , RangeExecution(..) , LessThan(..) , LessThanEq(..) , GreaterThan(..) , GreaterThanEq(..) + , LessThanD(..) + , LessThanEqD(..) + , GreaterThanD(..) + , GreaterThanEqD(..) , Regexp(..) , RegexpFlags(..) , RegexpFlag(..) @@ -137,6 +150,8 @@ , IgnoreTermFrequency(..) , MaxQueryTerms(..) , ScoreType(..) + , Score + , Cache , TypeName(..) , BoostTerms(..) , MaxWordLength(..) @@ -167,6 +182,7 @@ , CollectionMode(..) , TermOrder(..) , TermInclusion(..) + , Aggregation(..) , Aggregations , AggregationResults @@ -192,13 +208,16 @@ ) where import Control.Applicative +import Control.Monad.Error +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 Data.List.NonEmpty (NonEmpty(..), toList) +import Data.List.NonEmpty (NonEmpty (..), toList) import qualified Data.Map.Strict as M -import Data.Monoid import Data.Text (Text) import qualified Data.Text as T import Data.Time.Clock (UTCTime) @@ -220,6 +239,52 @@ -- defaultIndexSettings is exported by Database.Bloodhound as well -- no trailing slashes in servers, library handles building the path. +{-| Common environment for Elasticsearch calls. Connections will be + pipelined according to the provided HTTP connection manager. +-} +data BHEnv = BHEnv { bhServer :: Server + , bhManager :: Manager + } + +{-| All API calls to Elasticsearch operate within + MonadBH. The idea is that it can be easily embedded in your + own monad transformer stack. A default instance for a ReaderT and + alias 'BH' is provided for the simple case. +-} +class (Functor m, Applicative m, MonadIO m) => MonadBH m where + getBHEnv :: m BHEnv + +newtype BH m a = BH { + unBH :: ReaderT BHEnv m a + } deriving ( Functor + , Applicative + , Monad + , MonadIO + , MonadState s + , MonadWriter w + , MonadError e + , Alternative + , MonadPlus + , MonadFix) + +instance MonadTrans BH where + lift = BH . lift + +instance (MonadReader r m) => MonadReader r (BH m) where + ask = lift ask + local f (BH (ReaderT m)) = BH $ ReaderT $ \r -> + local f (m r) + +instance (Functor m, Applicative m, MonadIO m) => MonadBH (BH m) where + getBHEnv = BH getBHEnv + + +instance (Functor m, Applicative m, MonadIO m) => MonadBH (ReaderT BHEnv m) where + getBHEnv = ask + +runBH :: BHEnv -> BH m a -> m a +runBH e f = runReaderT (unBH f) e + {-| 'Version' is embedded in 'Status' -} data Version = Version { number :: Text , build_hash :: Text @@ -398,22 +463,22 @@ {-| 'Server' is used with the client functions to point at the ES instance -} -newtype Server = Server String deriving (Eq, Show) +newtype Server = Server Text deriving (Eq, Show) {-| 'IndexName' is used to describe which index to query/create/delete -} -newtype IndexName = IndexName String deriving (Eq, Generic, Show) +newtype IndexName = IndexName Text deriving (Eq, Generic, Show) {-| 'MappingName' is part of mappings which are how ES describes and schematizes the data in the indices. -} -newtype MappingName = MappingName String deriving (Eq, Generic, Show) +newtype MappingName = MappingName Text deriving (Eq, Generic, Show) {-| 'DocId' is a generic wrapper value for expressing unique Document IDs. Can be set by the user or created by ES itself. Often used in client functions for poking at specific documents. -} -newtype DocId = DocId String deriving (Eq, Generic, Show) +newtype DocId = DocId Text deriving (Eq, Generic, Show) {-| 'QueryString' is used to wrap query text bodies, be they human written or not. -} @@ -524,12 +589,12 @@ {-| 'unpackId' is a silly convenience function that gets used once. -} -unpackId :: DocId -> String +unpackId :: DocId -> Text unpackId (DocId docId) = docId type TrackSortScores = Bool -type From = Int -type Size = Int +newtype From = From Int deriving (Eq, Show, ToJSON) +newtype Size = Size Int deriving (Eq, Show, ToJSON) data Search = Search { queryBody :: Maybe Query , filterBody :: Maybe Filter @@ -635,10 +700,10 @@ data RangeQuery = RangeQuery { rangeQueryField :: FieldName - , rangeQueryRange :: Either HalfRange Range + , rangeQueryRange :: RangeValue , rangeQueryBoost :: Boost } deriving (Eq, Show) -mkRangeQuery :: FieldName -> Either HalfRange Range -> RangeQuery +mkRangeQuery :: FieldName -> RangeValue -> RangeQuery mkRangeQuery f r = RangeQuery f r (Boost 1.0) data SimpleQueryStringQuery = @@ -921,7 +986,7 @@ | LimitFilter Int | MissingFilter FieldName Existence NullValue | PrefixFilter FieldName PrefixValue Cache - | RangeFilter FieldName (Either HalfRange Range) RangeExecution Cache + | RangeFilter FieldName RangeValue RangeExecution Cache | RegexpFilter FieldName Regexp RegexpFlags CacheName Cache CacheKey | TermFilter Term Cache deriving (Eq, Show) @@ -929,22 +994,6 @@ 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) @@ -961,20 +1010,53 @@ | Intersection | Interval deriving (Eq, Show) -halfRangeToKV :: HalfRange -> (Text, Double) -halfRangeToKV (HalfRangeLt (LessThan n)) = ("lt", n) -halfRangeToKV (HalfRangeLte (LessThanEq n)) = ("lte", n) -halfRangeToKV (HalfRangeGt (GreaterThan n)) = ("gt", n) -halfRangeToKV (HalfRangeGte (GreaterThanEq n)) = ("gte", n) +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) -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) +newtype LessThanD = LessThanD UTCTime deriving (Eq, Show) +newtype LessThanEqD = LessThanEqD UTCTime deriving (Eq, Show) +newtype GreaterThanD = GreaterThanD UTCTime deriving (Eq, Show) +newtype GreaterThanEqD = GreaterThanEqD UTCTime deriving (Eq, Show) --- phew. Coulda used Agda style case breaking there but, you know, whatever. :) +data RangeValue = RangeDateLte LessThanEqD + | RangeDateLt LessThanD + | RangeDateGte GreaterThanEqD + | RangeDateGt GreaterThanD + | RangeDateGtLt GreaterThanD LessThanD + | RangeDateGteLte GreaterThanEqD LessThanEqD + | RangeDateGteLt GreaterThanEqD LessThanD + | RangeDateGtLte GreaterThanD LessThanEqD + | RangeDoubleLte LessThanEq + | RangeDoubleLt LessThan + | RangeDoubleGte GreaterThanEq + | RangeDoubleGt GreaterThan + | RangeDoubleGtLt GreaterThan LessThan + | RangeDoubleGteLte GreaterThanEq LessThanEq + | RangeDoubleGteLt GreaterThanEq LessThan + | RangeDoubleGtLte GreaterThan LessThanEq + deriving (Eq, Show) +rangeValueToPair :: RangeValue -> [Pair] +rangeValueToPair rv = case rv of + RangeDateLte (LessThanEqD t) -> ["lte" .= t] + RangeDateGte (GreaterThanEqD t) -> ["gte" .= t] + RangeDateLt (LessThanD t) -> ["lt" .= t] + RangeDateGt (GreaterThanD t) -> ["gt" .= t] + RangeDateGteLte (GreaterThanEqD l) (LessThanEqD g) -> ["gte" .= l, "lte" .= g] + RangeDateGtLte (GreaterThanD l) (LessThanEqD g) -> ["gt" .= l, "lte" .= g] + RangeDateGteLt (GreaterThanEqD l) (LessThanD g) -> ["gte" .= l, "lt" .= g] + RangeDateGtLt (GreaterThanD l) (LessThanD g) -> ["gt" .= l, "lt" .= g] + RangeDoubleLte (LessThanEq t) -> ["lte" .= t] + RangeDoubleGte (GreaterThanEq t) -> ["gte" .= t] + RangeDoubleLt (LessThan t) -> ["lt" .= t] + RangeDoubleGt (GreaterThan t) -> ["gt" .= t] + RangeDoubleGteLte (GreaterThanEq l) (LessThanEq g) -> ["gte" .= l, "lte" .= g] + RangeDoubleGtLte (GreaterThan l) (LessThanEq g) -> ["gt" .= l, "lte" .= g] + RangeDoubleGteLt (GreaterThanEq l) (LessThan g) -> ["gte" .= l, "lt" .= g] + RangeDoubleGtLt (GreaterThan l) (LessThan g) -> ["gt" .= l, "lt" .= g] + data Term = Term { termField :: Text , termValue :: Text } deriving (Eq, Show) @@ -1036,13 +1118,20 @@ , searchHits :: SearchHits a , aggregations :: Maybe AggregationResults } deriving (Eq, Show) -type Score = Double +type Score = Maybe Double data SearchHits a = SearchHits { hitsTotal :: Int , maxScore :: Score , hits :: [Hit a] } deriving (Eq, Show) + +instance Monoid (SearchHits a) where + mempty = SearchHits 0 Nothing mempty + mappend (SearchHits ta ma ha) (SearchHits tb mb hb) = + SearchHits (ta + tb) (max ma mb) (ha <> hb) + + data Hit a = Hit { hitIndex :: IndexName , hitType :: MappingName @@ -1176,29 +1265,29 @@ instance ToJSON Aggregation where toJSON (TermsAgg (TermsAggregation term include exclude order minDocCount size shardSize collectMode executionHint termAggs)) = omitNulls ["terms" .= omitNulls [ toJSON' term, - "include" .= toJSON include, - "exclude" .= toJSON exclude, - "order" .= toJSON order, - "min_doc_count" .= toJSON minDocCount, - "size" .= toJSON size, - "shard_size" .= toJSON shardSize, - "collect_mode" .= toJSON collectMode, - "execution_hint" .= toJSON executionHint + "include" .= include, + "exclude" .= exclude, + "order" .= order, + "min_doc_count" .= minDocCount, + "size" .= size, + "shard_size" .= shardSize, + "collect_mode" .= collectMode, + "execution_hint" .= executionHint ], - "aggs" .= toJSON termAggs ] + "aggs" .= termAggs ] where - toJSON' x = case x of { Left y -> "field" .= toJSON y; Right y -> "script" .= toJSON y } + toJSON' x = case x of { Left y -> "field" .= y; Right y -> "script" .= y } toJSON (DateHistogramAgg (DateHistogramAggregation field interval format preZone postZone preOffset postOffset dateHistoAggs)) = - omitNulls ["date_histogram" .= omitNulls [ "field" .= toJSON field, - "interval" .= toJSON interval, - "format" .= toJSON format, - "pre_zone" .= toJSON preZone, - "post_zone" .= toJSON postZone, - "pre_offset" .= toJSON preOffset, - "post_offset" .= toJSON postOffset + omitNulls ["date_histogram" .= omitNulls [ "field" .= field, + "interval" .= interval, + "format" .= format, + "pre_zone" .= preZone, + "post_zone" .= postZone, + "pre_offset" .= preOffset, + "post_offset" .= postOffset ], - "aggs" .= toJSON dateHistoAggs ] + "aggs" .= dateHistoAggs ] type AggregationResults = M.Map Text Value @@ -1266,17 +1355,18 @@ instance ToJSON Filter where toJSON (AndFilter filters cache) = - object ["and" .= + object ["and" .= object [ "filters" .= fmap toJSON filters - , "_cache" .= cache]] + , "_cache" .= cache]] toJSON (OrFilter filters cache) = - object ["or" .= fmap toJSON filters - , "_cache" .= cache] + object ["or" .= + object [ "filters" .= fmap toJSON filters + , "_cache" .= cache]] toJSON (NotFilter notFilter cache) = object ["not" .= - object ["filter" .= toJSON notFilter + object ["filter" .= notFilter , "_cache" .= cache]] toJSON (IdentityFilter) = @@ -1292,26 +1382,26 @@ ["field" .= fieldName]] toJSON (BoolFilter boolMatch) = - object ["bool" .= toJSON boolMatch] + object ["bool" .= boolMatch] toJSON (GeoBoundingBoxFilter bbConstraint) = - object ["geo_bounding_box" .= toJSON bbConstraint] + object ["geo_bounding_box" .= bbConstraint] toJSON (GeoDistanceFilter (GeoPoint (FieldName distanceGeoField) geoDistLatLon) distance distanceType optimizeBbox cache) = object ["geo_distance" .= - object ["distance" .= toJSON distance - , "distance_type" .= toJSON distanceType + object ["distance" .= distance + , "distance_type" .= distanceType , "optimize_bbox" .= optimizeBbox - , distanceGeoField .= toJSON geoDistLatLon + , distanceGeoField .= geoDistLatLon , "_cache" .= cache]] toJSON (GeoDistanceRangeFilter (GeoPoint (FieldName gddrField) drLatLon) (DistanceRange geoDistRangeDistFrom drDistanceTo)) = object ["geo_distance_range" .= - object ["from" .= toJSON geoDistRangeDistFrom - , "to" .= toJSON drDistanceTo - , gddrField .= toJSON drLatLon]] + object ["from" .= geoDistRangeDistFrom + , "to" .= drDistanceTo + , gddrField .= drLatLon]] toJSON (GeoPolygonFilter (FieldName geoPolygonFilterField) latLons) = object ["geo_polygon" .= @@ -1321,7 +1411,7 @@ toJSON (IdsFilter (MappingName mappingName) values) = object ["ids" .= object ["type" .= mappingName - , "values" .= fmap (T.pack . unpackId) values]] + , "values" .= fmap unpackId values]] toJSON (LimitFilter limit) = object ["limit" .= object ["value" .= limit]] @@ -1337,38 +1427,25 @@ object [fieldName .= fieldValue , "_cache" .= cache]] - toJSON (RangeFilter (FieldName fieldName) (Left halfRange) rangeExecution cache) = + toJSON (RangeFilter (FieldName fieldName) rangeValue rangeExecution cache) = object ["range" .= - object [fieldName .= - object [rqFKey .= rqFVal] - , "execution" .= toJSON rangeExecution + object [ fieldName .= object (rangeValueToPair rangeValue) + , "execution" .= rangeExecution , "_cache" .= cache]] - where - (rqFKey, rqFVal) = halfRangeToKV halfRange - toJSON (RangeFilter (FieldName fieldName) (Right range) rangeExecution cache) = - object ["range" .= - object [fieldName .= - object [lessKey .= lessVal - , greaterKey .= greaterVal] - , "execution" .= toJSON rangeExecution - , "_cache" .= cache]] - where - (lessKey, lessVal, greaterKey, greaterVal) = rangeToKV range - toJSON (RegexpFilter (FieldName fieldName) (Regexp regexText) flags (CacheName cacheName) cache (CacheKey cacheKey)) = object ["regexp" .= object [fieldName .= object ["value" .= regexText - , "flags" .= toJSON flags] + , "flags" .= flags] , "_name" .= cacheName , "_cache" .= cache , "_cache_key" .= cacheKey]] instance ToJSON GeoPoint where toJSON (GeoPoint (FieldName geoPointField) geoPointLatLon) = - object [ geoPointField .= toJSON geoPointLatLon ] + object [ geoPointField .= geoPointLatLon ] instance ToJSON Query where @@ -1388,82 +1465,82 @@ getTermValue (Term _ v) = v toJSON (IdsQuery idsQueryMappingName docIds) = object [ "ids" .= object conjoined ] - where conjoined = [ "type" .= toJSON idsQueryMappingName + where conjoined = [ "type" .= idsQueryMappingName , "values" .= fmap toJSON docIds ] toJSON (QueryQueryStringQuery qQueryStringQuery) = - object [ "query_string" .= toJSON qQueryStringQuery ] + object [ "query_string" .= qQueryStringQuery ] toJSON (QueryMatchQuery matchQuery) = - object [ "match" .= toJSON matchQuery ] + object [ "match" .= matchQuery ] toJSON (QueryMultiMatchQuery multiMatchQuery) = toJSON multiMatchQuery toJSON (QueryBoolQuery boolQuery) = - object [ "bool" .= toJSON boolQuery ] + object [ "bool" .= boolQuery ] toJSON (QueryBoostingQuery boostingQuery) = - object [ "boosting" .= toJSON boostingQuery ] + object [ "boosting" .= boostingQuery ] toJSON (QueryCommonTermsQuery commonTermsQuery) = - object [ "common" .= toJSON commonTermsQuery ] + object [ "common" .= commonTermsQuery ] toJSON (ConstantScoreFilter csFilter boost) = - object [ "constant_score" .= toJSON csFilter - , "boost" .= toJSON boost] + object [ "constant_score" .= csFilter + , "boost" .= boost] toJSON (ConstantScoreQuery query boost) = - object [ "constant_score" .= toJSON query - , "boost" .= toJSON boost] + object [ "constant_score" .= query + , "boost" .= boost] toJSON (QueryDisMaxQuery disMaxQuery) = - object [ "dis_max" .= toJSON disMaxQuery ] + object [ "dis_max" .= disMaxQuery ] toJSON (QueryFilteredQuery qFilteredQuery) = - object [ "filtered" .= toJSON qFilteredQuery ] + object [ "filtered" .= qFilteredQuery ] toJSON (QueryFuzzyLikeThisQuery fuzzyQuery) = - object [ "fuzzy_like_this" .= toJSON fuzzyQuery ] + object [ "fuzzy_like_this" .= fuzzyQuery ] toJSON (QueryFuzzyLikeFieldQuery fuzzyFieldQuery) = - object [ "fuzzy_like_this_field" .= toJSON fuzzyFieldQuery ] + object [ "fuzzy_like_this_field" .= fuzzyFieldQuery ] toJSON (QueryFuzzyQuery fuzzyQuery) = - object [ "fuzzy" .= toJSON fuzzyQuery ] + object [ "fuzzy" .= fuzzyQuery ] toJSON (QueryHasChildQuery childQuery) = - object [ "has_child" .= toJSON childQuery ] + object [ "has_child" .= childQuery ] toJSON (QueryHasParentQuery parentQuery) = - object [ "has_parent" .= toJSON parentQuery ] + object [ "has_parent" .= parentQuery ] toJSON (QueryIndicesQuery qIndicesQuery) = - object [ "indices" .= toJSON qIndicesQuery ] + object [ "indices" .= qIndicesQuery ] toJSON (MatchAllQuery boost) = object [ "match_all" .= omitNulls [ "boost" .= boost ] ] toJSON (QueryMoreLikeThisQuery query) = - object [ "more_like_this" .= toJSON query ] + object [ "more_like_this" .= query ] toJSON (QueryMoreLikeThisFieldQuery query) = - object [ "more_like_this_field" .= toJSON query ] + object [ "more_like_this_field" .= query ] toJSON (QueryNestedQuery query) = - object [ "nested" .= toJSON query ] + object [ "nested" .= query ] toJSON (QueryPrefixQuery query) = - object [ "prefix" .= toJSON query ] + object [ "prefix" .= query ] toJSON (QueryRangeQuery query) = - object [ "range" .= toJSON query ] + object [ "range" .= query ] toJSON (QueryRegexpQuery query) = - object [ "regexp" .= toJSON query ] + object [ "regexp" .= query ] toJSON (QuerySimpleQueryStringQuery query) = - object [ "simple_query_string" .= toJSON query ] + object [ "simple_query_string" .= query ] omitNulls :: [(Text, Value)] -> Value @@ -1476,7 +1553,7 @@ instance ToJSON SimpleQueryStringQuery where toJSON SimpleQueryStringQuery {..} = omitNulls (base ++ maybeAdd) - where base = [ "query" .= toJSON simpleQueryStringQuery ] + where base = [ "query" .= simpleQueryStringQuery ] maybeAdd = [ "fields" .= simpleQueryStringField , "default_operator" .= simpleQueryStringOperator , "analyzer" .= simpleQueryStringAnalyzer @@ -1512,7 +1589,7 @@ rqQueryBoost) = object [ rqQueryField .= omitNulls base ] where base = [ "value" .= regexpQueryQuery - , "flags" .= toJSON rqQueryFlags + , "flags" .= rqQueryFlags , "boost" .= rqQueryBoost ] @@ -1528,7 +1605,7 @@ qsLenient qsLocale) = omitNulls base where - base = [ "query" .= toJSON qsQueryString + base = [ "query" .= qsQueryString , "default_field" .= qsDefaultField , "default_operator" .= qsOperator , "analyzer" .= qsAnalyzer @@ -1548,32 +1625,23 @@ instance ToJSON RangeQuery where - toJSON (RangeQuery (FieldName fieldName) (Right range) boost) = - object [ fieldName .= conjoined ] - where conjoined = [ "boost" .= toJSON boost - , lessKey .= lessVal - , greaterKey .= greaterVal ] - (lessKey, lessVal, greaterKey, greaterVal) = rangeToKV range - - toJSON (RangeQuery (FieldName fieldName) (Left halfRange) boost) = + toJSON (RangeQuery (FieldName fieldName) range boost) = object [ fieldName .= conjoined ] - where conjoined = [ "boost" .= toJSON boost - , rqKey .= rqVal ] - (rqKey, rqVal) = halfRangeToKV halfRange + where conjoined = [ "boost" .= boost ] ++ (rangeValueToPair range) instance ToJSON PrefixQuery where toJSON (PrefixQuery (FieldName fieldName) queryValue boost) = object [ fieldName .= omitNulls base ] - where base = [ "value" .= toJSON queryValue + where base = [ "value" .= queryValue , "boost" .= boost ] instance ToJSON NestedQuery where toJSON (NestedQuery nqPath nqScoreType nqQuery) = - object [ "path" .= toJSON nqPath - , "score_mode" .= toJSON nqScoreType - , "query" .= toJSON nqQuery ] + object [ "path" .= nqPath + , "score_mode" .= nqScoreType + , "query" .= nqQuery ] instance ToJSON MoreLikeThisFieldQuery where @@ -1581,7 +1649,7 @@ percent mtf mqt stopwords mindf maxdf minwl maxwl boostTerms boost analyzer) = object [ fieldName .= omitNulls base ] - where base = [ "like_text" .= toJSON text + where base = [ "like_text" .= text , "percent_terms_to_match" .= percent , "min_term_freq" .= mtf , "max_query_terms" .= mqt @@ -1600,7 +1668,7 @@ mtf mqt stopwords mindf maxdf minwl maxwl boostTerms boost analyzer) = omitNulls base - where base = [ "like_text" .= toJSON text + where base = [ "like_text" .= text , "fields" .= fields , "percent_terms_to_match" .= percent , "min_term_freq" .= mtf @@ -1617,34 +1685,34 @@ instance ToJSON IndicesQuery where toJSON (IndicesQuery indices query noMatch) = - omitNulls [ "indices" .= toJSON indices - , "no_match_query" .= toJSON noMatch - , "query" .= toJSON query ] + omitNulls [ "indices" .= indices + , "no_match_query" .= noMatch + , "query" .= query ] instance ToJSON HasParentQuery where toJSON (HasParentQuery queryType query scoreType) = - omitNulls [ "parent_type" .= toJSON queryType - , "score_type" .= toJSON scoreType - , "query" .= toJSON query ] + omitNulls [ "parent_type" .= queryType + , "score_type" .= scoreType + , "query" .= query ] instance ToJSON HasChildQuery where toJSON (HasChildQuery queryType query scoreType) = - omitNulls [ "query" .= toJSON query - , "score_type" .= toJSON scoreType - , "type" .= toJSON queryType ] + omitNulls [ "query" .= query + , "score_type" .= scoreType + , "type" .= queryType ] instance ToJSON FuzzyQuery where toJSON (FuzzyQuery (FieldName fieldName) queryText prefixLength maxEx fuzziness boost) = object [ fieldName .= omitNulls base ] - where base = [ "value" .= toJSON queryText - , "fuzziness" .= toJSON fuzziness - , "prefix_length" .= toJSON prefixLength - , "boost" .= toJSON boost - , "max_expansions" .= toJSON maxEx ] + where base = [ "value" .= queryText + , "fuzziness" .= fuzziness + , "prefix_length" .= prefixLength + , "boost" .= boost + , "max_expansions" .= maxEx ] instance ToJSON FuzzyLikeFieldQuery where @@ -1652,41 +1720,41 @@ fieldText maxTerms ignoreFreq fuzziness prefixLength boost analyzer) = object [ fieldName .= - omitNulls [ "like_text" .= toJSON fieldText - , "max_query_terms" .= toJSON maxTerms - , "ignore_tf" .= toJSON ignoreFreq - , "fuzziness" .= toJSON fuzziness - , "prefix_length" .= toJSON prefixLength - , "analyzer" .= toJSON analyzer - , "boost" .= toJSON boost ]] + omitNulls [ "like_text" .= fieldText + , "max_query_terms" .= maxTerms + , "ignore_tf" .= ignoreFreq + , "fuzziness" .= fuzziness + , "prefix_length" .= prefixLength + , "analyzer" .= analyzer + , "boost" .= boost ]] instance ToJSON FuzzyLikeThisQuery where toJSON (FuzzyLikeThisQuery fields text maxTerms ignoreFreq fuzziness prefixLength boost analyzer) = omitNulls base - where base = [ "fields" .= toJSON fields - , "like_text" .= toJSON text - , "max_query_terms" .= toJSON maxTerms - , "ignore_tf" .= toJSON ignoreFreq - , "fuzziness" .= toJSON fuzziness - , "prefix_length" .= toJSON prefixLength - , "analyzer" .= toJSON analyzer - , "boost" .= toJSON boost ] + where base = [ "fields" .= fields + , "like_text" .= text + , "max_query_terms" .= maxTerms + , "ignore_tf" .= ignoreFreq + , "fuzziness" .= fuzziness + , "prefix_length" .= prefixLength + , "analyzer" .= analyzer + , "boost" .= boost ] instance ToJSON FilteredQuery where toJSON (FilteredQuery query fFilter) = - object [ "query" .= toJSON query - , "filter" .= toJSON fFilter ] + object [ "query" .= query + , "filter" .= fFilter ] instance ToJSON DisMaxQuery where toJSON (DisMaxQuery queries tiebreaker boost) = omitNulls base - where base = [ "queries" .= toJSON queries - , "boost" .= toJSON boost - , "tie_breaker" .= toJSON tiebreaker ] + where base = [ "queries" .= queries + , "boost" .= boost + , "tie_breaker" .= tiebreaker ] instance ToJSON CommonTermsQuery where @@ -1694,38 +1762,38 @@ (QueryString query) cf lfo hfo msm boost analyzer disableCoord) = object [fieldName .= omitNulls base ] - where base = [ "query" .= toJSON query - , "cutoff_frequency" .= toJSON cf - , "low_freq_operator" .= toJSON lfo - , "minimum_should_match" .= toJSON msm - , "boost" .= toJSON boost - , "analyzer" .= toJSON analyzer - , "disable_coord" .= toJSON disableCoord - , "high_freq_operator" .= toJSON hfo ] + where base = [ "query" .= query + , "cutoff_frequency" .= cf + , "low_freq_operator" .= lfo + , "minimum_should_match" .= msm + , "boost" .= boost + , "analyzer" .= analyzer + , "disable_coord" .= disableCoord + , "high_freq_operator" .= hfo ] instance ToJSON CommonMinimumMatch where toJSON (CommonMinimumMatch mm) = toJSON mm toJSON (CommonMinimumMatchHighLow (MinimumMatchHighLow lowF highF)) = - object [ "low_freq" .= toJSON lowF - , "high_freq" .= toJSON highF ] + object [ "low_freq" .= lowF + , "high_freq" .= highF ] instance ToJSON BoostingQuery where toJSON (BoostingQuery bqPositiveQuery bqNegativeQuery bqNegativeBoost) = - object [ "positive" .= toJSON bqPositiveQuery - , "negative" .= toJSON bqNegativeQuery - , "negative_boost" .= toJSON bqNegativeBoost ] + object [ "positive" .= bqPositiveQuery + , "negative" .= bqNegativeQuery + , "negative_boost" .= bqNegativeBoost ] instance ToJSON BoolQuery where toJSON (BoolQuery mustM notM shouldM bqMin boost disableCoord) = omitNulls base - where base = [ "must" .= toJSON mustM - , "must_not" .= toJSON notM - , "should" .= toJSON shouldM - , "minimum_should_match" .= toJSON bqMin - , "boost" .= toJSON boost - , "disable_coord" .= toJSON disableCoord ] + where base = [ "must" .= mustM + , "must_not" .= notM + , "should" .= shouldM + , "minimum_should_match" .= bqMin + , "boost" .= boost + , "disable_coord" .= disableCoord ] instance ToJSON MatchQuery where @@ -1735,13 +1803,13 @@ analyzer maxExpansions lenient) = object [ fieldName .= omitNulls base ] where base = [ "query" .= mqQueryString - , "operator" .= toJSON booleanOperator - , "zero_terms_query" .= toJSON zeroTermsQuery - , "cutoff_frequency" .= toJSON cutoffFrequency - , "type" .= toJSON matchQueryType - , "analyzer" .= toJSON analyzer - , "max_expansions" .= toJSON maxExpansions - , "lenient" .= toJSON lenient ] + , "operator" .= booleanOperator + , "zero_terms_query" .= zeroTermsQuery + , "cutoff_frequency" .= cutoffFrequency + , "type" .= matchQueryType + , "analyzer" .= analyzer + , "max_expansions" .= maxExpansions + , "lenient" .= lenient ] instance ToJSON MultiMatchQuery where @@ -1750,14 +1818,14 @@ object ["multi_match" .= omitNulls base] where base = [ "fields" .= fmap toJSON fields , "query" .= query - , "operator" .= toJSON boolOp - , "zero_terms_query" .= toJSON ztQ - , "tiebreaker" .= toJSON tb - , "type" .= toJSON mmqt - , "cutoff_frequency" .= toJSON cf - , "analyzer" .= toJSON analyzer - , "max_expansions" .= toJSON maxEx - , "lenient" .= toJSON lenient ] + , "operator" .= boolOp + , "zero_terms_query" .= ztQ + , "tiebreaker" .= tb + , "type" .= mmqt + , "cutoff_frequency" .= cf + , "analyzer" .= analyzer + , "max_expansions" .= maxEx + , "lenient" .= lenient ] instance ToJSON MultiMatchQueryType where @@ -1869,7 +1937,7 @@ instance ToJSON Highlights where toJSON (Highlights global fields) = - omitNulls (("fields" .= toJSON fields) + omitNulls (("fields" .= fields) : highlightSettingsPairs global) instance ToJSON HighlightSettings where @@ -1947,16 +2015,16 @@ (DefaultSort (FieldName dsSortFieldName) dsSortOrder dsIgnoreUnmapped dsSortMode dsMissingSort dsNestedFilter)) = object [dsSortFieldName .= omitNulls base] where - base = [ "order" .= toJSON dsSortOrder + base = [ "order" .= dsSortOrder , "ignore_unmapped" .= dsIgnoreUnmapped , "mode" .= dsSortMode , "missing" .= dsMissingSort , "nested_filter" .= dsNestedFilter ] toJSON (GeoDistanceSortSpec gdsSortOrder (GeoPoint (FieldName field) gdsLatLon) units) = - object [ "unit" .= toJSON units - , field .= toJSON gdsLatLon - , "order" .= toJSON gdsSortOrder ] + object [ "unit" .= units + , field .= gdsLatLon + , "order" .= gdsSortOrder ] instance ToJSON SortOrder where @@ -2018,7 +2086,7 @@ instance ToJSON GeoBoundingBoxConstraint where toJSON (GeoBoundingBoxConstraint (FieldName gbbcGeoBBField) gbbcConstraintBox cache type') = - object [gbbcGeoBBField .= toJSON gbbcConstraintBox + object [gbbcGeoBBField .= gbbcConstraintBox , "_cache" .= cache , "type" .= type'] @@ -2030,8 +2098,8 @@ instance ToJSON GeoBoundingBox where toJSON (GeoBoundingBox gbbTopLeft gbbBottomRight) = - object ["top_left" .= toJSON gbbTopLeft - , "bottom_right" .= toJSON gbbBottomRight] + object ["top_left" .= gbbTopLeft + , "bottom_right" .= gbbBottomRight] instance ToJSON LatLon where @@ -2064,9 +2132,9 @@ instance ToJSON BoolMatch where - toJSON (MustMatch term cache) = object ["must" .= toJSON term, + toJSON (MustMatch term cache) = object ["must" .= term, "_cache" .= cache] - toJSON (MustNotMatch term cache) = object ["must_not" .= toJSON term, + toJSON (MustNotMatch term cache) = object ["must_not" .= term, "_cache" .= cache] toJSON (ShouldMatch terms cache) = object ["should" .= fmap toJSON terms, "_cache" .= cache] diff --git a/tests/tests.hs b/tests/tests.hs --- a/tests/tests.hs +++ b/tests/tests.hs @@ -1,30 +1,33 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} - +{-# OPTIONS_GHC -fno-warn-orphans #-} module Main where import Control.Applicative import Control.Monad +import Control.Monad.Reader import Data.Aeson -import qualified Data.HashMap.Strict as HM -import Data.List (nub) -import Data.List.NonEmpty (NonEmpty (..)) -import qualified Data.List.NonEmpty as NE -import qualified Data.Map.Strict as M -import Data.Text (Text) -import qualified Data.Text as T -import Data.Time.Calendar (Day (..)) -import Data.Time.Clock (UTCTime (..), secondsToDiffTime) -import qualified Data.Vector as V +import qualified Data.HashMap.Strict as HM +import Data.List (nub) +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as NE +import qualified Data.Map.Strict as M +import Data.Text (Text) +import qualified Data.Text as T +import Data.Time.Calendar (Day (..)) +import Data.Time.Clock (UTCTime (..), + secondsToDiffTime) +import qualified Data.Vector as V import Database.Bloodhound -import GHC.Generics (Generic) +import GHC.Generics (Generic) import Network.HTTP.Client -import qualified Network.HTTP.Types.Status as NHTS -import Prelude hiding (filter, putStrLn) +import qualified Network.HTTP.Types.Status as NHTS +import Prelude hiding (filter, putStrLn) import Test.Hspec +import Test.QuickCheck.Property.Monoid -import Test.Hspec.QuickCheck (prop) +import Test.Hspec.QuickCheck (prop) import Test.QuickCheck testServer :: Server @@ -34,15 +37,18 @@ testMapping :: MappingName testMapping = MappingName "tweet" +withTestEnv :: BH IO a -> IO a +withTestEnv = withBH defaultManagerSettings testServer + 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 +createExampleIndex :: BH IO Reply +createExampleIndex = createIndex defaultIndexSettings testIndex +deleteExampleIndex :: BH IO Reply +deleteExampleIndex = deleteIndex testIndex data ServerVersion = ServerVersion Int Int Int deriving (Show, Eq, Ord) @@ -70,18 +76,16 @@ Just (ServerVersion majorVer minorVer patchVer) mkServerVersion _ = Nothing -getServerVersion :: Server -> IO (Maybe ServerVersion) -getServerVersion s = liftM extractVersion (getStatus s) +getServerVersion :: IO (Maybe ServerVersion) +getServerVersion = liftM extractVersion (withTestEnv getStatus) where version' = T.splitOn "." . number . version toInt = read . T.unpack parseVersion v = map toInt (version' v) extractVersion = join . liftM (mkServerVersion . parseVersion) - - testServerBranch :: IO (Maybe ServerVersion) -testServerBranch = getServerVersion testServer >>= \v -> return $ liftM serverBranch v +testServerBranch = getServerVersion >>= \v -> return $ liftM serverBranch v atleast :: ServerVersion -> IO Bool atleast v = testServerBranch >>= \x -> return $ x >= Just (serverBranch v) @@ -136,60 +140,63 @@ , age = 1000 , location = Location 40.12 (-71.34) } -insertData :: IO () +insertData :: BH IO () insertData = do _ <- deleteExampleIndex _ <- createExampleIndex - _ <- putMapping testServer testIndex testMapping TweetMapping - _ <- indexDocument testServer testIndex testMapping exampleTweet (DocId "1") - _ <- refreshIndex testServer testIndex + _ <- putMapping testIndex testMapping TweetMapping + _ <- indexDocument testIndex testMapping exampleTweet (DocId "1") + _ <- refreshIndex testIndex return () -insertOther :: IO () +insertOther :: BH IO () insertOther = do - _ <- indexDocument testServer testIndex testMapping otherTweet (DocId "2") - _ <- refreshIndex testServer testIndex + _ <- indexDocument testIndex testMapping otherTweet (DocId "2") + _ <- refreshIndex testIndex return () -searchTweet :: Search -> IO (Either String Tweet) +searchTweet :: Search -> BH IO (Either String Tweet) searchTweet search = do - reply <- searchByIndex testServer testIndex search + reply <- searchByIndex 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 -> BH IO () searchExpectNoResults search = do - reply <- searchByIndex testServer testIndex search + reply <- searchByIndex testIndex search let result = eitherDecode (responseBody reply) :: Either String (SearchResult Tweet) let emptyHits = fmap (hits . searchHits) result - emptyHits `shouldBe` Right [] + liftIO $ + emptyHits `shouldBe` Right [] -searchExpectAggs :: Search -> IO () +searchExpectAggs :: Search -> BH IO () searchExpectAggs search = do - reply <- searchAll testServer search + reply <- searchAll search let isEmpty x = return (M.null x) let result = decode (responseBody reply) :: Maybe (SearchResult Tweet) - (result >>= aggregations >>= isEmpty) `shouldBe` Just False + liftIO $ + (result >>= aggregations >>= isEmpty) `shouldBe` Just False -searchValidBucketAgg :: (BucketAggregation a, FromJSON a, Show a) => Search -> Text -> (Text -> AggregationResults -> Maybe (Bucket a)) -> IO () +searchValidBucketAgg :: (BucketAggregation a, FromJSON a, Show a) => Search -> Text -> (Text -> AggregationResults -> Maybe (Bucket a)) -> BH IO () searchValidBucketAgg search aggKey extractor = do - reply <- searchAll testServer search + reply <- searchAll search let bucketDocs = docCount . head . buckets let result = decode (responseBody reply) :: Maybe (SearchResult Tweet) let count = result >>= aggregations >>= extractor aggKey >>= \x -> return (bucketDocs x) - count `shouldBe` Just 1 + liftIO $ + count `shouldBe` Just 1 -searchTermsAggHint :: [ExecutionHint] -> IO () +searchTermsAggHint :: [ExecutionHint] -> BH IO () searchTermsAggHint hints = do let terms hint = TermsAgg $ (mkTermsAggregation "user") { termExecutionHint = Just hint } let search hint = mkAggregateSearch Nothing $ mkAggregations "users" $ terms hint forM_ hints $ searchExpectAggs . search forM_ hints (\x -> searchValidBucketAgg (search x) "users" toTerms) -searchTweetHighlight :: Search -> IO (Either String (Maybe HitHighlight)) +searchTweetHighlight :: Search -> BH IO (Either String (Maybe HitHighlight)) searchTweetHighlight search = do - reply <- searchByIndex testServer testIndex search + reply <- searchByIndex testIndex search let result = eitherDecode (responseBody reply) :: Either String (SearchResult Tweet) let myHighlight = fmap (hitHighlight . head . hits . searchHits) result return myHighlight @@ -219,30 +226,65 @@ , pure Interval ] +arbitraryScore :: Gen Score +arbitraryScore = fmap getPositive <$> arbitrary + +instance Arbitrary Text where + arbitrary = T.pack <$> arbitrary + +instance (Arbitrary k, Arbitrary v, Ord k) => Arbitrary (M.Map k v) where + arbitrary = M.fromList <$> arbitrary + +instance Arbitrary IndexName where + arbitrary = IndexName <$> arbitrary + +instance Arbitrary MappingName where + arbitrary = MappingName <$> arbitrary + +instance Arbitrary DocId where + arbitrary = DocId <$> arbitrary + +instance Arbitrary a => Arbitrary (Hit a) where + arbitrary = Hit <$> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitraryScore + <*> arbitrary + <*> arbitrary + + +instance Arbitrary a => Arbitrary (SearchHits a) where + arbitrary = sized $ \n -> resize (n `div` 2) $ do + tot <- getPositive <$> arbitrary + score <- arbitraryScore + hs <- arbitrary + return $ SearchHits tot score hs + main :: IO () main = hspec $ do describe "index create/delete API" $ do - it "creates and then deletes the requested index" $ do + it "creates and then deletes the requested index" $ withTestEnv $ do -- priming state. _ <- deleteExampleIndex resp <- createExampleIndex deleteResp <- deleteExampleIndex - validateStatus resp 200 - validateStatus deleteResp 200 + liftIO $ do + validateStatus resp 200 + validateStatus deleteResp 200 describe "document API" $ do - it "indexes, gets, and then deletes the generated document" $ do + it "indexes, gets, and then deletes the generated document" $ withTestEnv $ do _ <- insertData - docInserted <- getDocument testServer testIndex testMapping (DocId "1") + docInserted <- getDocument testIndex testMapping (DocId "1") let newTweet = eitherDecode (responseBody docInserted) :: Either String (EsResult Tweet) - fmap _source newTweet `shouldBe` Right exampleTweet + liftIO $ (fmap _source newTweet `shouldBe` Right exampleTweet) describe "bulk API" $ do - it "inserts all documents we request" $ do + it "inserts all documents we request" $ withTestEnv $ do _ <- insertData let firstTest = BulkTest "blah" let secondTest = BulkTest "bloo" @@ -251,49 +293,54 @@ let secondDoc = BulkCreate testIndex testMapping (DocId "3") (toJSON secondTest) let stream = V.fromList [firstDoc, secondDoc] - _ <- bulk testServer stream - _ <- refreshIndex testServer testIndex - fDoc <- getDocument testServer testIndex testMapping (DocId "2") - sDoc <- getDocument testServer testIndex testMapping (DocId "3") + _ <- bulk stream + _ <- refreshIndex testIndex + fDoc <- getDocument testIndex testMapping (DocId "2") + sDoc <- getDocument 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 + liftIO $ do + 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 + it "returns document for term query and identity filter" $ withTestEnv $ 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 + liftIO $ + myTweet `shouldBe` Right exampleTweet - it "returns document for terms query and identity filter" $ do + it "returns document for terms query and identity filter" $ withTestEnv $ do _ <- insertData let query = TermsQuery (NE.fromList [(Term "user" "bitemyapp")]) let filter = IdentityFilter <&&> IdentityFilter let search = mkSearch (Just query) (Just filter) myTweet <- searchTweet search - myTweet `shouldBe` Right exampleTweet + liftIO $ + myTweet `shouldBe` Right exampleTweet - it "returns document for match query" $ do + it "returns document for match query" $ withTestEnv $ do _ <- insertData let query = QueryMatchQuery $ mkMatchQuery (FieldName "user") (QueryString "bitemyapp") let search = mkSearch (Just query) Nothing myTweet <- searchTweet search - myTweet `shouldBe` Right exampleTweet + liftIO $ + myTweet `shouldBe` Right exampleTweet - it "returns document for multi-match query" $ do + it "returns document for multi-match query" $ withTestEnv $ 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 + liftIO $ + myTweet `shouldBe` Right exampleTweet - it "returns document for bool query" $ do + it "returns document for bool query" $ withTestEnv $ do _ <- insertData let innerQuery = QueryMatchQuery $ mkMatchQuery (FieldName "user") (QueryString "bitemyapp") @@ -301,18 +348,20 @@ mkBoolQuery [innerQuery] [] [] let search = mkSearch (Just query) Nothing myTweet <- searchTweet search - myTweet `shouldBe` Right exampleTweet + liftIO $ + myTweet `shouldBe` Right exampleTweet - it "returns document for boosting query" $ do + it "returns document for boosting query" $ withTestEnv $ 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 + liftIO $ + myTweet `shouldBe` Right exampleTweet - it "returns document for common terms query" $ do + it "returns document for common terms query" $ withTestEnv $ do _ <- insertData let query = QueryCommonTermsQuery $ CommonTermsQuery (FieldName "user") @@ -321,55 +370,61 @@ Or Or Nothing Nothing Nothing Nothing let search = mkSearch (Just query) Nothing myTweet <- searchTweet search - myTweet `shouldBe` Right exampleTweet + liftIO $ + myTweet `shouldBe` Right exampleTweet describe "sorting" $ do - it "returns documents in the right order" $ do + it "returns documents in the right order" $ withTestEnv $ do _ <- insertData _ <- insertOther let sortSpec = DefaultSortSpec $ mkSort (FieldName "age") Ascending let search = Search Nothing (Just IdentityFilter) (Just [sortSpec]) Nothing Nothing - False 0 10 - reply <- searchByIndex testServer testIndex search + False (From 0) (Size 10) + reply <- searchByIndex testIndex search let result = eitherDecode (responseBody reply) :: Either String (SearchResult Tweet) let myTweet = fmap (hitSource . head . hits . searchHits) result - myTweet `shouldBe` Right otherTweet + liftIO $ + myTweet `shouldBe` Right otherTweet describe "filtering API" $ do - it "returns document for composed boolmatch and identity" $ do + it "returns document for composed boolmatch and identity" $ withTestEnv $ do _ <- insertData let queryFilter = BoolFilter (MustMatch (Term "user" "bitemyapp") False) <&&> IdentityFilter let search = mkSearch Nothing (Just queryFilter) myTweet <- searchTweet search - myTweet `shouldBe` Right exampleTweet + liftIO $ + myTweet `shouldBe` Right exampleTweet - it "returns document for term filter" $ do + it "returns document for term filter" $ withTestEnv $ do _ <- insertData let termFilter = TermFilter (Term "user" "bitemyapp") False let search = mkSearch Nothing (Just termFilter) myTweet <- searchTweet search - myTweet `shouldBe` Right exampleTweet + liftIO $ + myTweet `shouldBe` Right exampleTweet - it "returns document for existential filter" $ do + it "returns document for existential filter" $ withTestEnv $ do _ <- insertData let search = mkSearch Nothing (Just (ExistsFilter (FieldName "user"))) myTweet <- searchTweet search - myTweet `shouldBe` Right exampleTweet + liftIO $ + myTweet `shouldBe` Right exampleTweet - it "returns document for geo boundingbox filter" $ do + it "returns document for geo boundingbox filter" $ withTestEnv $ do _ <- insertData let box = GeoBoundingBox (LatLon 40.73 (-74.1)) (LatLon 40.10 (-71.12)) let bbConstraint = GeoBoundingBoxConstraint (FieldName "tweet.location") box False GeoFilterMemory let geoFilter = GeoBoundingBoxFilter bbConstraint let search = mkSearch Nothing (Just geoFilter) myTweet <- searchTweet search - myTweet `shouldBe` Right exampleTweet + liftIO $ + myTweet `shouldBe` Right exampleTweet - it "doesn't return document for nonsensical boundingbox filter" $ do + it "doesn't return document for nonsensical boundingbox filter" $ withTestEnv $ do _ <- insertData let box = GeoBoundingBox (LatLon 0.73 (-4.1)) (LatLon 0.10 (-1.12)) let bbConstraint = GeoBoundingBoxConstraint (FieldName "tweet.location") box False GeoFilterMemory @@ -377,7 +432,7 @@ let search = mkSearch Nothing (Just geoFilter) searchExpectNoResults search - it "returns document for geo distance filter" $ do + it "returns document for geo distance filter" $ withTestEnv $ do _ <- insertData let geoPoint = GeoPoint (FieldName "tweet.location") (LatLon 40.12 (-71.34)) let distance = Distance 10.0 Miles @@ -385,18 +440,20 @@ let geoFilter = GeoDistanceFilter geoPoint distance SloppyArc optimizeBbox False let search = mkSearch Nothing (Just geoFilter) myTweet <- searchTweet search - myTweet `shouldBe` Right exampleTweet + liftIO $ + myTweet `shouldBe` Right exampleTweet - it "returns document for geo distance range filter" $ do + it "returns document for geo distance range filter" $ withTestEnv $ 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 + liftIO $ + myTweet `shouldBe` Right exampleTweet - it "doesn't return document for wild geo distance range filter" $ do + it "doesn't return document for wild geo distance range filter" $ withTestEnv $ do _ <- insertData let geoPoint = GeoPoint (FieldName "tweet.location") (LatLon 40.12 (-71.34)) let distanceRange = DistanceRange (Distance 100.0 Miles) (Distance 1000.0 Miles) @@ -404,7 +461,7 @@ let search = mkSearch Nothing (Just geoFilter) searchExpectNoResults search - it "returns document for geo polygon filter" $ do + it "returns document for geo polygon filter" $ withTestEnv $ do _ <- insertData let points = [LatLon 40.0 (-70.00), LatLon 40.0 (-72.00), @@ -413,9 +470,10 @@ let geoFilter = GeoPolygonFilter (FieldName "tweet.location") points let search = mkSearch Nothing (Just geoFilter) myTweet <- searchTweet search - myTweet `shouldBe` Right exampleTweet + liftIO $ + myTweet `shouldBe` Right exampleTweet - it "doesn't return document for bad geo polygon filter" $ do + it "doesn't return document for bad geo polygon filter" $ withTestEnv $ do _ <- insertData let points = [LatLon 40.0 (-70.00), LatLon 40.0 (-71.00), @@ -425,31 +483,51 @@ let search = mkSearch Nothing (Just geoFilter) searchExpectNoResults search - it "returns document for ids filter" $ do + it "returns document for ids filter" $ withTestEnv $ do _ <- insertData let filter = IdsFilter (MappingName "tweet") [DocId "1"] let search = mkSearch Nothing (Just filter) myTweet <- searchTweet search - myTweet `shouldBe` Right exampleTweet + liftIO $ + myTweet `shouldBe` Right exampleTweet - it "returns document for range filter" $ do + it "returns document for Double range filter" $ withTestEnv $ do _ <- insertData let filter = RangeFilter (FieldName "age") - (Right (RangeLtGt (LessThan 100000.0) (GreaterThan 1000.0))) + (RangeDoubleGtLt (GreaterThan 1000.0) (LessThan 100000.0)) RangeExecutionIndex False let search = mkSearch Nothing (Just filter) myTweet <- searchTweet search - myTweet `shouldBe` Right exampleTweet + liftIO $ + myTweet `shouldBe` Right exampleTweet - it "returns document for regexp filter" $ do + it "returns document for UTCTime date filter" $ withTestEnv $ do _ <- insertData + let filter = RangeFilter (FieldName "postDate") + (RangeDateGtLt + (GreaterThanD (UTCTime + (ModifiedJulianDay 55000) + (secondsToDiffTime 9))) + (LessThanD (UTCTime + (ModifiedJulianDay 55000) + (secondsToDiffTime 11)))) + RangeExecutionIndex False + let search = mkSearch Nothing (Just filter) + myTweet <- searchTweet search + liftIO $ + myTweet `shouldBe` Right exampleTweet + + + it "returns document for regexp filter" $ withTestEnv $ do + _ <- insertData let filter = RegexpFilter (FieldName "user") (Regexp "bite.*app") AllRegexpFlags (CacheName "test") False (CacheKey "key") let search = mkSearch Nothing (Just filter) myTweet <- searchTweet search - myTweet `shouldBe` Right exampleTweet + liftIO $ + myTweet `shouldBe` Right exampleTweet - it "doesn't return document for non-matching regexp filter" $ do + it "doesn't return document for non-matching regexp filter" $ withTestEnv $ do _ <- insertData let filter = RegexpFilter (FieldName "user") (Regexp "boy") AllRegexpFlags @@ -458,40 +536,40 @@ searchExpectNoResults search describe "Aggregation API" $ do - it "returns term aggregation results" $ do + it "returns term aggregation results" $ withTestEnv $ do _ <- insertData let terms = TermsAgg $ mkTermsAggregation "user" let search = mkAggregateSearch Nothing $ mkAggregations "users" terms searchExpectAggs search searchValidBucketAgg search "users" toTerms - it "can give collection hint parameters to term aggregations" $ when' (atleast es13) $ do + it "can give collection hint parameters to term aggregations" $ when' (atleast es13) $ withTestEnv $ do _ <- insertData let terms = TermsAgg $ (mkTermsAggregation "user") { termCollectMode = Just BreadthFirst } let search = mkAggregateSearch Nothing $ mkAggregations "users" terms searchExpectAggs search searchValidBucketAgg search "users" toTerms - it "can give execution hint paramters to term aggregations" $ when' (atmost es11) $ do + it "can give execution hint paramters to term aggregations" $ when' (atmost es11) $ withTestEnv $ do _ <- insertData searchTermsAggHint [Map, Ordinals] - it "can give execution hint paramters to term aggregations" $ when' (is es12) $ do + it "can give execution hint paramters to term aggregations" $ when' (is es12) $ withTestEnv $ do _ <- insertData searchTermsAggHint [GlobalOrdinals, GlobalOrdinalsHash, GlobalOrdinalsLowCardinality, Map, Ordinals] - it "can give execution hint paramters to term aggregations" $ when' (atleast es12) $ do + it "can give execution hint paramters to term aggregations" $ when' (atleast es12) $ withTestEnv $ do _ <- insertData searchTermsAggHint [GlobalOrdinals, GlobalOrdinalsHash, GlobalOrdinalsLowCardinality, Map] - it "returns date histogram aggregation results" $ do + it "returns date histogram aggregation results" $ withTestEnv $ do _ <- insertData let histogram = DateHistogramAgg $ mkDateHistogram (FieldName "postDate") Minute let search = mkAggregateSearch Nothing (mkAggregations "byDate" histogram) searchExpectAggs search searchValidBucketAgg search "byDate" toDateHistogram - it "returns date histogram using fractional date" $ do + it "returns date histogram using fractional date" $ withTestEnv $ do _ <- insertData let periods = [Year, Quarter, Month, Week, Day, Hour, Minute, Second] let fractionals = map (FractionalInterval 1.5) [Weeks, Days, Hours, Minutes, Seconds] @@ -505,7 +583,7 @@ describe "Highlights API" $ do - it "returns highlight from query when there should be one" $ do + it "returns highlight from query when there should be one" $ withTestEnv $ do _ <- insertData _ <- insertOther let query = QueryMatchQuery $ mkMatchQuery (FieldName "_all") (QueryString "haskell") @@ -513,9 +591,10 @@ let search = mkHighlightSearch (Just query) testHighlight myHighlight <- searchTweetHighlight search - myHighlight `shouldBe` Right (Just (M.fromList [("message",["Use haskell!"])])) + liftIO $ + myHighlight `shouldBe` Right (Just (M.fromList [("message",["Use haskell!"])])) - it "doesn't return highlight from a query when it shouldn't" $ do + it "doesn't return highlight from a query when it shouldn't" $ withTestEnv $ do _ <- insertData _ <- insertOther let query = QueryMatchQuery $ mkMatchQuery (FieldName "_all") (QueryString "haskell") @@ -523,7 +602,8 @@ let search = mkHighlightSearch (Just query) testHighlight myHighlight <- searchTweetHighlight search - myHighlight `shouldBe` Right Nothing + liftIO $ + myHighlight `shouldBe` Right Nothing @@ -566,4 +646,7 @@ let notDropped = omitNulls $ [ "test1" .= (toJSON (1 :: Int)) , "test2" .= (toJSON ("some value" :: Text))] in notDropped `shouldBe` Object (HM.fromList [ ("test1", Number 1.0) - , ("test2", String "some value")]) + , ("test2", String "some value")]) + describe "Monoid (SearchHits a)" $ do + prop "abides the monoid laws" $ eq $ + prop_Monoid (T :: T (SearchHits ()))