More lenient url validation accepts custom protocols

Author: maca

src/FormToolkit/Field.elm

@@ -79,6 +79,7 @@ import Internal.View
 import Json.Decode as Decode
 import Json.Encode as Encode
 import List.Extra
+import Regex
 import RoseTree.Path as Path
 import RoseTree.Tree as Tree
 import String.Extra
@@ -288,7 +289,9 @@ email =
     init Email
 
 
-{-| Builds a URL input field.
+{-| Builds a URL input field, validation will fail if input is a valid url.
+This check is more lenient than `Parse.url` since protocols other than http and
+https are accepted.
 
     urlField : Field id
     urlField =
@@ -1408,7 +1411,7 @@ checkEmail node =
                     setError ParseError node
 
         Url ->
-            case Internal.Value.toString attrs.value |> Maybe.andThen Url.fromString of
+            case Internal.Value.toString attrs.value |> Maybe.andThen validateUrl of
                 Just _ ->
                     node
 
@@ -1419,6 +1422,14 @@ checkEmail node =
             node
 
 
+validateUrl : String -> Maybe Url.Url
+validateUrl urlString =
+    Regex.fromString "^(\\w+)://"
+        |> Maybe.withDefault Regex.never
+        |> (\regex -> Regex.replace regex (\_ -> "http://") urlString)
+        |> Url.fromString
+
+
 checkPattern : Node id -> Node id
 checkPattern node =
     let

tests/ParseTest.elm

@@ -383,6 +383,9 @@ suite =
                         , \_ -> testUrl "http://example.com" True
                         , \_ -> testUrl "https://example.com/path" True
                         , \_ -> testUrl "https://example.com/path?query=value" True
+                        , \_ -> testUrl "ftp://example.com" True
+                        , \_ -> testUrl "ssh://example.com" True
+                        , \_ -> testUrl "custom://example.com" True
                         , \_ -> testUrl "not-a-url" False
                         , \_ -> testUrl "example.com" False
                         , \_ -> testUrl "//example.com" False