Merge pull request #6 from garyb/auth-part-parsing

Authority part parsing fixes

Author: garyb

src/Data/URI/HierarchicalPart.purs

@@ -14,17 +14,19 @@ import Text.Parsing.StringParser.Combinators (optionMaybe)
 import Text.Parsing.StringParser.String (string)
 
 parseHierarchicalPart :: Parser HierarchicalPart
-parseHierarchicalPart =
-  (HierarchicalPart
-   <$> optionMaybe (string "//" *> parseAuthority)
-   <*> parsePathAbEmpty parseURIPathAbs)
+parseHierarchicalPart = withAuth <|> withoutAuth
+  where
+  withAuth =
+    HierarchicalPart
+      <$> Just <$> (string "//" *> parseAuthority)
+      <*> parsePathAbEmpty parseURIPathAbs
 
-  <|> (HierarchicalPart Nothing
-       <$> ((Just <$> parsePathAbsolute parseURIPathAbs)
-            <|>
-            (Just <$> parsePathRootless parseURIPathAbs)
-            <|>
-            pure Nothing))
+  withoutAuth = HierarchicalPart Nothing <$> noAuthPath
+
+  noAuthPath
+      = (Just <$> parsePathAbsolute parseURIPathAbs)
+    <|> (Just <$> parsePathRootless parseURIPathAbs)
+    <|> pure Nothing
 
 printHierPart :: HierarchicalPart -> String
 printHierPart (HierarchicalPart a p) =

src/Data/URI/Path.purs

@@ -17,8 +17,8 @@ import Control.Alt ((<|>))
 import Control.Bind ((=<<))
 import Data.Either (Either(..), either)
 import Data.Maybe (Maybe(..))
-import Data.Path.Pathy (parseAbsDir, parseRelDir, parseAbsFile, parseRelFile, sandbox, rootDir, (</>), unsafePrintPath)
-import Data.String (drop, length)
+import Data.Path.Pathy (Path(), parseAbsDir, parseRelDir, parseAbsFile, parseRelFile, sandbox, rootDir, (</>), unsafePrintPath)
+import Data.String as Str
 import Data.URI.Common
 import Data.URI.Types
 import Text.Parsing.StringParser (Parser(..), ParseError(..), try)
@@ -67,19 +67,24 @@ parseSegmentNonZeroNoColon = joinWith "" <$> many1 (parseUnreserved
 
 parseURIPathAbs :: Parser URIPathAbs
 parseURIPathAbs = Parser \{ str: str, pos: i } fc sc ->
-  case sandbox rootDir =<< parseAbsFile (drop i str) of
-    Just file -> sc (Left $ rootDir </> file) { str: str, pos: length str }
-    Nothing -> case sandbox rootDir =<< parseAbsDir (drop i str) of
-      Just dir -> sc (Right $ rootDir </> dir) { str: str, pos: length str }
+  case sandbox rootDir =<< parseAbsFile (Str.drop i str) of
+    Just file -> sc (Left $ rootDir </> file) { str: str, pos: Str.length str }
+    Nothing -> case sandbox rootDir =<< parseAbsDir (Str.drop i str) of
+      Just dir -> sc (Right $ rootDir </> dir) { str: str, pos: Str.length str }
       Nothing -> fc i (ParseError $ "Expected a valid path")
 
 parseURIPathRel :: Parser URIPathRel
 parseURIPathRel = Parser \{ str: str, pos: i } fc sc ->
-  case parseRelFile (drop i str) of
-    Just file -> sc (Left file) { str: str, pos: length str }
-    Nothing -> case parseRelDir (drop i str) of
-      Just dir -> sc (Right dir) { str: str, pos: length str }
+  case parseRelFile (Str.drop i str) of
+    Just file -> sc (Left file) { str: str, pos: Str.length str }
+    Nothing -> case parseRelDir (Str.drop i str) of
+      Just dir -> sc (Right dir) { str: str, pos: Str.length str }
       Nothing -> fc i (ParseError $ "Expected a valid path")
 
 printPath :: forall a s. URIPath a s -> String
-printPath = either unsafePrintPath unsafePrintPath
+printPath = either print print
+  where
+  print :: forall a' b s'. Path a' b s' -> String
+  print path =
+    let printed = unsafePrintPath path
+    in if Str.take 2 printed == "./" then Str.drop 2 printed else printed

src/Data/URI/RelativePart.purs

@@ -14,10 +14,20 @@ import Text.Parsing.StringParser.Combinators (optionMaybe)
 import Text.Parsing.StringParser.String (string)
 
 parseRelativePart :: Parser RelativePart
-parseRelativePart = (RelativePart <$> optionMaybe (string "//" *> parseAuthority) <*> parsePathAbEmpty parseURIPathRel)
-                <|> (RelativePart Nothing <$> ((Just <$> parsePathAbsolute parseURIPathRel)
-                                          <|> (Just <$> parsePathNoScheme parseURIPathRel)
-                                          <|> pure Nothing))
+parseRelativePart = withAuth <|> withoutAuth
+  where
+
+  withAuth =
+    RelativePart
+      <$> Just <$> (string "//" *> parseAuthority)
+      <*> parsePathAbEmpty parseURIPathRel
+
+  withoutAuth = RelativePart Nothing <$> noAuthPath
+
+  noAuthPath
+      = (Just <$> parsePathAbsolute parseURIPathRel)
+    <|> (Just <$> parsePathNoScheme parseURIPathRel)
+    <|> pure Nothing
 
 printRelativePart :: RelativePart -> String
 printRelativePart (RelativePart a p) =

test/Main.purs

@@ -34,15 +34,15 @@ main = do
   test runParseURIRef "foo://example.com:8042/over/there?name=ferret#nose"
   test runParseURIRef "foo://info.example.com?fred"
   test runParseURIRef "ftp://cnn.example.com&[email protected]/top_story.htm"
+  test runParseURIRef "../top_story.htm"
+  test runParseURIRef "top_story.htm"
 
   C.log "\nFailing test cases: "
   testFails runParseURIRef "news:comp.infosystems.www.servers.unix"
   testFails runParseURIRef "tel:+1-816-555-1212"
   testFails runParseURIRef "urn:oasis:names:specification:docbook:dtd:xml:4.1.2"
   testFails runParseURIRef "mailto:[email protected]"
   testFails runParseURIRef "mailto:[email protected]"
-  testFails runParseURIRef "../top_story.htm"
-  testFails runParseURIRef "top_story.htm"
   testFails runParseURIRef "/top_story.htm"