Add Hostname type, `hostname' creator, and Attoparsec hostname validation

examples/echoclient/EchoClient.hs

@@ -31,7 +31,7 @@ import           System.Log.Handler.Simple
 import           System.Log.Logger
 
 -- Server and authentication details.
-realm    = "species64739.dyndns.org"
+realm    = fromJust $ hostname "species64739.dyndns.org"
 username = "echo"
 password = "pwd"
 resource = Just "bot"

source/Network/Xmpp.hs

@@ -154,7 +154,8 @@ module Network.Xmpp
                , AuthSaslFailure
                , AuthIllegalCredentials
                , AuthOtherFailure )
-
+  , Hostname
+  , hostname
   ) where
 
 import Network

source/Network/Xmpp/Concurrent.hs

@@ -132,7 +132,7 @@ writeWorker stCh writeR = forever $ do
 -- value, @session@ will attempt to secure the connection with TLS. If the fifth
 -- parameters is a 'Just' value, @session@ will attempt to authenticate and
 -- acquire an XMPP resource.
-session :: Text                              -- ^ The realm host name
+session :: Hostname                          -- ^ The realm host name
         -> Maybe TLS.TLSParams               -- ^ TLS settings, if securing the
                                              -- connection to the server is
                                              -- desired

source/Network/Xmpp/Sasl/Mechanisms/DigestMd5.hs

@@ -45,8 +45,8 @@ xmppDigestMd5 ::  Text -- ^ Authentication identity (authzid or username)
                -> ErrorT AuthFailure (StateT Stream IO) ()
 xmppDigestMd5 authcid authzid password = do
     (ac, az, pw) <- prepCredentials authcid authzid password
-    hn <- gets streamHostname
+    Just (Hostname hn) <- gets streamHostname
-    xmppDigestMd5' (fromJust hn) ac az pw
+    xmppDigestMd5' hn ac az pw
   where
     xmppDigestMd5' :: Text -> Text -> Maybe Text -> Text -> ErrorT AuthFailure (StateT Stream IO) ()
     xmppDigestMd5' hostname authcid authzid password = do

source/Network/Xmpp/Stream.hs

@@ -113,7 +113,7 @@ startStream = runErrorT $ do
     case streamHostname state of
         Nothing -> throwError $ XmppOtherFailure "server sent no hostname"
                    -- TODO: When does this happen?
-        Just hostname -> lift $ do
+        Just (Hostname hostname) -> lift $ do
             pushXmlDecl
             pushOpenElement $
                 pickleElem xpStream ( "1.0"
@@ -134,7 +134,7 @@ startStream = runErrorT $ do
             closeStreamWithError StreamInvalidXml Nothing
                 "stream has no language tag"
         -- If `from' is set, we verify that it's the correct one. TODO: Should we check against the realm instead?
-        | isJust from && (from /= Just (Jid Nothing (fromJust $ streamHostname state) Nothing)) ->
+        | isJust from && (from /= Just (Jid Nothing (Text.pack $ show $ fromJust $ streamHostname state) Nothing)) ->
             closeStreamWithError StreamInvalidFrom Nothing
                 "stream from is invalid"
         | to /= expectedTo ->
@@ -258,7 +258,7 @@ streamS expectedTo = do
 
 -- | Connects to the XMPP server and opens the XMPP stream against the given
 -- realm.
-openStream :: Text -> StreamConfiguration -> IO (Either XmppFailure (TMVar Stream))
+openStream :: Hostname -> StreamConfiguration -> IO (Either XmppFailure (TMVar Stream))
 openStream realm config = runErrorT $ do
     stream' <- createStream realm config
     result <- liftIO $ withStream startStream stream'
@@ -409,8 +409,8 @@ xmppNoStream = Stream {
     zeroSource :: Source IO output
     zeroSource = liftIO . ExL.throwIO $ XmppOtherFailure "zeroSource"
 
-createStream :: Text -> StreamConfiguration -> ErrorT XmppFailure IO (TMVar Stream)
+createStream :: Hostname -> StreamConfiguration -> ErrorT XmppFailure IO (TMVar Stream)
-createStream realm config = do
+createStream (Hostname realm) config = do
     result <- connect realm config
     case result of
         Just h -> ErrorT $ do
@@ -439,7 +439,7 @@ createStream realm config = do
                   , streamHandle = hand
                   , streamEventSource = eSource
                   , streamFeatures = StreamFeatures Nothing [] []
-                  , streamHostname = (Just realm)
+                  , streamHostname = (Just $ Hostname realm)
                   , streamFrom = Nothing
                   , streamId = Nothing
                   , streamLang = Nothing

source/Network/Xmpp/Types.hs

@@ -44,6 +44,8 @@ module Network.Xmpp.Types
     , fromTexts
     , StreamEnd(..)
     , InvalidXmppXml(..)
+    , Hostname(..)
+    , hostname
     )
        where
 
@@ -806,7 +808,7 @@ data Stream = Stream
       -- | Stream features advertised by the server
     , streamFeatures :: !StreamFeatures -- TODO: Maybe?
       -- | The hostname we specified for the connection
-    , streamHostname :: !(Maybe Text)
+    , streamHostname :: !(Maybe Hostname)
       -- | The hostname specified in the server's stream element's
       -- `from' attribute
     , streamFrom :: !(Maybe Jid)
@@ -1039,3 +1041,39 @@ instance Default StreamConfiguration where
                               , hardcodedTcpDetails = Nothing
                               , resolvConf = defaultResolvConf
                               }
+
+data Hostname = Hostname Text deriving (Eq, Show)
+
+instance Read Hostname where
+  readsPrec _ x = case hostname (Text.pack x) of
+      Nothing -> []
+      Just h -> [(h,"")]
+
+instance IsString Hostname where
+  fromString = fromJust . hostname . Text.pack
+
+-- | Validates the hostname string in accordance with RFC 1123.
+hostname :: Text -> Maybe Hostname
+hostname t = do
+    eitherToMaybeHostname $ AP.parseOnly hostnameP t
+  where
+    eitherToMaybeHostname = either (const Nothing) (Just . Hostname)
+
+-- Validation of RFC 1123 hostnames.
+hostnameP :: AP.Parser Text
+hostnameP = do
+    -- Hostnames may not begin with a hyphen.
+    h <- AP.satisfy $ AP.inClass $ ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9']
+    t <- AP.takeWhile $ AP.inClass $ ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ ['-']
+    let label = Text.concat [Text.pack [h], t]
+    if Text.length label > 63
+        then fail "Label too long."
+        else do
+            AP.endOfInput
+            return label
+            <|> do
+                _ <- AP.satisfy (== '.')
+                r <- hostnameP
+                if (Text.length label) + 1 + (Text.length r) > 255
+                    then fail "Hostname too long."
+                    else return $ Text.concat [label, Text.pack ".", r]