bloodhound 0.5.0.1 → 0.6.0.0

raw patch · 4 files changed

+702/−475 lines, 4 filesdep +data-default-classdep +exceptionsdep +mtldep −conduitdep ~hspecPVP ok

version bump matches the API change (PVP)

Dependencies added: data-default-class, exceptions, mtl, quickcheck-properties, transformers, uri-bytestring

Dependencies removed: conduit

Dependency ranges changed: hspec

API changes (from Hackage documentation)

Files

• bloodhound.cabal +22/−10
• src/Database/Bloodhound/Client.hs +196/−132
• src/Database/Bloodhound/Types.hs +288/−220
• tests/tests.hs +196/−113

@@ -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

@@ -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 --   <http://www.elasticsearch.org/guide/en/elasticsearch/reference/current/indices-open-close.html> ----- >>> 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 --   <http://www.elasticsearch.org/guide/en/elasticsearch/reference/current/indices-open-close.html> ----- >>> 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 --    <http://www.elasticsearch.org/guide/en/elasticsearch/reference/current/docs-bulk.html Elasticsearch's bulk API>@@ -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]

@@ -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]

@@ -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 <em>haskell</em>!"])]))+      liftIO $+        myHighlight `shouldBe` Right (Just (M.fromList [("message",["Use <em>haskell</em>!"])])) -    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 ()))