Hello community,
here is the log from the commit of package ghc-consul-haskell for
openSUSE:Factory checked in at 2017-03-03 17:49:02
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Comparing /work/SRC/openSUSE:Factory/ghc-consul-haskell (Old)
and /work/SRC/openSUSE:Factory/.ghc-consul-haskell.new (New)
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Package is "ghc-consul-haskell"
Fri Mar 3 17:49:02 2017 rev:2 rq:461619 version:0.4.2
Changes:
--------
--- /work/SRC/openSUSE:Factory/ghc-consul-haskell/ghc-consul-haskell.changes
2016-09-25 14:39:32.000000000 +0200
+++
/work/SRC/openSUSE:Factory/.ghc-consul-haskell.new/ghc-consul-haskell.changes
2017-03-03 17:49:03.246821089 +0100
@@ -1,0 +2,5 @@
+Sun Feb 12 14:14:58 UTC 2017 - [email protected]
+
+- Update to version 0.4.2 with cabal2obs.
+
+-------------------------------------------------------------------
Old:
----
consul-haskell-0.3.tar.gz
New:
----
consul-haskell-0.4.2.tar.gz
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Other differences:
------------------
++++++ ghc-consul-haskell.spec ++++++
--- /var/tmp/diff_new_pack.AU5pWj/_old 2017-03-03 17:49:03.886730715 +0100
+++ /var/tmp/diff_new_pack.AU5pWj/_new 2017-03-03 17:49:03.894729584 +0100
@@ -1,7 +1,7 @@
#
# spec file for package ghc-consul-haskell
#
-# Copyright (c) 2016 SUSE LINUX GmbH, Nuernberg, Germany.
+# Copyright (c) 2017 SUSE LINUX GmbH, Nuernberg, Germany.
#
# All modifications and additions to the file contributed by third parties
# remain the property of their copyright owners, unless otherwise agreed
@@ -19,20 +19,20 @@
%global pkg_name consul-haskell
%bcond_with tests
Name: ghc-%{pkg_name}
-Version: 0.3
+Version: 0.4.2
Release: 0
Summary: A consul client for Haskell
License: BSD-3-Clause
-Group: System/Libraries
+Group: Development/Languages/Other
Url: https://hackage.haskell.org/package/%{pkg_name}
Source0:
https://hackage.haskell.org/package/%{pkg_name}-%{version}/%{pkg_name}-%{version}.tar.gz
BuildRequires: ghc-Cabal-devel
-# Begin cabal-rpm deps:
BuildRequires: ghc-aeson-devel
BuildRequires: ghc-base64-bytestring-devel
BuildRequires: ghc-bytestring-devel
BuildRequires: ghc-connection-devel
BuildRequires: ghc-either-devel
+BuildRequires: ghc-exceptions-devel
BuildRequires: ghc-http-client-devel
BuildRequires: ghc-http-client-tls-devel
BuildRequires: ghc-http-types-devel
@@ -40,17 +40,21 @@
BuildRequires: ghc-lifted-base-devel
BuildRequires: ghc-monad-control-devel
BuildRequires: ghc-network-devel
+BuildRequires: ghc-retry-devel
BuildRequires: ghc-rpm-macros
BuildRequires: ghc-stm-devel
BuildRequires: ghc-text-devel
BuildRequires: ghc-transformers-devel
+BuildRequires: ghc-unordered-containers-devel
+BuildRequires: ghc-vector-devel
BuildRoot: %{_tmppath}/%{name}-%{version}-build
%if %{with tests}
BuildRequires: ghc-HUnit-devel
+BuildRequires: ghc-random-devel
BuildRequires: ghc-tasty-devel
BuildRequires: ghc-tasty-hunit-devel
+BuildRequires: ghc-uuid-devel
%endif
-# End cabal-rpm deps
%description
A consul client for Haskell
@@ -71,20 +75,14 @@
%prep
%setup -q -n %{pkg_name}-%{version}
-
%build
%ghc_lib_build
-
%install
%ghc_lib_install
-
%check
-%if %{with tests}
-%{cabal} test
-%endif
-
+%cabal_test
%post devel
%ghc_pkg_recache
++++++ consul-haskell-0.3.tar.gz -> consul-haskell-0.4.2.tar.gz ++++++
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/consul-haskell-0.3/consul-haskell.cabal
new/consul-haskell-0.4.2/consul-haskell.cabal
--- old/consul-haskell-0.3/consul-haskell.cabal 2015-09-30 18:33:32.000000000
+0200
+++ new/consul-haskell-0.4.2/consul-haskell.cabal 2017-01-25
17:42:27.000000000 +0100
@@ -1,5 +1,5 @@
name: consul-haskell
-version: 0.3
+version: 0.4.2
synopsis: A consul client for Haskell
description:
A consul client for Haskell
@@ -36,6 +36,7 @@
bytestring,
connection,
either,
+ exceptions,
http-client,
http-client-tls,
http-types,
@@ -43,9 +44,12 @@
lifted-base,
monad-control >= 1.0,
network,
+ retry,
+ stm,
text,
transformers,
- stm
+ unordered-containers,
+ vector
ghc-options:
-Wall
@@ -63,10 +67,12 @@
consul-haskell,
http-client,
network,
+ random,
tasty,
tasty-hunit,
text,
transformers,
+ uuid,
HUnit >= 1.2
ghc-options:
-Wall
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/consul-haskell-0.3/src/Network/Consul/Internal.hs
new/consul-haskell-0.4.2/src/Network/Consul/Internal.hs
--- old/consul-haskell-0.3/src/Network/Consul/Internal.hs 2015-10-13
06:56:36.000000000 +0200
+++ new/consul-haskell-0.4.2/src/Network/Consul/Internal.hs 2016-09-26
00:23:08.000000000 +0200
@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE OverloadedStrings #-}
@@ -37,15 +38,18 @@
--Catalog
, getDatacenters
, getService
+ , getServices
) where
import Control.Monad.IO.Class
-import Data.Aeson (decode,encode)
+import Data.Aeson (Value(..), 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 qualified Data.HashMap.Strict as H
import Data.Maybe
+import qualified Data.Vector as V
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
@@ -64,13 +68,23 @@
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
+#if MIN_VERSION_http_client(0,5,0)
+ case body of
+ Just x -> return $ indef $ initReq{ method = "PUT", requestBody =
RequestBodyBS x, checkResponse = \ _ _ -> return ()}
+ Nothing -> return $ indef $ initReq{checkResponse = \ _ _ -> return ()}
+#else
case body of
Just x -> return $ indef $ initReq{ method = "PUT", requestBody =
RequestBodyBS x, checkStatus = \ _ _ _ -> Nothing}
Nothing -> return $ indef $ initReq{checkStatus = \ _ _ _ -> Nothing}
+#endif
where
needQueryString = if isJust dc || isJust query then "?" else ""
prefixAnd = if isJust query && isJust dc then "&" else ""
+#if MIN_VERSION_http_client(0,5,0)
+ indef req = if wait == True then req{responseTimeout =
responseTimeoutNone} else req
+#else
indef req = if wait == True then req{responseTimeout = Nothing} else req
+#endif
{- Key Value Store -}
getKey :: MonadIO m => Manager -> Text -> PortNumber -> Text -> Maybe Word64
-> Maybe Consistency -> Maybe Datacenter -> m (Maybe
Network.Consul.Types.KeyValue)
@@ -172,13 +186,17 @@
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 :: MonadIO m => Manager -> Text -> PortNumber -> Text -> Bool ->
Maybe Datacenter -> m Bool
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 ()
+ bodyParts <- brConsume $ responseBody response
+ let body = B.concat bodyParts
+ case TE.decodeUtf8 body of
+ "true" -> return True
+ "false" -> return False
+ _ -> return False
{- Agent -}
{-getHealthChecks :: MonadIO m => Manager -> Text -> PortNumber -> Maybe
Datacenter -> m [Check]
@@ -289,8 +307,8 @@
x | x == status200 -> return True
_ -> return False
-getSessionInfo :: MonadIO m => Manager -> Text -> PortNumber -> Text -> Maybe
Datacenter -> m (Maybe [SessionInfo])
-getSessionInfo manager hostname portNumber session dc = do
+getSessionInfo :: MonadIO m => Manager -> Text -> PortNumber -> Session ->
Maybe Datacenter -> m (Maybe [SessionInfo])
+getSessionInfo manager hostname portNumber (Session session _) dc = do
req <- createRequest hostname portNumber (T.concat
["/v1/session/info/",session]) Nothing Nothing False dc
liftIO $ withResponse req manager $ \ response -> do
case responseStatus response of
@@ -317,3 +335,16 @@
liftIO $ withResponse req manager $ \ response -> do
bodyParts <- brConsume $ responseBody response
return $ decode $ BL.fromStrict $ B.concat bodyParts
+
+getServices :: MonadIO m => Manager -> Text -> PortNumber -> Maybe Text ->
Maybe Datacenter -> m [Text]
+getServices manager hostname portNumber tag dc = do
+ req <- createRequest hostname portNumber "/v1/catalog/services" Nothing
Nothing False dc
+ liftIO $ withResponse req manager $ \ response -> do
+ bodyParts <- brConsume $ responseBody response
+ return $ parseServices tag $ decode $ BL.fromStrict $ B.concat
bodyParts
+ where
+ parseServices t (Just (Object v)) = filterTags t $ H.toList v
+ parseServices _ _ = []
+ filterTags :: Maybe Text -> [(Text, Value)] -> [Text]
+ filterTags (Just t) = map fst . filter (\ (_, (Array v)) ->
(String t) `V.elem` v)
+ filterTags Nothing = map fst
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/consul-haskell-0.3/src/Network/Consul/Types.hs
new/consul-haskell-0.4.2/src/Network/Consul/Types.hs
--- old/consul-haskell-0.3/src/Network/Consul/Types.hs 2015-10-13
06:37:32.000000000 +0200
+++ new/consul-haskell-0.4.2/src/Network/Consul/Types.hs 2017-01-25
17:41:15.000000000 +0100
@@ -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]
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/consul-haskell-0.3/src/Network/Consul.hs
new/consul-haskell-0.4.2/src/Network/Consul.hs
--- old/consul-haskell-0.3/src/Network/Consul.hs 2015-09-30
18:33:32.000000000 +0200
+++ new/consul-haskell-0.4.2/src/Network/Consul.hs 2017-01-10
18:54:42.000000000 +0100
@@ -4,13 +4,15 @@
{-# LANGUAGE ScopedTypeVariables #-}
module Network.Consul (
- createManagedSession
+ createSession
, deleteKey
- , destroyManagedSession
+ , destroySession
+ , deregisterService
, getKey
, getKeys
, getSelf
, getService
+ , getServices
, getServiceHealth
, getSessionInfo
, getSequencerForLock
@@ -18,26 +20,27 @@
, initializeTlsConsulClient
, isValidSequencer
, listKeys
- , ManagedSession (..)
, passHealthCheck
, putKey
, putKeyAcquireLock
, putKeyReleaseLock
, registerService
+ , renewSession
, runService
- , withManagedSession
- , withSequencer
, withSession
, module Network.Consul.Types
) where
import Control.Concurrent hiding (killThread)
import Control.Concurrent.Async.Lifted
-import Control.Concurrent.Lifted (fork, killThread)
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
+import Control.Retry
+import Data.Monoid ((<>))
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Read as TR
@@ -88,7 +91,7 @@
putKeyReleaseLock :: MonadIO m => ConsulClient -> KeyValuePut -> Session ->
Maybe Datacenter -> m Bool
putKeyReleaseLock _client@ConsulClient{..} = I.putKeyReleaseLock ccManager
(I.hostWithScheme _client) ccPort
-deleteKey :: MonadIO m => ConsulClient -> Text -> Bool -> Maybe Datacenter ->
m ()
+deleteKey :: MonadIO m => ConsulClient -> Text -> Bool -> Maybe Datacenter ->
m Bool
deleteKey _client@ConsulClient{..} key = I.deleteKey ccManager
(I.hostWithScheme _client) ccPort key
{- Health Checks -}
@@ -102,10 +105,16 @@
getService :: MonadIO m => ConsulClient -> Text -> Maybe Text -> Maybe
Datacenter -> m (Maybe [ServiceResult])
getService _client@ConsulClient{..} = I.getService ccManager (I.hostWithScheme
_client) ccPort
+getServices :: MonadIO m => ConsulClient -> Maybe Text -> Maybe Datacenter ->
m [Text]
+getServices _client@ConsulClient{..} = I.getServices ccManager
(I.hostWithScheme _client) ccPort
+
{- Agent -}
getSelf :: MonadIO m => ConsulClient -> m (Maybe Self)
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
+
registerService :: MonadIO m => ConsulClient -> RegisterService -> Maybe
Datacenter -> m Bool
registerService _client@ConsulClient{..} = I.registerService ccManager
(I.hostWithScheme _client) ccPort
@@ -115,61 +124,52 @@
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
+
+ _foo :: () <- wait mainFunc --prevent: 'StM’ is a type function, and may
not be injective
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
+ 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
{- Session -}
-getSessionInfo :: MonadIO m => ConsulClient -> Text -> Maybe Datacenter -> m
(Maybe [SessionInfo])
-getSessionInfo _client@ConsulClient{..} = I.getSessionInfo ccManager
(I.hostWithScheme _client) ccPort
+createSession :: MonadIO m => ConsulClient -> SessionRequest -> Maybe
Datacenter -> m (Maybe Session)
+createSession client@ConsulClient{..} = I.createSession ccManager
(I.hostWithScheme client) ccPort
+
+destroySession :: MonadIO m => ConsulClient -> Session -> Maybe Datacenter ->
m ()
+destroySession client@ConsulClient{..} = I.destroySession ccManager
(I.hostWithScheme client) ccPort
+
+renewSession :: MonadIO m => ConsulClient -> Session -> Maybe Datacenter -> m
Bool
+renewSession client@ConsulClient{..} = I.renewSession 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
- var <- liftIO $ newEmptyTMVarIO
- tidVar <- liftIO $ newEmptyTMVarIO
- stid <- fork $ runThread var tidVar
- tid <- fork $ action session >>= \ x -> liftIO $ atomically $ putTMVar var x
- liftIO $ atomically $ putTMVar tidVar tid
- ret <- liftIO $ atomically $ takeTMVar var
- killThread stid
- return ret
+getSessionInfo :: MonadIO m => ConsulClient -> Session -> Maybe Datacenter ->
m (Maybe [SessionInfo])
+getSessionInfo client@ConsulClient{..} = I.getSessionInfo ccManager
(I.hostWithScheme client) ccPort
+
+withSession :: forall m a. (MonadBaseControl IO m, MonadIO m, MonadMask m) =>
ConsulClient -> Maybe Text -> Int -> Session -> (Session -> m a) -> m a -> m a
+withSession client@ConsulClient{..} name delay session action lostAction = (do
+ withAsync (action session) $ \ mainAsync -> withAsync extendSession $ \
extendAsync -> do
+ result :: a <- return . snd =<< waitAnyCancel [mainAsync,extendAsync]
+ return result) `finally` (destroySession client session Nothing)
where
- runThread :: TMVar a -> TMVar ThreadId -> m ()
- runThread var threadVar = do
- liftIO $ threadDelay (10 * 1000000)
- x <- getSessionInfo client (sId session) Nothing
+ extendSession :: m a
+ extendSession = do
+ liftIO $ threadDelay $ (delay * 1000000)
+ x <- renewSession client session Nothing
case x of
- Just [] -> cancelAction var threadVar
- Nothing -> cancelAction var threadVar
- Just _ -> runThread var threadVar
-
- cancelAction :: TMVar a -> TMVar ThreadId -> m ()
- cancelAction resultVar tidVar = do
- tid <- liftIO $ atomically $ readTMVar tidVar
- killThread tid
- empty <- liftIO $ atomically $ isEmptyTMVar resultVar
- if empty then do
- result <- lostAction
- liftIO $ atomically $ putTMVar resultVar result
- return ()
- else return ()
+ True -> extendSession
+ False -> lostAction
getSequencerForLock :: MonadIO m => ConsulClient -> Text -> Session -> Maybe
Datacenter -> m (Maybe Sequencer)
getSequencerForLock client key session datacenter = do
@@ -187,54 +187,14 @@
Just kv -> return $ (maybe False ((sId $ sSession sequencer) ==) $
kvSession kv) && (kvLockIndex kv) == (sLockIndex sequencer)
Nothing -> return False
-withSequencer :: (MonadBaseControl IO m, MonadIO m) => ConsulClient ->
Sequencer -> m a -> m a -> Int -> Maybe Datacenter -> m a
-withSequencer client sequencer action lostAction delay dc = do
- mainFunc <- async action
- pulseFunc <- async pulseLock
- waitAny [mainFunc, pulseFunc] >>= return . snd
+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
+ waitAnyCancel [mainAsync, pulseAsync] >>= return . snd
where
- pulseLock = do
+ pulseLock = recoverAll (exponentialBackoff 50000 <> limitRetries 5) $ \ _
-> do
liftIO $ threadDelay delay
valid <- isValidSequencer client sequencer dc
case valid of
True -> pulseLock
False -> lostAction
-
-{- 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 :: (MonadBaseControl IO m, MonadIO m) => ConsulClient ->
Text -> (Session -> m ()) -> m () -> m ()
-withManagedSession client ttl action lostAction = do
- x <- createManagedSession client Nothing ttl
- case x of
- Just s -> withSession client (msSession s) action lostAction >>
destroyManagedSession client s
- Nothing -> lostAction
-
-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 (I.hostWithScheme _client) ccPort r Nothing
- mapM f s
- where
- f x = do
- tid <- liftIO $ forkIO $ runThread x
- return $ ManagedSession x tid
-
- saneTtl = let Right (x,_) = TR.decimal $ T.filter (/= 's') ttl in x
-
- runThread :: Session -> IO ()
- runThread s = do
- threadDelay $ (saneTtl - (saneTtl - 10)) * 1000000
- x <- I.renewSession ccManager (I.hostWithScheme _client) ccPort s Nothing
- case x of
- True -> runThread s
- False -> return ()
-
-destroyManagedSession :: MonadIO m => ConsulClient -> ManagedSession -> m ()
-destroyManagedSession _client@ConsulClient{..} (ManagedSession session tid) =
do
- liftIO $ killThread tid
- I.destroySession ccManager (I.hostWithScheme _client) ccPort session Nothing
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/consul-haskell-0.3/tests/Main.hs
new/consul-haskell-0.4.2/tests/Main.hs
--- old/consul-haskell-0.3/tests/Main.hs 2015-10-13 06:17:41.000000000
+0200
+++ new/consul-haskell-0.4.2/tests/Main.hs 2017-01-10 18:54:42.000000000
+0100
@@ -1,14 +1,18 @@
-{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
import Control.Concurrent
import Control.Monad.IO.Class
import Data.Maybe
import Data.Text (Text)
-import Network.Consul
(createManagedSession,getSessionInfo,initializeConsulClient,withSession,ConsulClient(..),ManagedSession(..))
+import Data.UUID
+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
import Network.Socket (PortNumber(..))
+import System.Random
import Test.Tasty
import Test.Tasty.HUnit
@@ -18,7 +22,7 @@
{- Internal Tests -}
internalKVTests :: TestTree
internalKVTests = testGroup "Internal Key Value" [testGetInvalidKey,
testPutKey,
- testGetKey,testGetKeys,testListKeys,testDeleteKey,testGetNullValueKey]
+
testGetKey,testGetKeys,testListKeys,testDeleteKey,testGetNullValueKey,testDeleteRecursive]
testGetInvalidKey :: TestTree
testGetInvalidKey = testCase "testGetInvalidKey" $ do
@@ -56,7 +60,6 @@
Just x -> assertEqual "testGetNullValueKey: Incorrect Value" (kvValue x)
Nothing
Nothing -> assertFailure "testGetNullValueKey: No value returned"
-
testGetKeys :: TestTree
testGetKeys = testCase "testGetKeys" $ do
_client@ConsulClient{..} <- client
@@ -87,9 +90,40 @@
let put1 = KeyValuePut "/testDeleteKey" "Test" Nothing Nothing
x1 <- I.putKey ccManager (I.hostWithScheme _client) ccPort put1 Nothing
assertEqual "testDeleteKey: Write failed" True x1
- 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
+ x2 <- I.deleteKey ccManager (I.hostWithScheme _client) ccPort
"/testDeleteKey" False Nothing
+ 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
+
+testDeleteRecursive :: TestTree
+testDeleteRecursive = testCase "testDeleteRecursive" $ do
+ _client@ConsulClient{..} <- client
+ let put1 = KeyValuePut "/testDeleteRecursive/1" "Test" Nothing Nothing
+ put2 = KeyValuePut "/testDeleteRecursive/2" "Test" Nothing Nothing
+ x1 <- I.putKey ccManager (I.hostWithScheme _client) ccPort put1 Nothing
+ assertEqual "testDeleteKey: Write failed" True x1
+ x2 <- I.putKey ccManager (I.hostWithScheme _client) ccPort put2 Nothing
+ assertEqual "testDeleteKey: Write failed" True x2
+ I.deleteKey ccManager (I.hostWithScheme _client) ccPort
"/testDeleteRecursive/" True Nothing
+ x3 <- I.getKey ccManager (I.hostWithScheme _client) ccPort
"/testDeleteRecursive/1" Nothing Nothing Nothing
+ assertEqual "testDeleteKey: Key was not deleted" Nothing x3
+
+{- Client KV -}
+clientKVTests :: TestTree
+clientKVTests = testGroup "Client KV Tests" [testDeleteRecursiveClient]
+
+testDeleteRecursiveClient :: TestTree
+testDeleteRecursiveClient = testCase "testDeleteRecursiveClient" $ do
+ c <- client
+ let put1 = KeyValuePut "/testDeleteRecursive/1" "Test" Nothing Nothing
+ put2 = KeyValuePut "/testDeleteRecursive/2" "Test" Nothing Nothing
+ x1 <- putKey c put1 Nothing
+ assertEqual "testDeleteKey: Write failed" True x1
+ x2 <- putKey c put2 Nothing
+ assertEqual "testDeleteKey: Write failed" True x2
+ deleteKey c "/testDeleteRecursive/" True Nothing
+ x3 <- getKey c "/testDeleteRecursive/1" Nothing Nothing Nothing
+ assertEqual "testDeleteKey: Key was not deleted" Nothing x3
{- Agent -}
testRegisterService :: TestTree
@@ -98,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
@@ -149,7 +187,7 @@
result <- I.createSession ccManager (I.hostWithScheme _client) ccPort req
Nothing
case result of
Just x -> do
- x1 <- I.getSessionInfo ccManager (I.hostWithScheme _client) ccPort (sId
x) Nothing
+ x1 <- I.getSessionInfo ccManager (I.hostWithScheme _client) ccPort x
Nothing
case x1 of
Just _ -> return ()
Nothing -> assertFailure "testGetSessionInfo: Session Info was not
returned"
@@ -168,6 +206,16 @@
False -> assertFailure "testRenewSession: Session was not renewed"
Nothing -> assertFailure "testRenewSession: No session was created"
+testRenewNonexistentSession :: TestTree
+testRenewNonexistentSession = testCase "testRenewNonexistentSession" $ do
+ _client@ConsulClient{..} <- client
+ sessId :: UUID <- randomIO
+ let session = Session (toText sessId) Nothing
+ x <- I.renewSession ccManager (I.hostWithScheme _client) ccPort session
Nothing
+ case x of
+ True -> assertFailure "testRenewNonexistentSession: Non-existent session
was renewed"
+ False -> return ()
+
testDestroySession :: TestTree
testDestroySession = testCase "testDestroySession" $ do
_client@ConsulClient{..} <- client
@@ -176,29 +224,26 @@
case result of
Just x -> do
_ <- 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
+ x1 <- I.getSessionInfo ccManager (I.hostWithScheme _client) ccPort x
Nothing
+ assertBool "testDestroySession: Session info was returned after
destruction" $ (x1 == Nothing) || (x1 == Just [])
Nothing -> assertFailure "testDestroySession: No session was created"
testInternalSession :: TestTree
-testInternalSession = testGroup "Internal Session Tests" [testCreateSession,
testGetSessionInfo, testRenewSession, testDestroySession]
+testInternalSession = testGroup "Internal Session Tests" [testCreateSession,
testGetSessionInfo, testRenewSession, testRenewNonexistentSession,
testDestroySession]
-{- Managed Session -}
-testCreateManagedSession :: TestTree
-testCreateManagedSession = testCase "testCreateManagedSession" $ do
- 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" 8500 Nothing
- x <- createManagedSession client (Just "testCreateManagedSession") "10s"
- assertEqual "testSessionMaintained: Session not created" True (isJust x)
- let (Just foo) = x
- threadDelay (12 * 1000000)
- y <- getSessionInfo client (sId $ msSession foo) Nothing
- assertEqual "testSessionMaintained: Session not found" True (isJust y)
+ client@ConsulClient{..} <- client
+ let req = SessionRequest Nothing (Just "testSessionMaintained") Nothing
["serfHealth"] (Just Release) (Just "10s")
+ result <- I.createSession ccManager (I.hostWithScheme client) ccPort req
Nothing
+ case result of
+ Just session -> do
+ threadDelay (12 * 1000000)
+ y <- getSessionInfo client session Nothing
+ assertEqual "testSessionMaintained: Session not found" True (isJust y)
+ Nothing -> assertFailure "testSessionMaintained: No Session was created"
+
testWithSessionCancel :: TestTree
testWithSessionCancel = testCase "testWithSessionCancel" $ do
@@ -206,26 +251,53 @@
let req = SessionRequest Nothing (Just "testWithSessionCancel") Nothing
["serfHealth"] (Just Release) (Just "10s")
result <- I.createSession ccManager (I.hostWithScheme client) ccPort req
Nothing
case result of
- Just x -> do
- x1 <- withSession client x (\ y -> action y client ) cancelAction
+ Just session -> do
+ x1 <- withSession client Nothing 5 session (\ y -> action y client )
cancelAction
assertEqual "testWithSessionCancel: Incorrect value" "Canceled" x1
+ z <- getSessionInfo client session Nothing
+ assertBool "testWithSessionCancel: Session was found" $ (z == Nothing)
|| (z == Just [])
+
Nothing -> assertFailure "testWithSessionCancel: No session was created"
where
+ action :: MonadIO m => Session -> ConsulClient -> m Text
action x client@ConsulClient{..} = do
I.destroySession ccManager (I.hostWithScheme client) ccPort x Nothing
- threadDelay (30 * 1000000)
+ liftIO $ threadDelay (30 * 1000000)
return ("NotCanceled" :: Text)
+
+ cancelAction :: MonadIO m => m Text
cancelAction = return ("Canceled" :: Text)
-managedSessionTests :: TestTree
-managedSessionTests = testGroup "Managed Session Tests" [
testCreateManagedSession, testSessionMaintained, testWithSessionCancel]
+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,
managedSessionTests, agentTests,testHealth]
+allTests = testGroup "All Tests" [testInternalSession, internalKVTests,
sessionWorkflowTests, agentTests,testHealth, clientKVTests, runServiceTests]
main :: IO ()
main = defaultMain allTests
