diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Yann Esposito (c) 2015 + +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 Yann Esposito 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. 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/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,94 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE OverloadedStrings #-} + +module Main where + +import Data.Char (toLower) +import Data.Monoid ((<>)) +import System.Console.CmdArgs.Implicit +import System.Log.Formatter +import System.Log.Handler (setFormatter) +import System.Log.Handler.Simple +import System.Log.Handler.Syslog +import System.Log.Logger +import System.Metrics +import System.Remote.Monitoring (forkServerWith) +import Text.Show.Pretty (ppShow) + +import Cerberus.Lib + +data Options = Options { proxyUrl :: String + , debug :: Bool + , proxyPort :: Int + , port :: Int + , maxNbReqBySeconds :: Int + , infoPort :: Int + , cacheSize :: Integer + , backendCache :: String + , redisHost :: String + , redisPort :: Int + , redisPass :: Maybe String + } deriving (Show, Data, Typeable) +options :: Options +options = Options { + debug = False &= help "Debug mode" + , proxyUrl = ("api.projectoxford.ai" :: String) + &= name "proxy-url" + &= help "External HTTPS URL to proxy to." + &= typ "HOST" + , backendCache = "LRU" &= name "backend-cache" &= help "Could be LRU or Redis" + , proxyPort = 443 &= name "proxy-port" &= help "External Port default 443" + , port = 3000 &= help "port to listen to" + , maxNbReqBySeconds = 60 + &= name "max-nb-req-by-sec" + &= help "max number of requests by seconds" + , infoPort = 8000 + &= help "port to look at monitoring infos" + &= name "info-port" + , cacheSize = 10000000 + &= name "cache-size" + &= help "size of cache" + , redisHost = "localhost" &= name "redis-host" &= help "Redis host" &= groupname "Redis" + , redisPort = 6379 &= name "redis-port" &= help "Redis port" &= groupname "Redis" + , redisPass = Nothing &= name "redis-password" &= groupname "Redis" + } &= program "cerberus" &= summary "cerberus v0.1 © Vigiglobe 2015" + +initLogging :: Bool -> IO () +initLogging debugMode = do + let defaultLevel = if debugMode then DEBUG else WARNING + h <- fileHandler "cerberus.log" defaultLevel + >>= \lh -> return (setFormatter lh (simpleLogFormatter "[$time : $loggername : $prio] $msg")) + updateGlobalLogger rootLoggerName (addHandler h) + s <- openlog "tornado" [PID] LOCAL7 defaultLevel + updateGlobalLogger rootLoggerName (addHandler s) + updateGlobalLogger rootLoggerName (setLevel defaultLevel) + +main :: IO () +main = do + opts <- cmdArgsRun (cmdArgsMode options) + initLogging (debug opts) + putStrLn (ppShow opts) + store <- newStore + req <- createCounter "cerberus.requests_count" store + reqF <- createCounter "cerberus.requests_followed_count" store + reqC <- createCounter "cerberus.requests_cached_count" store + _ <- forkServerWith store "localhost" (infoPort opts) + putStrLn ("Go to http://localhost:" <> show (port opts) + <> " to reach https://" <> proxyUrl opts + <> ":" <> show (proxyPort opts)) + let + backend = case map toLower (backendCache opts) of + "redis" -> Redis + "lru" -> LRU + _ -> error "Unrecognized backend cache should be LRU or Redis." + proxyOpts = ProxyOpts req reqF reqC + (cacheSize opts) + (port opts) + (proxyUrl opts) + (proxyPort opts) + (fromIntegral (maxNbReqBySeconds opts)) + backend + (redisHost opts) + (redisPort opts) + (redisPass opts) + serveProxy proxyOpts diff --git a/cerberus.cabal b/cerberus.cabal new file mode 100644 --- /dev/null +++ b/cerberus.cabal @@ -0,0 +1,63 @@ +name: cerberus +version: 0.1.0.0 +synopsis: Protect and control API access with cerberus +description: Please see README.md +homepage: http://github.com/yogsototh/cerberus#readme +license: BSD3 +license-file: LICENSE +author: Yann Esposito +maintainer: yann.esposito@gmail.com +copyright: 2015 Yann Esposito +category: Development +build-type: Simple +-- extra-source-files: +cabal-version: >=1.10 + +library + hs-source-dirs: src + exposed-modules: Cerberus.Lib + build-depends: base >= 4.7 && < 5 + , blaze-builder + , bytestring + , conduit-extra + , ekg + , ekg-core + , hslogger + , http-types + , http-client + , http-client-tls + , http-reverse-proxy + , text + , wai + , wai-middleware-throttle + , wai-middleware-caching >= 0.1.0.2 + , wai-middleware-caching-lru + , wai-middleware-caching-redis + , warp + default-language: Haskell2010 + +executable cerberus + hs-source-dirs: app + main-is: Main.hs + ghc-options: -Wall -O2 -threaded -optc-O3 -rtsopts -auto-all -caf-all -with-rtsopts=-TN + build-depends: base + , ekg + , ekg-core + , hslogger + , cerberus + , cmdargs + , pretty-show + default-language: Haskell2010 + +test-suite cerberus-test + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Spec.hs + build-depends: base + , cerberus + ghc-options: -Wall -O2 -threaded -optc-O3 -rtsopts -auto-all -caf-all -with-rtsopts=-TN + default-language: Haskell2010 + +source-repository head + type: git + location: https://github.com/yogsototh/cerberus diff --git a/src/Cerberus/Lib.hs b/src/Cerberus/Lib.hs new file mode 100644 --- /dev/null +++ b/src/Cerberus/Lib.hs @@ -0,0 +1,103 @@ +{-# LANGUAGE OverloadedStrings #-} +module Cerberus.Lib + (serveProxy, ProxyOpts(..), CacheBackend(..)) where + +import Control.Arrow ((>>>)) +import Data.ByteString.Char8 (ByteString, pack) +import Network.HTTP.Client (newManager) +import Network.HTTP.Client.TLS +import Network.HTTP.ReverseProxy +import Network.HTTP.Types +import Network.Wai (Application, Middleware) +import Network.Wai.Handler.Warp (run) +import qualified Network.Wai.Internal as I +import Network.Wai.Middleware.Cache (cache) +import qualified Network.Wai.Middleware.LRUCache as LRUCache +import Network.Wai.Middleware.RedisCache (ConnectInfo (..), PortID(..), + defaultConnectInfo) +import qualified Network.Wai.Middleware.RedisCache as RedisCache +import Network.Wai.Middleware.Throttle +import System.Log.Logger +import System.Metrics.Counter (Counter) +import qualified System.Metrics.Counter as Counter + +data CacheBackend = LRU | Redis deriving (Eq,Show) + +data ProxyOpts = ProxyOpts { _req :: Counter + , _reqF :: Counter + , _reqC :: Counter + , _cacheSize :: Integer + , _localPort :: Int + , _url :: String + , _portN :: Int + , _maxNbReqBySeq :: Integer + , _cacheBackend :: CacheBackend + , _redisHost :: String + , _redisPort :: Int + , _redisPass :: Maybe String + } + +updateHeaders :: Header -> [Header] -> [Header] +updateHeaders h headers = let removed = filter (fst >>> (/= fst h)) headers + in h:removed + +proxyRequest :: ByteString -> I.Request -> I.Request +proxyRequest url req = + req {I.requestHeaderHost = Just url + ,I.requestHeaders = + updateHeaders ("Host",url) + (I.requestHeaders req)} + +proxyToApp :: Counter -> String -> Int -> IO Application +proxyToApp reqF url portN = do + mng <- newManager tlsManagerSettings + return (waiProxyTo (\req -> do + debugM "Cerberus.Lib" (show req) + Counter.inc reqF + return (WPRModifiedRequestSecure + (proxyRequest (pack url) req) + (ProxyDest (pack url) portN))) + defaultOnExc + mng) + +throttleSettings :: Integer -> ThrottleSettings +throttleSettings nbReqBySec = + defaultThrottleSettings { throttleRate = 1 + , throttleBurst = nbReqBySec + } + +countRequests :: Counter -> Middleware +countRequests req app = newapp + where newapp request respond = do + Counter.inc req + app request respond + +_serveProxy :: Middleware -- ^ Cache Middleware + -> ProxyOpts -- ^ Proxy Options + -> IO () +_serveProxy cacheM opts = do + reverseApp <- proxyToApp (_reqF opts) (_url opts) (_portN opts) + st <- initThrottler + run (_localPort opts) + ((countRequests (_req opts) + >>> throttle (throttleSettings (_maxNbReqBySeq opts)) st + >>> cacheM) + reverseApp) + +serveProxy :: ProxyOpts -> IO () +serveProxy opts + | _cacheBackend opts == LRU = do + cb <- LRUCache.newCacheBackend (Just (_cacheSize opts)) + (const . const . return $ True) + (const . const . Counter.inc . _req $ opts) + (const . const . Counter.inc . _reqC $ opts) + _serveProxy (cache cb) opts + | _cacheBackend opts == Redis = do + cb <- RedisCache.newCacheBackend (defaultConnectInfo { connectHost = _redisHost opts + , connectPort = PortNumber (fromIntegral (_redisPort opts)) + , connectAuth = fmap pack (_redisPass opts)}) + (const . const . return $ True) + (const . const . Counter.inc . _req $ opts) + (const . const . Counter.inc . _reqC $ opts) + _serveProxy (cache cb) opts + | otherwise = error ("Unsupported Cache Backend: " ++ show (_cacheBackend opts)) diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,2 @@ +main :: IO () +main = putStrLn "Test suite not yet implemented"