module Web.Twain.Internal where

import Control.Exception (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 qualified 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 (..))
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
import Network.HTTP2.Client (HTTP2Error (..), ErrorCode(..))
import qualified Data.ByteString.Char8 as BC

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

responderOptsKey :: V.Key ResponderOptions
responderOptsKey :: Key ResponderOptions
responderOptsKey = IO (Key ResponderOptions) -> Key ResponderOptions
forall a. IO a -> a
unsafePerformIO IO (Key ResponderOptions)
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 = (Request -> IO (Either RouteAction (Request, Request)))
-> ResponderM Request
forall a.
(Request -> IO (Either RouteAction (a, Request))) -> ResponderM a
ResponderM ((Request -> IO (Either RouteAction (Request, Request)))
 -> ResponderM Request)
-> (Request -> IO (Either RouteAction (Request, Request)))
-> ResponderM Request
forall a b. (a -> b) -> a -> b
$ \Request
r -> Either RouteAction (Request, Request)
-> IO (Either RouteAction (Request, Request))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Request, Request) -> Either RouteAction (Request, Request)
forall a b. b -> Either a b
Right (Request
r, Request
r))

setRequest :: Request -> ResponderM ()
setRequest :: Request -> ResponderM ()
setRequest Request
r = (Request -> IO (Either RouteAction ((), Request))) -> ResponderM ()
forall a.
(Request -> IO (Either RouteAction (a, Request))) -> ResponderM a
ResponderM ((Request -> IO (Either RouteAction ((), Request)))
 -> ResponderM ())
-> (Request -> IO (Either RouteAction ((), Request)))
-> ResponderM ()
forall a b. (a -> b) -> a -> b
$ \Request
_ -> Either RouteAction ((), Request)
-> IO (Either RouteAction ((), Request))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (((), Request) -> Either RouteAction ((), Request)
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 [Param] -> [Param] -> [Param]
forall a. Semigroup a => a -> a -> a
<> [Param]
pps [Param] -> [Param] -> [Param]
forall a. Semigroup a => a -> a -> a
<> [Param]
cps [Param] -> [Param] -> [Param]
forall a. Semigroup a => a -> a -> a
<> [Param]
fps
concatParams ParsedRequest
preq =
  ParsedRequest -> [Param]
preqQueryParams ParsedRequest
preq [Param] -> [Param] -> [Param]
forall a. Semigroup a => a -> a -> a
<> ParsedRequest -> [Param]
preqPathParams ParsedRequest
preq [Param] -> [Param] -> [Param]
forall a. Semigroup a => a -> a -> a
<> ParsedRequest -> [Param]
preqCookieParams ParsedRequest
preq

parseRequest :: Request -> ParsedRequest
parseRequest :: Request -> ParsedRequest
parseRequest Request
req =
  case Key ParsedRequest -> Vault -> Maybe ParsedRequest
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 ((Method, Maybe Method) -> Param)
-> [(Method, Maybe Method)] -> [Param]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Request -> [(Method, Maybe Method)]
queryString Request
req,
          preqCookieParams :: [Param]
preqCookieParams = Request -> [Param]
parseCookieParams Request
req,
          preqBody :: Maybe ParsedBody
preqBody = Maybe ParsedBody
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
  | Bool -> (Method -> Bool) -> Maybe Method -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (Request -> Method
requestMethod Request
req Method -> Method -> Bool
forall a. Eq a => a -> a -> Bool
==) Maybe Method
method = Request -> Maybe [Param]
f Request
req
  | Bool
otherwise = Maybe [Param]
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 = ParsedRequest -> Maybe ParsedRequest -> ParsedRequest
forall a. a -> Maybe a -> a
fromMaybe (Request -> ParsedRequest
parseRequest Request
req) (Maybe ParsedRequest -> ParsedRequest)
-> Maybe ParsedRequest -> ParsedRequest
forall a b. (a -> b) -> a -> b
$ Key ParsedRequest -> Vault -> Maybe ParsedRequest
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])
_) -> ParsedRequest -> ResponderM ParsedRequest
forall a. a -> ResponderM a
forall (m :: * -> *) a. Monad m => a -> m a
return ParsedRequest
preq
    Maybe ParsedBody
_ -> do
      let optsM :: Maybe ParseRequestBodyOptions
optsM = ResponderOptions -> ParseRequestBodyOptions
optsParseBody (ResponderOptions -> ParseRequestBodyOptions)
-> Maybe ResponderOptions -> Maybe ParseRequestBodyOptions
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Key ResponderOptions -> Vault -> Maybe ResponderOptions
forall a. Key a -> Vault -> Maybe a
V.lookup Key ResponderOptions
responderOptsKey (Request -> Vault
vault Request
req)
          opts :: ParseRequestBodyOptions
opts = ParseRequestBodyOptions
-> Maybe ParseRequestBodyOptions -> ParseRequestBodyOptions
forall a. a -> Maybe a -> a
fromMaybe ParseRequestBodyOptions
noLimitParseRequestBodyOptions Maybe ParseRequestBodyOptions
optsM
      ([Param]
ps, [File ByteString]
fs) <- IO ([Param], [File ByteString])
-> ResponderM ([Param], [File ByteString])
forall a. IO a -> ResponderM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ([Param], [File ByteString])
 -> ResponderM ([Param], [File ByteString]))
-> IO ([Param], [File ByteString])
-> ResponderM ([Param], [File ByteString])
forall a b. (a -> b) -> a -> b
$ IO ([Param], [File ByteString]) -> IO ([Param], [File ByteString])
forall a. IO a -> IO a
wrapErr (IO ([Param], [File ByteString])
 -> IO ([Param], [File ByteString]))
-> IO ([Param], [File ByteString])
-> IO ([Param], [File ByteString])
forall a b. (a -> b) -> a -> b
$ ParseRequestBodyOptions
-> BackEnd ByteString -> Request -> IO ([Param], [File ByteString])
forall y.
ParseRequestBodyOptions
-> BackEnd y -> Request -> IO ([Param], [File y])
parseRequestBodyEx ParseRequestBodyOptions
opts BackEnd ByteString
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 (Param -> Param) -> [Param] -> [Param]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Param]
ps, [File ByteString]
fs)
          preq' :: ParsedRequest
preq' = ParsedRequest
preq {preqBody = Just parsedBody}
      Request -> ResponderM ()
setRequest (Request -> ResponderM ()) -> Request -> ResponderM ()
forall a b. (a -> b) -> a -> b
$ Request
req {vault = V.insert parsedReqKey preq' (vault req)}
      ParsedRequest -> ResponderM ParsedRequest
forall a. a -> ResponderM a
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 = ParsedRequest -> Maybe ParsedRequest -> ParsedRequest
forall a. a -> Maybe a -> a
fromMaybe (Request -> ParsedRequest
parseRequest Request
req) (Maybe ParsedRequest -> ParsedRequest)
-> Maybe ParsedRequest -> ParsedRequest
forall a b. (a -> b) -> a -> b
$ Key ParsedRequest -> Vault -> Maybe ParsedRequest
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) -> Value -> ResponderM Value
forall a. a -> ResponderM a
forall (m :: * -> *) a. Monad m => a -> m a
return Value
json
    Maybe ParsedBody
_ -> do
      Either String Value
jsonE <- IO (Either String Value) -> ResponderM (Either String Value)
forall a. IO a -> ResponderM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either String Value) -> ResponderM (Either String Value))
-> IO (Either String Value) -> ResponderM (Either String Value)
forall a b. (a -> b) -> a -> b
$ IO (Either String Value) -> IO (Either String Value)
forall a. IO a -> IO a
wrapErr (IO (Either String Value) -> IO (Either String Value))
-> IO (Either String Value) -> IO (Either String Value)
forall a b. (a -> b) -> a -> b
$ ByteString -> Either String Value
forall a. FromJSON a => ByteString -> Either String a
JSON.eitherDecode (ByteString -> Either String Value)
-> IO ByteString -> IO (Either String Value)
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 -> HttpError -> ResponderM Value
forall e a. (HasCallStack, Exception e) => e -> ResponderM a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM (HttpError -> ResponderM Value) -> HttpError -> ResponderM Value
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 = Just (JSONBody json)}
          Request -> ResponderM ()
setRequest (Request -> ResponderM ()) -> Request -> ResponderM ()
forall a b. (a -> b) -> a -> b
$ Request
req {vault = V.insert parsedReqKey preq' (vault req)}
          Value -> ResponderM Value
forall a. a -> ResponderM a
forall (m :: * -> *) a. Monad m => a -> m a
return Value
json

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

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


wrapParseErr :: HTTP2Exception -> IO a
wrapParseErr :: forall a. HTTP2Exception -> IO a
wrapParseErr (HTTP2Exception (ErrorCode Word32
code)) = do
  let statusCode :: Int
statusCode = Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
code
      statusMsg :: Method
statusMsg = String -> Method
BC.pack (String -> Method) -> String -> Method
forall a b. (a -> b) -> a -> b
$ String
"HTTP/2 error: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Word32 -> String
forall a. Show a => a -> String
show Word32
code
      status :: Status
status = Int -> Method -> Status
mkStatus Int
statusCode Method
statusMsg
      errorMsg :: String
errorMsg = Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Method -> Text
decodeUtf8 Method
statusMsg
  HttpError -> IO a
forall e a. Exception e => e -> IO a
throwIO (HttpError -> IO a) -> HttpError -> IO a
forall a b. (a -> b) -> a -> b
$ Status -> String -> HttpError
HttpError Status
status String
errorMsg


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