prodapi-proxy (empty) → 0.1.0.0

raw patch · 10 files changed

+405/−0 lines, 10 filesdep +aesondep +basedep +bytestringsetup-changed

Dependencies added: aeson, base, bytestring, containers, http-client, http-reverse-proxy, http-types, prodapi, prometheus-client, random-shuffle, servant, servant-server, text, time, tls, wai, warp-tls

Files

• CHANGELOG.md +5/−0
• LICENSE +30/−0
• Setup.hs +3/−0
• prodapi-proxy.cabal +51/−0
• src/Prod/Proxy.hs +11/−0
• src/Prod/Proxy/Base.hs +86/−0
• src/Prod/Proxy/Compat.hs +19/−0
• src/Prod/Proxy/Lookups.hs +53/−0
• src/Prod/Proxy/MultiApp.hs +69/−0
• src/Prod/Proxy/R.hs +78/−0

@@ -0,0 +1,5 @@+# Revision history for prodapi-userauth++## 0.1.0.0 -- YYYY-mm-dd++* First version. Released on an unsuspecting world.

@@ -0,0 +1,30 @@+Copyright Lucas DiCioccio (c) 2021++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 name of Author name here nor the names of other+      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.

@@ -0,0 +1,3 @@+import Distribution.Simple++main = defaultMain

@@ -0,0 +1,51 @@+cabal-version:       >=1.10+-- Initial package description 'prodapi-userauth.cabal' generated by 'cabal+--  init'.  For further documentation, see+-- http://haskell.org/cabal/users-guide/++name:                prodapi-proxy+version:             0.1.0.0+synopsis: write an HTTP proxy with prodapi counters+description: a library to write loadbalancers compatible with prodapi discovery and healthchecks+-- bug-reports:+license: BSD3+license-file:        LICENSE+author:              Lucas DiCioccio+maintainer:          lucas@dicioccio.fr+-- copyright:+category: System+build-type:          Simple+extra-source-files:  CHANGELOG.md++library+  exposed-modules:+      Prod.Proxy+      Prod.Proxy.Base+      Prod.Proxy.Compat+      Prod.Proxy.Lookups+      Prod.Proxy.MultiApp+      Prod.Proxy.R+      Paths_prodapi_proxy+  default-extensions: OverloadedStrings DataKinds TypeApplications TypeOperators+  build-depends:+    aeson >= 2.2.1 && < 2.3,+    base >= 4.19.1 && < 4.20,+    containers >= 0.6.8 && < 0.7,+    bytestring >= 0.12.1 && < 0.13,+    text >= 2.1.1 && < 2.2,+    time >= 1.12.2 && < 1.13,+    http-client >= 0.7.17 && < 0.8,+    http-types >= 0.12.4 && < 0.13,+    http-reverse-proxy >= 0.6.0 && < 0.7,+    wai >= 3.2.4 && < 3.3,+    prodapi >= 0.1.0 && < 0.2,+    prometheus-client >= 1.1.1 && < 1.2,+    servant >= 0.20.1 && < 0.21,+    servant-server >= 0.20 && < 0.21,+    random-shuffle >= 0.0.4 && < 0.1,+    tls >= 2.0.5 && < 2.1,+    warp-tls >= 3.4.5 && < 3.5+  -- hs-source-dirs:+  default-language:    Haskell2010+  hs-source-dirs:+      src

@@ -0,0 +1,11 @@+module Prod.Proxy (+    module Prod.Proxy.Base,+    module Prod.Proxy.Lookups,+    module Prod.Proxy.Compat,+    module Prod.Proxy.R,+) where++import Prod.Proxy.Base+import Prod.Proxy.Compat+import Prod.Proxy.Lookups+import Prod.Proxy.R

@@ -0,0 +1,86 @@+module Prod.Proxy.Base where++import Control.Monad.IO.Class (MonadIO, liftIO)+import Data.ByteString (ByteString)+import Data.Coerce (coerce)+import qualified Data.List as List+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import Data.Ord (comparing)+import Data.Text (Text)+import qualified Data.Text.Encoding as Text+import Network.HTTP.Client as HTTP (Manager, defaultManagerSettings, newManager)+import Network.HTTP.ReverseProxy+import Network.HTTP.Types.Status (status404)+import qualified Network.Wai as Wai+import qualified Prometheus as Prometheus+import Servant+import Servant.Server++type Api = ProxyRequestApi++type ProxyRequestApi = Raw++data Counters = Counters+    { cnt_proxied_requests :: Prometheus.Counter+    }++initCounters :: IO Counters+initCounters =+    Counters+        <$> Prometheus.register (Prometheus.counter (Prometheus.Info "cnt_proxied_requests" "number of requests proxied"))++type Host = ByteString+type Port = Int++type LookupHostPort = Wai.Request -> IO (Maybe (Host, Port))++-- | Helpers to build backends WaiProxyResponse.+data Backends+    = StaticBackend Host Port+    | DynamicBackend LookupHostPort+    | WaiProxyBackend (Wai.Request -> IO WaiProxyResponse)++data Runtime = Runtime+    { counters :: Counters+    , backends :: Backends+    , httpManager :: HTTP.Manager+    }++initRuntime :: Backends -> IO Runtime+initRuntime backends =+    Runtime+        <$> initCounters+        <*> pure backends+        <*> newManager defaultManagerSettings++handle :: Runtime -> Server Api+handle rt = coerce (handleProxy rt)++handleProxy :: Runtime -> Application+handleProxy rt =+    case backends rt of+        StaticBackend host port ->+            let+                destination = const $ pure $ WPRProxyDest $ ProxyDest host port+             in+                \req rsp -> do+                    countProxiedQuery+                    waiProxyTo destination defaultOnExc (httpManager rt) req rsp+        DynamicBackend lookup ->+            \req rsp -> do+                countProxiedQuery+                dest <- lookup req+                case dest of+                    Just (host, port) -> do+                        let destination = const $ pure $ WPRProxyDest $ ProxyDest host port+                        waiProxyTo destination defaultOnExc (httpManager rt) req rsp+                    Nothing ->+                        rsp $ Wai.responseLBS status404 [] "api proxy runtime is disabled"+        WaiProxyBackend lookup ->+            \req rsp -> do+                countProxiedQuery+                waiProxyTo lookup defaultOnExc (httpManager rt) req rsp+  where+    countProxiedQuery :: IO ()+    countProxiedQuery = liftIO $ Prometheus.incCounter $ cnt_proxied_requests $ counters rt

@@ -0,0 +1,19 @@+module Prod.Proxy.Compat where++import qualified Data.Text.Encoding as Text++import qualified Prod.Healthcheck as Healthcheck+import Prod.Proxy.Base+import Prod.Proxy.Lookups+import qualified Prometheus as Prometheus++-- | Generate a list of healthy backends from an health-checked result.+pickHealthy :: Healthcheck.SummaryMap -> [(Host, Port)]+pickHealthy =+    fmap adapt . Healthcheck.healthyKeys+  where+    adapt (hcHost, port) = (Text.encodeUtf8 hcHost, port)++-- | Count successful lookups.+countWith :: Prometheus.Counter -> LookupHostPort -> LookupHostPort+countWith cnt l1 = decorateSuccessWith (const $ Prometheus.incCounter cnt) l1

@@ -0,0 +1,53 @@+module Prod.Proxy.Lookups where++import Control.Monad (when)++import Data.ByteString (ByteString)+import Data.Maybe (isJust)+import Data.Text (Text)+import qualified Data.Text.Encoding as Text+import System.Random.Shuffle (shuffleM)++import Prod.Health (Readiness (..))+import Prod.Proxy.Base++-- | Lookup that always fails.+noBackend :: LookupHostPort+noBackend = const (pure Nothing)++-- | Lookup that always returns the same value.+constBackend :: (Host, Port) -> LookupHostPort+constBackend hp = const (pure $ Just hp)++-- | Lookup the first backend among a generated list.+firstBackend :: IO [(Host, Port)] -> LookupHostPort+firstBackend disc =+    const f+  where+    f :: IO (Maybe (Host, Port))+    f = safeHead <$> disc++    safeHead :: [a] -> Maybe a+    safeHead (x : _) = Just x+    safeHead _ = Nothing++-- | Picks a random backend among a generated list.+randomBackend :: IO [(Host, Port)] -> LookupHostPort+randomBackend disc = firstBackend (disc >>= shuffleM)++-- | Fallbacks to the second lookup function if the first fails.+fallback :: LookupHostPort -> LookupHostPort -> LookupHostPort+fallback l1 l2 = \req -> do+    o1 <- l1 req+    case o1 of+        Nothing -> l2 req+        Just _ -> pure o1++-- | Decorates successful lookups with an action.+decorateSuccessWith :: ((Host, Port) -> IO ()) -> LookupHostPort -> LookupHostPort+decorateSuccessWith f l1 = \req -> do+    o1 <- l1 req+    case o1 of+        Nothing -> pure ()+        Just hp -> f hp+    pure o1

@@ -0,0 +1,69 @@+{-# LANGUAGE TupleSections #-}++-- | Set of helpers to configure WarpTLS settings.+module Prod.Proxy.MultiApp where++import Control.Applicative ((<|>))+import qualified Data.ByteString.Char8 as ByteString+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import Data.Maybe (fromMaybe)++import Network.TLS as TLS+import Network.Wai as WAI+import Network.Wai.Handler.WarpTLS as WarpTLS+import Network.Wai.Internal as WAI++-- TLS++type CredentialMap = Map TLS.HostName TLS.Credentials++type DefaultCredentials = TLS.Credentials++type X509Path = FilePath++type PrivateKeyPath = FilePath++loadCredentialMap :: [(HostName, X509Path, PrivateKeyPath)] -> IO (Either String CredentialMap)+loadCredentialMap configs = do+    loads <- traverse loadHostConfig configs+    pure $ fmap bundleMap (sequence loads)+  where+    loadHostConfig :: (HostName, X509Path, PrivateKeyPath) -> IO (Either String (HostName, Credential))+    loadHostConfig (h, x, k) = do+        c <- TLS.credentialLoadX509 x k+        pure $ fmap (h,) c+    bundleMap :: [(HostName, Credential)] -> CredentialMap+    bundleMap pairs = Map.fromListWith (<>) [(h, Credentials [c]) | (h, c) <- pairs]++type SNIHandler = Maybe HostName -> IO (Credentials)++toSNIHandler ::+    CredentialMap ->+    DefaultCredentials ->+    SNIHandler+toSNIHandler m def = \h -> case h of+    Nothing -> pure def+    Just x -> pure $ fromMaybe def $ Map.lookup x m++withTLSCredentialMap ::+    CredentialMap ->+    DefaultCredentials ->+    TLSSettings ->+    TLSSettings+withTLSCredentialMap m c tlsSetts =+    let+        hooks = (tlsServerHooks tlsSetts){onServerNameIndication = toSNIHandler m c}+     in+        tlsSetts{tlsServerHooks = hooks}++-- WEB++type ApplicationMap = Map TLS.HostName WAI.Application++routeApplication :: ApplicationMap -> WAI.Application -> WAI.Application+routeApplication apps defaultApp = \req reply -> do+    let host = ByteString.unpack <$> WAI.requestHeaderHost req+    let routedApp = host >>= flip Map.lookup apps+    let app = fromMaybe defaultApp routedApp+    app req reply

@@ -0,0 +1,78 @@+module Prod.Proxy.R where++import Control.Applicative+import Control.Monad.IO.Class+import qualified Network.Wai as Wai+import System.Random.Shuffle (shuffleM)++import qualified Prod.Healthcheck as Healthcheck+import Prod.Proxy.Base++-- | A monad to help building LookupHostPort functions from composable bricks.+newtype R a = R {run :: Wai.Request -> IO (Maybe a)}++toLookup :: R (Host, Port) -> LookupHostPort+toLookup = run++instance Functor R where+    fmap f (R pa) = R ((fmap . fmap . fmap) f pa)++instance Applicative R where+    pure x = R ((pure . pure . pure) x)+    pf <*> px = R $ \req -> do+        mf1 <- run pf $ req+        case mf1 of+            Nothing -> pure Nothing+            Just f1 -> do+                mx <- run px $ req+                case mx of+                    Nothing -> pure Nothing+                    Just x -> pure $ Just $ f1 x++instance Alternative R where+    empty = R (const $ pure Nothing)+    r1 <|> r2 = R $ \req -> do+        x1 <- run r1 req+        case x1 of+            Just _ -> pure x1+            Nothing -> run r2 req++instance Monad R where+    pa >>= pf = R $ \req -> do+        ma <- run pa $ req+        case ma of+            Nothing -> pure Nothing+            Just a -> do+                run (pf a) req++instance MonadIO R where+    liftIO = io++-- Special cases++request :: (Wai.Request -> IO a) -> R a+request f = R $ \req -> fmap Just (f req)++request1 :: (Wai.Request -> IO (Maybe a)) -> R a+request1 = R++io :: IO a -> R a+io x = R $ \_ -> fmap Just x++io1 :: IO (Maybe a) -> R a+io1 x = R $ \_ -> x++lookup :: LookupHostPort -> R (Host, Port)+lookup = R++-- bricks++safeHead :: [a] -> R a+safeHead (x : _) = pure x+safeHead _ = empty++shuffle :: [x] -> R [x]+shuffle = io . shuffleM++decorate :: R a -> IO () -> R a+decorate g x = g <* io x