{-# 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 ()
_ [] = () -> 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
, setCookieHttpOnly :: Bool
setCookieHttpOnly = Bool
cookie_http_only
, setCookieSecure :: Bool
setCookieSecure = Bool
cookie_secure_only
}
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
[] = 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
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
[] _ = 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 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
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)