packages feed

consul-haskell (empty) → 0.1

raw patch · 7 files changed

+764/−0 lines, 7 filesdep +HUnitdep +aesondep +basesetup-changed

Dependencies added: HUnit, aeson, base, base64-bytestring, bytestring, consul-haskell, http-client, network, tasty, tasty-hunit, text, transformers

Files

+ LICENSE view
@@ -0,0 +1,26 @@+Copyright (c) 2014, Alpha Heavy Industries, Inc.+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++- Redistributions of source code must retain the above copyright notice,+  this list of conditions and the following disclaimer.+- Redistributions in binary form must reproduce the above copyright+  notice, this list of conditions and the following disclaimer in the+  documentation and/or other materials provided with the distribution.+- Neither the names of the copyright owners nor the names of the+  contributors may be used to endorse or promote products derived+  from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ consul-haskell.cabal view
@@ -0,0 +1,67 @@+name:                consul-haskell+version:             0.1+synopsis:            A consul client for Haskell+description:+  A consul client for Haskell+  .+  Requires consul 0.5 or later.++license:             BSD3+license-file:        LICENSE+author:              Steve Severance+maintainer:          sseverance@alphaheavy.com+homepage:            https://github.com/alphaHeavy/consul-haskell+bug-reports:         https://github.com/alphaHeavy/consul-haskell/issues+category:            Network++build-type:          Simple+cabal-version:       >= 1.10++extra-source-files:+  tests/Main.hs++library+  default-language:+    Haskell2010+  hs-source-dirs:+    src+  exposed-modules:+    Network.Consul+    Network.Consul.Internal+    Network.Consul.Types+  build-depends:+    aeson,+    base                       >= 4.6 && < 5,+    base64-bytestring,+    bytestring,+    http-client,+    network,+    text,+    transformers+  ghc-options:+    -Wall++test-suite consul-haskell-test+  default-language:+    Haskell2010+  hs-source-dirs:+    tests+  type:+    exitcode-stdio-1.0+  main-is:+    Main.hs+  build-depends:+    base                       >= 4.6 && < 5,+    consul-haskell,+    http-client,+    network,+    tasty,+    tasty-hunit,+    HUnit                      >= 1.2+  ghc-options:+    -Wall+++source-repository head+  type:     git+  location: https://github.com/alphaHeavy/consul-haskell.git
+ src/Network/Consul.hs view
@@ -0,0 +1,105 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Network.Consul (+    createManagedSession+  , deleteKey+  , destroyManagedSession+  , getKey+  , getKeys+  , initializeConsulClient+  , listKeys+  , putKey+  , putKeyAcquireLock+  , putKeyReleaseLock+  , withManagedSession+  , Consistency(..)+  , ConsulClient(..)+  , Datacenter(..)+  , KeyValue(..)+  , KeyValuePut(..)+  , ManagedSession(..)+  , Session(..)+) where++import Control.Concurrent+import Control.Monad.IO.Class+import Data.Text (Text)+import Data.Traversable+import qualified Network.Consul.Internal as I+import Data.Word+import Network.Consul.Types+import Network.HTTP.Client (defaultManagerSettings, newManager, Manager)+import Network.Socket (PortNumber)++import Prelude hiding (mapM)++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+++{- Key Value -}++getKey :: MonadIO m => ConsulClient -> Text -> Maybe Word64 -> Maybe Consistency -> Maybe Datacenter -> m (Maybe KeyValue)+getKey _client@ConsulClient{..} = I.getKey ccManager ccHostname ccPort++getKeys :: MonadIO m => ConsulClient -> Text -> Maybe Word64 -> Maybe Consistency -> Maybe Datacenter -> m [KeyValue]+getKeys _client@ConsulClient{..} = I.getKeys ccManager ccHostname ccPort++listKeys :: MonadIO m => ConsulClient -> Text -> Maybe Word64 -> Maybe Consistency -> Maybe Datacenter -> m [Text]+listKeys _client@ConsulClient{..} = I.listKeys ccManager ccHostname ccPort++putKey :: MonadIO m => ConsulClient -> KeyValuePut -> Maybe Datacenter -> m Bool+putKey _client@ConsulClient{..} = I.putKey ccManager ccHostname ccPort++putKeyAcquireLock :: MonadIO m => ConsulClient -> KeyValuePut -> Session -> Maybe Datacenter -> m Bool+putKeyAcquireLock _client@ConsulClient{..} = I.putKeyAcquireLock ccManager ccHostname ccPort++putKeyReleaseLock :: MonadIO m => ConsulClient -> KeyValuePut -> Session -> Maybe Datacenter -> m Bool+putKeyReleaseLock _client@ConsulClient{..} = I.putKeyReleaseLock ccManager ccHostname ccPort++deleteKey :: MonadIO m => ConsulClient -> Text -> Bool -> Maybe Datacenter -> m ()+deleteKey _client@ConsulClient{..} key = I.deleteKey ccManager ccHostname ccPort key++{- Agent -}++{- 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 :: MonadIO m => ConsulClient -> Int -> (Session -> m ()) -> m ()+withManagedSession client ttl action = do+  x <- createManagedSession client Nothing ttl+  case x of+    Just s -> action (msSession s) >> destroyManagedSession client s+    Nothing -> return ()++createManagedSession :: MonadIO m => ConsulClient -> Maybe Text -> Int -> 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+  mapM f s+  where+    f x = do+      tid <- liftIO $ forkIO $ runThread x+      return $ ManagedSession x tid++    runThread :: Session -> IO ()+    runThread s = do+      threadDelay 10+      I.renewSession ccManager ccHostname ccPort s Nothing+      return ()++destroyManagedSession :: MonadIO m => ConsulClient -> ManagedSession -> m ()+destroyManagedSession _client@ConsulClient{..} (ManagedSession session tid) = do+  liftIO $ killThread tid+  I.destroySession ccManager ccHostname ccPort session Nothing
+ src/Network/Consul/Internal.hs view
@@ -0,0 +1,282 @@+{-# LANGUAGE OverloadedStrings #-}++module Network.Consul.Internal (+  --Key-Value Store+    deleteKey+  , getKey+  , getKeys+  , listKeys+  , putKey+  , putKeyAcquireLock+  , putKeyReleaseLock++  --Agent+  , deregisterHealthCheck+  , deregisterService+  , failHealthCheck+  , passHealthCheck+  , registerHealthCheck+  , registerService+  , warnHealthCheck++  --Health+  , getServiceChecks+  , getServiceHealth++  -- Session+  , createSession+  , destroySession+  , renewSession++  --Catalog+  , getDatacenters+  ) 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.Lazy as BL+import Data.Maybe+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE+import Data.Word+import Network.Consul.Types+import Network.HTTP.Client+import Network.Socket (PortNumber(..))++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+                         ,maybe "" id query, prefixAnd, maybe "" (\ (Datacenter x) -> T.concat["dc=",x]) dc]+  initReq <- liftIO $ parseUrl $ T.unpack baseUrl+  case body of+    Just x -> return $ indef $ initReq{ method = "PUT", requestBody = RequestBodyBS x, checkStatus = \ _ _ _ -> Nothing}+    Nothing -> return $ indef $ initReq{checkStatus = \ _ _ _ -> Nothing}+  where+    needQueryString = if isJust dc || isJust query then "?" else ""+    prefixAnd = if isJust query && isJust dc then "&" else ""+    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 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+    case responseStatus response of+      _status200 -> do+        bodyParts <- brConsume $ responseBody response+        let body = B.concat bodyParts+        return $ listToMaybe =<< (decode $ BL.fromStrict body)+      _ -> return Nothing+  where+    cons = fmap (\ x -> T.concat["consistency=", T.pack $ show x] ) consistency+    ind = fmap (\ x -> T.concat["index=", T.pack $ show x]) index+    query = T.intercalate "&" $ catMaybes [cons,ind]+    fquery = if query /= T.empty then Just query else Nothing++getKeys :: MonadIO m => Manager -> Text -> PortNumber -> Text -> Maybe Word64 -> Maybe Consistency -> Maybe Datacenter -> m [KeyValue]+getKeys 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+    case responseStatus response of+      _status200 -> do+        bodyParts <- brConsume $ responseBody response+        let body = B.concat bodyParts+        return $ maybe [] id $ decode $ BL.fromStrict body+      _ -> return []+  where+    cons = fmap (\ x -> T.concat["consistency=", T.pack $ show x] ) consistency+    ind = fmap (\ x -> T.concat["index=", T.pack $ show x]) index+    query = T.intercalate "&" $ catMaybes [cons,ind, Just "recurse"]+    fquery = if query /= T.empty then Just query else Nothing+++listKeys :: MonadIO m => Manager -> Text -> PortNumber -> Text -> Maybe Word64 -> Maybe Consistency -> Maybe Datacenter -> m [Text]+listKeys manager hostname portNumber prefix index consistency dc = do+  initReq <- createRequest hostname portNumber (T.concat ["/v1/kv/", prefix]) fquery Nothing (isJust index) dc+  liftIO $ withResponse initReq manager $ \ response ->+    case responseStatus response of+      _status200 -> do+        bodyParts <- brConsume $ responseBody response+        let body = B.concat bodyParts+        return $ maybe [] id $ decode $ BL.fromStrict body+      _ -> return []+  where+    cons = fmap (\ x -> T.concat["consistency=", T.pack $ show x] ) consistency+    ind = fmap (\ x -> T.concat["index=", T.pack $ show x]) index+    query = T.intercalate "&" $ catMaybes [cons,ind, Just "keys"]+    fquery = if query /= T.empty then Just query else Nothing++putKey :: MonadIO m => Manager -> Text -> PortNumber -> KeyValuePut -> Maybe Datacenter -> m Bool+putKey manager hostname portNumber request dc = do+  initReq <- createRequest hostname portNumber (T.concat ["/v1/kv/", kvpKey request]) fquery (Just $ kvpValue request) False dc+  liftIO $ withResponse initReq manager $ \ response -> do+    bodyParts <- brConsume $ responseBody response+    let body = B.concat bodyParts+    case TE.decodeUtf8 body of+      "true" -> return True+      "false" -> return False+      _ -> return False+  where+    flags = fmap (\ x -> T.concat["flags=", T.pack $ show x]) $ kvpFlags request+    cas = fmap (\ x -> T.concat["cas=",T.pack $ show x]) $ kvpCasIndex request+    query = T.intercalate "&" $ catMaybes [flags,cas]+    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+  liftIO $ withResponse initReq manager $ \ response -> do+    bodyParts <- brConsume $ responseBody response+    let body = B.concat bodyParts+    case TE.decodeUtf8 body of+      "true" -> return True+      "false" -> return False+      _ -> return False+  where+    flags = fmap (\ x -> T.concat["flags=", T.pack $ show x]) $ kvpFlags request+    cas = fmap (\ x -> T.concat["cas=",T.pack $ show x]) $ kvpCasIndex request+    acquire = T.concat["acquire=",session]+    query = T.intercalate "&" $ catMaybes [flags,cas,Just acquire]+    fquery = if query /= T.empty then Just query else Nothing++putKeyReleaseLock :: MonadIO m => Manager -> Text -> PortNumber -> KeyValuePut -> Session -> Maybe Datacenter -> m Bool+putKeyReleaseLock manager hostname portNumber request (Session session _) dc = do+  initReq <- createRequest hostname portNumber (T.concat ["/v1/kv/", kvpKey request]) fquery (Just $ kvpValue request) False dc+  liftIO $ withResponse initReq manager $ \ response -> do+    bodyParts <- brConsume $ responseBody response+    let body = B.concat bodyParts+    case TE.decodeUtf8 body of+      "true" -> return True+      "false" -> return False+      _ -> return False+  where+    flags = fmap (\ x -> T.concat["flags=", T.pack $ show x]) $ kvpFlags request+    cas = fmap (\ x -> T.concat["cas=",T.pack $ show x]) $ kvpCasIndex request+    release = T.concat["release=",session]+    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 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 ()++{- Agent -}+{-getHealthChecks :: MonadIO m => Manager -> Text -> PortNumber -> Maybe Datacenter -> m [Check]+getHealthChecks  manager hostname portNumber dc = do+  request <- createRequest hostname portNumber "/agent/checks" Nothing Nothing False dc+ -}++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"]+  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]+  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]+  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]+  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]+  liftIO $ withResponse initReq manager $ \ response -> do+    _bodyParts <- brConsume $ responseBody response+    return ()++registerService :: MonadIO m => Manager -> Text -> PortNumber -> RegisterService -> m ()+registerService manager hostname (PortNum portNumber) request = do+  initReq <- liftIO $ parseUrl $ T.unpack $ T.concat ["http://",hostname, ":", T.pack $ show portNumber ,"/v1/agent/service/register"]+  let httpReq = initReq { method = "PUT", requestBody = RequestBodyBS $ BL.toStrict $ encode request}+  liftIO $ withResponse httpReq manager $ \ response -> do+    _bodyParts <- brConsume $ responseBody response+    return ()++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]+  liftIO $ withResponse initReq manager $ \ response -> do+    _bodyParts <- brConsume $ responseBody response+    return ()+++{- 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]+  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]+  liftIO $ withResponse initReq manager $ \ response -> do+    bodyParts <- brConsume $ responseBody response+    let body = B.concat bodyParts+    return $ decode $ BL.fromStrict body++{- Session -}+createSession :: MonadIO m => Manager -> Text -> PortNumber -> SessionRequest -> Maybe Datacenter -> m (Maybe Session)+createSession manager hostname portNumber request dc = do+  initReq <- createRequest hostname portNumber "/v1/session/create" Nothing (Just $ BL.toStrict $ encode request) False dc+  liftIO $ withResponse initReq manager $ \ response -> do+    case responseStatus response of+      status200 -> do+        bodyParts <- brConsume $ responseBody response+        return $ decode $ BL.fromStrict $ B.concat bodyParts+      _ -> return Nothing++destroySession :: MonadIO m => Manager -> Text -> PortNumber -> Session -> Maybe Datacenter -> m ()+destroySession manager hostname portNumber (Session session _) dc = do+  initReq <- createRequest hostname portNumber (T.concat ["/v1/session/destroy/", session]) Nothing Nothing False dc+  liftIO $ withResponse initReq manager $ \ response -> do+    return ()++renewSession :: MonadIO m => Manager -> Text -> PortNumber -> Session -> Maybe Datacenter -> m Bool+renewSession manager hostname portNumber (Session session _) dc = do+  initReq <- createRequest hostname portNumber (T.concat ["/v1/session/renew/", session]) Nothing Nothing False dc+  liftIO $ withResponse initReq manager $ \ response -> do+    case responseStatus response of+      status200 -> return True+      _ -> return False++{- 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/"]+  withResponse initReq manager $ \ response -> do+    bodyParts <- brConsume $ responseBody response+    let body = B.concat bodyParts+    let val = (decode $ BL.fromStrict body)+    case val of+      Just x -> return x+      Nothing -> return []+
+ src/Network/Consul/Types.hs view
@@ -0,0 +1,189 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+module Network.Consul.Types (+  Check(..),+  Consistency(..),+  ConsulClient(..),+  Datacenter (..),+  Health(..),+  KeyValue(..),+  KeyValuePut(..),+  RegisterRequest(..),+  RegisterHealthCheck(..),+  RegisterService(..),+  Session(..),+  SessionBehavior(..),+  SessionRequest(..)+) where++import Control.Applicative+import Control.Monad+import Data.Aeson+import Data.ByteString (ByteString)+import qualified Data.ByteString.Base64 as B64+import Data.Int+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+}++data Datacenter = Datacenter Text deriving (Eq,Show,Ord)++data Consistency = Consistent | Default | Stale deriving (Eq,Show,Enum,Ord)++data HealthCheckStatus = Critical | Passing | Unknown | Warning deriving (Eq,Show,Enum,Ord)++data SessionBehavior = Release | Delete deriving (Eq,Show,Enum,Ord)++data KeyValue = KeyValue {+  kvCreateIndex :: Word64,+  kvLockIndex :: Word64,+  kvModifyIndex :: Word64,+  kvValue :: ByteString,+  kvFlags :: Word64,+  kvSession :: Maybe Text,+  kvKey :: Text+} deriving (Show,Eq)++data KeyValuePut = KeyValuePut {+  kvpKey :: Text,+  kvpValue :: ByteString,+  kvpCasIndex :: Maybe Word64,+  kvpFlags :: Maybe Word64+}++data Session = Session {+  sId :: Text,+  sCreateIndex :: Maybe Word64+}++data SessionRequest = SessionRequest {+  srLockDelay :: Maybe Text,+  srName :: Maybe Text,+  srNode :: Maybe Node,+  srChecks :: [Text],+  srBehavor :: Maybe SessionBehavior,+  srTtl :: Maybe Int+}++data RegisterRequest = RegisterRequest {+  rrDatacenter :: Maybe Datacenter,+  rrNode :: Text,+  rrAddress :: Text,+  rrService :: Maybe Service,+  rrCheck :: Maybe Check+}++data Service = Service {+  seId :: Text,+  seService :: Text,+  seTags :: [Text],+  sePort :: Maybe Int+}++data Check = Check {+  cNode :: Text,+  cCheckId :: Text,+  cName :: Maybe Text,+  cNotes :: Maybe Text,+  cServiceId :: Maybe Text,+  cStatus :: HealthCheckStatus,+  cOutput :: Text,+  cServiceName :: Text+}++data Node = Node {+  nNode :: Text,+  nAddress :: Text+}++{- Agent -}+data RegisterHealthCheck = RegisterHealthCheck {+  rhcId :: Text,+  rhcName :: Text,+  rhcNotes :: Text,+  rhcScript :: Maybe Text,+  rhcInterval :: Maybe Text,+  rhcTtl :: Maybe Text+}++data RegisterService = RegisterService {+  rsId :: Maybe Text,+  rsName :: Text,+  rsTags :: [Text],+  rsPort :: Maybe Int16,+  rsCheck :: Either (Text,Text) Text -- (script,interval) ttl+}++{- Health -}+data Health = Health {+  hNode :: Node,+  hService :: Service,+  hChecks :: [Check]+}+++{- JSON Instances -}+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 _ = 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"+  parseJSON _ = mzero++instance FromJSON Datacenter where+  parseJSON (String val) = pure $ Datacenter val+  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 _ = mzero++instance FromJSON Service where+  parseJSON (Object x) = Service <$> x .: "Id" <*> x .: "Service" <*> x .: "Tags" <*> x .: "Port"+  parseJSON _ = mzero++instance FromJSON Node where+  parseJSON (Object x) = Node <$> x .: "Node" <*> x .: "Address"+  parseJSON _ = mzero++instance FromJSON Health where+  parseJSON (Object x) = Health <$> x.: "Node" <*> x .: "Service" <*> x .: "Checks"+  parseJSON _ = mzero++instance FromJSON Session where+  parseJSON (Object x) = Session <$> x .: "ID" <*> pure Nothing+  parseJSON _ = mzero++instance ToJSON SessionBehavior where+  toJSON Release = String "release"+  toJSON Delete = String "delete"++instance ToJSON RegisterHealthCheck where+  toJSON (RegisterHealthCheck id name notes script interval ttl) = object ["id" .= id, "name" .= name, "notes" .= notes, "script" .= script, "interval" .= interval, "ttl" .= ttl]++instance ToJSON RegisterService where+  toJSON (RegisterService id name tags port check) = object ["ID" .= id, "Name" .= name, "Tags" .= tags, "Port" .= port, "Check" .= check]++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]++foo :: Monad m => Either String a -> m a+foo (Left x) = trace "failing" $ fail x+foo (Right x) = return x
+ tests/Main.hs view
@@ -0,0 +1,93 @@+{-# LANGUAGE OverloadedStrings #-}+import Network.Consul.Types+import qualified Network.Consul.Internal as I+import Network.HTTP.Client+import Network.Socket (PortNumber(..))+import Test.Tasty+import Test.Tasty.HUnit++manager :: IO Manager+manager = newManager defaultManagerSettings++{- Internal Tests -}+internalKVTests :: TestTree+internalKVTests = testGroup "Internal Key Value" [testGetInvalidKey, testPutKey, +  testGetKey,testGetKeys,testListKeys,testDeleteKey]++testGetInvalidKey :: TestTree+testGetInvalidKey = testCase "testGetInvalidKey" $ do+  man <- manager+  x <- I.getKey man "localhost" (PortNum 8500) "nokey" Nothing Nothing Nothing+  assertEqual "testGetInvalidKey: Found a key that doesn't exist" x Nothing++testPutKey :: TestTree+testPutKey = testCase "testPutKey" $ do+  man <- manager+  let put = KeyValuePut "/testPutKey" "Test" Nothing Nothing+  x <- I.putKey man "localhost" (PortNum 8500) put Nothing+  assertEqual "testPutKey: Write failed" True x++testGetKey :: TestTree+testGetKey = testCase "testGetKey" $ do+  man <- manager+  let put = KeyValuePut "/testGetKey" "Test" Nothing Nothing+  x1 <- I.putKey man "localhost" (PortNum 8500) put Nothing+  assertEqual "testGetKey: Write failed" True x1+  x2 <- I.getKey man "localhost" (PortNum 8500) "/testGetKey" Nothing Nothing Nothing+  case x2 of+    Just x -> assertEqual "testGetKey: Incorrect Value" (kvValue x) "Test"+    Nothing -> assertFailure "testGetKey: No value returned"++testGetKeys :: TestTree+testGetKeys = testCase "testGetKeys" $ do+  man <- manager+  let put1 = KeyValuePut "/testGetKeys/key1" "Test" Nothing Nothing+  x1 <- I.putKey man "localhost" (PortNum 8500) 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+  assertEqual "testGetKeys: Write failed" True x2+  x3 <- I.getKeys man "localhost" (PortNum 8500) "/testGetKeys" Nothing Nothing Nothing+  assertEqual "testGetKeys: Incorrect number of results" 2 (length x3)++testListKeys :: TestTree+testListKeys = testCase "testListKeys" $ do+  man  <- manager+  let put1 = KeyValuePut "/testListKeys/key1" "Test" Nothing Nothing+  x1 <- I.putKey man "localhost" (PortNum 8500) 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+  assertEqual "testListKeys: Write failed" True x2+  x3 <- I.listKeys man "localhost" (PortNum 8500) "/testListKeys/" Nothing Nothing Nothing+  assertEqual "testListKeys: Incorrect number of results" 2 (length x3)++testDeleteKey :: TestTree+testDeleteKey = testCase "testDeleteKey" $ do+  man  <- manager+  let put1 = KeyValuePut "/testDeleteKey" "Test" Nothing Nothing+  x1 <- I.putKey man "localhost" (PortNum 8500) 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+  assertEqual "testDeleteKey: Key was not deleted" Nothing x2++{- Agent -}+testRegisterService :: TestTree+testRegisterService = testCase "testRegisterService" $ do+  man <- manager+  let req = RegisterService Nothing "testService" ["test"] Nothing (Right "10s")+  I.registerService man "localhost" (PortNum 8500) req+{-+testRegisterHealthCheck :: TestTree+testRegisterHealthCheck = testCase "testRegisterHealthCheck" $ do+  man <- manager+  let check = RegisterHealthCheck "testHealthCheck" "testHealthCheck" "" Nothing Nothing (Just "15s")+  x1 <- I.registerHealthCheck man "localhost" (PortNum 8500) check+  undefined -}++{- Health Checks -}+--testServiceChecks :: ++main :: IO ()+main = defaultMain internalKVTests