asakul
/
pontarius-xmpp
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity
Browse Source

cleaned up the TLS and Stream modules

master
Jon Kristensen 15 years ago
parent
a27609bced
commit
e3929e7ab0
2 changed files with 83 additions and 105 deletions
Whitespace
Show all changes Ignore whitespace when comparing lines Ignore changes in amount of whitespace Ignore changes in whitespace at EOL
Unified View
Diff Options
Show Stats Download Patch File Download Diff File
  1. 142
      Network/XMPP/Stream.hs
  2. 46
      Network/XMPP/TLS.hs

142
Network/XMPP/Stream.hs
Unescape View File

@ -6,7 +6,6 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
module Network.XMPP.Stream ( module Network.XMPP.Stream (
isTLSSecured,
xmlEnumerator, xmlEnumerator,
presenceToXML, presenceToXML,
iqToXML, iqToXML,
@ -19,78 +18,59 @@ versionFromString,
versionFromNumbers versionFromNumbers
) where ) where
import Network.XMPP.Address hiding (fromString)
import qualified Network.XMPP.Address as X
import Network.XMPP.Types hiding (Continue) import Network.XMPP.Types hiding (Continue)
import Network.XMPP.Utilities
import Network.XMPP.TLS
import Network.XMPP.Stanza
import qualified Control.Exception as CE
import Control.Concurrent.Chan (Chan, newChan, readChan, writeChan)
import GHC.IO.Handle (Handle, hPutStr, hFlush, hSetBuffering, hWaitForInput)
import Network.TLS hiding (Version)
import Network.TLS.Cipher
import Data.Enumerator (($$), Iteratee, continue, joinI,
run, run_, yield)
import Data.Enumerator.Binary (enumHandle, enumFile)
import Text.XML.Enumerator.Parse (parseBytes, decodeEntities)
import Text.XML.Enumerator.Document (fromEvents)
import qualified Data.ByteString as DB
import qualified Data.ByteString.Lazy as DBL (ByteString, append, pack, fromChunks, toChunks, null)
import qualified Data.ByteString.Lazy.Char8 as DBLC (append, pack, unpack)
import qualified Data.List as DL
import qualified Data.Text as DT
import qualified Data.Text.Lazy as DTL
import Data.Maybe
import Data.XML.Types
import Control.Monad.IO.Class (liftIO, MonadIO) import Prelude hiding (null)
import Data.String (IsString(..))
import Control.Concurrent.Chan (Chan, writeChan)
import Control.Exception.Base (SomeException)
import Control.Monad.IO.Class (liftIO)
import Data.ByteString.Lazy (null, toChunks)
import Data.Enumerator ((>>==), ($$), Iteratee (..), Enumeratee, Step (..), Enumerator (..), Stream (Chunks), returnI, joinI, run)
import Data.Enumerator.Binary (enumHandle)
import Data.Maybe (fromJust, isJust)
import Data.Text (pack, unpack)
import Data.XML.Types (Content (..), Document (..), Element (..), Event (..), Name (..), Node (..))
import GHC.IO.Handle (Handle)
import Network.TLS (TLSCtx, recvData)
import Text.Parsec (char, count, digit, eof, many, many1, oneOf, parse) import Text.Parsec (char, count, digit, eof, many, many1, oneOf, parse)
import Text.Parsec.ByteString (GenParser) import Text.Parsec.ByteString (GenParser)
import Text.XML.Enumerator.Document (fromEvents)
import Text.XML.Enumerator.Parse (parseBytes, decodeEntities)
import qualified Data.ByteString as DB (ByteString)
import qualified Data.ByteString.Char8 as DBC (pack) import qualified Data.ByteString.Char8 as DBC (pack)
import Data.Enumerator ((>>==), Iteratee (..), Enumeratee, Step (..), Enumerator (..), Stream (Chunks), returnI)
import qualified Data.Enumerator.List as DEL (head) import qualified Data.Enumerator.List as DEL (head)
import Control.Exception.Base (SomeException)
isTLSSecured :: TLSState -> Bool
isTLSSecured (PostHandshake _) = True
isTLSSecured _ = False
-- Reads from the provided handle or TLS context and sends the events to the -- Reads from the provided handle or TLS context and sends the events to the
-- internal event channel. -- internal event channel.
xmlEnumerator :: Chan (InternalEvent s m) -> Either Handle TLSCtx -> IO () xmlEnumerator :: Chan (InternalEvent s m) -> Either Handle TLSCtx -> IO ()
xmlEnumerator c s = do xmlEnumerator c s = do
enumeratorResult <- case s of enumeratorResult <- case s of
Left handle -> run $ enumHandle 1 handle $$ joinI $ Left handle -> run $ enumHandle 1 handle $$ joinI $
parseBytes decodeEntities $$ eventConsumer c [] 0 parseBytes decodeEntities $$ eventConsumer c [] 0
Right tlsCtx -> run $ enumTLS tlsCtx $$ joinI $ Right tlsCtx -> run $ enumTLS tlsCtx $$ joinI $
parseBytes decodeEntities $$ eventConsumer c [] 0 parseBytes decodeEntities $$ eventConsumer c [] 0
case enumeratorResult of case enumeratorResult of
Right _ -> Right _ -> writeChan c $ IEE EnumeratorDone
writeChan c $ IEE EnumeratorDone Left e -> writeChan c $ IEE (EnumeratorException e)
Left e -> where
writeChan c $ IEE (EnumeratorException e) -- Behaves like enumHandle, but reads from the TLS context instead
where -- TODO: Type?
-- Behaves like enumHandle, but reads from the TLS context instead enumTLS :: TLSCtx -> Enumerator DB.ByteString IO b
enumTLS :: TLSCtx -> Enumerator DB.ByteString IO b enumTLS c s = loop c s
enumTLS c s = loop c s
-- TODO: Type?
loop :: TLSCtx -> Step DB.ByteString IO b -> Iteratee DB.ByteString IO b loop :: TLSCtx -> Step DB.ByteString IO b -> Iteratee DB.ByteString IO b
loop c (Continue k) = do loop c (Continue k) = do
d <- recvData c d <- recvData c
case DBL.null d of case null d of
True -> loop c (Continue k) True -> loop c (Continue k)
False -> k (Chunks $ DBL.toChunks d) >>== loop c False -> k (Chunks $ toChunks d) >>== loop c
loop _ step = returnI step loop _ step = returnI step
-- Consumes XML events from the input stream, accumulating as necessary, and -- Consumes XML events from the input stream, accumulating as necessary, and
@ -103,7 +83,7 @@ eventConsumer :: Chan (InternalEvent s m) -> [Event] -> Int ->
-- <stream:stream> open event received. -- <stream:stream> open event received.
eventConsumer chan [EventBeginElement (Name localName namespace prefixName) attribs] 0 eventConsumer chan [EventBeginElement (Name localName namespace prefixName) attribs] 0
| localName == DT.pack "stream" && isJust prefixName && fromJust prefixName == DT.pack "stream" = do | localName == pack "stream" && isJust prefixName && fromJust prefixName == pack "stream" = do
liftIO $ writeChan chan $ IEE $ EnumeratorBeginStream from to id ver lang ns liftIO $ writeChan chan $ IEE $ EnumeratorBeginStream from to id ver lang ns
eventConsumer chan [] 1 eventConsumer chan [] 1
where where
@ -112,12 +92,12 @@ eventConsumer chan [EventBeginElement (Name localName namespace prefixName) attr
id = case lookup "id" attribs of Nothing -> Nothing; Just idAttrib -> Just $ show idAttrib id = case lookup "id" attribs of Nothing -> Nothing; Just idAttrib -> Just $ show idAttrib
ver = case lookup "version" attribs of Nothing -> Nothing; Just verAttrib -> Just $ show verAttrib ver = case lookup "version" attribs of Nothing -> Nothing; Just verAttrib -> Just $ show verAttrib
lang = case lookup "xml:lang" attribs of Nothing -> Nothing; Just langAttrib -> Just $ show langAttrib lang = case lookup "xml:lang" attribs of Nothing -> Nothing; Just langAttrib -> Just $ show langAttrib
ns = case namespace of Nothing -> Nothing; Just namespaceAttrib -> Just $ DT.unpack namespaceAttrib ns = case namespace of Nothing -> Nothing; Just namespaceAttrib -> Just $ unpack namespaceAttrib
-- <stream:stream> close event received. -- <stream:stream> close event received.
eventConsumer chan [EventEndElement name] 1 eventConsumer chan [EventEndElement name] 1
| namePrefix name == Just (DT.pack "stream") && nameLocalName name == DT.pack "stream" = do | namePrefix name == Just (pack "stream") && nameLocalName name == pack "stream" = do
liftIO $ writeChan chan $ IEE $ EnumeratorEndStream liftIO $ writeChan chan $ IEE $ EnumeratorEndStream
return Nothing return Nothing
@ -173,7 +153,7 @@ messageToXML (Right m) streamLang = Element "message" attribs nodes
-- Has the stanza attributes and the message type. -- Has the stanza attributes and the message type.
attribs :: [(Name, [Content])] attribs :: [(Name, [Content])]
attribs = stanzaAttribs (messageID m) (messageFrom m) (messageTo m) stanzaLang ++ attribs = stanzaAttribs (messageID m) (messageFrom m) (messageTo m) stanzaLang ++
[("type", [ContentText $ DT.pack $ show $ messageType m])] [("type", [ContentText $ pack $ show $ messageType m])]
-- Has an arbitrary number of elements as children. -- Has an arbitrary number of elements as children.
nodes :: [Node] nodes :: [Node]
@ -191,7 +171,7 @@ messageToXML (Left m) streamLang = Element "message" attribs nodes
-- Has the stanza attributes and the "error" presence type. -- Has the stanza attributes and the "error" presence type.
attribs :: [(Name, [Content])] attribs :: [(Name, [Content])]
attribs = stanzaAttribs (messageErrorID m) (messageErrorFrom m) (messageErrorTo m) attribs = stanzaAttribs (messageErrorID m) (messageErrorFrom m) (messageErrorTo m)
stanzaLang ++ [("type", [ContentText $ DT.pack "error"])] stanzaLang ++ [("type", [ContentText $ pack "error"])]
-- Has the error element stanza as its child. -- Has the error element stanza as its child.
-- TODO: Include sender XML here? -- TODO: Include sender XML here?
@ -227,7 +207,7 @@ presenceToXML (Right p) streamLang = Element "presence" attribs nodes
stanzaLang = stanzaLang' streamLang $ presenceLangTag p stanzaLang = stanzaLang' streamLang $ presenceLangTag p
typeAttrib :: [(Name, [Content])] typeAttrib :: [(Name, [Content])]
typeAttrib = case presenceType p of Nothing -> []; Just presenceType' -> [("type", [ContentText $ DT.pack $ show presenceType'])] typeAttrib = case presenceType p of Nothing -> []; Just presenceType' -> [("type", [ContentText $ pack $ show presenceType'])]
-- Presence error. -- Presence error.
@ -238,7 +218,7 @@ presenceToXML (Left p) streamLang = Element "presence" attribs nodes
-- Has the stanza attributes and the "error" presence type. -- Has the stanza attributes and the "error" presence type.
attribs :: [(Name, [Content])] attribs :: [(Name, [Content])]
attribs = stanzaAttribs (presenceErrorID p) (presenceErrorFrom p) (presenceErrorTo p) attribs = stanzaAttribs (presenceErrorID p) (presenceErrorFrom p) (presenceErrorTo p)
stanzaLang ++ [("type", [ContentText $ DT.pack "error"])] stanzaLang ++ [("type", [ContentText $ pack "error"])]
-- Has the error element stanza as its child. -- Has the error element stanza as its child.
-- TODO: Include sender XML here? -- TODO: Include sender XML here?
@ -276,7 +256,7 @@ iqToXML (Left i) streamLang = Element "iq" attribs nodes
-- The required type attribute. -- The required type attribute.
typeAttrib :: [(Name, [Content])] typeAttrib :: [(Name, [Content])]
typeAttrib = [("type", [ContentText $ DT.pack $ show $ iqRequestType i])] typeAttrib = [("type", [ContentText $ pack $ show $ iqRequestType i])]
-- Response result IQ. -- Response result IQ.
@ -298,7 +278,7 @@ iqToXML (Right (Right i)) streamLang = Element "iq" attribs nodes
-- The required type attribute. -- The required type attribute.
typeAttrib :: [(Name, [Content])] typeAttrib :: [(Name, [Content])]
typeAttrib = [("type", [ContentText $ DT.pack "result"])] typeAttrib = [("type", [ContentText $ pack "result"])]
-- Response error IQ. -- Response error IQ.
@ -319,7 +299,7 @@ iqToXML (Right (Left i)) streamLang = Element "iq" attribs nodes
stanzaLang = stanzaLang' streamLang $ iqErrorLangTag i stanzaLang = stanzaLang' streamLang $ iqErrorLangTag i
typeAttrib :: [(Name, [Content])] typeAttrib :: [(Name, [Content])]
typeAttrib = [("type", [ContentText $ DT.pack "error"])] typeAttrib = [("type", [ContentText $ pack "error"])]
-- Creates the error element that is common for all stanzas. -- Creates the error element that is common for all stanzas.
@ -333,11 +313,11 @@ errorElem streamLang stanzaLang stanzaError = Element "error" typeAttrib
-- The required stanza error type. -- The required stanza error type.
typeAttrib :: [(Name, [Content])] typeAttrib :: [(Name, [Content])]
typeAttrib = [("type", [ContentText $ DT.pack $ show $ stanzaErrorType stanzaError])] typeAttrib = [("type", [ContentText $ pack $ show $ stanzaErrorType stanzaError])]
-- The required defined condition element. -- The required defined condition element.
defCondElem :: Node defCondElem :: Node
defCondElem = NodeElement $ Element (Name (DT.pack $ show $ stanzaErrorCondition stanzaError) (Just $ DT.pack "urn:ietf:params:xml:ns:xmpp-stanzas") Nothing) [] [] defCondElem = NodeElement $ Element (Name (pack $ show $ stanzaErrorCondition stanzaError) (Just $ pack "urn:ietf:params:xml:ns:xmpp-stanzas") Nothing) [] []
-- The optional text element. -- The optional text element.
@ -347,7 +327,7 @@ errorElem streamLang stanzaLang stanzaError = Element "error" typeAttrib
Just (textLang, text) -> Just (textLang, text) ->
[NodeElement $ Element "{urn:ietf:params:xml:ns:xmpp-stanzas}text" [NodeElement $ Element "{urn:ietf:params:xml:ns:xmpp-stanzas}text"
(langTagAttrib $ childLang streamLang [stanzaLang, fst $ fromJust $ stanzaErrorText stanzaError]) (langTagAttrib $ childLang streamLang [stanzaLang, fst $ fromJust $ stanzaErrorText stanzaError])
[NodeContent $ ContentText $ DT.pack text]] [NodeContent $ ContentText $ pack text]]
-- The optional application specific condition element. -- The optional application specific condition element.
appSpecCondElem :: [Node] appSpecCondElem :: [Node]
@ -360,7 +340,7 @@ errorElem streamLang stanzaLang stanzaError = Element "error" typeAttrib
langTagAttrib :: Maybe LangTag -> [(Name, [Content])] langTagAttrib :: Maybe LangTag -> [(Name, [Content])]
langTagAttrib lang = case lang of Nothing -> []; Just lang' -> [("xml:lang", [ContentText $ DT.pack $ show lang'])] langTagAttrib lang = case lang of Nothing -> []; Just lang' -> [("xml:lang", [ContentText $ pack $ show lang'])]
stanzaLang' :: LangTag -> LangTag -> Maybe LangTag stanzaLang' :: LangTag -> LangTag -> Maybe LangTag
@ -403,10 +383,10 @@ childLang streamLang optLangTags
stanzaAttribs :: Maybe StanzaID -> Maybe From -> Maybe To -> Maybe LangTag -> [(Name, [Content])] stanzaAttribs :: Maybe StanzaID -> Maybe From -> Maybe To -> Maybe LangTag -> [(Name, [Content])]
stanzaAttribs i f t l = if isJust $ i then [("id", [ContentText $ DT.pack $ show $ fromJust i])] else [] ++ stanzaAttribs i f t l = if isJust $ i then [("id", [ContentText $ pack $ show $ fromJust i])] else [] ++
if isJust $ f then [("from", [ContentText $ DT.pack $ show $ fromJust f])] else [] ++ if isJust $ f then [("from", [ContentText $ pack $ show $ fromJust f])] else [] ++
if isJust $ t then [("to", [ContentText $ DT.pack $ show $ fromJust t])] else [] ++ if isJust $ t then [("to", [ContentText $ pack $ show $ fromJust t])] else [] ++
if isJust $ l then [("xml:lang", [ContentText $ DT.pack $ show l])] else [] if isJust $ l then [("xml:lang", [ContentText $ pack $ show l])] else []
parseIQ :: Element -> IQ parseIQ :: Element -> IQ
@ -424,6 +404,9 @@ parseMessage :: Element -> InternalMessage
parseMessage = parseMessage parseMessage = parseMessage
-- Converts a string to a PresenceType. Nothing means convertion error, Just
-- Nothing means the presence error type, and Just $ Just is the PresenceType.
stringToPresenceType :: String -> Maybe (Maybe PresenceType) stringToPresenceType :: String -> Maybe (Maybe PresenceType)
stringToPresenceType "probe" = Just $ Just Probe stringToPresenceType "probe" = Just $ Just Probe
@ -436,6 +419,8 @@ stringToPresenceType "error" = Just Nothing
stringToPresenceType _ = Nothing stringToPresenceType _ = Nothing
-- Converts a Maybe MessageType to a string. Nothing means "error".
presenceTypeToString :: Maybe PresenceType -> String presenceTypeToString :: Maybe PresenceType -> String
presenceTypeToString (Just Unavailable) = "unavailable" presenceTypeToString (Just Unavailable) = "unavailable"
@ -447,6 +432,9 @@ presenceTypeToString (Just Unsubscribe) = "unsubscribe"
presenceTypeToString (Just Unsubscribed) = "unsubscribed" presenceTypeToString (Just Unsubscribed) = "unsubscribed"
-- Converts a string to a MessageType. Nothing means convertion error, Just
-- Nothing means the message error type, and Just $ Just is the MessageType.
stringToMessageType :: String -> Maybe (Maybe MessageType) stringToMessageType :: String -> Maybe (Maybe MessageType)
stringToMessageType "chat" = Just $ Just Chat stringToMessageType "chat" = Just $ Just Chat
@ -457,6 +445,8 @@ stringToMessageType "normal" = Just $ Just Normal
stringToMessageType _ = Nothing stringToMessageType _ = Nothing
-- Converts a Maybe MessageType to a string. Nothing means "error".
messageTypeToString :: Maybe MessageType -> String messageTypeToString :: Maybe MessageType -> String
messageTypeToString (Just Chat) = "chat" messageTypeToString (Just Chat) = "chat"

46
Network/XMPP/TLS.hs
Unescape View File

@ -1,42 +1,30 @@
-- Copyright © 2010-2011 Jon Kristensen. See the LICENSE file in the Pontarius -- Copyright © 2010-2011 Jon Kristensen. See the LICENSE file in the Pontarius
-- XMPP distribution for more details. -- XMPP distribution for more details.
-- TODO: TLS12 when supported in tls; TODO: TLS11 results in a read error - bug?
-- TODO: cipher_AES128_SHA1 = TLS_RSA_WITH_AES_128_CBC_SHA?
-- TODO: Compression?
-- TODO: Validate certificate
{-# OPTIONS_HADDOCK hide #-} {-# OPTIONS_HADDOCK hide #-}
module Network.XMPP.TLS (tlsParams) where module Network.XMPP.TLS (tlsParams) where
import Network.TLS import Network.TLS (TLSCertificateUsage (CertificateUsageAccept),
import Network.TLS.Extra -- (cipher_AES128_SHA1) TLSParams (..), Version (SSL3, TLS10, TLS11),
import Network.TLS.Cipher defaultLogging, nullCompression)
import Crypto.Hash.SHA1 import Network.TLS.Extra (cipher_AES128_SHA1)
import GHC.IO.Handle (Handle, hPutStr, hFlush, hSetBuffering, hWaitForInput)
import Data.Time.Calendar
tlsParams :: TLSParams tlsParams :: TLSParams
tlsParams = TLSParams { pConnectVersion = TLS10 -- TODO: TLS12 when supported in tls; TODO: TLS11 results in a read error - bug? tlsParams = TLSParams { pConnectVersion = TLS10
, pAllowedVersions = [SSL3, TLS10,TLS11] -- TODO: TLS12 when supported in tls , pAllowedVersions = [SSL3, TLS10,TLS11]
, pCiphers = [cipher_AES128_SHA1] -- TODO: cipher_AES128_SHA1 = TLS_RSA_WITH_AES_128_CBC_SHA? , pCiphers = [cipher_AES128_SHA1]
, pCompressions = [nullCompression] -- TODO , pCompressions = [nullCompression]
, pWantClientCert = False -- Used for servers , pWantClientCert = False -- Used for servers
, pUseSecureRenegotiation = False -- TODO: No renegotiation! , pUseSecureRenegotiation = False -- No renegotiation
, pCertificates = [] -- TODO , pCertificates = [] -- TODO
, pLogging = defaultLogging -- TODO , pLogging = defaultLogging -- TODO
, onCertificatesRecv = \ certificate -> do , onCertificatesRecv = \ certificate ->
putStrLn "%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%" return CertificateUsageAccept }
putStrLn $ show certificate
putStrLn "0 !!!!!!!!!!!!!!!!!!!!!!!!!!!!! verify chain (will be false if self-signed - not the case)"
lolz <- certificateVerifyChain certificate
putStrLn $ show lolz
putStrLn "1 !!!!!!!!!!!!!!!!!!!!!!!!!!!!! self signed (only cas can be self-signed)"
putStrLn $ show $ certificateSelfSigned $ head certificate
putStrLn "2 !!!!!!!!!!!!!!!!!!!!!!!!!!!!! verify domain"
putStrLn $ show $ certificateVerifyDomain "jonkristensen.com" certificate
putStrLn "3 !!!!!!!!!!!!!!!!!!!!!!!!!!!!! verify validity"
putStrLn $ show $ certificateVerifyValidity (fromGregorian 2011 07 14) certificate
putStrLn "4 !!!!!!!!!!!!!!!!!!!!!!!!!!!!! fingerprint (didn't change when i changed last bytes - good!)"
putStrLn $ show $ certificateFingerprint hashlazy $ head certificate
putStrLn "%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%"
return CertificateUsageAccept } -- TODO

Write Preview
Loading…
Cancel
Save