module Network.Etcd
( Client
, createClient
, Node(..)
, Index
, Key
, Value
, TTL
, get
, set
, create
, createDirectory
, listDirectoryContents
, 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 Control.Applicative
import Control.Exception
import Control.Monad
import Network.HTTP.Conduit hiding (Response, path)
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
deriving (Show, Eq, Ord)
instance FromJSON Error where
parseJSON _ = return Error
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"
<*> o .: "modifiedIndex"
<*> o .:? "dir" .!= False
<*> o .:? "value"
<*> o .:? "nodes"
<*> o .:? "ttl"
<*> (fmap zonedTimeToUTC <$> (o .:? "expiration"))
parseJSON _ = fail "Response"
type HR = Either Error Response
httpGET :: Text -> IO HR
httpGET url = do
req <- acceptJSON <$> parseUrl (T.unpack 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 :: 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" })
return $ maybe (Left Error) Right $ decode 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
httpDELETE :: Text -> [(Text, Text)] -> IO HR
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
where
asQueryParams [] = ""
asQueryParams xs = "?" <> mconcat (intersperse "&" (map (\(k,v) -> k <> "=" <> v) xs))
runRequest :: IO HR -> IO HR
runRequest a = catch a (ignoreExceptionWith (return $ Left Error))
ignoreExceptionWith :: a -> SomeException -> a
ignoreExceptionWith a _ = a
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)
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 :: 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 :: 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
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
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