diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,26 @@ +Copyright (c) 2014, Alpha Heavy Industries, Inc. +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +- Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. +- Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. +- Neither the names of the copyright owners nor the names of the + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/consul-haskell.cabal b/consul-haskell.cabal new file mode 100644 --- /dev/null +++ b/consul-haskell.cabal @@ -0,0 +1,67 @@ +name: consul-haskell +version: 0.1 +synopsis: A consul client for Haskell +description: + A consul client for Haskell + . + Requires consul 0.5 or later. + +license: BSD3 +license-file: LICENSE +author: Steve Severance +maintainer: sseverance@alphaheavy.com +homepage: https://github.com/alphaHeavy/consul-haskell +bug-reports: https://github.com/alphaHeavy/consul-haskell/issues +category: Network + +build-type: Simple +cabal-version: >= 1.10 + +extra-source-files: + tests/Main.hs + +library + default-language: + Haskell2010 + hs-source-dirs: + src + exposed-modules: + Network.Consul + Network.Consul.Internal + Network.Consul.Types + build-depends: + aeson, + base >= 4.6 && < 5, + base64-bytestring, + bytestring, + http-client, + network, + text, + transformers + ghc-options: + -Wall + +test-suite consul-haskell-test + default-language: + Haskell2010 + hs-source-dirs: + tests + type: + exitcode-stdio-1.0 + main-is: + Main.hs + build-depends: + base >= 4.6 && < 5, + consul-haskell, + http-client, + network, + tasty, + tasty-hunit, + HUnit >= 1.2 + ghc-options: + -Wall + + +source-repository head + type: git + location: https://github.com/alphaHeavy/consul-haskell.git diff --git a/src/Network/Consul.hs b/src/Network/Consul.hs new file mode 100644 --- /dev/null +++ b/src/Network/Consul.hs @@ -0,0 +1,105 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Network.Consul ( + createManagedSession + , deleteKey + , destroyManagedSession + , getKey + , getKeys + , initializeConsulClient + , listKeys + , putKey + , putKeyAcquireLock + , putKeyReleaseLock + , withManagedSession + , Consistency(..) + , ConsulClient(..) + , Datacenter(..) + , KeyValue(..) + , KeyValuePut(..) + , ManagedSession(..) + , Session(..) +) where + +import Control.Concurrent +import Control.Monad.IO.Class +import Data.Text (Text) +import Data.Traversable +import qualified Network.Consul.Internal as I +import Data.Word +import Network.Consul.Types +import Network.HTTP.Client (defaultManagerSettings, newManager, Manager) +import Network.Socket (PortNumber) + +import Prelude hiding (mapM) + +initializeConsulClient :: MonadIO m => Text -> PortNumber -> Maybe Manager -> m ConsulClient +initializeConsulClient hostname port man = do + manager <- liftIO $ case man of + Just x -> return x + Nothing -> newManager defaultManagerSettings + return $ ConsulClient manager hostname port + + +{- Key Value -} + +getKey :: MonadIO m => ConsulClient -> Text -> Maybe Word64 -> Maybe Consistency -> Maybe Datacenter -> m (Maybe KeyValue) +getKey _client@ConsulClient{..} = I.getKey ccManager ccHostname ccPort + +getKeys :: MonadIO m => ConsulClient -> Text -> Maybe Word64 -> Maybe Consistency -> Maybe Datacenter -> m [KeyValue] +getKeys _client@ConsulClient{..} = I.getKeys ccManager ccHostname ccPort + +listKeys :: MonadIO m => ConsulClient -> Text -> Maybe Word64 -> Maybe Consistency -> Maybe Datacenter -> m [Text] +listKeys _client@ConsulClient{..} = I.listKeys ccManager ccHostname ccPort + +putKey :: MonadIO m => ConsulClient -> KeyValuePut -> Maybe Datacenter -> m Bool +putKey _client@ConsulClient{..} = I.putKey ccManager ccHostname ccPort + +putKeyAcquireLock :: MonadIO m => ConsulClient -> KeyValuePut -> Session -> Maybe Datacenter -> m Bool +putKeyAcquireLock _client@ConsulClient{..} = I.putKeyAcquireLock ccManager ccHostname ccPort + +putKeyReleaseLock :: MonadIO m => ConsulClient -> KeyValuePut -> Session -> Maybe Datacenter -> m Bool +putKeyReleaseLock _client@ConsulClient{..} = I.putKeyReleaseLock ccManager ccHostname ccPort + +deleteKey :: MonadIO m => ConsulClient -> Text -> Bool -> Maybe Datacenter -> m () +deleteKey _client@ConsulClient{..} key = I.deleteKey ccManager ccHostname ccPort key + +{- Agent -} + +{- Helper Functions -} + +{- ManagedSession is a session with an associated TTL healthcheck so the session will be terminated if the client dies. The healthcheck will be automatically updated. -} +data ManagedSession = ManagedSession{ + msSession :: Session, + msThreadId :: ThreadId +} + +withManagedSession :: MonadIO m => ConsulClient -> Int -> (Session -> m ()) -> m () +withManagedSession client ttl action = do + x <- createManagedSession client Nothing ttl + case x of + Just s -> action (msSession s) >> destroyManagedSession client s + Nothing -> return () + +createManagedSession :: MonadIO m => ConsulClient -> Maybe Text -> Int -> m (Maybe ManagedSession) +createManagedSession _client@ConsulClient{..} name ttl = do + let r = SessionRequest Nothing name Nothing [] (Just Release) (Just ttl) + s <- I.createSession ccManager ccHostname ccPort r Nothing + mapM f s + where + f x = do + tid <- liftIO $ forkIO $ runThread x + return $ ManagedSession x tid + + runThread :: Session -> IO () + runThread s = do + threadDelay 10 + I.renewSession ccManager ccHostname ccPort s Nothing + return () + +destroyManagedSession :: MonadIO m => ConsulClient -> ManagedSession -> m () +destroyManagedSession _client@ConsulClient{..} (ManagedSession session tid) = do + liftIO $ killThread tid + I.destroySession ccManager ccHostname ccPort session Nothing diff --git a/src/Network/Consul/Internal.hs b/src/Network/Consul/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Network/Consul/Internal.hs @@ -0,0 +1,282 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Network.Consul.Internal ( + --Key-Value Store + deleteKey + , getKey + , getKeys + , listKeys + , putKey + , putKeyAcquireLock + , putKeyReleaseLock + + --Agent + , deregisterHealthCheck + , deregisterService + , failHealthCheck + , passHealthCheck + , registerHealthCheck + , registerService + , warnHealthCheck + + --Health + , getServiceChecks + , getServiceHealth + + -- Session + , createSession + , destroySession + , renewSession + + --Catalog + , getDatacenters + ) where + +import Control.Monad.IO.Class +import Data.Aeson (decode,encode) +import Data.ByteString (ByteString) +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as BL +import Data.Maybe +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import Data.Word +import Network.Consul.Types +import Network.HTTP.Client +import Network.Socket (PortNumber(..)) + +createRequest :: MonadIO m => Text -> PortNumber -> Text -> Maybe Text -> Maybe ByteString -> Bool -> Maybe Datacenter -> m Request +createRequest hostname (PortNum portNumber) endpoint query body wait dc = do + let baseUrl = T.concat ["http://",hostname,":",T.pack $ show portNumber,endpoint,needQueryString + ,maybe "" id query, prefixAnd, maybe "" (\ (Datacenter x) -> T.concat["dc=",x]) dc] + initReq <- liftIO $ parseUrl $ T.unpack baseUrl + case body of + Just x -> return $ indef $ initReq{ method = "PUT", requestBody = RequestBodyBS x, checkStatus = \ _ _ _ -> Nothing} + Nothing -> return $ indef $ initReq{checkStatus = \ _ _ _ -> Nothing} + where + needQueryString = if isJust dc || isJust query then "?" else "" + prefixAnd = if isJust query && isJust dc then "&" else "" + indef req = if wait == True then req{responseTimeout = Nothing} else req + +{- Key Value Store -} +getKey :: MonadIO m => Manager -> Text -> PortNumber -> Text -> Maybe Word64 -> Maybe Consistency -> Maybe Datacenter -> m (Maybe KeyValue) +getKey manager hostname portnumber key index consistency dc = do + request <- createRequest hostname portnumber (T.concat ["/v1/kv/",key]) fquery Nothing (isJust index) dc + liftIO $ withResponse request manager $ \ response -> do + case responseStatus response of + _status200 -> do + bodyParts <- brConsume $ responseBody response + let body = B.concat bodyParts + return $ listToMaybe =<< (decode $ BL.fromStrict body) + _ -> return Nothing + where + cons = fmap (\ x -> T.concat["consistency=", T.pack $ show x] ) consistency + ind = fmap (\ x -> T.concat["index=", T.pack $ show x]) index + query = T.intercalate "&" $ catMaybes [cons,ind] + fquery = if query /= T.empty then Just query else Nothing + +getKeys :: MonadIO m => Manager -> Text -> PortNumber -> Text -> Maybe Word64 -> Maybe Consistency -> Maybe Datacenter -> m [KeyValue] +getKeys manager hostname portnumber key index consistency dc = do + request <- createRequest hostname portnumber (T.concat ["/v1/kv/",key]) fquery Nothing (isJust index) dc + liftIO $ withResponse request manager $ \ response -> do + case responseStatus response of + _status200 -> do + bodyParts <- brConsume $ responseBody response + let body = B.concat bodyParts + return $ maybe [] id $ decode $ BL.fromStrict body + _ -> return [] + where + cons = fmap (\ x -> T.concat["consistency=", T.pack $ show x] ) consistency + ind = fmap (\ x -> T.concat["index=", T.pack $ show x]) index + query = T.intercalate "&" $ catMaybes [cons,ind, Just "recurse"] + fquery = if query /= T.empty then Just query else Nothing + + +listKeys :: MonadIO m => Manager -> Text -> PortNumber -> Text -> Maybe Word64 -> Maybe Consistency -> Maybe Datacenter -> m [Text] +listKeys manager hostname portNumber prefix index consistency dc = do + initReq <- createRequest hostname portNumber (T.concat ["/v1/kv/", prefix]) fquery Nothing (isJust index) dc + liftIO $ withResponse initReq manager $ \ response -> + case responseStatus response of + _status200 -> do + bodyParts <- brConsume $ responseBody response + let body = B.concat bodyParts + return $ maybe [] id $ decode $ BL.fromStrict body + _ -> return [] + where + cons = fmap (\ x -> T.concat["consistency=", T.pack $ show x] ) consistency + ind = fmap (\ x -> T.concat["index=", T.pack $ show x]) index + query = T.intercalate "&" $ catMaybes [cons,ind, Just "keys"] + fquery = if query /= T.empty then Just query else Nothing + +putKey :: MonadIO m => Manager -> Text -> PortNumber -> KeyValuePut -> Maybe Datacenter -> m Bool +putKey manager hostname portNumber request dc = do + initReq <- createRequest hostname portNumber (T.concat ["/v1/kv/", kvpKey request]) fquery (Just $ kvpValue request) False dc + liftIO $ withResponse initReq manager $ \ response -> do + bodyParts <- brConsume $ responseBody response + let body = B.concat bodyParts + case TE.decodeUtf8 body of + "true" -> return True + "false" -> return False + _ -> return False + where + flags = fmap (\ x -> T.concat["flags=", T.pack $ show x]) $ kvpFlags request + cas = fmap (\ x -> T.concat["cas=",T.pack $ show x]) $ kvpCasIndex request + query = T.intercalate "&" $ catMaybes [flags,cas] + fquery = if query /= T.empty then Just query else Nothing + +putKeyAcquireLock :: MonadIO m => Manager -> Text -> PortNumber -> KeyValuePut -> Session -> Maybe Datacenter -> m Bool +putKeyAcquireLock manager hostname portNumber request (Session session _) dc = do + initReq <- createRequest hostname portNumber (T.concat ["/v1/kv/", kvpKey request]) fquery (Just $ kvpValue request) False dc + liftIO $ withResponse initReq manager $ \ response -> do + bodyParts <- brConsume $ responseBody response + let body = B.concat bodyParts + case TE.decodeUtf8 body of + "true" -> return True + "false" -> return False + _ -> return False + where + flags = fmap (\ x -> T.concat["flags=", T.pack $ show x]) $ kvpFlags request + cas = fmap (\ x -> T.concat["cas=",T.pack $ show x]) $ kvpCasIndex request + acquire = T.concat["acquire=",session] + query = T.intercalate "&" $ catMaybes [flags,cas,Just acquire] + fquery = if query /= T.empty then Just query else Nothing + +putKeyReleaseLock :: MonadIO m => Manager -> Text -> PortNumber -> KeyValuePut -> Session -> Maybe Datacenter -> m Bool +putKeyReleaseLock manager hostname portNumber request (Session session _) dc = do + initReq <- createRequest hostname portNumber (T.concat ["/v1/kv/", kvpKey request]) fquery (Just $ kvpValue request) False dc + liftIO $ withResponse initReq manager $ \ response -> do + bodyParts <- brConsume $ responseBody response + let body = B.concat bodyParts + case TE.decodeUtf8 body of + "true" -> return True + "false" -> return False + _ -> return False + where + flags = fmap (\ x -> T.concat["flags=", T.pack $ show x]) $ kvpFlags request + cas = fmap (\ x -> T.concat["cas=",T.pack $ show x]) $ kvpCasIndex request + release = T.concat["release=",session] + query = T.intercalate "&" $ catMaybes [flags,cas,Just release] + fquery = if query /= T.empty then Just query else Nothing + +deleteKey :: MonadIO m => Manager -> Text -> PortNumber -> Text -> Bool -> Maybe Datacenter -> m () +deleteKey manager hostname portNumber key recurse dc = do + initReq <- createRequest hostname portNumber (T.concat ["/v1/kv/", key]) (if recurse then Just "recurse" else Nothing) Nothing False dc + let httpReq = initReq { method = "DELETE"} + liftIO $ withResponse httpReq manager $ \ response -> do + _bodyParts <- brConsume $ responseBody response + return () + +{- Agent -} +{-getHealthChecks :: MonadIO m => Manager -> Text -> PortNumber -> Maybe Datacenter -> m [Check] +getHealthChecks manager hostname portNumber dc = do + request <- createRequest hostname portNumber "/agent/checks" Nothing Nothing False dc + -} + +registerHealthCheck :: MonadIO m => Manager -> Text -> PortNumber -> RegisterHealthCheck -> m () +registerHealthCheck manager hostname (PortNum portNumber) request = do + initReq <- liftIO $ parseUrl $ T.unpack $ T.concat ["http://",hostname, ":", T.pack $ show portNumber ,"/v1/agent/check/register"] + let httpReq = initReq { method = "PUT", requestBody = RequestBodyBS $ BL.toStrict $ encode request} + liftIO $ withResponse httpReq manager $ \ response -> do + _bodyParts <- brConsume $ responseBody response + return () + +deregisterHealthCheck :: MonadIO m => Manager -> Text -> PortNumber -> Text -> m () +deregisterHealthCheck manager hostname (PortNum portNumber) checkId = do + initReq <- liftIO $ parseUrl $ T.unpack $ T.concat ["http://",hostname, ":", T.pack $ show portNumber ,"/v1/agent/check/deregister/", checkId] + liftIO $ withResponse initReq manager $ \ response -> do + _bodyParts <- brConsume $ responseBody response + return () + + +passHealthCheck :: MonadIO m => Manager -> Text -> PortNumber -> Text -> m () +passHealthCheck manager hostname (PortNum portNumber) checkId = do + initReq <- liftIO $ parseUrl $ T.unpack $ T.concat ["http://",hostname, ":", T.pack $ show portNumber ,"/v1/agent/check/pass/", checkId] + liftIO $ withResponse initReq manager $ \ response -> do + _bodyParts <- brConsume $ responseBody response + return () + +warnHealthCheck :: MonadIO m => Manager -> Text -> PortNumber -> Text -> m () +warnHealthCheck manager hostname (PortNum portNumber) checkId = do + initReq <- liftIO $ parseUrl $ T.unpack $ T.concat ["http://",hostname, ":", T.pack $ show portNumber ,"/v1/agent/check/warn/", checkId] + liftIO $ withResponse initReq manager $ \ response -> do + _bodyParts <- brConsume $ responseBody response + return () + +failHealthCheck :: MonadIO m => Manager -> Text -> PortNumber -> Text -> m () +failHealthCheck manager hostname (PortNum portNumber) checkId = do + initReq <- liftIO $ parseUrl $ T.unpack $ T.concat ["http://",hostname, ":", T.pack $ show portNumber ,"/v1/agent/check/fail/", checkId] + liftIO $ withResponse initReq manager $ \ response -> do + _bodyParts <- brConsume $ responseBody response + return () + +registerService :: MonadIO m => Manager -> Text -> PortNumber -> RegisterService -> m () +registerService manager hostname (PortNum portNumber) request = do + initReq <- liftIO $ parseUrl $ T.unpack $ T.concat ["http://",hostname, ":", T.pack $ show portNumber ,"/v1/agent/service/register"] + let httpReq = initReq { method = "PUT", requestBody = RequestBodyBS $ BL.toStrict $ encode request} + liftIO $ withResponse httpReq manager $ \ response -> do + _bodyParts <- brConsume $ responseBody response + return () + +deregisterService :: MonadIO m => Manager -> Text -> PortNumber -> Text -> m () +deregisterService manager hostname (PortNum portNumber) service = do + initReq <- liftIO $ parseUrl $ T.unpack $ T.concat ["http://",hostname, ":", T.pack $ show portNumber ,"/v1/agent/service/deregister/", service] + liftIO $ withResponse initReq manager $ \ response -> do + _bodyParts <- brConsume $ responseBody response + return () + + +{- Health -} +getServiceChecks :: MonadIO m => Manager -> Text -> PortNumber -> Text -> m [Check] +getServiceChecks manager hostname (PortNum portNumber) name = do + initReq <- liftIO $ parseUrl $ T.unpack $ T.concat ["http://",hostname, ":", T.pack $ show portNumber ,"/v1/health/checks/", name] + liftIO $ withResponse initReq manager $ \ response -> do + bodyParts <- brConsume $ responseBody response + let body = B.concat bodyParts + return $ maybe [] id (decode $ BL.fromStrict body) + +getServiceHealth :: MonadIO m => Manager -> Text -> PortNumber -> Text -> m (Maybe Health) +getServiceHealth manager hostname (PortNum portNumber) name = do + initReq <- liftIO $ parseUrl $ T.unpack $ T.concat ["http://",hostname, ":", T.pack $ show portNumber ,"/v1/health/service/", name] + liftIO $ withResponse initReq manager $ \ response -> do + bodyParts <- brConsume $ responseBody response + let body = B.concat bodyParts + return $ decode $ BL.fromStrict body + +{- Session -} +createSession :: MonadIO m => Manager -> Text -> PortNumber -> SessionRequest -> Maybe Datacenter -> m (Maybe Session) +createSession manager hostname portNumber request dc = do + initReq <- createRequest hostname portNumber "/v1/session/create" Nothing (Just $ BL.toStrict $ encode request) False dc + liftIO $ withResponse initReq manager $ \ response -> do + case responseStatus response of + status200 -> do + bodyParts <- brConsume $ responseBody response + return $ decode $ BL.fromStrict $ B.concat bodyParts + _ -> return Nothing + +destroySession :: MonadIO m => Manager -> Text -> PortNumber -> Session -> Maybe Datacenter -> m () +destroySession manager hostname portNumber (Session session _) dc = do + initReq <- createRequest hostname portNumber (T.concat ["/v1/session/destroy/", session]) Nothing Nothing False dc + liftIO $ withResponse initReq manager $ \ response -> do + return () + +renewSession :: MonadIO m => Manager -> Text -> PortNumber -> Session -> Maybe Datacenter -> m Bool +renewSession manager hostname portNumber (Session session _) dc = do + initReq <- createRequest hostname portNumber (T.concat ["/v1/session/renew/", session]) Nothing Nothing False dc + liftIO $ withResponse initReq manager $ \ response -> do + case responseStatus response of + status200 -> return True + _ -> return False + +{- Catalog -} +getDatacenters :: MonadIO m => Manager -> Text -> PortNumber -> m [Datacenter] +getDatacenters manager hostname (PortNum portNumber) = liftIO $ do + initReq <- parseUrl $ T.unpack $ T.concat ["http://",hostname, ":", T.pack $ show portNumber ,"/v1/catalog/datacenters/"] + withResponse initReq manager $ \ response -> do + bodyParts <- brConsume $ responseBody response + let body = B.concat bodyParts + let val = (decode $ BL.fromStrict body) + case val of + Just x -> return x + Nothing -> return [] + diff --git a/src/Network/Consul/Types.hs b/src/Network/Consul/Types.hs new file mode 100644 --- /dev/null +++ b/src/Network/Consul/Types.hs @@ -0,0 +1,189 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +module Network.Consul.Types ( + Check(..), + Consistency(..), + ConsulClient(..), + Datacenter (..), + Health(..), + KeyValue(..), + KeyValuePut(..), + RegisterRequest(..), + RegisterHealthCheck(..), + RegisterService(..), + Session(..), + SessionBehavior(..), + SessionRequest(..) +) where + +import Control.Applicative +import Control.Monad +import Data.Aeson +import Data.ByteString (ByteString) +import qualified Data.ByteString.Base64 as B64 +import Data.Int +import Data.Text(Text) +import qualified Data.Text.Encoding as TE +import Data.Word +import Debug.Trace +import Network.HTTP.Client (Manager) +import Network.Socket + +data ConsulClient = ConsulClient{ + ccManager :: Manager, + ccHostname :: Text, + ccPort :: PortNumber +} + +data Datacenter = Datacenter Text deriving (Eq,Show,Ord) + +data Consistency = Consistent | Default | Stale deriving (Eq,Show,Enum,Ord) + +data HealthCheckStatus = Critical | Passing | Unknown | Warning deriving (Eq,Show,Enum,Ord) + +data SessionBehavior = Release | Delete deriving (Eq,Show,Enum,Ord) + +data KeyValue = KeyValue { + kvCreateIndex :: Word64, + kvLockIndex :: Word64, + kvModifyIndex :: Word64, + kvValue :: ByteString, + kvFlags :: Word64, + kvSession :: Maybe Text, + kvKey :: Text +} deriving (Show,Eq) + +data KeyValuePut = KeyValuePut { + kvpKey :: Text, + kvpValue :: ByteString, + kvpCasIndex :: Maybe Word64, + kvpFlags :: Maybe Word64 +} + +data Session = Session { + sId :: Text, + sCreateIndex :: Maybe Word64 +} + +data SessionRequest = SessionRequest { + srLockDelay :: Maybe Text, + srName :: Maybe Text, + srNode :: Maybe Node, + srChecks :: [Text], + srBehavor :: Maybe SessionBehavior, + srTtl :: Maybe Int +} + +data RegisterRequest = RegisterRequest { + rrDatacenter :: Maybe Datacenter, + rrNode :: Text, + rrAddress :: Text, + rrService :: Maybe Service, + rrCheck :: Maybe Check +} + +data Service = Service { + seId :: Text, + seService :: Text, + seTags :: [Text], + sePort :: Maybe Int +} + +data Check = Check { + cNode :: Text, + cCheckId :: Text, + cName :: Maybe Text, + cNotes :: Maybe Text, + cServiceId :: Maybe Text, + cStatus :: HealthCheckStatus, + cOutput :: Text, + cServiceName :: Text +} + +data Node = Node { + nNode :: Text, + nAddress :: Text +} + +{- Agent -} +data RegisterHealthCheck = RegisterHealthCheck { + rhcId :: Text, + rhcName :: Text, + rhcNotes :: Text, + rhcScript :: Maybe Text, + rhcInterval :: Maybe Text, + rhcTtl :: Maybe Text +} + +data RegisterService = RegisterService { + rsId :: Maybe Text, + rsName :: Text, + rsTags :: [Text], + rsPort :: Maybe Int16, + rsCheck :: Either (Text,Text) Text -- (script,interval) ttl +} + +{- Health -} +data Health = Health { + hNode :: Node, + hService :: Service, + hChecks :: [Check] +} + + +{- JSON Instances -} +instance FromJSON HealthCheckStatus where + parseJSON (String "Critical") = pure Critical + parseJSON (String "Passing") = pure Passing + parseJSON (String "Unknown") = pure Unknown + parseJSON (String "Warning") = pure Warning + parseJSON _ = mzero + +instance FromJSON KeyValue where + parseJSON (Object v) = KeyValue <$> v .: "CreateIndex" <*> v .: "LockIndex" <*> v .: "ModifyIndex" <*> (foo =<< B64.decode . TE.encodeUtf8 <$> v .: "Value") <*> v .: "Flags" <*> v .:? "Session" <*> v .: "Key" + parseJSON _ = mzero + +instance FromJSON Datacenter where + parseJSON (String val) = pure $ Datacenter val + parseJSON _ = mzero + +instance FromJSON Check where + parseJSON (Object x) = Check <$> x .: "Node" <*> x .: "CheckId" <*> x .: "Name" <*> x .: "Notes" <*> x .: "ServiceId" <*> x .: "Status" <*> x .: "Output" <*> x .: "ServiceName" + parseJSON _ = mzero + +instance FromJSON Service where + parseJSON (Object x) = Service <$> x .: "Id" <*> x .: "Service" <*> x .: "Tags" <*> x .: "Port" + parseJSON _ = mzero + +instance FromJSON Node where + parseJSON (Object x) = Node <$> x .: "Node" <*> x .: "Address" + parseJSON _ = mzero + +instance FromJSON Health where + parseJSON (Object x) = Health <$> x.: "Node" <*> x .: "Service" <*> x .: "Checks" + parseJSON _ = mzero + +instance FromJSON Session where + parseJSON (Object x) = Session <$> x .: "ID" <*> pure Nothing + parseJSON _ = mzero + +instance ToJSON SessionBehavior where + toJSON Release = String "release" + toJSON Delete = String "delete" + +instance ToJSON RegisterHealthCheck where + toJSON (RegisterHealthCheck id name notes script interval ttl) = object ["id" .= id, "name" .= name, "notes" .= notes, "script" .= script, "interval" .= interval, "ttl" .= ttl] + +instance ToJSON RegisterService where + toJSON (RegisterService id name tags port check) = object ["ID" .= id, "Name" .= name, "Tags" .= tags, "Port" .= port, "Check" .= check] + +instance ToJSON SessionRequest where + toJSON (SessionRequest lockDelay name node checks behavior ttl) = object["LockDelay" .= lockDelay, "Name" .= name, "Node" .= (fmap nNode node), "Checks" .= checks, "Behavior" .= behavior, "TTL" .= ttl] + +instance ToJSON (Either (Text,Text) Text) where + toJSON (Left (script,interval)) = object ["Script" .= script, "Interval" .= interval] + toJSON (Right ttl) = object ["TTL" .= ttl] + +foo :: Monad m => Either String a -> m a +foo (Left x) = trace "failing" $ fail x +foo (Right x) = return x diff --git a/tests/Main.hs b/tests/Main.hs new file mode 100644 --- /dev/null +++ b/tests/Main.hs @@ -0,0 +1,93 @@ +{-# LANGUAGE OverloadedStrings #-} +import Network.Consul.Types +import qualified Network.Consul.Internal as I +import Network.HTTP.Client +import Network.Socket (PortNumber(..)) +import Test.Tasty +import Test.Tasty.HUnit + +manager :: IO Manager +manager = newManager defaultManagerSettings + +{- Internal Tests -} +internalKVTests :: TestTree +internalKVTests = testGroup "Internal Key Value" [testGetInvalidKey, testPutKey, + testGetKey,testGetKeys,testListKeys,testDeleteKey] + +testGetInvalidKey :: TestTree +testGetInvalidKey = testCase "testGetInvalidKey" $ do + man <- manager + x <- I.getKey man "localhost" (PortNum 8500) "nokey" Nothing Nothing Nothing + assertEqual "testGetInvalidKey: Found a key that doesn't exist" x Nothing + +testPutKey :: TestTree +testPutKey = testCase "testPutKey" $ do + man <- manager + let put = KeyValuePut "/testPutKey" "Test" Nothing Nothing + x <- I.putKey man "localhost" (PortNum 8500) put Nothing + assertEqual "testPutKey: Write failed" True x + +testGetKey :: TestTree +testGetKey = testCase "testGetKey" $ do + man <- manager + let put = KeyValuePut "/testGetKey" "Test" Nothing Nothing + x1 <- I.putKey man "localhost" (PortNum 8500) put Nothing + assertEqual "testGetKey: Write failed" True x1 + x2 <- I.getKey man "localhost" (PortNum 8500) "/testGetKey" Nothing Nothing Nothing + case x2 of + Just x -> assertEqual "testGetKey: Incorrect Value" (kvValue x) "Test" + Nothing -> assertFailure "testGetKey: No value returned" + +testGetKeys :: TestTree +testGetKeys = testCase "testGetKeys" $ do + man <- manager + let put1 = KeyValuePut "/testGetKeys/key1" "Test" Nothing Nothing + x1 <- I.putKey man "localhost" (PortNum 8500) put1 Nothing + assertEqual "testGetKeys: Write failed" True x1 + let put2 = KeyValuePut "/testGetKeys/key2" "Test" Nothing Nothing + x2 <- I.putKey man "localhost" (PortNum 8500) put2 Nothing + assertEqual "testGetKeys: Write failed" True x2 + x3 <- I.getKeys man "localhost" (PortNum 8500) "/testGetKeys" Nothing Nothing Nothing + assertEqual "testGetKeys: Incorrect number of results" 2 (length x3) + +testListKeys :: TestTree +testListKeys = testCase "testListKeys" $ do + man <- manager + let put1 = KeyValuePut "/testListKeys/key1" "Test" Nothing Nothing + x1 <- I.putKey man "localhost" (PortNum 8500) put1 Nothing + assertEqual "testListKeys: Write failed" True x1 + let put2 = KeyValuePut "/testListKeys/key2" "Test" Nothing Nothing + x2 <- I.putKey man "localhost" (PortNum 8500) put2 Nothing + assertEqual "testListKeys: Write failed" True x2 + x3 <- I.listKeys man "localhost" (PortNum 8500) "/testListKeys/" Nothing Nothing Nothing + assertEqual "testListKeys: Incorrect number of results" 2 (length x3) + +testDeleteKey :: TestTree +testDeleteKey = testCase "testDeleteKey" $ do + man <- manager + let put1 = KeyValuePut "/testDeleteKey" "Test" Nothing Nothing + x1 <- I.putKey man "localhost" (PortNum 8500) put1 Nothing + assertEqual "testDeleteKey: Write failed" True x1 + I.deleteKey man "localhost" (PortNum 8500) "/testDeleteKey" False Nothing + x2 <- I.getKey man "localhost" (PortNum 8500) "/testDeleteKey" Nothing Nothing Nothing + assertEqual "testDeleteKey: Key was not deleted" Nothing x2 + +{- Agent -} +testRegisterService :: TestTree +testRegisterService = testCase "testRegisterService" $ do + man <- manager + let req = RegisterService Nothing "testService" ["test"] Nothing (Right "10s") + I.registerService man "localhost" (PortNum 8500) req +{- +testRegisterHealthCheck :: TestTree +testRegisterHealthCheck = testCase "testRegisterHealthCheck" $ do + man <- manager + let check = RegisterHealthCheck "testHealthCheck" "testHealthCheck" "" Nothing Nothing (Just "15s") + x1 <- I.registerHealthCheck man "localhost" (PortNum 8500) check + undefined -} + +{- Health Checks -} +--testServiceChecks :: + +main :: IO () +main = defaultMain internalKVTests