git.iko.soy/typeable/bloodhound
on 3379c6a help sign in
typeable/bloodhound/Database/Bloodhound/Client.hs
234 lines 8.5 kB history raw
1module Database.Bloodhound.Client
2 ( createIndex
3 , deleteIndex
4 , createMapping
5 , deleteMapping
6 , indexDocument
7 , getDocument
8 , documentExists
9 , deleteDocument
10 , searchAll
11 , searchByIndex
12 , searchByType
13 , refreshIndex
14 , mkSearch
15 , bulk
16 )
17 where
19import Data.Aeson
20import qualified Data.ByteString.Lazy.Char8 as L
21import Data.ByteString.Builder
22import Data.List (foldl', intercalate, intersperse)
23import Data.Maybe (fromMaybe)
24import Data.Text (Text)
25import Network.HTTP.Conduit
26import qualified Network.HTTP.Types.Method as NHTM
27import qualified Network.HTTP.Types.Status as NHTS
28import Prelude hiding (head)
30import Database.Bloodhound.Types
31import Database.Bloodhound.Types.Class
32import Database.Bloodhound.Types.Instances
34-- find way to avoid destructuring Servers and Indexes?
35-- make get, post, put, delete helpers.
36-- make dispatch take URL last for better variance and
37-- utilization of partial application
39mkShardCount :: Int -> Maybe ShardCount
40mkShardCount n
41 | n < 1 = Nothing
42 | n > 1000 = Nothing -- seriously, what the fuck?
43 | otherwise = Just (ShardCount n)
45mkReplicaCount :: Int -> Maybe ReplicaCount
46mkReplicaCount n
47 | n < 1 = Nothing
48 | n > 1000 = Nothing -- ...
49 | otherwise = Just (ReplicaCount n)
51responseIsError :: Reply -> Bool
52responseIsError resp = NHTS.statusCode (responseStatus resp) > 299
54emptyBody = L.pack ""
56dispatch :: Method -> String -> Maybe L.ByteString
57 -> IO Reply
58dispatch method url body = do
59 initReq <- parseUrl url
60 let reqBody = RequestBodyLBS $ fromMaybe emptyBody body
61 let req = initReq { method = method
62 , requestBody = reqBody
63 , checkStatus = \_ _ _ -> Nothing}
64 withManager $ httpLbs req
66joinPath :: [String] -> String
67joinPath = intercalate "/"
69delete = flip (dispatch NHTM.methodDelete) $ Nothing
70get = flip (dispatch NHTM.methodGet) $ Nothing
71head = flip (dispatch NHTM.methodHead) $ Nothing
72put = dispatch NHTM.methodPost
73post = dispatch NHTM.methodPost
75-- indexDocument s ix name doc = put (root </> s </> ix </> name </> doc) (Just encode doc)
76-- http://hackage.haskell.org/package/http-client-lens-0.1.0/docs/Network-HTTP-Client-Lens.html
77-- https://github.com/supki/libjenkins/blob/master/src/Jenkins/Rest/Internal.hs
79getStatus :: Server -> IO (Maybe (Status Version))
80getStatus (Server server) = do
81 request <- parseUrl $ joinPath [server]
82 response <- withManager $ httpLbs request
83 return $ decode (responseBody response)
85createIndex :: Server -> IndexSettings -> IndexName -> IO Reply
86createIndex (Server server) indexSettings (IndexName indexName) =
87 put url body
88 where url = joinPath [server, indexName]
89 body = Just $ encode indexSettings
91deleteIndex :: Server -> IndexName -> IO Reply
92deleteIndex (Server server) (IndexName indexName) =
93 delete $ joinPath [server, indexName]
95respIsTwoHunna :: Reply -> Bool
96respIsTwoHunna resp = NHTS.statusCode (responseStatus resp) == 200
98existentialQuery url = do
99 reply <- head url
100 return (reply, respIsTwoHunna reply)
102indexExists :: Server -> IndexName -> IO Bool
103indexExists (Server server) (IndexName indexName) = do
104 (reply, exists) <- existentialQuery url
105 return exists
106 where url = joinPath [server, indexName]
108refreshIndex :: Server -> IndexName -> IO Reply
109refreshIndex (Server server) (IndexName indexName) =
110 post url Nothing
111 where url = joinPath [server, indexName, "_refresh"]
113stringifyOCIndex oci = case oci of
114 OpenIndex -> "_open"
115 CloseIndex -> "_close"
117openOrCloseIndexes :: OpenCloseIndex -> Server -> IndexName -> IO Reply
118openOrCloseIndexes oci (Server server) (IndexName indexName) =
119 post url Nothing
120 where ociString = stringifyOCIndex oci
121 url = joinPath [server, indexName, ociString]
123openIndex :: Server -> IndexName -> IO Reply
124openIndex = openOrCloseIndexes OpenIndex
126closeIndex :: Server -> IndexName -> IO Reply
127closeIndex = openOrCloseIndexes CloseIndex
129createMapping :: ToJSON a => Server -> IndexName
130 -> MappingName -> a -> IO Reply
131createMapping (Server server) (IndexName indexName) (MappingName mappingName) mapping =
132 put url body
133 where url = joinPath [server, indexName, mappingName, "_mapping"]
134 body = Just $ encode mapping
136deleteMapping :: Server -> IndexName -> MappingName -> IO Reply
137deleteMapping (Server server) (IndexName indexName) (MappingName mappingName) =
138 delete $ joinPath [server, indexName, mappingName, "_mapping"]
140indexDocument :: ToJSON doc => Server -> IndexName -> MappingName
141 -> doc -> DocId -> IO Reply
142indexDocument (Server server) (IndexName indexName)
143 (MappingName mappingName) document (DocId docId) =
144 put url body
145 where url = joinPath [server, indexName, mappingName, docId]
146 body = Just (encode document)
148deleteDocument :: Server -> IndexName -> MappingName
149 -> DocId -> IO Reply
150deleteDocument (Server server) (IndexName indexName)
151 (MappingName mappingName) (DocId docId) =
152 delete $ joinPath [server, indexName, mappingName, docId]
154bulk :: Server -> [BulkOperation] -> IO Reply
155bulk (Server server) bulkOps = post url body where
156 url = joinPath [server, "_bulk"]
157 body = Just $ collapseStream bulkOps
159collapseStream :: [BulkOperation] -> L.ByteString
160collapseStream stream = collapsed where
161 blobs = intersperse "\n" $ concat $ fmap getStreamChunk stream
162 mashedTaters = mash (mempty :: Builder) blobs
163 collapsed = toLazyByteString $ mappend mashedTaters "\n"
165mash :: Builder -> [L.ByteString] -> Builder
166mash builder xs = foldl' (\b x -> mappend b (lazyByteString x)) builder xs
168mkMetadataValue :: Text -> String -> String -> String -> Value
169mkMetadataValue operation indexName mappingName docId =
170 object [operation .=
171 object ["_index" .= indexName
172 , "_type" .= mappingName
173 , "_id" .= docId]]
175getStreamChunk :: BulkOperation -> [L.ByteString]
176getStreamChunk (BulkIndex (IndexName indexName)
177 (MappingName mappingName)
178 (DocId docId) value) = blob where
179 metadata = mkMetadataValue "index" indexName mappingName docId
180 blob = [encode metadata, encode value]
182getStreamChunk (BulkCreate (IndexName indexName)
183 (MappingName mappingName)
184 (DocId docId) value) = blob where
185 metadata = mkMetadataValue "create" indexName mappingName docId
186 blob = [encode metadata, encode value]
188getStreamChunk (BulkDelete (IndexName indexName)
189 (MappingName mappingName)
190 (DocId docId)) = blob where
191 metadata = mkMetadataValue "delete" indexName mappingName docId
192 blob = [encode metadata]
194getStreamChunk (BulkUpdate (IndexName indexName)
195 (MappingName mappingName)
196 (DocId docId) value) = blob where
197 metadata = mkMetadataValue "update" indexName mappingName docId
198 doc = object ["doc" .= value]
199 blob = [encode metadata, encode doc]
201getDocument :: Server -> IndexName -> MappingName
202 -> DocId -> IO Reply
203getDocument (Server server) (IndexName indexName) (MappingName mappingName) (DocId docId) =
204 get $ joinPath [server, indexName, mappingName, docId]
206documentExists :: Server -> IndexName -> MappingName
207 -> DocId -> IO Bool
208documentExists (Server server) (IndexName indexName)
209 (MappingName mappingName) (DocId docId) = do
210 (reply, exists) <- existentialQuery url
211 return exists where
212 url = joinPath [server, indexName, mappingName, docId]
214dispatchSearch :: String -> Search -> IO Reply
215dispatchSearch url search = post url (Just (encode search))
217searchAll :: Server -> Search -> IO Reply
218searchAll (Server server) search = dispatchSearch url search where
219 url = joinPath [server, "_search"]
221searchByIndex :: Server -> IndexName -> Search -> IO Reply
222searchByIndex (Server server) (IndexName indexName) search = dispatchSearch url search where
223 url = joinPath [server, indexName, "_search"]
225searchByType :: Server -> IndexName -> MappingName -> Search -> IO Reply
226searchByType (Server server) (IndexName indexName)
227 (MappingName mappingName) search = dispatchSearch url search where
228 url = joinPath [server, indexName, mappingName, "_search"]
230mkSearch :: Maybe Query -> Maybe Filter -> Search
231mkSearch query filter = Search query filter Nothing False 0 10
233pageSearch :: Int -> Int -> Search -> Search
234pageSearch from size search = search { from = from, size = size }