git.iko.soy/typeable/bloodhound
on d4fe69c help sign in
typeable/bloodhound/Database/Bloodhound/Client.hs
453 lines 16 kB history raw
1{-# LANGUAGE DeriveGeneric #-}
3module Database.Bloodhound.Client
4 ( createIndex
5 , deleteIndex
6 , IndexSettings(..)
7 , Server(..)
8 , defaultIndexSettings
9 , indexDocument
10 , getDocument
11 , documentExists
12 , deleteDocument
13 , EsResult(..)
14 )
15 where
17import Control.Applicative
18import Control.Monad (liftM)
19import Data.Aeson
20import Data.Aeson.TH (deriveJSON)
21import qualified Data.ByteString.Lazy.Char8 as L
22import Data.List (intercalate)
23import Data.Maybe (fromMaybe)
24import Data.Text (Text)
25import Data.Time.Clock (UTCTime)
26import GHC.Generics (Generic)
27import Network.HTTP.Conduit
28import qualified Network.HTTP.Types.Method as NHTM
29import qualified Network.HTTP.Types.Status as NHTS
31data Version = Version { number :: Text
32 , build_hash :: Text
33 , build_timestamp :: UTCTime
34 , build_snapshot :: Bool
35 , lucene_version :: Text } deriving (Show, Generic)
37data (FromJSON a, ToJSON a) => Status a =
38 Status { ok :: Bool
39 , status :: Int
40 , name :: Text
41 , version :: a
42 , tagline :: Text } deriving (Show)
44instance ToJSON Version
45instance FromJSON Version
47instance (FromJSON a, ToJSON a) => FromJSON (Status a) where
48 parseJSON (Object v) = Status <$>
49 v .: "ok" <*>
50 v .: "status" <*>
51 v .: "name" <*>
52 v .: "version" <*>
53 v .: "tagline"
54 parseJSON _ = empty
56-- instance ToJSON (Status a)
57-- instance FromJSON (Status a)
59-- bloo <- (liftM responseBody $ parseUrl "http://localhost:9200/" >>= \r -> withManager (httpLbs r))
61-- rootPath :: String
62-- rootPath = rollUp $ ["/"]
64-- -- Kinda hate this.
65-- pathFromType :: String -> String -> String
66-- pathFromType index docType = "/" ++ index ++ docType
68-- -- Kinda hate this too.
69-- rollUp :: [String] -> String
70-- rollUp = Prelude.concat
72main = simpleHttp "http://localhost:9200/events/event/_search?q=hostname:localhost&size=1" >>= L.putStrLn
74-- data Response = Response { blah :: Text } deriving (Show)
76-- indexDocument :: ToJSON a => a -> IO Response
77-- indexDocument doc = ToJSON a
79-- nomenclature is because you're dropping the type baggage. All of this is compile-time erased.
80-- newtype ShardCount = ShardCount { unShardCount :: Int } deriving (Show, Generic)
81-- newtype ReplicaCount = ReplicaCount { unReplicaCount :: Int } deriving (Show, Generic)
83newtype ShardCount = ShardCount Int deriving (Show, Generic)
84newtype ReplicaCount = ReplicaCount Int deriving (Show, Generic)
86mkShardCount :: Int -> Maybe ShardCount
87mkShardCount n
88 | n < 1 = Nothing
89 | n > 1000 = Nothing -- seriously, what the fuck?
90 | otherwise = Just (ShardCount n)
92mkReplicaCount :: Int -> Maybe ReplicaCount
93mkReplicaCount n
94 | n < 1 = Nothing
95 | n > 1000 = Nothing -- ...
96 | otherwise = Just (ReplicaCount n)
98-- IndexSettings <$> mkShardCount 10 <*> mkReplicaCount 20
100data IndexSettings =
101 IndexSettings { indexShards :: ShardCount
102 , indexReplicas :: ReplicaCount } deriving (Show)
104instance ToJSON IndexSettings where
105 toJSON (IndexSettings s r) = object ["settings" .= object ["shards" .= s, "replicas" .= r]]
107instance ToJSON ReplicaCount
108instance ToJSON ShardCount
110defaultIndexSettings = IndexSettings (ShardCount 3) (ReplicaCount 2)
112data Strategy = RoundRobinStrat | RandomStrat | HeadStrat deriving (Show)
114newtype Server = Server String deriving (Show)
116-- data Errors = IndexAlreadyExistsError | GenericError deriving (Show)
118-- data ElasticsearchError = ElasticsearchError
119-- { status :: Int
120-- , error :: Text } deriving (Show, Generic)
122-- instance FromJSON ElasticsearchError
124-- errorForResponse resp = do
125-- let (sts, err) = decode (responseBody resp) :: ElasticsearchError
126-- if T.isInfixOf "IndexAlreadyExistsException" error
127-- then IndexAlreadyExistsError
128-- else
130type Reply = Network.HTTP.Conduit.Response L.ByteString
131type Method = NHTM.Method
133responseIsError :: Reply -> Bool
134responseIsError resp = NHTS.statusCode (responseStatus resp) > 299
136emptyBody = L.pack ""
138dispatch :: String -> Method -> Maybe L.ByteString
139 -> IO Reply
140dispatch url method body = do
141 initReq <- parseUrl url
142 let reqBody = RequestBodyLBS $ fromMaybe emptyBody body
143 let req = initReq { method = method
144 , requestBody = reqBody
145 , checkStatus = \_ _ _ -> Nothing}
146 withManager $ httpLbs req
148type IndexName = String
150joinPath :: [String] -> String
151joinPath = intercalate "/"
153getStatus :: Server -> IO (Maybe (Status Version))
154getStatus (Server server) = do
155 request <- parseUrl $ joinPath [server]
156 response <- withManager $ httpLbs request
157 return $ decode (responseBody response)
159createIndex :: Server -> IndexSettings -> IndexName -> IO Reply
160createIndex (Server server) indexSettings indexName =
161 dispatch url method body where
162 url = joinPath [server, indexName]
163 method = NHTM.methodPut
164 body = Just $ encode indexSettings
166deleteIndex :: Server -> IndexName -> IO Reply
167deleteIndex (Server server) indexName =
168 dispatch url method body where
169 url = joinPath [server, indexName]
170 method = NHTM.methodDelete
171 body = Nothing
173respIsTwoHunna :: Reply -> Bool
174respIsTwoHunna resp = NHTS.statusCode (responseStatus resp) == 200
176existentialQuery url = do
177 reply <- dispatch url NHTM.methodHead Nothing
178 return (reply, respIsTwoHunna reply)
180indexExists :: Server -> IndexName -> IO Bool
181indexExists (Server server) indexName = do
182 (reply, exists) <- existentialQuery url
183 return exists where
184 url = joinPath [server, indexName]
186data OpenCloseIndex = OpenIndex | CloseIndex deriving (Show)
188stringifyOCIndex oci = case oci of
189 OpenIndex -> "_open"
190 CloseIndex -> "_close"
192openOrCloseIndexes :: OpenCloseIndex -> Server -> IndexName -> IO Reply
193openOrCloseIndexes oci (Server server) indexName =
194 dispatch url method body where
195 ociString = stringifyOCIndex oci
196 url = joinPath [server, indexName, ociString]
197 method = NHTM.methodPost
198 body = Nothing
200openIndex :: Server -> IndexName -> IO Reply
201openIndex = openOrCloseIndexes OpenIndex
203closeIndex :: Server -> IndexName -> IO Reply
204closeIndex = openOrCloseIndexes CloseIndex
206type MappingName = String
208createMapping :: ToJSON a => Server -> IndexName
209 -> MappingName -> a -> IO Reply
210createMapping (Server server) indexName mappingName mapping =
211 dispatch url method body where
212 url = joinPath [server, indexName, mappingName, "_mapping"]
213 method = NHTM.methodPut
214 body = Just $ encode mapping
216deleteMapping :: Server -> IndexName -> MappingName -> IO Reply
217deleteMapping (Server server) indexName mappingName =
218 dispatch url method body where
219 url = joinPath [server, indexName, mappingName, "_mapping"]
220 method = NHTM.methodDelete
221 body = Nothing
223type DocumentID = String
225indexDocument :: ToJSON doc => Server -> IndexName -> MappingName
226 -> doc -> DocumentID -> IO Reply
227indexDocument (Server server) indexName mappingName document docId =
228 dispatch url method body where
229 url = joinPath [server, indexName, mappingName, docId]
230 method = NHTM.methodPut
231 body = Just (encode document)
233deleteDocument :: Server -> IndexName -> MappingName
234 -> DocumentID -> IO Reply
235deleteDocument (Server server) indexName mappingName docId =
236 dispatch url method body where
237 url = joinPath [server, indexName, mappingName, docId]
238 method = NHTM.methodDelete
239 body = Nothing
241data EsResult a = EsResult { _index :: Text
242 , _type :: Text
243 , _id :: Text
244 , _version :: Int
245 , found :: Bool
246 , _source :: a } deriving (Eq, Show)
248instance (FromJSON a, ToJSON a) => FromJSON (EsResult a) where
249 parseJSON (Object v) = EsResult <$>
250 v .: "_index" <*>
251 v .: "_type" <*>
252 v .: "_id" <*>
253 v .: "_version" <*>
254 v .: "found" <*>
255 v .: "_source"
256 parseJSON _ = empty
258getDocument :: Server -> IndexName -> MappingName
259 -> DocumentID -> IO Reply
260getDocument (Server server) indexName mappingName docId =
261 dispatch url method body where
262 url = joinPath [server, indexName, mappingName, docId]
263 method = NHTM.methodGet
264 body = Nothing
266documentExists :: Server -> IndexName -> MappingName
267 -> DocumentID -> IO Bool
268documentExists (Server server) indexName mappingName docId = do
269 (reply, exists) <- existentialQuery url
270 return exists where
271 url = joinPath [server, indexName, mappingName, docId]
273-- data Analyzer = AStandardAnalyzer StandardAnalyzer
274-- | SimpleAnalyzer -- just "simple"
275-- | WhitespaceAnalyzer
276-- | StopAnalyzer
277-- | KeywordAnalyzer
278-- | PatternAnalyzer
279-- | LanguageAnalyzer
280-- | SnowballAnalyzer
281-- | CustomAnalyzer
283-- data StandardAnalyzer =
284-- StandardAnalyzer
285-- { stopwords :: Maybe [Text] -- default []
286-- , max_token_length :: Maybe Int -- default 255
287-- }
289-- DefaultField -> "default_field": ""
290-- Fields -> "fields": []
292type QueryString = Text
293-- status:active
294-- author:"John Smith"
295-- for book.title and book.date containing quick OR brown, book.\*:(quick brown)
296-- field title has no value or doesn't exist, _missing_:title
297-- field title has any non-null value, _exists:title
299data BooleanOperator = AND | OR deriving (Show)
301type DisMax = Bool -- "use_dis_max"
302newtype TieBreaker = TieBreaker Int deriving (Show)
303data QueryField = DefaultField Text | Fields [Text] DisMax TieBreaker deriving (Show)
305data QueryStringQuery =
306 QueryStringQuery { query :: QueryString
307 , field :: Maybe QueryField -- default _all
308 , defaultOperator :: Maybe BooleanOperator -- default OR
309 , analyzer :: Maybe Text -- analyzer name
310 , allowLeadingWildcard :: Maybe Bool -- default true
311 , lowercaseExpandedTerms :: Maybe Bool -- default true
312 , enablePositionIncrements :: Maybe Bool -- default true
313 , fuzzyMaxExpansions :: Maybe Int -- default 50
314 , fuzziness :: Maybe Text -- Fuzziness -- default AUTO, add type later
315 , fuzzyPrefixLength :: Maybe Int -- default 0
316 , phraseSlop :: Maybe Int -- default 0, 0 means exact phrase matches
317 , boost :: Maybe Double -- default 1.0
318 , analyzeWildcard :: Maybe Bool -- default false, true forces wildcard analysis
319 , autoGeneratePhraseQueries :: Maybe Bool -- default false
320 , minimumShouldMatch :: Maybe Text -- # "should" clauses in the boolean query should match
321 -- Text to handle weird % and other cases. Needs type
322 , lenient :: Maybe Bool -- default false, true shuts off format based failures
323 , locale :: Maybe Text -- default ROOT, locale used for string conversions
324 } deriving (Show)
326emptyQueryStringQuery = QueryStringQuery "" Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing
327queryStringQuery query = emptyQueryStringQuery { query = query }
329-- ugh
330type FieldName = Text
332type Cache = Bool -- caching on/off
333data Filter = AndFilter [Filter] Cache
334 | OrFilter [Filter] Cache
335 | BoolFilter BoolMatch Cache
336 | ExistsFilter FieldName -- always cached
337 | GeoBoundingBoxFilter GeoBoundingBoxConstraint GeoFilterType Cache
338 | GeoDistanceFilter GeoConstraint Distance Cache
339 deriving (Show)
341instance ToJSON Filter where
342 toJSON (AndFilter filters cache) =
343 object ["and" .= fmap toJSON filters
344 , "_cache" .= cache]
345 toJSON (OrFilter filters cache) =
346 object ["or" .= fmap toJSON filters
347 , "_cache" .= cache]
348 toJSON (ExistsFilter fieldName) =
349 object ["exists" .= object
350 ["field" .= fieldName]]
351 toJSON (BoolFilter boolMatch cache) =
352 object ["bool" .= toJSON boolMatch
353 , "_cache" .= cache]
355-- I dunno.
356data Term = Term { termField :: Text
357 , termValue :: Text } deriving (Show)
359instance ToJSON Term where
360 toJSON (Term field value) = object ["term" .= object
361 [field .= value]]
363data BoolMatch = MustMatch Term
364 | MustNotMatch Term
365 | ShouldMatch [Term] deriving (Show)
367instance ToJSON BoolMatch where
368 toJSON (MustMatch term) = object ["must" .= toJSON term]
369 toJSON (MustNotMatch term) = object ["must_not" .= toJSON term]
370 toJSON (ShouldMatch terms) = object ["should" .= fmap toJSON terms]
372-- "memory" or "indexed"
373data GeoFilterType = GeoFilterMemory | GeoFilterIndexed deriving (Show)
375data LatLon = LatLon { lat :: Double, lon :: Double } deriving (Show)
376data GeoBoundingBox =
377 GeoBoundingBox { topLeft :: LatLon
378 , bottomRight :: LatLon } deriving (Show)
380data GeoBoundingBoxConstraint =
381 GeoBoundingBoxConstraint { geoBBField :: FieldName
382 , constraintBox :: GeoBoundingBox
383 } deriving (Show)
385data GeoConstraint =
386 GeoConstraint { geoField :: FieldName
387 , latLon :: LatLon } deriving (Show)
389data DistanceUnits = Miles
390 | Yards
391 | Feet
392 | Inches
393 | Kilometers
394 | Meters
395 | Centimeters
396 | Millimeters
397 | NauticalMiles deriving (Show)
399data DistanceType = Arc | SloppyArc | Plane deriving (Show)
401-- geo_point?
402data OptimizeBbox = GeoFilterType | NoOptimizeBbox deriving (Show)
404data Distance =
405 Distance { coefficient :: Double
406 , unit :: DistanceUnits } deriving (Show)
408data FromJSON a => SearchResults a =
409 SearchResults { took :: Int
410 , timedOut :: Bool
411 , shards :: ShardResults
412 , searchHits :: SearchHits a } deriving (Show)
414type Score = Double
416data FromJSON a => SearchHits a =
417 SearchHits { hitsTotal :: Int
418 , maxScore :: Score
419 , hits :: [Hits a] } deriving (Show)
421data FromJSON a => Hits a =
422 Hits { hitsIndex :: IndexName
423 , hitsType :: MappingName
424 , hitDocumentID :: DocumentID
425 , hitScore :: Score
426 , hitSource :: a } deriving (Show)
428data ShardResults =
429 ShardResults { shardTotal :: Int
430 , shardsSuccessful :: Int
431 , shardsFailed :: Int } deriving (Show)
433-- This is turning into a fractal of horror
434-- data Fuzziness = FDateFuzziness DateFuzziness |
436-- data Query = Query { query :: () } deriving (Show)
437-- search :: Server -> IndexName -> Maybe MappingName
438-- -> Query -> IO Reply
439-- search = fuck
441-- getStatus :: String -> IO (Maybe (Status Version))
442-- getStatus server = do
443-- request <- parseUrl $ server ++ rootPath
444-- response <- withManager $ httpLbs request
445-- return $ (decode $ responseBody response)
447-- mkServer -- (Maybe Server) for URL parsing?
449-- data Cluster = Cluster { targets :: [Server]
450-- , strategy :: Strategy } deriving (Show)
452-- target :: Cluster -> Server
453-- target (Cluster targets HeadStrat) = head targets