|
|
|
@ -70,13 +70,13 @@ tls con = Ex.handle (return . Left . TlsError) |
|
|
|
(RefuseTls , Just True) -> throwError XmppOtherFailure |
|
|
|
(RefuseTls , Just True) -> throwError XmppOtherFailure |
|
|
|
(RefuseTls , _ ) -> skipTls |
|
|
|
(RefuseTls , _ ) -> skipTls |
|
|
|
where |
|
|
|
where |
|
|
|
skipTls = liftIO $ infoM "Pontarius.Xmpp" "Skipping TLS negotiation" |
|
|
|
skipTls = liftIO $ infoM "Pontarius.Xmpp.Tls" "Skipping TLS negotiation" |
|
|
|
startTls = do |
|
|
|
startTls = do |
|
|
|
liftIO $ infoM "Pontarius.Xmpp" "Running StartTLS" |
|
|
|
liftIO $ infoM "Pontarius.Xmpp.Tls" "Running StartTLS" |
|
|
|
params <- gets $ tlsParams . streamConfiguration |
|
|
|
params <- gets $ tlsParams . streamConfiguration |
|
|
|
sent <- ErrorT $ pushElement starttlsE |
|
|
|
sent <- ErrorT $ pushElement starttlsE |
|
|
|
unless sent $ do |
|
|
|
unless sent $ do |
|
|
|
liftIO $ errorM "Pontarius.Xmpp" "startTls: Could not sent stanza." |
|
|
|
liftIO $ errorM "Pontarius.Xmpp.Tls" "Could not sent stanza." |
|
|
|
throwError XmppOtherFailure |
|
|
|
throwError XmppOtherFailure |
|
|
|
answer <- lift $ pullElement |
|
|
|
answer <- lift $ pullElement |
|
|
|
case answer of |
|
|
|
case answer of |
|
|
|
@ -87,8 +87,8 @@ tls con = Ex.handle (return . Left . TlsError) |
|
|
|
liftIO $ errorM "Pontarius.Xmpp" "startTls: TLS initiation failed." |
|
|
|
liftIO $ errorM "Pontarius.Xmpp" "startTls: TLS initiation failed." |
|
|
|
throwError XmppOtherFailure |
|
|
|
throwError XmppOtherFailure |
|
|
|
Right r -> |
|
|
|
Right r -> |
|
|
|
liftIO $ errorM "Pontarius.Xmpp" $ |
|
|
|
liftIO $ errorM "Pontarius.Xmpp.Tls" $ |
|
|
|
"startTls: Unexpected element: " ++ show r |
|
|
|
"Unexpected element: " ++ show r |
|
|
|
hand <- gets streamHandle |
|
|
|
hand <- gets streamHandle |
|
|
|
(_raw, _snk, psh, recv, ctx) <- lift $ tlsinit params (mkBackend hand) |
|
|
|
(_raw, _snk, psh, recv, ctx) <- lift $ tlsinit params (mkBackend hand) |
|
|
|
let newHand = StreamHandle { streamSend = catchPush . psh |
|
|
|
let newHand = StreamHandle { streamSend = catchPush . psh |
|
|
|
@ -97,7 +97,7 @@ tls con = Ex.handle (return . Left . TlsError) |
|
|
|
, streamClose = bye ctx >> streamClose hand |
|
|
|
, streamClose = bye ctx >> streamClose hand |
|
|
|
} |
|
|
|
} |
|
|
|
lift $ modify ( \x -> x {streamHandle = newHand}) |
|
|
|
lift $ modify ( \x -> x {streamHandle = newHand}) |
|
|
|
liftIO $ infoM "Pontarius.Xmpp" "Stream Secured." |
|
|
|
liftIO $ infoM "Pontarius.Xmpp.Tls" "Stream Secured." |
|
|
|
either (lift . Ex.throwIO) return =<< lift restartStream |
|
|
|
either (lift . Ex.throwIO) return =<< lift restartStream |
|
|
|
modify (\s -> s{streamConnectionState = Secured}) |
|
|
|
modify (\s -> s{streamConnectionState = Secured}) |
|
|
|
return () |
|
|
|
return () |
|
|
|
@ -119,13 +119,13 @@ tlsinit :: (MonadIO m, MonadIO m1) => |
|
|
|
, Context |
|
|
|
, Context |
|
|
|
) |
|
|
|
) |
|
|
|
tlsinit params backend = do |
|
|
|
tlsinit params backend = do |
|
|
|
liftIO $ debugM "Pontarius.Xmpp.TLS" "TLS with debug mode enabled." |
|
|
|
liftIO $ debugM "Pontarius.Xmpp.Tls" "TLS with debug mode enabled." |
|
|
|
gen <- liftIO $ getSystemRandomGen -- TODO: Find better random source? |
|
|
|
gen <- liftIO $ getSystemRandomGen -- TODO: Find better random source? |
|
|
|
con <- client params gen backend |
|
|
|
con <- client params gen backend |
|
|
|
handshake con |
|
|
|
handshake con |
|
|
|
let src = forever $ do |
|
|
|
let src = forever $ do |
|
|
|
dt <- liftIO $ recvData con |
|
|
|
dt <- liftIO $ recvData con |
|
|
|
liftIO $ debugM "Pontarius.Xmpp.TLS" ("In :" ++ BSC8.unpack dt) |
|
|
|
liftIO $ debugM "Pontarius.Xmpp.Tls" ("In :" ++ BSC8.unpack dt) |
|
|
|
yield dt |
|
|
|
yield dt |
|
|
|
let snk = do |
|
|
|
let snk = do |
|
|
|
d <- await |
|
|
|
d <- await |
|
|
|
|