pontarius-xmpp/source/Network/Xmpp/Xep/InbandRegistration.hs

-- | XEP 0077: In-Band Registration
-- http://xmpp.org/extensions/xep-0077.html

{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE OverloadedStrings #-}

module Network.Xmpp.Xep.InbandRegistration where

import           Control.Applicative((<$>))
import           Control.Arrow(left)
import           Control.Exception
import           Control.Monad.Error
import           Control.Monad.State

import           Data.Either (partitionEithers)
import qualified Data.Text as Text
import           Data.XML.Pickle
import qualified Data.XML.Types as XML

import           Network.Xmpp.Internal
import           Network.Xmpp.Xep.ServiceDiscovery


-- In-Band Registration name space
ibrns :: Text.Text
ibrns = "jabber:iq:register"

ibrName x = (XML.Name x (Just ibrns) Nothing)

data IbrError = IbrNotSupported
              | IbrNoStream
              | IbrIQError IQError

                deriving (Show)
instance Error IbrError


data Query = Query { instructions :: Maybe Text.Text
                   , registered   :: Bool
                   , remove       :: Bool
                   , fields       ::[(Field, Maybe Text.Text)]
                   } deriving Show

emptyQuery = Query Nothing False False []

-- supported :: XmppConMonad (Either IbrError Bool)
-- supported = runErrorT $ fromFeatures <+> fromDisco
--   where
--   fromFeatures = do
--       fs <- other <$> gets sFeatures
--       let fe = XML.Element
--                    "{http://jabber.org/features/iq-register}register"
--                    []
--                    []
--       return $ fe `elem` fs
--   fromDisco = do
--       hn' <- gets sHostname
--       hn <- case hn' of
--           Just h -> return (Jid Nothing h Nothing)
--           Nothing -> throwError IbrNoStream
--       qi <- lift $ xmppQueryInfo Nothing Nothing
--       case qi of
--           Left e -> return False
--           Right qir -> return $ "jabber:iq:register" `elem` qiFeatures qir
--   f <+> g = do
--             r <- f
--             if r then return True else g


query :: IQRequestType -> Query -> TMVar Stream -> IO (Either IbrError Query)
query queryType x con = do
    answer <- pushIQ "ibr" Nothing queryType Nothing (pickleElem xpQuery x) con
    case answer of
        Right IQResult{iqResultPayload = Just b} ->
            case unpickleElem xpQuery b of
                Right query -> return $ Right query
                Left e -> throw . StreamXMLError $
                            "RequestField: unpickle failed, got "
                            ++ Text.unpack (ppUnpickleError e)
                            ++ " saw " ++ ppElement b
        Right _ -> return $ Right emptyQuery -- TODO: That doesn't seem right
        Left e -> return . Left $ IbrIQError e

data RegisterError = IbrError IbrError
                   | MissingFields   [Field]
                   | AlreadyRegistered
                     deriving (Show)

instance Error RegisterError

mapError f = mapErrorT (liftM $ left f)

-- | Retrieve the necessary fields and fill them in to register an account with
-- the server
registerWith :: [(Field, Text.Text)]
             -> TMVar Stream
             -> IO  (Either RegisterError Query)
registerWith givenFields con = runErrorT $ do
    fs <- mapError IbrError . ErrorT $ requestFields con
    when (registered fs) . throwError $ AlreadyRegistered
    let res = flip map (fields fs) $ \(field,_) ->
            case lookup field givenFields of
                Just entry -> Right (field, Just entry)
                Nothing -> Left field
    fields <- case partitionEithers res of
        ([],fs) -> return fs
        (fs,_) -> throwError $ MissingFields fs
    result <- mapError IbrError . ErrorT $ query Set (emptyQuery {fields}) con
    return result

-- | Terminate your account on the server. You have to be logged in for this to
-- work. You connection will most likely be terminated after unregistering.
unregister :: TMVar Stream -> IO (Either IbrError Query)
unregister = query Set $ emptyQuery {remove = True}

requestFields con = runErrorT $ do
--     supp <- ErrorT supported
--    unless supp $ throwError $ IbrNotSupported
    qr <- ErrorT $ query Get emptyQuery con
    return $ qr

xpQuery :: PU [XML.Node] Query
xpQuery = xpWrap
            (\(is, r, u, fs) -> Query is r u fs)
            (\(Query is r u fs) -> (is, r, u, fs)) $
            xpElemNodes (ibrName "query") $
              xp4Tuple
                 (xpOption $
                    xpElemNodes (ibrName "instructions") (xpContent $ xpText))
                 (xpElemExists (ibrName "registered"))
                 (xpElemExists (ibrName "remove"))
                 (xpAllByNamespace ibrns  ( xpWrap
                                              (\(name,_,c) -> (name, c))
                                              (\(name,c) -> (name,(),c)) $
                         xpElemByNamespace ibrns xpPrim xpUnit
                           (xpOption $ xpContent xpText)
                        ))

data Field = Username
           | Nick
           | Password
           | Name
           | First
           | Last
           | Email
           | Address
           | City
           | State
           | Zip
           | Phone
           | Url
           | Date
           | Misc
           | Text
           | Key
           | OtherField Text.Text
             deriving Eq

instance Show Field where
    show  Username       = "username"
    show  Nick           = "nick"
    show  Password       = "password"
    show  Name           = "name"
    show  First          = "first"
    show  Last           = "last"
    show  Email          = "email"
    show  Address        = "address"
    show  City           = "city"
    show  State          = "state"
    show  Zip            = "zip"
    show  Phone          = "phone"
    show  Url            = "url"
    show  Date           = "date"
    show  Misc           = "misc"
    show  Text           = "text"
    show  Key            = "key"
    show  (OtherField x) = Text.unpack x

instance Read Field where
    readsPrec _ "username" = [(Username     , "")]
    readsPrec _ "nick"     = [(Nick         , "")]
    readsPrec _ "password" = [(Password     , "")]
    readsPrec _ "name"     = [(Name         , "")]
    readsPrec _ "first"    = [(First        , "")]
    readsPrec _ "last"     = [(Last         , "")]
    readsPrec _ "email"    = [(Email        , "")]
    readsPrec _ "address"  = [(Address      , "")]
    readsPrec _ "city"     = [(City         , "")]
    readsPrec _ "state"    = [(State        , "")]
    readsPrec _ "zip"      = [(Zip          , "")]
    readsPrec _ "phone"    = [(Phone        , "")]
    readsPrec _ "url"      = [(Url          , "")]
    readsPrec _ "date"     = [(Date         , "")]
    readsPrec _ "misc"     = [(Misc         , "")]
    readsPrec _ "text"     = [(Text         , "")]
    readsPrec _ "key"      = [(Key          , "")]
    readsPrec _ x          = [(OtherField $ Text.pack x , "")]



-- Registered
-- Instructions

ppElement :: Element -> String
ppElement = Text.unpack . Text.decodeUtf8 . renderElement