isActiveAction should take query string into account

Guide/view.markdown

@@ -183,21 +183,23 @@ Use [`theRequest`](https://ihp.digitallyinduced.com/api-docs/IHP-ViewSupport.htm
 
 ### Highlighting the current active link
 
-Use [`isActivePath`](https://ihp.digitallyinduced.com/api-docs/IHP-ViewSupport.html#v:isActivePath) to check whether the current request URL matches a given action:
+Use [`isActiveAction`](https://ihp.digitallyinduced.com/api-docs/IHP-ViewSupport.html#v:isActiveAction) to check whether the current request URL matches a given action:
 
 ```haskell
-<a href={ShowProjectAction} class={classes ["nav-link", ("active", isActivePath ShowProjectAction)]}>
+<a href={ShowProjectAction} class={classes ["nav-link", ("active", isActiveAction ShowProjectAction)]}>
     Show Project
 </a>
 ```
 
-### Check whether this view is called from a specific controller
+If you need to work with a Text for the URL you can use the [`isActivePath`](https://ihp.digitallyinduced.com/api-docs/IHP-ViewSupport.html#v:isActiveAction).
 
-Use [`isActiveController`](https://ihp.digitallyinduced.com/api-docs/IHP-ViewSupport.html#v:isActiveController).
-
-### Check whether this view is called from a specific action
+```haskell
+<a href={ShowProjectAction} class={classes ["nav-link", ("active", isActivePath "/ShowProject")]}>
+    Show Project
+</a>
+```
 
-Use [`isActiveAction`](https://ihp.digitallyinduced.com/api-docs/IHP-ViewSupport.html#v:isActiveAction).
+Finally, if you only need to know if the current Controller is used, regardless of which action, use [`isActiveController`](https://ihp.digitallyinduced.com/api-docs/IHP-ViewSupport.html#v:isActiveController)
 
 #### `timeAgo`
 

IHP/ViewSupport.hs

@@ -163,15 +163,18 @@ isActiveController =
 --
 -- >>> 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
 --
--- 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 controllerAction =
-    let
-        currentPath = Wai.rawPathInfo theRequest
-    in
-        currentPath == cs (pathTo controllerAction)
+    isActivePath (pathTo controllerAction)
 
 css = plain
 

Test/Main.hs

@@ -41,6 +41,7 @@ import qualified Test.ModelSupportSpec
 import qualified Test.SchemaCompilerSpec
 import qualified Test.QueryBuilderSpec
 import qualified Test.RouterSupportSpec
+import qualified Test.ViewSupportSpec
 import qualified Test.ServerSideComponent.HtmlParserSpec
 import qualified Test.ServerSideComponent.HtmlDiffSpec
 import qualified Test.FileStorage.MimeTypesSpec
@@ -74,6 +75,7 @@ main = hspec do
     Test.SchemaCompilerSpec.tests
     Test.QueryBuilderSpec.tests
     Test.RouterSupportSpec.tests
+    Test.ViewSupportSpec.tests
     Test.ServerSideComponent.HtmlParserSpec.tests
     Test.ServerSideComponent.HtmlDiffSpec.tests
     Test.FileStorage.MimeTypesSpec.tests

Test/RouterSupportSpec.hs

@@ -112,7 +112,7 @@ instance AutoRoute TestController where
     autoRoute = autoRouteWithIdType (parseIntegerId @(Id Band))
 
 instance FrontController WebApplication where
-  controllers = [ startPage TestAction, parseRoute @TestController ]
+  controllers = [ parseRoute @TestController ]
 
 defaultLayout :: Html -> Html
 defaultLayout inner =  [hsx|{inner}|]
@@ -124,9 +124,6 @@ instance InitControllerContext WebApplication where
 instance FrontController RootApplication where
     controllers = [ mountFrontController WebApplication ]
 
-instance Worker RootApplication where
-    workers _ = []
-
 testGet :: ByteString -> Session SResponse
 testGet url = request $ setPath defaultRequest { requestMethod = methodGet } url
 

Test/ViewSupportSpec.hs

@@ -0,0 +1,129 @@
+{-|
+Module: Test.ViewSupportSpec
+
+Tests for view support functions.
+-}
+{-# LANGUAGE AllowAmbiguousTypes #-}
+
+module Test.ViewSupportSpec where
+import qualified Prelude
+import ClassyPrelude
+import Test.Hspec
+import IHP.Test.Mocking hiding (application)
+import IHP.Prelude
+import IHP.QueryBuilder
+import IHP.Environment
+import IHP.FrameworkConfig
+import IHP.HaskellSupport
+import IHP.RouterSupport hiding (get)
+import IHP.FrameworkConfig
+import IHP.Job.Types
+import IHP.Controller.RequestContext hiding (request)
+import IHP.ViewPrelude
+import IHP.ControllerPrelude hiding (get, request)
+import qualified IHP.Server as Server
+import Data.Attoparsec.ByteString.Char8 (string, Parser, (<?>), parseOnly, take, endOfInput, choice, takeTill, takeByteString)
+import Network.Wai
+import Network.Wai.Test
+import Network.HTTP.Types
+import qualified IHP.ErrorController as ErrorController
+import Data.String.Conversions
+import Data.Text as Text
+import Unsafe.Coerce
+import IHP.ApplicationContext
+
+import qualified Network.Wai.Session as Session
+import qualified Network.Wai.Session.Map as Session
+
+data WebApplication = WebApplication deriving (Eq, Show, Data)
+
+data TestController
+    = TestAction
+    | TestWithParamAction { param :: Text }
+  deriving (Eq, Show, Data)
+
+data AnotherTestController
+    = AnotherTestAction
+  deriving (Eq, Show, Data)
+
+instance Controller TestController where
+    action TestAction = do
+        renderPlain "TestAction"
+    action TestWithParamAction { .. } = do
+        render ShowView { .. }
+
+instance Controller AnotherTestController where
+    action AnotherTestAction = do
+        renderPlain "AnotherTestAction"
+
+instance AutoRoute TestController
+instance AutoRoute AnotherTestController
+
+instance FrontController WebApplication where
+  controllers = [ parseRoute @TestController, parseRoute @AnotherTestController ]
+
+data ShowView = ShowView { param :: Text}
+
+instance View ShowView where
+    html ShowView { .. }= [hsx|
+        isActiveAction {param}: {isActiveAction $ TestWithParamAction param}
+        isActiveAction bar: {isActiveAction $ TestWithParamAction "bar"}
+
+        isActivePath {param}: {isActivePath $ "/test/TestWithParam?param=" <> param}
+        isActivePath bar: {isActivePath ("/test/TestWithParam?param=bar" :: Text)}
+
+        isActiveController TestController: {isActiveController @TestController}
+        isActiveController AnotherTestAction: {isActiveController @AnotherTestController}
+    |]
+
+defaultLayout :: Html -> Html
+defaultLayout inner =  [hsx|{inner}|]
+
+instance InitControllerContext WebApplication where
+  initContext = do
+    setLayout defaultLayout
+
+instance FrontController RootApplication where
+    controllers = [ mountFrontController WebApplication ]
+
+testGet :: ByteString -> Session SResponse
+testGet url = request $ setPath defaultRequest { requestMethod = methodGet } url
+
+assertTextExists :: Text -> SResponse -> IO ()
+assertTextExists body response = do
+    response.simpleStatus `shouldBe` status200
+    Text.isInfixOf body (cs response.simpleBody) `shouldBe` True
+
+config = do
+    option Development
+    option (AppPort 8000)
+
+makeApplication :: (?applicationContext :: ApplicationContext) => IO Application
+makeApplication = do
+    store <- Session.mapStore_
+    let sessionMiddleware :: Middleware = Session.withSession store "SESSION" ?applicationContext.frameworkConfig.sessionCookie ?applicationContext.session
+    pure (sessionMiddleware (Server.application ErrorController.handleNotFound))
+
+tests :: Spec
+tests = beforeAll (mockContextNoDatabase WebApplication config) do
+    describe "isActiveAction" $ do
+        it "should return True on the same route" $ withContext do
+            application <- makeApplication
+            runSession (testGet "test/TestWithParam?param=foo") application >>= assertTextExists "isActiveAction foo: True"
+        it "should return False on a different route" $ withContext do
+            application <- makeApplication
+            runSession (testGet "test/TestWithParam?param=foo") application >>= assertTextExists "isActiveAction bar: False"
+    describe "isActivePath" $ do
+        it "should return True on the same route" $ withContext do
+            application <- makeApplication
+            runSession (testGet "test/TestWithParam?param=foo") application >>= assertTextExists "isActivePath foo: True"
+        it "should return False on a different route" $ withContext do
+            application <- makeApplication
+            runSession (testGet "test/TestWithParam?param=foo") application >>= assertTextExists "isActivePath bar: False"
+    describe "isActiveController" $ do
+        it "should return True on the same route" $ withContext do
+            application <- makeApplication
+            runSession (testGet "test/TestWithParam?param=foo") application >>= assertTextExists "isActiveController TestController: True"
+        it "should return False on a different route" $ withContext do
+            application <- makeApplication
+            runSession (testGet "test/TestWithParam?param=foo") application >>= assertTextExists "isActiveController AnotherTestAction: False"