From 34eb41c80dcc89a21b1319d9005644bd8a0dc611 Mon Sep 17 00:00:00 2001 From: Ashwin Siripurapu Date: Thu, 8 Oct 2015 00:21:22 -0700 Subject: [PATCH 1/3] Beginning work on Template Haskell-izing the Consul client's shim of the internal API. Have excised the old code, and am working on determining the parse tree and constructing it in TH. --- TestConsulParsing.hs | 16 ++++++++ src/Network/Consul.hs | 57 +++++++++------------------ src/Network/Consul/TemplateHaskell.hs | 0 3 files changed, 34 insertions(+), 39 deletions(-) create mode 100644 TestConsulParsing.hs create mode 100644 src/Network/Consul/TemplateHaskell.hs diff --git a/TestConsulParsing.hs b/TestConsulParsing.hs new file mode 100644 index 0000000..ac06026 --- /dev/null +++ b/TestConsulParsing.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE TemplateHaskell #-} + +import Language.Haskell.TH + +data ConsulClient = ConsulClient { ccHostname :: String + , ccPort :: Int + } + +modFunc :: String -> Int -> Int +modFunc str x = x * (length str) + +main = do + dec <- runQ [d| myFunc _consul@ConsulClient{..} = modFunc ccHostname ccPort |] + print dec + +-- Output: [FunD myFunc_0 [Clause [AsP _consul_1 (RecP Main.ConsulClient [(Main.ccHostname,VarP ccHostname_2),(Main.ccPort,VarP ccPort_3)])] (NormalB (AppE (AppE (VarE Main.modFunc) (VarE ccHostname_2)) (VarE ccPort_3))) []]] diff --git a/src/Network/Consul.hs b/src/Network/Consul.hs index 985f647..39e5bda 100644 --- a/src/Network/Consul.hs +++ b/src/Network/Consul.hs @@ -2,6 +2,7 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} module Network.Consul ( createManagedSession @@ -48,6 +49,7 @@ import Network.Consul.Types import Network.HTTP.Client (defaultManagerSettings, newManager, Manager) import Network.HTTP.Client.TLS (tlsManagerSettings) import Network.Socket (PortNumber) +import qualified Network.Consul.TemplateHaskell as TH import Prelude hiding (mapM) @@ -69,45 +71,22 @@ initializeTlsConsulClient hostname port man = do 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 (I.hostWithScheme _client) ccPort - -getKeys :: MonadIO m => ConsulClient -> Text -> Maybe Word64 -> Maybe Consistency -> Maybe Datacenter -> m [KeyValue] -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 (I.hostWithScheme _client) ccPort - -putKey :: MonadIO m => ConsulClient -> KeyValuePut -> Maybe Datacenter -> m Bool -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 (I.hostWithScheme _client) ccPort - -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 _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 (I.hostWithScheme _client) ccPort - -registerService :: MonadIO m => ConsulClient -> RegisterService -> Maybe Datacenter -> m Bool -registerService _client@ConsulClient{..} = I.registerService ccManager (I.hostWithScheme _client) ccPort +toShim :: [Name] +toShim = map mkName [ "I.getKey" + , "I.getKeys" + , "I.listKeys" + , "I.putKey" + , "I.putKeyAcquireLock" + , "I.putKeyReleaseLock" + , "I.deleteKey" + , "I.passHealthCheck" + , "I.getServiceHealth" + , "I.getService" + , "I.getSelf" + , "I.registerService" + ] + +performShim toShim runService :: (MonadBaseControl IO m, MonadIO m) => ConsulClient -> RegisterService -> m () -> Maybe Datacenter -> m () runService client request action dc = do diff --git a/src/Network/Consul/TemplateHaskell.hs b/src/Network/Consul/TemplateHaskell.hs new file mode 100644 index 0000000..e69de29 From f3838e449162535d8038a768c37dc6e44cc23794 Mon Sep 17 00:00:00 2001 From: Ashwin Siripurapu Date: Thu, 8 Oct 2015 21:10:01 -0700 Subject: [PATCH 2/3] Ready to test TemplateHaskell --- TestConsulParsing.hs | 6 ++++-- src/Network/Consul.hs | 2 +- src/Network/Consul/TemplateHaskell.hs | 24 ++++++++++++++++++++++++ 3 files changed, 29 insertions(+), 3 deletions(-) diff --git a/TestConsulParsing.hs b/TestConsulParsing.hs index ac06026..b97a6dd 100644 --- a/TestConsulParsing.hs +++ b/TestConsulParsing.hs @@ -10,7 +10,9 @@ modFunc :: String -> Int -> Int modFunc str x = x * (length str) main = do - dec <- runQ [d| myFunc _consul@ConsulClient{..} = modFunc ccHostname ccPort |] + -- dec <- runQ [d| myFunc _consul@ConsulClient{..} = modFunc ccHostname ccPort |] + dec <- runQ [d| myFunc _consul = modFunc (ccHostname _consul) (ccPort _consul) |] print dec --- Output: [FunD myFunc_0 [Clause [AsP _consul_1 (RecP Main.ConsulClient [(Main.ccHostname,VarP ccHostname_2),(Main.ccPort,VarP ccPort_3)])] (NormalB (AppE (AppE (VarE Main.modFunc) (VarE ccHostname_2)) (VarE ccPort_3))) []]] +-- Output with as-pattern: [FunD myFunc_0 [Clause [AsP _consul_1 (RecP Main.ConsulClient [(Main.ccHostname,VarP ccHostname_2),(Main.ccPort,VarP ccPort_3)])] (NormalB (AppE (AppE (VarE Main.modFunc) (VarE ccHostname_2)) (VarE ccPort_3))) []]] +-- Output without as-pattern: [FunD myFunc_0 [Clause [VarP _consul_1] (NormalB (AppE (AppE (VarE Main.modFunc) (AppE (VarE Main.ccHostname) (VarE _consul_1))) (AppE (VarE Main.ccPort) (VarE _consul_1)))) []]] diff --git a/src/Network/Consul.hs b/src/Network/Consul.hs index 39e5bda..82b7560 100644 --- a/src/Network/Consul.hs +++ b/src/Network/Consul.hs @@ -86,7 +86,7 @@ toShim = map mkName [ "I.getKey" , "I.registerService" ] -performShim toShim +mkShim toShim runService :: (MonadBaseControl IO m, MonadIO m) => ConsulClient -> RegisterService -> m () -> Maybe Datacenter -> m () runService client request action dc = do diff --git a/src/Network/Consul/TemplateHaskell.hs b/src/Network/Consul/TemplateHaskell.hs index e69de29..39761c7 100644 --- a/src/Network/Consul/TemplateHaskell.hs +++ b/src/Network/Consul/TemplateHaskell.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Network.Consul.TemplateHaskell ( + mkShim + ) where + +import Language.Haskell.TH +import Network.Consul.Types +import qualified Network.Consul.Internal as I + +applyArgs :: ExpQ -> [ExpQ] -> ExpQ +applyArgs = foldl appE + +mkShim :: [Name] -> Q [Dec] +mkShim fnNames = forM fnNames $ \fnName -> do + -- shimmedName will be the name of the function used in Network.Consul + let shimmedName = mkName $ nameBase fnName + let clientE = varE $ mkName "_consul" + let args = [appE (varE getter) clientE | + getter <- ['ccManager, 'I.hostWithScheme, 'ccPort]] + let body = normalB $ applyArgs (varE fnName) args + let cls = clause [varP $ mkName "_consul"] body [] + dec <- funD shimmedName [cls] + return dec From 80835db3d65eb4b51305d55975166a85c801dac0 Mon Sep 17 00:00:00 2001 From: Ashwin Siripurapu Date: Thu, 8 Oct 2015 23:01:17 -0700 Subject: [PATCH 3/3] Making sure everything compiles. Changed .cabal file to include template-haskell dependency. Had to move some code around because TH requires that any arguments to TH functions come from an import. Deleting unused files. --- TestConsulParsing.hs | 18 ------------------ consul-haskell.cabal | 1 + src/Network/Consul.hs | 17 +---------------- src/Network/Consul/TemplateHaskell.hs | 20 ++++++++++++++++++-- 4 files changed, 20 insertions(+), 36 deletions(-) delete mode 100644 TestConsulParsing.hs diff --git a/TestConsulParsing.hs b/TestConsulParsing.hs deleted file mode 100644 index b97a6dd..0000000 --- a/TestConsulParsing.hs +++ /dev/null @@ -1,18 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - -import Language.Haskell.TH - -data ConsulClient = ConsulClient { ccHostname :: String - , ccPort :: Int - } - -modFunc :: String -> Int -> Int -modFunc str x = x * (length str) - -main = do - -- dec <- runQ [d| myFunc _consul@ConsulClient{..} = modFunc ccHostname ccPort |] - dec <- runQ [d| myFunc _consul = modFunc (ccHostname _consul) (ccPort _consul) |] - print dec - --- Output with as-pattern: [FunD myFunc_0 [Clause [AsP _consul_1 (RecP Main.ConsulClient [(Main.ccHostname,VarP ccHostname_2),(Main.ccPort,VarP ccPort_3)])] (NormalB (AppE (AppE (VarE Main.modFunc) (VarE ccHostname_2)) (VarE ccPort_3))) []]] --- Output without as-pattern: [FunD myFunc_0 [Clause [VarP _consul_1] (NormalB (AppE (AppE (VarE Main.modFunc) (AppE (VarE Main.ccHostname) (VarE _consul_1))) (AppE (VarE Main.ccPort) (VarE _consul_1)))) []]] diff --git a/consul-haskell.cabal b/consul-haskell.cabal index eb48a28..f94e009 100644 --- a/consul-haskell.cabal +++ b/consul-haskell.cabal @@ -44,6 +44,7 @@ library monad-control >= 1.0, network, text, + template-haskell >= 2.10, transformers, stm ghc-options: diff --git a/src/Network/Consul.hs b/src/Network/Consul.hs index 82b7560..c4cfff1 100644 --- a/src/Network/Consul.hs +++ b/src/Network/Consul.hs @@ -71,22 +71,7 @@ initializeTlsConsulClient hostname port man = do Nothing -> newManager tlsManagerSettings return $ ConsulClient manager hostname port True -toShim :: [Name] -toShim = map mkName [ "I.getKey" - , "I.getKeys" - , "I.listKeys" - , "I.putKey" - , "I.putKeyAcquireLock" - , "I.putKeyReleaseLock" - , "I.deleteKey" - , "I.passHealthCheck" - , "I.getServiceHealth" - , "I.getService" - , "I.getSelf" - , "I.registerService" - ] - -mkShim toShim +TH.mkShim TH.toShim runService :: (MonadBaseControl IO m, MonadIO m) => ConsulClient -> RegisterService -> m () -> Maybe Datacenter -> m () runService client request action dc = do diff --git a/src/Network/Consul/TemplateHaskell.hs b/src/Network/Consul/TemplateHaskell.hs index 39761c7..2b3c16a 100644 --- a/src/Network/Consul/TemplateHaskell.hs +++ b/src/Network/Consul/TemplateHaskell.hs @@ -2,12 +2,29 @@ module Network.Consul.TemplateHaskell ( mkShim + , toShim ) where +import Control.Monad (forM) import Language.Haskell.TH import Network.Consul.Types import qualified Network.Consul.Internal as I +toShim :: [Name] +toShim = map mkName [ "I.getKey" + , "I.getKeys" + , "I.listKeys" + , "I.putKey" + , "I.putKeyAcquireLock" + , "I.putKeyReleaseLock" + , "I.deleteKey" + , "I.passHealthCheck" + , "I.getServiceHealth" + , "I.getService" + , "I.getSelf" + , "I.registerService" + ] + applyArgs :: ExpQ -> [ExpQ] -> ExpQ applyArgs = foldl appE @@ -20,5 +37,4 @@ mkShim fnNames = forM fnNames $ \fnName -> do getter <- ['ccManager, 'I.hostWithScheme, 'ccPort]] let body = normalB $ applyArgs (varE fnName) args let cls = clause [varP $ mkName "_consul"] body [] - dec <- funD shimmedName [cls] - return dec + funD shimmedName [cls]