@@ -8,10 +8,14 @@ import Control.Monad (liftM)
88import Data.Aeson
99import Data.Aeson.TH (deriveJSON)
1010import qualified Data.ByteString.Lazy.Char8 as L
11+import Data.Maybe (fromMaybe)
1112import qualified Data.Text as T
1213import Data.Time.Clock as DTC
1314import GHC.Generics (Generic)
1415import Network.HTTP.Conduit
16+import qualified Network.HTTP.Types.Method as NHTM
17+import qualified Network.HTTP.Types.Status as NHTS
18+import qualified Control.Exception as E
1519
1620data Version = Version { number :: T.Text
1721 , build_hash :: T.Text
@@ -63,3 +67,149 @@ getStatus server = do
6367 return $ (decode $ responseBody response)
6468
6569main = simpleHttp "http://localhost:9200/events/event/_search?q=hostname:localhost&size=1" >>= L.putStrLn
70+
71+-- data Response = Response { blah :: T.Text } deriving (Show)
72+
73+-- indexDocument :: ToJSON a => a -> IO Response
74+-- indexDocument doc = ToJSON a
75+
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)
79+
80+newtype ShardCount = ShardCount Int deriving (Show, Generic)
81+newtype ReplicaCount = ReplicaCount Int deriving (Show, Generic)
82+
83+mkShardCount :: Int -> Maybe ShardCount
84+mkShardCount n
85+ | n < 1 = Nothing
86+ | n > 1000 = Nothing -- seriously, what the fuck?
87+ | otherwise = Just (ShardCount n)
88+
89+mkReplicaCount :: Int -> Maybe ReplicaCount
90+mkReplicaCount n
91+ | n < 1 = Nothing
92+ | n > 1000 = Nothing -- ...
93+ | otherwise = Just (ReplicaCount n)
94+
95+-- IndexSettings <$> mkShardCount 10 <*> mkReplicaCount 20
96+
97+data IndexSettings = IndexSettings { shards :: ShardCount
98+ , replicas :: ReplicaCount } deriving (Show, Generic)
99+
100+instance ToJSON IndexSettings where
101+ toJSON (IndexSettings s r) = object ["settings" .= object ["shards" .= s, "replicas" .= r]]
102+
103+instance ToJSON ReplicaCount
104+instance ToJSON ShardCount
105+
106+defaultIndexSettings = IndexSettings (ShardCount 3) (ReplicaCount 2)
107+
108+data Strategy = RoundRobinStrat | RandomStrat | HeadStrat deriving (Show)
109+
110+newtype Server = Server String deriving (Show)
111+
112+-- data Errors = IndexAlreadyExistsError | GenericError deriving (Show)
113+
114+-- data ElasticsearchError = ElasticsearchError
115+-- { status :: Int
116+-- , error :: T.Text } deriving (Show, Generic)
117+
118+-- instance FromJSON ElasticsearchError
119+
120+-- errorForResponse resp = do
121+-- let (sts, err) = decode (responseBody resp) :: ElasticsearchError
122+-- if T.isInfixOf "IndexAlreadyExistsException" error
123+-- then IndexAlreadyExistsError
124+-- else
125+
126+type Reply = Network.HTTP.Conduit.Response L.ByteString
127+type Method = NHTM.Method
128+
129+responseIsError :: Reply -> Bool
130+responseIsError resp = if (NHTS.statusCode (responseStatus resp)) > 299
131+ then True
132+ else False
133+
134+emptyBody = L.pack ""
135+
136+dispatch :: String -> Method -> Maybe L.ByteString
137+ -> IO Reply
138+dispatch 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
146+
147+type IndexName = String
148+
149+createIndex :: Server -> IndexSettings -> IndexName -> IO Reply
150+createIndex (Server server) indexSettings indexName =
151+ dispatch url method body where
152+ url = server ++ "/" ++ indexName
153+ method = NHTM.methodPut
154+ body = Just $ encode indexSettings
155+
156+deleteIndex :: Server -> IndexName -> IO Reply
157+deleteIndex (Server server) indexName =
158+ dispatch url method body where
159+ url = server ++ "/" ++ indexName
160+ method = NHTM.methodDelete
161+ body = Nothing
162+
163+indexExists :: Server -> IndexName -> IO Bool
164+indexExists (Server server) indexName =
165+ exists where
166+ url = server ++ "/" ++ indexName
167+ method = NHTM.methodHead
168+ body = Nothing
169+ reply = dispatch url method body
170+ exists = do
171+ resp <- reply
172+ if (NHTS.statusCode $ responseStatus resp) == 200
173+ then return True
174+ else return False
175+
176+data OpenCloseIndex = OpenIndex | CloseIndex deriving (Show)
177+
178+stringifyOCIndex oci = case oci of
179+ OpenIndex -> "_open"
180+ CloseIndex -> "_close"
181+
182+openOrCloseIndexes :: OpenCloseIndex -> Server -> IndexName -> IO Reply
183+openOrCloseIndexes oci (Server server) indexName =
184+ dispatch url method body where
185+ ociString = stringifyOCIndex oci
186+ url = server ++ "/" ++ indexName ++ "/" ++ ociString
187+ method = NHTM.methodPost
188+ body = Nothing
189+
190+openIndex :: Server -> IndexName -> IO Reply
191+openIndex = openOrCloseIndexes OpenIndex
192+
193+closeIndex :: Server -> IndexName -> IO Reply
194+closeIndex = openOrCloseIndexes CloseIndex
195+
196+createMapping :: ToJSON a => Server -> IndexName -> a -> IO Reply
197+createMapping (Server server) indexName mapping =
198+ dispatch url method body where
199+ url = server ++ "/" ++ indexName ++ "/" ++ "_mapping"
200+ method = NHTM.methodPut
201+ body = Just $ encode mapping
202+
203+-- getStatus :: String -> IO (Maybe (Status Version))
204+-- getStatus server = do
205+-- request <- parseUrl $ server ++ rootPath
206+-- response <- withManager $ httpLbs request
207+-- return $ (decode $ responseBody response)
208+
209+-- mkServer -- (Maybe Server) for URL parsing?
210+
211+-- data Cluster = Cluster { targets :: [Server]
212+-- , strategy :: Strategy } deriving (Show)
213+
214+-- target :: Cluster -> Server
215+-- target (Cluster targets HeadStrat) = head targets