implemented Helpers.makeHttps

This commit is contained in:
Jonathan Lamothe 2021-09-22 15:21:37 -04:00
parent b7737766f6
commit b809cdf082
2 changed files with 28 additions and 0 deletions

View File

@ -25,6 +25,7 @@ along with this program. If not, see <https://www.gnu.org/licenses/>.
module Helpers ( module Helpers (
textToUrl, textToUrl,
urlToText, urlToText,
makeHttps,
editHost editHost
) where ) where
@ -63,6 +64,15 @@ urlToText url = T.pack $
Just str -> "#" ++ str Just str -> "#" ++ str
Nothing -> "" Nothing -> ""
-- | Convert HTTP to HTTPS (if necessary)
makeHttps :: Url -> Maybe Url
makeHttps url = if any ($ protocol url)
[ (== "https")
, (== "http")
]
then Just url { protocol = "https" }
else Nothing
-- | Edit the 'host' value of a 'Url' -- | Edit the 'host' value of a 'Url'
editHost editHost
:: (String -> Maybe String) :: (String -> Maybe String)

View File

@ -33,6 +33,7 @@ spec :: Spec
spec = do spec = do
textToUrlSpec textToUrlSpec
urlToTextSpec urlToTextSpec
makeHttpsSpec
editHostSpec editHostSpec
textToUrlSpec :: Spec textToUrlSpec :: Spec
@ -65,6 +66,23 @@ urlToTextSpec = describe "urlToText" $ mapM_
, ( anchorUrl, anchorTxt ) , ( anchorUrl, anchorTxt )
] ]
makeHttpsSpec :: Spec
makeHttpsSpec = describe "makeHttps" $ mapM_
( \(desc, input, expected) -> context desc $
it ("should be " ++ show expected) $
makeHttps input `shouldBe` expected
)
-- description, input, expected
[ ( "HTTP", simpleUrl, Just https )
, ( "HTTPS", https, Just https )
, ( "FTP", urlWith "ftp", Nothing )
]
where
https = urlWith "https"
urlWith p = simpleUrl { protocol = p }
editHostSpec ::Spec editHostSpec ::Spec
editHostSpec = describe "editHost" $ mapM_ editHostSpec = describe "editHost" $ mapM_
( \(desc, f, url, expected) -> context desc $ ( \(desc, f, url, expected) -> context desc $