git.iko.soy/typeable/bloodhound
on 10671dc help sign in
typeable/bloodhound/Database/Bloodhound/Client.hs
924 lines 34 kB history raw
1{-# LANGUAGE DeriveGeneric, ExistentialQuantification, StandaloneDeriving #-}
3module Database.Bloodhound.Client
4 ( createIndex
5 , deleteIndex
6 , defaultIndexSettings
7 , createMapping
8 , deleteMapping
9 , indexDocument
10 , getDocument
11 , documentExists
12 , deleteDocument
13 , searchAll
14 , searchByIndex
15 , searchByType
16 , refreshIndex
17 , mkSearch
18 , bulk
19 , IndexSettings(..)
20 , Server(..)
21 , Reply(..)
22 , EsResult(..)
23 , Query(..)
24 , Search(..)
25 , SearchResult(..)
26 , SearchHits(..)
27 , ShardResult(..)
28 , Hit(..)
29 , Filter(..)
30 , Seminearring(..)
31 , BoolMatch(..)
32 , Term(..)
33 , GeoPoint(..)
34 , GeoBoundingBoxConstraint(..)
35 , GeoBoundingBox(..)
36 , GeoFilterType(..)
37 , Distance(..)
38 , DistanceUnit(..)
39 , DistanceType(..)
40 , DistanceRange(..)
41 , OptimizeBbox(..)
42 , LatLon(..)
43 , Range(..)
44 , HalfRange(..)
45 , RangeExecution(..)
46 , LessThan(..)
47 , LessThanEq(..)
48 , GreaterThan(..)
49 , GreaterThanEq(..)
50 , Regexp(..)
51 , RegexpFlags(..)
52 , FieldName(..)
53 , IndexName(..)
54 , MappingName(..)
55 , DocId(..)
56 , CacheName(..)
57 , CacheKey(..)
58 , BulkOperation(..)
59 )
60 where
62import Control.Applicative
63import Control.Monad (liftM)
64import Data.Aeson
65import Data.Aeson.TH (deriveJSON)
66import qualified Data.ByteString.Lazy.Char8 as L
67import Data.ByteString.Builder
68import Data.List (foldl', intercalate, intersperse)
69import Data.Maybe (fromMaybe)
70import Data.Monoid
71import Data.Text (Text)
72import qualified Data.Text as T
73import Data.Time.Clock (UTCTime)
74import GHC.Generics (Generic)
75import Network.HTTP.Conduit
76import qualified Network.HTTP.Types.Method as NHTM
77import qualified Network.HTTP.Types.Status as NHTS
79data Version = Version { number :: Text
80 , build_hash :: Text
81 , build_timestamp :: UTCTime
82 , build_snapshot :: Bool
83 , lucene_version :: Text } deriving (Show, Generic)
85data (FromJSON a, ToJSON a) => Status a =
86 Status { ok :: Bool
87 , status :: Int
88 , name :: Text
89 , version :: a
90 , tagline :: Text } deriving (Eq, Show)
92instance ToJSON Version
93instance FromJSON Version
95instance (FromJSON a, ToJSON a) => FromJSON (Status a) where
96 parseJSON (Object v) = Status <$>
97 v .: "ok" <*>
98 v .: "status" <*>
99 v .: "name" <*>
100 v .: "version" <*>
101 v .: "tagline"
102 parseJSON _ = empty
104main = simpleHttp "http://localhost:9200/events/event/_search?q=hostname:localhost&size=1" >>= L.putStrLn
106newtype ShardCount = ShardCount Int deriving (Eq, Show, Generic)
107newtype ReplicaCount = ReplicaCount Int deriving (Eq, Show, Generic)
109mkShardCount :: Int -> Maybe ShardCount
110mkShardCount n
111 | n < 1 = Nothing
112 | n > 1000 = Nothing -- seriously, what the fuck?
113 | otherwise = Just (ShardCount n)
115mkReplicaCount :: Int -> Maybe ReplicaCount
116mkReplicaCount n
117 | n < 1 = Nothing
118 | n > 1000 = Nothing -- ...
119 | otherwise = Just (ReplicaCount n)
121data IndexSettings =
122 IndexSettings { indexShards :: ShardCount
123 , indexReplicas :: ReplicaCount } deriving (Eq, Show)
125instance ToJSON IndexSettings where
126 toJSON (IndexSettings s r) = object ["settings" .= object ["shards" .= s, "replicas" .= r]]
128instance ToJSON ReplicaCount
129instance ToJSON ShardCount
131defaultIndexSettings = IndexSettings (ShardCount 3) (ReplicaCount 2)
133data Strategy = RoundRobinStrat | RandomStrat | HeadStrat deriving (Eq, Show)
135newtype Server = Server String deriving (Eq, Show)
137type Reply = Network.HTTP.Conduit.Response L.ByteString
138type Method = NHTM.Method
140responseIsError :: Reply -> Bool
141responseIsError resp = NHTS.statusCode (responseStatus resp) > 299
143emptyBody = L.pack ""
145dispatch :: String -> Method -> Maybe L.ByteString
146 -> IO Reply
147dispatch url method body = do
148 initReq <- parseUrl url
149 let reqBody = RequestBodyLBS $ fromMaybe emptyBody body
150 let req = initReq { method = method
151 , requestBody = reqBody
152 , checkStatus = \_ _ _ -> Nothing}
153 withManager $ httpLbs req
155joinPath :: [String] -> String
156joinPath = intercalate "/"
158getStatus :: Server -> IO (Maybe (Status Version))
159getStatus (Server server) = do
160 request <- parseUrl $ joinPath [server]
161 response <- withManager $ httpLbs request
162 return $ decode (responseBody response)
164createIndex :: Server -> IndexSettings -> IndexName -> IO Reply
165createIndex (Server server) indexSettings (IndexName indexName) =
166 dispatch url method body where
167 url = joinPath [server, indexName]
168 method = NHTM.methodPut
169 body = Just $ encode indexSettings
171deleteIndex :: Server -> IndexName -> IO Reply
172deleteIndex (Server server) (IndexName indexName) =
173 dispatch url method body where
174 url = joinPath [server, indexName]
175 method = NHTM.methodDelete
176 body = Nothing
178respIsTwoHunna :: Reply -> Bool
179respIsTwoHunna resp = NHTS.statusCode (responseStatus resp) == 200
181existentialQuery url = do
182 reply <- dispatch url NHTM.methodHead Nothing
183 return (reply, respIsTwoHunna reply)
185indexExists :: Server -> IndexName -> IO Bool
186indexExists (Server server) (IndexName indexName) = do
187 (reply, exists) <- existentialQuery url
188 return exists where
189 url = joinPath [server, indexName]
191refreshIndex :: Server -> IndexName -> IO Reply
192refreshIndex (Server server) (IndexName indexName) = dispatch url method body where
193 url = joinPath [server, indexName, "_refresh"]
194 method = NHTM.methodPost
195 body = Nothing
197data OpenCloseIndex = OpenIndex | CloseIndex deriving (Eq, Show)
199stringifyOCIndex oci = case oci of
200 OpenIndex -> "_open"
201 CloseIndex -> "_close"
203openOrCloseIndexes :: OpenCloseIndex -> Server -> IndexName -> IO Reply
204openOrCloseIndexes oci (Server server) (IndexName indexName) =
205 dispatch url method body where
206 ociString = stringifyOCIndex oci
207 url = joinPath [server, indexName, ociString]
208 method = NHTM.methodPost
209 body = Nothing
211openIndex :: Server -> IndexName -> IO Reply
212openIndex = openOrCloseIndexes OpenIndex
214closeIndex :: Server -> IndexName -> IO Reply
215closeIndex = openOrCloseIndexes CloseIndex
217data FieldType = GeoPointType
218 | GeoShapeType
219 | FloatType
220 | IntegerType
221 | LongType
222 | ShortType
223 | ByteType deriving (Eq, Show)
225data FieldDefinition =
226 FieldDefinition { fieldType :: FieldType } deriving (Eq, Show)
228data MappingField =
229 MappingField { mappingFieldName :: FieldName
230 , fieldDefinition :: FieldDefinition } deriving (Eq, Show)
232data Mapping = Mapping { typeName :: Text
233 , fields :: [MappingField] } deriving (Eq, Show)
235createMapping :: ToJSON a => Server -> IndexName
236 -> MappingName -> a -> IO Reply
237createMapping (Server server) (IndexName indexName) (MappingName mappingName) mapping =
238 dispatch url method body where
239 url = joinPath [server, indexName, mappingName, "_mapping"]
240 method = NHTM.methodPut
241 body = Just $ encode mapping
243deleteMapping :: Server -> IndexName -> MappingName -> IO Reply
244deleteMapping (Server server) (IndexName indexName) (MappingName mappingName) =
245 dispatch url method body where
246 url = joinPath [server, indexName, mappingName, "_mapping"]
247 method = NHTM.methodDelete
248 body = Nothing
250indexDocument :: ToJSON doc => Server -> IndexName -> MappingName
251 -> doc -> DocId -> IO Reply
252indexDocument (Server server) (IndexName indexName)
253 (MappingName mappingName) document (DocId docId) =
254 dispatch url method body where
255 url = joinPath [server, indexName, mappingName, docId]
256 method = NHTM.methodPut
257 body = Just (encode document)
259deleteDocument :: Server -> IndexName -> MappingName
260 -> DocId -> IO Reply
261deleteDocument (Server server) (IndexName indexName)
262 (MappingName mappingName) (DocId docId) =
263 dispatch url method body where
264 url = joinPath [server, indexName, mappingName, docId]
265 method = NHTM.methodDelete
266 body = Nothing
268bulk :: Server -> [BulkOperation] -> IO Reply
269bulk (Server server) bulkOps = dispatch url method body where
270 url = joinPath [server, "_bulk"]
271 method = NHTM.methodPost
272 body = Just $ collapseStream bulkOps
274collapseStream :: [BulkOperation] -> L.ByteString
275collapseStream stream = collapsed where
276 blobs = intersperse "\n" $ concat $ fmap getStreamChunk stream
277 mashedTaters = mash (mempty :: Builder) blobs
278 collapsed = toLazyByteString $ mappend mashedTaters "\n"
280mash :: Builder -> [L.ByteString] -> Builder
281mash builder xs = foldl' (\b x -> mappend b (lazyByteString x)) builder xs
283data BulkOperation =
284 BulkIndex IndexName MappingName DocId Value
285 | BulkCreate IndexName MappingName DocId Value
286 | BulkDelete IndexName MappingName DocId
287 | BulkUpdate IndexName MappingName DocId Value deriving (Eq, Show)
289mkMetadataValue :: Text -> String -> String -> String -> Value
290mkMetadataValue operation indexName mappingName docId =
291 object [operation .=
292 object ["_index" .= indexName
293 , "_type" .= mappingName
294 , "_id" .= docId]]
296getStreamChunk :: BulkOperation -> [L.ByteString]
297getStreamChunk (BulkIndex (IndexName indexName)
298 (MappingName mappingName)
299 (DocId docId) value) = blob where
300 metadata = mkMetadataValue "index" indexName mappingName docId
301 blob = [encode metadata, encode value]
303getStreamChunk (BulkCreate (IndexName indexName)
304 (MappingName mappingName)
305 (DocId docId) value) = blob where
306 metadata = mkMetadataValue "create" indexName mappingName docId
307 blob = [encode metadata, encode value]
309getStreamChunk (BulkDelete (IndexName indexName)
310 (MappingName mappingName)
311 (DocId docId)) = blob where
312 metadata = mkMetadataValue "delete" indexName mappingName docId
313 blob = [encode metadata]
315getStreamChunk (BulkUpdate (IndexName indexName)
316 (MappingName mappingName)
317 (DocId docId) value) = blob where
318 metadata = mkMetadataValue "update" indexName mappingName docId
319 doc = object ["doc" .= value]
320 blob = [encode metadata, encode doc]
322data EsResult a = EsResult { _index :: Text
323 , _type :: Text
324 , _id :: Text
325 , _version :: Int
326 , found :: Maybe Bool
327 , _source :: a } deriving (Eq, Show)
329instance (FromJSON a, ToJSON a) => FromJSON (EsResult a) where
330 parseJSON (Object v) = EsResult <$>
331 v .: "_index" <*>
332 v .: "_type" <*>
333 v .: "_id" <*>
334 v .: "_version" <*>
335 v .:? "found" <*>
336 v .: "_source"
337 parseJSON _ = empty
339getDocument :: Server -> IndexName -> MappingName
340 -> DocId -> IO Reply
341getDocument (Server server) (IndexName indexName) (MappingName mappingName) (DocId docId) =
342 dispatch url method body where
343 url = joinPath [server, indexName, mappingName, docId]
344 method = NHTM.methodGet
345 body = Nothing
347documentExists :: Server -> IndexName -> MappingName
348 -> DocId -> IO Bool
349documentExists (Server server) (IndexName indexName) (MappingName mappingName) (DocId docId) = do
350 (reply, exists) <- existentialQuery url
351 return exists where
352 url = joinPath [server, indexName, mappingName, docId]
355dispatchSearch :: String -> Search -> IO Reply
356dispatchSearch url search = dispatch url NHTM.methodPost (Just (encode search))
358searchAll :: Server -> Search -> IO Reply
359searchAll (Server server) search = dispatchSearch url search where
360 url = joinPath [server, "_search"]
362searchByIndex :: Server -> IndexName -> Search -> IO Reply
363searchByIndex (Server server) (IndexName indexName) search = dispatchSearch url search where
364 url = joinPath [server, indexName, "_search"]
366searchByType :: Server -> IndexName -> MappingName -> Search -> IO Reply
367searchByType (Server server) (IndexName indexName)
368 (MappingName mappingName) search = dispatchSearch url search where
369 url = joinPath [server, indexName, mappingName, "_search"]
371data Search = Search { queryBody :: Maybe Query
372 , filterBody :: Maybe Filter
373 , sortBody :: Maybe Sort
374 -- default False
375 , trackSortScores :: Bool
376 , from :: Int
377 , size :: Int} deriving (Eq, Show)
379mkSearch :: Maybe Query -> Maybe Filter -> Search
380mkSearch query filter = Search query filter Nothing False 0 10
382pageSearch :: Int -> Int -> Search -> Search
383pageSearch from size search = search { from = from, size = size }
385-- defaultFieldMaybeJSON :: Text -> Maybe a ->
386maybeJson field (Just value) = [field .= toJSON value]
387maybeJson _ _ = []
388maybeJsonF field (Just value) = [field .= fmap toJSON value]
389maybeJsonF _ _ = []
391instance ToJSON Search where
392 toJSON (Search query filter sort trackSortScores from size) =
393 object merged where
394 lQuery = maybeJson "query" query
395 lFilter = maybeJson "filter" filter
396 lSort = maybeJsonF "sort" sort
397 merged = mconcat [[ "from" .= from
398 , "size" .= size
399 , "track_scores" .= trackSortScores]
400 , lQuery
401 , lFilter
402 , lSort]
404type Sort = [SortSpec]
406data SortSpec = DefaultSortSpec DefaultSort
407 | GeoDistanceSortSpec SortOrder GeoPoint deriving (Eq, Show)
409instance ToJSON SortSpec where
410 toJSON (DefaultSortSpec
411 (DefaultSort (FieldName sortFieldName) sortOrder ignoreUnmapped
412 sortMode missingSort nestedFilter)) =
413 object [sortFieldName .= object merged] where
414 base = ["order" .= toJSON sortOrder
415 , "ignore_unmapped" .= ignoreUnmapped]
416 lSortMode = maybeJson "mode" sortMode
417 lMissingSort = maybeJson "missing" missingSort
418 lNestedFilter = maybeJson "nested_filter" nestedFilter
419 merged = mconcat [base, lSortMode, lMissingSort, lNestedFilter]
421instance ToJSON SortOrder where
422 toJSON Ascending = String "asc"
423 toJSON Descending = String "desc"
425instance ToJSON SortMode where
426 toJSON SortMin = String "min"
427 toJSON SortMax = String "max"
428 toJSON SortSum = String "sum"
429 toJSON SortAvg = String "avg"
431instance ToJSON Missing where
432 toJSON LastMissing = String "_last"
433 toJSON FirstMissing = String "_first"
434 toJSON (CustomMissing txt) = String txt
436data DefaultSort =
437 DefaultSort { sortFieldName :: FieldName
438 , sortOrder :: SortOrder
439 -- default False
440 , ignoreUnmapped :: Bool
441 , sortMode :: Maybe SortMode
442 , missingSort :: Maybe Missing
443 , nestedFilter :: Maybe Filter } deriving (Eq, Show)
445data SortOrder = Ascending
446 | Descending deriving (Eq, Show)
448data Missing = LastMissing
449 | FirstMissing
450 | CustomMissing Text deriving (Eq, Show)
452data SortMode = SortMin
453 | SortMax
454 | SortSum
455 | SortAvg deriving (Eq, Show)
457-- status:active
458-- author:"John Smith"
459-- for book.title and book.date containing quick OR brown, book.\*:(quick brown)
460-- field title has no value or doesn't exist, _missing_:title
461-- field title has any non-null value, _exists:title
463-- type DisMax = Bool -- "use_dis_max"
464-- newtype TieBreaker = TieBreaker Int deriving (Eq, Show)
465-- data QueryField = DefaultField Text
466-- | Fields [Text] DisMax TieBreaker deriving (Eq, Show)
468-- -- this is will go away later
470-- data QueryStringQuery =
471-- QueryStringQuery { query :: Text
472-- -- default _all
473-- , field :: Maybe QueryField
474-- -- default OR
475-- , defaultOperator :: Maybe BooleanOperator
476-- -- analyzer name
477-- , analyzer :: Maybe Text
478-- -- default true
479-- , allowLeadingWildcard :: Maybe Bool
480-- -- default true
481-- , lowercaseExpandedTerms :: Maybe Bool
482-- -- default true
483-- , enablePositionIncrements :: Maybe Bool
484-- -- default 50
485-- , fuzzyMaxExpansions :: Maybe Int
486-- -- Fuzziness -- default AUTO, add type later
487-- , fuzziness :: Maybe Text
488-- , fuzzyPrefixLength :: Maybe Int -- default 0
489-- -- default 0, 0 means exact phrase matches
490-- , phraseSlop :: Maybe Int
491-- -- default 1.0
492-- , boost :: Maybe Double
493-- -- default false, true forces wildcard analysis
494-- , analyzeWildcard :: Maybe Bool
495-- -- default false
496-- , autoGeneratePhraseQueries :: Maybe Bool
497-- -- # "should" clauses in the boolean query should match
498-- , minimumShouldMatch :: Maybe Text
499-- -- Text to handle weird % and other cases. Needs type
500-- -- default false, true shuts off format based failures
501-- , lenient :: Maybe Bool
502-- -- default ROOT, locale used for string conversions
503-- , locale :: Maybe Text
504-- } deriving (Eq, Show)
506-- emptyQueryStringQuery = QueryStringQuery "" Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing
507-- queryStringQuery query = emptyQueryStringQuery { query = query }
509-- type FieldName = Text
511type Cache = Bool -- caching on/off
512defaultCache = False
514type PrefixValue = Text
516data BooleanOperator = And | Or deriving (Eq, Show)
518newtype IndexName = IndexName String deriving (Eq, Generic, Show)
519newtype MappingName = MappingName String deriving (Eq, Generic, Show)
520newtype DocId = DocId String deriving (Eq, Generic, Show)
521newtype QueryString = QueryString Text deriving (Eq, Show)
522newtype FieldName = FieldName Text deriving (Eq, Show)
523newtype CacheName = CacheName Text deriving (Eq, Show)
524newtype CacheKey = CacheKey Text deriving (Eq, Show)
525newtype Existence = Existence Bool deriving (Eq, Show)
526newtype NullValue = NullValue Bool deriving (Eq, Show)
528unpackId :: DocId -> String
529unpackId (DocId docId) = docId
531instance FromJSON IndexName
532instance FromJSON MappingName
533instance FromJSON DocId
535-- data QueryType = BooleanQueryType
536-- | PhraseQueryType
537-- | PhrasePrefixQueryType deriving (Eq, Show)
538type Boost = Double
540data Query = TermQuery Term (Maybe Boost)
541 | ConstantScoreFilter Filter Boost
542 | ConstantScoreQuery Query Boost
543 deriving (Eq, Show)
545instance ToJSON Query where
546 toJSON (TermQuery (Term termField termValue) boost) =
547 object ["term" .=
548 object [termField .= object merged]]
549 where
550 base = ["value" .= termValue]
551 boosted = case boost of
552 (Just boostValue) -> ["boost" .= boostValue]
553 Nothing -> []
554 merged = mappend base boosted
556data Filter = AndFilter [Filter] Cache
557 | OrFilter [Filter] Cache
558 | NotFilter Filter Cache
559 | IdentityFilter
560 | BoolFilter BoolMatch
561 | ExistsFilter FieldName -- always cached
562 | GeoBoundingBoxFilter GeoBoundingBoxConstraint GeoFilterType
563 | GeoDistanceFilter GeoPoint Distance DistanceType OptimizeBbox Cache
564 | GeoDistanceRangeFilter GeoPoint DistanceRange
565 | GeoPolygonFilter FieldName [LatLon]
566 | IdsFilter MappingName [DocId]
567 | LimitFilter Int
568 | MissingFilter FieldName Existence NullValue
569 | PrefixFilter FieldName PrefixValue Cache
570 | RangeFilter FieldName (Either HalfRange Range) RangeExecution Cache
571 | RegexpFilter FieldName Regexp RegexpFlags CacheName Cache CacheKey
572 deriving (Eq, Show)
574class Monoid a => Seminearring a where
575 -- 0, +, *
576 (<||>) :: a -> a -> a
577 (<&&>) :: a -> a -> a
578 (<&&>) = mappend
580infixr 5 <||>
581infixr 5 <&&>
583instance Monoid Filter where
584 mempty = IdentityFilter
585 mappend a b = AndFilter [a, b] defaultCache
587instance Seminearring Filter where
588 a <||> b = OrFilter [a, b] defaultCache
590instance ToJSON Filter where
591 toJSON (AndFilter filters cache) =
592 object ["and" .= fmap toJSON filters
593 , "_cache" .= cache]
595 toJSON (OrFilter filters cache) =
596 object ["or" .= fmap toJSON filters
597 , "_cache" .= cache]
599 toJSON (NotFilter filter cache) =
600 object ["not" .=
601 object ["filter" .= toJSON filter
602 , "_cache" .= cache]]
604 toJSON (IdentityFilter) =
605 object ["match_all" .= object []]
607 toJSON (ExistsFilter (FieldName fieldName)) =
608 object ["exists" .= object
609 ["field" .= fieldName]]
611 toJSON (BoolFilter boolMatch) =
612 object ["bool" .= toJSON boolMatch]
614 toJSON (GeoBoundingBoxFilter bbConstraint filterType) =
615 object ["geo_bounding_box" .= toJSON bbConstraint
616 , "type" .= toJSON filterType]
618 toJSON (GeoDistanceFilter (GeoPoint (FieldName geoField) latLon)
619 distance distanceType optimizeBbox cache) =
620 object ["geo_distance" .=
621 object ["distance" .= toJSON distance
622 , "distance_type" .= toJSON distanceType
623 , "optimize_bbox" .= optimizeBbox
624 , geoField .= toJSON latLon
625 , "_cache" .= cache]]
627 toJSON (GeoDistanceRangeFilter (GeoPoint (FieldName geoField) latLon)
628 (DistanceRange distanceFrom distanceTo)) =
629 object ["geo_distance_range" .=
630 object ["from" .= toJSON distanceFrom
631 , "to" .= toJSON distanceTo
632 , geoField .= toJSON latLon]]
634 toJSON (GeoPolygonFilter (FieldName geoField) latLons) =
635 object ["geo_polygon" .=
636 object [geoField .=
637 object ["points" .= fmap toJSON latLons]]]
639 toJSON (IdsFilter (MappingName mappingName) values) =
640 object ["ids" .=
641 object ["type" .= mappingName
642 , "values" .= fmap (T.pack . unpackId) values]]
644 toJSON (LimitFilter limit) =
645 object ["limit" .= object ["value" .= limit]]
647 toJSON (MissingFilter (FieldName fieldName) (Existence existence) (NullValue nullValue)) =
648 object ["missing" .=
649 object ["field" .= fieldName
650 , "existence" .= existence
651 , "null_value" .= nullValue]]
653 toJSON (PrefixFilter (FieldName fieldName) fieldValue cache) =
654 object ["prefix" .=
655 object [fieldName .= fieldValue
656 , "_cache" .= cache]]
658 toJSON (RangeFilter (FieldName fieldName) (Left halfRange) rangeExecution cache) =
659 object ["range" .=
660 object [fieldName .=
661 object [key .= val]
662 , "execution" .= toJSON rangeExecution
663 , "_cache" .= cache]]
664 where
665 (key, val) = halfRangeToKV halfRange
667 toJSON (RangeFilter (FieldName fieldName) (Right range) rangeExecution cache) =
668 object ["range" .=
669 object [fieldName .=
670 object [lessKey .= lessVal
671 , greaterKey .= greaterVal]
672 , "execution" .= toJSON rangeExecution
673 , "_cache" .= cache]]
674 where
675 (lessKey, lessVal, greaterKey, greaterVal) = rangeToKV range
677 toJSON (RegexpFilter (FieldName fieldName)
678 (Regexp regexText) flags (CacheName cacheName) cache (CacheKey cacheKey)) =
679 object ["regexp" .=
680 object [fieldName .=
681 object ["value" .= regexText
682 , "flags" .= toJSON flags]
683 , "_name" .= cacheName
684 , "_cache" .= cache
685 , "_cache_key" .= cacheKey]]
687instance ToJSON GeoPoint where
688 toJSON (GeoPoint (FieldName geoField) latLon) =
689 object [geoField .= toJSON latLon]
691showText :: Show a => a -> Text
692showText = T.pack . show
694instance ToJSON Distance where
695 toJSON (Distance coefficient unit) =
696 String boltedTogether where
697 coefText = showText coefficient
698 (String unitText) = (toJSON unit)
699 boltedTogether = mappend coefText unitText
701instance ToJSON DistanceUnit where
702 toJSON Miles = String "mi"
703 toJSON Yards = String "yd"
704 toJSON Feet = String "ft"
705 toJSON Inches = String "in"
706 toJSON Kilometers = String "km"
707 toJSON Meters = String "m"
708 toJSON Centimeters = String "cm"
709 toJSON Millimeters = String "mm"
710 toJSON NauticalMiles = String "nmi"
712instance ToJSON DistanceType where
713 toJSON Arc = String "arc"
714 toJSON SloppyArc = String "sloppy_arc"
715 toJSON Plane = String "plane"
717instance ToJSON OptimizeBbox where
718 toJSON NoOptimizeBbox = String "none"
719 toJSON (OptimizeGeoFilterType gft) = toJSON gft
721instance ToJSON GeoBoundingBoxConstraint where
722 toJSON (GeoBoundingBoxConstraint (FieldName geoBBField) constraintBox cache) =
723 object [geoBBField .= toJSON constraintBox
724 , "_cache" .= cache]
726instance ToJSON GeoFilterType where
727 toJSON GeoFilterMemory = String "memory"
728 toJSON GeoFilterIndexed = String "indexed"
730instance ToJSON GeoBoundingBox where
731 toJSON (GeoBoundingBox topLeft bottomRight) =
732 object ["top_left" .= toJSON topLeft
733 , "bottom_right" .= toJSON bottomRight]
735instance ToJSON LatLon where
736 toJSON (LatLon lat lon) =
737 object ["lat" .= lat
738 , "lon" .= lon]
740-- lt, lte | gt, gte
741newtype LessThan = LessThan Double deriving (Eq, Show)
742newtype LessThanEq = LessThanEq Double deriving (Eq, Show)
743newtype GreaterThan = GreaterThan Double deriving (Eq, Show)
744newtype GreaterThanEq = GreaterThanEq Double deriving (Eq, Show)
746data HalfRange = HalfRangeLt LessThan
747 | HalfRangeLte LessThanEq
748 | HalfRangeGt GreaterThan
749 | HalfRangeGte GreaterThanEq deriving (Eq, Show)
751data Range = RangeLtGt LessThan GreaterThan
752 | RangeLtGte LessThan GreaterThanEq
753 | RangeLteGt LessThanEq GreaterThan
754 | RangeLteGte LessThanEq GreaterThanEq deriving (Eq, Show)
756halfRangeToKV :: HalfRange -> (Text, Double)
757halfRangeToKV (HalfRangeLt (LessThan n)) = ("lt", n)
758halfRangeToKV (HalfRangeLte (LessThanEq n)) = ("lte", n)
759halfRangeToKV (HalfRangeGt (GreaterThan n)) = ("gt", n)
760halfRangeToKV (HalfRangeGte (GreaterThanEq n)) = ("gte", n)
762rangeToKV :: Range -> (Text, Double, Text, Double)
763rangeToKV (RangeLtGt (LessThan m) (GreaterThan n)) = ("lt", m, "gt", n)
764rangeToKV (RangeLtGte (LessThan m) (GreaterThanEq n)) = ("lt", m, "gte", n)
765rangeToKV (RangeLteGt (LessThanEq m) (GreaterThan n)) = ("lte", m, "gt", n)
766rangeToKV (RangeLteGte (LessThanEq m) (GreaterThanEq n)) = ("lte", m, "gte", n)
768data RangeExecution = RangeExecutionIndex
769 | RangeExecutionFielddata deriving (Eq, Show)
771-- index for smaller ranges, fielddata for longer ranges
772instance ToJSON RangeExecution where
773 toJSON RangeExecutionIndex = "index"
774 toJSON RangeExecutionFielddata = "fielddata"
776newtype Regexp = Regexp Text deriving (Eq, Show)
777data RegexpFlags = RegexpAll
778 | Complement
779 | Interval
780 | Intersection
781 | AnyString
782 | CompInterval
783 | CompIntersection
784 | CompAnyString
785 | IntervalIntersection
786 | IntervalAnyString
787 | IntersectionAnyString deriving (Eq, Show)
789instance ToJSON RegexpFlags where
790 toJSON RegexpAll = String "ALL"
791 toJSON Complement = String "COMPLEMENT"
792 toJSON Interval = String "INTERVAL"
793 toJSON Intersection = String "INTERSECTION"
794 toJSON AnyString = String "ANYSTRING"
795 toJSON CompInterval = String "COMPLEMENT|INTERVAL"
796 toJSON CompIntersection = String "COMPLEMENT|INTERSECTION"
797 toJSON CompAnyString = String "COMPLEMENT|ANYSTRING"
798 toJSON IntervalIntersection = String "INTERVAL|INTERSECTION"
799 toJSON IntervalAnyString = String "INTERVAL|ANYSTRING"
800 toJSON IntersectionAnyString = String "INTERSECTION|ANYSTRING"
802-- phew. Coulda used Agda style case breaking there but, you know, whatever. :)
804data Term = Term { termField :: Text
805 , termValue :: Text } deriving (Eq, Show)
807instance ToJSON Term where
808 toJSON (Term field value) = object ["term" .= object
809 [field .= value]]
811data BoolMatch = MustMatch Term Cache
812 | MustNotMatch Term Cache
813 | ShouldMatch [Term] Cache deriving (Eq, Show)
815instance ToJSON BoolMatch where
816 toJSON (MustMatch term cache) = object ["must" .= toJSON term,
817 "_cache" .= cache]
818 toJSON (MustNotMatch term cache) = object ["must_not" .= toJSON term,
819 "_cache" .= cache]
820 toJSON (ShouldMatch terms cache) = object ["should" .= fmap toJSON terms,
821 "_cache" .= cache]
823-- "memory" or "indexed"
824data GeoFilterType = GeoFilterMemory
825 | GeoFilterIndexed deriving (Eq, Show)
828data LatLon = LatLon { lat :: Double
829 , lon :: Double } deriving (Eq, Show)
831data GeoBoundingBox =
832 GeoBoundingBox { topLeft :: LatLon
833 , bottomRight :: LatLon } deriving (Eq, Show)
835data GeoBoundingBoxConstraint =
836 GeoBoundingBoxConstraint { geoBBField :: FieldName
837 , constraintBox :: GeoBoundingBox
838 , bbConstraintcache :: Cache
839 } deriving (Eq, Show)
841data GeoPoint =
842 GeoPoint { geoField :: FieldName
843 , latLon :: LatLon} deriving (Eq, Show)
845data DistanceUnit = Miles
846 | Yards
847 | Feet
848 | Inches
849 | Kilometers
850 | Meters
851 | Centimeters
852 | Millimeters
853 | NauticalMiles deriving (Eq, Show)
855data DistanceType = Arc
856 | SloppyArc -- doesn't exist <1.0
857 | Plane deriving (Eq, Show)
859data OptimizeBbox = OptimizeGeoFilterType GeoFilterType
860 | NoOptimizeBbox deriving (Eq, Show)
862data Distance =
863 Distance { coefficient :: Double
864 , unit :: DistanceUnit } deriving (Eq, Show)
866data DistanceRange =
867 DistanceRange { distanceFrom :: Distance
868 , distanceTo :: Distance } deriving (Eq, Show)
870data FromJSON a => SearchResult a =
871 SearchResult { took :: Int
872 , timedOut :: Bool
873 , shards :: ShardResult
874 , searchHits :: SearchHits a } deriving (Eq, Show)
876type Score = Double
878data FromJSON a => SearchHits a =
879 SearchHits { hitsTotal :: Int
880 , maxScore :: Score
881 , hits :: [Hit a] } deriving (Eq, Show)
883data FromJSON a => Hit a =
884 Hit { hitIndex :: IndexName
885 , hitType :: MappingName
886 , hitDocId :: DocId
887 , hitScore :: Score
888 , hitSource :: a } deriving (Eq, Show)
890data ShardResult =
891 ShardResult { shardTotal :: Int
892 , shardsSuccessful :: Int
893 , shardsFailed :: Int } deriving (Eq, Show, Generic)
895instance (FromJSON a, ToJSON a) => FromJSON (SearchResult a) where
896 parseJSON (Object v) = SearchResult <$>
897 v .: "took" <*>
898 v .: "timed_out" <*>
899 v .: "_shards" <*>
900 v .: "hits"
901 parseJSON _ = empty
903instance (FromJSON a, ToJSON a) => FromJSON (SearchHits a) where
904 parseJSON (Object v) = SearchHits <$>
905 v .: "total" <*>
906 v .: "max_score" <*>
907 v .: "hits"
908 parseJSON _ = empty
910instance (FromJSON a, ToJSON a) => FromJSON (Hit a) where
911 parseJSON (Object v) = Hit <$>
912 v .: "_index" <*>
913 v .: "_type" <*>
914 v .: "_id" <*>
915 v .: "_score" <*>
916 v .: "_source"
917 parseJSON _ = empty
919instance FromJSON ShardResult where
920 parseJSON (Object v) = ShardResult <$>
921 v .: "total" <*>
922 v .: "successful" <*>
923 v .: "failed"
924 parseJSON _ = empty