{-# LANGUAGE OverloadedStrings #-}
import System.Posix.Signals
import Control.Concurrent.STM
import Control.Monad.Trans.Resource (runResourceT)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Network.Socket
    ( addrAddress
    , getAddrInfo
    , defaultHints
    , addrFlags
    , AddrInfoFlag(AI_CANONNAME)
    )
import Data.Monoid ( (<>) )
import qualified Data.Text as Text
import qualified Data.Text.IO as Text
import qualified Data.Text.Encoding as Text
import Control.Monad
import qualified Network.BSD as BSD
import qualified Data.Text as Text
import Data.Text (Text)
import qualified Data.Map as Map
import Data.Map (Map)
import Control.Exception ({-evaluate,-}handle,SomeException(..),bracketOnError,ErrorCall(..))
import System.Posix.User (getUserEntryForID,userName)
import qualified Data.ByteString.Lazy.Char8 as L

import UTmp (ProcessID,users)
import LocalPeerCred
import XMPPServer
import Server

textHostName = fmap Text.pack BSD.getHostName

localJID user resource = do
    hostname <- textHostName
    return $ user <> "@" <> hostname <> "/" <> resource

data ClientState = ClientState
    { clientResource :: Text
    , clientUser :: Text
    , clientPid :: Maybe ProcessID
    }

data PresenceState = PresenceState
    { clients :: TVar (Map ConnectionKey ClientState)
    }

getConsolePids :: PresenceState -> IO [(Text,ProcessID)]
getConsolePids state = do --  return [("tty7", 23)] -- todo
    us <- UTmp.users
    return $ map (\(_,tty,pid)->(lazyByteStringToText tty,pid)) us

lazyByteStringToText = (foldr1 (<>) . map Text.decodeUtf8 . L.toChunks)

identifyTTY' ttypids uid inode = ttypid
 where ttypids' = map (\(tty,pid)->(L.fromChunks [Text.encodeUtf8 tty], pid)) ttypids
       ttypid = fmap textify $ identifyTTY ttypids' uid inode
       textify (tty,pid) = (fmap lazyByteStringToText tty, pid)

chooseResourceName state k addr desired = do
    muid <- getLocalPeerCred' addr
    (mtty,pid) <- getTTYandPID muid
    user <- getJabberUserForId muid
    let client = ClientState { clientResource = maybe "fallback" id mtty
                             , clientUser = user
                             , clientPid = pid }

    atomically $
        modifyTVar' (clients state) $ Map.insert k client
    localJID (clientUser client) (clientResource client)
    
  where
    getTTYandPID muid = do
        -- us <- fmap (map (second fst) . Map.toList) . readTVarIO $ activeUsers state
        ttypids <- getConsolePids state
        -- let tailOf3 ((_,a),b) = (a,b)
        (t,pid) <- case muid of
                      Just (uid,inode) -> identifyTTY' ttypids uid inode
                      Nothing          -> return (Nothing,Nothing)
        let rsc = t `mplus` fmap ( ("pid."<>) . Text.pack . show ) pid
        return (rsc,pid)

    getJabberUserForId muid =
             maybe (return "nobody") 
                   (\(uid,_) -> 
                        handle (\(SomeException _) -> 
                                return . (<> "uid.") . Text.pack . show $ uid)
                          $ do
                             user <- fmap userName $ getUserEntryForID uid
                             return (Text.pack user)
                        )
                   muid

forClient state k fallback f = do
    mclient <- atomically $ do
        cs <- readTVar (clients state)
        return $ Map.lookup k cs
    maybe (fallback k) (flip f k) mclient

tellClientHisName state k = forClient state k fallback go
 where
    fallback k = localJID "nobody" "fallback"
    go client k = localJID (clientUser client) (clientResource client)


main = runResourceT $ do
    -- us <- liftIO UTmp.users
    -- liftIO $ putStrLn (show us)
    hostname <- liftIO textHostName
    state <- do
        clients <- liftIO . atomically $ newTVar Map.empty
        return PresenceState
            { clients = clients
            }
    sv <- xmppServer
        XMPPServerParameters
        { xmppChooseResourceName = chooseResourceName state
        , xmppTellClientHisName = tellClientHisName state
        , xmppTellMyNameToClient = textHostName
        , xmppTellMyNameToPeer = \addr -> return $ addrToText addr
        , xmppTellPeerHisName = return . peerKeyToText
        , xmppNewConnection = \k outchan -> return ()
        , xmppEOF = \k -> return ()
        , xmppRosterBuddies = \k -> return []
        , xmppRosterSubscribers = \k -> return []
        , xmppRosterSolicited = \k -> return []
        , xmppRosterOthers = \k -> return []
        , xmppSubscribeToRoster = \k -> return ()
        , xmppLookupPeerName = \k ->  return "localhost"
        -- , xmppLookupClientJID = \k -> return $ "nobody@" <> hostname <> "/tty666"
        , xmppDeliverMessage = \fail msg -> do
            let msgs = msgLangMap (stanzaType msg)
                body = fmap (maybe "" id . msgBody . snd) $ take 1 msgs
            when (not $ null body) $ do
            Text.putStrLn $ "MESSAGE " <> head body
            return ()
        , xmppInformClientPresence = \k stanza -> return ()
        }
    liftIO $ do
    let testaddr0 = "fd97:ca88:fa7c:b94b:c8b8:fad4:1021:a54d"
        -- testaddr0 = "fdef:9e0b:b502:52c3:c074:28d3:fcd7:bfb7"
    testaddr<- fmap (addrAddress . head) $
        getAddrInfo (Just $ defaultHints { addrFlags = [ AI_CANONNAME ]})
                (Just testaddr0)
                (Just "5269")
    putStrLn $ "Connecting to "++show testaddr
    addPeer sv testaddr

    quitVar <- newEmptyTMVarIO
    installHandler sigTERM (CatchOnce (atomically $ putTMVar quitVar True)) Nothing
    installHandler sigINT (CatchOnce (atomically $ putTMVar quitVar True)) Nothing
    quitMessage <- atomically $ takeTMVar quitVar

    putStrLn "goodbye."
    return ()