{-# LANGUAGE AllowAmbiguousTypes, UndecidableInstances, LambdaCase #-}
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
, putContextRouter
, RouteParser
) where

import qualified Prelude
import ClassyPrelude hiding (index, delete, take)
import qualified IHP.ModelSupport as ModelSupport
import IHP.FrameworkConfig
import IHP.ApplicationContext hiding (frameworkConfig)
import Data.UUID
import Network.HTTP.Types.Method
import GHC.Records
import IHP.Controller.RequestContext
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 qualified Data.Char as Char
import Control.Monad.Fail
import Data.String.Conversions (ConvertibleStrings (convertString), cs)
import qualified Text.Blaze.Html5 as Html5
import qualified IHP.ErrorController as ErrorController
import qualified Control.Exception as Exception
import qualified Data.List.Split as List
import qualified Network.URI.Encode as URI
import qualified Data.Text.Encoding as Text
import Data.Dynamic
import IHP.Router.Types
import IHP.WebSocket (WSApp)
import qualified IHP.WebSocket as WS
import GHC.TypeLits as T
import IHP.Controller.Context
import IHP.Controller.Param
import qualified Data.TMap as TMap
import qualified IHP.ApplicationContext as ApplicationContext
import Data.Kind

putContextRouter :: forall value. (Typeable value) => value -> RouteParser -> RouteParser
putContextRouter :: forall value. Typeable value => value -> RouteParser -> RouteParser
putContextRouter value
value RouteParser
parser = do
    RouteParseResult
ioRouteResult <- RouteParser
parser
    let ioRouteResult' :: RouteParseResult
ioRouteResult' = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(TMap -> TMap
routeSetters, (TMap -> TMap) -> IO ResponseReceived
action) -> (TMap -> TMap
routeSetters forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall a. Typeable a => a -> TMap -> TMap
TMap.insert value
value, (TMap -> TMap) -> IO ResponseReceived
action)) RouteParseResult
ioRouteResult
    forall (f :: * -> *) a. Applicative f => a -> f a
pure RouteParseResult
ioRouteResult'

runAction'
    :: forall application controller
     . ( Controller controller
       , ?applicationContext :: ApplicationContext
       , ?context :: RequestContext
       , InitControllerContext application
       , ?application :: application
       , Typeable application
       , Typeable controller
       )
     => controller -> (TMap.TMap -> TMap.TMap) -> IO ResponseReceived
runAction' :: forall application controller.
(Controller controller, ?applicationContext::ApplicationContext,
 ?context::RequestContext, InitControllerContext application,
 ?application::application, Typeable application,
 Typeable controller) =>
controller -> (TMap -> TMap) -> IO ResponseReceived
runAction' controller
controller TMap -> TMap
contextSetter = do
    let ?modelContext = ApplicationContext -> ModelContext
ApplicationContext.modelContext ?applicationContext::ApplicationContext
?applicationContext
    let ?requestContext = ?context::RequestContext
?context
    Either (IO ResponseReceived) ControllerContext
contextOrErrorResponse <- forall application controller.
(Controller controller, ?applicationContext::ApplicationContext,
 ?context::RequestContext, InitControllerContext application,
 ?application::application, Typeable application,
 Typeable controller) =>
(TMap -> TMap)
-> controller
-> IO (Either (IO ResponseReceived) ControllerContext)
newContextForAction TMap -> TMap
contextSetter controller
controller
    case Either (IO ResponseReceived) ControllerContext
contextOrErrorResponse of
        Left IO ResponseReceived
res -> IO ResponseReceived
res
        Right ControllerContext
context -> let ?context = ControllerContext
context in forall controller.
(Controller controller, ?context::ControllerContext,
 ?modelContext::ModelContext,
 ?applicationContext::ApplicationContext,
 ?requestContext::RequestContext) =>
controller -> IO ResponseReceived
runAction controller
controller

type RouteParseResult = IO (TMap.TMap -> TMap.TMap, (TMap.TMap -> TMap.TMap) -> IO ResponseReceived)
type RouteParser = Parser (RouteParseResult)

toRouteParser :: Parser (IO ResponseReceived) -> RouteParser
toRouteParser :: Parser (IO ResponseReceived) -> RouteParser
toRouteParser Parser (IO ResponseReceived)
parser = do
    IO ResponseReceived
controller <- Parser (IO ResponseReceived)
parser
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure (\TMap
t -> TMap
t, \TMap -> TMap
_ -> IO ResponseReceived
controller)

toRouteParser' :: Parser ((TMap.TMap -> TMap.TMap) -> IO ResponseReceived) -> RouteParser
toRouteParser' :: Parser ((TMap -> TMap) -> IO ResponseReceived) -> RouteParser
toRouteParser' Parser ((TMap -> TMap) -> IO ResponseReceived)
parser = do
    (TMap -> TMap) -> IO ResponseReceived
controller <- Parser ((TMap -> TMap) -> IO ResponseReceived)
parser
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure (\TMap
t -> TMap
t, (TMap -> TMap) -> IO ResponseReceived
controller)

toRouteParseResult :: IO ResponseReceived -> RouteParseResult
toRouteParseResult :: IO ResponseReceived -> RouteParseResult
toRouteParseResult IO ResponseReceived
ioResponseReceived = forall (f :: * -> *) a. Applicative f => a -> f a
pure (\TMap
t -> TMap
t, \TMap -> TMap
_ -> IO ResponseReceived
ioResponseReceived)

class FrontController application where
    controllers
        :: forall controller
         . (?applicationContext :: ApplicationContext, ?application :: application, ?context :: RequestContext)
        => [RouteParser]

    router
        :: (?applicationContext :: ApplicationContext, ?application :: application, ?context :: RequestContext)
        => [RouteParser] -> RouteParser
    router = forall application.
(?applicationContext::ApplicationContext,
 ?application::application, ?context::RequestContext,
 FrontController application) =>
[RouteParser] -> RouteParser
defaultRouter

defaultRouter
    :: (?applicationContext :: ApplicationContext, ?application :: application, ?context :: RequestContext, FrontController application)
    => [RouteParser] -> RouteParser
defaultRouter :: forall application.
(?applicationContext::ApplicationContext,
 ?application::application, ?context::RequestContext,
 FrontController application) =>
[RouteParser] -> RouteParser
defaultRouter [RouteParser]
additionalControllers = do
    let allControllers :: [RouteParser]
allControllers = forall application {k} (controller :: k).
(FrontController application,
 ?applicationContext::ApplicationContext, ?application::application,
 ?context::RequestContext) =>
[RouteParser]
controllers forall a. Semigroup a => a -> a -> a
<> [RouteParser]
additionalControllers
    RouteParseResult
ioResponseReceived <- forall (f :: * -> *) a. Alternative f => [f a] -> f a
choice forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (\RouteParser
r -> RouteParser
r forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall t. Chunk t => Parser t ()
endOfInput) [RouteParser]
allControllers
    forall (f :: * -> *) a. Applicative f => a -> f a
pure RouteParseResult
ioResponseReceived

class HasPath controller where
    -- | Returns the path to a given action
    --
    -- >>> pathTo UsersAction
    -- "/Users"
    --
    -- >>> pathTo ShowUserAction { userId = "a32913dd-ef80-4f3e-9a91-7879e17b2ece" }
    -- "/ShowUser?userId=a32913dd-ef80-4f3e-9a91-7879e17b2ece"
    pathTo :: controller -> Text

-- | 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.frameworkConfig.baseUrl forall a. Semigroup a => a -> a -> a
<> forall controller. HasPath controller => controller -> Text
pathTo action
action
{-# INLINE urlTo #-}

class HasPath controller => CanRoute controller where
    parseRoute' :: (?context :: RequestContext) => Parser controller


-- | 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 forall {k} (a :: k) (b :: k).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
eqT :: Maybe (d :~: Int) of
                    Just d :~: Int
Refl -> forall c a.
(Element c ~ Char, MonoFoldable c, Read a) =>
c -> Maybe a
readMay (forall a b. ConvertibleStrings a b => a -> b
cs ByteString
queryValue :: String)
                        forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> \case
                            Just d
int -> forall a b. b -> Either a b
Right d
int
                            Maybe d
Nothing -> forall a b. a -> Either a b
Left BadType { $sel:field:BadType :: ByteString
field = ByteString
"", $sel:value:BadType :: Maybe ByteString
value = forall a. a -> Maybe a
Just ByteString
queryValue, $sel:expectedType:BadType :: ByteString
expectedType = ByteString
"Int" }
                    Maybe (d :~: Int)
Nothing -> case forall {k} (a :: k) (b :: k).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
eqT :: Maybe (d :~: Maybe Int) of
                        Just d :~: Maybe Int
Refl -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall c a.
(Element c ~ Char, MonoFoldable c, Read a) =>
c -> Maybe a
readMay (forall a b. ConvertibleStrings a b => a -> b
cs ByteString
queryValue :: String)
                        Maybe (d :~: Maybe Int)
Nothing -> forall a b. a -> Either a b
Left TypedAutoRouteError
NotMatched
                Maybe ByteString
Nothing -> case forall {k} (a :: k) (b :: k).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
eqT :: Maybe (d :~: Maybe Int) of
                    Just d :~: Maybe Int
Refl -> forall a b. b -> Either a b
Right forall a. Maybe a
Nothing
                    Maybe (d :~: Maybe Int)
Nothing -> forall a b. a -> Either a b
Left TypedAutoRouteError
NotMatched,

            \case
                Just ByteString
queryValue -> case forall {k} (a :: k) (b :: k).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
eqT :: Maybe (d :~: Integer) of
                    Just d :~: Integer
Refl -> forall c a.
(Element c ~ Char, MonoFoldable c, Read a) =>
c -> Maybe a
readMay (forall a b. ConvertibleStrings a b => a -> b
cs ByteString
queryValue :: String)
                        forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> \case
                            Just d
int -> forall a b. b -> Either a b
Right d
int
                            Maybe d
Nothing -> forall a b. a -> Either a b
Left BadType { $sel:field:BadType :: ByteString
field = ByteString
"", $sel:value:BadType :: Maybe ByteString
value = forall a. a -> Maybe a
Just ByteString
queryValue, $sel:expectedType:BadType :: ByteString
expectedType = ByteString
"Integer" }
                    Maybe (d :~: Integer)
Nothing -> case forall {k} (a :: k) (b :: k).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
eqT :: Maybe (d :~: Maybe Integer) of
                        Just d :~: Maybe Integer
Refl -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall c a.
(Element c ~ Char, MonoFoldable c, Read a) =>
c -> Maybe a
readMay (forall a b. ConvertibleStrings a b => a -> b
cs ByteString
queryValue :: String)
                        Maybe (d :~: Maybe Integer)
Nothing -> forall a b. a -> Either a b
Left TypedAutoRouteError
NotMatched
                Maybe ByteString
Nothing -> case forall {k} (a :: k) (b :: k).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
eqT :: Maybe (d :~: Maybe Integer) of
                    Just d :~: Maybe Integer
Refl -> forall a b. b -> Either a b
Right forall a. Maybe a
Nothing
                    Maybe (d :~: Maybe Integer)
Nothing -> forall a b. a -> Either a b
Left TypedAutoRouteError
NotMatched,

            -- Try and parse @Text@ or @Maybe Text@
            \case
                Just ByteString
queryValue -> case forall {k} (a :: k) (b :: k).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
eqT :: Maybe (d :~: Text) of
                    Just d :~: Text
Refl -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall a b. ConvertibleStrings a b => a -> b
cs ByteString
queryValue
                    Maybe (d :~: Text)
Nothing -> case forall {k} (a :: k) (b :: k).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
eqT :: Maybe (d :~: Maybe Text) of
                        Just d :~: Maybe Text
Refl -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a b. ConvertibleStrings a b => a -> b
cs ByteString
queryValue
                        Maybe (d :~: Maybe Text)
Nothing -> forall a b. a -> Either a b
Left TypedAutoRouteError
NotMatched
                Maybe ByteString
Nothing -> case forall {k} (a :: k) (b :: k).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
eqT :: Maybe (d :~: Maybe Text) of
                    Just d :~: Maybe Text
Refl -> forall a b. b -> Either a b
Right forall a. Maybe a
Nothing
                    Maybe (d :~: Maybe Text)
Nothing -> 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 forall {k} (a :: k) (b :: k).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
eqT :: Maybe (d :~: idType) of
                        Just d :~: idType
Refl -> forall a b. b -> Either a b
Right idType
idValue
                        Maybe (d :~: idType)
Nothing -> forall a b. a -> Either a b
Left TypedAutoRouteError
NotMatched
                    Maybe idType
Nothing -> forall a b. a -> Either a b
Left TypedAutoRouteError
NotMatched
                Maybe ByteString
Nothing -> 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 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 -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ Text -> Text -> [Text]
Text.splitOn Text
"," (forall a b. ConvertibleStrings a b => a -> b
cs ByteString
queryValue)
                    Maybe ByteString
Nothing -> forall a b. b -> Either a b
Right []
                Maybe (d :~: [Text])
Nothing -> 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 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 -> Text -> Text -> [Text]
Text.splitOn Text
"," (forall a b. ConvertibleStrings a b => a -> b
cs ByteString
queryValue)
                        forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map forall c a.
(Element c ~ Char, MonoFoldable c, Read a) =>
c -> Maybe a
readMay
                        forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> forall (f :: * -> *) t.
(IsSequence (f (Maybe t)), Functor f,
 Element (f (Maybe t)) ~ Maybe t) =>
f (Maybe t) -> f t
catMaybes
                        forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> forall a b. b -> Either a b
Right
                    Maybe ByteString
Nothing -> forall a b. b -> Either a b
Right []
                Maybe (d :~: [Int])
Nothing -> forall a b. a -> Either a b
Left TypedAutoRouteError
NotMatched,

            \Maybe ByteString
queryValue -> case 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 -> Text -> Text -> [Text]
Text.splitOn Text
"," (forall a b. ConvertibleStrings a b => a -> b
cs ByteString
queryValue)
                        forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map forall c a.
(Element c ~ Char, MonoFoldable c, Read a) =>
c -> Maybe a
readMay
                        forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> forall (f :: * -> *) t.
(IsSequence (f (Maybe t)), Functor f,
 Element (f (Maybe t)) ~ Maybe t) =>
f (Maybe t) -> f t
catMaybes
                        forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> forall a b. b -> Either a b
Right
                    Maybe ByteString
Nothing -> forall a b. b -> Either a b
Right []
                Maybe (d :~: [Integer])
Nothing -> forall a b. a -> Either a b
Left TypedAutoRouteError
NotMatched,

            -- Try and parse a raw [UUID]
            \Maybe ByteString
queryValue -> case 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
                        forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> forall a b. ConvertibleStrings a b => a -> b
cs
                        forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> Text -> Text -> [Text]
Text.splitOn Text
","
                        forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (ByteString -> Maybe UUID
fromASCIIBytes forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall a b. ConvertibleStrings a b => a -> b
cs)
                        forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> forall (f :: * -> *) t.
(IsSequence (f (Maybe t)), Functor f,
 Element (f (Maybe t)) ~ Maybe t) =>
f (Maybe t) -> f t
catMaybes
                        forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> forall a b. b -> Either a b
Right
                    Maybe ByteString
Nothing -> forall a b. b -> Either a b
Right []
                Maybe (d :~: [UUID])
Nothing -> forall a b. a -> Either a b
Left TypedAutoRouteError
NotMatched,

            -- Try and parse a raw UUID
            \Maybe ByteString
queryValue -> case 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
                        forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> ByteString -> Maybe UUID
fromASCIIBytes
                        forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> \case
                            Just UUID
uuid -> UUID
uuid forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> forall a b. b -> Either a b
Right
                            Maybe UUID
Nothing -> forall a b. a -> Either a b
Left BadType { $sel:field:BadType :: ByteString
field = ByteString
"", $sel:value:BadType :: Maybe ByteString
value = forall a. a -> Maybe a
Just ByteString
queryValue, $sel:expectedType:BadType :: ByteString
expectedType = ByteString
"UUID" }
                    Maybe ByteString
Nothing -> forall a b. a -> Either a b
Left TypedAutoRouteError
NotMatched
                Maybe (d :~: UUID)
Nothing -> 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
                    forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> ByteString -> Maybe UUID
fromASCIIBytes
                    forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> \case
                        Just UUID
uuid -> UUID
uuid forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> forall a b. a -> b
unsafeCoerce forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> forall a b. b -> Either a b
Right
                        Maybe UUID
Nothing -> forall a b. a -> Either a b
Left BadType { $sel:field:BadType :: ByteString
field = ByteString
"", $sel:value:BadType :: Maybe ByteString
value = forall a. a -> Maybe a
Just ByteString
queryValue, $sel:expectedType:BadType :: ByteString
expectedType = ByteString
"UUID" }
                Maybe ByteString
Nothing -> forall a b. a -> Either a b
Left TypedAutoRouteError
NotMatched
            ]

-- | 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
        forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map forall a b. ConvertibleStrings a b => a -> b
cs
        forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (\ByteString
field -> (ByteString
field, forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall a b. (a -> b) -> a -> b
$ forall a b. Eq a => a -> [(a, b)] -> Maybe b
List.lookup ByteString
field Query
query))

-- | 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) [] = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
State.lift (forall a b. a -> Either a b
Left NoConstructorMatched
                { $sel:field:BadType :: ByteString
field = ByteString
queryName
                , $sel:value:BadType :: Maybe ByteString
value = Maybe ByteString
queryValue
                , $sel:expectedType:BadType :: ByteString
expectedType = (forall a. Data a => a -> DataType
dataTypeOf (forall a. HasCallStack => a
undefined :: d)) forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> DataType -> String
dataTypeName forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> 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 -> 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{} -> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
State.lift (forall a b. a -> Either a b
Left TypedAutoRouteError
badType { $sel:field:BadType :: ByteString
field = ByteString
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
_ -> 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
            Query
queryParams <- forall s (m :: * -> *). MonadState s m => m s
State.get
            case Query
queryParams of
                [] -> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
State.lift (forall a b. a -> Either a b
Left TypedAutoRouteError
TooFewArguments)
                (p :: QueryItem
p@(ByteString
key, Maybe ByteString
value):Query
rest) -> do
                    forall s (m :: * -> *). MonadState s m => s -> m ()
State.put Query
rest
                    forall d.
Data d =>
QueryItem
-> [Maybe ByteString -> Either TypedAutoRouteError d]
-> StateT Query (Either TypedAutoRouteError) d
attemptToParseArg QueryItem
p (forall d idType.
(Data d, Data idType) =>
(ByteString -> Maybe idType)
-> [Maybe ByteString -> Either TypedAutoRouteError d]
parseFuncs ByteString -> Maybe idType
parseIdType)


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


class Data controller => AutoRoute controller where
    autoRouteWithIdType :: (?context :: RequestContext, Data idType) => (ByteString -> Maybe idType) -> Parser controller
    autoRouteWithIdType ByteString -> Maybe idType
parseIdFunc =
        let
            allConstructors :: [Constr]
            allConstructors :: [Constr]
allConstructors = DataType -> [Constr]
dataTypeConstrs (forall a. Data a => a -> DataType
dataTypeOf (forall a. HasCallStack => a
Prelude.undefined :: controller))

            query :: Query
            query :: Query
query = Request -> Query
queryString (forall {k} (x :: k) r a. HasField x r a => r -> a
getField @"request" ?context::RequestContext
?context)

            paramValues :: [ByteString]
            paramValues :: [ByteString]
paramValues = forall (f :: * -> *) t.
(IsSequence (f (Maybe t)), Functor f,
 Element (f (Maybe t)) ~ Maybe t) =>
f (Maybe t) -> f t
catMaybes forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map forall a b. (a, b) -> b
snd Query
query

            parseAction :: Constr -> Parser controller
            parseAction :: Constr -> Parser controller
parseAction Constr
constr = let
                    prefix :: ByteString
                    prefix :: ByteString
prefix = String -> ByteString
ByteString.pack (forall controller. Typeable controller => String
actionPrefix @controller)

                    actionName :: ByteString
actionName = String -> ByteString
ByteString.pack (Constr -> String
showConstr Constr
constr)

                    actionPath :: ByteString
                    actionPath :: ByteString
actionPath = forall {a}. (IsSequence a, IsString a, Eq (Element a)) => a -> a
stripActionSuffix ByteString
actionName

                    allowedMethods :: [StdMethod]
allowedMethods = forall controller.
AutoRoute controller =>
ByteString -> [StdMethod]
allowedMethodsForAction @controller ByteString
actionName

                    checkRequestMethod :: controller -> Parser controller
checkRequestMethod controller
action = do
                            StdMethod
method <- (?context::RequestContext) => Parser StdMethod
getMethod
                            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([StdMethod]
allowedMethods forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> forall container.
(MonoFoldable container, Eq (Element container)) =>
Element container -> container -> Bool
includes StdMethod
method) (forall a e. Exception e => e -> a
Exception.throw UnexpectedMethodException { [StdMethod]
$sel:allowedMethods:UnexpectedMethodException :: [StdMethod]
allowedMethods :: [StdMethod]
allowedMethods, StdMethod
$sel:method:UnexpectedMethodException :: StdMethod
method :: StdMethod
method })
                            forall (f :: * -> *) a. Applicative f => a -> f a
pure controller
action

                    action :: Parser controller
action = case forall controller idType.
(Data controller, Data idType) =>
(ByteString -> Maybe idType)
-> Constr -> Query -> Either TypedAutoRouteError controller
applyConstr ByteString -> Maybe idType
parseIdFunc Constr
constr Query
query of
                        Right controller
parsedAction -> forall (f :: * -> *) a. Applicative f => a -> f a
pure controller
parsedAction
                        Left TypedAutoRouteError
e -> forall a e. Exception e => e -> a
Exception.throw TypedAutoRouteError
e

                in do
                    controller
parsedAction <- ByteString -> Parser ByteString
string ByteString
prefix forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (ByteString -> Parser ByteString
string ByteString
actionPath forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall t. Chunk t => Parser t ()
endOfInput) forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser controller
action
                    controller -> Parser controller
checkRequestMethod controller
parsedAction

        in forall (f :: * -> *) a. Alternative f => [f a] -> f a
choice (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map Constr -> Parser controller
parseAction [Constr]
allConstructors)

    autoRoute :: (?context :: RequestContext) => Parser controller
    autoRoute = forall controller idType.
(AutoRoute controller, ?context::RequestContext, Data idType) =>
(ByteString -> Maybe idType) -> Parser controller
autoRouteWithIdType (\ByteString
_ -> forall a. Maybe a
Nothing :: Maybe Integer)

    -- | 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 #-}

-- | 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/@.
actionPrefix :: forall (controller :: Type). Typeable controller => String
actionPrefix :: forall controller. Typeable controller => String
actionPrefix =
        case String
moduleName of
            (Char
'W':Char
'e':Char
'b':Char
'.':String
_) -> String
"/"
            (Char
'I':Char
'H':Char
'P':Char
'.':String
_) -> String
"/"
            (String
"") -> String
"/"
            String
moduleName -> String
"/" forall a. Semigroup a => a -> a -> a
<> let (String
prefix:[String]
_) = forall a. (a -> Bool) -> [a] -> [[a]]
List.splitWhen (forall a. Eq a => a -> a -> Bool
== Char
'.') String
moduleName in forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map Char -> Char
Char.toLower String
prefix forall a. Semigroup a => a -> a -> a
<> String
"/"
    where
        moduleName :: String
        moduleName :: String
moduleName = forall a. Typeable a => a -> TypeRep
Typeable.typeOf (forall a. HasCallStack => String -> a
error String
"unreachable" :: controller)
                forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> TypeRep -> TyCon
Typeable.typeRepTyCon
                forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> TyCon -> String
Typeable.tyConModule
{-# INLINE actionPrefix #-}

-- | Strips the "Action" at the end of action names
--
-- >>> stripActionSuffix "ShowUserAction"
-- "ShowUser"
--
-- >>> stripActionSuffix "UsersAction"
-- "UsersAction"
--
-- >>> stripActionSuffix "User"
-- "User"
stripActionSuffix :: a -> a
stripActionSuffix a
actionName = forall a. a -> Maybe a -> a
fromMaybe a
actionName (forall seq.
(IsSequence seq, Eq (Element seq)) =>
seq -> seq -> Maybe seq
stripSuffix a
"Action" a
actionName)
{-# INLINE stripActionSuffix #-}

-- | 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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Data a => Constr -> a
fromConstr Maybe Constr
createConstructor
    where
        createConstructor :: Maybe Constr
        createConstructor :: Maybe Constr
createConstructor = forall seq.
SemiSequence seq =>
(Element seq -> Bool) -> seq -> Maybe (Element seq)
find Constr -> Bool
isCreateConstructor [Constr]
allConstructors

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

        isCreateConstructor :: Constr -> Bool
        isCreateConstructor :: Constr -> Bool
isCreateConstructor Constr
constructor = String
"Create" forall seq.
(IsSequence seq, Eq (Element seq)) =>
seq -> seq -> Bool
`isPrefixOf` Constr -> String
showConstr Constr
constructor Bool -> Bool -> Bool
&& forall mono. MonoFoldable mono => mono -> Bool
ClassyPrelude.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 -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ \id
id -> Constr -> id -> controller
buildInstance Constr
constructor id
id
            Maybe Constr
Nothing -> forall a. Maybe a
Nothing
    where
        updateConstructor :: Maybe Constr
        updateConstructor :: Maybe Constr
updateConstructor = forall seq.
SemiSequence seq =>
(Element seq -> Bool) -> seq -> Maybe (Element seq)
find Constr -> Bool
isUpdateConstructor [Constr]
allConstructors

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

                forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
State.modify (forall a. Num a => a -> a -> a
+Integer
1)
                forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. a -> b
unsafeCoerce id
id)
            )) Constr
constructor) Integer
0

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

        isUpdateConstructor :: Constr -> Bool
        isUpdateConstructor :: Constr -> Bool
isUpdateConstructor Constr
constructor = String
"Update" forall seq.
(IsSequence seq, Eq (Element seq)) =>
seq -> seq -> Bool
`isPrefixOf` (Constr -> String
showConstr Constr
constructor) Bool -> Bool -> Bool
&& (forall mono. MonoFoldable mono => mono -> Int
length (Constr -> [String]
constrFields Constr
constructor) forall a. Eq a => a -> a -> Bool
== Int
1)
{-# INLINE updateAction #-}

instance {-# OVERLAPPABLE #-} (AutoRoute controller, Controller controller) => CanRoute controller where
    parseRoute' :: (?context::RequestContext) => Parser controller
parseRoute' = forall controller.
(AutoRoute controller, ?context::RequestContext) =>
Parser controller
autoRoute
    {-# INLINABLE parseRoute' #-}

-- | 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 = forall a. Show a => a -> String
show

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

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

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

instance QueryParam a => QueryParam [a] where
    showQueryParam :: [a] -> String
showQueryParam = forall a. [a] -> [[a]] -> [a]
List.intercalate String
"," forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map forall a. QueryParam a => a -> String
showQueryParam

instance {-# OVERLAPPABLE #-} (Show controller, AutoRoute controller) => HasPath controller where
    {-# INLINABLE pathTo #-}
    pathTo :: controller -> Text
pathTo !controller
action = String -> Text
Text.pack (String
appPrefix forall a. Semigroup a => a -> a -> a
<> String
actionName forall a. Semigroup a => a -> a -> a
<> String
arguments)
        where
            appPrefix :: String
            !appPrefix :: String
appPrefix = forall controller. Typeable controller => String
actionPrefix @controller

            actionName :: String
            !actionName :: String
actionName = (forall {a}. (IsSequence a, IsString a, Eq (Element a)) => a -> a
stripActionSuffix forall a b. (a -> b) -> a -> b
$! Constr -> String
showConstr Constr
constructor)

            constructor :: Constr
constructor = forall a. Data a => a -> Constr
toConstr controller
action

            stripQuotes :: String -> String
stripQuotes (Char
'"':String
rest) = forall a. [a] -> [a]
List.init String
rest
            stripQuotes String
otherwise = String
otherwise

            -- | The @gmapQ@ function allows us to iterate over each term in a constructor function and
            -- build a list of results from performing some function on each term.
            -- Here we send each term through @constrShow@, giving us our preferred representation for
            -- use in URLs.
            showTerms :: controller -> [Maybe String]
            showTerms :: controller -> [Maybe String]
showTerms = forall a u. Data a => (forall d. Data d => d -> u) -> a -> [u]
gmapQ (forall d. Data d => [d -> Maybe String] -> d -> Maybe String
constrShow forall d. Data d => [d -> Maybe String]
typeShows)

            -- | @constrShow@ tries to convert each value @d@ into a String representation.
            -- If one passes, return it immediately, otherwise try all the defined @typeShow@ functions.
            constrShow :: Data d => [(d -> Maybe String)] -> d -> Maybe String
            constrShow :: forall d. Data d => [d -> Maybe String] -> d -> Maybe String
constrShow [] d
_ = forall a. Maybe a
Nothing
            constrShow (d -> Maybe String
f:[d -> Maybe String]
fs) d
d = case d -> Maybe String
f d
d of
                Just String
str -> forall a. a -> Maybe a
Just String
str
                Maybe String
Nothing -> forall d. Data d => [d -> Maybe String] -> d -> Maybe String
constrShow [d -> Maybe String]
fs d
d

            -- | Try and match some value to all of the types we can represent in a URL.
            -- Only type not contained in here is the "Id" type, since we cannot match
            -- on polymorphic types.
            typeShows :: forall d. Data d => [(d -> Maybe String)]
            typeShows :: forall d. Data d => [d -> Maybe String]
typeShows = [
                \d
val -> (forall {k} (a :: k) (b :: k).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
eqT :: Maybe (d :~: Text))
                    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \d :~: Text
Refl -> forall a. a -> Maybe a
Just (forall a. QueryParam a => a -> String
showQueryParam d
val),
                \d
val -> (forall {k} (a :: k) (b :: k).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
eqT :: Maybe (d :~: [Text]))
                    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \d :~: [Text]
Refl -> forall a. a -> Maybe a
Just (forall a. QueryParam a => a -> String
showQueryParam (d
val :: [Text])),
                \d
val -> (forall {k} (a :: k) (b :: k).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
eqT :: Maybe (d :~: Maybe Text))
                    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \d :~: Maybe Text
Refl -> forall a. a -> Maybe a
Just (forall a. QueryParam a => a -> String
showQueryParam d
val),
                \d
val -> (forall {k} (a :: k) (b :: k).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
eqT :: Maybe (d :~: Int))
                    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \d :~: Int
Refl -> forall a. a -> Maybe a
Just (forall a. QueryParam a => a -> String
showQueryParam d
val),
                \d
val -> (forall {k} (a :: k) (b :: k).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
eqT :: Maybe (d :~: [Int]))
                    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \d :~: [Int]
Refl -> forall a. a -> Maybe a
Just (forall a. QueryParam a => a -> String
showQueryParam d
val),
                \d
val -> (forall {k} (a :: k) (b :: k).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
eqT :: Maybe (d :~: Maybe Int))
                    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \d :~: Maybe Int
Refl -> forall a. a -> Maybe a
Just (forall a. QueryParam a => a -> String
showQueryParam d
val),
                \d
val -> (forall {k} (a :: k) (b :: k).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
eqT :: Maybe (d :~: Integer))
                    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \d :~: Integer
Refl -> forall a. a -> Maybe a
Just (forall a. QueryParam a => a -> String
showQueryParam d
val),
                \d
val -> (forall {k} (a :: k) (b :: k).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
eqT :: Maybe (d :~: [Integer]))
                    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \d :~: [Integer]
Refl -> forall a. a -> Maybe a
Just (forall a. QueryParam a => a -> String
showQueryParam d
val),
                \d
val -> (forall {k} (a :: k) (b :: k).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
eqT :: Maybe (d :~: Maybe Integer))
                    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \d :~: Maybe Integer
Refl -> forall a. a -> Maybe a
Just (forall a. QueryParam a => a -> String
showQueryParam d
val),
                \d
val -> (forall {k} (a :: k) (b :: k).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
eqT :: Maybe (d :~: UUID))
                    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \d :~: UUID
Refl -> forall a. a -> Maybe a
Just (forall a. QueryParam a => a -> String
showQueryParam d
val),
                \d
val -> (forall {k} (a :: k) (b :: k).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
eqT :: Maybe (d :~: Maybe UUID))
                    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \d :~: Maybe UUID
Refl -> forall a. a -> Maybe a
Just (forall a. QueryParam a => a -> String
showQueryParam d
val),
                \d
val -> (forall {k} (a :: k) (b :: k).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
eqT :: Maybe (d :~: [UUID]))
                    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \d :~: [UUID]
Refl -> forall a. a -> Maybe a
Just (forall a. QueryParam a => a -> String
showQueryParam d
val)
                ]

            arguments :: String
            !arguments :: String
arguments = forall a. Show a => a -> String
show controller
action -- `SomeRecord { a = b, c = d }`
                    forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> forall a. (a -> Bool) -> [a] -> [a]
List.filter (forall a. Eq a => a -> a -> Bool
/= Char
' ')
                    forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> forall a. (a -> Bool) -> [a] -> ([a], [a])
List.break (forall a. Eq a => a -> a -> Bool
== Char
'{')
                    forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> forall a b. (a, b) -> b
snd
                    forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> forall a. Int -> [a] -> [a]
List.drop Int
1
                    forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> forall a. (a -> Bool) -> [a] -> ([a], [a])
List.break (forall a. Eq a => a -> a -> Bool
== Char
'}')
                    forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> forall a b. (a, b) -> a
fst -- `a=b,c=d`
                    forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> forall a. (a -> Bool) -> [a] -> [[a]]
List.splitWhen (forall a. Eq a => a -> a -> Bool
== Char
',') -- ["a=b", "c=d"]
                    forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (\String
s -> let (String
key, String
value) = forall a. (a -> Bool) -> [a] -> ([a], [a])
List.break (forall a. Eq a => a -> a -> Bool
== Char
'=') String
s in (String
key, forall a. Int -> [a] -> [a]
List.drop Int
1 String
value))
                    forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (\(String
k ,String
v) -> (String
k, String -> String
stripQuotes String
v)) -- "value" -> value
                    forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> forall seq. IsSequence seq => (Element seq -> Bool) -> seq -> seq
filter (\(String
k, String
v) -> (Bool -> Bool
not forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
List.null) String
k Bool -> Bool -> Bool
&& (Bool -> Bool
not forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
List.null) String
v)
                    -- At this point we have a list of keys and values as represented by @show@.
                    -- For Lists and Maybe types, we want to represent these in a different way,
                    -- so we construct another list of values using type reflection and the QueryParam type class.
                    forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> \([(String, String)]
kvs :: [(String, String)]) -> forall (f :: * -> *) a b. Zip f => f a -> f b -> f (a, b)
zip (controller -> [Maybe String]
showTerms controller
action) [(String, String)]
kvs
                    -- If an Id type was present in the action, it will be returned as Nothing by @showTerms@
                    -- as we are not able to match on the type using reflection.
                    -- In this case we default back to the @show@ representation.
                    forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (\(Maybe String
v1, (String
k, String
v2)) -> (String
k, forall a. a -> Maybe a -> a
fromMaybe String
v2 Maybe String
v1))
                    forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (\(String
k, String
v) -> if forall value. IsEmpty value => value -> Bool
isEmpty String
v
                        then String
""
                        else  String
k forall a. Semigroup a => a -> a -> a
<> String
"=" forall a. Semigroup a => a -> a -> a
<> String -> String
URI.encode String
v)
                    forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> forall a. (a -> Bool) -> [a] -> [a]
List.filter (Bool -> Bool
not forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall value. IsEmpty value => value -> Bool
isEmpty)
                    forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> forall a. [a] -> [[a]] -> [a]
List.intercalate String
"&"
                    forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> (\String
q -> if forall (t :: * -> *) a. Foldable t => t a -> Bool
List.null String
q then String
q else Char
'?'forall a. a -> [a] -> [a]
:String
q)

-- | Parses the HTTP Method from the request and returns it.
getMethod :: (?context :: RequestContext) => Parser StdMethod
getMethod :: (?context::RequestContext) => Parser StdMethod
getMethod =
        ?context::RequestContext
?context
        forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> RequestContext -> Request
IHP.Controller.RequestContext.request
        forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> Request -> ByteString
requestMethod
        forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> ByteString -> Either ByteString StdMethod
parseMethod
        forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> \case
            Left ByteString
error -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail (ByteString -> String
ByteString.unpack ByteString
error)
            Right StdMethod
method -> 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
    , ?applicationContext :: ApplicationContext
    , ?context :: RequestContext
    , Typeable application
    , Typeable action
    ) => ByteString -> action -> RouteParser
get :: forall action application.
(Controller action, InitControllerContext application,
 ?application::application, ?applicationContext::ApplicationContext,
 ?context::RequestContext, Typeable application, Typeable action) =>
ByteString -> action -> RouteParser
get ByteString
path action
action = Parser ((TMap -> TMap) -> IO ResponseReceived) -> RouteParser
toRouteParser' do
    StdMethod
method <- (?context::RequestContext) => Parser StdMethod
getMethod
    case StdMethod
method of
        StdMethod
GET -> do
            ByteString -> Parser ByteString
string ByteString
path
            forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall application controller.
(Controller controller, ?applicationContext::ApplicationContext,
 ?context::RequestContext, InitControllerContext application,
 ?application::application, Typeable application,
 Typeable controller) =>
controller -> (TMap -> TMap) -> IO ResponseReceived
runAction' action
action)
        StdMethod
_   -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Invalid method, expected GET"
{-# 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
    , ?applicationContext :: ApplicationContext
    , ?context :: RequestContext
    , Typeable application
    , Typeable action
    ) => ByteString -> action -> RouteParser
post :: forall action application.
(Controller action, InitControllerContext application,
 ?application::application, ?applicationContext::ApplicationContext,
 ?context::RequestContext, Typeable application, Typeable action) =>
ByteString -> action -> RouteParser
post ByteString
path action
action = Parser ((TMap -> TMap) -> IO ResponseReceived) -> RouteParser
toRouteParser' do
    StdMethod
method <- (?context::RequestContext) => Parser StdMethod
getMethod
    case StdMethod
method of
        StdMethod
POST -> do
            ByteString -> Parser ByteString
string ByteString
path
            forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall application controller.
(Controller controller, ?applicationContext::ApplicationContext,
 ?context::RequestContext, InitControllerContext application,
 ?application::application, Typeable application,
 Typeable controller) =>
controller -> (TMap -> TMap) -> IO ResponseReceived
runAction' action
action)
        StdMethod
_   -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Invalid method, expected POST"
{-# 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 :: (?context :: RequestContext) => [StdMethod] -> Parser ()
onlyAllowMethods :: (?context::RequestContext) => [StdMethod] -> Parser ()
onlyAllowMethods [StdMethod]
methods = do
    StdMethod
method <- (?context::RequestContext) => Parser StdMethod
getMethod
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (StdMethod
method forall container.
(MonoFoldable container, Eq (Element container)) =>
Element container -> container -> Bool
`elem` [StdMethod]
methods) (forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"Invalid method, expected one of: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show [StdMethod]
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 controller.
    ( WSApp webSocketApp
    , InitControllerContext application
    , ?application :: application
    , ?applicationContext :: ApplicationContext
    , ?context :: RequestContext
    , Typeable application
    , Typeable webSocketApp
    ) => RouteParser
webSocketApp :: forall {k} webSocketApp application (controller :: k).
(WSApp webSocketApp, InitControllerContext application,
 ?application::application, ?applicationContext::ApplicationContext,
 ?context::RequestContext, Typeable application,
 Typeable webSocketApp) =>
RouteParser
webSocketApp = forall {k} webSocketApp application (controller :: k).
(WSApp webSocketApp, InitControllerContext application,
 ?application::application, ?applicationContext::ApplicationContext,
 ?context::RequestContext, Typeable application,
 Typeable webSocketApp) =>
ByteString -> RouteParser
webSocketAppWithCustomPath @webSocketApp ByteString
typeName
    where
        typeName :: ByteString
        typeName :: ByteString
typeName = forall a. Typeable a => a -> TypeRep
Typeable.typeOf (forall a. HasCallStack => String -> a
error String
"unreachable" :: webSocketApp)
                forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> forall a. Show a => a -> String
show
                forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> String -> ByteString
ByteString.pack
{-# INLINABLE webSocketApp #-}

webSocketAppWithHTTPFallback :: forall webSocketApp application.
    ( WSApp webSocketApp
    , InitControllerContext application
    , ?application :: application
    , ?applicationContext :: ApplicationContext
    , ?context :: RequestContext
    , Typeable application
    , Typeable webSocketApp
    , Controller webSocketApp
    ) => Parser (IO ResponseReceived)
webSocketAppWithHTTPFallback :: forall webSocketApp application.
(WSApp webSocketApp, InitControllerContext application,
 ?application::application, ?applicationContext::ApplicationContext,
 ?context::RequestContext, Typeable application,
 Typeable webSocketApp, Controller webSocketApp) =>
Parser (IO ResponseReceived)
webSocketAppWithHTTPFallback = forall webSocketApp application.
(WSApp webSocketApp, InitControllerContext application,
 ?application::application, ?applicationContext::ApplicationContext,
 ?context::RequestContext, Typeable application,
 Typeable webSocketApp, Controller webSocketApp) =>
ByteString -> Parser (IO ResponseReceived)
webSocketAppWithCustomPathAndHTTPFallback @webSocketApp @application ByteString
typeName
    where
        typeName :: ByteString
        typeName :: ByteString
typeName = forall a. Typeable a => a -> TypeRep
Typeable.typeOf (forall a. HasCallStack => String -> a
error String
"unreachable" :: webSocketApp)
                forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> forall a. Show a => a -> String
show
                forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> 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 controller.
    ( WSApp webSocketApp
    , InitControllerContext application
    , ?application :: application
    , ?applicationContext :: ApplicationContext
    , ?context :: RequestContext
    , Typeable application
    , Typeable webSocketApp
    ) => ByteString -> RouteParser
webSocketAppWithCustomPath :: forall {k} webSocketApp application (controller :: k).
(WSApp webSocketApp, InitControllerContext application,
 ?application::application, ?applicationContext::ApplicationContext,
 ?context::RequestContext, Typeable application,
 Typeable webSocketApp) =>
ByteString -> RouteParser
webSocketAppWithCustomPath ByteString
path = Parser (IO ResponseReceived) -> RouteParser
toRouteParser forall a b. (a -> b) -> a -> b
$ do
        Char -> Parser Char
Attoparsec.char Char
'/'
        ByteString -> Parser ByteString
string ByteString
path
        forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall webSocketApp application.
(?applicationContext::ApplicationContext, ?context::RequestContext,
 InitControllerContext application, ?application::application,
 Typeable application, WSApp webSocketApp) =>
IO ResponseReceived
startWebSocketAppAndFailOnHTTP @webSocketApp)
{-# INLINABLE webSocketAppWithCustomPath #-}

webSocketAppWithCustomPathAndHTTPFallback :: forall webSocketApp application.
    ( WSApp webSocketApp
    , InitControllerContext application
    , ?application :: application
    , ?applicationContext :: ApplicationContext
    , ?context :: RequestContext
    , Typeable application
    , Typeable webSocketApp
    , Controller webSocketApp
    ) => ByteString -> Parser (IO ResponseReceived)
webSocketAppWithCustomPathAndHTTPFallback :: forall webSocketApp application.
(WSApp webSocketApp, InitControllerContext application,
 ?application::application, ?applicationContext::ApplicationContext,
 ?context::RequestContext, Typeable application,
 Typeable webSocketApp, Controller webSocketApp) =>
ByteString -> Parser (IO ResponseReceived)
webSocketAppWithCustomPathAndHTTPFallback ByteString
path = do
        Char -> Parser Char
Attoparsec.char Char
'/'
        ByteString -> Parser ByteString
string ByteString
path
        forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall webSocketApp application.
(?applicationContext::ApplicationContext, ?context::RequestContext,
 InitControllerContext application, ?application::application,
 Typeable application, WSApp webSocketApp) =>
IO ResponseReceived -> IO ResponseReceived
startWebSocketApp @webSocketApp (forall application controller.
(Controller controller, ?applicationContext::ApplicationContext,
 ?context::RequestContext, InitControllerContext application,
 ?application::application, Typeable application,
 Typeable controller) =>
controller -> IO ResponseReceived
runActionWithNewContext (forall state. WSApp state => state
WS.initialState @webSocketApp)))
{-# INLINABLE webSocketAppWithCustomPathAndHTTPFallback #-}


-- | Defines the start page for a router (when @\/@ is requested).
startPage :: forall action application controller. (Controller action, InitControllerContext application, ?application::application, ?applicationContext::ApplicationContext, ?context::RequestContext, Typeable application, Typeable action) => action -> RouteParser
startPage :: forall {k} action application (controller :: k).
(Controller action, InitControllerContext application,
 ?application::application, ?applicationContext::ApplicationContext,
 ?context::RequestContext, Typeable application, Typeable action) =>
action -> RouteParser
startPage action
action = forall action application.
(Controller action, InitControllerContext application,
 ?application::application, ?applicationContext::ApplicationContext,
 ?context::RequestContext, Typeable application, Typeable action) =>
ByteString -> action -> RouteParser
get (String -> ByteString
ByteString.pack (forall controller. Typeable controller => String
actionPrefix @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 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (f :: * -> *) a. Alternative f => [f a] -> f a
choice (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (\Parser ByteString b
r -> Parser ByteString b
r forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall t. Chunk t => Parser t ()
endOfInput) [Parser ByteString b]
routes)
{-# INLINABLE withPrefix #-}

runApp :: (?applicationContext :: ApplicationContext, ?context :: RequestContext) => RouteParser -> IO ResponseReceived -> IO ResponseReceived
runApp :: (?applicationContext::ApplicationContext,
 ?context::RequestContext) =>
RouteParser -> IO ResponseReceived -> IO ResponseReceived
runApp RouteParser
routes IO ResponseReceived
notFoundAction = do
    let path :: ByteString
path = ?context::RequestContext
?context
                forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> forall {k} (x :: k) r a. HasField x r a => r -> a
getField @"request"
                forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> Request -> ByteString
rawPathInfo
        handleException :: SomeException -> IO (Either String (IO ResponseReceived))
        handleException :: SomeException -> IO (Either String (IO ResponseReceived))
handleException SomeException
exception = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ (?context::RequestContext) => SomeException -> IO ResponseReceived
ErrorController.handleRouterException SomeException
exception

    Either String (IO ResponseReceived)
routedAction :: Either String (IO ResponseReceived) <-
        (do
            Either String RouteParseResult
res <- forall (m :: * -> *) a. MonadIO m => a -> m a
evaluate forall a b. (a -> b) -> a -> b
$ forall a. Parser a -> ByteString -> Either String a
parseOnly (RouteParser
routes forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall t. Chunk t => Parser t ()
endOfInput) ByteString
path
            case Either String RouteParseResult
res of
                Left String
s -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left String
s
                Right RouteParseResult
io -> do
                    (TMap -> TMap
tmapSetter, (TMap -> TMap) -> IO ResponseReceived
controllerFn) <- RouteParseResult
io
                    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ (TMap -> TMap) -> IO ResponseReceived
controllerFn forall a b. (a -> b) -> a -> b
$ TMap -> TMap
tmapSetter
            )
            -- pure (undefined::IO ResponseReceived)))
        forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`Exception.catch` SomeException -> IO (Either String (IO ResponseReceived))
handleException
    case Either String (IO ResponseReceived)
routedAction of
        Left String
message -> IO ResponseReceived
notFoundAction
        Right IO ResponseReceived
action -> IO ResponseReceived
action
{-# INLINABLE runApp #-}

frontControllerToWAIApp :: forall app. (?applicationContext :: ApplicationContext, ?context :: RequestContext, FrontController app) => app -> [RouteParser] -> IO ResponseReceived -> IO ResponseReceived
frontControllerToWAIApp :: forall app.
(?applicationContext::ApplicationContext, ?context::RequestContext,
 FrontController app) =>
app -> [RouteParser] -> IO ResponseReceived -> IO ResponseReceived
frontControllerToWAIApp app
application [RouteParser]
additionalControllers IO ResponseReceived
notFoundAction = (?applicationContext::ApplicationContext,
 ?context::RequestContext) =>
RouteParser -> IO ResponseReceived -> IO ResponseReceived
runApp RouteParser
defaultRouter IO ResponseReceived
notFoundAction
    where
        RouteParser
defaultRouter :: RouteParser = (let ?application = app
application in forall application.
(FrontController application,
 ?applicationContext::ApplicationContext, ?application::application,
 ?context::RequestContext) =>
[RouteParser] -> RouteParser
router [RouteParser]
additionalControllers)
{-# INLINABLE frontControllerToWAIApp #-}

mountFrontController :: forall frontController. (?applicationContext :: ApplicationContext, ?context :: RequestContext, FrontController frontController) => frontController -> RouteParser
mountFrontController :: forall frontController.
(?applicationContext::ApplicationContext, ?context::RequestContext,
 FrontController frontController) =>
frontController -> RouteParser
mountFrontController frontController
application = let ?application = frontController
application in forall application.
(FrontController application,
 ?applicationContext::ApplicationContext, ?application::application,
 ?context::RequestContext) =>
[RouteParser] -> RouteParser
router []
{-# INLINABLE mountFrontController #-}

parseRoute :: forall controller application. (?applicationContext :: ApplicationContext, ?context :: RequestContext, Controller controller, CanRoute controller, InitControllerContext application, ?application :: application, Typeable application, Data controller) => RouteParser
parseRoute :: forall controller application.
(?applicationContext::ApplicationContext, ?context::RequestContext,
 Controller controller, CanRoute controller,
 InitControllerContext application, ?application::application,
 Typeable application, Data controller) =>
RouteParser
parseRoute = Parser ((TMap -> TMap) -> IO ResponseReceived) -> RouteParser
toRouteParser' forall a b. (a -> b) -> a -> b
$ do
    controller
action <- forall controller.
(CanRoute controller, ?context::RequestContext) =>
Parser controller
parseRoute' @controller
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall application controller.
(Controller controller, ?applicationContext::ApplicationContext,
 ?context::RequestContext, InitControllerContext application,
 ?application::application, Typeable application,
 Typeable controller) =>
controller -> (TMap -> TMap) -> IO ResponseReceived
runAction' @application controller
action
{-# INLINABLE parseRoute #-}

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

parseRouteWithId
    :: forall controller application.
        (?applicationContext :: ApplicationContext,
            ?context :: RequestContext,
            Controller controller,
            CanRoute controller,
            InitControllerContext application,
            ?application :: application,
            Typeable application,
            Data controller)
        => RouteParser
parseRouteWithId :: forall controller application.
(?applicationContext::ApplicationContext, ?context::RequestContext,
 Controller controller, CanRoute controller,
 InitControllerContext application, ?application::application,
 Typeable application, Data controller) =>
RouteParser
parseRouteWithId = Parser ((TMap -> TMap) -> IO ResponseReceived) -> RouteParser
toRouteParser' do
    controller
action <- forall controller.
(CanRoute controller, ?context::RequestContext) =>
Parser controller
parseRoute' @controller
    forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall application controller.
(Controller controller, ?applicationContext::ApplicationContext,
 ?context::RequestContext, InitControllerContext application,
 ?application::application, Typeable application,
 Typeable controller) =>
controller -> (TMap -> TMap) -> IO ResponseReceived
runAction' @application controller
action)

catchAll :: forall action application. (?applicationContext :: ApplicationContext, ?context :: RequestContext, Controller action, InitControllerContext application, Typeable action, ?application :: application, Typeable application, Data action) => action -> RouteParser
catchAll :: forall action application.
(?applicationContext::ApplicationContext, ?context::RequestContext,
 Controller action, InitControllerContext application,
 Typeable action, ?application::application, Typeable application,
 Data action) =>
action -> RouteParser
catchAll action
action = Parser ((TMap -> TMap) -> IO ResponseReceived) -> RouteParser
toRouteParser' do
    ByteString -> Parser ByteString
string (String -> ByteString
ByteString.pack (forall controller. Typeable controller => String
actionPrefix @action))
    ByteString
_ <- Parser ByteString
takeByteString
    forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall application controller.
(Controller controller, ?applicationContext::ApplicationContext,
 ?context::RequestContext, InitControllerContext application,
 ?application::application, Typeable application,
 Typeable controller) =>
controller -> (TMap -> TMap) -> IO ResponseReceived
runAction' @application action
action)
{-# INLINABLE 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 (forall controller. HasPath controller => controller -> Text
pathTo action
action)
    {-# INLINE convertString #-}

-- | Parses and returns an UUID
parseUUID :: Parser UUID
parseUUID :: Parser UUID
parseUUID = do
        ByteString
uuid <- Int -> Parser ByteString
take Int
36
        case ByteString -> Maybe UUID
fromASCIIBytes ByteString
uuid of
            Just UUID
theUUID -> forall (f :: * -> *) a. Applicative f => a -> f a
pure UUID
theUUID
            Maybe UUID
Nothing -> 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 = forall (table :: Symbol). PrimaryKey table -> Id' table
ModelSupport.Id 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 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Bool) -> Parser ByteString
takeTill (Char
'/' ==)
{-# 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 = forall c a.
(Element c ~ Char, MonoFoldable c, Read a) =>
c -> Maybe a
readMay (forall a b. ConvertibleStrings a b => a -> b
cs ByteString
queryVal :: String)
    in
       Maybe Integer
rawValue forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. a -> Maybe a
Just forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. 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 :: (?context::RequestContext, ParamReader paramType) => ByteString -> paramType
routeParam :: forall paramType.
(?context::RequestContext, ParamReader paramType) =>
ByteString -> paramType
routeParam ByteString
paramName =
    let requestContext :: RequestContext
requestContext = ?context::RequestContext
?context
    in
        let ?context = FrozenControllerContext { $sel:requestContext:ControllerContext :: RequestContext
requestContext = RequestContext
requestContext, $sel:customFields:ControllerContext :: TMap
customFields = forall a. Monoid a => a
mempty }
        in forall valueType.
(?context::ControllerContext, 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://forum.ihpapp.com/ShowThread?threadId=ad73d6a5-2481-4e2f-af46-9bf8849f998b
-- 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