From f6bf16b7051408a72ea4aac689d101fee116994e Mon Sep 17 00:00:00 2001 From: Ketzacoatl Date: Sun, 19 Jan 2020 01:46:38 +0000 Subject: [PATCH 1/7] WIP support for ACL Policy API endpoints --- src/Network/Consul/Internal.hs | 68 +++++++++++++++++++++++++++++++++- src/Network/Consul/Types.hs | 43 +++++++++++++++++++++ tests/Main.hs | 5 +++ 3 files changed, 114 insertions(+), 2 deletions(-) diff --git a/src/Network/Consul/Internal.hs b/src/Network/Consul/Internal.hs index d0fe025..6e1609a 100644 --- a/src/Network/Consul/Internal.hs +++ b/src/Network/Consul/Internal.hs @@ -3,8 +3,15 @@ {-# LANGUAGE OverloadedStrings #-} module Network.Consul.Internal ( + --ACL Policies + createPolicy + , deletePolicy + , getPolicy + , listPolicies + , updatePolicy + --Client - hostWithScheme + , hostWithScheme --Key-Value Store , deleteKey @@ -75,6 +82,64 @@ createRequest hostWithScheme portNumber endpoint query body wait dc = do prefixAnd = if isJust query && isJust dc then "&" else "" indef req = if wait == True then req{responseTimeout = responseTimeoutNone} else req +{- ACL Policies -} +createPolicy :: MonadIO m => Manager -> Text -> PortNumber -> AclPolicyPut -> Maybe Word64 -> Maybe Consistency -> Maybe Datacenter -> m Bool +createPolicy manager hostname portNumber policy dc = do + initReq <- createRequest hostname portNumber "/v1/acl/policy/" Nothing policy False dc + liftIO $ withResponse initReq manager $ \ response -> do + bodyParts <- brConsume $ responseBody response + let body = B.concat bodyParts + let result = decodeAndStrip body + case result of + "true" -> return True + "false" -> return False + _ -> return False + + +deletePolicy :: MonadIO m => Manager -> Text -> PortNumber -> Text -> Maybe Word64 -> Maybe Consistency -> Maybe Datacenter -> m Bool +deletePolicy manager hostname portnumber policyId dc = do + initReq <- createRequest hostname portNumber (T.concat ["/v1/acl/policy",policyId]) Nothing Nothing False dc + let httpReq = initReq { method = "DELETE"} + liftIO $ withResponse httpReq manager $ \ response -> do + bodyParts <- brConsume $ responseBody response + let body = B.concat bodyParts + let result = decodeAndStrip body + case result of + "true" -> return True + "false" -> return False + _ -> return False + + +getPolicy :: MonadIO m => Manager -> Text -> PortNumber -> Text -> Maybe Word64 -> Maybe Consistency -> Maybe Datacenter -> m (Maybe Network.Consul.Types.AclPolicy) +getPolicy manager hostname portnumber policyId dc = do + request <- createRequest hostname portnumber (T.concat ["/v1/acl/policy/",policyId]) Nothing Nothing False dc + liftIO $ withResponse request manager $ \ response -> do + case responseStatus response of + x | x == status200 -> do + bodyParts <- brConsume $ responseBody response + let body = B.concat bodyParts + return $ listToMaybe =<< (decode $ BL.fromStrict body) + _ -> return Nothing + + +-- TODO: IMPLEMENT +--listPolicies +--listPolicies + + +putPolicy :: MonadIO m => Manager -> Text -> PortNumber -> Text -> AclPolicyPut -> Maybe Word64 -> Maybe Consistency -> Maybe Datacenter -> m Bool +putPolicy manager hostname portNumber policyId policy dc = do + initReq <- createRequest hostname portNumber (T.concat ["/v1/acl/policy/", policyId]) Nothing policy False dc + liftIO $ withResponse initReq manager $ \ response -> do + bodyParts <- brConsume $ responseBody response + let body = B.concat bodyParts + let result = decodeAndStrip body + case result of + "true" -> return True + "false" -> return False + _ -> return False + + {- Key Value Store -} 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 @@ -147,7 +212,6 @@ putKey manager hostname portNumber request dc = do 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 diff --git a/src/Network/Consul/Types.hs b/src/Network/Consul/Types.hs index 7c57106..26a88e9 100644 --- a/src/Network/Consul/Types.hs +++ b/src/Network/Consul/Types.hs @@ -3,6 +3,8 @@ {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Network.Consul.Types ( + AclPolicy(..), + AclPolicyPut(..), Check(..), Config(..), Consistency(..), @@ -40,6 +42,34 @@ import Data.Word import Network.HTTP.Client (Manager) import Network.Socket +data AclPolicy = AclPolicy { + aclPolicyId :: Text, + aclPolicyName :: Text, + aclPolicyDescription :: Text, + aclPolicyRules :: Text, + aclPolicyDatacenters :: [Text], + aclPolicyHash :: Text, + aclPolicyCreateIndex :: Word64, + aclPolicyModifyIndex :: Word64 +} deriving (Eq, Ord, Show) + +data AclPolicyPut = AclPolicyPut { + aclPolicyName :: Text, + aclPolicyDescription :: Maybe Text + aclPolicyRules :: Maybe Text, + aclPolicyDatacenters :: Maybe [Text], + aclPolicyNamespace :: Maybe Text +} deriving (Eq, Ord, Show) + +--data AclPolicyUpdate = AclPolicyUpdate { +-- aclPolicyId :: Text, +-- aclPolicyName :: Text, +-- aclPolicyDescription :: Maybe Text +-- aclPolicyRules :: Maybe Text, +-- aclPolicyDatacenters :: Maybe [Text], +-- aclPolicyNamespace :: Maybe Text +--} deriving (Eq, Ord, Show) + data ConsulClient = ConsulClient{ ccManager :: Manager, ccHostname :: Text, @@ -202,6 +232,19 @@ data Health = Health { {- JSON Instances -} +instance FromJSON AclPolicy where + parseJSON (Object v) = + AclPolicy + <$> v .: "ID" + <*> v .: "Name" + <*> v .: "Description" + <*> v .: "Rules" + <*> v .: "Datacenters" + <*> v .: "Hash" + <*> v .: "CreateIndex" + <*> v .: "ModifyIndex" + parseJSON _ = mzero + instance FromJSON Self where parseJSON (Object v) = Self <$> v .: "Member" parseJSON _ = mzero diff --git a/tests/Main.hs b/tests/Main.hs index 8e17b59..e5465c8 100644 --- a/tests/Main.hs +++ b/tests/Main.hs @@ -365,6 +365,11 @@ testIsValidSequencer = testCase "testIsValidSequencer" $ do result2 <- isValidSequencer client sequencer Nothing assertEqual "testIsValidSequencer: Invalid session was valid" False result2 +--testAclCreatePolicy :: TestTree +--testAclCreatePolicy = testCase "testAclCreatePolicy" $ do +-- client@ConsulClient{..} <- newClient +-- -- define new tests here + sessionWorkflowTests :: TestTree sessionWorkflowTests = testGroup "Session Workflow Tests" [testWithSessionCancel,testSessionMaintained] From 192b88c297d3e152c5abf631c87a26e878cc96ad Mon Sep 17 00:00:00 2001 From: Ketzacoatl Date: Sun, 19 Jan 2020 03:15:26 +0000 Subject: [PATCH 2/7] small fixup to types in last commit --- src/Network/Consul/Types.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Network/Consul/Types.hs b/src/Network/Consul/Types.hs index 26a88e9..3210b3f 100644 --- a/src/Network/Consul/Types.hs +++ b/src/Network/Consul/Types.hs @@ -55,7 +55,7 @@ data AclPolicy = AclPolicy { data AclPolicyPut = AclPolicyPut { aclPolicyName :: Text, - aclPolicyDescription :: Maybe Text + aclPolicyDescription :: Maybe Text, aclPolicyRules :: Maybe Text, aclPolicyDatacenters :: Maybe [Text], aclPolicyNamespace :: Maybe Text From d0463825adbc4ad35f0cc415478dff4c25bfe6a9 Mon Sep 17 00:00:00 2001 From: Ketzacoatl Date: Sun, 19 Jan 2020 03:29:42 +0000 Subject: [PATCH 3/7] it nearly compiles, sorta --- src/Network/Consul/Internal.hs | 10 +++++----- src/Network/Consul/Types.hs | 26 ++++++++++---------------- 2 files changed, 15 insertions(+), 21 deletions(-) diff --git a/src/Network/Consul/Internal.hs b/src/Network/Consul/Internal.hs index 6e1609a..a5f7614 100644 --- a/src/Network/Consul/Internal.hs +++ b/src/Network/Consul/Internal.hs @@ -83,7 +83,7 @@ createRequest hostWithScheme portNumber endpoint query body wait dc = do indef req = if wait == True then req{responseTimeout = responseTimeoutNone} else req {- ACL Policies -} -createPolicy :: MonadIO m => Manager -> Text -> PortNumber -> AclPolicyPut -> Maybe Word64 -> Maybe Consistency -> Maybe Datacenter -> m Bool +createPolicy :: MonadIO m => Manager -> Text -> PortNumber -> AclPolicyPut -> Maybe Datacenter -> m Bool createPolicy manager hostname portNumber policy dc = do initReq <- createRequest hostname portNumber "/v1/acl/policy/" Nothing policy False dc liftIO $ withResponse initReq manager $ \ response -> do @@ -96,9 +96,9 @@ createPolicy manager hostname portNumber policy dc = do _ -> return False -deletePolicy :: MonadIO m => Manager -> Text -> PortNumber -> Text -> Maybe Word64 -> Maybe Consistency -> Maybe Datacenter -> m Bool +deletePolicy :: MonadIO m => Manager -> Text -> PortNumber -> Text -> Maybe Datacenter -> m Bool deletePolicy manager hostname portnumber policyId dc = do - initReq <- createRequest hostname portNumber (T.concat ["/v1/acl/policy",policyId]) Nothing Nothing False dc + initReq <- createRequest hostname portnumber (T.concat ["/v1/acl/policy",policyId]) Nothing Nothing False dc let httpReq = initReq { method = "DELETE"} liftIO $ withResponse httpReq manager $ \ response -> do bodyParts <- brConsume $ responseBody response @@ -110,7 +110,7 @@ deletePolicy manager hostname portnumber policyId dc = do _ -> return False -getPolicy :: MonadIO m => Manager -> Text -> PortNumber -> Text -> Maybe Word64 -> Maybe Consistency -> Maybe Datacenter -> m (Maybe Network.Consul.Types.AclPolicy) +getPolicy :: MonadIO m => Manager -> Text -> PortNumber -> Text -> Maybe Datacenter -> m (Maybe Network.Consul.Types.AclPolicy) getPolicy manager hostname portnumber policyId dc = do request <- createRequest hostname portnumber (T.concat ["/v1/acl/policy/",policyId]) Nothing Nothing False dc liftIO $ withResponse request manager $ \ response -> do @@ -127,7 +127,7 @@ getPolicy manager hostname portnumber policyId dc = do --listPolicies -putPolicy :: MonadIO m => Manager -> Text -> PortNumber -> Text -> AclPolicyPut -> Maybe Word64 -> Maybe Consistency -> Maybe Datacenter -> m Bool +putPolicy :: MonadIO m => Manager -> Text -> PortNumber -> Text -> AclPolicyPut -> Maybe Datacenter -> m Bool putPolicy manager hostname portNumber policyId policy dc = do initReq <- createRequest hostname portNumber (T.concat ["/v1/acl/policy/", policyId]) Nothing policy False dc liftIO $ withResponse initReq manager $ \ response -> do diff --git a/src/Network/Consul/Types.hs b/src/Network/Consul/Types.hs index 3210b3f..aa3d36a 100644 --- a/src/Network/Consul/Types.hs +++ b/src/Network/Consul/Types.hs @@ -42,34 +42,28 @@ import Data.Word import Network.HTTP.Client (Manager) import Network.Socket +-- ACL Policy w/ ID (Response from API) +-- Can be used with the List of All Polocies API as Rules is a Maybe Text data AclPolicy = AclPolicy { aclPolicyId :: Text, aclPolicyName :: Text, aclPolicyDescription :: Text, - aclPolicyRules :: Text, - aclPolicyDatacenters :: [Text], + aclPolicyRules :: Maybe Text, + aclPolicyDatacenters :: Maybe [Text], aclPolicyHash :: Text, aclPolicyCreateIndex :: Word64, aclPolicyModifyIndex :: Word64 } deriving (Eq, Ord, Show) +-- ACL Policy Data type for Creating and Updating a Policy data AclPolicyPut = AclPolicyPut { - aclPolicyName :: Text, - aclPolicyDescription :: Maybe Text, - aclPolicyRules :: Maybe Text, - aclPolicyDatacenters :: Maybe [Text], - aclPolicyNamespace :: Maybe Text + aclPolicyPutName :: Text, + aclPolicyPutDescription :: Maybe Text, + aclPolicyPutRules :: Maybe Text, + aclPolicyPutDatacenters :: Maybe [Text], + aclPolicyPutNamespace :: Maybe Text } deriving (Eq, Ord, Show) ---data AclPolicyUpdate = AclPolicyUpdate { --- aclPolicyId :: Text, --- aclPolicyName :: Text, --- aclPolicyDescription :: Maybe Text --- aclPolicyRules :: Maybe Text, --- aclPolicyDatacenters :: Maybe [Text], --- aclPolicyNamespace :: Maybe Text ---} deriving (Eq, Ord, Show) - data ConsulClient = ConsulClient{ ccManager :: Manager, ccHostname :: Text, From c4999e99e817579000806448ee01ff3a93fff428 Mon Sep 17 00:00:00 2001 From: Ketzacoatl Date: Sun, 19 Jan 2020 17:47:31 +0000 Subject: [PATCH 4/7] add placeholders for ACL / Policy tests --- tests/Main.hs | 62 +++++++++++++++++++++++++++++++++++++++++++++++---- 1 file changed, 58 insertions(+), 4 deletions(-) diff --git a/tests/Main.hs b/tests/Main.hs index e5465c8..07f039c 100644 --- a/tests/Main.hs +++ b/tests/Main.hs @@ -15,11 +15,31 @@ import Data.Maybe #else import Data.Monoid ((<>)) #endif +import Data.ByteString (pack) import Data.Text (Text) import Data.UUID -import Network.Consul (createSession, deleteKey, destroySession,getKey, getSequencerForLock,getSessionInfo,initializeConsulClient, isValidSequencer,putKey,putKeyAcquireLock,withSession,ConsulClient(..),runService,getServiceHealth) + +import Network.Consul + ( createAclPolicy + , createSession + , deleteKey + , destroySession + , getKey + , getSequencerForLock + , getSessionInfo + , initializeConsulClient + , isValidSequencer + , putKey + , putKeyAcquireLock + , 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.IO (hFlush) @@ -92,7 +112,6 @@ testPutKeyReleaseLock = testCase "testPutKeyReleaseLock" $ do assertEqual "testPutKeyAcquireLock: Session still held" Nothing (kvSession kv2) - testGetKey :: TestTree testGetKey = testCase "testGetKey" $ do client@ConsulClient{..} <- newClient @@ -365,8 +384,43 @@ testIsValidSequencer = testCase "testIsValidSequencer" $ do result2 <- isValidSequencer client sequencer Nothing assertEqual "testIsValidSequencer: Invalid session was valid" False result2 ---testAclCreatePolicy :: TestTree ---testAclCreatePolicy = testCase "testAclCreatePolicy" $ do +testAclCreatePolicy :: TestTree +testAclCreatePolicy = testCase "testAclCreatePolicy" $ do + client@ConsulClient{..} <- initializeConsulClient "localhost" consulPort Nothing + let policy = "{key_prefix \"\" {policy = \"read\"}}" + --policy = AclPolicyPut + -- { "somePolicyId" + -- , "somePolicyName" + -- , "a test policy to test consul-haskell with" + -- , "" + -- , [dc] + -- , Nothing + -- } + result <- createAclPolicy client (Just policy) Nothing + assertEqual "testAclCreatePolicy: placeholder awesome" False True + + -- define new tests here + +--testAclGetPolicy :: TestTree +--testAclGetPolicy = testCase "testAclGetPolicy" $ do +-- client@ConsulClient{..} <- newClient +-- -- define new tests here +-- +-- +--testAclUpdatePolicy :: TestTree +--testAclUpdatePolicy = testCase "testAclUpdatePolicy" $ do +-- client@ConsulClient{..} <- newClient +-- -- define new tests here +-- +-- +--testAclDeletePolicy :: TestTree +--testAclDeletePolicy = testCase "testAclDeletePolicy" $ do +-- client@ConsulClient{..} <- newClient +-- -- define new tests here +-- +-- +--testAclListAllPolicy :: TestTree +--testAclListAllPolicy = testCase "testAclListAllPolicy" $ do -- client@ConsulClient{..} <- newClient -- -- define new tests here From ae42bf745e1d4363bdc8f8698d6824ba0c27b2d8 Mon Sep 17 00:00:00 2001 From: Ketzacoatl Date: Wed, 15 Jul 2020 02:01:58 +0000 Subject: [PATCH 5/7] parseUrl was renamed to parseUrlThrow, do it here --- src/Network/Consul/Internal.hs | 20 ++++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/src/Network/Consul/Internal.hs b/src/Network/Consul/Internal.hs index a5f7614..e18f9e5 100644 --- a/src/Network/Consul/Internal.hs +++ b/src/Network/Consul/Internal.hs @@ -73,7 +73,7 @@ createRequest :: MonadIO m => Text -> PortNumber -> Text -> Maybe Text -> Maybe 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 + initReq <- liftIO $ parseUrlThrow $ T.unpack baseUrl case body of Just x -> return $ indef $ initReq{ method = "PUT", requestBody = RequestBodyBS x, checkResponse = \ _ _ -> return ()} Nothing -> return $ indef $ initReq{checkResponse = \ _ _ -> return ()} @@ -269,7 +269,7 @@ getHealthChecks manager hostname portNumber dc = do registerHealthCheck :: MonadIO m => Manager -> Text -> PortNumber -> RegisterHealthCheck -> m () registerHealthCheck manager hostname portNumber request = do - initReq <- liftIO $ parseUrl $ T.unpack $ T.concat [hostname, ":", T.pack $ show portNumber ,"/v1/agent/check/register"] + initReq <- liftIO $ parseUrlThrow $ 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 @@ -277,7 +277,7 @@ registerHealthCheck manager hostname portNumber request = do deregisterHealthCheck :: MonadIO m => Manager -> Text -> PortNumber -> Text -> m () deregisterHealthCheck manager hostname portNumber checkId = do - initReq <- liftIO $ parseUrl $ T.unpack $ T.concat [hostname, ":", T.pack $ show portNumber ,"/v1/agent/check/deregister/", checkId] + initReq <- liftIO $ parseUrlThrow $ 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 () @@ -301,14 +301,14 @@ passHealthCheck manager hostname portNumber checkId dc = do warnHealthCheck :: MonadIO m => Manager -> Text -> PortNumber -> Text -> m () warnHealthCheck manager hostname portNumber checkId = do - initReq <- liftIO $ parseUrl $ T.unpack $ T.concat [hostname, ":", T.pack $ show portNumber ,"/v1/agent/check/warn/", checkId] + initReq <- liftIO $ parseUrlThrow $ 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 portNumber checkId = do - initReq <- liftIO $ parseUrl $ T.unpack $ T.concat [hostname, ":", T.pack $ show portNumber ,"/v1/agent/check/fail/", checkId] + initReq <- liftIO $ parseUrlThrow $ 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 () @@ -323,14 +323,14 @@ registerService manager hostname portNumber request dc = do deregisterService :: MonadIO m => Manager -> Text -> PortNumber -> Text -> m () deregisterService manager hostname portNumber service = do - initReq <- liftIO $ parseUrl $ T.unpack $ T.concat [hostname, ":", T.pack $ show portNumber ,"/v1/agent/service/deregister/", service] + initReq <- liftIO $ parseUrlThrow $ 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 portNumber = do - initReq <- liftIO $ parseUrl $ T.unpack $ T.concat [hostname, ":", T.pack $ show portNumber ,"/v1/agent/self"] + initReq <- liftIO $ parseUrlThrow $ 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 @@ -340,7 +340,7 @@ getSelf manager hostname portNumber = do {- Health -} getServiceChecks :: MonadIO m => Manager -> Text -> PortNumber -> Text -> m [Check] getServiceChecks manager hostname portNumber name = do - initReq <- liftIO $ parseUrl $ T.unpack $ T.concat [hostname, ":", T.pack $ show portNumber ,"/v1/health/checks/", name] + initReq <- liftIO $ parseUrlThrow $ 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 @@ -348,7 +348,7 @@ getServiceChecks manager hostname portNumber name = do 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] + initReq <- liftIO $ parseUrlThrow $ 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 @@ -393,7 +393,7 @@ getSessionInfo manager hostname portNumber (Session session _) dc = do {- Catalog -} getDatacenters :: MonadIO m => Manager -> Text -> PortNumber -> m [Datacenter] getDatacenters manager hostname portNumber = liftIO $ do - initReq <- parseUrl $ T.unpack $ T.concat [hostname, ":", T.pack $ show portNumber ,"/v1/catalog/datacenters/"] + initReq <- parseUrlThrow $ 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 From 89f64b5b1c104dfae9a8bc926a850efa634c1747 Mon Sep 17 00:00:00 2001 From: Ketzacoatl Date: Wed, 15 Jul 2020 02:02:27 +0000 Subject: [PATCH 6/7] get it to compile --- src/Network/Consul/Internal.hs | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/src/Network/Consul/Internal.hs b/src/Network/Consul/Internal.hs index e18f9e5..cd18b3e 100644 --- a/src/Network/Consul/Internal.hs +++ b/src/Network/Consul/Internal.hs @@ -7,8 +7,8 @@ module Network.Consul.Internal ( createPolicy , deletePolicy , getPolicy - , listPolicies - , updatePolicy + --, listPolicies + --, updatePolicy --Client , hostWithScheme @@ -63,7 +63,7 @@ import Data.Word import Network.Consul.Types import Network.HTTP.Client import Network.HTTP.Types -import Network.Socket (PortNumber(..)) +import Network.Socket (PortNumber) hostWithScheme :: ConsulClient -> Text hostWithScheme ConsulClient{..} = scheme `T.append` ccHostname @@ -83,7 +83,7 @@ createRequest hostWithScheme portNumber endpoint query body wait dc = do indef req = if wait == True then req{responseTimeout = responseTimeoutNone} else req {- ACL Policies -} -createPolicy :: MonadIO m => Manager -> Text -> PortNumber -> AclPolicyPut -> Maybe Datacenter -> m Bool +createPolicy :: MonadIO m => Manager -> Text -> PortNumber -> Maybe B.ByteString -> Maybe Datacenter -> m Bool createPolicy manager hostname portNumber policy dc = do initReq <- createRequest hostname portNumber "/v1/acl/policy/" Nothing policy False dc liftIO $ withResponse initReq manager $ \ response -> do @@ -127,7 +127,7 @@ getPolicy manager hostname portnumber policyId dc = do --listPolicies -putPolicy :: MonadIO m => Manager -> Text -> PortNumber -> Text -> AclPolicyPut -> Maybe Datacenter -> m Bool +putPolicy :: MonadIO m => Manager -> Text -> PortNumber -> Text -> Maybe B.ByteString -> Maybe Datacenter -> m Bool putPolicy manager hostname portNumber policyId policy dc = do initReq <- createRequest hostname portNumber (T.concat ["/v1/acl/policy/", policyId]) Nothing policy False dc liftIO $ withResponse initReq manager $ \ response -> do From 20bdd4a9cd32c104fcf6fa33000d1a65de32ffa8 Mon Sep 17 00:00:00 2001 From: Ketzacoatl Date: Wed, 15 Jul 2020 02:02:49 +0000 Subject: [PATCH 7/7] add missing wrapper function for createAclPolicy --- src/Network/Consul.hs | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) diff --git a/src/Network/Consul.hs b/src/Network/Consul.hs index 82fe5f5..7d0d193 100644 --- a/src/Network/Consul.hs +++ b/src/Network/Consul.hs @@ -3,8 +3,9 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} -module Network.Consul ( - createSession +module Network.Consul + ( createAclPolicy + , createSession , deleteKey , destroySession , deregisterService @@ -37,6 +38,7 @@ import Control.Monad (forever) import Control.Monad.IO.Class import Control.Monad.Catch (MonadMask) import Control.Retry +import qualified Data.ByteString as B import Data.Monoid ((<>)) import Data.Text (Text) import qualified Data.Text as T @@ -69,6 +71,10 @@ initializeTlsConsulClient hostname port man = do Nothing -> newTlsManagerWith tlsManagerSettings return $ ConsulClient manager hostname port True +{- ACL -} +createAclPolicy :: MonadIO m => ConsulClient -> Maybe B.ByteString -> Maybe Datacenter -> m Bool +createAclPolicy _client@ConsulClient{..} = I.createPolicy ccManager (I.hostWithScheme _client) ccPort + {- Key Value -} getKey :: MonadIO m => ConsulClient -> Text -> Maybe Word64 -> Maybe Consistency -> Maybe Datacenter -> m (Maybe KeyValue) getKey _client@ConsulClient{..} = I.getKey ccManager (I.hostWithScheme _client) ccPort