diff --git a/examples/echoclient/EchoClient.hs b/examples/echoclient/EchoClient.hs index 6b44404..e69be62 100644 --- a/examples/echoclient/EchoClient.hs +++ b/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" diff --git a/source/Network/Xmpp.hs b/source/Network/Xmpp.hs index e384f62..39d7812 100644 --- a/source/Network/Xmpp.hs +++ b/source/Network/Xmpp.hs @@ -154,7 +154,8 @@ module Network.Xmpp , AuthSaslFailure , AuthIllegalCredentials , AuthOtherFailure ) - + , Hostname + , hostname ) where import Network diff --git a/source/Network/Xmpp/Concurrent.hs b/source/Network/Xmpp/Concurrent.hs index 451bb97..1f6eb45 100644 --- a/source/Network/Xmpp/Concurrent.hs +++ b/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 diff --git a/source/Network/Xmpp/Sasl/Mechanisms/DigestMd5.hs b/source/Network/Xmpp/Sasl/Mechanisms/DigestMd5.hs index dfb9710..06cc93e 100644 --- a/source/Network/Xmpp/Sasl/Mechanisms/DigestMd5.hs +++ b/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 - xmppDigestMd5' (fromJust hn) ac az pw + Just (Hostname hn) <- gets streamHostname + xmppDigestMd5' hn ac az pw where xmppDigestMd5' :: Text -> Text -> Maybe Text -> Text -> ErrorT AuthFailure (StateT Stream IO) () xmppDigestMd5' hostname authcid authzid password = do diff --git a/source/Network/Xmpp/Stream.hs b/source/Network/Xmpp/Stream.hs index 0c7f908..80a9e69 100644 --- a/source/Network/Xmpp/Stream.hs +++ b/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 realm config = do +createStream :: Hostname -> StreamConfiguration -> ErrorT XmppFailure IO (TMVar Stream) +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 diff --git a/source/Network/Xmpp/Types.hs b/source/Network/Xmpp/Types.hs index 315db1d..2e22c28 100644 --- a/source/Network/Xmpp/Types.hs +++ b/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]