etcd (empty) → 0.1.0.1

raw patch · 5 files changed

+232/−0 lines, 5 filesdep +aesondep +basedep +bytestringsetup-changed

Dependencies added: aeson, base, bytestring, http-conduit

Files

• Setup.hs +2/−0
• UNLICENSE +0/−0
• etcd.cabal +40/−0
• src/Data/Etcd.hs +179/−0
• src/Main.hs +11/−0

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -0,0 +1,40 @@+name:                etcd+version:             0.1.0.1+license:             OtherLicense+license-file:        UNLICENSE+synopsis:            Client for etcd, a highly-available key value store+description:         See https://github.com/coreos/etcd+author:              Tomas Carnecky+maintainer:          tomas.carnecky@gmail.com+category:            Data+build-type:          Simple+cabal-version:       >=1.10+++library+  hs-source-dirs:    src++  exposed-modules:   Data.Etcd++  build-depends:     aeson         >= 0+  build-depends:     base          >= 4.0     && < 5+  build-depends:     bytestring    >= 0+  build-depends:     http-conduit  >= 0++  default-language:  Haskell2010+  ghc-options:       -Wall++++executable etcd-client+  hs-source-dirs:    src++  main-is:           Main.hs++  build-depends:     aeson         >= 0+  build-depends:     base          >= 4.0     && < 5+  build-depends:     bytestring    >= 0+  build-depends:     http-conduit  >= 0++  default-language:  Haskell2010+  ghc-options:       -Wall

@@ -0,0 +1,179 @@+{-# 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 ()

@@ -0,0 +1,11 @@+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 ()