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 = 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 :: Word64 -> ParseRequestBodyOptions -> ResponderOptions
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 (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 (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 :: Maybe ParsedBody -> [Param] -> [Param] -> [Param] -> ParsedRequest
ParsedRequest
        { preqPathParams :: [Param]
preqPathParams = [],
          preqQueryParams :: [Param]
preqQueryParams = (ByteString, Maybe ByteString) -> Param
decodeQueryParam ((ByteString, Maybe ByteString) -> Param)
-> [(ByteString, Maybe ByteString)] -> [Param]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Request -> [(ByteString, Maybe ByteString)]
queryString Request
req,
          preqCookieParams :: [Param]
preqCookieParams = Request -> [Param]
cookieParams Request
req,
          preqBody :: Maybe ParsedBody
preqBody = Maybe ParsedBody
forall a. Maybe a
Nothing
        }

match :: Maybe Method -> PathPattern -> Request -> Maybe [Param]
match :: Maybe ByteString -> PathPattern -> Request -> Maybe [Param]
match Maybe ByteString
method (MatchPath Request -> Maybe [Param]
f) Request
req
  | Bool -> (ByteString -> Bool) -> Maybe ByteString -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (Request -> ByteString
requestMethod Request
req ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
==) Maybe ByteString
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 (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 (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 ByteString -> 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 :: Maybe ParsedBody
preqBody = ParsedBody -> Maybe ParsedBody
forall a. a -> Maybe a
Just ParsedBody
parsedBody}
      Request -> ResponderM ()
setRequest (Request -> ResponderM ()) -> Request -> ResponderM ()
forall a b. (a -> b) -> a -> b
$ Request
req {vault :: Vault
vault = Key ParsedRequest -> ParsedRequest -> Vault -> Vault
forall a. Key a -> a -> Vault -> Vault
V.insert Key ParsedRequest
parsedReqKey ParsedRequest
preq' (Request -> Vault
vault Request
req)}
      ParsedRequest -> ResponderM ParsedRequest
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 (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 (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 (m :: * -> *) e a. (MonadThrow m, 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 :: Maybe ParsedBody
preqBody = ParsedBody -> Maybe ParsedBody
forall a. a -> Maybe a
Just (Value -> ParsedBody
JSONBody Value
json)}
          Request -> ResponderM ()
setRequest (Request -> ResponderM ()) -> Request -> ResponderM ()
forall a b. (a -> b) -> a -> b
$ Request
req {vault :: Vault
vault = Key ParsedRequest -> ParsedRequest -> Vault -> Vault
forall a. Key a -> a -> Vault -> Vault
V.insert Key ParsedRequest
parsedReqKey ParsedRequest
preq' (Request -> Vault
vault Request
req)}
          Value -> ResponderM Value
forall (m :: * -> *) a. Monad m => a -> m a
return Value
json

wrapErr :: 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
. (HTTP2Error -> IO a) -> IO a -> IO a
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
handle HTTP2Error -> IO a
forall a. HTTP2Error -> IO a
wrapParseErr

wrapMaxReqErr :: RequestSizeException -> IO a
wrapMaxReqErr :: 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 :: HTTP2Error -> IO a
wrapParseErr :: HTTP2Error -> IO a
wrapParseErr (ConnectionError (UnknownErrorCode ErrorCode
code) ByteString
msg) = do
  let msg' :: String
msg' = Text -> String
unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
decodeUtf8 ByteString
msg
  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 (Int -> ByteString -> Status
mkStatus (ErrorCode -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral ErrorCode
code) ByteString
msg) String
msg'
wrapParseErr (ConnectionError ErrorCodeId
_ ByteString
msg) = do
  let msg' :: String
msg' = Text -> String
unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
decodeUtf8 ByteString
msg
  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
status500 String
msg'

cookieParams :: Request -> [Param]
cookieParams :: Request -> [Param]
cookieParams Request
req =
  let headers :: [ByteString]
headers = (HeaderName, ByteString) -> ByteString
forall a b. (a, b) -> b
snd ((HeaderName, ByteString) -> ByteString)
-> [(HeaderName, ByteString)] -> [ByteString]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((HeaderName, ByteString) -> Bool)
-> [(HeaderName, ByteString)] -> [(HeaderName, ByteString)]
forall a. (a -> Bool) -> [a] -> [a]
L.filter (HeaderName -> HeaderName -> Bool
forall a. Eq a => a -> a -> Bool
(==) HeaderName
hCookie (HeaderName -> Bool)
-> ((HeaderName, ByteString) -> HeaderName)
-> (HeaderName, ByteString)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HeaderName, ByteString) -> HeaderName
forall a b. (a, b) -> a
fst) (Request -> [(HeaderName, ByteString)]
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
$ ByteString -> [Param]
parseCookiesText (ByteString -> [Param]) -> [ByteString] -> [[Param]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ByteString]
headers

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

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

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