{-# OPTIONS_HADDOCK hide #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE OverloadedStrings #-}

module Network.Xmpp.IM.Roster where

import           Control.Applicative ((<$>))
import           Control.Concurrent.STM
import           Control.Monad
import           Data.List (nub)
#if MIN_VERSION_containers(0, 5, 0)
import qualified Data.Map.Strict as Map
#else
import qualified Data.Map as Map
#endif
import           Data.Maybe (isJust, fromMaybe)
import           Data.Text (Text)
import           Data.XML.Pickle
import           Data.XML.Types
import           System.Log.Logger

import           Network.Xmpp.Concurrent.Basic
import           Network.Xmpp.Concurrent.IQ
import           Network.Xmpp.Concurrent.Types
import           Network.Xmpp.IM.Roster.Types
import           Network.Xmpp.Marshal
import           Network.Xmpp.Types

-- | Timeout to use with IQ requests
timeout :: Maybe Integer
timeout :: Maybe Integer
timeout = Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
3000000 -- 3 seconds

-- | Add or update an item to the roster.
--
-- To update the item just send the complete set of new data.
rosterSet :: Jid -- ^ JID of the item
          -> Maybe Text -- ^ Name alias
          -> [Text] -- ^ Groups (duplicates will be removed)
          -> Session
          -> IO (Either IQSendError (Annotated IQResponse))
rosterSet :: Jid
-> Maybe Text
-> [Text]
-> Session
-> IO (Either IQSendError (Annotated IQResponse))
rosterSet Jid
j Maybe Text
n [Text]
gs Session
session = do
    let el :: Element
el = PU [Node] Query -> Query -> Element
forall a. PU [Node] a -> a -> Element
pickleElem PU [Node] Query
xpQuery (Maybe Text -> [QueryItem] -> Query
Query Maybe Text
forall a. Maybe a
Nothing
                                 [QueryItem { qiApproved :: Maybe Bool
qiApproved = Maybe Bool
forall a. Maybe a
Nothing
                                            , qiAsk :: Bool
qiAsk = Bool
False
                                            , qiJid :: Jid
qiJid = Jid
j
                                            , qiName :: Maybe Text
qiName = Maybe Text
n
                                            , qiSubscription :: Maybe Subscription
qiSubscription = Maybe Subscription
forall a. Maybe a
Nothing
                                            , qiGroups :: [Text]
qiGroups = [Text] -> [Text]
forall a. Eq a => [a] -> [a]
nub [Text]
gs
                                            }])
    Maybe Integer
-> Maybe Jid
-> IQRequestType
-> Maybe LangTag
-> Element
-> [ExtendedAttribute]
-> Session
-> IO (Either IQSendError (Annotated IQResponse))
sendIQA' Maybe Integer
timeout Maybe Jid
forall a. Maybe a
Nothing IQRequestType
Set Maybe LangTag
forall a. Maybe a
Nothing Element
el [] Session
session

-- | Synonym to rosterSet
rosterAdd :: Jid
          -> Maybe Text
          -> [Text]
          -> Session
          -> IO (Either IQSendError (Annotated IQResponse))
rosterAdd :: Jid
-> Maybe Text
-> [Text]
-> Session
-> IO (Either IQSendError (Annotated IQResponse))
rosterAdd = Jid
-> Maybe Text
-> [Text]
-> Session
-> IO (Either IQSendError (Annotated IQResponse))
rosterSet

-- | Remove an item from the roster. Return 'True' when the item is sucessfully
-- removed or if it wasn't in the roster to begin with.
rosterRemove :: Jid -> Session -> IO Bool
rosterRemove :: Jid -> Session -> IO Bool
rosterRemove Jid
j Session
sess = do
    Roster
roster <- Session -> IO Roster
getRoster Session
sess
    case Jid -> Map Jid Item -> Maybe Item
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Jid
j (Roster -> Map Jid Item
items Roster
roster) of
        Maybe Item
Nothing -> Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True -- jid is not on the Roster
        Just Item
_ -> do
            Either IQSendError (Annotated IQResponse)
res <- Item -> Session -> IO (Either IQSendError (Annotated IQResponse))
rosterPush (Bool -> Bool -> Jid -> Maybe Text -> Subscription -> [Text] -> Item
Item Bool
False Bool
False Jid
j Maybe Text
forall a. Maybe a
Nothing Subscription
Remove []) Session
sess
            case Either IQSendError (Annotated IQResponse)
res of
                Right (IQResponseResult IQResult{}, [Annotation]
_) -> Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
                Either IQSendError (Annotated IQResponse)
_ -> Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
  where
    rosterPush :: Item
               -> Session
               -> IO (Either IQSendError (Annotated IQResponse))
    rosterPush :: Item -> Session -> IO (Either IQSendError (Annotated IQResponse))
rosterPush Item
item Session
session = do
        let el :: Element
el = PU [Node] Query -> Query -> Element
forall a. PU [Node] a -> a -> Element
pickleElem PU [Node] Query
xpQuery (Maybe Text -> [QueryItem] -> Query
Query Maybe Text
forall a. Maybe a
Nothing [Item -> QueryItem
fromItem Item
item])
        Maybe Integer
-> Maybe Jid
-> IQRequestType
-> Maybe LangTag
-> Element
-> [ExtendedAttribute]
-> Session
-> IO (Either IQSendError (Annotated IQResponse))
sendIQA' Maybe Integer
timeout Maybe Jid
forall a. Maybe a
Nothing IQRequestType
Set Maybe LangTag
forall a. Maybe a
Nothing Element
el [] Session
session

-- | Retrieve the current Roster state (STM version)
getRosterSTM :: Session -> STM Roster
getRosterSTM :: Session -> STM Roster
getRosterSTM Session
session = TVar Roster -> STM Roster
forall a. TVar a -> STM a
readTVar (Session -> TVar Roster
rosterRef Session
session)

-- | Retrieve the current Roster state
getRoster :: Session -> IO Roster
getRoster :: Session -> IO Roster
getRoster Session
session = STM Roster -> IO Roster
forall a. STM a -> IO a
atomically (STM Roster -> IO Roster) -> STM Roster -> IO Roster
forall a b. (a -> b) -> a -> b
$ Session -> STM Roster
getRosterSTM Session
session

-- | Get the initial roster or refresh the roster. You don't need to call this
-- on your own.
initRoster :: Session -> IO ()
initRoster :: Session -> IO ()
initRoster Session
session = do
    Roster
oldRoster <- Session -> IO Roster
getRoster Session
session
    Maybe Roster
mbRoster <- Maybe Roster -> Session -> IO (Maybe Roster)
retrieveRoster (if Maybe Text -> Bool
forall a. Maybe a -> Bool
isJust (Roster -> Maybe Text
ver Roster
oldRoster) then Roster -> Maybe Roster
forall a. a -> Maybe a
Just Roster
oldRoster
                                                          else Maybe Roster
forall a. Maybe a
Nothing ) Session
session
    case Maybe Roster
mbRoster of
        Maybe Roster
Nothing -> [Char] -> [Char] -> IO ()
errorM [Char]
"Pontarius.Xmpp"
                          [Char]
"Server did not return a roster: "
        Just Roster
roster -> STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar Roster -> Roster -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar (Session -> TVar Roster
rosterRef Session
session) Roster
roster

handleRoster :: Maybe Jid
             -> TVar Roster
             -> RosterPushCallback
             -> StanzaHandler
handleRoster :: Maybe Jid -> TVar Roster -> RosterPushCallback -> StanzaHandler
handleRoster Maybe Jid
mbBoundJid TVar Roster
ref RosterPushCallback
onUpdate XmppElement -> IO (Either XmppFailure ())
out XmppElement
sta [Annotation]
_ = do
    case XmppElement
sta of
        XmppStanza (IQRequestS (iqr :: IQRequest
iqr@IQRequest{iqRequestPayload :: IQRequest -> Element
iqRequestPayload =
                                              iqb :: Element
iqb@Element{elementName :: Element -> Name
elementName = Name
en}}))
            | Name -> Maybe Text
nameNamespace Name
en Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"jabber:iq:roster" -> do
                let doHandle :: Bool
doHandle = case (IQRequest -> Maybe Jid
iqRequestFrom IQRequest
iqr, Maybe Jid
mbBoundJid) of
                        -- We don't need to check our own JID when the IQ
                        -- request was sent without a from address
                        (Maybe Jid
Nothing, Maybe Jid
_) -> Bool
True
                        -- We don't have a Jid bound, so we can't verify that
                        -- the from address matches our bare jid
                        (Just Jid
_fr, Maybe Jid
Nothing) -> Bool
False
                        -- Check that the from address matches our bare jid
                        (Just Jid
fr, Just Jid
boundJid) | Jid
fr Jid -> Jid -> Bool
forall a. Eq a => a -> a -> Bool
== Jid -> Jid
toBare Jid
boundJid -> Bool
True
                                                 | Bool
otherwise -> Bool
False
                if Bool
doHandle
                    then case PU [Node] Query -> Element -> Either UnpickleError Query
forall a. PU [Node] a -> Element -> Either UnpickleError a
unpickleElem PU [Node] Query
xpQuery Element
iqb of
                        Right Query{ queryVer :: Query -> Maybe Text
queryVer = Maybe Text
v
                                   , queryItems :: Query -> [QueryItem]
queryItems = [QueryItem
update]
                                   } -> do
                            Maybe Text -> QueryItem -> IO ()
handleUpdate Maybe Text
v QueryItem
update
                            Either XmppFailure ()
_ <- XmppElement -> IO (Either XmppFailure ())
out (XmppElement -> IO (Either XmppFailure ()))
-> (Stanza -> XmppElement) -> Stanza -> IO (Either XmppFailure ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Stanza -> XmppElement
XmppStanza (Stanza -> IO (Either XmppFailure ()))
-> Stanza -> IO (Either XmppFailure ())
forall a b. (a -> b) -> a -> b
$ IQRequest -> Stanza
result IQRequest
iqr
                            [(XmppElement, [Annotation])] -> IO [(XmppElement, [Annotation])]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []
                        Either UnpickleError Query
_ -> do
                            [Char] -> [Char] -> IO ()
errorM [Char]
"Pontarius.Xmpp" [Char]
"Invalid roster query"
                            Either XmppFailure ()
_ <- XmppElement -> IO (Either XmppFailure ())
out (XmppElement -> IO (Either XmppFailure ()))
-> (Stanza -> XmppElement) -> Stanza -> IO (Either XmppFailure ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Stanza -> XmppElement
XmppStanza (Stanza -> IO (Either XmppFailure ()))
-> Stanza -> IO (Either XmppFailure ())
forall a b. (a -> b) -> a -> b
$ IQRequest -> Stanza
badRequest IQRequest
iqr
                            [(XmppElement, [Annotation])] -> IO [(XmppElement, [Annotation])]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []
                    -- Don't handle roster pushes from unauthorized sources
                    else [(XmppElement, [Annotation])] -> IO [(XmppElement, [Annotation])]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [(XmppElement
sta, [])]
        XmppElement
_ -> [(XmppElement, [Annotation])] -> IO [(XmppElement, [Annotation])]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [(XmppElement
sta, [])]
  where
    handleUpdate :: Maybe Text -> QueryItem -> IO ()
handleUpdate Maybe Text
v' QueryItem
update = do
        Roster
oldRoster <- STM Roster -> IO Roster
forall a. STM a -> IO a
atomically (STM Roster -> IO Roster) -> STM Roster -> IO Roster
forall a b. (a -> b) -> a -> b
$ TVar Roster -> STM Roster
forall a. TVar a -> STM a
readTVar TVar Roster
ref
        case QueryItem -> Maybe Subscription
qiSubscription QueryItem
update of
         Just Subscription
Remove -> do
             let j :: Jid
j = QueryItem -> Jid
qiJid QueryItem
update
             RosterPushCallback
onUpdate Roster
oldRoster (RosterUpdate -> IO ()) -> RosterUpdate -> IO ()
forall a b. (a -> b) -> a -> b
$ Jid -> RosterUpdate
RosterUpdateRemove Jid
j
             (Map Jid Item -> Map Jid Item) -> IO ()
updateRoster (Jid -> Map Jid Item -> Map Jid Item
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete Jid
j)
         Maybe Subscription
_ -> do
             let i :: Item
i = (QueryItem -> Item
toItem QueryItem
update)
             RosterPushCallback
onUpdate Roster
oldRoster (RosterUpdate -> IO ()) -> RosterUpdate -> IO ()
forall a b. (a -> b) -> a -> b
$ Item -> RosterUpdate
RosterUpdateAdd Item
i
             (Map Jid Item -> Map Jid Item) -> IO ()
updateRoster ((Map Jid Item -> Map Jid Item) -> IO ())
-> (Map Jid Item -> Map Jid Item) -> IO ()
forall a b. (a -> b) -> a -> b
$ Jid -> Item -> Map Jid Item -> Map Jid Item
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (QueryItem -> Jid
qiJid QueryItem
update) Item
i
      where
        updateRoster :: (Map Jid Item -> Map Jid Item) -> IO ()
updateRoster Map Jid Item -> Map Jid Item
f = STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ())
-> ((Roster -> Roster) -> STM ()) -> (Roster -> Roster) -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TVar Roster -> (Roster -> Roster) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar Roster
ref ((Roster -> Roster) -> IO ()) -> (Roster -> Roster) -> IO ()
forall a b. (a -> b) -> a -> b
$
                           \(Roster Maybe Text
v Map Jid Item
is) -> Maybe Text -> Map Jid Item -> Roster
Roster (Maybe Text
v' Maybe Text -> Maybe Text -> Maybe Text
forall a. Maybe a -> Maybe a -> Maybe a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` Maybe Text
v) (Map Jid Item -> Map Jid Item
f Map Jid Item
is)

    badRequest :: IQRequest -> Stanza
badRequest (IQRequest Text
iqid Maybe Jid
from Maybe Jid
_to Maybe LangTag
lang IQRequestType
_tp Element
bd [ExtendedAttribute]
_attrs) =
        IQError -> Stanza
IQErrorS (IQError -> Stanza) -> IQError -> Stanza
forall a b. (a -> b) -> a -> b
$ Text
-> Maybe Jid
-> Maybe Jid
-> Maybe LangTag
-> StanzaError
-> Maybe Element
-> [ExtendedAttribute]
-> IQError
IQError Text
iqid Maybe Jid
forall a. Maybe a
Nothing Maybe Jid
from Maybe LangTag
lang StanzaError
errBR (Element -> Maybe Element
forall a. a -> Maybe a
Just Element
bd) []
    errBR :: StanzaError
errBR = StanzaErrorType
-> StanzaErrorCondition
-> Maybe (Maybe LangTag, NonemptyText)
-> Maybe Element
-> StanzaError
StanzaError StanzaErrorType
Cancel StanzaErrorCondition
BadRequest Maybe (Maybe LangTag, NonemptyText)
forall a. Maybe a
Nothing Maybe Element
forall a. Maybe a
Nothing
    result :: IQRequest -> Stanza
result (IQRequest Text
iqid Maybe Jid
from Maybe Jid
_to Maybe LangTag
lang IQRequestType
_tp Element
_bd [ExtendedAttribute]
_attrs) =
        IQResult -> Stanza
IQResultS (IQResult -> Stanza) -> IQResult -> Stanza
forall a b. (a -> b) -> a -> b
$ Text
-> Maybe Jid
-> Maybe Jid
-> Maybe LangTag
-> Maybe Element
-> [ExtendedAttribute]
-> IQResult
IQResult Text
iqid Maybe Jid
forall a. Maybe a
Nothing Maybe Jid
from Maybe LangTag
lang Maybe Element
forall a. Maybe a
Nothing []

retrieveRoster :: Maybe Roster -> Session -> IO (Maybe Roster)
retrieveRoster :: Maybe Roster -> Session -> IO (Maybe Roster)
retrieveRoster Maybe Roster
mbOldRoster Session
sess = do
    Bool
useVersioning <- Maybe Bool -> Bool
forall a. Maybe a -> Bool
isJust (Maybe Bool -> Bool)
-> (StreamFeatures -> Maybe Bool) -> StreamFeatures -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StreamFeatures -> Maybe Bool
streamFeaturesRosterVer (StreamFeatures -> Bool) -> IO StreamFeatures -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Session -> IO StreamFeatures
getFeatures Session
sess
    let version :: Maybe Text
version = if Bool
useVersioning
                then case Maybe Roster
mbOldRoster of
                      Maybe Roster
Nothing -> Text -> Maybe Text
forall a. a -> Maybe a
Just Text
""
                      Just Roster
oldRoster -> Roster -> Maybe Text
ver Roster
oldRoster
                else Maybe Text
forall a. Maybe a
Nothing
    Either IQSendError IQResponse
res <- Maybe Integer
-> Maybe Jid
-> IQRequestType
-> Maybe LangTag
-> Element
-> [ExtendedAttribute]
-> Session
-> IO (Either IQSendError IQResponse)
sendIQ' Maybe Integer
timeout Maybe Jid
forall a. Maybe a
Nothing IQRequestType
Get Maybe LangTag
forall a. Maybe a
Nothing
                   (PU [Node] Query -> Query -> Element
forall a. PU [Node] a -> a -> Element
pickleElem PU [Node] Query
xpQuery (Maybe Text -> [QueryItem] -> Query
Query Maybe Text
version []))
                   []
                   Session
sess
    case Either IQSendError IQResponse
res of
        Left IQSendError
e -> do
            [Char] -> [Char] -> IO ()
errorM [Char]
"Pontarius.Xmpp.Roster" ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"getRoster: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ IQSendError -> [Char]
forall a. Show a => a -> [Char]
show IQSendError
e
            Maybe Roster -> IO (Maybe Roster)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Roster
forall a. Maybe a
Nothing
        Right (IQResponseResult IQResult{iqResultPayload :: IQResult -> Maybe Element
iqResultPayload = Just Element
ros})
            -> case PU [Node] Query -> Element -> Either UnpickleError Query
forall a. PU [Node] a -> Element -> Either UnpickleError a
unpickleElem PU [Node] Query
xpQuery Element
ros of
            Left UnpickleError
_e -> do
                [Char] -> [Char] -> IO ()
errorM [Char]
"Pontarius.Xmpp.Roster" [Char]
"getRoster: invalid query element"
                Maybe Roster -> IO (Maybe Roster)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Roster
forall a. Maybe a
Nothing
            Right Query
ros' -> Maybe Roster -> IO (Maybe Roster)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Roster -> IO (Maybe Roster))
-> (Roster -> Maybe Roster) -> Roster -> IO (Maybe Roster)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Roster -> Maybe Roster
forall a. a -> Maybe a
Just (Roster -> IO (Maybe Roster)) -> Roster -> IO (Maybe Roster)
forall a b. (a -> b) -> a -> b
$ Query -> Roster
toRoster Query
ros'
        Right (IQResponseResult IQResult{iqResultPayload :: IQResult -> Maybe Element
iqResultPayload = Maybe Element
Nothing}) -> do
            Maybe Roster -> IO (Maybe Roster)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Roster
mbOldRoster
                -- sever indicated that no roster updates are necessary
        Right (IQResponseError IQError
e) -> do
            [Char] -> [Char] -> IO ()
errorM [Char]
"Pontarius.Xmpp.Roster" ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"getRoster: server returned error"
                   [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ IQError -> [Char]
forall a. Show a => a -> [Char]
show IQError
e
            Maybe Roster -> IO (Maybe Roster)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Roster
forall a. Maybe a
Nothing
  where
    toRoster :: Query -> Roster
toRoster (Query Maybe Text
v [QueryItem]
is) = Maybe Text -> Map Jid Item -> Roster
Roster Maybe Text
v ([(Jid, Item)] -> Map Jid Item
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
                                             ([(Jid, Item)] -> Map Jid Item) -> [(Jid, Item)] -> Map Jid Item
forall a b. (a -> b) -> a -> b
$ (QueryItem -> (Jid, Item)) -> [QueryItem] -> [(Jid, Item)]
forall a b. (a -> b) -> [a] -> [b]
map (\QueryItem
i -> (QueryItem -> Jid
qiJid QueryItem
i, QueryItem -> Item
toItem QueryItem
i))
                                               [QueryItem]
is)

toItem :: QueryItem -> Item
toItem :: QueryItem -> Item
toItem QueryItem
qi = Item { riApproved :: Bool
riApproved = Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
False (QueryItem -> Maybe Bool
qiApproved QueryItem
qi)
                 , riAsk :: Bool
riAsk = QueryItem -> Bool
qiAsk QueryItem
qi
                 , riJid :: Jid
riJid = QueryItem -> Jid
qiJid QueryItem
qi
                 , riName :: Maybe Text
riName = QueryItem -> Maybe Text
qiName QueryItem
qi
                 , riSubscription :: Subscription
riSubscription = Maybe Subscription -> Subscription
fromSubscription (QueryItem -> Maybe Subscription
qiSubscription QueryItem
qi)
                 , riGroups :: [Text]
riGroups = [Text] -> [Text]
forall a. Eq a => [a] -> [a]
nub ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ QueryItem -> [Text]
qiGroups QueryItem
qi
                 }
  where
    fromSubscription :: Maybe Subscription -> Subscription
fromSubscription Maybe Subscription
Nothing = Subscription
None
    fromSubscription (Just Subscription
s) | Subscription
s Subscription -> [Subscription] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Subscription
None, Subscription
To, Subscription
From, Subscription
Both] = Subscription
s
                              | Bool
otherwise = Subscription
None

fromItem :: Item -> QueryItem
fromItem :: Item -> QueryItem
fromItem Item
i = QueryItem { qiApproved :: Maybe Bool
qiApproved = Maybe Bool
forall a. Maybe a
Nothing
                       , qiAsk :: Bool
qiAsk = Bool
False
                       , qiJid :: Jid
qiJid = Item -> Jid
riJid Item
i
                       , qiName :: Maybe Text
qiName = Item -> Maybe Text
riName Item
i
                       , qiSubscription :: Maybe Subscription
qiSubscription = case Item -> Subscription
riSubscription Item
i of
                           Subscription
Remove -> Subscription -> Maybe Subscription
forall a. a -> Maybe a
Just Subscription
Remove
                           Subscription
_ -> Maybe Subscription
forall a. Maybe a
Nothing
                       , qiGroups :: [Text]
qiGroups = [Text] -> [Text]
forall a. Eq a => [a] -> [a]
nub ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ Item -> [Text]
riGroups Item
i
                       }

xpItems :: PU [Node] [QueryItem]
xpItems :: PU [Node] [QueryItem]
xpItems = ([((Maybe Bool, Bool, Jid, Maybe Text, Maybe Subscription),
   [Text])]
 -> [QueryItem])
-> ([QueryItem]
    -> [((Maybe Bool, Bool, Jid, Maybe Text, Maybe Subscription),
         [Text])])
-> PU
     [Node]
     [((Maybe Bool, Bool, Jid, Maybe Text, Maybe Subscription), [Text])]
-> PU [Node] [QueryItem]
forall a b t. (a -> b) -> (b -> a) -> PU t a -> PU t b
xpWrap ((((Maybe Bool, Bool, Jid, Maybe Text, Maybe Subscription), [Text])
 -> QueryItem)
-> [((Maybe Bool, Bool, Jid, Maybe Text, Maybe Subscription),
     [Text])]
-> [QueryItem]
forall a b. (a -> b) -> [a] -> [b]
map (\((Maybe Bool
app_, Bool
ask_, Jid
jid_, Maybe Text
name_, Maybe Subscription
sub_), [Text]
groups_) ->
                        Maybe Bool
-> Bool
-> Jid
-> Maybe Text
-> Maybe Subscription
-> [Text]
-> QueryItem
QueryItem Maybe Bool
app_ Bool
ask_ Jid
jid_ Maybe Text
name_ Maybe Subscription
sub_ [Text]
groups_))
                 ((QueryItem
 -> ((Maybe Bool, Bool, Jid, Maybe Text, Maybe Subscription),
     [Text]))
-> [QueryItem]
-> [((Maybe Bool, Bool, Jid, Maybe Text, Maybe Subscription),
     [Text])]
forall a b. (a -> b) -> [a] -> [b]
map (\(QueryItem Maybe Bool
app_ Bool
ask_ Jid
jid_ Maybe Text
name_ Maybe Subscription
sub_ [Text]
groups_) ->
                        ((Maybe Bool
app_, Bool
ask_, Jid
jid_, Maybe Text
name_, Maybe Subscription
sub_), [Text]
groups_))) (PU
   [Node]
   [((Maybe Bool, Bool, Jid, Maybe Text, Maybe Subscription), [Text])]
 -> PU [Node] [QueryItem])
-> PU
     [Node]
     [((Maybe Bool, Bool, Jid, Maybe Text, Maybe Subscription), [Text])]
-> PU [Node] [QueryItem]
forall a b. (a -> b) -> a -> b
$
          Name
-> PU
     [Attribute] (Maybe Bool, Bool, Jid, Maybe Text, Maybe Subscription)
-> PU [Node] [Text]
-> PU
     [Node]
     [((Maybe Bool, Bool, Jid, Maybe Text, Maybe Subscription), [Text])]
forall a n.
Name -> PU [Attribute] a -> PU [Node] n -> PU [Node] [(a, n)]
xpElems Name
"{jabber:iq:roster}item"
          (PU [Attribute] (Maybe Bool)
-> PU [Attribute] Bool
-> PU [Attribute] Jid
-> PU [Attribute] (Maybe Text)
-> PU [Attribute] (Maybe Subscription)
-> PU
     [Attribute] (Maybe Bool, Bool, Jid, Maybe Text, Maybe Subscription)
forall a a1 a2 a3 a4 a5.
PU [a] a1
-> PU [a] a2
-> PU [a] a3
-> PU [a] a4
-> PU [a] a5
-> PU [a] (a1, a2, a3, a4, a5)
xp5Tuple
            (Name -> PU Text Bool -> PU [Attribute] (Maybe Bool)
forall a. Name -> PU Text a -> PU [Attribute] (Maybe a)
xpAttribute' Name
"approved" PU Text Bool
xpBool)
            ((Maybe () -> Bool)
-> (Bool -> Maybe ())
-> PU [Attribute] (Maybe ())
-> PU [Attribute] Bool
forall a b t. (a -> b) -> (b -> a) -> PU t a -> PU t b
xpWrap Maybe () -> Bool
forall a. Maybe a -> Bool
isJust
                    (\Bool
p -> if Bool
p then () -> Maybe ()
forall a. a -> Maybe a
Just () else Maybe ()
forall a. Maybe a
Nothing) (PU [Attribute] (Maybe ()) -> PU [Attribute] Bool)
-> PU [Attribute] (Maybe ()) -> PU [Attribute] Bool
forall a b. (a -> b) -> a -> b
$
                     PU [Attribute] () -> PU [Attribute] (Maybe ())
forall t a. PU [t] a -> PU [t] (Maybe a)
xpOption (PU [Attribute] () -> PU [Attribute] (Maybe ()))
-> PU [Attribute] () -> PU [Attribute] (Maybe ())
forall a b. (a -> b) -> a -> b
$ Name -> Text -> PU [Attribute] ()
xpAttribute_ Name
"ask" Text
"subscribe")
            (Name -> PU Text Jid -> PU [Attribute] Jid
forall a. Name -> PU Text a -> PU [Attribute] a
xpAttribute  Name
"jid" PU Text Jid
xpJid)
            (Name -> PU Text Text -> PU [Attribute] (Maybe Text)
forall a. Name -> PU Text a -> PU [Attribute] (Maybe a)
xpAttribute' Name
"name" PU Text Text
xpText)
            (Name -> PU Text Subscription -> PU [Attribute] (Maybe Subscription)
forall a. Name -> PU Text a -> PU [Attribute] (Maybe a)
xpAttribute' Name
"subscription" PU Text Subscription
xpSubscription)
          )
          (PU [Node] Text -> PU [Node] [Text]
forall b a. PU [b] a -> PU [b] [a]
xpFindMatches (PU [Node] Text -> PU [Node] [Text])
-> PU [Node] Text -> PU [Node] [Text]
forall a b. (a -> b) -> a -> b
$ Name -> PU [Node] Text
xpElemText Name
"{jabber:iq:roster}group")

xpQuery :: PU [Node] Query
xpQuery :: PU [Node] Query
xpQuery = ((Maybe Text, [QueryItem]) -> Query)
-> (Query -> (Maybe Text, [QueryItem]))
-> PU [Node] (Maybe Text, [QueryItem])
-> PU [Node] Query
forall a b t. (a -> b) -> (b -> a) -> PU t a -> PU t b
xpWrap (\(Maybe Text
ver_, [QueryItem]
items_) -> Maybe Text -> [QueryItem] -> Query
Query Maybe Text
ver_ [QueryItem]
items_ )
                 (\(Query Maybe Text
ver_ [QueryItem]
items_) -> (Maybe Text
ver_, [QueryItem]
items_)) (PU [Node] (Maybe Text, [QueryItem]) -> PU [Node] Query)
-> PU [Node] (Maybe Text, [QueryItem]) -> PU [Node] Query
forall a b. (a -> b) -> a -> b
$
          Name
-> PU [Attribute] (Maybe Text)
-> PU [Node] [QueryItem]
-> PU [Node] (Maybe Text, [QueryItem])
forall a n.
Name -> PU [Attribute] a -> PU [Node] n -> PU [Node] (a, n)
xpElem Name
"{jabber:iq:roster}query"
            (Name -> PU Text Text -> PU [Attribute] (Maybe Text)
forall a. Name -> PU Text a -> PU [Attribute] (Maybe a)
xpAttribute' Name
"ver" PU Text Text
xpText)
            PU [Node] [QueryItem]
xpItems

xpSubscription :: PU Text Subscription
xpSubscription :: PU Text Subscription
xpSubscription = (Text
"xpSubscription", Text
"") (Text, Text) -> PU Text Subscription -> PU Text Subscription
forall t a. (Text, Text) -> PU t a -> PU t a
<?>
        (Text -> Subscription)
-> (Subscription -> Text) -> PU Text Subscription
forall a b. (a -> b) -> (b -> a) -> PU a b
xpIso Text -> Subscription
forall {a}. (Eq a, IsString a) => a -> Subscription
subscriptionFromText
              Subscription -> Text
forall {a}. IsString a => Subscription -> a
subscriptionToText
  where
    subscriptionFromText :: a -> Subscription
subscriptionFromText a
"none" = Subscription
None
    subscriptionFromText a
"to" = Subscription
To
    subscriptionFromText a
"from" = Subscription
From
    subscriptionFromText a
"both" = Subscription
Both
    subscriptionFromText a
"remove" = Subscription
Remove
    subscriptionFromText a
_ = Subscription
None
    subscriptionToText :: Subscription -> a
subscriptionToText Subscription
None = a
"none"
    subscriptionToText Subscription
To = a
"to"
    subscriptionToText Subscription
From = a
"from"
    subscriptionToText Subscription
Both = a
"both"
    subscriptionToText Subscription
Remove = a
"remove"