d78d735dbf7c5ce5ae545eecd8ee2c052224db77ndDescription : A test module for trying API communication via sockets.
a1d62218cdb0efd0f02da1b54fd3eda91a681d98nd The code is based on the TCP syslog server example in Real
d78d735dbf7c5ce5ae545eecd8ee2c052224db77nd World Haskell.
acc36ab93565d2880447d535da6ca6e5feac7a70ndCopyright : (c) Till Mossakowski and Uni Bremen 2003-2006
031b91a62d25106ae69d4693475c79618dd5e884fieldingLicense : GPLv2 or higher, see LICENSE.txt
031b91a62d25106ae69d4693475c79618dd5e884fieldingMaintainer : mchan@inf.ed.ac.uk
031b91a62d25106ae69d4693475c79618dd5e884fieldingStability : provisional
031b91a62d25106ae69d4693475c79618dd5e884fieldingPortability : non-portable (imports Logic.Grothendieck)
031b91a62d25106ae69d4693475c79618dd5e884fieldingA test module for trying API communication via sockets. Use 'telnet <ip> <port>' to connect.
acc36ab93565d2880447d535da6ca6e5feac7a70ndimport SyslogTypes
d78d735dbf7c5ce5ae545eecd8ee2c052224db77ndtype HandlerFunc = Maybe Handle -> SockAddr -> String -> IO ()
d78d735dbf7c5ce5ae545eecd8ee2c052224db77ndserveLog :: String -- ^ Port number or name; 514 is default
d78d735dbf7c5ce5ae545eecd8ee2c052224db77nd -> HandlerFunc -- ^ Function to handle incoming messages
d78d735dbf7c5ce5ae545eecd8ee2c052224db77ndserveLog port handlerfunc = withSocketsDo $
d78d735dbf7c5ce5ae545eecd8ee2c052224db77nd do {- Look up the port. Either raises an exception or returns
d78d735dbf7c5ce5ae545eecd8ee2c052224db77nd a nonempty list. -}
d78d735dbf7c5ce5ae545eecd8ee2c052224db77nd addrinfos <- getAddrInfo
d78d735dbf7c5ce5ae545eecd8ee2c052224db77nd (Just (defaultHints {addrFlags = [AI_PASSIVE]}))
d78d735dbf7c5ce5ae545eecd8ee2c052224db77nd Nothing (Just port)
5652dbe450e4fcfdf36d4cfb42d7f2345ded29a4maczniak let serveraddr = head addrinfos
d78d735dbf7c5ce5ae545eecd8ee2c052224db77nd -- Create a socket
d78d735dbf7c5ce5ae545eecd8ee2c052224db77nd sock <- socket (addrFamily serveraddr) Stream defaultProtocol
d78d735dbf7c5ce5ae545eecd8ee2c052224db77nd -- Bind it to the address we're listening to
d78d735dbf7c5ce5ae545eecd8ee2c052224db77nd bindSocket sock (addrAddress serveraddr)
d78d735dbf7c5ce5ae545eecd8ee2c052224db77nd {- Start listening for connection requests. Maximum queue size
d78d735dbf7c5ce5ae545eecd8ee2c052224db77nd of 5 connection requests waiting to be accepted. -}
d78d735dbf7c5ce5ae545eecd8ee2c052224db77nd listen sock 5
d78d735dbf7c5ce5ae545eecd8ee2c052224db77nd -- Create a lock to use for synchronizing access to the handler
d78d735dbf7c5ce5ae545eecd8ee2c052224db77nd lock <- newMVar ()
d78d735dbf7c5ce5ae545eecd8ee2c052224db77nd -- Loop forever waiting for connections. Ctrl-C to abort.
d78d735dbf7c5ce5ae545eecd8ee2c052224db77nd procRequests lock sock
d78d735dbf7c5ce5ae545eecd8ee2c052224db77nd -- | Process incoming connection requests
d78d735dbf7c5ce5ae545eecd8ee2c052224db77nd procRequests :: MVar () -> Socket -> IO ()
5652dbe450e4fcfdf36d4cfb42d7f2345ded29a4maczniak procRequests lock mastersock =
d78d735dbf7c5ce5ae545eecd8ee2c052224db77nd do (connsock, clientaddr) <- accept mastersock
d78d735dbf7c5ce5ae545eecd8ee2c052224db77nd handle lock Nothing clientaddr
d78d735dbf7c5ce5ae545eecd8ee2c052224db77nd "syslogtcpserver.hs: client connnected"
d78d735dbf7c5ce5ae545eecd8ee2c052224db77nd forkIO $ procMessages lock connsock clientaddr
d78d735dbf7c5ce5ae545eecd8ee2c052224db77nd procRequests lock mastersock
d78d735dbf7c5ce5ae545eecd8ee2c052224db77nd -- | Process incoming messages
d78d735dbf7c5ce5ae545eecd8ee2c052224db77nd procMessages :: MVar () -> Socket -> SockAddr -> IO ()
d78d735dbf7c5ce5ae545eecd8ee2c052224db77nd procMessages lock connsock clientaddr =
d78d735dbf7c5ce5ae545eecd8ee2c052224db77nd do connhdl <- socketToHandle connsock ReadWriteMode
d78d735dbf7c5ce5ae545eecd8ee2c052224db77nd hSetBuffering connhdl LineBuffering
d78d735dbf7c5ce5ae545eecd8ee2c052224db77nd messages <- hGetContents connhdl
5652dbe450e4fcfdf36d4cfb42d7f2345ded29a4maczniak mapM_ (handle lock (Just connhdl) clientaddr) (lines messages)
d78d735dbf7c5ce5ae545eecd8ee2c052224db77nd hClose connhdl
d78d735dbf7c5ce5ae545eecd8ee2c052224db77nd handle lock (Just connhdl) clientaddr
d78d735dbf7c5ce5ae545eecd8ee2c052224db77nd "syslogtcpserver.hs: client disconnected"
d78d735dbf7c5ce5ae545eecd8ee2c052224db77nd -- Lock the handler before passing data to it.
d78d735dbf7c5ce5ae545eecd8ee2c052224db77nd handle :: MVar () -> HandlerFunc
d78d735dbf7c5ce5ae545eecd8ee2c052224db77nd {- This type is the same as
d78d735dbf7c5ce5ae545eecd8ee2c052224db77nd handle :: MVar () -> Handle -> SockAddr -> String -> IO () -}
d78d735dbf7c5ce5ae545eecd8ee2c052224db77nd handle lock h clientaddr msg =
5652dbe450e4fcfdf36d4cfb42d7f2345ded29a4maczniak withMVar lock
d78d735dbf7c5ce5ae545eecd8ee2c052224db77nd (\ a -> handlerfunc h clientaddr msg >> return a)
d78d735dbf7c5ce5ae545eecd8ee2c052224db77ndsyslog :: Maybe Handle -> Facility -> Priority -> String -> IO ()
d78d735dbf7c5ce5ae545eecd8ee2c052224db77ndsyslog syslogh fac pri msg = case syslogh of
d78d735dbf7c5ce5ae545eecd8ee2c052224db77nd Just h -> do hPutStrLn h sendmsg
d78d735dbf7c5ce5ae545eecd8ee2c052224db77nd -- Make sure that we send data immediately
d78d735dbf7c5ce5ae545eecd8ee2c052224db77nd sendmsg = msg
d78d735dbf7c5ce5ae545eecd8ee2c052224db77nd _ -> return ()
d78d735dbf7c5ce5ae545eecd8ee2c052224db77nd-- A simple handler that prints incoming packets
d78d735dbf7c5ce5ae545eecd8ee2c052224db77ndplainHandler :: HandlerFunc
d78d735dbf7c5ce5ae545eecd8ee2c052224db77ndplainHandler h addr msg = do
d78d735dbf7c5ce5ae545eecd8ee2c052224db77nd putStrLn $ "From " ++ show addr ++ ": " ++ msg
d78d735dbf7c5ce5ae545eecd8ee2c052224db77nd syslog h USER INFO $ "Message received: " ++ msg