{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ViewPatterns        #-}
{-# LANGUAGE TupleSections       #-}
{-# LANGUAGE TypeFamilies        #-}
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


class XMPPSession session where
    data XMPPClass session
    newSession   :: XMPPClass session -> Socket -> Handle -> IO session
    setResource  :: session -> ByteString -> IO ()
    getJID       :: session -> IO ByteString
    closeSession :: session -> IO ()


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

newtype TaggedXMPPSession s = TaggedXMPPSession s

startCon session_factory sock st  = do
    let h = hOccursFst st :: Handle 
    cred <- getLocalPeerCred sock
    Prelude.putStrLn $ "PEER CRED: "++show cred
    pname <- getPeerName sock
    session <- newSession session_factory sock h
    Prelude.putStrLn $ "PEER NAME: "++show pname
    
    return ( ConnectionFinalizer (return ()) 
           .*. TaggedXMPPSession session
           .*. 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

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 <++> "'"
    , 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
                let jid = "TODO" <++> "@" <++> host <++> "/" <++> pack rsrc
                Just $ iq_bind_reply id jid )
              (do
                guard (hasElem "session" content)
                Just (iq_session_reply host id))
                
      "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 $ "\nOUT:\n" <++> r
 
        putStrLn $ (show $ hang (text "\nIN:") 2 $ pp elem) ++ "\n"

        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

        cont ()

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

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

pp (Element e) = PP.element e
pp o = fromString (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

{-
xmppParseOld :: [(Posn, TokenT)] -> (Either String XmppObject, [(Posn, TokenT)])
xmppParseOld 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 (),rs) -> (Right (CloseTag ()),rs)
                (Left _,_) ->
                  case xmlParseWith processinginstruction ls of
                    (Right e,rs) -> (Right (ProcessingInstruction e),rs)
                    (Left err,rs) -> (Left err,rs)
-}
    


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