4a7d9fe · typeable/bloodhound

git.iko.soy/typeable/bloodhound

on master help sign in

Merge pull request #126 from Soostone/snapshot-restore

4a7d9feChris Allen10 years ago

.travis.yml+3−1

compare with master

unifiedsplit

@@ -10,7 +10,7 @@ env:

10 # - GHCVER=7.6.3 ESVER=1.6.0 # Deprecated

11 # - GHCVER=7.8.3 ESVER=1.0.3 # Deprecated

12 # - GHCVER=7.8.3 ESVER=1.1.2 # Deprecated

13− - GHCVER=7.8 ESVER=1.2.4

13+ # - GHCVER=7.8 ESVER=1.2.4 # deprecated

14 - GHCVER=7.8 ESVER=1.3.6

15 - GHCVER=7.8 ESVER=1.4.1

16 - GHCVER=7.10 ESVER=1.5.2

@@ -29,6 +29,8 @@ install:

29 # elasticsearch

30 - wget --no-check-certificate https://download.elastic.co/elasticsearch/elasticsearch/elasticsearch-$ESVER.tar.gz

31 - tar xzf elasticsearch-$ESVER.tar.gz

32+ # set up a repo for snapshot testing. Required in ES >= 1.6

33+ - echo "path.repo = [\"/tmp\"]" >> ./elasticsearch-$ESVER/elasticsearch.yml

32 - ./elasticsearch-$ESVER/bin/elasticsearch &

34 - ./elasticsearch-$ESVER/bin/elasticsearch &

34script:

36script:

bloodhound.cabal+5−1

@@ -73,7 +73,11 @@ test-suite tests

73 mtl,

74 quickcheck-properties,

75 derive,

76− errors

76+ errors,

77+ exceptions,

78+ temporary,

79+ unix,

80+ network-uri

77 default-language: Haskell2010

81 default-language: Haskell2010

79test-suite doctests

83test-suite doctests

src/Database/Bloodhound/Client.hs+208−25

@@ -59,6 +59,14 @@ module Database.Bloodhound.Client

59 , mkShardCount

60 , mkReplicaCount

61 , getStatus

62+ , getSnapshotRepos

63+ , updateSnapshotRepo

64+ , verifySnapshotRepo

65+ , deleteSnapshotRepo

66+ , createSnapshot

67+ , getSnapshots

68+ , deleteSnapshot

69+ , restoreSnapshot

62 , encodeBulkOperations

70 , encodeBulkOperations

63 , encodeBulkOperation

71 , encodeBulkOperation

64 -- * Authentication

72 -- * Authentication

@@ -71,32 +79,33 @@ module Database.Bloodhound.Client

71 )

79 )

72 where

80 where

74−import qualified Blaze.ByteString.Builder as BB

82+import qualified Blaze.ByteString.Builder as BB

75−import Control.Applicative

83+import Control.Applicative as A

76import Control.Monad

84import Control.Monad

77import Control.Monad.Catch

85import Control.Monad.Catch

78import Control.Monad.IO.Class

86import Control.Monad.IO.Class

79import Data.Aeson

87import Data.Aeson

80import Data.ByteString.Lazy.Builder

88import Data.ByteString.Lazy.Builder

81−import qualified Data.ByteString.Lazy.Char8 as L

89+import qualified Data.ByteString.Lazy.Char8 as L

82−import Data.Foldable (toList)

90+import Data.Foldable (toList)

83−import qualified Data.HashMap.Strict as HM

91+import qualified Data.HashMap.Strict as HM

84import Data.Ix

92import Data.Ix

85−import qualified Data.List as LS (filter, foldl')

93+import qualified Data.List as LS (filter, foldl')

86−import Data.List.NonEmpty (NonEmpty (..))

94+import Data.List.NonEmpty (NonEmpty (..))

87−import Data.Maybe (catMaybes, fromMaybe, isJust)

95+import Data.Maybe (catMaybes, fromMaybe,

96+ isJust)

88import Data.Monoid

97import Data.Monoid

89−import Data.Text (Text)

98+import Data.Text (Text)

90−import qualified Data.Text as T

99+import qualified Data.Text as T

91−import qualified Data.Text.Encoding as T

100+import qualified Data.Text.Encoding as T

92import Data.Time.Clock

101import Data.Time.Clock

93−import qualified Data.Vector as V

102+import qualified Data.Vector as V

94import Network.HTTP.Client

103import Network.HTTP.Client

95−import qualified Network.HTTP.Types.Method as NHTM

104+import qualified Network.HTTP.Types.Method as NHTM

96−import qualified Network.HTTP.Types.Status as NHTS

105+import qualified Network.HTTP.Types.Status as NHTS

97−import qualified Network.HTTP.Types.URI as NHTU

106+import qualified Network.HTTP.Types.URI as NHTU

98−import qualified Network.URI as URI

107+import qualified Network.URI as URI

99−import Prelude hiding (filter, head)

108+import Prelude hiding (filter, head)

100

109

101import Database.Bloodhound.Types

110import Database.Bloodhound.Types

102

111

@@ -183,7 +192,7 @@ dispatch :: MonadBH m

183 -> m Reply

192 -> m Reply

184dispatch dMethod url body = do

193dispatch dMethod url body = do

185 initReq <- liftIO $ parseUrl' url

194 initReq <- liftIO $ parseUrl' url

186− reqHook <- bhRequestHook <$> getBHEnv

195+ reqHook <- bhRequestHook A.<$> getBHEnv

187 let reqBody = RequestBodyLBS $ fromMaybe emptyBody body

196 let reqBody = RequestBodyLBS $ fromMaybe emptyBody body

188 req <- liftIO $ reqHook $ setRequestIgnoreStatus $ initReq { method = dMethod

197 req <- liftIO $ reqHook $ setRequestIgnoreStatus $ initReq { method = dMethod

189 , requestBody = reqBody }

198 , requestBody = reqBody }

@@ -260,6 +269,182 @@ getStatus = do

260 return $ decode (responseBody response)

269 return $ decode (responseBody response)

261 where url = joinPath []

270 where url = joinPath []

262

271

272+-- | 'getSnapshotRepos' gets the definitions of a subset of the

273+-- defined snapshot repos.

274+getSnapshotRepos

275+ :: ( MonadBH m

276+ , MonadThrow m

277+ )

278+ => SnapshotRepoSelection

279+ -> m (Either EsError [GenericSnapshotRepo])

280+getSnapshotRepos sel = fmap (fmap unGSRs) . parseEsResponse =<< get =<< url

281+ where

282+ url = joinPath ["_snapshot", selectorSeg]

283+ selectorSeg = case sel of

284+ AllSnapshotRepos -> "_all"

285+ SnapshotRepoList (p :| ps) -> T.intercalate "," (renderPat <$> (p:ps))

286+ renderPat (RepoPattern t) = t

287+ renderPat (ExactRepo (SnapshotRepoName t)) = t

288+

289+

290+-- | Wrapper to extract the list of 'GenericSnapshotRepo' in the

291+-- format they're returned in

292+newtype GSRs = GSRs { unGSRs :: [GenericSnapshotRepo] }

293+

294+

295+instance FromJSON GSRs where

296+ parseJSON = withObject "Collection of GenericSnapshotRepo" parse

297+ where

298+ parse = fmap GSRs . mapM (uncurry go) . HM.toList

299+ go rawName = withObject "GenericSnapshotRepo" $ \o -> do

300+ GenericSnapshotRepo (SnapshotRepoName rawName) <$> o .: "type"

301+ <*> o .: "settings"

302+

303+

304+-- | Create or update a snapshot repo

305+updateSnapshotRepo

306+ :: ( MonadBH m

307+ , SnapshotRepo repo

308+ )

309+ => SnapshotRepoUpdateSettings

310+ -- ^ Use 'defaultSnapshotRepoUpdateSettings' if unsure

311+ -> repo

312+ -> m Reply

313+updateSnapshotRepo SnapshotRepoUpdateSettings {..} repo =

314+ bindM2 put url (return (Just body))

315+ where

316+ url = addQuery params <$> joinPath ["_snapshot", snapshotRepoName gSnapshotRepoName]

317+ params

318+ | repoUpdateVerify = []

319+ | otherwise = [("verify", Just "false")]

320+ body = encode $ object [ "type" .= gSnapshotRepoType

321+ , "settings" .= gSnapshotRepoSettings

322+ ]

323+ GenericSnapshotRepo {..} = toGSnapshotRepo repo

324+

325+

326+

327+-- | Verify if a snapshot repo is working. __NOTE:__ this API did not

328+-- make it into ElasticSearch until 1.4. If you use an older version,

329+-- you will get an error here.

330+verifySnapshotRepo

331+ :: ( MonadBH m

332+ , MonadThrow m

333+ )

334+ => SnapshotRepoName

335+ -> m (Either EsError SnapshotVerification)

336+verifySnapshotRepo (SnapshotRepoName n) =

337+ parseEsResponse =<< bindM2 post url (return Nothing)

338+ where

339+ url = joinPath ["_snapshot", n, "_verify"]

340+

341+

342+deleteSnapshotRepo :: MonadBH m => SnapshotRepoName -> m Reply

343+deleteSnapshotRepo (SnapshotRepoName n) = delete =<< url

344+ where

345+ url = joinPath ["_snapshot", n]

346+

347+

348+-- | Create and start a snapshot

349+createSnapshot

350+ :: (MonadBH m)

351+ => SnapshotRepoName

352+ -> SnapshotName

353+ -> SnapshotCreateSettings

354+ -> m Reply

355+createSnapshot (SnapshotRepoName repoName)

356+ (SnapshotName snapName)

357+ SnapshotCreateSettings {..} =

358+ bindM2 put url (return (Just body))

359+ where

360+ url = addQuery params <$> joinPath ["_snapshot", repoName, snapName]

361+ params = [("wait_for_completion", Just (boolQP snapWaitForCompletion))]

362+ body = encode $ object prs

363+ prs = catMaybes [ ("indices" .=) . indexSelectionName <$> snapIndices

364+ , Just ("ignore_unavailable" .= snapIgnoreUnavailable)

365+ , Just ("ignore_global_state" .= snapIncludeGlobalState)

366+ , Just ("partial" .= snapPartial)

367+ ]

368+

369+

370+indexSelectionName :: IndexSelection -> Text

371+indexSelectionName AllIndexes = "_all"

372+indexSelectionName (IndexList (i :| is)) = T.intercalate "," (renderIndex <$> (i:is))

373+ where

374+ renderIndex (IndexName n) = n

375+

376+

377+-- | Get info about known snapshots given a pattern and repo name.

378+getSnapshots

379+ :: ( MonadBH m

380+ , MonadThrow m

381+ )

382+ => SnapshotRepoName

383+ -> SnapshotSelection

384+ -> m (Either EsError [SnapshotInfo])

385+getSnapshots (SnapshotRepoName repoName) sel =

386+ fmap (fmap unSIs) . parseEsResponse =<< get =<< url

387+ where

388+ url = joinPath ["_snapshot", repoName, snapPath]

389+ snapPath = case sel of

390+ AllSnapshots -> "_all"

391+ SnapshotList (s :| ss) -> T.intercalate "," (renderPath <$> (s:ss))

392+ renderPath (SnapPattern t) = t

393+ renderPath (ExactSnap (SnapshotName t)) = t

394+

395+

396+newtype SIs = SIs { unSIs :: [SnapshotInfo] }

397+

398+

399+instance FromJSON SIs where

400+ parseJSON = withObject "Collection of SnapshotInfo" parse

401+ where

402+ parse o = SIs <$> o .: "snapshots"

403+

404+

405+-- | Delete a snapshot. Cancels if it is running.

406+deleteSnapshot :: MonadBH m => SnapshotRepoName -> SnapshotName -> m Reply

407+deleteSnapshot (SnapshotRepoName repoName) (SnapshotName snapName) =

408+ delete =<< url

409+ where

410+ url = joinPath ["_snapshot", repoName, snapName]

411+

412+

413+-- | Restore a snapshot to the cluster See

414+-- <https://www.elastic.co/guide/en/elasticsearch/reference/1.7/modules-snapshots.html#_restore>

415+-- for more details.

416+restoreSnapshot

417+ :: MonadBH m

418+ => SnapshotRepoName

419+ -> SnapshotName

420+ -> SnapshotRestoreSettings

421+ -- ^ Start with 'defaultSnapshotRestoreSettings' and customize

422+ -- from there for reasonable defaults.

423+ -> m Reply

424+restoreSnapshot (SnapshotRepoName repoName)

425+ (SnapshotName snapName)

426+ SnapshotRestoreSettings {..} = bindM2 post url (return (Just body))

427+ where

428+ url = addQuery params <$> joinPath ["_snapshot", repoName, snapName, "_restore"]

429+ params = [("wait_for_completion", Just (boolQP snapRestoreWaitForCompletion))]

430+ body = encode (object prs)

431+

432+

433+ prs = catMaybes [ ("indices" .=) . indexSelectionName <$> snapRestoreIndices

434+ , Just ("ignore_unavailable" .= snapRestoreIgnoreUnavailable)

435+ , Just ("include_global_state" .= snapRestoreIncludeGlobalState)

436+ , ("rename_pattern" .=) <$> snapRestoreRenamePattern

437+ , ("rename_replacement" .=) . renderTokens <$> snapRestoreRenameReplacement

438+ , Just ("include_aliases" .= snapRestoreIncludeAliases)

439+ , ("index_settings" .= ) <$> snapRestoreIndexSettingsOverrides

440+ , ("ignore_index_settings" .= ) <$> snapRestoreIgnoreIndexSettings

441+ ]

442+ renderTokens (t :| ts) = mconcat (renderToken <$> (t:ts))

443+ renderToken (RRTLit t) = t

444+ renderToken RRSubWholeMatch = "$0"

445+ renderToken (RRSubGroup g) = T.pack (show (rrGroupRefNum g))

446+

447+

263-- | 'createIndex' will create an index given a 'Server', 'IndexSettings', and an 'IndexName'.

448-- | 'createIndex' will create an index given a 'Server', 'IndexSettings', and an 'IndexName'.

264--

449--

265-- >>> response <- runBH' $ createIndex defaultIndexSettings (IndexName "didimakeanindex")

450-- >>> response <- runBH' $ createIndex defaultIndexSettings (IndexName "didimakeanindex")

@@ -339,16 +524,9 @@ optimizeIndex ixs IndexOptimizationSettings {..} =

339 , Just ("flush", Just (boolQP flushAfterOptimize))

524 , Just ("flush", Just (boolQP flushAfterOptimize))

340 ]

525 ]

341 indexName = indexSelectionName ixs

526 indexName = indexSelectionName ixs

342− boolQP True = "true"

343− boolQP False = "false"

344 body = Nothing

527 body = Nothing

345

528

346

529

347−-------------------------------------------------------------------------------

348−indexSelectionName :: IndexSelection -> Text

349−indexSelectionName (IndexList names) = T.intercalate "," [n | IndexName n <- toList names]

350−indexSelectionName AllIndexes = "_all"

351−

352deepMerge :: [Object] -> Object

530deepMerge :: [Object] -> Object

353deepMerge = LS.foldl' go mempty

531deepMerge = LS.foldl' go mempty

354 where go acc = LS.foldl' go' acc . HM.toList

532 where go acc = LS.foldl' go' acc . HM.toList

@@ -856,3 +1034,8 @@ basicAuthHook :: Monad m => EsUsername -> EsPassword -> Request -> m Request

856basicAuthHook (EsUsername u) (EsPassword p) = return . applyBasicAuth u' p'

1034basicAuthHook (EsUsername u) (EsPassword p) = return . applyBasicAuth u' p'

857 where u' = T.encodeUtf8 u

1035 where u' = T.encodeUtf8 u

858 p' = T.encodeUtf8 p

1036 p' = T.encodeUtf8 p

1037+

1038+

1039+boolQP :: Bool -> Text

1040+boolQP True = "true"

1041+boolQP False = "false"

src/Database/Bloodhound/Types.hs+489−16

@@ -5,10 +5,10 @@

5{-# LANGUAGE GeneralizedNewtypeDeriving #-}

6{-# LANGUAGE MultiParamTypeClasses #-}

7-- {-# LANGUAGE NoMonomorphismRestriction #-}

8+{-# LANGUAGE NamedFieldPuns #-}

8{-# LANGUAGE OverloadedStrings #-}

9{-# LANGUAGE OverloadedStrings #-}

9{-# LANGUAGE RecordWildCards #-}

10{-# LANGUAGE RecordWildCards #-}

10{-# LANGUAGE UndecidableInstances #-}

11{-# LANGUAGE UndecidableInstances #-}

11−{-# LANGUAGE NamedFieldPuns #-}

13-------------------------------------------------------------------------------

14-- |

@@ -69,6 +69,9 @@ module Database.Bloodhound.Types

69 , AllocationPolicy(..)

70 , ReplicaBounds(..)

71 , Bytes(..)

72+ , gigabytes

73+ , megabytes

74+ , kilobytes

72 , FSType(..)

75 , FSType(..)

73 , InitialShardCount(..)

76 , InitialShardCount(..)

74 , NodeAttrFilter(..)

77 , NodeAttrFilter(..)

@@ -235,6 +238,38 @@ module Database.Bloodhound.Types

235 , CollectionMode(..)

238 , CollectionMode(..)

236 , TermOrder(..)

239 , TermOrder(..)

237 , TermInclusion(..)

240 , TermInclusion(..)

241+ , SnapshotRepoSelection(..)

242+ , GenericSnapshotRepo(..)

243+ , SnapshotRepo(..)

244+ , SnapshotRepoConversionError(..)

245+ , SnapshotRepoType(..)

246+ , GenericSnapshotRepoSettings(..)

247+ , SnapshotRepoUpdateSettings(..)

248+ , defaultSnapshotRepoUpdateSettings

249+ , SnapshotRepoName(..)

250+ , SnapshotRepoPattern(..)

251+ , SnapshotVerification(..)

252+ , SnapshotNodeVerification(..)

253+ , FullNodeId(..)

254+ , NodeName(..)

255+ , FsSnapshotRepo(..)

256+ , SnapshotCreateSettings(..)

257+ , defaultSnapshotCreateSettings

258+ , SnapshotSelection(..)

259+ , SnapshotPattern(..)

260+ , SnapshotInfo(..)

261+ , SnapshotShardFailure(..)

262+ , ShardId(..)

263+ , SnapshotName(..)

264+ , SnapshotState(..)

265+ , SnapshotRestoreSettings(..)

266+ , defaultSnapshotRestoreSettings

267+ , RestoreRenamePattern(..)

268+ , RestoreRenameToken(..)

269+ , RRGroupRefNum

270+ , rrGroupRefNum

271+ , mkRRGroupRefNum

272+ , RestoreIndexSettings(..)

238

273

239 , Aggregation(..)

274 , Aggregation(..)

240 , Aggregations

275 , Aggregations

@@ -275,7 +310,7 @@ module Database.Bloodhound.Types

275 , EsPassword(..)

310 , EsPassword(..)

276 ) where

311 ) where

277

312

278−import Control.Applicative

313+import Control.Applicative as A

279import Control.Monad.Catch

314import Control.Monad.Catch

280import Control.Monad.Except

315import Control.Monad.Except

281import Control.Monad.Reader

316import Control.Monad.Reader

@@ -283,7 +318,7 @@ import Control.Monad.State

283import Control.Monad.Writer

318import Control.Monad.Writer

284import Data.Aeson

319import Data.Aeson

285import Data.Aeson.Types (Pair, Parser, emptyObject,

320import Data.Aeson.Types (Pair, Parser, emptyObject,

286− parseMaybe)

321+ parseEither, parseMaybe)

287import qualified Data.ByteString.Lazy.Char8 as L

322import qualified Data.ByteString.Lazy.Char8 as L

288import Data.Char

323import Data.Char

289import Data.Hashable (Hashable)

324import Data.Hashable (Hashable)

@@ -332,7 +367,7 @@ mkBHEnv s m = BHEnv s m return

332newtype BH m a = BH {

367newtype BH m a = BH {

333 unBH :: ReaderT BHEnv m a

368 unBH :: ReaderT BHEnv m a

334 } deriving ( Functor

369 } deriving ( Functor

335− , Applicative

370+ , A.Applicative

336 , Monad

371 , Monad

337 , MonadIO

372 , MonadIO

338 , MonadState s

373 , MonadState s

@@ -483,8 +518,31 @@ data ReplicaBounds = ReplicasBounded Int Int

483 | ReplicasUnbounded

518 | ReplicasUnbounded

484 deriving (Eq, Read, Show, Generic, Typeable)

519 deriving (Eq, Read, Show, Generic, Typeable)

485

520

521+-- | A measure of bytes used for various configurations. You may want

522+-- to use smart constructors like 'gigabytes' for larger values.

523+--

524+-- >>> gigabytes 9

525+-- Bytes 9000000000

526+--

527+-- >>> megabytes 9

528+-- Bytes 9000000

529+--

530+-- >>> kilobytes 9

531+-- Bytes 9000

486newtype Bytes = Bytes Int deriving (Eq, Read, Show, Generic, Typeable, Ord, ToJSON, FromJSON)

532newtype Bytes = Bytes Int deriving (Eq, Read, Show, Generic, Typeable, Ord, ToJSON, FromJSON)

487

533

534+gigabytes :: Int -> Bytes

535+gigabytes n = megabytes (1000 * n)

536+

537+

538+megabytes :: Int -> Bytes

539+megabytes n = kilobytes (1000 * n)

540+

541+

542+kilobytes :: Int -> Bytes

543+kilobytes n = Bytes (1000 * n)

544+

545+

488data FSType = FSSimple

546data FSType = FSSimple

489 | FSBuffered deriving (Eq, Read, Show, Generic, Typeable, Ord)

547 | FSBuffered deriving (Eq, Read, Show, Generic, Typeable, Ord)

490

548

@@ -803,6 +861,7 @@ newtype IndexName = IndexName Text deriving (Eq, Generic, Read, Show, ToJSON, Fr

803{-| 'IndexSelection' is used for APIs which take a single index, a list of

861{-| 'IndexSelection' is used for APIs which take a single index, a list of

804 indexes, or the special @_all@ index.

862 indexes, or the special @_all@ index.

805-}

863-}

864+--TODO: this does not fully support <https://www.elastic.co/guide/en/elasticsearch/reference/1.7/multi-index.html multi-index syntax>. It wouldn't be too hard to implement but you'd have to add the optional parameters (ignore_unavailable, allow_no_indices, expand_wildcards) to any APIs using it. Also would be a breaking API.

806data IndexSelection = IndexList (NonEmpty IndexName)

865data IndexSelection = IndexList (NonEmpty IndexName)

807 | AllIndexes deriving (Eq, Generic, Show, Typeable)

866 | AllIndexes deriving (Eq, Generic, Show, Typeable)

808

867

@@ -2947,7 +3006,7 @@ instance FromJSON UpdatableIndexSetting where

2947 <|> blocksWrite `taggedAt` ["blocks", "write"]

3006 <|> blocksWrite `taggedAt` ["blocks", "write"]

2948 <|> blocksMetaData `taggedAt` ["blocks", "metadata"]

3007 <|> blocksMetaData `taggedAt` ["blocks", "metadata"]

2949 where taggedAt f ks = taggedAt' f (Object o) ks

3008 where taggedAt f ks = taggedAt' f (Object o) ks

2950− taggedAt' f v [] = f =<< (parseJSON v <|> (parseJSON =<< unStringlyTypeJSON v))

3009+ taggedAt' f v [] = f =<< (parseJSON v <|> (parseJSON (unStringlyTypeJSON v)))

2951 taggedAt' f v (k:ks) = withObject "Object" (\o -> do v' <- o .: k

3010 taggedAt' f v (k:ks) = withObject "Object" (\o -> do v' <- o .: k

2952 taggedAt' f v' ks) v

3011 taggedAt' f v' ks) v

2953 numberOfReplicas = pure . NumberOfReplicas

3012 numberOfReplicas = pure . NumberOfReplicas

@@ -2989,18 +3048,17 @@ instance FromJSON IndexSettingsSummary where

2989 redundant (NumberOfReplicas _) = True

3048 redundant (NumberOfReplicas _) = True

2990 redundant _ = False

3049 redundant _ = False

2991

3050

2992−-- | For some reason in the settings API, all leaf values get returned

3051+-- | For some reason in several settings APIs, all leaf values get returned

2993-- as strings. This function attepmts to recover from this for all

3052-- as strings. This function attepmts to recover from this for all

2994−-- non-recursive JSON types. If nothing can be done or the same value

3053+-- non-recursive JSON types. If nothing can be done, the value is left alone.

2995−-- would be return, it returns 'mzero'

2996−unStringlyTypeJSON :: MonadPlus m => Value -> m Value

3054+unStringlyTypeJSON :: Value -> Value

2997−unStringlyTypeJSON (String "true") = return (Bool True)

3055+unStringlyTypeJSON (String "true") = Bool True

2998−unStringlyTypeJSON (String "false") = return (Bool False)

3056+unStringlyTypeJSON (String "false") = Bool False

2999−unStringlyTypeJSON (String "null") = return Null

3057+unStringlyTypeJSON (String "null") = Null

3000−unStringlyTypeJSON (String t) = case readMay (T.unpack t) of

3058+unStringlyTypeJSON v@(String t) = case readMay (T.unpack t) of

3001− Just n -> return (Number n)

3059+ Just n -> Number n

3002− Nothing -> mzero

3060+ Nothing -> v

3003−unStringlyTypeJSON _ = mzero

3061+unStringlyTypeJSON v = v

3004

3062

3005

3063

3006parseSettings :: Object -> Parser [UpdatableIndexSetting]

3064parseSettings :: Object -> Parser [UpdatableIndexSetting]

@@ -3625,3 +3683,418 @@ newtype EsUsername = EsUsername { esUsername :: Text } deriving (Read, Show, Eq)

3625

3683

3626-- | Password type used for HTTP Basic authentication. See 'basicAuthHook'.

3684-- | Password type used for HTTP Basic authentication. See 'basicAuthHook'.

3627newtype EsPassword = EsPassword { esPassword :: Text } deriving (Read, Show, Eq)

3685newtype EsPassword = EsPassword { esPassword :: Text } deriving (Read, Show, Eq)

3686+

3687+

3688+data SnapshotRepoSelection = SnapshotRepoList (NonEmpty SnapshotRepoPattern)

3689+ | AllSnapshotRepos deriving (Eq, Generic, Show, Typeable)

3690+

3691+

3692+-- | Either specifies an exact repo name or one with globs in it,

3693+-- e.g. @RepoPattern "foo*"@ __NOTE__: Patterns are not supported on ES < 1.7

3694+data SnapshotRepoPattern = ExactRepo SnapshotRepoName

3695+ | RepoPattern Text

3696+ deriving (Eq, Generic, Show, Typeable)

3697+

3698+-- | The unique name of a snapshot repository.

3699+newtype SnapshotRepoName = SnapshotRepoName { snapshotRepoName :: Text }

3700+ deriving (Eq, Ord, Generic, Show, Typeable, ToJSON, FromJSON)

3701+

3702+

3703+-- | A generic representation of a snapshot repo. This is what gets

3704+-- sent to and parsed from the server. For repo types enabled by

3705+-- plugins that aren't exported by this library, consider making a

3706+-- custom type which implements 'SnapshotRepo'. If it is a common repo

3707+-- type, consider submitting a pull request to have it included in the

3708+-- library proper

3709+data GenericSnapshotRepo = GenericSnapshotRepo {

3710+ gSnapshotRepoName :: SnapshotRepoName

3711+ , gSnapshotRepoType :: SnapshotRepoType

3712+ , gSnapshotRepoSettings :: GenericSnapshotRepoSettings

3713+ } deriving (Eq, Generic, Show, Typeable)

3714+

3715+

3716+instance SnapshotRepo GenericSnapshotRepo where

3717+ toGSnapshotRepo = id

3718+ fromGSnapshotRepo = Right

3719+

3720+

3721+newtype SnapshotRepoType = SnapshotRepoType { snapshotRepoType :: Text }

3722+ deriving (Eq, Ord, Generic, Show, Typeable, ToJSON, FromJSON)

3723+

3724+

3725+-- | Opaque representation of snapshot repo settings. Instances of

3726+-- 'SnapshotRepo' will produce this.

3727+newtype GenericSnapshotRepoSettings = GenericSnapshotRepoSettings { gSnapshotRepoSettingsObject :: Object }

3728+ deriving (Eq, Generic, Show, Typeable, ToJSON)

3729+

3730+

3731+ -- Regardless of whether you send strongly typed json, my version of

3732+ -- ES sends back stringly typed json in the settings, e.g. booleans

3733+ -- as strings, so we'll try to convert them.

3734+instance FromJSON GenericSnapshotRepoSettings where

3735+ parseJSON = fmap (GenericSnapshotRepoSettings . fmap unStringlyTypeJSON). parseJSON

3736+

3737+-- | The result of running 'verifySnapshotRepo'.

3738+newtype SnapshotVerification = SnapshotVerification { snapshotNodeVerifications :: [SnapshotNodeVerification] }

3739+ deriving (Eq, Generic, Show, Typeable)

3740+

3741+

3742+instance FromJSON SnapshotVerification where

3743+ parseJSON = withObject "SnapshotVerification" parse

3744+ where

3745+ parse o = do

3746+ o2 <- o .: "nodes"

3747+ SnapshotVerification <$> mapM (uncurry parse') (HM.toList o2)

3748+ parse' rawFullId = withObject "SnapshotNodeVerification" $ \o ->

3749+ SnapshotNodeVerification (FullNodeId rawFullId) <$> o .: "name"

3750+

3751+

3752+-- | A node that has verified a snapshot

3753+data SnapshotNodeVerification = SnapshotNodeVerification {

3754+ snvFullId :: FullNodeId

3755+ , snvNodeName :: NodeName

3756+ } deriving (Eq, Generic, Show, Typeable)

3757+

3758+

3759+-- | Unique, automatically-generated name assigned to nodes that are

3760+-- usually returned in node-oriented APIs.

3761+newtype FullNodeId = FullNodeId { fullNodeId :: Text }

3762+ deriving (Eq, Ord, Generic, Show, Typeable, FromJSON)

3763+

3764+

3765+-- | A human-readable node name that is supplied by the user in the

3766+-- node config or automatically generated by ElasticSearch.

3767+newtype NodeName = NodeName { nodeName :: Text }

3768+ deriving (Eq, Ord, Generic, Show, Typeable, FromJSON)

3769+

3770+

3771+data SnapshotRepoUpdateSettings = SnapshotRepoUpdateSettings {

3772+ repoUpdateVerify :: Bool

3773+ -- ^ After creation/update, synchronously check that nodes can

3774+ -- write to this repo. Defaults to True. You may use False if you

3775+ -- need a faster response and plan on verifying manually later

3776+ -- with 'verifySnapshotRepo'.

3777+ } deriving (Eq, Show, Generic, Typeable)

3778+

3779+

3780+-- | Reasonable defaults for repo creation/update

3781+--

3782+-- * repoUpdateVerify True

3783+defaultSnapshotRepoUpdateSettings :: SnapshotRepoUpdateSettings

3784+defaultSnapshotRepoUpdateSettings = SnapshotRepoUpdateSettings True

3785+

3786+

3787+-- | A filesystem-based snapshot repo that ships with

3788+-- ElasticSearch. This is an instance of 'SnapshotRepo' so it can be

3789+-- used with 'updateSnapshotRepo'

3790+data FsSnapshotRepo = FsSnapshotRepo {

3791+ fsrName :: SnapshotRepoName

3792+ , fsrLocation :: FilePath

3793+ , fsrCompressMetadata :: Bool

3794+ , fsrChunkSize :: Maybe Bytes

3795+ -- ^ Size by which to split large files during snapshotting.

3796+ , fsrMaxRestoreBytesPerSec :: Maybe Bytes

3797+ -- ^ Throttle node restore rate. If not supplied, defaults to 40mb/sec

3798+ , fsrMaxSnapshotBytesPerSec :: Maybe Bytes

3799+ -- ^ Throttle node snapshot rate. If not supplied, defaults to 40mb/sec

3800+ } deriving (Eq, Generic, Show, Typeable)

3801+

3802+

3803+instance SnapshotRepo FsSnapshotRepo where

3804+ toGSnapshotRepo FsSnapshotRepo {..} =

3805+ GenericSnapshotRepo fsrName fsRepoType (GenericSnapshotRepoSettings settings)

3806+ where

3807+ Object settings = object $ [ "location" .= fsrLocation

3808+ , "compress" .= fsrCompressMetadata

3809+ ] ++ optionalPairs

3810+ optionalPairs = catMaybes [ ("chunk_size" .=) <$> fsrChunkSize

3811+ , ("max_restore_bytes_per_sec" .=) <$> fsrMaxRestoreBytesPerSec

3812+ , ("max_snapshot_bytes_per_sec" .=) <$> fsrMaxSnapshotBytesPerSec

3813+ ]

3814+ fromGSnapshotRepo GenericSnapshotRepo {..}

3815+ | gSnapshotRepoType == fsRepoType = do

3816+ let o = gSnapshotRepoSettingsObject gSnapshotRepoSettings

3817+ parseRepo $ do

3818+ FsSnapshotRepo gSnapshotRepoName <$> o .: "location"

3819+ <*> o .:? "compress" .!= False

3820+ <*> o .:? "chunk_size"

3821+ <*> o .:? "max_restore_bytes_per_sec"

3822+ <*> o .:? "max_snapshot_bytes_per_sec"

3823+ | otherwise = Left (RepoTypeMismatch fsRepoType gSnapshotRepoType)

3824+

3825+

3826+parseRepo :: Parser a -> Either SnapshotRepoConversionError a

3827+parseRepo parser = case parseEither (const parser) () of

3828+ Left e -> Left (OtherRepoConversionError (T.pack e))

3829+ Right a -> Right a

3830+

3831+

3832+fsRepoType :: SnapshotRepoType

3833+fsRepoType = SnapshotRepoType "fs"

3834+

3835+-- | Law: fromGSnapshotRepo (toGSnapshotRepo r) == Right r

3836+class SnapshotRepo r where

3837+ toGSnapshotRepo :: r -> GenericSnapshotRepo

3838+ fromGSnapshotRepo :: GenericSnapshotRepo -> Either SnapshotRepoConversionError r

3839+

3840+

3841+data SnapshotRepoConversionError = RepoTypeMismatch SnapshotRepoType SnapshotRepoType

3842+ -- ^ Expected type and actual type

3843+ | OtherRepoConversionError Text

3844+ deriving (Show, Eq, Generic, Typeable)

3845+

3846+

3847+instance Exception SnapshotRepoConversionError

3848+

3849+

3850+data SnapshotCreateSettings = SnapshotCreateSettings {

3851+ snapWaitForCompletion :: Bool

3852+ -- ^ Should the API call return immediately after initializing

3853+ -- the snapshot or wait until completed? Note that if this is

3854+ -- enabled it could wait a long time, so you should adjust your

3855+ -- 'ManagerSettings' accordingly to set long timeouts or

3856+ -- explicitly handle timeouts.

3857+ , snapIndices :: Maybe IndexSelection

3858+ -- ^ Nothing will snapshot all indices. Just [] is permissable and

3859+ -- will essentially be a no-op snapshot.

3860+ , snapIgnoreUnavailable :: Bool

3861+ -- ^ If set to True, any matched indices that don't exist will be

3862+ -- ignored. Otherwise it will be an error and fail.

3863+ , snapIncludeGlobalState :: Bool

3864+ , snapPartial :: Bool

3865+ -- ^ If some indices failed to snapshot (e.g. if not all primary

3866+ -- shards are available), should the process proceed?

3867+ } deriving (Eq, Generic, Show, Typeable)

3868+

3869+

3870+-- | Reasonable defaults for snapshot creation

3871+--

3872+-- * snapWaitForCompletion False

3873+-- * snapIndices Nothing

3874+-- * snapIgnoreUnavailable False

3875+-- * snapIncludeGlobalState True

3876+-- * snapPartial False

3877+defaultSnapshotCreateSettings :: SnapshotCreateSettings

3878+defaultSnapshotCreateSettings = SnapshotCreateSettings {

3879+ snapWaitForCompletion = False

3880+ , snapIndices = Nothing

3881+ , snapIgnoreUnavailable = False

3882+ , snapIncludeGlobalState = True

3883+ , snapPartial = False

3884+ }

3885+

3886+

3887+data SnapshotSelection = SnapshotList (NonEmpty SnapshotPattern)

3888+ | AllSnapshots deriving (Eq, Generic, Show, Typeable)

3889+

3890+

3891+-- | Either specifies an exact snapshot name or one with globs in it,

3892+-- e.g. @SnapPattern "foo*"@ __NOTE__: Patterns are not supported on

3893+-- ES < 1.7

3894+data SnapshotPattern = ExactSnap SnapshotName

3895+ | SnapPattern Text

3896+ deriving (Eq, Generic, Show, Typeable)

3897+

3898+

3899+-- | General information about the state of a snapshot. Has some

3900+-- redundancies with 'SnapshotStatus'

3901+data SnapshotInfo = SnapshotInfo {

3902+ snapInfoShards :: ShardResult

3903+ , snapInfoFailures :: [SnapshotShardFailure]

3904+ , snapInfoDuration :: NominalDiffTime

3905+ , snapInfoEndTime :: UTCTime

3906+ , snapInfoStartTime :: UTCTime

3907+ , snapInfoState :: SnapshotState

3908+ , snapInfoIndices :: [IndexName]

3909+ , snapInfoName :: SnapshotName

3910+ } deriving (Eq, Generic, Show, Typeable)

3911+

3912+

3913+instance FromJSON SnapshotInfo where

3914+ parseJSON = withObject "SnapshotInfo" parse

3915+ where

3916+ parse o = SnapshotInfo <$> o .: "shards"

3917+ <*> o .: "failures"

3918+ <*> (unMS <$> o .: "duration_in_millis")

3919+ <*> (posixMS <$> o .: "end_time_in_millis")

3920+ <*> (posixMS <$> o .: "start_time_in_millis")

3921+ <*> o .: "state"

3922+ <*> o .: "indices"

3923+ <*> o .: "snapshot"

3924+

3925+data SnapshotShardFailure = SnapshotShardFailure {

3926+ snapShardFailureIndex :: IndexName

3927+ , snapShardFailureNodeId :: Maybe NodeName -- I'm not 100% sure this isn't actually 'FullNodeId'

3928+ , snapShardFailureReason :: Text

3929+ , snapShardFailureShardId :: ShardId

3930+ } deriving (Eq, Show, Generic, Typeable)

3931+

3932+

3933+instance FromJSON SnapshotShardFailure where

3934+ parseJSON = withObject "SnapshotShardFailure" parse

3935+ where

3936+ parse o = SnapshotShardFailure <$> o .: "index"

3937+ <*> o .:? "node_id"

3938+ <*> o .: "reason"

3939+ <*> o .: "shard_id"

3940+

3941+

3942+newtype ShardId = ShardId { shardId :: Int }

3943+ deriving (Eq, Show, Generic, Typeable, FromJSON)

3944+

3945+-- | Milliseconds

3946+newtype MS = MS NominalDiffTime

3947+

3948+

3949+-- keeps the unexported constructor warnings at bay

3950+unMS :: MS -> NominalDiffTime

3951+unMS (MS t) = t

3952+

3953+

3954+instance FromJSON MS where

3955+ parseJSON = withScientific "MS" (return . MS . parse)

3956+ where

3957+ parse n = fromInteger ((truncate n) * 1000)

3958+

3959+

3960+data SnapshotState = SnapshotInit

3961+ | SnapshotStarted

3962+ | SnapshotSuccess

3963+ | SnapshotFailed

3964+ | SnapshotAborted

3965+ | SnapshotMissing

3966+ | SnapshotWaiting

3967+ deriving (Show, Eq, Generic, Typeable)

3968+

3969+instance FromJSON SnapshotState where

3970+ parseJSON = withText "SnapshotState" parse

3971+ where

3972+ parse "INIT" = return SnapshotInit

3973+ parse "STARTED" = return SnapshotStarted

3974+ parse "SUCCESS" = return SnapshotSuccess

3975+ parse "FAILED" = return SnapshotFailed

3976+ parse "ABORTED" = return SnapshotAborted

3977+ parse "MISSING" = return SnapshotMissing

3978+ parse "WAITING" = return SnapshotWaiting

3979+ parse t = fail ("Invalid snapshot state " <> T.unpack t)

3980+

3981+

3982+newtype SnapshotName = SnapshotName { snapshotName :: Text }

3983+ deriving (Show, Eq, Ord, Generic, Typeable, ToJSON, FromJSON)

3984+

3985+

3986+data SnapshotRestoreSettings = SnapshotRestoreSettings {

3987+ snapRestoreWaitForCompletion :: Bool

3988+ -- ^ Should the API call return immediately after initializing

3989+ -- the restore or wait until completed? Note that if this is

3990+ -- enabled, it could wait a long time, so you should adjust your

3991+ -- 'ManagerSettings' accordingly to set long timeouts or

3992+ -- explicitly handle timeouts.

3993+ , snapRestoreIndices :: Maybe IndexSelection

3994+ -- ^ Nothing will restore all indices in the snapshot. Just [] is

3995+ -- permissable and will essentially be a no-op restore.

3996+ , snapRestoreIgnoreUnavailable :: Bool

3997+ -- ^ If set to True, any indices that do not exist will be ignored

3998+ -- during snapshot rather than failing the restore.

3999+ , snapRestoreIncludeGlobalState :: Bool

4000+ -- ^ If set to false, will ignore any global state in the snapshot

4001+ -- and will not restore it.

4002+ , snapRestoreRenamePattern :: Maybe RestoreRenamePattern

4003+ -- ^ A regex pattern for matching indices. Used with

4004+ -- 'snapRestoreRenameReplacement', the restore can reference the

4005+ -- matched index and create a new index name upon restore.

4006+ , snapRestoreRenameReplacement :: Maybe (NonEmpty RestoreRenameToken)

4007+ -- ^ Expression of how index renames should be constructed.

4008+ , snapRestorePartial :: Bool

4009+ -- ^ If some indices fail to restore, should the process proceed?

4010+ , snapRestoreIncludeAliases :: Bool

4011+ -- ^ Should the restore also restore the aliases captured in the

4012+ -- snapshot.

4013+ , snapRestoreIndexSettingsOverrides :: Maybe RestoreIndexSettings

4014+ -- ^ Settings to apply during the restore process. __NOTE:__ This

4015+ -- option is not supported in ES < 1.5 and should be set to

4016+ -- Nothing in that case.

4017+ , snapRestoreIgnoreIndexSettings :: Maybe (NonEmpty Text)

4018+ -- ^ This type could be more rich but it isn't clear which

4019+ -- settings are allowed to be ignored during restore, so we're

4020+ -- going with including this feature in a basic form rather than

4021+ -- omitting it. One example here would be

4022+ -- "index.refresh_interval". Any setting specified here will

4023+ -- revert back to the server default during the restore process.

4024+ } deriving (Eq, Generic, Show, Typeable)

4025+

4026+-- | Regex-stype pattern, e.g. "index_(.+)" to match index names

4027+newtype RestoreRenamePattern = RestoreRenamePattern { rrPattern :: Text }

4028+ deriving (Show, Eq, Generic, Typeable, Ord, ToJSON)

4029+

4030+

4031+-- | A single token in a index renaming scheme for a restore. These

4032+-- are concatenated into a string before being sent to

4033+-- ElasticSearch. Check out these Java

4034+-- <https://docs.oracle.com/javase/7/docs/api/java/util/regex/Matcher.html docs> to find out more if you're into that sort of thing.

4035+data RestoreRenameToken = RRTLit Text

4036+ -- ^ Just a literal string of characters

4037+ | RRSubWholeMatch

4038+ -- ^ Equivalent to $0. The entire matched pattern, not any subgroup

4039+ | RRSubGroup RRGroupRefNum

4040+ -- ^ A specific reference to a group number

4041+ deriving (Show, Eq, Generic, Typeable)

4042+

4043+

4044+-- | A group number for regex matching. Only values from 1-9 are

4045+-- supported. Construct with 'mkRRGroupRefNum'

4046+newtype RRGroupRefNum = RRGroupRefNum { rrGroupRefNum :: Int }

4047+ deriving (Show, Eq, Generic, Typeable, Ord)

4048+

4049+instance Bounded RRGroupRefNum where

4050+ minBound = RRGroupRefNum 1

4051+ maxBound = RRGroupRefNum 9

4052+

4053+

4054+-- | Only allows valid group number references (1-9).

4055+mkRRGroupRefNum :: Int -> Maybe RRGroupRefNum

4056+mkRRGroupRefNum i

4057+ | i >= (rrGroupRefNum minBound) && i <= (rrGroupRefNum maxBound) =

4058+ Just $ RRGroupRefNum i

4059+ | otherwise = Nothing

4060+

4061+

4062+-- | Reasonable defaults for snapshot restores

4063+--

4064+-- * snapRestoreWaitForCompletion False

4065+-- * snapRestoreIndices Nothing

4066+-- * snapRestoreIgnoreUnavailable False

4067+-- * snapRestoreIncludeGlobalState True

4068+-- * snapRestoreRenamePattern Nothing

4069+-- * snapRestoreRenameReplacement Nothing

4070+-- * snapRestorePartial False

4071+-- * snapRestoreIncludeAliases True

4072+-- * snapRestoreIndexSettingsOverrides Nothing

4073+-- * snapRestoreIgnoreIndexSettings Nothing

4074+defaultSnapshotRestoreSettings :: SnapshotRestoreSettings

4075+defaultSnapshotRestoreSettings = SnapshotRestoreSettings {

4076+ snapRestoreWaitForCompletion = False

4077+ , snapRestoreIndices = Nothing

4078+ , snapRestoreIgnoreUnavailable = False

4079+ , snapRestoreIncludeGlobalState = True

4080+ , snapRestoreRenamePattern = Nothing

4081+ , snapRestoreRenameReplacement = Nothing

4082+ , snapRestorePartial = False

4083+ , snapRestoreIncludeAliases = True

4084+ , snapRestoreIndexSettingsOverrides = Nothing

4085+ , snapRestoreIgnoreIndexSettings = Nothing

4086+ }

4087+

4088+

4089+-- | Index settings that can be overridden. The docs only mention you

4090+-- can update number of replicas, but there may be more. You

4091+-- definitely cannot override shard count.

4092+data RestoreIndexSettings = RestoreIndexSettings {

4093+ restoreOverrideReplicas :: Maybe ReplicaCount

4094+ } deriving (Show, Eq, Generic, Typeable)

4095+

4096+

4097+instance ToJSON RestoreIndexSettings where

4098+ toJSON RestoreIndexSettings {..} = object prs

4099+ where

4100+ prs = catMaybes [("index.number_of_replicas" .=) <$> restoreOverrideReplicas]

src/Database/Bloodhound/Types/Internal.hs+2−2

@@ -22,7 +22,7 @@ module Database.Bloodhound.Types.Internal

22 ) where

25−import Control.Applicative

25+import Control.Applicative as A

26import Control.Monad.Reader

27import Data.Text (Text)

28import Data.Typeable (Typeable)

@@ -51,6 +51,6 @@ newtype Server = Server Text deriving (Eq, Show, Generic, Typeable)

51 own monad transformer stack. A default instance for a ReaderT and

52 alias 'BH' is provided for the simple case.

53-}

54−class (Functor m, Applicative m, MonadIO m) => MonadBH m where

54+class (Functor m, A.Applicative m, MonadIO m) => MonadBH m where

55 getBHEnv :: m BHEnv

stack-7.10.yaml+1

@@ -12,4 +12,5 @@ extra-deps:

12- quickcheck-properties-0.1

13- semigroups-0.18.0.1

14- uri-bytestring-0.1.9

15+- temporary-resourcet-0.1.0.0

15resolver: lts-5.1

16resolver: lts-5.1

tests/tests.hs+213−7

@@ -3,6 +3,7 @@

3{-# LANGUAGE FlexibleContexts #-}

4{-# LANGUAGE GeneralizedNewtypeDeriving #-}

5{-# LANGUAGE OverloadedStrings #-}

6+{-# LANGUAGE RecordWildCards #-}

6{-# LANGUAGE ScopedTypeVariables #-}

7{-# LANGUAGE ScopedTypeVariables #-}

7{-# LANGUAGE TemplateHaskell #-}

8{-# LANGUAGE TemplateHaskell #-}

8{-# LANGUAGE TypeOperators #-}

9{-# LANGUAGE TypeOperators #-}

@@ -11,8 +12,9 @@ module Main where

12import Control.Applicative

13import Control.Applicative

13import Control.Error

14import Control.Error

14−import Control.Exception

15+import Control.Exception (evaluate)

15import Control.Monad

16import Control.Monad

17+import Control.Monad.Catch

16import Control.Monad.Reader

18import Control.Monad.Reader

17import Data.Aeson

19import Data.Aeson

18import Data.Aeson.Types (parseEither)

20import Data.Aeson.Types (parseEither)

@@ -25,6 +27,7 @@ import Data.List.NonEmpty (NonEmpty (..))

25import qualified Data.List.NonEmpty as NE

27import qualified Data.List.NonEmpty as NE

26import qualified Data.Map.Strict as M

28import qualified Data.Map.Strict as M

27import Data.Monoid

29import Data.Monoid

30+import Data.Ord (comparing)

28import Data.Proxy

31import Data.Proxy

29import Data.Text (Text)

32import Data.Text (Text)

30import qualified Data.Text as T

33import qualified Data.Text as T

@@ -36,14 +39,19 @@ import qualified Data.Vector as V

36import Database.Bloodhound

39import Database.Bloodhound

37import GHC.Generics as G

40import GHC.Generics as G

38import Network.HTTP.Client hiding (Proxy)

41import Network.HTTP.Client hiding (Proxy)

42+import qualified Network.HTTP.Types.Method as NHTM

39import qualified Network.HTTP.Types.Status as NHTS

43import qualified Network.HTTP.Types.Status as NHTS

44+import qualified Network.URI as URI

40import Prelude hiding (filter)

45import Prelude hiding (filter)

46+import System.IO.Temp

47+import System.Posix.Files

41import Test.Hspec

48import Test.Hspec

42import Test.QuickCheck.Property.Monoid (T (..), eq, prop_Monoid)

49import Test.QuickCheck.Property.Monoid (T (..), eq, prop_Monoid)

44import Test.Hspec.QuickCheck (prop)

51import Test.Hspec.QuickCheck (prop)

45import Test.QuickCheck

52import Test.QuickCheck

54+

47testServer :: Server

55testServer :: Server

48testServer = Server "http://localhost:9200"

56testServer = Server "http://localhost:9200"

49testIndex :: IndexName

57testIndex :: IndexName

@@ -54,14 +62,18 @@ testMapping = MappingName "tweet"

54withTestEnv :: BH IO a -> IO a

62withTestEnv :: BH IO a -> IO a

55withTestEnv = withBH defaultManagerSettings testServer

63withTestEnv = withBH defaultManagerSettings testServer

57−validateStatus :: Response body -> Int -> Expectation

65+validateStatus :: Show body => Response body -> Int -> Expectation

58validateStatus resp expected =

66validateStatus resp expected =

67+ if actual == expected

68+ then return ()

69+ else expectationFailure ("Expected " <> show expected <> " but got " <> show actual <> ": " <> show body)

70+ where

59− (NHTS.statusCode $ responseStatus resp)

71+ actual = NHTS.statusCode (responseStatus resp)

60− `shouldBe` (expected :: Int)

72+ body = responseBody resp

62−createExampleIndex :: BH IO Reply

74+createExampleIndex :: (MonadBH m) => m Reply

63createExampleIndex = createIndex (IndexSettings (ShardCount 1) (ReplicaCount 0)) testIndex

75createExampleIndex = createIndex (IndexSettings (ShardCount 1) (ReplicaCount 0)) testIndex

64−deleteExampleIndex :: BH IO Reply

76+deleteExampleIndex :: (MonadBH m) => m Reply

65deleteExampleIndex = deleteIndex testIndex

77deleteExampleIndex = deleteIndex testIndex

67data ServerVersion = ServerVersion Int Int Int deriving (Show, Eq, Ord)

79data ServerVersion = ServerVersion Int Int Int deriving (Show, Eq, Ord)

@@ -75,6 +87,15 @@ es12 = ServerVersion 1 2 0

75es11 :: ServerVersion

87es11 :: ServerVersion

76es11 = ServerVersion 1 1 0

88es11 = ServerVersion 1 1 0

90+es14 :: ServerVersion

91+es14 = ServerVersion 1 4 0

92+

93+es15 :: ServerVersion

94+es15 = ServerVersion 1 5 0

95+

96+es16 :: ServerVersion

97+es16 = ServerVersion 1 6 0

98+

78serverBranch :: ServerVersion -> ServerVersion

99serverBranch :: ServerVersion -> ServerVersion

79serverBranch (ServerVersion majorVer minorVer patchVer) =

100serverBranch (ServerVersion majorVer minorVer patchVer) =

80 ServerVersion majorVer minorVer patchVer

101 ServerVersion majorVer minorVer patchVer

@@ -92,6 +113,33 @@ getServerVersion = liftM extractVersion (withTestEnv getStatus)

92 parseVersion v = map toInt (version' v)

113 parseVersion v = map toInt (version' v)

93 extractVersion = join . liftM (mkServerVersion . parseVersion)

114 extractVersion = join . liftM (mkServerVersion . parseVersion)

115

116+-- | Get configured repo paths for snapshotting. Note that by default

117+-- this is not enabled and if we are over es 1.5, we won't be able to

118+-- test snapshotting. Note that this can and should be part of the

119+-- client functionality in a much less ad-hoc incarnation.

120+getRepoPaths :: IO [FilePath]

121+getRepoPaths = withTestEnv $ do

122+ bhe <- getBHEnv

123+ let Server s = bhServer bhe

124+ let tUrl = s <> "/" <> "_nodes"

125+ initReq <- parseRequest (URI.escapeURIString URI.isAllowedInURI (T.unpack tUrl))

126+ let req = setRequestIgnoreStatus $ initReq { method = NHTM.methodGet }

127+ Right (Object o) <- parseEsResponse =<< liftIO (httpLbs req (bhManager bhe))

128+ return $ fromMaybe mempty $ do

129+ Object nodes <- HM.lookup "nodes" o

130+ Object firstNode <- snd <$> headMay (HM.toList nodes)

131+ Object settings <- HM.lookup "settings" firstNode

132+ Object path <- HM.lookup "path" settings

133+ Array repo <- HM.lookup "repo" path

134+ return [ T.unpack t | String t <- V.toList repo]

135+

136+-- | 1.5 and earlier don't care about repo paths

137+canSnapshot :: IO Bool

138+canSnapshot = do

139+ caresAboutRepos <- atleast es16

140+ repoPaths <- getRepoPaths

141+ return (not caresAboutRepos || not (null (repoPaths)))

142+

95testServerBranch :: IO (Maybe ServerVersion)

143testServerBranch :: IO (Maybe ServerVersion)

96testServerBranch = getServerVersion >>= \v -> return $ liftM serverBranch v

144testServerBranch = getServerVersion >>= \v -> return $ liftM serverBranch v

145

@@ -312,6 +360,57 @@ searchExpectSource src expected = do

312 liftIO $

360 liftIO $

313 value `shouldBe` expected

361 value `shouldBe` expected

314

362

363+withSnapshotRepo

364+ :: ( MonadMask m

365+ , MonadBH m

366+ )

367+ => SnapshotRepoName

368+ -> (GenericSnapshotRepo -> m a)

369+ -> m a

370+withSnapshotRepo srn@(SnapshotRepoName n) f = do

371+ repoPaths <- liftIO getRepoPaths

372+ -- we'll use the first repo path if available, otherwise system temp

373+ -- dir. Note that this will fail on ES > 1.6, so be sure you use

374+ -- @when' canSnapshot@.

375+ case repoPaths of

376+ (firstRepoPath:_) -> withTempDirectory firstRepoPath (T.unpack n) $ \dir -> bracket (alloc dir) free f

377+ [] -> withSystemTempDirectory (T.unpack n) $ \dir -> bracket (alloc dir) free f

378+ where

379+ alloc dir = do

380+ liftIO (setFileMode dir mode)

381+ let repo = FsSnapshotRepo srn "bloodhound-tests-backups" True Nothing Nothing Nothing

382+ resp <- updateSnapshotRepo defaultSnapshotRepoUpdateSettings repo

383+ liftIO (validateStatus resp 200)

384+ return (toGSnapshotRepo repo)

385+ mode = ownerModes `unionFileModes` groupModes `unionFileModes` otherModes

386+ free GenericSnapshotRepo {..} = do

387+ resp <- deleteSnapshotRepo gSnapshotRepoName

388+ liftIO (validateStatus resp 200)

389+

390+

391+withSnapshot

392+ :: ( MonadMask m

393+ , MonadBH m

394+ )

395+ => SnapshotRepoName

396+ -> SnapshotName

397+ -> m a

398+ -> m a

399+withSnapshot srn sn = bracket_ alloc free

400+ where

401+ alloc = do

402+ resp <- createSnapshot srn sn createSettings

403+ liftIO (validateStatus resp 200)

404+ -- We'll make this synchronous for testing purposes

405+ createSettings = defaultSnapshotCreateSettings { snapWaitForCompletion = True

406+ , snapIndices = Just (IndexList (testIndex :| []))

407+ -- We don't actually need to back up any data

408+ }

409+ free = do

410+ deleteSnapshot srn sn

411+

412+

413+

315data BulkTest = BulkTest { name :: Text } deriving (Eq, Generic, Show)

414data BulkTest = BulkTest { name :: Text } deriving (Eq, Generic, Show)

316instance FromJSON BulkTest where

415instance FromJSON BulkTest where

317 parseJSON = genericParseJSON defaultOptions

416 parseJSON = genericParseJSON defaultOptions

@@ -773,7 +872,8 @@ $(derive makeArbitrary ''AllocationPolicy)

773$(derive makeArbitrary ''InitialShardCount)

872$(derive makeArbitrary ''InitialShardCount)

774$(derive makeArbitrary ''FSType)

873$(derive makeArbitrary ''FSType)

775$(derive makeArbitrary ''CompoundFormat)

874$(derive makeArbitrary ''CompoundFormat)

776−

875+$(derive makeArbitrary ''FsSnapshotRepo)

876+$(derive makeArbitrary ''SnapshotRepoName)

777

877

778main :: IO ()

878main :: IO ()

779main = hspec $ do

879main = hspec $ do

@@ -1365,6 +1465,112 @@ main = hspec $ do

1365 (dv <= maxBound) .&&.

1465 (dv <= maxBound) .&&.

1366 docVersionNumber dv === i

1466 docVersionNumber dv === i

1367

1467

1468+ describe "FsSnapshotRepo" $ do

1469+ prop "SnapshotRepo laws" $ \fsr ->

1470+ fromGSnapshotRepo (toGSnapshotRepo fsr) === Right (fsr :: FsSnapshotRepo)

1471+

1472+ describe "snapshot repos" $ do

1473+ it "always parses all snapshot repos API" $ when' canSnapshot $ withTestEnv $ do

1474+ res <- getSnapshotRepos AllSnapshotRepos

1475+ liftIO $ case res of

1476+ Left e -> expectationFailure ("Expected a right but got Left " <> show e)

1477+ Right _ -> return ()

1478+

1479+ it "finds an existing list of repos" $ when' canSnapshot $ withTestEnv $ do

1480+ let r1n = SnapshotRepoName "bloodhound-repo1"

1481+ let r2n = SnapshotRepoName "bloodhound-repo2"

1482+ withSnapshotRepo r1n $ \r1 ->

1483+ withSnapshotRepo r2n $ \r2 -> do

1484+ repos <- getSnapshotRepos (SnapshotRepoList (ExactRepo r1n :| [ExactRepo r2n]))

1485+ liftIO $ case repos of

1486+ Right xs -> do

1487+ let srt = L.sortBy (comparing gSnapshotRepoName)

1488+ srt xs `shouldBe` srt [r1, r2]

1489+ Left e -> expectationFailure (show e)

1490+

1491+ it "creates and updates with updateSnapshotRepo" $ when' canSnapshot $ withTestEnv $ do

1492+ let r1n = SnapshotRepoName "bloodhound-repo1"

1493+ withSnapshotRepo r1n $ \r1 -> do

1494+ let Just (String dir) = HM.lookup "location" (gSnapshotRepoSettingsObject (gSnapshotRepoSettings r1))

1495+ let noCompression = FsSnapshotRepo r1n (T.unpack dir) False Nothing Nothing Nothing

1496+ resp <- updateSnapshotRepo defaultSnapshotRepoUpdateSettings noCompression

1497+ liftIO (validateStatus resp 200)

1498+ Right [roundtrippedNoCompression] <- getSnapshotRepos (SnapshotRepoList (ExactRepo r1n :| []))

1499+ liftIO (roundtrippedNoCompression `shouldBe` toGSnapshotRepo noCompression)

1500+

1501+ -- verify came around in 1.4 it seems

1502+ it "can verify existing repos" $ when' canSnapshot $ when' (atleast es14) $ withTestEnv $ do

1503+ let r1n = SnapshotRepoName "bloodhound-repo1"

1504+ withSnapshotRepo r1n $ \_ -> do

1505+ res <- verifySnapshotRepo r1n

1506+ liftIO $ case res of

1507+ Right (SnapshotVerification vs)

1508+ | null vs -> expectationFailure "Expected nonempty set of verifying nodes"

1509+ | otherwise -> return ()

1510+ Left e -> expectationFailure (show e)

1511+

1512+ describe "snapshots" $ do

1513+ it "always parses all snapshots API" $ when' canSnapshot $ withTestEnv $ do

1514+ let r1n = SnapshotRepoName "bloodhound-repo1"

1515+ withSnapshotRepo r1n $ \_ -> do

1516+ res <- getSnapshots r1n AllSnapshots

1517+ liftIO $ case res of

1518+ Left e -> expectationFailure ("Expected a right but got Left " <> show e)

1519+ Right _ -> return ()

1520+

1521+ it "can parse a snapshot that it created" $ when' canSnapshot $ withTestEnv $ do

1522+ let r1n = SnapshotRepoName "bloodhound-repo1"

1523+ withSnapshotRepo r1n $ \_ -> do

1524+ let s1n = SnapshotName "example-snapshot"

1525+ withSnapshot r1n s1n $ do

1526+ res <- getSnapshots r1n (SnapshotList (ExactSnap s1n :| []))

1527+ liftIO $ case res of

1528+ Right [snap]

1529+ | snapInfoState snap == SnapshotSuccess &&

1530+ snapInfoName snap == s1n -> return ()

1531+ | otherwise -> expectationFailure (show snap)

1532+ Right [] -> expectationFailure "There were no snapshots"

1533+ Right snaps -> expectationFailure ("Expected 1 snapshot but got" <> show (length snaps))

1534+ Left e -> expectationFailure (show e)

1535+

1536+ describe "snapshot restore" $ do

1537+ it "can restore a snapshot that we create" $ when' canSnapshot $ withTestEnv $ do

1538+ let r1n = SnapshotRepoName "bloodhound-repo1"

1539+ withSnapshotRepo r1n $ \_ -> do

1540+ let s1n = SnapshotName "example-snapshot"

1541+ withSnapshot r1n s1n $ do

1542+ let settings = defaultSnapshotRestoreSettings { snapRestoreWaitForCompletion = True }

1543+ -- have to close an index to restore it

1544+ resp1 <- closeIndex testIndex

1545+ liftIO (validateStatus resp1 200)

1546+ resp2 <- restoreSnapshot r1n s1n settings

1547+ liftIO (validateStatus resp2 200)

1548+

1549+ it "can restore and rename" $ when' canSnapshot $ withTestEnv $ do

1550+ let r1n = SnapshotRepoName "bloodhound-repo1"

1551+ withSnapshotRepo r1n $ \_ -> do

1552+ let s1n = SnapshotName "example-snapshot"

1553+ withSnapshot r1n s1n $ do

1554+ let pat = RestoreRenamePattern "bloodhound-tests-twitter-(\\d+)"

1555+ let replace = RRTLit "restored-" :| [RRSubWholeMatch]

1556+ let expectedIndex = IndexName "restored-bloodhound-tests-twitter-1"

1557+ oldEnoughForOverrides <- liftIO (atleast es15)

1558+ let overrides = RestoreIndexSettings { restoreOverrideReplicas = Just (ReplicaCount 0) }

1559+ let settings = defaultSnapshotRestoreSettings { snapRestoreWaitForCompletion = True

1560+ , snapRestoreRenamePattern = Just pat

1561+ , snapRestoreRenameReplacement = Just replace

1562+ , snapRestoreIndexSettingsOverrides = if oldEnoughForOverrides

1563+ then Just overrides

1564+ else Nothing

1565+ }

1566+ -- have to close an index to restore it

1567+ let go = do

1568+ resp <- restoreSnapshot r1n s1n settings

1569+ liftIO (validateStatus resp 200)

1570+ exists <- indexExists expectedIndex

1571+ liftIO (exists `shouldBe` True)

1572+ go `finally` deleteIndex expectedIndex

1573+

1368 describe "Enum DocVersion" $ do

1574 describe "Enum DocVersion" $ do

1369 it "follows the laws of Enum, Bounded" $ do

1575 it "follows the laws of Enum, Bounded" $ do

1370 evaluate (succ maxBound :: DocVersion) `shouldThrow` anyErrorCall

1576 evaluate (succ maxBound :: DocVersion) `shouldThrow` anyErrorCall