git.iko.soy/typeable/bloodhound
on master help sign in
Merge branch 'master' of github.com:bitemyapp/bloodhound
commit6a04d9dea580827d6ba4d444ff3fc558316268d5 authorChris Allen <cma@bitemyapp.com> dateMon 10 Nov 2014, 12:25 (12 years ago) parentc425c566e65116
8 files changed+613−74
compare with master
unifiedsplit
.travis.yml+6−5 Database/Bloodhound/Client.hs+37−29 Database/Bloodhound/Types.hs+238−16 LICENSE+8−17 README.org+194−1 bloodhound.cabal+3−1 changelog.md+5−2 tests/tests.hs+122−3
.travis.yml+6−5
@@ -7,11 +7,12 @@
77# release of a major GHC version. Setting HPVER implictly sets
88# GHCVER. Omit lines with versions you don't need/want testing for.
99env:
10− - GHCVER=7.6.3 ESVER=1.3.2
11− - GHCVER=7.8.2 ESVER=1.0.3
12− - GHCVER=7.8.2 ESVER=1.1.2
13− - GHCVER=7.8.2 ESVER=1.2.3
14− - GHCVER=7.8.2 ESVER=1.3.2
10+ - GHCVER=7.6.3 ESVER=1.4.0
11+ - GHCVER=7.8.3 ESVER=1.0.3
12+ - GHCVER=7.8.3 ESVER=1.1.2
13+ - GHCVER=7.8.3 ESVER=1.2.3
14+ - GHCVER=7.8.3 ESVER=1.3.2
15+ - GHCVER=7.8.3 ESVER=1.4.0
1516
1617# services:
1718# - elasticsearch
Database/Bloodhound/Client.hs+37−29
@@ -15,20 +15,24 @@ module Database.Bloodhound.Client
1515 , searchByType
1616 , refreshIndex
1717 , mkSearch
18+ , mkAggregateSearch
1819 , bulk
1920 , pageSearch
2021 , mkShardCount
2122 , mkReplicaCount
2223 , getStatus
24+ , encodeBulkOperations
25+ , encodeBulkOperation
2326 )
2427 where
2528
2629import Data.Aeson
2730import qualified Data.ByteString.Lazy.Char8 as L
2831import Data.ByteString.Builder
29−import Data.List (foldl', intercalate, intersperse)
32+import Data.List (intercalate)
3033import Data.Maybe (fromMaybe)
3134import Data.Text (Text)
35+import qualified Data.Vector as V
3236import Network.HTTP.Client
3337import qualified Network.HTTP.Types.Method as NHTM
3438import qualified Network.HTTP.Types.Status as NHTS
@@ -166,52 +170,53 @@ deleteDocument (Server server) (IndexName indexName)
166170 (MappingName mappingName) (DocId docId) =
167171 delete $ joinPath [server, indexName, mappingName, docId]
168172
169−bulk :: Server -> [BulkOperation] -> IO Reply
173+bulk :: Server -> V.Vector BulkOperation -> IO Reply
170174bulk (Server server) bulkOps = post url body where
171175 url = joinPath [server, "_bulk"]
172− body = Just $ collapseStream bulkOps
176+ body = Just $ encodeBulkOperations bulkOps
173177
174−collapseStream :: [BulkOperation] -> L.ByteString
175−collapseStream stream = collapsed where
176− blobs = intersperse "\n" $ concat $ fmap getStreamChunk stream
178+encodeBulkOperations :: V.Vector BulkOperation -> L.ByteString
179+encodeBulkOperations stream = collapsed where
180+ blobs = fmap encodeBulkOperation stream
177181 mashedTaters = mash (mempty :: Builder) blobs
178182 collapsed = toLazyByteString $ mappend mashedTaters (byteString "\n")
179183
180−mash :: Builder -> [L.ByteString] -> Builder
181−mash = foldl' (\b x -> mappend b (lazyByteString x))
184+mash :: Builder -> V.Vector L.ByteString -> Builder
185+mash = V.foldl' (\b x -> b `mappend` "\n" `mappend` (lazyByteString x))
182186
183−mkMetadataValue :: Text -> String -> String -> String -> Value
184−mkMetadataValue operation indexName mappingName docId =
187+mkBulkStreamValue :: Text -> String -> String -> String -> Value
188+mkBulkStreamValue operation indexName mappingName docId =
185189 object [operation .=
186190 object [ "_index" .= indexName
187191 , "_type" .= mappingName
188192 , "_id" .= docId]]
189193
190−getStreamChunk :: BulkOperation -> [L.ByteString]
191−getStreamChunk (BulkIndex (IndexName indexName)
194+encodeBulkOperation :: BulkOperation -> L.ByteString
195+encodeBulkOperation (BulkIndex (IndexName indexName)
192196 (MappingName mappingName)
193− (DocId docId) value) = blob where
194− metadata = mkMetadataValue "index" indexName mappingName docId
195− blob = [encode metadata, encode value]
197+ (DocId docId) value) = blob
198+ where metadata = mkBulkStreamValue "index" indexName mappingName docId
199+ blob = encode metadata `mappend` "\n" `mappend` encode value
196200
197−getStreamChunk (BulkCreate (IndexName indexName)
201+encodeBulkOperation (BulkCreate (IndexName indexName)
198202 (MappingName mappingName)
199− (DocId docId) value) = blob where
200− metadata = mkMetadataValue "create" indexName mappingName docId
201− blob = [encode metadata, encode value]
203+ (DocId docId) value) = blob
204+ where metadata = mkBulkStreamValue "create" indexName mappingName docId
205+ blob = encode metadata `mappend` "\n" `mappend` encode value
202206
203−getStreamChunk (BulkDelete (IndexName indexName)
207+encodeBulkOperation (BulkDelete (IndexName indexName)
204208 (MappingName mappingName)
205− (DocId docId)) = blob where
206− metadata = mkMetadataValue "delete" indexName mappingName docId
207− blob = [encode metadata]
209+ (DocId docId)) = blob
210+ where metadata = mkBulkStreamValue "delete" indexName mappingName docId
211+ blob = encode metadata
208212
209−getStreamChunk (BulkUpdate (IndexName indexName)
213+encodeBulkOperation (BulkUpdate (IndexName indexName)
210214 (MappingName mappingName)
211− (DocId docId) value) = blob where
212− metadata = mkMetadataValue "update" indexName mappingName docId
213− doc = object ["doc" .= value]
214− blob = [encode metadata, encode doc]
215+ (DocId docId) value) = blob
216+ where metadata = mkBulkStreamValue "update" indexName mappingName docId
217+ doc = object ["doc" .= value]
218+ blob = encode metadata `mappend` "\n" `mappend` encode doc
219+
215220
216221getDocument :: Server -> IndexName -> MappingName
217222 -> DocId -> IO Reply
@@ -244,7 +249,10 @@ searchByType (Server server) (IndexName indexName)
244249 url = joinPath [server, indexName, mappingName, "_search"]
245250
246251mkSearch :: Maybe Query -> Maybe Filter -> Search
247−mkSearch query filter = Search query filter Nothing False 0 10
252+mkSearch query filter = Search query filter Nothing Nothing False 0 10
253+
254+mkAggregateSearch :: Maybe Query -> Aggregations -> Search
255+mkAggregateSearch query mkSearchAggs = Search query Nothing Nothing (Just mkSearchAggs) False 0 0
248256
249257pageSearch :: Int -> Int -> Search -> Search
250258pageSearch pageFrom pageSize search = search { from = pageFrom, size = pageSize }
Database/Bloodhound/Types.hs+238−16
@@ -22,6 +22,12 @@ module Database.Bloodhound.Types
2222 , mkBoolQuery
2323 , mkRangeQuery
2424 , mkQueryStringQuery
25+ , mkAggregations
26+ , mkTermsAggregation
27+ , mkTermsScriptAggregation
28+ , mkDateHistogram
29+ , toTerms
30+ , toDateHistogram
2531 , omitNulls
2632 , Version(..)
2733 , Status(..)
@@ -143,16 +149,33 @@ module Database.Bloodhound.Types
143149 , FieldOrFields(..)
144150 , Monoid(..)
145151 , ToJSON(..)
152+ , Interval(..)
153+ , TimeInterval(..)
154+ , ExecutionHint(..)
155+ , CollectionMode(..)
156+ , TermOrder(..)
157+ , TermInclusion(..)
158+ , Aggregation(..)
159+ , Aggregations
160+ , AggregationResults
161+ , Bucket(..)
162+ , BucketAggregation(..)
163+ , TermsAggregation(..)
164+ , DateHistogramAggregation(..)
165+ , TermsResult(..)
166+ , DateHistogramResult(..)
146167 ) where
147168
148169import Control.Applicative
149170import Data.Aeson
171+import Data.Aeson.Types (parseMaybe)
150172import qualified Data.ByteString.Lazy.Char8 as L
151173import Data.List (nub)
152174import Data.List.NonEmpty (NonEmpty (..))
153175import Data.Monoid
154176import Data.Text (Text)
155177import qualified Data.Text as T
178+import qualified Data.Map.Strict as M
156179import Data.Time.Clock (UTCTime)
157180import qualified Data.Vector as V
158181import GHC.Generics (Generic)
@@ -473,9 +496,10 @@ type TrackSortScores = Bool
473496type From = Int
474497type Size = Int
475498
476−data Search = Search { queryBody :: Maybe Query
477− , filterBody :: Maybe Filter
478− , sortBody :: Maybe Sort
499+data Search = Search { queryBody :: Maybe Query
500+ , filterBody :: Maybe Filter
501+ , sortBody :: Maybe Sort
502+ , aggBody :: Maybe Aggregations
479503 -- default False
480504 , trackSortScores :: TrackSortScores
481505 , from :: From
@@ -915,10 +939,11 @@ data DistanceRange =
915939 , distanceTo :: Distance } deriving (Eq, Show)
916940
917941data FromJSON a => SearchResult a =
918− SearchResult { took :: Int
919− , timedOut :: Bool
920− , shards :: ShardResult
921− , searchHits :: SearchHits a } deriving (Eq, Show)
942+ SearchResult { took :: Int
943+ , timedOut :: Bool
944+ , shards :: ShardResult
945+ , searchHits :: SearchHits a
946+ , aggregations :: Maybe AggregationResults } deriving (Eq, Show)
922947
923948type Score = Double
924949
@@ -942,6 +967,201 @@ data ShardResult =
942967showText :: Show a => a -> Text
943968showText = T.pack . show
944969
970+type Aggregations = M.Map Text Aggregation
971+
972+emptyAggregations :: Aggregations
973+emptyAggregations = M.empty
974+
975+mkAggregations :: Text -> Aggregation -> Aggregations
976+mkAggregations name aggregation = M.insert name aggregation emptyAggregations
977+
978+data TermOrder = TermOrder{ termSortField :: Text
979+ , termSortOrder :: SortOrder } deriving (Eq, Show)
980+
981+data TermInclusion = TermInclusion Text
982+ | TermPattern Text Text deriving (Eq, Show)
983+
984+data CollectionMode = BreadthFirst
985+ | DepthFirst deriving (Eq, Show)
986+
987+data ExecutionHint = Ordinals
988+ | GlobalOrdinals
989+ | GlobalOrdinalsHash
990+ | GlobalOrdinalsLowCardinality
991+ | Map deriving (Eq, Show)
992+
993+data TimeInterval = Weeks
994+ | Days
995+ | Hours
996+ | Minutes
997+ | Seconds deriving (Eq)
998+
999+data Interval = Year
1000+ | Quarter
1001+ | Month
1002+ | Week
1003+ | Day
1004+ | Hour
1005+ | Minute
1006+ | Second
1007+ | FractionalInterval Float TimeInterval deriving (Eq, Show)
1008+
1009+data Aggregation = TermsAgg TermsAggregation
1010+ | DateHistogramAgg DateHistogramAggregation deriving (Eq, Show)
1011+
1012+
1013+data TermsAggregation = TermsAggregation { term :: Either Text Text
1014+ , termInclude :: Maybe TermInclusion
1015+ , termExclude :: Maybe TermInclusion
1016+ , termOrder :: Maybe TermOrder
1017+ , termMinDocCount :: Maybe Int
1018+ , termSize :: Maybe Int
1019+ , termShardSize :: Maybe Int
1020+ , termCollectMode :: Maybe CollectionMode
1021+ , termExecutionHint :: Maybe ExecutionHint
1022+ , termAggs :: Maybe Aggregations
1023+ } deriving (Eq, Show)
1024+
1025+data DateHistogramAggregation = DateHistogramAggregation { dateField :: FieldName
1026+ , dateInterval :: Interval
1027+ , dateFormat :: Maybe Text
1028+ , datePreZone :: Maybe Text
1029+ , datePostZone :: Maybe Text
1030+ , datePreOffset :: Maybe Text
1031+ , datePostOffset :: Maybe Text
1032+ , dateAggs :: Maybe Aggregations
1033+ } deriving (Eq, Show)
1034+
1035+
1036+mkTermsAggregation :: Text -> TermsAggregation
1037+mkTermsAggregation t = TermsAggregation (Left t) Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing
1038+
1039+mkTermsScriptAggregation :: Text -> TermsAggregation
1040+mkTermsScriptAggregation t = TermsAggregation (Right t) Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing
1041+
1042+mkDateHistogram :: FieldName -> Interval -> DateHistogramAggregation
1043+mkDateHistogram t i = DateHistogramAggregation t i Nothing Nothing Nothing Nothing Nothing Nothing
1044+
1045+instance ToJSON TermOrder where
1046+ toJSON (TermOrder termSortField termSortOrder) = object [termSortField .= termSortOrder]
1047+
1048+instance ToJSON TermInclusion where
1049+ toJSON (TermInclusion x) = toJSON x
1050+ toJSON (TermPattern pattern flags) = omitNulls [ "pattern" .= pattern,
1051+ "flags" .= flags]
1052+
1053+instance ToJSON CollectionMode where
1054+ toJSON BreadthFirst = "breadth_first"
1055+ toJSON DepthFirst = "depth_first"
1056+
1057+instance ToJSON ExecutionHint where
1058+ toJSON Ordinals = "ordinals"
1059+ toJSON GlobalOrdinals = "global_ordinals"
1060+ toJSON GlobalOrdinalsHash = "global_ordinals_hash"
1061+ toJSON GlobalOrdinalsLowCardinality = "global_ordinals_low_cardinality"
1062+ toJSON Map = "map"
1063+
1064+instance ToJSON Interval where
1065+ toJSON Year = "year"
1066+ toJSON Quarter = "quarter"
1067+ toJSON Month = "month"
1068+ toJSON Week = "week"
1069+ toJSON Day = "day"
1070+ toJSON Hour = "hour"
1071+ toJSON Minute = "minute"
1072+ toJSON Second = "second"
1073+ toJSON (FractionalInterval fraction interval) = toJSON $ show fraction ++ show interval
1074+
1075+instance Show TimeInterval where
1076+ show Weeks = "w"
1077+ show Days = "d"
1078+ show Hours = "h"
1079+ show Minutes = "m"
1080+ show Seconds = "s"
1081+
1082+instance ToJSON Aggregation where
1083+ toJSON (TermsAgg (TermsAggregation term include exclude order minDocCount size shardSize collectMode executionHint termAggs)) =
1084+ omitNulls ["terms" .= omitNulls [ toJSON' term,
1085+ "include" .= toJSON include,
1086+ "exclude" .= toJSON exclude,
1087+ "order" .= toJSON order,
1088+ "min_doc_count" .= toJSON minDocCount,
1089+ "size" .= toJSON size,
1090+ "shard_size" .= toJSON shardSize,
1091+ "collect_mode" .= toJSON collectMode,
1092+ "execution_hint" .= toJSON executionHint
1093+ ],
1094+ "aggs" .= toJSON termAggs ]
1095+ where
1096+ toJSON' x = case x of { Left y -> "field" .= toJSON y; Right y -> "script" .= toJSON y }
1097+
1098+ toJSON (DateHistogramAgg (DateHistogramAggregation field interval format preZone postZone preOffset postOffset dateHistoAggs)) =
1099+ omitNulls ["date_histogram" .= omitNulls [ "field" .= toJSON field,
1100+ "interval" .= toJSON interval,
1101+ "format" .= toJSON format,
1102+ "pre_zone" .= toJSON preZone,
1103+ "post_zone" .= toJSON postZone,
1104+ "pre_offset" .= toJSON preOffset,
1105+ "post_offset" .= toJSON postOffset
1106+ ],
1107+ "aggs" .= toJSON dateHistoAggs ]
1108+
1109+type AggregationResults = M.Map Text Value
1110+
1111+class BucketAggregation a where
1112+ key :: a -> Text
1113+ docCount :: a -> Int
1114+ aggs :: a -> Maybe AggregationResults
1115+
1116+
1117+data (FromJSON a, BucketAggregation a) => Bucket a = Bucket { buckets :: [a]} deriving (Show)
1118+
1119+data TermsResult = TermsResult { termKey :: Text
1120+ , termsDocCount :: Int
1121+ , termsAggs :: Maybe AggregationResults } deriving (Show)
1122+
1123+data DateHistogramResult = DateHistogramResult { dateKey :: Int
1124+ , dateKeyStr :: Maybe Text
1125+ , dateDocCount :: Int
1126+ , dateHistogramAggs :: Maybe AggregationResults } deriving (Show)
1127+
1128+toTerms :: Text -> AggregationResults -> Maybe (Bucket TermsResult)
1129+toTerms t a = M.lookup t a >>= deserialize
1130+ where deserialize = parseMaybe parseJSON
1131+
1132+toDateHistogram :: Text -> AggregationResults -> Maybe (Bucket DateHistogramResult)
1133+toDateHistogram t a = M.lookup t a >>= deserialize
1134+ where deserialize = parseMaybe parseJSON
1135+
1136+instance BucketAggregation TermsResult where
1137+ key = termKey
1138+ docCount = termsDocCount
1139+ aggs = termsAggs
1140+
1141+instance BucketAggregation DateHistogramResult where
1142+ key = showText . dateKey
1143+ docCount = dateDocCount
1144+ aggs = dateHistogramAggs
1145+
1146+instance (FromJSON a, BucketAggregation a) => FromJSON (Bucket a) where
1147+ parseJSON (Object v) = Bucket <$>
1148+ v .: "buckets"
1149+ parseJSON _ = mempty
1150+
1151+instance FromJSON TermsResult where
1152+ parseJSON (Object v) = TermsResult <$>
1153+ v .: "key" <*>
1154+ v .: "doc_count" <*>
1155+ v .:? "aggregations"
1156+ parseJSON _ = mempty
1157+
1158+instance FromJSON DateHistogramResult where
1159+ parseJSON (Object v) = DateHistogramResult <$>
1160+ v .: "key" <*>
1161+ v .:? "key_as_string" <*>
1162+ v .: "doc_count" <*>
1163+ v .:? "aggregations"
1164+ parseJSON _ = mempty
9451165
9461166instance Monoid Filter where
9471167 mempty = IdentityFilter
@@ -1026,11 +1246,11 @@ instance ToJSON Filter where
10261246 toJSON (RangeFilter (FieldName fieldName) (Left halfRange) rangeExecution cache) =
10271247 object ["range" .=
10281248 object [fieldName .=
1029− object [key .= val]
1249+ object [rqFKey .= rqFVal]
10301250 , "execution" .= toJSON rangeExecution
10311251 , "_cache" .= cache]]
10321252 where
1033− (key, val) = halfRangeToKV halfRange
1253+ (rqFKey, rqFVal) = halfRangeToKV halfRange
10341254
10351255 toJSON (RangeFilter (FieldName fieldName) (Right range) rangeExecution cache) =
10361256 object ["range" .=
@@ -1244,8 +1464,8 @@ instance ToJSON RangeQuery where
12441464 toJSON (RangeQuery (FieldName fieldName) (Left halfRange) boost) =
12451465 object [ fieldName .= conjoined ]
12461466 where conjoined = [ "boost" .= toJSON boost
1247− , key .= val ]
1248− (key, val) = halfRangeToKV halfRange
1467+ , rqKey .= rqVal ]
1468+ (rqKey, rqVal) = halfRangeToKV halfRange
12491469
12501470
12511471instance ToJSON PrefixQuery where
@@ -1536,10 +1756,11 @@ instance (FromJSON a) => FromJSON (EsResult a) where
15361756
15371757
15381758instance ToJSON Search where
1539− toJSON (Search query sFilter sort sTrackSortScores sFrom sSize) =
1759+ toJSON (Search query sFilter sort searchAggs sTrackSortScores sFrom sSize) =
15401760 omitNulls [ "query" .= query
15411761 , "filter" .= sFilter
15421762 , "sort" .= sort
1763+ , "aggregations" .= searchAggs
15431764 , "from" .= sFrom
15441765 , "size" .= sSize
15451766 , "track_scores" .= sTrackSortScores ]
@@ -1677,10 +1898,11 @@ instance ToJSON BoolMatch where
16771898
16781899instance (FromJSON a) => FromJSON (SearchResult a) where
16791900 parseJSON (Object v) = SearchResult <$>
1680− v .: "took" <*>
1681− v .: "timed_out" <*>
1682− v .: "_shards" <*>
1683− v .: "hits"
1901+ v .: "took" <*>
1902+ v .: "timed_out" <*>
1903+ v .: "_shards" <*>
1904+ v .: "hits" <*>
1905+ v .:? "aggregations"
16841906 parseJSON _ = empty
16851907
16861908instance (FromJSON a) => FromJSON (SearchHits a) where
LICENSE+8−17
@@ -1,21 +1,12 @@
1−The MIT License (MIT)
1+Copyright (c) 2014, Chris Allen
2+All rights reserved.
23
3−Copyright (c) <2014> <Chris Allen>
4+Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:
45
5−Permission is hereby granted, free of charge, to any person obtaining a copy
6−of this software and associated documentation files (the "Software"), to deal
7−in the Software without restriction, including without limitation the rights
8−to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
9−copies of the Software, and to permit persons to whom the Software is
10−furnished to do so, subject to the following conditions:
6+1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer.
117
12−The above copyright notice and this permission notice shall be included in
13−all copies or substantial portions of the Software.
8+2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution.
149
15−THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
16−IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
17−FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
18−AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
19−LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
20−OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
21−THE SOFTWARE.
10+3. Neither the name of the copyright holder nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission.
11+
12+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
README.org+194−1
@@ -48,6 +48,7 @@ http://hackage.haskell.org/package/bloodhound
4848-- the multi-line examples into your ghci REPL.
4949
5050:set -XDeriveGeneric
51+:{
5152import Database.Bloodhound
5253import Data.Aeson
5354import Data.Either (Either(..))
@@ -71,6 +72,7 @@ let defaultIndexSettings = IndexSettings (ShardCount 3) (ReplicaCount 2)
7172
7273-- response :: Reply, Reply is a synonym for Network.HTTP.Conduit.Response
7374response <- createIndex testServer defaultIndexSettings testIndex
75+:}
7476
7577#+END_SRC
7678
@@ -284,7 +286,7 @@ Right (Tweet {user = "bitemyapp"
284286
285287*** Bulk create, index
286288
287−#+BEGIN_SRC haskell
289+#+BEGIN_SRC haskell
288290
289291-- don't forget the imports and derive generic setting for ghci
290292-- at the beginning of the examples.
@@ -321,6 +323,40 @@ resp <- bulk testServer stream
321323
322324#+END_SRC
323325
326+*** Encoding individual bulk API operations
327+
328+#+BEGIN_SRC haskell
329+-- the following functions are exported in Bloodhound so
330+-- you can build up bulk operations yourself
331+encodeBulkOperations :: V.Vector BulkOperation -> L.ByteString
332+encodeBulkOperation :: BulkOperation -> L.ByteString
333+
334+-- How to use the above:
335+data BulkTest = BulkTest { name :: Text } deriving (Eq, Generic, Show)
336+instance FromJSON BulkTest
337+instance ToJSON BulkTest
338+
339+_ <- insertData
340+let firstTest = BulkTest "blah"
341+let secondTest = BulkTest "bloo"
342+let firstDoc = BulkIndex testIndex
343+ testMapping (DocId "2") (toJSON firstTest)
344+let secondDoc = BulkCreate testIndex
345+ testMapping (DocId "3") (toJSON secondTest)
346+let stream = V.fromList [firstDoc, secondDoc] :: V.Vector BulkOperation
347+
348+-- to encode yourself
349+let firstDocEncoded = encode firstDoc :: L.ByteString
350+
351+-- to encode a vector of bulk operations
352+let encodedOperations = encodeBulkOperations stream
353+
354+-- to insert into a particular server
355+-- bulk :: Server -> V.Vector BulkOperation -> IO Reply
356+_ <- bulk testServer stream
357+
358+#+END_SRC
359+
324360** Search
325361
326362*** Querying
@@ -643,6 +679,163 @@ let filter = RegexpFilter (FieldName "user") (Regexp "bite.*app")
643679
644680#+END_SRC
645681
682+*** Aggregations
683+**** Adding aggregations to search
684+Aggregations can now be added to search queries, or made on their own.
685+#+BEGIN_SRC haskell
686+type Aggregations = M.Map Text Aggregation
687+data Aggregation
688+ = TermsAgg TermsAggregation
689+ | DateHistogramAgg DateHistogramAggregation
690+#+END_SRC
691+
692+For convenience, ```mkAggregations``` exists, that will create an
693+```Aggregations``` with the aggregation provided.
694+
695+For example:
696+#+BEGIN_SRC haskell
697+ let a = mkAggregations "users" $ TermsAgg $ mkTermsAggregation "user"
698+ let search = mkAggregateSearch Nothing a
699+#+END_SRC
700+
701+Aggregations can be added to an existing search, using the
702+```aggBody``` field
703+
704+#+BEGIN_SRC haskell
705+ let search = mkSearch (Just (MatchAllQuery Nothing)) Nothing
706+ let search' = search {aggBody = Just a}
707+#+END_SRC
708+
709+Since the ```Aggregations``` structure is just a Map Text
710+Aggregation, M.insert can be used to add additional aggregations.
711+
712+#+BEGIN_SRC haskell
713+ let a' = M.insert "age" (TermsAgg $ mkTermsAggregation "age") a
714+#+END_SRC
715+
716+**** Extracting aggregations from results
717+Aggregations are part of the reply structure of every search, in the
718+form of ~Maybe AggregationResults~
719+
720+#+BEGIN_SRC haskell
721+-- Lift decode and response body to be in the IO monad.
722+let decode' = liftM decode
723+let responseBody' = liftM responseBody
724+let reply = searchByIndex testServer testIndex search
725+let response = decode' $ responseBody' reply :: IO (Maybe (SearchResult Tweet))
726+
727+-- Now that we have our response, we can extract our terms aggregation result -- which is a list of buckets.
728+
729+let terms = do { response' <- response; return $ response' >>= aggregations >>= toTerms "users" }
730+terms
731+Just (Bucket {buckets = [TermsResult {termKey = "bitemyapp", termsDocCount = 1, termsAggs = Nothing}]})
732+#+END_SRC
733+
734+Note that bucket aggregation results, such as the TermsResult is a
735+member of the type class ~BucketAggregation~:
736+
737+#+BEGIN_SRC haskell
738+class BucketAggregation a where
739+ key :: a -> Text
740+ docCount :: a -> Int
741+ aggs :: a -> Maybe AggregationResults
742+#+END_SRC haskell
743+
744+You can use the ~aggs~ function to get any nested results, if
745+there were any. For example, if there were a nested terms
746+aggregation keyed to "age" in a TermsResult named ~termresult~, you would call ~aggs termresult >>=
747+toTerms "age"~
748+
749+**** Terms Aggregation
750+#+BEGIN_SRC haskell
751+data TermsAggregation
752+ = TermsAggregation {term :: Either Text Text,
753+ termInclude :: Maybe TermInclusion,
754+ termExclude :: Maybe TermInclusion,
755+ termOrder :: Maybe TermOrder,
756+ termMinDocCount :: Maybe Int,
757+ termSize :: Maybe Int,
758+ termShardSize :: Maybe Int,
759+ termCollectMode :: Maybe CollectionMode,
760+ termExecutionHint :: Maybe ExecutionHint,
761+ termAggs :: Maybe Aggregations}
762+#+END_SRC
763+
764+Term Aggregations have two factory functions,
765+~mkTermsAggregation~, and ~mkTermsScriptAggregation~, and can
766+be used as follows:
767+
768+#+BEGIN_SRC haskell
769+let ta = TermsAgg $ mkTermsAggregation "user"
770+#+END_SRC
771+
772+There are of course other options that can be added to a Terms
773+Aggregation, such as the collection mode:
774+#+BEGIN_SRC haskell
775+let ta = mkTermsAggregation "user"
776+let ta' = ta { termCollectMode = Just BreadthFirst }
777+let ta'' = TermsAgg ta'
778+#+END_SRC
779+
780+For more documentation on how the Terms Aggregation works, see
781+http://www.elasticsearch.org/guide/en/elasticsearch/reference/current/search-aggregations-bucket-terms-aggregation.html
782+
783+**** Date Histogram Aggregation
784+
785+#+BEGIN_SRC haskell
786+data DateHistogramAggregation
787+ = DateHistogramAggregation {dateField :: FieldName,
788+ dateInterval :: Interval,
789+ dateFormat :: Maybe Text,
790+ datePreZone :: Maybe Text,
791+ datePostZone :: Maybe Text,
792+ datePreOffset :: Maybe Text,
793+ datePostOffset :: Maybe Text,
794+ dateAggs :: Maybe Aggregations}
795+#+END_SRC haskell
796+
797+The Date Histogram Aggregation works much the same as the Terms
798+Aggregation.
799+
800+Relevant functions include ~mkDateHistogram~, and ~toDateHistogram~
801+
802+#+BEGIN_SRC haskell
803+let dh = DateHistogramAgg (mkDateHistogram (FieldName "postDate") Minute)
804+#+END_SRC
805+
806+Date histograms also accept a ~FractionalInterval~:
807+
808+#+BEGIN_SRC haskell
809+FractionalInterval :: Float -> TimeInterval -> Interval
810+-- TimeInterval is the following:
811+data TimeInterval = Weeks | Days | Hours | Minutes | Seconds
812+#+END_SRC
813+
814+It can be used as follows:
815+
816+#+BEGIN_SRC haskell
817+let dh = DateHistogramAgg (mkDateHistogram (FieldName "postDate") (FractionalInterval 1.5 Minutes))
818+#+END_SRC
819+
820+The ~DateHistogramResult~ is defined as:
821+
822+#+BEGIN_SRC haskell
823+data DateHistogramResult
824+ = DateHistogramResult {dateKey :: Int,
825+ dateKeyStr :: Maybe Text,
826+ dateDocCount :: Int,
827+ dateHistogramAggs :: Maybe AggregationResults}
828+#+END_SRC
829+
830+It is an instance of ~BucketAggregation~, and can have nested
831+aggregations in each bucket.
832+
833+Buckets can be extracted from a ~AggregationResult~ using
834+~toDateHistogram name~
835+
836+For more information on the Date Histogram Aggregation, see:
837+http://www.elasticsearch.org/guide/en/elasticsearch/reference/current/search-aggregations-bucket-datehistogram-aggregation.html
838+
646839* Possible future functionality
647840
648841** Span Queries
bloodhound.cabal+3−1
@@ -3,7 +3,7 @@ version: 0.4.0.0
33synopsis: ElasticSearch client library for Haskell
44description: ElasticSearch made awesome for Haskell hackers
55homepage: https://github.com/bitemyapp/bloodhound
6−license: MIT
6+license: BSD3
77license-file: LICENSE
88author: Chris Allen
99maintainer: cma@bitemyapp.com
@@ -25,6 +25,7 @@ library
2525 Database.Bloodhound.Types.Class
2626 build-depends: base >= 4.3 && <5,
2727 bytestring >= 0.10.2,
28+ containers >= 0.5.0.0,
2829 aeson >= 0.7,
2930 conduit >= 1.0,
3031 http-client >= 0.3,
@@ -45,6 +46,7 @@ test-suite tests
4546 bloodhound,
4647 http-client,
4748 http-types,
49+ containers >= 0.5.0.0,
4850 hspec >= 1.8,
4951 text >= 0.11,
5052 time >= 1.4,
changelog.md+5−2
@@ -1,6 +1,9 @@
110.4.0.0
22===================
33
4+* Term and date aggregation - thanks to Christopher Guiney! (@chrisguiney)
5+
6+Following three thanks to Liam Atkins (@latkins)
47* omitNulls changed to exclude empty lists and null values
58
69* BoolQuery must/mustNot/Should changed from Maybe (Query|[Query]) to [Query]
@@ -12,7 +15,7 @@
1215
1316* Status "ok" changed from Bool to Maybe Bool
1417
15−* Elasticsearch 1.3.x compatibility fixed with changes to geo bounding boxes
18+* Elasticsearch 1.3.x compatibility fixed with changes to geo bounding boxes - thanks to Curtis Carter! (@ccarter)
1619
1720* CI coverage expanded to 1.0.x -> 1.3.x
1821
@@ -36,4 +39,4 @@
3639
3740* Fixed and rebuilt documentation
3841
39−* RegexpFlags changed to a sum type instead of Text, thanks @MichaelXavier!
42+* RegexpFlags changed to a sum type instead of Text, thanks to @MichaelXavier!
tests/tests.hs+122−3
@@ -4,10 +4,12 @@
44module Main where
55
66import Control.Applicative
7+import Control.Monad
78import Data.Aeson
89import Data.HashMap.Strict (fromList)
910import Data.List (nub)
1011import Data.List.NonEmpty (NonEmpty (..))
12+import qualified Data.Map.Strict as M
1113import Data.Text (Text)
1214import qualified Data.Text as T
1315import Data.Time.Calendar (Day (..))
@@ -39,6 +41,57 @@ createExampleIndex = createIndex testServer defaultIndexSettings testIndex
3941deleteExampleIndex :: IO Reply
4042deleteExampleIndex = deleteIndex testServer testIndex
4143
44+data ServerVersion = ServerVersion Int Int Int deriving (Show, Eq, Ord)
45+
46+es14 :: ServerVersion
47+es14 = ServerVersion 1 4 0
48+
49+es13 :: ServerVersion
50+es13 = ServerVersion 1 3 0
51+
52+es12 :: ServerVersion
53+es12 = ServerVersion 1 2 0
54+
55+es11 :: ServerVersion
56+es11 = ServerVersion 1 1 0
57+
58+es10 :: ServerVersion
59+es10 = ServerVersion 1 0 0
60+
61+serverBranch :: ServerVersion -> ServerVersion
62+serverBranch (ServerVersion majorVer minorVer patchVer) =
63+ ServerVersion majorVer minorVer patchVer
64+
65+mkServerVersion :: [Int] -> Maybe ServerVersion
66+mkServerVersion [majorVer, minorVer, patchVer] =
67+ Just (ServerVersion majorVer minorVer patchVer)
68+mkServerVersion _ = Nothing
69+
70+getServerVersion :: Server -> IO (Maybe ServerVersion)
71+getServerVersion s = liftM extractVersion (getStatus s)
72+ where
73+ version' = T.splitOn "." . number . version
74+ toInt = read . T.unpack
75+ parseVersion v = map toInt (version' v)
76+ extractVersion = join . liftM (mkServerVersion . parseVersion)
77+
78+
79+
80+testServerBranch :: IO (Maybe ServerVersion)
81+testServerBranch = getServerVersion testServer >>= \v -> return $ liftM serverBranch v
82+
83+atleast :: ServerVersion -> IO Bool
84+atleast v = testServerBranch >>= \x -> return $ x >= Just (serverBranch v)
85+
86+atmost :: ServerVersion -> IO Bool
87+atmost v = testServerBranch >>= \x -> return $ x <= Just (serverBranch v)
88+
89+is :: ServerVersion -> IO Bool
90+is v = testServerBranch >>= \x -> return $ x == Just (serverBranch v)
91+
92+when' :: Monad m => m Bool -> m () -> m ()
93+when' b f = b >>= \x -> when x f
94+
4295data Location = Location { lat :: Double
4396 , lon :: Double } deriving (Eq, Generic, Show)
4497
@@ -109,6 +162,28 @@ searchExpectNoResults search = do
109162 let emptyHits = fmap (hits . searchHits) result
110163 emptyHits `shouldBe` Right []
111164
165+searchExpectAggs :: Search -> IO ()
166+searchExpectAggs search = do
167+ reply <- searchAll testServer search
168+ let isEmpty x = return (M.null x)
169+ let result = decode (responseBody reply) :: Maybe (SearchResult Tweet)
170+ (result >>= aggregations >>= isEmpty) `shouldBe` Just False
171+
172+searchValidBucketAgg :: (BucketAggregation a, FromJSON a, Show a) => Search -> Text -> (Text -> AggregationResults -> Maybe (Bucket a)) -> IO ()
173+searchValidBucketAgg search aggKey extractor = do
174+ reply <- searchAll testServer search
175+ let bucketDocs = docCount . head . buckets
176+ let result = decode (responseBody reply) :: Maybe (SearchResult Tweet)
177+ let count = result >>= aggregations >>= extractor aggKey >>= \x -> return (bucketDocs x)
178+ count `shouldBe` Just 1
179+
180+searchTermsAggHint :: [ExecutionHint] -> IO ()
181+searchTermsAggHint hints = do
182+ let terms hint = TermsAgg $ (mkTermsAggregation "user") { termExecutionHint = Just hint }
183+ let search hint = mkAggregateSearch Nothing $ mkAggregations "users" $ terms hint
184+ forM_ hints $ searchExpectAggs . search
185+ forM_ hints (\x -> searchValidBucketAgg (search x) "users" toTerms)
186+
112187data BulkTest = BulkTest { name :: Text } deriving (Eq, Generic, Show)
113188instance FromJSON BulkTest
114189instance ToJSON BulkTest
@@ -165,7 +240,7 @@ main = hspec $ do
165240 testMapping (DocId "2") (toJSON firstTest)
166241 let secondDoc = BulkCreate testIndex
167242 testMapping (DocId "3") (toJSON secondTest)
168− let stream = [firstDoc, secondDoc]
243+ let stream = V.fromList [firstDoc, secondDoc]
169244 _ <- bulk testServer stream
170245 _ <- refreshIndex testServer testIndex
171246 fDoc <- getDocument testServer testIndex testMapping (DocId "2")
@@ -237,7 +312,7 @@ main = hspec $ do
237312 _ <- insertOther
238313 let sortSpec = DefaultSortSpec $ mkSort (FieldName "age") Ascending
239314 let search = Search Nothing
240− (Just IdentityFilter) (Just [sortSpec])
315+ (Just IdentityFilter) (Just [sortSpec]) Nothing
241316 False 0 10
242317 reply <- searchByIndex testServer testIndex search
243318 let result = eitherDecode (responseBody reply) :: Either String (SearchResult Tweet)
@@ -364,6 +439,51 @@ main = hspec $ do
364439 let search = mkSearch Nothing (Just filter)
365440 searchExpectNoResults search
366441
442+ describe "Aggregation API" $ do
443+ it "returns term aggregation results" $ do
444+ _ <- insertData
445+ let terms = TermsAgg $ mkTermsAggregation "user"
446+ let search = mkAggregateSearch Nothing $ mkAggregations "users" terms
447+ searchExpectAggs search
448+ searchValidBucketAgg search "users" toTerms
449+
450+ it "can give collection hint parameters to term aggregations" $ when' (atleast es13) $ do
451+ _ <- insertData
452+ let terms = TermsAgg $ (mkTermsAggregation "user") { termCollectMode = Just BreadthFirst }
453+ let search = mkAggregateSearch Nothing $ mkAggregations "users" terms
454+ searchExpectAggs search
455+ searchValidBucketAgg search "users" toTerms
456+
457+ it "can give execution hint paramters to term aggregations" $ when' (atmost es11) $ do
458+ _ <- insertData
459+ searchTermsAggHint [Map, Ordinals]
460+
461+ it "can give execution hint paramters to term aggregations" $ when' (is es12) $ do
462+ _ <- insertData
463+ searchTermsAggHint [GlobalOrdinals, GlobalOrdinalsHash, GlobalOrdinalsLowCardinality, Map, Ordinals]
464+
465+ it "can give execution hint paramters to term aggregations" $ when' (atleast es12) $ do
466+ _ <- insertData
467+ searchTermsAggHint [GlobalOrdinals, GlobalOrdinalsHash, GlobalOrdinalsLowCardinality, Map]
468+
469+ it "returns date histogram aggregation results" $ do
470+ _ <- insertData
471+ let histogram = DateHistogramAgg $ mkDateHistogram (FieldName "postDate") Minute
472+ let search = mkAggregateSearch Nothing (mkAggregations "byDate" histogram)
473+ searchExpectAggs search
474+ searchValidBucketAgg search "byDate" toDateHistogram
475+
476+ it "returns date histogram using fractional date" $ do
477+ _ <- insertData
478+ let periods = [Year, Quarter, Month, Week, Day, Hour, Minute, Second]
479+ let fractionals = map (FractionalInterval 1.5) [Weeks, Days, Hours, Minutes, Seconds]
480+ let intervals = periods ++ fractionals
481+ let histogram = mkDateHistogram (FieldName "postDate")
482+ let search interval = mkAggregateSearch Nothing $ mkAggregations "byDate" $ DateHistogramAgg (histogram interval)
483+ let expect interval = searchExpectAggs (search interval)
484+ let valid interval = searchValidBucketAgg (search interval) "byDate" toDateHistogram
485+ forM_ intervals expect
486+ forM_ intervals valid
367487
368488 describe "ToJSON RegexpFlags" $ do
369489 it "generates the correct JSON for AllRegexpFlags" $
@@ -385,7 +505,6 @@ main = hspec $ do
385505 flagStrs = T.splitOn "|" str
386506 in noDuplicates flagStrs
387507
388−
389508 describe "omitNulls" $ do
390509 it "checks that omitNulls drops list elements when it should" $
391510 let dropped = omitNulls $ [ "test1" .= (toJSON ([] :: [Int]))