etcd 1.0.3 → 1.0.4

raw patch · 3 files changed

+126/−45 lines, 3 filesdep +asyncPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: async

API changes (from Hackage documentation)

Files

• etcd.cabal +12/−7
• src/Network/Etcd.hs +76/−36
• test/Test.hs +38/−2

@@ -1,5 +1,5 @@ name:                etcd-version:             1.0.3+version:             1.0.4 license:             OtherLicense license-file:        UNLICENSE synopsis:            Client for etcd, a highly-available key value store@@ -11,23 +11,27 @@ cabal-version:       >=1.10  +source-repository head+  type:     git+  location: git://github.com/wereHamster/etcd-hs.git++ library   default-language:  Haskell2010   hs-source-dirs:    src    exposed-modules:   Network.Etcd -  build-depends:     aeson         >= 0-  build-depends:     base          >= 4.0     && < 5-  build-depends:     bytestring    >= 0-  build-depends:     http-conduit  >= 0-  build-depends:     time          >= 0+  build-depends:     aeson+  build-depends:     base >= 4.0 && < 5+  build-depends:     bytestring+  build-depends:     http-conduit+  build-depends:     time   build-depends:     text    ghc-options:       -Wall  - test-suite test   type:              exitcode-stdio-1.0 @@ -36,6 +40,7 @@    main-is:           Test.hs +  build-depends:     async   build-depends:     MonadRandom   build-depends:     base   build-depends:     etcd

@@ -1,4 +1,5 @@-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE ScopedTypeVariables #-}  {-| @@ -21,6 +22,10 @@     , get     , set     , create+    , wait+    , waitIndex+    , waitRecursive+    , waitIndexRecursive        -- * Directory operations     , createDirectory@@ -38,6 +43,7 @@ import qualified Data.Text as T import           Data.Text.Encoding import           Data.Monoid+import           Data.ByteString.Lazy (ByteString)  import           Control.Applicative import           Control.Exception@@ -45,7 +51,9 @@  import           Network.HTTP.Conduit hiding (Response, path) +import           Prelude + -- | The 'Client' holds all data required to make requests to the etcd -- cluster. You should use 'createClient' to initialize a new client. data Client = Client@@ -105,13 +113,10 @@  ------------------------------------------------------------------------------ -- | The server sometimes responds to errors with this error object.-data Error = Error+data Error = Error !Text     deriving (Show, Eq, Ord) -instance FromJSON Error where-    parseJSON _ = return Error - -- | The etcd index is a unique, monotonically-incrementing integer created for -- each change to etcd. See etcd documentation for more details. type Index = Int@@ -153,7 +158,7 @@       -- which the given key was created.      , _nodeModifiedIndex :: !Index-      -- ^ Like '_nodeCreatedIndex', but reflects when the node was laste+      -- ^ Like '_nodeCreatedIndex', but reflects when the node was last       -- changed.      , _nodeDir           :: !Bool@@ -179,9 +184,9 @@  instance FromJSON Node where     parseJSON (Object o) = Node-        <$> o .:  "key"-        <*> o .:  "createdIndex"-        <*> o .:  "modifiedIndex"+        <$> o .:? "key" .!= "/"+        <*> o .:? "createdIndex" .!= 0+        <*> o .:? "modifiedIndex" .!= 0         <*> o .:? "dir" .!= False         <*> o .:? "value"         <*> o .:? "nodes"@@ -206,12 +211,19 @@ -- A type synonym for a http response. type HR = Either Error Response +decodeResponseBody :: ByteString -> IO HR+decodeResponseBody body = do+    return $ case eitherDecode body of+        Left e  -> Left $ Error (T.pack e)+        Right n -> Right n -httpGET :: Text -> IO HR-httpGET url = do-    req  <- acceptJSON <$> parseUrl (T.unpack url)++httpGET :: Text -> [(Text, Text)] -> IO HR+httpGET url params = do+    req'  <- acceptJSON <$> parseUrl (T.unpack url)+    let req = setQueryString (map (\(k,v) -> (encodeUtf8 k, Just $ encodeUtf8 v)) params) $ req'     body <- responseBody <$> (withManager $ httpLbs req)-    return $ maybe (Left Error) Right $ decode body+    decodeResponseBody body    where     acceptHeader   = ("Accept","application/json")@@ -224,15 +236,16 @@     let req = urlEncodedBody (map (\(k,v) -> (encodeUtf8 k, encodeUtf8 v)) params) $ req'      body <- responseBody <$> (withManager $ httpLbs $ req { method = "PUT" })-    return $ maybe (Left Error) Right $ decode body+    decodeResponseBody body + httpPOST :: Text -> [(Text, Text)] -> IO HR httpPOST url params = do     req' <- parseUrl (T.unpack url)     let req = urlEncodedBody (map (\(k,v) -> (encodeUtf8 k, encodeUtf8 v)) params) $ req'      body <- responseBody <$> (withManager $ httpLbs $ req { method = "POST" })-    return $ maybe (Left Error) Right $ decode body+    decodeResponseBody body   -- | Issue a DELETE request to the given url. Since DELETE requests don't have@@ -241,7 +254,7 @@ httpDELETE url params = do     req  <- parseUrl $ T.unpack $ url <> (asQueryParams params)     body <- responseBody <$> (withManager $ httpLbs $ req { method = "DELETE" })-    return $ maybe (Left Error) Right $ decode body+    decodeResponseBody body    where     asQueryParams [] = ""@@ -252,10 +265,10 @@ -- | Run a low-level HTTP request. Catch any exceptions and convert them into -- a 'Left Error'. runRequest :: IO HR -> IO HR-runRequest a = catch a (ignoreExceptionWith (return $ Left Error))+runRequest a = catch a (\(e :: SomeException) -> return $ Left $ Error $ T.pack $ show e) -ignoreExceptionWith :: a -> SomeException -> a-ignoreExceptionWith a _ = a+runRequest' :: IO HR -> IO (Maybe Node)+runRequest' m = either (const Nothing) (Just . _resNode) <$> runRequest m   -- | Encode an optional TTL into a param pair.@@ -285,41 +298,68 @@  -} +waitParam :: (Text, Text)+waitParam = ("wait","true") +waitRecursiveParam :: (Text, Text)+waitRecursiveParam = ("recursive","true")++waitIndexParam :: Index -> (Text, Text)+waitIndexParam i = ("waitIndex", (T.pack $ show i))++ -- | Get the node at the given key. get :: Client -> Key -> IO (Maybe Node)-get client key = do-    hr <- runRequest $ httpGET $ keyUrl client key-    case hr of-        Left _ -> return Nothing-        Right res -> return $ Just $ _resNode res+get client key =+    runRequest' $ httpGET (keyUrl client key) []   -- | Set the value at the given key. set :: Client -> Key -> Value -> Maybe TTL -> IO (Maybe Node)-set client key value mbTTL = do-    hr <- runRequest $ httpPUT (keyUrl client key) params-    case hr of-        Left _ -> return Nothing-        Right res -> return $ Just $ _resNode res--  where-    params = [("value",value)] ++ ttlParam mbTTL+set client key value mbTTL =+    runRequest' $ httpPUT (keyUrl client key) $+        [("value",value)] ++ ttlParam mbTTL   -- | Create a value in the given key. The key must be a directory. create :: Client -> Key -> Value -> Maybe TTL -> IO Node create client key value mbTTL = do-    hr <- runRequest $ httpPOST (keyUrl client key) params+    hr <- runRequest $ httpPOST (keyUrl client key) $+        [("value",value)] ++ ttlParam mbTTL+     case hr of         Left _ -> error "Unexpected error"         Right res -> return $ _resNode res -  where-    params = [("value",value)] ++ ttlParam mbTTL +-- | Wait for changes on the node at the given key.+wait :: Client -> Key -> IO (Maybe Node)+wait client key =+    runRequest' $ httpGET (keyUrl client key) [waitParam]  +-- | Same as 'wait' but at a given index.+waitIndex :: Client -> Key -> Index -> IO (Maybe Node)+waitIndex client key index =+    runRequest' $ httpGET (keyUrl client key) $+        [waitParam, waitIndexParam index]+++-- | Same as 'wait' but includes changes on children.+waitRecursive :: Client -> Key -> IO (Maybe Node)+waitRecursive client key =+    runRequest' $ httpGET (keyUrl client key) $+        [waitParam, waitRecursiveParam]+++-- | Same as 'waitIndex' but includes changes on children.+waitIndexRecursive :: Client -> Key -> Index -> IO (Maybe Node)+waitIndexRecursive client key index =+    runRequest' $ httpGET (keyUrl client key) $+        [waitParam, waitIndexParam index, waitRecursiveParam]+++ {-----------------------------------------------------------------------------  Directories are non-leaf nodes which contain zero or more child nodes. When@@ -343,7 +383,7 @@ -- | List all nodes within the given directory. listDirectoryContents :: Client -> Key -> IO [Node] listDirectoryContents client key = do-    hr <- runRequest $ httpGET $ keyUrl client key+    hr <- runRequest $ httpGET (keyUrl client key) []     case hr of         Left _ -> return []         Right res -> do

@@ -12,6 +12,7 @@  import           Control.Applicative import           Control.Concurrent+import qualified Control.Concurrent.Async as Async import           Control.Monad import           Control.Monad.Random (getRandomR, evalRandIO) import           Control.Monad.Trans@@ -58,6 +59,11 @@ spec = parallel $ do      describe "Key Space Operations" $ do+        it "Get the root directory node" $ do+            (client, key) <- setup+            node <- expectNode =<< get client "/"+            shouldBeDirectory node+         it "Setting the value of a key" $ do             (client, key) <- setup             node <- expectNode =<< set client key "value" Nothing@@ -65,11 +71,11 @@          it "Using key TTL" $ do             (client, key) <- setup-            set client key "value" (Just 1)+            set client key "value" (Just 5)             node <- expectNode =<< get client key             node `shouldBeLeaf` "value" -            threadDelay $ 2 * 1000 * 1000+            threadDelay $ 6 * 1000 * 1000             node <- get client key             node `shouldSatisfy` isNothing @@ -82,6 +88,36 @@         it "Get the value of a key" $ do             (client, _) <- setup             void $ fromJust <$> get client "/_etcd/machines"++        it "Wait for any change on a key" $ do+            (client, key) <- setup+            a <- Async.async $ wait client key+            threadDelay $ 2 * 1000 * 1000+            Async.async $ set client key "value" Nothing+            node <- expectNode =<< Async.wait a+            node `shouldBeLeaf` "value"++        it "Wait for a change on a key at a given index" $ do+            (client, key) <- setup+            Just n <- set client key "value" Nothing+            let i = _nodeModifiedIndex n+            node <- expectNode =<< waitIndex client key i+            node `shouldBeLeaf` "value"++        it "Wait for any change on a key recursively" $ do+            (client, key) <- setup+            a <- Async.async $ waitRecursive client key+            threadDelay $ 2 * 1000 * 1000+            Async.async $ set client (key <> "/child") "value" Nothing+            node <- expectNode =<< Async.wait a+            node `shouldBeLeaf` "value"++        it "Wait for a change on a key at a given index recursively" $ do+            (client, key) <- setup+            Just n <- set client (key <> "/child") "value" Nothing+            let i = _nodeModifiedIndex n+            node <- expectNode =<< waitIndexRecursive client key i+            node `shouldBeLeaf` "value"          it "Creating directories" $ do             (client, key) <- setup