diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,5 @@ +# micro-gateway + +A Micro service gateway. + +Support http, and websockets reverse proxy. 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,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 + } diff --git a/micro-gateway.cabal b/micro-gateway.cabal new file mode 100644 --- /dev/null +++ b/micro-gateway.cabal @@ -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 diff --git a/src/Micro/Gateway.hs b/src/Micro/Gateway.hs new file mode 100644 --- /dev/null +++ b/src/Micro/Gateway.hs @@ -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) diff --git a/src/Micro/Gateway/Types.hs b/src/Micro/Gateway/Types.hs new file mode 100644 --- /dev/null +++ b/src/Micro/Gateway/Types.hs @@ -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 + } diff --git a/src/Micro/Gateway/Utils.hs b/src/Micro/Gateway/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Micro/Gateway/Utils.hs @@ -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