From d1f0e6ccafc0d1628f453ae382c6861f0d5729a2 Mon Sep 17 00:00:00 2001 From: Amitai Burstein Date: Fri, 2 Jun 2023 21:25:01 +0300 Subject: [PATCH 01/12] Remove Just prefix from query params --- IHP/RouterSupport.hs | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/IHP/RouterSupport.hs b/IHP/RouterSupport.hs index e61b75544..4041a840a 100644 --- a/IHP/RouterSupport.hs +++ b/IHP/RouterSupport.hs @@ -633,8 +633,9 @@ instance {-# OVERLAPPABLE #-} (Show controller, AutoRoute controller) => HasPath |> \(kvs :: [(String, String)]) -> zip (showTerms action) 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. - |> map (\(v1, (k, v2)) -> (k, fromMaybe v2 v1)) + -- In this case we default back to the @show@ representation, making sure to remove + -- the "Just" prefix. + |> map (\(v1, (k, v2)) -> (k, fromMaybe (cs $ Text.replace "Just" "" $ cs v2) v1)) |> map (\(k, v) -> if isEmpty v then "" else k <> "=" <> URI.encode v) @@ -645,7 +646,7 @@ instance {-# OVERLAPPABLE #-} (Show controller, AutoRoute controller) => HasPath -- | Parses the HTTP Method from the request and returns it. getMethod :: (?context :: RequestContext) => Parser StdMethod getMethod = - case parseMethod ?context.request.requestMethod of + case parseMethod ?context.request.requestMethod of Left error -> fail (ByteString.unpack error) Right method -> pure method {-# INLINABLE getMethod #-} From 00f8e36eb40a2298501d8164e80a45aecfcdbdbb Mon Sep 17 00:00:00 2001 From: Amitai Burstein Date: Fri, 2 Jun 2023 21:35:27 +0300 Subject: [PATCH 02/12] Add tests --- Test/RouterSupportSpec.hs | 15 ++++++++++++++- 1 file changed, 14 insertions(+), 1 deletion(-) diff --git a/Test/RouterSupportSpec.hs b/Test/RouterSupportSpec.hs index caabb229d..aa297c116 100644 --- a/Test/RouterSupportSpec.hs +++ b/Test/RouterSupportSpec.hs @@ -66,6 +66,7 @@ data TestController | TestInteger { p1 :: Integer, p2 :: Maybe Integer, p3 :: [Integer] } | TestIntegerId { integerId :: Id Band } | TestUUIDId { uuidId :: Id Performance } + | TestMaybeUUIDId { maybeUuidId :: Maybe (Id Performance) } | TestUUIDList { uuidList :: [UUID] } deriving (Eq, Show, Data) @@ -105,6 +106,10 @@ instance Controller TestController where renderPlain (cs $ ClassyPrelude.show integerId) action TestUUIDId { .. } = do renderPlain (cs $ ClassyPrelude.show uuidId) + action TestMaybeUUIDId { ..} = + case maybeUuidId of + Just uuidId -> renderPlain ("Just " <> cs (ClassyPrelude.show uuidId)) + Nothing -> renderPlain "Nothing" action TestUUIDList { .. } = do renderPlain $ cs $ ClassyPrelude.show uuidList @@ -193,6 +198,10 @@ tests = beforeAll (mockContextNoDatabase WebApplication config) do runSession (testGet "test/TestIntegerId?integerId=123") application >>= assertSuccess "123" it "parses Id with UUID param" $ withContext do runSession (testGet "test/TestUUIDId?uuidId=8dd57d19-490a-4323-8b94-6081ab93bf34") application >>= assertSuccess "8dd57d19-490a-4323-8b94-6081ab93bf34" + it "parses Maybe Id with UUID param: Nothing" $ withContext do + runSession (testGet "test/TestMaybeUUIDId") application >>= assertSuccess "Nothing" + it "parses Maybe Id with UUID param: Just" $ withContext do + runSession (testGet "test/TestMaybeUUIDId?maybeUuidId=8dd57d19-490a-4323-8b94-6081ab93bf34") application >>= assertSuccess "Just 8dd57d19-490a-4323-8b94-6081ab93bf34" it "parses [UUID] param: empty" $ withContext do runSession (testGet "test/TestUUIDList") application >>= assertSuccess "[]" it "parses [UUID] param: one element" $ withContext do @@ -218,8 +227,12 @@ tests = beforeAll (mockContextNoDatabase WebApplication config) do pathTo (TestTextListAction ["hello", "there"]) `shouldBe` "/test/TestTextList?textList=hello%2Cthere" it "generates correct path for [Int] param" $ withContext do pathTo (TestIntListAction [1,2,3]) `shouldBe` "/test/TestIntList?intList=1%2C2%2C3" - it "generates correct path for UUID param" $ withContext do + it "generates correct path for Id with UUID param" $ withContext do pathTo (TestUUIDId "8dd57d19-490a-4323-8b94-6081ab93bf34") `shouldBe` "/test/TestUUIDId?uuidId=8dd57d19-490a-4323-8b94-6081ab93bf34" + it "generates correct path for Maybe ID with UUID param: Nothing" $ withContext do + pathTo (TestMaybeUUIDId Nothing) `shouldBe` "/test/TestMaybeUUIDId" + it "generates correct path for Maybe ID with UUID param: Just" $ withContext do + pathTo (TestMaybeUUIDId (Just "8dd57d19-490a-4323-8b94-6081ab93bf34")) `shouldBe` "/test/TestMaybeUUIDId?maybeUuidId=8dd57d19-490a-4323-8b94-6081ab93bf34" it "generates correct path for [UUID] param" $ withContext do pathTo (TestUUIDList ["8dd57d19-490a-4323-8b94-6081ab93bf34", "fdb15f8e-2fe9-441a-ae0e-da56956b1722"]) `shouldBe` "/test/TestUUIDList?uuidList=8dd57d19-490a-4323-8b94-6081ab93bf34%2Cfdb15f8e-2fe9-441a-ae0e-da56956b1722" it "generates correct path when used with Breadcrumbs" $ withContext do From 64a9941475c6889890e186b07cb8f3e742d959d3 Mon Sep 17 00:00:00 2001 From: Amitai Burstein Date: Fri, 2 Jun 2023 21:45:32 +0300 Subject: [PATCH 03/12] Fix param on Nothing --- IHP/RouterSupport.hs | 11 +++++++++-- 1 file changed, 9 insertions(+), 2 deletions(-) diff --git a/IHP/RouterSupport.hs b/IHP/RouterSupport.hs index 4041a840a..45bd61626 100644 --- a/IHP/RouterSupport.hs +++ b/IHP/RouterSupport.hs @@ -634,8 +634,15 @@ instance {-# OVERLAPPABLE #-} (Show controller, AutoRoute controller) => HasPath -- 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, making sure to remove - -- the "Just" prefix. - |> map (\(v1, (k, v2)) -> (k, fromMaybe (cs $ Text.replace "Just" "" $ cs v2) v1)) + -- the "Just" prefix, or to remove the "Nothing". + |> map (\(v1, (k, v2)) -> + let + defaultValue = + if "Nothing" == v2 then "" + else Text.replace "Just" "" $ cs v2 + in + (k, fromMaybe (cs defaultValue) v1) + ) |> map (\(k, v) -> if isEmpty v then "" else k <> "=" <> URI.encode v) From dffd0f2dbfa1779c95885c0ac834dc811f5e9687 Mon Sep 17 00:00:00 2001 From: Amitai Burstein Date: Fri, 2 Jun 2023 22:24:10 +0300 Subject: [PATCH 04/12] Keep Just in the query param --- IHP/RouterSupport.hs | 18 ++++++++---------- Test/RouterSupportSpec.hs | 2 +- 2 files changed, 9 insertions(+), 11 deletions(-) diff --git a/IHP/RouterSupport.hs b/IHP/RouterSupport.hs index 45bd61626..875e3fbc2 100644 --- a/IHP/RouterSupport.hs +++ b/IHP/RouterSupport.hs @@ -48,6 +48,7 @@ import GHC.TypeLits import Data.Data import qualified Control.Monad.State.Strict as State import qualified Data.Text as Text +import qualified Data.UUID as UUID import Network.HTTP.Types.URI import qualified Data.List as List import Unsafe.Coerce @@ -285,7 +286,11 @@ parseFuncs parseIdType = [ Just queryValue -> queryValue |> fromASCIIBytes |> \case - Just uuid -> uuid |> unsafeCoerce |> Right + Just uuid -> + let idValue = if "Just" `Text.isPrefixOf` (UUID.toText uuid) + then Text.replace "Just" "" (UUID.toText uuid) |> UUID.fromText |> unsafeCoerce + else uuid |> unsafeCoerce + in idValue |> Right Nothing -> Left BadType { field = "", value = Just queryValue, expectedType = "UUID" } Nothing -> Left NotMatched ] @@ -634,15 +639,8 @@ instance {-# OVERLAPPABLE #-} (Show controller, AutoRoute controller) => HasPath -- 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, making sure to remove - -- the "Just" prefix, or to remove the "Nothing". - |> map (\(v1, (k, v2)) -> - let - defaultValue = - if "Nothing" == v2 then "" - else Text.replace "Just" "" $ cs v2 - in - (k, fromMaybe (cs defaultValue) v1) - ) + -- the "Nothing". + |> map (\(v1, (k, v2)) -> (k, fromMaybe (cs $ Text.replace "Nothing" "" $ cs v2) v1)) |> map (\(k, v) -> if isEmpty v then "" else k <> "=" <> URI.encode v) diff --git a/Test/RouterSupportSpec.hs b/Test/RouterSupportSpec.hs index aa297c116..1760cfe88 100644 --- a/Test/RouterSupportSpec.hs +++ b/Test/RouterSupportSpec.hs @@ -232,7 +232,7 @@ tests = beforeAll (mockContextNoDatabase WebApplication config) do it "generates correct path for Maybe ID with UUID param: Nothing" $ withContext do pathTo (TestMaybeUUIDId Nothing) `shouldBe` "/test/TestMaybeUUIDId" it "generates correct path for Maybe ID with UUID param: Just" $ withContext do - pathTo (TestMaybeUUIDId (Just "8dd57d19-490a-4323-8b94-6081ab93bf34")) `shouldBe` "/test/TestMaybeUUIDId?maybeUuidId=8dd57d19-490a-4323-8b94-6081ab93bf34" + pathTo (TestMaybeUUIDId (Just "8dd57d19-490a-4323-8b94-6081ab93bf34")) `shouldBe` "/test/TestMaybeUUIDId?maybeUuidId=Just8dd57d19-490a-4323-8b94-6081ab93bf34" it "generates correct path for [UUID] param" $ withContext do pathTo (TestUUIDList ["8dd57d19-490a-4323-8b94-6081ab93bf34", "fdb15f8e-2fe9-441a-ae0e-da56956b1722"]) `shouldBe` "/test/TestUUIDList?uuidList=8dd57d19-490a-4323-8b94-6081ab93bf34%2Cfdb15f8e-2fe9-441a-ae0e-da56956b1722" it "generates correct path when used with Breadcrumbs" $ withContext do From 68720e1dc56c1dfd590217402c4e1e112dffb15a Mon Sep 17 00:00:00 2001 From: Amitai Burstein Date: Fri, 2 Jun 2023 22:25:39 +0300 Subject: [PATCH 05/12] Adjust test --- Test/RouterSupportSpec.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Test/RouterSupportSpec.hs b/Test/RouterSupportSpec.hs index 1760cfe88..0f088fcc3 100644 --- a/Test/RouterSupportSpec.hs +++ b/Test/RouterSupportSpec.hs @@ -201,7 +201,7 @@ tests = beforeAll (mockContextNoDatabase WebApplication config) do it "parses Maybe Id with UUID param: Nothing" $ withContext do runSession (testGet "test/TestMaybeUUIDId") application >>= assertSuccess "Nothing" it "parses Maybe Id with UUID param: Just" $ withContext do - runSession (testGet "test/TestMaybeUUIDId?maybeUuidId=8dd57d19-490a-4323-8b94-6081ab93bf34") application >>= assertSuccess "Just 8dd57d19-490a-4323-8b94-6081ab93bf34" + runSession (testGet "test/TestMaybeUUIDId?maybeUuidId=Just8dd57d19-490a-4323-8b94-6081ab93bf34") application >>= assertSuccess "Just 8dd57d19-490a-4323-8b94-6081ab93bf34" it "parses [UUID] param: empty" $ withContext do runSession (testGet "test/TestUUIDList") application >>= assertSuccess "[]" it "parses [UUID] param: one element" $ withContext do From bc6c5d1c07598567e9f3dc11bf5989546adf4706 Mon Sep 17 00:00:00 2001 From: Amitai Burstein Date: Fri, 2 Jun 2023 22:35:37 +0300 Subject: [PATCH 06/12] Not there yet --- IHP/RouterSupport.hs | 18 ++++++++++++------ 1 file changed, 12 insertions(+), 6 deletions(-) diff --git a/IHP/RouterSupport.hs b/IHP/RouterSupport.hs index 875e3fbc2..de309efe9 100644 --- a/IHP/RouterSupport.hs +++ b/IHP/RouterSupport.hs @@ -286,13 +286,19 @@ parseFuncs parseIdType = [ Just queryValue -> queryValue |> fromASCIIBytes |> \case - Just uuid -> - let idValue = if "Just" `Text.isPrefixOf` (UUID.toText uuid) - then Text.replace "Just" "" (UUID.toText uuid) |> UUID.fromText |> unsafeCoerce - else uuid |> unsafeCoerce - in idValue |> Right - Nothing -> Left BadType { field = "", value = Just queryValue, expectedType = "UUID" } + Just uuid -> uuid |> unsafeCoerce |> Right + Nothing -> + -- We couldn't parse the UUID, so try Maybe (Id record), + -- where we have a @Just@ prefix before the UUID. + queryValue + |> (\val -> cs $ Text.replace "Just " "" $ cs val) + |> fromASCIIBytes + |> \case + Just uuid -> Just uuid |> unsafeCoerce |> Right + Nothing -> Left BadType { field = "", value = Just queryValue, expectedType = "UUID" } + Nothing -> Left NotMatched + ] {-# INLINABLE parseFuncs #-} From 272a6c887b9794daa9b19857d1f6ef03b6f8ddd1 Mon Sep 17 00:00:00 2001 From: Amitai Burstein Date: Fri, 2 Jun 2023 22:42:34 +0300 Subject: [PATCH 07/12] Simplify code --- IHP/RouterSupport.hs | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/IHP/RouterSupport.hs b/IHP/RouterSupport.hs index de309efe9..0b8a2ba5e 100644 --- a/IHP/RouterSupport.hs +++ b/IHP/RouterSupport.hs @@ -291,8 +291,9 @@ parseFuncs parseIdType = [ -- We couldn't parse the UUID, so try Maybe (Id record), -- where we have a @Just@ prefix before the UUID. queryValue - |> (\val -> cs $ Text.replace "Just " "" $ cs val) - |> fromASCIIBytes + |> cs + |> Text.replace "Just " "" + |> UUID.fromText |> \case Just uuid -> Just uuid |> unsafeCoerce |> Right Nothing -> Left BadType { field = "", value = Just queryValue, expectedType = "UUID" } From 2080d273a1934c965f6408e7317ef8479099685c Mon Sep 17 00:00:00 2001 From: Amitai Burstein Date: Fri, 2 Jun 2023 22:45:57 +0300 Subject: [PATCH 08/12] Fix string --- IHP/RouterSupport.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/IHP/RouterSupport.hs b/IHP/RouterSupport.hs index 0b8a2ba5e..8cd9d7315 100644 --- a/IHP/RouterSupport.hs +++ b/IHP/RouterSupport.hs @@ -292,7 +292,7 @@ parseFuncs parseIdType = [ -- where we have a @Just@ prefix before the UUID. queryValue |> cs - |> Text.replace "Just " "" + |> Text.replace "Just" "" |> UUID.fromText |> \case Just uuid -> Just uuid |> unsafeCoerce |> Right From c54ad0b2e5e1e1094bc8e2ae5088624cc2cdde66 Mon Sep 17 00:00:00 2001 From: Amitai Burstein Date: Fri, 2 Jun 2023 22:54:14 +0300 Subject: [PATCH 09/12] Stick to Just and Nothing --- IHP/RouterSupport.hs | 24 +++++++++++++----------- Test/RouterSupportSpec.hs | 4 ++-- 2 files changed, 15 insertions(+), 13 deletions(-) diff --git a/IHP/RouterSupport.hs b/IHP/RouterSupport.hs index 8cd9d7315..56f0e630e 100644 --- a/IHP/RouterSupport.hs +++ b/IHP/RouterSupport.hs @@ -289,14 +289,17 @@ parseFuncs parseIdType = [ Just uuid -> uuid |> unsafeCoerce |> Right Nothing -> -- We couldn't parse the UUID, so try Maybe (Id record), - -- where we have a @Just@ prefix before the UUID. - queryValue - |> cs - |> Text.replace "Just" "" - |> UUID.fromText - |> \case - Just uuid -> Just uuid |> unsafeCoerce |> Right - Nothing -> Left BadType { field = "", value = Just queryValue, expectedType = "UUID" } + -- where we have a @Just@ prefix before the UUID, or a "Nothing" string. + if (cs queryValue == ("Nothing" :: Text)) + then Nothing |> unsafeCoerce |> Right + else + queryValue + |> cs + |> Text.replace "Just" "" + |> UUID.fromText + |> \case + Just uuid -> Just uuid |> unsafeCoerce |> Right + Nothing -> Left BadType { field = "", value = Just queryValue, expectedType = "UUID" } Nothing -> Left NotMatched @@ -645,9 +648,8 @@ instance {-# OVERLAPPABLE #-} (Show controller, AutoRoute controller) => HasPath |> \(kvs :: [(String, String)]) -> zip (showTerms action) 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, making sure to remove - -- the "Nothing". - |> map (\(v1, (k, v2)) -> (k, fromMaybe (cs $ Text.replace "Nothing" "" $ cs v2) v1)) + -- In this case we default back to the @show@ representation. + |> map (\(v1, (k, v2)) -> (k, fromMaybe v2 v1)) |> map (\(k, v) -> if isEmpty v then "" else k <> "=" <> URI.encode v) diff --git a/Test/RouterSupportSpec.hs b/Test/RouterSupportSpec.hs index 0f088fcc3..35b377d1e 100644 --- a/Test/RouterSupportSpec.hs +++ b/Test/RouterSupportSpec.hs @@ -199,7 +199,7 @@ tests = beforeAll (mockContextNoDatabase WebApplication config) do it "parses Id with UUID param" $ withContext do runSession (testGet "test/TestUUIDId?uuidId=8dd57d19-490a-4323-8b94-6081ab93bf34") application >>= assertSuccess "8dd57d19-490a-4323-8b94-6081ab93bf34" it "parses Maybe Id with UUID param: Nothing" $ withContext do - runSession (testGet "test/TestMaybeUUIDId") application >>= assertSuccess "Nothing" + runSession (testGet "test/TestMaybeUUIDId?maybeUuidId=Nothing") application >>= assertSuccess "Nothing" it "parses Maybe Id with UUID param: Just" $ withContext do runSession (testGet "test/TestMaybeUUIDId?maybeUuidId=Just8dd57d19-490a-4323-8b94-6081ab93bf34") application >>= assertSuccess "Just 8dd57d19-490a-4323-8b94-6081ab93bf34" it "parses [UUID] param: empty" $ withContext do @@ -230,7 +230,7 @@ tests = beforeAll (mockContextNoDatabase WebApplication config) do it "generates correct path for Id with UUID param" $ withContext do pathTo (TestUUIDId "8dd57d19-490a-4323-8b94-6081ab93bf34") `shouldBe` "/test/TestUUIDId?uuidId=8dd57d19-490a-4323-8b94-6081ab93bf34" it "generates correct path for Maybe ID with UUID param: Nothing" $ withContext do - pathTo (TestMaybeUUIDId Nothing) `shouldBe` "/test/TestMaybeUUIDId" + pathTo (TestMaybeUUIDId Nothing) `shouldBe` "/test/TestMaybeUUIDId?maybeUuidId=Nothing" it "generates correct path for Maybe ID with UUID param: Just" $ withContext do pathTo (TestMaybeUUIDId (Just "8dd57d19-490a-4323-8b94-6081ab93bf34")) `shouldBe` "/test/TestMaybeUUIDId?maybeUuidId=Just8dd57d19-490a-4323-8b94-6081ab93bf34" it "generates correct path for [UUID] param" $ withContext do From a47df1292ba5a65267f8e4e0aa191c8d51f031c1 Mon Sep 17 00:00:00 2001 From: Amitai Burstein Date: Fri, 2 Jun 2023 22:57:17 +0300 Subject: [PATCH 10/12] Improve comment --- IHP/RouterSupport.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/IHP/RouterSupport.hs b/IHP/RouterSupport.hs index 56f0e630e..eee5d5ed8 100644 --- a/IHP/RouterSupport.hs +++ b/IHP/RouterSupport.hs @@ -291,6 +291,7 @@ parseFuncs parseIdType = [ -- We couldn't parse the UUID, so try Maybe (Id record), -- where we have a @Just@ prefix before the UUID, or a "Nothing" string. if (cs queryValue == ("Nothing" :: Text)) + -- This is a @Nothing@ then Nothing |> unsafeCoerce |> Right else queryValue @@ -298,6 +299,7 @@ parseFuncs parseIdType = [ |> Text.replace "Just" "" |> UUID.fromText |> \case + -- We were able to parse the UUID, so wrap it in a @Just@. Just uuid -> Just uuid |> unsafeCoerce |> Right Nothing -> Left BadType { field = "", value = Just queryValue, expectedType = "UUID" } From 559bf9434febfd2eb105971b1e756f433ec5512a Mon Sep 17 00:00:00 2001 From: Amitai Burstein Date: Fri, 2 Jun 2023 22:58:20 +0300 Subject: [PATCH 11/12] Improve comment --- IHP/RouterSupport.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/IHP/RouterSupport.hs b/IHP/RouterSupport.hs index eee5d5ed8..ac50c77b5 100644 --- a/IHP/RouterSupport.hs +++ b/IHP/RouterSupport.hs @@ -288,7 +288,7 @@ parseFuncs parseIdType = [ |> \case Just uuid -> uuid |> unsafeCoerce |> Right Nothing -> - -- We couldn't parse the UUID, so try Maybe (Id record), + -- We couldn't parse the UUID, so try Maybe (Id UUID), -- where we have a @Just@ prefix before the UUID, or a "Nothing" string. if (cs queryValue == ("Nothing" :: Text)) -- This is a @Nothing@ From 19066cfe13bd8bccf5c8673f50f312f786d3c2f4 Mon Sep 17 00:00:00 2001 From: Amitai Burstein Date: Fri, 2 Jun 2023 22:58:33 +0300 Subject: [PATCH 12/12] Improve comment --- IHP/RouterSupport.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/IHP/RouterSupport.hs b/IHP/RouterSupport.hs index ac50c77b5..4dd11cb0b 100644 --- a/IHP/RouterSupport.hs +++ b/IHP/RouterSupport.hs @@ -289,7 +289,7 @@ parseFuncs parseIdType = [ Just uuid -> uuid |> unsafeCoerce |> Right Nothing -> -- We couldn't parse the UUID, so try Maybe (Id UUID), - -- where we have a @Just@ prefix before the UUID, or a "Nothing" string. + -- where we have a @Just@ prefix before the UUID, or a @Nothing@ string. if (cs queryValue == ("Nothing" :: Text)) -- This is a @Nothing@ then Nothing |> unsafeCoerce |> Right