{-# LANGUAGE AllowAmbiguousTypes, UndecidableInstances, LambdaCase, ScopedTypeVariables #-}
module IHP.RouterSupport (
CanRoute (..)
, HasPath (..)
, AutoRoute (..)
, runAction
, get
, post
, startPage
, frontControllerToWAIApp
, withPrefix
, FrontController (..)
, defaultRouter
, parseRoute
, catchAll
, mountFrontController
, createAction
, updateAction
, urlTo
, parseUUID
, parseId
, parseIntegerId
, remainingText
, parseText
, webSocketApp
, webSocketAppWithCustomPath
, webSocketAppWithHTTPFallback
, onlyAllowMethods
, getMethod
, routeParam
, withImplicits
, applyConstr
, ControllerRoute (..)
, findInRouteMaps
, buildAutoRouteMap
) where

import Prelude hiding (take)
import Data.ByteString (ByteString)
import Data.Text (Text)
import Data.Maybe (fromMaybe, mapMaybe)
import Data.List (find, isPrefixOf)
import Control.Monad (unless, join)
import Control.Applicative ((<|>), empty)
import Text.Read (readMaybe)
import Control.Exception.Safe (SomeException, catch, throwIO)
import Control.Exception (evaluate)
import qualified IHP.ModelSupport as ModelSupport
import IHP.FrameworkConfig
import Data.UUID
import Network.HTTP.Types.Method
import Network.Wai
import IHP.ControllerSupport
import Data.Attoparsec.ByteString.Char8 (string, Parser, parseOnly, take, endOfInput, choice, takeTill, takeByteString)
import qualified Data.Attoparsec.ByteString.Char8 as Attoparsec
import GHC.TypeLits
import Data.Data
import qualified Control.Monad.State.Strict as State
import qualified Data.Text as Text
import Network.HTTP.Types.URI
import qualified Data.List as List
import Unsafe.Coerce
import IHP.HaskellSupport hiding (get)
import qualified Data.Typeable as Typeable
import qualified Data.ByteString.Char8 as ByteString
import Data.String.Conversions (ConvertibleStrings (convertString), cs)
import qualified Text.Blaze.Html5 as Html5
import qualified Control.Exception as Exception
import qualified IHP.ErrorController as ErrorController
import qualified Network.URI.Encode as URI
import qualified Data.Text.Encoding as Text
import Data.Dynamic
import IHP.Router.Types
import IHP.Router.UrlGenerator
import qualified Data.HashMap.Strict as HashMap
import IHP.WebSocket (WSApp)
import qualified IHP.WebSocket as WS
import GHC.TypeLits as T
import IHP.Controller.Context
import IHP.Controller.Param
import Data.Kind
import qualified Data.TMap as TypeMap
import Network.Wai.Middleware.EarlyReturn (earlyReturnMiddleware)

-- | Binds @?request@ and @?respond@ from WAI arguments, then runs the given action.
--
-- This avoids repeating @let ?request = waiRequest; let ?respond = waiRespond@ at each call site.
{-# INLINE withImplicits #-}
withImplicits :: ((?request :: Request, ?respond :: Respond) => Application) -> Application
withImplicits :: ((?request::Request, ?respond::Respond) => Application)
-> Application
withImplicits (?request::Request, ?respond::Respond) => Application
action Request
waiRequest Respond
waiRespond =
    let ?request = ?request::Request
Request
waiRequest
        ?respond = ?respond::Respond
Respond
waiRespond
    in (?request::Request, ?respond::Respond) => Application
Application
action Request
waiRequest Respond
waiRespond

runAction'
    :: forall application controller
     . ( Controller controller
       , InitControllerContext application
       , ?application :: application
       , Typeable application
       , Typeable controller
       )
     => controller -> Application
runAction' :: forall application controller.
(Controller controller, InitControllerContext application,
 ?application::application, Typeable application,
 Typeable controller) =>
controller -> Application
runAction' controller
controller Request
waiRequest Respond
waiRespond =
    Middleware
earlyReturnMiddleware (\Request
request Respond
respond -> do
        context <- forall application.
(InitControllerContext application, ?application::application,
 Typeable application) =>
TypeRep -> Request -> Respond -> IO ControllerContext
setupActionContext @application (controller -> TypeRep
forall a. Typeable a => a -> TypeRep
Typeable.typeOf controller
controller) Request
request Respond
respond
        let ?context = context
        let ?respond = respond
        let ?request = context.request
        let ?modelContext = ?request.modelContext
        runAction controller
        ) Request
waiRequest Respond
waiRespond
{-# INLINE runAction' #-}

-- | Catches exceptions from routing and rethrows them wrapped in
-- 'RouterException' so the error handler middleware can distinguish
-- routing failures from action failures.
wrapRouterException :: IO a -> IO a
wrapRouterException :: forall a. IO a -> IO a
wrapRouterException IO a
action = IO a
action IO a -> (SomeException -> IO a) -> IO a
forall (m :: * -> *) e a.
(HasCallStack, MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` \(SomeException
e :: SomeException) -> RouterException -> IO a
forall (m :: * -> *) e a.
(HasCallStack, MonadThrow m, Exception e) =>
e -> m a
throwIO (SomeException -> RouterException
ErrorController.RouterException SomeException
e)

class FrontController application where
    controllers
        :: (?application :: application, ?request :: Request, ?respond :: Respond)
        => [ControllerRoute application]

    router
        :: (?application :: application, ?request :: Request, ?respond :: Respond)
        => [ControllerRoute application] -> Parser Application
    router = [ControllerRoute application] -> Parser Application
forall application.
(?application::application, ?request::Request, ?respond::Respond,
 FrontController application) =>
[ControllerRoute application] -> Parser Application
defaultRouter
    {-# INLINABLE router #-}

defaultRouter
    :: (?application :: application, ?request :: Request, ?respond :: Respond, FrontController application)
    => [ControllerRoute application] -> Parser Application
defaultRouter :: forall application.
(?application::application, ?request::Request, ?respond::Respond,
 FrontController application) =>
[ControllerRoute application] -> Parser Application
defaultRouter [ControllerRoute application]
additionalRoutes = do
    let allRoutes :: [ControllerRoute application]
allRoutes = [ControllerRoute application]
forall application.
(FrontController application, ?application::application,
 ?request::Request, ?respond::Respond) =>
[ControllerRoute application]
controllers [ControllerRoute application]
-> [ControllerRoute application] -> [ControllerRoute application]
forall a. Semigroup a => a -> a -> a
<> [ControllerRoute application]
additionalRoutes
        path :: ByteString
path = Request -> ByteString
rawPathInfo ?request::Request
Request
?request
    -- Fast path: check auto-route HashMaps directly (no Attoparsec string matching)
    case ByteString
-> [ControllerRoute application]
-> Maybe (application -> Application)
forall application.
ByteString
-> [ControllerRoute application]
-> Maybe (application -> Application)
findInRouteMaps ByteString
path [ControllerRoute application]
allRoutes of
        Just application -> Application
handler -> Parser ByteString
takeByteString Parser ByteString -> Parser Application -> Parser Application
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Application -> Parser Application
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (application -> Application
handler application
?application::application
?application)
        Maybe (application -> Application)
Nothing -> do
            -- Slow path: fall back to Attoparsec parsers for custom/dynamic routes
            let parsers :: [Parser Application]
parsers = (ControllerRoute application -> [Parser Application])
-> [ControllerRoute application] -> [Parser Application]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ControllerRoute application -> [Parser Application]
forall application.
ControllerRoute application -> [Parser Application]
getRouteParsers [ControllerRoute application]
allRoutes
            [Parser Application] -> Parser Application
forall (f :: * -> *) a. Alternative f => [f a] -> f a
choice ((Parser Application -> Parser Application)
-> [Parser Application] -> [Parser Application]
forall a b. (a -> b) -> [a] -> [b]
map (Parser Application -> Parser ByteString () -> Parser Application
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ByteString ()
forall t. Chunk t => Parser t ()
endOfInput) [Parser Application]
parsers)
{-# INLINABLE defaultRouter #-}

-- | Scan 'ControllerRouteMap' entries for a matching path.
-- Returns as soon as a HashMap contains the path. Skips 'ControllerRouteParser' entries.
findInRouteMaps :: ByteString -> [ControllerRoute application] -> Maybe (application -> Application)
findInRouteMaps :: forall application.
ByteString
-> [ControllerRoute application]
-> Maybe (application -> Application)
findInRouteMaps ByteString
_ [] = Maybe (application -> Application)
forall a. Maybe a
Nothing
findInRouteMaps ByteString
path (ControllerRouteMap HashMap ByteString (application -> Application)
m Parser Application
_ : [ControllerRoute application]
rest) =
    case ByteString
-> HashMap ByteString (application -> Application)
-> Maybe (application -> Application)
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup ByteString
path HashMap ByteString (application -> Application)
m of
        Just application -> Application
handler -> (application -> Application) -> Maybe (application -> Application)
forall a. a -> Maybe a
Just application -> Application
handler
        Maybe (application -> Application)
Nothing -> ByteString
-> [ControllerRoute application]
-> Maybe (application -> Application)
forall application.
ByteString
-> [ControllerRoute application]
-> Maybe (application -> Application)
findInRouteMaps ByteString
path [ControllerRoute application]
rest
findInRouteMaps ByteString
path (ControllerRoute application
_ : [ControllerRoute application]
rest) = ByteString
-> [ControllerRoute application]
-> Maybe (application -> Application)
forall application.
ByteString
-> [ControllerRoute application]
-> Maybe (application -> Application)
findInRouteMaps ByteString
path [ControllerRoute application]
rest

-- | Extract fallback parsers from controller routes.
getRouteParsers :: ControllerRoute application -> [Parser Application]
getRouteParsers :: forall application.
ControllerRoute application -> [Parser Application]
getRouteParsers (ControllerRouteMap HashMap ByteString (application -> Application)
_ Parser Application
fallback) = [Parser Application
fallback]
getRouteParsers (ControllerRouteParser Parser Application
p) = [Parser Application
p]

-- | Returns the url to a given action.
--
-- Uses the baseUrl configured in @Config/Config.hs@. When no @baseUrl@
-- is configured in development mode, it will automatically detect the
-- correct @baseUrl@ value.
--
-- >>> urlTo UsersAction
-- "http://localhost:8000/Users"
--
-- >>> urlTo ShowUserAction { userId = "a32913dd-ef80-4f3e-9a91-7879e17b2ece" }
-- "http://localhost:8000/ShowUser?userId=a32913dd-ef80-4f3e-9a91-7879e17b2ece"
urlTo :: (?context :: context, ConfigProvider context, HasPath action) => action -> Text
urlTo :: forall context action.
(?context::context, ConfigProvider context, HasPath action) =>
action -> Text
urlTo action
action = context
?context::context
?context.frameworkConfig.baseUrl Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> action -> Text
forall controller. HasPath controller => controller -> Text
pathTo action
action
{-# INLINE urlTo #-}

class HasPath controller => CanRoute controller where
    parseRoute' :: (?request :: Request, ?respond :: Respond) => Parser controller

    -- | Builds a WAI Application parser for this controller.
    --
    -- The default implementation parses the controller action using 'parseRoute''
    -- and applies the given callback. The overlappable 'AutoRoute' instance overrides
    -- this to defer query string parsing and method validation to the Application closure.
    parseRouteWithAction :: (?request :: Request, ?respond :: Respond) => (controller -> Application) -> Parser Application
    parseRouteWithAction controller -> Application
toApp = do
        action <- Parser controller
forall controller.
(CanRoute controller, ?request::Request, ?respond::Respond) =>
Parser controller
parseRoute'
        pure (toApp action)
    {-# INLINE parseRouteWithAction #-}

    -- | Build a 'ControllerRoute' for this controller.
    --
    -- The default wraps the parser in 'ControllerRouteParser'.
    -- The overlappable 'AutoRoute' instance overrides this to use 'ControllerRouteMap'
    -- for O(1) HashMap dispatch. This is what 'parseRoute' calls.
    toControllerRoute :: forall application.
        ( ?request :: Request
        , ?respond :: Respond
        , Controller controller
        , InitControllerContext application
        , ?application :: application
        , Typeable application
        , Typeable controller
        ) => ControllerRoute application
    toControllerRoute = Parser Application -> ControllerRoute application
forall application.
Parser Application -> ControllerRoute application
ControllerRouteParser (forall controller.
(CanRoute controller, ?request::Request, ?respond::Respond) =>
(controller -> Application) -> Parser Application
parseRouteWithAction @controller (forall application controller.
(Controller controller, InitControllerContext application,
 ?application::application, Typeable application,
 Typeable controller) =>
controller -> Application
runAction' @application))
    {-# INLINABLE toControllerRoute #-}


-- | Each of these is tried when trying to parse an argument to a controller constructor (i.e. in IHP, an action).
-- The type @d@ is an the type of the argument, and all we know about this type that its conforms to @Data@.
-- We cannot cast @d@ to some arbitrary type, since adding additional constraints to @d@ (such as Read)
-- will break the @fromConstrM@ function which actually constructs the action.
--
-- The approach taken here is to make use of the type equality operator @:~:@
-- to check and see if @d@ happens to be a certain type. If it is,
-- by matching on Just Refl, we are able to use @d@ as the type we matched it to.
--
-- Please consult your doctor before engaging in Haskell type programming.
parseFuncs :: forall d idType. (Data d, Data idType) => (ByteString -> Maybe idType) -> [Maybe ByteString -> Either TypedAutoRouteError d]
parseFuncs :: forall d idType.
(Data d, Data idType) =>
(ByteString -> Maybe idType)
-> [Maybe ByteString -> Either TypedAutoRouteError d]
parseFuncs ByteString -> Maybe idType
parseIdType = [
            -- Try and parse @Int@ or @Maybe Int@
            \case
                Just ByteString
queryValue -> case Maybe (d :~: Int)
forall {k} (a :: k) (b :: k).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
eqT :: Maybe (d :~: Int) of
                    Just d :~: Int
Refl -> case ByteString -> Maybe (Int, ByteString)
ByteString.readInt ByteString
queryValue of
                        Just (Int
n, ByteString
"") -> d -> Either TypedAutoRouteError d
forall a b. b -> Either a b
Right d
Int
n
                        Maybe (Int, ByteString)
_ -> TypedAutoRouteError -> Either TypedAutoRouteError d
forall a b. a -> Either a b
Left BadType { field :: ByteString
field = ByteString
"", value :: Maybe ByteString
value = ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
queryValue, expectedType :: ByteString
expectedType = ByteString
"Int" }
                    Maybe (d :~: Int)
Nothing -> case Maybe (d :~: Maybe Int)
forall {k} (a :: k) (b :: k).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
eqT :: Maybe (d :~: Maybe Int) of
                        Just d :~: Maybe Int
Refl -> d -> Either TypedAutoRouteError d
forall a b. b -> Either a b
Right (d -> Either TypedAutoRouteError d)
-> d -> Either TypedAutoRouteError d
forall a b. (a -> b) -> a -> b
$ case ByteString -> Maybe (Int, ByteString)
ByteString.readInt ByteString
queryValue of
                            Just (Int
n, ByteString
"") -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
n
                            Maybe (Int, ByteString)
_ -> d
Maybe Int
forall a. Maybe a
Nothing
                        Maybe (d :~: Maybe Int)
Nothing -> TypedAutoRouteError -> Either TypedAutoRouteError d
forall a b. a -> Either a b
Left TypedAutoRouteError
NotMatched
                Maybe ByteString
Nothing -> case Maybe (d :~: Maybe Int)
forall {k} (a :: k) (b :: k).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
eqT :: Maybe (d :~: Maybe Int) of
                    Just d :~: Maybe Int
Refl -> d -> Either TypedAutoRouteError d
forall a b. b -> Either a b
Right d
Maybe Int
forall a. Maybe a
Nothing
                    Maybe (d :~: Maybe Int)
Nothing -> TypedAutoRouteError -> Either TypedAutoRouteError d
forall a b. a -> Either a b
Left TypedAutoRouteError
NotMatched,

            \case
                Just ByteString
queryValue -> case Maybe (d :~: Integer)
forall {k} (a :: k) (b :: k).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
eqT :: Maybe (d :~: Integer) of
                    Just d :~: Integer
Refl -> case ByteString -> Maybe (Integer, ByteString)
ByteString.readInteger ByteString
queryValue of
                        Just (Integer
n, ByteString
"") -> d -> Either TypedAutoRouteError d
forall a b. b -> Either a b
Right d
Integer
n
                        Maybe (Integer, ByteString)
_ -> TypedAutoRouteError -> Either TypedAutoRouteError d
forall a b. a -> Either a b
Left BadType { field :: ByteString
field = ByteString
"", value :: Maybe ByteString
value = ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
queryValue, expectedType :: ByteString
expectedType = ByteString
"Integer" }
                    Maybe (d :~: Integer)
Nothing -> case Maybe (d :~: Maybe Integer)
forall {k} (a :: k) (b :: k).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
eqT :: Maybe (d :~: Maybe Integer) of
                        Just d :~: Maybe Integer
Refl -> d -> Either TypedAutoRouteError d
forall a b. b -> Either a b
Right (d -> Either TypedAutoRouteError d)
-> d -> Either TypedAutoRouteError d
forall a b. (a -> b) -> a -> b
$ case ByteString -> Maybe (Integer, ByteString)
ByteString.readInteger ByteString
queryValue of
                            Just (Integer
n, ByteString
"") -> Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
n
                            Maybe (Integer, ByteString)
_ -> d
Maybe Integer
forall a. Maybe a
Nothing
                        Maybe (d :~: Maybe Integer)
Nothing -> TypedAutoRouteError -> Either TypedAutoRouteError d
forall a b. a -> Either a b
Left TypedAutoRouteError
NotMatched
                Maybe ByteString
Nothing -> case Maybe (d :~: Maybe Integer)
forall {k} (a :: k) (b :: k).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
eqT :: Maybe (d :~: Maybe Integer) of
                    Just d :~: Maybe Integer
Refl -> d -> Either TypedAutoRouteError d
forall a b. b -> Either a b
Right d
Maybe Integer
forall a. Maybe a
Nothing
                    Maybe (d :~: Maybe Integer)
Nothing -> TypedAutoRouteError -> Either TypedAutoRouteError d
forall a b. a -> Either a b
Left TypedAutoRouteError
NotMatched,

            -- Try and parse @Text@ or @Maybe Text@
            \case
                Just ByteString
queryValue -> case Maybe (d :~: Text)
forall {k} (a :: k) (b :: k).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
eqT :: Maybe (d :~: Text) of
                    Just d :~: Text
Refl -> d -> Either TypedAutoRouteError d
forall a b. b -> Either a b
Right (d -> Either TypedAutoRouteError d)
-> d -> Either TypedAutoRouteError d
forall a b. (a -> b) -> a -> b
$ ByteString -> d
forall a b. ConvertibleStrings a b => a -> b
cs ByteString
queryValue
                    Maybe (d :~: Text)
Nothing -> case Maybe (d :~: Maybe Text)
forall {k} (a :: k) (b :: k).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
eqT :: Maybe (d :~: Maybe Text) of
                        Just d :~: Maybe Text
Refl -> d -> Either TypedAutoRouteError d
forall a b. b -> Either a b
Right (d -> Either TypedAutoRouteError d)
-> d -> Either TypedAutoRouteError d
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
forall a b. ConvertibleStrings a b => a -> b
cs ByteString
queryValue
                        Maybe (d :~: Maybe Text)
Nothing -> TypedAutoRouteError -> Either TypedAutoRouteError d
forall a b. a -> Either a b
Left TypedAutoRouteError
NotMatched
                Maybe ByteString
Nothing -> case Maybe (d :~: Maybe Text)
forall {k} (a :: k) (b :: k).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
eqT :: Maybe (d :~: Maybe Text) of
                    Just d :~: Maybe Text
Refl -> d -> Either TypedAutoRouteError d
forall a b. b -> Either a b
Right d
Maybe Text
forall a. Maybe a
Nothing
                    Maybe (d :~: Maybe Text)
Nothing -> TypedAutoRouteError -> Either TypedAutoRouteError d
forall a b. a -> Either a b
Left TypedAutoRouteError
NotMatched,
            \case
                Just ByteString
queryValue -> case ByteString -> Maybe idType
parseIdType ByteString
queryValue of
                    Just idType
idValue -> case Maybe (d :~: idType)
forall {k} (a :: k) (b :: k).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
eqT :: Maybe (d :~: idType) of
                        Just d :~: idType
Refl -> d -> Either TypedAutoRouteError d
forall a b. b -> Either a b
Right d
idType
idValue
                        Maybe (d :~: idType)
Nothing -> TypedAutoRouteError -> Either TypedAutoRouteError d
forall a b. a -> Either a b
Left TypedAutoRouteError
NotMatched
                    Maybe idType
Nothing -> TypedAutoRouteError -> Either TypedAutoRouteError d
forall a b. a -> Either a b
Left TypedAutoRouteError
NotMatched
                Maybe ByteString
Nothing -> TypedAutoRouteError -> Either TypedAutoRouteError d
forall a b. a -> Either a b
Left TypedAutoRouteError
NotMatched,

            -- Try and parse @[Text]@. If value is not present then default to empty list.
            \Maybe ByteString
queryValue -> case Maybe (d :~: [Text])
forall {k} (a :: k) (b :: k).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
eqT :: Maybe (d :~: [Text]) of
                Just d :~: [Text]
Refl -> case Maybe ByteString
queryValue of
                    Just ByteString
queryValue -> [Text] -> Either TypedAutoRouteError [Text]
forall a b. b -> Either a b
Right ([Text] -> Either TypedAutoRouteError [Text])
-> [Text] -> Either TypedAutoRouteError [Text]
forall a b. (a -> b) -> a -> b
$ HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
Text.splitOn Text
"," (ByteString -> Text
forall a b. ConvertibleStrings a b => a -> b
cs ByteString
queryValue)
                    Maybe ByteString
Nothing -> d -> Either TypedAutoRouteError d
forall a b. b -> Either a b
Right []
                Maybe (d :~: [Text])
Nothing -> TypedAutoRouteError -> Either TypedAutoRouteError d
forall a b. a -> Either a b
Left TypedAutoRouteError
NotMatched,

            -- Try and parse @[Int]@. If value is not present then default to empty list.
            \Maybe ByteString
queryValue -> case Maybe (d :~: [Int])
forall {k} (a :: k) (b :: k).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
eqT :: Maybe (d :~: [Int]) of
                Just d :~: [Int]
Refl -> case Maybe ByteString
queryValue of
                    Just ByteString
queryValue -> Char -> ByteString -> [ByteString]
ByteString.split Char
',' ByteString
queryValue
                        [ByteString] -> ([ByteString] -> [Int]) -> [Int]
forall a b. a -> (a -> b) -> b
|> (ByteString -> Maybe Int) -> [ByteString] -> [Int]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\ByteString
b -> case ByteString -> Maybe (Int, ByteString)
ByteString.readInt ByteString
b of Just (Int
n, ByteString
"") -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
n; Maybe (Int, ByteString)
_ -> Maybe Int
forall a. Maybe a
Nothing)
                        [Int]
-> ([Int] -> Either TypedAutoRouteError d)
-> Either TypedAutoRouteError d
forall a b. a -> (a -> b) -> b
|> [Int] -> Either TypedAutoRouteError d
[Int] -> Either TypedAutoRouteError [Int]
forall a b. b -> Either a b
Right
                    Maybe ByteString
Nothing -> d -> Either TypedAutoRouteError d
forall a b. b -> Either a b
Right []
                Maybe (d :~: [Int])
Nothing -> TypedAutoRouteError -> Either TypedAutoRouteError d
forall a b. a -> Either a b
Left TypedAutoRouteError
NotMatched,

            \Maybe ByteString
queryValue -> case Maybe (d :~: [Integer])
forall {k} (a :: k) (b :: k).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
eqT :: Maybe (d :~: [Integer]) of
                Just d :~: [Integer]
Refl -> case Maybe ByteString
queryValue of
                    Just ByteString
queryValue -> Char -> ByteString -> [ByteString]
ByteString.split Char
',' ByteString
queryValue
                        [ByteString] -> ([ByteString] -> [Integer]) -> [Integer]
forall a b. a -> (a -> b) -> b
|> (ByteString -> Maybe Integer) -> [ByteString] -> [Integer]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\ByteString
b -> case ByteString -> Maybe (Integer, ByteString)
ByteString.readInteger ByteString
b of Just (Integer
n, ByteString
"") -> Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
n; Maybe (Integer, ByteString)
_ -> Maybe Integer
forall a. Maybe a
Nothing)
                        [Integer]
-> ([Integer] -> Either TypedAutoRouteError d)
-> Either TypedAutoRouteError d
forall a b. a -> (a -> b) -> b
|> [Integer] -> Either TypedAutoRouteError d
[Integer] -> Either TypedAutoRouteError [Integer]
forall a b. b -> Either a b
Right
                    Maybe ByteString
Nothing -> d -> Either TypedAutoRouteError d
forall a b. b -> Either a b
Right []
                Maybe (d :~: [Integer])
Nothing -> TypedAutoRouteError -> Either TypedAutoRouteError d
forall a b. a -> Either a b
Left TypedAutoRouteError
NotMatched,

            -- Try and parse a raw [UUID]
            \Maybe ByteString
queryValue -> case Maybe (d :~: [UUID])
forall {k} (a :: k) (b :: k).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
eqT :: Maybe (d :~: [UUID]) of
                Just d :~: [UUID]
Refl -> case Maybe ByteString
queryValue of
                    Just ByteString
queryValue -> Char -> ByteString -> [ByteString]
ByteString.split Char
',' ByteString
queryValue
                        [ByteString] -> ([ByteString] -> [UUID]) -> [UUID]
forall a b. a -> (a -> b) -> b
|> (ByteString -> Maybe UUID) -> [ByteString] -> [UUID]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ByteString -> Maybe UUID
fromASCIIBytes
                        [UUID]
-> ([UUID] -> Either TypedAutoRouteError d)
-> Either TypedAutoRouteError d
forall a b. a -> (a -> b) -> b
|> [UUID] -> Either TypedAutoRouteError d
[UUID] -> Either TypedAutoRouteError [UUID]
forall a b. b -> Either a b
Right
                    Maybe ByteString
Nothing -> d -> Either TypedAutoRouteError d
forall a b. b -> Either a b
Right []
                Maybe (d :~: [UUID])
Nothing -> TypedAutoRouteError -> Either TypedAutoRouteError d
forall a b. a -> Either a b
Left TypedAutoRouteError
NotMatched,

            -- Try and parse a raw UUID
            \Maybe ByteString
queryValue -> case Maybe (d :~: UUID)
forall {k} (a :: k) (b :: k).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
eqT :: Maybe (d :~: UUID) of
                Just d :~: UUID
Refl -> case Maybe ByteString
queryValue of
                    Just ByteString
queryValue -> ByteString
queryValue
                        ByteString -> (ByteString -> Maybe UUID) -> Maybe UUID
forall a b. a -> (a -> b) -> b
|> ByteString -> Maybe UUID
fromASCIIBytes
                        Maybe UUID
-> (Maybe UUID -> Either TypedAutoRouteError d)
-> Either TypedAutoRouteError d
forall a b. a -> (a -> b) -> b
|> \case
                            Just UUID
uuid -> UUID
uuid UUID
-> (UUID -> Either TypedAutoRouteError d)
-> Either TypedAutoRouteError d
forall a b. a -> (a -> b) -> b
|> UUID -> Either TypedAutoRouteError d
UUID -> Either TypedAutoRouteError UUID
forall a b. b -> Either a b
Right
                            Maybe UUID
Nothing -> TypedAutoRouteError -> Either TypedAutoRouteError d
forall a b. a -> Either a b
Left BadType { field :: ByteString
field = ByteString
"", value :: Maybe ByteString
value = ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
queryValue, expectedType :: ByteString
expectedType = ByteString
"UUID" }
                    Maybe ByteString
Nothing -> TypedAutoRouteError -> Either TypedAutoRouteError d
forall a b. a -> Either a b
Left TypedAutoRouteError
NotMatched
                Maybe (d :~: UUID)
Nothing -> TypedAutoRouteError -> Either TypedAutoRouteError d
forall a b. a -> Either a b
Left TypedAutoRouteError
NotMatched,

            -- This has to be last parser in the list
            --
            -- Try and parse a UUID wrapped with a Id. In IHP types these are wrapped in a newtype @Id@ such as @Id User@.
            -- Since @Id@ is a newtype wrapping a UUID, it has the same data representation in GHC.
            -- Therefore, we're able to safely cast it to its @Id@ type with @unsafeCoerce@.
            --
            -- We cannot use 'eqT' here for checking the types, as it's wrapped inside the @Id@ type. We expect
            -- that if it looks like a UUID, we can just treat it like an @Id@ type. For that to not overshadow other
            -- parsers, we need to have this last.
            \Maybe ByteString
queryValue -> case Maybe ByteString
queryValue of
                Just ByteString
queryValue -> ByteString
queryValue
                    ByteString -> (ByteString -> Maybe UUID) -> Maybe UUID
forall a b. a -> (a -> b) -> b
|> ByteString -> Maybe UUID
fromASCIIBytes
                    Maybe UUID
-> (Maybe UUID -> Either TypedAutoRouteError d)
-> Either TypedAutoRouteError d
forall a b. a -> (a -> b) -> b
|> \case
                        Just UUID
uuid -> UUID
uuid UUID -> (UUID -> d) -> d
forall a b. a -> (a -> b) -> b
|> UUID -> d
forall a b. a -> b
unsafeCoerce d
-> (d -> Either TypedAutoRouteError d)
-> Either TypedAutoRouteError d
forall a b. a -> (a -> b) -> b
|> d -> Either TypedAutoRouteError d
forall a b. b -> Either a b
Right
                        Maybe UUID
Nothing -> TypedAutoRouteError -> Either TypedAutoRouteError d
forall a b. a -> Either a b
Left BadType { field :: ByteString
field = ByteString
"", value :: Maybe ByteString
value = ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
queryValue, expectedType :: ByteString
expectedType = ByteString
"UUID" }
                Maybe ByteString
Nothing -> TypedAutoRouteError -> Either TypedAutoRouteError d
forall a b. a -> Either a b
Left TypedAutoRouteError
NotMatched
            ]
{-# NOINLINE parseFuncs #-}

-- | As we fold over a constructor, we want the values parsed from the query string
-- to be in the same order as they are in the constructor.
-- This function uses the field labels from the constructor to sort the values from
-- the query string. As a consequence, constructors with basic record syntax will not work with auto types.
--
-- @data MyController = MyAction Text Int@
--
-- does not work. Instead use,
--
-- @data MyController = MyAction { textArg :: Text, intArg :: Int }@
querySortedByFields :: Query -> Constr -> Query
querySortedByFields :: Query -> Constr -> Query
querySortedByFields Query
query Constr
constructor = Constr -> [String]
constrFields Constr
constructor
        [String] -> ([String] -> [ByteString]) -> [ByteString]
forall a b. a -> (a -> b) -> b
|> (String -> ByteString) -> [String] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map String -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs
        [ByteString] -> ([ByteString] -> Query) -> Query
forall a b. a -> (a -> b) -> b
|> (ByteString -> QueryItem) -> [ByteString] -> Query
forall a b. (a -> b) -> [a] -> [b]
map (\ByteString
field -> (ByteString
field, Maybe (Maybe ByteString) -> Maybe ByteString
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Maybe (Maybe ByteString) -> Maybe ByteString)
-> Maybe (Maybe ByteString) -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> Query -> Maybe (Maybe ByteString)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
List.lookup ByteString
field Query
query))
{-# NOINLINE querySortedByFields #-}

-- | Given a constructor and a parsed query string, attempt to construct a value of the constructor's type.
-- For example, given the controller
--
-- @data MyController = MyAction { textArg :: Text, intArg :: Int }@
--
-- this function will receive a representation of the @MyAction@ constructor as well as some query string
-- @[("textArg", "some text"), ("intArg", "123")]@.
--
-- By iterating through the query and attempting to match the type of each constructor argument
-- with some transformation of the query string, we attempt to call @MyAction@.
applyConstr :: (Data controller, Data idType) => (ByteString -> Maybe idType) -> Constr -> Query -> Either TypedAutoRouteError controller
applyConstr :: forall controller idType.
(Data controller, Data idType) =>
(ByteString -> Maybe idType)
-> Constr -> Query -> Either TypedAutoRouteError controller
applyConstr ByteString -> Maybe idType
parseIdType Constr
constructor Query
query = let

    -- | Given some query item (key, optional value), try to parse into the current expected type
    -- by iterating through the available parse functions.
    attemptToParseArg :: forall d. (Data d) => (ByteString, Maybe ByteString) -> [Maybe ByteString -> Either TypedAutoRouteError d] -> State.StateT Query (Either TypedAutoRouteError) d
    attemptToParseArg :: forall d.
Data d =>
QueryItem
-> [Maybe ByteString -> Either TypedAutoRouteError d]
-> StateT Query (Either TypedAutoRouteError) d
attemptToParseArg queryParam :: QueryItem
queryParam@(ByteString
queryName, Maybe ByteString
queryValue) [] = Either TypedAutoRouteError d
-> StateT Query (Either TypedAutoRouteError) d
forall (m :: * -> *) a. Monad m => m a -> StateT Query m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
State.lift (TypedAutoRouteError -> Either TypedAutoRouteError d
forall a b. a -> Either a b
Left NoConstructorMatched
                { field :: ByteString
field = ByteString
queryName
                , value :: Maybe ByteString
value = Maybe ByteString
queryValue
                , expectedType :: ByteString
expectedType = (d -> DataType
forall a. Data a => a -> DataType
dataTypeOf (d
forall a. HasCallStack => a
Prelude.undefined :: d)) DataType -> (DataType -> String) -> String
forall a b. a -> (a -> b) -> b
|> DataType -> String
dataTypeName String -> (String -> ByteString) -> ByteString
forall a b. a -> (a -> b) -> b
|> String -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs
                })
    attemptToParseArg queryParam :: QueryItem
queryParam@(ByteString
k, Maybe ByteString
v) (Maybe ByteString -> Either TypedAutoRouteError d
parseFunc:[Maybe ByteString -> Either TypedAutoRouteError d]
restFuncs) = case Maybe ByteString -> Either TypedAutoRouteError d
parseFunc Maybe ByteString
v of
            Right d
result -> d -> StateT Query (Either TypedAutoRouteError) d
forall a. a -> StateT Query (Either TypedAutoRouteError) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure d
result
            -- BadType will be returned if, for example, a text is passed to a query parameter typed as int.
            Left badType :: TypedAutoRouteError
badType@BadType{} -> Either TypedAutoRouteError d
-> StateT Query (Either TypedAutoRouteError) d
forall (m :: * -> *) a. Monad m => m a -> StateT Query m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
State.lift (TypedAutoRouteError -> Either TypedAutoRouteError d
forall a b. a -> Either a b
Left TypedAutoRouteError
badType { field = k })
            -- otherwise, safe to assume the match just failed, so recurse on the rest of the functions and try to find one that matches.
            Left TypedAutoRouteError
_ -> QueryItem
-> [Maybe ByteString -> Either TypedAutoRouteError d]
-> StateT Query (Either TypedAutoRouteError) d
forall d.
Data d =>
QueryItem
-> [Maybe ByteString -> Either TypedAutoRouteError d]
-> StateT Query (Either TypedAutoRouteError) d
attemptToParseArg QueryItem
queryParam [Maybe ByteString -> Either TypedAutoRouteError d]
restFuncs

    -- | Attempt to parse the current expected type, and return its value.
    -- For the example @MyController@ this is called twice by @fromConstrM@.
    -- Once, it is called for @textArg@ where @d :: Text@. Then it is called
    -- for @intArg@ with @d ::: Int@. With both of these values parsed from the query string,
    -- the controller action is able to be created.
    nextField :: forall d. (Data d) => State.StateT Query (Either TypedAutoRouteError) d
    nextField :: forall d. Data d => StateT Query (Either TypedAutoRouteError) d
nextField = do
            queryParams <- StateT Query (Either TypedAutoRouteError) Query
forall s (m :: * -> *). MonadState s m => m s
State.get
            case queryParams of
                [] -> Either TypedAutoRouteError d
-> StateT Query (Either TypedAutoRouteError) d
forall (m :: * -> *) a. Monad m => m a -> StateT Query m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
State.lift (TypedAutoRouteError -> Either TypedAutoRouteError d
forall a b. a -> Either a b
Left TypedAutoRouteError
TooFewArguments)
                (p :: QueryItem
p@(ByteString
key, Maybe ByteString
value):Query
rest) -> do
                    Query -> StateT Query (Either TypedAutoRouteError) ()
forall s (m :: * -> *). MonadState s m => s -> m ()
State.put Query
rest
                    QueryItem
-> [Maybe ByteString -> Either TypedAutoRouteError d]
-> StateT Query (Either TypedAutoRouteError) d
forall d.
Data d =>
QueryItem
-> [Maybe ByteString -> Either TypedAutoRouteError d]
-> StateT Query (Either TypedAutoRouteError) d
attemptToParseArg QueryItem
p ((ByteString -> Maybe idType)
-> [Maybe ByteString -> Either TypedAutoRouteError d]
forall d idType.
(Data d, Data idType) =>
(ByteString -> Maybe idType)
-> [Maybe ByteString -> Either TypedAutoRouteError d]
parseFuncs ByteString -> Maybe idType
parseIdType)


   in case StateT Query (Either TypedAutoRouteError) controller
-> Query -> Either TypedAutoRouteError (controller, Query)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
State.runStateT ((forall d. Data d => StateT Query (Either TypedAutoRouteError) d)
-> Constr -> StateT Query (Either TypedAutoRouteError) controller
forall (m :: * -> *) a.
(Monad m, Data a) =>
(forall d. Data d => m d) -> Constr -> m a
fromConstrM StateT Query (Either TypedAutoRouteError) d
forall d. Data d => StateT Query (Either TypedAutoRouteError) d
nextField Constr
constructor) (Query -> Constr -> Query
querySortedByFields Query
query Constr
constructor) of
        Right (controller
x, []) -> controller -> Either TypedAutoRouteError controller
forall a. a -> Either TypedAutoRouteError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure controller
x
        Right ((controller, Query)
_) -> TypedAutoRouteError -> Either TypedAutoRouteError controller
forall a b. a -> Either a b
Left TypedAutoRouteError
TooFewArguments
        Left TypedAutoRouteError
e -> TypedAutoRouteError -> Either TypedAutoRouteError controller
forall a b. a -> Either a b
Left TypedAutoRouteError
e  -- runtime type error
{-# NOINLINE applyConstr #-}

class Data controller => AutoRoute controller where
    autoRouteWithIdType :: (?request :: Request, ?respond :: Respond, Data idType) => (ByteString -> Maybe idType) -> Parser controller
    autoRouteWithIdType ByteString -> Maybe idType
parseIdFunc =
        let
            query :: Query
            query :: Query
query = Request -> Query
queryString ?request::Request
Request
?request
        in do
            -- routeMatchParser is a CAF (no ?request dependency), computed once per controller type.
            -- It handles the static string matching against URL paths.
            (constr, allowedMethods) <- forall controller.
(Data controller, AutoRoute controller) =>
Parser (Constr, [StdMethod])
routeMatchParser @controller
            action <- case applyConstr parseIdFunc constr query of
                    Right controller
parsedAction -> controller -> Parser controller
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure controller
parsedAction
                    Left TypedAutoRouteError
e -> TypedAutoRouteError -> Parser controller
forall a e. (HasCallStack, Exception e) => e -> a
Exception.throw TypedAutoRouteError
e
            method <- getMethod
            unless (allowedMethods |> includes method) (Exception.throw UnexpectedMethodException { allowedMethods, method })
            pure action
    {-# INLINABLE autoRouteWithIdType #-}

    autoRoute :: (?request :: Request, ?respond :: Respond) => Parser controller
    autoRoute = (ByteString -> Maybe Integer) -> Parser controller
forall idType.
(?request::Request, ?respond::Respond, Data idType) =>
(ByteString -> Maybe idType) -> Parser controller
forall controller idType.
(AutoRoute controller, ?request::Request, ?respond::Respond,
 Data idType) =>
(ByteString -> Maybe idType) -> Parser controller
autoRouteWithIdType (\ByteString
_ -> Maybe Integer
forall a. Maybe a
Nothing :: Maybe Integer)
    {-# INLINABLE autoRoute #-}

    -- | Constructs a controller value from a matched constructor and query string.
    --
    -- Uses the same id parser as 'autoRoute'. Override this when you override
    -- 'autoRoute' with 'autoRouteWithIdType' to keep them in sync.
    --
    -- This is used by 'parseRoute' to defer query string parsing to the Application
    -- closure while keeping path matching in the parser.
    --
    -- __Example:__
    --
    -- > instance AutoRoute MyController where
    -- >     autoRoute = autoRouteWithIdType (parseIntegerId @(Id MyModel))
    -- >     applyAction = applyConstr (parseIntegerId @(Id MyModel))
    applyAction :: Constr -> Query -> Either TypedAutoRouteError controller
    applyAction = (ByteString -> Maybe Integer)
-> Constr -> Query -> Either TypedAutoRouteError controller
forall controller idType.
(Data controller, Data idType) =>
(ByteString -> Maybe idType)
-> Constr -> Query -> Either TypedAutoRouteError controller
applyConstr (\ByteString
_ -> Maybe Integer
forall a. Maybe a
Nothing :: Maybe Integer)
    {-# INLINE applyAction #-}

    -- | Specifies the allowed HTTP methods for a given action
    --
    -- The default implementation does a smart guess based on the
    -- usual naming conventions for controllers.
    --
    -- __Example (for default implementation):__
    --
    -- >>> allowedMethodsForAction @ProjectsController "DeleteProjectAction"
    -- [DELETE]
    --
    -- >>> allowedMethodsForAction @ProjectsController "UpdateProjectAction"
    -- [POST, PATCH]
    --
    -- >>> allowedMethodsForAction @ProjectsController "CreateProjectAction"
    -- [POST]
    --
    -- >>> allowedMethodsForAction @ProjectsController "ShowProjectAction"
    -- [GET, HEAD]
    --
    -- >>> allowedMethodsForAction @ProjectsController "HelloAction"
    -- [GET, POST, HEAD]
    --
    allowedMethodsForAction :: ByteString -> [StdMethod]
    allowedMethodsForAction ByteString
actionName =
            case ByteString
actionName of
                ByteString
a | ByteString
"Delete" ByteString -> ByteString -> Bool
`ByteString.isPrefixOf` ByteString
a -> [StdMethod
DELETE]
                ByteString
a | ByteString
"Update" ByteString -> ByteString -> Bool
`ByteString.isPrefixOf` ByteString
a -> [StdMethod
POST, StdMethod
PATCH]
                ByteString
a | ByteString
"Create" ByteString -> ByteString -> Bool
`ByteString.isPrefixOf` ByteString
a -> [StdMethod
POST]
                ByteString
a | ByteString
"Show"   ByteString -> ByteString -> Bool
`ByteString.isPrefixOf` ByteString
a -> [StdMethod
GET, StdMethod
HEAD]
                ByteString
_ -> [StdMethod
GET, StdMethod
POST, StdMethod
HEAD]
    {-# INLINE allowedMethodsForAction #-}

    -- | Custom route parser for overriding individual action routes.
    --
    -- Use this to provide custom URL patterns for specific actions while keeping
    -- the auto-generated routes for all other actions.
    --
    -- The custom routes are tried first, before the auto-generated routes.
    -- The auto-generated route for the overridden action still works as a fallback.
    --
    -- __Example:__
    --
    -- > instance AutoRoute PostsController where
    -- >     customRoutes = do
    -- >         string "/posts/"
    -- >         postId <- parseId
    -- >         endOfInput
    -- >         onlyAllowMethods [GET, HEAD]
    -- >         pure ShowPostAction { postId }
    --
    customRoutes :: (?request :: Request, ?respond :: Respond) => Parser controller
    customRoutes = Parser controller
forall a. Parser ByteString a
forall (f :: * -> *) a. Alternative f => f a
empty
    {-# INLINE customRoutes #-}

    -- | Custom path generation for overriding individual action URLs.
    --
    -- Use this together with 'customRoutes' to generate custom URLs for specific
    -- actions while keeping the auto-generated URLs for all other actions.
    --
    -- Return @Just path@ for actions with custom URLs, or @Nothing@ to fall back
    -- to the auto-generated URL.
    --
    -- __Example:__
    --
    -- > instance AutoRoute PostsController where
    -- >     customPathTo ShowPostAction { postId } = Just ("/posts/" <> tshow postId)
    -- >     customPathTo _ = Nothing
    --
    customPathTo :: controller -> Maybe Text
    customPathTo controller
_ = Maybe Text
forall a. Maybe a
Nothing
    {-# INLINE customPathTo #-}

-- | Static route-matching parser that becomes a CAF when specialized for a concrete
-- controller type. Uses a 'HashMap' for O(1) action name lookup after matching the prefix.
-- Since it doesn't reference @?request@ or @?respond@, GHC can float this out as a
-- top-level constant.
routeMatchParser :: forall controller. (Data controller, AutoRoute controller) => Parser (Constr, [StdMethod])
routeMatchParser :: forall controller.
(Data controller, AutoRoute controller) =>
Parser (Constr, [StdMethod])
routeMatchParser = do
    ByteString -> Parser ByteString
string ByteString
prefix
    remaining <- Parser ByteString
takeByteString
    case HashMap.lookup remaining actionMatchMap of
        Just (Constr, [StdMethod])
result -> (Constr, [StdMethod]) -> Parser (Constr, [StdMethod])
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Constr, [StdMethod])
result
        Maybe (Constr, [StdMethod])
Nothing -> String -> Parser (Constr, [StdMethod])
forall a. String -> Parser ByteString a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"no matching action"
    where
        prefix :: ByteString
        prefix :: ByteString
prefix = Text -> ByteString
Text.encodeUtf8 (forall controller. Typeable controller => Text
actionPrefixText @controller)

        actionMatchMap :: HashMap.HashMap ByteString (Constr, [StdMethod])
        actionMatchMap :: HashMap ByteString (Constr, [StdMethod])
actionMatchMap = [(ByteString, (Constr, [StdMethod]))]
-> HashMap ByteString (Constr, [StdMethod])
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HashMap.fromList
            [ (ByteString
actionPath, (Constr
constr, [StdMethod]
allowedMethods))
            | Constr
constr <- DataType -> [Constr]
dataTypeConstrs (controller -> DataType
forall a. Data a => a -> DataType
dataTypeOf (controller
forall a. HasCallStack => a
Prelude.undefined :: controller))
            , let actionName :: ByteString
actionName = String -> ByteString
ByteString.pack (Constr -> String
showConstr Constr
constr)
                  actionPath :: ByteString
actionPath = ByteString -> ByteString
stripActionSuffixByteString ByteString
actionName
                  allowedMethods :: [StdMethod]
allowedMethods = forall controller.
AutoRoute controller =>
ByteString -> [StdMethod]
allowedMethodsForAction @controller ByteString
actionName
            ]
{-# NOINLINE routeMatchParser #-}

-- | Returns the url prefix for a controller. The prefix is based on the
-- module where the controller is defined.
--
-- All controllers defined in the `Web/` directory don't have a prefix at all.
--
-- E.g. controllers in the `Admin/` directory are prefixed with @/admin/@.
actionPrefixText :: forall (controller :: Type). Typeable controller => Text
actionPrefixText :: forall controller. Typeable controller => Text
actionPrefixText
    | Text
"Web." Text -> Text -> Bool
`Text.isPrefixOf` Text
moduleName = Text
"/"
    | Text
"IHP." Text -> Text -> Bool
`Text.isPrefixOf` Text
moduleName = Text
"/"
    | Text -> Bool
Text.null Text
moduleName = Text
"/"
    | Bool
otherwise = Text
"/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
Text.toLower (Text -> Text
getPrefix Text
moduleName) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/"
    where
        moduleName :: Text
        moduleName :: Text
moduleName = String -> Text
Text.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ controller -> TypeRep
forall a. Typeable a => a -> TypeRep
Typeable.typeOf (String -> controller
forall a. HasCallStack => String -> a
error String
"unreachable" :: controller)
                TypeRep -> (TypeRep -> TyCon) -> TyCon
forall a b. a -> (a -> b) -> b
|> TypeRep -> TyCon
Typeable.typeRepTyCon
                TyCon -> (TyCon -> String) -> String
forall a b. a -> (a -> b) -> b
|> TyCon -> String
Typeable.tyConModule

        getPrefix :: Text -> Text
        getPrefix :: Text -> Text
getPrefix Text
t = (Text, Text) -> Text
forall a b. (a, b) -> a
fst (HasCallStack => Text -> Text -> (Text, Text)
Text -> Text -> (Text, Text)
Text.breakOn Text
"." Text
t)
{-# NOINLINE actionPrefixText #-}

-- | Strips the "Action" suffix from action names
--
-- >>> stripActionSuffixByteString "ShowUserAction"
-- "ShowUser"
--
-- >>> stripActionSuffixByteString "UsersAction"
-- "UsersAction"
--
-- >>> stripActionSuffixByteString "User"
-- "User"
stripActionSuffixByteString :: ByteString -> ByteString
stripActionSuffixByteString :: ByteString -> ByteString
stripActionSuffixByteString ByteString
actionName = ByteString -> Maybe ByteString -> ByteString
forall a. a -> Maybe a -> a
fromMaybe ByteString
actionName (ByteString -> ByteString -> Maybe ByteString
ByteString.stripSuffix ByteString
"Action" ByteString
actionName)
{-# INLINE stripActionSuffixByteString #-}

-- | Strips the "Action" suffix from action names
--
-- >>> stripActionSuffixText "ShowUserAction"
-- "ShowUser"
--
-- >>> stripActionSuffixText "UsersAction"
-- "UsersAction"
--
-- >>> stripActionSuffixText "User"
-- "User"
stripActionSuffixText :: Text -> Text
stripActionSuffixText :: Text -> Text
stripActionSuffixText Text
actionName = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
actionName (Text -> Text -> Maybe Text
Text.stripSuffix Text
"Action" Text
actionName)
{-# INLINE stripActionSuffixText #-}


-- | Returns the create action for a given controller.
-- Example: `createAction @UsersController == Just CreateUserAction`
createAction :: forall controller. AutoRoute controller => Maybe controller
createAction :: forall controller. AutoRoute controller => Maybe controller
createAction = (Constr -> controller) -> Maybe Constr -> Maybe controller
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Constr -> controller
forall a. Data a => Constr -> a
fromConstr Maybe Constr
createConstructor
    where
        createConstructor :: Maybe Constr
        createConstructor :: Maybe Constr
createConstructor = (Constr -> Bool) -> [Constr] -> Maybe Constr
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find Constr -> Bool
isCreateConstructor [Constr]
allConstructors

        allConstructors :: [Constr]
        allConstructors :: [Constr]
allConstructors = DataType -> [Constr]
dataTypeConstrs (controller -> DataType
forall a. Data a => a -> DataType
dataTypeOf (controller
forall a. HasCallStack => a
Prelude.undefined :: controller))

        isCreateConstructor :: Constr -> Bool
        isCreateConstructor :: Constr -> Bool
isCreateConstructor Constr
constructor = String
"Create" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` Constr -> String
showConstr Constr
constructor Bool -> Bool -> Bool
&& [String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
Prelude.null (Constr -> [String]
constrFields Constr
constructor)
{-# INLINE createAction #-}

-- | Returns the update action when given a controller and id.
-- Example: `updateAction @UsersController == Just (\id -> UpdateUserAction id)`
updateAction :: forall controller id. AutoRoute controller => Maybe (id -> controller)
updateAction :: forall controller id.
AutoRoute controller =>
Maybe (id -> controller)
updateAction =
        case Maybe Constr
updateConstructor of
            Just Constr
constructor -> (id -> controller) -> Maybe (id -> controller)
forall a. a -> Maybe a
Just ((id -> controller) -> Maybe (id -> controller))
-> (id -> controller) -> Maybe (id -> controller)
forall a b. (a -> b) -> a -> b
$ \id
id -> Constr -> id -> controller
buildInstance Constr
constructor id
id
            Maybe Constr
Nothing -> Maybe (id -> controller)
forall a. Maybe a
Nothing
    where
        updateConstructor :: Maybe Constr
        updateConstructor :: Maybe Constr
updateConstructor = (Constr -> Bool) -> [Constr] -> Maybe Constr
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find Constr -> Bool
isUpdateConstructor [Constr]
allConstructors

        buildInstance :: Constr -> id -> controller
        buildInstance :: Constr -> id -> controller
buildInstance Constr
constructor id
id = State Integer controller -> Integer -> controller
forall s a. State s a -> s -> a
State.evalState (((forall d. Data d => StateT Integer Identity d)
-> Constr -> State Integer controller
forall (m :: * -> *) a.
(Monad m, Data a) =>
(forall d. Data d => m d) -> Constr -> m a
fromConstrM (do
                i <- StateT Integer Identity Integer
forall s (m :: * -> *). MonadState s m => m s
State.get

                State.modify (+1)
                pure (unsafeCoerce id)
            )) Constr
constructor) Integer
0

        allConstructors :: [Constr]
        allConstructors :: [Constr]
allConstructors = DataType -> [Constr]
dataTypeConstrs (controller -> DataType
forall a. Data a => a -> DataType
dataTypeOf (controller
forall a. HasCallStack => a
Prelude.undefined :: controller))

        isUpdateConstructor :: Constr -> Bool
        isUpdateConstructor :: Constr -> Bool
isUpdateConstructor Constr
constructor = String
"Update" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` (Constr -> String
showConstr Constr
constructor) Bool -> Bool -> Bool
&& ([String] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Constr -> [String]
constrFields Constr
constructor) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1)
{-# INLINE updateAction #-}

instance {-# OVERLAPPABLE #-} (AutoRoute controller, Controller controller) => CanRoute controller where
    parseRoute' :: (?request::Request, ?respond::Respond) => Parser controller
parseRoute' = Parser controller
forall controller.
(AutoRoute controller, ?request::Request, ?respond::Respond) =>
Parser controller
customRoutes Parser controller -> Parser controller -> Parser controller
forall a.
Parser ByteString a -> Parser ByteString a -> Parser ByteString a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser controller
forall controller.
(AutoRoute controller, ?request::Request, ?respond::Respond) =>
Parser controller
autoRoute
    {-# INLINABLE parseRoute' #-}

    -- | This is only used as a fallback parser (via lazy thunk in 'ControllerRouteMap').
    -- The primary routing path goes through 'findInRouteMaps' / 'buildAutoRouteMap' instead.
    -- Performance here doesn't matter — keep it simple.
    parseRouteWithAction :: (?request::Request, ?respond::Respond) =>
(controller -> Application) -> Parser Application
parseRouteWithAction controller -> Application
toApp = (do
        action <- forall controller.
(AutoRoute controller, ?request::Request, ?respond::Respond) =>
Parser controller
customRoutes @controller
        pure (toApp action)
      ) Parser Application -> Parser Application -> Parser Application
forall a.
Parser ByteString a -> Parser ByteString a -> Parser ByteString a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (do
        (constr, allowedMethods) <- forall controller.
(Data controller, AutoRoute controller) =>
Parser (Constr, [StdMethod])
routeMatchParser @controller
        pure $ \Request
waiRequest Respond
waiRespond -> IO ResponseReceived -> IO ResponseReceived
forall a. IO a -> IO a
wrapRouterException do
            case forall controller.
AutoRoute controller =>
Constr -> Query -> Either TypedAutoRouteError controller
applyAction @controller Constr
constr (Request -> Query
queryString Request
waiRequest) of
                Left TypedAutoRouteError
e -> TypedAutoRouteError -> IO ResponseReceived
forall a e. (HasCallStack, Exception e) => e -> a
Exception.throw TypedAutoRouteError
e
                Right controller
action -> do
                    case ByteString -> Either ByteString StdMethod
parseMethod (Request -> ByteString
requestMethod Request
waiRequest) of
                        Right StdMethod
method -> do
                            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([StdMethod]
allowedMethods [StdMethod] -> ([StdMethod] -> Bool) -> Bool
forall a b. a -> (a -> b) -> b
|> Element [StdMethod] -> [StdMethod] -> Bool
forall container.
(MonoFoldable container, Eq (Element container)) =>
Element container -> container -> Bool
includes Element [StdMethod]
StdMethod
method)
                                (UnexpectedMethodException -> IO ()
forall a e. (HasCallStack, Exception e) => e -> a
Exception.throw UnexpectedMethodException { [StdMethod]
allowedMethods :: [StdMethod]
allowedMethods :: [StdMethod]
allowedMethods, StdMethod
method :: StdMethod
method :: StdMethod
method })
                            controller -> Application
toApp controller
action Request
waiRequest Respond
waiRespond
                        Left ByteString
err -> String -> IO ResponseReceived
forall a. HasCallStack => String -> a
error (String
"Invalid HTTP method: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ByteString -> String
ByteString.unpack ByteString
err)
      )
    {-# INLINABLE parseRouteWithAction #-}

    -- | Override to use 'ControllerRouteMap' for O(1) HashMap dispatch.
    toControllerRoute :: forall application.
        ( ?request :: Request, ?respond :: Respond, Controller controller
        , InitControllerContext application, ?application :: application
        , Typeable application, Typeable controller
        ) => ControllerRoute application
    toControllerRoute :: forall application.
(?request::Request, ?respond::Respond, Controller controller,
 InitControllerContext application, ?application::application,
 Typeable application, Typeable controller) =>
ControllerRoute application
toControllerRoute = HashMap ByteString (application -> Application)
-> Parser Application -> ControllerRoute application
forall application.
HashMap ByteString (application -> Application)
-> Parser Application -> ControllerRoute application
ControllerRouteMap
        (forall controller application.
(AutoRoute controller, Controller controller,
 InitControllerContext application, Typeable application,
 Typeable controller) =>
HashMap ByteString (application -> Application)
buildAutoRouteMap @controller @application)
        (forall controller.
(CanRoute controller, ?request::Request, ?respond::Respond) =>
(controller -> Application) -> Parser Application
parseRouteWithAction @controller (forall application controller.
(Controller controller, InitControllerContext application,
 ?application::application, Typeable application,
 Typeable controller) =>
controller -> Application
runAction' @application))
    {-# INLINABLE toControllerRoute #-}

-- | Instances of the @QueryParam@ type class can be represented in URLs as query parameters.
-- Currently this is only Int, Text, and both wrapped in List and Maybe.
-- IDs also are representable in a URL, but we are unable to match on polymorphic types using reflection,
-- so we fall back to the default "show" for these.
class Data a => QueryParam a where
    showQueryParam :: a -> String

instance QueryParam Text where
    showQueryParam :: Text -> String
showQueryParam Text
text = Text -> String
Text.unpack Text
text

instance QueryParam Int where
    showQueryParam :: Int -> String
showQueryParam = Int -> String
forall a. Show a => a -> String
show

instance QueryParam Integer where
    showQueryParam :: Integer -> String
showQueryParam = Integer -> String
forall a. Show a => a -> String
show

instance QueryParam UUID where
    showQueryParam :: UUID -> String
showQueryParam = UUID -> String
forall a. Show a => a -> String
show

instance QueryParam a => QueryParam (Maybe a) where
    showQueryParam :: Maybe a -> String
showQueryParam (Just a
val) = a -> String
forall a. QueryParam a => a -> String
showQueryParam a
val
    showQueryParam Maybe a
Nothing = String
""

instance QueryParam a => QueryParam [a] where
    showQueryParam :: [a] -> String
showQueryParam = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
List.intercalate String
"," ([String] -> String) -> ([a] -> [String]) -> [a] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> String) -> [a] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map a -> String
forall a. QueryParam a => a -> String
showQueryParam

instance {-# OVERLAPPABLE #-} (Show controller, AutoRoute controller) => HasPath controller where
    pathTo :: controller -> Text
pathTo !controller
action = case controller -> Maybe Text
forall controller. AutoRoute controller => controller -> Maybe Text
customPathTo controller
action of
        Just Text
path -> Text
path
        Maybe Text
Nothing ->
            let !ci :: Int
ci = Constr -> Int
constrIndex (controller -> Constr
forall a. Data a => a -> Constr
toConstr controller
action) Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
                (!Text
basePath, ![Text]
fieldNames) = [(Text, [Text])]
constrInfoCache [(Text, [Text])] -> Int -> (Text, [Text])
forall a. HasCallStack => [a] -> Int -> a
!! Int
ci
            in case [Text]
fieldNames of
                [] -> Text
basePath
                [Text]
_ ->
                    let !fieldValues :: [Text]
fieldValues = (forall d. Data d => d -> Text) -> controller -> [Text]
forall a u. Data a => (forall d. Data d => d -> u) -> a -> [u]
forall u. (forall d. Data d => d -> u) -> controller -> [u]
gmapQ d -> Text
forall d. Data d => d -> Text
renderFieldForUrl controller
action
                    in Text
basePath Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> [Text] -> Text
buildQueryText [Text]
fieldNames [Text]
fieldValues
        where
            -- Precomputed per constructor: (basePath, fieldNames).
            -- Does not reference 'action', so GHC floats this out as a CAF
            -- when the instance is specialized for a concrete controller type.
            constrInfoCache :: [(Text, [Text])]
            constrInfoCache :: [(Text, [Text])]
constrInfoCache = (Constr -> (Text, [Text])) -> [Constr] -> [(Text, [Text])]
forall a b. (a -> b) -> [a] -> [b]
map Constr -> (Text, [Text])
mkInfo [Constr]
allConstrs
                where
                    allConstrs :: [Constr]
allConstrs = DataType -> [Constr]
dataTypeConstrs (controller -> DataType
forall a. Data a => a -> DataType
dataTypeOf (controller
forall a. HasCallStack => a
Prelude.undefined :: controller))
                    !appPrefix :: Text
appPrefix = forall controller. Typeable controller => Text
actionPrefixText @controller
                    mkInfo :: Constr -> (Text, [Text])
mkInfo Constr
c =
                        let !bp :: Text
bp = Text
appPrefix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
stripActionSuffixText (String -> Text
Text.pack (Constr -> String
showConstr Constr
c))
                            !fns :: [Text]
fns = (String -> Text) -> [String] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map String -> Text
Text.pack (Constr -> [String]
constrFields Constr
c)
                        in (Text
bp, [Text]
fns)

            buildQueryText :: [Text] -> [Text] -> Text
            buildQueryText :: [Text] -> [Text] -> Text
buildQueryText [Text]
names [Text]
values =
                [Text] -> [Text] -> [(Text, Text)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Text]
names [Text]
values
                [(Text, Text)]
-> ([(Text, Text)] -> [(Text, Text)]) -> [(Text, Text)]
forall a b. a -> (a -> b) -> b
|> ((Text, Text) -> Bool) -> [(Text, Text)] -> [(Text, Text)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(Text
_, Text
v) -> Bool -> Bool
not (Text -> Bool
Text.null Text
v))
                [(Text, Text)] -> ([(Text, Text)] -> [Text]) -> [Text]
forall a b. a -> (a -> b) -> b
|> ((Text, Text) -> Text) -> [(Text, Text)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (\(Text
k, Text
v) -> Text
k Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"=" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
URI.encodeText Text
v)
                [Text] -> ([Text] -> Text) -> Text
forall a b. a -> (a -> b) -> b
|> Text -> [Text] -> Text
Text.intercalate Text
"&"
                Text -> (Text -> Text) -> Text
forall a b. a -> (a -> b) -> b
|> (\Text
q -> if Text -> Bool
Text.null Text
q then Text
q else Char -> Text -> Text
Text.cons Char
'?' Text
q)
    {-# NOINLINE pathTo #-}

-- | Render a controller field value as 'Text' for URL query parameter inclusion.
--
-- Uses type reflection ('eqT') to match known types (Text, UUID, Int, Integer,
-- and their Maybe\/List variants). For newtypes like @Id'@ that wrap a known type,
-- falls back to recursive unwrap via 'gmapQ'.
renderFieldForUrl :: forall d. Data d => d -> Text
renderFieldForUrl :: forall d. Data d => d -> Text
renderFieldForUrl d
val
    -- UUID first: most common type after Id newtype unwrap
    | Just d :~: UUID
Refl <- forall {k} (a :: k) (b :: k).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
forall a b. (Typeable a, Typeable b) => Maybe (a :~: b)
eqT @d @UUID = UUID -> Text
toText d
UUID
val
    | Just d :~: Text
Refl <- forall {k} (a :: k) (b :: k).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
forall a b. (Typeable a, Typeable b) => Maybe (a :~: b)
eqT @d @Text = d
Text
val
    | Just d :~: Int
Refl <- forall {k} (a :: k) (b :: k).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
forall a b. (Typeable a, Typeable b) => Maybe (a :~: b)
eqT @d @Int = String -> Text
Text.pack (d -> String
forall a. Show a => a -> String
show d
val)
    | Just d :~: Integer
Refl <- forall {k} (a :: k) (b :: k).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
forall a b. (Typeable a, Typeable b) => Maybe (a :~: b)
eqT @d @Integer = String -> Text
Text.pack (d -> String
forall a. Show a => a -> String
show d
val)
    | Just d :~: Maybe UUID
Refl <- forall {k} (a :: k) (b :: k).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
forall a b. (Typeable a, Typeable b) => Maybe (a :~: b)
eqT @d @(Maybe UUID) = Text -> (UUID -> Text) -> Maybe UUID -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"" UUID -> Text
toText d
Maybe UUID
val
    | Just d :~: Maybe Text
Refl <- forall {k} (a :: k) (b :: k).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
forall a b. (Typeable a, Typeable b) => Maybe (a :~: b)
eqT @d @(Maybe Text) = Text -> (Text -> Text) -> Maybe Text -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"" Text -> Text
forall a. a -> a
id d
Maybe Text
val
    | Just d :~: Maybe Int
Refl <- forall {k} (a :: k) (b :: k).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
forall a b. (Typeable a, Typeable b) => Maybe (a :~: b)
eqT @d @(Maybe Int) = Text -> (Int -> Text) -> Maybe Int -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"" (String -> Text
Text.pack (String -> Text) -> (Int -> String) -> Int -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String
forall a. Show a => a -> String
show) d
Maybe Int
val
    | Just d :~: Maybe Integer
Refl <- forall {k} (a :: k) (b :: k).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
forall a b. (Typeable a, Typeable b) => Maybe (a :~: b)
eqT @d @(Maybe Integer) = Text -> (Integer -> Text) -> Maybe Integer -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"" (String -> Text
Text.pack (String -> Text) -> (Integer -> String) -> Integer -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> String
forall a. Show a => a -> String
show) d
Maybe Integer
val
    | Just d :~: [UUID]
Refl <- forall {k} (a :: k) (b :: k).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
forall a b. (Typeable a, Typeable b) => Maybe (a :~: b)
eqT @d @[UUID] = Text -> [Text] -> Text
Text.intercalate Text
"," ((UUID -> Text) -> [UUID] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map UUID -> Text
toText d
[UUID]
val)
    | Just d :~: [Text]
Refl <- forall {k} (a :: k) (b :: k).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
forall a b. (Typeable a, Typeable b) => Maybe (a :~: b)
eqT @d @[Text] = Text -> [Text] -> Text
Text.intercalate Text
"," (d
[Text]
val :: [Text])
    | Just d :~: [Int]
Refl <- forall {k} (a :: k) (b :: k).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
forall a b. (Typeable a, Typeable b) => Maybe (a :~: b)
eqT @d @[Int] = Text -> [Text] -> Text
Text.intercalate Text
"," ((Int -> Text) -> [Int] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Text
Text.pack (String -> Text) -> (Int -> String) -> Int -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String
forall a. Show a => a -> String
show) d
[Int]
val)
    | Just d :~: [Integer]
Refl <- forall {k} (a :: k) (b :: k).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
forall a b. (Typeable a, Typeable b) => Maybe (a :~: b)
eqT @d @[Integer] = Text -> [Text] -> Text
Text.intercalate Text
"," ((Integer -> Text) -> [Integer] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Text
Text.pack (String -> Text) -> (Integer -> String) -> Integer -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> String
forall a. Show a => a -> String
show) d
[Integer]
val)
    | Bool
otherwise =
        -- Unwrap one layer for newtypes (e.g., Id' wrapping UUID, Maybe (Id' table))
        case (forall d. Data d => d -> Text) -> d -> [Text]
forall a u. Data a => (forall d. Data d => d -> u) -> a -> [u]
forall u. (forall d. Data d => d -> u) -> d -> [u]
gmapQ d -> Text
forall d. Data d => d -> Text
renderFieldForUrl d
val of
            [Text
inner] -> Text
inner
            [Text]
_ -> Text
""
{-# NOINLINE renderFieldForUrl #-}

-- | Parses the HTTP Method from the request and returns it.
getMethod :: (?request :: Request, ?respond :: Respond) => Parser StdMethod
getMethod :: (?request::Request, ?respond::Respond) => Parser StdMethod
getMethod =
    case ByteString -> Either ByteString StdMethod
parseMethod ?request::Request
Request
?request.requestMethod of
        Left ByteString
error -> String -> Parser StdMethod
forall a. String -> Parser ByteString a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (ByteString -> String
ByteString.unpack ByteString
error)
        Right StdMethod
method -> StdMethod -> Parser StdMethod
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure StdMethod
method
{-# INLINABLE getMethod #-}

-- | Routes a given path to an action when requested via GET.
--
-- __Example:__
--
-- > instance FrontController WebApplication where
-- >     controllers = [
-- >             get "/my-custom-page" NewSessionAction
-- >         ]
--
-- The request @GET \/my-custom-page@ is now executing NewSessionAction
--
-- Also see 'post'.
get :: (Controller action
    , InitControllerContext application
    , ?application :: application
    , Typeable application
    , Typeable action
    ) => ByteString -> action -> ControllerRoute application
get :: forall action application.
(Controller action, InitControllerContext application,
 ?application::application, Typeable application,
 Typeable action) =>
ByteString -> action -> ControllerRoute application
get ByteString
path action
action = Parser Application -> ControllerRoute application
forall application.
Parser Application -> ControllerRoute application
ControllerRouteParser (Parser Application -> ControllerRoute application)
-> Parser Application -> ControllerRoute application
forall a b. (a -> b) -> a -> b
$ do
    ByteString -> Parser ByteString
string ByteString
path
    Application -> Parser Application
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Application -> Parser Application)
-> Application -> Parser Application
forall a b. (a -> b) -> a -> b
$ \Request
waiRequest Respond
waiRespond ->
        case ByteString -> Either ByteString StdMethod
parseMethod (Request -> ByteString
requestMethod Request
waiRequest) of
            Right StdMethod
GET -> action -> Application
forall application controller.
(Controller controller, InitControllerContext application,
 ?application::application, Typeable application,
 Typeable controller) =>
controller -> Application
runAction' action
action Request
waiRequest Respond
waiRespond
            Right StdMethod
HEAD -> action -> Application
forall application controller.
(Controller controller, InitControllerContext application,
 ?application::application, Typeable application,
 Typeable controller) =>
controller -> Application
runAction' action
action Request
waiRequest Respond
waiRespond
            Right StdMethod
method -> UnexpectedMethodException -> IO ResponseReceived
forall a e. (HasCallStack, Exception e) => e -> a
Exception.throw UnexpectedMethodException { allowedMethods :: [StdMethod]
allowedMethods = [StdMethod
GET, StdMethod
HEAD], StdMethod
method :: StdMethod
method :: StdMethod
method }
            Left ByteString
err -> String -> IO ResponseReceived
forall a. HasCallStack => String -> a
error (String
"Invalid HTTP method: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ByteString -> String
ByteString.unpack ByteString
err)
{-# INLINABLE get #-}

-- | Routes a given path to an action when requested via POST.
--
-- __Example:__
--
-- > instance FrontController WebApplication where
-- >     controllers = [
-- >             post "/do-something" DoSomethingAction
-- >         ]
--
-- The request @POST \/do-something@ is now executing DoSomethingAction
--
-- Also see 'get'.
post :: (Controller action
    , InitControllerContext application
    , ?application :: application
    , Typeable application
    , Typeable action
    ) => ByteString -> action -> ControllerRoute application
post :: forall action application.
(Controller action, InitControllerContext application,
 ?application::application, Typeable application,
 Typeable action) =>
ByteString -> action -> ControllerRoute application
post ByteString
path action
action = Parser Application -> ControllerRoute application
forall application.
Parser Application -> ControllerRoute application
ControllerRouteParser (Parser Application -> ControllerRoute application)
-> Parser Application -> ControllerRoute application
forall a b. (a -> b) -> a -> b
$ do
    ByteString -> Parser ByteString
string ByteString
path
    Application -> Parser Application
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Application -> Parser Application)
-> Application -> Parser Application
forall a b. (a -> b) -> a -> b
$ \Request
waiRequest Respond
waiRespond ->
        case ByteString -> Either ByteString StdMethod
parseMethod (Request -> ByteString
requestMethod Request
waiRequest) of
            Right StdMethod
POST -> action -> Application
forall application controller.
(Controller controller, InitControllerContext application,
 ?application::application, Typeable application,
 Typeable controller) =>
controller -> Application
runAction' action
action Request
waiRequest Respond
waiRespond
            Right StdMethod
method -> UnexpectedMethodException -> IO ResponseReceived
forall a e. (HasCallStack, Exception e) => e -> a
Exception.throw UnexpectedMethodException { allowedMethods :: [StdMethod]
allowedMethods = [StdMethod
POST], StdMethod
method :: StdMethod
method :: StdMethod
method }
            Left ByteString
err -> String -> IO ResponseReceived
forall a. HasCallStack => String -> a
error (String
"Invalid HTTP method: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ByteString -> String
ByteString.unpack ByteString
err)
{-# INLINABLE post #-}

-- | Filter methods when writing a custom routing parser
--
-- __Example:__
--
-- > instance CanRoute ApiController where
-- >    parseRoute' = do
-- >        string "/api/"
-- >        let
-- >            createRecordAction = do
-- >                onlyAllowMethods [POST]
-- >
-- >                table <- parseText
-- >                endOfInput
-- >                pure CreateRecordAction { table }
-- >
-- >            updateRecordAction = do
-- >                onlyAllowMethods [PATCH]
-- >
-- >                table <- parseText
-- >                string "/"
-- >                id <- parseUUID
-- >                pure UpdateRecordAction { table, id }
-- >
-- > createRecordAction <|> updateRecordAction
--
onlyAllowMethods :: (?request :: Request, ?respond :: Respond) => [StdMethod] -> Parser ()
onlyAllowMethods :: (?request::Request, ?respond::Respond) =>
[StdMethod] -> Parser ByteString ()
onlyAllowMethods [StdMethod]
methods = do
    method <- Parser StdMethod
(?request::Request, ?respond::Respond) => Parser StdMethod
getMethod
    unless (method `elem` methods) (fail ("Invalid method, expected one of: " <> show methods))
{-# INLINABLE onlyAllowMethods #-}

-- | Routes to a given WebSocket app if the path matches the WebSocket app name
--
-- __Example:__
--
-- > instance FrontController WebApplication where
-- >     controllers = [
-- >             webSocketApp @AutoRefreshWSApp
-- >         ]
--
-- The request @\/AutoRefreshWSApp@ will call the AutoRefreshWSApp
--
webSocketApp :: forall webSocketApp application.
    ( WSApp webSocketApp
    , InitControllerContext application
    , ?application :: application
    , Typeable application
    , Typeable webSocketApp
    ) => ControllerRoute application
webSocketApp :: forall webSocketApp application.
(WSApp webSocketApp, InitControllerContext application,
 ?application::application, Typeable application,
 Typeable webSocketApp) =>
ControllerRoute application
webSocketApp = forall webSocketApp application.
(WSApp webSocketApp, InitControllerContext application,
 ?application::application, Typeable application,
 Typeable webSocketApp) =>
ByteString -> ControllerRoute application
webSocketAppWithCustomPath @webSocketApp ByteString
typeName
    where
        typeName :: ByteString
        typeName :: ByteString
typeName = webSocketApp -> TypeRep
forall a. Typeable a => a -> TypeRep
Typeable.typeOf (String -> webSocketApp
forall a. HasCallStack => String -> a
error String
"unreachable" :: webSocketApp)
                TypeRep -> (TypeRep -> String) -> String
forall a b. a -> (a -> b) -> b
|> TypeRep -> String
forall a. Show a => a -> String
show
                String -> (String -> ByteString) -> ByteString
forall a b. a -> (a -> b) -> b
|> String -> ByteString
ByteString.pack
{-# INLINABLE webSocketApp #-}

webSocketAppWithHTTPFallback :: forall webSocketApp application.
    ( WSApp webSocketApp
    , InitControllerContext application
    , ?application :: application
    , Typeable application
    , Typeable webSocketApp
    , Controller webSocketApp
    ) => ControllerRoute application
webSocketAppWithHTTPFallback :: forall webSocketApp application.
(WSApp webSocketApp, InitControllerContext application,
 ?application::application, Typeable application,
 Typeable webSocketApp, Controller webSocketApp) =>
ControllerRoute application
webSocketAppWithHTTPFallback = forall webSocketApp application.
(WSApp webSocketApp, InitControllerContext application,
 ?application::application, Typeable application,
 Typeable webSocketApp, Controller webSocketApp) =>
ByteString -> ControllerRoute application
webSocketAppWithCustomPathAndHTTPFallback @webSocketApp @application ByteString
typeName
    where
        typeName :: ByteString
        typeName :: ByteString
typeName = webSocketApp -> TypeRep
forall a. Typeable a => a -> TypeRep
Typeable.typeOf (String -> webSocketApp
forall a. HasCallStack => String -> a
error String
"unreachable" :: webSocketApp)
                TypeRep -> (TypeRep -> String) -> String
forall a b. a -> (a -> b) -> b
|> TypeRep -> String
forall a. Show a => a -> String
show
                String -> (String -> ByteString) -> ByteString
forall a b. a -> (a -> b) -> b
|> String -> ByteString
ByteString.pack
{-# INLINABLE webSocketAppWithHTTPFallback #-}

-- | Routes to a given WebSocket app if the path matches
--
-- __Example:__
--
-- > instance FrontController WebApplication where
-- >     controllers = [
-- >             webSocketAppWithCustomPath @AutoRefreshWSApp "my-ws-app"
-- >         ]
--
-- The request @\/my-ws-app@ will call the AutoRefreshWSApp
--
webSocketAppWithCustomPath :: forall webSocketApp application.
    ( WSApp webSocketApp
    , InitControllerContext application
    , ?application :: application
    , Typeable application
    , Typeable webSocketApp
    ) => ByteString -> ControllerRoute application
webSocketAppWithCustomPath :: forall webSocketApp application.
(WSApp webSocketApp, InitControllerContext application,
 ?application::application, Typeable application,
 Typeable webSocketApp) =>
ByteString -> ControllerRoute application
webSocketAppWithCustomPath ByteString
path = Parser Application -> ControllerRoute application
forall application.
Parser Application -> ControllerRoute application
ControllerRouteParser (Parser Application -> ControllerRoute application)
-> Parser Application -> ControllerRoute application
forall a b. (a -> b) -> a -> b
$ do
        Char -> Parser Char
Attoparsec.char Char
'/'
        ByteString -> Parser ByteString
string ByteString
path
        Application -> Parser Application
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Application -> Parser Application)
-> Application -> Parser Application
forall a b. (a -> b) -> a -> b
$ ((?request::Request, ?respond::Respond) => Application)
-> Application
withImplicits (forall webSocketApp application.
(?request::Request, ?respond::Respond,
 InitControllerContext application, ?application::application,
 Typeable application, WSApp webSocketApp) =>
webSocketApp -> Application
startWebSocketAppAndFailOnHTTP @webSocketApp @application (forall state. WSApp state => state
WS.initialState @webSocketApp))
{-# INLINABLE webSocketAppWithCustomPath #-}

webSocketAppWithCustomPathAndHTTPFallback :: forall webSocketApp application.
    ( WSApp webSocketApp
    , InitControllerContext application
    , ?application :: application
    , Typeable application
    , Typeable webSocketApp
    , Controller webSocketApp
    ) => ByteString -> ControllerRoute application
webSocketAppWithCustomPathAndHTTPFallback :: forall webSocketApp application.
(WSApp webSocketApp, InitControllerContext application,
 ?application::application, Typeable application,
 Typeable webSocketApp, Controller webSocketApp) =>
ByteString -> ControllerRoute application
webSocketAppWithCustomPathAndHTTPFallback ByteString
path = Parser Application -> ControllerRoute application
forall application.
Parser Application -> ControllerRoute application
ControllerRouteParser (Parser Application -> ControllerRoute application)
-> Parser Application -> ControllerRoute application
forall a b. (a -> b) -> a -> b
$ do
        Char -> Parser Char
Attoparsec.char Char
'/'
        ByteString -> Parser ByteString
string ByteString
path
        let action :: webSocketApp
action = forall state. WSApp state => state
WS.initialState @webSocketApp
        Application -> Parser Application
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Application -> Parser Application)
-> Application -> Parser Application
forall a b. (a -> b) -> a -> b
$ ((?request::Request, ?respond::Respond) => Application)
-> Application
withImplicits (forall webSocketApp application.
(?request::Request, ?respond::Respond,
 InitControllerContext application, ?application::application,
 Typeable application, WSApp webSocketApp) =>
webSocketApp -> IO ResponseReceived -> Application
startWebSocketApp @webSocketApp @application webSocketApp
action (webSocketApp -> IO ResponseReceived
forall application controller.
(Controller controller, ?request::Request, ?respond::Respond,
 InitControllerContext application, ?application::application,
 Typeable application, Typeable controller) =>
controller -> IO ResponseReceived
runActionWithNewContext webSocketApp
action))
{-# INLINABLE webSocketAppWithCustomPathAndHTTPFallback #-}


-- | Defines the start page for a router (when @\/@ is requested).
startPage :: forall action application. (Controller action, InitControllerContext application, ?application::application, Typeable application, Typeable action) => action -> ControllerRoute application
startPage :: forall action application.
(Controller action, InitControllerContext application,
 ?application::application, Typeable application,
 Typeable action) =>
action -> ControllerRoute application
startPage action
action = ByteString -> action -> ControllerRoute application
forall action application.
(Controller action, InitControllerContext application,
 ?application::application, Typeable application,
 Typeable action) =>
ByteString -> action -> ControllerRoute application
get (Text -> ByteString
Text.encodeUtf8 (forall controller. Typeable controller => Text
actionPrefixText @action)) action
action
{-# INLINABLE startPage #-}

withPrefix :: ByteString -> [Parser ByteString b] -> Parser ByteString b
withPrefix ByteString
prefix [Parser ByteString b]
routes = ByteString -> Parser ByteString
string ByteString
prefix Parser ByteString -> Parser ByteString b -> Parser ByteString b
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [Parser ByteString b] -> Parser ByteString b
forall (f :: * -> *) a. Alternative f => [f a] -> f a
choice ((Parser ByteString b -> Parser ByteString b)
-> [Parser ByteString b] -> [Parser ByteString b]
forall a b. (a -> b) -> [a] -> [b]
map (\Parser ByteString b
r -> Parser ByteString b
r Parser ByteString b -> Parser ByteString () -> Parser ByteString b
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ByteString ()
forall t. Chunk t => Parser t ()
endOfInput) [Parser ByteString b]
routes)
{-# INLINABLE withPrefix #-}

frontControllerToWAIApp :: forall app (autoRefreshApp :: Type). (FrontController app, WSApp autoRefreshApp, Typeable autoRefreshApp, InitControllerContext ()) => Middleware -> app -> Application -> Application
frontControllerToWAIApp :: forall app autoRefreshApp.
(FrontController app, WSApp autoRefreshApp,
 Typeable autoRefreshApp, InitControllerContext ()) =>
Middleware -> app -> Middleware
frontControllerToWAIApp Middleware
middleware app
application Application
notFoundAction Request
waiRequest Respond
waiRespond = do
    let ?request = ?request::Request
Request
waiRequest
    let ?respond = ?respond::Respond
Respond
waiRespond

    let autoRefreshWSParser :: Parser Application
        autoRefreshWSParser :: Parser Application
autoRefreshWSParser =
            let ?application = () in
            let typeName :: ByteString
typeName = autoRefreshApp -> TypeRep
forall a. Typeable a => a -> TypeRep
Typeable.typeOf (String -> autoRefreshApp
forall a. HasCallStack => String -> a
error String
"unreachable" :: autoRefreshApp)
                    TypeRep -> (TypeRep -> String) -> String
forall a b. a -> (a -> b) -> b
|> TypeRep -> String
forall a. Show a => a -> String
show String -> (String -> ByteString) -> ByteString
forall a b. a -> (a -> b) -> b
|> String -> ByteString
ByteString.pack
            in do
                Char -> Parser Char
Attoparsec.char Char
'/'
                ByteString -> Parser ByteString
string ByteString
typeName
                Application -> Parser Application
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Application -> Parser Application)
-> Application -> Parser Application
forall a b. (a -> b) -> a -> b
$ ((?request::Request, ?respond::Respond) => Application)
-> Application
withImplicits (forall webSocketApp application.
(?request::Request, ?respond::Respond,
 InitControllerContext application, ?application::application,
 Typeable application, WSApp webSocketApp) =>
webSocketApp -> Application
startWebSocketAppAndFailOnHTTP @autoRefreshApp @() (forall state. WSApp state => state
WS.initialState @autoRefreshApp))

    let allRoutes :: [ControllerRoute app]
allRoutes = let ?application = app
?application::app
application in
            Parser Application -> ControllerRoute app
forall application.
Parser Application -> ControllerRoute application
ControllerRouteParser Parser Application
autoRefreshWSParser ControllerRoute app
-> [ControllerRoute app] -> [ControllerRoute app]
forall a. a -> [a] -> [a]
: forall application.
(FrontController application, ?application::application,
 ?request::Request, ?respond::Respond) =>
[ControllerRoute application]
controllers @app

    let path :: ByteString
path = Request
waiRequest.rawPathInfo

    -- Fast path: scan auto-route HashMaps directly (no Attoparsec overhead)
    case ByteString -> [ControllerRoute app] -> Maybe (app -> Application)
forall application.
ByteString
-> [ControllerRoute application]
-> Maybe (application -> Application)
findInRouteMaps ByteString
path [ControllerRoute app]
allRoutes of
        Just app -> Application
handler -> (Middleware
middleware (app -> Application
handler app
application)) Request
waiRequest Respond
waiRespond
        Maybe (app -> Application)
Nothing -> do
            -- Slow path: Attoparsec for custom/dynamic route parsers only
            -- Wrap any exceptions during routing in RouterException so the error handler
            -- middleware can distinguish them from action exceptions
            let customParsers :: [Parser Application]
customParsers = (ControllerRoute app -> [Parser Application])
-> [ControllerRoute app] -> [Parser Application]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ControllerRoute app -> [Parser Application]
forall application.
ControllerRoute application -> [Parser Application]
getRouteParsers [ControllerRoute app]
allRoutes

            routedAction :: Either String Application <-
                (do
                    res <- Either String Application -> IO (Either String Application)
forall a. a -> IO a
evaluate (Either String Application -> IO (Either String Application))
-> Either String Application -> IO (Either String Application)
forall a b. (a -> b) -> a -> b
$ Parser Application -> ByteString -> Either String Application
forall a. Parser a -> ByteString -> Either String a
parseOnly ([Parser Application] -> Parser Application
forall (f :: * -> *) a. Alternative f => [f a] -> f a
choice ((Parser Application -> Parser Application)
-> [Parser Application] -> [Parser Application]
forall a b. (a -> b) -> [a] -> [b]
map (Parser Application -> Parser ByteString () -> Parser Application
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ByteString ()
forall t. Chunk t => Parser t ()
endOfInput) [Parser Application]
customParsers)) ByteString
path
                    case res of
                        Left String
s -> Either String Application -> IO (Either String Application)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String Application -> IO (Either String Application))
-> Either String Application -> IO (Either String Application)
forall a b. (a -> b) -> a -> b
$ String -> Either String Application
forall a b. a -> Either a b
Left String
s
                        Right Application
action -> Either String Application -> IO (Either String Application)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String Application -> IO (Either String Application))
-> Either String Application -> IO (Either String Application)
forall a b. (a -> b) -> a -> b
$ Application -> Either String Application
forall a b. b -> Either a b
Right Application
action
                    )
                IO (Either String Application)
-> (IO (Either String Application)
    -> IO (Either String Application))
-> IO (Either String Application)
forall a b. a -> (a -> b) -> b
|> IO (Either String Application) -> IO (Either String Application)
forall a. IO a -> IO a
wrapRouterException
            case routedAction of
                Left String
_ -> Application
notFoundAction Request
waiRequest Respond
waiRespond
                Right Application
action -> (Middleware
middleware Application
action) Request
waiRequest Respond
waiRespond
{-# INLINABLE frontControllerToWAIApp #-}

mountFrontController :: forall frontController application. (?request :: Request, ?respond :: Respond, FrontController frontController) => frontController -> ControllerRoute application
mountFrontController :: forall frontController application.
(?request::Request, ?respond::Respond,
 FrontController frontController) =>
frontController -> ControllerRoute application
mountFrontController frontController
application = Parser Application -> ControllerRoute application
forall application.
Parser Application -> ControllerRoute application
ControllerRouteParser (let ?application = frontController
?application::frontController
application in [ControllerRoute frontController] -> Parser Application
forall application.
(FrontController application, ?application::application,
 ?request::Request, ?respond::Respond) =>
[ControllerRoute application] -> Parser Application
router [])
{-# INLINABLE mountFrontController #-}

-- | Create a route entry for a controller.
--
-- Automatically uses the HashMap fast path when 'AutoRoute' is available
-- (via the overlappable 'CanRoute' instance), or falls back to Attoparsec
-- for controllers with custom 'CanRoute' instances.
--
-- No user code changes needed — @parseRoute \@PostsController@ picks the
-- optimal strategy at compile time.
parseRoute :: forall controller application.
    ( ?request :: Request
    , ?respond :: Respond
    , CanRoute controller
    , Controller controller
    , InitControllerContext application
    , ?application :: application
    , Typeable application
    , Typeable controller
    ) => ControllerRoute application
parseRoute :: forall controller application.
(?request::Request, ?respond::Respond, CanRoute controller,
 Controller controller, InitControllerContext application,
 ?application::application, Typeable application,
 Typeable controller) =>
ControllerRoute application
parseRoute = forall controller application.
(CanRoute controller, ?request::Request, ?respond::Respond,
 Controller controller, InitControllerContext application,
 ?application::application, Typeable application,
 Typeable controller) =>
ControllerRoute application
toControllerRoute @controller @application
{-# INLINABLE parseRoute #-}

-- | Build a HashMap from full paths (prefix + action name) to Application closures.
-- The Application closures take the application value explicitly and handle query string
-- parsing, method validation, and controller execution.
-- Computed once per (controller, application) type pair (NOINLINE CAF).
buildAutoRouteMap :: forall controller application.
    ( AutoRoute controller
    , Controller controller
    , InitControllerContext application
    , Typeable application
    , Typeable controller
    ) => HashMap.HashMap ByteString (application -> Application)
buildAutoRouteMap :: forall controller application.
(AutoRoute controller, Controller controller,
 InitControllerContext application, Typeable application,
 Typeable controller) =>
HashMap ByteString (application -> Application)
buildAutoRouteMap = [(ByteString, application -> Application)]
-> HashMap ByteString (application -> Application)
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HashMap.fromList
    [ (ByteString
prefix ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
actionPath, application -> Application
handler)
    | Constr
constr <- DataType -> [Constr]
dataTypeConstrs (controller -> DataType
forall a. Data a => a -> DataType
dataTypeOf (controller
forall a. HasCallStack => a
Prelude.undefined :: controller))
    , let actionName :: ByteString
actionName = String -> ByteString
ByteString.pack (Constr -> String
showConstr Constr
constr)
          actionPath :: ByteString
actionPath = ByteString -> ByteString
stripActionSuffixByteString ByteString
actionName
          allowedMethods :: [StdMethod]
allowedMethods = forall controller.
AutoRoute controller =>
ByteString -> [StdMethod]
allowedMethodsForAction @controller ByteString
actionName
          handler :: application -> Application
handler application
app Request
waiRequest Respond
waiRespond =
              let ?application = application
?application::application
app
              in IO ResponseReceived -> IO ResponseReceived
forall a. IO a -> IO a
wrapRouterException do
                  case ByteString -> Either ByteString StdMethod
parseMethod (Request -> ByteString
requestMethod Request
waiRequest) of
                      Left ByteString
err -> String -> IO ResponseReceived
forall a. HasCallStack => String -> a
error (String
"Invalid HTTP method: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ByteString -> String
ByteString.unpack ByteString
err)
                      Right StdMethod
method -> do
                          Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([StdMethod]
allowedMethods [StdMethod] -> ([StdMethod] -> Bool) -> Bool
forall a b. a -> (a -> b) -> b
|> Element [StdMethod] -> [StdMethod] -> Bool
forall container.
(MonoFoldable container, Eq (Element container)) =>
Element container -> container -> Bool
includes Element [StdMethod]
StdMethod
method)
                              (UnexpectedMethodException -> IO ()
forall a e. (HasCallStack, Exception e) => e -> a
Exception.throw UnexpectedMethodException { [StdMethod]
allowedMethods :: [StdMethod]
allowedMethods :: [StdMethod]
allowedMethods, StdMethod
method :: StdMethod
method :: StdMethod
method })
                          case forall controller.
AutoRoute controller =>
Constr -> Query -> Either TypedAutoRouteError controller
applyAction @controller Constr
constr (Request -> Query
queryString Request
waiRequest) of
                              Left TypedAutoRouteError
e -> TypedAutoRouteError -> IO ResponseReceived
forall a e. (HasCallStack, Exception e) => e -> a
Exception.throw TypedAutoRouteError
e
                              Right controller
action -> forall application controller.
(Controller controller, InitControllerContext application,
 ?application::application, Typeable application,
 Typeable controller) =>
controller -> Application
runAction' @application controller
action Request
waiRequest Respond
waiRespond
    ]
    where
        prefix :: ByteString
        prefix :: ByteString
prefix = Text -> ByteString
Text.encodeUtf8 (forall controller. Typeable controller => Text
actionPrefixText @controller)
{-# NOINLINE buildAutoRouteMap #-}

parseUUIDOrTextId ::  ByteString -> Maybe Dynamic
parseUUIDOrTextId :: ByteString -> Maybe Dynamic
parseUUIDOrTextId ByteString
queryVal = ByteString
queryVal
    ByteString -> (ByteString -> Maybe UUID) -> Maybe UUID
forall a b. a -> (a -> b) -> b
|> ByteString -> Maybe UUID
fromASCIIBytes
    Maybe UUID -> (Maybe UUID -> Maybe Dynamic) -> Maybe Dynamic
forall a b. a -> (a -> b) -> b
|> \case
        Just UUID
uuid -> UUID
uuid UUID -> (UUID -> Dynamic) -> Dynamic
forall a b. a -> (a -> b) -> b
|> UUID -> Dynamic
forall a. Typeable a => a -> Dynamic
toDyn Dynamic -> (Dynamic -> Maybe Dynamic) -> Maybe Dynamic
forall a b. a -> (a -> b) -> b
|> Dynamic -> Maybe Dynamic
forall a. a -> Maybe a
Just
        Maybe UUID
Nothing -> Maybe Dynamic
forall a. Maybe a
Nothing

parseRouteWithId
    :: forall controller application.
        (
            ?request :: Request,
            ?respond :: Respond,
            CanRoute controller,
            Controller controller,
            InitControllerContext application,
            ?application :: application,
            Typeable application,
            Typeable controller)
        => ControllerRoute application
parseRouteWithId :: forall controller application.
(?request::Request, ?respond::Respond, CanRoute controller,
 Controller controller, InitControllerContext application,
 ?application::application, Typeable application,
 Typeable controller) =>
ControllerRoute application
parseRouteWithId = forall controller application.
(?request::Request, ?respond::Respond, CanRoute controller,
 Controller controller, InitControllerContext application,
 ?application::application, Typeable application,
 Typeable controller) =>
ControllerRoute application
parseRoute @controller @application

catchAll :: forall action application. (Controller action, InitControllerContext application, Typeable action, ?application :: application, Typeable application, Data action) => action -> ControllerRoute application
catchAll :: forall action application.
(Controller action, InitControllerContext application,
 Typeable action, ?application::application, Typeable application,
 Data action) =>
action -> ControllerRoute application
catchAll action
action = Parser Application -> ControllerRoute application
forall application.
Parser Application -> ControllerRoute application
ControllerRouteParser (Parser Application -> ControllerRoute application)
-> Parser Application -> ControllerRoute application
forall a b. (a -> b) -> a -> b
$ do
    ByteString -> Parser ByteString
string (Text -> ByteString
Text.encodeUtf8 (forall controller. Typeable controller => Text
actionPrefixText @action))
    _ <- Parser ByteString
takeByteString
    pure (runAction' @application action)
{-# INLINE catchAll #-}

-- | This instances makes it possible to write @<a href={MyAction}/>@ in HSX
instance {-# OVERLAPPABLE #-} (HasPath action) => ConvertibleStrings action Html5.AttributeValue where
    convertString :: action -> AttributeValue
convertString action
action = Text -> AttributeValue
Html5.textValue (action -> Text
forall controller. HasPath controller => controller -> Text
pathTo action
action)
    {-# INLINE convertString #-}

-- | Parses and returns an UUID
parseUUID :: Parser UUID
parseUUID :: Parser UUID
parseUUID = do
        uuid <- Int -> Parser ByteString
take Int
36
        case fromASCIIBytes uuid of
            Just UUID
theUUID -> UUID -> Parser UUID
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure UUID
theUUID
            Maybe UUID
Nothing -> String -> Parser UUID
forall a. String -> Parser ByteString a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"not uuid"
{-# INLINABLE parseUUID #-}

-- | Parses an UUID, afterwards wraps it in an Id
parseId :: ((ModelSupport.PrimaryKey table) ~ UUID) => Parser (ModelSupport.Id' table)
parseId :: forall (table :: Symbol).
(PrimaryKey table ~ UUID) =>
Parser (Id' table)
parseId = UUID -> Id' table
PrimaryKey table -> Id' table
forall (table :: Symbol). PrimaryKey table -> Id' table
ModelSupport.Id (UUID -> Id' table) -> Parser UUID -> Parser ByteString (Id' table)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser UUID
parseUUID
{-# INLINABLE parseId #-}

-- | Returns all the remaining text until the end of the input
remainingText :: Parser Text
remainingText :: Parser Text
remainingText = ByteString -> Text
Text.decodeUtf8 (ByteString -> Text) -> Parser ByteString -> Parser Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString
takeByteString
{-# INLINABLE remainingText #-}

-- | Parses until the next @/@
parseText :: Parser Text
parseText :: Parser Text
parseText = ByteString -> Text
Text.decodeUtf8 (ByteString -> Text) -> Parser ByteString -> Parser Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Bool) -> Parser ByteString
takeTill (Char
'/' Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==)
{-# INLINABLE parseText #-}

parseIntegerId :: (Data idType) => ByteString -> Maybe idType
parseIntegerId :: forall idType. Data idType => ByteString -> Maybe idType
parseIntegerId ByteString
queryVal = let
    Maybe Integer
rawValue :: Maybe Integer = String -> Maybe Integer
forall a. Read a => String -> Maybe a
readMaybe (ByteString -> String
forall a b. ConvertibleStrings a b => a -> b
cs ByteString
queryVal :: String)
    in
       Maybe Integer
rawValue Maybe Integer -> (Integer -> Maybe idType) -> Maybe idType
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= idType -> Maybe idType
forall a. a -> Maybe a
Just (idType -> Maybe idType)
-> (Integer -> idType) -> Integer -> Maybe idType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> idType
forall a b. a -> b
unsafeCoerce

-- | Parses and returns an integer
-- parseRational :: (Integral a) => Parser a
-- parseRational = Attoparsec.decimal

-- | Parses a route query parameter
--
-- __Example:__
--
-- > let showPost = do
-- >     string "/post"
-- >     let postId = routeParam "postId"
-- >     pure ShowPostAction { .. }
-- Will parse the `postId` query in `/post?postId=09b545dd-9744-4ef8-87b8-8d227f4faa1e`
--
routeParam :: (?request :: Request, ?respond :: Respond, ParamReader paramType) => ByteString -> paramType
routeParam :: forall paramType.
(?request::Request, ?respond::Respond, ParamReader paramType) =>
ByteString -> paramType
routeParam ByteString
paramName =
    let customFields :: TMap
customFields = Request -> TMap -> TMap
forall a. Typeable a => a -> TMap -> TMap
TypeMap.insert ?request::Request
Request
?request TMap
TypeMap.empty
    in
        let ?context = FrozenControllerContext { TMap
customFields :: TMap
customFields :: TMap
customFields }
        in ByteString -> paramType
forall valueType.
(?request::Request, ParamReader valueType) =>
ByteString -> valueType
param ByteString
paramName

-- | Display a better error when the user missed to pass an argument to an action.
--
-- E.g. when you forgot to pass a projectId to the ShowProjectAction:
--
-- > <a href={ShowProjectAction}>Show project</a>
--
-- The correct code would be this:
--
-- > <a href={ShowProjectAction projectId}>Show project</a>
--
-- See https://github.com/digitallyinduced/ihp/issues/840
instance ((T.TypeError (T.Text "Looks like you forgot to pass a " :<>: (T.ShowType argument) :<>: T.Text " to this " :<>: (T.ShowType controller))), Data argument, Data controller, Data (argument -> controller)) => AutoRoute (argument -> controller) where