We no longer require root. (ConsoleWriter is disabled without).

6 files changed, 61 insertions, 28 deletions

diff --git a/Presence/ConsoleWriter.hs b/Presence/ConsoleWriter.hs
index e755b27f..986294f4 100644
--- a/Presence/ConsoleWriter.hs
+++ b/Presence/ConsoleWriter.hs
@@ -17,7 +17,6 @@ import Data.Monoid
 import Data.Char
 import Data.Maybe
 import System.Environment hiding (setEnv)
-import System.Process ( rawSystem )
 import System.Exit ( ExitCode(ExitSuccess) )
 import System.Posix.Env     ( setEnv )
 import System.Posix.Process ( forkProcess, exitImmediately, executeFile )
@@ -36,7 +35,7 @@ import qualified Data.Text as Text
 import qualified Network.BSD as BSD
 
 import UTmp           ( users2, utmp_file, UtmpRecord(..), UT_Type(..) )
-import FGConsole      ( monitorTTY )
+import FGConsole      ( forkTTYMonitor )
 import XMPPServer     ( Stanza, makePresenceStanza, JabberShow(..), stanzaType
                       , LangSpecificMessage(..), msgLangMap, cloneStanza, stanzaFrom )
 import ControlMaybe   ( handleIO_ )
@@ -109,7 +108,7 @@ onLogin cs start = \e -> do
 -- | Sets up threads to monitor tty switches and logins that are
 -- written to the system utmp file and returns a 'ConsoleWriter'
 -- object for interacting with that information.
-newConsoleWriter :: IO ConsoleWriter
+newConsoleWriter :: IO (Maybe ConsoleWriter)
 newConsoleWriter = do
     chan <- atomically $ newEmptyTMVar
     cs <- atomically $ do
@@ -136,7 +135,8 @@ newConsoleWriter = do
     inotify <- initINotify
 
     -- get active tty
-    mtty <- monitorTTY (onTTY outvar cs)
+    mtty <- forkTTYMonitor (onTTY outvar cs)
+    forM mtty $ \_ -> do
     atomically $ retryWhen (readTVar $ csActiveTTY cs) (==0)
 
     -- read utmp
diff --git a/Presence/FGConsole.hs b/Presence/FGConsole.hs
index 623fb493..03aaebf2 100644
--- a/Presence/FGConsole.hs
+++ b/Presence/FGConsole.hs
@@ -11,7 +11,6 @@ import Unsafe.Coerce
 import Control.Exception as E
 -- import Prelude as E
 import Control.Monad
-import Foreign.C.Error
 import Foreign.C
 
 import Logging
@@ -19,12 +18,13 @@ import System.Posix.Signals
 
 -- c_monitorTTY fd = trace "c_monitorTTY" (return ()) -- (trace "WTF" todo)
 
-foreign import ccall "monitorTTY" c_monitorTTY :: Fd -> IO ()
+foreign import ccall "monitorTTY" c_monitorTTY :: Fd -> IO CInt
 foreign import ccall "closeTTY" c_closeTTY :: IO ()
 
-monitorTTY :: (Word8 -> IO ()) -> IO (Fd,ThreadId)
-monitorTTY handler =  do
+forkTTYMonitor :: (Word8 -> IO ()) -> IO (Maybe (Fd,ThreadId))
+forkTTYMonitor handler =  do
     (rfd,wfd) <- createPipe
+    retvar <- newEmptyMVar
     thread <- forkIO $ do
         let cleanup = do
                 trace "quitting monitorTTY thread." (return ())
@@ -32,8 +32,10 @@ monitorTTY handler =  do
                 closeFd rfd `E.catch` \(e::IOException) -> return ()
                 c_closeTTY
         -- rh <- fdToHandle rfd
-        c_monitorTTY wfd
-        let monitor = 
+        didfork <- c_monitorTTY wfd
+        putMVar retvar didfork
+        when (didfork == 0) $ do
+        let monitor =
                 (do
                     threadWaitRead rfd
                     (cs,cnt) <- fdRead rfd 1
@@ -45,13 +47,16 @@ monitorTTY handler =  do
                         case () of
                          _ | err==eAGAIN -> monitor
                          _ | otherwise   -> cleanup
-                `E.catch` 
+                `E.catch`
                       \(e ::  AsyncException) -> cleanup
         monitor
-    return (rfd,thread)
+    didfork <- takeMVar retvar
+    if didfork == 0
+        then return $! Just (rfd,thread)
+        else return $! Nothing
 
-unmonitorTTY :: (Fd, ThreadId) -> IO ()
-unmonitorTTY (rfd,thread) = do
+killTTYMonitor :: (Fd, ThreadId) -> IO ()
+killTTYMonitor (rfd,thread) = do
     closeFd rfd
     yield
     killThread thread
diff --git a/Presence/Presence.hs b/Presence/Presence.hs
index 2344fb75..9660b29f 100644
--- a/Presence/Presence.hs
+++ b/Presence/Presence.hs
@@ -148,7 +148,7 @@ data PresenceState = PresenceState
     , associatedPeers :: TVar (Map SockAddr ())
     , server :: TMVar XMPPServer
     , keyToChan :: TVar (Map ConnectionKey Conn)
-    , consoleWriter :: ConsoleWriter
+    , consoleWriter :: Maybe ConsoleWriter
     }
 
 
@@ -435,11 +435,11 @@ rewriteJIDForPeer jid = do
         in (to',addr)
 
 deliverToConsole :: PresenceState -> IO () -> Stanza -> IO ()
-deliverToConsole state fail msg = do
-    putStrLn $ "TODO: deliver to console"
-    did1 <- writeActiveTTY (consoleWriter state) msg
-    did2 <- writeAllPty (consoleWriter state) msg
+deliverToConsole PresenceState{ consoleWriter = Just cw } fail msg = do
+    did1 <- writeActiveTTY cw msg
+    did2 <- writeAllPty cw msg
     if not (did1 || did2) then fail else return ()
+deliverToConsole _ fail _ = fail
 
 -- | deliver <message/> or error stanza
 deliverMessage :: PresenceState
@@ -636,6 +636,11 @@ informPeerPresence state k stanza = do
         sendModifiedStanzaToClient (dup { stanzaFrom=Just from' })
                                    (connChan con)
 
+consoleClients :: PresenceState -> STM (Map Text ClientState)
+consoleClients PresenceState{ consoleWriter = Just cw } = readTVar (cwClients cw)
+consoleClients _                                        = return Map.empty
+
+
 answerProbe :: PresenceState
              -> Maybe Text -> ConnectionKey -> TChan Stanza -> IO ()
 answerProbe state mto k chan = do
@@ -671,7 +676,7 @@ answerProbe state mto k chan = do
     replies <- runTraversableT $ do
         cbu <- lift . atomically $ readTVar (clientsByUser state)
         let lpres = maybeToList $ Map.lookup u cbu
-        cw <- lift . atomically $ readTVar (cwClients $ consoleWriter state)
+        cw <- lift . atomically $ consoleClients state
         clientState <- liftT $ (lpres >>= Map.elems . networkClients)
                                 ++ Map.elems cw
         stanza <- liftIOMaybe $ atomically (readTVar (clientStatus clientState))
diff --git a/Presence/monitortty.c b/Presence/monitortty.c
index a9a095cf..7582aa56 100644
--- a/Presence/monitortty.c
+++ b/Presence/monitortty.c
@@ -146,10 +146,19 @@ void *write_vtch(void *pfd) {
 }
 
 
-void monitorTTY(int fd) {
+// Returns 0 on success.
+int monitorTTY(int fd) {
+    int er = -1, dev = -1;
         pthread_mutex_init(&mu,NULL);
-        // printf ("Hello world.\n");
-        pthread_create (&mt, NULL, write_vtch, (void*)(intptr_t)fd);
+    // Ensure we can open a device before we bother forking a thread.
+        dev = ttyfd();
+    if( dev != -1 ) {
+        er = pthread_create (&mt, NULL, write_vtch, (void*)(intptr_t)fd);
+        return er;
+    }
+    else {
+        return -1;
+    }
 }
 
 void closeTTY() {
diff --git a/examples/dhtd.hs b/examples/dhtd.hs
index 0996ffab..4c0cd114 100644
--- a/examples/dhtd.hs
+++ b/examples/dhtd.hs
@@ -1368,10 +1368,10 @@ main = do
 
         forkIO $ do
             myThreadId >>= flip labelThread "XMPP.stanzas"
-            let console = cwPresenceChan $ consoleWriter state
+            let console = cwPresenceChan <$> consoleWriter state
             fix $ \loop -> do
             what <- atomically
-                $ orElse (do (client,stanza) <- takeTMVar console
+                $ orElse (do (client,stanza) <- maybe retry takeTMVar console
                              return $ do informClientPresence0 state Nothing client stanza
                                          loop)
                          (checkQuit >> return (return ()))
diff --git a/p b/p
index 63dee6c2..1ed6e374 100755
--- a/p
+++ b/p
@@ -1,14 +1,28 @@
 #!/bin/bash
-args="-rtsopts -osuf -prof pf -fprof-auto -fprof-auto-exported"
+warn="-freverse-errors -fwarn-unused-imports -Wmissing-signatures -fdefer-typed-holes"
+exts="-XOverloadedStrings -XRecordWildCards"
+defs="-DBENCODE_AESON -DTHREAD_DEBUG"
+hide="-hide-package crypto-random -hide-package crypto-api -hide-package crypto-numbers -hide-package cryptohash -hide-package prettyclass"
+opts="-rtsopts -hisuf p_hi -osuf p_o -prof -fprof-auto -fprof-auto-exported"
 
 root=${0%/*}
 cd "$root"
 
 me=${0##*/}
 me=${me%.*}
+set -x
 ghc                                  \
+    $opts                            \
+    $hide                            \
+    $exts                            \
+    $defs                            \
     -hidir build/$me -odir build/$me \
-    -iPresence                        \
+    -iPresence                       \
     -iArchive                        \
-    $args                            \
+    -isrc                            \
+    -icryptonite-backport            \
+    build/b/Presence/monitortty.o    \
+    build/b/cbits/cryptonite_salsa.o \
+    build/b/cbits/cryptonite_xsalsa.o\
+    $warn                            \
     "$@"