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

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

import Server
import Data.ByteString.Lazy.Char8 as L 
    ( hPutStrLn
    , unlines
    , 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  (xmlParseWith,element,{-doctypedecl,-}processinginstruction,elemOpenTag,elemCloseTag)
import Text.XML.HaXml.Types as Hax (ElemTag,QName(..),Namespace(..),Element(..),Content(..),AttValue(..))
import Data.Maybe
import Debug.Trace
import Control.Arrow
import LocalPeerCred
import Network.Socket



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>"
    ]

startCon sock st  = do
    let h = hOccursFst st :: Handle 
    cred <- getLocalPeerCred sock
    Prelude.putStrLn $ "PEER CRED: "++show cred
    pname <- getPeerName sock
    Prelude.putStrLn $ "PEER NAME: "++show pname
    return (ConnectionFinalizer (return ()) .*. st)

iq_query_unavailable host id mjid xmlns kind = L.unlines $
    [ "<iq type='error'"
    , "    from='" <++> host <++> "'"
    , case mjid of  Just jid -> "    to='" <++> jid <++> "'"
                    Nothing  -> ""
    , "    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

iqresult host id (Just rsrc) = L.unlines $
    [ "<iq type='result' id='" <++> id <++> "'>"
    , "<bind xmlns='urn:ietf:params:xml:ns:xmpp-bind'>"
    , "<jid>" <++> id <++> "@" <++> host <++> "/" <++> rsrc <++> "</jid>"
    , "</bind>"
    , "</iq> "
    ]
iqresult host id Nothing = L.unlines $
    [ "<iq type='result'"
    , "    id='" <++> id <++> "'"
    , "    from='" <++> host <++> "'"
    , "    /> "
    ]

iqresult_info host id mjid = L.unlines $
    [ "<iq type='result'"
    , "    from='" <++> host <++> "'"
    , case mjid of  Just jid -> "    to='" <++> jid <++> "'"
                    Nothing  -> ""
    , "    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 host (Elem _ attrs content) = do
    id <- fmap pack (lookup (N "id") attrs >>= unattr) 
    typ <- fmap pack (lookup (N "type") attrs >>= unattr)
    case typ of
      "set" -> do
        let string (CString _ s _) = [s]
        mplus (do
                rsrc <- listToMaybe . Prelude.concatMap string . tagcontent "resource" . tagcontent "bind" $ content
                Just $ iqresult host id (Just (pack rsrc)) )
              (do
                guard (hasElem "session" content)
                Just (iqresult host id Nothing))
                
      "get" -> trace ("iq-get "++show (attrs,content)) $ do
        (tag,as) <- lookup (N "xmlns") (anytagattrs content) 
        xmlns <- fmap pack $ listToMaybe . astring $ as
        let servicekind = case tag of { (N s) -> pack s ; _ -> "query" }
        case xmlns of
            "urn:xmpp:ping" -> do
                let to = case fmap pack (lookup (N "from") attrs >>= unattr) of
                            Just jid -> "to='" <++> jid <++> "' "
                            Nothing  -> ""
                Just $ "<iq from='" <++> host <++> "' " <++> to <++> "id='" <++> id <++> "' type='result'/>"

            _ -> Just (iq_query_unavailable host id Nothing xmlns servicekind)
      _ -> Nothing
    
-- <presence>
-- <priority>1</priority>
-- <c xmlns='http://jabber.org/protocol/caps' 
--     node='http://pidgin.im/' 
--     hash='sha-1' ver='lV6i//bt2U8Rm0REcX8h4F3Nk3M=' 
--     ext='voice-v1 camera-v1 video-v1'/>
-- <x xmlns='vcard-temp:x:update'/>
-- </presence>

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 
            host = "localhost"
            hsend r = do
                hPutStrLn h r
                L.putStrLn $ "SENT:\n" <++> r
 
        case elem of
            OpenTag _ -> 
                hsend (greet host)
            Element e@(Elem (N "iq") _ _) -> 
                case iqresponse host e 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

        putStrLn (show elem)
        cont ()

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

data XmppObject e i t c
    = Element e
    | ProcessingInstruction i
    | OpenTag t
    | CloseTag c
 deriving Show

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

xmppParse ls =
    case xmlParseWith element ls of
        (Right e,rs) -> (Right (Element e), rs)
        (Left _,_) -> 
          case xmlParseWith elemOpenTag ls of
            (Right e,rs) -> (Right (OpenTag e),rs)
            (Left _,_) -> 
              case xmlParseWith (elemCloseTag streamName) ls of
                (Right e,rs) -> (Right (CloseTag e),rs)
                (Left _,_) -> 
                  case xmlParseWith processinginstruction ls of
                    (Right e,rs) -> (Right (ProcessingInstruction e),rs)
                    (Left err,rs) -> (Left err,rs)
    


listenForXmppClients port st = do
    let (start,dopkt) = 
            adaptServer ( xmlLex "stream" . unpack
                        , xmppParse)
                        (startCon,doCon)
    doServer (port .*. st)
             dopkt
             start