consul-haskell 0.4 → 0.4.2

raw patch · 4 files changed

+35/−12 lines, 4 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• consul-haskell.cabal +1/−1
• src/Network/Consul.hs +7/−4
• src/Network/Consul/Types.hs +0/−4
• tests/Main.hs +27/−3

@@ -1,5 +1,5 @@ name:                consul-haskell-version:             0.4+version:             0.4.2 synopsis:            A consul client for Haskell description:   A consul client for Haskell

@@ -35,6 +35,7 @@ import Control.Concurrent.Async.Lifted import Control.Concurrent.STM import Control.Exception.Lifted+import Control.Monad (forever) import Control.Monad.IO.Class import Control.Monad.Catch (MonadMask) import Control.Monad.Trans.Control@@ -112,7 +113,7 @@ getSelf _client@ConsulClient{..} = I.getSelf ccManager (I.hostWithScheme _client) ccPort  deregisterService :: MonadIO m => ConsulClient -> Text -> m ()-deregisterService _client@ConsulClient{..} = I.deregisterService ccManager (I.hostWithScheme _client) ccPort +deregisterService _client@ConsulClient{..} = I.deregisterService ccManager (I.hostWithScheme _client) ccPort  registerService :: MonadIO m => ConsulClient -> RegisterService -> Maybe Datacenter -> m Bool registerService _client@ConsulClient{..} = I.registerService ccManager (I.hostWithScheme _client) ccPort@@ -123,11 +124,14 @@   case r of     True -> do       mainFunc <- async action++      --this is here instead of the where to prevent typechecking nastiness       checkAction <- case rsCheck request of                       Just(x@(Ttl _)) -> do-                        a <- async $ ttlFunc x+                        a <- async $ forever $ ttlFunc x                         return $ Just a                       _ -> return Nothing+       _foo :: () <- wait mainFunc --prevent: 'StM’ is a type function, and may not be injective       case checkAction of         Just a -> cancel a@@ -182,7 +186,7 @@   case mkv of     Just kv -> return $ (maybe False ((sId $ sSession sequencer) ==) $ kvSession kv) && (kvLockIndex kv) == (sLockIndex sequencer)     Nothing -> return False-{- + withSequencer :: (MonadBaseControl IO m, MonadIO m, MonadMask m) => ConsulClient -> Sequencer -> m a -> m a -> Int -> Maybe Datacenter -> m a withSequencer client sequencer action lostAction delay dc =   withAsync action $ \ mainAsync -> withAsync pulseLock $ \ pulseAsync -> do@@ -194,4 +198,3 @@       case valid of         True -> pulseLock         False -> lostAction--}

@@ -292,10 +292,6 @@ 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]- 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] 

@@ -7,7 +7,7 @@ import Data.Maybe import Data.Text (Text) import Data.UUID-import Network.Consul (deleteKey,getKey,getSessionInfo,initializeConsulClient,putKey,withSession,ConsulClient(..))+import Network.Consul (deleteKey,getKey,getSessionInfo,initializeConsulClient,putKey,withSession,ConsulClient(..),runService,getServiceHealth) import Network.Consul.Types import qualified Network.Consul.Internal as I import Network.HTTP.Client@@ -94,7 +94,6 @@   assertEqual "testDeleteKey: Delete Failed" True x2   x3 <- I.getKey ccManager (I.hostWithScheme _client) ccPort "/testDeleteKey" Nothing Nothing Nothing   assertEqual "testDeleteKey: Key was not deleted" Nothing x3-  print x3  testDeleteRecursive :: TestTree testDeleteRecursive = testCase "testDeleteRecursive" $ do@@ -133,6 +132,10 @@   let req = RegisterService Nothing "testService" ["test"] Nothing (Just $ Ttl "10s")   val <- I.registerService ccManager (I.hostWithScheme _client) ccPort req Nothing   assertEqual "testRegisterService: Service was not created" val True+  mService <- I.getService ccManager (I.hostWithScheme _client) ccPort "testService" Nothing Nothing+  case mService of+    Just _ -> return ()+    Nothing -> assertFailure "testRegisterService: Service was not found"  testGetSelf :: TestTree testGetSelf = testCase "testGetSelf" $ do@@ -266,14 +269,35 @@     cancelAction = return ("Canceled" :: Text)  +testRunServiceTtl :: TestTree+testRunServiceTtl = testCase "testRunServiceTtl" $ do+  client@ConsulClient{..} <- initializeConsulClient "localhost" 8500 Nothing+  let register = RegisterService Nothing "testRunServiceTtl" [] (Just 8000) $ Just $ Ttl "10s"+  runService client register (action client) Nothing+  where+    action client = do+      threadDelay 15000000+      mHealth <- getServiceHealth client "testRunServiceTtl"+      case mHealth of+        Nothing -> assertFailure "testRunServiceTtl: No healthcheck was found"+        Just [x] -> do+          let checks = hChecks x+          mapM_ (testCheck) checks+    testCheck check = do+      assertBool "testRunServiceTtl: Check not passing" $ cStatus check == Passing++ sessionWorkflowTests :: TestTree sessionWorkflowTests = testGroup "Session Workflow Tests" [testWithSessionCancel,testSessionMaintained] +runServiceTests :: TestTree+runServiceTests = testGroup "Run Service Tests" [testRunServiceTtl]+ agentTests :: TestTree agentTests = testGroup "Agent Tests" [testGetSelf,testRegisterService]  allTests :: TestTree-allTests = testGroup "All Tests" [testInternalSession, internalKVTests, sessionWorkflowTests, agentTests,testHealth, clientKVTests]+allTests = testGroup "All Tests" [testInternalSession, internalKVTests, sessionWorkflowTests, agentTests,testHealth, clientKVTests, runServiceTests]  main :: IO () main = defaultMain allTests