diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2015, FPComplete and Contributors + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be +included in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE +LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION +OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION +WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,114 @@ +# WAI Consul Middleware + +![TravisCI](https://travis-ci.org/fpco/wai-middleware-consul.svg) +![Hackage](https://img.shields.io/hackage/v/wai-middleware-consul.svg) + +This library assists you in monitoring Consul k/v data & with +proxying data to Consul safely from the Internet. The first use +case is receiving Github 'push' notifications when a repository is +updated and doing a git pull on all webservers to update content. +The [example](./example) app shows GitHub Webhooks working. + + ┌─────────┐ ┌─────────┐ + │ Github │ │ │ + │ Repo │─────▶│ AWS ELB │ + │ Webhook │ │ │ + └─────────┘ └─────────┘ + │ + ┌────────────┬──────┘─ ─ ─ + │ │ + ▼ ▼ ▼ + ┌─────────┐ ┌─────────┐ ┌─────────┐ + │ │ │ │ │ │ + ┌──│ WAI App │ │ WAI App │ │ WAI App │ + │ │ │ │ │ │ │ + │ └─────────┘ └─────────┘ └─────────┘ + │ ▲ ▲ + │ │ │ + │ ┌────────────┴────────────┘ + │ │ + │ │ + │ ┌─────────┐ ┌─────────┐ ┌─────────┐ + │ │ │ │ │ │ │ + └─▶│ Consul │──│ Consul │──│ Consul │ + │ │ │ │ │ │ + └─────────┘ └─────────┘ └─────────┘ + +## Install + + cabal install wai-middleware-consul + +Or if you want to play with the example github webhook web-app: + + cabal install -fexample wai-middleware-consul + +## Example + +You'll need to launch a small Consul cluster to try the example app. +It's easy to do with Docker. Please use the following steps: + +### Launch 4 containers of Docker w/ Consul running on each + + docker run -d --name node1 -h node1 progrium/consul -server -bootstrap-expect 3 + sleep 10 + JOIN_IP="$(docker inspect -f '{{.NetworkSettings.IPAddress}}' node1)" + docker run -d --name node2 -h node2 progrium/consul -server -join $JOIN_IP + docker run -d --name node3 -h node3 progrium/consul -server -join $JOIN_IP + docker run -d -p 8400:8400 -p 8500:8500 -p 8600:53/udp --name node4 -h node4 progrium/consul -join $JOIN_IP + sleep 10 + +1. Try out all the interfaces of Consul + + 1. Browse the [Web UI Interface](http://localhost:8500/ui/#/dc1/services/consul) + + 2. Query Consul at the command line + + consul members + + 3. Query the HTTP Interface + + curl 0.0.0.0:8500/v1/catalog/nodes + + 4. Query the DNS Interface + + dig @0.0.0.0 -p 8600 node1.node.consul + +### Setting up a Github Webhook + +First we start \`ngrok\` to proxy HTTP requests from the Internet to +our local machine (most likely behind a firewall). Then we'll start +the example web application to receive webhooks from Github. + +Run the example application (in the root Github directory for +wai-middleware-consul). We need to be in this directory so our +example app can find/read cabal & Github version status. + + ./.cabal-sandbox/bin/wai-middleware-consul-example + +Try navigating to the example app page. + +Run ngrok to expose the example application to the Internet: + + ngrok 8080 ;# take note of this public web address for Github + +Set up the webhook for the repo on Github. Point it to the ngrok web +address and add the path /github onto that URL ( eg, + ). This is the specific route in +the example application for Github->Consul data updates. + +Now that we have the application running and a proxy to the public +Internet established, we can receive webhook events. + +Try pushing to the repository. You should see notifications that an +event was received in the web application STDOUT log. The event +should be pushed into Consul also. The web application will be +listening to events from Consul & this will fire also. You should +see it try to \`git pull\` the repository & you should see the changes +if you refresh the home page of the example app. + +### Cleanup (kill & remove Consul containers) + + for n in $(seq 1 4); do + docker kill node$n + docker rm node$n + done diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/example/Main.hs b/example/Main.hs new file mode 100644 --- /dev/null +++ b/example/Main.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} + +import BasePrelude +import Control.Monad.IO.Class ( MonadIO(liftIO) ) +import Control.Monad.Logger ( runStdoutLoggingT ) +import Network.Wai.Application.Static + ( staticApp, defaultWebAppSettings ) +import Network.Wai.Handler.Warp ( run ) +import Network.Wai.Middleware.Consul ( withConsul ) +import Network.Wai.Middleware.Consul.GitHub ( gitHubPullOnWebhook ) +import Network.Wai.Middleware.RequestLogger ( logStdoutDev ) + +main :: IO () +main = + runStdoutLoggingT + (void (withConsul + gitHubPullOnWebhook + (\middleware -> + liftIO (run 8080 + (logStdoutDev $ + middleware $ + staticApp $ + defaultWebAppSettings "."))))) diff --git a/src/Network/Wai/Middleware/Consul.hs b/src/Network/Wai/Middleware/Consul.hs new file mode 100644 --- /dev/null +++ b/src/Network/Wai/Middleware/Consul.hs @@ -0,0 +1,252 @@ +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} + +{-| +Module : Network.Wai.Middleware.Consul +Description : WAI Middleware for Consul +Copyright : (c) FPComplete, 2015 +License : MIT +Maintainer : Tim Dysinger +Stability : experimental +Portability : POSIX + +This module helps you proxy information to Consul from the internet & +also react to changes to K/V data coming from Consul. + +@ + ┌─────────┐ ┌─────────┐ + │ JSON │ │ LOAD │ + │ HTTP │─────▶│ BALANCR │ + │ POST │ │ │ + └─────────┘ └─────────┘ + │ + ┌────────────┬──────┘─ ─ ─ + │ │ + ▼ ▼ ▼ + ┌─────────┐ ┌─────────┐ ┌─────────┐ + │ │ │ │ │ │ +┌──│ WAI App │ │ WAI App │ │ WAI App │ +│ │ │ │ │ │ │ +│ └─────────┘ └─────────┘ └─────────┘ +│ ▲ ▲ +│ │ │ +│ ┌────────────┴────────────┘ +│ │ +│ │ +│ ┌─────────┐ ┌─────────┐ ┌─────────┐ +│ │ │ │ │ │ │ +└─▶│ Consul │──│ Consul │──│ Consul │ + │ │ │ │ │ │ + └─────────┘ └─────────┘ └─────────┘ +@ +-} + +module Network.Wai.Middleware.Consul + ( ConsulSettings + , defaultConsulSettings + , getConsulCallback + , getConsulFilter + , getConsulHost + , getConsulKey + , getConsulLimit + , getConsulPort + , mkConsulProxy + , mkConsulWatch + , setConsulCallback + , setConsulFilter + , setConsulHost + , setConsulKey + , setConsulLimit + , setConsulPort + , withConsul + ) where + +import BasePrelude +import Control.Concurrent.Async ( race ) +import Control.Exception.Enclosed ( catchAny ) +import Control.Monad.IO.Class ( MonadIO(..), liftIO ) +import Control.Monad.Logger ( MonadLoggerIO, logWarn ) +import Control.Monad.Trans.Control + ( MonadBaseControl(liftBaseWith, restoreM) ) +import Control.Monad.Trans.Resource ( runResourceT ) +import qualified Data.ByteString.Lazy as LB ( toStrict ) +import Data.Conduit ( ($$) ) +import Data.Void ( Void(..), absurd ) +import qualified Data.Conduit.Binary as C ( take ) +import Data.Text ( Text ) +import qualified Data.Text as T ( pack ) +import Network.Consul + ( KeyValue(kvModifyIndex), + KeyValuePut(KeyValuePut, kvpCasIndex, kvpFlags, kvpKey, kvpValue), + putKey, + initializeConsulClient, + getKey ) +import Network.HTTP.Client + ( defaultManagerSettings, managerResponseTimeout ) +import Network.HTTP.Types ( status201, methodPost ) +import Network.Socket ( PortNumber(PortNum) ) +import Network.Wai + ( Middleware, Request, responseBuilder, pathInfo, requestMethod ) +import Network.Wai.Conduit ( sourceRequestBody ) + +-- | Consul Settings for watching & proxying Consul data +data ConsulSettings = + ConsulSettings {csHost :: Text -- ^ Consul host address + ,csPort :: PortNumber -- ^ Consul host port + ,csKey :: Text -- ^ Consul key + ,csFilter :: Request -> Bool -- ^ Filter for proxy put + ,csLimit :: Maybe Int -- ^ Optional request body size limit + ,csCallback :: ConsulCallback -- ^ Callback when data changes + } + +type ConsulCallback = forall (m :: * -> *). + (MonadBaseControl IO m,MonadLoggerIO m) => KeyValue -> m () + +defaultConsulSettings :: ConsulSettings +defaultConsulSettings = + ConsulSettings {csHost = "0.0.0.0" + ,csPort = PortNum 8500 + ,csKey = "wai" + ,csFilter = + (\req -> + (requestMethod req == methodPost) && + (pathInfo req == + ["wai"])) + ,csLimit = Nothing + ,csCallback = liftIO . print} + +setConsulHost :: Text -> ConsulSettings -> ConsulSettings +setConsulHost a b = b { csHost = a } + +getConsulHost :: ConsulSettings -> Text +getConsulHost = csHost + +setConsulPort :: PortNumber -> ConsulSettings -> ConsulSettings +setConsulPort a b = b { csPort = a } + +getConsulPort :: ConsulSettings -> PortNumber +getConsulPort = csPort + +setConsulKey :: Text -> ConsulSettings -> ConsulSettings +setConsulKey a b = b { csKey = a } + +getConsulKey :: ConsulSettings -> Text +getConsulKey = csKey + +setConsulFilter :: (Request -> Bool) -> ConsulSettings -> ConsulSettings +setConsulFilter a b = b { csFilter = a } + +getConsulFilter :: ConsulSettings -> Request -> Bool +getConsulFilter = csFilter + +setConsulLimit :: Maybe Int -> ConsulSettings -> ConsulSettings +setConsulLimit a b = b { csLimit = a } + +getConsulLimit :: ConsulSettings -> Maybe Int +getConsulLimit = csLimit + +setConsulCallback :: ConsulCallback -> ConsulSettings -> ConsulSettings +setConsulCallback a b = b { csCallback = a } + +getConsulCallback :: ConsulSettings -> ConsulCallback +getConsulCallback = csCallback + +-- | Creates a complete Consul middleware for the cluster. +-- Combines mkConsulWatch async function (watches Consul data for +-- updates) & mkConsulProxy (proxys data from the internet to Consul) +-- into one common-use function. This will probably be the function +-- you want. See the example/ application for more insight. +withConsul :: (Monad m,MonadBaseControl IO m,MonadLoggerIO m) + => ConsulSettings -> (Middleware -> m a) -> m a +withConsul cs f = + fmap (either absurd id) + (liftRace (mkConsulWatch cs) + (mkConsulProxy cs >>= f)) + +liftRace :: MonadBaseControl IO m + => m a -> m b -> m (Either a b) +liftRace x y = + do res <- + liftBaseWith + (\run -> + race (run x) + (run y)) + case res of + Left x' -> Left <$> restoreM x' + Right y' -> Right <$> restoreM y' + +-- | Creates a background process to receive notifications. +-- Notifications happen via blocking HTTP request. (The HTTP client +-- manager used has been configured to wait forever for a response.) +-- The ConsulSettings (csHost, csPort & csKey) are used to connect to +-- Consul and watch for key-value changes. When Consul's value +-- changes, it will respond to the HTTP request. Upon receiving a +-- good changed-value response, we fire the csCallback function to +-- allow for a reaction to the data change. If there there is a +-- problem with the request/response cycle or an exception in the +-- supplied callback function, we just re-make the rquest & wait +-- patiently for changes again. +mkConsulWatch :: (MonadBaseControl IO m,MonadLoggerIO m) + => ConsulSettings -> m Void +mkConsulWatch cs = + initializeConsulClient (csHost cs) + (csPort cs) + Nothing >>= + go 0 >>= + pure . absurd -- this function shouldn't exit under normal circumstances + where go idx' cc = + catchAny (do kv <- + getKey cc + (csKey cs) + (Just idx') + Nothing + Nothing + case kv of + Nothing -> + do liftIO (threadDelay $ 1000 * 1000) + go idx' cc + (Just kv') -> + do (csCallback cs $ kv') + go (kvModifyIndex kv') cc) + (\ex -> + do liftIO (threadDelay $ 1000 * 1000) + $(logWarn) (T.pack $ show ex) + go idx' cc) + +-- | Create WAI middleware that can be used to proxy incoming data +-- into Consul (one-way). This function initiates our consul client +-- and returns the middleware for WAI to use. The middleware will +-- filter incoming requests that match ConsulSettings csFilter. If +-- there is a match it will create a make the key value put call for +-- Consul using the incoming request body as the data for the Consul +-- K/V. +mkConsulProxy :: (MonadIO m,Functor m) + => ConsulSettings -> m Middleware +mkConsulProxy cs = + proxyToConsul <$> + initializeConsulClient (csHost cs) + (csPort cs) + Nothing + where proxyToConsul cc app' req respond + | csFilter cs req = + do bs <- + liftIO (runResourceT $ + sourceRequestBody req $$ + C.take (fromMaybe 5242880 (csLimit cs))) + let keyValuePut = + KeyValuePut {kvpKey = csKey cs + ,kvpValue = LB.toStrict bs + ,kvpCasIndex = Nothing + ,kvpFlags = Nothing} + _workedOK <- + putKey cc keyValuePut Nothing + -- TODO respond negatively if Consul 'put' didn't work + respond (responseBuilder status201 [] "") + | otherwise = app' req respond diff --git a/src/Network/Wai/Middleware/Consul/GitHub.hs b/src/Network/Wai/Middleware/Consul/GitHub.hs new file mode 100644 --- /dev/null +++ b/src/Network/Wai/Middleware/Consul/GitHub.hs @@ -0,0 +1,106 @@ +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +{-| +Module : Network.Wai.Middleware.Consul +Description : WAI Middleware for Consul +Copyright : (c) FPComplete, 2015 +License : MIT +Maintainer : Tim Dysinger +Stability : experimental +Portability : POSIX + +This module contains specific configuration for using WAI Middleware +for Consul with Github. We can configure a GitHub Webhook to POST to +consul middleware. Consul middleware will push the GitHub webhook +payload to Consul. Consul will let every WAI application know of the +data update & each application will execute `git pull` to update their +git repository contents. + +@ + ┌─────────┐ ┌─────────┐ + │ Github │ │ │ + │ Repo │─────▶│ AWS ELB │ + │ Webhook │ │ │ + └─────────┘ └─────────┘ + │ + ┌────────────┬──────┘─ ─ ─ + │ │ + ▼ ▼ ▼ + ┌─────────┐ ┌─────────┐ ┌─────────┐ + │ │ │ │ │ │ +┌──│ WAI App │ │ WAI App │ │ WAI App │ +│ │ │ │ │ │ │ +│ └─────────┘ └─────────┘ └─────────┘ +│ ▲ ▲ +│ │ │ +│ ┌────────────┴────────────┘ +│ │ +│ │ +│ ┌─────────┐ ┌─────────┐ ┌─────────┐ +│ │ │ │ │ │ │ +└─▶│ Consul │──│ Consul │──│ Consul │ + │ │ │ │ │ │ + └─────────┘ └─────────┘ └─────────┘ +@ +-} + +module Network.Wai.Middleware.Consul.GitHub + (gitHubPullOnWebhook) + where + +import BasePrelude + +import Control.Monad.IO.Class ( liftIO ) +import qualified Data.ByteString as B ( isPrefixOf ) +import Network.HTTP.Types ( methodPost, hUserAgent ) +import Network.Wai + ( Request(pathInfo, requestHeaders, requestMethod) ) +import Network.Wai.Middleware.Consul + ( ConsulSettings, + defaultConsulSettings, + setConsulKey, + setConsulFilter, + setConsulCallback ) +import System.Process ( callProcess ) + +-- | GitHub Webhook handler with Consul callback that does a `git pull` +-- when fired. +gitHubPullOnWebhook :: ConsulSettings +gitHubPullOnWebhook = + (setConsulKey "github" . + setConsulFilter isGitHubWebhook . + setConsulCallback + (\_ -> + liftIO (callProcess "git" + ["pull"]))) defaultConsulSettings + +isGitHubWebhook :: Request -> Bool +isGitHubWebhook req = + (requestMethod req == methodPost) && + -- https://developer.github.com/webhooks/#delivery-headers "When + -- one of those events is triggered, we’ll send a HTTP POST + -- payload to the webhook’s configured URL." + (pathInfo req == + ["github"]) && + -- "X-Github-Event: Name of the event that triggered this + -- delivery." + (lookup' "X-Github-Event" (requestHeaders req) == + ["push"]) && + -- "X-Hub-Signature: HMAC hex digest of the payload, using the + -- hook’s secret as the key (if configured)." + (lookup' "X-Hub-Signature" (requestHeaders req) /= + []) && -- FIXME: Validate HMAC + -- "X-Github-Delivery: Unique ID for this delivery." + (lookup' "X-Github-Delivery" (requestHeaders req) /= + []) && + -- "Also, the User-Agent for the requests will have the prefix + -- GitHub-Hookshot/" + case lookup' hUserAgent (requestHeaders req) of + [agent] -> "GitHub-Hookshot/" `B.isPrefixOf` agent + _ -> False + where lookup' a = + map snd . + filter (\x -> a == fst x) diff --git a/wai-middleware-consul.cabal b/wai-middleware-consul.cabal new file mode 100644 --- /dev/null +++ b/wai-middleware-consul.cabal @@ -0,0 +1,66 @@ +name: wai-middleware-consul +version: 0.1.0.0 +homepage: https://github.com/fpco/wai-middleware-consul +synopsis: Wai Middleware for Consul +description: Proxies data to/from Consul. Watches for updates. +category: Network +license: MIT +license-file: LICENSE +author: FP Complete Developers +maintainer: dev@fpcomplete.com +build-type: Simple +extra-source-files: README.md +cabal-version: >=1.10 + +flag example + description: enable example-app executable + default: False + +source-repository head + type: git + location: https://github.com/fpco/wai-middleware-consul + +library + default-language: Haskell2010 + hs-source-dirs: src + exposed-modules: Network.Wai.Middleware.Consul + , Network.Wai.Middleware.Consul.GitHub + build-depends: async + , base >=4 && <5 + , base-prelude + , bytestring + , conduit + , conduit-extra + , consul-haskell + , enclosed-exceptions + , http-client + , http-types + , monad-control + , monad-logger + , network + , process + , resourcet + , text + , transformers + , void + , wai + , wai-conduit + +executable wai-middleware-consul-example + if flag(example) + buildable: True + else + buildable: False + default-language: Haskell2010 + hs-source-dirs: example + main-is: Main.hs + build-depends: async + , base >=4 && <5 + , base-prelude + , monad-logger + , transformers + , wai + , wai-app-static + , wai-extra + , wai-middleware-consul + , warp