diff --git a/etcd.cabal b/etcd.cabal --- a/etcd.cabal +++ b/etcd.cabal @@ -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 diff --git a/src/Network/Etcd.hs b/src/Network/Etcd.hs --- a/src/Network/Etcd.hs +++ b/src/Network/Etcd.hs @@ -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 diff --git a/test/Test.hs b/test/Test.hs --- a/test/Test.hs +++ b/test/Test.hs @@ -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