epoll-0.1: examples/Server.hs

module Main where

import System.Linux.EpollM
import System.Posix.IO
import System.Posix.Types
import System.Environment
import System.IO
import Data.Maybe
import Text.Printf
import Control.Monad
import Control.Monad.Trans
import System.Posix.Signals
import Network.Socket

main :: IO ()
main = getAndVerifyArgs >>= start . head

start :: String -> IO ()
start p = runEpollBig_ $ do

    defaultDispatchLoop_ readRequest

    ai <- liftIO $ getAddrInfo (Just (defaultHints {addrFlags = [AI_PASSIVE]}))
                               Nothing 
                               (Just p)

    let serveraddr = head ai

    -- create server socket
    sock <- liftIO $ socket (addrFamily serveraddr) Stream defaultProtocol
    liftIO $ setSocketOption sock ReuseAddr 1

    -- bind it to the address we're listening to
    liftIO $ bindSocket sock (addrAddress serveraddr)

    liftIO $ printf "Listening at port %s\n" p

    -- start listening for connection requests max. connection requests waiting
    -- to be accepted = 5 (max. queue size)
    liftIO $ listen sock 256

    -- Ignore broken pipes
    liftIO $ installHandler sigPIPE Ignore Nothing

    -- accept connection requests (CTRL-C to abort)
    forever $ do
        (connsock, clientaddr) <- liftIO $ accept sock
        procRequest connsock clientaddr
 where
    procRequest :: Socket -> SockAddr -> Epoll ()
    procRequest sock' _ = do
        let fd = Fd $ fdSocket sock'
        liftIO $ setFdOption fd NonBlockingRead True
        add sock' [inEvent, peerCloseEvent, oneShotEvent] fd
        return ()

readRequest :: Event Socket -> Epoll ()
readRequest e = fork_ $ do
    let et = eventType e
        fd = eventFd e
    liftIO $ printf "event=%s, fd=%s\n" (show et) (show fd)
    if et =~ peerCloseEvent
        then do liftIO $ putStrLn "peer closed"
                delete (eventDesc e)
                liftIO $ sClose (eventRef e)
        else do (s, _) <- liftIO $ fdRead fd 2048
                modify [inEvent, peerCloseEvent, oneShotEvent] (eventDesc e)
                liftIO $ printf "readRequest: %s\n" s

getAndVerifyArgs :: IO [String]
getAndVerifyArgs = do
    args <- getArgs
    when (length args /= 1)
         (error "Usage: Server <port>")
    return args