I tried the following approach:
import System.Exit
import System.Posix.Signals
import Control.Concurrent (threadDelay)
main :: IO ()
main = do
installHandler keyboardSignal (Catch (do exitSuccess)) Nothing
threadDelay (1000000000)
But it only outputs:
^CTest.hs: ExitSuccess
on Ctrl-C, instead of exiting. How should I do it properly?
From the docs of installHandler:
a handler is installed which will invoke action in a new thread when (or shortly after) the signal is received.
and exitWith:
Note: in GHC, exitWith should be called from the main program thread in order to exit the process. When called from another thread, exitWith will throw an ExitException as normal, but the exception will not cause the process itself to exit.
So an exitSuccess handler doesn't end the process, and that's expected (although unexpected ;) behaviour.
If you want immediate action,
import System.Exit
import System.Posix.Signals
import Control.Concurrent
main :: IO ()
main = do
tid <- myThreadId
installHandler keyboardSignal (Catch (killThread tid)) Nothing
threadDelay (1000000000)
kills the thread immediately upon receiving the signal.
Less drastic, if you want a successful exit, would be
import System.Exit
import System.Posix.Signals
import Control.Concurrent
import qualified Control.Exception as E
main :: IO ()
main = do
tid <- myThreadId
installHandler keyboardSignal (Catch (E.throwTo tid ExitSuccess)) Nothing
threadDelay (10000000)
I think it will also work reliably, but I'm not entirely sure.
Related
I want to make an "asynchronous" reading of stdin for a few seconds. The way I am doing if is by forking getContents and writing to a Chan. After 5 seconds, I kill the thread and read the channel.
From my understading, the code below should just print whatever is in chan and terminate, but it keeps waiting for input and ^C must be pressed to finish. This is the behaviour you have when doing getContents >>= print on its own, so I have two guesses and no clue about each:
The thread is not killed and getContent keep running asking for more input
Something weird is happening with multithreading (see considerations below)
-- OS: Ubuntu 22.04.1 LTS
-- Gnome Terminal
-- ghc 9.2.5
import Control.Concurrent.Chan ( newChan, readChan, writeChan, Chan )
import Control.Concurrent (threadDelay, forkIO, killThread)
import System.IO (getContents, BufferMode (..), stdin, hSetBuffering)
main :: IO ()
main = do
hSetBuffering stdin NoBuffering
chan <- newChan
putStrLn "start"
threadId <- forkIO $ getContents >>= writeChan chan
threadDelay 5000000
putStrLn "\nend"
killThread threadId
a <- readChan chan
print a
Some considerations:
Using getLine make it work only if Enter is pressed. But I'd like to just "stream" stdin into the channel
hSetBuffering stdin NoBuffering is neccessary, otherwise the programm hangs (I guess waiting for end of input?)
Using getContents' cause a thread blocked indefinitely in an MVar operation, which up to the documentation is due to the channel being empty. I guess getContents' actually never terminates.
Last but most importantly, the behaviour is different depending on the compilation parameters:
ghc -threaded main.hs && ./main +RTS -N2 wont print anything and will hang until ^C is pressed (same thing with -N1, -N3, etc...)
runghc main.hs will actually print whatever has being the stdin during the 5 seconds (i.e. whatever is in chan) and then hang.
Just to clarify. Here are the ouputs:
> runghc main.hs
start
abc # user input
end
"abc^C" # ^C is done manually, to termiante the program and the last \" is for formatting purpose
> ghc -threaded main.hs && ./main +RTS -N2
start
abc # user input
end
^C # ^C is done manually, to termiante the program
So the question is simple. How do I make my program to end?
The thread getContents >>= writeChan chan is not an infinite loop that constantly adds content to chan. getContents creates a thunk, which is put in chan, and the thread terminates near instantaneously. Then in the main thread readChan gets that thunk, and print a forces it. It's the forcing of the thunk which prompts reading stdin, hence your program just blocks for more input until EOF or it gets killed.
What you want to do is to explicitly take small bits of input and write them into the channel. However, in the main thread, the channel does not give you a way to tell when it's ended. A workaround is to use an IORef String instead as a channel. Write to it by explicitly appending to the stored string, and readIORef will give you whatever content was written so far.
import Control.Concurrent.Chan ( newChan, readChan, writeChan, Chan )
import Control.Concurrent (threadDelay, forkIO, killThread)
import Control.Monad (forever)
import Data.IORef
import System.IO (getContents, BufferMode (..), stdin, hSetBuffering)
main :: IO ()
main = do
hSetBuffering stdin NoBuffering
buf <- newIORef []
putStrLn "start"
threadId <- forkIO $ forever $ do
c <- getChar
atomicModifyIORef' buf (\cs -> (c : cs, ()))
threadDelay 5000000
putStrLn "\nend"
killThread threadId
a <- reverse <$> readIORef buf
print a
I have a long running process which I need to start.
It takes a few seconds to start, and outputs logs to stdout, with one that indicates it is ready.
I would like to:
start the process silently, so that the stdout from the process is not displayed in my session.
capture the output as it streams so that I can determine that it is ready.
have some handle on the process so that I can stop the process at a later point.
I have come close using Shelly, Turtle and System.Process, but fail to capture the stdout.
Using System.Process I had:
import Control.Concurrent (threadDelay)
import Control.Concurrent.Async (race)
import System.IO
import System.Process
startService :: IO ProcessHandle
startService = do
let cmd = "./my-service"
args = [ "-p 1234" ]
(_, Just hout, _, p) <- createProcess $ (proc cmd args) { std_out = CreatePipe }
started <- either id id <$> race (checkStarted hout) timeOut
unless started $ fail "Service not started"
pure p
where
checkStarted :: Handle -> IO Bool
checkStarted h = do
str <- hGetLine h
-- check str for started log, else loop
timeOut :: IO Bool
timeOut = do
threadDelay 10000000
pure False
But The handler hout was never in a ready state.
Using Shelly I had:
import Control.Concurrent (threadDelay)
import Control.Concurrent.Async (race)
import Control.Concurrent.MVar
import Shelly
import System.IO
startService :: IO (Async ())
startService = do
let cmd = "./my-service"
args = [ "-p 1234" ]
startedMVar <- newEmptyMVar
async <- shelly $ asyncSh $ runHandle cmd args $ recordWhenStarted startedMVar
started <- either id id <$> race (readMVar startedMVar) timeOut
unless started $ fail "Service not started"
pure async
where
recordWhenStarted :: MVar Bool -> Text -> IO ()
recordWhenStarted mvar txt =
when (isStartedLog txt) $
modifyMVar_ mvar (const $ pure True)
timeOut :: IO Bool
timeOut = do
threadDelay 10000000
pure False
But the recordWhenStarted is never called.
The following is example of starting process and reading stdout in a program of mine:
runMystem :: [T.Text] -> IO T.Text
runMystem stemWords = do
(i, o, _, ph) <- createProcess (proc mystemExecutabe mystemParams) { std_in = CreatePipe, std_out = CreatePipe }
res <- flip (maybe (return T.empty)) i $ \hIn ->
flip (maybe (return T.empty)) o $ \hOut -> do
hSetEncoding hIn utf8
hSetEncoding hOut utf8
forM_ stemWords $ TIO.hPutStrLn hIn
TIO.hGetContents hOut
void $ waitForProcess ph
return res
This answer uses the process-streaming library (written by the author of this answer) which is a set of helpers over process.
{-# language OverloadedStrings #-}
{-# language NumDecimals #-}
import System.Process.Streaming (execute,piped,shell,foldOut,transduce1)
import qualified System.Process.Streaming.Text as PT
import Data.Text.Lazy (isInfixOf)
import Control.Applicative
import Control.Monad
import Control.Concurrent (threadDelay)
import Control.Concurrent.Async
import Control.Concurrent.MVar
main :: IO ()
main = do
started <- newEmptyMVar
let execution =
execute (piped (shell "{ sleep 3 ; echo fooo ; sleep 3 ; }")) $
foldOut . transduce1 PT.utf8x . PT.eachLine $ lookline
lookline line = do
when (isInfixOf "foo" line) (putMVar started ())
return (Right ())
stopOrNot =
do abort <- race (threadDelay 4e6) (readMVar started)
case abort of
Left () -> return () -- stop immediately
Right () -> runConcurrently empty -- sleep forever
result <- race stopOrNot execution
print result
execute installs exception handlers that terminate the external process when an asynchronous exceptions arrives, to it is safe to use race with it.
execute also takes care to drain any standard stream that is not read explicitly (like stderr in this case) to avoid a common source of deadlocks.
I am having an issue with threading when using callbacks in GI-Gtk. Consider the following program:
import GI.Gtk hiding (main)
import GI.Gdk
import GI.GLib
import GI.GLib.Constants
import qualified GI.Gtk as Gtk
import Control.Concurrent
import Control.Concurrent.MVar
main = do
t <- myThreadId
putStrLn $ "init "++show t
Gtk.init Nothing
d <- dialogNew
dialogRun d
onWidgetDestroy d onDestroy
Gtk.main
onDestroy :: IO ()
onDestroy = do
t <- myThreadId
putStrLn $ "onDestroy "++show t
runOnGUI $ putStrLn "Destroying"
putStrLn "Destroyed"
Gtk.mainQuit
runOnGUI :: IO a -> IO a
runOnGUI action = do
ans <- newEmptyMVar
threadsAddIdle PRIORITY_DEFAULT_IDLE $ action >>= putMVar ans >> return False
takeMVar ans
When running the above program, the program hangs when I attempt to close the window, and I get the following output:
init ThreadId 11
Gtk-Message: GtkDialog mapped without a transient parent. This is discouraged.
onDestroy ThreadId 12
Looking at the code alone, I would expect to see this deadlock if runOnGUI is being called from the main thread (which I would expect it to be). However based on the output, runOnGUI should be getting called on a different thread, and therefore avoid the deadlock.
In my actual program, I attempt to avoid this type of deadlock by guarding runOnGUI in a if currentThread /= mainThread type conditional; but, as the above example shows, that does not appear to be sufficient.
I have a simple forked conduit setup, with two inputs feeding one single output....
{-# LANGUAGE OverloadedStrings #-}
import Control.Concurrent (threadDelay)
import Control.Monad.IO.Class
import Control.Monad.Trans.Resource
import qualified Data.ByteString as B
import Data.Conduit
import Data.Conduit.TMChan
import Data.Conduit.Network
main::IO ()
main = do
runTCPClient (clientSettings 3000 "127.0.0.1") $ \server -> do
runResourceT $ do
input <- mergeSources [
transPipe liftIO (appSource server),
infiniteSource
] 2
input $$ transPipe liftIO (appSink server)
infiniteSource::MonadIO m=>Source m B.ByteString
infiniteSource = do
liftIO $ threadDelay 10000000
yield "infinite source"
infiniteSource
(here I connect to a tcp socket, then combine the socket input with a timed infinite source, then respond back to the socket)
This works great, until the connection is dropped.... Because the second input still exists, the conduit keeps running. (In this case, the program does end when the timed input fires and there is no socket to write to, but this isn't always the case in my real example).
What is the proper way to shut down the full conduit when one of the inputs is closed?
I tried to brute force a crash by adding the following
crashOnEndOfStream::MonadIO m=>Conduit B.ByteString m B.ByteString
crashOnEndOfStream = do
awaitForever $ yield
error "the peer connection has disconnected" --tried with error
liftIO $ exitWith ExitSuccess --also tried with exitWith
but because the input conduit runs in a thread, the executable was immune to runtime exceptions shutting it down (plus, there is probably a smoother way to shut stuff down than halting the program).
the Source created by mergeSources keeps a count of unclosed sources. It's only closed when the count reaches 0 i.e. every upstream source is closed. This mechanism and the underlying TBMChannel is hidden from user code so you have no way to change its behavior.
One possible solution is to create the channel and the source manually with some medium-level functions exported by Data.Conduit.TMChan, so you can finalize the source by closing the TBMChannel. I haven't tested the code below since your program is not runnable on my machine.
{-# LANGUAGE OverloadedStrings #-}
import Control.Concurrent (threadDelay)
import Control.Monad.IO.Class
import Control.Monad.Trans.Resource
import qualified Data.ByteString as B
import Data.Conduit
import Data.Conduit.Network
import Data.Conduit.TMChan
main::IO ()
main = do
runTCPClient (clientSettings 3000 "127.0.0.1") $ \server -> do
runResourceT $ do
-- create the TBMChannel
chan <- liftIO $ newTBMChanIO 2
let
-- everything piped to the sink will appear at the source
chanSink = sinkTBMChan chan True
chanSource = sourceTBMChan chan
tid1 <- resourceForkIO $ appSource server $$ chanSink
tid2 <- resourceForkIO $ infiniteSource $$ chanSink
chanSource $$ transPipe liftIO (appSink server)
-- and call 'closeTBMChan chan' when you want to exit.
-- 'chanSource' will be closed when the underlying TBMChannel is closed.
infiniteSource :: MonadIO m => Source m B.ByteString
infiniteSource = do
liftIO $ threadDelay 10000000
yield "infinite source"
infiniteSource
I'd like to implement a 'graceful shutdown' command for my webapp (as opposed to my first instinct, which is to just ask people to kill the process)
My first two attempts consisted of
liftIO exitSuccess
E.yield (responseLBS statusOK [G.contentType "text/plain"] "") E.EOF
Both of which just cheerfully returned a result to the client and continued listening. Is there anything an application can do to kill the server? Is this even a reasonable thing to want to do?
I confess I don't have a very strong understanding of iteratee, only enough to know that I can consume my input and that Iteratee is a MonadIO instance.
Use an MVar. Block the main thread until the MVar has been signaled, then cleanup and exit.
Call exitImmediately. One of the fastest ways to tear down the process, and also terribly annoying to debug. I don't believe finalizers/brackets/finally blocks will be called on the way down, depending on your application it may corrupt state.
Throw an exception to the main thread. Warp.run doesn't catch exceptions, so this works by allowing the default exception handler on the main thread (and the main thread only) to terminate the process.
As others have mentioned, using an MVar is probably the best option. I included the others for the sake of completeness, but they do have their place. throwTo is used somewhat in the base library and I've worked on a few applications that use the C equivalent of exitImmediately: exit(), though I haven't run across any Haskell apps that use this method.
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE OverloadedStrings #-}
module Main (main) where
import Control.Concurrent (MVar, ThreadId, forkIO, myThreadId, newEmptyMVar, putMVar, takeMVar)
import Control.Exception (Exception, throwTo)
import Control.Monad.Trans (liftIO)
import Data.ByteString (ByteString)
import Data.Data (Data, Typeable)
import Data.Enumerator (Iteratee)
import Network.HTTP.Types
import Network.Wai as Wai
import Network.Wai.Handler.Warp as Warp
import System.Exit (ExitCode (ExitSuccess))
import System.Posix.Process (exitImmediately)
data Shutdown = Shutdown deriving (Data, Typeable, Show)
instance Exception Shutdown
app :: ThreadId -> MVar () -> Request -> Iteratee ByteString IO Response
app mainThread shutdownMVar Request{pathInfo = pathInfo} = do
liftIO $ case pathInfo of
["shutdownByThrowing"] -> throwTo mainThread Shutdown
["shutdownByMVar"] -> putMVar shutdownMVar ()
["shutdownByExit"] -> exitImmediately ExitSuccess
_ -> return ()
return $ responseLBS statusOK [headerContentType "text/plain"] "ok"
main :: IO ()
main = do
mainThread <- myThreadId
shutdownMVar <- newEmptyMVar
forkIO $ Warp.run 3000 (app mainThread shutdownMVar)
takeMVar shutdownMVar