git.iko.soy/typeable/bloodhound
on d6d4112 help sign in
typeable/bloodhound/Database/Bloodhound/Client.hs
260 lines 8.6 kB history raw
1{-# LANGUAGE DeriveGeneric #-}
2{-# LANGUAGE OverloadedStrings #-}
4module Database.Bloodhound.Client
5 ( createIndex
6 , deleteIndex
7 , IndexSettings(..)
8 , Server(..)
9 , defaultIndexSettings
10 , indexDocument
11 )
12 where
14import Control.Applicative
15import Control.Monad (liftM)
16import Data.Aeson
17import Data.Aeson.TH (deriveJSON)
18import qualified Data.ByteString.Lazy.Char8 as L
19import Data.List (intersperse)
20import Data.Maybe (fromMaybe)
21import qualified Data.Text as T
22import Data.Time.Clock as DTC
23import GHC.Generics (Generic)
24import Network.HTTP.Conduit
25import qualified Network.HTTP.Types.Method as NHTM
26import qualified Network.HTTP.Types.Status as NHTS
28data Version = Version { number :: T.Text
29 , build_hash :: T.Text
30 , build_timestamp :: DTC.UTCTime
31 , build_snapshot :: Bool
32 , lucene_version :: T.Text } deriving (Show, Generic)
34data (FromJSON a, ToJSON a) => Status a =
35 Status { ok :: Bool
36 , status :: Int
37 , name :: T.Text
38 , version :: a
39 , tagline :: T.Text } deriving (Show)
41instance ToJSON Version
42instance FromJSON Version
44instance (FromJSON a, ToJSON a) => FromJSON (Status a) where
45 parseJSON (Object v) = Status <$>
46 v .: "ok" <*>
47 v .: "status" <*>
48 v .: "name" <*>
49 v .: "version" <*>
50 v .: "tagline"
51 parseJSON _ = empty
53-- instance ToJSON (Status a)
54-- instance FromJSON (Status a)
56-- bloo <- (liftM responseBody $ parseUrl "http://localhost:9200/" >>= \r -> withManager (httpLbs r))
58-- rootPath :: String
59-- rootPath = rollUp $ ["/"]
61-- -- Kinda hate this.
62-- pathFromType :: String -> String -> String
63-- pathFromType index docType = "/" ++ index ++ docType
65-- -- Kinda hate this too.
66-- rollUp :: [String] -> String
67-- rollUp = Prelude.concat
69main = simpleHttp "http://localhost:9200/events/event/_search?q=hostname:localhost&size=1" >>= L.putStrLn
71-- data Response = Response { blah :: T.Text } deriving (Show)
73-- indexDocument :: ToJSON a => a -> IO Response
74-- indexDocument doc = ToJSON a
76-- nomenclature is because you're dropping the type baggage. All of this is compile-time erased.
77-- newtype ShardCount = ShardCount { unShardCount :: Int } deriving (Show, Generic)
78-- newtype ReplicaCount = ReplicaCount { unReplicaCount :: Int } deriving (Show, Generic)
80newtype ShardCount = ShardCount Int deriving (Show, Generic)
81newtype ReplicaCount = ReplicaCount Int deriving (Show, Generic)
83mkShardCount :: Int -> Maybe ShardCount
84mkShardCount n
85 | n < 1 = Nothing
86 | n > 1000 = Nothing -- seriously, what the fuck?
87 | otherwise = Just (ShardCount n)
89mkReplicaCount :: Int -> Maybe ReplicaCount
90mkReplicaCount n
91 | n < 1 = Nothing
92 | n > 1000 = Nothing -- ...
93 | otherwise = Just (ReplicaCount n)
95-- IndexSettings <$> mkShardCount 10 <*> mkReplicaCount 20
97data IndexSettings = IndexSettings { shards :: ShardCount
98 , replicas :: ReplicaCount } deriving (Show, Generic)
100instance ToJSON IndexSettings where
101 toJSON (IndexSettings s r) = object ["settings" .= object ["shards" .= s, "replicas" .= r]]
103instance ToJSON ReplicaCount
104instance ToJSON ShardCount
106defaultIndexSettings = IndexSettings (ShardCount 3) (ReplicaCount 2)
108data Strategy = RoundRobinStrat | RandomStrat | HeadStrat deriving (Show)
110newtype Server = Server String deriving (Show)
112-- data Errors = IndexAlreadyExistsError | GenericError deriving (Show)
114-- data ElasticsearchError = ElasticsearchError
115-- { status :: Int
116-- , error :: T.Text } deriving (Show, Generic)
118-- instance FromJSON ElasticsearchError
120-- errorForResponse resp = do
121-- let (sts, err) = decode (responseBody resp) :: ElasticsearchError
122-- if T.isInfixOf "IndexAlreadyExistsException" error
123-- then IndexAlreadyExistsError
124-- else
126type Reply = Network.HTTP.Conduit.Response L.ByteString
127type Method = NHTM.Method
129responseIsError :: Reply -> Bool
130responseIsError resp = if (NHTS.statusCode (responseStatus resp)) > 299
131 then True
132 else False
134emptyBody = L.pack ""
136dispatch :: String -> Method -> Maybe L.ByteString
137 -> IO Reply
138dispatch url method body = do
139 initReq <- parseUrl url
140 let reqBody = RequestBodyLBS $ fromMaybe emptyBody body
141 let req = initReq { method = method
142 , requestBody = reqBody
143 , checkStatus = \_ _ _ -> Nothing}
144 response <- withManager $ httpLbs req
145 return response
147type IndexName = String
149joinPath :: [String] -> String
150joinPath path = concat $ intersperse "/" path
152getStatus :: Server -> IO (Maybe (Status Version))
153getStatus (Server server) = do
154 request <- parseUrl $ joinPath [server]
155 response <- withManager $ httpLbs request
156 return $ (decode $ responseBody response)
158createIndex :: Server -> IndexSettings -> IndexName -> IO Reply
159createIndex (Server server) indexSettings indexName =
160 dispatch url method body where
161 url = joinPath [server, indexName]
162 method = NHTM.methodPut
163 body = Just $ encode indexSettings
165deleteIndex :: Server -> IndexName -> IO Reply
166deleteIndex (Server server) indexName =
167 dispatch url method body where
168 url = joinPath [server, indexName]
169 method = NHTM.methodDelete
170 body = Nothing
172indexExists :: Server -> IndexName -> IO Bool
173indexExists (Server server) indexName =
174 exists where
175 url = joinPath [server, indexName]
176 method = NHTM.methodHead
177 body = Nothing
178 reply = dispatch url method body
179 exists = do
180 resp <- reply
181 if (NHTS.statusCode $ responseStatus resp) == 200
182 then return True
183 else return False
185data OpenCloseIndex = OpenIndex | CloseIndex deriving (Show)
187stringifyOCIndex oci = case oci of
188 OpenIndex -> "_open"
189 CloseIndex -> "_close"
191openOrCloseIndexes :: OpenCloseIndex -> Server -> IndexName -> IO Reply
192openOrCloseIndexes oci (Server server) indexName =
193 dispatch url method body where
194 ociString = stringifyOCIndex oci
195 url = joinPath [server, indexName, ociString]
196 method = NHTM.methodPost
197 body = Nothing
199openIndex :: Server -> IndexName -> IO Reply
200openIndex = openOrCloseIndexes OpenIndex
202closeIndex :: Server -> IndexName -> IO Reply
203closeIndex = openOrCloseIndexes CloseIndex
205type MappingName = String
207createMapping :: ToJSON a => Server -> IndexName
208 -> MappingName -> a -> IO Reply
209createMapping (Server server) indexName mappingName mapping =
210 dispatch url method body where
211 url = joinPath [server, indexName, mappingName, "_mapping"]
212 method = NHTM.methodPut
213 body = Just $ encode mapping
215deleteMapping :: Server -> IndexName -> MappingName -> IO Reply
216deleteMapping (Server server) indexName mappingName =
217 dispatch url method body where
218 url = joinPath [server, indexName, mappingName, "_mapping"]
219 method = NHTM.methodDelete
220 body = Nothing
222type DocumentID = String
224indexDocument :: ToJSON doc => Server -> IndexName -> MappingName
225 -> doc -> DocumentID -> IO Reply
226indexDocument (Server server) indexName mappingName document docId =
227 dispatch url method body where
228 url = joinPath [server, indexName, mappingName, docId]
229 method = NHTM.methodPut
230 body = Just (encode document)
232deleteDocument :: Server -> IndexName -> MappingName
233 -> DocumentID -> IO Reply
234deleteDocument (Server server) indexName mappingName docId =
235 dispatch url method body where
236 url = joinPath [server, indexName, mappingName, docId]
237 method = NHTM.methodDelete
238 body = Nothing
240getDocument :: Server -> IndexName -> MappingName
241 -> DocumentID -> IO Reply
242getDocument (Server server) indexName mappingName docId =
243 dispatch url method body where
244 url = joinPath [server, indexName, mappingName, docId]
245 method = NHTM.methodGet
246 body = Nothing
248-- getStatus :: String -> IO (Maybe (Status Version))
249-- getStatus server = do
250-- request <- parseUrl $ server ++ rootPath
251-- response <- withManager $ httpLbs request
252-- return $ (decode $ responseBody response)
254-- mkServer -- (Maybe Server) for URL parsing?
256-- data Cluster = Cluster { targets :: [Server]
257-- , strategy :: Strategy } deriving (Show)
259-- target :: Cluster -> Server
260-- target (Cluster targets HeadStrat) = head targets