{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE UndecidableInstances  #-}
{-|
Module: IHP.ViewSupport
Description: Provides functions to be used in all views
Copyright: (c) digitally induced GmbH, 2020
-}
module IHP.ViewSupport
( HtmlWithContext
, Layout
, Html
, View (..)
, currentViewId
, forEach
, isActivePath
, isActivePathOrSub
, css
, onClick
, onLoad
, theRequest
, viewContext
, addStyle
, ViewFetchHelpMessage
, param
, fetch
, query
, isActiveController
, isActiveAction
, nl2br
, stripTags
, theCSSFramework
, fromCSSFramework
, liveReloadWebsocketUrl
) where

import IHP.Prelude
import qualified Text.Blaze.Html5 as Html5
import IHP.ControllerSupport
import IHP.ModelSupport
import qualified Data.Aeson as JSON
import qualified Data.Text as Text
import qualified Data.Typeable as Typeable
import qualified Text.Inflections as Inflector
import qualified Data.Either as Either
import GHC.TypeLits as T
import qualified Data.ByteString as ByteString
import IHP.RouterSupport hiding (get)
import qualified Network.Wai as Wai
import Text.Blaze.Html5.Attributes as A
import IHP.HSX.QQ (hsx)
import IHP.HSX.ToHtml
import qualified Data.Sequences as Sequences
import qualified IHP.Controller.RequestContext
import qualified IHP.View.CSSFramework as CSSFramework ()
import IHP.View.Types
import qualified IHP.FrameworkConfig as FrameworkConfig
import IHP.Controller.Context


class View theView where
    -- | Hook which is called before the render is called
    beforeRender :: (?context :: ControllerContext) => theView -> IO ()
    beforeRender theView
view = () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

    -- Renders the view as html
    html :: (?context :: ControllerContext, ?view :: theView) => theView -> Html5.Html

    -- | Renders the view to a JSON
    json :: theView -> JSON.Value
    json = Text -> theView -> Value
forall a. Text -> a
error Text
"Json View for this route is not implemented"

-- | Returns a string to be used as a html id attribute for the current view.
-- E.g. when calling @currentViewId@ while rendering the view @Web.View.Projects.Show@, this will return @"projects-show"@
--
-- Useful to automatically scope certain css rules to a specific view.
-- Example:
--
-- > module Web.View.Projects.Show where
-- > render = [hsx|<div id={currentViewId}>Hello World!</div>|]
--
-- This will render @<div id="projects-show">Hello World!</div>@
{-# INLINE currentViewId #-}
currentViewId :: (?view :: view, Typeable view) => Text
currentViewId :: forall view. (?view::view, Typeable view) => Text
currentViewId =
        case [Text]
moduleParts of
            [Text
_, Text
"View", Text
controllerName, Text
viewName] -> Text -> Either (ParseErrorBundle Text Void) Text -> Text
forall b a. b -> Either a b -> b
Either.fromRight (Text -> Text
forall a. Text -> a
error Text
"currentViewId: Failed to parse controller name") (Text -> Either (ParseErrorBundle Text Void) Text
Inflector.toDashed Text
controllerName) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"-" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Either (ParseErrorBundle Text Void) Text -> Text
forall b a. b -> Either a b -> b
Either.fromRight (Text -> Text
forall a. Text -> a
error Text
"currentViewId: Failed to parse view name") (Text -> Either (ParseErrorBundle Text Void) Text
Inflector.toDashed Text
viewName)
            [Text]
_ -> Text -> Text
forall a. Text -> a
error (Text
"currentViewId: Failed to read view id for " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
forall a b. ConvertibleStrings a b => a -> b
cs Text
moduleName)
    where
        constructor :: TyCon
constructor = TypeRep -> TyCon
Typeable.typeRepTyCon (view -> TypeRep
forall a. Typeable a => a -> TypeRep
Typeable.typeOf view
?view::view
?view)

        -- Module name: Web.View.Projects.Show
        moduleName :: Text
        moduleName :: Text
moduleName = String -> Text
forall a b. ConvertibleStrings a b => a -> b
cs (TyCon -> String
Typeable.tyConModule TyCon
constructor)

        moduleParts :: [Text]
        moduleParts :: [Text]
moduleParts = HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
Text.splitOn Text
"." Text
moduleName

-- | Returns @True@ when the current request path matches the path given as argument. Takes into account the search query: @?name=value@
--
-- __Example:__ The browser has requested the url @\/Projects@.
--
-- >>> isActivePath "/Projects"
-- True
--
-- Returns @True@ because @"\/Projects"@ is the current requested path.
--
-- >>> isActivePath "/Users"
-- False
--
-- Returns false because @"/Users"@ is not @"/Projects"@
--
-- __Example:__ The browser has requested the url @\/Projects@.
--
-- >>> isActivePath "/Projects/1"
-- False
--
-- This function returns @False@ when a sub-path is request. Use 'isActivePathOrSub' if you want this example to return @True@.
isActivePath :: (?context :: ControllerContext, PathString controller) => controller -> Bool
isActivePath :: forall controller.
(?context::ControllerContext, PathString controller) =>
controller -> Bool
isActivePath controller
route =
    let
        currentPath :: ByteString
currentPath = Request -> ByteString
Wai.rawPathInfo Request
(?context::ControllerContext) => Request
theRequest ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Request -> ByteString
Wai.rawQueryString Request
(?context::ControllerContext) => Request
theRequest
    in
        ByteString
currentPath ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs (controller -> Text
forall a. PathString a => a -> Text
pathToString controller
route)

-- | Returns @True@ when the current request path starts with the path given as argument.
--
-- __Example:__ The browser has requested the url @\/Projects/1@.
--
-- >>> isActivePathOrSub "/Projects"
-- True
--
-- __Example:__ The browser has requested the url @\/Projects@.
--
-- >>> isActivePathOrSub "/Projects"
-- True
--
-- Also see 'isActivePath'.
isActivePathOrSub :: (?context :: ControllerContext, PathString controller) => controller -> Bool
isActivePathOrSub :: forall controller.
(?context::ControllerContext, PathString controller) =>
controller -> Bool
isActivePathOrSub controller
route =
    let
        currentPath :: ByteString
currentPath = Request -> ByteString
Wai.rawPathInfo Request
(?context::ControllerContext) => Request
theRequest
    in
        Text -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs (controller -> Text
forall a. PathString a => a -> Text
pathToString controller
route) ByteString -> ByteString -> Bool
`ByteString.isPrefixOf` ByteString
currentPath

-- | Returns @True@ when the given type matches the type of the currently executed controller action
--
-- __Example:__ The browser has requested @\/Posts@ and the @Posts@ action of the @PostsController@ is called.
--
-- >>> isActiveController @PostsController
-- True
--
-- Returns @True@ because the current action is part of the @PostsController@
isActiveController :: forall controller. (?context :: ControllerContext, Typeable controller) => Bool
isActiveController :: forall {k} (controller :: k).
(?context::ControllerContext, Typeable controller) =>
Bool
isActiveController =
    let
        (ActionType TypeRep
actionType) = forall value.
(?context::ControllerContext, Typeable value) =>
value
fromFrozenContext @ActionType
    in
        (forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
forall (proxy :: k -> *) (a :: k). Typeable a => proxy a -> TypeRep
Typeable.typeRep @Proxy @controller (forall (t :: k). Proxy t
forall {k} (t :: k). Proxy t
Proxy @controller)) TypeRep -> TypeRep -> Bool
forall a. Eq a => a -> a -> Bool
== TypeRep
actionType

-- | Returns @True@ when the given action matches the path of the currently executed action
--
-- __Example:__ The browser has requested @\/PostsAction@.
--
-- >>> isActiveAction PostsAction
-- True
--
-- Returns @True@ because the current path is the same as the path to the action, does not take into account the search query.
-- Use 'isActivePath' if you need to match path and search query.
isActiveAction :: forall controllerAction. (?context::ControllerContext, HasPath controllerAction) => controllerAction -> Bool
isActiveAction :: forall controllerAction.
(?context::ControllerContext, HasPath controllerAction) =>
controllerAction -> Bool
isActiveAction controllerAction
controllerAction =
    let
        currentPath :: ByteString
currentPath = Request -> ByteString
Wai.rawPathInfo Request
(?context::ControllerContext) => Request
theRequest
    in
        ByteString
currentPath ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs (controllerAction -> Text
forall controller. HasPath controller => controller -> Text
pathTo controllerAction
controllerAction)

css :: QuasiQuoter
css = QuasiQuoter
plain

onClick :: AttributeValue -> Attribute
onClick = AttributeValue -> Attribute
A.onclick
onLoad :: AttributeValue -> Attribute
onLoad = AttributeValue -> Attribute
A.onload

-- | Returns the current request
theRequest :: (?context :: ControllerContext) => Wai.Request
theRequest :: (?context::ControllerContext) => Request
theRequest = ?context::ControllerContext
ControllerContext
?context.requestContext.request
{-# INLINE theRequest #-}

class PathString a where
    pathToString :: a -> Text

instance PathString Text where
    pathToString :: Text -> Text
pathToString Text
path = Text
path

instance {-# OVERLAPPABLE #-} HasPath action => PathString action where
    pathToString :: action -> Text
pathToString = action -> Text
forall controller. HasPath controller => controller -> Text
pathTo

-- | Alias for @?context@
viewContext :: (?context :: ControllerContext) => ControllerContext
viewContext :: (?context::ControllerContext) => ControllerContext
viewContext = ?context::ControllerContext
ControllerContext
?context
{-# INLINE viewContext #-}

-- | Adds an inline style element to the html.
--
-- This helps to work around the issue, that our HSX parser cannot deal with CSS yet.
--
-- __Example:__
--
-- > myStyle = addStyle "#my-div { color: blue; }"
-- > [hsx|{myStyle}<div id="my-div">Hello World</div>|]
--
-- This will render like:
--
-- > <style>
-- >     #my-div { color: blue; }
-- > </style>
-- > <div id="my-div">Hello World</div>
addStyle :: (ConvertibleStrings string Text) => string -> Html5.Markup
addStyle :: forall string. ConvertibleStrings string Text => string -> Markup
addStyle string
style = Markup -> Markup
Html5.style (Text -> Markup
Html5.preEscapedText (string -> Text
forall a b. ConvertibleStrings a b => a -> b
cs string
style))
{-# INLINE addStyle #-}

-- | This class provides helpful compile-time error messages when you use common
-- controller functions inside of your views.
class ViewParamHelpMessage where
    param :: a

instance (T.TypeError (T.Text "‘param‘ can only be used inside your controller actions.\nYou have to run the ‘param \"my_param\"‘ call inside your controller and then pass the resulting value to your view.\n\nController Example:\n\n    module Web.Controller.Projects\n\n    instance Controller ProjectsController where\n        action ProjectsAction = do\n            let showDetails = param \"showDetails\"\n            render ProjectsView { showDetails }\n\nView Example:\n\n    module Web.View.Projects.Index\n\n    data ProjectsView = ProjectsView { showDetails :: Bool }\n    instance View ProjectsView where\n        html ProjectsView { .. } = [hsx|Show details: {showDetails}|]\n\n")) => ViewParamHelpMessage where
    param :: forall a. a
param = Text -> a
forall a. Text -> a
error Text
"unreachable"

-- | This class provides helpful compile-time error messages when you use common
-- controller functions inside of your views.
class ViewFetchHelpMessage where
    fetch :: a
    query :: a
instance (T.TypeError (T.Text "‘fetch‘ or ‘query‘ can only be used inside your controller actions. You have to call it from your controller action and then pass the result to the view.")) => ViewFetchHelpMessage where
    fetch :: forall a. a
fetch = Text -> a
forall a. Text -> a
error Text
"unreachable"
    query :: forall a. a
query = Text -> a
forall a. Text -> a
error Text
"unreachable"

instance (T.TypeError (T.Text "Looks like you forgot to pass a " :<>: (T.ShowType (GetModelByTableName record)) :<>: T.Text " id to this data constructor.")) => Eq (Id' (record :: T.Symbol) -> controller) where
    Id' record -> controller
a == :: (Id' record -> controller) -> (Id' record -> controller) -> Bool
== Id' record -> controller
b = Text -> Bool
forall a. Text -> a
error Text
"unreachable"

fromCSSFramework :: (?context :: ControllerContext, KnownSymbol field, HasField field CSSFramework (CSSFramework -> appliedFunction)) => Proxy field -> appliedFunction
fromCSSFramework :: forall (field :: Symbol) appliedFunction.
(?context::ControllerContext, KnownSymbol field,
 HasField field CSSFramework (CSSFramework -> appliedFunction)) =>
Proxy field -> appliedFunction
fromCSSFramework Proxy field
field = let cssFramework :: CSSFramework
cssFramework = CSSFramework
(?context::ControllerContext) => CSSFramework
theCSSFramework in (Proxy field -> CSSFramework -> CSSFramework -> appliedFunction
forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get Proxy field
field CSSFramework
cssFramework) CSSFramework
cssFramework

theCSSFramework :: (?context :: ControllerContext) => CSSFramework
theCSSFramework :: (?context::ControllerContext) => CSSFramework
theCSSFramework = ?context::ControllerContext
ControllerContext
?context.frameworkConfig.cssFramework

-- | Replaces all newline characters with a @<br>@ tag. Useful for displaying preformatted text.
--
-- >>> nl2br "Hello\nWorld!"
-- [hsx|Hello<br/>World!|]
nl2br :: (Sequences.Textual text, ToHtml text) => text -> Html5.Html
nl2br :: forall text. (Textual text, ToHtml text) => text -> Markup
nl2br text
content = text
content
    text -> (text -> [text]) -> [text]
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> text -> [text]
forall t. Textual t => t -> [t]
Sequences.lines
    [text] -> ([text] -> [Markup]) -> [Markup]
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> (text -> Markup) -> [text] -> [Markup]
forall a b. (a -> b) -> [a] -> [b]
map (\text
line -> [hsx|{line}<br/>|])
    [Markup] -> ([Markup] -> Markup) -> Markup
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> [Markup] -> Markup
forall a. Monoid a => [a] -> a
mconcat

type Html = HtmlWithContext ControllerContext

-- | The URL for the dev-mode live reload server. Typically "ws://localhost:8001"
liveReloadWebsocketUrl :: (?context :: ControllerContext) => Text
liveReloadWebsocketUrl :: (?context::ControllerContext) => Text
liveReloadWebsocketUrl = ?context::ControllerContext
ControllerContext
?context.frameworkConfig.ideBaseUrl
    Text -> (Text -> Text) -> Text
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> HasCallStack => Text -> Text -> Text -> Text
Text -> Text -> Text -> Text
Text.replace Text
"http://" Text
"ws://"
    Text -> (Text -> Text) -> Text
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> HasCallStack => Text -> Text -> Text -> Text
Text -> Text -> Text -> Text
Text.replace Text
"https://" Text
"wss://"