{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE UndecidableInstances #-}

module Web.Hyperbole.Effect.Request where

import Data.Bifunctor (first)
import Data.List qualified as List
import Data.Maybe (isJust)
import Data.Text (Text)
import Effectful
import Effectful.Dispatch.Dynamic
import Network.HTTP.Types (QueryText)
import Web.FormUrlEncoded (Form, urlDecodeForm)
import Web.HttpApiData (FromHttpApiData, parseQueryParam)
import Web.Hyperbole.Effect.Hyperbole
import Web.Hyperbole.Effect.Server
import Web.View


-- | Return all information about the 'Request'
request :: (Hyperbole :> es) => Eff es Request
request :: forall (es :: [Effect]). (Hyperbole :> es) => Eff es Request
request = Hyperbole (Eff es) Request -> Eff es Request
forall (e :: Effect) (es :: [Effect]) a.
(HasCallStack, DispatchOf e ~ 'Dynamic, e :> es) =>
e (Eff es) a -> Eff es a
send Hyperbole (Eff es) Request
forall (a :: * -> *). Hyperbole a Request
GetRequest


{- | Return the request path

>>> reqPath
["users", "100"]
-}
reqPath :: (Hyperbole :> es) => Eff es [Segment]
reqPath :: forall (es :: [Effect]). (Hyperbole :> es) => Eff es [Segment]
reqPath = (.path) (Request -> [Segment]) -> Eff es Request -> Eff es [Segment]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Eff es Request
forall (es :: [Effect]). (Hyperbole :> es) => Eff es Request
request


{- | Return the request body as a Web.FormUrlEncoded.Form

Prefer using Type-Safe 'Form's when possible
-}
formBody :: (Hyperbole :> es) => Eff es Form
formBody :: forall (es :: [Effect]). (Hyperbole :> es) => Eff es Form
formBody = do
  ByteString
b <- (.body) (Request -> ByteString) -> Eff es Request -> Eff es ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Eff es Request
forall (es :: [Effect]). (Hyperbole :> es) => Eff es Request
request
  let ef :: Either Segment Form
ef = ByteString -> Either Segment Form
urlDecodeForm ByteString
b
  -- not going to work. we need a way to `throwError` or it doesn't work...
  (Segment -> Eff es Form)
-> (Form -> Eff es Form) -> Either Segment Form -> Eff es Form
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Hyperbole (Eff es) Form -> Eff es Form
forall (e :: Effect) (es :: [Effect]) a.
(HasCallStack, DispatchOf e ~ 'Dynamic, e :> es) =>
e (Eff es) a -> Eff es a
send (Hyperbole (Eff es) Form -> Eff es Form)
-> (Segment -> Hyperbole (Eff es) Form) -> Segment -> Eff es Form
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Response -> Hyperbole (Eff es) Form
forall (a :: * -> *) b. Response -> Hyperbole a b
RespondEarly (Response -> Hyperbole (Eff es) Form)
-> (Segment -> Response) -> Segment -> Hyperbole (Eff es) Form
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ResponseError -> Response
Err (ResponseError -> Response)
-> (Segment -> ResponseError) -> Segment -> Response
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Segment -> ResponseError
ErrParse) Form -> Eff es Form
forall a. a -> Eff es a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Either Segment Form
ef


{- | Return the entire 'Query'

@
myPage :: 'Page' es 'Response'
myPage = do
  'load' $ do
    q <- reqParams
    case 'lookupParam' "token" q of
      Nothing -> pure $ errorView "Missing Token in Query String"
      Just t -> do
        sideEffectUsingToken token
        pure myPageView
@
-}
reqParams :: (Hyperbole :> es) => Eff es QueryText
reqParams :: forall (es :: [Effect]). (Hyperbole :> es) => Eff es QueryText
reqParams = (.query) (Request -> QueryText) -> Eff es Request -> Eff es QueryText
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Eff es Request
forall (es :: [Effect]). (Hyperbole :> es) => Eff es Request
request


{- | Require a given parameter from the 'Query' arguments

@
myPage :: 'Page' es 'Response'
myPage = do
  'load' $ do
    token <- reqParam "token"
    sideEffectUsingToken token
    pure myPageView
@
-}
reqParam :: forall a es. (Hyperbole :> es, FromHttpApiData a) => Text -> Eff es a
reqParam :: forall a (es :: [Effect]).
(Hyperbole :> es, FromHttpApiData a) =>
Segment -> Eff es a
reqParam Segment
p = do
  QueryText
q <- Eff es QueryText
forall (es :: [Effect]). (Hyperbole :> es) => Eff es QueryText
reqParams
  (Either Response a
er :: Either Response a) <- Either Response a -> Eff es (Either Response a)
forall a. a -> Eff es a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Response a -> Eff es (Either Response a))
-> Either Response a -> Eff es (Either Response a)
forall a b. (a -> b) -> a -> b
$ do
    Maybe Segment
mv <- Maybe (Maybe Segment) -> Either Response (Maybe Segment)
forall x. Maybe x -> Either Response x
require (Maybe (Maybe Segment) -> Either Response (Maybe Segment))
-> Maybe (Maybe Segment) -> Either Response (Maybe Segment)
forall a b. (a -> b) -> a -> b
$ Segment -> QueryText -> Maybe (Maybe Segment)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
List.lookup Segment
p QueryText
q
    Segment
v <- Maybe Segment -> Either Response Segment
forall x. Maybe x -> Either Response x
require Maybe Segment
mv
    (Segment -> Response) -> Either Segment a -> Either Response a
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (ResponseError -> Response
Err (ResponseError -> Response)
-> (Segment -> ResponseError) -> Segment -> Response
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Segment -> ResponseError
ErrParam) (Either Segment a -> Either Response a)
-> Either Segment a -> Either Response a
forall a b. (a -> b) -> a -> b
$ Segment -> Either Segment a
forall a. FromHttpApiData a => Segment -> Either Segment a
parseQueryParam Segment
v
  case Either Response a
er of
    Left Response
e -> Hyperbole (Eff es) a -> Eff es a
forall (e :: Effect) (es :: [Effect]) a.
(HasCallStack, DispatchOf e ~ 'Dynamic, e :> es) =>
e (Eff es) a -> Eff es a
send (Hyperbole (Eff es) a -> Eff es a)
-> Hyperbole (Eff es) a -> Eff es a
forall a b. (a -> b) -> a -> b
$ Response -> Hyperbole (Eff es) a
forall (a :: * -> *) b. Response -> Hyperbole a b
RespondEarly Response
e
    Right a
a -> a -> Eff es a
forall a. a -> Eff es a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
 where
  require :: Maybe x -> Either Response x
  require :: forall x. Maybe x -> Either Response x
require Maybe x
Nothing = Response -> Either Response x
forall a b. a -> Either a b
Left (Response -> Either Response x) -> Response -> Either Response x
forall a b. (a -> b) -> a -> b
$ ResponseError -> Response
Err (ResponseError -> Response) -> ResponseError -> Response
forall a b. (a -> b) -> a -> b
$ Segment -> ResponseError
ErrParam (Segment -> ResponseError) -> Segment -> ResponseError
forall a b. (a -> b) -> a -> b
$ Segment
"Missing: " Segment -> Segment -> Segment
forall a. Semigroup a => a -> a -> a
<> Segment
p
  require (Just x
a) = x -> Either Response x
forall a. a -> Either Response a
forall (f :: * -> *) a. Applicative f => a -> f a
pure x
a

{- | Maybe version of 'reqParam'

@
myPage :: 'Page' es 'Response'
myPage = do
  'load' $ do
      mbToken <- lookupParam "token"
      sideEffectUsingToken $ fromMaybe "default" mbToken
      pure myPageView
@
-}
lookupParam :: forall a es. (Hyperbole :> es, FromHttpApiData a) => Text -> Eff es (Maybe a)
lookupParam :: forall a (es :: [Effect]).
(Hyperbole :> es, FromHttpApiData a) =>
Segment -> Eff es (Maybe a)
lookupParam Segment
p = do
  QueryText
q <- Eff es QueryText
forall (es :: [Effect]). (Hyperbole :> es) => Eff es QueryText
reqParams
  Maybe a -> Eff es (Maybe a)
forall a. a -> Eff es a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe a -> Eff es (Maybe a)) -> Maybe a -> Eff es (Maybe a)
forall a b. (a -> b) -> a -> b
$
    Segment -> QueryText -> Maybe (Maybe Segment)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Segment
p QueryText
q Maybe (Maybe Segment) -> (Maybe Segment -> Maybe a) -> Maybe a
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Maybe Segment
Nothing -> Maybe a
forall a. Maybe a
Nothing
      Just Segment
v -> (Segment -> Maybe a)
-> (a -> Maybe a) -> Either Segment a -> Maybe a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe a -> Segment -> Maybe a
forall a b. a -> b -> a
const Maybe a
forall a. Maybe a
Nothing) a -> Maybe a
forall a. a -> Maybe a
Just (Either Segment a -> Maybe a) -> Either Segment a -> Maybe a
forall a b. (a -> b) -> a -> b
$ Segment -> Either Segment a
forall a. FromHttpApiData a => Segment -> Either Segment a
parseQueryParam Segment
v


-- | Whether the param is present or not
hasParam :: Text -> QueryText -> Bool
hasParam :: Segment -> QueryText -> Bool
hasParam Segment
p QueryText
q =
  Maybe (Maybe Segment) -> Bool
forall a. Maybe a -> Bool
isJust (Maybe (Maybe Segment) -> Bool) -> Maybe (Maybe Segment) -> Bool
forall a b. (a -> b) -> a -> b
$ Segment -> QueryText -> Maybe (Maybe Segment)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Segment
p QueryText
q