diff --git a/src/Helpers.hs b/src/Helpers.hs new file mode 100644 index 0000000..ab0ccd7 --- /dev/null +++ b/src/Helpers.hs @@ -0,0 +1,120 @@ +{-| + +Module : Helpers +Copyright : Jonathan Lamothe +License : GPL-3 +Maintainer : jonathan@jlamothe.net + +This program is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or (at +your option) any later version. + +This program is distributed in the hope that it will be useful, but +WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +General Public License for more details. + +You should have received a copy of the GNU General Public License +along with this program. If not, see . + +-} + +{-# LANGUAGE LambdaCase, OverloadedStrings #-} + +module Helpers ( + textToUrl, + urlToText, + ) where + +import qualified Data.List as L +import qualified Data.Text as T + +import Types + +-- | Convert a text to a 'Url' (if possible) +textToUrl :: T.Text -> Maybe Url +textToUrl text = case T.splitOn "#" text of + [sub, anchorT] -> do + url <- subToUrl sub + Just $ url { anchor = Just $ T.unpack anchorT } + [sub] -> subToUrl sub + _ -> Nothing + +-- | Convert a 'Url' to text +urlToText :: Url -> T.Text +urlToText url = T.pack $ + protocol url ++ "://" ++ + host url ++ "/" ++ + pathStr ++ paramsStr ++ anchorStr + where + pathStr = L.intercalate "/" $ path url + paramsStr = case params url of + [] -> "" + ps -> '?' : L.intercalate "&" + ( map + ( \case + (name, Just val) -> name ++ "=" ++ val + (name, Nothing) -> name + ) ps + ) + anchorStr = case anchor url of + Just str -> "#" ++ str + Nothing -> "" + +subToUrl :: T.Text -> Maybe Url +subToUrl text = case T.splitOn "://" text of + [protT, raw] -> do + let prot = T.unpack protT + url <- getParts raw + Just url { protocol = prot } + _ -> Nothing + +getParts :: T.Text -> Maybe Url +getParts text = do + (host', path', params') <- case T.splitOn "?" text of + [pathT, paramsT] -> do + (host', path') <- getPath pathT + params' <- getParams paramsT + Just (host', path', params') + [pathT] -> do + (host', path') <- getPath pathT + Just (host', path', []) + _ -> Nothing + Just newUrl + { host = host' + , path = path' + , params = params' + } + +getPath :: T.Text -> Maybe (String, [String]) +getPath text = case T.splitOn "/" (removeTrailing '/' text) of + hostT : dirs -> Just + ( T.unpack hostT + , map T.unpack dirs + ) + _ -> Nothing + +getParams :: T.Text -> Maybe [(String, Maybe String)] +getParams = mapM getParam . T.splitOn "&" + +getParam :: T.Text -> Maybe (String, Maybe String) +getParam text = case T.splitOn "=" text of + [name, val] -> Just + ( T.unpack name + , Just $ T.unpack val + ) + [name] -> Just + ( T.unpack name + , Nothing + ) + _ -> Nothing + +removeTrailing :: Char -> T.Text -> T.Text +removeTrailing ch text + | T.null text = "" + | otherwise = if T.last text == ch + then T.init text + else text + +--jl diff --git a/test/HelpersSpec.hs b/test/HelpersSpec.hs new file mode 100644 index 0000000..b2dbfa6 --- /dev/null +++ b/test/HelpersSpec.hs @@ -0,0 +1,100 @@ +{- + +dmfix + +Copyright (C) Jonathan Lamothe + +This program is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or (at +your option) any later version. + +This program is distributed in the hope that it will be useful, but +WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +General Public License for more details. + +You should have received a copy of the GNU General Public License +along with this program. If not, see . + +-} + +{-# LANGUAGE OverloadedStrings #-} + +module HelpersSpec (spec) where + +import qualified Data.Text as T +import Test.Hspec (Spec, context, describe, it, shouldBe) + +import Helpers +import Types + +spec :: Spec +spec = do + textToUrlSpec + urlToTextSpec + +textToUrlSpec :: Spec +textToUrlSpec = describe "textToUrl" $ mapM_ + ( \(input, expected) -> context (show input) $ + it ("should be " ++ show expected) $ + textToUrl input `shouldBe` expected + ) + + -- input, expected + [ ( "", Nothing ) + , ( "foo", Nothing ) + , ( simpleTxt, Just simpleUrl ) + , ( pathTxt, Just pathUrl ) + , ( paramsTxt, Just paramsUrl ) + , ( anchorTxt, Just anchorUrl ) + ] + +urlToTextSpec :: Spec +urlToTextSpec = describe "urlToText" $ mapM_ + ( \(input, expected) -> context (show input) $ + it ("should be " ++ show expected) $ + urlToText input `shouldBe` expected + ) + + -- input, expected + [ ( simpleUrl, simpleTxt ) + , ( pathUrl, pathTxt ) + , ( paramsUrl, paramsTxt ) + , ( anchorUrl, anchorTxt ) + ] + +simpleTxt :: T.Text +simpleTxt = "http://example.com/" + +simpleUrl :: Url +simpleUrl = newUrl + { protocol = "http" + , host = "example.com" + } + +pathTxt :: T.Text +pathTxt = simpleTxt `T.append` "foo/bar" + +pathUrl :: Url +pathUrl = simpleUrl { path = ["foo", "bar"] } + +paramsTxt :: T.Text +paramsTxt = pathTxt `T.append` "?a=1&b=2&c" + +paramsUrl :: Url +paramsUrl = pathUrl + { params = + [ ( "a", Just "1" ) + , ( "b", Just "2" ) + , ( "c", Nothing ) + ] + } + +anchorTxt :: T.Text +anchorTxt = paramsTxt `T.append` "#abc" + +anchorUrl :: Url +anchorUrl = paramsUrl { anchor = Just "abc" } + +--jl