I am trying to create a simple server using Haskell. When clients connect to the server, the server records their address. Every n microseconds the server sends out a broadcast.
Here is the server
data Server = Server {
sSocket :: Socket,
sPort :: Port,
sClients :: MVar [ClientAddress]
}
(Notice the MVar that allows the clients to be used from multiple threads.)
This is how a server is created
startServer port = withSocketsDo $ do
socket <- listenOn $ PortNumber $ fromIntegral port
clients <- newEmptyMVar
let server = Server socket port clients
forkIO $ forever $ accept socket >>= forkIO . (handleClientRequest server)
forever $ updateClients server 1000000
The server uses its thread and forks another. The forked thread handles any incoming client requests
handleClientRequest server client = do
clients <- takeMVar $ sClients server
putMVar (sClients server) (client : clients)
and the broadcast is sent using the updateClients function
updateClients server frequency = do
putStrLn "1"
clients <- (takeMVar $ sClients server)
putStrLn "2"
putStrLn $ show $ length clients
threadDelay frequency
The problem I encounter is that "2" is never printed to the screen. I believe this is because the takeMVar line in updateClients is never finishing.
Why would this freeze?
You start with an empty MVar, so takeMVar blocks forever. Try using newMVar [] instead of newEmptyMVar, possibly like this:
startServer port = withSocketsDo $ do
socket <- listenOn $ PortNumber $ fromIntegral port
clients <- newMVar []
let server = Server socket port clients
forkIO $ forever $ accept socket >>= forkIO . (handleClientRequest server)
forever $ updateClients server 1000000
Now, the MVar is always full, except when it's actually being modified by a client.
When you use an MVar to protect a critical section, it's helpful to think of what the normal state is; in this case it's a list of clients. The only time the MVar should be empty is when a client is actually modifying the state, so if you can use modifyMVar and set up the initial state, your code should be deadlock-free.
Also, if you can use withMVar instead of takeMVar/putMVar you should do so, because it leaves the MVar in a consistent state if an async exception arises.
Related
I wrote this simple tcp server:
import Network
import Network.Socket.ByteString
main :: IO()
main = do
sock <- listenOn $ PortNumber 2000
contents <- recv sock 4096
print contents
Stack built successfully, so then I ran the server, using telnet to test it, but I got an error:
On linux:
Network.Socket.recvBuf:invalid argument (Transport endpoint is not connected)
On windows:
Network.Socket.recvBuf:failed(No error)
What's wrong with the program?
listenOn just creates a "listen socket" which "listen" new connections to your server. You should to use the accept function to obtain new clients, like this:
main :: IO ()
main = do
sock <- listenOn $ PortNumber 2000
(client, _, _) <- accept sock
contents <- hGetContents client
print contents
sClose sock
Or use lowlevel the accept function (from the Network.Socket module) to obtain socket:
main :: IO ()
main = do
sock <- listenOn $ PortNumber 2000
(client, _) <- accept sock
contents <- recv client 4096
print contents
sClose client
sClose sock
If you want to handle more clients you can use forkIO like this:
main :: IO ()
main = do
sock <- listenOn $ PortNumber 2000
forever $ do
(client, _) <- accept sock
forkIO $ do
contents <- recv client 4096
print contents
sClose client
I'm trying to run a rabbitmq background process on heroku to pick tasks off a queue and process them. I'm working with the AMQP haskell library and they give the following example (parts omitted or brevity.
main = do
--setup connection omitted
--connect to queue, wait for messages
consumeMsgs chan "myQueue" Ack myCallback
--halts process so messages are taken off the queue until a key is presseed
getLine -- wait for keypress
closeConnection conn -- close connection after key
putStrLn "connection closed"
This works fine locally because getLine keeps the process running until you press a key. However, when I deploy this to heroku the process exits with
2016-04-19T08:37:23.373087+00:00 app[worker.1]: worker: <stdin>: hGetChar: end of file
I figured out from the accepted answer to this question that this is because in order to deploy a background process via ssh you need to redirect /dev/null/ to stdin which sends an EOF signal to the process.
In our case the getLine function exits because of this signal and the entire process stops, preventing our worker from staying up.
How can I keep this worker running when I deploy?
EDIT: Final Solution
Using #carstons comments I ended up with the following implementation that worked:
main :: IO ()
main = do
mvar <- newEmptyMVar
conn <- setupConnection
queueName <- pack <$> getEnv "QUEUE_NAME"
chan <- openChannel conn
consumeMsgs chan queueName Ack processMessage
installHandler sigINT (Catch (cleanupConnection conn mvar)) Nothing
putStrLn "Running forever, press ctrl c to exit"
-- this blocks until sigint is recieved and the handler for SIGINT
-- "fills" the mvar. once that is filled the process exits
run <- takeMVar mvar
case run of
_ -> return ()
mixpanelConfig :: IO Config
mixpanelConfig = liftM2 Config (ApiToken . pack <$> getEnv "MIXPANEL_API_TOKEN") (newManager tlsManagerSettings)
cleanupConnection :: Connection -> MVar () -> IO ()
cleanupConnection conn mvar = do
closeConnection conn
putStrLn "SIGINT received.. closing rabbitmq connection"
putMVar mvar ()
processMessage :: (Message, Envelope) -> IO ()
as I pointed out in the comment if you just want to keep it running forever you can use forever with - for example - threadDelay:
import Control.Concurrent (threadDelay)
import Control.Monad (forever)
main = do
--setup connection omitted
--connect to queue, wait for messages
consumeMsgs chan "myQueue" Ack myCallback
--halts process so messages are taken off the queue forever
forever $ threadDelay 10000
-- so this will never happen and you could remove it
closeConnection conn -- close connection after key
putStrLn "connection closed"
note that this will of course never really close the connection or exit the application - you'll have to kill the process.
the alternative would be a bit more involved as you need some message/way to send your program a termination signal.
An easy way is to use MVars which you could set in your myCallback when a certain stop-message was received on your queue:
import Control.Concurrent.MVar
main = do
-- MVar to receve the quit-signal
quitSignal <- newEmptyMVar
--setup connection omitted
--connect to queue, wait for messages - the callback should
--set the quitSignal with putMVar quitSignal ()
consumeMsgs chan "myQueue" Ack (myCallback quitSignal)
--halts process so messages are taken off the queue till quitSignal
takeMVar quitSignal
-- so this will happen after quitSignal was set
closeConnection conn -- close connection after key
putStrLn "connection closed"
I am creating a simple chat server using Haskell's Network library. The server has to do two things:
Broadcast a message every n ticks to all of the currently connected clients
Receive any messages from the clients sent to the server.
The server and client are defined as
data Server = Server {
sSocket :: Socket,
sPort :: Port,
sClients :: MVar (Set.Set ClientAddress)
}
newtype ClientAddress = ClientAddress (Handle, HostName, PortNumber)
deriving (Show)
A server is constructed by running the following function
startServer :: Port -> IO ThreadId --
startServer port = withSocketsDo $ do
socket <- listenOn $ PortNumber $ fromIntegral port
clients <- newMVar Set.empty
let server = Server socket port clients
forkIO $ forever $ do
client#(handle, host, port) <- accept socket
modifyMVar_ clients (\cs -> return $ Set.insert (ClientAddress client) cs)
forkIO $ forever $ serve $ ClientAddress client
forkIO $ forever $ sendServerUpdates 1000000 server
Note that the last two lines fork two different threads: the first for handling client connections and "serving" their messages, and the second for sending server broadcasts to the clients.
Broadcasting to the clients works as follows
sendServerUpdates :: Microsecond -> Server -> IO ()
sendServerUpdates frequency server = do
withMVar (sClients server) (mapM_ sendServerUpdate)
threadDelay frequency
sendServerUpdate :: ClientAddress -> IO ()
sendServerUpdate (ClientAddress (handle, host, port)) = do
putStrLn "Sending update."
The issue I have, is that receiving messages from the clients seem to block. I receive messages by checking if the handle has contents
serve :: ClientAddress -> IO ()
serve (ClientAddress (handle, host, port)) = do
b <- hIsEOF handle
putStrLn $ show $ b -- <-- It never makes it this far...
Unfortunately, the code never makes it to the second line to call the putStrLn. It seems like hIsEOF encounters some exception, although the documentation doesn't seem to mention it.
Why does my code block on hIsEOF forever?
In hIsEOF's documentation I found the following:
NOTE: hIsEOF may block, because it has to attempt to read from the
stream to determine whether there is any more data to be read.
I wouldn't have expected this. I wonder if hReady or hGetBufNonBlocking are any better? I've never tried the whole non-blocking IO bit in Haskell.
I am trying to build a chat feature for a website in Yesod, and I want it to have a list of all the connected users that are there. I imagine the best way to do that is to add the person to the user list on a connection, and remove them when they leave. It seems that the response should block if it keeps the connection open, so I naively wrote
getReceiveR :: Handler ()
getReceiveR = do
App chan <- getYesod
req <- waiRequest
res <- lift $ eventSourceAppChan chan req
sendWaiResponse res
liftIO $ putStrLn "client disconnected" <-- Note this
But it didn't work of course, because sendWaiResponse short circuits.
Is there any way to detect when the client disconnects?
Edit: I am using a very slighly modified version of this tutorial to test out the concept.
I can't really run the code to be sure, but would this work?
import Control.Monad.Trans.Resource
getReceiveR :: Handler ()
getReceiveR = do
App chan <- getYesod
req <- waiRequest
res <- lift $ eventSourceAppChan chan req
register . liftIO $ putStrLn "client disconnected"
sendWaiResponse res
I'm trying to figure out how to properly use the OpenSSL.Session API in a concurrent context
E.g. assume I want to implement a stunnel-style ssl-wrapper, I'd expect to have the following basic skeleton structure, which implements a naive full-duplex tcp-port-forwarder:
runProxy :: PortID -> AddrInfo -> IO ()
runProxy localPort#(PortNumber lpn) serverAddrInfo = do
listener <- listenOn localPort
forever $ do
(sClient, clientAddr) <- accept listener
let finalize sServer = do
sClose sServer
sClose sClient
forkIO $ do
tidToServer <- myThreadId
bracket (connectToServer serverAddrInfo) finalize $ \sServer -> do
-- execute one 'copySocket' thread for each data direction
-- and make sure that if one direction dies, the other gets
-- pulled down as well
bracket (forkIO (copySocket sServer sClient
`finally` killThread tidToServer))
(killThread) $ \_ -> do
copySocket sClient sServer -- "controlling" thread
where
-- |Copy data from source to dest until EOF occurs on source
-- Copying may also be aborted due to exceptions
copySocket :: Socket -> Socket -> IO ()
copySocket src dst = go
where
go = do
buf <- B.recv src 4096
unless (B.null buf) $ do
B.sendAll dst buf
go
-- |Create connection to given AddrInfo target and return socket
connectToServer saddr = do
sServer <- socket (addrFamily saddr) Stream defaultProtocol
connect sServer (addrAddress saddr)
return sServer
How do I transform the above skeleton into a full-duplex ssl-wrapping tcp-forwarding proxy? Where are the dangers W.R.T to concurrent/parallel execution (in the context of the above use-case) of the function calls provided by the HsOpenSSL API?
PS: I'm still struggling to fully comprehend how to make the code robust w.r.t. to exceptions and resource-leaks. So, albeit not being the primary focus of this question, if you notice something bad in the code above, please leave a comment.
To do this you need to replace copySocket with two different functions, one to handle data from the plain socket to SSL and the other from SSL to the plain socket:
copyIn :: SSL.SSL -> Socket -> IO ()
copyIn src dst = go
where
go = do
buf <- SSL.read src 4096
unless (B.null buf) $ do
SB.sendAll dst buf
go
copyOut :: Socket -> SSL.SSL -> IO ()
copyOut src dst = go
where
go = do
buf <- SB.recv src 4096
unless (B.null buf) $ do
SSL.write dst buf
go
Then you need to modify connectToServer so that it establishes an SSL connection
-- |Create connection to given AddrInfo target and return socket
connectToServer saddr = do
sServer <- socket (addrFamily saddr) Stream defaultProtocol
putStrLn "connecting"
connect sServer (addrAddress saddr)
putStrLn "establishing ssl context"
ctx <- SSL.context
putStrLn "setting ciphers"
SSL.contextSetCiphers ctx "DEFAULT"
putStrLn "setting verfication mode"
SSL.contextSetVerificationMode ctx SSL.VerifyNone
putStrLn "making ssl connection"
sslServer <- SSL.connection ctx sServer
putStrLn "doing handshake"
SSL.connect sslServer
putStrLn "connected"
return sslServer
and change finalize to shut down the SSL session
let finalize sServer = do
putStrLn "shutting down ssl"
SSL.shutdown sServer SSL.Unidirectional
putStrLn "closing server socket"
maybe (return ()) sClose (SSL.sslSocket sServer)
putStrLn "closing client socket"
sClose sClient
Finally, don't forget to run your main stuff within withOpenSSL as in
main = withOpenSSL $ do
let hints = defaultHints { addrSocketType = Stream, addrFamily = AF_INET }
addrs <- getAddrInfo (Just hints) (Just "localhost") (Just "22222")
let addr = head addrs
print addr
runProxy (PortNumber 11111) addr