consul-haskell 0.2.1 → 0.3

raw patch · 5 files changed

+257/−129 lines, 5 filesdep +connectiondep +eitherdep +http-client-tlsdep ~monad-controlPVP ok

version bump matches the API change (PVP)

Dependencies added: connection, either, http-client-tls

Dependency ranges changed: monad-control

API changes (from Hackage documentation)

Files

• consul-haskell.cabal +5/−2
• src/Network/Consul.hs +75/−27
• src/Network/Consul/Internal.hs +42/−27
• src/Network/Consul/Types.hs +54/−21
• tests/Main.hs +81/−52

@@ -1,5 +1,5 @@ name:                consul-haskell-version:             0.2.1+version:             0.3 synopsis:            A consul client for Haskell description:   A consul client for Haskell@@ -34,11 +34,14 @@     base                       >= 4.6 && < 5,     base64-bytestring,     bytestring,+    connection,+    either,     http-client,+    http-client-tls,     http-types,     lifted-async,     lifted-base,-    monad-control,+    monad-control >= 1.0,     network,     text,     transformers,

@@ -10,31 +10,32 @@   , getKey   , getKeys   , getSelf+  , getService+  , getServiceHealth   , getSessionInfo   , getSequencerForLock   , initializeConsulClient+  , initializeTlsConsulClient   , isValidSequencer   , listKeys+  , ManagedSession (..)+  , passHealthCheck   , putKey   , putKeyAcquireLock   , putKeyReleaseLock   , registerService+  , runService   , withManagedSession   , withSequencer   , withSession-  , Consistency(..)-  , ConsulClient(..)-  , Datacenter(..)-  , KeyValue(..)-  , KeyValuePut(..)-  , ManagedSession(..)-  , Session(..)+  , module Network.Consul.Types ) where  import Control.Concurrent hiding (killThread)-import Control.Concurrent.Async.Lifted hiding (cancel)+import Control.Concurrent.Async.Lifted import Control.Concurrent.Lifted (fork, killThread) import Control.Concurrent.STM+import Control.Exception.Lifted import Control.Monad.IO.Class import Control.Monad.Trans.Control import Data.Text (Text)@@ -45,52 +46,99 @@ import qualified Network.Consul.Internal as I import Network.Consul.Types import Network.HTTP.Client (defaultManagerSettings, newManager, Manager)+import Network.HTTP.Client.TLS (tlsManagerSettings) import Network.Socket (PortNumber)   import Prelude hiding (mapM) +parseTtl :: forall t. Integral t => Text -> t+parseTtl ttl = let Right (x,_) = TR.decimal $ T.filter (/= 's') ttl in x+ 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+  return $ ConsulClient manager hostname port False +initializeTlsConsulClient :: MonadIO m => Text -> PortNumber -> Maybe Manager -> m ConsulClient+initializeTlsConsulClient hostname port man = do+    manager <- liftIO $ case man of+                        Just x -> return x+                        Nothing -> newManager tlsManagerSettings+    return $ ConsulClient manager hostname port True  {- Key Value -}- getKey :: MonadIO m => ConsulClient -> Text -> Maybe Word64 -> Maybe Consistency -> Maybe Datacenter -> m (Maybe KeyValue)-getKey _client@ConsulClient{..} = I.getKey ccManager ccHostname ccPort+getKey _client@ConsulClient{..} = I.getKey ccManager (I.hostWithScheme _client) ccPort  getKeys :: MonadIO m => ConsulClient -> Text -> Maybe Word64 -> Maybe Consistency -> Maybe Datacenter -> m [KeyValue]-getKeys _client@ConsulClient{..} = I.getKeys ccManager ccHostname ccPort+getKeys _client@ConsulClient{..} = I.getKeys ccManager (I.hostWithScheme _client) ccPort  listKeys :: MonadIO m => ConsulClient -> Text -> Maybe Word64 -> Maybe Consistency -> Maybe Datacenter -> m [Text]-listKeys _client@ConsulClient{..} = I.listKeys ccManager ccHostname ccPort+listKeys _client@ConsulClient{..} = I.listKeys ccManager (I.hostWithScheme _client) ccPort  putKey :: MonadIO m => ConsulClient -> KeyValuePut -> Maybe Datacenter -> m Bool-putKey _client@ConsulClient{..} = I.putKey ccManager ccHostname ccPort+putKey _client@ConsulClient{..} = I.putKey ccManager (I.hostWithScheme _client) ccPort  putKeyAcquireLock :: MonadIO m => ConsulClient -> KeyValuePut -> Session -> Maybe Datacenter -> m Bool-putKeyAcquireLock _client@ConsulClient{..} = I.putKeyAcquireLock ccManager ccHostname ccPort+putKeyAcquireLock _client@ConsulClient{..} = I.putKeyAcquireLock ccManager (I.hostWithScheme _client) ccPort  putKeyReleaseLock :: MonadIO m => ConsulClient -> KeyValuePut -> Session -> Maybe Datacenter -> m Bool-putKeyReleaseLock _client@ConsulClient{..} = I.putKeyReleaseLock ccManager ccHostname ccPort+putKeyReleaseLock _client@ConsulClient{..} = I.putKeyReleaseLock ccManager (I.hostWithScheme _client) ccPort  deleteKey :: MonadIO m => ConsulClient -> Text -> Bool -> Maybe Datacenter -> m ()-deleteKey _client@ConsulClient{..} key = I.deleteKey ccManager ccHostname ccPort key+deleteKey _client@ConsulClient{..} key = I.deleteKey ccManager (I.hostWithScheme _client) ccPort key +{- Health Checks -}+passHealthCheck :: MonadIO m => ConsulClient -> Text -> Maybe Datacenter -> m ()+passHealthCheck _client@ConsulClient{..} = I.passHealthCheck ccManager (I.hostWithScheme _client) ccPort++getServiceHealth :: MonadIO m => ConsulClient -> Text -> m (Maybe [Health])+getServiceHealth _client@ConsulClient{..} = I.getServiceHealth ccManager (I.hostWithScheme _client) ccPort++{- Catalog -}+getService :: MonadIO m => ConsulClient -> Text -> Maybe Text -> Maybe Datacenter -> m (Maybe [ServiceResult])+getService _client@ConsulClient{..} = I.getService ccManager (I.hostWithScheme _client) ccPort+ {- Agent -} getSelf :: MonadIO m => ConsulClient -> m (Maybe Self)-getSelf _client@ConsulClient{..} = I.getSelf ccManager ccHostname ccPort+getSelf _client@ConsulClient{..} = I.getSelf ccManager (I.hostWithScheme _client) ccPort  registerService :: MonadIO m => ConsulClient -> RegisterService -> Maybe Datacenter -> m Bool-registerService _client@ConsulClient{..} = I.registerService ccManager ccHostname ccPort+registerService _client@ConsulClient{..} = I.registerService ccManager (I.hostWithScheme _client) ccPort +runService :: (MonadBaseControl IO m, MonadIO m) => ConsulClient -> RegisterService -> m () -> Maybe Datacenter -> m ()+runService client request action dc = do+  r <- registerService client request dc+  case r of+    True -> do+      mainFunc <- async action+      checkAction <- case rsCheck request of+                      Just(x@(Ttl _)) -> do+                        a <- async $ ttlFunc x+                        return $ Just a+                      _ -> return Nothing+      _foo :: () <- wait mainFunc+      case checkAction of+        Just a -> cancel a+        Nothing -> return ()+    False -> return ()+  where+    ttlFunc y@(Ttl x) = do+      (do+        let ttl = parseTtl x+        liftIO $ threadDelay $ (ttl - (fromIntegral $ floor (fromIntegral ttl / fromIntegral 2))) * 1000000+        let checkId = T.concat["service:",maybe (rsName request) id (rsId request)]+        passHealthCheck client checkId dc) `catch` (\ e -> do+           let _x :: SomeException = e+           return ())+      ttlFunc y+ {- Session -} getSessionInfo :: MonadIO m => ConsulClient -> Text -> Maybe Datacenter -> m (Maybe [SessionInfo])-getSessionInfo _client@ConsulClient{..} = I.getSessionInfo ccManager ccHostname ccPort+getSessionInfo _client@ConsulClient{..} = I.getSessionInfo ccManager (I.hostWithScheme _client) ccPort  withSession :: forall a m. (MonadIO m,MonadBaseControl IO m) => ConsulClient -> Session -> (Session -> m a) -> m a -> m a withSession client session action lostAction = do@@ -108,12 +156,12 @@       liftIO $ threadDelay (10 * 1000000)       x <- getSessionInfo client (sId session) Nothing       case x of-        Just [] -> cancel var threadVar-        Nothing -> cancel var threadVar+        Just [] -> cancelAction var threadVar+        Nothing -> cancelAction var threadVar         Just _ -> runThread var threadVar -    cancel :: TMVar a -> TMVar ThreadId -> m ()-    cancel resultVar tidVar = do+    cancelAction :: TMVar a -> TMVar ThreadId -> m ()+    cancelAction resultVar tidVar = do       tid <- liftIO $ atomically $ readTMVar tidVar       killThread tid       empty <- liftIO $ atomically $ isEmptyTMVar resultVar@@ -169,7 +217,7 @@ createManagedSession :: MonadIO m => ConsulClient -> Maybe Text -> Text -> 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+  s <- I.createSession ccManager (I.hostWithScheme _client) ccPort r Nothing   mapM f s   where     f x = do@@ -181,7 +229,7 @@     runThread :: Session -> IO ()     runThread s = do       threadDelay $ (saneTtl - (saneTtl - 10)) * 1000000-      x <- I.renewSession ccManager ccHostname ccPort s Nothing+      x <- I.renewSession ccManager (I.hostWithScheme _client) ccPort s Nothing       case x of         True -> runThread s         False -> return ()@@ -189,4 +237,4 @@ destroyManagedSession :: MonadIO m => ConsulClient -> ManagedSession -> m () destroyManagedSession _client@ConsulClient{..} (ManagedSession session tid) = do   liftIO $ killThread tid-  I.destroySession ccManager ccHostname ccPort session Nothing+  I.destroySession ccManager (I.hostWithScheme _client) ccPort session Nothing

@@ -1,8 +1,12 @@+{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE OverloadedStrings #-}  module Network.Consul.Internal (+  --Client+    hostWithScheme+   --Key-Value Store-    deleteKey+  , deleteKey   , getKey   , getKeys   , listKeys@@ -32,12 +36,14 @@    --Catalog   , getDatacenters+  , getService   ) 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.Base64 as B64 import qualified Data.ByteString.Lazy as BL import Data.Maybe import Data.Text (Text)@@ -49,9 +55,13 @@ import Network.HTTP.Types import Network.Socket (PortNumber(..)) +hostWithScheme :: ConsulClient -> Text+hostWithScheme ConsulClient{..} = scheme `T.append` ccHostname+  where scheme = if ccWithTls then "https://" else "http://"+ 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+createRequest hostWithScheme portNumber endpoint query body wait dc = do+  let baseUrl = T.concat [hostWithScheme,":",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@@ -63,7 +73,7 @@     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 :: MonadIO m => Manager -> Text -> PortNumber -> Text -> Maybe Word64 -> Maybe Consistency -> Maybe Datacenter -> m (Maybe Network.Consul.Types.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@@ -177,38 +187,37 @@  -}  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"]+registerHealthCheck manager hostname portNumber request = do+  initReq <- liftIO $ parseUrl $ T.unpack $ T.concat [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]+deregisterHealthCheck manager hostname portNumber checkId = do+  initReq <- liftIO $ parseUrl $ T.unpack $ T.concat [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]+passHealthCheck :: MonadIO m => Manager -> Text -> PortNumber -> Text -> Maybe Datacenter -> m ()+passHealthCheck manager hostname portNumber checkId dc = do+  initReq <- createRequest hostname portNumber (T.concat ["/v1/agent/check/pass/", checkId]) Nothing Nothing False dc   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]+warnHealthCheck manager hostname portNumber checkId = do+  initReq <- liftIO $ parseUrl $ T.unpack $ T.concat [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]+failHealthCheck manager hostname portNumber checkId = do+  initReq <- liftIO $ parseUrl $ T.unpack $ T.concat [hostname, ":", T.pack $ show portNumber ,"/v1/agent/check/fail/", checkId]   liftIO $ withResponse initReq manager $ \ response -> do     _bodyParts <- brConsume $ responseBody response     return ()@@ -222,15 +231,15 @@       _ -> return False  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]+deregisterService manager hostname portNumber service = do+  initReq <- liftIO $ parseUrl $ T.unpack $ T.concat [hostname, ":", T.pack $ show portNumber ,"/v1/agent/service/deregister/", service]   liftIO $ withResponse initReq manager $ \ response -> do     _bodyParts <- brConsume $ responseBody response     return ()  getSelf :: MonadIO m => Manager -> Text -> PortNumber -> m (Maybe Self)-getSelf manager hostname (PortNum portNumber) = do-  initReq <- liftIO $ parseUrl $ T.unpack $ T.concat ["http://",hostname, ":", T.pack $ show portNumber ,"/v1/agent/self"]+getSelf manager hostname portNumber = do+  initReq <- liftIO $ parseUrl $ T.unpack $ T.concat [hostname, ":", T.pack $ show portNumber ,"/v1/agent/self"]   liftIO $ withResponse initReq manager $ \ response -> do     bodyParts <- brConsume $ responseBody response     let body = B.concat bodyParts@@ -239,16 +248,16 @@  {- 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]+getServiceChecks manager hostname portNumber name = do+  initReq <- liftIO $ parseUrl $ T.unpack $ T.concat [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]+getServiceHealth :: MonadIO m => Manager -> Text -> PortNumber -> Text -> m (Maybe [Health])+getServiceHealth manager hostname portNumber name = do+  initReq <- liftIO $ parseUrl $ T.unpack $ T.concat [hostname, ":", T.pack $ show portNumber ,"/v1/health/service/", name]   liftIO $ withResponse initReq manager $ \ response -> do     bodyParts <- brConsume $ responseBody response     let body = B.concat bodyParts@@ -292,8 +301,8 @@  {- 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/"]+getDatacenters manager hostname portNumber = liftIO $ do+  initReq <- parseUrl $ T.unpack $ T.concat [hostname, ":", T.pack $ show portNumber ,"/v1/catalog/datacenters/"]   withResponse initReq manager $ \ response -> do     bodyParts <- brConsume $ responseBody response     let body = B.concat bodyParts@@ -302,3 +311,9 @@       Just x -> return x       Nothing -> return [] +getService :: MonadIO m => Manager -> Text -> PortNumber -> Text -> Maybe Text -> Maybe Datacenter -> m (Maybe [ServiceResult])+getService manager hostname portNumber name tag dc = do+  req <- createRequest hostname portNumber (T.concat["/v1/catalog/service/",name]) (fmap (\ x -> T.concat ["tag=",x]) tag) Nothing False dc+  liftIO $ withResponse req manager $ \ response -> do+    bodyParts <- brConsume $ responseBody response+    return $ decode $ BL.fromStrict $ B.concat bodyParts

@@ -10,7 +10,8 @@   Datacenter (..),   Health(..),   HealthCheck(..),-  KeyValue(..),+  HealthCheckStatus(..),+  Network.Consul.Types.KeyValue(..),   KeyValuePut(..),   Member(..),   Node(..),@@ -19,6 +20,7 @@   RegisterService(..),   Self(..),   Service(..),+  ServiceResult(..),   Session(..),   SessionBehavior(..),   SessionInfo(..),@@ -31,6 +33,7 @@ #endif import Control.Monad import Data.Aeson+import Data.Aeson.Types import Data.ByteString (ByteString) import qualified Data.ByteString.Base64 as B64 import Data.Foldable@@ -38,14 +41,14 @@ 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+  ccPort :: PortNumber,+  ccWithTls :: Bool }  data Datacenter = Datacenter Text deriving (Eq,Show,Ord)@@ -62,7 +65,7 @@   kvCreateIndex :: Word64,   kvLockIndex :: Word64,   kvModifyIndex :: Word64,-  kvValue :: ByteString,+  kvValue :: Maybe ByteString,   kvFlags :: Word64,   kvSession :: Maybe Text,   kvKey :: Text@@ -120,9 +123,20 @@   seId :: Text,   seService :: Text,   seTags :: [Text],+  seAddress :: Maybe Text,   sePort :: Maybe Int-}+} deriving (Show) +data ServiceResult = ServiceResult{+  srrNode :: Text,+  srrAddress :: Text,+  srrServiceId :: Text,+  srrServiceName :: Text,+  srrServiceTags :: [Text],+  srrServiceAddress :: Maybe Text,+  srrServicePort :: Maybe Int+} deriving (Show)+ data Check = Check {   cNode :: Text,   cCheckId :: Text,@@ -131,13 +145,13 @@   cServiceId :: Maybe Text,   cStatus :: HealthCheckStatus,   cOutput :: Text,-  cServiceName :: Text-}+  cServiceName :: Maybe Text+} deriving (Show)  data Node = Node {   nNode :: Text,   nAddress :: Text-}+} deriving (Show)  {- Agent -} data RegisterHealthCheck = RegisterHealthCheck {@@ -188,7 +202,7 @@   hNode :: Node,   hService :: Service,   hChecks :: [Check]-}+} deriving (Show)   {- JSON Instances -}@@ -205,14 +219,22 @@   parseJSON _ = mzero  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 (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"+instance FromJSON Network.Consul.Types.KeyValue where+  parseJSON (Object v) =+    Network.Consul.Types.KeyValue+      <$> v .: "CreateIndex"+      <*> v .: "LockIndex"+      <*> v .: "ModifyIndex"+      <*> (foo =<< (v .:? "Value"))+      <*> v .: "Flags"+      <*> v .:? "Session"+      <*> v .: "Key"   parseJSON _ = mzero  instance FromJSON Datacenter where@@ -220,11 +242,11 @@   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 (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 (Object x) = Service <$> x .: "ID" <*> x .: "Service" <*> x .: "Tags" <*> x .:? "Address" <*> x .:? "Port"   parseJSON _ = mzero  instance FromJSON Node where@@ -260,7 +282,7 @@   toJSON (RegisterHealthCheck i name notes script interval ttl) = object ["id" .= i, "name" .= name, "notes" .= notes, "script" .= script, "interval" .= interval, "ttl" .= ttl]  instance ToJSON RegisterService where-  toJSON (RegisterService i name tags port check) = object ["ID" .= i, "Name" .= name, "Tags" .= tags, "Port" .= port, "Check" .= check]+  toJSON (RegisterService i name tags port check) = object ["ID" .= i, "Name" .= name, "tags" .= tags, "port" .= port, "Check" .= check]  instance ToJSON HealthCheck where   toJSON (Ttl x) = object ["TTL" .= x]@@ -274,6 +296,17 @@   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+instance ToJSON ServiceResult where+  toJSON (ServiceResult node addr sid sName sTags sAddress sPort) = object["Node" .= node, "Address" .= addr, "ServiceID" .= sid, "ServiceName" .= sName, "ServiceTags" .= sTags, "ServiceAddress" .= sAddress, "ServicePort" .= sPort]++instance FromJSON ServiceResult where+  parseJSON (Object x) = ServiceResult <$> x .: "Node" <*> x .: "Address" <*> x .: "ServiceID" <*> x .: "ServiceName" <*> x .: "ServiceTags" <*> x .:? "ServiceAddress" <*> x .:? "ServicePort"+  parseJSON _ = mzero++foo :: Maybe Value -> Parser (Maybe ByteString)+foo (Just (String x)) =+  case B64.decode $ TE.encodeUtf8 x of+    Left y -> fail y+    Right y -> return $ Just y+foo (Just _) = return Nothing+foo Nothing = return Nothing

@@ -1,3 +1,4 @@+{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE OverloadedStrings #-} import Control.Concurrent import Control.Monad.IO.Class@@ -11,115 +12,144 @@ import Test.Tasty import Test.Tasty.HUnit -manager :: IO Manager-manager = newManager defaultManagerSettings+client :: IO ConsulClient+client = initializeConsulClient "localhost" 8500 Nothing  {- Internal Tests -} internalKVTests :: TestTree-internalKVTests = testGroup "Internal Key Value" [testGetInvalidKey, testPutKey, -  testGetKey,testGetKeys,testListKeys,testDeleteKey]+internalKVTests = testGroup "Internal Key Value" [testGetInvalidKey, testPutKey,+  testGetKey,testGetKeys,testListKeys,testDeleteKey,testGetNullValueKey]  testGetInvalidKey :: TestTree testGetInvalidKey = testCase "testGetInvalidKey" $ do-  man <- manager-  x <- I.getKey man "localhost" (PortNum 8500) "nokey" Nothing Nothing Nothing+  _client@ConsulClient{..} <- client+  x <- I.getKey ccManager (I.hostWithScheme _client) ccPort "nokey" Nothing Nothing Nothing   assertEqual "testGetInvalidKey: Found a key that doesn't exist" x Nothing  testPutKey :: TestTree testPutKey = testCase "testPutKey" $ do-  man <- manager+  _client@ConsulClient{..} <- client   let put = KeyValuePut "/testPutKey" "Test" Nothing Nothing-  x <- I.putKey man "localhost" (PortNum 8500) put Nothing+  x <- I.putKey ccManager (I.hostWithScheme _client) ccPort put Nothing   assertEqual "testPutKey: Write failed" True x  testGetKey :: TestTree testGetKey = testCase "testGetKey" $ do-  man <- manager+  _client@ConsulClient{..} <- client   let put = KeyValuePut "/testGetKey" "Test" Nothing Nothing-  x1 <- I.putKey man "localhost" (PortNum 8500) put Nothing+  x1 <- I.putKey ccManager (I.hostWithScheme _client) ccPort put Nothing   assertEqual "testGetKey: Write failed" True x1-  x2 <- I.getKey man "localhost" (PortNum 8500) "/testGetKey" Nothing Nothing Nothing+  x2 <- I.getKey ccManager (I.hostWithScheme _client) ccPort "/testGetKey" Nothing Nothing Nothing   case x2 of-    Just x -> assertEqual "testGetKey: Incorrect Value" (kvValue x) "Test"+    Just x -> assertEqual "testGetKey: Incorrect Value" (kvValue x) (Just "Test")     Nothing -> assertFailure "testGetKey: No value returned" +testGetNullValueKey :: TestTree+testGetNullValueKey = testCase "testGetNullValueKey" $ do+  _client@ConsulClient{..} <- client+  let put = KeyValuePut "/testGetNullValueKey" "" Nothing Nothing+  x1 <- I.putKey ccManager (I.hostWithScheme _client) ccPort put Nothing+  assertEqual "testGetNullValueKey: Write failed" True x1+  liftIO $ threadDelay (500 * 1000)+  x2 <- I.getKey ccManager (I.hostWithScheme _client) ccPort "/testGetNullValueKey" Nothing Nothing Nothing+  case x2 of+    Just x -> assertEqual "testGetNullValueKey: Incorrect Value" (kvValue x) Nothing+    Nothing -> assertFailure "testGetNullValueKey: No value returned"++ testGetKeys :: TestTree testGetKeys = testCase "testGetKeys" $ do-  man <- manager+  _client@ConsulClient{..} <- client   let put1 = KeyValuePut "/testGetKeys/key1" "Test" Nothing Nothing-  x1 <- I.putKey man "localhost" (PortNum 8500) put1 Nothing+  x1 <- I.putKey ccManager (I.hostWithScheme _client) ccPort 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+  x2 <- I.putKey ccManager (I.hostWithScheme _client) ccPort put2 Nothing   assertEqual "testGetKeys: Write failed" True x2-  x3 <- I.getKeys man "localhost" (PortNum 8500) "/testGetKeys" Nothing Nothing Nothing+  x3 <- I.getKeys ccManager (I.hostWithScheme _client) ccPort "/testGetKeys" Nothing Nothing Nothing   assertEqual "testGetKeys: Incorrect number of results" 2 (length x3)  testListKeys :: TestTree testListKeys = testCase "testListKeys" $ do-  man  <- manager+  _client@ConsulClient{..} <- client   let put1 = KeyValuePut "/testListKeys/key1" "Test" Nothing Nothing-  x1 <- I.putKey man "localhost" (PortNum 8500) put1 Nothing+  x1 <- I.putKey ccManager (I.hostWithScheme _client) ccPort 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+  x2 <- I.putKey ccManager (I.hostWithScheme _client) ccPort put2 Nothing   assertEqual "testListKeys: Write failed" True x2-  x3 <- I.listKeys man "localhost" (PortNum 8500) "/testListKeys/" Nothing Nothing Nothing+  x3 <- I.listKeys ccManager (I.hostWithScheme _client) ccPort "/testListKeys/" Nothing Nothing Nothing   assertEqual "testListKeys: Incorrect number of results" 2 (length x3)  testDeleteKey :: TestTree testDeleteKey = testCase "testDeleteKey" $ do-  man  <- manager+  _client@ConsulClient{..} <- client   let put1 = KeyValuePut "/testDeleteKey" "Test" Nothing Nothing-  x1 <- I.putKey man "localhost" (PortNum 8500) put1 Nothing+  x1 <- I.putKey ccManager (I.hostWithScheme _client) ccPort 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+  I.deleteKey ccManager (I.hostWithScheme _client) ccPort "/testDeleteKey" False Nothing+  x2 <- I.getKey ccManager (I.hostWithScheme _client) ccPort "/testDeleteKey" Nothing Nothing Nothing   assertEqual "testDeleteKey: Key was not deleted" Nothing x2  {- Agent -} testRegisterService :: TestTree testRegisterService = testCase "testRegisterService" $ do-  man <- manager+  _client@ConsulClient{..} <- client   let req = RegisterService Nothing "testService" ["test"] Nothing (Just $ Ttl "10s")-  val <- I.registerService man "localhost" (PortNum 8500) req Nothing+  val <- I.registerService ccManager (I.hostWithScheme _client) ccPort req Nothing   assertEqual "testRegisterService: Service was not created" val True  testGetSelf :: TestTree testGetSelf = testCase "testGetSelf" $ do-  man <- manager-  x <- I.getSelf man "localhost" (PortNum 8500)+  _client@ConsulClient{..} <- client+  x <- I.getSelf ccManager (I.hostWithScheme _client) ccPort   assertEqual "testGetSelf: Self not returned" True (isJust x)  {- testRegisterHealthCheck :: TestTree testRegisterHealthCheck = testCase "testRegisterHealthCheck" $ do-  man <- manager+  _client@ConsulClient{..} <- client   let check = RegisterHealthCheck "testHealthCheck" "testHealthCheck" "" Nothing Nothing (Just "15s")-  x1 <- I.registerHealthCheck man "localhost" (PortNum 8500) check+  x1 <- I.registerHealthCheck ccManager (I.hostWithScheme _client) ccPort check   undefined -}  {- Health Checks -}---testServiceChecks :: +testGetServiceHealth :: TestTree+testGetServiceHealth = testCase "testGetServiceHealth" $ do+  _client@ConsulClient{..} <- client+  let req = RegisterService (Just "testGetServiceHealth") "testGetServiceHealth" [] Nothing Nothing+  r1 <- I.registerService ccManager (I.hostWithScheme _client) ccPort req Nothing+  case r1 of+    True -> do+      liftIO $ threadDelay 1000000+      r2 <- I.getServiceHealth ccManager (I.hostWithScheme _client) ccPort "testGetServiceHealth"+      case r2 of+        Just [x] -> return ()+        Just [] -> assertFailure "testGetServiceHealth: No Services Returned"+        Nothing -> assertFailure "testGetServiceHealth: Failed to parse result"+    False -> assertFailure "testGetServiceHealth: Service was not created" +testHealth :: TestTree+testHealth = testGroup "Health Check Tests" [testGetServiceHealth]+ {- Session -} testCreateSession :: TestTree testCreateSession = testCase "testCreateSession" $ do-  man <- manager+  _client@ConsulClient{..} <- client   let req = SessionRequest Nothing (Just "testCreateSession") Nothing ["serfHealth"] (Just Release) (Just "30s")-  result <- I.createSession man "localhost" (PortNum 8500) req Nothing+  result <- I.createSession ccManager (I.hostWithScheme _client) ccPort req Nothing   case result of     Just _ -> return ()     Nothing -> assertFailure "testCreateSession: No session was created"  testGetSessionInfo :: TestTree testGetSessionInfo = testCase "testGetSessionInfo" $ do-  man <- manager+  _client@ConsulClient{..} <- client   let req = SessionRequest Nothing (Just "testGetSessionInfo") Nothing ["serfHealth"] (Just Release) (Just "30s")-  result <- I.createSession man "localhost" (PortNum 8500) req Nothing+  result <- I.createSession ccManager (I.hostWithScheme _client) ccPort req Nothing   case result of     Just x -> do-      x1 <- I.getSessionInfo man "localhost" (PortNum 8500) (sId x) Nothing+      x1 <- I.getSessionInfo ccManager (I.hostWithScheme _client) ccPort (sId x) Nothing       case x1 of         Just _ -> return ()         Nothing -> assertFailure "testGetSessionInfo: Session Info was not returned"@@ -127,12 +157,12 @@  testRenewSession :: TestTree testRenewSession = testCase "testRenewSession" $ do-  man <- manager+  _client@ConsulClient{..} <- client   let req = SessionRequest Nothing (Just "testRenewSession") Nothing ["serfHealth"] (Just Release) (Just "30s")-  result <- I.createSession man "localhost" (PortNum 8500) req Nothing+  result <- I.createSession ccManager (I.hostWithScheme _client) ccPort req Nothing   case result of     Just x -> do-      x1 <- I.renewSession man "localhost" (PortNum 8500) x Nothing+      x1 <- I.renewSession ccManager (I.hostWithScheme _client) ccPort x Nothing       case x1 of         True -> return ()         False -> assertFailure "testRenewSession: Session was not renewed"@@ -140,13 +170,13 @@  testDestroySession :: TestTree testDestroySession = testCase "testDestroySession" $ do-  man <- manager+  _client@ConsulClient{..} <- client   let req = SessionRequest Nothing (Just "testDestroySession") Nothing ["serfHealth"] (Just Release) (Just "30s")-  result <- I.createSession man "localhost" (PortNum 8500) req Nothing+  result <- I.createSession ccManager (I.hostWithScheme _client) ccPort req Nothing   case result of     Just x -> do-      _ <- I.destroySession man "localhost" (PortNum 8500) x Nothing-      x1 <- I.getSessionInfo man "localhost" (PortNum 8500) (sId x) Nothing+      _ <- I.destroySession ccManager (I.hostWithScheme _client) ccPort x Nothing+      x1 <- I.getSessionInfo ccManager (I.hostWithScheme _client) ccPort (sId x) Nothing       assertEqual "testDestroySession: Session info was returned after destruction" Nothing x1     Nothing -> assertFailure "testDestroySession: No session was created" @@ -156,13 +186,13 @@ {- Managed Session -} testCreateManagedSession :: TestTree testCreateManagedSession = testCase "testCreateManagedSession" $ do-  client <- initializeConsulClient "localhost" (PortNum 8500) Nothing+  client <- initializeConsulClient "localhost" 8500 Nothing   x <- createManagedSession client (Just "testCreateManagedSession") "60s"   assertEqual "testCreateManagedSession: Session not created" True (isJust x)  testSessionMaintained :: TestTree testSessionMaintained = testCase "testSessionMaintained" $ do-  client <- initializeConsulClient "localhost" (PortNum 8500) Nothing+  client <- initializeConsulClient "localhost" 8500 Nothing   x <- createManagedSession client (Just "testCreateManagedSession") "10s"   assertEqual "testSessionMaintained: Session not created" True (isJust x)   let (Just foo) = x@@ -172,18 +202,17 @@  testWithSessionCancel :: TestTree testWithSessionCancel = testCase "testWithSessionCancel" $ do-  man <- manager-  client <- initializeConsulClient "localhost" (PortNum 8500) Nothing+  client@ConsulClient{..} <- initializeConsulClient "localhost" 8500 Nothing   let req = SessionRequest Nothing (Just "testWithSessionCancel") Nothing ["serfHealth"] (Just Release) (Just "10s")-  result <- I.createSession man "localhost" (PortNum 8500) req Nothing+  result <- I.createSession ccManager (I.hostWithScheme client) ccPort req Nothing   case result of     Just x -> do-      x1 <- withSession client x (\ y -> action y man ) cancelAction+      x1 <- withSession client x (\ y -> action y client ) cancelAction       assertEqual "testWithSessionCancel: Incorrect value" "Canceled" x1     Nothing -> assertFailure "testWithSessionCancel: No session was created"   where-    action x man = do-      I.destroySession man "localhost" (PortNum 8500) x Nothing+    action x client@ConsulClient{..} = do+      I.destroySession ccManager (I.hostWithScheme client) ccPort x Nothing       threadDelay (30 * 1000000)       return ("NotCanceled" :: Text)     cancelAction = return ("Canceled" :: Text)@@ -196,7 +225,7 @@ agentTests = testGroup "Agent Tests" [testGetSelf,testRegisterService]  allTests :: TestTree-allTests = testGroup "All Tests" [testInternalSession, internalKVTests, managedSessionTests, agentTests]+allTests = testGroup "All Tests" [testInternalSession, internalKVTests, managedSessionTests, agentTests,testHealth]  main :: IO () main = defaultMain allTests