path: root/Presence/XMPPServer.hs

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

import Todo
import Data.HList.TypeEqGeneric1()
import Data.HList.TypeCastGeneric1()
import ByteStringOperators
import System.IO 
    ( IOMode(..)
    , BufferMode(..)
    , hSetBuffering
    )

import Server
import Data.ByteString.Lazy.Char8 as L 
    ( hPutStrLn
    , unlines
    , lines
    , splitWith
    , drop
    , 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,TokenT(..))
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, posnLine, posnColumn)
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 as Exception
import Text.Show.ByteString as L
import Data.Binary.Builder as B
import Data.Binary.Put
import qualified Data.Map as Map
import GHC.Conc
import Network.BSD
import Control.Concurrent.Async
import qualified Data.Set as Set

-- | 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)
    announcePresence :: session -> Presence -> IO ()

class XMPPConfig config where
    getBuddies :: config -> ByteString -> IO [ByteString]
    getSubscribers :: config -> ByteString -> IO [ByteString]

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 ( dropTill
                        , xmlLexPartial "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-IN: connected " <++> name
    let quit = L.putStrLn $ "REMOTE-IN: disconnected " <++> name
    session <- newSession session_factory sock h
    return ( session .*. ConnectionFinalizer quit .*. st )

doPeer st elem cont = do
    let session = hHead st
    L.putStrLn $ "REMOTE-IN: received " <++> bshow elem
    case elem of
      Element e@(Elem (N "presence") attrs content) -> do
        let jid = fmap pack (lookup (N "from") attrs >>= unattr)
            typ = fmap pack (lookup (N "type") attrs >>= unattr)
        case (jid,typ) of
          (Just jid,Just "unavailable") -> do
            L.putStrLn $ "INBOUND PRESENCE! Offline jid=" <++> jid
            announcePresence session (Presence (parseJID jid) Offline)
          (Just jid,Just typ) -> 
            -- possible probe, ignored for now
            L.putStrLn $ "INBOUND PRESENCE! "<++>typ<++>" jid="<++>jid
          (Just jid,Nothing) -> do
            let string (CString _ s _) = [s]
                show = listToMaybe . Prelude.concatMap string . tagcontent "show" $ content

            -- Available or Away.
            L.putStrLn $ "INBOUND PRESENCE! avail/away jid=" <++> jid
            -- todo: announcePresence
      _ -> return () -- putStrLn $ "inbound unhandled: "++show v
    cont ()

xmlLexPartial name cs =
    let ls = xmlLex name cs
        isTokError (_,TokError _) = True
        isTokError _              = False
        (gs,bs) = break isTokError ls
    in if any (not . isTokError) bs
        then ls
        else gs
        

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

dropTill bs ((fst->posn):_) =
  let ls = zip [1..] (L.lines bs)
      ln = posnLine posn
      col = posnColumn posn
      ls' = map snd $ dropWhile ((<ln).fst) ls
  in case ls' of
        []           -> ""
        fstLine:ls'' -> foldr1 (<++>) (L.drop (fromIntegral (col-1)) fstLine : ls'')


data OutBoundMessage = OutBoundPresence Presence
 deriving Prelude.Show

newServerConnections = atomically $ newTVar Map.empty

sendMessage cons msg peer = do
    found <- atomically $ do
        consmap <- readTVar cons
        return (Map.lookup peer consmap)
    let newEntry = do
          chan <- atomically newTChan
          t <- forkIO $ connect_to_server chan peer
          L.putStrLn $ "remote-map new: " <++> peer
          return (True,(chan,t))
    (is_new,entry) <- maybe newEntry
          ( \(chan,t) -> do 
                        st <- threadStatus t
                        let running = do
                                L.putStrLn $ "remote-map, thread running: " <++> peer
                                return (False,(chan,t))
                            died = do
                                L.putStrLn $ "remote-map, thread died("<++>bshow st<++>"): " <++> peer
                                newEntry 
                        case st of 
                          ThreadRunning   -> running
                          ThreadBlocked _ -> running
                          ThreadDied      -> died
                          ThreadFinished  -> died
                        )
          found
    L.putStrLn $ "sendMessage ->"<++>peer<++>": "<++>bshow msg
    atomically $ writeTChan (fst entry) msg
    when is_new . atomically $
        readTVar cons >>= writeTVar cons . Map.insert peer entry

connect_to_server chan peer = (>> return ()) . runMaybeT $ do
    let port = "5269"

    connected <- liftIO . async $ connect' (unpack peer) port

    -- We'll cache Presence notifications until the socket
    -- is ready.
    cached <- liftIO $ newIORef Map.empty

    sock <- MaybeT . fix $ \loop -> do
        e <- atomically $ orElse
                (fmap Right $ waitSTM connected)
                (fmap Left  $ readTChan chan)
        case e of
            Left (OutBoundPresence (Presence jid Offline)) -> do
                cached_map <- readIORef cached
                writeIORef cached (Map.delete jid cached_map)
                loop
            Left (OutBoundPresence p@(Presence jid st)) -> do
                cached_map <- readIORef cached
                writeIORef cached (Map.insert jid st cached_map)
                loop
            {-
            Left event -> do
                L.putStrLn $ "REMOTE-OUT DISCARDED: " <++> bshow event
                loop
            -}
            Right sock -> return sock

    liftIO $ do
        h <- socketToHandle sock ReadWriteMode
        hSetBuffering h NoBuffering
        hPutStrLn h "<stream>"
        L.putStrLn $ "REMOTE-OUT: <stream>"
        cache <- fmap Map.assocs . readIORef $ cached
        writeIORef cached Map.empty -- hint garbage collector: we're done with this
        forM_ cache $ \(jid,st) -> do
            let r = xmlifyPresence (Presence jid st)
            hPutStrLn h r
            L.putStrLn $ "REMOTE-OUT (cache):\n" <++> r <++> "\n"
        fix $ \loop -> do
            event <- atomically $ readTChan chan
            case event of
              OutBoundPresence p -> do
                let r = xmlifyPresence p
                hPutStrLn h r
                L.putStrLn $ "REMOTE-OUT:\n" <++> r <++> "\n"
            loop
        hPutStrLn h "</stream>"
        L.putStrLn $ "REMOTE-OUT: </stream>"


parseJID :: ByteString -> JID
parseJID bjid = 
    let xs = L.splitWith (=='@') bjid
        ys = L.splitWith (=='/') (last xs)
        (name,server) 
            = case xs of
                (n:s:_) -> (Just n,s)
                (s:_)   -> (Nothing,s)
        rsrc = case ys of
                (s:_:_) -> Just $ last ys
                _       -> Nothing
    in JID name server rsrc

connect' :: HostName -> ServiceName -> IO (Maybe Socket)
connect' host serv = do
    proto <- getProtocolNumber "tcp"
    let hints = defaultHints { addrFlags = [AI_ADDRCONFIG]
                             , addrProtocol = proto
                             , addrSocketType = Stream }
    addrs <- getAddrInfo (Just hints) (Just host) (Just serv)
    firstSuccessful $ map tryToConnect addrs
  where
  tryToConnect addr =
    bracketOnError
        (socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr))
        (sClose )  -- only done if there's an error
        (\sock -> do
          connect sock (addrAddress addr)
          return (Just sock) -- socketToHandle sock ReadWriteMode
        )

catchIO :: IO a -> (IOException -> IO a) -> IO a
catchIO a h = Exception.catch a h

-- Returns the first action from a list which does not throw an exception.
-- If all the actions throw exceptions (and the list of actions is not empty),
-- the last exception is thrown.
firstSuccessful :: [IO a] -> IO a
firstSuccessful [] = error "firstSuccessful: empty list"
firstSuccessful (p:ps) = catchIO p $ \e ->
    case ps of
        [] -> Exception.throwIO e
        _  -> firstSuccessful ps


seekRemotePeers :: XMPPConfig config =>
     (ByteString -> Bool) -> config -> TChan Presence -> IO b0
seekRemotePeers is_peer config chan = do
    server_connections <- newServerConnections
    fix $ \loop -> do
        event <- atomically $ readTChan chan
        case event of
            p@(Presence jid stat) -> do
              L.putStrLn $ "seekRemotePeers: " <++> L.show jid <++> " " <++> bshow stat
              runMaybeT $ do
                  u <- MaybeT . return $ name jid
                  subscribers <- liftIO $ getSubscribers config u
                  liftIO . L.putStrLn $ "subscribers: " <++> bshow subscribers
                  let peers = Set.map (server . parseJID) (Set.fromList subscribers)
                  forM_ (Set.toList peers) $ \peer -> do
                    when (is_peer peer) $
                        liftIO $ sendMessage server_connections (OutBoundPresence p) peer
        loop