micro-gateway (empty) → 1.1.0.0
raw patch · 8 files changed
+1073/−0 lines, 8 filesdep +aesondep +basedep +binarysetup-changed
Dependencies added: aeson, base, binary, bytestring, case-insensitive, containers, cookie, data-default-class, hslogger, http-client, http-types, micro-gateway, network-uri, optparse-applicative, scotty, signature, stm, streaming-commons, text, time, unix-time, unordered-containers, wai, wai-cors, wai-websockets, warp, websockets, yaml
Files
- LICENSE +30/−0
- README.md +5/−0
- Setup.hs +2/−0
- app/Main.hs +193/−0
- micro-gateway.cabal +66/−0
- src/Micro/Gateway.hs +614/−0
- src/Micro/Gateway/Types.hs +126/−0
- src/Micro/Gateway/Utils.hs +37/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Li Meng Jun (c) 2017++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 Li Meng Jun 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.
+ README.md view
@@ -0,0 +1,5 @@+# micro-gateway++A Micro service gateway.++Support http, and websockets reverse proxy.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ app/Main.hs view
@@ -0,0 +1,193 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++module Main+ ( main+ ) where++import Data.Aeson (FromJSON, parseJSON,+ withObject, (.!=), (.:),+ (.:?))+import Data.ByteString (ByteString)+import qualified Data.ByteString.Lazy as LB (ByteString)+import Data.Maybe (fromMaybe)+import Data.Streaming.Network.Internal (HostPreference (Host))+import Data.Text.Encoding (encodeUtf8)+import qualified Data.Text.Lazy as LT (Text)+import qualified Data.Yaml as Y+import Micro.Gateway (matchAny, optionsHandler,+ proxyDELETEHandler,+ proxyGETHandler,+ proxyPOSTHandler,+ proxyPUTHandler, requireApp,+ verifySignature,+ verifySignature',+ wsProxyHandler)+import qualified Micro.Gateway as GW+import qualified Network.HTTP.Client as HTTP+import Network.URI (URI (..), URIAuth (..),+ parseURI)+import qualified Network.Wai.Handler.Warp as W (defaultSettings,+ runSettings, setHost,+ setPort)+import Network.Wai.Handler.WebSockets (websocketsOr)+import Network.Wai.Middleware.Cors (CorsResourcePolicy (..), cors,+ simpleCorsResourcePolicy)+import qualified Network.WebSockets as WS (defaultConnectionOptions)+import Options.Applicative+import Web.Scotty (ScottyM, delete, get,+ middleware, options, post,+ put, scottyApp)++newtype Options' = Options' {getConfigFile :: String}++parser :: Parser Options'+parser = Options' <$> strOption (long "config"+ <> short 'c'+ <> metavar "FILE"+ <> help "config file."+ <> value "config.yaml")++data AppConfig = AppConfig+ { key :: GW.AppKey+ , secret :: GW.AppSecret+ , baseUrl :: String+ , secure :: Bool+ , proxy :: Bool -- flag of only proxy+ , wsUrl :: Maybe String+ , replacePages :: [LT.Text]+ , replaceName :: ByteString++ -- allow page prefix+ , allowPages :: [LT.Text]+ }++data Config = Config+ { appList :: [AppConfig]+ , connTimeout :: Int+ -- default 10 seconds, unit seconds+ , connPool :: Int+ -- default 10+ , host :: String+ , port :: Int+ }++instance FromJSON AppConfig where+ parseJSON = withObject "AppConfig" $ \o -> do+ key <- o .: "key"+ secret <- o .: "secret"+ baseUrl <- o .: "baseUrl"+ secure <- o .:? "secure" .!= False+ proxy <- o .:? "proxy" .!= False+ wsUrl <- o .:? "wsUrl"+ allowPages <- o .:? "allowPages" .!= []+ replacePages <- o .:? "replacePages" .!= []+ rname <- o .:? "replaceName" .!= "__KEY__"+ return AppConfig+ { replaceName = encodeUtf8 rname+ , ..+ }++instance FromJSON Config where+ parseJSON = withObject "Config" $ \o -> do+ appList <- o .: "appList"+ connPool <- o .:? "connPool" .!= 10+ connTimeout <- o .:? "connTimeout" .!= 10+ host <- o .:? "host" .!= "127.0.0.1"+ port <- o .:? "port" .!= 3000+ return Config{..}+++main :: IO ()+main = execParser opts >>= program+ where+ opts = info (helper <*> parser)+ ( fullDesc+ <> progDesc "Simple Gateway"+ <> header "simple-gateway - Simple Gateway" )++program :: Options' -> IO ()+program Options'{getConfigFile=configPath} = do+ c <- Y.decodeFileEither configPath+ case c of+ Left e -> print e+ Right Config{..} -> do+ mgr <- HTTP.newManager HTTP.defaultManagerSettings+ { HTTP.managerConnCount = connPool+ , HTTP.managerResponseTimeout = HTTP.responseTimeoutMicro $ connTimeout * 10000000+ }++ let provider = GW.newProvider+ { GW.getAppByKey = getAppAndInitail mgr appList+ }++ sapp <- scottyApp $ application provider+ let app = websocketsOr WS.defaultConnectionOptions (wsProxyHandler provider) sapp+ W.runSettings (W.setPort port . W.setHost (Host host) $ W.defaultSettings) app+++findApp :: [AppConfig] -> GW.AppKey -> Maybe AppConfig+findApp [] _ = Nothing+findApp (x:xs) k = if key x == k then Just x+ else findApp xs k++getAppAndInitail :: HTTP.Manager -> [AppConfig] -> GW.AppKey -> IO (Maybe GW.App)+getAppAndInitail mgr configs k =+ case findApp configs k of+ Nothing -> return Nothing+ Just AppConfig{..} -> do+ let app = GW.newApp key secret secure proxy+ app' = app+ { GW.doRequest = processRequest mgr baseUrl+ , GW.prepareWsRequest = processWsRequest $ fromMaybe baseUrl wsUrl+ , GW.allowPages = allowPages+ , GW.replaceKeyName = replaceName+ , GW.replaceKeyPages = replacePages+ }++ return $ Just app'++processRequest :: HTTP.Manager -> String+ -> (HTTP.Request -> HTTP.Manager -> IO (HTTP.Response LB.ByteString))+ -> String -> IO (HTTP.Response LB.ByteString)+processRequest mgr root req uri = do+ r <- HTTP.parseRequest $ root ++ uri+ req r mgr+++processWsRequest :: String -> (String -> Int -> IO ()) -> IO ()+processWsRequest baseUrl next = next (uriRegName auth) (read . drop 1 $ uriPort auth)+ where Just uri = parseURI baseUrl+ Just auth = uriAuthority uri++application :: GW.Provider -> ScottyM ()+application provider = do+ middleware $ cors (const $ Just policy)++ get matchAny . requireApp provider $ verifySignature' proxyGETHandler+ post matchAny . requireApp provider $ verifySignature proxyPOSTHandler+ put matchAny . requireApp provider $ verifySignature proxyPUTHandler+ delete matchAny . requireApp provider $ verifySignature proxyDELETEHandler+ options matchAny optionsHandler++ where policy = simpleCorsResourcePolicy+ { corsMethods = [ "GET", "POST", "PUT", "DELETE", "OPTIONS" ]+ , corsRequestHeaders =+ [ "X-REQUEST-KEY"+ , "X-REQUEST-SIGNATURE"+ , "X-REQUEST-TIME"+ , "X-REQUEST-TYPE"+ , "X-REQUEST-NONCE"+ , "Content-Type"+ , "User-Agent"+ , "X-Real-IP"+ , "Host"+ , "X-Forwarded-For"+ , "X-URI"+ , "X-Query-String"+ , "X-Scheme"+ , "Cookie"+ , "Authorization"+ ]+ , corsMaxAge = Just 86400+ }
+ micro-gateway.cabal view
@@ -0,0 +1,66 @@+name: micro-gateway+version: 1.1.0.0+synopsis: A Micro service gateway.+description: A Micro service gateway. Support http, and websockets reverse proxy.+homepage: https://github.com/Lupino/micro-gateway#readme+license: BSD3+license-file: LICENSE+author: Li Meng Jun+maintainer: lmjubuntu@gmail.com+copyright: MIT+category: Gateway,Network,Cloud,Faas,Saas+build-type: Simple+extra-source-files: README.md+cabal-version: >=1.10++library+ hs-source-dirs: src+ exposed-modules: Micro.Gateway+ , Micro.Gateway.Utils+ , Micro.Gateway.Types+ build-depends: base >= 4.7 && < 5+ , containers+ , time+ , text+ , scotty+ , signature+ , bytestring+ , http-types+ , aeson+ , unix-time+ , wai+ , unordered-containers+ , http-client+ , case-insensitive+ , hslogger+ , websockets+ , stm+ , cookie+ , binary+ default-language: Haskell2010++executable simple-gateway+ hs-source-dirs: app+ main-is: Main.hs+ ghc-options: -threaded -rtsopts -with-rtsopts=-N+ build-depends: base+ , micro-gateway+ , scotty+ , wai-cors+ , optparse-applicative+ , aeson+ , yaml+ , bytestring+ , http-client+ , data-default-class+ , streaming-commons+ , warp+ , network-uri+ , wai-websockets+ , websockets+ , text+ default-language: Haskell2010++source-repository head+ type: git+ location: https://github.com/Lupino/micro-gateway
+ src/Micro/Gateway.hs view
@@ -0,0 +1,614 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Micro.Gateway+ ( module Micro.Gateway.Types+ , requireApp+ , verifySignature+ , verifySignature'+ , matchAny+ , proxyPOSTHandler+ , proxyPUTHandler+ , proxyGETHandler+ , proxyDELETEHandler+ , optionsHandler+ , wsProxyHandler+ ) where+++import Control.Concurrent (forkIO, killThread, myThreadId)+import Control.Concurrent.STM.TChan (newTChanIO, readTChan,+ writeTChan)+import Control.Concurrent.STM.TVar (newTVarIO, readTVar, readTVarIO,+ writeTVar)+import Control.Exception (SomeException, try)+import Control.Monad (forever, void, when)+import Control.Monad.IO.Class (liftIO)+import Control.Monad.STM (atomically)+import Crypto.Signature (hmacSHA256, signJSON,+ signParams, signRaw)+import Data.Aeson (Value (..), decode, object,+ toJSON, (.=))+import Data.Binary.Builder (toLazyByteString)+import qualified Data.ByteString.Char8 as B (ByteString, append,+ breakSubstring, concat,+ drop, dropWhile, length,+ null, pack, takeWhile,+ unpack)+import qualified Data.ByteString.Lazy as LB (ByteString, empty,+ fromStrict, length,+ toStrict)+import Data.CaseInsensitive (CI, mk, original)+import Data.HashMap.Strict (delete, insert, lookupDefault)+import Data.Int (Int64)+import Data.Maybe (fromMaybe)+import Data.Text as T (Text, unpack)+import Data.Text.Encoding (decodeUtf8, encodeUtf8)+import qualified Data.Text.Lazy as LT (Text, fromStrict, length,+ null, pack, take,+ toStrict, unpack)+import Micro.Gateway.Types+import Micro.Gateway.Utils+import Network.HTTP.Client (Cookie (..), CookieJar,+ HttpException (..),+ HttpExceptionContent (..),+ destroyCookieJar)+import qualified Network.HTTP.Client as HTTP+import Network.HTTP.Types (Method, RequestHeaders,+ ResponseHeaders, Status,+ status204, status400, status404,+ status500, status502, status503,+ status504, statusCode,+ urlDecode)+import Network.Wai (Request (rawPathInfo, rawQueryString, requestMethod))+import qualified Network.WebSockets as WS (Headers, RequestHead (..),+ ServerApp, acceptRequest,+ defaultConnectionOptions,+ pendingRequest,+ receiveDataMessage,+ rejectRequest,+ runClientWith,+ sendDataMessage)+import Network.WebSockets.Connection as WS (pingThread)+import System.Log.Logger (errorM)+import Text.Read (readMaybe)+import Web.Cookie (SetCookie (..),+ defaultSetCookie,+ renderSetCookie)+import Web.Scotty (ActionM, Param, RoutePattern,+ addHeader, body, function,+ header, json, param, params,+ raw, request, rescue, setHeader,+ status)++++err :: Status -> String -> ActionM ()+err st msg = status st >> json (object ["err" .= msg])++errBadRequest :: String -> ActionM ()+errBadRequest = err status400++errNotFound :: String -> ActionM ()+errNotFound = err status404++proxyPOSTHandler :: App -> ActionM ()+proxyPOSTHandler app = do+ wb <- body+ responseHTTP app $ prepareHTTPRequest "POST" (Just wb)++proxyPUTHandler :: App -> ActionM ()+proxyPUTHandler app = do+ wb <- body+ responseHTTP app $ prepareHTTPRequest "PUT" (Just wb)++proxyGETHandler :: App -> ActionM ()+proxyGETHandler app = responseHTTP app (prepareHTTPRequest "GET" Nothing)++proxyDELETEHandler :: App -> ActionM ()+proxyDELETEHandler app = do+ wb <- body+ responseHTTP app $ prepareHTTPRequest "DELETE" (Just wb)++prepareHTTPRequest+ :: Method -> Maybe LB.ByteString+ -> HTTP.Request -> HTTP.Manager -> IO (HTTP.Response LB.ByteString)+prepareHTTPRequest m Nothing req =+ HTTP.httpLbs (req {HTTP.method=m})+prepareHTTPRequest m (Just bs) req =+ HTTP.httpLbs (req {HTTP.method=m, HTTP.requestBody = HTTP.RequestBodyLBS bs })++mergeResponseHeaders :: [CI B.ByteString] -> ResponseHeaders -> ActionM ()+mergeResponseHeaders _ [] = return ()+mergeResponseHeaders k ((n, v):xs) =+ if n `elem` k then do+ setHeader (b2t $ original n) $ b2t v+ mergeResponseHeaders k xs+ else mergeResponseHeaders k xs++cookie2SetCookie :: Cookie -> SetCookie+cookie2SetCookie Cookie {..}= defaultSetCookie+ { setCookieName = cookie_name+ , setCookieValue = cookie_value+ , setCookiePath = Just cookie_path+ , setCookieExpires = Just cookie_expiry_time+ -- , setCookieMaxAge =+ -- , setCookieDomain = Just cookie_domain+ , setCookieHttpOnly = cookie_http_only+ , setCookieSecure = cookie_secure_only+ -- , setCookieSameSite =+ }++mergeSetCookie :: CookieJar -> ActionM ()+mergeSetCookie cj = do+ mapM_ (addHeader "Set-Cookie") cookies+ where cookies = map (LT.fromStrict . decodeUtf8 . LB.toStrict . toLazyByteString . renderSetCookie . cookie2SetCookie) $ destroyCookieJar cj++getPathName :: App -> ActionM LT.Text+getPathName App{isKeyOnPath=isOnPath} = do+ dropKeyFromPath isOnPath <$> param "pathname"++getRawUri :: App -> ActionM LT.Text+getRawUri App{isKeyOnPath=isOnPath} =+ dropKeyFromPath isOnPath <$> param "rawuri"++responseHTTP :: App -> (HTTP.Request -> HTTP.Manager -> IO (HTTP.Response LB.ByteString)) -> ActionM ()+responseHTTP app req = do+ ret <- liftIO . beforeRequest app (retryError app) =<< request+ case ret of+ Left e -> err status500 e+ Right _ -> responseHTTP' app req++responseHTTP' :: App -> (HTTP.Request -> HTTP.Manager -> IO (HTTP.Response LB.ByteString)) -> ActionM ()+responseHTTP' app@App{onErrorRequest=onError} req = do+ uri <- LT.unpack <$> getRawUri app++ rheaders <- mergeRequestHeaders+ [ "Content-Type"+ , "User-Agent"+ , "X-REQUEST-KEY"+ , "X-Real-IP"+ , "Host"+ , "X-Forwarded-For"+ , "X-URI"+ , "X-Query-String"+ , "X-Scheme"+ , "Cookie"+ , "Authorization"+ ]++ e <- liftIO . try $ doRequest app (prepareReq rheaders req) uri+ case e of+ Left (HttpExceptionRequest _ content) ->+ case content of+ (StatusCodeException r dat) -> do+ let hdrs = HTTP.responseHeaders r+ st = HTTP.responseStatus r+ cookie = HTTP.responseCookieJar r++ output hdrs st cookie $ LB.fromStrict dat+ when (st == status502 || st == status504 || st == status503)+ $ liftIO onError+ ResponseTimeout -> do+ status status504+ raw LB.empty+ liftIO onError+ other -> do+ liftIO $ errorM "Micro.Gateway.Handler" (show other)+ liftIO onError+ if maxRetry app <= 1 then do+ status status502+ raw LB.empty+ else do+ responseHTTP (app+ { maxRetry = maxRetry app - 1+ , retryError = Just (show other)+ }) req++ Left (InvalidUrlException _ _) -> do+ status status500+ raw LB.empty+ Right r -> do+ let hdrs = HTTP.responseHeaders r+ st = HTTP.responseStatus r+ dat = HTTP.responseBody r+ cookie = HTTP.responseCookieJar r++ output hdrs st cookie dat++ where output hdrs st cookie dat' = do+ pathname <- getPathName app++ let dat = replaceData pathname dat'+ len = LB.length dat++ status st+ setHeader "Content-Length" . LT.pack . show $ len+ mergeResponseHeaders ["Content-Type", "Location", "Date"] hdrs+ mergeSetCookie cookie++ raw dat++ liftIO . afterRequest app len $ statusCode st++ prepareReq h f req' mgr = f (req' {HTTP.requestHeaders = h, HTTP.redirectCount = 0}) mgr++ rkName = replaceKeyName app+ key = t2b . unAppKey $ appKey app++ replaceData pathname dat =+ if pathname `elem` replaceKeyPages app+ then LB.fromStrict $ replaceByteString rkName key $ LB.toStrict dat+ else dat++replaceByteString :: B.ByteString -> B.ByteString -> B.ByteString -> B.ByteString+replaceByteString sep sub = go . B.breakSubstring sep+ where len = B.length sep+ go :: (B.ByteString, B.ByteString) -> B.ByteString+ go (bs, "") = bs+ go (bs, ts) = bs <> sub <> go (B.breakSubstring sep $ B.drop len ts)+++mergeRequestHeaders :: [CI B.ByteString] -> ActionM RequestHeaders+mergeRequestHeaders [] = return []+mergeRequestHeaders (x:xs) = do+ hdr <- header (b2t $ original x)+ hdrs <- mergeRequestHeaders xs+ case hdr of+ Just hd -> return ((x, encodeUtf8 $ LT.toStrict hd):hdrs)+ Nothing -> return hdrs+++verifySignature' :: (App -> ActionM()) -> App -> ActionM ()+verifySignature' proxy app@App{isSecure=False} = proxy app+verifySignature' proxy app@App{isSecure=True} = do+ sp <- getPathName app+ if isAllowPages (allowPages app) sp+ then proxy app else verifySignature proxy app++ where isAllowPages :: [LT.Text] -> LT.Text -> Bool+ isAllowPages [] _ = False+ isAllowPages (x:xs) p+ | x == p = True+ | x == LT.take (LT.length x) p = True+ | otherwise = isAllowPages xs p++verifySignature :: (App -> ActionM ()) -> App -> ActionM ()+verifySignature proxy app@App{onlyProxy = True} = proxy app+verifySignature proxy app@App{appSecret=sec, appKey=key}= do+ ct <- header "Content-Type"+ sec' <- signSecretKey . t2b $ unAppSecret sec+ case sec' of+ Left e -> errBadRequest e+ Right secret ->+ case ct of+ Just "application/json" -> doVerifyJSON secret+ $ doVerifyRaw secret errorInvalidSignature++ Just "application/x-www-form-urlencoded" -> doVerifyParams secret errorInvalidSignature+ Just "application/octet-stream" -> doVerifyRaw secret errorInvalidSignature+ _ -> doVerifyParams secret+ $ doVerifyRaw secret errorInvalidSignature++ where doVerifyJSON :: B.ByteString -> ActionM () -> ActionM ()+ doVerifyJSON secret next = do+ hsign <- LT.toStrict <$> headerOrParam "X-REQUEST-SIGNATURE" "sign"+ hts <- LT.toStrict <$> headerOrParam "X-REQUEST-TIME" "timestamp"+ wb <- body+ sp <- getPathName app+ case (decode wb :: Maybe Value) of+ Just (Object v) -> do+ let (String sign) = lookupDefault (String hsign) "sign" v+ (String ts) = lookupDefault (String hts) "timestamp" v+ v' = delete "sign" $ insert "timestamp" (String ts)+ $ insert "key" (toJSON key)+ $ insert "pathname" (String $ LT.toStrict sp) v+ exceptSign = signJSON secret (Object v')++ verifyTime (T.unpack ts) $ equalSign exceptSign sign next++ _ -> next++ equalSign :: CI B.ByteString -> T.Text -> ActionM () -> ActionM ()+ equalSign except sign next =+ if except == mk (encodeUtf8 sign) then proxy app+ else next++ doVerifyRaw :: B.ByteString -> ActionM () -> ActionM ()+ doVerifyRaw secret next = do+ sign <- LT.toStrict <$> headerOrParam "X-REQUEST-SIGNATURE" "sign"+ timestamp <- headerOrParam "X-REQUEST-TIME" "timestamp"+ sp <- getPathName app+ wb <- body+ let exceptSign = signRaw secret [ ("key", t2b $ unAppKey key)+ , ("timestamp", t2b timestamp)+ , ("raw", LB.toStrict wb)+ , ("pathname", t2b sp)+ ]++ verifyTime (LT.unpack timestamp) $ equalSign exceptSign sign next++ doVerifyParams :: B.ByteString -> ActionM () -> ActionM ()+ doVerifyParams secret next = do+ sign <- LT.toStrict <$> headerOrParam "X-REQUEST-SIGNATURE" "sign"+ timestamp <- headerOrParam "X-REQUEST-TIME" "timestamp"+ vv <- params+ sp <- getPathName app+ let exceptSign = signParams secret $ set "key" (unAppKey key)+ $ set "timestamp" timestamp+ $ set "pathname" sp+ $ remove "sign"+ $ remove "rawuri" vv++ verifyTime (LT.unpack timestamp) $ equalSign exceptSign sign next++ where remove :: LT.Text -> [Param] -> [Param]+ remove _ [] = []+ remove k' ((k, v):xs) = if k' == k then xs+ else (k, v) : remove k' xs++ has :: LT.Text -> [Param] -> Bool+ has _ [] = False+ has k' ((k, _):xs) = (k' == k) || has k' xs++ set :: LT.Text -> LT.Text -> [Param] -> [Param]+ set k v vv = if has k vv then set k v $ remove k vv+ else (k, v):vv++ signSecretKey :: B.ByteString -> ActionM (Either String B.ByteString)+ signSecretKey secret = do+ tp <- headerOrParam "X-REQUEST-TYPE" "type"+ case tp of+ "JSAPI" -> do+ nonce <- headerOrParam "X-REQUEST-NONCE" "nonce"+ ts <- headerOrParam "X-REQUEST-TIME" "timestamp"+ sp <- getPathName app+ method <- requestMethod <$> request+ if LT.null nonce then return (Left "Invalid REQUEST NONCE")+ else return . Right . original . hmacSHA256 (t2b nonce)+ $ B.concat [secret, method, t2b sp, t2b ts]++ _ -> return (Right secret)++ errorInvalidSignature :: ActionM ()+ errorInvalidSignature = errBadRequest "Invalid REQUEST SIGNATURE"++ errorTimeout :: ActionM ()+ errorTimeout = errBadRequest "SIGNATURE TIMEOUT"++ verifyTime :: String -> ActionM () -> ActionM ()+ verifyTime ts' next = do+ let ts = fromMaybe (0::Int64) $ readMaybe ts'+ t <- liftIO getEpochTime+ if t - 300 < ts then next+ else errorTimeout++optionsHandler :: ActionM ()+optionsHandler = status status204 >> raw LB.empty++headerOrParam :: LT.Text -> LT.Text -> ActionM LT.Text+headerOrParam hk pk = do+ hv <- header hk+ case hv of+ Just hv' -> return hv'+ Nothing -> param pk `rescue` const (return "")++requireApp :: Provider -> (App -> ActionM ()) -> ActionM ()+requireApp Provider{..} proxy = doGetAppByDomain+ where doGetAppFromPath :: ActionM ()+ doGetAppFromPath = do+ key <- AppKey . takeKeyFromPath <$> param "pathname"+ valid <- liftIO $ isValidKey key+ if valid then do+ app <- liftIO $ getAppByKey key+ case app of+ Nothing -> errorRequired+ Just app' -> proxy app' {isKeyOnPath=True}+ else errorRequired++ doGetAppByDomain :: ActionM ()+ doGetAppByDomain = do+ host <- Domain . fromMaybe "" <$> header "Host"+ valid <- liftIO $ isValidDomain host+ if valid then process host =<< liftIO (getAppByDomain host)+ else doGetAppByHeaderOrParam++ doGetAppByHeaderOrParam :: ActionM ()+ doGetAppByHeaderOrParam = do+ key <- AppKey <$> headerOrParam "X-REQUEST-KEY" "key"++ valid <- liftIO $ isValidKey key+ if valid then process key =<< liftIO (getAppByKey key)+ else doGetAppFromPath++ process :: Show a => a -> Maybe App -> ActionM ()+ process n Nothing = errorNotFound n+ process _ (Just app) = proxy app++ errorRequired :: ActionM ()+ errorRequired = errBadRequest "KEY is required."++ errorNotFound :: Show a => a -> ActionM ()+ errorNotFound d = errNotFound $ "APP " ++ show d ++ " is not found."++matchAny :: RoutePattern+matchAny = function $ \req ->+ Just [ ("rawuri", b2t $ rawPathInfo req `B.append` rawQueryString req)+ , ("pathname", b2t $ urlDecode True $ rawPathInfo req)+ ]++--------------------------------------------------------------------------------+getFromHeader :: WS.Headers -> CI B.ByteString -> Maybe B.ByteString+getFromHeader [] _ = Nothing+getFromHeader ((x, y):xs) k | x == k = Just y+ | otherwise = getFromHeader xs k++removeFromHeader :: CI B.ByteString -> WS.Headers -> WS.Headers+removeFromHeader _ [] = []+removeFromHeader k (h@(x,_):xs)+ | x == k = xs+ | otherwise = h : removeFromHeader k xs++getParam :: B.ByteString -> B.ByteString -> Maybe B.ByteString+getParam k = go . snd . B.breakSubstring k+ where go :: B.ByteString -> Maybe B.ByteString+ go "" = Nothing+ go v = go1 . B.drop 1 $ B.takeWhile (/='&') $ B.dropWhile (/='=') v++ go1 :: B.ByteString -> Maybe B.ByteString+ go1 "" = Nothing+ go1 v = Just v++getFromHeaderOrParam :: WS.Headers -> B.ByteString -> CI B.ByteString -> B.ByteString -> B.ByteString+getFromHeaderOrParam headers rawuri hk k =+ fromMaybe (fromMaybe "" $ getParam k rawuri) $ getFromHeader headers hk++wsProxyHandler :: Provider -> WS.ServerApp+wsProxyHandler Provider{..} pendingConn =+ withDomainOr+ $ withKeyOr key+ $ withKeyOr pkey+ $ rejectRequest "KEY is required"+ where requestHead = WS.pendingRequest pendingConn+ rawuri = WS.requestPath requestHead+ pathname = b2t $ urlDecode True $ B.takeWhile (/='?') rawuri+ headers = WS.requestHeaders requestHead+ host = Domain . b2t . fromMaybe "" $ getFromHeader headers "Host"++ key = AppKey+ . b2t+ $ getFromHeaderOrParam headers rawuri "X-REQUEST-KEY" "key"++ pkey = AppKey $ takeKeyFromPath pathname++ timestamp = getFromHeaderOrParam headers rawuri "X-REQUEST-TIME" "timestamp"+ ts = fromMaybe (0::Int64) $ readMaybe $ B.unpack timestamp+ tp = getFromHeaderOrParam headers rawuri "X-REQUEST-TYPE" "type"+ nonce = getFromHeaderOrParam headers rawuri "X-REQUEST-NONCE" "nonce"+ sign = getFromHeaderOrParam headers rawuri "X-REQUEST-SIGNATURE" "sign"+ method = "WSPROXY"++ rejectRequest :: B.ByteString -> IO ()+ rejectRequest bs = WS.rejectRequest pendingConn $ "{\"err\": \"" <> bs <> "\"}"++ fillKeyOnPath :: Show a => a -> App -> App+ fillKeyOnPath n app = app {isKeyOnPath = show n == show pkey}++ process :: Show a => a -> Maybe App -> IO ()+ process n Nothing = rejectRequest $ "APP " <> B.pack (show n) <> " is not found."+ process n (Just app@App{onlyProxy = True}) = runAction $ fillKeyOnPath n app+ process n (Just app) =+ case signSecretKey isOnPath (t2b . unAppSecret $ appSecret app) of+ Left e -> WS.rejectRequest pendingConn $ "{\"err\": \"" <> B.pack e <> ".\"}"+ Right secret -> do+ now <- getEpochTime+ if verifyTime now then+ if verifySign (appKey app) secret+ then runAction app'+ else rejectRequest "Invalid REQUEST SIGNATURE"+ else rejectRequest "SIGNATURE TIMEOUT"++ where app' = fillKeyOnPath n app+ isOnPath = isKeyOnPath app'++ withDomainOr :: IO () -> IO ()+ withDomainOr tryNext = do+ valid <- isValidDomain host+ if valid then process host =<< getAppByDomain host+ else tryNext++ withKeyOr :: AppKey -> IO () -> IO ()+ withKeyOr k tryNext = do+ valid <- isValidKey key+ if valid then process k =<< liftIO (getAppByKey k)+ else tryNext++ verifySign :: AppKey -> B.ByteString -> Bool+ verifySign rkey secret = equalSign exceptSign+ where exceptSign = signRaw secret+ [ ("key", t2b $ unAppKey rkey)+ , ("timestamp", timestamp)+ , ("pathname", t2b pathname)+ ]++ equalSign :: CI B.ByteString -> Bool+ equalSign except = except == mk sign++ verifyTime :: Int64 -> Bool+ verifyTime now = now - 300 < ts++ signSecretKey :: Bool -> B.ByteString -> Either String B.ByteString+ signSecretKey isOnPath secret =+ case tp of+ "JSAPI" ->+ if B.null nonce+ then+ Left "Invalid REQUEST NONCE"+ else+ Right+ . original+ . hmacSHA256 nonce+ $ B.concat+ [ secret+ , method+ , t2b $ dropKeyFromPath isOnPath pathname+ , timestamp+ ]++ _ -> Right secret+++ runAction :: App -> IO ()+ runAction app = do+ conn <- WS.acceptRequest pendingConn+ readChan <- newTChanIO+ writeChan <- newTChanIO+ threads <- newTVarIO []+ let addThread t = atomically $ do+ xs <- readTVar threads+ writeTVar threads (t:xs)+ killThreads = do+ xs <- readTVarIO threads+ void . forkIO $ mapM_ killThread xs++ thread1 <- forkIO $ forever $ do+ bs <- atomically $ readTChan writeChan+ WS.sendDataMessage conn bs++ addThread thread1++ thread2 <- forkIO $ WS.pingThread conn 30 (return ())+ addThread thread2++ thread3 <- forkIO $ forever $ do+ bs0 <- try $ WS.receiveDataMessage conn+ case bs0 of+ Left (_ :: SomeException) -> killThreads+ Right bs1 -> atomically $ writeTChan readChan bs1++ addThread thread3++ prepareWsRequest app $ \h p -> do+ WS.runClientWith h p rawuri' WS.defaultConnectionOptions (removeFromHeader "Host" headers) $ \pconn -> do+ thread4 <- forkIO $ forever $ do+ bs <- atomically $ readTChan readChan+ WS.sendDataMessage pconn bs++ addThread thread4++ thread5 <- forkIO $ WS.pingThread pconn 30 (return ())++ addThread thread5++ thread6 <- myThreadId+ addThread thread6++ forever $ do+ bs0 <- try $ WS.receiveDataMessage pconn+ case bs0 of+ Left (_ :: SomeException) -> killThreads+ Right bs1 -> atomically $ writeTChan writeChan bs1++ where rawuri' = LT.unpack+ $ dropKeyFromPath (isKeyOnPath app) (b2t rawuri)
+ src/Micro/Gateway/Types.hs view
@@ -0,0 +1,126 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++module Micro.Gateway.Types+ ( App (..)+ , AppKey (..)+ , AppSecret (..)+ , Domain (..)+ , newApp++ , Provider (..)+ , newProvider+ ) where++import Data.Aeson (FromJSON (..), ToJSON (..), withText)+import Data.ByteString (ByteString)+import qualified Data.ByteString.Lazy as LB (ByteString)+import Data.Int (Int64)+import Data.String (IsString (..))+import qualified Data.Text.Lazy as LT (Text, fromStrict, null, unpack)+import qualified Network.HTTP.Client as HTTP+import Network.Wai (Request (..))++newtype AppKey = AppKey {unAppKey :: LT.Text}+ deriving (Eq)++instance Show AppKey where+ show = LT.unpack . unAppKey++instance IsString AppKey where+ fromString = AppKey . fromString++instance FromJSON AppKey where+ parseJSON = withText "AppKey" $ pure . AppKey . LT.fromStrict++instance ToJSON AppKey where+ toJSON (AppKey k) = toJSON k++newtype AppSecret = AppSecret {unAppSecret :: LT.Text}++instance Show AppSecret where+ show = LT.unpack . unAppSecret++instance IsString AppSecret where+ fromString = AppSecret . fromString++instance FromJSON AppSecret where+ parseJSON = withText "AppSecret" $ pure . AppSecret . LT.fromStrict++instance ToJSON AppSecret where+ toJSON (AppSecret s) = toJSON s++newtype Domain = Domain {unDomain :: LT.Text}++instance Show Domain where+ show = LT.unpack . unDomain++instance IsString Domain where+ fromString = Domain . fromString++instance FromJSON Domain where+ parseJSON = withText "Domain" $ pure . Domain . LT.fromStrict++instance ToJSON Domain where+ toJSON (Domain d) = toJSON d++data App = App+ { appKey :: AppKey+ , appSecret :: AppSecret+ , isKeyOnPath :: Bool+ , isSecure :: Bool+ , onlyProxy :: Bool+ , doRequest :: (HTTP.Request -> HTTP.Manager -> IO (HTTP.Response LB.ByteString))+ -> String -> IO (HTTP.Response LB.ByteString)+ , beforeRequest :: Maybe String -> Request -> IO (Either String ())+ -- beforeRequest retryError req+ , afterRequest :: Int64 -> Int -> IO ()+ -- afterRequest contentLength statusCode+ , onErrorRequest :: IO ()+ , maxRetry :: Int+ -- set the max retry on bad gateway error+ , retryError :: Maybe String+ , prepareWsRequest :: (String -> Int -> IO ()) -> IO ()+ --+ , replaceKeyPages :: [LT.Text]+ , replaceKeyName :: ByteString++ -- allow page prefix+ , allowPages :: [LT.Text]+ }+++newApp :: AppKey -> AppSecret -> Bool -> Bool -> App+newApp appKey appSecret isSecure onlyProxy = App+ { isKeyOnPath = False+ , doRequest = error "no implement"+ , beforeRequest = \_ _ -> pure $ Right ()+ , afterRequest = \_ _ -> pure ()+ , onErrorRequest = pure ()+ , maxRetry = 3+ , retryError = Nothing+ , prepareWsRequest = error "no implement"+ , replaceKeyPages = []+ , replaceKeyName = "__KEY__"+ , allowPages = []+ , ..+ }+++data Provider = Provider+ { getAppByKey :: AppKey -> IO (Maybe App)+ , getAppByDomain :: Domain -> IO (Maybe App)+ , isValidDomain :: Domain -> IO Bool+ , isValidKey :: AppKey -> IO Bool+ }++notNull :: AppKey -> Bool+notNull (AppKey k) = not $ LT.null k++newProvider :: Provider+newProvider = Provider+ { getAppByKey = const $ pure Nothing+ , getAppByDomain = const $ pure Nothing+ , isValidDomain = return . const False+ , isValidKey = return . notNull+ }
+ src/Micro/Gateway/Utils.hs view
@@ -0,0 +1,37 @@+module Micro.Gateway.Utils+ ( getEpochTime+ , b2t+ , t2b+ , flip'+ , takeKeyFromPath+ , dropKeyFromPath+ ) where++import qualified Data.ByteString as B (ByteString)+import Data.Int (Int64)+import Data.Text.Encoding (decodeUtf8, encodeUtf8)+import qualified Data.Text.Lazy as LT (Text, drop, dropWhile, fromStrict,+ takeWhile, toStrict)+import Data.UnixTime+import Foreign.C.Types (CTime (..))++getEpochTime :: Num a => IO a+getEpochTime = fromIntegral . un . toEpochTime <$> getUnixTime+ where un :: CTime -> Int64+ un (CTime t) = t++b2t :: B.ByteString -> LT.Text+b2t = LT.fromStrict . decodeUtf8++t2b :: LT.Text -> B.ByteString+t2b = encodeUtf8 . LT.toStrict++flip' :: (a -> b -> c -> d) -> c -> a -> b -> d+flip' f c a b = f a b c++takeKeyFromPath :: LT.Text -> LT.Text+takeKeyFromPath = LT.takeWhile (/= '/') . LT.drop 1++dropKeyFromPath :: Bool -> LT.Text -> LT.Text+dropKeyFromPath True = LT.dropWhile (/= '/') . LT.drop 1+dropKeyFromPath False = id