Allow unreserved characters in host

Rather than simply allowing only alpha numeric characters, which is against
RFC 3986.

CHANGELOG.md

@@ -1,3 +1,9 @@
+## 0.3.6.1
+
+* Host now can contain unreserved characters rather than simply alpha
+  numeric ones, which was against RFC 3986. [Issue
+  73](https://github.com/mrkkrp/modern-uri/issues/73).
+
 ## 0.3.6.0
 
 * Now colons are not escaped in paths, unless the `URI` in question is a

Text/URI/Parser/ByteString.hs

@@ -143,7 +143,7 @@ pHost =
       void (char 46)
       skipSome (unreservedChar <|> subDelimChar <|> char 58)
     regName = fmap (intercalate [46]) . flip sepBy1 (char 46) $ do
-      let ch = percentEncChar <|> asciiAlphaNumChar
+      let ch = percentEncChar <|> unreservedChar
       mx <- optional ch
       case mx of
         Nothing -> return []

Text/URI/Parser/Text/Utils.hs

@@ -80,8 +80,8 @@ pHost pe =
     regName = fmap (intercalate ".") . flip sepBy1 (char '.') $ do
       let ch =
             if pe
-              then percentEncChar <|> asciiAlphaNumChar
-              else alphaNumChar
+              then percentEncChar <|> unreservedChar
+              else unreservedCharUnicode
       mx <- optional ch
       case mx of
         Nothing -> return ""
@@ -110,6 +110,12 @@ unreservedChar = label "unreserved character" . satisfy $ \x ->
   isAsciiAlphaNum x || x == '-' || x == '.' || x == '_' || x == '~'
 {-# INLINE unreservedChar #-}
 
+-- | Parse an unreserved character allowing Unicode.
+unreservedCharUnicode :: (MonadParsec e Text m) => m Char
+unreservedCharUnicode = label "unreserved character" . satisfy $ \x ->
+  isAlphaNum x || x == '-' || x == '.' || x == '_' || x == '~'
+{-# INLINE unreservedCharUnicode #-}
+
 -- | Parse a percent-encoded character.
 percentEncChar :: (MonadParsec e Text m) => m Char
 percentEncChar = do

Text/URI/Types.hs

@@ -526,7 +526,7 @@ arbHost =
             ]
       return ("v" ++ [v] ++ "." ++ xs)
     domainLabel = do
-      let g = arbitrary `suchThat` isAlphaNum
+      let g = arbitrary `suchThat` isUnreservedChar
       x <- g
       xs <-
         listOf $
@@ -535,6 +535,11 @@ arbHost =
       return ([x] ++ xs ++ [x'])
     regName = intercalate "." <$> resize 5 (listOf1 domainLabel)
 
+-- | Return 'True' if the given character is unreserved.
+isUnreservedChar :: Char -> Bool
+isUnreservedChar x =
+  isAlphaNum x || x == '-' || x == '.' || x == '_' || x == '~'
+
 -- | Make generator for refined text given how to lift a possibly empty
 -- arbitrary 'Text' value into a refined type.
 arbText :: (Text -> Maybe (RText l)) -> Gen (RText l)

tests/Text/URISpec.hs

@@ -28,6 +28,24 @@ spec = do
     it "accepts valid URIs" $ do
       uri <- mkTestURI
       URI.mkURI testURI `shouldReturn` uri
+    it "accepts a URI with an underscore in host name" $ do
+      scheme <- URI.mkScheme "http"
+      host <- URI.mkHost "auth_service"
+      path <- mapM URI.mkPathPiece ["api", "v1", "users", "validate"]
+      URI.mkURI "http://auth_service:3000/api/v1/users/validate"
+        `shouldReturn` URI
+          { uriScheme = Just scheme,
+            uriAuthority =
+              Right
+                URI.Authority
+                  { URI.authUserInfo = Nothing,
+                    URI.authHost = host,
+                    URI.authPort = Just 3000
+                  },
+            uriPath = Just (False, NE.fromList path),
+            uriQuery = [],
+            uriFragment = Nothing
+          }
     it "rejects invalid URIs" $ do
       let e =
             err 0 . mconcat $
@@ -122,9 +140,10 @@ spec = do
       URI.mkHost "104.155.144.4.sslip.io" `shouldRText` "104.155.144.4.sslip.io"
       URI.mkHost "юникод.рф" `shouldRText` "юникод.рф"
       URI.mkHost "" `shouldRText` ""
+      URI.mkHost "auth_service" `shouldRText` "auth_service"
     it "rejects invalid hosts" $ do
-      URI.mkHost "_something"
-        `shouldThrow` (== RTextException Host "_something")
+      URI.mkHost ")something"
+        `shouldThrow` (== RTextException Host ")something")
       URI.mkHost "some@thing"
         `shouldThrow` (== RTextException Host "some@thing")
   describe "mkUsername" $ do
@@ -204,9 +223,9 @@ spec = do
                 etok ':',
                 etok '?',
                 etok '[',
-                elabel "ASCII alpha-numeric character",
-                elabel "username",
                 elabel "path piece",
+                elabel "unreserved character",
+                elabel "username",
                 eeof
               ]
           )
@@ -276,7 +295,7 @@ spec = do
                 etok '%',
                 etok '-',
                 etok '.',
-                elabel "ASCII alpha-numeric character",
+                elabel "unreserved character",
                 elabel "host that can be decoded as UTF-8"
               ]
           )