{-# 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 = Just 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 j n gs session = do
    let el = pickleElem xpQuery (Query Nothing
                                 [QueryItem { qiApproved = Nothing
                                            , qiAsk = False
                                            , qiJid = j
                                            , qiName = n
                                            , qiSubscription = Nothing
                                            , qiGroups = nub gs
                                            }])
    sendIQA' timeout Nothing Set Nothing el [] session

-- | Synonym to rosterSet
rosterAdd :: Jid
          -> Maybe Text
          -> [Text]
          -> Session
          -> IO (Either IQSendError (Annotated IQResponse))
rosterAdd = 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 j sess = do
    roster <- getRoster sess
    case Map.lookup j (items roster) of
        Nothing -> return True -- jid is not on the Roster
        Just _ -> do
            res <- rosterPush (Item False False j Nothing Remove []) sess
            case res of
                Right (IQResponseResult IQResult{}, _) -> return True
                _ -> return False
  where
    rosterPush :: Item
               -> Session
               -> IO (Either IQSendError (Annotated IQResponse))
    rosterPush item session = do
        let el = pickleElem xpQuery (Query Nothing [fromItem item])
        sendIQA' timeout Nothing Set Nothing el [] session

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

-- | Retrieve the current Roster state
getRoster :: Session -> IO Roster
getRoster session = atomically $ getRosterSTM session

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

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

    badRequest (IQRequest iqid from _to lang _tp bd _attrs) =
        IQErrorS $ IQError iqid Nothing from lang errBR (Just bd) []
    errBR = StanzaError Cancel BadRequest Nothing Nothing
    result (IQRequest iqid from _to lang _tp _bd _attrs) =
        IQResultS $ IQResult iqid Nothing from lang Nothing []

retrieveRoster :: Maybe Roster -> Session -> IO (Maybe Roster)
retrieveRoster mbOldRoster sess = do
    useVersioning <- isJust . streamFeaturesRosterVer <$> getFeatures sess
    let version = if useVersioning
                then case mbOldRoster of
                      Nothing -> Just ""
                      Just oldRoster -> ver oldRoster
                else Nothing
    res <- sendIQ' timeout Nothing Get Nothing
                   (pickleElem xpQuery (Query version []))
                   []
                   sess
    case res of
        Left e -> do
            errorM "Pontarius.Xmpp.Roster" $ "getRoster: " ++ show e
            return Nothing
        Right (IQResponseResult IQResult{iqResultPayload = Just ros})
            -> case unpickleElem xpQuery ros of
            Left _e -> do
                errorM "Pontarius.Xmpp.Roster" "getRoster: invalid query element"
                return Nothing
            Right ros' -> return . Just $ toRoster ros'
        Right (IQResponseResult IQResult{iqResultPayload = Nothing}) -> do
            return mbOldRoster
                -- sever indicated that no roster updates are necessary
        Right (IQResponseError e) -> do
            errorM "Pontarius.Xmpp.Roster" $ "getRoster: server returned error"
                   ++ show e
            return Nothing
  where
    toRoster (Query v is) = Roster v (Map.fromList
                                             $ map (\i -> (qiJid i, toItem i))
                                               is)

toItem :: QueryItem -> Item
toItem qi = Item { riApproved = fromMaybe False (qiApproved qi)
                 , riAsk = qiAsk qi
                 , riJid = qiJid qi
                 , riName = qiName qi
                 , riSubscription = fromSubscription (qiSubscription qi)
                 , riGroups = nub $ qiGroups qi
                 }
  where
    fromSubscription Nothing = None
    fromSubscription (Just s) | s `elem` [None, To, From, Both] = s
                              | otherwise = None

fromItem :: Item -> QueryItem
fromItem i = QueryItem { qiApproved = Nothing
                       , qiAsk = False
                       , qiJid = riJid i
                       , qiName = riName i
                       , qiSubscription = case riSubscription i of
                           Remove -> Just Remove
                           _ -> Nothing
                       , qiGroups = nub $ riGroups i
                       }

xpItems :: PU [Node] [QueryItem]
xpItems = xpWrap (map (\((app_, ask_, jid_, name_, sub_), groups_) ->
                        QueryItem app_ ask_ jid_ name_ sub_ groups_))
                 (map (\(QueryItem app_ ask_ jid_ name_ sub_ groups_) ->
                        ((app_, ask_, jid_, name_, sub_), groups_))) $
          xpElems "{jabber:iq:roster}item"
          (xp5Tuple
            (xpAttribute' "approved" xpBool)
            (xpWrap isJust
                    (\p -> if p then Just () else Nothing) $
                     xpOption $ xpAttribute_ "ask" "subscribe")
            (xpAttribute  "jid" xpJid)
            (xpAttribute' "name" xpText)
            (xpAttribute' "subscription" xpSubscription)
          )
          (xpFindMatches $ xpElemText "{jabber:iq:roster}group")

xpQuery :: PU [Node] Query
xpQuery = xpWrap (\(ver_, items_) -> Query ver_ items_ )
                 (\(Query ver_ items_) -> (ver_, items_)) $
          xpElem "{jabber:iq:roster}query"
            (xpAttribute' "ver" xpText)
            xpItems

xpSubscription :: PU Text Subscription
xpSubscription = ("xpSubscription", "") <?>
        xpIso subscriptionFromText
              subscriptionToText
  where
    subscriptionFromText "none" = None
    subscriptionFromText "to" = To
    subscriptionFromText "from" = From
    subscriptionFromText "both" = Both
    subscriptionFromText "remove" = Remove
    subscriptionFromText _ = None
    subscriptionToText None = "none"
    subscriptionToText To = "to"
    subscriptionToText From = "from"
    subscriptionToText Both = "both"
    subscriptionToText Remove = "remove"