git.iko.soy/typeable/bloodhound
on 6a04d9d help sign in
typeable/bloodhound/Database/Bloodhound/Client.hs
258 lines 9.3 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 , bulk
20 , pageSearch
21 , mkShardCount
22 , mkReplicaCount
23 , getStatus
24 , encodeBulkOperations
25 , encodeBulkOperation
26 )
27 where
29import Data.Aeson
30import qualified Data.ByteString.Lazy.Char8 as L
31import Data.ByteString.Builder
32import Data.List (intercalate)
33import Data.Maybe (fromMaybe)
34import Data.Text (Text)
35import qualified Data.Vector as V
36import Network.HTTP.Client
37import qualified Network.HTTP.Types.Method as NHTM
38import qualified Network.HTTP.Types.Status as NHTS
39import Prelude hiding (head, filter)
41import Database.Bloodhound.Types
43-- find way to avoid destructuring Servers and Indexes?
44-- make get, post, put, delete helpers.
45-- make dispatch take URL last for better variance and
46-- utilization of partial application
48mkShardCount :: Int -> Maybe ShardCount
49mkShardCount n
50 | n < 1 = Nothing
51 | n > 1000 = Nothing -- seriously, what the fuck?
52 | otherwise = Just (ShardCount n)
54mkReplicaCount :: Int -> Maybe ReplicaCount
55mkReplicaCount n
56 | n < 1 = Nothing
57 | n > 1000 = Nothing -- ...
58 | otherwise = Just (ReplicaCount n)
60emptyBody :: L.ByteString
61emptyBody = L.pack ""
63dispatch :: Method -> String -> Maybe L.ByteString
64 -> IO Reply
65dispatch dMethod url body = do
66 initReq <- parseUrl url
67 let reqBody = RequestBodyLBS $ fromMaybe emptyBody body
68 let req = initReq { method = dMethod
69 , requestBody = reqBody
70 , checkStatus = \_ _ _ -> Nothing}
71 withManager defaultManagerSettings $ httpLbs req
73joinPath :: [String] -> String
74joinPath = intercalate "/"
76-- Shortcut functions for HTTP methods
77delete :: String -> IO Reply
78delete = flip (dispatch NHTM.methodDelete) Nothing
79get :: String -> IO Reply
80get = flip (dispatch NHTM.methodGet) Nothing
81head :: String -> IO Reply
82head = flip (dispatch NHTM.methodHead) Nothing
83put :: String -> Maybe L.ByteString -> IO Reply
84put = dispatch NHTM.methodPost
85post :: String -> Maybe L.ByteString -> IO Reply
86post = dispatch NHTM.methodPost
88-- indexDocument s ix name doc = put (root </> s </> ix </> name </> doc) (Just encode doc)
89-- http://hackage.haskell.org/package/http-client-lens-0.1.0/docs/Network-HTTP-Client-Lens.html
90-- https://github.com/supki/libjenkins/blob/master/src/Jenkins/Rest/Internal.hs
92getStatus :: Server -> IO (Maybe Status)
93getStatus (Server server) = do
94 request <- parseUrl $ joinPath [server]
95 response <- withManager defaultManagerSettings $ httpLbs request
96 return $ decode (responseBody response)
98createIndex :: Server -> IndexSettings -> IndexName -> IO Reply
99createIndex (Server server) indexSettings (IndexName indexName) =
100 put url body
101 where url = joinPath [server, indexName]
102 body = Just $ encode indexSettings
104deleteIndex :: Server -> IndexName -> IO Reply
105deleteIndex (Server server) (IndexName indexName) =
106 delete $ joinPath [server, indexName]
108respIsTwoHunna :: Reply -> Bool
109respIsTwoHunna resp = NHTS.statusCode (responseStatus resp) == 200
111existentialQuery :: String -> IO (Reply, Bool)
112existentialQuery url = do
113 reply <- head url
114 return (reply, respIsTwoHunna reply)
116indexExists :: Server -> IndexName -> IO Bool
117indexExists (Server server) (IndexName indexName) = do
118 (_, exists) <- existentialQuery url
119 return exists
120 where url = joinPath [server, indexName]
122refreshIndex :: Server -> IndexName -> IO Reply
123refreshIndex (Server server) (IndexName indexName) =
124 post url Nothing
125 where url = joinPath [server, indexName, "_refresh"]
127stringifyOCIndex :: OpenCloseIndex -> String
128stringifyOCIndex oci = case oci of
129 OpenIndex -> "_open"
130 CloseIndex -> "_close"
132openOrCloseIndexes :: OpenCloseIndex -> Server -> IndexName -> IO Reply
133openOrCloseIndexes oci (Server server) (IndexName indexName) =
134 post url Nothing
135 where ociString = stringifyOCIndex oci
136 url = joinPath [server, indexName, ociString]
138openIndex :: Server -> IndexName -> IO Reply
139openIndex = openOrCloseIndexes OpenIndex
141closeIndex :: Server -> IndexName -> IO Reply
142closeIndex = openOrCloseIndexes CloseIndex
144{-| putMapping is an HTTP PUT and has upsert semantics. Mappings are schemas
145 for documents in indexes.
146-}
147putMapping :: ToJSON a => Server -> IndexName
148 -> MappingName -> a -> IO Reply
149putMapping (Server server) (IndexName indexName) (MappingName mappingName) mapping =
150 put url body
151 where url = joinPath [server, indexName, mappingName, "_mapping"]
152 body = Just $ encode mapping
154deleteMapping :: Server -> IndexName -> MappingName -> IO Reply
155deleteMapping (Server server) (IndexName indexName)
156 (MappingName mappingName) =
157 delete $ joinPath [server, indexName, mappingName, "_mapping"]
159indexDocument :: ToJSON doc => Server -> IndexName -> MappingName
160 -> doc -> DocId -> IO Reply
161indexDocument (Server server) (IndexName indexName)
162 (MappingName mappingName) document (DocId docId) =
163 put url body
164 where url = joinPath [server, indexName, mappingName, docId]
165 body = Just (encode document)
167deleteDocument :: Server -> IndexName -> MappingName
168 -> DocId -> IO Reply
169deleteDocument (Server server) (IndexName indexName)
170 (MappingName mappingName) (DocId docId) =
171 delete $ joinPath [server, indexName, mappingName, docId]
173bulk :: Server -> V.Vector BulkOperation -> IO Reply
174bulk (Server server) bulkOps = post url body where
175 url = joinPath [server, "_bulk"]
176 body = Just $ encodeBulkOperations bulkOps
178encodeBulkOperations :: V.Vector BulkOperation -> L.ByteString
179encodeBulkOperations stream = collapsed where
180 blobs = fmap encodeBulkOperation stream
181 mashedTaters = mash (mempty :: Builder) blobs
182 collapsed = toLazyByteString $ mappend mashedTaters (byteString "\n")
184mash :: Builder -> V.Vector L.ByteString -> Builder
185mash = V.foldl' (\b x -> b `mappend` "\n" `mappend` (lazyByteString x))
187mkBulkStreamValue :: Text -> String -> String -> String -> Value
188mkBulkStreamValue operation indexName mappingName docId =
189 object [operation .=
190 object [ "_index" .= indexName
191 , "_type" .= mappingName
192 , "_id" .= docId]]
194encodeBulkOperation :: BulkOperation -> L.ByteString
195encodeBulkOperation (BulkIndex (IndexName indexName)
196 (MappingName mappingName)
197 (DocId docId) value) = blob
198 where metadata = mkBulkStreamValue "index" indexName mappingName docId
199 blob = encode metadata `mappend` "\n" `mappend` encode value
201encodeBulkOperation (BulkCreate (IndexName indexName)
202 (MappingName mappingName)
203 (DocId docId) value) = blob
204 where metadata = mkBulkStreamValue "create" indexName mappingName docId
205 blob = encode metadata `mappend` "\n" `mappend` encode value
207encodeBulkOperation (BulkDelete (IndexName indexName)
208 (MappingName mappingName)
209 (DocId docId)) = blob
210 where metadata = mkBulkStreamValue "delete" indexName mappingName docId
211 blob = encode metadata
213encodeBulkOperation (BulkUpdate (IndexName indexName)
214 (MappingName mappingName)
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
221getDocument :: Server -> IndexName -> MappingName
222 -> DocId -> IO Reply
223getDocument (Server server) (IndexName indexName)
224 (MappingName mappingName) (DocId docId) =
225 get $ joinPath [server, indexName, mappingName, docId]
227documentExists :: Server -> IndexName -> MappingName
228 -> DocId -> IO Bool
229documentExists (Server server) (IndexName indexName)
230 (MappingName mappingName) (DocId docId) = do
231 (_, exists) <- existentialQuery url
232 return exists where
233 url = joinPath [server, indexName, mappingName, docId]
235dispatchSearch :: String -> Search -> IO Reply
236dispatchSearch url search = post url (Just (encode search))
238searchAll :: Server -> Search -> IO Reply
239searchAll (Server server) = dispatchSearch url where
240 url = joinPath [server, "_search"]
242searchByIndex :: Server -> IndexName -> Search -> IO Reply
243searchByIndex (Server server) (IndexName indexName) = dispatchSearch url where
244 url = joinPath [server, indexName, "_search"]
246searchByType :: Server -> IndexName -> MappingName -> Search -> IO Reply
247searchByType (Server server) (IndexName indexName)
248 (MappingName mappingName) = dispatchSearch url where
249 url = joinPath [server, indexName, mappingName, "_search"]
251mkSearch :: Maybe Query -> Maybe Filter -> Search
252mkSearch query filter = Search query filter Nothing Nothing False 0 10
254mkAggregateSearch :: Maybe Query -> Aggregations -> Search
255mkAggregateSearch query mkSearchAggs = Search query Nothing Nothing (Just mkSearchAggs) False 0 0
257pageSearch :: Int -> Int -> Search -> Search
258pageSearch pageFrom pageSize search = search { from = pageFrom, size = pageSize }