{-# OPTIONS_HADDOCK hide #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PackageImports #-}
{-# LANGUAGE FlexibleContexts #-}

module Network.Xmpp.Tls where

import                 Control.Applicative ((<$>))
import qualified       Control.Exception.Lifted as Ex
import                 Control.Monad
import                 Control.Monad.Except
import                 Control.Monad.State.Strict
import qualified       Data.ByteString as BS
import qualified       Data.ByteString.Char8 as BSC8
import qualified       Data.ByteString.Lazy as BL
import                 Data.Conduit
import                 Data.IORef
import                 Data.Monoid
import                 Data.XML.Types
import                 Network.DNS.Resolver (ResolvConf)
import                 Network.TLS
import                 Network.Xmpp.Stream
import                 Network.Xmpp.Types
import                 System.Log.Logger (debugM, errorM, infoM)
import                 System.X509

mkBackend :: StreamHandle -> Backend
mkBackend :: StreamHandle -> Backend
mkBackend StreamHandle
con = Backend { backendSend :: ByteString -> IO ()
backendSend = \ByteString
bs -> IO (Either XmppFailure ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (StreamHandle -> ByteString -> IO (Either XmppFailure ())
streamSend StreamHandle
con ByteString
bs)
                        , backendRecv :: Int -> IO ByteString
backendRecv = (Int -> IO (Either XmppFailure ByteString)) -> Int -> IO ByteString
forall {m :: * -> *} {e}.
(MonadBase IO m, Exception e) =>
(Int -> m (Either e ByteString)) -> Int -> m ByteString
bufferReceive (StreamHandle -> Int -> IO (Either XmppFailure ByteString)
streamReceive StreamHandle
con)
                        , backendFlush :: IO ()
backendFlush = StreamHandle -> IO ()
streamFlush StreamHandle
con
                        , backendClose :: IO ()
backendClose = StreamHandle -> IO ()
streamClose StreamHandle
con
                        }
  where
    bufferReceive :: (Int -> m (Either e ByteString)) -> Int -> m ByteString
bufferReceive Int -> m (Either e ByteString)
_ Int
0 = ByteString -> m ByteString
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
BS.empty
    bufferReceive Int -> m (Either e ByteString)
recv Int
n = [ByteString] -> ByteString
BS.concat ([ByteString] -> ByteString) -> m [ByteString] -> m ByteString
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` (Int -> m [ByteString]
go Int
n)
      where
        go :: Int -> m [ByteString]
go Int
m = do
            Either e ByteString
mbBs <- Int -> m (Either e ByteString)
recv Int
m
            ByteString
bs <- case Either e ByteString
mbBs of
                Left e
e -> e -> m ByteString
forall (m :: * -> *) e a. (MonadBase IO m, Exception e) => e -> m a
Ex.throwIO e
e
                Right ByteString
r -> ByteString -> m ByteString
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
r
            case ByteString -> Int
BS.length ByteString
bs of
                Int
0 -> [ByteString] -> m [ByteString]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return []
                Int
l -> if Int
l Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
m
                     then (ByteString
bs ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
:) ([ByteString] -> [ByteString]) -> m [ByteString] -> m [ByteString]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` Int -> m [ByteString]
go (Int
m Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
l)
                     else [ByteString] -> m [ByteString]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return [ByteString
bs]

starttlsE :: Element
starttlsE :: Element
starttlsE = Name -> [(Name, [Content])] -> [Node] -> Element
Element Name
"{urn:ietf:params:xml:ns:xmpp-tls}starttls" [] []

-- | Checks for TLS support and run starttls procedure if applicable
tls :: Stream -> IO (Either XmppFailure ())
tls :: Stream -> IO (Either XmppFailure ())
tls Stream
con = (Either XmppFailure (Either XmppFailure ())
 -> Either XmppFailure ())
-> IO (Either XmppFailure (Either XmppFailure ()))
-> IO (Either XmppFailure ())
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Either XmppFailure (Either XmppFailure ()) -> Either XmppFailure ()
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join -- We can have Left values both from exceptions and the
                    -- error monad. Join unifies them into one error layer
          (IO (Either XmppFailure (Either XmppFailure ()))
 -> IO (Either XmppFailure ()))
-> (ExceptT XmppFailure (StateT StreamState IO) ()
    -> IO (Either XmppFailure (Either XmppFailure ())))
-> ExceptT XmppFailure (StateT StreamState IO) ()
-> IO (Either XmppFailure ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO (Either XmppFailure ())
-> IO (Either XmppFailure (Either XmppFailure ()))
forall a. IO a -> IO (Either XmppFailure a)
wrapExceptions
          (IO (Either XmppFailure ())
 -> IO (Either XmppFailure (Either XmppFailure ())))
-> (ExceptT XmppFailure (StateT StreamState IO) ()
    -> IO (Either XmppFailure ()))
-> ExceptT XmppFailure (StateT StreamState IO) ()
-> IO (Either XmppFailure (Either XmppFailure ()))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StateT StreamState IO (Either XmppFailure ())
 -> Stream -> IO (Either XmppFailure ()))
-> Stream
-> StateT StreamState IO (Either XmppFailure ())
-> IO (Either XmppFailure ())
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT StreamState IO (Either XmppFailure ())
-> Stream -> IO (Either XmppFailure ())
forall a. StateT StreamState IO a -> Stream -> IO a
withStream Stream
con
          (StateT StreamState IO (Either XmppFailure ())
 -> IO (Either XmppFailure ()))
-> (ExceptT XmppFailure (StateT StreamState IO) ()
    -> StateT StreamState IO (Either XmppFailure ()))
-> ExceptT XmppFailure (StateT StreamState IO) ()
-> IO (Either XmppFailure ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExceptT XmppFailure (StateT StreamState IO) ()
-> StateT StreamState IO (Either XmppFailure ())
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT XmppFailure (StateT StreamState IO) ()
 -> IO (Either XmppFailure ()))
-> ExceptT XmppFailure (StateT StreamState IO) ()
-> IO (Either XmppFailure ())
forall a b. (a -> b) -> a -> b
$ do
    StreamConfiguration
conf <- (StreamState -> StreamConfiguration)
-> ExceptT XmppFailure (StateT StreamState IO) StreamConfiguration
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets StreamState -> StreamConfiguration
streamConfiguration
    ConnectionState
sState <- (StreamState -> ConnectionState)
-> ExceptT XmppFailure (StateT StreamState IO) ConnectionState
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets StreamState -> ConnectionState
streamConnectionState
    case ConnectionState
sState of
        ConnectionState
Plain -> () -> ExceptT XmppFailure (StateT StreamState IO) ()
forall a. a -> ExceptT XmppFailure (StateT StreamState IO) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        ConnectionState
Closed -> do
            IO () -> ExceptT XmppFailure (StateT StreamState IO) ()
forall a. IO a -> ExceptT XmppFailure (StateT StreamState IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT XmppFailure (StateT StreamState IO) ())
-> IO () -> ExceptT XmppFailure (StateT StreamState IO) ()
forall a b. (a -> b) -> a -> b
$ String -> String -> IO ()
errorM String
"Pontarius.Xmpp.Tls" String
"The stream is closed."
            XmppFailure -> ExceptT XmppFailure (StateT StreamState IO) ()
forall a.
XmppFailure -> ExceptT XmppFailure (StateT StreamState IO) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError XmppFailure
XmppNoStream
        ConnectionState
Finished -> do
            IO () -> ExceptT XmppFailure (StateT StreamState IO) ()
forall a. IO a -> ExceptT XmppFailure (StateT StreamState IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT XmppFailure (StateT StreamState IO) ())
-> IO () -> ExceptT XmppFailure (StateT StreamState IO) ()
forall a b. (a -> b) -> a -> b
$ String -> String -> IO ()
errorM String
"Pontarius.Xmpp.Tls" String
"The stream is finished."
            XmppFailure -> ExceptT XmppFailure (StateT StreamState IO) ()
forall a.
XmppFailure -> ExceptT XmppFailure (StateT StreamState IO) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError XmppFailure
XmppNoStream
        ConnectionState
Secured -> do
            IO () -> ExceptT XmppFailure (StateT StreamState IO) ()
forall a. IO a -> ExceptT XmppFailure (StateT StreamState IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT XmppFailure (StateT StreamState IO) ())
-> IO () -> ExceptT XmppFailure (StateT StreamState IO) ()
forall a b. (a -> b) -> a -> b
$ String -> String -> IO ()
errorM String
"Pontarius.Xmpp.Tls" String
"The stream is already secured."
            XmppFailure -> ExceptT XmppFailure (StateT StreamState IO) ()
forall a.
XmppFailure -> ExceptT XmppFailure (StateT StreamState IO) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError XmppFailure
TlsStreamSecured
    StreamFeatures
features <- StateT StreamState IO StreamFeatures
-> ExceptT XmppFailure (StateT StreamState IO) StreamFeatures
forall (m :: * -> *) a. Monad m => m a -> ExceptT XmppFailure m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT StreamState IO StreamFeatures
 -> ExceptT XmppFailure (StateT StreamState IO) StreamFeatures)
-> StateT StreamState IO StreamFeatures
-> ExceptT XmppFailure (StateT StreamState IO) StreamFeatures
forall a b. (a -> b) -> a -> b
$ (StreamState -> StreamFeatures)
-> StateT StreamState IO StreamFeatures
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets StreamState -> StreamFeatures
streamFeatures
    case (StreamConfiguration -> TlsBehaviour
tlsBehaviour StreamConfiguration
conf, StreamFeatures -> Maybe Bool
streamFeaturesTls StreamFeatures
features) of
        (TlsBehaviour
RequireTls  , Just Bool
_   ) -> ExceptT XmppFailure (StateT StreamState IO) ()
startTls
        (TlsBehaviour
RequireTls  , Maybe Bool
Nothing  ) -> XmppFailure -> ExceptT XmppFailure (StateT StreamState IO) ()
forall a.
XmppFailure -> ExceptT XmppFailure (StateT StreamState IO) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError XmppFailure
TlsNoServerSupport
        (TlsBehaviour
PreferTls   , Just Bool
_   ) -> ExceptT XmppFailure (StateT StreamState IO) ()
startTls
        (TlsBehaviour
PreferTls   , Maybe Bool
Nothing  ) -> ExceptT XmppFailure (StateT StreamState IO) ()
skipTls
        (TlsBehaviour
PreferPlain , Just Bool
True) -> ExceptT XmppFailure (StateT StreamState IO) ()
startTls
        (TlsBehaviour
PreferPlain , Maybe Bool
_        ) -> ExceptT XmppFailure (StateT StreamState IO) ()
skipTls
        (TlsBehaviour
RefuseTls   , Just Bool
True) -> XmppFailure -> ExceptT XmppFailure (StateT StreamState IO) ()
forall a.
XmppFailure -> ExceptT XmppFailure (StateT StreamState IO) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError XmppFailure
XmppOtherFailure
        (TlsBehaviour
RefuseTls   , Maybe Bool
_        ) -> ExceptT XmppFailure (StateT StreamState IO) ()
skipTls
  where
    skipTls :: ExceptT XmppFailure (StateT StreamState IO) ()
skipTls = IO () -> ExceptT XmppFailure (StateT StreamState IO) ()
forall a. IO a -> ExceptT XmppFailure (StateT StreamState IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT XmppFailure (StateT StreamState IO) ())
-> IO () -> ExceptT XmppFailure (StateT StreamState IO) ()
forall a b. (a -> b) -> a -> b
$ String -> String -> IO ()
infoM String
"Pontarius.Xmpp.Tls" String
"Skipping TLS negotiation"
    startTls :: ExceptT XmppFailure (StateT StreamState IO) ()
startTls = do
        IO () -> ExceptT XmppFailure (StateT StreamState IO) ()
forall a. IO a -> ExceptT XmppFailure (StateT StreamState IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT XmppFailure (StateT StreamState IO) ())
-> IO () -> ExceptT XmppFailure (StateT StreamState IO) ()
forall a b. (a -> b) -> a -> b
$ String -> String -> IO ()
infoM String
"Pontarius.Xmpp.Tls" String
"Running StartTLS"
        ClientParams
params <- (StreamState -> ClientParams)
-> ExceptT XmppFailure (StateT StreamState IO) ClientParams
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ((StreamState -> ClientParams)
 -> ExceptT XmppFailure (StateT StreamState IO) ClientParams)
-> (StreamState -> ClientParams)
-> ExceptT XmppFailure (StateT StreamState IO) ClientParams
forall a b. (a -> b) -> a -> b
$ StreamConfiguration -> ClientParams
tlsParams (StreamConfiguration -> ClientParams)
-> (StreamState -> StreamConfiguration)
-> StreamState
-> ClientParams
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StreamState -> StreamConfiguration
streamConfiguration
        StateT StreamState IO (Either XmppFailure ())
-> ExceptT XmppFailure (StateT StreamState IO) ()
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (StateT StreamState IO (Either XmppFailure ())
 -> ExceptT XmppFailure (StateT StreamState IO) ())
-> StateT StreamState IO (Either XmppFailure ())
-> ExceptT XmppFailure (StateT StreamState IO) ()
forall a b. (a -> b) -> a -> b
$ Element -> StateT StreamState IO (Either XmppFailure ())
pushElement Element
starttlsE
        Either XmppFailure Element
answer <- StateT StreamState IO (Either XmppFailure Element)
-> ExceptT
     XmppFailure (StateT StreamState IO) (Either XmppFailure Element)
forall (m :: * -> *) a. Monad m => m a -> ExceptT XmppFailure m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT StreamState IO (Either XmppFailure Element)
 -> ExceptT
      XmppFailure (StateT StreamState IO) (Either XmppFailure Element))
-> StateT StreamState IO (Either XmppFailure Element)
-> ExceptT
     XmppFailure (StateT StreamState IO) (Either XmppFailure Element)
forall a b. (a -> b) -> a -> b
$ StateT StreamState IO (Either XmppFailure Element)
pullElement
        case Either XmppFailure Element
answer of
            Left XmppFailure
e -> XmppFailure -> ExceptT XmppFailure (StateT StreamState IO) ()
forall a.
XmppFailure -> ExceptT XmppFailure (StateT StreamState IO) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError XmppFailure
e
            Right (Element Name
"{urn:ietf:params:xml:ns:xmpp-tls}proceed" [] []) ->
                () -> ExceptT XmppFailure (StateT StreamState IO) ()
forall a. a -> ExceptT XmppFailure (StateT StreamState IO) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            Right (Element Name
"{urn:ietf:params:xml:ns:xmpp-tls}failure" [(Name, [Content])]
_ [Node]
_) -> do
                IO () -> ExceptT XmppFailure (StateT StreamState IO) ()
forall a. IO a -> ExceptT XmppFailure (StateT StreamState IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT XmppFailure (StateT StreamState IO) ())
-> IO () -> ExceptT XmppFailure (StateT StreamState IO) ()
forall a b. (a -> b) -> a -> b
$ String -> String -> IO ()
errorM String
"Pontarius.Xmpp" String
"startTls: TLS initiation failed."
                XmppFailure -> ExceptT XmppFailure (StateT StreamState IO) ()
forall a.
XmppFailure -> ExceptT XmppFailure (StateT StreamState IO) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError XmppFailure
XmppOtherFailure
            Right Element
r ->
                IO () -> ExceptT XmppFailure (StateT StreamState IO) ()
forall a. IO a -> ExceptT XmppFailure (StateT StreamState IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT XmppFailure (StateT StreamState IO) ())
-> IO () -> ExceptT XmppFailure (StateT StreamState IO) ()
forall a b. (a -> b) -> a -> b
$ String -> String -> IO ()
errorM String
"Pontarius.Xmpp.Tls" (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
                            String
"Unexpected element: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Element -> String
forall a. Show a => a -> String
show Element
r
        StreamHandle
hand <- (StreamState -> StreamHandle)
-> ExceptT XmppFailure (StateT StreamState IO) StreamHandle
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets StreamState -> StreamHandle
streamHandle
        (ConduitT () ByteString IO ()
_raw, ConduitT ByteString Void IO ()
_snk, ByteString -> IO ()
psh, Int -> IO ByteString
recv, Context
ctx) <- StateT
  StreamState
  IO
  (ConduitT () ByteString IO (), ConduitT ByteString Void IO (),
   ByteString -> IO (), Int -> IO ByteString, Context)
-> ExceptT
     XmppFailure
     (StateT StreamState IO)
     (ConduitT () ByteString IO (), ConduitT ByteString Void IO (),
      ByteString -> IO (), Int -> IO ByteString, Context)
forall (m :: * -> *) a. Monad m => m a -> ExceptT XmppFailure m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT
   StreamState
   IO
   (ConduitT () ByteString IO (), ConduitT ByteString Void IO (),
    ByteString -> IO (), Int -> IO ByteString, Context)
 -> ExceptT
      XmppFailure
      (StateT StreamState IO)
      (ConduitT () ByteString IO (), ConduitT ByteString Void IO (),
       ByteString -> IO (), Int -> IO ByteString, Context))
-> StateT
     StreamState
     IO
     (ConduitT () ByteString IO (), ConduitT ByteString Void IO (),
      ByteString -> IO (), Int -> IO ByteString, Context)
-> ExceptT
     XmppFailure
     (StateT StreamState IO)
     (ConduitT () ByteString IO (), ConduitT ByteString Void IO (),
      ByteString -> IO (), Int -> IO ByteString, Context)
forall a b. (a -> b) -> a -> b
$ ClientParams
-> Backend
-> StateT
     StreamState
     IO
     (ConduitT () ByteString IO (), ConduitT ByteString Void IO (),
      ByteString -> IO (), Int -> IO ByteString, Context)
forall (m :: * -> *) (m1 :: * -> *).
(MonadIO m, MonadIO m1) =>
ClientParams
-> Backend
-> m (ConduitT () ByteString m1 (), ConduitT ByteString Void m1 (),
      ByteString -> IO (), Int -> m1 ByteString, Context)
tlsinit ClientParams
params (StreamHandle -> Backend
mkBackend StreamHandle
hand)
        let newHand :: StreamHandle
newHand = StreamHandle { streamSend :: ByteString -> IO (Either XmppFailure ())
streamSend = IO () -> IO (Either XmppFailure ())
catchPush (IO () -> IO (Either XmppFailure ()))
-> (ByteString -> IO ())
-> ByteString
-> IO (Either XmppFailure ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> IO ()
psh
                                   , streamReceive :: Int -> IO (Either XmppFailure ByteString)
streamReceive = IO ByteString -> IO (Either XmppFailure ByteString)
forall a. IO a -> IO (Either XmppFailure a)
wrapExceptions (IO ByteString -> IO (Either XmppFailure ByteString))
-> (Int -> IO ByteString)
-> Int
-> IO (Either XmppFailure ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> IO ByteString
recv
                                   , streamFlush :: IO ()
streamFlush = Context -> IO ()
contextFlush Context
ctx
                                   , streamClose :: IO ()
streamClose = Context -> IO ()
forall (m :: * -> *). MonadIO m => Context -> m ()
bye Context
ctx IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> StreamHandle -> IO ()
streamClose StreamHandle
hand
                                   }
        StateT StreamState IO ()
-> ExceptT XmppFailure (StateT StreamState IO) ()
forall (m :: * -> *) a. Monad m => m a -> ExceptT XmppFailure m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT StreamState IO ()
 -> ExceptT XmppFailure (StateT StreamState IO) ())
-> StateT StreamState IO ()
-> ExceptT XmppFailure (StateT StreamState IO) ()
forall a b. (a -> b) -> a -> b
$ (StreamState -> StreamState) -> StateT StreamState IO ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ( \StreamState
x -> StreamState
x {streamHandle = newHand})
        IO () -> ExceptT XmppFailure (StateT StreamState IO) ()
forall a. IO a -> ExceptT XmppFailure (StateT StreamState IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT XmppFailure (StateT StreamState IO) ())
-> IO () -> ExceptT XmppFailure (StateT StreamState IO) ()
forall a b. (a -> b) -> a -> b
$ String -> String -> IO ()
infoM String
"Pontarius.Xmpp.Tls" String
"Stream Secured."
        (XmppFailure -> ExceptT XmppFailure (StateT StreamState IO) ())
-> (() -> ExceptT XmppFailure (StateT StreamState IO) ())
-> Either XmppFailure ()
-> ExceptT XmppFailure (StateT StreamState IO) ()
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (StateT StreamState IO ()
-> ExceptT XmppFailure (StateT StreamState IO) ()
forall (m :: * -> *) a. Monad m => m a -> ExceptT XmppFailure m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT StreamState IO ()
 -> ExceptT XmppFailure (StateT StreamState IO) ())
-> (XmppFailure -> StateT StreamState IO ())
-> XmppFailure
-> ExceptT XmppFailure (StateT StreamState IO) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XmppFailure -> StateT StreamState IO ()
forall (m :: * -> *) e a. (MonadBase IO m, Exception e) => e -> m a
Ex.throwIO) () -> ExceptT XmppFailure (StateT StreamState IO) ()
forall a. a -> ExceptT XmppFailure (StateT StreamState IO) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either XmppFailure ()
 -> ExceptT XmppFailure (StateT StreamState IO) ())
-> ExceptT
     XmppFailure (StateT StreamState IO) (Either XmppFailure ())
-> ExceptT XmppFailure (StateT StreamState IO) ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< StateT StreamState IO (Either XmppFailure ())
-> ExceptT
     XmppFailure (StateT StreamState IO) (Either XmppFailure ())
forall (m :: * -> *) a. Monad m => m a -> ExceptT XmppFailure m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift StateT StreamState IO (Either XmppFailure ())
restartStream
        (StreamState -> StreamState)
-> ExceptT XmppFailure (StateT StreamState IO) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\StreamState
s -> StreamState
s{streamConnectionState = Secured})
        () -> ExceptT XmppFailure (StateT StreamState IO) ()
forall a. a -> ExceptT XmppFailure (StateT StreamState IO) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

client :: MonadIO m => ClientParams -> Backend -> m Context
client :: forall (m :: * -> *).
MonadIO m =>
ClientParams -> Backend -> m Context
client ClientParams
params Backend
backend = Backend -> ClientParams -> m Context
forall (m :: * -> *) backend params.
(MonadIO m, HasBackend backend, TLSParams params) =>
backend -> params -> m Context
contextNew Backend
backend ClientParams
params

tlsinit :: (MonadIO m, MonadIO m1) =>
        ClientParams
     -> Backend
     -> m ( ConduitT () BS.ByteString m1 ()
          , ConduitT BS.ByteString Void m1 ()
          , BS.ByteString -> IO ()
          , Int -> m1 BS.ByteString
          , Context
          )
tlsinit :: forall (m :: * -> *) (m1 :: * -> *).
(MonadIO m, MonadIO m1) =>
ClientParams
-> Backend
-> m (ConduitT () ByteString m1 (), ConduitT ByteString Void m1 (),
      ByteString -> IO (), Int -> m1 ByteString, Context)
tlsinit ClientParams
params Backend
backend = do
    IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> String -> IO ()
debugM String
"Pontarius.Xmpp.Tls" String
"TLS with debug mode enabled."
    -- gen <- liftIO (cprgCreate <$> createEntropyPool :: IO SystemRNG)
    CertificateStore
sysCStore <- IO CertificateStore -> m CertificateStore
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO CertificateStore
getSystemCertificateStore
    let params' :: ClientParams
params' = ClientParams
params{clientShared =
                      (clientShared params){ sharedCAStore =
                          sysCStore <> sharedCAStore (clientShared params)}}
    Context
con <- ClientParams -> Backend -> m Context
forall (m :: * -> *).
MonadIO m =>
ClientParams -> Backend -> m Context
client ClientParams
params' Backend
backend
    Context -> m ()
forall (m :: * -> *). MonadIO m => Context -> m ()
handshake Context
con
    let src :: ConduitT i ByteString m1 b
src = ConduitT i ByteString m1 () -> ConduitT i ByteString m1 b
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (ConduitT i ByteString m1 () -> ConduitT i ByteString m1 b)
-> ConduitT i ByteString m1 () -> ConduitT i ByteString m1 b
forall a b. (a -> b) -> a -> b
$ do
            ByteString
dt <- IO ByteString -> ConduitT i ByteString m1 ByteString
forall a. IO a -> ConduitT i ByteString m1 a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> ConduitT i ByteString m1 ByteString)
-> IO ByteString -> ConduitT i ByteString m1 ByteString
forall a b. (a -> b) -> a -> b
$ Context -> IO ByteString
forall (m :: * -> *). MonadIO m => Context -> m ByteString
recvData Context
con
            IO () -> ConduitT i ByteString m1 ()
forall a. IO a -> ConduitT i ByteString m1 a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ConduitT i ByteString m1 ())
-> IO () -> ConduitT i ByteString m1 ()
forall a b. (a -> b) -> a -> b
$ String -> String -> IO ()
debugM String
"Pontarius.Xmpp.Tls" (String
"In :" String -> String -> String
forall a. [a] -> [a] -> [a]
++ ByteString -> String
BSC8.unpack ByteString
dt)
            ByteString -> ConduitT i ByteString m1 ()
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield ByteString
dt
    let snk :: ConduitT ByteString o m1 ()
snk = do
            Maybe ByteString
d <- ConduitT ByteString o m1 (Maybe ByteString)
forall (m :: * -> *) i o. Monad m => ConduitT i o m (Maybe i)
await
            case Maybe ByteString
d of
                Maybe ByteString
Nothing -> () -> ConduitT ByteString o m1 ()
forall a. a -> ConduitT ByteString o m1 a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                Just ByteString
x -> do
                       Context -> ByteString -> ConduitT ByteString o m1 ()
forall (m :: * -> *). MonadIO m => Context -> ByteString -> m ()
sendData Context
con ([ByteString] -> ByteString
BL.fromChunks [ByteString
x])
                       ConduitT ByteString o m1 ()
snk
    Int -> IO ByteString
readWithBuffer <- IO (Int -> IO ByteString) -> m (Int -> IO ByteString)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Int -> IO ByteString) -> m (Int -> IO ByteString))
-> IO (Int -> IO ByteString) -> m (Int -> IO ByteString)
forall a b. (a -> b) -> a -> b
$ IO ByteString -> IO (Int -> IO ByteString)
mkReadBuffer (Context -> IO ByteString
forall (m :: * -> *). MonadIO m => Context -> m ByteString
recvData Context
con)
    (ConduitT () ByteString m1 (), ConduitT ByteString Void m1 (),
 ByteString -> IO (), Int -> m1 ByteString, Context)
-> m (ConduitT () ByteString m1 (), ConduitT ByteString Void m1 (),
      ByteString -> IO (), Int -> m1 ByteString, Context)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ( ConduitT () ByteString m1 ()
forall {i} {b}. ConduitT i ByteString m1 b
src
           , ConduitT ByteString Void m1 ()
forall {o}. ConduitT ByteString o m1 ()
snk
             -- Note: sendData already sends the data to the debug output
           , \ByteString
s -> Context -> ByteString -> IO ()
forall (m :: * -> *). MonadIO m => Context -> ByteString -> m ()
sendData Context
con (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ [ByteString] -> ByteString
BL.fromChunks [ByteString
s]
           , IO ByteString -> m1 ByteString
forall a. IO a -> m1 a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> m1 ByteString)
-> (Int -> IO ByteString) -> Int -> m1 ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> IO ByteString
readWithBuffer
           , Context
con
           )

mkReadBuffer :: IO BS.ByteString -> IO (Int -> IO BS.ByteString)
mkReadBuffer :: IO ByteString -> IO (Int -> IO ByteString)
mkReadBuffer IO ByteString
recv = do
    IORef ByteString
buffer <- ByteString -> IO (IORef ByteString)
forall a. a -> IO (IORef a)
newIORef ByteString
BS.empty
    let read' :: Int -> IO ByteString
read' Int
n = do
            ByteString
nc <- IORef ByteString -> IO ByteString
forall a. IORef a -> IO a
readIORef IORef ByteString
buffer
            ByteString
bs <- if ByteString -> Bool
BS.null ByteString
nc then IO ByteString
recv
                                else ByteString -> IO ByteString
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
nc
            let (ByteString
result, ByteString
rest) = Int -> ByteString -> (ByteString, ByteString)
BS.splitAt Int
n ByteString
bs
            IORef ByteString -> ByteString -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef ByteString
buffer ByteString
rest
            ByteString -> IO ByteString
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
result
    (Int -> IO ByteString) -> IO (Int -> IO ByteString)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Int -> IO ByteString
read'

-- | Connect to an XMPP server and secure the connection with TLS before
-- starting the XMPP streams
--
-- /NB/ RFC 6120 does not specify this method, but some servers, notably GCS,
-- seem to use it.
connectTls :: ResolvConf -- ^ Resolv conf to use (try 'defaultResolvConf' as a
                         -- default)
           -> ClientParams  -- ^ TLS parameters to use when securing the connection
           -> String     -- ^ Host to use when connecting (will be resolved
                         -- using SRV records)
           -> ExceptT XmppFailure IO StreamHandle
connectTls :: ResolvConf
-> ClientParams -> String -> ExceptT XmppFailure IO StreamHandle
connectTls ResolvConf
config ClientParams
params String
host = do
    Handle
h <- ResolvConf -> String -> ExceptT XmppFailure IO (Maybe Handle)
connectSrv ResolvConf
config String
host ExceptT XmppFailure IO (Maybe Handle)
-> (Maybe Handle -> ExceptT XmppFailure IO Handle)
-> ExceptT XmppFailure IO Handle
forall a b.
ExceptT XmppFailure IO a
-> (a -> ExceptT XmppFailure IO b) -> ExceptT XmppFailure IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Maybe Handle
h' -> case Maybe Handle
h' of
        Maybe Handle
Nothing -> XmppFailure -> ExceptT XmppFailure IO Handle
forall a. XmppFailure -> ExceptT XmppFailure IO a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError XmppFailure
TcpConnectionFailure
        Just Handle
h'' -> Handle -> ExceptT XmppFailure IO Handle
forall a. a -> ExceptT XmppFailure IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Handle
h''
    let hand :: StreamHandle
hand = Handle -> StreamHandle
handleToStreamHandle Handle
h
    let params' :: ClientParams
params' = ClientParams
params{clientServerIdentification
                   = case clientServerIdentification params of
                       (String
"", ByteString
_) -> (String
host, ByteString
"")
                       (String, ByteString)
csi -> (String, ByteString)
csi
                       }
    (ConduitT () ByteString IO ()
_raw, ConduitT ByteString Void IO ()
_snk, ByteString -> IO ()
psh, Int -> IO ByteString
recv, Context
ctx) <- ClientParams
-> Backend
-> ExceptT
     XmppFailure
     IO
     (ConduitT () ByteString IO (), ConduitT ByteString Void IO (),
      ByteString -> IO (), Int -> IO ByteString, Context)
forall (m :: * -> *) (m1 :: * -> *).
(MonadIO m, MonadIO m1) =>
ClientParams
-> Backend
-> m (ConduitT () ByteString m1 (), ConduitT ByteString Void m1 (),
      ByteString -> IO (), Int -> m1 ByteString, Context)
tlsinit ClientParams
params' (Backend
 -> ExceptT
      XmppFailure
      IO
      (ConduitT () ByteString IO (), ConduitT ByteString Void IO (),
       ByteString -> IO (), Int -> IO ByteString, Context))
-> Backend
-> ExceptT
     XmppFailure
     IO
     (ConduitT () ByteString IO (), ConduitT ByteString Void IO (),
      ByteString -> IO (), Int -> IO ByteString, Context)
forall a b. (a -> b) -> a -> b
$ StreamHandle -> Backend
mkBackend StreamHandle
hand
    StreamHandle -> ExceptT XmppFailure IO StreamHandle
forall a. a -> ExceptT XmppFailure IO a
forall (m :: * -> *) a. Monad m => a -> m a
return StreamHandle{ streamSend :: ByteString -> IO (Either XmppFailure ())
streamSend = IO () -> IO (Either XmppFailure ())
catchPush (IO () -> IO (Either XmppFailure ()))
-> (ByteString -> IO ())
-> ByteString
-> IO (Either XmppFailure ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> IO ()
psh
                       , streamReceive :: Int -> IO (Either XmppFailure ByteString)
streamReceive = IO ByteString -> IO (Either XmppFailure ByteString)
forall a. IO a -> IO (Either XmppFailure a)
wrapExceptions (IO ByteString -> IO (Either XmppFailure ByteString))
-> (Int -> IO ByteString)
-> Int
-> IO (Either XmppFailure ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> IO ByteString
recv
                       , streamFlush :: IO ()
streamFlush = Context -> IO ()
contextFlush Context
ctx
                       , streamClose :: IO ()
streamClose = Context -> IO ()
forall (m :: * -> *). MonadIO m => Context -> m ()
bye Context
ctx IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> StreamHandle -> IO ()
streamClose StreamHandle
hand
                       }

wrapExceptions :: IO a -> IO (Either XmppFailure a)
wrapExceptions :: forall a. IO a -> IO (Either XmppFailure a)
wrapExceptions IO a
f = IO (Either XmppFailure a)
-> [Handler IO (Either XmppFailure a)] -> IO (Either XmppFailure a)
forall (m :: * -> *) a.
MonadBaseControl IO m =>
m a -> [Handler m a] -> m a
Ex.catches ((a -> Either XmppFailure a) -> IO a -> IO (Either XmppFailure a)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM a -> Either XmppFailure a
forall a b. b -> Either a b
Right (IO a -> IO (Either XmppFailure a))
-> IO a -> IO (Either XmppFailure a)
forall a b. (a -> b) -> a -> b
$ IO a
f)
                 [ (IOException -> IO (Either XmppFailure a))
-> Handler IO (Either XmppFailure a)
forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
Ex.Handler ((IOException -> IO (Either XmppFailure a))
 -> Handler IO (Either XmppFailure a))
-> (IOException -> IO (Either XmppFailure a))
-> Handler IO (Either XmppFailure a)
forall a b. (a -> b) -> a -> b
$ Either XmppFailure a -> IO (Either XmppFailure a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either XmppFailure a -> IO (Either XmppFailure a))
-> (IOException -> Either XmppFailure a)
-> IOException
-> IO (Either XmppFailure a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XmppFailure -> Either XmppFailure a
forall a b. a -> Either a b
Left (XmppFailure -> Either XmppFailure a)
-> (IOException -> XmppFailure)
-> IOException
-> Either XmppFailure a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IOException -> XmppFailure
XmppIOException
#if !MIN_VERSION_tls(1,8,0)
                 , Ex.Handler $ wrap . XmppTlsError
#endif
                 , (TLSException -> IO (Either XmppFailure a))
-> Handler IO (Either XmppFailure a)
forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
Ex.Handler ((TLSException -> IO (Either XmppFailure a))
 -> Handler IO (Either XmppFailure a))
-> (TLSException -> IO (Either XmppFailure a))
-> Handler IO (Either XmppFailure a)
forall a b. (a -> b) -> a -> b
$ XmppTlsError -> IO (Either XmppFailure a)
forall {b}. XmppTlsError -> IO (Either XmppFailure b)
wrap (XmppTlsError -> IO (Either XmppFailure a))
-> (TLSException -> XmppTlsError)
-> TLSException
-> IO (Either XmppFailure a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TLSException -> XmppTlsError
XmppTlsException
                 , (XmppFailure -> IO (Either XmppFailure a))
-> Handler IO (Either XmppFailure a)
forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
Ex.Handler ((XmppFailure -> IO (Either XmppFailure a))
 -> Handler IO (Either XmppFailure a))
-> (XmppFailure -> IO (Either XmppFailure a))
-> Handler IO (Either XmppFailure a)
forall a b. (a -> b) -> a -> b
$ Either XmppFailure a -> IO (Either XmppFailure a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either XmppFailure a -> IO (Either XmppFailure a))
-> (XmppFailure -> Either XmppFailure a)
-> XmppFailure
-> IO (Either XmppFailure a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XmppFailure -> Either XmppFailure a
forall a b. a -> Either a b
Left
                 ]
  where
    wrap :: XmppTlsError -> IO (Either XmppFailure b)
wrap = Either XmppFailure b -> IO (Either XmppFailure b)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either XmppFailure b -> IO (Either XmppFailure b))
-> (XmppTlsError -> Either XmppFailure b)
-> XmppTlsError
-> IO (Either XmppFailure b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XmppFailure -> Either XmppFailure b
forall a b. a -> Either a b
Left (XmppFailure -> Either XmppFailure b)
-> (XmppTlsError -> XmppFailure)
-> XmppTlsError
-> Either XmppFailure b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XmppTlsError -> XmppFailure
TlsError