{-# 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 :: Status -> String -> ActionM ()
err st :: Status
st msg :: String
msg = Status -> ActionM ()
status Status
st ActionM () -> ActionM () -> ActionM ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Value -> ActionM ()
forall a. ToJSON a => a -> ActionM ()
json ([Pair] -> Value
object ["err" Text -> String -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= String
msg])

errBadRequest :: String -> ActionM ()
errBadRequest :: String -> ActionM ()
errBadRequest = Status -> String -> ActionM ()
err Status
status400

errNotFound :: String -> ActionM ()
errNotFound :: String -> ActionM ()
errNotFound = Status -> String -> ActionM ()
err Status
status404

proxyPOSTHandler :: App -> ActionM ()
proxyPOSTHandler :: App -> ActionM ()
proxyPOSTHandler app :: App
app = do
  ByteString
wb <- ActionM ByteString
body
  App
-> (Request -> Manager -> IO (Response ByteString)) -> ActionM ()
responseHTTP App
app ((Request -> Manager -> IO (Response ByteString)) -> ActionM ())
-> (Request -> Manager -> IO (Response ByteString)) -> ActionM ()
forall a b. (a -> b) -> a -> b
$ Method
-> Maybe ByteString
-> Request
-> Manager
-> IO (Response ByteString)
prepareHTTPRequest "POST" (ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
wb)

proxyPUTHandler :: App -> ActionM ()
proxyPUTHandler :: App -> ActionM ()
proxyPUTHandler app :: App
app = do
  ByteString
wb <- ActionM ByteString
body
  App
-> (Request -> Manager -> IO (Response ByteString)) -> ActionM ()
responseHTTP App
app ((Request -> Manager -> IO (Response ByteString)) -> ActionM ())
-> (Request -> Manager -> IO (Response ByteString)) -> ActionM ()
forall a b. (a -> b) -> a -> b
$ Method
-> Maybe ByteString
-> Request
-> Manager
-> IO (Response ByteString)
prepareHTTPRequest "PUT" (ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
wb)

proxyGETHandler :: App -> ActionM ()
proxyGETHandler :: App -> ActionM ()
proxyGETHandler app :: App
app = App
-> (Request -> Manager -> IO (Response ByteString)) -> ActionM ()
responseHTTP App
app (Method
-> Maybe ByteString
-> Request
-> Manager
-> IO (Response ByteString)
prepareHTTPRequest "GET" Maybe ByteString
forall a. Maybe a
Nothing)

proxyDELETEHandler :: App -> ActionM ()
proxyDELETEHandler :: App -> ActionM ()
proxyDELETEHandler app :: App
app = do
  ByteString
wb <- ActionM ByteString
body
  App
-> (Request -> Manager -> IO (Response ByteString)) -> ActionM ()
responseHTTP App
app ((Request -> Manager -> IO (Response ByteString)) -> ActionM ())
-> (Request -> Manager -> IO (Response ByteString)) -> ActionM ()
forall a b. (a -> b) -> a -> b
$ Method
-> Maybe ByteString
-> Request
-> Manager
-> IO (Response ByteString)
prepareHTTPRequest "DELETE" (ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
wb)

prepareHTTPRequest
  :: Method -> Maybe LB.ByteString
  -> HTTP.Request -> HTTP.Manager -> IO (HTTP.Response LB.ByteString)
prepareHTTPRequest :: Method
-> Maybe ByteString
-> Request
-> Manager
-> IO (Response ByteString)
prepareHTTPRequest m :: Method
m Nothing req :: Request
req =
  Request -> Manager -> IO (Response ByteString)
HTTP.httpLbs (Request
req {method :: Method
HTTP.method=Method
m})
prepareHTTPRequest m :: Method
m (Just bs :: ByteString
bs) req :: Request
req =
  Request -> Manager -> IO (Response ByteString)
HTTP.httpLbs (Request
req {method :: Method
HTTP.method=Method
m, requestBody :: RequestBody
HTTP.requestBody = ByteString -> RequestBody
HTTP.RequestBodyLBS ByteString
bs })

mergeResponseHeaders :: [CI B.ByteString] -> ResponseHeaders -> ActionM ()
mergeResponseHeaders :: [CI Method] -> ResponseHeaders -> ActionM ()
mergeResponseHeaders _ [] = () -> ActionM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
mergeResponseHeaders k :: [CI Method]
k ((n :: CI Method
n, v :: Method
v):xs :: ResponseHeaders
xs) =
  if CI Method
n CI Method -> [CI Method] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [CI Method]
k then do
                Text -> Text -> ActionM ()
setHeader (Method -> Text
b2t (Method -> Text) -> Method -> Text
forall a b. (a -> b) -> a -> b
$ CI Method -> Method
forall s. CI s -> s
original CI Method
n) (Text -> ActionM ()) -> Text -> ActionM ()
forall a b. (a -> b) -> a -> b
$ Method -> Text
b2t Method
v
                [CI Method] -> ResponseHeaders -> ActionM ()
mergeResponseHeaders [CI Method]
k ResponseHeaders
xs
                else [CI Method] -> ResponseHeaders -> ActionM ()
mergeResponseHeaders [CI Method]
k ResponseHeaders
xs

cookie2SetCookie :: Cookie -> SetCookie
cookie2SetCookie :: Cookie -> SetCookie
cookie2SetCookie Cookie {..}= SetCookie
defaultSetCookie
  { setCookieName :: Method
setCookieName = Method
cookie_name
  , setCookieValue :: Method
setCookieValue = Method
cookie_value
  , setCookiePath :: Maybe Method
setCookiePath = Method -> Maybe Method
forall a. a -> Maybe a
Just Method
cookie_path
  , setCookieExpires :: Maybe UTCTime
setCookieExpires = UTCTime -> Maybe UTCTime
forall a. a -> Maybe a
Just UTCTime
cookie_expiry_time
  -- , setCookieMaxAge =
  -- , setCookieDomain = Just cookie_domain
  , setCookieHttpOnly :: Bool
setCookieHttpOnly = Bool
cookie_http_only
  , setCookieSecure :: Bool
setCookieSecure = Bool
cookie_secure_only
  -- , setCookieSameSite =
  }

mergeSetCookie :: CookieJar -> ActionM ()
mergeSetCookie :: CookieJar -> ActionM ()
mergeSetCookie cj :: CookieJar
cj = do
  (Text -> ActionM ()) -> [Text] -> ActionM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Text -> Text -> ActionM ()
addHeader "Set-Cookie") [Text]
cookies
  where cookies :: [Text]
cookies = (Cookie -> Text) -> [Cookie] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> Text
LT.fromStrict (Text -> Text) -> (Cookie -> Text) -> Cookie -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Method -> Text
decodeUtf8 (Method -> Text) -> (Cookie -> Method) -> Cookie -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Method
LB.toStrict (ByteString -> Method)
-> (Cookie -> ByteString) -> Cookie -> Method
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> ByteString
toLazyByteString (Builder -> ByteString)
-> (Cookie -> Builder) -> Cookie -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SetCookie -> Builder
renderSetCookie (SetCookie -> Builder)
-> (Cookie -> SetCookie) -> Cookie -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cookie -> SetCookie
cookie2SetCookie) ([Cookie] -> [Text]) -> [Cookie] -> [Text]
forall a b. (a -> b) -> a -> b
$ CookieJar -> [Cookie]
destroyCookieJar CookieJar
cj

getPathName :: App -> ActionM LT.Text
getPathName :: App -> ActionM Text
getPathName App{isKeyOnPath :: App -> Bool
isKeyOnPath=Bool
isOnPath} = do
  Bool -> Text -> Text
dropKeyFromPath Bool
isOnPath (Text -> Text) -> ActionM Text -> ActionM Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> ActionM Text
forall a. Parsable a => Text -> ActionM a
param "pathname"

getRawUri :: App -> ActionM LT.Text
getRawUri :: App -> ActionM Text
getRawUri App{isKeyOnPath :: App -> Bool
isKeyOnPath=Bool
isOnPath} =
  Bool -> Text -> Text
dropKeyFromPath Bool
isOnPath (Text -> Text) -> ActionM Text -> ActionM Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> ActionM Text
forall a. Parsable a => Text -> ActionM a
param "rawuri"

responseHTTP :: App -> (HTTP.Request -> HTTP.Manager -> IO (HTTP.Response LB.ByteString)) -> ActionM ()
responseHTTP :: App
-> (Request -> Manager -> IO (Response ByteString)) -> ActionM ()
responseHTTP app :: App
app req :: Request -> Manager -> IO (Response ByteString)
req = do
  Either String ()
ret <- IO (Either String ()) -> ActionT Text IO (Either String ())
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either String ()) -> ActionT Text IO (Either String ()))
-> (Request -> IO (Either String ()))
-> Request
-> ActionT Text IO (Either String ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. App -> Maybe String -> Request -> IO (Either String ())
beforeRequest App
app (App -> Maybe String
retryError App
app) (Request -> ActionT Text IO (Either String ()))
-> ActionT Text IO Request -> ActionT Text IO (Either String ())
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ActionT Text IO Request
request
  case Either String ()
ret of
    Left e :: String
e  -> Status -> String -> ActionM ()
err Status
status500 String
e
    Right _ -> App
-> (Request -> Manager -> IO (Response ByteString)) -> ActionM ()
responseHTTP' App
app Request -> Manager -> IO (Response ByteString)
req

responseHTTP' :: App -> (HTTP.Request -> HTTP.Manager -> IO (HTTP.Response LB.ByteString)) -> ActionM ()
responseHTTP' :: App
-> (Request -> Manager -> IO (Response ByteString)) -> ActionM ()
responseHTTP' app :: App
app@App{onErrorRequest :: App -> IO ()
onErrorRequest=IO ()
onError} req :: Request -> Manager -> IO (Response ByteString)
req = do
  String
uri <- Text -> String
LT.unpack (Text -> String) -> ActionM Text -> ActionT Text IO String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> App -> ActionM Text
getRawUri App
app

  ResponseHeaders
rheaders <- [CI Method] -> ActionM ResponseHeaders
mergeRequestHeaders
    [ "Content-Type"
    , "User-Agent"
    , "X-REQUEST-KEY"
    , "X-Real-IP"
    , "Host"
    , "X-Forwarded-For"
    , "X-URI"
    , "X-Query-String"
    , "X-Scheme"
    , "Cookie"
    , "Authorization"
    ]

  Either HttpException (Response ByteString)
e <- IO (Either HttpException (Response ByteString))
-> ActionT Text IO (Either HttpException (Response ByteString))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either HttpException (Response ByteString))
 -> ActionT Text IO (Either HttpException (Response ByteString)))
-> (IO (Response ByteString)
    -> IO (Either HttpException (Response ByteString)))
-> IO (Response ByteString)
-> ActionT Text IO (Either HttpException (Response ByteString))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO (Response ByteString)
-> IO (Either HttpException (Response ByteString))
forall e a. Exception e => IO a -> IO (Either e a)
try (IO (Response ByteString)
 -> ActionT Text IO (Either HttpException (Response ByteString)))
-> IO (Response ByteString)
-> ActionT Text IO (Either HttpException (Response ByteString))
forall a b. (a -> b) -> a -> b
$ App
-> (Request -> Manager -> IO (Response ByteString))
-> String
-> IO (Response ByteString)
doRequest App
app (ResponseHeaders
-> (Request -> Manager -> IO (Response ByteString))
-> Request
-> Manager
-> IO (Response ByteString)
forall t t.
ResponseHeaders -> (Request -> t -> t) -> Request -> t -> t
prepareReq ResponseHeaders
rheaders Request -> Manager -> IO (Response ByteString)
req) String
uri
  case Either HttpException (Response ByteString)
e of
    Left (HttpExceptionRequest _ content :: HttpExceptionContent
content) ->
      case HttpExceptionContent
content of
        (StatusCodeException r :: Response ()
r dat :: Method
dat) -> do
          let hdrs :: ResponseHeaders
hdrs = Response () -> ResponseHeaders
forall body. Response body -> ResponseHeaders
HTTP.responseHeaders Response ()
r
              st :: Status
st   = Response () -> Status
forall body. Response body -> Status
HTTP.responseStatus Response ()
r
              cookie :: CookieJar
cookie = Response () -> CookieJar
forall body. Response body -> CookieJar
HTTP.responseCookieJar Response ()
r

          ResponseHeaders -> Status -> CookieJar -> ByteString -> ActionM ()
output ResponseHeaders
hdrs Status
st CookieJar
cookie (ByteString -> ActionM ()) -> ByteString -> ActionM ()
forall a b. (a -> b) -> a -> b
$ Method -> ByteString
LB.fromStrict Method
dat
          Bool -> ActionM () -> ActionM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Status
st Status -> Status -> Bool
forall a. Eq a => a -> a -> Bool
== Status
status502 Bool -> Bool -> Bool
|| Status
st Status -> Status -> Bool
forall a. Eq a => a -> a -> Bool
== Status
status504 Bool -> Bool -> Bool
|| Status
st Status -> Status -> Bool
forall a. Eq a => a -> a -> Bool
== Status
status503)
            (ActionM () -> ActionM ()) -> ActionM () -> ActionM ()
forall a b. (a -> b) -> a -> b
$ IO () -> ActionM ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ()
onError
        ResponseTimeout -> do
          Status -> ActionM ()
status Status
status504
          ByteString -> ActionM ()
raw ByteString
LB.empty
          IO () -> ActionM ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ()
onError
        other :: HttpExceptionContent
other -> do
          IO () -> ActionM ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ActionM ()) -> IO () -> ActionM ()
forall a b. (a -> b) -> a -> b
$ String -> String -> IO ()
errorM "Micro.Gateway.Handler" (HttpExceptionContent -> String
forall a. Show a => a -> String
show HttpExceptionContent
other)
          IO () -> ActionM ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ()
onError
          if App -> Int
maxRetry App
app Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= 1 then do
            Status -> ActionM ()
status Status
status502
            ByteString -> ActionM ()
raw ByteString
LB.empty
          else do
            App
-> (Request -> Manager -> IO (Response ByteString)) -> ActionM ()
responseHTTP (App
app
              { maxRetry :: Int
maxRetry = App -> Int
maxRetry App
app Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1
              , retryError :: Maybe String
retryError = String -> Maybe String
forall a. a -> Maybe a
Just (HttpExceptionContent -> String
forall a. Show a => a -> String
show HttpExceptionContent
other)
              }) Request -> Manager -> IO (Response ByteString)
req

    Left (InvalidUrlException _ _) -> do
      Status -> ActionM ()
status Status
status500
      ByteString -> ActionM ()
raw ByteString
LB.empty
    Right r :: Response ByteString
r  -> do
      let hdrs :: ResponseHeaders
hdrs = Response ByteString -> ResponseHeaders
forall body. Response body -> ResponseHeaders
HTTP.responseHeaders Response ByteString
r
          st :: Status
st   = Response ByteString -> Status
forall body. Response body -> Status
HTTP.responseStatus Response ByteString
r
          dat :: ByteString
dat  = Response ByteString -> ByteString
forall body. Response body -> body
HTTP.responseBody Response ByteString
r
          cookie :: CookieJar
cookie = Response ByteString -> CookieJar
forall body. Response body -> CookieJar
HTTP.responseCookieJar Response ByteString
r

      ResponseHeaders -> Status -> CookieJar -> ByteString -> ActionM ()
output ResponseHeaders
hdrs Status
st CookieJar
cookie ByteString
dat

  where output :: ResponseHeaders -> Status -> CookieJar -> ByteString -> ActionM ()
output hdrs :: ResponseHeaders
hdrs st :: Status
st cookie :: CookieJar
cookie dat' :: ByteString
dat' = do
          Text
pathname <- App -> ActionM Text
getPathName App
app

          let dat :: ByteString
dat = Text -> ByteString -> ByteString
replaceData Text
pathname ByteString
dat'
              len :: Int64
len = ByteString -> Int64
LB.length ByteString
dat

          Status -> ActionM ()
status Status
st
          Text -> Text -> ActionM ()
setHeader "Content-Length" (Text -> ActionM ()) -> (Int64 -> Text) -> Int64 -> ActionM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
LT.pack (String -> Text) -> (Int64 -> String) -> Int64 -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int64 -> String
forall a. Show a => a -> String
show (Int64 -> ActionM ()) -> Int64 -> ActionM ()
forall a b. (a -> b) -> a -> b
$ Int64
len
          [CI Method] -> ResponseHeaders -> ActionM ()
mergeResponseHeaders ["Content-Type", "Location", "Date"] ResponseHeaders
hdrs
          CookieJar -> ActionM ()
mergeSetCookie CookieJar
cookie

          ByteString -> ActionM ()
raw ByteString
dat

          IO () -> ActionM ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ActionM ()) -> (Int -> IO ()) -> Int -> ActionM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. App -> Int64 -> Int -> IO ()
afterRequest App
app Int64
len (Int -> ActionM ()) -> Int -> ActionM ()
forall a b. (a -> b) -> a -> b
$ Status -> Int
statusCode Status
st

        prepareReq :: ResponseHeaders -> (Request -> t -> t) -> Request -> t -> t
prepareReq h :: ResponseHeaders
h f :: Request -> t -> t
f req' :: Request
req' mgr :: t
mgr = Request -> t -> t
f (Request
req' {requestHeaders :: ResponseHeaders
HTTP.requestHeaders = ResponseHeaders
h, redirectCount :: Int
HTTP.redirectCount = 0}) t
mgr

        rkName :: Method
rkName = App -> Method
replaceKeyName App
app
        key :: Method
key = Text -> Method
t2b (Text -> Method) -> (AppKey -> Text) -> AppKey -> Method
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AppKey -> Text
unAppKey (AppKey -> Method) -> AppKey -> Method
forall a b. (a -> b) -> a -> b
$ App -> AppKey
appKey App
app

        replaceData :: Text -> ByteString -> ByteString
replaceData pathname :: Text
pathname dat :: ByteString
dat =
          if Text
pathname Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` App -> [Text]
replaceKeyPages App
app
            then Method -> ByteString
LB.fromStrict (Method -> ByteString) -> Method -> ByteString
forall a b. (a -> b) -> a -> b
$ Method -> Method -> Method -> Method
replaceByteString Method
rkName Method
key (Method -> Method) -> Method -> Method
forall a b. (a -> b) -> a -> b
$ ByteString -> Method
LB.toStrict ByteString
dat
            else ByteString
dat

replaceByteString :: B.ByteString -> B.ByteString -> B.ByteString -> B.ByteString
replaceByteString :: Method -> Method -> Method -> Method
replaceByteString sep :: Method
sep sub :: Method
sub = (Method, Method) -> Method
go ((Method, Method) -> Method)
-> (Method -> (Method, Method)) -> Method -> Method
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Method -> Method -> (Method, Method)
B.breakSubstring Method
sep
  where len :: Int
len = Method -> Int
B.length Method
sep
        go :: (B.ByteString, B.ByteString) -> B.ByteString
        go :: (Method, Method) -> Method
go (bs :: Method
bs, "") = Method
bs
        go (bs :: Method
bs, ts :: Method
ts) = Method
bs Method -> Method -> Method
forall a. Semigroup a => a -> a -> a
<> Method
sub Method -> Method -> Method
forall a. Semigroup a => a -> a -> a
<> (Method, Method) -> Method
go (Method -> Method -> (Method, Method)
B.breakSubstring Method
sep (Method -> (Method, Method)) -> Method -> (Method, Method)
forall a b. (a -> b) -> a -> b
$ Int -> Method -> Method
B.drop Int
len Method
ts)


mergeRequestHeaders :: [CI B.ByteString] -> ActionM RequestHeaders
mergeRequestHeaders :: [CI Method] -> ActionM ResponseHeaders
mergeRequestHeaders [] = ResponseHeaders -> ActionM ResponseHeaders
forall (m :: * -> *) a. Monad m => a -> m a
return []
mergeRequestHeaders (x :: CI Method
x:xs :: [CI Method]
xs) = do
  Maybe Text
hdr <- Text -> ActionM (Maybe Text)
header (Method -> Text
b2t (Method -> Text) -> Method -> Text
forall a b. (a -> b) -> a -> b
$ CI Method -> Method
forall s. CI s -> s
original CI Method
x)
  ResponseHeaders
hdrs <- [CI Method] -> ActionM ResponseHeaders
mergeRequestHeaders [CI Method]
xs
  case Maybe Text
hdr of
    Just hd :: Text
hd -> ResponseHeaders -> ActionM ResponseHeaders
forall (m :: * -> *) a. Monad m => a -> m a
return ((CI Method
x, Text -> Method
encodeUtf8 (Text -> Method) -> Text -> Method
forall a b. (a -> b) -> a -> b
$ Text -> Text
LT.toStrict Text
hd)(CI Method, Method) -> ResponseHeaders -> ResponseHeaders
forall a. a -> [a] -> [a]
:ResponseHeaders
hdrs)
    Nothing -> ResponseHeaders -> ActionM ResponseHeaders
forall (m :: * -> *) a. Monad m => a -> m a
return ResponseHeaders
hdrs


verifySignature' :: (App -> ActionM()) -> App -> ActionM ()
verifySignature' :: (App -> ActionM ()) -> App -> ActionM ()
verifySignature' proxy :: App -> ActionM ()
proxy app :: App
app@App{isSecure :: App -> Bool
isSecure=Bool
False} = App -> ActionM ()
proxy App
app
verifySignature' proxy :: App -> ActionM ()
proxy app :: App
app@App{isSecure :: App -> Bool
isSecure=Bool
True}  = do
  Text
sp <- App -> ActionM Text
getPathName App
app
  if [Text] -> Text -> Bool
isAllowPages (App -> [Text]
allowPages App
app) Text
sp
    then App -> ActionM ()
proxy App
app else (App -> ActionM ()) -> App -> ActionM ()
verifySignature App -> ActionM ()
proxy App
app

  where isAllowPages :: [LT.Text] -> LT.Text -> Bool
        isAllowPages :: [Text] -> Text -> Bool
isAllowPages [] _ = Bool
False
        isAllowPages (x :: Text
x:xs :: [Text]
xs) p :: Text
p
          | Text
x Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
p = Bool
True
          | Text
x Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Int64 -> Text -> Text
LT.take (Text -> Int64
LT.length Text
x) Text
p = Bool
True
          | Bool
otherwise = [Text] -> Text -> Bool
isAllowPages [Text]
xs Text
p

verifySignature :: (App -> ActionM ()) -> App -> ActionM ()
verifySignature :: (App -> ActionM ()) -> App -> ActionM ()
verifySignature proxy :: App -> ActionM ()
proxy app :: App
app@App{onlyProxy :: App -> Bool
onlyProxy = Bool
True} = App -> ActionM ()
proxy App
app
verifySignature proxy :: App -> ActionM ()
proxy app :: App
app@App{appSecret :: App -> AppSecret
appSecret=AppSecret
sec, appKey :: App -> AppKey
appKey=AppKey
key}= do
  Maybe Text
ct <- Text -> ActionM (Maybe Text)
header "Content-Type"
  Either String Method
sec' <- Method -> ActionM (Either String Method)
signSecretKey (Method -> ActionM (Either String Method))
-> (Text -> Method) -> Text -> ActionM (Either String Method)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Method
t2b (Text -> ActionM (Either String Method))
-> Text -> ActionM (Either String Method)
forall a b. (a -> b) -> a -> b
$ AppSecret -> Text
unAppSecret AppSecret
sec
  case Either String Method
sec' of
    Left e :: String
e -> String -> ActionM ()
errBadRequest String
e
    Right secret :: Method
secret ->
      case Maybe Text
ct of
        Just "application/json"                  -> Method -> ActionM () -> ActionM ()
doVerifyJSON Method
secret
                                                  (ActionM () -> ActionM ()) -> ActionM () -> ActionM ()
forall a b. (a -> b) -> a -> b
$ Method -> ActionM () -> ActionM ()
doVerifyRaw Method
secret ActionM ()
errorInvalidSignature

        Just "application/x-www-form-urlencoded" -> Method -> ActionM () -> ActionM ()
doVerifyParams Method
secret ActionM ()
errorInvalidSignature
        Just "application/octet-stream"          -> Method -> ActionM () -> ActionM ()
doVerifyRaw Method
secret ActionM ()
errorInvalidSignature
        _                                        -> Method -> ActionM () -> ActionM ()
doVerifyParams Method
secret
                                                  (ActionM () -> ActionM ()) -> ActionM () -> ActionM ()
forall a b. (a -> b) -> a -> b
$ Method -> ActionM () -> ActionM ()
doVerifyRaw Method
secret ActionM ()
errorInvalidSignature

  where doVerifyJSON :: B.ByteString -> ActionM () -> ActionM ()
        doVerifyJSON :: Method -> ActionM () -> ActionM ()
doVerifyJSON secret :: Method
secret next :: ActionM ()
next = do
          Text
hsign <- Text -> Text
LT.toStrict (Text -> Text) -> ActionM Text -> ActionT Text IO Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Text -> ActionM Text
headerOrParam "X-REQUEST-SIGNATURE" "sign"
          Text
hts   <- Text -> Text
LT.toStrict (Text -> Text) -> ActionM Text -> ActionT Text IO Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Text -> ActionM Text
headerOrParam "X-REQUEST-TIME" "timestamp"
          ByteString
wb    <- ActionM ByteString
body
          Text
sp    <- App -> ActionM Text
getPathName App
app
          case (ByteString -> Maybe Value
forall a. FromJSON a => ByteString -> Maybe a
decode ByteString
wb :: Maybe Value) of
            Just (Object v :: Object
v) -> do
              let (String sign :: Text
sign) = Value -> Text -> Object -> Value
forall k v. (Eq k, Hashable k) => v -> k -> HashMap k v -> v
lookupDefault (Text -> Value
String Text
hsign) "sign" Object
v
                  (String ts :: Text
ts) = Value -> Text -> Object -> Value
forall k v. (Eq k, Hashable k) => v -> k -> HashMap k v -> v
lookupDefault (Text -> Value
String Text
hts) "timestamp" Object
v
                  v' :: Object
v' = Text -> Object -> Object
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> HashMap k v
delete "sign" (Object -> Object) -> Object -> Object
forall a b. (a -> b) -> a -> b
$ Text -> Value -> Object -> Object
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
insert "timestamp" (Text -> Value
String Text
ts)
                                     (Object -> Object) -> Object -> Object
forall a b. (a -> b) -> a -> b
$ Text -> Value -> Object -> Object
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
insert "key" (AppKey -> Value
forall a. ToJSON a => a -> Value
toJSON AppKey
key)
                                     (Object -> Object) -> Object -> Object
forall a b. (a -> b) -> a -> b
$ Text -> Value -> Object -> Object
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
insert "pathname" (Text -> Value
String (Text -> Value) -> Text -> Value
forall a b. (a -> b) -> a -> b
$ Text -> Text
LT.toStrict Text
sp) Object
v
                  exceptSign :: CI Method
exceptSign = Method -> Value -> CI Method
signJSON Method
secret (Object -> Value
Object Object
v')

              String -> ActionM () -> ActionM ()
verifyTime (Text -> String
T.unpack Text
ts) (ActionM () -> ActionM ()) -> ActionM () -> ActionM ()
forall a b. (a -> b) -> a -> b
$ CI Method -> Text -> ActionM () -> ActionM ()
equalSign CI Method
exceptSign Text
sign ActionM ()
next

            _ -> ActionM ()
next

        equalSign :: CI B.ByteString -> T.Text -> ActionM () -> ActionM ()
        equalSign :: CI Method -> Text -> ActionM () -> ActionM ()
equalSign except :: CI Method
except sign :: Text
sign next :: ActionM ()
next =
          if CI Method
except CI Method -> CI Method -> Bool
forall a. Eq a => a -> a -> Bool
== Method -> CI Method
forall s. FoldCase s => s -> CI s
mk (Text -> Method
encodeUtf8 Text
sign) then App -> ActionM ()
proxy App
app
                                            else ActionM ()
next

        doVerifyRaw :: B.ByteString -> ActionM () -> ActionM ()
        doVerifyRaw :: Method -> ActionM () -> ActionM ()
doVerifyRaw secret :: Method
secret next :: ActionM ()
next = do
          Text
sign <- Text -> Text
LT.toStrict (Text -> Text) -> ActionM Text -> ActionT Text IO Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Text -> ActionM Text
headerOrParam "X-REQUEST-SIGNATURE" "sign"
          Text
timestamp <- Text -> Text -> ActionM Text
headerOrParam "X-REQUEST-TIME" "timestamp"
          Text
sp <- App -> ActionM Text
getPathName App
app
          ByteString
wb <- ActionM ByteString
body
          let exceptSign :: CI Method
exceptSign = Method -> [(Method, Method)] -> CI Method
signRaw Method
secret [ ("key", Text -> Method
t2b (Text -> Method) -> Text -> Method
forall a b. (a -> b) -> a -> b
$ AppKey -> Text
unAppKey AppKey
key)
                                          , ("timestamp", Text -> Method
t2b Text
timestamp)
                                          , ("raw", ByteString -> Method
LB.toStrict ByteString
wb)
                                          , ("pathname", Text -> Method
t2b Text
sp)
                                          ]

          String -> ActionM () -> ActionM ()
verifyTime (Text -> String
LT.unpack Text
timestamp) (ActionM () -> ActionM ()) -> ActionM () -> ActionM ()
forall a b. (a -> b) -> a -> b
$ CI Method -> Text -> ActionM () -> ActionM ()
equalSign CI Method
exceptSign Text
sign ActionM ()
next

        doVerifyParams :: B.ByteString -> ActionM () -> ActionM ()
        doVerifyParams :: Method -> ActionM () -> ActionM ()
doVerifyParams secret :: Method
secret next :: ActionM ()
next = do
          Text
sign <- Text -> Text
LT.toStrict (Text -> Text) -> ActionM Text -> ActionT Text IO Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Text -> ActionM Text
headerOrParam "X-REQUEST-SIGNATURE" "sign"
          Text
timestamp <- Text -> Text -> ActionM Text
headerOrParam "X-REQUEST-TIME" "timestamp"
          [Param]
vv <- ActionM [Param]
params
          Text
sp <- App -> ActionM Text
getPathName App
app
          let exceptSign :: CI Method
exceptSign = Method -> [Param] -> CI Method
signParams Method
secret ([Param] -> CI Method) -> [Param] -> CI Method
forall a b. (a -> b) -> a -> b
$ Text -> Text -> [Param] -> [Param]
set "key" (AppKey -> Text
unAppKey AppKey
key)
                                             ([Param] -> [Param]) -> [Param] -> [Param]
forall a b. (a -> b) -> a -> b
$ Text -> Text -> [Param] -> [Param]
set "timestamp" Text
timestamp
                                             ([Param] -> [Param]) -> [Param] -> [Param]
forall a b. (a -> b) -> a -> b
$ Text -> Text -> [Param] -> [Param]
set "pathname" Text
sp
                                             ([Param] -> [Param]) -> [Param] -> [Param]
forall a b. (a -> b) -> a -> b
$ Text -> [Param] -> [Param]
remove "sign"
                                             ([Param] -> [Param]) -> [Param] -> [Param]
forall a b. (a -> b) -> a -> b
$ Text -> [Param] -> [Param]
remove "rawuri" [Param]
vv

          String -> ActionM () -> ActionM ()
verifyTime (Text -> String
LT.unpack Text
timestamp) (ActionM () -> ActionM ()) -> ActionM () -> ActionM ()
forall a b. (a -> b) -> a -> b
$ CI Method -> Text -> ActionM () -> ActionM ()
equalSign CI Method
exceptSign Text
sign ActionM ()
next

          where remove :: LT.Text -> [Param] -> [Param]
                remove :: Text -> [Param] -> [Param]
remove _ []          = []
                remove k' :: Text
k' ((k :: Text
k, v :: Text
v):xs :: [Param]
xs) = if Text
k' Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
k then [Param]
xs
                                                   else (Text
k, Text
v) Param -> [Param] -> [Param]
forall a. a -> [a] -> [a]
: Text -> [Param] -> [Param]
remove Text
k' [Param]
xs

                has :: LT.Text -> [Param] -> Bool
                has :: Text -> [Param] -> Bool
has _ []           = Bool
False
                has k' :: Text
k' ((k :: Text
k, _):xs :: [Param]
xs) = (Text
k' Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
k) Bool -> Bool -> Bool
|| Text -> [Param] -> Bool
has Text
k' [Param]
xs

                set :: LT.Text -> LT.Text -> [Param] -> [Param]
                set :: Text -> Text -> [Param] -> [Param]
set k :: Text
k v :: Text
v vv :: [Param]
vv = if Text -> [Param] -> Bool
has Text
k [Param]
vv then Text -> Text -> [Param] -> [Param]
set Text
k Text
v ([Param] -> [Param]) -> [Param] -> [Param]
forall a b. (a -> b) -> a -> b
$ Text -> [Param] -> [Param]
remove Text
k [Param]
vv
                                         else (Text
k, Text
v)Param -> [Param] -> [Param]
forall a. a -> [a] -> [a]
:[Param]
vv

        signSecretKey :: B.ByteString -> ActionM (Either String B.ByteString)
        signSecretKey :: Method -> ActionM (Either String Method)
signSecretKey secret :: Method
secret = do
          Text
tp <- Text -> Text -> ActionM Text
headerOrParam "X-REQUEST-TYPE" "type"
          case Text
tp of
            "JSAPI" -> do
              Text
nonce <- Text -> Text -> ActionM Text
headerOrParam "X-REQUEST-NONCE" "nonce"
              Text
ts <- Text -> Text -> ActionM Text
headerOrParam "X-REQUEST-TIME" "timestamp"
              Text
sp <- App -> ActionM Text
getPathName App
app
              Method
method <- Request -> Method
requestMethod (Request -> Method)
-> ActionT Text IO Request -> ActionT Text IO Method
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ActionT Text IO Request
request
              if Text -> Bool
LT.null Text
nonce then Either String Method -> ActionM (Either String Method)
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Either String Method
forall a b. a -> Either a b
Left "Invalid REQUEST NONCE")
                               else Either String Method -> ActionM (Either String Method)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String Method -> ActionM (Either String Method))
-> (Method -> Either String Method)
-> Method
-> ActionM (Either String Method)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Method -> Either String Method
forall a b. b -> Either a b
Right (Method -> Either String Method)
-> (Method -> Method) -> Method -> Either String Method
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CI Method -> Method
forall s. CI s -> s
original (CI Method -> Method) -> (Method -> CI Method) -> Method -> Method
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Method -> Method -> CI Method
hmacSHA256 (Text -> Method
t2b Text
nonce)
                                      (Method -> ActionM (Either String Method))
-> Method -> ActionM (Either String Method)
forall a b. (a -> b) -> a -> b
$ [Method] -> Method
B.concat [Method
secret, Method
method, Text -> Method
t2b Text
sp, Text -> Method
t2b Text
ts]

            _ -> Either String Method -> ActionM (Either String Method)
forall (m :: * -> *) a. Monad m => a -> m a
return (Method -> Either String Method
forall a b. b -> Either a b
Right Method
secret)

        errorInvalidSignature :: ActionM ()
        errorInvalidSignature :: ActionM ()
errorInvalidSignature = String -> ActionM ()
errBadRequest "Invalid REQUEST SIGNATURE"

        errorTimeout :: ActionM ()
        errorTimeout :: ActionM ()
errorTimeout = String -> ActionM ()
errBadRequest "SIGNATURE TIMEOUT"

        verifyTime :: String -> ActionM () -> ActionM ()
        verifyTime :: String -> ActionM () -> ActionM ()
verifyTime ts' :: String
ts' next :: ActionM ()
next = do
          let ts :: Int64
ts = Int64 -> Maybe Int64 -> Int64
forall a. a -> Maybe a -> a
fromMaybe (0::Int64) (Maybe Int64 -> Int64) -> Maybe Int64 -> Int64
forall a b. (a -> b) -> a -> b
$ String -> Maybe Int64
forall a. Read a => String -> Maybe a
readMaybe String
ts'
          Int64
t <- IO Int64 -> ActionT Text IO Int64
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Int64
forall a. Num a => IO a
getEpochTime
          if Int64
t Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
- 300 Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
< Int64
ts then ActionM ()
next
                          else ActionM ()
errorTimeout

optionsHandler :: ActionM ()
optionsHandler :: ActionM ()
optionsHandler = Status -> ActionM ()
status Status
status204 ActionM () -> ActionM () -> ActionM ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ByteString -> ActionM ()
raw ByteString
LB.empty

headerOrParam :: LT.Text -> LT.Text -> ActionM LT.Text
headerOrParam :: Text -> Text -> ActionM Text
headerOrParam hk :: Text
hk pk :: Text
pk = do
  Maybe Text
hv <- Text -> ActionM (Maybe Text)
header Text
hk
  case Maybe Text
hv of
    Just hv' :: Text
hv' -> Text -> ActionM Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
hv'
    Nothing  -> Text -> ActionM Text
forall a. Parsable a => Text -> ActionM a
param Text
pk ActionM Text -> (Text -> ActionM Text) -> ActionM Text
forall a. ActionM a -> (Text -> ActionM a) -> ActionM a
`rescue` ActionM Text -> Text -> ActionM Text
forall a b. a -> b -> a
const (Text -> ActionM Text
forall (m :: * -> *) a. Monad m => a -> m a
return "")

requireApp :: Provider -> (App -> ActionM ()) -> ActionM ()
requireApp :: Provider -> (App -> ActionM ()) -> ActionM ()
requireApp Provider{..} proxy :: App -> ActionM ()
proxy = ActionM ()
doGetAppByDomain
  where doGetAppFromPath :: ActionM ()
        doGetAppFromPath :: ActionM ()
doGetAppFromPath = do
          AppKey
key <- Text -> AppKey
AppKey (Text -> AppKey) -> (Text -> Text) -> Text -> AppKey
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
takeKeyFromPath (Text -> AppKey) -> ActionM Text -> ActionT Text IO AppKey
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> ActionM Text
forall a. Parsable a => Text -> ActionM a
param "pathname"
          Bool
valid <- IO Bool -> ActionT Text IO Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> ActionT Text IO Bool)
-> IO Bool -> ActionT Text IO Bool
forall a b. (a -> b) -> a -> b
$ AppKey -> IO Bool
isValidKey AppKey
key
          if Bool
valid then do
            Maybe App
app <- IO (Maybe App) -> ActionT Text IO (Maybe App)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe App) -> ActionT Text IO (Maybe App))
-> IO (Maybe App) -> ActionT Text IO (Maybe App)
forall a b. (a -> b) -> a -> b
$ AppKey -> IO (Maybe App)
getAppByKey AppKey
key
            case Maybe App
app of
              Nothing   -> ActionM ()
errorRequired
              Just app' :: App
app' -> App -> ActionM ()
proxy App
app' {isKeyOnPath :: Bool
isKeyOnPath=Bool
True}
          else ActionM ()
errorRequired

        doGetAppByDomain :: ActionM ()
        doGetAppByDomain :: ActionM ()
doGetAppByDomain = do
          Domain
host <- Text -> Domain
Domain (Text -> Domain) -> (Maybe Text -> Text) -> Maybe Text -> Domain
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe "" (Maybe Text -> Domain)
-> ActionM (Maybe Text) -> ActionT Text IO Domain
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> ActionM (Maybe Text)
header "Host"
          Bool
valid <- IO Bool -> ActionT Text IO Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> ActionT Text IO Bool)
-> IO Bool -> ActionT Text IO Bool
forall a b. (a -> b) -> a -> b
$ Domain -> IO Bool
isValidDomain Domain
host
          if Bool
valid then Domain -> Maybe App -> ActionM ()
forall a. Show a => a -> Maybe App -> ActionM ()
process Domain
host (Maybe App -> ActionM ())
-> ActionT Text IO (Maybe App) -> ActionM ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO (Maybe App) -> ActionT Text IO (Maybe App)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Domain -> IO (Maybe App)
getAppByDomain Domain
host)
                   else ActionM ()
doGetAppByHeaderOrParam

        doGetAppByHeaderOrParam :: ActionM ()
        doGetAppByHeaderOrParam :: ActionM ()
doGetAppByHeaderOrParam = do
          AppKey
key <- Text -> AppKey
AppKey (Text -> AppKey) -> ActionM Text -> ActionT Text IO AppKey
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Text -> ActionM Text
headerOrParam "X-REQUEST-KEY" "key"

          Bool
valid <- IO Bool -> ActionT Text IO Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> ActionT Text IO Bool)
-> IO Bool -> ActionT Text IO Bool
forall a b. (a -> b) -> a -> b
$ AppKey -> IO Bool
isValidKey AppKey
key
          if Bool
valid then AppKey -> Maybe App -> ActionM ()
forall a. Show a => a -> Maybe App -> ActionM ()
process AppKey
key (Maybe App -> ActionM ())
-> ActionT Text IO (Maybe App) -> ActionM ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO (Maybe App) -> ActionT Text IO (Maybe App)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (AppKey -> IO (Maybe App)
getAppByKey AppKey
key)
                   else ActionM ()
doGetAppFromPath

        process :: Show a => a -> Maybe App -> ActionM ()
        process :: a -> Maybe App -> ActionM ()
process n :: a
n Nothing    = a -> ActionM ()
forall a. Show a => a -> ActionM ()
errorNotFound a
n
        process _ (Just app :: App
app) = App -> ActionM ()
proxy App
app

        errorRequired :: ActionM ()
        errorRequired :: ActionM ()
errorRequired = String -> ActionM ()
errBadRequest "KEY is required."

        errorNotFound :: Show a => a -> ActionM ()
        errorNotFound :: a -> ActionM ()
errorNotFound d :: a
d = String -> ActionM ()
errNotFound (String -> ActionM ()) -> String -> ActionM ()
forall a b. (a -> b) -> a -> b
$ "APP " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
d String -> String -> String
forall a. [a] -> [a] -> [a]
++ " is not found."

matchAny :: RoutePattern
matchAny :: RoutePattern
matchAny = (Request -> Maybe [Param]) -> RoutePattern
function ((Request -> Maybe [Param]) -> RoutePattern)
-> (Request -> Maybe [Param]) -> RoutePattern
forall a b. (a -> b) -> a -> b
$ \req :: Request
req ->
  [Param] -> Maybe [Param]
forall a. a -> Maybe a
Just [ ("rawuri",  Method -> Text
b2t (Method -> Text) -> Method -> Text
forall a b. (a -> b) -> a -> b
$ Request -> Method
rawPathInfo Request
req Method -> Method -> Method
`B.append` Request -> Method
rawQueryString Request
req)
       , ("pathname", Method -> Text
b2t (Method -> Text) -> Method -> Text
forall a b. (a -> b) -> a -> b
$ Bool -> Method -> Method
urlDecode Bool
True (Method -> Method) -> Method -> Method
forall a b. (a -> b) -> a -> b
$ Request -> Method
rawPathInfo Request
req)
       ]

--------------------------------------------------------------------------------
getFromHeader :: WS.Headers -> CI B.ByteString -> Maybe B.ByteString
getFromHeader :: ResponseHeaders -> CI Method -> Maybe Method
getFromHeader [] _ = Maybe Method
forall a. Maybe a
Nothing
getFromHeader ((x :: CI Method
x, y :: Method
y):xs :: ResponseHeaders
xs) k :: CI Method
k | CI Method
x CI Method -> CI Method -> Bool
forall a. Eq a => a -> a -> Bool
== CI Method
k = Method -> Maybe Method
forall a. a -> Maybe a
Just Method
y
                            | Bool
otherwise = ResponseHeaders -> CI Method -> Maybe Method
getFromHeader ResponseHeaders
xs CI Method
k

removeFromHeader :: CI B.ByteString -> WS.Headers -> WS.Headers
removeFromHeader :: CI Method -> ResponseHeaders -> ResponseHeaders
removeFromHeader _ []         = []
removeFromHeader k :: CI Method
k (h :: (CI Method, Method)
h@(x :: CI Method
x,_):xs :: ResponseHeaders
xs)
  | CI Method
x CI Method -> CI Method -> Bool
forall a. Eq a => a -> a -> Bool
== CI Method
k = ResponseHeaders
xs
  | Bool
otherwise = (CI Method, Method)
h (CI Method, Method) -> ResponseHeaders -> ResponseHeaders
forall a. a -> [a] -> [a]
: CI Method -> ResponseHeaders -> ResponseHeaders
removeFromHeader CI Method
k ResponseHeaders
xs

getParam :: B.ByteString -> B.ByteString -> Maybe B.ByteString
getParam :: Method -> Method -> Maybe Method
getParam k :: Method
k = Method -> Maybe Method
go (Method -> Maybe Method)
-> (Method -> Method) -> Method -> Maybe Method
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Method, Method) -> Method
forall a b. (a, b) -> b
snd ((Method, Method) -> Method)
-> (Method -> (Method, Method)) -> Method -> Method
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Method -> Method -> (Method, Method)
B.breakSubstring Method
k
  where go :: B.ByteString -> Maybe B.ByteString
        go :: Method -> Maybe Method
go "" = Maybe Method
forall a. Maybe a
Nothing
        go v :: Method
v  = Method -> Maybe Method
go1 (Method -> Maybe Method)
-> (Method -> Method) -> Method -> Maybe Method
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Method -> Method
B.drop 1 (Method -> Maybe Method) -> Method -> Maybe Method
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> Method -> Method
B.takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/='&') (Method -> Method) -> Method -> Method
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> Method -> Method
B.dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/='=') Method
v

        go1 :: B.ByteString -> Maybe B.ByteString
        go1 :: Method -> Maybe Method
go1 "" = Maybe Method
forall a. Maybe a
Nothing
        go1 v :: Method
v  = Method -> Maybe Method
forall a. a -> Maybe a
Just Method
v

getFromHeaderOrParam :: WS.Headers -> B.ByteString -> CI B.ByteString -> B.ByteString -> B.ByteString
getFromHeaderOrParam :: ResponseHeaders -> Method -> CI Method -> Method -> Method
getFromHeaderOrParam headers :: ResponseHeaders
headers rawuri :: Method
rawuri hk :: CI Method
hk k :: Method
k =
  Method -> Maybe Method -> Method
forall a. a -> Maybe a -> a
fromMaybe (Method -> Maybe Method -> Method
forall a. a -> Maybe a -> a
fromMaybe "" (Maybe Method -> Method) -> Maybe Method -> Method
forall a b. (a -> b) -> a -> b
$ Method -> Method -> Maybe Method
getParam Method
k Method
rawuri) (Maybe Method -> Method) -> Maybe Method -> Method
forall a b. (a -> b) -> a -> b
$ ResponseHeaders -> CI Method -> Maybe Method
getFromHeader ResponseHeaders
headers CI Method
hk

wsProxyHandler :: Provider -> WS.ServerApp
wsProxyHandler :: Provider -> ServerApp
wsProxyHandler Provider{..} pendingConn :: PendingConnection
pendingConn =
  IO () -> IO ()
withDomainOr
    (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ AppKey -> IO () -> IO ()
withKeyOr AppKey
key
    (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ AppKey -> IO () -> IO ()
withKeyOr AppKey
pkey
    (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Method -> IO ()
rejectRequest "KEY is required"
  where requestHead :: RequestHead
requestHead = PendingConnection -> RequestHead
WS.pendingRequest PendingConnection
pendingConn
        rawuri :: Method
rawuri = RequestHead -> Method
WS.requestPath RequestHead
requestHead
        pathname :: Text
pathname = Method -> Text
b2t (Method -> Text) -> Method -> Text
forall a b. (a -> b) -> a -> b
$ Bool -> Method -> Method
urlDecode Bool
True (Method -> Method) -> Method -> Method
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> Method -> Method
B.takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/='?') Method
rawuri
        headers :: ResponseHeaders
headers = RequestHead -> ResponseHeaders
WS.requestHeaders RequestHead
requestHead
        host :: Domain
host = Text -> Domain
Domain (Text -> Domain)
-> (Maybe Method -> Text) -> Maybe Method -> Domain
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Method -> Text
b2t (Method -> Text)
-> (Maybe Method -> Method) -> Maybe Method -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Method -> Maybe Method -> Method
forall a. a -> Maybe a -> a
fromMaybe "" (Maybe Method -> Domain) -> Maybe Method -> Domain
forall a b. (a -> b) -> a -> b
$ ResponseHeaders -> CI Method -> Maybe Method
getFromHeader ResponseHeaders
headers "Host"

        key :: AppKey
key = Text -> AppKey
AppKey
          (Text -> AppKey) -> (Method -> Text) -> Method -> AppKey
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Method -> Text
b2t
          (Method -> AppKey) -> Method -> AppKey
forall a b. (a -> b) -> a -> b
$ ResponseHeaders -> Method -> CI Method -> Method -> Method
getFromHeaderOrParam ResponseHeaders
headers Method
rawuri "X-REQUEST-KEY" "key"

        pkey :: AppKey
pkey = Text -> AppKey
AppKey (Text -> AppKey) -> Text -> AppKey
forall a b. (a -> b) -> a -> b
$ Text -> Text
takeKeyFromPath Text
pathname

        timestamp :: Method
timestamp = ResponseHeaders -> Method -> CI Method -> Method -> Method
getFromHeaderOrParam ResponseHeaders
headers Method
rawuri "X-REQUEST-TIME" "timestamp"
        ts :: Int64
ts = Int64 -> Maybe Int64 -> Int64
forall a. a -> Maybe a -> a
fromMaybe (0::Int64) (Maybe Int64 -> Int64) -> Maybe Int64 -> Int64
forall a b. (a -> b) -> a -> b
$ String -> Maybe Int64
forall a. Read a => String -> Maybe a
readMaybe (String -> Maybe Int64) -> String -> Maybe Int64
forall a b. (a -> b) -> a -> b
$ Method -> String
B.unpack Method
timestamp
        tp :: Method
tp = ResponseHeaders -> Method -> CI Method -> Method -> Method
getFromHeaderOrParam ResponseHeaders
headers Method
rawuri "X-REQUEST-TYPE" "type"
        nonce :: Method
nonce = ResponseHeaders -> Method -> CI Method -> Method -> Method
getFromHeaderOrParam ResponseHeaders
headers Method
rawuri "X-REQUEST-NONCE" "nonce"
        sign :: Method
sign = ResponseHeaders -> Method -> CI Method -> Method -> Method
getFromHeaderOrParam ResponseHeaders
headers Method
rawuri "X-REQUEST-SIGNATURE" "sign"
        method :: Method
method = "WSPROXY"

        rejectRequest :: B.ByteString -> IO ()
        rejectRequest :: Method -> IO ()
rejectRequest bs :: Method
bs = PendingConnection -> Method -> IO ()
WS.rejectRequest PendingConnection
pendingConn (Method -> IO ()) -> Method -> IO ()
forall a b. (a -> b) -> a -> b
$ "{\"err\": \"" Method -> Method -> Method
forall a. Semigroup a => a -> a -> a
<> Method
bs Method -> Method -> Method
forall a. Semigroup a => a -> a -> a
<> "\"}"

        fillKeyOnPath :: Show a => a -> App -> App
        fillKeyOnPath :: a -> App -> App
fillKeyOnPath n :: a
n app :: App
app = App
app {isKeyOnPath :: Bool
isKeyOnPath = a -> String
forall a. Show a => a -> String
show a
n String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== AppKey -> String
forall a. Show a => a -> String
show AppKey
pkey}

        process :: Show a => a -> Maybe App -> IO ()
        process :: a -> Maybe App -> IO ()
process n :: a
n Nothing = Method -> IO ()
rejectRequest (Method -> IO ()) -> Method -> IO ()
forall a b. (a -> b) -> a -> b
$ "APP " Method -> Method -> Method
forall a. Semigroup a => a -> a -> a
<> String -> Method
B.pack (a -> String
forall a. Show a => a -> String
show a
n) Method -> Method -> Method
forall a. Semigroup a => a -> a -> a
<> " is not found."
        process n :: a
n (Just app :: App
app@App{onlyProxy :: App -> Bool
onlyProxy = Bool
True}) = App -> IO ()
runAction (App -> IO ()) -> App -> IO ()
forall a b. (a -> b) -> a -> b
$ a -> App -> App
forall a. Show a => a -> App -> App
fillKeyOnPath a
n App
app
        process n :: a
n (Just app :: App
app) =
          case Bool -> Method -> Either String Method
signSecretKey Bool
isOnPath (Text -> Method
t2b (Text -> Method) -> (AppSecret -> Text) -> AppSecret -> Method
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AppSecret -> Text
unAppSecret (AppSecret -> Method) -> AppSecret -> Method
forall a b. (a -> b) -> a -> b
$ App -> AppSecret
appSecret App
app) of
            Left e :: String
e -> PendingConnection -> Method -> IO ()
WS.rejectRequest PendingConnection
pendingConn (Method -> IO ()) -> Method -> IO ()
forall a b. (a -> b) -> a -> b
$ "{\"err\": \"" Method -> Method -> Method
forall a. Semigroup a => a -> a -> a
<> String -> Method
B.pack String
e Method -> Method -> Method
forall a. Semigroup a => a -> a -> a
<> ".\"}"
            Right secret :: Method
secret -> do
              Int64
now <- IO Int64
forall a. Num a => IO a
getEpochTime
              if Int64 -> Bool
verifyTime Int64
now then
                if AppKey -> Method -> Bool
verifySign (App -> AppKey
appKey App
app) Method
secret
                   then App -> IO ()
runAction App
app'
                   else Method -> IO ()
rejectRequest "Invalid REQUEST SIGNATURE"
              else Method -> IO ()
rejectRequest "SIGNATURE TIMEOUT"

          where app' :: App
app' = a -> App -> App
forall a. Show a => a -> App -> App
fillKeyOnPath a
n App
app
                isOnPath :: Bool
isOnPath = App -> Bool
isKeyOnPath App
app'

        withDomainOr ::  IO () -> IO ()
        withDomainOr :: IO () -> IO ()
withDomainOr tryNext :: IO ()
tryNext = do
          Bool
valid <- Domain -> IO Bool
isValidDomain Domain
host
          if Bool
valid then Domain -> Maybe App -> IO ()
forall a. Show a => a -> Maybe App -> IO ()
process Domain
host (Maybe App -> IO ()) -> IO (Maybe App) -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Domain -> IO (Maybe App)
getAppByDomain Domain
host
                   else IO ()
tryNext

        withKeyOr :: AppKey -> IO () -> IO ()
        withKeyOr :: AppKey -> IO () -> IO ()
withKeyOr k :: AppKey
k tryNext :: IO ()
tryNext = do
          Bool
valid <- AppKey -> IO Bool
isValidKey AppKey
key
          if Bool
valid then AppKey -> Maybe App -> IO ()
forall a. Show a => a -> Maybe App -> IO ()
process AppKey
k (Maybe App -> IO ()) -> IO (Maybe App) -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO (Maybe App) -> IO (Maybe App)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (AppKey -> IO (Maybe App)
getAppByKey AppKey
k)
                   else IO ()
tryNext

        verifySign :: AppKey -> B.ByteString -> Bool
        verifySign :: AppKey -> Method -> Bool
verifySign rkey :: AppKey
rkey secret :: Method
secret = CI Method -> Bool
equalSign CI Method
exceptSign
          where exceptSign :: CI Method
exceptSign = Method -> [(Method, Method)] -> CI Method
signRaw Method
secret
                  [ ("key", Text -> Method
t2b (Text -> Method) -> Text -> Method
forall a b. (a -> b) -> a -> b
$ AppKey -> Text
unAppKey AppKey
rkey)
                  , ("timestamp", Method
timestamp)
                  , ("pathname", Text -> Method
t2b Text
pathname)
                  ]

        equalSign :: CI B.ByteString -> Bool
        equalSign :: CI Method -> Bool
equalSign except :: CI Method
except = CI Method
except CI Method -> CI Method -> Bool
forall a. Eq a => a -> a -> Bool
== Method -> CI Method
forall s. FoldCase s => s -> CI s
mk Method
sign

        verifyTime :: Int64 -> Bool
        verifyTime :: Int64 -> Bool
verifyTime now :: Int64
now = Int64
now Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
- 300 Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
< Int64
ts

        signSecretKey :: Bool -> B.ByteString -> Either String B.ByteString
        signSecretKey :: Bool -> Method -> Either String Method
signSecretKey isOnPath :: Bool
isOnPath secret :: Method
secret =
          case Method
tp of
            "JSAPI" ->
              if Method -> Bool
B.null Method
nonce
                then
                  String -> Either String Method
forall a b. a -> Either a b
Left "Invalid REQUEST NONCE"
                else
                  Method -> Either String Method
forall a b. b -> Either a b
Right
                    (Method -> Either String Method)
-> (Method -> Method) -> Method -> Either String Method
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CI Method -> Method
forall s. CI s -> s
original
                    (CI Method -> Method) -> (Method -> CI Method) -> Method -> Method
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Method -> Method -> CI Method
hmacSHA256 Method
nonce
                    (Method -> Either String Method) -> Method -> Either String Method
forall a b. (a -> b) -> a -> b
$ [Method] -> Method
B.concat
                      [ Method
secret
                      , Method
method
                      , Text -> Method
t2b (Text -> Method) -> Text -> Method
forall a b. (a -> b) -> a -> b
$ Bool -> Text -> Text
dropKeyFromPath Bool
isOnPath Text
pathname
                      , Method
timestamp
                      ]

            _ -> Method -> Either String Method
forall a b. b -> Either a b
Right Method
secret


        runAction :: App -> IO ()
        runAction :: App -> IO ()
runAction app :: App
app = do
          Connection
conn <- PendingConnection -> IO Connection
WS.acceptRequest PendingConnection
pendingConn
          TChan DataMessage
readChan  <- IO (TChan DataMessage)
forall a. IO (TChan a)
newTChanIO
          TChan DataMessage
writeChan <- IO (TChan DataMessage)
forall a. IO (TChan a)
newTChanIO
          TVar [ThreadId]
threads <- [ThreadId] -> IO (TVar [ThreadId])
forall a. a -> IO (TVar a)
newTVarIO []
          let addThread :: ThreadId -> IO ()
addThread t :: ThreadId
t = STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                [ThreadId]
xs <- TVar [ThreadId] -> STM [ThreadId]
forall a. TVar a -> STM a
readTVar TVar [ThreadId]
threads
                TVar [ThreadId] -> [ThreadId] -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar [ThreadId]
threads (ThreadId
tThreadId -> [ThreadId] -> [ThreadId]
forall a. a -> [a] -> [a]
:[ThreadId]
xs)
              killThreads :: IO ()
killThreads = do
                [ThreadId]
xs <- TVar [ThreadId] -> IO [ThreadId]
forall a. TVar a -> IO a
readTVarIO TVar [ThreadId]
threads
                IO ThreadId -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO ThreadId -> IO ()) -> (IO () -> IO ThreadId) -> IO () -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> IO ThreadId
forkIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ (ThreadId -> IO ()) -> [ThreadId] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ThreadId -> IO ()
killThread [ThreadId]
xs

          ThreadId
thread1 <- IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            DataMessage
bs <- STM DataMessage -> IO DataMessage
forall a. STM a -> IO a
atomically (STM DataMessage -> IO DataMessage)
-> STM DataMessage -> IO DataMessage
forall a b. (a -> b) -> a -> b
$ TChan DataMessage -> STM DataMessage
forall a. TChan a -> STM a
readTChan TChan DataMessage
writeChan
            Connection -> DataMessage -> IO ()
WS.sendDataMessage Connection
conn DataMessage
bs

          ThreadId -> IO ()
addThread ThreadId
thread1

          ThreadId
thread2 <- IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ Connection -> Int -> IO () -> IO ()
WS.pingThread Connection
conn 30 (() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())
          ThreadId -> IO ()
addThread ThreadId
thread2

          ThreadId
thread3 <- IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            Either SomeException DataMessage
bs0 <- IO DataMessage -> IO (Either SomeException DataMessage)
forall e a. Exception e => IO a -> IO (Either e a)
try (IO DataMessage -> IO (Either SomeException DataMessage))
-> IO DataMessage -> IO (Either SomeException DataMessage)
forall a b. (a -> b) -> a -> b
$ Connection -> IO DataMessage
WS.receiveDataMessage Connection
conn
            case Either SomeException DataMessage
bs0 of
              Left (SomeException
_ :: SomeException) -> IO ()
killThreads
              Right bs1 :: DataMessage
bs1 -> STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TChan DataMessage -> DataMessage -> STM ()
forall a. TChan a -> a -> STM ()
writeTChan TChan DataMessage
readChan DataMessage
bs1

          ThreadId -> IO ()
addThread ThreadId
thread3

          App -> (String -> Int -> IO ()) -> IO ()
prepareWsRequest App
app ((String -> Int -> IO ()) -> IO ())
-> (String -> Int -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \h :: String
h p :: Int
p -> do
            String
-> Int
-> String
-> ConnectionOptions
-> ResponseHeaders
-> ClientApp ()
-> IO ()
forall a.
String
-> Int
-> String
-> ConnectionOptions
-> ResponseHeaders
-> ClientApp a
-> IO a
WS.runClientWith String
h Int
p String
rawuri' ConnectionOptions
WS.defaultConnectionOptions (CI Method -> ResponseHeaders -> ResponseHeaders
removeFromHeader "Host" ResponseHeaders
headers) (ClientApp () -> IO ()) -> ClientApp () -> IO ()
forall a b. (a -> b) -> a -> b
$ \pconn :: Connection
pconn -> do
              ThreadId
thread4 <- IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                DataMessage
bs <- STM DataMessage -> IO DataMessage
forall a. STM a -> IO a
atomically (STM DataMessage -> IO DataMessage)
-> STM DataMessage -> IO DataMessage
forall a b. (a -> b) -> a -> b
$ TChan DataMessage -> STM DataMessage
forall a. TChan a -> STM a
readTChan TChan DataMessage
readChan
                Connection -> DataMessage -> IO ()
WS.sendDataMessage Connection
pconn DataMessage
bs

              ThreadId -> IO ()
addThread ThreadId
thread4

              ThreadId
thread5 <- IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ Connection -> Int -> IO () -> IO ()
WS.pingThread Connection
pconn 30 (() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())

              ThreadId -> IO ()
addThread ThreadId
thread5

              ThreadId
thread6 <- IO ThreadId
myThreadId
              ThreadId -> IO ()
addThread ThreadId
thread6

              IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                Either SomeException DataMessage
bs0 <- IO DataMessage -> IO (Either SomeException DataMessage)
forall e a. Exception e => IO a -> IO (Either e a)
try (IO DataMessage -> IO (Either SomeException DataMessage))
-> IO DataMessage -> IO (Either SomeException DataMessage)
forall a b. (a -> b) -> a -> b
$ Connection -> IO DataMessage
WS.receiveDataMessage Connection
pconn
                case Either SomeException DataMessage
bs0 of
                  Left (SomeException
_ :: SomeException) -> IO ()
killThreads
                  Right bs1 :: DataMessage
bs1 -> STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TChan DataMessage -> DataMessage -> STM ()
forall a. TChan a -> a -> STM ()
writeTChan TChan DataMessage
writeChan DataMessage
bs1

          where rawuri' :: String
rawuri' = Text -> String
LT.unpack
                        (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Bool -> Text -> Text
dropKeyFromPath (App -> Bool
isKeyOnPath App
app) (Method -> Text
b2t Method
rawuri)