path: root/Presence/XMPPServer.hs

{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ViewPatterns        #-}
{-# LANGUAGE TupleSections       #-}
{-# LANGUAGE TypeFamilies        #-}
-- {-# LANGUAGE GADTs               #-}
module XMPPServer where -- ( listenForXmppClients ) where

import Data.HList.TypeEqGeneric1()
import Data.HList.TypeCastGeneric1()
import ByteStringOperators

import Server
import Data.ByteString.Lazy.Char8 as L 
    ( hPutStrLn
    , unlines
    , ByteString
    , pack
    , unpack )
import qualified Data.ByteString.Lazy.Char8 as L 
    ( putStrLn )
import System.IO 
    ( Handle
    )
import Data.HList
import AdaptServer
import Text.XML.HaXml.Lex (xmlLex)
import Text.XML.HaXml.Parse  (XParser,xmlParseWith,element,{-doctypedecl,-}processinginstruction,elemOpenTag,elemCloseTag)
import Text.XML.HaXml.Types as Hax hiding (Element) -- (ElemTag,QName(..),Namespace(..),Element(..),Content(..),AttValue(..))
import qualified Text.XML.HaXml.Types as Hax (Element(..))
import Text.XML.HaXml.Posn (Posn)
import Text.XML.HaXml.Lex  (TokenT)
import qualified Text.XML.HaXml.Pretty as PP
import Text.PrettyPrint
import Data.Maybe
import Debug.Trace
import Control.Arrow
import LocalPeerCred
import Network.Socket
import Data.String
import Control.Monad.Trans.Maybe
import Control.Monad.IO.Class
import Control.DeepSeq
import Control.Concurrent.STM
import Control.Concurrent
import Control.Exception
import Text.Show.ByteString as L
import Data.Binary.Builder as B
import Data.Binary.Put

-- | Jabber ID (JID) datatype
data JID = JID { name :: Maybe ByteString
               , server :: ByteString
               , resource :: Maybe ByteString
               }
 deriving (Ord,Eq)

instance L.Show JID where
    showp (JID n s r ) = putBuilder . B.fromLazyByteString $ n <$++> "@" <?++> s <++?>  "/" <++$> r

instance Prelude.Show JID where
    show jid = L.unpack $ L.show jid

instance NFData JID where
    rnf v@(JID n s r) = n `seq` s `seq` r `seq` ()

jid user host rsrc = JID (Just user) host (Just rsrc)

data JabberShow = Offline
                | Away
                | Available
 deriving (Prelude.Show,Enum,Ord,Eq,Read)

data Presence = Presence JID JabberShow
 deriving Prelude.Show

xmlifyPresence (Presence jid stat) = L.unlines 
  [ "<presence from='" <++> L.show jid <++> "' " <++> typ stat <++> ">"
  , "<show>" <++> shw stat <++> "</show>"
  , "</presence>"
  ]
 where
    typ Offline = " type='unavailable'"
    typ _       = ""
    shw Available = "chat"
    shw Away      = "away"
    shw Offline   = "away" -- Is this right?

instance NFData Presence where
    rnf (Presence jid stat) = rnf jid `seq` stat `seq` ()


class XMPPSession session where
    data XMPPClass session
    newSession   :: XMPPClass session -> Socket -> Handle -> IO session
    setResource  :: session -> ByteString -> IO ()
    getJID       :: session -> IO JID
    closeSession :: session -> IO ()
    subscribe :: session -> Maybe JID -> IO (TChan Presence)


greet host = L.unlines 
    [ "<?xml version='1.0'?>"
    , "<stream:stream"
    , "from='" <++> host <++> "'"
    , "id='someid'"
    , "xmlns='jabber:client' xmlns:stream='http://etherx.jabber.org/streams' version='1.0'>"
    , "<stream:features>"
    , "  <bind xmlns='urn:ietf:params:xml:ns:xmpp-bind'/>"
    {-
    -- , "  <session xmlns='urn:ietf:params:xml:ns:xmpp-session'/>"
    , " <mechanisms xmlns='urn:ietf:params:xml:ns:xmpp-sasl'>"
    -- , " <mechanism>DIGEST-MD5</mechanism>"
    , " <mechanism>PLAIN</mechanism>"
    , " </mechanisms> "
    -}
    , "</stream:features>"
    ]

-- data TaggedXMPPSession s = TaggedXMPPSession s

data Commands = Send ByteString
 deriving Prelude.Show

startCon session_factory sock st  = do
    let h = hOccursFst st :: Handle 
    cred <- getLocalPeerCred sock
    Prelude.putStrLn $ "PEER CRED: "++Prelude.show cred
    pname <- getPeerName sock
    session <- newSession session_factory sock h
    Prelude.putStrLn $ "PEER NAME: "++Prelude.show pname
    pchan <- subscribe session Nothing
    cmdChan <- atomically newTChan
    reader <- forkIO $
        handle (\(SomeException _) -> L.putStrLn "quit reader via exception.") $
         fix $ \loop -> do
            event <- atomically $ 
                (fmap Left $ readTChan pchan)
              `orElse`
                (fmap Right $ readTChan cmdChan)
            case event of
                Left presence -> do
                    L.putStrLn $ "PRESENCE: " <++> bshow presence
                    -- TODO: it violates spec to send presence information before
                    --  a resource is bound.
                    let r = xmlifyPresence presence
                    hPutStrLn h r
                    L.putStrLn $ "\nOUT:\n" <++> r
                Right (Send r) ->
                    hPutStrLn h r
            loop
    let quit = do
            killThread reader
            closeSession session
    return ( (session,cmdChan) .*. ConnectionFinalizer quit .*. st)

iq_query_unavailable host id mjid xmlns kind = L.unlines $
    [ "<iq type='error'"
    , "    from='" <++> host <++> "'" <++?> " to='" <++$> mjid <$++> "'"
    , "    id='" <++> id <++> "'>"
    , "  <" <++> kind <++> " xmlns='" <++> xmlns <++> "'/>"
    , "  <error type='cancel'>"
    , "    <service-unavailable"
    , "        xmlns='urn:ietf:params:xml:ns:xmpp-stanzas'/>"
    , "  </error>"
    , "</iq>"
    ]

tagattrs tag content = Prelude.concatMap (\(CElem (Elem _ a _) _)->a) 
                          $ Prelude.filter (bindElem tag) content
anytagattrs content = Prelude.concatMap (\(CElem (Elem n a _) _)->map (second (n,)) a) content

bindElem tag (CElem (Elem (N n) _ _) _) | n==tag = True
bindElem _   _                                   = False

hasElem tag content =
  not . Prelude.null . Prelude.filter (bindElem tag) $ content

unattr (AttValue as) = listToMaybe $ Prelude.concatMap left as
    where left (Left x) = [x]
          left _        = []

astring (AttValue [Left s]) = [s]

tagcontent tag content = Prelude.concatMap (\(CElem (Elem _ _ c) _)->c) 
                              $ Prelude.filter (bindElem tag) content

iq_bind_reply id jid = L.unlines $
    [ "<iq type='result' id='" <++> id <++> "'>"
    , "<bind xmlns='urn:ietf:params:xml:ns:xmpp-bind'>"
    , "<jid>" <++> jid <++> "</jid>"
    , "</bind>"
    , "</iq> "
    ]
iq_session_reply host id = L.unlines $
    [ "<iq type='result'"
    , "    id='" <++> id <++> "'"
    , "    from='" <++> host <++> "'"
    , "    /> "
    ]

{-
iqresult_info host id mjid = L.unlines $
    [ "<iq type='result'"
    , "    from='" <++> host <++> "'" <++?> " to='" <++$> mjid <$++> "'"
    , "    id='" <++> id <++> "'>"
    , "  <query xmlns='http://jabber.org/protocol/disco#info'>"
    , "    <identity"
    , "       category='server'"
    , "       type='im'"
    , "       name='" <++> host <++> "'/>"
    , "    <feature var='http://jabber.org/protocol/disco#info'/>"
    , "    <feature var='http://jabber.org/protocol/disco#items'/>"
    , "  </query>"
    , "</iq>"
    ]
-}

iqresponse session host (Elem _ attrs content) = runMaybeT $ do
    id <- MaybeT . return $ fmap pack (lookup (N "id") attrs >>= unattr) 
    typ <- MaybeT . return $ fmap pack (lookup (N "type") attrs >>= unattr)
    case typ of
      "set" -> do
        let string (CString _ s _) = [s]
        mplus (do
                rsrc <- MaybeT . return . fmap pack $ listToMaybe . Prelude.concatMap string . tagcontent "resource" . tagcontent "bind" $ content
                -- let jid = "TODO" <++> "@" <++> host <++> "/" <++> pack rsrc
                liftIO $ do
                 setResource session rsrc
                 jid <- getJID session
                 return $ iq_bind_reply id (L.show jid) )
              (do
                guard (hasElem "session" content)
                return (iq_session_reply host id))
                
      "get" -> {- trace ("iq-get "++show (attrs,content)) $ -} do
        (tag,as) <- MaybeT . return $ lookup (N "xmlns") (anytagattrs content) 
        xmlns <- MaybeT . return $ fmap pack $ listToMaybe . astring $ as
        let servicekind = case tag of { (N s) -> pack s ; _ -> "query" }
        case xmlns of
            "urn:xmpp:ping" ->
                return $ 
                    "<iq from='" <++> host 
                    <++> ("' " <++?> "to='" <++$> fmap pack (lookup (N "from") attrs >>= unattr) <$++> "' ")
                    <++> "id='" <++> id <++> "' type='result'/>"

            _ -> return (iq_query_unavailable host id Nothing xmlns servicekind)
      _ -> MaybeT (return Nothing)
    

presence_response host (Elem _ attrs content) = do
    -- let id = fmap pack (lookup (N "id") attrs >>= unattr) 
    typ <- fmap pack (lookup (N "type") attrs >>= unattr)
    case typ of
        "subscribe" -> do
            -- <presence to='guest@localhost' type='subscribe'/>
            to <- fmap pack (lookup (N "to") attrs >>= unattr)
            Just $ "<presence to='" <++> to <++> "' type='subscribed'/>"
        _ -> Nothing

doCon st elem cont = do
        let h = hOccursFst st :: Handle 
            (session,cmdChan) = hHead st
            hsend r = do
                atomically $ writeTChan cmdChan (Send r)
                -- hPutStrLn h r
                L.putStrLn $ "\nOUT:\n" <++> r
        host <- fmap server $ getJID session
        
        putStrLn $ (Prelude.show $ hang (text "\nIN:") 2 $ pp elem) ++ "\n"

        case elem of
            OpenTag _ -> 
                hsend (greet host)
            Element e@(Elem (N "iq") _ _) -> do
                rpns <- iqresponse session host e
                case rpns of
                    Nothing -> trace "IGNORE: no response to <iq>" $ return ()
                    Just r -> hsend r
            Element e@(Elem (N "presence") _ _) ->
                case presence_response host e of
                    Nothing -> trace "IGNORE: no response to <presence>" $ return ()
                    Just r -> hsend r

            _ -> return () -- putStrLn $ "unhandled: "++show v

        cont ()

instance Prelude.Show Hax.ElemTag where
    show _ = "elemtag"

data XmppObject
    = Element (Hax.Element Posn)
    | ProcessingInstruction Hax.ProcessingInstruction
    | OpenTag ElemTag
    | CloseTag ()
 deriving Prelude.Show

pp (Element e) = PP.element e
pp o = fromString (Prelude.show o)

streamName = QN (Namespace {nsPrefix= "stream" , nsURI="http://etherx.jabber.org/streams" }) "stream" 

newtype TryParse p x e = Try (Either e p,[x])

instance Monad (TryParse p x) where
        return v = Try (Left v,[])
        Try (Left m,xs)  >>= k = k m
        Try (Right e,xs) >>= _ = Try (Right e,xs)

runTryParse (Try p) = p
mapRight f (Right x,ls) = (Right (f x),ls)
mapRight f (Left  y,ls) = (Left  y    ,ls)

xmppParse :: [(Posn, TokenT)] -> (Either String XmppObject, [(Posn, TokenT)])
xmppParse ls = runTryParse $ do
    let xml :: (t -> b) -> XParser t -> (Either String b, [(Posn, TokenT)])
        xml tag = mapRight tag . flip xmlParseWith ls
    Try . xml Element               $ element
    Try . xml OpenTag               $ elemOpenTag
    Try . xml CloseTag              $ elemCloseTag streamName
    Try . xml ProcessingInstruction $ processinginstruction
    

listenForXmppClients session_factory port st = do
    -- standard port: 5222
    let (start,dopkt) = 
            adaptServer ( xmlLex "local-client" . unpack
                        , xmppParse)
                        (startCon session_factory,doCon)
    doServer (port .*. st)
             dopkt
             start


startPeer session_factory sock st = do
    let h = hOccursFst st :: Handle 
    name <- fmap bshow $ getPeerName sock
    L.putStrLn $ "REMOTE: connected " <++> name
    let quit = L.putStrLn $ "REMOTE: disconnected " <++> name
    return ( ConnectionFinalizer quit .*. st )

doPeer st elem cont = do
    cont ()

listenForRemotePeers session_factory port st = do
    -- standard port: 5269
    let (start,dopkt) = 
            adaptServer ( xmlLex "remote-peer" . unpack
                        , xmppParse)
                        (startPeer session_factory,doPeer)
    doServer (port .*. st)
             dopkt
             start

seekRemotePeers session_factory st = do
    return ()