etcd 0.1.0.1 → 0.1.0.2
raw patch · 6 files changed
+517/−202 lines, 6 filesdep +MonadRandomdep +etcddep +hspecdep ~base
Dependencies added: MonadRandom, etcd, hspec, mtl, time
Dependency ranges changed: base
Files
- UNLICENSE +24/−0
- etcd.cabal +15/−12
- src/Data/Etcd.hs +0/−179
- src/Main.hs +0/−11
- src/Network/Etcd.hs +364/−0
- test/Test.hs +114/−0
UNLICENSE view
@@ -0,0 +1,24 @@+This is free and unencumbered software released into the public domain.++Anyone is free to copy, modify, publish, use, compile, sell, or+distribute this software, either in source code form or as a compiled+binary, for any purpose, commercial or non-commercial, and by any+means.++In jurisdictions that recognize copyright laws, the author or authors+of this software dedicate any and all copyright interest in the+software to the public domain. We make this dedication for the benefit+of the public at large and to the detriment of our heirs and+successors. We intend this dedication to be an overt act of+relinquishment in perpetuity of all present and future rights to this+software under copyright law.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.+IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY CLAIM, DAMAGES OR+OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE,+ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR+OTHER DEALINGS IN THE SOFTWARE.++For more information, please refer to <http://unlicense.org/>
etcd.cabal view
@@ -1,12 +1,12 @@ name: etcd-version: 0.1.0.1+version: 0.1.0.2 license: OtherLicense license-file: UNLICENSE synopsis: Client for etcd, a highly-available key value store-description: See https://github.com/coreos/etcd+description: See <https://coreos.com/using-coreos/etcd/> author: Tomas Carnecky maintainer: tomas.carnecky@gmail.com-category: Data+category: Network build-type: Simple cabal-version: >=1.10 @@ -14,27 +14,30 @@ library hs-source-dirs: src - exposed-modules: Data.Etcd+ 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 default-language: Haskell2010 ghc-options: -Wall -executable etcd-client- hs-source-dirs: src+test-suite test+ type: exitcode-stdio-1.0 - main-is: Main.hs+ hs-source-dirs: test+ main-is: Test.hs - build-depends: aeson >= 0- build-depends: base >= 4.0 && < 5- build-depends: bytestring >= 0- build-depends: http-conduit >= 0+ build-depends: MonadRandom+ build-depends: base+ build-depends: etcd+ build-depends: hspec+ build-depends: mtl default-language: Haskell2010- ghc-options: -Wall+ ghc-options: -threaded -with-rtsopts=-N
− src/Data/Etcd.hs
@@ -1,179 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module Data.Etcd where---import Data.Aeson hiding (Error)-import Data.ByteString.Char8 (pack)--import Control.Applicative-import Control.Exception-import Control.Monad--import Network.HTTP.Conduit hiding (Response, path)---data Client = Client- { leaderUrl :: String- , machines :: [ String ]- }------ | The version prefix used in URLs. The current client supports v2.-versionPrefix :: String-versionPrefix = "v2"---buildUrl :: Client -> String -> String-buildUrl c p = leaderUrl c ++ "/" ++ versionPrefix ++ "/" ++ p------------------------------------------------------------------------------------ | Each response comes with an "action" field, which describes what kind of--- action was performed.-data Action = GET | SET | DELETE | CREATE | EXPIRE | CAS | CAD- deriving (Show, Eq, Ord)---instance FromJSON Action where- parseJSON (String "get") = return GET- parseJSON (String "set") = return SET- parseJSON (String "delete") = return DELETE- parseJSON (String "create") = return CREATE- parseJSON (String "expire") = return EXPIRE- parseJSON (String "compareAndSwap") = return CAS- parseJSON (String "compareAndDelete") = return CAD- parseJSON _ = fail "Action"------------------------------------------------------------------------------------- | The server responds with this object to all successful requests.-data Response = Response- { _resAction :: Action- , _resNode :: Node- , _resPrevNode :: Maybe Node- } deriving (Show, Eq, Ord)---instance FromJSON Response where- parseJSON (Object o) = Response- <$> o .: "action"- <*> o .: "node"- <*> o .:? "prevNode"-- parseJSON _ = fail "Response"------------------------------------------------------------------------------------- | The server sometimes responds to errors with this error object.-data Error = Error- deriving (Show, Eq, Ord)--instance FromJSON Error where- parseJSON _ = return Error----data Node = Node- { _nodeKey :: String- , _nodeValue :: Maybe String- , _nodeCreatedIndex :: Int- , _nodeModifiedIndex :: Int- , _nodeNodes :: Maybe [Node]- } deriving (Show, Eq, Ord)---instance FromJSON Node where- parseJSON (Object o) = Node- <$> o .: "key"- <*> o .:? "value"- <*> o .: "createdIndex"- <*> o .: "modifiedIndex"- <*> o .:? "nodes"-- parseJSON _ = fail "Response"----{-|-----------------------------------------------------------------------------Low-level HTTP interface--The functions here are used internally when sending requests to etcd. If the-server is running, the result is 'Either Error Response'. These functions may-throw an exception if the server is unreachable or not responding.---}----- A type synonym for a http response.-type HR = Either Error Response---httpGET :: String -> IO HR-httpGET url = do- req <- acceptJSON <$> parseUrl url- body <- responseBody <$> (withManager $ httpLbs req)- return $ maybe (Left Error) Right $ decode body-- where- acceptHeader = ("Accept","application/json")- acceptJSON req = req { requestHeaders = acceptHeader : requestHeaders req }---httpPOST :: String -> [(String, String)] -> IO HR-httpPOST url params = do- req' <- parseUrl url- let req = urlEncodedBody (map (\(k,v) -> (pack k, pack v)) params) $ req'-- void $ withManager $ httpLbs req- return $ Left Error------------------------------------------------------------------------------------ | 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))--ignoreExceptionWith :: a -> SomeException -> a-ignoreExceptionWith a _ = a----{-|-----------------------------------------------------------------------------Public API---}----- | Create a new client and initialize it with a list of seed machines. The--- list must be non-empty.-createClient :: [ String ] -> IO Client-createClient seed = return $ Client (head seed) seed---listKeys :: Client -> String -> IO [ Node ]-listKeys client path = do- hr <- runRequest $ httpGET $ buildUrl client $ "keys/" ++ path- case hr of- Left _ -> return []- Right res -> return $ [ _resNode res ]---getKey :: Client -> String -> IO (Maybe Node)-getKey client path = do- hr <- runRequest $ httpGET $ buildUrl client $ "keys/" ++ path- case hr of- Left _ -> return Nothing- Right res -> return $ Just $ _resNode res---putKey :: Client -> String -> String -> IO ()-putKey client path value = do- void $ httpPOST (buildUrl client $ "keys/" ++ path) [("value", value)]- return ()
− src/Main.hs
@@ -1,11 +0,0 @@-module Main where--import Data.Etcd---main = do- print "Starting etcd client..."- client <- createClient [ "http://127.0.0.1:4001" ]- keys <- listKeys client "/_etcd/machines"- print keys- return ()
+ src/Network/Etcd.hs view
@@ -0,0 +1,364 @@+{-# LANGUAGE OverloadedStrings #-}++{-|++This module contains an implementation of the etcd client.++-}++module Network.Etcd+ ( Client+ , createClient++ -- * Types+ , Node(..)+ , Index+ , Key+ , Value+ , TTL++ -- * Low-level key operations+ , get+ , set+ , create++ -- * Directory operations+ , createDirectory+ , listDirectoryContents+ , removeDirectory+ , removeDirectoryRecursive+ ) where+++import Data.Aeson hiding (Value, Error)+import Data.ByteString.Char8 (pack)+import Data.Time.Clock+import Data.Time.LocalTime+import Data.List++import Control.Applicative+import Control.Exception+import Control.Monad++import Network.HTTP.Conduit hiding (Response, path)+++-- | 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+ { leaderUrl :: String+ -- ^ The URL to the leader. HTTP requests are sent to this server.+ }++++-- | The version prefix used in URLs. The current client supports v2.+versionPrefix :: String+versionPrefix = "v2"+++-- | The URL to the given key.+keyUrl :: Client -> Key -> String+keyUrl client key = leaderUrl client ++ "/" ++ versionPrefix ++ "/keys/" ++ key+++------------------------------------------------------------------------------+-- | Each response comes with an "action" field, which describes what kind of+-- action was performed.+data Action = GET | SET | DELETE | CREATE | EXPIRE | CAS | CAD+ deriving (Show, Eq, Ord)+++instance FromJSON Action where+ parseJSON (String "get") = return GET+ parseJSON (String "set") = return SET+ parseJSON (String "delete") = return DELETE+ parseJSON (String "create") = return CREATE+ parseJSON (String "expire") = return EXPIRE+ parseJSON (String "compareAndSwap") = return CAS+ parseJSON (String "compareAndDelete") = return CAD+ parseJSON _ = fail "Action"++++------------------------------------------------------------------------------+-- | The server responds with this object to all successful requests.+data Response = Response+ { _resAction :: Action+ , _resNode :: Node+ , _resPrevNode :: Maybe Node+ } deriving (Show, Eq, Ord)+++instance FromJSON Response where+ parseJSON (Object o) = Response+ <$> o .: "action"+ <*> o .: "node"+ <*> o .:? "prevNode"++ parseJSON _ = fail "Response"++++------------------------------------------------------------------------------+-- | The server sometimes responds to errors with this error object.+data Error = Error+ 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+++-- | Keys are strings, formatted like filesystem paths (ie. slash-delimited+-- list of path components).+type Key = String+++-- | Values attached to leaf nodes are strings. If you want to store+-- structured data in the values, you'll need to encode it into a string.+type Value = String+++-- | TTL is specified in seconds. The server accepts negative values, but they+-- don't make much sense.+type TTL = Int+++-- | The 'Node' corresponds to the node object as returned by the etcd API.+--+-- There are two types of nodes in etcd. One is a leaf node which holds+-- a value, the other is a directory node which holds zero or more child nodes.+-- A directory node can not hold a value, the two types are exclusive.+--+-- On the wire, the two are not really distinguished, except that the JSON+-- objects have different fields.+--+-- A node may be set to expire after a number of seconds. This is indicated by+-- the two fields 'ttl' and 'expiration'.++data Node = Node+ { _nodeKey :: Key+ -- ^ The key of the node. It always starts with a slash character (0x47).++ , _nodeCreatedIndex :: Index+ -- ^ A unique index, reflects the point in the etcd state machine at+ -- which the given key was created.++ , _nodeModifiedIndex :: Index+ -- ^ Like '_nodeCreatedIndex', but reflects when the node was laste+ -- changed.++ , _nodeDir :: Bool+ -- ^ 'True' if this node is a directory.++ , _nodeValue :: Maybe Value+ -- ^ The value is only present on leaf nodes. If the node is+ -- a directory, then this field is 'Nothing'.++ , _nodeNodes :: Maybe [Node]+ -- ^ If this node is a directory, then these are its children. The list+ -- may be empty.++ , _nodeTTL :: Maybe TTL+ -- ^ If the node has TTL set, this is the number of seconds how long the+ -- node will exist.++ , _nodeExpiration :: Maybe UTCTime+ -- ^ If TTL is set, then this is the time when it expires.++ } deriving (Show, Eq, Ord)+++instance FromJSON Node where+ parseJSON (Object o) = Node+ <$> o .: "key"+ <*> o .: "createdIndex"+ <*> o .: "modifiedIndex"+ <*> o .:? "dir" .!= False+ <*> o .:? "value"+ <*> o .:? "nodes"+ <*> o .:? "ttl"+ <*> (fmap zonedTimeToUTC <$> (o .:? "expiration"))++ parseJSON _ = fail "Response"++++{-|---------------------------------------------------------------------------++Low-level HTTP interface++The functions here are used internally when sending requests to etcd. If the+server is running, the result is 'Either Error Response'. These functions may+throw an exception if the server is unreachable or not responding.++-}+++-- A type synonym for a http response.+type HR = Either Error Response+++httpGET :: String -> IO HR+httpGET url = do+ req <- acceptJSON <$> parseUrl url+ body <- responseBody <$> (withManager $ httpLbs req)+ return $ maybe (Left Error) Right $ decode body++ where+ acceptHeader = ("Accept","application/json")+ acceptJSON req = req { requestHeaders = acceptHeader : requestHeaders req }+++httpPUT :: String -> [(String, String)] -> IO HR+httpPUT url params = do+ req' <- parseUrl url+ let req = urlEncodedBody (map (\(k,v) -> (pack k, pack v)) params) $ req'++ body <- responseBody <$> (withManager $ httpLbs $ req { method = "PUT" })+ return $ maybe (Left Error) Right $ decode body++httpPOST :: String -> [(String, String)] -> IO HR+httpPOST url params = do+ req' <- parseUrl url+ let req = urlEncodedBody (map (\(k,v) -> (pack k, pack v)) params) $ req'++ body <- responseBody <$> (withManager $ httpLbs $ req { method = "POST" })+ return $ maybe (Left Error) Right $ decode body+++-- | Issue a DELETE request to the given url. Since DELETE requests don't have+-- a body, the params are appended to the URL as a query string.+httpDELETE :: String -> [(String, String)] -> IO HR+httpDELETE url params = do+ req <- parseUrl $ url ++ (asQueryParams params)+ body <- responseBody <$> (withManager $ httpLbs $ req { method = "DELETE" })+ return $ maybe (Left Error) Right $ decode body++ where+ asQueryParams [] = ""+ asQueryParams xs = "?" ++ intercalate "&" (map (\(k,v) -> k ++ "=" ++ v) xs)+++------------------------------------------------------------------------------+-- | 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))++ignoreExceptionWith :: a -> SomeException -> a+ignoreExceptionWith a _ = a+++-- | Encode an optional TTL into a param pair.+ttlParam :: Maybe TTL -> [(String,String)]+ttlParam Nothing = []+ttlParam (Just ttl) = [("ttl",show ttl)]++++{-----------------------------------------------------------------------------++Public API++-}+++-- | Create a new client and initialize it with a list of seed machines. The+-- list must be non-empty.+createClient :: [ String ] -> IO Client+createClient seed = return $ Client (head seed)++++{-----------------------------------------------------------------------------++Low-level key operations++-}+++-- | 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+++-- | 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+++-- | 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+ case hr of+ Left _ -> error "Unexpected error"+ Right res -> return $ _resNode res++ where+ params = [("value",value)] ++ ttlParam mbTTL++++{-----------------------------------------------------------------------------++Directories are non-leaf nodes which contain zero or more child nodes. When+manipulating directories one must include dir=true in the request params.++-}++dirParam :: [(String,String)]+dirParam = [("dir","true")]++recursiveParam :: [(String,String)]+recursiveParam = [("recursive","true")]+++-- | Create a directory at the given key.+createDirectory :: Client -> Key -> Maybe TTL -> IO ()+createDirectory client key mbTTL =+ void $ runRequest $ httpPUT (keyUrl client key) $ dirParam ++ ttlParam mbTTL+++-- | List all nodes within the given directory.+listDirectoryContents :: Client -> Key -> IO [Node]+listDirectoryContents client key = do+ hr <- runRequest $ httpGET $ keyUrl client key+ case hr of+ Left _ -> return []+ Right res -> do+ let node = _resNode res+ case _nodeNodes node of+ Nothing -> return []+ Just children -> return children+++-- | Remove the directory at the given key. The directory MUST be empty,+-- otherwise the removal fails. If you don't care about the keys within, you+-- can use 'removeDirectoryRecursive'.+removeDirectory :: Client -> Key -> IO ()+removeDirectory client key =+ void $ runRequest $ httpDELETE (keyUrl client key) dirParam+++-- | Remove the directory at the given key, including all its children.+removeDirectoryRecursive :: Client -> Key -> IO ()+removeDirectoryRecursive client key =+ void $ runRequest $ httpDELETE (keyUrl client key) $ dirParam ++ recursiveParam
+ test/Test.hs view
@@ -0,0 +1,114 @@+module Main where++import Test.Hspec++import Data.Char+import Data.Maybe++import Control.Applicative+import Control.Concurrent+import Control.Monad+import Control.Monad.Random (getRandomR, evalRandIO)+import Control.Monad.Trans++import Network.Etcd+++main :: IO ()+main = hspec spec+++randomKey :: IO String+randomKey = do+ rnd <- evalRandIO (sequence $ repeat $ getRandomR (0, 61))+ return $ take 13 $ map alnum rnd+ where+ alnum :: Int -> Char+ alnum x+ | x < 26 = chr ((x ) + 65)+ | x < 52 = chr ((x - 26) + 97)+ | x < 62 = chr ((x - 52) + 48)+ | otherwise = error $ "Out of range: " ++ show x+++setup :: IO (Client, String)+setup = do+ client <- createClient [ "http://127.0.0.1:4001" ]+ key <- randomKey++ return (client, key)+++expectNode :: Maybe Node -> IO Node+expectNode = maybe (error "Expected Node") return++shouldBeLeaf :: Node -> Value -> Expectation+shouldBeLeaf node value = _nodeValue node `shouldBe` (Just value)++shouldBeDirectory :: Node -> Expectation+shouldBeDirectory node = _nodeDir node `shouldBe` True+++spec :: Spec+spec = parallel $ do++ describe "Key Space Operations" $ do+ it "Setting the value of a key" $ do+ (client, key) <- setup+ node <- expectNode =<< set client key "value" Nothing+ node `shouldBeLeaf` "value"++ it "Using key TTL" $ do+ (client, key) <- setup+ set client key "value" (Just 1)+ node <- expectNode =<< get client key+ node `shouldBeLeaf` "value"++ threadDelay $ 2 * 1000 * 1000+ node <- get client key+ node `shouldSatisfy` isNothing++ it "Changing the value of a key" $ do+ (client, key) <- setup+ set client key "value" Nothing+ node <- expectNode =<< set client key "value2" Nothing+ node `shouldBeLeaf` "value2"++ it "Get the value of a key" $ do+ (client, _) <- setup+ void $ fromJust <$> get client "/_etcd/machines"++ it "Creating directories" $ do+ (client, key) <- setup+ createDirectory client key Nothing+ node <- expectNode =<< get client key+ shouldBeDirectory node++ it "Deleting a directory" $ do+ (client, key) <- setup+ createDirectory client key Nothing+ removeDirectory client key++ it "Listing a directory" $ do+ (client, key) <- setup+ createDirectory client key Nothing+ set client (key ++ "/one") "value" Nothing+ nodes <- listDirectoryContents client key+ length nodes `shouldBe` 1+ _nodeValue (head nodes) `shouldBe` (Just "value")++ it "Deleting a directory recursively" $ do+ (client, key) <- setup+ createDirectory client key Nothing+ set client (key ++ "/one") "value" Nothing+ removeDirectoryRecursive client key++ it "Atomically Creating In-Order Keys" $ do+ (client, key) <- setup+ createDirectory client key Nothing+ node <- create client key "value" Nothing+ node `shouldBeLeaf` "value"++ nodes <- listDirectoryContents client key+ length nodes `shouldBe` 1+ _nodeValue (head nodes) `shouldBe` (Just "value")