git.iko.soy/typeable/bloodhound
on d28751d help sign in
typeable/bloodhound/Database/Bloodhound/Client.hs
259 lines 9.5 kB history raw
1module Database.Bloodhound.Client
2 ( createIndex
3 , deleteIndex
4 , indexExists
5 , openIndex
6 , closeIndex
7 , putMapping
8 , deleteMapping
9 , indexDocument
10 , getDocument
11 , documentExists
12 , deleteDocument
13 , searchAll
14 , searchByIndex
15 , searchByType
16 , refreshIndex
17 , mkSearch
18 , mkAggregateSearch
19 , mkHighlightSearch
20 , bulk
21 , pageSearch
22 , mkShardCount
23 , mkReplicaCount
24 , getStatus
25 )
26 where
28import Data.Aeson
29import Data.ByteString.Builder
30import qualified Data.ByteString.Lazy.Char8 as L
31import Data.List (foldl', intercalate, intersperse)
32import Data.Maybe (fromMaybe)
33import Data.Text (Text)
34import Network.HTTP.Client
35import qualified Network.HTTP.Types.Method as NHTM
36import qualified Network.HTTP.Types.Status as NHTS
37import Prelude hiding (filter, head)
39import Database.Bloodhound.Types
41-- find way to avoid destructuring Servers and Indexes?
42-- make get, post, put, delete helpers.
43-- make dispatch take URL last for better variance and
44-- utilization of partial application
46mkShardCount :: Int -> Maybe ShardCount
47mkShardCount n
48 | n < 1 = Nothing
49 | n > 1000 = Nothing -- seriously, what the fuck?
50 | otherwise = Just (ShardCount n)
52mkReplicaCount :: Int -> Maybe ReplicaCount
53mkReplicaCount n
54 | n < 1 = Nothing
55 | n > 1000 = Nothing -- ...
56 | otherwise = Just (ReplicaCount n)
58emptyBody :: L.ByteString
59emptyBody = L.pack ""
61dispatch :: Method -> String -> Maybe L.ByteString
62 -> IO Reply
63dispatch dMethod url body = do
64 initReq <- parseUrl url
65 let reqBody = RequestBodyLBS $ fromMaybe emptyBody body
66 let req = initReq { method = dMethod
67 , requestBody = reqBody
68 , checkStatus = \_ _ _ -> Nothing}
69 withManager defaultManagerSettings $ httpLbs req
71joinPath :: [String] -> String
72joinPath = intercalate "/"
74-- Shortcut functions for HTTP methods
75delete :: String -> IO Reply
76delete = flip (dispatch NHTM.methodDelete) Nothing
77get :: String -> IO Reply
78get = flip (dispatch NHTM.methodGet) Nothing
79head :: String -> IO Reply
80head = flip (dispatch NHTM.methodHead) Nothing
81put :: String -> Maybe L.ByteString -> IO Reply
82put = dispatch NHTM.methodPost
83post :: String -> Maybe L.ByteString -> IO Reply
84post = dispatch NHTM.methodPost
86-- indexDocument s ix name doc = put (root </> s </> ix </> name </> doc) (Just encode doc)
87-- http://hackage.haskell.org/package/http-client-lens-0.1.0/docs/Network-HTTP-Client-Lens.html
88-- https://github.com/supki/libjenkins/blob/master/src/Jenkins/Rest/Internal.hs
90getStatus :: Server -> IO (Maybe Status)
91getStatus (Server server) = do
92 request <- parseUrl $ joinPath [server]
93 response <- withManager defaultManagerSettings $ httpLbs request
94 return $ decode (responseBody response)
96createIndex :: Server -> IndexSettings -> IndexName -> IO Reply
97createIndex (Server server) indexSettings (IndexName indexName) =
98 put url body
99 where url = joinPath [server, indexName]
100 body = Just $ encode indexSettings
102deleteIndex :: Server -> IndexName -> IO Reply
103deleteIndex (Server server) (IndexName indexName) =
104 delete $ joinPath [server, indexName]
106respIsTwoHunna :: Reply -> Bool
107respIsTwoHunna resp = NHTS.statusCode (responseStatus resp) == 200
109existentialQuery :: String -> IO (Reply, Bool)
110existentialQuery url = do
111 reply <- head url
112 return (reply, respIsTwoHunna reply)
114indexExists :: Server -> IndexName -> IO Bool
115indexExists (Server server) (IndexName indexName) = do
116 (_, exists) <- existentialQuery url
117 return exists
118 where url = joinPath [server, indexName]
120refreshIndex :: Server -> IndexName -> IO Reply
121refreshIndex (Server server) (IndexName indexName) =
122 post url Nothing
123 where url = joinPath [server, indexName, "_refresh"]
125stringifyOCIndex :: OpenCloseIndex -> String
126stringifyOCIndex oci = case oci of
127 OpenIndex -> "_open"
128 CloseIndex -> "_close"
130openOrCloseIndexes :: OpenCloseIndex -> Server -> IndexName -> IO Reply
131openOrCloseIndexes oci (Server server) (IndexName indexName) =
132 post url Nothing
133 where ociString = stringifyOCIndex oci
134 url = joinPath [server, indexName, ociString]
136openIndex :: Server -> IndexName -> IO Reply
137openIndex = openOrCloseIndexes OpenIndex
139closeIndex :: Server -> IndexName -> IO Reply
140closeIndex = openOrCloseIndexes CloseIndex
142{-| putMapping is an HTTP PUT and has upsert semantics. Mappings are schemas
143 for documents in indexes.
144-}
145putMapping :: ToJSON a => Server -> IndexName
146 -> MappingName -> a -> IO Reply
147putMapping (Server server) (IndexName indexName) (MappingName mappingName) mapping =
148 put url body
149 where url = joinPath [server, indexName, mappingName, "_mapping"]
150 body = Just $ encode mapping
152deleteMapping :: Server -> IndexName -> MappingName -> IO Reply
153deleteMapping (Server server) (IndexName indexName)
154 (MappingName mappingName) =
155 delete $ joinPath [server, indexName, mappingName, "_mapping"]
157indexDocument :: ToJSON doc => Server -> IndexName -> MappingName
158 -> doc -> DocId -> IO Reply
159indexDocument (Server server) (IndexName indexName)
160 (MappingName mappingName) document (DocId docId) =
161 put url body
162 where url = joinPath [server, indexName, mappingName, docId]
163 body = Just (encode document)
165deleteDocument :: Server -> IndexName -> MappingName
166 -> DocId -> IO Reply
167deleteDocument (Server server) (IndexName indexName)
168 (MappingName mappingName) (DocId docId) =
169 delete $ joinPath [server, indexName, mappingName, docId]
171bulk :: Server -> [BulkOperation] -> IO Reply
172bulk (Server server) bulkOps = post url body where
173 url = joinPath [server, "_bulk"]
174 body = Just $ collapseStream bulkOps
176collapseStream :: [BulkOperation] -> L.ByteString
177collapseStream stream = collapsed where
178 blobs = intersperse "\n" $ concat $ fmap getStreamChunk stream
179 mashedTaters = mash (mempty :: Builder) blobs
180 collapsed = toLazyByteString $ mappend mashedTaters (byteString "\n")
182mash :: Builder -> [L.ByteString] -> Builder
183mash = foldl' (\b x -> mappend b (lazyByteString x))
185mkMetadataValue :: Text -> String -> String -> String -> Value
186mkMetadataValue operation indexName mappingName docId =
187 object [operation .=
188 object [ "_index" .= indexName
189 , "_type" .= mappingName
190 , "_id" .= docId]]
192getStreamChunk :: BulkOperation -> [L.ByteString]
193getStreamChunk (BulkIndex (IndexName indexName)
194 (MappingName mappingName)
195 (DocId docId) value) = blob where
196 metadata = mkMetadataValue "index" indexName mappingName docId
197 blob = [encode metadata, encode value]
199getStreamChunk (BulkCreate (IndexName indexName)
200 (MappingName mappingName)
201 (DocId docId) value) = blob where
202 metadata = mkMetadataValue "create" indexName mappingName docId
203 blob = [encode metadata, encode value]
205getStreamChunk (BulkDelete (IndexName indexName)
206 (MappingName mappingName)
207 (DocId docId)) = blob where
208 metadata = mkMetadataValue "delete" indexName mappingName docId
209 blob = [encode metadata]
211getStreamChunk (BulkUpdate (IndexName indexName)
212 (MappingName mappingName)
213 (DocId docId) value) = blob where
214 metadata = mkMetadataValue "update" indexName mappingName docId
215 doc = object ["doc" .= value]
216 blob = [encode metadata, encode doc]
218getDocument :: Server -> IndexName -> MappingName
219 -> DocId -> IO Reply
220getDocument (Server server) (IndexName indexName)
221 (MappingName mappingName) (DocId docId) =
222 get $ joinPath [server, indexName, mappingName, docId]
224documentExists :: Server -> IndexName -> MappingName
225 -> DocId -> IO Bool
226documentExists (Server server) (IndexName indexName)
227 (MappingName mappingName) (DocId docId) = do
228 (_, exists) <- existentialQuery url
229 return exists where
230 url = joinPath [server, indexName, mappingName, docId]
232dispatchSearch :: String -> Search -> IO Reply
233dispatchSearch url search = post url (Just (encode search))
235searchAll :: Server -> Search -> IO Reply
236searchAll (Server server) = dispatchSearch url where
237 url = joinPath [server, "_search"]
239searchByIndex :: Server -> IndexName -> Search -> IO Reply
240searchByIndex (Server server) (IndexName indexName) = dispatchSearch url where
241 url = joinPath [server, indexName, "_search"]
243searchByType :: Server -> IndexName -> MappingName -> Search -> IO Reply
244searchByType (Server server) (IndexName indexName)
245 (MappingName mappingName) = dispatchSearch url where
246 url = joinPath [server, indexName, mappingName, "_search"]
248mkSearch :: Maybe Query -> Maybe Filter -> Search
249mkSearch query filter = Search query filter Nothing Nothing Nothing False 0 10
251mkAggregateSearch :: Maybe Query -> Aggregations -> Search
252mkAggregateSearch query aggregations = Search query Nothing Nothing (Just aggregations) Nothing False 0 0
255mkHighlightSearch :: Maybe Query -> Highlights -> Search
256mkHighlightSearch query searchHighlights = Search query Nothing Nothing Nothing (Just searchHighlights) False 0 10
258pageSearch :: Int -> Int -> Search -> Search
259pageSearch pageFrom pageSize search = search { from = pageFrom, size = pageSize }