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.
Related
Problem
I'm attempting to extend the IRC bot from https://wiki.haskell.org/Roll_your_own_IRC_bot with some state that's updated every time the bot posts a message in the channel it's connected to.
The feature is: every time the command !last said is issued in the IRC channel, the bot should respond with a time stamp. To support this, the privmsg function needs to update the bot's state -- specifically the lastPosted record -- with a new timestamp every time it is called.
Work so far
I took the code from the bottom of the Haskell wiki page (which used a ReaderT to access information about the bot's environment) and tried to change out the ReaderT for a State Transformer (StateT). The results are below and as you can see, I didn't get very far.
import Data.List
import Network
import System.IO
import System.Exit
import System.Time
import Control.Arrow
import Control.Monad.State
import Control.Exception
import Text.Printf
server = "irc.freenode.org"
port = 6667
chan = "#testbot-test"
nick = "testbottest"
-- The 'Net' monad, a wrapper over IO, carrying the bot's immutable state.
type Net = StateT Bot IO
data Bot = Bot { socket :: Handle, lastPosted :: ClockTime }
-- Set up actions to run on start and end, and run the main loop
main :: IO ()
main = bracket connect disconnect loop
where
disconnect = hClose . socket
loop st = runStateT run st
-- Connect to the server and return the initial bot state
connect :: IO Bot
connect = notify $ do
h <- connectTo server (PortNumber (fromIntegral port))
t <- getClockTime
hSetBuffering h NoBuffering
return (Bot h t)
where
notify a = bracket_
(printf "Connecting to %s ... " server >> hFlush stdout)
(putStrLn "done.")
a
-- We're in the Net monad now, so we've connected successfully
-- Join a channel, and start processing commands
run :: Net ()
run = do
write "NICK" nick
write "USER" (nick ++ " 0 * :test bot")
write "JOIN" chan
gets socket >>= listen
-- Process each line from the server
listen :: Handle -> Net ()
listen h = forever $ do
s <- init `fmap` liftIO (hGetLine h)
liftIO (putStrLn s)
if ping s then pong s else eval (clean s)
where
forever a = a >> forever a
clean = drop 1 . dropWhile (/= ':') . drop 1
ping x = "PING :" `isPrefixOf` x
pong x = write "PONG" (':' : drop 6 x)
-- Dispatch a command
eval :: String -> Net ()
eval "!quit" = write "QUIT" ":Exiting" >> liftIO (exitWith ExitSuccess)
-- Posting when something was last posted shouldn't count as last posted.
eval "!last said" = getLastPosted >>= (\t -> write "PRIVMSG" (chan ++ " :" ++ t))
eval x | "!id " `isPrefixOf` x = privmsg (drop 4 x)
eval _ = return () -- ignore everything else
getLastPosted :: Net String
getLastPosted = do
t <- gets lastPosted
return $ show t
-- Send a privmsg to the current chan + server
privmsg :: String -> Net ()
privmsg s = write "PRIVMSG" (chan ++ " :" ++ s)
-- Send a message out to the server we're currently connected to
write :: String -> String -> Net ()
write s t = do
h <- gets socket
liftIO $ hPrintf h "%s %s\r\n" s t
liftIO $ printf "> %s %s\n" s t
Other support avenues explored
spent a couple of days reading up on ReaderT, StateT and their non-transformer friends Reader and State,
checking Stack Overflow for anyone with a similar problem, but the only other IRC bot question threaded the socket as an argument to every function that needed it (instead of using a ReaderT),
Tweeted Don S. the original author of the wiki page
asked in the Haskell IRC channel.
Question
How can the Haskell wiki IRC bot be extended to post a message, containing the date and time stamp of the last message posted? Preferably using an abstraction like ReaderT (only allowing mutable state) rather than passing state around in function arguments.
I got your code to compile by simply adding a >> return () to the definition of loop in your main:
main :: IO ()
main = bracket connect disconnect loop
where
disconnect = hClose . socket
loop st = (runStateT run st) >> return ()
This effectively ignores the return value of runStateT. Here are all of the variants of runState/runStateT:
runStateT - return both the final state and returned value
evalStateT - return only the final value
execStateT - return only the final state
Your original definition of loop was returning a pair (from runStateT), and this didn't type check since main wants a computation which returns just ().
To update the lastPosted field, consider this addition to the eval function which is triggered when the bot is sent the message !update time:
eval "!update time"
= do t <- liftIO getClockTime
bot <- get
put (bot { lastPosted = t })
We need to liftIO getClockTime since we are operating in the Net monad.
Then we get the old state and put the updated state. You can add this logic wherever you want to update the lastPosted time in the Net monad.
Full code is available at: http://lpaste.net/142931
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.
I'm trying to implement simple TCP Client in Haskell. But it gets closed as soon as it connects. I don't know what is causing it to close. How could I make it so that it would print lines from server into stdout and send lines from stdin to server forever until stdin receives line ":quit"?
import Control.Monad (forever)
import Network (withSocketsDo, PortID(..), connectTo)
import System.IO
import Control.Concurrent (forkFinally)
import Control.Concurrent.Async (race)
main :: IO ()
main = withSocketsDo $ do
-- connect to my local tcp server
handle <- connectTo "192.168.137.1" (PortNumber 44444)
-- should close the connection using handle after everything is done
_ <- forkFinally (talk handle) (\_ -> hClose handle)
return ()
talk :: Handle -> IO ()
talk handle = do
hSetNewlineMode handle universalNewlineMode
hSetBuffering handle LineBuffering
-- if either one of them terminates, other one will get terminated
_ <- race (interactWithServer handle) (interactWithUser handle)
return ()
interactWithServer :: Handle -> IO ()
interactWithServer handle = forever $ do
line <- hGetLine handle
print line -- print a line that came from server into stdout
interactWithUser :: Handle -> IO ()
interactWithUser handle = do
line <- getLine
case line of
":quit" -> return () -- stop loop if user input is :quit
_ -> do hPutStrLn handle line
interactWithUser handle -- send, then continue looping
With Ørjan Johansen's help I figured it out. forkFinally was creating a thread then after that main thread was getting closed. That line was meant to wait until talk finished and then close the connection. It had to be (also shortened it)
main :: IO ()
main = withSocketsDo $ do
handle <- connectTo "192.168.137.1" (PortNumber 44444)
talk handle `finally` hClose handle
talk :: Handle -> IO ()
talk handle = do
hSetNewlineMode handle universalNewlineMode
hSetBuffering handle LineBuffering
_ <- race fromServer toServer
return ()
where
fromServer = forever $ do
line <- hGetLine handle
print line
toServer = do
line <- getLine
case line of
-- server accepts /quit as disconnect command so better send it to the server
":quit" -> do hPutStrLn handle "/quit"; return "Quit"
_ -> do hPutStrLn handle line; toServer
I hope this code is safe :D
To learn the basics of conduit library, I used network-conduit to make a simple echo server:
import Control.Monad.IO.Class
import qualified Data.ByteString.Char8 as BS
import Data.Conduit
import Data.Conduit.Network
-- A conduit that print the input it receives on the console
-- and passes it through.
echo :: (MonadIO m) => Conduit BS.ByteString m BS.ByteString
echo = do
yield (BS.pack "Anything you type will be echoed back.\n")
-- Print the received data to the console as well:
awaitForever (\x -> liftIO (BS.putStr x) >> yield x)
echoApp :: (MonadIO m) => Application m
echoApp appData = appSource appData $= echo $$ appSink appData
-- Listen on port 4545:
main :: IO ()
main = runTCPServer (serverSettings 4545 HostAny) echoApp
It does what I wanted, but when the client closes its part of the connection, the server is still waiting for input instead of writing out any remaining data and closing its sending part of the connection too:
$ nc localhost 4545 <<<"Hello world!"
Anything you type will be echoed back.
Hello world!
I tried removing echo and do just
echoApp appData = appSource appData $$ appSink appData
but the problem is still there. What am I doing wrong?
I'm not sure what you mean by "the server won't respond to it"? I'd guess you're expecting the server to shut down after the client disconnects. If so, that's not the intention of the library: it continues to server connections in an infinite loop as long as they continue coming in. Using addCleanup, you can see that the individual connection handlers do in fact terminate, e.g.:
echo :: (MonadIO m) => Conduit BS.ByteString m BS.ByteString
echo = addCleanup (const $ liftIO $ putStrLn "Stopping") $ do
yield (BS.pack "Anything you type will be echoed back.\n")
-- Print the received data to the console as well:
awaitForever (\x -> liftIO (BS.putStr x) >> yield x)
It turned out that the problem wasn't with network-conduit, that part works correctly. The problem was with nc, which doesn't close its sending part of the socket when it sends all the data. I made a testing python script and it works against the server as expected:
#!/usr/bin/env python
import socket
HOST = 'localhost'
PORT = 4545
s = socket.socket(socket.AF_INET, socket.SOCK_STREAM)
s.connect((HOST, PORT))
s.sendall('Hello, world')
# This was missing in `nc`:
s.shutdown(socket.SHUT_WR);
print 'Received'
data = s.recv(1024)
while data:
print data,
data = s.recv(1024)
s.close()
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