From 03360100f3375abab128144b0851d043a96bacbc Mon Sep 17 00:00:00 2001 From: Michael Orlitzky Date: Thu, 28 Jun 2012 17:11:55 -0400 Subject: [PATCH] Add the add_trailing_slash function and tests. --- src/LWN/URI.hs | 42 +++++++++++++++++++++++++++++++++++++++++- 1 file changed, 41 insertions(+), 1 deletion(-) diff --git a/src/LWN/URI.hs b/src/LWN/URI.hs index 7aa4240..3a21413 100644 --- a/src/LWN/URI.hs +++ b/src/LWN/URI.hs @@ -1,6 +1,7 @@ module LWN.URI where +import Data.List (isSuffixOf) import Data.Maybe (fromJust) import Data.String.Utils (split) import Network.URI ( @@ -53,6 +54,21 @@ make_https url = parse_result = parseURIReference url + +add_trailing_slash :: URL -> URL +add_trailing_slash url = + case parse_result of + Nothing -> url -- Shrug? + Just uri -> + let old_path = uriPath uri in + if isSuffixOf "/" old_path then + url -- It already had a trailing slash + else + show $ uri { uriPath = old_path ++ "/" } + where + parse_result = parseURIReference url + + -- | Does this URI use an HTTPS-compatible port? https_port :: URI -> Bool https_port uri = @@ -234,6 +250,25 @@ test_normal_url_conversion = actual = fromJust $ make_absolute_url url + +test_make_https :: Assertion +test_make_https = + assertEqual "HTTP URL is made HTTPS" expected actual + where + url = "http://lwn.net/current" + expected = "https://lwn.net/current" + actual = make_https url + + +test_add_trailing_slash :: Assertion +test_add_trailing_slash = + assertEqual "Trailing slashes get added" expected actual + where + url = "https://lwn.net/current" + expected = "https://lwn.net/current/" + actual = add_trailing_slash url + + uri_tests :: Test uri_tests = testGroup "URI Tests" [ @@ -250,4 +285,9 @@ uri_tests = testGroup "Relative -> Absolute Conversion" [ testCase "Empty URL converted to lwn.net" test_empty_url_conversion, - testCase "Normal URL made absolute" test_normal_url_conversion ]] + testCase "Normal URL made absolute" test_normal_url_conversion ], + + testGroup "URL Mangling" [ + testCase "HTTP URLs are made HTTPS" test_make_https, + testCase "Trailing slashes get added" test_add_trailing_slash ] + ] -- 2.44.2