module Network.Etcd
( Client
, createClient
, Node(..)
, Index
, Key
, Value
, TTL
, get
, set
, create
, wait
, waitIndex
, waitRecursive
, waitIndexRecursive
, createDirectory
, listDirectoryContents
, listDirectoryContentsRecursive
, removeDirectory
, removeDirectoryRecursive
) where
import Data.Aeson hiding (Value, Error)
import Data.Time.Clock
import Data.Time.LocalTime
import Data.List
import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Encoding
import Data.Monoid
import Data.ByteString.Lazy (ByteString)
import Control.Applicative
import Control.Exception
import Control.Monad
import Network.HTTP.Conduit hiding (Response, path)
import Prelude
data Client = Client
{ leaderUrl :: !Text
}
versionPrefix :: Text
versionPrefix = "v2"
keyUrl :: Client -> Key -> Text
keyUrl client key = leaderUrl client <> "/" <> versionPrefix <> "/keys/" <> key
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"
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"
data Error = Error !Text
deriving (Show, Eq, Ord)
type Index = Int
type Key = Text
type Value = Text
type TTL = Int
data Node = Node
{ _nodeKey :: !Key
, _nodeCreatedIndex :: !Index
, _nodeModifiedIndex :: !Index
, _nodeDir :: !Bool
, _nodeValue :: !(Maybe Value)
, _nodeNodes :: !(Maybe [Node])
, _nodeTTL :: !(Maybe TTL)
, _nodeExpiration :: !(Maybe UTCTime)
} deriving (Show, Eq, Ord)
instance FromJSON Node where
parseJSON (Object o) = Node
<$> o .:? "key" .!= "/"
<*> o .:? "createdIndex" .!= 0
<*> o .:? "modifiedIndex" .!= 0
<*> o .:? "dir" .!= False
<*> o .:? "value"
<*> o .:? "nodes"
<*> o .:? "ttl"
<*> (fmap zonedTimeToUTC <$> (o .:? "expiration"))
parseJSON _ = fail "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 -> [(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)
decodeResponseBody body
where
acceptHeader = ("Accept","application/json")
acceptJSON req = req { requestHeaders = acceptHeader : requestHeaders req }
httpPUT :: Text -> [(Text, Text)] -> IO HR
httpPUT 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 = "PUT" })
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" })
decodeResponseBody body
httpDELETE :: Text -> [(Text, Text)] -> IO HR
httpDELETE url params = do
req <- parseUrl $ T.unpack $ url <> (asQueryParams params)
body <- responseBody <$> (withManager $ httpLbs $ req { method = "DELETE" })
decodeResponseBody body
where
asQueryParams [] = ""
asQueryParams xs = "?" <> mconcat (intersperse "&" (map (\(k,v) -> k <> "=" <> v) xs))
runRequest :: IO HR -> IO HR
runRequest a = catch a (\(e :: SomeException) -> return $ Left $ Error $ T.pack $ show e)
runRequest' :: IO HR -> IO (Maybe Node)
runRequest' m = either (const Nothing) (Just . _resNode) <$> runRequest m
ttlParam :: Maybe TTL -> [(Text, Text)]
ttlParam Nothing = []
ttlParam (Just ttl) = [("ttl", T.pack $ show ttl)]
createClient :: [ Text ] -> IO Client
createClient seed = return $ Client (head seed)
waitParam :: (Text, Text)
waitParam = ("wait","true")
waitRecursiveParam :: (Text, Text)
waitRecursiveParam = ("recursive","true")
waitIndexParam :: Index -> (Text, Text)
waitIndexParam i = ("waitIndex", (T.pack $ show i))
get :: Client -> Key -> IO (Maybe Node)
get client key =
runRequest' $ httpGET (keyUrl client key) []
set :: Client -> Key -> Value -> Maybe TTL -> IO (Maybe Node)
set client key value mbTTL =
runRequest' $ httpPUT (keyUrl client key) $
[("value",value)] ++ ttlParam mbTTL
create :: Client -> Key -> Value -> Maybe TTL -> IO Node
create client key value mbTTL = do
hr <- runRequest $ httpPOST (keyUrl client key) $
[("value",value)] ++ ttlParam mbTTL
case hr of
Left _ -> error "Unexpected error"
Right res -> return $ _resNode res
wait :: Client -> Key -> IO (Maybe Node)
wait client key =
runRequest' $ httpGET (keyUrl client key) [waitParam]
waitIndex :: Client -> Key -> Index -> IO (Maybe Node)
waitIndex client key index =
runRequest' $ httpGET (keyUrl client key) $
[waitParam, waitIndexParam index]
waitRecursive :: Client -> Key -> IO (Maybe Node)
waitRecursive client key =
runRequest' $ httpGET (keyUrl client key) $
[waitParam, waitRecursiveParam]
waitIndexRecursive :: Client -> Key -> Index -> IO (Maybe Node)
waitIndexRecursive client key index =
runRequest' $ httpGET (keyUrl client key) $
[waitParam, waitIndexParam index, waitRecursiveParam]
dirParam :: [(Text, Text)]
dirParam = [("dir","true")]
recursiveParam :: [(Text, Text)]
recursiveParam = [("recursive","true")]
createDirectory :: Client -> Key -> Maybe TTL -> IO ()
createDirectory client key mbTTL =
void $ runRequest $ httpPUT (keyUrl client key) $ dirParam ++ ttlParam mbTTL
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
listDirectoryContentsRecursive :: Client -> Key -> IO [Node]
listDirectoryContentsRecursive client key = do
hr <- runRequest $ httpGET (keyUrl client key) recursiveParam
case hr of
Left _ -> return []
Right res -> do
let node = _resNode res
flatten n = n { _nodeNodes = Nothing }
: maybe [] (concatMap flatten) (_nodeNodes n)
case _nodeNodes node of
Nothing -> return []
Just children -> return $ concatMap flatten children
removeDirectory :: Client -> Key -> IO ()
removeDirectory client key =
void $ runRequest $ httpDELETE (keyUrl client key) dirParam
removeDirectoryRecursive :: Client -> Key -> IO ()
removeDirectoryRecursive client key =
void $ runRequest $ httpDELETE (keyUrl client key) $ dirParam ++ recursiveParam