{-# LANGUAGE CPP               #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies      #-}
module Main where

import System.Directory
import Control.Monad
import System.Posix.Signals
import System.Posix.Types
import System.Posix.Process
import Data.Maybe
import Data.Char

import System.INotify
#ifndef NOUTMP
import UTmp 
-- Breaks profiling build with error:
--     Dynamic linking required, but this is a non-standard build (eg. prof).
--         You need to build the program twice: once the normal way, and then
--             in the desired way using -osuf to set the object file suffix.
--
-- TODO: Figure out wtf ghc is trying to tell me.
--       In the mean time, use -DNOTMP to build for profiling.
-- 
#endif
import FGConsole
import XMPPServer
import Data.HList
import Network.Socket (sClose)
import Control.Exception
import LocalPeerCred
import System.Posix.User
import qualified Data.Set as Set
import           Data.Set as Set (Set,(\\))
import Control.Concurrent.MVar.Strict
import Control.Concurrent (threadDelay)
import Control.DeepSeq
import Debug.Trace

import ByteStringOperators
import qualified Data.ByteString.Lazy.Char8 as L
import           Data.ByteString.Lazy.Char8 as L (ByteString,putStrLn)
import qualified Prelude
import           Prelude hiding (putStrLn)


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

instance Show JID where
    show (JID n s r ) = L.unpack $ fmap (<++>"@") n <?++> s <++?> fmap ("/"<++>) r

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)  --  user <++> "@" <++> host <++> "/" <++> rsrc

toJabberId host (user,tty,_) = 
    if L.take 3 tty == "tty"
      then Just (jid user host tty)
      else Nothing

track_login :: MVar (ByteString,Set JID) -> t -> IO ()
track_login tracked e = do
#ifndef NOUTMP
    us <- users
#else
    let us = []
#endif
    let ids = Set.fromList $ mapMaybe (toJabberId "localhost") us
    (tty,state) <- modifyMVar tracked $ \(tty,st) ->
                    return ((tty,ids),(tty,st))
    let arrivals   = ids \\ state
        departures = state \\ ids
    forM_ (Set.toList departures) $ \id -> do
        putStrLn $ bshow id <++> " Offline."
    forM_ (Set.toList arrivals) $ \jid -> do
      case fmap (==tty) $ resource jid of
        Just True  -> putStrLn $ bshow jid <++> " Available."
        Just False -> putStrLn $ bshow jid <++> " Away."
        Nothing    -> trace "Unexpected lack of resource" $ return ()

data UnixSession = UnixSession {
    unix_uid :: (IORef (Maybe UserID)),
    unix_resource :: (IORef (Maybe L.ByteString))
}

instance XMPPSession UnixSession where
    data XMPPClass UnixSession = UnixSessions
    newSession   _ sock handle = do
        muid <- getLocalPeerCred sock
        L.putStrLn $ "SESSION: open " <++> bshow muid
        uid_ref <- newIORef muid
        res_ref <- newIORef Nothing
        return $ UnixSession uid_ref res_ref
    setResource  s  resource    = do
        writeIORef (unix_resource s) (Just resource)
        L.putStrLn $ "SESSION: resource " <++> resource
    getJID       s             = do
        let host = "localhost" -- TODO
        muid <- readIORef (unix_uid s)
        user <- maybe (return "nobody") 
                   (\uid -> 
                        handle (\(SomeException _) -> 
                                return . L.append "uid." . L.pack . show $ uid)
                          $ do
                             user <- fmap userName $ getUserEntryForID uid
                             return (L.pack user)
                        )
                   muid
        rsc <- readIORef (unix_resource s)
        let suf = maybe "" ("/"<++>) rsc
            jid = user <++> "@" <++> L.pack host <++> suf
        L.putStrLn $ "SESSION: jid " <++> jid
        return jid
    closeSession _             = L.putStrLn "SESSION: close"

on_chvt tracked vtnum = do
    let tty = L.snoc "tty" $ intToDigit (fromIntegral vtnum)
    L.putStrLn $ "VT switch: " <++> tty
    state <- modifyMVar tracked $ \(_,us) -> do
                return ((tty,us),us)
    forM_ (Set.toList state) $ \jid -> do
      case fmap (==tty) $ resource jid of
        Just True  -> putStrLn $ bshow jid <++> " Available."
        Just False -> putStrLn $ bshow jid <++> " Away."
        Nothing    -> return ()


start :: IO ()
start = do
    tracked <- newMVar ("",Set.empty)
    let dologin e = track_login tracked e
        dologin :: t -> IO ()
#ifndef NOUTMP
    installHandler sigUSR1 (Catch (dologin (userError "signaled"))) Nothing
#endif
    -- installHandler sigTERM (CatchOnce (dologin (userError "term signaled"))) Nothing
    mtty <- monitorTTY (on_chvt tracked)
    inotify <- initINotify
#ifndef NOUTMP
    wd <- addWatch
            inotify
            [CloseWrite] -- [Open,Close,Access,Modify,Move]
            utmp_file
            dologin
#endif
    sock <- listenForXmppClients UnixSessions 5222 HNil

    threadDelay 1000 -- wait a moment to obtain current tty
    dologin ()
    putStrLn "\nHit enter to terminate...\n"
    getLine
    {-
    let doException (SomeException e) = Prelude.putStrLn ("\n\nexception: " ++ show e ++ "\n\n")
    handle doException $ do
    -}
    sClose sock
    -- threadDelay 1000
    putStrLn "closed listener."
    unmonitorTTY mtty
    putStrLn "unhooked tty monitor."
#ifndef NOUTMP
    removeWatch wd
#endif
    putStrLn "Normal termination."

sendUSR1 pid = do
    signalProcess sigUSR1 pid

getStartupAction []     = throw (userError "pid file?") >> return (Right "")
getStartupAction (p:ps) = do
    handle onEr $
        ( do
            pid <- fmap CPid (readFile p >>= readIO)
            -- signal pid
            return (Left pid) )
 where
    onEr (SomeException _) = do
        pid <- getProcessID
        putStrLn $ "starting pid = " <++> bshow pid
        handle (\(SomeException _) -> getStartupAction ps)
            (do 
                writeFile p (show pid)
                putStrLn $ "writing " <++> bshow p
                -- start daemon
                return (Right p) )

runOnce ps run notify = getStartupAction ps >>= doit
 where
    doit (Left pid      ) = notify pid
    doit (Right pidfile ) = do 
        run
        removeFile pidfile


main = do
    runOnce ["/var/run/presence.pid","/tmp/presence.pid"] start sendUSR1