1 files changed, 52 insertions, 12 deletions

diff --git a/examples/dhtd.hs b/examples/dhtd.hs
index 755a65d7..badea2b1 100644
--- a/examples/dhtd.hs
+++ b/examples/dhtd.hs
@@ -98,13 +98,21 @@ showColumns rows = do
 marshalForClient :: String -> String
 marshalForClient s = show (length s) ++ ":" ++ s
 
+data ClientHandle = ClientHandle Handle (MVar Int)
+
 -- | Writes a message and signals ready for next command.
-hPutClient :: Handle -> String -> IO ()
-hPutClient h s = hPutStr h ('.' : marshalForClient s)
+hPutClient :: ClientHandle -> String -> IO ()
+hPutClient (ClientHandle h hstate) s = do
+    st <- takeMVar hstate
+    hPutStr h ('.' : marshalForClient s)
+    putMVar hstate 1 -- ready for input
 
 -- | Writes message, but signals there is more to come.
-hPutClientChunk :: Handle -> String -> IO ()
-hPutClientChunk h s = hPutStr h (' ' : marshalForClient s)
+hPutClientChunk :: ClientHandle -> String -> IO ()
+hPutClientChunk (ClientHandle h hstate) s = do
+    st <- takeMVar hstate
+    hPutStr h (' ' : marshalForClient s)
+    putMVar hstate 2 -- ready for more output
 
 data DHTQuery nid ni = forall addr r tok.
                         ( Ord addr
@@ -253,7 +261,7 @@ reportResult ::
     -> (r -> String)
     -> (tok -> Maybe String)
     -> (ni -> String)
-    -> Handle
+    -> ClientHandle
     -> Either String ([ni],[r],Maybe tok)
     -> IO ()
 reportResult meth showR showTok showN h (Left e)            = hPutClient h e
@@ -334,7 +342,7 @@ forkSearch method nid DHTQuery{qsearch,qshowTok,qshowR} dhtSearches dhtBuckets
     writeTVar kvar $ Just $ searchLoop qsearch nid storeResult st
 
 reportSearchResults :: (Show t, Ord t1, Ord t, Hashable t) =>
-                                   String -> Handle -> DHTSearch t1 t -> IO ()
+                                   String -> ClientHandle -> DHTSearch t1 t -> IO ()
 reportSearchResults meth h DHTSearch{searchShowTok,searchState,searchResults} = do
     (ns,rs) <- atomically $ do
         mm <- readTVar $ searchInformant searchState
@@ -361,12 +369,39 @@ data Session = Session
     , signalQuit        :: MVar ()
     }
 
-clientSession :: Session -> t1 -> t -> Handle -> IO ()
+exceptionsToClient :: ClientHandle -> IO () -> IO ()
+exceptionsToClient (ClientHandle h hstate) action =
+    action `catch` \(SomeException e) -> do
+                        st <- takeMVar hstate
+                        when (st /= 1) $ do
+                            hPutStr h ('.': marshalForClient (show e))
+                        putMVar hstate 1 -- ready for input
+
+hGetClientLine :: ClientHandle -> IO String
+hGetClientLine (ClientHandle h hstate) = do
+    st <- takeMVar hstate
+    -- st should be 1
+    x <- hGetLine h
+    putMVar hstate 0 -- ready for output
+    return x
+
+hCloseClient :: ClientHandle -> IO ()
+hCloseClient (ClientHandle h hstate) = do
+    st <- takeMVar hstate
+    hClose h
+    putMVar hstate 3 -- closed file handle
+
+clientSession0 :: Session -> t1 -> t -> Handle -> IO ()
+clientSession0 s sock cnum h = do
+    hstate <- newMVar 1 -- ready for input
+    clientSession s sock cnum (ClientHandle h hstate)
+
+clientSession :: Session -> t1 -> t -> ClientHandle -> IO ()
 clientSession s@Session{..} sock cnum h = do
-    line <- dropWhile isSpace <$> hGetLine h
+    line <- dropWhile isSpace <$> hGetClientLine h
     let (c,args) = second (dropWhile isSpace) $ break isSpace line
         cmd0 :: IO () -> IO ()
-        cmd0 action = action >> clientSession s sock cnum h
+        cmd0 action = exceptionsToClient h action >> clientSession s sock cnum h
         switchNetwork dest = do hPutClient h ("Network: "++dest)
                                 clientSession s{netname=dest} sock cnum h
         strp = B.unpack . fst . until snd dropEnd . (,False) . B.dropWhile isSpace . B.pack
@@ -401,6 +436,7 @@ clientSession s@Session{..} sock cnum h = do
             , ["toxids"]
             , ["c"]
             , ["help"]
+            , ["throw"]
             ]
     case (map toLower c,args) of
         (n, _) | n `elem` Map.keys dhts -> switchNetwork n
@@ -421,10 +457,14 @@ clientSession s@Session{..} sock cnum h = do
                 hPutClient h $ "error."
 
         ("stop", _) -> do hPutClient h "Terminating DHT Daemon."
-                          hClose h
+                          hCloseClient h
                           putMVar signalQuit ()
 
-        ("quit", _) -> hPutClient h "" >> hClose h
+        ("throw", er) -> cmd0 $ do
+                            throwIO $ userError er
+                            hPutClient h "The impossible happened!"
+
+        ("quit", _) -> hPutClient h "" >> hCloseClient h
 
         ("pid", _) -> cmd0 $ do
                     pid <- getProcessID
@@ -1131,7 +1171,7 @@ main = do
         (toxids,rstr) <- fromMaybe ((,) <$> atomically (newTVar []) <*> newRoster) $ do
             tox <- mbtox
             return $ return ( userKeys (Tox.toxCryptoKeys tox), Tox.toxRoster tox )
-        let session = clientSession $ Session
+        let session = clientSession0 $ Session
                 { netname           = concat $ take 1 $ Map.keys dhts -- initial default DHT
                 , dhts              = dhts  -- all DHTs
                 , signalQuit        = signalQuit