echoserver.hs

{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Main
    (
      main
    ) where

import           Control.Concurrent
import qualified Control.Exception                as E
import           Control.Monad                    (forever, void)
import           Data.Attoparsec.ByteString
import           Data.Attoparsec.ByteString.Char8 (endOfLine)
import           Data.ByteString                  (ByteString)
import           Data.Conduit                     (($$), ($=))
import qualified Data.Conduit                     as C
import           Data.Conduit.Attoparsec
import           Data.Conduit.Network
import           Network                          (withSocketsDo)
import           Network.Socket
import qualified Network.Socket.ByteString        as N
import           System.Exit
import           System.IO                        (BufferMode (LineBuffering),
                                                   Handle, hClose,
                                                   hSetBuffering)
import           Text.Printf                      (printf)

data Packet = Ping

packetParser :: Parser Packet
packetParser = do
    string "PING" >> endOfLine
    return Ping

port :: Int
port = 8080

main :: IO ()
main = withSocketsDo $ do
    mv <- newEmptyMVar
    runInUnboundThread mainThread
  where
    mainThread =
        E.bracket (socket AF_INET Stream 0)
                  (\sock -> do putStrLn "exiting..."
                               sClose sock)
                  (\sock -> do
                      setSocketOption sock ReuseAddr 1
                      setSocketOption sock NoDelay 1
                      (ainfo:_) <- getAddrInfo hints (Just "0.0.0.0") (Just $ show port)
                      let addr = addrAddress ainfo
                      bind sock addr
                      listen sock 2048
                      printf "Listening on port %d\n" port
                      go sock)

    go sock = loop
      where
        {-# NOINLINE loop #-}
        loop = do (csock, _) <- accept sock
                  forkIOWithUnmask (\r -> r (echo csock) `E.finally` sClose csock)
                  loop

    hints = Just $ defaultHints {addrFlags = [AI_NUMERICHOST, AI_NUMERICSERV]}

eatExceptions :: IO a -> IO ()
eatExceptions m = void m `E.catch` \(e :: E.SomeException) -> do
    putStrLn $ show e
    return ()


echo :: Socket -> IO ()
echo sock = eatExceptions loop
  where
    {-# NOINLINE loop #-}
    loop = sourceSocket sock $= conduitParserEither packetParser
                             $= echoPacket
                             $$ sinkSocket sock
    echoPacket = C.awaitForever $ \packet -> do
        case packet of
            Right (_, Ping) -> C.yield "PING\n"
            _               -> C.yield "NOTPING\n"