{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes       #-}
{-# LANGUAGE DataKinds         #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Network.XMPP.Core
-- Copyright   :  (c) Dmitry Astapov, 2006 ; pierre, 2007
-- License     :  BSD-style (see the file LICENSE)
-- Copyright   :  (c) riskbook, 2020
-- SPDX-License-Identifier:  BSD3
-- 
-- Maintainer  :  Dmitry Astapov <dastapov@gmail.com>
-- Stability   :  experimental
-- Portability :  portable
--
-- Implementation of XMPP Core Protocol (RFC 3920)
--
-----------------------------------------------------------------------------

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)

-- | Open connection to specified server and return `Stream' coming from it
initStream :: MonadIO m => Handle
               -> Server -- ^ Server (hostname) we are connecting to
               -> Username -- ^ Username to use
               -> Password -- ^ Password to use
               -> Resource -- ^ Resource to use
               -> 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 ()
        -- TODO: JEP 0078 in case of absent of version we wont process stream:features
        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"
     --debug $ "Observing: " ++ render (P.content m)
     [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

     -- Handle the authentication
     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

     -- Bind this session to resource
     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" -- `catch` (fail "Binding is not proposed")

     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']" -- (error "Session binding failed")

     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