git.iko.soy/typeable/bloodhound
on 1aea945 help sign in
typeable/bloodhound/Database/Bloodhound/Client.hs
923 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 query filter = Search query filter Nothing False 0 10
381pageSearch :: Int -> Int -> Search -> Search
382pageSearch from size search = search { from = from, size = size }
384-- defaultFieldMaybeJSON :: Text -> Maybe a ->
385maybeJson field (Just value) = [field .= toJSON value]
386maybeJson _ _ = []
387maybeJsonF field (Just value) = [field .= fmap toJSON value]
388maybeJsonF _ _ = []
390instance ToJSON Search where
391 toJSON (Search query filter sort trackSortScores from size) =
392 object merged where
393 lQuery = maybeJson "query" query
394 lFilter = maybeJson "filter" filter
395 lSort = maybeJsonF "sort" sort
396 merged = mconcat [[ "from" .= from
397 , "size" .= size
398 , "track_scores" .= trackSortScores]
399 , lQuery
400 , lFilter
401 , lSort]
403type Sort = [SortSpec]
405data SortSpec = DefaultSortSpec DefaultSort
406 | GeoDistanceSortSpec SortOrder GeoPoint deriving (Eq, Show)
408instance ToJSON SortSpec where
409 toJSON (DefaultSortSpec
410 (DefaultSort (FieldName sortFieldName) sortOrder ignoreUnmapped
411 sortMode missingSort nestedFilter)) =
412 object [sortFieldName .= object merged] where
413 base = ["order" .= toJSON sortOrder
414 , "ignore_unmapped" .= ignoreUnmapped]
415 lSortMode = maybeJson "mode" sortMode
416 lMissingSort = maybeJson "missing" missingSort
417 lNestedFilter = maybeJson "nested_filter" nestedFilter
418 merged = mconcat [base, lSortMode, lMissingSort, lNestedFilter]
420instance ToJSON SortOrder where
421 toJSON Ascending = String "asc"
422 toJSON Descending = String "desc"
424instance ToJSON SortMode where
425 toJSON SortMin = String "min"
426 toJSON SortMax = String "max"
427 toJSON SortSum = String "sum"
428 toJSON SortAvg = String "avg"
430instance ToJSON Missing where
431 toJSON LastMissing = String "_last"
432 toJSON FirstMissing = String "_first"
433 toJSON (CustomMissing txt) = String txt
435data DefaultSort =
436 DefaultSort { sortFieldName :: FieldName
437 , sortOrder :: SortOrder
438 -- default False
439 , ignoreUnmapped :: Bool
440 , sortMode :: Maybe SortMode
441 , missingSort :: Maybe Missing
442 , nestedFilter :: Maybe Filter } deriving (Eq, Show)
444data SortOrder = Ascending
445 | Descending deriving (Eq, Show)
447data Missing = LastMissing
448 | FirstMissing
449 | CustomMissing Text deriving (Eq, Show)
451data SortMode = SortMin
452 | SortMax
453 | SortSum
454 | SortAvg deriving (Eq, Show)
456-- status:active
457-- author:"John Smith"
458-- for book.title and book.date containing quick OR brown, book.\*:(quick brown)
459-- field title has no value or doesn't exist, _missing_:title
460-- field title has any non-null value, _exists:title
462-- type DisMax = Bool -- "use_dis_max"
463-- newtype TieBreaker = TieBreaker Int deriving (Eq, Show)
464-- data QueryField = DefaultField Text
465-- | Fields [Text] DisMax TieBreaker deriving (Eq, Show)
467-- -- this is will go away later
469-- data QueryStringQuery =
470-- QueryStringQuery { query :: Text
471-- -- default _all
472-- , field :: Maybe QueryField
473-- -- default OR
474-- , defaultOperator :: Maybe BooleanOperator
475-- -- analyzer name
476-- , analyzer :: Maybe Text
477-- -- default true
478-- , allowLeadingWildcard :: Maybe Bool
479-- -- default true
480-- , lowercaseExpandedTerms :: Maybe Bool
481-- -- default true
482-- , enablePositionIncrements :: Maybe Bool
483-- -- default 50
484-- , fuzzyMaxExpansions :: Maybe Int
485-- -- Fuzziness -- default AUTO, add type later
486-- , fuzziness :: Maybe Text
487-- , fuzzyPrefixLength :: Maybe Int -- default 0
488-- -- default 0, 0 means exact phrase matches
489-- , phraseSlop :: Maybe Int
490-- -- default 1.0
491-- , boost :: Maybe Double
492-- -- default false, true forces wildcard analysis
493-- , analyzeWildcard :: Maybe Bool
494-- -- default false
495-- , autoGeneratePhraseQueries :: Maybe Bool
496-- -- # "should" clauses in the boolean query should match
497-- , minimumShouldMatch :: Maybe Text
498-- -- Text to handle weird % and other cases. Needs type
499-- -- default false, true shuts off format based failures
500-- , lenient :: Maybe Bool
501-- -- default ROOT, locale used for string conversions
502-- , locale :: Maybe Text
503-- } deriving (Eq, Show)
505-- emptyQueryStringQuery = QueryStringQuery "" Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing
506-- queryStringQuery query = emptyQueryStringQuery { query = query }
508-- type FieldName = Text
510type Cache = Bool -- caching on/off
511defaultCache = False
513type PrefixValue = Text
515data BooleanOperator = And | Or deriving (Eq, Show)
517newtype IndexName = IndexName String deriving (Eq, Generic, Show)
518newtype MappingName = MappingName String deriving (Eq, Generic, Show)
519newtype DocId = DocId String deriving (Eq, Generic, Show)
520newtype QueryString = QueryString Text deriving (Eq, Show)
521newtype FieldName = FieldName Text deriving (Eq, Show)
522newtype CacheName = CacheName Text deriving (Eq, Show)
523newtype CacheKey = CacheKey Text deriving (Eq, Show)
524newtype Existence = Existence Bool deriving (Eq, Show)
525newtype NullValue = NullValue Bool deriving (Eq, Show)
527unpackId :: DocId -> String
528unpackId (DocId docId) = docId
530instance FromJSON IndexName
531instance FromJSON MappingName
532instance FromJSON DocId
534-- data QueryType = BooleanQueryType
535-- | PhraseQueryType
536-- | PhrasePrefixQueryType deriving (Eq, Show)
537type Boost = Double
539data Query = TermQuery Term (Maybe Boost)
540 | ConstantScoreFilter Filter Boost
541 | ConstantScoreQuery Query Boost
542 deriving (Eq, Show)
544instance ToJSON Query where
545 toJSON (TermQuery (Term termField termValue) boost) =
546 object ["term" .=
547 object [termField .= object merged]]
548 where
549 base = ["value" .= termValue]
550 boosted = case boost of
551 (Just boostValue) -> ["boost" .= boostValue]
552 Nothing -> []
553 merged = mappend base boosted
555data Filter = AndFilter [Filter] Cache
556 | OrFilter [Filter] Cache
557 | NotFilter Filter Cache
558 | IdentityFilter
559 | BoolFilter BoolMatch
560 | ExistsFilter FieldName -- always cached
561 | GeoBoundingBoxFilter GeoBoundingBoxConstraint GeoFilterType
562 | GeoDistanceFilter GeoPoint Distance DistanceType OptimizeBbox Cache
563 | GeoDistanceRangeFilter GeoPoint DistanceRange
564 | GeoPolygonFilter FieldName [LatLon]
565 | IdsFilter MappingName [DocId]
566 | LimitFilter Int
567 | MissingFilter FieldName Existence NullValue
568 | PrefixFilter FieldName PrefixValue Cache
569 | RangeFilter FieldName (Either HalfRange Range) RangeExecution Cache
570 | RegexpFilter FieldName Regexp RegexpFlags CacheName Cache CacheKey
571 deriving (Eq, Show)
573class Monoid a => Seminearring a where
574 -- 0, +, *
575 (<||>) :: a -> a -> a
576 (<&&>) :: a -> a -> a
577 (<&&>) = mappend
579infixr 5 <||>
580infixr 5 <&&>
582instance Monoid Filter where
583 mempty = IdentityFilter
584 mappend a b = AndFilter [a, b] defaultCache
586instance Seminearring Filter where
587 a <||> b = OrFilter [a, b] defaultCache
589instance ToJSON Filter where
590 toJSON (AndFilter filters cache) =
591 object ["and" .= fmap toJSON filters
592 , "_cache" .= cache]
594 toJSON (OrFilter filters cache) =
595 object ["or" .= fmap toJSON filters
596 , "_cache" .= cache]
598 toJSON (NotFilter filter cache) =
599 object ["not" .=
600 object ["filter" .= toJSON filter
601 , "_cache" .= cache]]
603 toJSON (IdentityFilter) =
604 object ["match_all" .= object []]
606 toJSON (ExistsFilter (FieldName fieldName)) =
607 object ["exists" .= object
608 ["field" .= fieldName]]
610 toJSON (BoolFilter boolMatch) =
611 object ["bool" .= toJSON boolMatch]
613 toJSON (GeoBoundingBoxFilter bbConstraint filterType) =
614 object ["geo_bounding_box" .= toJSON bbConstraint
615 , "type" .= toJSON filterType]
617 toJSON (GeoDistanceFilter (GeoPoint (FieldName geoField) latLon)
618 distance distanceType optimizeBbox cache) =
619 object ["geo_distance" .=
620 object ["distance" .= toJSON distance
621 , "distance_type" .= toJSON distanceType
622 , "optimize_bbox" .= optimizeBbox
623 , geoField .= toJSON latLon
624 , "_cache" .= cache]]
626 toJSON (GeoDistanceRangeFilter (GeoPoint (FieldName geoField) latLon)
627 (DistanceRange distanceFrom distanceTo)) =
628 object ["geo_distance_range" .=
629 object ["from" .= toJSON distanceFrom
630 , "to" .= toJSON distanceTo
631 , geoField .= toJSON latLon]]
633 toJSON (GeoPolygonFilter (FieldName geoField) latLons) =
634 object ["geo_polygon" .=
635 object [geoField .=
636 object ["points" .= fmap toJSON latLons]]]
638 toJSON (IdsFilter (MappingName mappingName) values) =
639 object ["ids" .=
640 object ["type" .= mappingName
641 , "values" .= fmap (T.pack . unpackId) values]]
643 toJSON (LimitFilter limit) =
644 object ["limit" .= object ["value" .= limit]]
646 toJSON (MissingFilter (FieldName fieldName) (Existence existence) (NullValue nullValue)) =
647 object ["missing" .=
648 object ["field" .= fieldName
649 , "existence" .= existence
650 , "null_value" .= nullValue]]
652 toJSON (PrefixFilter (FieldName fieldName) fieldValue cache) =
653 object ["prefix" .=
654 object [fieldName .= fieldValue
655 , "_cache" .= cache]]
657 toJSON (RangeFilter (FieldName fieldName) (Left halfRange) rangeExecution cache) =
658 object ["range" .=
659 object [fieldName .=
660 object [key .= val]
661 , "execution" .= toJSON rangeExecution
662 , "_cache" .= cache]]
663 where
664 (key, val) = halfRangeToKV halfRange
666 toJSON (RangeFilter (FieldName fieldName) (Right range) rangeExecution cache) =
667 object ["range" .=
668 object [fieldName .=
669 object [lessKey .= lessVal
670 , greaterKey .= greaterVal]
671 , "execution" .= toJSON rangeExecution
672 , "_cache" .= cache]]
673 where
674 (lessKey, lessVal, greaterKey, greaterVal) = rangeToKV range
676 toJSON (RegexpFilter (FieldName fieldName)
677 (Regexp regexText) flags (CacheName cacheName) cache (CacheKey cacheKey)) =
678 object ["regexp" .=
679 object [fieldName .=
680 object ["value" .= regexText
681 , "flags" .= toJSON flags]
682 , "_name" .= cacheName
683 , "_cache" .= cache
684 , "_cache_key" .= cacheKey]]
686instance ToJSON GeoPoint where
687 toJSON (GeoPoint (FieldName geoField) latLon) =
688 object [geoField .= toJSON latLon]
690showText :: Show a => a -> Text
691showText = T.pack . show
693instance ToJSON Distance where
694 toJSON (Distance coefficient unit) =
695 String boltedTogether where
696 coefText = showText coefficient
697 (String unitText) = (toJSON unit)
698 boltedTogether = mappend coefText unitText
700instance ToJSON DistanceUnit where
701 toJSON Miles = String "mi"
702 toJSON Yards = String "yd"
703 toJSON Feet = String "ft"
704 toJSON Inches = String "in"
705 toJSON Kilometers = String "km"
706 toJSON Meters = String "m"
707 toJSON Centimeters = String "cm"
708 toJSON Millimeters = String "mm"
709 toJSON NauticalMiles = String "nmi"
711instance ToJSON DistanceType where
712 toJSON Arc = String "arc"
713 toJSON SloppyArc = String "sloppy_arc"
714 toJSON Plane = String "plane"
716instance ToJSON OptimizeBbox where
717 toJSON NoOptimizeBbox = String "none"
718 toJSON (OptimizeGeoFilterType gft) = toJSON gft
720instance ToJSON GeoBoundingBoxConstraint where
721 toJSON (GeoBoundingBoxConstraint (FieldName geoBBField) constraintBox cache) =
722 object [geoBBField .= toJSON constraintBox
723 , "_cache" .= cache]
725instance ToJSON GeoFilterType where
726 toJSON GeoFilterMemory = String "memory"
727 toJSON GeoFilterIndexed = String "indexed"
729instance ToJSON GeoBoundingBox where
730 toJSON (GeoBoundingBox topLeft bottomRight) =
731 object ["top_left" .= toJSON topLeft
732 , "bottom_right" .= toJSON bottomRight]
734instance ToJSON LatLon where
735 toJSON (LatLon lat lon) =
736 object ["lat" .= lat
737 , "lon" .= lon]
739-- lt, lte | gt, gte
740newtype LessThan = LessThan Double deriving (Eq, Show)
741newtype LessThanEq = LessThanEq Double deriving (Eq, Show)
742newtype GreaterThan = GreaterThan Double deriving (Eq, Show)
743newtype GreaterThanEq = GreaterThanEq Double deriving (Eq, Show)
745data HalfRange = HalfRangeLt LessThan
746 | HalfRangeLte LessThanEq
747 | HalfRangeGt GreaterThan
748 | HalfRangeGte GreaterThanEq deriving (Eq, Show)
750data Range = RangeLtGt LessThan GreaterThan
751 | RangeLtGte LessThan GreaterThanEq
752 | RangeLteGt LessThanEq GreaterThan
753 | RangeLteGte LessThanEq GreaterThanEq deriving (Eq, Show)
755halfRangeToKV :: HalfRange -> (Text, Double)
756halfRangeToKV (HalfRangeLt (LessThan n)) = ("lt", n)
757halfRangeToKV (HalfRangeLte (LessThanEq n)) = ("lte", n)
758halfRangeToKV (HalfRangeGt (GreaterThan n)) = ("gt", n)
759halfRangeToKV (HalfRangeGte (GreaterThanEq n)) = ("gte", n)
761rangeToKV :: Range -> (Text, Double, Text, Double)
762rangeToKV (RangeLtGt (LessThan m) (GreaterThan n)) = ("lt", m, "gt", n)
763rangeToKV (RangeLtGte (LessThan m) (GreaterThanEq n)) = ("lt", m, "gte", n)
764rangeToKV (RangeLteGt (LessThanEq m) (GreaterThan n)) = ("lte", m, "gt", n)
765rangeToKV (RangeLteGte (LessThanEq m) (GreaterThanEq n)) = ("lte", m, "gte", n)
767data RangeExecution = RangeExecutionIndex
768 | RangeExecutionFielddata deriving (Eq, Show)
770-- index for smaller ranges, fielddata for longer ranges
771instance ToJSON RangeExecution where
772 toJSON RangeExecutionIndex = "index"
773 toJSON RangeExecutionFielddata = "fielddata"
775newtype Regexp = Regexp Text deriving (Eq, Show)
776data RegexpFlags = RegexpAll
777 | Complement
778 | Interval
779 | Intersection
780 | AnyString
781 | CompInterval
782 | CompIntersection
783 | CompAnyString
784 | IntervalIntersection
785 | IntervalAnyString
786 | IntersectionAnyString deriving (Eq, Show)
788instance ToJSON RegexpFlags where
789 toJSON RegexpAll = String "ALL"
790 toJSON Complement = String "COMPLEMENT"
791 toJSON Interval = String "INTERVAL"
792 toJSON Intersection = String "INTERSECTION"
793 toJSON AnyString = String "ANYSTRING"
794 toJSON CompInterval = String "COMPLEMENT|INTERVAL"
795 toJSON CompIntersection = String "COMPLEMENT|INTERSECTION"
796 toJSON CompAnyString = String "COMPLEMENT|ANYSTRING"
797 toJSON IntervalIntersection = String "INTERVAL|INTERSECTION"
798 toJSON IntervalAnyString = String "INTERVAL|ANYSTRING"
799 toJSON IntersectionAnyString = String "INTERSECTION|ANYSTRING"
801-- phew. Coulda used Agda style case breaking there but, you know, whatever. :)
803data Term = Term { termField :: Text
804 , termValue :: Text } deriving (Eq, Show)
806instance ToJSON Term where
807 toJSON (Term field value) = object ["term" .= object
808 [field .= value]]
810data BoolMatch = MustMatch Term Cache
811 | MustNotMatch Term Cache
812 | ShouldMatch [Term] Cache deriving (Eq, Show)
814instance ToJSON BoolMatch where
815 toJSON (MustMatch term cache) = object ["must" .= toJSON term,
816 "_cache" .= cache]
817 toJSON (MustNotMatch term cache) = object ["must_not" .= toJSON term,
818 "_cache" .= cache]
819 toJSON (ShouldMatch terms cache) = object ["should" .= fmap toJSON terms,
820 "_cache" .= cache]
822-- "memory" or "indexed"
823data GeoFilterType = GeoFilterMemory
824 | GeoFilterIndexed deriving (Eq, Show)
827data LatLon = LatLon { lat :: Double
828 , lon :: Double } deriving (Eq, Show)
830data GeoBoundingBox =
831 GeoBoundingBox { topLeft :: LatLon
832 , bottomRight :: LatLon } deriving (Eq, Show)
834data GeoBoundingBoxConstraint =
835 GeoBoundingBoxConstraint { geoBBField :: FieldName
836 , constraintBox :: GeoBoundingBox
837 , bbConstraintcache :: Cache
838 } deriving (Eq, Show)
840data GeoPoint =
841 GeoPoint { geoField :: FieldName
842 , latLon :: LatLon} deriving (Eq, Show)
844data DistanceUnit = Miles
845 | Yards
846 | Feet
847 | Inches
848 | Kilometers
849 | Meters
850 | Centimeters
851 | Millimeters
852 | NauticalMiles deriving (Eq, Show)
854data DistanceType = Arc
855 | SloppyArc -- doesn't exist <1.0
856 | Plane deriving (Eq, Show)
858data OptimizeBbox = OptimizeGeoFilterType GeoFilterType
859 | NoOptimizeBbox deriving (Eq, Show)
861data Distance =
862 Distance { coefficient :: Double
863 , unit :: DistanceUnit } deriving (Eq, Show)
865data DistanceRange =
866 DistanceRange { distanceFrom :: Distance
867 , distanceTo :: Distance } deriving (Eq, Show)
869data FromJSON a => SearchResult a =
870 SearchResult { took :: Int
871 , timedOut :: Bool
872 , shards :: ShardResult
873 , searchHits :: SearchHits a } deriving (Eq, Show)
875type Score = Double
877data FromJSON a => SearchHits a =
878 SearchHits { hitsTotal :: Int
879 , maxScore :: Score
880 , hits :: [Hit a] } deriving (Eq, Show)
882data FromJSON a => Hit a =
883 Hit { hitIndex :: IndexName
884 , hitType :: MappingName
885 , hitDocId :: DocId
886 , hitScore :: Score
887 , hitSource :: a } deriving (Eq, Show)
889data ShardResult =
890 ShardResult { shardTotal :: Int
891 , shardsSuccessful :: Int
892 , shardsFailed :: Int } deriving (Eq, Show, Generic)
894instance (FromJSON a, ToJSON a) => FromJSON (SearchResult a) where
895 parseJSON (Object v) = SearchResult <$>
896 v .: "took" <*>
897 v .: "timed_out" <*>
898 v .: "_shards" <*>
899 v .: "hits"
900 parseJSON _ = empty
902instance (FromJSON a, ToJSON a) => FromJSON (SearchHits a) where
903 parseJSON (Object v) = SearchHits <$>
904 v .: "total" <*>
905 v .: "max_score" <*>
906 v .: "hits"
907 parseJSON _ = empty
909instance (FromJSON a, ToJSON a) => FromJSON (Hit a) where
910 parseJSON (Object v) = Hit <$>
911 v .: "_index" <*>
912 v .: "_type" <*>
913 v .: "_id" <*>
914 v .: "_score" <*>
915 v .: "_source"
916 parseJSON _ = empty
918instance FromJSON ShardResult where
919 parseJSON (Object v) = ShardResult <$>
920 v .: "total" <*>
921 v .: "successful" <*>
922 v .: "failed"
923 parseJSON _ = empty