New and improved URIs

fcmtp-data.cabal

@@ -26,6 +26,8 @@ library
         string-convert,
         memory,
         cond,
+        network-uri,
+        split,
         cryptonite >= 0.9
     exposed-modules:
         Data.SMTP.Response

src/Data/SMTP/Parser/URI.hs

@@ -4,95 +4,33 @@ module Data.SMTP.Parser.URI (parseURI) where
 
 import Data.Attoparsec.ByteString.Char8
 import qualified Data.Attoparsec.ByteString.Char8 as A
-import qualified Data.Attoparsec.ByteString as AA
-import Data.Word8 (Word8)
-import qualified Data.ByteString as BS
+import qualified Network.URI as N
 import Data.SMTP.Types.URI
 import Data.SMTP.Account
-import qualified Data.Char as C
-import Control.Applicative ((<|>))
 import Text.StringConvert
+import Data.List.Split
+import Control.Monad
 
 parseURI :: Parser URI
 parseURI = do
   stringCI "fCMTP://"
-  a <- parseAccount
-  u <- A.choice [
-    do
-      string "/"
-      p <- parsePath
-      return $ URI a p Nothing,
-    return $ URI a (Path []) Nothing
-    ]
-  r <- parseRevision
-  return u{revision=r}
-
-parsePath :: Parser Path
-parsePath = Path <$>
-  A.many' parseSegment
-
-parseSegment :: Parser String
-parseSegment = do
-  pp <- A.many' $ A.choice [
-    escapeURI <$> A.takeWhile isPathChar,
-    do
-      A.string "%"
-      c0 <- AA.anyWord8
-      c1 <- AA.anyWord8
-      let n' = do
-            n0 <- fromHex c0
-            n1 <- fromHex c1
-            return $ 16*n0 + n1
-      case n' of
-        Nothing -> fail "Invalid URI character escaping"
-        Just n -> return . BS.pack $ if isUnquoted n
-                            then [n]
-                            else [asWord8 '%', c0, c1]
-    ]
-  string "/" <|> return "" -- Segments end on a slash, colon, or end of input
-  return . s . BS.concat $ pp
-  where
-    isPathChar :: Char -> Bool
-    isPathChar c = (C.isAscii c && C.isAlphaNum c) || elem c ("_-=[]{}()." :: String)
-    escapeURI = BS.pack . normalizePath . BS.unpack
-    normalizePath :: [Word8] -> [Word8]
-    normalizePath [] = []
-    normalizePath (p:pp)
-      | isReserved p = p : normalizePath pp
-      | isUnquoted p = p : normalizePath pp
-      | otherwise = let
-        c0 = asWord8 '%'
-        c1 = div p 16
-        c2 = mod p 16
-        in c0:c1:c2: normalizePath pp
-    fromHex p
-      | p >= asWord8 '0' && p <= asWord8 '9' = Just $ p - asWord8 '0'
-      | p >= asWord8 'a' && p <= asWord8 'z' = Just $ 10 + p - asWord8 'a'
-      | p >= asWord8 'A' && p <= asWord8 'Z' = Just $ 10 + p - asWord8 'A'
-      | otherwise = Nothing
-    isReserved :: Word8 -> Bool
-    isReserved x = elem x $ fmap asWord8
-                   [':', '/', '?', '#', '[', ']', '@', '!', '$', '&',
-                    '\'', '(', ')', '*', '+', ',', ';', '=']
-    isUnquoted :: Word8 -> Bool
-    isUnquoted x =
-      inRange x '=' '9' ||
-      inRange x 'A' 'Z' ||
-      (x == asWord8 '_') ||
-      inRange x 'a' 'z'
-    inRange x b e = x >= asWord8 b && x <= asWord8 e
-    asWord8 :: Char -> Word8
-    asWord8 = fromIntegral . C.ord
-    
-
-parseRevision :: Parser (Maybe Revision)
-parseRevision =
-  A.choice [
-    do
-      string ":"
-      Just . Revision . s <$> A.takeWhile isRevisionChar,
-    return Nothing
-    ]
-  where
-    isRevisionChar :: Char -> Bool
-    isRevisionChar c = C.isAlphaNum c || elem c ("+-_=." :: String)
+  remURI <- A.takeWhile N.isAllowedInURI
+  let u' = do
+        u <- N.parseURI $ "fCMTP://" ++ s remURI
+        a <- N.uriAuthority u
+        return (u, a)
+  case u' of
+    Nothing -> fail "Not a valid URI"
+    Just (uri, auth) -> do
+      let au = N.uriUserInfo $ auth
+          ah = N.uriRegName auth
+      ac <- case A.parseOnly parseAccount (s $ au++ah) of
+        Left e -> fail e
+        Right ac -> return ac
+      let (p, r) = break (==':') . N.uriPath $ uri
+          pp = splitOn "/" p
+          qq = if null . N.uriQuery $ uri
+               then []
+               else map (\(x, y) -> (drop 1 x, drop 1 y)) . map (break (=='=')) . splitOn "&" . N.uriQuery $ uri
+      unless (null . N.uriPort $ auth) $ fail "fCMTP URIs must not determine a port"
+      return $ URI ac (Path pp) (Just . Revision . drop 1 $ r) (map (\(x, y) -> Parameter x y) qq)

src/Data/SMTP/Types/URI.hs

@@ -2,6 +2,7 @@
 
 module Data.SMTP.Types.URI where
 
+import qualified Network.URI as N
 import Data.SMTP.Account
 import Data.List
 
@@ -9,19 +10,29 @@ import Text.StringConvert
 
 newtype Path = Path [String] deriving (Eq, Ord, Read, Show)
 newtype Revision = Revision String deriving (Eq, Ord, Read, Show)
+data Parameter = Parameter String String deriving (Eq, Ord, Read, Show)
 
-data URI = URI {account :: Account, path :: Path, revision :: Maybe Revision} 
+data URI = URI {account :: Account, path :: Path, revision :: Maybe Revision, parameters :: [Parameter]} 
          deriving (Eq, Ord, Read)
 
 fullPath :: URI -> String
-fullPath URI{path=Path p} = "/" ++ intercalate "/" p
+fullPath URI{path=Path p} = intercalate "/" $ map uriEncode p
 
 fullURI :: URI -> String
-fullURI u@(URI{account=a, revision=r}) =
-  concat $ ["FCMTP://", s . fullAccount $ a, fullPath u] ++
-  case r of
-    Nothing -> []
-    Just (Revision r') -> [":", r']
-
+fullURI u@(URI{account=a, revision=r, parameters=pp}) =
+  concat $ ["FCMTP://", s . fullAccount $ a, fullPath u] ++ (
+    case r of
+      Nothing -> []
+      Just (Revision r') -> [":", r']
+    ) ++ (
+    if null pp
+    then []
+    else ["?", intercalate "&" $ map formatParameter pp]
+    )
+  where
+    formatParameter (Parameter nm vl) = concat [uriEncode nm, "=", uriEncode vl]
+
+uriEncode = N.escapeURIString N.isUnescapedInURIComponent
+    
 instance Show URI where
-  show = toString . fullURI
+  show = fullURI