module Net.Servers where
import Control.Monad(unless)
import Data.Char(isPrint,isAscii)
import Data.Maybe(fromJust)
import Net.Concurrent
import Net.ClientInterface
import Net.Interface as Net
import qualified Net.TCP_Client as TCP
import qualified Net.UDP_Client as UDP
import qualified Net.PortNumber as Port
import Monad.Util
import Net.Packet(outLen,loopbackout)
import Net.PacketParsing(doParse,doUnparse)
tcpEchoServer debug net = server =<< TCP.listen (tcp net) Port.echo
where
server socket = loop $ fork . echo =<< TCP.accept socket
echo (peer,con) =
do debug $ "echo server accepted a connection from "++show peer
loop
debug $ "echo server closing connection to "++show peer
TCP.close con
where
loop = do p <- loopbackout # TCP.rx con
let n=outLen p
unless (n==0) $
do debug $ "echo server echoing "++show n++" bytes"
TCP.tx con p
loop
udpEchoServer debug net = server =<< UDP.listen (udp net) Port.echo
where
server iface = loop $ echo =<< rxT iface Nothing
where
echo (Just (srcIP,udpP)) =
do debug $ "replying to UDP echo request from "++show srcIP
txT iface (srcIP,loopbackout # reply)
where
reply = udpP{UDP.sourcePort=Port.echo,
UDP.destPort=UDP.sourcePort udpP}
simpleTCPServer debug net port simpleServer =
listener =<< TCP.listen (tcp net) port
where
listener socket = loop $ fork . clientHandler =<< TCP.accept socket
clientHandler (peer,con) =
do debug $ "server on "++show port
++" accepted a connection from "++show peer
simpleServer Interface { rx=fmap doParse $ TCP.rx con,
tx=TCP.tx con.doUnparse}
debug $ "server on "++show port++" closing connection to "++show peer
TCP.close con
lineBuffered debug iface =
do bufVar <- newMVar []
let rxloop buf = case break (=='\n') buf of
(line,'\n':buf') -> return (line,buf')
_ -> maybe (rxloop buf) (rxloop . (buf++)) =<< rx iface
rxLine = do buf <- takeMVar bufVar
(line,buf') <- rxloop buf
putMVar bufVar buf'
return line
return iface { rx=rxLine }
telnetServer debug prompt execute net =
simpleTCPServer debug net Port.telnet (server @@ lineBuffered debug)
where
server iface =
do debug "Telnet server prompting for a command"
tx iface prompt
s <- rx iface
debug $ "Got a command: "++show s
if null s || s=="logout\r"
then do debug "Telnet session ending"
return ()
else do let cmd = [c|c<-s,isPrint c && isAscii c]
execute iface cmd
server iface
telnet user net peer =
maybe timeout telnetSession =<< TCP.connect (tcp net) peer
where
timeout = tx user "Connection attempt timed out\n"
telnetSession iface =
do tx user $ "Connected to "++show peer++"\n"
stopRef <- newRef False
fork $
do repeatM $ do s<- fromJust . doParse # TCP.rx iface
tx user s
return $ not $ null s
writeRef stopRef True
repeatM $
do line <- addcr # rx user
stop <- (line==".\r" ||) # readRef stopRef
unless stop $ TCP.tx iface . doUnparse $ line++"\n"
return (not stop)
TCP.close iface
tx user $ "Connection to "++show peer++" closed\n"
addcr s = if null s || last s/='\r' then s++"\r" else s