{-# 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
, ViewFetchHelpMessage
, param
, fetch
, query
, isActiveController
, isActiveAction
, nl2br
, stripTags
, theCSSFramework
, fromCSSFramework
, liveReloadWebsocketUrl
, assetPath
, assetVersion
) 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.Router.UrlGenerator (HasPath(..))
import Network.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.View.CSSFramework as CSSFramework ()
import IHP.View.Types
import qualified IHP.FrameworkConfig as FrameworkConfig
import qualified IHP.HSX.Attribute as HSX
import qualified Network.Wai.Middleware.AssetPath as AssetPath
import IHP.ActionType (isActiveController)

class View theView where
    -- | Hook which is called before the render is called
    beforeRender :: (?context :: ControllerContext, ?request :: Request) => 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, ?request :: Request) => 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 :: (?request :: Request, PathString controller) => controller -> Bool
isActivePath :: forall controller.
(?request::Request, PathString controller) =>
controller -> Bool
isActivePath controller
route =
    let
        currentPath :: ByteString
currentPath = Request
(?request::Request) => Request
theRequest.rawPathInfo ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Request
(?request::Request) => Request
theRequest.rawQueryString
    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 :: (?request :: Request, PathString controller) => controller -> Bool
isActivePathOrSub :: forall controller.
(?request::Request, PathString controller) =>
controller -> Bool
isActivePathOrSub controller
route =
    let
        currentPath :: ByteString
currentPath = Request
(?request::Request) => Request
theRequest.rawPathInfo
    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 action matches the path of the currently executed action
--
-- __Example:__ The browser has requested @\/PostsAction@.
--
-- >>> isActiveAction PostsAction
-- True

-- __Example:__ The browser has requested @\/ShowPossAction@ along with the post ID.
--
-- >>> -- Get the post ID out of a UUID.
-- >>> let myUUID = ...
-- >>> let postId = (Id myUUID) :: Id Post
-- >>> isActiveAction (ShowPostAction postId)
-- True
--
isActiveAction :: forall controllerAction. (?request :: Request, HasPath controllerAction) => controllerAction -> Bool
isActiveAction :: forall controllerAction.
(?request::Request, HasPath controllerAction) =>
controllerAction -> Bool
isActiveAction controllerAction
controllerAction =
    Text -> Bool
forall controller.
(?request::Request, PathString controller) =>
controller -> Bool
isActivePath (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 :: (?request :: Request) => Request
theRequest :: (?request::Request) => Request
theRequest = ?request::Request
Request
?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

-- | 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 :: (?request :: Request, KnownSymbol field, HasField field CSSFramework (CSSFramework -> appliedFunction)) => Proxy field -> appliedFunction
fromCSSFramework :: forall (field :: Symbol) appliedFunction.
(?request::Request, KnownSymbol field,
 HasField field CSSFramework (CSSFramework -> appliedFunction)) =>
Proxy field -> appliedFunction
fromCSSFramework Proxy field
field = let cssFramework :: CSSFramework
cssFramework = CSSFramework
(?request::Request) => 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 :: (?request :: Request) => CSSFramework
theCSSFramework :: (?request::Request) => CSSFramework
theCSSFramework = ?request::Request
Request
?request.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 -> Html
nl2br text
content = text
content
    text -> (text -> [text]) -> [text]
forall a b. a -> (a -> b) -> b
|> text -> [text]
forall t. Textual t => t -> [t]
Sequences.lines
    [text] -> ([text] -> [Html]) -> [Html]
forall a b. a -> (a -> b) -> b
|> (text -> Html) -> [text] -> [Html]
forall a b. (a -> b) -> [a] -> [b]
map (\text
line -> [hsx|{line}<br/>|])
    [Html] -> ([Html] -> Html) -> Html
forall a b. a -> (a -> b) -> b
|> [Html] -> Html
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 :: (?request :: Request) => Text
liveReloadWebsocketUrl :: (?request::Request) => Text
liveReloadWebsocketUrl = ?request::Request
Request
?request.frameworkConfig.ideBaseUrl
    Text -> (Text -> Text) -> Text
forall a b. a -> (a -> b) -> b
|> HasCallStack => Text -> Text -> Text -> Text
Text -> Text -> Text -> Text
Text.replace Text
"http://" Text
"ws://"
    Text -> (Text -> Text) -> Text
forall a b. a -> (a -> b) -> b
|> HasCallStack => Text -> Text -> Text -> Text
Text -> Text -> Text -> Text
Text.replace Text
"https://" Text
"wss://"

instance InputValue (PrimaryKey table) => HSX.ApplyAttribute (Id' table) where
    applyAttribute :: Text -> Text -> Id' table -> Html -> Html
applyAttribute Text
attr Text
attr' Id' table
value Html
h = Text -> Text -> Text -> Html -> Html
forall value.
ApplyAttribute value =>
Text -> Text -> value -> Html -> Html
HSX.applyAttribute Text
attr Text
attr' (Id' table -> Text
forall a. InputValue a => a -> Text
inputValue Id' table
value) Html
h


-- | Adds a cache buster to a asset path
--
-- >>> assetPath "/keyhandlers.js"
-- "/keyhandlers.js?v=9be8995c-7055-43d9-a1b2-43e05c210271"
--
-- The asset version can be configured using the
-- @IHP_ASSET_VERSION@ environment variable.
assetPath :: (?request :: Request) => Text -> Text
assetPath :: (?request::Request) => Text -> Text
assetPath Text
assetPath = Request -> Text -> Text
AssetPath.assetPath Request
(?request::Request) => Request
theRequest Text
assetPath

-- | Returns the assetVersion
--
-- >>> assetVersion
-- "9be8995c-7055-43d9-a1b2-43e05c210271"
--
-- The asset version can be configured using the
-- @IHP_ASSET_VERSION@ environment variable.
assetVersion :: (?request :: Request) => Text
assetVersion :: (?request::Request) => Text
assetVersion = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe (Text -> Text
forall a. Text -> a
error Text
"assetPath middleware missing") (Request -> Maybe Text
AssetPath.assetVersion Request
(?request::Request) => Request
theRequest)