bloodhound 0.4.0.2 → 0.5.0.0

raw patch · 6 files changed

+425/−49 lines, 6 filesdep +directorydep +doctestdep +doctest-propdep ~basedep ~bytestringbuild-type:Customsetup-changedPVP ok

version bump matches the API change (PVP)

Dependencies added: directory, doctest, doctest-prop, filepath

Dependency ranges changed: base, bytestring

API changes (from Hackage documentation)

Files

• Setup.hs +51/−2
• bloodhound.cabal +16/−7
• src/Database/Bloodhound/Client.hs +225/−13
• src/Database/Bloodhound/Types.hs +40/−18
• tests/doctests.hsc +74/−0
• tests/tests.hs +19/−9

@@ -1,2 +1,51 @@-import Distribution.Simple-main = defaultMain+{-# OPTIONS_GHC -Wall #-}+module Main (main) where++import Data.List ( nub )+import Data.Version ( showVersion )+import Distribution.Package ( PackageName(PackageName), Package, PackageId, InstalledPackageId, packageVersion, packageName )+import Distribution.PackageDescription ( PackageDescription(), TestSuite(..) )+import Distribution.Simple ( defaultMainWithHooks, UserHooks(..), simpleUserHooks )+import Distribution.Simple.Utils ( rewriteFile, createDirectoryIfMissingVerbose, copyFiles )+import Distribution.Simple.BuildPaths ( autogenModulesDir )+import Distribution.Simple.Setup ( BuildFlags(buildVerbosity), Flag(..), fromFlag, HaddockFlags(haddockDistPref))+import Distribution.Simple.LocalBuildInfo ( withLibLBI, withTestLBI, LocalBuildInfo(), ComponentLocalBuildInfo(componentPackageDeps) )+import Distribution.Text ( display )+import Distribution.Verbosity ( Verbosity, normal )+import System.FilePath ( (</>) )++main :: IO ()+main = defaultMainWithHooks simpleUserHooks+  { buildHook = \pkg lbi hooks flags -> do+     generateBuildModule (fromFlag (buildVerbosity flags)) pkg lbi+     buildHook simpleUserHooks pkg lbi hooks flags+  , postHaddock = \args flags pkg lbi -> do+     -- copyFiles normal (haddockOutputDir flags pkg) [("images","Hierarchy.png")]+     postHaddock simpleUserHooks args flags pkg lbi+  }++haddockOutputDir :: Package p => HaddockFlags -> p -> FilePath+haddockOutputDir flags pkg = destDir where+  baseDir = case haddockDistPref flags of+    NoFlag -> "."+    Flag x -> x+  destDir = baseDir </> "doc" </> "html" </> display (packageName pkg)++generateBuildModule :: Verbosity -> PackageDescription -> LocalBuildInfo -> IO ()+generateBuildModule verbosity pkg lbi = do+  let dir = autogenModulesDir lbi+  createDirectoryIfMissingVerbose verbosity True dir+  withLibLBI pkg lbi $ \_ libcfg -> do+    withTestLBI pkg lbi $ \suite suitecfg -> do+      rewriteFile (dir </> "Build_" ++ testName suite ++ ".hs") $ unlines+        [ "module Build_" ++ testName suite ++ " where"+        , "deps :: [String]"+        , "deps = " ++ (show $ formatdeps (testDeps libcfg suitecfg))+        ]+  where+    formatdeps = map (formatone . snd)+    formatone p = case packageName p of+      PackageName n -> n ++ "-" ++ showVersion (packageVersion p)++testDeps :: ComponentLocalBuildInfo -> ComponentLocalBuildInfo -> [(InstalledPackageId, PackageId)]+testDeps xs ys = nub $ componentPackageDeps xs ++ componentPackageDeps ys

@@ -1,5 +1,5 @@ name:                bloodhound-version:             0.4.0.2+version:             0.5.0.0 synopsis:            ElasticSearch client library for Haskell description:         ElasticSearch made awesome for Haskell hackers homepage:            https://github.com/bitemyapp/bloodhound@@ -9,7 +9,7 @@ maintainer:          cma@bitemyapp.com copyright:           2014, Chris Allen category:            Database, Search-build-type:          Simple+build-type:          Custom cabal-version:       >=1.10  source-repository head@@ -18,14 +18,13 @@  library   ghc-options: -Wall-  default-extensions:  OverloadedStrings   exposed-modules:     Database.Bloodhound                        Database.Bloodhound.Client                        Database.Bloodhound.Types                        Database.Bloodhound.Types.Class   hs-source-dirs:      src   build-depends:       base             >= 4.3     && <5,-                       bytestring       >= 0.10.2  && <0.11,+                       bytestring       >= 0.10.0  && <0.11,                        containers       >= 0.5.0.0 && <0.6,                        aeson            >= 0.7     && <0.9,                        conduit          >= 1.0     && <1.3,@@ -34,12 +33,11 @@                        time             >= 1.4     && <1.6,                        text             >= 0.11    && <1.3,                        http-types       >= 0.8     && <0.9,-                       vector           >= 0.10.9 && <0.11+                       vector           >= 0.10.9  && <0.11   default-language:    Haskell2010  test-suite tests-  ghc-options: -Wall-  default-extensions:  OverloadedStrings+  ghc-options: -Wall -fno-warn-orphans   type: exitcode-stdio-1.0   main-is: tests.hs   hs-source-dirs: tests@@ -57,3 +55,14 @@                        vector,                        unordered-containers >= 0.2.5.0 && <0.3   default-language:    Haskell2010++test-suite doctests+  default-language: Haskell2010+  type:             exitcode-stdio-1.0+  main-is:          doctests.hs+  hs-source-dirs:   tests+  build-depends:    base,+                    directory,+                    doctest,+                    doctest-prop,+                    filepath

@@ -1,5 +1,27 @@+{-# LANGUAGE OverloadedStrings #-}++-------------------------------------------------------------------------------+-- |+-- Module : Database.Bloodhound.Client+-- Copyright : (C) 2014 Chris Allen+-- License : BSD-style (see the file LICENSE)+-- Maintainer : Chris Allen <cma@bitemyapp.com+-- Stability : provisional+-- Portability : OverloadedStrings+--+-- Client side functions for talking to Elasticsearch servers.+--+-------------------------------------------------------------------------------+ module Database.Bloodhound.Client-       ( createIndex+       ( -- * Bloodhound client functions+         -- | The examples in this module assume the following code has been run.+         --   The :{ and :} will only work in GHCi. You'll only need the data types+         --   and typeclass instances for the functions that make use of them.++         -- $setup++         createIndex        , deleteIndex        , indexExists        , openIndex@@ -28,7 +50,7 @@        where  import           Data.Aeson-import           Data.ByteString.Builder+import           Data.ByteString.Lazy.Builder import qualified Data.ByteString.Lazy.Char8 as L import           Data.List                  (intercalate) import           Data.Maybe                 (fromMaybe)@@ -41,17 +63,67 @@  import           Database.Bloodhound.Types --- find way to avoid destructuring Servers and Indexes?--- make get, post, put, delete helpers.--- make dispatch take URL last for better variance and--- utilization of partial application+-- $setup+-- >>> :set -XOverloadedStrings+-- >>> :set -XDeriveGeneric+-- >>> import Database.Bloodhound+-- >>> import Test.DocTest.Prop (assert)+-- >>> let testServer = (Server "http://localhost:9200")+-- >>> 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+-- >>> import GHC.Generics+-- >>> import           Data.Time.Calendar        (Day (..))+-- >>> import Data.Time.Clock (UTCTime (..), secondsToDiffTime)+-- >>> :{+--instance ToJSON TweetMapping where+--          toJSON TweetMapping =+--            object ["tweet" .=+--              object ["properties" .=+--                object ["location" .=+--                  object ["type" .= ("geo_point" :: Text)]]]]+--data Location = Location { lat :: Double+--                         , lon :: Double } deriving (Eq, Generic, Show)+--data Tweet = Tweet { user     :: Text+--                    , postDate :: UTCTime+--                    , message  :: Text+--                    , age      :: Int+--                    , location :: Location } deriving (Eq, Generic, Show)+--exampleTweet = Tweet { user     = "bitemyapp"+--                      , postDate = UTCTime+--                                   (ModifiedJulianDay 55000)+--                                   (secondsToDiffTime 10)+--                      , message  = "Use haskell!"+--                      , age      = 10000+--                      , location = Location 40.12 (-71.34) }+--instance ToJSON   Tweet+--instance FromJSON Tweet+--instance ToJSON   Location+--instance FromJSON Location+--data BulkTest = BulkTest { name :: Text } deriving (Eq, Generic, Show)+--instance FromJSON BulkTest+--instance ToJSON BulkTest+-- :} +-- | 'mkShardCount' is a straight-forward smart constructor for 'ShardCount'+--   which rejects 'Int' values below 1 and above 1000.+--+-- >>> mkShardCount 10+-- Just (ShardCount 10) mkShardCount :: Int -> Maybe ShardCount mkShardCount n   | n < 1 = Nothing-  | n > 1000 = Nothing -- seriously, what the fuck?+  | n > 1000 = Nothing   | otherwise = Just (ShardCount n) +-- | 'mkReplicaCount' is a straight-forward smart constructor for 'ReplicaCount'+--   which rejects 'Int' values below 1 and above 1000.+--+-- >>> mkReplicaCount 10+-- Just (ReplicaCount 10) mkReplicaCount :: Int -> Maybe ReplicaCount mkReplicaCount n   | n < 1 = Nothing@@ -90,36 +162,67 @@ -- http://hackage.haskell.org/package/http-client-lens-0.1.0/docs/Network-HTTP-Client-Lens.html -- https://github.com/supki/libjenkins/blob/master/src/Jenkins/Rest/Internal.hs +-- | 'getStatus' 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   return $ decode (responseBody response) +-- | 'createIndex' will create an index given a 'Server', 'IndexSettings', and an 'IndexName'.+--+-- >>> response <- createIndex testServer defaultIndexSettings (IndexName "didimakeanindex")+-- >>> respIsTwoHunna response+-- True+-- >>> indexExists testServer (IndexName "didimakeanindex")+-- True createIndex :: Server -> IndexSettings -> IndexName -> IO Reply createIndex (Server server) indexSettings (IndexName indexName) =   put url body   where url = joinPath [server, indexName]         body = Just $ encode indexSettings +-- | 'deleteIndex' will delete an index given a 'Server', and an 'IndexName'.+--+-- >>> response <- createIndex testServer defaultIndexSettings (IndexName "didimakeanindex")+-- >>> response <- deleteIndex testServer (IndexName "didimakeanindex")+-- >>> respIsTwoHunna response+-- True+-- >>> indexExists testServer testIndex+-- False deleteIndex :: Server -> IndexName -> IO Reply deleteIndex (Server server) (IndexName indexName) =   delete $ joinPath [server, indexName] +statusCodeIs :: Int -> Reply -> Bool+statusCodeIs n resp = NHTS.statusCode (responseStatus resp) == n+ respIsTwoHunna :: Reply -> Bool-respIsTwoHunna resp = NHTS.statusCode (responseStatus resp) == 200+respIsTwoHunna = statusCodeIs 200  existentialQuery :: String -> IO (Reply, Bool) existentialQuery url = do   reply <- head url   return (reply, respIsTwoHunna reply) +-- | '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   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@@ -136,15 +239,27 @@   where ociString = stringifyOCIndex oci         url = joinPath [server, indexName, ociString] +-- | '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 openIndex = openOrCloseIndexes OpenIndex +-- | '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 closeIndex = openOrCloseIndexes CloseIndex -{-| putMapping is an HTTP PUT and has upsert semantics. Mappings are schemas-    for documents in indexes.--}+-- | '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+-- >>> 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 =@@ -152,11 +267,27 @@   where url = joinPath [server, 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+-- >>> 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)   (MappingName mappingName) =   delete $ joinPath [server, 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")+-- >>> 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)@@ -165,17 +296,36 @@   where url = joinPath [server, 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)   (MappingName mappingName) (DocId docId) =   delete $ joinPath [server, indexName, mappingName, docId] +-- | 'bulk' uses Elasticsearch's bulk API at+--    http://www.elasticsearch.org/guide/en/elasticsearch/reference/current/docs-bulk.html+--    to perform bulk operations. The 'BulkOperation' data type encodes the+--    index/update/delete/create operations. You pass a 'V.Vector' of 'BulkOperation's+--    and a 'Server' to 'bulk' in order to send those operations up to your Elasticsearch+--    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 +-- | 'encodeBulkOperations' is a convenience function for dumping a vector of 'BulkOperation'+--   into an 'L.ByteString'+--+-- >>> let bulkOps = V.fromList [BulkIndex testIndex testMapping (DocId "2") (toJSON (BulkTest "blah"))]+-- >>> encodeBulkOperations bulkOps+-- "\n{\"index\":{\"_type\":\"tweet\",\"_id\":\"2\",\"_index\":\"twitter\"}}\n{\"name\":\"blah\"}\n" encodeBulkOperations :: V.Vector BulkOperation -> L.ByteString encodeBulkOperations stream = collapsed where   blobs = fmap encodeBulkOperation stream@@ -183,7 +333,7 @@   collapsed = toLazyByteString $ mappend mashedTaters (byteString "\n")  mash :: Builder -> V.Vector L.ByteString -> Builder-mash = V.foldl' (\b x -> b `mappend` "\n" `mappend` (lazyByteString x))+mash = V.foldl' (\b x -> b `mappend` (byteString "\n") `mappend` (lazyByteString x))  mkBulkStreamValue :: Text -> String -> String -> String -> Value mkBulkStreamValue operation indexName mappingName docId =@@ -192,6 +342,12 @@                  , "_type"  .= mappingName                  , "_id"    .= docId]] +-- | 'encodeBulkOperation' is a convenience function for dumping a single 'BulkOperation'+--   into an 'L.ByteString'+--+-- >>> let bulkOp = BulkIndex testIndex testMapping (DocId "2") (toJSON (BulkTest "blah"))+-- >>> encodeBulkOperation bulkOp+-- "{\"index\":{\"_type\":\"tweet\",\"_id\":\"2\",\"_index\":\"twitter\"}}\n{\"name\":\"blah\"}" encodeBulkOperation :: BulkOperation -> L.ByteString encodeBulkOperation (BulkIndex (IndexName indexName)                 (MappingName mappingName)@@ -218,13 +374,21 @@           doc = object ["doc" .= value]           blob = encode metadata `mappend` "\n" `mappend` encode doc -+-- | 'getDocument' is a straight-forward way to fetch a single document from+--   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)   (MappingName mappingName) (DocId docId) =   get $ joinPath [server, 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)@@ -236,27 +400,75 @@ dispatchSearch :: String -> Search -> IO Reply dispatchSearch url search = post url (Just (encode search)) +-- | 'searchAll', given a 'Search', will perform that search against all indexes+--   on an Elasticsearch server. Try to avoid doing this if it can be helped.+--+-- >>> 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"] +-- | '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"] +-- | '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"] +-- | 'mkSearch' is a helper function for defaulting additional fields of a 'Search'+--   to Nothing in case you only care about your 'Query' and 'Filter'. Use record update+--   syntax if you want to add things like aggregations or highlights while still using+--   this helper function.+--+-- >>> 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} mkSearch :: Maybe Query -> Maybe Filter -> Search mkSearch query filter = Search query filter Nothing Nothing Nothing False 0 10 +-- | 'mkAggregateSearch' is a helper function that defaults everything in a 'Search' except for+--   the 'Query' and the 'Aggregation'.+--+-- >>> let terms = TermsAgg $ (mkTermsAggregation "user") { termCollectMode = Just BreadthFirst }+-- >>> terms+-- 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 +-- | 'mkHighlightSearch' is a helper function that defaults everything in a 'Search' except for+--   the 'Query' and the 'Aggregation'.+--+-- >>> let query = QueryMatchQuery $ mkMatchQuery (FieldName "_all") (QueryString "haskell")+-- >>> 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 +-- | 'pageSearch' is a helper function that takes a search and assigns the page from and to+--   fields for the search.+--+-- >>> 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 }

@@ -1,14 +1,26 @@ {-# LANGUAGE DeriveGeneric   #-}+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} -{-| Data types for describing actions and data structures performed to interact-    with Elasticsearch. The two main buckets your queries against Elasticsearch-    will fall into are 'Query's and 'Filter's. 'Filter's are more like-    traditional database constraints and often have preferable performance-    properties. 'Query's support human-written textual queries, such as fuzzy-    queries.--}+-------------------------------------------------------------------------------+-- |+-- Module : Database.Bloodhound.Types+-- Copyright : (C) 2014 Chris Allen+-- License : BSD-style (see the file LICENSE)+-- Maintainer : Chris Allen <cma@bitemyapp.com+-- Stability : provisional+-- Portability : DeriveGeneric, RecordWildCards+--+-- Data types for describing actions and data structures performed to interact+-- with Elasticsearch. The two main buckets your queries against Elasticsearch+-- will fall into are 'Query's and 'Filter's. 'Filter's are more like+-- traditional database constraints and often have preferable performance+-- properties. 'Query's support human-written textual queries, such as fuzzy+-- queries.+------------------------------------------------------------------------------- ++ module Database.Bloodhound.Types        ( defaultCache        , defaultIndexSettings@@ -184,7 +196,7 @@ import           Data.Aeson.Types                (Pair, emptyObject, parseMaybe) import qualified Data.ByteString.Lazy.Char8      as L import           Data.List                       (nub)-import           Data.List.NonEmpty              (NonEmpty (..))+import           Data.List.NonEmpty              (NonEmpty(..), toList) import qualified Data.Map.Strict                 as M import           Data.Monoid import           Data.Text                       (Text)@@ -197,7 +209,17 @@  import           Database.Bloodhound.Types.Class +-- $setup+-- >>> :set -XOverloadedStrings+-- >>> import Database.Bloodhound+-- >>> let testServer = (Server "http://localhost:9200")+-- >>> let testIndex = IndexName "twitter"+-- >>> let testMapping = MappingName "tweet"+-- >>> let defaultIndexSettings = IndexSettings (ShardCount 3) (ReplicaCount 2) +-- defaultIndexSettings is exported by Database.Bloodhound as well+-- no trailing slashes in servers, library handles building the path.+ {-| 'Version' is embedded in 'Status' -} data Version = Version { number          :: Text                        , build_hash      :: Text@@ -576,7 +598,7 @@  data Query =   TermQuery                     Term (Maybe Boost)-  | TermsQuery                  [Term] MinimumMatch+  | TermsQuery                  (NonEmpty Term)   | QueryMatchQuery             MatchQuery   | QueryMultiMatchQuery        MultiMatchQuery   | QueryBoolQuery              BoolQuery@@ -1007,7 +1029,7 @@   DistanceRange { distanceFrom :: Distance                 , distanceTo   :: Distance } deriving (Eq, Show) -data (FromJSON a) => SearchResult a =+data SearchResult a =   SearchResult { took         :: Int                , timedOut     :: Bool                , shards       :: ShardResult@@ -1016,12 +1038,12 @@  type Score = Double -data (FromJSON a) => SearchHits a =+data SearchHits a =   SearchHits { hitsTotal :: Int              , maxScore  :: Score              , hits      :: [Hit a] } deriving (Eq, Show) -data (FromJSON a) => Hit a =+data Hit a =   Hit { hitIndex     :: IndexName       , hitType      :: MappingName       , hitDocId     :: DocId@@ -1186,7 +1208,7 @@   aggs :: a -> Maybe AggregationResults  -data (FromJSON a, BucketAggregation a) => Bucket a = Bucket { buckets :: [a]} deriving (Show)+data Bucket a = Bucket { buckets :: [a]} deriving (Show)  data TermsResult = TermsResult { termKey       :: Text                                , termsDocCount :: Int@@ -1358,12 +1380,12 @@       boosted = maybe [] (return . ("boost" .=)) boost       merged = mappend base boosted -  toJSON (TermsQuery terms termsQueryMinimumMatch) =+  toJSON (TermsQuery terms) =     object [ "terms" .= object conjoined ]-    where conjoined =-            [ "tags"                 .= fmap toJSON terms-            , "minimum_should_match" .= toJSON termsQueryMinimumMatch ]-+    where conjoined = [ getTermsField terms .=+                        fmap (toJSON . getTermValue) (toList terms)]+          getTermsField ((Term f _ ) :| _) = f+          getTermValue (Term _ v) = v   toJSON (IdsQuery idsQueryMappingName docIds) =     object [ "ids" .= object conjoined ]     where conjoined = [ "type"   .= toJSON idsQueryMappingName

@@ -0,0 +1,74 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ForeignFunctionInterface #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Main (doctests)+-- Copyright   :  (C) 2014 Chris Allen+-- License     :  BSD-style (see the file LICENSE)+-- Maintainer  :  Chris Allen <cma@bitemyapp.com>+-- Stability   :  provisional+-- Portability :  portable+--+-- This module provides doctests for a project based on the actual versions+-- of the packages it was built with. It requires a corresponding Setup.lhs+-- to be added to the project+-----------------------------------------------------------------------------++module Main where++import Build_doctests (deps)+import Control.Applicative+import Control.Monad+import Data.List+import System.Directory+import System.FilePath+import Test.DocTest++##if defined(mingw32_HOST_OS)+##if defined(i386_HOST_ARCH)+##define USE_CP+import Control.Applicative+import Control.Exception+import Foreign.C.Types+foreign import stdcall "windows.h SetConsoleCP" c_SetConsoleCP :: CUInt -> IO Bool+foreign import stdcall "windows.h GetConsoleCP" c_GetConsoleCP :: IO CUInt+##elif defined(x86_64_HOST_ARCH)+##define USE_CP+import Control.Applicative+import Control.Exception+import Foreign.C.Types+foreign import ccall "windows.h SetConsoleCP" c_SetConsoleCP :: CUInt -> IO Bool+foreign import ccall "windows.h GetConsoleCP" c_GetConsoleCP :: IO CUInt+##endif+##endif++-- | Run in a modified codepage where we can print UTF-8 values on Windows.+withUnicode :: IO a -> IO a+##ifdef USE_CP+withUnicode m = do+  cp <- c_GetConsoleCP+  (c_SetConsoleCP 65001 >> m) `finally` c_SetConsoleCP cp+##else+withUnicode m = m+##endif++main :: IO ()+main = withUnicode $ getSources >>= \sources -> doctest $+    "-isrc"+  : "-idist/build/autogen"+  : "-optP-include"+  : "-optPdist/build/autogen/cabal_macros.h"+  : "-hide-all-packages"+  : map ("-package="++) deps ++ sources++getSources :: IO [FilePath]+getSources = filter (isSuffixOf ".hs") <$> go "src"+  where+    go dir = do+      (dirs, files) <- getFilesAndDirectories dir+      (files ++) . concat <$> mapM go dirs++getFilesAndDirectories :: FilePath -> IO ([FilePath], [FilePath])+getFilesAndDirectories dir = do+  c <- map (dir </>) . filter (`notElem` ["..", "."]) <$> getDirectoryContents dir+  (,) <$> filterM doesDirectoryExist c <*> filterM doesFileExist c

@@ -1,4 +1,5 @@ {-# LANGUAGE DeriveGeneric       #-}+{-# LANGUAGE OverloadedStrings   #-} {-# LANGUAGE ScopedTypeVariables #-}  module Main where@@ -6,9 +7,10 @@ import           Control.Applicative import           Control.Monad import           Data.Aeson-import           Data.HashMap.Strict       (fromList)+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@@ -268,6 +270,14 @@       myTweet <- searchTweet search       myTweet `shouldBe` Right exampleTweet +    it "returns document for terms query and identity filter" $ 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+     it "returns document for match query" $ do       _ <- insertData       let query = QueryMatchQuery $ mkMatchQuery (FieldName "user") (QueryString "bitemyapp")@@ -499,9 +509,9 @@       _ <- insertData       _ <- insertOther       let query = QueryMatchQuery $ mkMatchQuery (FieldName "_all") (QueryString "haskell")-      let highlight = Highlights Nothing [FieldHighlight (FieldName "message") Nothing]+      let testHighlight = Highlights Nothing [FieldHighlight (FieldName "message") Nothing] -      let search = mkHighlightSearch (Just query) highlight+      let search = mkHighlightSearch (Just query) testHighlight       myHighlight <- searchTweetHighlight search       myHighlight `shouldBe` Right (Just (M.fromList [("message",["Use <em>haskell</em>!"])])) @@ -509,9 +519,9 @@       _ <- insertData       _ <- insertOther       let query = QueryMatchQuery $ mkMatchQuery (FieldName "_all") (QueryString "haskell")-      let highlight = Highlights Nothing [FieldHighlight (FieldName "user") Nothing]+      let testHighlight = Highlights Nothing [FieldHighlight (FieldName "user") Nothing] -      let search = mkHighlightSearch (Just query) highlight+      let search = mkHighlightSearch (Just query) testHighlight       myHighlight <- searchTweetHighlight search       myHighlight `shouldBe` Right Nothing @@ -541,19 +551,19 @@     it "checks that omitNulls drops list elements when it should" $        let dropped = omitNulls $ [ "test1" .= (toJSON ([] :: [Int]))                                  , "test2" .= (toJSON ("some value" :: Text))]-       in dropped `shouldBe` Object (fromList [("test2", String "some value")])+       in dropped `shouldBe` Object (HM.fromList [("test2", String "some value")])      it "checks that omitNulls doesn't drop list elements when it shouldn't" $        let notDropped = omitNulls $ [ "test1" .= (toJSON ([1] :: [Int]))                                     , "test2" .= (toJSON ("some value" :: Text))]-       in notDropped `shouldBe` Object (fromList [ ("test1", Array (V.fromList [Number 1.0]))+       in notDropped `shouldBe` Object (HM.fromList [ ("test1", Array (V.fromList [Number 1.0]))                                                  , ("test2", String "some value")])     it "checks that omitNulls drops non list elements when it should" $        let dropped = omitNulls $ [ "test1" .= (toJSON Null)                                  , "test2" .= (toJSON ("some value" :: Text))]-       in dropped `shouldBe` Object (fromList [("test2", String "some value")])+       in dropped `shouldBe` Object (HM.fromList [("test2", String "some value")])     it "checks that omitNulls doesn't drop non list elements when it shouldn't" $        let notDropped = omitNulls $ [ "test1" .= (toJSON (1 :: Int))                                     , "test2" .= (toJSON ("some value" :: Text))]-       in notDropped `shouldBe` Object (fromList [ ("test1", Number 1.0)+       in notDropped `shouldBe` Object (HM.fromList [ ("test1", Number 1.0)                                                  , ("test2", String "some value")])