abb7052 · typeable/bloodhound

git.iko.soy/typeable/bloodhound

on master help sign in

Tests passing with snapshots repo API

abb7052Michael Xavier10 years ago

bloodhound.cabal+3−2

compare with master

unifiedsplit

@@ -74,8 +74,9 @@ test-suite tests

74 quickcheck-properties,

75 derive,

76 errors,

77− resourcet,

77+ exceptions,

78− temporary-resourcet

78+ temporary,

79+ unix

79 default-language: Haskell2010

80 default-language: Haskell2010

81test-suite doctests

82test-suite doctests

src/Database/Bloodhound/Client.hs+22−21

@@ -75,32 +75,33 @@ module Database.Bloodhound.Client

75 )

76 where

78−import qualified Blaze.ByteString.Builder as BB

78+import qualified Blaze.ByteString.Builder as BB

79−import Control.Applicative as A

79+import Control.Applicative as A

80import Control.Monad

81import Control.Monad.Catch

82import Control.Monad.IO.Class

83import Data.Aeson

84import Data.ByteString.Lazy.Builder

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

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

86−import Data.Foldable (toList)

86+import Data.Foldable (toList)

87−import qualified Data.HashMap.Strict as HM

87+import qualified Data.HashMap.Strict as HM

88import Data.Ix

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

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

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

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

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

91+import Data.Maybe (catMaybes, fromMaybe,

92+ isJust)

92import Data.Monoid

93import Data.Monoid

93−import Data.Text (Text)

94+import Data.Text (Text)

94−import qualified Data.Text as T

95+import qualified Data.Text as T

95−import qualified Data.Text.Encoding as T

96+import qualified Data.Text.Encoding as T

96import Data.Time.Clock

97import Data.Time.Clock

97−import qualified Data.Vector as V

98+import qualified Data.Vector as V

98import Network.HTTP.Client

99import Network.HTTP.Client

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

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

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

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

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

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

102−import qualified Network.URI as URI

103+import qualified Network.URI as URI

103−import Prelude hiding (filter, head)

104+import Prelude hiding (filter, head)

104

105

105import Database.Bloodhound.Types

106import Database.Bloodhound.Types

106

107

@@ -291,7 +292,7 @@ instance FromJSON GSRs where

291 parseJSON = withObject "Collection of GenericSnapshotRepo" parse

292 parseJSON = withObject "Collection of GenericSnapshotRepo" parse

292 where

293 where

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

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

294− go rawName = withObject "GenericSnapshotRepo" $ \o ->

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

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

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

296 <*> o .: "settings"

297 <*> o .: "settings"

297

298

@@ -304,14 +305,14 @@ updateSnapshotRepo

304 => SnapshotRepoUpdateSettings

305 => SnapshotRepoUpdateSettings

305 -- ^ Use 'defaultSnapshotRepoUpdateSettings' if unsure

306 -- ^ Use 'defaultSnapshotRepoUpdateSettings' if unsure

306 -> repo

307 -> repo

307− -> m Reply --TODO: more specific?

308+ -> m Reply

308updateSnapshotRepo SnapshotRepoUpdateSettings {..} repo = bindM2 post url (return (Just body))

309updateSnapshotRepo SnapshotRepoUpdateSettings {..} repo = bindM2 post url (return (Just body))

309 where

310 where

310− url = addQuery params <$> joinPath ["_snapshots", snapshotRepoName gSnapshotRepoName]

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

311 params

312 params

312 | repoUpdateVerify = []

313 | repoUpdateVerify = []

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

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

314− body = encode $ object [ "types" .= gSnapshotRepoName

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

315 , "settings" .= gSnapshotRepoSettings

316 , "settings" .= gSnapshotRepoSettings

316 ]

317 ]

317 GenericSnapshotRepo {..} = toGSnapshotRepo repo

318 GenericSnapshotRepo {..} = toGSnapshotRepo repo

src/Database/Bloodhound/Types.hs+27−17

@@ -2988,7 +2988,7 @@ instance FromJSON UpdatableIndexSetting where

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

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

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

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

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

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

2993 taggedAt' f v' ks) v

2994 numberOfReplicas = pure . NumberOfReplicas

@@ -3030,18 +3030,17 @@ instance FromJSON IndexSettingsSummary where

3030 redundant (NumberOfReplicas _) = True

3031 redundant _ = False

3032

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

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

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

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

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

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

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

3036+unStringlyTypeJSON :: Value -> Value

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

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

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

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

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

3039+unStringlyTypeJSON (String "null") = Null

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

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

3042− Just n -> return (Number n)

3041+ Just n -> Number n

3043− Nothing -> mzero

3042+ Nothing -> v

3044−unStringlyTypeJSON _ = mzero

3043+unStringlyTypeJSON v = v

3045

3044

3046

3045

3047parseSettings :: Object -> Parser [UpdatableIndexSetting]

3046parseSettings :: Object -> Parser [UpdatableIndexSetting]

@@ -3680,7 +3679,7 @@ data SnapshotRepoPattern = ExactRepo SnapshotRepoName

3680

3679

3681-- | The unique name of a snapshot repository.

3680-- | The unique name of a snapshot repository.

3682newtype SnapshotRepoName = SnapshotRepoName { snapshotRepoName :: Text }

3681newtype SnapshotRepoName = SnapshotRepoName { snapshotRepoName :: Text }

3683− deriving (Eq, Generic, Show, Typeable, ToJSON, FromJSON)

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

3684

3683

3685

3684

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

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

@@ -3696,15 +3695,26 @@ data GenericSnapshotRepo = GenericSnapshotRepo {

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

3695 } deriving (Eq, Generic, Show, Typeable)

3697

3696

3698

3697

3698+instance SnapshotRepo GenericSnapshotRepo where

3699+ toGSnapshotRepo = id

3700+ fromGSnapshotRepo = Right

3701+

3702+

3699newtype SnapshotRepoType = SnapshotRepoType { snapshotRepoType :: Text }

3703newtype SnapshotRepoType = SnapshotRepoType { snapshotRepoType :: Text }

3700− deriving (Eq, Generic, Show, Typeable, ToJSON, FromJSON)

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

3701

3705

3702

3706

3703-- | Opaque representation of snapshot repo settings. Instances of

3707-- | Opaque representation of snapshot repo settings. Instances of

3704-- 'SnapshotRepo' will produce this.

3708-- 'SnapshotRepo' will produce this.

3705newtype GenericSnapshotRepoSettings = GenericSnapshotRepoSettings { gSnapshotRepoSettingsObject :: Object }

3709newtype GenericSnapshotRepoSettings = GenericSnapshotRepoSettings { gSnapshotRepoSettingsObject :: Object }

3706− deriving (Eq, Generic, Show, Typeable, ToJSON, FromJSON)

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

3711+

3707

3712

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

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

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

3716+instance FromJSON GenericSnapshotRepoSettings where

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

3708

3718

3709-- | The result of running 'verifySnapshotRepo'. --TODO: more detail once you know what a failure looks like

3719-- | The result of running 'verifySnapshotRepo'. --TODO: more detail once you know what a failure looks like

3710newtype SnapshotVerification = SnapshotVerification { snapshotNodeVerifications :: [SnapshotNodeVerification] }

3720newtype SnapshotVerification = SnapshotVerification { snapshotNodeVerifications :: [SnapshotNodeVerification] }

@@ -3730,11 +3740,11 @@ data SnapshotNodeVerification = SnapshotNodeVerification {

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

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

3731-- usually returned in node-oriented APIs.

3741-- usually returned in node-oriented APIs.

3732newtype FullNodeId = FullNodeId { fullNodeId :: Text }

3742newtype FullNodeId = FullNodeId { fullNodeId :: Text }

3733− deriving (Eq, Generic, Show, Typeable, FromJSON)

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

3734

3744

3735

3745

3736newtype NodeName = NodeName { nodeName :: Text }

3746newtype NodeName = NodeName { nodeName :: Text }

3737− deriving (Eq, Generic, Show, Typeable, FromJSON)

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

3738

3748

3739

3749

3740data SnapshotRepoUpdateSettings = SnapshotRepoUpdateSettings {

3750data SnapshotRepoUpdateSettings = SnapshotRepoUpdateSettings {

tests/tests.hs+66−5

@@ -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,10 +12,10 @@ 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

17−import Control.Monad.Trans.Resource

18import Data.Aeson

19import Data.Aeson

19import Data.Aeson.Types (parseEither)

20import Data.Aeson.Types (parseEither)

20import qualified Data.ByteString.Lazy.Char8 as BL8

21import qualified Data.ByteString.Lazy.Char8 as BL8

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

26import qualified Data.List.NonEmpty as NE

27import qualified Data.List.NonEmpty as NE

27import qualified Data.Map.Strict as M

28import qualified Data.Map.Strict as M

28import Data.Monoid

29import Data.Monoid

30+import Data.Ord (comparing)

29import Data.Proxy

31import Data.Proxy

30import Data.Text (Text)

32import Data.Text (Text)

31import qualified Data.Text as T

33import qualified Data.Text as T

@@ -40,6 +42,7 @@ import Network.HTTP.Client hiding (Proxy)

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

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

41import Prelude hiding (filter)

43import Prelude hiding (filter)

42import System.IO.Temp

44import System.IO.Temp

45+import System.Posix.Files

43import Test.Hspec

46import Test.Hspec

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

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

@@ -56,10 +59,14 @@ testMapping = MappingName "tweet"

56withTestEnv :: BH IO a -> IO a

59withTestEnv :: BH IO a -> IO a

57withTestEnv = withBH defaultManagerSettings testServer

60withTestEnv = withBH defaultManagerSettings testServer

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

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

60validateStatus resp expected =

63validateStatus resp expected =

64+ if actual == expected

65+ then return ()

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

67+ where

61− (NHTS.statusCode $ responseStatus resp)

68+ actual = NHTS.statusCode (responseStatus resp)

62− `shouldBe` (expected :: Int)

69+ body = responseBody resp

64createExampleIndex :: BH IO Reply

71createExampleIndex :: BH IO Reply

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

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

@@ -314,6 +321,28 @@ searchExpectSource src expected = do

314 liftIO $

321 liftIO $

315 value `shouldBe` expected

322 value `shouldBe` expected

316

323

324+withSnapshotRepo

325+ :: ( MonadMask m

326+ , MonadBH m

327+ )

328+ => SnapshotRepoName

329+ -> (GenericSnapshotRepo -> m a)

330+ -> m a

331+withSnapshotRepo srn@(SnapshotRepoName n) f =

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

333+ where

334+ alloc dir = do

335+ liftIO (setFileMode dir mode)

336+ let repo = FsSnapshotRepo srn dir True Nothing Nothing Nothing

337+ resp <- updateSnapshotRepo defaultSnapshotRepoUpdateSettings repo

338+ liftIO (validateStatus resp 200)

339+ return (toGSnapshotRepo repo)

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

341+ free GenericSnapshotRepo {..} = do

342+ resp <- deleteSnapshotRepo gSnapshotRepoName

343+ liftIO (validateStatus resp 200)

344+

345+

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

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

318instance FromJSON BulkTest where

347instance FromJSON BulkTest where

319 parseJSON = genericParseJSON defaultOptions

348 parseJSON = genericParseJSON defaultOptions

@@ -1379,6 +1408,38 @@ main = hspec $ do

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

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

1380 Right _ -> return ()

1409 Right _ -> return ()

1381

1410

1411+ it "finds an existing list of repos" $ withTestEnv $ do

1412+ let r1n = SnapshotRepoName "bloodhound-repo1"

1413+ let r2n = SnapshotRepoName "bloodhound-repo2"

1414+ withSnapshotRepo r1n $ \r1 ->

1415+ withSnapshotRepo r2n $ \r2 -> do

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

1417+ liftIO $ case repos of

1418+ Right xs -> do

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

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

1421+ Left e -> expectationFailure (show e)

1422+

1423+ it "creates and updates with updateSnapshotRepo" $ withTestEnv $ do

1424+ let r1n = SnapshotRepoName "bloodhound-repo1"

1425+ withSnapshotRepo r1n $ \r1 -> do

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

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

1428+ resp <- updateSnapshotRepo defaultSnapshotRepoUpdateSettings noCompression

1429+ liftIO (validateStatus resp 200)

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

1431+ liftIO (roundtrippedNoCompression `shouldBe` toGSnapshotRepo noCompression)

1432+

1433+ it "can verify existing repos" $ withTestEnv $ do

1434+ let r1n = SnapshotRepoName "bloodhound-repo1"

1435+ withSnapshotRepo r1n $ \_ -> do

1436+ res <- verifySnapshotRepo r1n

1437+ liftIO $ case res of

1438+ Right (SnapshotVerification vs)

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

1440+ | otherwise -> return ()

1441+ Left e -> expectationFailure (show e)

1442+

1382 describe "Enum DocVersion" $ do

1443 describe "Enum DocVersion" $ do

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

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

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

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