{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE DataKinds #-}
module Network.XMPP.Core
( initStream
, closeStream
) where
import Control.Monad (void)
import System.IO (Handle, hSetBuffering, BufferMode(..))
import Control.Monad.Except (throwError, runExceptT, lift)
import Control.Monad.IO.Class (liftIO, MonadIO)
import Data.Text (unpack, pack)
import Text.Hamlet.XML (xml)
import Network.XMPP.Utils (debug)
import Network.XMPP.Sasl (saslAuth)
import Network.XMPP.IQ (iqSend)
import Network.XMPP.Print (stream, streamEnd)
import Network.XMPP.XML (noelem, lookupAttr, getText)
import Network.XMPP.Types (Server, Username, Password, Resource, XmppMonad,
JID(..), JIDQualification(..), StreamType(..),
IQType(..))
import Network.XMPP.Stream (resetStreamHandle, XmppSendable(..), XmppError(..),
xtractM, textractM, startM)
initStream :: MonadIO m => Handle
-> Server
-> Username
-> Password
-> Resource
-> XmppMonad m (Either XmppError (JID 'NodeResource))
initStream :: Handle
-> Server
-> Server
-> Server
-> Server
-> XmppMonad m (Either XmppError (JID 'NodeResource))
initStream Handle
h Server
server Server
username Server
password Server
resrc = ExceptT XmppError (XmppMonad m) (JID 'NodeResource)
-> XmppMonad m (Either XmppError (JID 'NodeResource))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT XmppError (XmppMonad m) (JID 'NodeResource)
-> XmppMonad m (Either XmppError (JID 'NodeResource)))
-> ExceptT XmppError (XmppMonad m) (JID 'NodeResource)
-> XmppMonad m (Either XmppError (JID 'NodeResource))
forall a b. (a -> b) -> a -> b
$
do IO () -> ExceptT XmppError (XmppMonad m) ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT XmppError (XmppMonad m) ())
-> IO () -> ExceptT XmppError (XmppMonad m) ()
forall a b. (a -> b) -> a -> b
$ Handle -> BufferMode -> IO ()
hSetBuffering Handle
h BufferMode
NoBuffering
Handle -> ExceptT XmppError (XmppMonad m) ()
forall (m :: * -> *).
(MonadIO m, MonadState Stream m) =>
Handle -> m ()
resetStreamHandle Handle
h
XmppMonad m () -> ExceptT XmppError (XmppMonad m) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (XmppMonad m () -> ExceptT XmppError (XmppMonad m) ())
-> XmppMonad m () -> ExceptT XmppError (XmppMonad m) ()
forall a b. (a -> b) -> a -> b
$ Content Posn -> XmppMonad m ()
forall (t :: * -> *) a. (XmppSendable t a, Monad t) => a -> t ()
xmppSend (Content Posn -> XmppMonad m ()) -> Content Posn -> XmppMonad m ()
forall a b. (a -> b) -> a -> b
$ [Content Posn] -> Content Posn
forall a. [a] -> a
head ([Content Posn] -> Content Posn) -> [Content Posn] -> Content Posn
forall a b. (a -> b) -> a -> b
$ StreamType -> Server -> CFilter Posn
forall a i. Show a => a -> Server -> CFilter i
stream StreamType
Client Server
server Content Posn
noelem
[Attribute]
attrs <- XmppMonad m (Either XmppError [Attribute])
-> ExceptT XmppError (XmppMonad m) (Either XmppError [Attribute])
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift XmppMonad m (Either XmppError [Attribute])
forall (m :: * -> *).
MonadIO m =>
XmppMonad m (Either XmppError [Attribute])
startM ExceptT XmppError (XmppMonad m) (Either XmppError [Attribute])
-> (Either XmppError [Attribute]
-> ExceptT XmppError (XmppMonad m) [Attribute])
-> ExceptT XmppError (XmppMonad m) [Attribute]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (XmppError -> ExceptT XmppError (XmppMonad m) [Attribute])
-> ([Attribute] -> ExceptT XmppError (XmppMonad m) [Attribute])
-> Either XmppError [Attribute]
-> ExceptT XmppError (XmppMonad m) [Attribute]
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either XmppError -> ExceptT XmppError (XmppMonad m) [Attribute]
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError [Attribute] -> ExceptT XmppError (XmppMonad m) [Attribute]
forall (f :: * -> *) a. Applicative f => a -> f a
pure
case String -> [Attribute] -> Maybe String
lookupAttr String
"version" [Attribute]
attrs of
Just String
"1.0" -> () -> ExceptT XmppError (XmppMonad m) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just String
ver -> XmppError -> ExceptT XmppError (XmppMonad m) ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (XmppError -> ExceptT XmppError (XmppMonad m) ())
-> XmppError -> ExceptT XmppError (XmppMonad m) ()
forall a b. (a -> b) -> a -> b
$ Server -> XmppError
UnknownVersion (Server -> XmppError) -> Server -> XmppError
forall a b. (a -> b) -> a -> b
$ String -> Server
pack String
ver
Maybe String
Nothing -> XmppError -> ExceptT XmppError (XmppMonad m) ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (XmppError -> ExceptT XmppError (XmppMonad m) ())
-> XmppError -> ExceptT XmppError (XmppMonad m) ()
forall a b. (a -> b) -> a -> b
$ Server -> XmppError
UnknownVersion Server
""
XmppMonad m () -> ExceptT XmppError (XmppMonad m) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (XmppMonad m () -> ExceptT XmppError (XmppMonad m) ())
-> XmppMonad m () -> ExceptT XmppError (XmppMonad m) ()
forall a b. (a -> b) -> a -> b
$ String -> XmppMonad m ()
forall (m :: * -> *). MonadIO m => String -> XmppMonad m ()
debug String
"Stream started"
[Content Posn]
m <- XmppMonad m [Content Posn]
-> ExceptT XmppError (XmppMonad m) [Content Posn]
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (XmppMonad m [Content Posn]
-> ExceptT XmppError (XmppMonad m) [Content Posn])
-> XmppMonad m [Content Posn]
-> ExceptT XmppError (XmppMonad m) [Content Posn]
forall a b. (a -> b) -> a -> b
$ Server -> XmppMonad m [Content Posn]
forall (m :: * -> *).
MonadIO m =>
Server -> XmppMonad m [Content Posn]
xtractM Server
"/stream:features/mechanisms/mechanism/-"
let mechs :: [Server]
mechs = Content Posn -> Server
forall i. Content i -> Server
getText (Content Posn -> Server) -> [Content Posn] -> [Server]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Content Posn]
m
XmppMonad m () -> ExceptT XmppError (XmppMonad m) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (XmppMonad m () -> ExceptT XmppError (XmppMonad m) ())
-> XmppMonad m () -> ExceptT XmppError (XmppMonad m) ()
forall a b. (a -> b) -> a -> b
$ String -> XmppMonad m ()
forall (m :: * -> *). MonadIO m => String -> XmppMonad m ()
debug (String -> XmppMonad m ()) -> String -> XmppMonad m ()
forall a b. (a -> b) -> a -> b
$ String
"Mechanisms: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Server] -> String
forall a. Show a => a -> String
show [Server]
mechs
XmppMonad m (Either XmppError ())
-> ExceptT XmppError (XmppMonad m) (Either XmppError ())
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift ([Server]
-> Server -> Server -> Server -> XmppMonad m (Either XmppError ())
forall (m :: * -> *).
MonadIO m =>
[Server]
-> Server -> Server -> Server -> XmppMonad m (Either XmppError ())
saslAuth [Server]
mechs Server
server Server
username Server
password) ExceptT XmppError (XmppMonad m) (Either XmppError ())
-> (Either XmppError () -> ExceptT XmppError (XmppMonad m) ())
-> ExceptT XmppError (XmppMonad m) ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (XmppError -> ExceptT XmppError (XmppMonad m) ())
-> (() -> ExceptT XmppError (XmppMonad m) ())
-> Either XmppError ()
-> ExceptT XmppError (XmppMonad m) ()
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either XmppError -> ExceptT XmppError (XmppMonad m) ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError () -> ExceptT XmppError (XmppMonad m) ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure
XmppMonad m () -> ExceptT XmppError (XmppMonad m) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (XmppMonad m () -> ExceptT XmppError (XmppMonad m) ())
-> XmppMonad m () -> ExceptT XmppError (XmppMonad m) ()
forall a b. (a -> b) -> a -> b
$ Content Posn -> XmppMonad m ()
forall (t :: * -> *) a. (XmppSendable t a, Monad t) => a -> t ()
xmppSend (Content Posn -> XmppMonad m ()) -> Content Posn -> XmppMonad m ()
forall a b. (a -> b) -> a -> b
$ [Content Posn] -> Content Posn
forall a. [a] -> a
head ([Content Posn] -> Content Posn) -> [Content Posn] -> Content Posn
forall a b. (a -> b) -> a -> b
$ StreamType -> Server -> CFilter Posn
forall a i. Show a => a -> Server -> CFilter i
stream StreamType
Client Server
server Content Posn
noelem
ExceptT XmppError (XmppMonad m) [Attribute]
-> ExceptT XmppError (XmppMonad m) ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ExceptT XmppError (XmppMonad m) [Attribute]
-> ExceptT XmppError (XmppMonad m) ())
-> ExceptT XmppError (XmppMonad m) [Attribute]
-> ExceptT XmppError (XmppMonad m) ()
forall a b. (a -> b) -> a -> b
$ XmppMonad m (Either XmppError [Attribute])
-> ExceptT XmppError (XmppMonad m) (Either XmppError [Attribute])
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift XmppMonad m (Either XmppError [Attribute])
forall (m :: * -> *).
MonadIO m =>
XmppMonad m (Either XmppError [Attribute])
startM ExceptT XmppError (XmppMonad m) (Either XmppError [Attribute])
-> (Either XmppError [Attribute]
-> ExceptT XmppError (XmppMonad m) [Attribute])
-> ExceptT XmppError (XmppMonad m) [Attribute]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (XmppError -> ExceptT XmppError (XmppMonad m) [Attribute])
-> ([Attribute] -> ExceptT XmppError (XmppMonad m) [Attribute])
-> Either XmppError [Attribute]
-> ExceptT XmppError (XmppMonad m) [Attribute]
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either XmppError -> ExceptT XmppError (XmppMonad m) [Attribute]
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError [Attribute] -> ExceptT XmppError (XmppMonad m) [Attribute]
forall (f :: * -> *) a. Applicative f => a -> f a
pure
XmppMonad m () -> ExceptT XmppError (XmppMonad m) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (XmppMonad m () -> ExceptT XmppError (XmppMonad m) ())
-> XmppMonad m () -> ExceptT XmppError (XmppMonad m) ()
forall a b. (a -> b) -> a -> b
$ XmppMonad m [Content Posn] -> XmppMonad m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (XmppMonad m [Content Posn] -> XmppMonad m ())
-> XmppMonad m [Content Posn] -> XmppMonad m ()
forall a b. (a -> b) -> a -> b
$ Server -> XmppMonad m [Content Posn]
forall (m :: * -> *).
MonadIO m =>
Server -> XmppMonad m [Content Posn]
xtractM Server
"/stream:features/bind"
XmppMonad m () -> ExceptT XmppError (XmppMonad m) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (XmppMonad m () -> ExceptT XmppError (XmppMonad m) ())
-> XmppMonad m () -> ExceptT XmppError (XmppMonad m) ()
forall a b. (a -> b) -> a -> b
$ Server -> IQType -> [Node] -> XmppMonad m ()
forall (m :: * -> *).
MonadIO m =>
Server -> IQType -> [Node] -> XmppMonad m ()
iqSend Server
"bind1" IQType
Set
[xml|
<bind xmlns="urn:ietf:params:xml:ns:xmpp-bind">
<resource>#{resrc}
|]
Server
my_jid <- XmppMonad m Server -> ExceptT XmppError (XmppMonad m) Server
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (XmppMonad m Server -> ExceptT XmppError (XmppMonad m) Server)
-> XmppMonad m Server -> ExceptT XmppError (XmppMonad m) Server
forall a b. (a -> b) -> a -> b
$ Server -> XmppMonad m Server
forall (m :: * -> *). MonadIO m => Server -> XmppMonad m Server
textractM Server
"/iq[@type='result' & @id='bind1']/bind/jid/-"
XmppMonad m () -> ExceptT XmppError (XmppMonad m) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (XmppMonad m () -> ExceptT XmppError (XmppMonad m) ())
-> XmppMonad m () -> ExceptT XmppError (XmppMonad m) ()
forall a b. (a -> b) -> a -> b
$ Server -> IQType -> [Node] -> XmppMonad m ()
forall (m :: * -> *).
MonadIO m =>
Server -> IQType -> [Node] -> XmppMonad m ()
iqSend Server
"session1" IQType
Set
[xml| <session xmlns="urn:ietf:params:xml:ns:xmpp-session"> |]
XmppMonad m () -> ExceptT XmppError (XmppMonad m) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (XmppMonad m () -> ExceptT XmppError (XmppMonad m) ())
-> XmppMonad m () -> ExceptT XmppError (XmppMonad m) ()
forall a b. (a -> b) -> a -> b
$ XmppMonad m [Content Posn] -> XmppMonad m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (XmppMonad m [Content Posn] -> XmppMonad m ())
-> XmppMonad m [Content Posn] -> XmppMonad m ()
forall a b. (a -> b) -> a -> b
$ Server -> XmppMonad m [Content Posn]
forall (m :: * -> *).
MonadIO m =>
Server -> XmppMonad m [Content Posn]
xtractM Server
"/iq[@type='result' & @id='session1']"
JID 'NodeResource
-> ExceptT XmppError (XmppMonad m) (JID 'NodeResource)
forall (m :: * -> *) a. Monad m => a -> m a
return (JID 'NodeResource
-> ExceptT XmppError (XmppMonad m) (JID 'NodeResource))
-> JID 'NodeResource
-> ExceptT XmppError (XmppMonad m) (JID 'NodeResource)
forall a b. (a -> b) -> a -> b
$ String -> JID 'NodeResource
forall a. Read a => String -> a
read (String -> JID 'NodeResource) -> String -> JID 'NodeResource
forall a b. (a -> b) -> a -> b
$ Server -> String
unpack Server
my_jid
closeStream :: MonadIO m => XmppMonad m ()
closeStream :: XmppMonad m ()
closeStream = Content Posn -> XmppMonad m ()
forall (t :: * -> *) a. (XmppSendable t a, Monad t) => a -> t ()
xmppSend (Content Posn -> XmppMonad m ()) -> Content Posn -> XmppMonad m ()
forall a b. (a -> b) -> a -> b
$ [Content Posn] -> Content Posn
forall a. [a] -> a
head ([Content Posn] -> Content Posn) -> [Content Posn] -> Content Posn
forall a b. (a -> b) -> a -> b
$ CFilter Posn
forall i. CFilter i
streamEnd Content Posn
noelem