module Web.Twain.Internal where

import Control.Exception (throwIO)
import Control.Monad (join)
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.Text as T
import Data.Text.Encoding
import Network.HTTP.Types (Method, hCookie, status204)
import Network.Wai (Application, Middleware, Request, lazyRequestBody, queryString, requestHeaders, requestMethod, responseLBS)
import Network.Wai.Parse (File, ParseRequestBodyOptions, lbsBackEnd, parseRequestBodyEx)
import Web.Cookie (SetCookie, parseCookiesText, renderSetCookie)
import Web.Twain.Types

type MaxRequestSizeBytes = Int64

routeState :: RouteM e (RouteState e)
routeState :: RouteM e (RouteState e)
routeState = (RouteState e
 -> IO (Either RouteAction (RouteState e, RouteState e)))
-> RouteM e (RouteState e)
forall e a.
(RouteState e -> IO (Either RouteAction (a, RouteState e)))
-> RouteM e a
RouteM ((RouteState e
  -> IO (Either RouteAction (RouteState e, RouteState e)))
 -> RouteM e (RouteState e))
-> (RouteState e
    -> IO (Either RouteAction (RouteState e, RouteState e)))
-> RouteM e (RouteState e)
forall a b. (a -> b) -> a -> b
$ \RouteState e
s -> Either RouteAction (RouteState e, RouteState e)
-> IO (Either RouteAction (RouteState e, RouteState e))
forall (m :: * -> *) a. Monad m => a -> m a
return ((RouteState e, RouteState e)
-> Either RouteAction (RouteState e, RouteState e)
forall a b. b -> Either a b
Right (RouteState e
s, RouteState e
s))

setRouteState :: RouteState e -> RouteM e ()
setRouteState :: RouteState e -> RouteM e ()
setRouteState RouteState e
s = (RouteState e -> IO (Either RouteAction ((), RouteState e)))
-> RouteM e ()
forall e a.
(RouteState e -> IO (Either RouteAction (a, RouteState e)))
-> RouteM e a
RouteM ((RouteState e -> IO (Either RouteAction ((), RouteState e)))
 -> RouteM e ())
-> (RouteState e -> IO (Either RouteAction ((), RouteState e)))
-> RouteM e ()
forall a b. (a -> b) -> a -> b
$ \RouteState e
_ -> Either RouteAction ((), RouteState e)
-> IO (Either RouteAction ((), RouteState e))
forall (m :: * -> *) a. Monad m => a -> m a
return (((), RouteState e) -> Either RouteAction ((), RouteState e)
forall a b. b -> Either a b
Right ((), RouteState e
s))

concatParams :: RouteState e -> [Param]
concatParams :: RouteState e -> [Param]
concatParams RouteState e
p =
  RouteState e -> [Param]
forall e. RouteState e -> [Param]
reqBodyParams RouteState e
p
    [Param] -> [Param] -> [Param]
forall a. Semigroup a => a -> a -> a
<> RouteState e -> [Param]
forall e. RouteState e -> [Param]
reqCookieParams RouteState e
p
    [Param] -> [Param] -> [Param]
forall a. Semigroup a => a -> a -> a
<> RouteState e -> [Param]
forall e. RouteState e -> [Param]
reqPathParams RouteState e
p
    [Param] -> [Param] -> [Param]
forall a. Semigroup a => a -> a -> a
<> RouteState e -> [Param]
forall e. RouteState e -> [Param]
reqQueryParams RouteState e
p

composeMiddleware :: [Middleware] -> Application
composeMiddleware :: [Middleware] -> Application
composeMiddleware = (Application -> Middleware -> Application)
-> Application -> [Middleware] -> Application
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
L.foldl' (\Application
a Middleware
m -> Middleware
m Application
a) Application
emptyApp

routeMiddleware ::
  Maybe Method ->
  PathPattern ->
  RouteM e a ->
  e ->
  Middleware
routeMiddleware :: Maybe Method -> PathPattern -> RouteM e a -> e -> Middleware
routeMiddleware Maybe Method
method PathPattern
pat (RouteM RouteState e -> IO (Either RouteAction (a, RouteState e))
route) e
env Application
app Request
req Response -> IO ResponseReceived
respond =
  case Maybe Method -> PathPattern -> Request -> Maybe [Param]
match Maybe Method
method PathPattern
pat Request
req of
    Maybe [Param]
Nothing -> Application
app Request
req Response -> IO ResponseReceived
respond
    Just [Param]
pathParams -> do
      let st :: RouteState e
st =
            RouteState :: forall e.
[Param]
-> [File ByteString]
-> [Param]
-> [Param]
-> [Param]
-> Either String Value
-> Bool
-> e
-> Request
-> RouteState e
RouteState
              { reqBodyParams :: [Param]
reqBodyParams = [],
                reqBodyFiles :: [File ByteString]
reqBodyFiles = [],
                reqPathParams :: [Param]
reqPathParams = [Param]
pathParams,
                reqQueryParams :: [Param]
reqQueryParams = (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,
                reqCookieParams :: [Param]
reqCookieParams = Request -> [Param]
cookieParams Request
req,
                reqBodyJson :: Either String Value
reqBodyJson = String -> Either String Value
forall a b. a -> Either a b
Left String
"missing JSON body",
                reqBodyParsed :: Bool
reqBodyParsed = Bool
False,
                reqEnv :: e
reqEnv = e
env,
                reqWai :: Request
reqWai = Request
req
              }
      Either RouteAction (a, RouteState e)
action <- RouteState e -> IO (Either RouteAction (a, RouteState e))
route RouteState e
st
      case Either RouteAction (a, RouteState e)
action of
        Left (Respond Response
res) -> Response -> IO ResponseReceived
respond Response
res
        Either RouteAction (a, RouteState e)
_ -> Application
app Request
req Response -> IO ResponseReceived
respond

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

parseBody :: ParseRequestBodyOptions -> RouteM e ([Param], [File BL.ByteString])
parseBody :: ParseRequestBodyOptions -> RouteM e ([Param], [File ByteString])
parseBody ParseRequestBodyOptions
opts = do
  RouteState e
s <- RouteM e (RouteState e)
forall e. RouteM e (RouteState e)
routeState
  if RouteState e -> Bool
forall e. RouteState e -> Bool
reqBodyParsed RouteState e
s
    then ([Param], [File ByteString])
-> RouteM e ([Param], [File ByteString])
forall (m :: * -> *) a. Monad m => a -> m a
return (RouteState e -> [Param]
forall e. RouteState e -> [Param]
concatParams RouteState e
s, RouteState e -> [File ByteString]
forall e. RouteState e -> [File ByteString]
reqBodyFiles RouteState e
s)
    else do
      ([Param]
ps, [File ByteString]
fs) <- IO ([Param], [File ByteString])
-> RouteM e ([Param], [File ByteString])
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ([Param], [File ByteString])
 -> RouteM e ([Param], [File ByteString]))
-> IO ([Param], [File ByteString])
-> RouteM e ([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 (RouteState e -> Request
forall e. RouteState e -> Request
reqWai RouteState e
s)
      let sb :: RouteState e
sb =
            RouteState e
s
              { reqBodyParams :: [Param]
reqBodyParams = Param -> Param
decodeBsParam (Param -> Param) -> [Param] -> [Param]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Param]
ps,
                reqBodyFiles :: [File ByteString]
reqBodyFiles = [File ByteString]
fs,
                reqBodyParsed :: Bool
reqBodyParsed = Bool
True
              }
      RouteState e -> RouteM e ()
forall e. RouteState e -> RouteM e ()
setRouteState RouteState e
sb
      ([Param], [File ByteString])
-> RouteM e ([Param], [File ByteString])
forall (m :: * -> *) a. Monad m => a -> m a
return (RouteState e -> [Param]
forall e. RouteState e -> [Param]
concatParams RouteState e
sb, RouteState e -> [File ByteString]
forall e. RouteState e -> [File ByteString]
reqBodyFiles RouteState e
sb)

parseBodyJson :: RouteM e (Either String JSON.Value)
parseBodyJson :: RouteM e (Either String Value)
parseBodyJson = do
  RouteState e
s <- RouteM e (RouteState e)
forall e. RouteM e (RouteState e)
routeState
  if RouteState e -> Bool
forall e. RouteState e -> Bool
reqBodyParsed RouteState e
s
    then Either String Value -> RouteM e (Either String Value)
forall (m :: * -> *) a. Monad m => a -> m a
return (RouteState e -> Either String Value
forall e. RouteState e -> Either String Value
reqBodyJson RouteState e
s)
    else do
      Either String Value
jsonE <- IO (Either String Value) -> RouteM e (Either String Value)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either String Value) -> RouteM e (Either String Value))
-> IO (Either String Value) -> RouteM e (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 (RouteState e -> Request
forall e. RouteState e -> Request
reqWai RouteState e
s)
      RouteState e -> RouteM e ()
forall e. RouteState e -> RouteM e ()
setRouteState (RouteState e -> RouteM e ()) -> RouteState e -> RouteM e ()
forall a b. (a -> b) -> a -> b
$ RouteState e
s {reqBodyJson :: Either String Value
reqBodyJson = Either String Value
jsonE, reqBodyParsed :: Bool
reqBodyParsed = Bool
True}
      Either String Value -> RouteM e (Either String Value)
forall (m :: * -> *) a. Monad m => a -> m a
return Either String Value
jsonE

cookieParams :: Request -> [Param]
cookieParams :: Request -> [Param]
cookieParams 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)

emptyApp :: Application
emptyApp :: Application
emptyApp Request
req Response -> IO ResponseReceived
respond = Response -> IO ResponseReceived
respond (Response -> IO ResponseReceived)
-> Response -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ Status -> [(HeaderName, Method)] -> ByteString -> Response
responseLBS Status
status204 [] ByteString
""