Control thread to exit haskell application - haskell

I'm brand new to Haskell and in messing around with a few samples I've got a problem where I can't stop the program. I'm using Windows 7 and using runhaskell from ght. Ctrl-c doesn't work so I have to resort to the task manager which is a bit of a pain.
Instead of doing that how can I create a separate control thread that would wait until I typed q and then quit my Haskell application.
The application I've got the problem with is of the format:
main = do
h <- connectTo server (PortNumber (fromInteger port))
hSetBuffering h NoBuffering
... do some stuff with the socket handle ...
listen h
listen :: Handle -> IO ()
listen h = forever $ do
t <- hGetLine h
let s = init t
putStrLn s
where
forever a = do a; forever a
In pseudo-code what I'd like to have is:
main = do
waitForQuit
... original program ...
waitForQuit :: IO()
option <- getChar
if option == 'q' then
... kill the app ...
else
waitForQuit

You should be able to do this with a Haskell thread, getChar and exit{With,Success,Failure}.
import Control.Concurrent
import System.Exit
import Data.Char (toLower)
import System.IO
main = do
forkIO realMain
exitOnQ
exitOnQ = do
hSetBuffering stdin NoBuffering
c <- getChar
when (toLower c /= 'q') exitOnQ
exitSuccess -- or "exitWith" and some ExitCode value, use hoogle.
Breaking this down: You get concurrently via forkIO. Notice this isn't a separate OS thread, but a Haskell thread which is extremely lightweight. The exitOnQ thread needs to get keystrokes without delay - without the NoBuffering you'd have to hit q-[ENTER]. If the pressed key wasn't q (or Q) then we loop, otherwise we terminate the program via one of the many exit* calls.
WARNING: It is a very uncommon corner case, but GHC uses GC points as thread scheduling points (has this changed in the past two years?) so if your code is spending significant blocks of time performing lots of pure computations that have zero allocation then you can't use this method to quit (unless you have multiple OS threads via the threaded RTS and an +RTS -N# option).

how can I create a separate control thread that would wait until I typed q and then quit my Haskell application.
You can create new threads with forkIO, which takes a chunk of code as an argument. E.g.
main = do
forkIO waitForQuit
....
The quit handler will spend most of its time blocked on getChar, but when it wakes up, it can terminate the program, by throwing an exit exception, such as:
exitWith ExitSuccess
You may need to compile the program with ghc -O -threaded to ensure the program main thread can make progress, while the handler is waiting on q

Related

Why this two function created by forkIO in haskell can't be run one by one?

I have this prog in windows ghc:
import Control.Concurrent
a=print 1
b=print 2
main=do
forkIO a
forkIO b
it can only print 1 in console,Why?
I think the main thread run first,then it create a thread,run function a,print 1,then create another thread,run function b,then print 2
so the console will give me
1
2
Ok, I think I remember something about "a Haskell program ends when the main thread exits". So the main thread is ending before the other threads have had a chance to do their thing. A quick fix is
main = do
forkIO a
forkIO b
threadDelay (10^6) -- 1 second
A less quick, more correct fix is to use MVars to simulate "joining" a thread -- i.e. waiting until it completes.

typed-process withProcessWait_ and getExitCode race condition?

import System.Process.Typed
import Control.Monad.STM
import Control.Concurrent.STM.TVar
processConf = setStderr byteStringOutput . setStdout byteStringOutput
main :: IO ()
main = do
withProcessWait_ (processConf $ proc "sleep" ["1"])
$ \p -> do
atomically (getStdout p) >>= print
atomically (getStderr p) >>= print
getExitCode p >>= print
print "test"
The above code mostly returns Nothing for the exit code, while other times it'll return Just ExitSuccess, so seemingly random / race condition.
Why might this occur?
The function in question is: http://hackage.haskell.org/package/typed-process-0.2.6.0/docs/System-Process-Typed.html#v:withProcessWait_
withProcessWait_ :: MonadUnliftIO m => ProcessConfig stdin stdout stderr -> (Process stdin stdout stderr -> m a) -> m a
My understanding of what the function will do is, run the process, wait till it's terminated and then run the IO a. However... I just noticed there is a readProcess function which sounds like what I should actually be using instead http://hackage.haskell.org/package/typed-process-0.2.6.0/docs/System-Process-Typed.html#v:readProcess
None the less, it would be useful to know what is actually happening in the above / withProcessWait_.
The race condition is that three separate threads are consuming all available standard output (first thread) and standard error (second thread) and waiting on the exit code (third thread). The standard output and standard error thread can complete and publish the full output to STM before the third thread publishes the exit code.
Since getExitCode checks the exit code TMVar but doesn't wait on it, the exit code may not be available. (In fact, if the child process closes standard output and error before exiting, it may genuinely still be running at this point!)
If you replace getExitCode with waitExitCode, you reliably get ExitSuccess. Of course, withProcessWait_ is already waiting on the exit code and will raise an exception if it's not ExitSuccess, so there's no particular reason to do this anyway.

Game server in Haskell

I'm using Network and Gloss for a game server in Haskell. It works fine, except that the client has to close for the server to receive the data it sent. I bet it's a case of laziness...
Minimalist server:
import Network
import System.IO
main = do
sock <- listenOn (PortNumber (fromIntegral 12345))
loop sock
loop sock = do
(hIn, _, _) <- accept sock
str <- hGetContents hIn
print str
loop sock
Minimalist client:
import Network
import System.IO
import Graphics.Gloss.Interface.IO.Game
main = playIO
(InWindow "Test Multi" (500, 500) (500, 500))
white
60
Nothing
draw
(\_ x -> return x)
advance
draw Nothing = return blank
draw (Just x) = return (Text (show x))
advance _ Nothing = do
hOut <- connectTo "000.000.0.0" (PortNumber (fromIntegral 12345))
hSetBuffering hOut NoBuffering
hPutStr hOut "Hello!"
return (Just hOut)
advance _ x = return x
I start the server, wait 10 seconds, then start the client, wait 15 seconds, see that nothing happens on the server, closes the client, see "Hello!" suddenly appear on the server.
I would like "Hello!" to appear while the client is running, in an advance call, otherwise I can't make a multiplayer game (sob)!
However, if I change the client's code to
main = loop Nothing
loop x = do
x' <- advance 0 x
getLine
the sever immediatly shows "Hello!" while the client is waiting for my input.
I tried, as suggested in another question, to use bang patterns and hClose:
-- ...
!str <- hGetContents hIn
hClose hIn
-- ...
which makes the output appear immediatly, without the client closing. That's great. But, I plan to use bytestrings because the data I send to the server is serialized, so I import qualified Data.ByteString as B and change hGetContents to B.hGetContents, which makes the problem re-appear.
The problem was indeed a case of laziness. hGetContents reads lazily all the contents of the Handle, so it finishes only when it's closed, when the client aborts the connection. Instead, I used hGetLine that returns the content each time it encounters a \n, which I use as a end-of-message tag.
I might be completely wrong, but isn't the problem hGetContents? Surely that should wait till the entire contents sent through your socket have arrived before the next line (print...) starts. hGetContents is designed to give you all the contents sent until the socket is closed. Something like hGetLine could terminate straight away and you can leave the socket open to send more data through later. Your client could then use a hPutStrLn instead of hPutStr.
It defaults to line-buffered output, which is why hPutStr (which doesn't provide a line ending) doesn't output anything until you flush the buffer. There are two ways you can solve this:
a) Call hFlush stdout manually any time you want to flush the output.
b) Use hSetBuffering to set the buffering to NoBuffering
All of those functions are found in the System.IO module.
Edit: Never mind, I just saw where you did that in the client. I retract my answer with apologies.
Probably, you need to disable algorithm Nagle.
Try this code:
import Network.Socket
setSocketOption sock NoDelay 1

can xmonad's logHook be run at set intervals rather than in (merely) response to layout events?

I'm using dynamicLogWithPP from XMonad.Hooks.DynamicLog together with dzen2 as a status bar under xmonad. One of the things I'd like to have displayed in the bar is the time remaining in the currently playing track in audacious (if any). Getting this information is easy:
audStatus :: Player -> X (Maybe String)
audStatus p = do
info <- liftIO $ tryS $ withPlayer p $ do
ispaused <- paused
md <- getMetadataString
timeleftmillis <- (-) <$> (getCurrentTrack >>= songFrames) <*> time
let artist = md ! "artist"
title = md ! "title"
timeleft = timeleftmillis `quot` 1000
(minutes, seconds) = timeleft `quotRem` 60
disp = artist ++ " - " ++ title ++ " (-"++(show minutes)++":"++(show seconds)++")" -- will be wrong if seconds < 10
audcolor False = dzenColor base0 base03
audcolor True = dzenColor base1 base02
return $ wrap "^ca(1, pms p)" "^ca()" (audcolor ispaused disp)
return $ either (const Nothing) Just info
So I can stick that in ppExtras and it works fine—except it only gets run when the logHook gets run, and that happens only when a suitable event comes down the pike. So the display is potentially static for a long time, until I (e.g.) switch workspaces.
It seems like some people just run two dzen bars, with one getting output piped in from a shell script. Is that the only way to have regular updates? Or can this be done from within xmonad (without getting too crazy/hacky)?
ETA: I tried this, which seems as if it should work better than it does:
create a TChan for updates from XMonad, and another for updates from a function polling Audacious;
set the ppOutput field in the PP structure from DynamicLog to write to the first TChan;
fork the audacious-polling function and have it write to the second TChan;
fork a function to read from both TChans (checking that they aren't empty, first), and combining the output.
Updates from XMonad are read from the channel and processed in a timely fashion, but updates from Audacious are hardly registered at all—every five or so seconds at best. It seems as if some approach along these lines ought to work, though.
I know this is an old question, but I came here looking for an answer to this a few days ago, and I thought I'd share the way I solved it. You actually can do it entirely from xmonad. It's a tiny bit hacky, but I think it's much nicer than any of the alternatives I've come across.
Basically, I used the XMonad.Util.Timer library, which will send an X event after a specified time period (in this case, one second). Then I just wrote an event hook for it, which starts the timer again, and then manually runs the log hook.
I also had to use the XMonad.Util.ExtensibleState library, because Timer uses an id variable to make sure it's responding to the right event, so I have to store that variable between events.
Here's my code:
{-# LANGUAGE DeriveDataTypeable #-}
import qualified XMonad.Util.ExtensibleState as XS
import XMonad.Util.Timer
...
-- wrapper for the Timer id, so it can be stored as custom mutable state
data TidState = TID TimerId deriving Typeable
instance ExtensionClass TidState where
initialValue = TID 0
...
-- put this in your startupHook
-- start the initial timer, store its id
clockStartupHook = startTimer 1 >>= XS.put . TID
-- put this in your handleEventHook
clockEventHook e = do -- e is the event we've hooked
(TID t) <- XS.get -- get the recent Timer id
handleTimer t e $ do -- run the following if e matches the id
startTimer 1 >>= XS.put . TID -- restart the timer, store the new id
ask >>= logHook.config -- get the loghook and run it
return Nothing -- return required type
return $ All True -- return required type
Pretty straightforward. I hope this is helpful to someone.
It cannot be done from within xmonad; xmonad's current threading model is a bit lacking (and so is dzen's). However, you can start a separate process that periodically polls your music player and then use one of the dzen multiplexers (e.g. dmplex) to combine the output from the two processes.
You may also want to look into xmobar and taffybar, which both have better threading stories than dzen does.
With regards to why your proposed TChan solution doesn't work properly, you might want to read the sections "Conventions", "Foreign Imports", and "The Non-Threaded Runtime" at my crash course on the FFI and gtk, keeping in mind that xmonad currently uses GHC's non-threaded runtime. The short answer is that xmonad's main loop makes an FFI call to Xlib that waits for an X event; this call blocks all other Haskell threads from running until it returns.

How can I make file I/O more transactional?

I'm writing CGI scripts in Haskell. When the user hits ‘submit’, a Haskell program runs on the server, updating (i.e. reading in, processing, overwriting) a status file. Reading then overwriting sometimes causes issues with lazy IO, as we may be able to generate a large output prefix before we've finished reading the input. Worse, users sometimes bounce on the submit button and two instances of the process run concurrently, fighting over the same file!
What's a good way to implement
transactionalUpdate :: FilePath -> (String -> String) -> IO ()
where the function (‘update’) computes the new file contents from the old file contents? It is not safe to presume that ‘update’ is strict, but it may be presumed that it is total (robustness to partial update functions is a bonus). Transactions may be attempted concurrently, but no transaction should be able to update if the file has been written by anyone else since it was read. It's ok for a transaction to abort in case of competition for file access. We may assume a source of systemwide-unique temporary filenames.
My current attempt writes to a temporary file, then uses a system copy command to overwrite. That seems to deal with the lazy IO problems, but it doesn't strike me as safe from races. Is there a tried and tested formula that we could just bottle?
The most idiomatic unixy way to do this is with flock:
http://hackage.haskell.org/package/flock
http://swoolley.org/man.cgi/2/flock
Here is a rough first cut that relies on the atomicity of the underlying mkdir. It seems to fulfill the specification, but I'm not sure how robust or fast it is:
import Control.DeepSeq
import Control.Exception
import System.Directory
import System.IO
transactionalUpdate :: FilePath -> (String -> String) -> IO ()
transactionalUpdate file upd = bracket acquire release update
where
acquire = do
let lockName = file ++ ".lock"
createDirectory lockName
return lockName
release = removeDirectory
update _ = nonTransactionalUpdate file upd
nonTransactionalUpdate :: FilePath -> (String -> String) -> IO ()
nonTransactionalUpdate file upd = do
h <- openFile file ReadMode
s <- upd `fmap` hGetContents h
s `deepseq` hClose h
h <- openFile file WriteMode
hPutStr h s
hClose h
I tested this by adding the following main and throwing a threadDelay in the middle of nonTransactionalUpdate:
main = do
[n] <- getArgs
transactionalUpdate "foo.txt" ((show n ++ "\n") ++)
putStrLn $ "successfully updated " ++ show n
Then I compiled and ran a bunch of instances with this script:
#!/bin/bash
rm foo.txt
touch foo.txt
for i in {1..50}
do
./SO $i &
done
A process that printed a successful update message if and only if the corresponding number was in foo.txt; all the others printed the expected SO: foo.txt.notveryunique: createDirectory: already exists (File exists).
Update: You actually do not want to use unique names here; it must be a consistent name across the competing processes. I've updated the code accordingly.

Resources