I have racy behavior with the following code
{-# LANGUAGE OverloadedStrings #-}
module Main where
import Control.Concurrent (threadDelay)
import qualified Control.Concurrent.Async as Async
import qualified System.Process.Typed as Proc
import qualified System.Process as P
import qualified GHC.IO.Handle as H
main :: IO ()
main = do
print "starting"
(readEnd, writeEnd) <- P.createPipe
let p1 = Proc.setStdout (Proc.useHandleClose writeEnd) "echo -n 'foo'"
let p2 = Proc.setStdin (Proc.useHandleClose readEnd) "base64 -"
Async.concurrently
(threadDelay 1000 *> Proc.runProcess_ p2) -- with the delay, it works
-- (Proc.runProcess_ p2) -- that line will make the program hang forever
(Proc.runProcess_ p1)
print "done"
I want to pipe stdout from the first subprocess to the second subprocess.
I tried using getStdout and setStdin but get into problem with the typechecker:
Proc.withProcess_ "echo -n foo" $ \r1 -> do
let p2 = Proc.setStdin (Proc.getStdout r1) "base64"
• Couldn't match expected type ‘Proc.StreamSpec
'Proc.STInput stdin0’
with actual type ‘()’
• In the first argument of ‘Proc.setStdin’, namely
‘(Proc.getStdout r1)’
In the expression: Proc.setStdin (Proc.getStdout r1) "base64"
Related
I am aware of this thread and the agreed-upon ghci :browse command, but I am looking for something similar to run from a script.hs file:
Say I have a module that I can import into my script.hs. How do I then view the list of functions I have just gained access to?
What I've settled on for now
Adapting this thread that suggests the now-deprecated ghc-mod command-line program, I am
calling the terminal command ghc -e ':browse <module, e.g. Data.List>'
from my script.hs using Shelly.
My full script:
#!/usr/bin/env runghc
{-# LANGUAGE OverloadedStrings #-}
import Safe (headDef)
import Shelly
import System.Environment (getArgs)
import qualified Data.Text as T
mdl :: IO String
mdl = getArgs >>= return . headDef "Data.List"
runShelly :: String -> IO ()
runShelly mdl = shelly $ silently $ do
out <- run "ghc" ["-e", T.pack (":browse " ++ mdl)]
let lns = T.lines out
liftIO $ mapM_ (putStrLn .T.unpack) $ lns
main :: IO ()
main = mdl >>= runShelly
This way I can pass the module name on the command line as <script> <module> and get back the functions, one per line. It defaults to Data.List if I pass no arguments.
So that's a solution, but surely there must be handier introspection facilities than this?
In my program I am starting external process and communicate with it via stdin and stdout. I'm feeding the input through conduit (producer) started from STMs TQueue. It worked like a charm until I've decided to bump lts version. It worked great with lts <= 8.24.
Here is the minimized program that reproduces my problem:
#!/usr/bin/env stack
-- stack --resolver lts-10.4 --install-ghc runghc --package conduit-extra --package stm-conduit
{-# LANGUAGE OverloadedStrings #-}
import Control.Concurrent
import Control.Monad.STM
import Control.Concurrent.STM.TQueue
import Data.Conduit
import qualified Data.Conduit.Binary as CB
import qualified Data.Conduit.List as CL
import Data.Conduit.Process (CreateProcess (..),
proc, sourceProcessWithStreams)
import qualified Data.Conduit.TQueue as CTQ
import qualified Data.ByteString.Char8 as BS
import Data.Monoid ((<>))
main :: IO ()
main = do
putStrLn "Enter \"exit\" to exit."
q <- open
putStrLn "connection opened"
loop q
where loop q = do
s <- BS.getLine
case s of
"exit" -> return ()
req -> do
atomically $ writeTQueue q req
loop q
open :: IO (TQueue BS.ByteString)
open = do
req <- atomically newTQueue
let chat :: CreateProcess
chat = proc "cat" []
input :: Producer IO BS.ByteString
input = toProducer
$ CTQ.sourceTQueue req
-- .| CL.mapM_ (\bs -> BS.putStrLn (("queue: " :: BS.ByteString) <> bs))
output :: Consumer BS.ByteString IO ()
output = toConsumer
$ CL.mapM_ BS.putStrLn
_ <- forkIO (sourceProcessWithStreams chat input output output >> pure ())
pure req
With newer lts it seems like the problem is not with communication via TQueue, as uncommenting the line which prints content from input conduit gives shows data from the queue. It looks like the spawned process never receives anything on it's stdin.
Furthermore writing to spawned cat stdin from console, like so:
echo "test" > /proc/<pid of spawned cat>/fd/0
produces output in my program.
Am I missing something that changed between versions?
So the issue was that default behaviour of sinkHandle was changed to not flush after every chunk of data.
I've fixed the issue by first porting to Data.Conduit.Process.Typed and then rolling my own variant of createSink that is using sinkHandleFlush instead of sinkHandle.
The Problem
Hello! I'm writing in Cloud Haskell a simple Server - Worker program. The problem is, that when I try to create ManagedProcess, after the server disovery step, my example hangs forever even while using callTimeout (which should break after 100 ms). The code is very simple, but I cannot find anything wrong with it.
I've posted the question on the mailing list also, but as far as I know the SO community, I canget the answer a lot faster here. If I get the answer from mailing list, I will postit here also.
Source Code
The Worker.hs:
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE TemplateHaskell #-}
module Main where
import Network.Transport (EndPointAddress(EndPointAddress))
import Control.Distributed.Process hiding (call)
import Control.Distributed.Process.Platform hiding (__remoteTable)
import Control.Distributed.Process.Platform.Async
import Control.Distributed.Process.Platform.ManagedProcess
import Control.Distributed.Process.Platform.Time
import Control.Distributed.Process.Platform.Timer (sleep)
import Control.Distributed.Process.Closure (mkClosure, remotable)
import Network.Transport.TCP (createTransport, defaultTCPParameters)
import Control.Distributed.Process.Node hiding (call)
import Control.Concurrent (threadDelay)
import GHC.Generics (Generic)
import Data.Binary (Binary)
import Data.Typeable (Typeable)
import Data.ByteString.Char8 (pack)
import System.Environment (getArgs)
import qualified Server as Server
main = do
[host, port, serverAddr] <- getArgs
Right transport <- createTransport host port defaultTCPParameters
node <- newLocalNode transport initRemoteTable
let addr = EndPointAddress (pack serverAddr)
srvID = NodeId addr
_ <- forkProcess node $ do
sid <- discoverServer srvID
liftIO $ putStrLn "x"
liftIO $ print sid
r <- callTimeout sid (Server.Add 5 6) 100 :: Process (Maybe Double)
liftIO $ putStrLn "x"
liftIO $ threadDelay (10 * 1000 * 1000)
threadDelay (10 * 1000 * 1000)
return ()
discoverServer srvID = do
whereisRemoteAsync srvID "serverPID"
reply <- expectTimeout 100 :: Process (Maybe WhereIsReply)
case reply of
Just (WhereIsReply _ msid) -> case msid of
Just sid -> return sid
Nothing -> discoverServer srvID
Nothing -> discoverServer srvID
The Server.hs:
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE TemplateHaskell #-}
module Server where
import Control.Distributed.Process hiding (call)
import Control.Distributed.Process.Platform hiding (__remoteTable)
import Control.Distributed.Process.Platform.Async
import Control.Distributed.Process.Platform.ManagedProcess
import Control.Distributed.Process.Platform.Time
import Control.Distributed.Process.Platform.Timer (sleep)
import Control.Distributed.Process.Closure (mkClosure, remotable)
import Network.Transport.TCP (createTransport, defaultTCPParameters)
import Control.Distributed.Process.Node hiding (call)
import Control.Concurrent (threadDelay)
import GHC.Generics (Generic)
import Data.Binary (Binary)
import Data.Typeable (Typeable)
data Add = Add Double Double
deriving (Typeable, Generic)
instance Binary Add
launchServer :: Process ProcessId
launchServer = spawnLocal $ serve () (statelessInit Infinity) server >> return () where
server = statelessProcess { apiHandlers = [ handleCall_ (\(Add x y) -> liftIO (putStrLn "!") >> return (x + y)) ]
, unhandledMessagePolicy = Drop
}
main = do
Right transport <- createTransport "127.0.0.1" "8080" defaultTCPParameters
node <- newLocalNode transport initRemoteTable
_ <- forkProcess node $ do
self <- getSelfPid
register "serverPID" self
liftIO $ putStrLn "x"
mid <- launchServer
liftIO $ putStrLn "y"
r <- call mid (Add 5 6) :: Process Double
liftIO $ print r
liftIO $ putStrLn "z"
liftIO $ threadDelay (10 * 1000 * 1000)
liftIO $ putStrLn "z2"
threadDelay (10 * 1000 * 1000)
return ()
We can run them as follow:
runhaskell Server.hs
runhaskell Worker.hs 127.0.0.2 8080 127.0.0.1:8080:0
The Results
When we run the programs, we got following results:
from Server:
x
y
!
11.0 -- this one shows that inside the same process we were able to use the "call" function
z
-- waiting - all the output above were tests from inside the server now it waits for external messages
from Worker:
x
pid://127.0.0.1:8080:0:10 -- this is the process id of the server optained with whereisRemoteAsync
-- waiting forever on the "callTimeout sid (Server.Add 5 6) 100" code!
As a sidenote - I've found out that, when sending messages with send (from Control.Distributed.Process) and reciving them with expect works. But sending them with call (from Control.Distributed.Process.Platform) and trying to recive them with ManagedProcess api handlers - hangs the call forever (even using callTimeout!)
Your client is getting an exception, which you are not able to observe easily because you are running your client in a forkProcess. If you want to do that it is fine but then you need to monitor or link to that process. In this case, simply using runProcess would be much simpler. If you do that, you will see you get this exception:
Worker.hs: trying to call fromInteger for a TimeInterval. Cannot guess units
callTimeout does not take an Integer, it takes a TimeInterval which are constructed with the functions in the Time module. This is a pseudo-Num - it does not actually support fromInteger it seems. I would consider that a bug or at least bad form (in Haskell) but in any case the way to fix your code is simply
r <- callTimeout sid (Server.Add 5 6) (milliSeconds 100) :: Process (Maybe Double)
To fix the problem with the client calling into the server, you need to register the pid of the server process you spawned rather than the main process you spawn it from - i.e. change
self <- getSelfPid
register "serverPID" self
liftIO $ putStrLn "x"
mid <- launchServer
liftIO $ putStrLn "y"
to
mid <- launchServer
register "serverPID" mid
liftIO $ putStrLn "y"
I am trying to write a simple program in Haskell which listens over Zero MQ socket and publishes it to websocket connection, below is my code
{-# LANGUAGE OverloadedStrings #-}
import Data.Char (isPunctuation, isSpace)
import Data.Monoid (mappend)
import Data.Text (Text)
import Control.Exception (fromException)
import Control.Monad (forM_, forever)
import Control.Concurrent (MVar, newMVar, modifyMVar_, readMVar)
import Control.Monad.IO.Class (liftIO)
import Control.Monad
import qualified Data.Text as T
import qualified Data.Text.IO as T
import qualified Network.WebSockets as WS
import System.ZMQ3.Monadic
import Data.ByteString.Char8 (pack, unpack)
import Control.Concurrent (threadDelay)
import Data.Text.Encoding
import Data.ByteString.Internal
main :: IO ()
main = do
liftIO $ putStrLn "starting main..."
WS.runServer "0.0.0.0" 9160 $ application
application :: WS.Request -> WS.WebSockets WS.Hybi00 ()
application rq = do
liftIO $ putStrLn "starting..."
WS.acceptRequest rq
sink <- WS.getSink
WS.getVersion >>= liftIO . putStrLn . ("Client version: " ++)
msg <- WS.receiveData
liftIO $ putStrLn $ show $ (msg:: Text)
WS.sendTextData (msg :: Text)
runZMQ $ do
repSocket<- socket Rep
s<-return $bind repSocket "tcp://*:6555"
msg2 <- receive repSocket
let quote = msg2
--msg2 <- WS.receiveData
--liftIO $ putStrLn $ quote
WS.sendTextData $ ("test"::Text)
But compiler fails at statement WS.sendTextData $ ("test"::Text) saying below error
websocket_server.hs:42:17:
Couldn't match expected type `ZMQ z a0'
with actual type `WS.WebSockets p0 ()'
In a stmt of a 'do' block: WS.sendTextData $ ("test" :: Text)
In the second argument of `($)', namely
`do { repSocket <- socket Rep;
s <- return $ bind repSocket "tcp://*:6555";
msg2 <- receive repSocket;
let quote = msg2;
.... }'
In a stmt of a 'do' block:
runZMQ
$ do { repSocket <- socket Rep;
s <- return $ bind repSocket "tcp://*:6555";
msg2 <- receive repSocket;
let quote = msg2;
.... }
I am not sure how to deal with this issue how can I make do block statements return same value when the values cannot be converted into each other?
A simple liftIO should be enough for that call, but I haven't tried.
The trouble is that both the ZMQ and Websockets libraries define a "top level monad" that is not a monad transformer. So there is no provided way to layer the monads. This is poor design on their parts.
My suggestion would be to A) write your own ZMQ transformer or B) use the nonmonadic interface provided by ZMQ at the top level.
According to this topic: https://stackoverflow.com/questions/14494922/examples-of-websocket-usage-in-haskell I have my first question. Why official example of WebSockets library doesn't run on my machine?
import Data.Char (isPunctuation, isSpace)
import Data.Monoid (mappend)
import Data.Text (Text)
import Control.Exception (fromException)
import Control.Monad (forM_, forever)
import Control.Concurrent (MVar, newMVar, modifyMVar_, readMVar)
import Control.Monad.IO.Class (liftIO)
import qualified Data.Text as T
import qualified Data.Text.IO as T
import Network.WebSockets
meow :: TextProtocol p => WebSockets p ()
meow = forever $ do
msg <- receiveData
sendTextData $ msg `T.append` ", meow."
main :: IO ()
main = runServer "0.0.0.0" 8000 meow
I get:
ciembor#freedom ~> ghc hchat.hs; and ./hchat
[1 of 1] Compiling Main ( hchat.hs, hchat.o )
hchat.hs:15:35:
Couldn't match expected type `Text' with actual type `[Char]'
In the second argument of `T.append', namely `", meow."'
In the second argument of `($)', namely `msg `T.append` ", meow."'
In a stmt of a 'do' block: sendTextData $ msg `T.append` ", meow."
hchat.hs:18:33:
Couldn't match expected type `Request -> WebSockets p0 ()'
with actual type `WebSockets p1 ()'
In the third argument of `runServer', namely `meow'
In the expression: runServer "0.0.0.0" 8000 meow
In an equation for `main': main = runServer "0.0.0.0" 8000 meow
The first error is because you didn't enable the OverloadedStrings language extension. Without that, a "xyz" is a String, but Data.Text.append takes two Texts as arguments. Add
{-# LANGUAGE OverloadedStrings #-}
to the top of the module to fix that one.
The second error is because the third argument to runServer must have type
Request -> WebSockets p0 ()
but you gave it a WebSockets p1 (). If you want to pass an action, you have to lift it to a function,
main = runServer "0.0.0.0" 8000 $ const meow
would compile (whether it would work [do what you want] is a question I cannot answer, that would just ignore all requests and always do the same thing).