work in JID.hs

src/Network/XMPP/JID.hs

@@ -15,183 +15,137 @@
 --
 -- This module does not internationalize hostnames.
 
-
 module Network.XMPP.JID (fromString, fromStrings, isBare, isFull) where
 
-import Network.XMPP.Types
+import           Control.Applicative ((<$>),(<|>))
-
+import           Control.Monad(guard)
-import Data.Maybe (fromJust, isJust)
-import Text.Parsec ((<|>), anyToken, char, eof, many, noneOf, parse)
-import Text.Parsec.ByteString (GenParser)
 
-import Text.StringPrep (StringPrepProfile (..), a1, b1, b2, c11, c12, c21, c22,
+import qualified Data.Attoparsec.Text as AP
-                        c3, c4, c5, c6, c7, c8, c9, runStringPrep)
+import           Data.Text (Text)
-import Text.NamePrep (namePrepProfile)
+import qualified Data.Text as Text
 
-import Network.URI (isIPv4address, isIPv6address)
+-- import           Network.URI (isIPv4address, isIPv6address)
-
+import           Network.XMPP.Types
-import qualified Data.ByteString.Char8 as DBC (pack)
-import qualified Data.Text as DT (pack, unpack)
 
+import qualified Text.NamePrep as SP
+import qualified Text.StringPrep as SP
 
 -- |
 -- Converts a string to a JID.
-
 fromString :: String -> Maybe JID
-
+fromString s = fromStrings l d r
-fromString s = fromStrings localpart domainpart resourcepart
     where
-        Right (localpart, domainpart, resourcepart) =
+        Right (l, d, r) =
-            parse jidParts "" (DBC.pack s)
+            AP.parseOnly jidParts (Text.pack s)
-
 
 -- |
 -- Converts localpart, domainpart, and resourcepart strings to a JID.
-
 -- Runs the appropriate stringprep profiles and validates the parts.
-
+fromStrings :: Maybe Text -> Text -> Maybe Text -> Maybe JID
-fromStrings :: Maybe String -> String -> Maybe String -> Maybe JID
+fromStrings l d r = do
-
+        localPart <- case l of
-fromStrings l s r
+          Nothing -> return Nothing
-  | domainpart == Nothing = Nothing
+          Just l'-> do
-  | otherwise = if validateNonDomainpart localpart &&
+            l'' <- SP.runStringPrep nodeprepProfile l'
-                   isJust domainpart' &&
+            guard $ validPartLength l''
-                   validateNonDomainpart resourcepart
+            return $ Just l''
-                then Just (JID localpart (fromJust domainpart') resourcepart)
+        domainPart <- SP.runStringPrep (SP.namePrepProfile False) d
-                else Nothing
+        guard $ validDomainPart domainPart
+        resourcePart <- case r of
+          Nothing -> return Nothing
+          Just r' -> do
+            r'' <- SP.runStringPrep resourceprepProfile r'
+            guard $ validPartLength r''
+            return $ Just r''
+        return $ JID localPart domainPart resourcePart
   where
-    
-    -- Applies the nodeprep profile on the localpart string, if any.
-    localpart :: Maybe String
-    localpart = case l of
-      Just l' -> case runStringPrep nodeprepProfile (DT.pack l') of
-        Just l'' -> Just $ DT.unpack l''
-        Nothing -> Nothing
-      Nothing -> Nothing
-
-    -- Applies the nameprep profile on the domainpart string.
-    -- TODO: Allow unassigned?
-    domainpart :: Maybe String
-    domainpart = case runStringPrep (namePrepProfile False) (DT.pack s) of
-      Just s' -> Just $ DT.unpack s'
-      Nothing -> Nothing
-
-    -- Applies the resourceprep profile on the resourcepart string, if
-    -- any.
-    resourcepart :: Maybe String
-    resourcepart = case r of
-      Just r' -> case runStringPrep resourceprepProfile (DT.pack r') of
-        Just r'' -> Just $ DT.unpack r''
-        Nothing -> Nothing
-      Nothing -> Nothing
-
     -- Returns the domainpart if it was a valid IP or if the toASCII
     -- function was successful, or Nothing otherwise.
-    domainpart' :: Maybe String
+    validDomainPart _s = True -- TODO
-    domainpart' | isIPv4address s || isIPv6address s = Just s
+      -- isIPv4address s || isIPv6address s || validHostname s
-                | validHostname s = Just s
-                | otherwise = Nothing
-
-    -- Validates that non-domainpart strings have an appropriate
-    -- length.
-    validateNonDomainpart :: Maybe String -> Bool
-    validateNonDomainpart Nothing = True
-    validateNonDomainpart (Just l) = validPartLength l
-      where
-        validPartLength :: String -> Bool
-        validPartLength p = length p > 0 && length p < 1024
 
+    validPartLength :: Text -> Bool
+    validPartLength p = Text.length p > 0 && Text.length p < 1024
     -- Validates a host name
-    validHostname :: String -> Bool
+    -- validHostname :: Text -> Bool
-    validHostname _ = True -- TODO
+    -- validHostname _ = True -- TODO
-
 
 -- | Returns True if the JID is `bare', and False otherwise.
-
 isBare :: JID -> Bool
-
 isBare j | resourcepart j == Nothing = True
          | otherwise                 = False
 
-
 -- | Returns True if the JID is `full', and False otherwise.
-
 isFull :: JID -> Bool
-
 isFull jid = not $ isBare jid
 
-
 -- Parses an JID string and returns its three parts. It performs no
 -- validation or transformations. We are using Parsec to parse the
 -- JIDs. There is no input for which 'jidParts' fails.
-
+jidParts :: AP.Parser (Maybe Text, Text, Maybe Text)
-jidParts :: GenParser Char st (Maybe String, String, Maybe String)
-
 jidParts = do
-
+  a <- firstPartP
-  -- Read until we reach an '@', a '/', or EOF.
+  b <- Just <$> domainPartP <|> (return Nothing)
-  a <- many $ noneOf ['@', '/']
+  c <- Just <$> resourcePartP <|> (return Nothing)
-
+  case (a,b,c) of
-  -- Case 1: We found an '@', and thus the localpart. At least the
+    -- Whether or not we have a resource part, if there is no "@"
-  -- domainpart is remaining. Read the '@' and until a '/' or EOF.
+    -- x is the domain
-  do
+    (x, Nothing, z) -> return (Nothing, x, z)
-    char '@'
+    -- When we do have an "@", x is the localpart
-    b <- many $ noneOf ['/']
+    (x, Just y, z) -> return (Just x, y, z)
-
+  where
-    -- Case 1A: We found a '/' and thus have all the JID parts. Read
+       firstPartP = AP.takeWhile1 (AP.notInClass ['@', '/'])
-    -- the '/' and until EOF.
+       domainPartP = do
-    do
+           _ <- AP.char '@'
-      char '/' -- Resourcepart remaining
+           AP.takeWhile1 (/= '/')
-      c <- many $ anyToken -- Parse resourcepart
+       resourcePartP = do
-      eof
+           _ <- AP.char '/'
-      return (Just a, b, Just c)
+           AP.takeText
-
+
-    -- Case 1B: We have reached EOF; the JID is in the form
+
-    -- localpart@domainpart.
+nodeprepProfile :: SP.StringPrepProfile
-      <|> do
+nodeprepProfile = SP.Profile
-        eof
+                             { SP.maps = [SP.b1, SP.b2]
-        return (Just a, b, Nothing)
+                             , SP.shouldNormalize = True
-
+                             , SP.prohibited = [SP.a1
-    -- Case 2: We found a '/'; the JID is in the form
+                                            , SP.c3
-    -- domainpart/resourcepart.
+                                            , SP.c4
-    <|> do
+                                            , SP.c5
-      char '/'
+                                            , SP.c6
-      b <- many $ anyToken
+                                            , SP.c7
-      eof
+                                            , SP.c8
-      return (Nothing, a, Just b)
+                                            , SP.c9
-
+                                            , SP.c11
-    -- Case 3: We have reached EOF; we have an JID consisting of only
+                                            , SP.c12
-    -- a domainpart.
+                                            , SP.c21
-    <|> do
+                                            , SP.c22
-      eof
+                                            ]
-      return (Nothing, a, Nothing)
+                             , SP.shouldCheckBidi = True
-
+                             }
-
-nodeprepProfile :: StringPrepProfile
-
-nodeprepProfile = Profile { maps = [b1, b2]
-                          , shouldNormalize = True
-                          , prohibited = [a1] ++ [c11, c12, c21, c22,
-                                                  c3, c4, c5, c6, c7,
-                                                  c8, c9]
-                          , shouldCheckBidi = True }
-
 
 -- These needs to be checked for after normalization. We could also
 -- look up the Unicode mappings and include a list of characters in
 -- the prohibited field above. Let's defer that until we know that we
 -- are going to use stringprep.
-
+nodeprepExtraProhibitedCharacters :: [Char]
 nodeprepExtraProhibitedCharacters = ['\x22', '\x26', '\x27', '\x2F',
                                      '\x3A', '\x3C', '\x3E', '\x40']
 
-
+resourceprepProfile :: SP.StringPrepProfile
-
+resourceprepProfile = SP.Profile
-resourceprepProfile :: StringPrepProfile
+                                 { SP.maps = [SP.b1]
-
+                                 , SP.shouldNormalize = True
-resourceprepProfile = Profile { maps = [b1]
+                                 , SP.prohibited = [ SP.a1
-                              , shouldNormalize = True
+                                                , SP.c3
-                              , prohibited = [a1] ++ [c12, c21, c22,
+                                                , SP.c4
-                                                      c3, c4, c5, c6,
+                                                , SP.c5
-                                                      c7, c8, c9]
+                                                , SP.c6
-                              , shouldCheckBidi = True }
+                                                , SP.c7
+                                                , SP.c8
+                                                , SP.c9
+                                                , SP.c12
+                                                , SP.c21
+                                                , SP.c22
+                                                ]
+                                 , SP.shouldCheckBidi = True
+                                 }