module Web.Twain.Internal where

import Control.Exception (handle, throwIO)
import Control.Monad (join)
import Control.Monad.Catch (throwM, try)
import Control.Monad.IO.Class (liftIO)
import qualified Data.Aeson as JSON
import qualified Data.ByteString as B
import Data.ByteString.Builder (toLazyByteString)
import qualified Data.ByteString.Lazy as BL
import Data.Int
import Data.List as L
import Data.Maybe (fromMaybe)
import Data.Text as T
import Data.Text.Encoding
import qualified Data.Vault.Lazy as V
import Data.Word (Word64)
import Network.HTTP.Types (Method, hCookie, mkStatus, status204, status400, status413, status500)
import Network.HTTP2.Frame (ErrorCodeId (..), HTTP2Error (..))
import Network.Wai (Application, Middleware, Request (..), lazyRequestBody, queryString, requestHeaders, requestMethod, responseLBS)
import Network.Wai.Parse (File, ParseRequestBodyOptions, lbsBackEnd, noLimitParseRequestBodyOptions, parseRequestBodyEx)
import Network.Wai.Request (RequestSizeException (..), requestSizeCheck)
import System.IO.Unsafe (unsafePerformIO)
import Web.Cookie (SetCookie, parseCookiesText, renderSetCookie)
import Web.Twain.Types

parsedReqKey :: V.Key ParsedRequest
parsedReqKey :: Key ParsedRequest
parsedReqKey = forall a. IO a -> a
unsafePerformIO forall a. IO (Key a)
V.newKey
{-# NOINLINE parsedReqKey #-}

responderOptsKey :: V.Key ResponderOptions
responderOptsKey :: Key ResponderOptions
responderOptsKey = forall a. IO a -> a
unsafePerformIO forall a. IO (Key a)
V.newKey
{-# NOINLINE responderOptsKey #-}

defaultResponderOpts :: ResponderOptions
defaultResponderOpts :: ResponderOptions
defaultResponderOpts =
  ResponderOptions
    { optsMaxBodySize :: Word64
optsMaxBodySize = Word64
64000,
      optsParseBody :: ParseRequestBodyOptions
optsParseBody = ParseRequestBodyOptions
noLimitParseRequestBodyOptions
    }

getRequest :: ResponderM Request
getRequest :: ResponderM Request
getRequest = forall a.
(Request -> IO (Either RouteAction (a, Request))) -> ResponderM a
ResponderM forall a b. (a -> b) -> a -> b
$ \Request
r -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. b -> Either a b
Right (Request
r, Request
r))

setRequest :: Request -> ResponderM ()
setRequest :: Request -> ResponderM ()
setRequest Request
r = forall a.
(Request -> IO (Either RouteAction (a, Request))) -> ResponderM a
ResponderM forall a b. (a -> b) -> a -> b
$ \Request
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. b -> Either a b
Right ((), Request
r))

concatParams :: ParsedRequest -> [Param]
concatParams :: ParsedRequest -> [Param]
concatParams
  ParsedRequest
    { preqBody :: ParsedRequest -> Maybe ParsedBody
preqBody = Just (FormBody ([Param]
fps, [File ByteString]
_)),
      preqCookieParams :: ParsedRequest -> [Param]
preqCookieParams = [Param]
cps,
      preqPathParams :: ParsedRequest -> [Param]
preqPathParams = [Param]
pps,
      preqQueryParams :: ParsedRequest -> [Param]
preqQueryParams = [Param]
qps
    } = [Param]
qps forall a. Semigroup a => a -> a -> a
<> [Param]
pps forall a. Semigroup a => a -> a -> a
<> [Param]
cps forall a. Semigroup a => a -> a -> a
<> [Param]
fps
concatParams ParsedRequest
preq =
  ParsedRequest -> [Param]
preqQueryParams ParsedRequest
preq forall a. Semigroup a => a -> a -> a
<> ParsedRequest -> [Param]
preqPathParams ParsedRequest
preq forall a. Semigroup a => a -> a -> a
<> ParsedRequest -> [Param]
preqCookieParams ParsedRequest
preq

parseRequest :: Request -> ParsedRequest
parseRequest :: Request -> ParsedRequest
parseRequest Request
req =
  case forall a. Key a -> Vault -> Maybe a
V.lookup Key ParsedRequest
parsedReqKey (Request -> Vault
vault Request
req) of
    Just ParsedRequest
preq -> ParsedRequest
preq
    Maybe ParsedRequest
Nothing ->
      ParsedRequest
        { preqPathParams :: [Param]
preqPathParams = [],
          preqQueryParams :: [Param]
preqQueryParams = (Method, Maybe Method) -> Param
decodeQueryParam forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Request -> Query
queryString Request
req,
          preqCookieParams :: [Param]
preqCookieParams = Request -> [Param]
parseCookieParams Request
req,
          preqBody :: Maybe ParsedBody
preqBody = forall a. Maybe a
Nothing
        }

match :: Maybe Method -> PathPattern -> Request -> Maybe [Param]
match :: Maybe Method -> PathPattern -> Request -> Maybe [Param]
match Maybe Method
method (MatchPath Request -> Maybe [Param]
f) Request
req
  | forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (Request -> Method
requestMethod Request
req forall a. Eq a => a -> a -> Bool
==) Maybe Method
method = Request -> Maybe [Param]
f Request
req
  | Bool
otherwise = forall a. Maybe a
Nothing

-- | Parse form request body.
parseBodyForm :: ResponderM ParsedRequest
parseBodyForm :: ResponderM ParsedRequest
parseBodyForm = do
  Request
req <- ResponderM Request
getRequest
  let preq :: ParsedRequest
preq = forall a. a -> Maybe a -> a
fromMaybe (Request -> ParsedRequest
parseRequest Request
req) forall a b. (a -> b) -> a -> b
$ forall a. Key a -> Vault -> Maybe a
V.lookup Key ParsedRequest
parsedReqKey (Request -> Vault
vault Request
req)
  case ParsedRequest -> Maybe ParsedBody
preqBody ParsedRequest
preq of
    Just (FormBody ([Param], [File ByteString])
_) -> forall (m :: * -> *) a. Monad m => a -> m a
return ParsedRequest
preq
    Maybe ParsedBody
_ -> do
      let optsM :: Maybe ParseRequestBodyOptions
optsM = ResponderOptions -> ParseRequestBodyOptions
optsParseBody forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Key a -> Vault -> Maybe a
V.lookup Key ResponderOptions
responderOptsKey (Request -> Vault
vault Request
req)
          opts :: ParseRequestBodyOptions
opts = forall a. a -> Maybe a -> a
fromMaybe ParseRequestBodyOptions
noLimitParseRequestBodyOptions Maybe ParseRequestBodyOptions
optsM
      ([Param]
ps, [File ByteString]
fs) <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall {a}. IO a -> IO a
wrapErr forall a b. (a -> b) -> a -> b
$ forall y.
ParseRequestBodyOptions
-> BackEnd y -> Request -> IO ([Param], [File y])
parseRequestBodyEx ParseRequestBodyOptions
opts forall (m :: * -> *) ignored1 ignored2.
Monad m =>
ignored1 -> ignored2 -> m Method -> m ByteString
lbsBackEnd Request
req
      let parsedBody :: ParsedBody
parsedBody = ([Param], [File ByteString]) -> ParsedBody
FormBody (Param -> Param
decodeBsParam forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Param]
ps, [File ByteString]
fs)
          preq' :: ParsedRequest
preq' = ParsedRequest
preq {preqBody :: Maybe ParsedBody
preqBody = forall a. a -> Maybe a
Just ParsedBody
parsedBody}
      Request -> ResponderM ()
setRequest forall a b. (a -> b) -> a -> b
$ Request
req {vault :: Vault
vault = forall a. Key a -> a -> Vault -> Vault
V.insert Key ParsedRequest
parsedReqKey ParsedRequest
preq' (Request -> Vault
vault Request
req)}
      forall (m :: * -> *) a. Monad m => a -> m a
return ParsedRequest
preq'

-- | Parse JSON request body.
parseBodyJson :: ResponderM JSON.Value
parseBodyJson :: ResponderM Value
parseBodyJson = do
  Request
req <- ResponderM Request
getRequest
  let preq :: ParsedRequest
preq = forall a. a -> Maybe a -> a
fromMaybe (Request -> ParsedRequest
parseRequest Request
req) forall a b. (a -> b) -> a -> b
$ forall a. Key a -> Vault -> Maybe a
V.lookup Key ParsedRequest
parsedReqKey (Request -> Vault
vault Request
req)
  case ParsedRequest -> Maybe ParsedBody
preqBody ParsedRequest
preq of
    Just (JSONBody Value
json) -> forall (m :: * -> *) a. Monad m => a -> m a
return Value
json
    Maybe ParsedBody
_ -> do
      Either String Value
jsonE <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall {a}. IO a -> IO a
wrapErr forall a b. (a -> b) -> a -> b
$ forall a. FromJSON a => ByteString -> Either String a
JSON.eitherDecode forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Request -> IO ByteString
lazyRequestBody Request
req
      case Either String Value
jsonE of
        Left String
msg -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$ Status -> String -> HttpError
HttpError Status
status400 String
msg
        Right Value
json -> do
          let preq' :: ParsedRequest
preq' = ParsedRequest
preq {preqBody :: Maybe ParsedBody
preqBody = forall a. a -> Maybe a
Just (Value -> ParsedBody
JSONBody Value
json)}
          Request -> ResponderM ()
setRequest forall a b. (a -> b) -> a -> b
$ Request
req {vault :: Vault
vault = forall a. Key a -> a -> Vault -> Vault
V.insert Key ParsedRequest
parsedReqKey ParsedRequest
preq' (Request -> Vault
vault Request
req)}
          forall (m :: * -> *) a. Monad m => a -> m a
return Value
json

wrapErr :: IO a -> IO a
wrapErr = forall e a. Exception e => (e -> IO a) -> IO a -> IO a
handle forall a. RequestSizeException -> IO a
wrapMaxReqErr forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e a. Exception e => (e -> IO a) -> IO a -> IO a
handle forall a. HTTP2Error -> IO a
wrapParseErr

wrapMaxReqErr :: RequestSizeException -> IO a
wrapMaxReqErr :: forall a. RequestSizeException -> IO a
wrapMaxReqErr (RequestSizeException Word64
max) =
  forall e a. Exception e => e -> IO a
throwIO forall a b. (a -> b) -> a -> b
$ Status -> String -> HttpError
HttpError Status
status413 forall a b. (a -> b) -> a -> b
$
    String
"Request body size larger than " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Word64
max forall a. Semigroup a => a -> a -> a
<> String
" bytes."

wrapParseErr :: HTTP2Error -> IO a
wrapParseErr :: forall a. HTTP2Error -> IO a
wrapParseErr (ConnectionError (UnknownErrorCode ErrorCode
code) Method
msg) = do
  let msg' :: String
msg' = Text -> String
unpack forall a b. (a -> b) -> a -> b
$ Method -> Text
decodeUtf8 Method
msg
  forall e a. Exception e => e -> IO a
throwIO forall a b. (a -> b) -> a -> b
$ Status -> String -> HttpError
HttpError (Int -> Method -> Status
mkStatus (forall a b. (Integral a, Num b) => a -> b
fromIntegral ErrorCode
code) Method
msg) String
msg'
wrapParseErr (ConnectionError ErrorCodeId
_ Method
msg) = do
  let msg' :: String
msg' = Text -> String
unpack forall a b. (a -> b) -> a -> b
$ Method -> Text
decodeUtf8 Method
msg
  forall e a. Exception e => e -> IO a
throwIO forall a b. (a -> b) -> a -> b
$ Status -> String -> HttpError
HttpError Status
status500 String
msg'

parseCookieParams :: Request -> [Param]
parseCookieParams :: Request -> [Param]
parseCookieParams Request
req =
  let headers :: [Method]
headers = forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. (a -> Bool) -> [a] -> [a]
L.filter (forall a. Eq a => a -> a -> Bool
(==) HeaderName
hCookie forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) (Request -> RequestHeaders
requestHeaders Request
req)
   in forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall a b. (a -> b) -> a -> b
$ Method -> [Param]
parseCookiesText forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Method]
headers

setCookieByteString :: SetCookie -> B.ByteString
setCookieByteString :: SetCookie -> Method
setCookieByteString SetCookie
setCookie =
  ByteString -> Method
BL.toStrict (Builder -> ByteString
toLazyByteString (SetCookie -> Builder
renderSetCookie SetCookie
setCookie))

decodeQueryParam :: (B.ByteString, Maybe B.ByteString) -> Param
decodeQueryParam :: (Method, Maybe Method) -> Param
decodeQueryParam (Method
a, Maybe Method
b) = (Method -> Text
decodeUtf8 Method
a, forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"" Method -> Text
decodeUtf8 Maybe Method
b)

decodeBsParam :: (B.ByteString, B.ByteString) -> Param
decodeBsParam :: Param -> Param
decodeBsParam (Method
a, Method
b) = (Method -> Text
decodeUtf8 Method
a, Method -> Text
decodeUtf8 Method
b)