If I run the following Java program on a Windows (10) machine (I'm posting the program here for the sake of completeness):
public class IdleServer {
public static void main(String[] args) throws IOException, InterruptedException {
ServerSocket serverSock = new ServerSocket(9090);
Socket sock = serverSock.accept();
while (true) Thread.sleep(1000);
}
}
and then I connect to the Java server from Haskell:
readWithinNSecs :: IO ()
readWithinNSecs = withSocketsDo $ do
h <- connectTo "localhost" (PortNumber 9090)
hSetBuffering h NoBuffering
readerTid <- forkIO $ reader h
threadDelay $ 2 * 10^6
putStrLn "Killing the reader"
killThread readerTid
putStrLn "Reader thread killed"
where
reader h = do
line <- strip <$> hGetLine h
putStrLn $ "Got " ++ line
then the Haskell program will hang when trying to kill the process that is trying to read from the handle. Killing the Java server will cause the Haskell program to terminate, giving also the error:
<socket: 380>: hGetLine: failed (No error)
If I run the same two programs on Linux then the Haskell program terminates.
This seems to point to a bug in the base libraries of Haskell, so I reported it, but in the meantime I need to find a way to workaround this. Any ideas?
UPDATE: I posted the solution below, but it is not satisfactory: it terminates the reader thread, but it leaks resources.
import Control.Concurrent.Async
-- ...
readerAsync h = do
a <- async $ strip <$> hGetLine h
line <- wait a
putStrLn $ "Got " ++ line
Related
I am trying to solve the following problem. I have some agents running in real-time, with a large heartbeat of couple of milliseconds, and the order of operations they process for this reason are mostly deterministic (as the message processing is not the bottleneck).
Now, I am running a large amount of simulations of the system where I no longer have a heartbeat (otherwise it will take a couple of centuries) - but I need to make sure the order of operations are preserved. For this, I adopted the following solution: the simulator makes sure each agent has processed his message queue, by posting a dummy synchronization message and blocking while waiting for the answer. This does work for my application, but the time it takes is not intuitive - as a single threaded implementation would be an order of magnitude faster (I guess - x 100 ish - although I have not tested ).
I have isolated a small test that shows the issue, even trying to use another library, akka.net
type Greet =
| Greet of string
| Hello of AsyncReplyChannel<bool>
| Hello2
[<EntryPoint>]
let main argv =
let system = System.create "MySystem" <| Configuration.load()
let greeter = spawn system "greeter" <| fun mailbox ->
let rec loop() = actor {
let! msg = mailbox.Receive()
let sender = mailbox.Sender()
match msg with
| Greet who -> () // printf "Hello, %s!\n" who
| Hello2 -> sender.Tell(true)
| _ -> ()
return! loop()
}
loop()
let greeterF =
MailboxProcessor.Start
(fun inbox ->
async {
while true do
let! msg = inbox.Receive()
match msg with
| Greet who -> () // printf "Hello, %s!\n" who
| Hello reply -> reply.Reply true
| _ -> ()
}
)
let n = 1000000
let t1 = System.Diagnostics.Stopwatch()
t1.Start()
for i = 1 to n do
let rep = greeterF.PostAndReply(fun reply -> (Hello reply)) |> ignore
()
printfn "elapsed Mailbox:%A" t1.ElapsedMilliseconds
t1.Restart()
for i = 1 to n do
let res = greeter.Ask (Hello2)
let rr = res.Result
()
printfn "elapsed Akka:%A" t1.ElapsedMilliseconds
System.Console.ReadLine () |> ignore
0
Basically, both take about 10 seconds for a mere 1 millions of synchronizations - and not computation what-so-ever involved, and this is... unfortunate.
I am wondering if anybody has come across the same problem and if there is anyway to switch off the overhead forcing everything to run in a single threaded mode... something like better than de-activating all the cpus but 1 in the bios - or writing a clone of the whole system without the agents.
Any help well appreciated.
The reason for the Akka.NET version beeing slow here is how you communicate with the actor:
main process Task FutureActorRef !!ThreadPool!! greeter
Ask ---------------------->
Tell----------->
MailboxRun ----->
(greeter mailbox is empty) |
<--------------------------Tell
<--Complete task
<----------.Result
For each iteration, a TPL task will be created
Then a single message is sent to the greeter.
The main process then blocks while waiting for the response to come back.
The greeter replies back which in turn completes the task inside the FutureActorRef
Rinse and Repeat..
This design will cause Akka.NET to start and stop the greeters "mailbox run" for each message as the mailbox queue becomes empty for each iteration.
This results in threadpool schedulation for each single message that is passed.
It's a bit like entering your car, putting the pedal to the metal, then abruptly stop and step out of the car, and then repeating the procedure again.
That is just not a very effective way to travel fast.
#Aaronontheweb's suggestion will only have effect if you work out the above kinks in your code.
The mailbox needs to be able to constantly pick messages of the internal queue to work with messages in batches to achieve full throughput.
Instead, separate the producer from the consumer.
Create an actor that listens for the responses from your greeter.
And once that actor have processes your 1000000 messages, let that actor send a WorkCompleted message back to the consumer.
[Edit]
I gave it a shot myself, I don't know F# so it might not be completely idiomatic :)
open Akka
open Akka.Actor
open Akka.FSharp
type Greet =
| Greet of string
| Hello of AsyncReplyChannel<bool>
| Hello2
type Consume =
| Response
| SetSender
[<EntryPoint>]
let main argv =
let system = System.create "MySystem" <| Configuration.load()
let greeter = spawn system "greeter" <| fun mailbox ->
let rec loop() = actor {
let! msg = mailbox.Receive()
let sender = mailbox.Sender()
match msg with
| Greet who -> () // printf "Hello, %s!\n" who
| Hello2 -> sender.Tell(Response)
| _ -> ()
return! loop()
}
loop()
let consumer = spawn system "consumer" <| fun mailbox ->
let rec loop(count,sender : IActorRef) = actor {
if count = 1000000 then sender.Tell(true)
let! msg = mailbox.Receive()
match msg with
| Response -> return! loop(count+1,sender)
| SetSender -> return! loop(count,mailbox.Sender())
}
loop(0,null)
let n = 1000000
let t1 = System.Diagnostics.Stopwatch()
t1.Start()
for i = 1 to n do
greeter.Tell(Hello2,consumer)
let workdone = consumer.Ask SetSender
workdone.Wait()
printfn "elapsed Akka:%A" t1.ElapsedMilliseconds
System.Console.ReadLine () |> ignore
0
I updated your code to use a separate consumer for the actor responses and then reply back once all replies had been processed.
By doing so, your processing time is now down to 650ms on my machine.
If you want better throughput, you need to involve more actors to parallelize more.
I'm not sure if this helps in your specific scenario
Here is a slightly modified MailboxProcessor version:
module MBPAsync =
type Greet =
| Greet of string
| Hello of AsyncReplyChannel<bool>
let run n =
let timer = Stopwatch.StartNew ()
use greeter =
MailboxProcessor.Start <| fun inbox -> async {
while true do
let! msg = inbox.Receive()
match msg with
| Greet who -> () // printf "Hello, %s!\n" who
| Hello reply -> reply.Reply true
}
Async.RunSynchronously <| async {
for i = 1 to n do
do! Async.Ignore (greeter.PostAndAsyncReply Hello)
}
let elapsed = timer.Elapsed
printfn "%A" elapsed
The difference here is that this version uses PostAndAsyncReply and keeps the computation in an async workflow. On my quick test this seemed to be much faster that using PostAndReply, but YMMV.
The timings I get from the above MBP version look roughly like this:
> MBPAsync.run 1000000 ;;
00:00:02.6883486
val it : unit = ()
A comment earlier mentioned my Hopac library. Here is an optimized version using Hopac:
module Hop =
type Greet =
| Greet of string
| Hello of IVar<bool>
let run n =
let timer = Stopwatch.StartNew ()
let greeterCh = ch ()
do greeterCh >>= function
| Greet who -> Job.unit ()
| Hello reply -> reply <-= true
|> Job.forever
|> server
Job.forUpToIgnore 1 n <| fun _ ->
let reply = ivar ()
greeterCh <-- Hello reply >>.
reply
|> run
let elapsed = timer.Elapsed
printfn "%A" elapsed
The timings I get from the above Hopac version look roughly like this:
> Hop.run 1000000 ;;
00:00:00.1088768
val it : unit = ()
I'm not an F# developer, but I'm a core dev on Akka.NET. A couple of ideas for your scenario:
If you're only using a single actor for this work, you can try using a PinnedDispatcher - that way the actor runs on its own dedicated thread all the time. That will save you on unnecessary context switching overhead.
You can also set the throughput of the mailbox to be much higher for this PinnedDispatcher than the normal settings. i.e. set a throughput value of 10000 (or something) instead of the normal 25. Assuming that the contents of your mailbox grow in large bursts this should save you on mailbox synchronization overhead.
Here's what your dispatcher configuration might look like:
my-pinned-dispatcher {
type = PinnedDispatcher
throughput = 1000 #your mileage may vary
}
And then configure an actor to use it
C# Fluent Interface
var myActor = myActorSystem.ActorOf(Props.Create<FooActor>()
.WithDispatcher("my-pinned-dispatcher");
Config
akka.actor.deployment{
/greeter{
dispatcher = my-pinned-dispatcher
}
}
These are both options you can configure via HOCON in App.config or Web.config or you can use the fluent interface on the Props class to do this. Also worth noting: there's a bug with pinned dispatchers at the moment, but that should be fixed in our next maintenance release (v1.0.1,) which should be out next week.
Your mileage may vary, but this is what I would try - basically it's just designed to help reduce contention and overhead around a single actor.
Suppose I have a list of Strings representing shell commands to execute.
commands = ["git clone https://github.com/test/repo.git", "git checkout origin"]
Also, suppose I have a command, execCommand that takes a string, executes it as a shell command, retrieves the exit code, stdout and stderr, and, if the exit code is nonzero, returns Just the concatenation of stdout and stderr; otherwise, it returns Nothing.
Now, how would I execute that list of commands sequentially while ensuring that subsequent commands do not execute after one command yields an error?
Below is the full code for execCommand.
import System.IO
import System.Process
import System.Exit
createCommand :: String -> FilePath -> CreateProcess
createCommand command curDir =
(shell command){std_out = CreatePipe, std_err = CreatePipe, cwd = Just curDir}
execCommand :: String -> FilePath -> IO (Maybe String)
execCommand command curDir = do
(_, Just hout, Just herr, procHandle) <- createProcess $ createCommand command curDir
exitCode <- waitForProcess procHandle
stdOut <- hGetContents hout
stdErr <- hGetContents herr
if exitCode /= ExitSuccess
then return $ Just $ concat [stdOut, stdErr]
else return $ Nothing
Well, this might solve your problem:
{-# LANGUAGE FlexibleInstances #-}
import System.IO
import System.Process
import System.Exit
import Control.Exception
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Trans.Maybe
createCommand :: CmdSpec -> FilePath -> CreateProcess
createCommand (ShellCommand command) curDir =
(shell command){std_out = CreatePipe, std_err = CreatePipe, cwd = Just curDir}
createCommand (RawCommand command arguments) curDir =
(proc command arguments){std_out = CreatePipe, std_err = CreatePipe, cwd = Just curDir}
execCommand :: CmdSpec -> FilePath -> IO ()
execCommand command curDir = do
(_, Just hout, Just herr, procHandle) <- createProcess $ createCommand command curDir
exitCode <- waitForProcess procHandle
when (exitCode /= ExitSuccess) $ do
stdOut <- hGetContents hout
stdErr <- hGetContents herr
throwIO $ stdOut ++ stdErr
instance Exception String
execList :: [(CmdSpec, FilePath)] -> MaybeT IO String
execList xs = do
out <- liftIO $ try $ mapM_ (uncurry execCommand) xs
case out of
Left c -> return c
Right _ -> mzero
Notice that this uses FlexibleInstances. This was required for making String an instance of the Exception typeclass (the problem lies in the fact that String = [Char]). You could remove the extension by creating a new type which encloses a string and making it an instance of Exception.
Well, I am pretty sure I figured it out. Instead of using "fancy" stuff, I fell back to good ol' recursion.
runCommands :: [String] -> FilePath -> IO (Maybe String)
runCommands [] _ = return Nothing
runCommands (command:rest) curDir = do
result <- execCommand command curDir
case result of
Nothing -> runCommands rest curDir
Just err -> return $ Just err
You can use mapM_, which has the type
mapM_ :: ( (CmdSpec, FilePath) -> ExceptT String IO ())
-> [(CmdSpec, FilePath)] -> ExceptT String IO ()
and appropriate short-circuiting behavior.
I wrote a simple TCP-client for some device, which consumes and produces 8-byte packets (the code of send-command-receive-result function is below).
When I run it on linux, it works perfectly, being part of the loop (send-recv-send-recv-...), but on windows it receives only first msg from device (send-recv-send-send-...). The packets are still going - I could clearly see them with Wireshark - but something under my client just ignores them (or truncates to zero?). It doesn't even print "Data was read!" - looks like the reading stucks and gets killed by timeout function.
Before that, I used the sockets directly; changing to HandleStream yelded no difference at all. Wrapping main in withSocketsDo did nothing, too.
transmit :: Int -> HandleStream ByteString -> ByteString -> IO [Bytestring]
transmit delay sock packet = do
let input = timeout delay $ sock `readBlock` 8 <* putStrLn "\nData was read!"
sock `writeBlock` pack
strings <- whileJust input
return [str | Right str <- strings]
whileJust action = do
result <- action
case result of
Just a -> (:) <$> return a <*> whileJust action
Nothing -> return []
What am I doing wrong?
I intend to build on this code, found here
However, I notice I can telnet to this server on the local host. Can't from another computer. I did a quick nmap scan, which reported that nothing was listening on the port I had selected.
For purposes of troubleshooting, I had shut down my firewall, so I've ruled that out as a possible problem.
Clues from haskell windows programmers would be appreciated.
It seems that the socket got bind to localhost (127.0.0.1), thats why you are not able to connect it from other machine and it only connect from local machine. Try to use Bind API to first create the socket and then bind the socket to "Any address" which binds the socket to every interface available on local machine.
This is for future new haskellers.
I based my code on this example.
I made improvements based on this reddit thread, and suggestions made above. The import statements are still sloppy, but fixing them is left as the proverbial "exercise for the reader". I invite any additional suggestions leading to improvements.
import Network.Socket
import Control.Monad
import Network
import System.Environment (getArgs)
import System.IO
import Control.Concurrent (forkIO)
main :: IO ()
main = withSocketsDo $ do
[portStr] <- getArgs
sock <- socket AF_INET Stream defaultProtocol
let port = fromIntegral (read portStr :: Int)
socketAddress = SockAddrInet port 0000
bindSocket sock socketAddress
listen sock 1
putStrLn $ "Listening on " ++ (show port)
sockHandler sock
sockHandler :: Socket -> IO ()
sockHandler sock' = forever $ do
(sock, _) <- Network.Socket.accept sock'
handle <- socketToHandle sock ReadWriteMode
hSetBuffering handle NoBuffering
forkIO $ commandProcessor handle
commandProcessor :: Handle -> IO ()
commandProcessor handle = forever $ do
line <- hGetLine handle
let (cmd:arg) = words line
case cmd of
"echo" -> echoCommand handle arg
"add" -> addCommand handle arg
_ -> do hPutStrLn handle "Unknown command"
echoCommand :: Handle -> [String] -> IO ()
echoCommand handle arg = do
hPutStrLn handle (unwords arg)
addCommand :: Handle -> [String] -> IO ()
addCommand handle [x,y] = do
hPutStrLn handle $ show $ read x + read y
addCommand handle _ = do
hPutStrLn handle "usage: add Int Int"
I usually go with
netstat -an | grep LISTEN
If you see the port listed, something is listening. I can't remember offhand what the lsof command is for sockets and Google isn't giving up the goods.
I've tried this:
main = do
hSetBuffering stdin NoBuffering
c <- getChar
but it waits until the enter is pressed, which is not what I want. I want to read the character immediately after user presses it.
I am using ghc v6.12.1 on Windows 7.
EDIT: workaround for me was moving from GHC to WinHugs, which supports this correctly.
Yes, it's a bug. Here's a workaround to save folks clicking and scrolling:
{-# LANGUAGE ForeignFunctionInterface #-}
import Data.Char
import Foreign.C.Types
getHiddenChar = fmap (chr.fromEnum) c_getch
foreign import ccall unsafe "conio.h getch"
c_getch :: IO CInt
So you can replace calls to getChar with calls to getHiddenChar.
Note this is a workaround just for ghc/ghci on Windows. For example, winhugs doesn't have the bug and this code doesn't work in winhugs.
Might be a bug:
http://hackage.haskell.org/trac/ghc/ticket/2189
The following program repeats inputted characters until the escape key is pressed.
import IO
import Monad
import Char
main :: IO ()
main = do hSetBuffering stdin NoBuffering
inputLoop
inputLoop :: IO ()
inputLoop = do i <- getContents
mapM_ putChar $ takeWhile ((/= 27) . ord) i
Because of the hSetBuffering stdin NoBuffering line it should not be necessary to press the enter key between keystrokes. This program works correctly in WinHugs (sep 2006 version). However, GHC 6.8.2 does not repeat the characters until the enter key is pressed. The problem was reproduced with all GHC executables (ghci, ghc, runghc, runhaskell), using both cmd.exe and command.com on Windows XP Professional...
Hmm.. Actually I can't see this feature to be a bug. When you read stdin that means that you want to work with a "file" and when you turn of buffering you are saying that there is no need for read buffer. But that doesn't mean that application which is emulating that "file" should not use write buffer. For linux if your terminal is in "icanon" mode it doesn't send any input until some special event will occur (like Enter pressed or Ctrl+D). Probably console in Windows have some similar modes.
The Haskeline package worked for me.
If you need it for individual characters, then just change the sample slightly.
getInputLine becomes getInputChar
"quit" becomes 'q'
++ input becomes ++ [input]
main = runInputT defaultSettings loop
where
loop :: InputT IO ()
loop = do
minput <- getInputChar "% "
case minput of
Nothing -> return ()
Just 'q' -> return ()
Just input -> do outputStrLn $ "Input was: " ++ [input]
loop
From comment of #Richard Cook:
Use hidden-char: Provides cross-platform getHiddenChar function.
I used the haskeline package, suggested in other answers, to put together this simple alternative to getChar. It requests input again in the case that getInputChar returns Nothing. This worked for me to get past the issue; modify as needed.
import System.Console.Haskeline
( runInputT
, defaultSettings
, getInputChar
)
betterInputChar :: IO Char
betterInputChar = do
mc <- runInputT defaultSettings (getInputChar "")
case mc of
Nothing -> betterInputChar
(Just c) -> return c