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